Skip to content

Commit

Permalink
actually build a map (statefully) as we process declarations
Browse files Browse the repository at this point in the history
  • Loading branch information
dorchard committed Sep 12, 2024
1 parent 2cc737a commit 3e780d5
Show file tree
Hide file tree
Showing 5 changed files with 88 additions and 35 deletions.
2 changes: 1 addition & 1 deletion src/Language/Fortran/Analysis.hs
Original file line number Diff line number Diff line change
Expand Up @@ -3,7 +3,7 @@
-- |
-- Common data structures and functions supporting analysis of the AST.
module Language.Fortran.Analysis
( initAnalysis, stripAnalysis, Analysis(..)
( initAnalysis, analysis0, stripAnalysis, Analysis(..)
, varName, srcName, lvVarName, lvSrcName, isNamedExpression
, genVar, puName, puSrcName, blockRhsExprs, rhsExprs
, ModEnv, NameType(..), Locality(..), markAsImported, isImported
Expand Down
81 changes: 65 additions & 16 deletions src/Language/Fortran/Analysis/DataFlow.hs
Original file line number Diff line number Diff line change
Expand Up @@ -368,33 +368,82 @@ type ConstExpMap = ASTExprNodeMap (Maybe Repr.FValue)
-- | Generate a constant-expression map with information about the
-- expressions (identified by insLabel numbering) in the ProgramFile
-- pf (must have analysis initiated & basic blocks generated) .
genConstExpMap :: forall a. Data a => ProgramFile (Analysis a) -> ConstExpMap
genConstExpMap :: forall a. (Data a) => ProgramFile (Analysis a) -> ConstExpMap
genConstExpMap pf = ceMap
where
-- Generate map of 'parameter' variables, obtaining their value from ceMap below, lazily.
pvMap = M.fromList $
[ (varName v, getE e)
| st@(StDeclaration _ _ (TypeSpec _ _ _ _) _ _) <- universeBi pf :: [Statement (Analysis a)]
, AttrParameter _ _ <- universeBi st :: [Attribute (Analysis a)]
, (Declarator _ _ v ScalarDecl _ (Just e)) <- universeBi st ] ++
[ (varName v, getE e)
| st@StParameter{} <- universeBi pf :: [Statement (Analysis a)]
, (Declarator _ _ v ScalarDecl _ (Just e)) <- universeBi st ]
getV :: Expression (Analysis a) -> Maybe Repr.FValue
getV e = constExp (getAnnotation e) `mplus` (join . flip M.lookup pvMap . varName $ e)

-- Generate map of information about 'constant expressions'.
ceMap = IM.fromList [ (label, doExpr e) | e <- universeBi pf, Just label <- [labelOf e] ]

-- Initial map of parameteri declarations
pvMap :: M.Map Name Repr.FValue
pvMap = execState (recursivelyProcessDecls declarations) M.empty

-- Gather all the declarations in order
declarations :: [Statement (Analysis a)]
declarations =
flip filter (universeBi pf :: [Statement (Analysis a)]) $
\case
StDeclaration{} -> True
StParameter{} -> True
_ -> False

recursivelyProcessDecls :: [Statement (Analysis a)] -> State (M.Map Name Repr.FValue) ()
recursivelyProcessDecls [] = return ()
recursivelyProcessDecls (stmt:stmts) = do
let internalDecls =
case stmt of
(StDeclaration _ _ (TypeSpec _ _ _ _) _ _) ->
-- Gather up all the declarations that are contain in this StDeclaration
-- (there could be many)
[ (varName v, e)
| (Declarator _ _ v _ _ (Just e)) <- universeBi stmt :: [Declarator (Analysis a)]
, AttrParameter _ _ <- universeBi stmt :: [Attribute (Analysis a)] ]

StParameter{} ->
[(varName v, e) | (Declarator _ _ v ScalarDecl _ (Just e)) <- universeBi stmt ]
_ -> []
-- Now process these decls
forM_ internalDecls (\(v, e) -> modify (\map ->
case getE0 map e of
Just evalExpr -> M.insert v evalExpr map
Nothing -> map))
recursivelyProcessDecls stmts

-- -- Generate map of 'parameter' variables, obtaining their value from ceMap below, lazily.
-- pvMapIter :: M.Map Name Repr.FValue -> M.Map Name Repr.FValue
-- pvMapIter map0 = map0 `M.union` M.fromList $
-- [ (varName v, expr)
-- | st@(StDeclaration _ _ (TypeSpec _ _ _ _) _ _) <- universeBi pf :: [Statement (Analysis a)]
-- , AttrParameter _ _ <- universeBi st :: [Attribute (Analysis a)]
-- , (Declarator _ _ v ScalarDecl _ (Just e)) <- universeBi st
-- , expr <- getE0 map0 e ]
-- ++
-- [ (varName v, expr)
-- | st@StParameter{} <- universeBi pf :: [Statement (Analysis a)]
-- , (Declarator _ _ v ScalarDecl _ (Just e)) <- universeBi st
-- , expr <- getE0 map0 e ]

getE0 :: M.Map Name Repr.FValue -> Expression (Analysis a) -> Maybe (Repr.FValue)
getE0 pvMap e = either (const Nothing) (Just . fst) (Repr.runEvalFValuePure pvMap (Repr.evalExpr e))

getE :: Expression (Analysis a) -> Maybe Repr.FValue
getE = join . (flip IM.lookup ceMap <=< labelOf)

labelOf = insLabel . getAnnotation

doExpr :: Expression (Analysis a) -> Maybe Repr.FValue
doExpr e =
-- TODO constants may use other constants! but genConstExpMap needs more
-- changes to support that
case Repr.runEvalFValuePure mempty (Repr.evalExpr e) of
Left _err -> Nothing
Right (a, _msgs) -> Just a
case Repr.runEvalFValuePure pvMap (Repr.evalExpr e) of
Left _err ->
case e of
ExpValue _ _ (ValVariable{}) -> Nothing
_ -> Nothing
Right (a, _msgs) ->
case e of
ExpValue _ _ (ValVariable{}) -> Just a
_ -> Just a

-- | Get constant-expression information and put it into the AST
-- analysis annotation. Must occur after analyseBBlocks.
Expand Down
22 changes: 12 additions & 10 deletions src/Language/Fortran/Repr/Eval/Value.hs
Original file line number Diff line number Diff line change
Expand Up @@ -25,6 +25,8 @@ import Language.Fortran.Repr.Type.Scalar ( fScalarTypeKind )
import Language.Fortran.Repr.Eval.Common
import qualified Language.Fortran.Repr.Eval.Value.Op as Op

import qualified Language.Fortran.Analysis as FA

import GHC.Generics ( Generic )
import qualified Data.Text as Text
import qualified Data.Char
Expand Down Expand Up @@ -102,11 +104,11 @@ evalVar name =
Nothing -> err $ ENoSuchVar name
Just val -> pure val

evalExpr :: MonadFEvalValue m => F.Expression a -> m FValue
evalExpr :: MonadFEvalValue m => F.Expression (FA.Analysis a) -> m FValue
evalExpr = \case
F.ExpValue _ _ astVal ->
e@(F.ExpValue _ _ astVal) ->
case astVal of
F.ValVariable name -> evalVar name
F.ValVariable name -> evalVar (FA.varName e)
-- TODO: Do same with ValIntrinsic??? idk...
_ -> MkFScalarValue <$> evalLit astVal
F.ExpUnary _ _ uop e -> do
Expand All @@ -125,13 +127,13 @@ evalExpr = \case
evalFunctionCall (forceVarExpr ve) evaledArgs
_ -> err $ EUnsupported "Expression constructor"

forceVarExpr :: F.Expression a -> F.Name
forceVarExpr :: F.Expression (FA.Analysis a) -> F.Name
forceVarExpr = \case
F.ExpValue _ _ (F.ValVariable v) -> v
F.ExpValue _ _ (F.ValIntrinsic v) -> v
_ -> error "program error, sent me an expr that wasn't a name"

evalLit :: MonadFEvalValue m => F.Value a -> m FScalarValue
evalLit :: MonadFEvalValue m => F.Value (FA.Analysis a) -> m FScalarValue
evalLit = \case
F.ValInteger i mkp -> do
evalMKp 4 mkp >>= \case
Expand Down Expand Up @@ -176,7 +178,7 @@ evalLit = \case
err :: MonadError Error m => Error -> m a
err = throwError

evalKp :: MonadFEvalValue m => F.KindParam a -> m FKindLit
evalKp :: MonadFEvalValue m => F.KindParam (FA.Analysis a) -> m FKindLit
evalKp = \case
F.KindParamInt _ _ k ->
-- TODO we may wish to check kind param sensibility here
Expand All @@ -192,14 +194,14 @@ evalKp = \case
_ -> err $ EKindLitBadType var (fValueType val)
Nothing -> err $ ENoSuchVar var

evalMKp :: MonadFEvalValue m => FKindLit -> Maybe (F.KindParam a) -> m FKindLit
evalMKp :: MonadFEvalValue m => FKindLit -> Maybe (F.KindParam (FA.Analysis a)) -> m FKindLit
evalMKp kDef = \case
Nothing -> pure kDef
Just kp -> evalKp kp

-- TODO needs cleanup: internal repetition, common parts with evalKp. also needs
-- a docstring
evalRealKp :: MonadFEvalValue m => F.ExponentLetter -> Maybe (F.KindParam a) -> m FKindLit
evalRealKp :: MonadFEvalValue m => F.ExponentLetter -> Maybe (F.KindParam (FA.Analysis a)) -> m FKindLit
evalRealKp l = \case
Nothing ->
case l of
Expand Down Expand Up @@ -425,7 +427,7 @@ evalIntrinsicIntXCoerce coerceToIX v = do
err $ EOpTypeError $
"int: unsupported or unimplemented type: "<>show (fScalarValueType v')

evalArg :: MonadFEvalValue m => F.Argument a -> m FValue
evalArg :: MonadFEvalValue m => F.Argument (FA.Analysis a) -> m FValue
evalArg (F.Argument _ _ _ ae) =
case ae of
F.ArgExpr e -> evalExpr e
Expand Down Expand Up @@ -493,5 +495,5 @@ evalIntrinsicMax = \case
"max: unsupported type: "<> show (fScalarValueType vCurMax)

-- | Evaluate a constant expression (F2018 10.1.12).
evalConstExpr :: MonadFEvalValue m => F.Expression a -> m FValue
evalConstExpr :: MonadFEvalValue m => F.Expression (FA.Analysis a) -> m FValue
evalConstExpr = evalExpr
4 changes: 2 additions & 2 deletions src/Language/Fortran/Util/ModFile.hs
Original file line number Diff line number Diff line change
Expand Up @@ -139,7 +139,7 @@ emptyModFile = ModFile "" M.empty M.empty M.empty M.empty M.empty M.empty
-- | Extracts the module map, declaration map and type analysis from
-- an analysed and renamed ProgramFile, then inserts it into the
-- ModFile.
regenModFile :: forall a. Data a => F.ProgramFile (FA.Analysis a) -> ModFile -> ModFile
regenModFile :: forall a. (Data a) => F.ProgramFile (FA.Analysis a) -> ModFile -> ModFile
regenModFile pf mf = mf { mfModuleMap = extractModuleMap pf
, mfDeclMap = extractDeclMap pf
, mfTypeEnv = FAT.extractTypeEnv pf
Expand All @@ -148,7 +148,7 @@ regenModFile pf mf = mf { mfModuleMap = extractModuleMap pf

-- | Generate a fresh ModFile from the module map, declaration map and
-- type analysis of a given analysed and renamed ProgramFile.
genModFile :: forall a. Data a => F.ProgramFile (FA.Analysis a) -> ModFile
genModFile :: forall a. (Data a) => F.ProgramFile (FA.Analysis a) -> ModFile
genModFile = flip regenModFile emptyModFile

-- | Looks up the raw "other data" that may be stored in a ModFile by
Expand Down
14 changes: 8 additions & 6 deletions test/Language/Fortran/Repr/EvalSpec.hs
Original file line number Diff line number Diff line change
Expand Up @@ -10,6 +10,8 @@ import Language.Fortran.AST
import Language.Fortran.Repr
import Language.Fortran.Repr.Eval.Value

import Language.Fortran.Analysis

import Data.Int

spec :: Spec
Expand All @@ -29,15 +31,15 @@ shouldEvalTo checkVal prog =
-- _ -> expectationFailure "not a scalar"
Left e -> expectationFailure (show e)

expBinary :: BinaryOp -> Expression () -> Expression () -> Expression ()
expBinary = ExpBinary () u
expBinary :: BinaryOp -> Expression (Analysis ()) -> Expression (Analysis ()) -> Expression (Analysis ())
expBinary = ExpBinary (analysis0 ()) u

expValue :: Value () -> Expression ()
expValue = ExpValue () u
expValue :: Value (Analysis ()) -> Expression (Analysis ())
expValue = ExpValue (analysis0 ()) u

-- | default kind. take integral-like over String because nicer to write :)
valInteger :: (Integral a, Show a) => a -> Value ()
valInteger :: (Integral a, Show a) => a -> Value (Analysis ())
valInteger i = ValInteger (show i) Nothing

expValInt :: (Integral a, Show a) => a -> Expression ()
expValInt :: (Integral a, Show a) => a -> Expression (Analysis ())
expValInt = expValue . valInteger

0 comments on commit 3e780d5

Please sign in to comment.