INCLUDE "ExecutionPlan.ag" INCLUDE "Patterns.ag" INCLUDE "Expression.ag" INCLUDE "HsToken.ag" imports { import ExecutionPlan import Pretty import PPUtil import Options import Data.Monoid(mappend,mempty) import Data.Maybe import Debug.Trace import System.IO import System.Directory import System.FilePath import UU.Scanner.Position import TokenDef import HsToken import ErrorMessages import Data.Set (Set) import qualified Data.Set as Set import Data.Map (Map) import qualified Data.Map as Map import Data.Sequence(Seq) import qualified Data.Sequence as Seq import Data.Foldable(toList) } ATTR ExecutionPlan ENonterminals ENonterminal EProductions EProduction ERules ERule EChildren EChild [ importBlocks : PP_Doc pragmaBlocks : String textBlocks : PP_Doc moduleHeader : {String -> String -> String -> Bool -> String} mainFile : String mainName : String | | ] ------------------------------------------------------------------------------- -- Options ------------------------------------------------------------------------------- ATTR ExecutionPlan ENonterminals ENonterminal EProductions EProduction ERules ERule EChildren EChild Expression HsToken HsTokens HsTokensRoot Pattern Patterns Visits Visit VisitSteps VisitStep [ options : {Options} | | ] ATTR EProductions EProduction [ rename : {Bool} | | ] SEM ENonterminal | ENonterminal prods.rename = rename @lhs.options ------------------------------------------------------------------------------- -- Context info (nonterminal ident, constructor ident, nonterm params, etc.) ------------------------------------------------------------------------------- ATTR Visit Visits EProduction EProductions EChildren EChild ERules ERule [ nt : NontermIdent | | ] SEM ENonterminal | ENonterminal prods.nt = @nt ATTR EChildren EChild ERules ERule Visits Visit [ con : ConstructorIdent | | ] SEM EProduction | EProduction children.con = @con rules.con = @con visits.con = @con ATTR EProductions EProduction Visits Visit [ params : {[Identifier]} | | ] SEM ENonterminal | ENonterminal prods.params = @params ATTR EProductions EProduction [ classCtxs : ClassContext | | ] SEM ENonterminal | ENonterminal prods.classCtxs = @classCtxs ------------------------------------------------------------------------------- -- Default output ------------------------------------------------------------------------------- ATTR ExecutionPlan [ | | output : {PP_Doc} ] SEM ExecutionPlan | ExecutionPlan lhs.output = @nonts.output >-< @loc.commonExtra >-< @loc.wrappersExtra ATTR ENonterminal ENonterminals [ wrappers : {Set NontermIdent} | | output USE {>-<} {empty} : {PP_Doc} ] SEM ExecutionPlan | ExecutionPlan nonts.wrappers = @wrappers SEM ENonterminal | ENonterminal lhs.output = ("-- " ++ getName @nt ++ " " ++ replicate (60 - length (getName @nt)) '-') >-< (if dataTypes @lhs.options then "-- data" >-< @loc.datatype >-< "" else empty) >-< (if @loc.hasWrapper then "-- wrapper" >-< @loc.wr_inh >-< @loc.wr_syn >-< @loc.wrapper >-< "" else empty) >-< (if folds @lhs.options then "-- cata" >-< @loc.sem_nt >-< "" else empty) >-< (if semfuns @lhs.options then "-- semantic domain" >-< @loc.t_init >-< @loc.t_states >-< @loc.k_states >-< @prods.t_visits >-< @prods.sem_prod >-< "" else empty) loc.hasWrapper = @nt `Set.member` @lhs.wrappers ------------------------------------------------------------------------------- -- Nonterminal datatype ------------------------------------------------------------------------------- ATTR ENonterminal ENonterminals [ typeSyns : {TypeSyns} derivings : {Derivings} | | ] SEM ExecutionPlan | ExecutionPlan nonts.typeSyns = @typeSyns nonts.derivings = @derivings SEM ENonterminal | ENonterminal loc.classPP = ppClasses $ classCtxsToDocs @classCtxs loc.aliasPre = "type" >#< @loc.classPP >#< @nt >#< @loc.t_params >#< "=" loc.datatype = case lookup @nt @lhs.typeSyns of Nothing -> "data" >#< @loc.classPP >#< @nt >#< @loc.t_params >-< ( if null @prods.datatype then empty else indent 2 $ vlist $ ( ("=" >#< head @prods.datatype) : (map ("|" >#<) $ tail @prods.datatype)) ) >-< indent 2 @loc.derivings Just (List t) -> @loc.aliasPre >#< "[" >#< show t >#< "]" Just (Maybe t) -> @loc.aliasPre >#< "Maybe" >#< pp_parens (show t) Just (Tuple ts) -> @loc.aliasPre >#< pp_parens (ppCommas $ map (show . snd) ts) Just (Either l r) -> @loc.aliasPre >#< "Either" >#< pp_parens (show l) >#< pp_parens (show r) Just (Map k v) -> @loc.aliasPre >#< "Data.Map" >#< pp_parens (show k) >#< pp_parens (show v) Just (IntMap t) -> @loc.aliasPre >#< "Data.IntMap.IntMap" >#< pp_parens (show t) Just (OrdSet t) -> @loc.aliasPre >#< "Data.Set.Set" >#< pp_parens (show t) Just IntSet -> @loc.aliasPre >#< "Data.IntSet.IntSet" -- Just x -> error $ "Type " ++ show x ++ " is not supported" loc.derivings = case Map.lookup @nt @lhs.derivings of Nothing -> empty Just s -> if Set.null s then empty else "deriving" >#< (pp_parens $ ppCommas $ map pp $ Set.toList s) { classCtxsToDocs :: ClassContext -> [PP_Doc] classCtxsToDocs = map toDoc where toDoc (ident,args) = (ident >#< ppSpaced (map pp_parens args)) classConstrsToDocs :: [Type] -> [PP_Doc] classConstrsToDocs = map ppTp ppClasses :: [PP_Doc] -> PP_Doc ppClasses [] = empty ppClasses xs = pp_block "(" ")" "," xs >#< "=>" ppQuants :: [Identifier] -> PP_Doc ppQuants [] = empty ppQuants ps = "forall" >#< ppSpaced ps >#< "." } ATTR EProduction [ | | datatype : {PP_Doc} ] ATTR EProductions [ | | datatype USE {:} {[]} : {[PP_Doc]} ] -- we generate the data type in the type-class style instead of the GADT style -- the GADT extension may be required if equality constraints are used SEM EProduction | EProduction lhs.datatype = @loc.quantPP1 >#< @loc.classPP1 >#< conname @lhs.rename @lhs.nt @con >#< ppConFields (dataRecords @lhs.options) @children.datatype loc.classPP1 = ppClasses (classConstrsToDocs @constraints) loc.quantPP1 = ppQuants @params { -- first parameter indicates: generate a record or not ppConFields :: Bool -> [PP_Doc] -> PP_Doc ppConFields True flds = ppListSep "{" "}" ", " $ filter (not . isEmpty) flds ppConFields False flds = ppSpaced flds } ATTR EChild [ | | datatype : {PP_Doc} ] ATTR EChildren [ | | datatype USE {:} {[]} : {[PP_Doc]} ] -- Note: the child may be a higher-order attribute, and its semantics may be deforested SEM EChild | EChild ETerm loc.tpDoc = @loc.addStrict $ pp_parens $ ppTp $ removeDeforested @tp loc.strNm = recordFieldname @lhs.nt @lhs.con @name loc.field = if dataRecords @lhs.options then @loc.strNm >#< "::" >#< @loc.tpDoc else @loc.tpDoc loc.addStrict = \x -> if strictData @lhs.options then "!" >|< x else x | EChild lhs.datatype = case @kind of ChildAttr -> empty -- higher order attributes are not part of the data type _ -> @loc.field | ETerm lhs.datatype = @loc.field { ppTp :: Type -> PP_Doc ppTp = text . typeToHaskellString Nothing [] } ------------------------------------------------------------------------------- -- Nonterminal semantic function ------------------------------------------------------------------------------- SEM ENonterminal | ENonterminal loc.fsemname = \x -> "sem_" ++ show x loc.semname = @loc.fsemname @nt loc.frecarg = \t x -> case t of NT nt _ _ -> pp_parens (@fsemname nt >#< x) _ -> pp x -- The sem_NT function is lazy in the AST: it depends on the application of "child" -- rules to which extend the AST needs to be constructed. loc.sem_tp = @loc.quantPP >#< @loc.classPP >#< @nt >#< @loc.t_params >#< "->" >#< @loc.t_type >#< @loc.t_params loc.quantPP = ppQuants @params loc.sem_nt = @loc.semPragma >-< @loc.semname >#< "::" >#< @loc.sem_tp >-< case lookup @nt @lhs.typeSyns of Nothing -> @prods.sem_nt Just (List t) -> @loc.semname >#< "list" >#< "=" >#< "Prelude.foldr" >#< @loc.semname >|< "_Cons" >#< @loc.semname >|< "_Nil" >#< case t of NT nt _ _ -> pp_parens ("Prelude.map" >#< @fsemname nt >#< "list") _ -> pp "list" Just (Maybe t) -> @loc.semname >#< "Prelude.Nothing" >#< "=" >#< @loc.semname >|< "_Nothing" >-< @loc.semname >#< pp_parens ("Prelude.Just just") >#< "=" >#< @loc.semname >|< "_Just" >#< @frecarg t "just" Just (Tuple ts) -> @loc.semname >#< pp_parens (ppCommas $ map fst ts) >#< "=" >#< @loc.semname >|< "_Tuple" >#< ppSpaced (map (\t -> @frecarg (snd t) (show $ fst t)) ts) Just (Either l r) -> @loc.semname >#< "(Prelude.Left left)" >#< "=" >#< @loc.semname >|< "_Left" >#< @frecarg l "left" >-< @loc.semname >#< "(Prelude.Right right)" >#< "=" >#< @loc.semname >|< "_Right" >#< @frecarg r "right" Just (Map k v) -> @loc.semname >#< "m" >#< "=" >#< "Data.Map.foldrWithKey" >#< @loc.semname >|< "_Entry" >#< @loc.semname >|< "_Nil" >#< case v of NT nt _ _ -> pp_parens ("Data.Map.map" >#< @fsemname nt >#< "m") _ -> pp "m" Just (IntMap v) -> @loc.semname >#< "m" >#< "=" >#< "Data.IntMap.foldWithKey" >#< @loc.semname >|< "_Entry" >#< @loc.semname >|< "_Nil" >#< case v of NT nt _ _ -> pp_parens ("Data.IntMap.map" >#< @fsemname nt >#< "m") _ -> pp "m" Just (OrdSet t) -> @loc.semname >#< "s" >#< "=" >#< "Prelude.foldr" >#< @loc.semname >|< "_Entry" >#< @loc.semname >|< "_Nil" >#< pp_parens ( ( case t of NT nt _ _ -> pp_parens ("Prelude.map" >#< @fsemname nt) _ -> empty ) >#< pp_parens ("Data.IntSet.elems" >#< "s") ) Just IntSet -> @loc.semname >#< "s" >#< "=" >#< "Prelude.foldr" >#< @loc.semname >|< "_Entry" >#< @loc.semname >|< "_Nil" >#< pp_parens ("Data.IntSet.elems" >#< "s") -- Just x -> error $ "Type " ++ show x ++ " is not supported yet" -- TODO: other typeSyns -- precise inlining strategies for inlining loc.inlineNt = not (lateHigherOrderBinding @lhs.options) && not @recursive && (@prods.count == 1 || (aggressiveInlinePragmas @lhs.options && not @loc.hasWrapper)) -- lucrative for inlining loc.semPragma = if noInlinePragmas @lhs.options then empty else if @loc.inlineNt then ppInline @loc.semname else if helpInlining @lhs.options && not (lateHigherOrderBinding @lhs.options) then ppInlinable @loc.semname else ppNoInline @loc.semname -- The number of productions ATTR EProductions EProduction [ | | count USE {+} {0} : {Int} ] SEM EProduction | EProduction lhs.count = {1} -- The per-production cases for the sem_NT function ATTR EProduction EProductions [ | | sem_nt USE {>-<} {empty} : {PP_Doc} ] SEM EProduction | EProduction lhs.sem_nt = "sem_" >|< @lhs.nt >#< "(" >#< conname @lhs.rename @lhs.nt @con >#< ppSpaced @children.argpats >#< ")" >#< "=" >#< "sem_" >|< @lhs.nt >|< "_" >|< @con >#< ppSpaced @children.argnamesw ATTR EChild [ | | argnamesw : { PP_Doc } ] ATTR EChildren [ | | argnamesw USE {:} {[]} : {[PP_Doc]} ] SEM EChild | EChild lhs.argnamesw = case @kind of ChildSyntax -> "(" >#< "sem_" >|< @loc.nt >#< @name >|< "_" >#< ")" ChildAttr -> empty -- no sem-case for a higher-order child ChildReplace tp -> "(" >#< "sem_" >|< extractNonterminal tp >#< @name >|< "_" >#< ")" | ETerm lhs.argnamesw = text $ fieldname @name ------------------------------------------------------------------------------- -- Types of attributes ------------------------------------------------------------------------------- ATTR ExecutionPlan ENonterminals ENonterminal [ inhmap : {Map NontermIdent Attributes} synmap : {Map NontermIdent Attributes} | | ] ATTR EProductions EProduction ERules ERule Patterns Pattern Visits Visit [ inhmap : {Attributes} synmap : {Attributes} allInhmap : {Map NontermIdent Attributes} allSynmap : {Map NontermIdent Attributes} | | ] SEM ENonterminal | ENonterminal (Just prods.inhmap) = Map.lookup @nt @lhs.inhmap (Just prods.synmap) = Map.lookup @nt @lhs.synmap prods.allInhmap = @lhs.inhmap prods.allSynmap = @lhs.synmap ------------------------------------------------------------------------------- -- State datatypes ------------------------------------------------------------------------------- {type VisitStateState = (VisitIdentifier,StateIdentifier, StateIdentifier)} ATTR Visit [ | | allvisits : { VisitStateState }] ATTR Visits [ | | allvisits USE {:} {[]} : {[VisitStateState]}] ATTR EProduction EProductions [ | | allvisits: {[VisitStateState]}] SEM Visit | Visit lhs.allvisits = (@ident, @from, @to) SEM EProductions | Cons lhs.allvisits = @hd.allvisits -- just pick the first production | Nil lhs.allvisits = error "Every nonterminal should have at least 1 production" -- type of tree in a given state s SEM ENonterminal | ENonterminal loc.outedges = Set.fromList $ map (\(_,f,_) -> f) @prods.allvisits loc.inedges = Set.fromList $ map (\(_,_,t) -> t) @prods.allvisits loc.allstates = Set.insert @initial $ @loc.inedges `Set.union` @loc.outedges loc.stvisits = \st -> filter (\(v,f,t) -> f == st) @prods.allvisits loc.t_type = "T_" >|< @nt loc.t_params = ppSpaced @params loc.t_init = "newtype" >#< @loc.t_type >#< @loc.t_params >#< "=" >#< @loc.t_type >#< pp_braces ( "attach_">|< @loc.t_type >#< "::" >#< ppMonadType @lhs.options >#< pp_parens (@loc.t_type >|< "_s" >|< @initial >#< @loc.t_params)) loc.t_states = vlist $ map (\st -> let nt_st = @nt >|< "_s" >|< st t_st = "T_" >|< nt_st k_st = "K_" >|< nt_st c_st = "C_" >|< nt_st inv_st = "inv_" >|< nt_st nextVisit = Map.findWithDefault ManyVis st @nextVisits in case nextVisit of NoneVis -> "data" >#< t_st >#< @loc.t_params >#< "=" >#< c_st -- empty semantics OneVis vId -> "newtype" >#< t_st >#< @loc.t_params >#< "=" >#< c_st >#< (pp_braces $ inv_st >#< "::" >#< pp_parens (conNmTVisit @nt vId >#< @loc.t_params)) ManyVis -> "data" >#< t_st >#< @loc.t_params >#< "where" >#< c_st >#< "::" >#< (pp_braces $ inv_st >#< "::" >#< "!" >|< pp_parens ("forall t." >#< k_st >#< @loc.t_params >#< "t" >#< "->" >#< "t")) >#< "->" >#< t_st >#< @loc.t_params -- this is a conventional data type, but declared with GADT syntax ) $ Set.toList @loc.allstates -- type of a key which identifies a visit v from state s SEM ENonterminal | ENonterminal loc.k_type = "K_" ++ show @nt loc.k_states = vlist $ map (\st -> let nt_st = @nt >|< "_s" >|< st k_st = "K_" >|< nt_st outg = filter (\(v,f,t) -> f == st) @prods.allvisits visitlist = vlist $ map (\(v,f,t) -> @loc.k_type >|< "_v" >|< v >#< "::" >#< k_st >#< @loc.t_params >#< pp_parens (@loc.t_type >|< "_v" >|< v >#< @loc.t_params) ) outg nextVisit = Map.findWithDefault ManyVis st @nextVisits decl = "data" >#< k_st >#< "k" >#< @loc.t_params >#< "where" >-< indent 3 visitlist in case nextVisit of NoneVis -> empty OneVis _ -> empty ManyVis -> decl ) $ Set.toList @loc.allstates -- type of a visit v, with continuation as new state s ATTR Visit Visits EProduction EProductions [ | | t_visits USE {>-<} {empty} : {PP_Doc} ] SEM EProductions | Cons lhs.t_visits = @hd.t_visits -- just pick the first production SEM Visit | Visit loc.nameT_visit = conNmTVisit @lhs.nt @ident loc.nameTIn_visit = conNmTVisitIn @lhs.nt @ident loc.nameTOut_visit = conNmTVisitOut @lhs.nt @ident loc.nameTNext_visit = conNmTNextVisit @lhs.nt @to loc.nextVisitInfo = Map.findWithDefault ManyVis @to @lhs.nextVisits -- which visits can we do after we reach the @to state? loc.typecon = case @kind of VisitPure _ -> empty VisitMonadic -> ppMonadType @lhs.options loc.t_params = ppSpaced @lhs.params lhs.t_visits = "type" >#< @loc.nameT_visit >#< @loc.t_params >#< "=" >#< pp_parens (@loc.nameTIn_visit >#< @loc.t_params) >#< ( if dummyTokenVisit @lhs.options then "->" >#< dummyType @lhs.options True -- Additional (unused though) argument else empty ) >#< "->" >#< @loc.typecon >#< pp_parens (@loc.nameTOut_visit >#< @loc.t_params) >-< "data" >#< @loc.nameTIn_visit >#< @loc.t_params >#< "=" >#< @loc.nameTIn_visit >#< @loc.inhpart >-< "data" >#< @loc.nameTOut_visit >#< @loc.t_params >#< "=" >#< @loc.nameTOut_visit >#< @loc.synpart >#< case @loc.nextVisitInfo of NoneVis -> empty -- don't return a continuation at all _ -> @loc.addbang1 $ pp_parens (@loc.nameTNext_visit >#< @loc.t_params) -- normal route: select the next semantics loc.inhpart = @loc.ppTypeList @inh @lhs.inhmap loc.synpart = @loc.ppTypeList @syn @lhs.synmap loc.ppTypeList = \s m -> ppSpaced $ map (\i -> @loc.addbang1 $ pp_parens $ case Map.lookup i m of Just tp -> ppTp tp ) $ Set.toList s { conNmTVisit nt vId = "T_" >|< nt >|< "_v" >|< vId conNmTVisitIn nt vId = "T_" >|< nt >|< "_vIn" >|< vId conNmTVisitOut nt vId = "T_" >|< nt >|< "_vOut" >|< vId conNmTNextVisit nt stId = "T_" >|< nt >|< "_s" >|< stId ppMonadType :: Options -> PP_Doc ppMonadType opts | parallelInvoke opts = text "IO" | otherwise = text "Identity" } ------------------------------------------------------------------------------- -- Inh and Syn wrappers ------------------------------------------------------------------------------- SEM ENonterminal | ENonterminal loc.wr_inh = @loc.genwrap "Inh" @loc.wr_inhs loc.wr_syn = @loc.genwrap "Syn" @loc.wr_syns loc.genwrap = \nm attr -> "data" >#< nm >|< "_" >|< @nt >#< @loc.t_params >#< "=" >#< nm >|< "_" >|< @nt >#< "{" >#< (ppCommas $ map (\(i,t) -> i >|< "_" >|< nm >|< "_" >|< @nt >#< "::" >#< (@loc.addbang $ pp_parens $ typeToHaskellString (Just @nt) [] t)) attr) >#< "}" loc.synAttrs = fromJust $ Map.lookup @nt @lhs.inhmap loc.wr_inhs = Map.toList $ @loc.wr_filter $ @loc.synAttrs loc.wr_inhs1 = Map.toList @loc.synAttrs loc.wr_filter = if lateHigherOrderBinding @lhs.options then Map.delete idLateBindingAttr else id loc.wr_syns = Map.toList $ fromJust $ Map.lookup @nt @lhs.synmap loc.inhlist = map (lhsname @lhs.options True . fst) @loc.wr_inhs loc.inhlist1 = map (lhsname @lhs.options True . fst) @loc.wr_inhs1 loc.synlist = map (lhsname @lhs.options False . fst) @loc.wr_syns loc.wrapname = "wrap_" ++ show @nt loc.inhname = "Inh_" ++ show @nt loc.synname = "Syn_" ++ show @nt loc.firstVisitInfo = Map.findWithDefault ManyVis @initial @nextVisits loc.wrapper = @loc.wrapPragma >-< (@loc.wrapname >#< "::" >#< @loc.quantPP >#< @loc.classPP >#< @loc.t_type >#< @loc.t_params >#< "->" >#< @loc.inhname >#< @loc.t_params >#< "->" >#< ( if monadicWrappers @lhs.options then ppMonadType @lhs.options else empty) >#< pp_parens (@loc.synname >#< @loc.t_params)) >-< (@loc.wrapname >#< (@loc.addbang $ pp_parens (@loc.t_type >#< pp "act")) >#< (@loc.addbang $ pp_parens (@loc.inhname >#< (ppSpaced $ map (@loc.addbangWrap . pp) @loc.inhlist)) >#< "=")) >-< indent 3 (case @initialv of -- case where there are no inherited or synthesized attributes [] -> @loc.synname >#< " { }" initvs@(initv:_) -> let extra = if dummyTokenVisit @lhs.options then pp $ dummyArg @lhs.options True else empty unMonad | monadicWrappers @lhs.options = empty | otherwise = unMon @lhs.options genSteps _ [] = [] genSteps curst (curv:nextvs) = setarg : dovis : genSteps nextst nextvs where inCon = conNmTVisitIn @nt curv outCon = conNmTVisitOut @nt curv pat = @loc.addbang $ pp_parens $ pat0 pat0 = outCon >#< ppSpaced (map (lhsname @lhs.options False) syns) >#< cont cont | null nextvs = empty | otherwise = pp "sem" inhs = Set.toList $ Map.findWithDefault Set.empty curv @prods.visituses syns = Set.toList $ Map.findWithDefault Set.empty curv @prods.visitdefs arg = inCon >#< ppSpaced (map (lhsname @lhs.options True) inhs) setarg = "let" >#< @loc.addbangWrap (pp "arg" >|< curv) >#< "=" >#< arg ind = case Map.findWithDefault ManyVis curst @nextVisits of NoneVis -> error "wrapper: initial state should have a next visit but it has none" OneVis _ -> empty ManyVis -> @loc.k_type >|< "_v" >|< initv nextst = curst + 1 -- This is not correct, but works both for KW and AOAG -- Should be lookup up based on visit convert = case Map.lookup curv @lhs.allVisitKinds of Just kind -> case kind of VisitPure _ -> text "return" VisitMonadic -> empty dovis = pat >#< "<-" >#< convert >#< pp_parens ("inv_" >|< @nt >|< "_s" >|< curst >#< "sem" >#< ind >#< "arg" >|< curv >#< extra) in unMonad >#< "(" >-< indent 2 ( "do" >#< ( @loc.addbang (pp "sem") >#< "<-" >#< "act" -- run the per-node monadic code to get the initial state (of the root) >-< vlist (genSteps @initial initvs) >-< "return" >#< pp_parens (@loc.synname >#< ppSpaced @loc.synlist) ) ) >-< ")" ) >-< if lateHigherOrderBinding @lhs.options then indent 2 ("where" >#< lhsname @lhs.options True idLateBindingAttr >#< "=" >#< lateBindingFieldNm @lhs.mainName) else empty loc.wrapPragma = if parallelInvoke @lhs.options && not (monadicWrappers @lhs.options) then ppNoInline @loc.wrapname -- required for the use of unsafePerformIO in case of the IO monad else if noInlinePragmas @lhs.options then empty else ppInlinable @loc.wrapname -- ensure that the wrapper is exposed as inlinable ------------------------------------------------------------------------------- -- Collection of NT / Production sem funs references ------------------------------------------------------------------------------- ATTR ENonterminals ENonterminal EProductions EProduction [ | | semFunBndDefs, semFunBndTps USE {Seq.><} {Seq.empty} : {Seq PP_Doc} ] SEM ENonterminal | ENonterminal lhs.semFunBndDefs = @loc.semFunBndDef Seq.<| @prods.semFunBndDefs lhs.semFunBndTps = @loc.semFunBndTp Seq.<| @prods.semFunBndTps loc.semFunBndDef = @loc.semFunBndNm >#< "=" >#< @loc.semname loc.semFunBndTp = @loc.semFunBndNm >#< "::" >#< @loc.sem_tp loc.semFunBndNm = lateSemNtLabel @nt SEM EProduction | EProduction lhs.semFunBndDefs = Seq.singleton @loc.semFunBndDef lhs.semFunBndTps = Seq.singleton @loc.semFunBndTp loc.semFunBndDef = @loc.semFunBndNm >#< "=" >#< @loc.semname loc.semFunBndTp = @loc.semFunBndNm >#< "::" >#< @loc.sem_tp loc.semFunBndNm = lateSemConLabel @lhs.nt @con -- Generate a dictionary that contains the semantics of all semantic functions SEM ExecutionPlan | ExecutionPlan loc.wrappersExtra = if lateHigherOrderBinding @lhs.options then @loc.lateSemBndDef else empty loc.commonExtra = if lateHigherOrderBinding @lhs.options then @loc.lateSemBndTp else empty loc.lateSemBndTp = "data" >#< lateBindingTypeNm @lhs.mainName >#< "=" >#< lateBindingTypeNm @lhs.mainName >-< (indent 2 $ pp_block "{" "}" "," $ toList @nonts.semFunBndTps) loc.lateSemBndDef = ( if noInlinePragmas @lhs.options then empty else if helpInlining @lhs.options && Set.size @wrappers == 1 then ppInline $ lateBindingFieldNm @lhs.mainName -- inline in the single wrapper else ppNoInline $ lateBindingFieldNm @lhs.mainName ) >-< lateBindingFieldNm @lhs.mainName >#< "::" >#< lateBindingTypeNm @lhs.mainName >-< lateBindingFieldNm @lhs.mainName >#< "=" >#< lateBindingTypeNm @lhs.mainName >-< (indent 2 $ pp_block "{" "}" "," $ toList @nonts.semFunBndDefs ) ------------------------------------------------------------------------------- -- Production semantic functions ------------------------------------------------------------------------------- ATTR EProduction [ | | sem_prod : {PP_Doc} ] ATTR EProductions [ | | sem_prod USE {>-<} {empty} : {PP_Doc} ] ATTR EProduction EProductions [ initial : {StateIdentifier} allstates : {Set StateIdentifier} | | ] SEM ENonterminal | ENonterminal prods.initial = @initial prods.allstates = @loc.allstates ATTR EChild [ | | argtps : { PP_Doc } argpats : { PP_Doc } ] ATTR EChildren [ | | argtps USE {:} {[]} : { [PP_Doc] } argpats USE {:} {[]} : { [PP_Doc] } ] SEM EChild | EChild lhs.argtps = case @kind of ChildSyntax -> ppDefor @tp >#< "->" ChildReplace tp -> ppDefor tp >#< "->" _ -> empty -- higher order attribute loc.argpats = case @kind of ChildSyntax -> @name >|< "_" -- no strictification of children semantics to allow infinite trees ChildReplace _ -> @name >|< "_" _ -> empty | ETerm lhs.argtps = (pp_parens $ show @tp) >#< "->" loc.argpats = @loc.addbang $ text $ fieldname @name -- terminals may be strict (perhaps this should become an option) { ppDefor :: Type -> PP_Doc ppDefor (NT nt args _) = "T_" >|< nt >#< ppSpaced (map pp_parens args) ppDefor (Haskell s) = text s } SEM EProduction | EProduction loc.t_type = "T_" >|< @lhs.nt loc.t_params = ppSpaced @lhs.params loc.usedArgs = @children.usedArgs `Set.union` @visits.usedArgs `Set.union` @rules.usedArgs -- A bit ugly, but this code renames arguments and puts an underscore when the argument -- is never used. This avoids compiler warnings of unused variables. loc.args = map (\x -> let (name,arg) = case show x of "" -> ("", empty) '!':name -> ("arg_" ++ name, "!arg_" >|< name) name -> ("arg_" ++ name, "arg_" >|< name) in if null name || name `Set.member` @loc.usedArgs then arg else text "_") @children.argpats loc.semname = "sem_" ++ show @lhs.nt ++ "_" ++ show @con loc.sem_tp = @loc.quantPP2 >#< @loc.classPP2 >#< ppSpaced @children.argtps >#< @loc.t_type >#< @loc.t_params loc.classPP2 = ppClasses (classCtxsToDocs @lhs.classCtxs ++ classConstrsToDocs @constraints) loc.quantPP2 = ppQuants (@lhs.params ++ @params) loc.sem_prod = @loc.semInlinePragma >-< @loc.semname >#< "::" >#< @loc.sem_tp >-< @loc.mkSemBody (@loc.semname >#< ppSpaced @loc.args >#< "=" >#< @loc.scc >#< @loc.t_type) @loc.mbInitializer @loc.outerlet ("return" >#< "st" >|< @lhs.initial) loc.mkSemBody = \prefix mbInit outerlet ret -> case mbInit of Nothing -> prefix >#< pp_parens ret >#< "where" >-< indent 3 outerlet -- code for states and visits Just m -> prefix >#< "(" >#< "do" >-< indent 1 ( m >-< "let" >-< indent 2 outerlet -- code for the states and visits >-< ret ) >-< indent 1 ")" loc.mbInitializer = --some monadic actions, performed upon attaching a child, can -- be specified here. The resulting bindings of these actions are -- in scope of the rules of the production if parallelInvoke @lhs.options then (Nothing :: Maybe PP_Doc) -- perhaps do some per-node registation, etc. For now: nothing else Nothing -- nothing special here loc.scc = if genCostCentres @lhs.options then ppCostCentre @loc.semname else empty loc.semInlinePragma = if noInlinePragmas @lhs.options then empty else ppNoInline @loc.semname -- prevent the semantic functions of constructors to be inlined (e.g. in the nt sem-funs) loc.outerlet = vlist @loc.statefns >-< @rules.sem_rules loc.statefns = map @loc.genstfn $ Set.toList @lhs.allstates loc.genstfn = \st -> let nextVisitInfo = Map.findWithDefault ManyVis st @lhs.nextVisits prevVisitInfo = Map.findWithDefault ManyVis st @lhs.prevVisits stNm = "st" >|< st lhs = pragma >-< bang stNm >#< "=" >#< ( -- generating a lambda for the same reasons as generating -- a lambda for rules: to ensure that overloading is -- resolved for all visit functions and rules together. if st == @lhs.initial then empty else "\\" >#< @loc.stargs st >#< "->" ) pragma = if noInlinePragmas @lhs.options then empty else if helpInlining @lhs.options then case prevVisitInfo of ManyVis -> ppNoInline stNm OneVis _ -> if aggressiveInlinePragmas @lhs.options then ppInline stNm else ppInlinable stNm NoneVis -> if st /= @lhs.initial then error ("State " ++ show st ++ " is not reachable from the initial state.") else if aggressiveInlinePragmas @lhs.options then ppInline stNm -- first state can be inlined else ppInlinable stNm else ppNoInline stNm cCon = "C_" >|< @lhs.nt >|< "_s" >|< st bang | st == @lhs.initial = @loc.addbang -- initial state is not parameterized | otherwise = id -- note about the initial state: the initial state should be the only -- state-binding that is not a function. It is non-recursive and not needed -- anywhere except delivered as initial result. This binding therefore does -- not end up needlessly in any closure. in case nextVisitInfo of NoneVis -> -- the (empty) closure of a (non-initial) end state is not referenced -- thus generating it is not needed (and omitting it may catch some small mistakes). if st == @lhs.initial then lhs >#< cCon -- empty state else empty -- no state generated OneVis vId -> mklet lhs (@loc.stvs st False) (cCon >#< "v" >|< vId) ManyVis -> mklet lhs (@loc.stks st >-< @loc.stvs st True) (cCon >#< "k" >|< st) loc.stargs = \st -> let attrs = maybe Map.empty id $ Map.lookup st @visits.intramap in ppSpaced [ let match | str `Set.member` @loc.lazyIntras = pp str | otherwise = @loc.addbang (pp str) in case mbAttr of Just (AttrSyn child nm) | child == _LOC && not (noPerStateTypeSigs @lhs.options) -> case Map.lookup nm @loc.localAttrTypes of Just tp -> pp_parens (pp_parens match >#< "::" >#< ppTp tp) Nothing -> match Just attr | not (noPerStateTypeSigs @lhs.options) -> case lookupAttrType attr @lhs.allInhmap @lhs.allSynmap @loc.childTypes of Just tpDoc -> pp_parens (pp_parens match >#< "::" >#< tpDoc) Nothing -> match _ -> match | (str,mbAttr) <- Map.assocs attrs ] >#< dummyPat @lhs.options (Map.null attrs) loc.stks = \st -> if null (@loc.stvisits st) then empty else ( if not (noInlinePragmas @lhs.options) && helpInlining @lhs.options then ppNoInline ("k" >|< st) else empty ) >-< "k" >|< st >#< "::" >#< "K_" >|< @lhs.nt >|< "_s" >|< st >#< @loc.t_params >#< "t" >#< "->" >#< "t" >-< vlist (map (\(v,f,t) -> "k" >|< st >#< "K_" >|< @lhs.nt >|< "_v" >|< v >#< "=" >#< "v" >|< v) $ @loc.stvisits st) loc.stvisits = \st -> filter (\(v,f,t) -> f == st) @visits.allvisits loc.stvs = \st inlinePragma -> vlist [ppf inlinePragma | (f,ppf) <- @visits.sem_visit, f == st] visits.mrules = @rules.mrules { mklet :: (PP a, PP b, PP c) => a -> b -> c -> PP_Doc mklet prefix defs body = prefix >#< "let" >-< indent 3 defs >-< indent 2 "in" >#< body } ------------------------------------------------------------------------------- -- Visit semantic functions ------------------------------------------------------------------------------- ATTR Visit [ | | sem_visit : { (StateIdentifier,Bool -> PP_Doc) } ] ATTR Visits [ | | sem_visit USE {:} {[]} : { [(StateIdentifier,Bool -> PP_Doc)] } ] SEM Visit | Visit lhs.sem_visit = ( @from , \addInlinePragma -> ( if noInlinePragmas @lhs.options then empty else if addInlinePragma && aggressiveInlinePragmas @lhs.options then ppInline @loc.vname else if helpInlining @lhs.options then ppNoInline @loc.vname else empty ) >-< "v" >|< @ident >#< "::" >#< @loc.nameT_visit >#< @loc.t_params -- generate a lambda here as well instead of a function definition >-< "v" >|< @ident >#< "=" >#< "\\" >#< (@loc.addbang $ pp_parens (@loc.nameTIn_visit >#< @loc.inhpats)) >#< ( if dummyTokenVisit @lhs.options then pp $ dummyPat @lhs.options True -- extra (but unused) argument else empty ) >#< "->" >#< ( if genCostCentres @lhs.options then ppCostCentre (@loc.vname >|< "_" >|< @lhs.nt >|< "_" >|< @lhs.con) else empty ) >#< "(" >#< @loc.stepsInitial >-< indent 3 (@steps.sem_steps >-< @loc.stepsClosing >#< ")") ) loc.stepsInitial = case @kind of VisitPure False -> text "let" VisitPure True -> empty VisitMonadic -> text "do" loc.stepsClosing = let decls = @loc.nextStBuild >-< @loc.addbang (pp resultValName) >#< "=" >#< @loc.resultval in case @kind of VisitPure False -> decls >-< "in" >#< resultValName VisitPure True -> "let" >#< decls >-< indent 1 ("in" >#< resultValName) VisitMonadic -> "let" >#< decls >-< "return" >#< resultValName loc.vname = "v" >|< @ident loc.inhpats = ppSpaced $ map (\arg -> {-@loc.addbang $-} pp $ attrname @lhs.options True _LHS arg) $ Set.toList @inh loc.inhargs = \chn -> ppSpaced $ map (attrname @lhs.options False chn) $ Set.toList @inh loc.synargs = ppSpaced $ map (\arg -> attrname @lhs.options False _LHS arg) $ Set.toList @syn loc.nextargsMp = maybe Map.empty id $ Map.lookup @to @lhs.allintramap loc.nextargs = ppSpaced $ Map.keys $ @loc.nextargsMp loc.nextst = "st" >|< @to >#< @loc.nextargs >#< dummyArg @lhs.options (Map.null @loc.nextargsMp) loc.resultval = @loc.nameTOut_visit >#< @loc.synargs >#< @loc.nextStRef (loc.nextStBuild, loc.nextStRef) = case @loc.nextVisitInfo of NoneVis -> (empty, empty) _ -> (@loc.addbang (pp nextStName) >#< "=" >#< @loc.nextst, pp nextStName) { resultValName :: String resultValName = "__result_" nextStName :: String nextStName = "__st_" } -- Propagate the visit kind to the steps ATTR VisitStep VisitSteps [ kind : VisitKind | | ] SEM Visit | Visit steps.kind = @kind -- the steps in this group should be executed in a pure fashion SEM VisitStep | PureGroup steps.kind = VisitPure @ordered ATTR Visits Visit VisitStep VisitSteps [ mrules : {Map Identifier (VisitKind -> FormatMode -> Either Error PP_Doc)} | | ] ATTR VisitStep VisitSteps [ | | sem_steps USE {>-<} {empty} : {PP_Doc} ] SEM VisitStep | Sem loc.ruleItf = Map.findWithDefault (error $ "Rule " ++ show @name ++ " not found") @name @lhs.mrules (lhs.errors, loc.sem_steps) = case @loc.ruleItf @lhs.kind @lhs.fmtMode of Left e -> (Seq.singleton e, empty) Right stmt -> (Seq.empty, stmt) | ChildIntro loc.attachItf = Map.findWithDefault (error $ "Child " ++ show @child ++ " not found") @child @lhs.childintros (lhs.errors,lhs.sem_steps,lhs.defs,lhs.uses) = case @loc.attachItf @lhs.kind @lhs.fmtMode of Left e -> (Seq.singleton e, empty, Set.empty, Map.empty) Right (code, defs, uses) -> (Seq.empty, code, defs, uses) | ChildVisit loc.visitItf = Map.findWithDefault (error $ "Visit " ++ show @visit ++ " not found") @visit @lhs.allchildvisit (lhs.errors, loc.patPP, loc.exprPP) = case @loc.visitItf @child @lhs.kind of Left e -> (Seq.singleton e, empty, empty) Right (pat,expr) -> (Seq.empty, pat, expr) loc.useParallel = @lhs.useParallel && not @lhs.isLast lhs.sem_steps = if @loc.useParallel -- assumes to be in a monadic do-expression then @loc.addbang ("sync_" >|< @lhs.index) >#< "<- newEmptyMVar" >-< "forkIO" >#< pp_parens (@loc.convToMonad >#< pp_parens @loc.exprPP >#< ">>= \\" >#< @loc.addbang (pp parResultName) >#< " -> putMVar sync_" >|< @lhs.index >#< parResultName) -- parResultName is guaranteed to be evaluated else let decl = case @lhs.kind of VisitPure _ -> @loc.patPP >#< "=" >#< @loc.exprPP VisitMonadic -> @loc.patPP >#< "<-" >#< @loc.exprPP in fmtDecl False @lhs.fmtMode decl loc.convToMonad = case @loc.callKind of VisitPure _ -> text "return" VisitMonadic -> empty loc.callKind = Map.findWithDefault (error "visit kind should be in the map") @visit @lhs.allVisitKinds | Sim lhs.sem_steps = @steps.sem_steps >-< @steps.sync_steps | PureGroup lhs.sem_steps = case @lhs.fmtMode of FormatDo -> "let" >#< @steps.sem_steps -- formatted as a let-block (not a line-let) _ -> @steps.sem_steps ATTR VisitSteps VisitStep [ | | sync_steps USE {>-<} {empty} : {PP_Doc} ] SEM VisitStep | ChildVisit lhs.sync_steps = if @loc.useParallel then @loc.patPP >#< "<-" >#< "takeMVar sync_" >|< @lhs.index else empty -- The fmtMode indicates in what kind of expression (do/let/line-lets) we are printing -- declarations, because that determines how we need to wrap declarations -- Invariant: @lhs.kind == VisitMonadic ---> @lhs.fmtMode == FormatDo ATTR VisitSteps VisitStep [ fmtMode : FormatMode | | ] SEM Visit | Visit steps.fmtMode = case @kind of VisitPure False -> FormatLetDecl VisitPure True -> FormatLetLine VisitMonadic -> FormatDo SEM VisitStep | PureGroup steps.fmtMode = case @lhs.fmtMode of FormatDo -> FormatLetDecl mode -> mode { parResultName :: String parResultName = "__outcome_" fmtDecl :: PP a => Bool -> FormatMode -> a -> PP_Doc fmtDecl declPure fmt decl = case fmt of FormatLetDecl -> pp decl FormatLetLine -> "let" >#< decl >#< "in" FormatDo | declPure -> "let" >#< decl | otherwise -> pp decl } -- -- Some properties of VisitStep(s) -- -- Used arguments ATTR VisitSteps VisitStep Visit Visits EChild EChildren ERule ERules [ | | usedArgs USE {`Set.union`} {Set.empty} : {Set String} ] SEM ERule | ERule +usedArgs = Set.union $ Map.keysSet $ Map.mapKeys (\a -> "arg_" ++ a) $ Map.filter isNothing @rhs.attrs SEM EChild | EChild +usedArgs = \s -> case @kind of ChildSyntax -> Set.insert ("arg_" ++ show @name ++ "_") s _ -> s -- Number of steps in a 'Sim' block ATTR VisitSteps [ | | size : Int ] SEM VisitSteps | Nil lhs.size = 0 | Cons lhs.size = 1 + @tl.size -- Number the steps in a 'Sim' block ATTR VisitSteps VisitStep [ | index : Int | ] SEM VisitSteps | Cons hd.index = @lhs.index -- copy rule tl.index = 1 + @lhs.index lhs.index = @tl.index -- copy rule SEM Visit | Visit steps.index = 0 SEM VisitStep | Sim steps.index = 0 lhs.index = @lhs.index -- needed for if we ever allow nested Sims -- Biggest number of steps in previous blocks that used parallel invocation -- This number - 1 (minimum 0) is the number of references for parallel invocation created ATTR VisitSteps VisitStep [ | prevMaxSimRefs : Int | ] SEM Visit | Visit steps.prevMaxSimRefs = 0 SEM VisitStep | Sim lhs.prevMaxSimRefs = if @loc.useParallel then @lhs.prevMaxSimRefs `max` (@steps.index - 1) -- possibly new references made else @lhs.prevMaxSimRefs -- no references created -- Is this the last step? ATTR VisitSteps VisitStep [ | | isLast : Bool ] ATTR VisitStep [ isLast : Bool | | ] SEM VisitSteps | Nil lhs.isLast = True | Cons lhs.isLast = False hd.isLast = @tl.isLast -- Use parallel invocation: only when option enabled and there is more than one visit to a child SEM VisitSteps VisitStep [ useParallel : Bool | | ] SEM Visit | Visit steps.useParallel = False SEM VisitStep | Sim loc.useParallel = parallelInvoke @lhs.options && @steps.size > 1 && @loc.isMonadic loc.isMonadic = case @lhs.kind of VisitMonadic -> True _ -> False -- Child introduction ATTR EChild EChildren [ | | childintros USE {`Map.union`} {Map.empty} : {Map Identifier (VisitKind -> FormatMode -> Either Error (PP_Doc, Set String, Map String (Maybe NonLocalAttr)))} ] ATTR Visits Visit VisitSteps VisitStep [ childintros : {Map Identifier (VisitKind -> FormatMode -> Either Error (PP_Doc, Set String, Map String (Maybe NonLocalAttr)))} | | ] SEM EProduction | EProduction visits.childintros = @children.childintros SEM EChild | ETerm lhs.childintros = Map.singleton @name (\_ _ -> Right (empty, Set.empty, Map.empty)) | EChild lhs.childintros = Map.singleton @name @loc.introcode loc.isDefor = case @tp of NT _ _ defor -> defor _ -> False loc.valcode = case @kind of ChildSyntax -> "arg_" >|< @name >|< "_" ChildAttr -> -- decide if we need to invoke the sem-function under the hood let prefix | not @loc.isDefor = if lateHigherOrderBinding @lhs.options -- && sepsemmods @lhs.options -- when sepsemmods is not enabled, the indirection can be optimized away then lateSemNtLabel @loc.nt >#< lhsname @lhs.options True idLateBindingAttr else "sem_" >|< @loc.nt | otherwise = empty -- no need to intro a terminal in pp_parens (prefix >#< instname @name) ChildReplace _ -> -- the higher-order attribute is actually a function that transforms -- the semantics of the child (always deforested) pp_parens (instname @name >#< @name >|< "_") loc.aroundcode = if @hasAround then locname @lhs.options @name >|< "_around" else empty loc.introcode = \kind fmtMode -> let pat = text $ stname @name @loc.initSt patStrict = @loc.addbang pat attach = "attach_T_" >|< @loc.nt >#< pp_parens (@loc.aroundcode >#< @loc.valcode) runAttach = unMon @lhs.options >#< pp_parens attach decl = case kind of VisitPure False -> pat >#< "=" >#< runAttach VisitPure True -> patStrict >#< "=" >#< runAttach VisitMonadic -> patStrict >#< "<-" >#< attach in if compatibleAttach kind @loc.nt @lhs.options then Right ( fmtDecl False fmtMode decl , Set.singleton (stname @name @loc.initSt) -- variables defined by the child intro , case @kind of -- variables used by the child introduction ChildAttr -> Map.insert (instname @name) Nothing $ -- the sem attr ( if @loc.isDefor || not (lateHigherOrderBinding @lhs.options) then id -- the sem dictionary attr is not used else Map.insert (lhsname @lhs.options True idLateBindingAttr) (Just $ AttrInh _LHS idLateBindingAttr) ) $ ( if @hasAround then Map.insert (locname @lhs.options (@name) ++ "_around") Nothing else id ) $ Map.empty ChildReplace _ -> Map.singleton (instname @name) Nothing -- uses the transformation function ChildSyntax -> Map.empty ) else Left $ IncompatibleAttachKind @name kind loc.nt = extractNonterminal @tp { stname :: Identifier -> Int -> String stname child st = "_" ++ getName child ++ "X" ++ show st -- should actually return some conversion info compatibleAttach :: VisitKind -> NontermIdent -> Options -> Bool compatibleAttach _ _ _ = True unMon :: Options -> PP_Doc unMon options | parallelInvoke options = text "System.IO.Unsafe.unsafePerformIO" -- IO monad | otherwise = text "Control.Monad.Identity.runIdentity" -- identity monad } -- rules ATTR ERules ERule [ | | sem_rules USE {>-<} {empty} : {PP_Doc} mrules USE {`Map.union`} {Map.empty} : {Map Identifier (VisitKind -> FormatMode -> Either Error PP_Doc)} ] SEM ERule | ERule lhs.sem_rules = if @loc.used == 0 then empty else @loc.rulePragma >-< @loc.rulecode loc.rulecode = ( if @loc.genpragma then @loc.pragma -- this additional pragma *may* help to give some AG source location in the presence of -- type errors in the rule. It will definitely not be precise, and may take some additional -- source space, but let's see if it's worth it in practice. else empty ) >-< @loc.lambda >#< @loc.scc >-< indent ((column @rhs.pos - 2) `max` 2) ( if @loc.genpragma then @loc.pragma >-< @rhs.semfunc >-< @loc.endpragma else @rhs.semfunc ) loc.rulePragma = ( let reallyInlineStr = "INLINE" reallyNoInlineStr = "NOINLINE" in if noInlinePragmas @lhs.options then empty else if @loc.used == 1 then ppPragmaBinding reallyInlineStr @name -- always inline if used exactly once else if helpInlining @lhs.options then if not @explicit && @loc.used <= reallyOftenUsedThreshold then ppPragmaBinding "INLINE[1]" @name -- inline if copy rule else if @loc.used > ruleInlineThresholdSoft && @explicit -- noinline if it passes the threshold and is not a copy rule then if @loc.used > ruleInlineThresholdHard then ppPragmaBinding reallyNoInlineStr @name -- used too often: force ghc not to inline it else if aggressiveInlinePragmas @lhs.options then ppPragmaBinding "NOINLINE[2]" @name -- allow inlining but only late in the process else ppNoInline @name else if aggressiveInlinePragmas @lhs.options then ppPragmaBinding "NOINLINE[1]" @name -- otherwise, let GHC decide (but do other inlining first) else ppNoInline @name else if not @explicit || @loc.used <= ruleInlineThresholdSoft then ppPragmaBinding "NOINLINE[1]" @name -- otherwise, let GHC decide (but do other inlining first) else ppNoInline @name ) loc.scc = if genCostCentres @lhs.options && @explicit && @pure && not (noPerRuleCostCentres @lhs.options) then ppCostCentre (@name >|< "_" >|< line @rhs.pos >|< "_" >|< @lhs.nt >|< "_" >|< @lhs.con) else empty loc.pragma = "{-# LINE" >#< show (line @rhs.pos) >#< show (file @rhs.pos) >#< "#-}" loc.endpragma = ppWithLineNr (\ln -> "{-# LINE " ++ show (ln+1) ++ " " ++ show @lhs.mainFile ++ "#-}") loc.genpragma = genLinePragmas @lhs.options && @explicit && @loc.haspos loc.haspos = line @rhs.pos > 0 && column @rhs.pos >= 0 && not (null (file @rhs.pos)) -- we generate a simple pattern binding because of overloading-resolving during the type inference process. -- The types of the rules are not generalized (nor do we want that - rules are used in a single typing-context). -- If overloading is resolved separately, it may not be clear which dictionaries to use. For that all rules have -- to be considered together, which is done when we use simple pattern bindings with a lambda expression instead -- of a function definition. -- Note: we also ensure that all rules are lambda expressions, so that they are not made part of any closures -- but are lambda-lifted instead. loc.lambda = @name >#< "=" >#< "\\" >#< @loc.argPats >#< dummyPat @lhs.options (Map.null @rhs.attrs) >#< "->" loc.argPats = ppSpaced [ let match | str `Set.member` @lhs.lazyIntras = pp str | otherwise = @loc.addbang1 (pp str) in case mbAttr of Just (AttrSyn child nm) | child == _LOC && not (noPerStateTypeSigs @lhs.options) -> case Map.lookup nm @lhs.localAttrTypes of Just tp -> pp_parens (pp_parens match >#< "::" >#< ppTp tp) Nothing -> match Just attr | not (noPerRuleTypeSigs @lhs.options) -> case lookupAttrType attr @lhs.allInhmap @lhs.allSynmap @lhs.childTypes of Just tpDoc -> pp_parens (pp_parens match >#< "::" >#< tpDoc) Nothing -> match _ -> match | (str,mbAttr) <- Map.assocs @rhs.attrs ] loc.argExprs = ppSpaced [ case mbAttr of Nothing -> "arg_" >|< str _ -> text str | (str,mbAttr) <- Map.assocs @rhs.attrs ] loc.stepcode = \kind fmtMode -> if kind `compatibleRule` @pure then Right $ let oper | @pure = "=" | otherwise = "<-" decl = @pattern.sem_lhs >#< oper >#< @name >#< @loc.argExprs >#< dummyArg @lhs.options (Map.null @rhs.attrs) tp = if @pure && not (noPerRuleTypeSigs @lhs.options) then @pattern.attrTypes else empty in fmtDecl @pure fmtMode (tp >-< decl) else Left $ IncompatibleRuleKind @name kind lhs.mrules = Map.singleton @name @loc.stepcode ATTR Expression [ | | tks : {[HsToken]} ] SEM Expression | Expression lhs.tks = @tks { dummyPat :: Options -> Bool -> PP_Doc dummyPat opts noArgs | not noArgs && tupleAsDummyToken opts = empty -- no unnecessary tuples | tupleAsDummyToken opts = if strictDummyToken opts then text "()" else text "(_ :: ())" | otherwise = let match | strictDummyToken opts = "!_" | otherwise = "_" in pp_parens (match >#< "::" >#< dummyType opts noArgs) where match | strictDummyToken opts = "(!_)" | otherwise = "_" dummyArg :: Options -> Bool -> PP_Doc dummyArg opts noArgs | not noArgs && tupleAsDummyToken opts = empty -- no unnecessary tuples | tupleAsDummyToken opts = text "()" | otherwise = text "GHC.Prim.realWorld#" dummyType :: Options -> Bool -> PP_Doc dummyType opts noArgs | not noArgs && tupleAsDummyToken opts = empty -- no unnecessary tuples | tupleAsDummyToken opts = text "()" | otherwise = text "(GHC.Prim.State# GHC.Prim.RealWorld)" } { -- rules are "deinlined" to prevent needless code duplication. -- if there is only a bit of duplication, we allow ghc to decide if it is worth it. -- if the duplication crosses this threshold, however, we tell ghc definitely not to inline it. ruleInlineThresholdSoft :: Int ruleInlineThresholdSoft = 3 ruleInlineThresholdHard :: Int ruleInlineThresholdHard = 5 reallyOftenUsedThreshold :: Int reallyOftenUsedThreshold = 12 } ATTR Expression [ | | pos : {Pos} ] SEM Expression | Expression lhs.pos = @pos -- pattern and expression semantics ATTR Pattern [ | | sem_lhs : { PP_Doc } ] ATTR Patterns [ | | sem_lhs USE {:} {[]} : {[PP_Doc]} ] ATTR Pattern Patterns [ | | ] SEM Pattern | Alias loc.varPat = text $ attrname @lhs.options False @field @attr loc.patExpr = if @pat.isUnderscore then @loc.varPat else @loc.varPat >|< "@" >|< @pat.sem_lhs lhs.sem_lhs = @loc.addbang1 @loc.patExpr | Product lhs.sem_lhs = @loc.addbang1 $ pp_block "(" ")" "," @pats.sem_lhs | Constr lhs.sem_lhs = @loc.addbang1 $ pp_parens $ @name >#< hv_sp @pats.sem_lhs | Underscore lhs.sem_lhs = text "_" | Irrefutable lhs.sem_lhs = text "~" >|< pp_parens @pat.sem_lhs -- Check if a pattern is just an underscore ATTR Pattern [ | | isUnderscore:{Bool}] SEM Pattern | Constr lhs.isUnderscore = False | Product lhs.isUnderscore = False | Alias lhs.isUnderscore = False | Underscore lhs.isUnderscore = True -- Collect the attributes defined by a pattern ATTR Pattern Patterns [ | | attrs USE {`Set.union`} {Set.empty} : {Set String} ] SEM Pattern | Alias lhs.attrs = Set.insert (attrname @lhs.options False @field @attr) @pat.attrs -- All attribute types of this pattern ATTR Pattern Patterns [ | | attrTypes USE {>-<} {empty} : {PP_Doc} ] SEM Pattern | Alias loc.mbTp = if @field == _LHS then Map.lookup @attr @lhs.synmap else if @field == _LOC then Map.lookup @attr @lhs.localAttrTypes else Nothing lhs.attrTypes = maybe empty (\tp -> (attrname @lhs.options False @field @attr) >#< "::" >#< ppTp tp) @loc.mbTp >-< @pat.attrTypes -- Collect the attributes used by the right-hand side ATTR HsToken Expression [ | | attrs USE {`Map.union`} {Map.empty} : {Map String (Maybe NonLocalAttr)} ] SEM HsToken | AGLocal lhs.attrs = Map.singleton (fieldname @var) Nothing | AGField loc.mbAttr = if @field == _INST || @field == _FIELD || @field == _INST' then Nothing -- should not be used in the first place else Just $ mkNonLocalAttr (@field == _LHS) @field @attr lhs.attrs = Map.singleton (attrname @lhs.options True @field @attr) @loc.mbAttr { data NonLocalAttr = AttrInh Identifier Identifier | AttrSyn Identifier Identifier deriving Show mkNonLocalAttr :: Bool -> Identifier -> Identifier -> NonLocalAttr mkNonLocalAttr True = AttrInh -- True: inherited attr mkNonLocalAttr False = AttrSyn lookupAttrType :: NonLocalAttr -> Map Identifier Attributes -> Map Identifier Attributes -> Map Identifier Type -> Maybe PP_Doc lookupAttrType (AttrInh child name) inhs _ = lookupType child name inhs lookupAttrType (AttrSyn child name) _ syns = lookupType child name syns -- Note: if the child takes type parameters, the type of an attribute of this child may refer to these parameters. This means that -- the actual type of the attribute needs to have its type parameters substituted with the actual type argument of the child. -- However, for now we simply decide to return Nothing in this case, which skips the type annotation. lookupType :: Identifier -> Identifier -> Map Identifier Attributes -> Map Identifier Type -> Maybe PP_Doc lookupType child name attrMp childMp | noParameters childTp = Just ppDoc | otherwise = Nothing where attrTp = Map.findWithDefault (error "lookupType: the attribute is not in the attrs of the child") name childAttrs childAttrs = Map.findWithDefault (error "lookupType: the attributes of the nonterm are not in the map") nonterm attrMp nonterm = extractNonterminal childTp childTp = Map.findWithDefault (error ("lookupType: the child " ++ show child ++ "is not in the appropriate map")) child childMp ppDoc = ppTp attrTp noParameters :: Type -> Bool noParameters (Haskell _) = True noParameters (NT _ args _) = null args } ATTR Expression [ | | semfunc : {PP_Doc} ] SEM Expression | Expression lhs.attrs = Map.unions $ map (\tok -> attrs_Syn_HsToken (wrap_HsToken (sem_HsToken tok) @loc.inhhstoken)) @tks lhs.semfunc = vlist $ showTokens $ map (\tok -> tok_Syn_HsToken (wrap_HsToken (sem_HsToken tok) @loc.inhhstoken)) @tks loc.inhhstoken = Inh_HsToken @lhs.options -- child visit map ATTR Visit Visits EProduction EProductions ENonterminal ENonterminals [ allchildvisit : {Map VisitIdentifier (Identifier -> VisitKind -> Either Error (PP_Doc, PP_Doc))} | | childvisit USE {`Map.union`} {Map.empty} : {Map VisitIdentifier (Identifier -> VisitKind -> Either Error (PP_Doc, PP_Doc))} ] ATTR VisitSteps VisitStep [ allchildvisit : {Map VisitIdentifier (Identifier -> VisitKind -> Either Error (PP_Doc, PP_Doc))} | | ] SEM ExecutionPlan | ExecutionPlan nonts.allchildvisit = @nonts.childvisit SEM Visit | Visit loc.prevVisitInfo = Map.findWithDefault ManyVis @from @lhs.nextVisits lhs.childvisit = Map.singleton @ident @loc.invokecode loc.invokecode = \chn kind -> -- "chn" is the name of the child at the place of invocation, and "kind" the kind of the calling visit if kind `compatibleKind` @kind then Right $ let pat | isLazyKind @kind = pat0 | otherwise = @loc.addbang pat0 pat0 = pp_parens pat1 pat1 = @loc.nameTOut_visit >#< (ppSpaced $ map (attrname @lhs.options True chn) $ Set.toList @syn) >#< cont cont = case @loc.nextVisitInfo of NoneVis -> empty _ -> ch1 ch0 = text $ stname chn @from ch1 = text $ stname chn @to expr = case (kind, @kind) of (VisitPure _, VisitPure _) -> expr0 (VisitPure _, VisitMonadic) -> unMon @lhs.options >#< expr0 (VisitMonadic, VisitPure _) -> "return" >#< expr0 (VisitMonadic, VisitMonadic) -> expr0 expr0 = case @loc.prevVisitInfo of NoneVis -> error "error: invocation of a visit from a state that has no next visits" OneVis _ -> "inv_" >|< @lhs.nt >|< "_s" >|< @from >#< ch0 >#< args ManyVis -> "inv_" >|< @lhs.nt >|< "_s" >|< @from >#< ch0 >#< "K_" >|< @lhs.nt >|< "_v" >|< @ident >#< args args = pp_parens args0 >#< args1 args0 = @loc.nameTIn_visit >#< @loc.inhargs chn args1 | dummyTokenVisit @lhs.options = pp $ dummyArg @lhs.options True | otherwise = empty in (pat, expr) -- pretty print of the pattern and the expression part else Left $ IncompatibleVisitKind chn @ident kind @kind { -- a `compatibleKind` b means: can kind b be invoked from a compatibleKind :: VisitKind -> VisitKind -> Bool compatibleKind _ _ = True compatibleRule :: VisitKind -> Bool -> Bool compatibleRule (VisitPure _) False = False compatibleRule _ _ = True } ------------------------------------------------------------------------------- -- Properties of rules ------------------------------------------------------------------------------- -- Construct an environment that counts how often certain rules are used ATTR Visits Visit VisitSteps VisitStep [ | | ruleUsage USE {`unionWithSum`} {Map.empty} : {Map Identifier Int} ] ATTR ERules ERule [ usageInfo : {Map Identifier Int} | | ] SEM EProduction | EProduction rules.usageInfo = @visits.ruleUsage SEM VisitStep | Sem lhs.ruleUsage = Map.singleton @name 1 SEM ERule | ERule loc.used = Map.findWithDefault 0 @name @lhs.usageInfo { unionWithSum = Map.unionWith (+) } -- Collect in what visit-kinds a rule is used ATTR Visits Visit VisitSteps VisitStep [ | | ruleKinds USE {`unionWithMappend`} {Map.empty} : {Map Identifier (Set VisitKind)} ] SEM VisitStep | Sem lhs.ruleKinds = Map.singleton @name (Set.singleton @lhs.kind) ATTR ERules ERule [ ruleKinds : {Map Identifier (Set VisitKind)} | | ] SEM EProduction | EProduction rules.ruleKinds = @visits.ruleKinds SEM ERule | ERule loc.kinds = Map.findWithDefault Set.empty @name @lhs.ruleKinds loc.anyLazyKind = Set.fold (\k r -> isLazyKind k || r) False @loc.kinds ATTR Pattern Patterns [ anyLazyKind : Bool | | ] ------------------------------------------------------------------------------- -- Intra attributes ------------------------------------------------------------------------------- { uwSetUnion :: (Ord a, Ord b) => Map a (Set b) -> Map a (Set b) -> Map a (Set b) uwSetUnion = Map.unionWith Set.union uwMapUnion :: (Ord a, Ord b) => Map a (Map b c) -> Map a (Map b c) -> Map a (Map b c) uwMapUnion = Map.unionWith Map.union } ATTR Visit Visits [ allintramap : {Map StateIdentifier (Map String (Maybe NonLocalAttr))} | | intramap USE {`uwMapUnion`} {Map.empty} : {Map StateIdentifier (Map String (Maybe NonLocalAttr))} ] ATTR Visit Visits [ terminaldefs : {Set String} | | ] ATTR EChild EChildren [ | | terminaldefs USE {`Set.union`} {Set.empty} : {Set String} ] SEM EChild | ETerm lhs.terminaldefs = Set.singleton $ fieldname @name SEM EProduction | EProduction visits.allintramap = @visits.intramap visits.terminaldefs = @children.terminaldefs SEM Visit | Visit loc.thisintra = (@loc.uses `Map.union` @loc.nextintra) `Map.difference` @loc.defsAsMap lhs.intramap = Map.singleton @from @loc.thisintra loc.nextintra = maybe Map.empty id $ Map.lookup @to @lhs.allintramap loc.uses = let mp1 = @steps.uses mp2 = Map.fromList [ (lhsname @lhs.options False i, Just (AttrSyn _LHS i)) | i <- Set.elems @syn ] in mp1 `Map.union` mp2 loc.inhVarNms = Set.map (lhsname @lhs.options True) @inh loc.defs = @steps.defs `Set.union` @loc.inhVarNms `Set.union` @lhs.terminaldefs loc.defsAsMap = Map.fromList [ (a, Nothing) | a <- Set.elems @loc.defs ] ATTR ERule ERules [ | | ruledefs USE {`uwSetUnion`} {Map.empty} : {Map Identifier (Set String)} ruleuses USE {`uwMapUnion`} {Map.empty} : {Map Identifier (Map String (Maybe NonLocalAttr))} ] ATTR Visit Visits VisitSteps VisitStep [ ruledefs : {Map Identifier (Set String)} ruleuses : {Map Identifier (Map String (Maybe NonLocalAttr))} | | ] SEM ERule | ERule lhs.ruledefs = Map.singleton @name @pattern.attrs lhs.ruleuses = Map.singleton @name @rhs.attrs SEM EProduction | EProduction visits.ruledefs = @rules.ruledefs visits.ruleuses = @rules.ruleuses ATTR Visit Visits EProduction EProductions ENonterminal ENonterminals [ | | visitdefs USE {`uwSetUnion`} {Map.empty} : {Map VisitIdentifier (Set Identifier)} visituses USE {`uwSetUnion`} {Map.empty} : {Map VisitIdentifier (Set Identifier)} ] SEM Visit | Visit lhs.visitdefs = Map.singleton @ident @syn lhs.visituses = Map.singleton @ident @inh ATTR Visit Visits VisitSteps VisitStep EProduction EProductions ENonterminal ENonterminals [ avisitdefs : {Map VisitIdentifier (Set Identifier)} avisituses : {Map VisitIdentifier (Set Identifier)} | | ] SEM ExecutionPlan | ExecutionPlan nonts.avisitdefs = @nonts.visitdefs nonts.avisituses = @nonts.visituses ATTR VisitSteps VisitStep [ | | defs USE {`Set.union`} {Set.empty} : {Set String} uses USE {`Map.union`} {Map.empty} : {Map String (Maybe NonLocalAttr)} ] SEM VisitStep | Sem lhs.defs = maybe (error "Rule not found") id $ Map.lookup @name @lhs.ruledefs lhs.uses = maybe (error "Rule not found") id $ Map.lookup @name @lhs.ruleuses | ChildVisit lhs.defs = Set.insert (stname @child @to) $ maybe (error "Visit not found") (Set.map $ attrname @lhs.options True @child) $ Map.lookup @visit @lhs.avisitdefs lhs.uses = let convert attrs = Map.fromList [ (attrname @lhs.options False @child attr, Just $ mkNonLocalAttr True @child attr) | attr <- Set.elems attrs ] in Map.insert (stname @child @from) Nothing $ convert $ maybe (error "Visit not found") id $ Map.lookup @visit @lhs.avisituses ------------------------------------------------------------------------------- -- Identification of lazy intra defs within a production -- -- These identifiers will not be marked as strict in rules and state closures ------------------------------------------------------------------------------- ATTR Visits Visit VisitSteps VisitStep [ | | lazyIntras USE {`Set.union`} {Set.empty} : {Set String} ] ATTR ERules ERule [ lazyIntras : {Set String} | | ] SEM Visit | Visit loc.lazyIntrasInh = case @kind of VisitPure False -> @loc.inhVarNms `Set.union` @steps.defs _ -> Set.empty lhs.lazyIntras = @loc.lazyIntrasInh `Set.union` @steps.lazyIntras SEM VisitStep | PureGroup lhs.lazyIntras = if @ordered then @steps.lazyIntras else @steps.defs SEM EProduction | EProduction loc.lazyIntras = @visits.lazyIntras ------------------------------------------------------------------------------- -- Pretty printing of haskell code ------------------------------------------------------------------------------- SEM HsTokens [ || tks : {[(Pos,String)]} ] | Cons lhs.tks = @hd.tok : @tl.tks | Nil lhs.tks = [] SEM HsToken | AGLocal loc.tok = (@pos,fieldname @var) SEM HsToken [ || tok:{(Pos,String)}] | AGField loc.addTrace = case @rdesc of Just d -> \x -> "(trace " ++ show (d ++ " -> " ++ show @field ++ "." ++ show @attr) ++ " (" ++ x ++ "))" Nothing -> id lhs.tok = (@pos, @loc.addTrace $ attrname @lhs.options True @field @attr) | HsToken lhs.tok = (@pos, @value) | CharToken lhs.tok = (@pos, if null @value then "" else showCharShort (head @value) ) | StrToken lhs.tok = (@pos, showStrShort @value) | Err lhs.tok = (@pos, "") ------------------------------------------------------------------------------- -- Alternative code generation (sepsemmods) ------------------------------------------------------------------------------- ATTR ExecutionPlan [ mainBlocksDoc : PP_Doc textBlockMap : {Map BlockInfo PP_Doc} | | genIO : {IO ()} ] SEM ExecutionPlan | ExecutionPlan lhs.genIO = do @loc.genMainModule @loc.genCommonModule @nonts.genProdIO loc.mainModuleFile = @lhs.mainFile loc.ppMonadImports = ( if tupleAsDummyToken @lhs.options then empty else pp "import GHC.Prim" ) >-< if parallelInvoke @lhs.options then pp "import qualified System.IO.Unsafe(unsafePerformIO)" >-< pp "import System.IO(IO)" >-< pp "import Control.Concurrent(newEmptyMVar,forkIO,putMVar,takeMVar)" else pp "import Control.Monad.Identity" loc.genMainModule = writeModule @loc.mainModuleFile ( [ warrenFlagsPP @lhs.options , pp $ @lhs.pragmaBlocks , pp $ @lhs.moduleHeader @lhs.mainName "" "" False , @loc.ppMonadImports , pp $ "import " ++ @lhs.mainName ++ "_common" ] ++ @nonts.imports ++ [@lhs.mainBlocksDoc] ++ [@loc.wrappersExtra] ++ @nonts.appendMain ) loc.commonFile = replaceBaseName @lhs.mainFile (takeBaseName @lhs.mainFile ++ "_common") loc.genCommonModule = writeModule @loc.commonFile ( [ pp $ "{-# LANGUAGE Rank2Types, GADTs #-}" -- the common module only needs GADTs and Rank2Types , pp $ @lhs.pragmaBlocks , pp $ @lhs.moduleHeader @lhs.mainName "_common" "" True , @loc.ppMonadImports , @lhs.importBlocks , @lhs.textBlocks , @loc.commonExtra ] ++ @nonts.appendCommon ) ATTR ENonterminal [ | | appendCommon, appendMain : { PP_Doc } ] ATTR ENonterminals [ | | appendCommon, appendMain USE {:} {[]} : {[PP_Doc]} ] SEM ENonterminal | ENonterminal lhs.appendMain = (if @nt `Set.member` @lhs.wrappers then @loc.wr_inh >-< @loc.wr_syn >-< @loc.wrapper else empty) >-< @loc.sem_nt lhs.appendCommon = (if dataTypes @lhs.options then @loc.datatype else empty) >-< @loc.t_init >-< @loc.t_states >-< @loc.k_states >-< @prods.t_visits ATTR EProduction EProductions ENonterminal ENonterminals [ | | imports USE {++} {[]} : {[PP_Doc]} genProdIO USE {>>} {return ()} : {IO ()} ] SEM EProduction | EProduction lhs.imports = [pp $ "import " ++ @loc.moduleName] loc.moduleName = @lhs.mainName ++ @loc.suffix loc.suffix = "_" ++ show @lhs.nt ++ "_" ++ show @con loc.outputfile = replaceBaseName @lhs.mainFile (takeBaseName @lhs.mainFile ++ @loc.suffix) loc.ppMonadImports = if parallelInvoke @lhs.options then pp "import qualified System.IO.Unsafe(unsafePerformIO)" >-< pp "import System.IO(IO)" >-< pp "import Control.Concurrent(newEmptyMVar,forkIO,putMVar,takeMVar)" else pp "import Control.Monad.Identity" lhs.genProdIO = writeModule @loc.outputfile [ warrenFlagsPP @lhs.options , pp $ @lhs.pragmaBlocks , pp $ @lhs.moduleHeader @lhs.mainName @loc.suffix @loc.semname True , @lhs.importBlocks , @loc.ppMonadImports , ( if tupleAsDummyToken @lhs.options then empty else pp "import GHC.Prim" -- need it to pass State# ) , pp $ "import " ++ @lhs.mainName ++ "_common" , @loc.sem_prod ] { renderDocs :: [PP_Doc] -> String renderDocs pps = foldr (.) id (map (\d -> (disp d 50000) . ( '\n':) ) pps) "" writeModule :: FilePath -> [PP_Doc] -> IO () writeModule path docs = do bExists <- doesFileExist path if bExists then do input <- readFile path seq (length input) (return ()) if input /= output then dumpIt else return () else dumpIt where output = renderDocs docs dumpIt = writeFile path output } -- -- Bang pattern usage -- SEM ERule | ERule loc.addbang = \x -> if bangpats @lhs.options then "!" >|< x else x SEM Visit | Visit loc.addbang = \x -> if bangpats @lhs.options then "!" >|< x else x SEM ENonterminal | ENonterminal loc.addbang = \x -> if bangpats @lhs.options then "!" >|< x else x SEM EProduction | EProduction loc.addbang = \x -> if bangpats @lhs.options then "!" >|< x else x SEM EChild | EChild loc.addbang = \x -> if bangpats @lhs.options then "!" >|< x else x SEM EChild | ETerm loc.addbang = \x -> if bangpats @lhs.options then "!" >|< x else x SEM VisitStep | ChildVisit loc.addbang = \x -> if bangpats @lhs.options then "!" >|< x else x SEM Pattern | Alias Constr Product loc.addbang = \x -> if bangpats @lhs.options then "!" >|< x else x SEM Visit | Visit loc.addbang1 = if isLazyKind @kind then id else @loc.addbang SEM ENonterminal | ENonterminal loc.addbangWrap = id --if strictWrap @lhs.options then @loc.addbang else id SEM ERule | ERule loc.addbang1 = if @loc.anyLazyKind then id else @loc.addbang SEM Pattern | Alias Constr Product loc.addbang1 = if @lhs.anyLazyKind then id else @loc.addbang -- -- Distribute single-visit-next map downward -- ATTR EProductions EProduction Visits Visit [ prevVisits, nextVisits : {Map StateIdentifier StateCtx} | | ] SEM ENonterminal | ENonterminal prods.nextVisits = @nextVisits prods.prevVisits = @prevVisits -- -- Collect and distribute the from/to states of a visit -- ATTR ENonterminals ENonterminal EProductions EProduction Visits Visit [ | | fromToStates USE {`mappend`} {mempty} : {Map VisitIdentifier (Int,Int)} ] ATTR ENonterminals ENonterminal EProductions EProduction Visits Visit VisitSteps VisitStep [ allFromToStates : {Map VisitIdentifier (Int,Int)} | | ] SEM Visit | Visit lhs.fromToStates = Map.singleton @ident (@from, @to) SEM ExecutionPlan | ExecutionPlan nonts.allFromToStates = @nonts.fromToStates SEM VisitStep | ChildVisit (loc.from, loc.to) = Map.findWithDefault (error "visit not in allFromToStates") @visit @lhs.allFromToStates -- -- Collect and distribute the actual types of children of productions -- ATTR EChildren EChild [ | | childTypes USE {`mappend`} {mempty} : {Map Identifier Type} ] ATTR ERules ERule Visits Visit VisitSteps VisitStep [ childTypes : {Map Identifier Type} | | ] SEM EProduction | EProduction loc.childTypes = Map.singleton _LHS @lhs.ntType `Map.union` @children.childTypes SEM EChild | EChild ETerm lhs.childTypes = Map.singleton @name @tp -- -- Distribute types of local attributes -- ATTR ExecutionPlan ENonterminals ENonterminal [ localAttrTypes : {Map NontermIdent (Map ConstructorIdent (Map Identifier Type))} | | ] ATTR EProductions EProduction [ localAttrTypes : {Map ConstructorIdent (Map Identifier Type)} | | ] ATTR ERules ERule Pattern Patterns [ localAttrTypes : {Map Identifier Type} | | ] SEM ENonterminal | ENonterminal prods.localAttrTypes = Map.findWithDefault Map.empty @nt @lhs.localAttrTypes SEM EProduction | EProduction loc.localAttrTypes = Map.findWithDefault Map.empty @con @lhs.localAttrTypes -- -- Collect and distribute visit kinds -- ATTR ENonterminals ENonterminal EProductions EProduction Visits Visit VisitSteps VisitStep [ allVisitKinds : {Map VisitIdentifier VisitKind} | | visitKinds USE {`mappend`} {mempty} : {Map VisitIdentifier VisitKind} ] SEM Visit | Visit lhs.visitKinds = Map.singleton @ident @kind SEM ExecutionPlan | ExecutionPlan nonts.allVisitKinds = @nonts.visitKinds -- -- Collect and distribute the initial state of nonterminals -- ATTR ENonterminals ENonterminal [ | | initStates USE {`mappend`} {mempty} : {Map NontermIdent Int} ] ATTR ENonterminals ENonterminal EProductions EProduction EChildren EChild Visits Visit VisitSteps VisitStep [ allInitStates : {Map NontermIdent Int} | | ] SEM ENonterminal | ENonterminal lhs.initStates = Map.singleton @nt @initial SEM ExecutionPlan | ExecutionPlan nonts.allInitStates = @nonts.initStates SEM EChild | EChild loc.initSt = Map.findWithDefault (error "nonterminal not in allInitStates map") @loc.nt @lhs.allInitStates -- -- Push the nonterminal type downward -- ATTR EProductions EProduction [ ntType : Type | | ] SEM ENonterminal | ENonterminal loc.ntType = NT @nt (map show @params) False -- -- Collect errors contained in rules that should be yielded when the -- rules are scheduled. -- ATTR ExecutionPlan ENonterminals ENonterminal EProductions EProduction ERules ERule Visits Visit VisitSteps VisitStep [ | | errors USE {Seq.><} {Seq.empty} : {Seq Error} ] SEM ERule | ERule lhs.errors = case @mbError of Just e | @loc.used > 0 -> Seq.singleton e _ -> Seq.empty -- Some pretty printing utility functions { ppNoInline :: PP a => a -> PP_Doc ppNoInline = ppPragmaBinding "NOINLINE" ppInline :: PP a => a -> PP_Doc ppInline = ppPragmaBinding "INLINE" ppInlinable :: PP a => a -> PP_Doc ppInlinable = ppPragmaBinding "INLINABLE" ppPragmaBinding :: (PP a, PP b) => a -> b -> PP_Doc ppPragmaBinding pragma nm = "{-#" >#< pragma >#< nm >#< "#-}" ppCostCentre :: PP a => a -> PP_Doc ppCostCentre nm = "{-#" >#< "SCC" >#< "\"" >|< nm >|< "\"" >#< "#-}" warrenFlagsPP :: Options -> PP_Doc warrenFlagsPP options = vlist [ pp "{-# LANGUAGE Rank2Types, GADTs #-}" , if bangpats options then pp "{-# LANGUAGE BangPatterns #-}" else empty , if noPerRuleTypeSigs options && noPerStateTypeSigs options then empty else pp "{-# LANGUAGE ScopedTypeVariables #-}" , if tupleAsDummyToken options then empty else pp "{-# LANGUAGE ScopedTypeVariables, MagicHash #-}" , -- not that the meaning of "unbox" is here that strict fields in data types may be -- unboxed if possible. This may affect user-defined data types declared in the module. -- Unfortunately, we cannot turn it on for only the AG generated data types without -- causing a zillion of warnings. if unbox options && bangpats options then pp $ "{-# OPTIONS_GHC -funbox-strict-fields -fstrictness #-}" else empty , if parallelInvoke options && not (noEagerBlackholing options) then pp $ "{-# OPTIONS_GHC -feager-blackholing #-}" else empty ] }