Remove annotation from ValVariable. Add: varName, genVar functions.

varName should be used instead of pattern-matching to extract the name of an
ExpValue variable. This is because it will first return the uniqueName if the
variable has one. This is better for doing analysis; otherwise you must rewrite
all of the ValVariables with the uniqueName before applying any analyses.

genVar is a helper function to generate a new ExpValue variable with
annotation, source span and uniqueName == source name.

src/Language/Fortran/AST.hs

@@ -289,7 +289,7 @@ data Value a =
   | ValComplex           (Expression a) (Expression a)
   | ValString            String
   | ValHollerith         String
-  | ValVariable          a Name
+  | ValVariable          Name
   | ValLogical           String
   | ValOperator          String
   | ValAssignment

src/Language/Fortran/Analysis.hs

@@ -3,7 +3,7 @@
 -- |
 -- Common data structures and functions supporting analysis of the AST.
 module Language.Fortran.Analysis
-  ( initAnalysis, stripAnalysis, Analysis(..), Env
+  ( initAnalysis, stripAnalysis, Analysis(..), Env, varName, genVar
   , lhsExprs, isLExpr, allVars, allLhsVars, blockVarUses, blockVarDefs
   , BB, BBGr )
 where
@@ -50,6 +50,14 @@ analysis0 a = Analysis { prevAnnotation = a
                        , insLabel       = Nothing
                        , moduleEnv      = Nothing }
 
+-- | Obtain either uniqueName or source name from an ExpValue variable.
+varName (ExpValue (Analysis { uniqueName = Just n }) _ (ValVariable {})) = n
+varName (ExpValue (Analysis { uniqueName = Nothing }) _ (ValVariable n)) = n
+varName _ = error "Use of varName on non-variable."
+
+-- | Generate an ExpValue variable with its source name == to its uniqueName.
+genVar a s n = ExpValue (a { uniqueName = Just n }) s (ValVariable n)
+
 -- | Create analysis annotations for the program, saving the original
 -- annotations.
 initAnalysis :: ProgramFile a -> ProgramFile (Analysis a)
@@ -74,22 +82,22 @@ lhsExprs x = [ e | StExpressionAssign _ _ e _  <- universeBi x
 
 -- | Is this an expression capable of assignment?
 isLExpr :: Expression a -> Bool
-isLExpr (ExpValue _ _ (ValVariable _ _)) = True
+isLExpr (ExpValue _ _ (ValVariable {}))  = True
 isLExpr (ExpSubscript _ _ _ _)           = True
 isLExpr _                                = False
 
 -- | Set of names found in an AST node.
 allVars :: (Data a, Data (b a)) => b a -> [Name]
-allVars b = [ v | ExpValue _ _ (ValVariable _ v) <- uniBi b ]
+allVars b = [ v | ExpValue _ _ (ValVariable v) <- uniBi b ]
   where
     uniBi :: (Data a, Data (b a)) => b a -> [Expression a]
     uniBi = universeBi
 
 -- | Set of names found in the parts of an AST that are the target of
 -- an assignment statement.
-allLhsVars :: (Data a, Data (b a)) => b a -> [Name]
-allLhsVars b = [ v | ExpValue _ _ (ValVariable _ v)                   <- lhsExprs b ] ++
-               [ v | ExpSubscript _ _ (ExpValue _ _ (ValVariable _ v)) _ <- lhsExprs b ]
+allLhsVars :: (Data a, Data (b (Analysis a))) => b (Analysis a) -> [Name]
+allLhsVars b = [ varName v | v@(ExpValue _ _ (ValVariable {})) <- lhsExprs b ] ++
+               [ varName v | ExpSubscript _ _ v@(ExpValue _ _ (ValVariable {})) _ <- lhsExprs b ]
 
 -- | Set of names used -- not defined -- by an AST-block.
 blockVarUses :: Data a => Block a -> [Name]
@@ -105,7 +113,7 @@ blockVarUses (BlIf _ _ e1 e2 _)        = allVars (e1, e2)
 blockVarUses b                         = allVars b
 
 -- | Set of names defined by an AST-block.
-blockVarDefs :: Data a => Block a -> [Name]
+blockVarDefs :: Data a => Block (Analysis a) -> [Name]
 blockVarDefs (BlStatement _ _ _ st) = allLhsVars st
 blockVarDefs (BlDo _ _ _ (Just doSpec) _)  = allLhsVars doSpec
 blockVarDefs _                      = []

src/Language/Fortran/Analysis/BBlocks.hs

@@ -86,7 +86,7 @@ insEntryEdges pu = insEdge (0, 1, ()) . insNode (0, bs)
 genInOutAssignments pu exit
   -- for now, designate return-value slot as a "ValVariable" without type-checking.
   | exit, PUFunction _ _ _ _ n _ _ _ _ <- pu =
-      zipWith genAssign (ExpValue a undefined (ValVariable a n):vs) [0..]
+      zipWith genAssign (genVar a noSrcSpan n:vs) [0..]
   | otherwise                          = zipWith genAssign vs [1..]
   where
     puName = getName pu
@@ -99,7 +99,7 @@ genInOutAssignments pu exit
       where
         (vl, vr) = if exit then (v', v) else (v, v')
         v'       = case v of
-          ExpValue a' s (ValVariable a _) -> ExpValue a' s (ValVariable a (name i))
+          ExpValue a' s (ValVariable _) -> genVar a' s (name i)
           _               -> error $ "unhandled genAssign case: " ++ show (fmap (const ()) v)
 
 -- Remove exit edges for bblocks where standard construction doesn't apply.
@@ -180,7 +180,7 @@ execBBlocker = flip execState bbs0
 --------------------------------------------------
 
 -- Handle a list of blocks (typically from ProgramUnit or nested inside a BlDo, BlIf, etc).
-processBlocks :: Data a => [Block a] -> BBlocker a (Node, Node)
+processBlocks :: Data a => [Block (Analysis a)] -> BBlocker (Analysis a) (Node, Node)
 -- precondition: curNode is not yet in the graph && will label the first block
 -- postcondition: final bblock is in the graph labeled as endN && curNode == endN
 -- returns start and end nodes for basic block graph corresponding to parameter bs
@@ -195,7 +195,7 @@ processBlocks bs = do
 --------------------------------------------------
 
 -- Handle an AST-block element
-perBlock :: Data a => Block a -> BBlocker a ()
+perBlock :: Data a => Block (Analysis a) -> BBlocker (Analysis a) ()
 -- invariant: curNode corresponds to curBB, and is not yet in the graph
 -- invariant: curBB is in reverse order
 perBlock b@(BlIf _ _ _ exps bss) = do
@@ -245,17 +245,17 @@ perBlock b@(BlStatement _ _ _ (StReturn {})) =
   processLabel b >> addToBBlock b >> closeBBlock_
 perBlock b@(BlStatement _ _ _ (StGotoUnconditional {})) =
   processLabel b >> addToBBlock b >> closeBBlock_
-perBlock b@(BlStatement a s l (StCall a' s' cn@(ExpValue _ _ (ValVariable _ n)) (Just aargs))) = do
+perBlock b@(BlStatement a s l (StCall a' s' cn@(ExpValue _ _ (ValVariable {})) (Just aargs))) = do
   let exps = map extractExp . aStrip $ aargs
   (prevN, formalN) <- closeBBlock
 
   -- create bblock that assigns formal parameters (n[1], n[2], ...)
   case l of
     Just (ExpValue _ _ (ValInteger l)) -> insertLabel l formalN -- label goes here, if present
     _                                -> return ()
-  let name i   = n ++ "[" ++ show i ++ "]"
-  let formal (ExpValue a s (ValVariable a' _)) i = ExpValue a s (ValVariable a' (name i))
-      formal e i                                 = ExpValue a s (ValVariable a (name i))
+  let name i   = varName cn ++ "[" ++ show i ++ "]"
+  let formal (ExpValue a s (ValVariable _)) i = ExpValue a s (ValVariable (name i))
+      formal e i                              = ExpValue a s (ValVariable (name i))
         where a = getAnnotation e; s = getSpan e
   forM_ (zip exps [1..]) $ \ (e, i) -> do
     e' <- processFunctionCalls e
@@ -288,7 +288,7 @@ perBlock b = do
 -- helper monadic combinators
 
 -- Do-block helper
-perDoBlock :: Data a => Maybe (Expression a) -> Block a -> [Block a] -> BBlocker a ()
+perDoBlock :: Data a => Maybe (Expression (Analysis a)) -> Block (Analysis a) -> [Block (Analysis a)] -> BBlocker (Analysis a) ()
 perDoBlock repeatExpr b bs = do
   (n, doN) <- closeBBlock
   case getLabel b of
@@ -363,28 +363,28 @@ stripNestedBlocks b                         = b
 -- Flatten out function calls within the expression, returning an
 -- expression that replaces the original expression (probably becoming
 -- a temporary variable).
-processFunctionCalls :: Data a => Expression a -> BBlocker a (Expression a)
+processFunctionCalls :: Data a => Expression (Analysis a) -> BBlocker (Analysis a) (Expression (Analysis a))
 processFunctionCalls = transformBiM processFunctionCall -- work bottom-up
 
 -- Flatten out a single function call.
-processFunctionCall :: Expression a -> BBlocker a (Expression a)
+processFunctionCall :: Expression (Analysis a) -> BBlocker (Analysis a) (Expression (Analysis a))
 -- precondition: there are no more nested function calls within the actual arguments
-processFunctionCall (ExpFunctionCall a s (ExpValue a' s' (ValVariable _ fn)) aargs) = do
+processFunctionCall (ExpFunctionCall a s fn@(ExpValue a' s' (ValVariable _)) aargs) = do
   (prevN, formalN) <- closeBBlock
 
   let exps = map extractExp (fromMaybe [] (aStrip <$> aargs))
 
   -- create bblock that assigns formal parameters (fn[1], fn[2], ...)
-  let name i   = fn ++ "[" ++ show i ++ "]"
-  let formal (ExpValue a s (ValVariable a' _)) i = ExpValue a s (ValVariable a' (name i))
-      formal e i                                 = ExpValue a s (ValVariable a (name i))
+  let name i   = varName fn ++ "[" ++ show i ++ "]"
+  let formal (ExpValue a s (ValVariable _)) i = ExpValue a s (ValVariable (name i))
+      formal e i                              = ExpValue a s (ValVariable (name i))
         where a = getAnnotation e; s = getSpan e
   forM_ (zip exps [1..]) $ \ (e, i) -> do
     addToBBlock $ BlStatement a s Nothing (StExpressionAssign a' s' (formal e i) e)
   (_, dummyCallN) <- closeBBlock
 
   -- create "dummy call" bblock with no parameters in the StCall AST-node.
-  addToBBlock $ BlStatement a s Nothing (StCall a' s' (ExpValue a' s' (ValVariable a' fn)) Nothing)
+  addToBBlock $ BlStatement a s Nothing (StCall a' s' (genVar a' s' (varName fn)) Nothing)
   (_, returnedN) <- closeBBlock
 
   -- re-assign the variables using the values of the formal parameters, if possible
@@ -394,9 +394,9 @@ processFunctionCall (ExpFunctionCall a s (ExpValue a' s' (ValVariable _ fn)) aar
     if isLExpr e then
       addToBBlock $ BlStatement a s Nothing (StExpressionAssign a' s' e (formal e i))
     else return ()
-  temp <- (ExpValue a s . ValVariable a) `fmap` genTemp fn
+  temp <- (ExpValue a s . ValVariable) `fmap` genTemp (varName fn)
   addToBBlock $ BlStatement a s Nothing
-                  (StExpressionAssign a' s' temp (ExpValue a s (ValVariable a (name 0))))
+                  (StExpressionAssign a' s' temp (ExpValue a s (ValVariable (name 0))))
   (_, nextN) <- closeBBlock
 
   -- connect the bblocks
@@ -420,7 +420,7 @@ superBBGrGraph = graph
 superBBGrClusters :: SuperBBGr a -> IM.IntMap ProgramUnitName
 superBBGrClusters = clusters
 
-genSuperBBGr :: BBlockMap a -> SuperBBGr a
+genSuperBBGr :: BBlockMap (Analysis a) -> SuperBBGr (Analysis a)
 genSuperBBGr bbm = SuperBBGr { graph = superGraph'', clusters = cmap }
   where
     -- [((PUName, Node), [Block a])]
@@ -441,7 +441,8 @@ genSuperBBGr bbm = SuperBBGr { graph = superGraph'', clusters = cmap }
     exitMap  = M.fromList [ (name, n') | ((name, n), n') <- M.toList superNodeMap, n == -1 ]
     -- [(SuperNode, String)]
     stCalls  = [ (getSuperNode n, sub) | (n, [BlStatement _ _ _ (StCall _ _ e Nothing)]) <- namedNodes
-                                       , ExpValue _ _ (ValVariable _ sub)            <- [e] ]
+                                       , v@(ExpValue _ _ (ValVariable _))                <- [e]
+                                       , let sub = varName v ]
     -- [([SuperEdge], SuperNode, String, [SuperEdge])]
     stCallCtxts = [ (inn superGraph n, n, sub, out superGraph n) | (n, sub) <- stCalls ]
     -- [SuperEdge]
@@ -573,7 +574,7 @@ showAttr (AttrTarget _ _) = "target"
 showLab Nothing = replicate 6 ' '
 showLab (Just (ExpValue _ _ (ValInteger l))) = ' ':l ++ replicate (5 - length l) ' '
 
-showValue (ValVariable _ v)     = v
+showValue (ValVariable v)       = v
 showValue (ValInteger v)        = v
 showValue (ValReal v)           = v
 showValue (ValComplex e1 e2)    = "( " ++ showExpr e1 ++ " , " ++ showExpr e2 ++ " )"
@@ -624,6 +625,8 @@ showDim (DimensionDeclarator _ _ me1 me2) = maybe "" ((++":") . showExpr) me1 ++
 
 aIntercalate sep f = intercalate sep . map f . aStrip
 
+noSrcSpan = error "noSrcSpan"
+
 --------------------------------------------------
 -- Some helper functions that really should be in fgl.
 

src/Language/Fortran/Analysis/DataFlow.hs

@@ -141,7 +141,7 @@ genDefMap bm = M.fromListWith IS.union [
 -- Muchnick, p. 445: A variable is "live" at a particular program
 -- point if there is a path to the exit along which its value may be
 -- used before it is redefined. It is "dead" if there is no such path.
-liveVariableAnalysis :: Data a => BBGr a -> InOutMap (S.Set Name)
+liveVariableAnalysis :: Data a => BBGr (Analysis a) -> InOutMap (S.Set Name)
 liveVariableAnalysis gr = dataFlowSolver gr (const (S.empty, S.empty)) revPreOrder inn out
   where
     inn outF b = (outF b S.\\ kill b) `S.union` gen b
@@ -150,17 +150,17 @@ liveVariableAnalysis gr = dataFlowSolver gr (const (S.empty, S.empty)) revPreOrd
     gen b      = bblockGen (fromJust $ lab gr b)
 
 -- | Iterate "KILL" set through a single basic block.
-bblockKill :: Data a => [Block a] -> S.Set Name
+bblockKill :: Data a => [Block (Analysis a)] -> S.Set Name
 bblockKill = S.fromList . concatMap blockKill
 
 -- | Iterate "GEN" set through a single basic block.
-bblockGen :: Data a => [Block a] -> S.Set Name
+bblockGen :: Data a => [Block (Analysis a)] -> S.Set Name
 bblockGen bs = S.fromList . fst . foldl' f ([], []) $ zip (map blockGen bs) (map blockKill bs)
   where
     f (bbgen, bbkill) (gen, kill) = ((gen \\ bbkill) `union` bbgen, kill `union` bbkill)
 
 -- | "KILL" set for a single AST-block.
-blockKill :: Data a => Block a -> [Name]
+blockKill :: Data a => Block (Analysis a) -> [Name]
 blockKill = blockVarDefs
 
 -- | "GEN" set for a single AST-block.
@@ -209,7 +209,7 @@ rdBblockGenKill dm bs = foldl' f (IS.empty, IS.empty) $ zip (map gen bs) (map ki
       ((bbgen IS.\\ kill) `IS.union` gen, (bbkill IS.\\ gen) `IS.union` kill)
 
 -- Set of all AST-block labels that also define variables defined by AST-block b
-rdDefs :: Data a => DefMap -> Block a -> IS.IntSet
+rdDefs :: Data a => DefMap -> Block (Analysis a) -> IS.IntSet
 rdDefs dm b = IS.unions [ IS.empty `fromMaybe` M.lookup y dm | y <- allLhsVars b ]
 
 --------------------------------------------------
@@ -345,7 +345,7 @@ type InductionVarMap = IM.IntMap (S.Set Name)
 -- | Basic induction variables are induction variables that are the
 -- most easily derived from the syntactic structure of the program:
 -- for example, directly appearing in a Do-statement.
-basicInductionVars :: Data a => BackEdgeMap -> BBGr a -> InductionVarMap
+basicInductionVars :: Data a => BackEdgeMap -> BBGr (Analysis a) -> InductionVarMap
 basicInductionVars bedges gr = IM.fromListWith S.union [
     (n, S.singleton v) | (_, n)      <- IM.toList bedges
                        , let Just bs = lab gr n
@@ -356,7 +356,7 @@ basicInductionVars bedges gr = IM.fromListWith S.union [
 -- | For each loop in the program, figure out the names of the
 -- induction variables: the variables that are used to represent the
 -- current iteration of the loop.
-genInductionVarMap :: Data a => BackEdgeMap -> BBGr a -> InductionVarMap
+genInductionVarMap :: Data a => BackEdgeMap -> BBGr (Analysis a) -> InductionVarMap
 genInductionVarMap = basicInductionVars
 
 --------------------------------------------------
@@ -403,7 +403,7 @@ showDataFlow pf@(ProgramFile cm_pus _) = (perPU . snd) =<< cm_pus
 type CallMap = M.Map ProgramUnitName (S.Set Name)
 
 -- | Create a call map showing the structure of the program.
-genCallMap :: Data a => ProgramFile a -> CallMap
+genCallMap :: Data a => ProgramFile (Analysis a) -> CallMap
 genCallMap pf = flip execState M.empty $ do
   let (ProgramFile cm_pus _) = pf
   forM_ cm_pus $ \ (_, pu) -> do
@@ -413,8 +413,8 @@ genCallMap pf = flip execState M.empty $ do
     let uE :: Data a => ProgramUnit a -> [Expression a]
         uE = universeBi
     m <- get
-    let ns = [ n' | StCall _ _ (ExpValue _ _ (ValVariable _ n')) _ <- uS pu ] ++
-             [ n' | ExpFunctionCall _ _ (ExpValue _ _ (ValVariable _ n')) _ <- uE pu ]
+    let ns = [ varName v | StCall _ _ v@(ExpValue _ _ (ValVariable _ )) _         <- uS pu ] ++
+             [ varName v | ExpFunctionCall _ _ v@(ExpValue _ _ (ValVariable _)) _ <- uE pu ]
     put $ M.insert n (S.fromList ns) m
 
 --------------------------------------------------

src/Language/Fortran/Analysis/Renaming.hs

@@ -63,7 +63,7 @@ rename pf = (extractNameMap pf, trPU fPU (trE fE pf))
     trE :: Data a => (Expression a -> Expression a) -> ProgramFile a -> ProgramFile a
     trE = transformBi
     fE :: Data a => Expression (Analysis a) -> Expression (Analysis a)
-    fE (ExpValue a s (ValVariable a' v)) = ExpValue a s . ValVariable a' $ fromMaybe v (uniqueName a)
+    fE (ExpValue a s (ValVariable v)) = ExpValue a s . ValVariable $ fromMaybe v (uniqueName a)
     fE x                 = x
 
     trPU :: Data a => (ProgramUnit a -> ProgramUnit a) -> ProgramFile a -> ProgramFile a
@@ -78,7 +78,7 @@ rename pf = (extractNameMap pf, trPU fPU (trE fE pf))
 extractNameMap :: Data a => ProgramFile (Analysis a) -> NameMap
 extractNameMap pf = eMap `union` puMap
   where
-    eMap  = fromList [ (un, n) | ExpValue (Analysis { uniqueName = Just un }) _ (ValVariable _ n) <- uniE pf ]
+    eMap  = fromList [ (un, n) | ExpValue (Analysis { uniqueName = Just un }) _ (ValVariable n)   <- uniE pf ]
     puMap = fromList [ (un, n) | PUFunction (Analysis { uniqueName = Just un }) _ _ _ n _ _ _ _   <- uniPU pf ]
 
     uniE :: Data a => ProgramFile a -> [Expression a]
@@ -97,7 +97,7 @@ unrename (nm, pf) = trPU fPU . trV fV $ pf
     trV :: Data a => (Value a -> Value a) -> ProgramFile a -> ProgramFile a
     trV = transformBi
     fV :: Data a => Value a -> Value a
-    fV (ValVariable a v) = ValVariable a $ fromMaybe v (v `lookup` nm)
+    fV (ValVariable v) = ValVariable $ fromMaybe v (v `lookup` nm)
     fV x                 = x
 
     trPU :: Data a => (ProgramUnit a -> ProgramUnit a) -> ProgramFile a -> ProgramFile a
@@ -200,8 +200,8 @@ uniquify scope var = do
 isModule (PUModule {}) = True
 isModule _             = False
 
-isUseStatement (BlStatement _ _ _ (StUse _ _ (ExpValue _ _ (ValVariable _ _)) _)) = True
-isUseStatement _                                                                  = False
+isUseStatement (BlStatement _ _ _ (StUse _ _ (ExpValue _ _ (ValVariable _)) _)) = True
+isUseStatement _                                                                = False
 
 -- Generate an initial environment for a scope based upon any Use
 -- statements in the blocks.
@@ -213,7 +213,7 @@ initialEnv blocks = do
   -- program).
   let uses = takeWhile isUseStatement blocks
   fmap M.unions . forM uses $ \ use -> case use of
-    (BlStatement _ _ _ (StUse _ _ (ExpValue _ _ (ValVariable _ m)) Nothing)) -> do
+    (BlStatement _ _ _ (StUse _ _ (ExpValue _ _ (ValVariable m)) Nothing)) -> do
       mMap <- gets moduleMap
       return $ fromMaybe empty (Named m `lookup` mMap)
 
@@ -299,8 +299,8 @@ renameGenericDecls = trans renameExpDecl
 -- declaration that possibly requires the creation of a new unique
 -- mapping.
 renameExpDecl :: Data a => RenamerFunc (Expression (Analysis a))
-renameExpDecl e@(ExpValue _ _ (ValVariable _ v)) = flip setUniqueName e `fmap` maybeAddUnique v
-renameExpDecl e                                  = return e
+renameExpDecl e@(ExpValue _ _ (ValVariable v)) = flip setUniqueName e `fmap` maybeAddUnique v
+renameExpDecl e                                = return e
 
 -- Find all declarators within a value and then dive within those
 -- declarators to rename any ExpValue variables, assuming they might
@@ -317,8 +317,8 @@ renameDeclDecls = trans declarator
 -- Rename an ExpValue variable, assuming that it is to be treated as a
 -- reference to a previous declaration, possibly in an outer scope.
 renameExp :: Data a => RenamerFunc (Expression (Analysis a))
-renameExp e@(ExpValue _ _ (ValVariable _ v)) = maybe e (flip setUniqueName e) `fmap` getFromEnvs v
-renameExp e                                  = return e
+renameExp e@(ExpValue _ _ (ValVariable v)) = maybe e (flip setUniqueName e) `fmap` getFromEnvs v
+renameExp e                                = return e
 
 -- Rename all ExpValue variables found within the block, assuming that
 -- they are to be treated as references to previous declarations,