Skip to content

Commit

Permalink
No commit message
Browse files Browse the repository at this point in the history
  • Loading branch information
rgvwille committed Feb 19, 2010
1 parent 8f76820 commit c94ea8d
Show file tree
Hide file tree
Showing 7 changed files with 247 additions and 64 deletions.
19 changes: 13 additions & 6 deletions EHC/src/ehc/GrinCode/Trf/ApplyUnited.cag
View file
Original file line number Diff line number Diff line change
Expand Up @@ -23,7 +23,9 @@ where n = |a b|
%%]
%%[(8 codegen grin) hs import ({%{EH}Base.Common}, {%{EH}GrinCode.Common}, {%{EH}GrinCode}, {%{EH}Base.HsName} )
%%]
%%[(8 codegen grin) hs import(Debug.Trace)
%%[(8 codegen grin) hs import({%{EH}Base.Debug})
%%]
%%[(8 codegen grin) hs import(EH.Util.Debug)
%%]
%%[(8 codegen grin)
WRAPPER GrAGItf
Expand Down Expand Up @@ -72,17 +74,21 @@ SEM GrBind
| Bind expr.env = Map.empty

SEM GrExpr
| Seq body.env = maybe @lhs.env
(\val -> Map.insert @pat.getName val @lhs.env)
| Seq body.env = -- (const $ "seq with pattern " ++ show @pat.getName ++ "\nexpr = " ++ show @expr.grTrf) >>>
maybe @lhs.env
(\val -> -- (const $ "\ninserting " ++ show @pat.getName ++ " for AU ") >>>
Map.insert @pat.getName val @lhs.env)
@expr.mbUnitPNode

| Unit lhs.mbUnitPNode = if @val.hasPAppTag
| Unit lhs.mbUnitPNode = -- (const $ "found unit, val = " ++ show @val.grTrf) >>>
if @val.hasPAppTag
then Just @val.grTrf
else Nothing
| * - Unit lhs.mbUnitPNode = Nothing

| App (lhs.grTrf,lhs.changed)
= maybe (@loc.grTrf,False)
= -- (const $ "\nfound apply, nm = " ++ show @nm) >>>
maybe (@loc.grTrf,False)
(\node -> (applyNode @nm @argL.grTrf node,True))
(Map.lookup @nm @lhs.env)

Expand All @@ -92,7 +98,8 @@ SEM GrExpr


applyNode nm2 flds2 node@(GrVal_Node (GrTag_PApp needs nm) flds1)
= let n = length flds2
= -- (const $ "\napplyNode " ++ show nm2 ++ "\nnode = " ++ show node) >>>
let n = length flds2
in if n<needs
then GrExpr_Unit (GrVal_Node (GrTag_PApp (needs-n) nm) (flds1++flds2))
else if n==needs
Expand Down
10 changes: 5 additions & 5 deletions EHC/src/ehc/GrinCode/Trf/CommonWillEval.cag
View file
Original file line number Diff line number Diff line change
Expand Up @@ -10,12 +10,12 @@
ATTR GrExpr GrAlt [ | | willUseForMp: WillUseForMp ]

SEM GrExpr
| * loc . willUseForMp : WillUseForMp
| Seq loc . willUseForMp = willUseUnion @expr.willUseForMp @body.willUseForMp
| Case loc . willUseForMp = foldr1 willUseIntersection @altL.willUseForMpL
| Eval loc . willUseForMp = Map.singleton @nm (Set.singleton WillUseFor_Eval)
| * loc . willUseForMp : WillUseForMp
| Seq loc . willUseForMp = willUseUnion @expr.willUseForMp @body.willUseForMp
| Case loc . willUseForMp = foldr1 willUseIntersection @altL.willUseForMpL
| Eval loc . willUseForMp = Map.singleton @nm (Set.singleton WillUseFor_Eval)
| * - Eval Seq Case
loc . willUseForMp = Map.empty
loc . willUseForMp = Map.empty
%%]

%%[(8 codegen grin)
Expand Down
0 EHC/src/ehc/GrinCode/Trf/CopyPropagation.cag → ...hc/GrinCode/Trf/CopyPropagationModded.cag
View file
File renamed without changes.
4 changes: 2 additions & 2 deletions EHC/src/ehc/GrinCode/Trf/ForceEval.cag
View file
Original file line number Diff line number Diff line change
Expand Up @@ -43,8 +43,8 @@ instance ForceEval GrTag where

%%[(99 codegen grin) hs
instance ForceEval GrInl where
forceEval i@(GrInl_Call a e _ ) | forceEval a `seq` forceEval e `seq` True = i
forceEval i@(GrInl_CAF e _ ) | forceEval e `seq` True = i
forceEval i@(GrInl_Call a e _ _) | forceEval a `seq` forceEval e `seq` True = i
forceEval i@(GrInl_CAF e _ ) | forceEval e `seq` True = i

%%]

Expand Down
97 changes: 65 additions & 32 deletions EHC/src/ehc/GrinCode/Trf/Inline.cag
View file
Original file line number Diff line number Diff line change
Expand Up @@ -47,13 +47,10 @@ to a loop.
%%[(8 codegen grin) hs import(EH.Util.Pretty,EH.Util.Utils)
%%]

%%[(8 codegen grin) hs import({%{EH}GrinCode.Trf.AliasRename})
%%]

%%[(8 codegen grin) hs import(qualified {%{EH}Config} as Cfg)
%%]

%%[(8 codegen grin) ag import({GrinCode/Trf/CommonAliasAG}, {GrinCode/Trf/CommonFreeVar}, {GrinCode/Trf/CommonWillEval})
%%[(8 codegen grin) ag import({GrinCode/Trf/CommonFreeVar},{GrinCode/Trf/CommonWillEval},{GrinCode/Trf/CommonAliasAG})
%%]


Expand All @@ -71,7 +68,13 @@ to a loop.
%%]

%%[(8 codegen grin) ag import({GrinCode/Trf/UniqueIds})
%%]
%%]

%%[(8 codegen grin) hs import({%{EH}GrinCode.Trf.MkUniqueBindings})
%%]

%%[(8 codegen grin) hs import({%{EH}GrinCode.Trf.SubstExpr})
%%]

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%% Wrapper
Expand Down Expand Up @@ -161,6 +164,8 @@ SEM GrModule
| Mod bindL . fviMp = @bindL.gathFviMp
%%]

