Skip to content

Commit

Permalink
start block node refactor
Browse files Browse the repository at this point in the history
  • Loading branch information
@raehik
raehik committed Aug 18, 2021
1 parent 606048d commit f8ec3e2
Show file tree
Hide file tree
Showing 5 changed files with 61 additions and 39 deletions.
37 changes: 27 additions & 10 deletions src/Language/Fortran/AST.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -86,6 +86,7 @@ module Language.Fortran.AST
, DoSpecification(..)
, ProgramUnitName(..)
, Kind
, BlockConstructStart(..)

-- * Node annotations & related typeclasses
, A0
Expand Down Expand Up @@ -301,6 +302,13 @@ programUnitSubprograms PUComment{} = Nothing
newtype Comment a = Comment String
deriving (Eq, Show, Data, Typeable, Generic, Functor)

data BlockConstructStart a =
BlockConstructStart a SrcSpan
(Maybe (Expression a))
(Maybe String)
(Maybe (Comment a))
deriving (Eq, Show, Data, Typeable, Generic, Functor)

data Block a =
BlStatement a SrcSpan
(Maybe (Expression a)) -- ^ Label
Expand Down Expand Up @@ -329,16 +337,14 @@ data Block a =
(Maybe (Expression a)) -- ^ Label to END SELECT

| BlDo a SrcSpan
(Maybe (Expression a)) -- ^ Label
(Maybe String) -- ^ Construct name
(BlockConstructStart a)
(Maybe (Expression a)) -- ^ Target label
(Maybe (DoSpecification a)) -- ^ Do Specification
[ Block a ] -- ^ Body
(Maybe (Expression a)) -- ^ Label to END DO

| BlDoWhile a SrcSpan
(Maybe (Expression a)) -- ^ Label
(Maybe String) -- ^ Construct name
(BlockConstructStart a)
(Maybe (Expression a)) -- ^ Target label
(Expression a) -- ^ Condition
[ Block a ] -- ^ Body
Expand Down Expand Up @@ -754,6 +760,7 @@ instance FirstParameter (Declarator a) a
instance FirstParameter (DimensionDeclarator a) a
instance FirstParameter (ControlPair a) a
instance FirstParameter (AllocOpt a) a
instance FirstParameter (BlockConstructStart a) a

instance SecondParameter (ProgramUnit a) SrcSpan
instance SecondParameter (Prefix a) SrcSpan
Expand Down Expand Up @@ -783,6 +790,7 @@ instance SecondParameter (Declarator a) SrcSpan
instance SecondParameter (DimensionDeclarator a) SrcSpan
instance SecondParameter (ControlPair a) SrcSpan
instance SecondParameter (AllocOpt a) SrcSpan
instance SecondParameter (BlockConstructStart a) SrcSpan

instance Annotated (AList t)
instance Annotated ProgramUnit
Expand Down Expand Up @@ -811,6 +819,7 @@ instance Annotated Declarator
instance Annotated DimensionDeclarator
instance Annotated ControlPair
instance Annotated AllocOpt
instance Annotated BlockConstructStart

instance Spanned (ProgramUnit a)
instance Spanned (Prefix a)
Expand Down Expand Up @@ -840,6 +849,7 @@ instance Spanned (Declarator a)
instance Spanned (DimensionDeclarator a)
instance Spanned (ControlPair a)
instance Spanned (AllocOpt a)
instance Spanned (BlockConstructStart a)

instance Spanned (ProgramFile a) where
getSpan (ProgramFile _ pus) =
Expand All @@ -854,25 +864,30 @@ class Labeled f where
getLastLabel :: f a -> Maybe (Expression a)
setLabel :: f a -> Expression a -> f a

instance Labeled BlockConstructStart where
getLabel (BlockConstructStart _ _ l _ _) = l
getLastLabel = const Nothing
setLabel (BlockConstructStart a ss _ s c) l = BlockConstructStart a ss (Just l) s c