{-
-}
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%% Will eval defined here because could not be factored out
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
Expand All @@ -185,29 +190,26 @@ ATTR GrAGItf GrModule AllBind [ allowOmitBind : {Bool} | | ]
%%[(8 codegen grin)
{

toNode nm nms = (nm,nm,nms)

-- Find the loopbreaker for inlining recursive functions, but don't loop.
-- TODO topological sorting. Fix the right scc instead of arbitrary.
-- TODO heuristic for choosing loopbreaker.
type GraphData = [(HsName, HsName, [HsName])]
type GraphData = [(HsName, [HsName])]
calcLoopBreakers :: GraphData -> [HsName]
calcLoopBreakers graph =
let sccs :: [[HsName]]
sccs = map Graph.flattenSCC (Graph.stronglyConnComp graph)
isDirectRecursive name = let (a,b,edges) = fromJust (find (\(name2,_,_) -> name == name2) graph)
sccs = scc graph
isDirectRecursive name = let (a,edges) = fromJust (find ((name ==) . fst) graph)
in elem name edges
nonTrivialSccs = filter (\l -> length l > 1 || isDirectRecursive (head l) ) sccs
loopBreaker = head (head nonTrivialSccs)
in if (null nonTrivialSccs)
then []
else let newGraph = map (map3 (filter (/= loopBreaker))) graph
map3 f (a,b,c) = (a,b,f c)
validEdge (a,b) = b /= loopBreaker
else let newGraph = map (\(a,b) -> (a,filter (/= loopBreaker) b)) graph
validEdge = (/= loopBreaker) . snd
in (loopBreaker : calcLoopBreakers newGraph)
}

ATTR AllBind [ | | dependencies USE {++} {[]}: {[(HsName,[HsName])]} ]
ATTR AllBind [ | | dependencies USE {++} {[]}: {GraphData} ]
ATTR AllBind [ loopBreakers: {[HsName]} | | ]
ATTR AllBind [ inhBindingNames : {[HsName]} | | ]
ATTR AllBind [ | | synBindingNames USE {++} {[]} : {[HsName]} ]
Expand All @@ -230,8 +232,7 @@ SEM GrBind
"\nrecursive bind found,names are:\n" ++ show @bindL.synBindingNames ++
"\n loopbreakers are:" ++ show b
) b) $
let graphData = map (\(nm,dependency) -> toNode nm dependency) @bindL.dependencies
in (calcLoopBreakers graphData) ++ @lhs.loopBreakers
(calcLoopBreakers @bindL.dependencies) ++ @lhs.loopBreakers
bindL.inhBindingNames = @bindL.synBindingNames
%%]

Expand Down Expand Up @@ -261,7 +262,7 @@ SEM GrBind
&& not (@nm `Set.member` @lhs.expNmS) -- only inline if not exported as global value
-- inline possible but keep the bind. (Code duplication).
%%]]
-> (Map.singleton @nm (GrInl_Call @argNmL @expr.trf isLoopBreaker), True)
-> (Map.singleton @nm (GrInl_Call @argNmL @expr.trf isLoopBreaker undefined), True)
Just (FvInfo 1 use) -- a once used, evaluated value can be inlined and its binding removed
| @isCAF
&& willUseForEval @nm @expr.willUseForMp
Expand All @@ -283,7 +284,7 @@ SEM GrBind
|| @expr.inlineCost <= 10 -- and low cost values as well
)
-- TODO: This is now only the size, so only code-duplication is only looked at, not work duplication.
-> (Map.singleton @nm (GrInl_Call @argNmL @expr.trf isLoopBreaker), False) --False because the bind is used more often.
-> (Map.singleton @nm (GrInl_Call @argNmL @expr.trf isLoopBreaker undefined), False) --False because the bind is used more often.
| otherwise

-> (Map.empty, False) -- don't inline
Expand Down Expand Up @@ -318,7 +319,7 @@ SEM GrModule
inlMayExport :: HsNameS -> HsNameS -> HsName -> GrInl -> Bool
inlMayExport onlyInThisModule expNmS n inl
= case inl of
GrInl_Call _ e _
GrInl_Call _ e _ _
-> n `Set.member` expNmS
&& Set.null (onlyInThisModule `Set.intersection` Map.keysSet (grFreeVars e))
_ -> False
Expand Down Expand Up @@ -384,6 +385,34 @@ SEM GrModule
| Mod loc . uniq = 0
%%]

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%% bindId
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

%%[(8 codegen grin)
ATTR AllBind [ | bindId: Int | ]
ATTR AllGrExpr [ bindId: Int | | ]
ATTR AllNTNoMod [ bindIdDigits: Int | | ]

SEM GrBind
| Bind expr.bindId = @lhs.bindId

SEM GrBind
| Bind lhs.bindId = @lhs.bindId+1

SEM GrModule
| Mod bindL.bindId = 0
bindL.bindIdDigits = digits @bindL.bindId

{
digits :: Int -> Int
digits i = if i < 10 then 1 + digits (floor (toEnum i / toEnum 10)) else 1
}

SEM GrBind
| Bind expr.uniqueIds = (map (\i -> i * 10 ^ @lhs.bindIdDigits + @lhs.bindId) [0..]) \\ @lhs.usedIds
%%]

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%% Transformation: inline
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
Expand All @@ -409,11 +438,7 @@ inlGrVar inlMp nmL
inlNmsAreInlineable :: [Maybe HsName] -> Bool
inlNmsAreInlineable = and . map isJust

inlRename :: Int -> [Maybe HsName] -> [HsName] -> GrExpr -> GrExpr
inlRename uniq asFrom as e
= grAliasRename (Just $ (`hsnSuffix` show uniq)) (mkNmAliasMp $ zip as (map fromJust asFrom)) e
%%]
= grAliasRename (Map.fromList $ zipWith (\a n -> (a,NmAlias_Nm n)) as (map fromJust asFrom)) e

%%[(8 codegen grin)
SEM GrExpr
Expand All @@ -426,15 +451,23 @@ SEM GrExpr
%%[(8 codegen grin)

SEM GrExpr
| Call (lhs.trf,loc.gathInlNmS,lhs.changed)
= case Map.lookup @nm @lhs.inlMp of
Just (GrInl_Call as e lb) | inlNmsAreInlineable @argL.asNmL
&& (not (lb && @lhs.insideCase))
-> condTrace showInlines ("inlining call " ++ show @nm) $
( @grVarTrf $ inlRename @lhs.uniq @argL.asNmL as e
, Set.insert @nm @grVarInlNmS
, True)
_ -> (@grVarTrf @trf, @grVarInlNmS, @inlGrVarChanges)
| Call (lhs.trf,loc.gathInlNmS,lhs.changed,lhs.uniqueIds)
= --(const $ "inlining.." ++ show @nm) >>>
--(\(a,b,c,d) -> "uniqueIds for " ++ show @nm ++ " is " ++ show (take 5 d)) >>>
case Map.lookup @nm @lhs.inlMp of
Just (GrInl_Call as e lb _) | not (lb {-&& @lhs.insideCase-})
&& inlNmsAreInlineable @argL.asNmL
-> condTrace showInlines ("inlining call " ++ show @nm) $
let argSubsEnv = Map.fromList (zip as (map fromJust @argL.asNmL))
argsSubstituted = substExpr argSubsEnv e
(newBindingNames,remUniqueIds) = mkUniqueBindings @lhs.uniqueIds argsSubstituted
in ( @grVarTrf newBindingNames
, Set.insert @nm @grVarInlNmS
, True
, remUniqueIds
)
_ -> (@grVarTrf @trf, @grVarInlNmS, @inlGrVarChanges, @lhs.uniqueIds)

| App (lhs.trf,loc.gathInlNmS,lhs.changed)
= if @lhs.isCAF
then let (grVarTrf,grVarInlNmS,changed) = inlGrVar @lhs.inlMp (@nm : Map.keys @argL.gathFviMp)
Expand Down
Loading

0 comments on commit c94ea8d

Please sign in to comment.