instance Labeled Block where
getLabel (BlStatement _ _ l _) = l
getLabel (BlIf _ _ l _ _ _ _) = l
getLabel (BlCase _ _ l _ _ _ _ _) = l
getLabel (BlDo _ _ l _ _ _ _ _) = l
getLabel (BlDoWhile _ _ l _ _ _ _ _) = l
getLabel (BlDo _ _ x _ _ _ _) = getLabel x
getLabel (BlDoWhile _ _ x _ _ _ _) = getLabel x
getLabel _ = Nothing

getLastLabel b@BlStatement{} = getLabel b
getLastLabel (BlIf _ _ _ _ _ _ l) = l
getLastLabel (BlCase _ _ _ _ _ _ _ l) = l
getLastLabel (BlDo _ _ _ _ _ _ _ l) = l
getLastLabel (BlDoWhile _ _ _ _ _ _ _ l) = l
getLastLabel (BlDo _ _ _ _ _ _ l) = l
getLastLabel (BlDoWhile _ _ _ _ _ _ l) = l
getLastLabel _ = Nothing

setLabel (BlStatement a s _ st) l = BlStatement a s (Just l) st
setLabel (BlIf a s _ mn conds bs el) l = BlIf a s (Just l) mn conds bs el
setLabel (BlDo a s _ mn tl spec bs el) l = BlDo a s (Just l) mn tl spec bs el
setLabel (BlDoWhile a s _ n tl spec bs el) l = BlDoWhile a s (Just l) n tl spec bs el
setLabel (BlDo a s st tl spec bs el) l = BlDo a s (setLabel st l) tl spec bs el
setLabel (BlDoWhile a s st tl spec bs el) l = BlDoWhile a s (setLabel st l) tl spec bs el
setLabel b _ = b

data ProgramUnitName =
Expand Down Expand Up @@ -949,6 +964,7 @@ instance Out a => Out (AllocOpt a)
instance Out UnaryOp
instance Out BinaryOp
instance Out a => Out (ForallHeader a)
instance Out a => Out (BlockConstructStart a)

-- Classifiers on statement and blocks ASTs

Expand Down Expand Up @@ -1042,3 +1058,4 @@ instance NFData BinaryOp
instance NFData Only
instance NFData ModuleNature
instance NFData Intent
instance NFData a => NFData (BlockConstructStart a)
10 changes: 5 additions & 5 deletions src/Language/Fortran/Analysis.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -335,10 +335,10 @@ computeAllLhsVars = concatMap lhsOfStmt . universeBi
-- | Set of expressions used -- not defined -- by an AST-block.
blockRhsExprs :: Data a => Block a -> [Expression a]
blockRhsExprs (BlStatement _ _ _ s) = statementRhsExprs s
blockRhsExprs (BlDo _ _ _ _ _ (Just (DoSpecification _ _ (StExpressionAssign _ _ lhs rhs) e1 e2)) _ _)
blockRhsExprs (BlDo _ _ _ _ (Just (DoSpecification _ _ (StExpressionAssign _ _ lhs rhs) e1 e2)) _ _)
| ExpSubscript _ _ _ subs <- lhs = universeBi (rhs, e1, e2) ++ universeBi subs
| otherwise = universeBi (rhs, e1, e2)
blockRhsExprs (BlDoWhile _ _ e1 _ _ e2 _ _) = universeBi (e1, e2)
blockRhsExprs (BlDoWhile _ _ e1 _ e2 _ _) = universeBi (e1, e2)
blockRhsExprs (BlIf _ _ e1 _ e2 _ _) = universeBi (e1, e2)
blockRhsExprs b = universeBi b

Expand All @@ -360,7 +360,7 @@ blockVarUses :: forall a. Data a => Block (Analysis a) -> [Name]
blockVarUses (BlStatement _ _ _ (StExpressionAssign _ _ lhs rhs))
| ExpSubscript _ _ _ subs <- lhs = allVars rhs ++ concatMap allVars (aStrip subs)
| otherwise = allVars rhs
blockVarUses (BlDo _ _ _ _ _ (Just (DoSpecification _ _ (StExpressionAssign _ _ lhs rhs) e1 e2)) _ _)
blockVarUses (BlDo _ _ _ _ (Just (DoSpecification _ _ (StExpressionAssign _ _ lhs rhs) e1 e2)) _ _)
| ExpSubscript _ _ _ subs <- lhs = allVars rhs ++ allVars e1 ++ maybe [] allVars e2 ++ concatMap allVars (aStrip subs)
| otherwise = allVars rhs ++ allVars e1 ++ maybe [] allVars e2
blockVarUses (BlStatement _ _ _ st@StDeclaration{}) = concat [ rhsOfDecls d | d <- universeBi st ]
Expand All @@ -372,14 +372,14 @@ blockVarUses (BlStatement _ _ _ st@StDeclaration{}) = concat [ rhsOfDecls d | d
blockVarUses (BlStatement _ _ _ (StCall _ _ f@(ExpValue _ _ (ValIntrinsic _)) _))
| Just uses <- intrinsicUses f = uses
blockVarUses (BlStatement _ _ _ (StCall _ _ _ (Just aexps))) = allVars aexps
blockVarUses (BlDoWhile _ _ e1 _ _ e2 _ _) = maybe [] allVars e1 ++ allVars e2
blockVarUses (BlDoWhile _ _ e1 _ e2 _ _) = maybe [] allVars (Just e1) ++ allVars e2
blockVarUses (BlIf _ _ e1 _ e2 _ _) = maybe [] allVars e1 ++ concatMap (maybe [] allVars) e2
blockVarUses b = allVars b

-- | Set of names defined by an AST-block.
blockVarDefs :: Data a => Block (Analysis a) -> [Name]
blockVarDefs b@BlStatement{} = allLhsVars b
blockVarDefs (BlDo _ _ _ _ _ (Just doSpec) _ _) = allLhsVarsDoSpec doSpec
blockVarDefs (BlDo _ _ _ _ (Just doSpec) _ _) = allLhsVarsDoSpec doSpec
blockVarDefs _ = []

-- form name: n[i]
Expand Down
17 changes: 9 additions & 8 deletions src/Language/Fortran/Analysis/BBlocks.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -91,6 +91,7 @@ labelWithinBlocks = perBlock'
perBlock' :: Block (Analysis a) -> Block (Analysis a)
perBlock' b =
case b of
-- TODO
BlStatement a s e st -> BlStatement a s (mfill i e) (fill i st)
BlIf a s e1 mn e2 bss el -> BlIf a s (mfill i e1) mn (mmfill i e2) bss el
BlCase a s e1 mn e2 is bss el -> BlCase a s (mfill i e1) mn (fill i e2) (mmfill i is) bss el
Expand Down Expand Up @@ -407,14 +408,14 @@ perBlock b@(BlStatement a ss _ (StIfLogical _ _ exp stm)) = do
perBlock b@(BlStatement _ _ _ StIfArithmetic{}) =
-- Treat an arithmetic if similarly to a goto
processLabel b >> addToBBlock b >> closeBBlock_
perBlock b@(BlDo _ _ _ _ _ (Just spec) bs _) = do
perBlock b@(BlDo _ _ _ _ (Just spec) bs _) = do
let DoSpecification _ _ (StExpressionAssign _ _ _ e1) e2 me3 = spec
_ <- processFunctionCalls e1
_ <- processFunctionCalls e2
_ <- case me3 of Just e3 -> Just `fmap` processFunctionCalls e3; Nothing -> return Nothing
perDoBlock Nothing b bs
perBlock b@(BlDo _ _ _ _ _ Nothing bs _) = perDoBlock Nothing b bs
perBlock b@(BlDoWhile _ _ _ _ _ exp bs _) = perDoBlock (Just exp) b bs
perBlock b@(BlDo _ _ _ _ Nothing bs _) = perDoBlock Nothing b bs
perBlock b@(BlDoWhile _ _ _ _ exp bs _) = perDoBlock (Just exp) b bs
perBlock b@(BlStatement _ _ _ StReturn{}) =
processLabel b >> addToBBlock b >> closeBBlock_
perBlock b@(BlStatement _ _ _ StGotoUnconditional{}) =
Expand Down Expand Up @@ -555,8 +556,8 @@ genTemp str = do
-- Strip nested code not necessary since it is duplicated in another
-- basic block.
stripNestedBlocks :: Block a -> Block a
stripNestedBlocks (BlDo a s l mn tl ds _ el) = BlDo a s l mn tl ds [] el
stripNestedBlocks (BlDoWhile a s l tl n e _ el) = BlDoWhile a s l tl n e [] el
stripNestedBlocks (BlDo a s x tl ds _ el) = BlDo a s x tl ds [] el
stripNestedBlocks (BlDoWhile a s x n e _ el) = BlDoWhile a s x n e [] el
stripNestedBlocks (BlIf a s l mn exps _ el) = BlIf a s l mn exps [] el
stripNestedBlocks (BlCase a s l mn sc inds _ el) = BlCase a s l mn sc inds [] el
stripNestedBlocks b = b
Expand Down Expand Up @@ -784,13 +785,13 @@ showBlock (BlStatement _ _ mlab st)
StExit{} -> "exit"
_ -> "<unhandled statement: " ++ show (toConstr (fmap (const ()) st)) ++ ">"
showBlock (BlIf _ _ mlab _ (Just e1:_) _ _) = showLab mlab ++ "if " ++ showExpr e1 ++ "\\l"
showBlock (BlDo _ _ mlab _ _ (Just spec) _ _) =
showLab mlab ++ "do " ++ showExpr e1 ++ " <- " ++
showBlock (BlDo _ _ x _ (Just spec) _ _) =
showLab (getLabel x) ++ "do " ++ showExpr e1 ++ " <- " ++
showExpr e2 ++ ", " ++
showExpr e3 ++ ", " ++
maybe "1" showExpr me4 ++ "\\l"
where DoSpecification _ _ (StExpressionAssign _ _ e1 e2) e3 me4 = spec
showBlock (BlDo _ _ _ _ _ Nothing _ _) = "do"
showBlock (BlDo _ _ _ _ Nothing _ _) = "do"
showBlock (BlComment{}) = ""
showBlock b = "<unhandled block: " ++ show (toConstr (fmap (const ()) b)) ++ ">"

Expand Down
4 changes: 2 additions & 2 deletions src/Language/Fortran/PrettyPrint.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -286,7 +286,7 @@ instance IndentablePretty (Block a) where
abstract | v >= Fortran2003 && abstractp = "abstract "
| otherwise = empty

pprint v (BlDo _ _ mLabel mn tl doSpec body el) i
pprint v (BlDo _ _ (BlockConstructStart _ _ mLabel mn _) tl doSpec body el) i
| v >= Fortran77Extended =
labeledIndent mLabel
(pprint' v mn <?> colon <+>
Expand All @@ -310,7 +310,7 @@ instance IndentablePretty (Block a) where
then indent i (pprint' v label <+> stDoc)
else pprint' v mLabel `overlay` indent i stDoc

pprint v (BlDoWhile _ _ mLabel mName mTarget cond body el) i
pprint v (BlDoWhile _ _ (BlockConstructStart _ _ mLabel mName _) mTarget cond body el) i
| v >= Fortran77Extended =
labeledIndent mLabel
(pprint' v mName <?> colon <+>
Expand Down
32 changes: 18 additions & 14 deletions src/Language/Fortran/Transformation/Grouping.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -85,17 +85,19 @@ groupDo' (b:bs) = b' : bs'
(b', bs') = case b of
BlStatement a s label st
-- Do While statement
| StDoWhile _ _ mTarget Nothing condition <- st ->
| StDoWhile a ss mName Nothing condition <- st ->
let ( blocks, leftOverBlocks, endLabel, stEnd ) =
collectNonDoBlocks groupedBlocks mTarget
in ( BlDoWhile a (getTransSpan s stEnd) label mTarget Nothing condition blocks endLabel
collectNonDoBlocks groupedBlocks mName
blStartStmt = BlockConstructStart a ss Nothing mName Nothing
in ( BlDoWhile a (getTransSpan s stEnd) blStartStmt Nothing condition blocks endLabel
, leftOverBlocks)
-- Vanilla do statement
| StDo _ _ mName Nothing doSpec <- st ->
| StDo a ss mName Nothing doSpec <- st ->
let ( blocks, leftOverBlocks, endLabel, stEnd ) =
collectNonDoBlocks groupedBlocks mName
in ( BlDo a (getTransSpan s stEnd) label mName Nothing doSpec blocks endLabel
, leftOverBlocks)
blStartStmt = BlockConstructStart a ss Nothing mName Nothing
in ( BlDo a (getTransSpan s stEnd) blStartStmt Nothing doSpec blocks endLabel
, leftOverBlocks)
b'' | containsGroups b'' ->
( applyGroupingToSubblocks groupDo' b'', groupedBlocks )
_ -> ( b, groupedBlocks )
Expand Down Expand Up @@ -137,16 +139,18 @@ groupLabeledDo' (b:bs) = b' : bs'
where
(b', bs') = case b of
BlStatement a s label
(StDo _ _ mn tl@Just{} doSpec) ->
(StDo a' ss' mn tl@Just{} doSpec) ->
let ( blocks, leftOverBlocks, lastLabel ) =
collectNonLabeledDoBlocks tl groupedBlocks
in ( BlDo a (getTransSpan s blocks) label mn tl doSpec blocks lastLabel
blStartStmt = BlockConstructStart a' ss' label mn Nothing
in ( BlDo a (getTransSpan s blocks) blStartStmt tl doSpec blocks lastLabel
, leftOverBlocks )
BlStatement a s label
(StDoWhile _ _ mn tl@Just{} cond) ->
(StDoWhile a' ss' mn tl@Just{} cond) ->
let ( blocks, leftOverBlocks, lastLabel ) =
collectNonLabeledDoBlocks tl groupedBlocks
in ( BlDoWhile a (getTransSpan s blocks) label mn tl cond blocks lastLabel
blStartStmt = BlockConstructStart a' ss' label mn Nothing
in ( BlDoWhile a (getTransSpan s blocks) blStartStmt tl cond blocks lastLabel
, leftOverBlocks )
b'' | containsGroups b'' ->
( applyGroupingToSubblocks groupLabeledDo' b'', groupedBlocks )
Expand Down Expand Up @@ -210,10 +214,10 @@ applyGroupingToSubblocks f b
BlIf a s l mn conds (map f blocks) el
| BlCase a s l mn scrutinee conds blocks el <- b =
BlCase a s l mn scrutinee conds (map f blocks) el
| BlDo a s l n tl doSpec blocks el <- b =
BlDo a s l n tl doSpec (f blocks) el
| BlDoWhile a s l n tl doSpec blocks el <- b =
BlDoWhile a s l n tl doSpec (f blocks) el
| BlDo a s x tl doSpec blocks el <- b =
BlDo a s x tl doSpec (f blocks) el
| BlDoWhile a s x tl doSpec blocks el <- b =
BlDoWhile a s x tl doSpec (f blocks) el
| BlInterface{} <- b =
error "Interface blocks do not have groupable subblocks. Must not occur."
| BlComment{} <- b =
Expand Down

0 comments on commit f8ec3e2

Please sign in to comment.