import StgSyn
-import AbsUniType ( mkForallTy, splitForalls, glueTyArgs,
- UniType, RhoType(..), TauType(..)
+import Type ( mkForallTy, splitForalls, glueTyArgs,
+ Type, RhoType(..), TauType(..)
)
import Bag
-import Id ( mkSysLocal, getIdUniType, addIdArity, Id )
-import IdEnv
+import Id ( mkSysLocal, idType, addIdArity, Id )
import Maybes
-import SplitUniq
+import UniqSupply
import SrcLoc ( mkUnknownSrcLoc, SrcLoc )
import UniqSet
import Util
* Non-recursive bindings whose RHS is a lambda abstractions are lifted,
provided all the occurrences of the bound variable is in a function
postition. In this example, f will be lifted:
-
- let
+
+ let
f = \x -> e
in
..(f a1)...(f a2)...
But in this case, f won't be lifted:
- let
+ let
f = \x -> e
in
..(g f)...(f a2)...
let
f = $f p q r
- in
+ in
..(g f)...($f p q r a2)..
so it might as well be the original lambda abstraction.
We also do not lift if the function has an occurrence with no arguments, e.g.
-
- let
- f = \x -> e
- in f
-
+
+ let
+ f = \x -> e
+ in f
+
as this form is more efficient than if we create a partial application
$f p q r x = e -- Supercombinator
- f p q r
+ f p q r
* Recursive bindings *all* of whose RHSs are lambda abstractions are
lifted iff
- there aren't ``too many'' free variables.
Same reasoning as before for the function-position stuff. The ``too many
- free variable'' part comes from considering the (potentially many)
+ free variable'' part comes from considering the (potentially many)
recursive calls, which may now have lots of free vars.
Recent Observations:
* We do not lambda lift if the function has at least one occurrence
without any arguments. This caused lots of problems. Ex:
h = \ x -> ... let y = ...
- in let let f = \x -> ...y...
- in f
- ==>
+ in let let f = \x -> ...y...
+ in f
+ ==>
f = \y x -> ...y...
h = \ x -> ... let y = ...
- in f y
-
+ in f y
+
now f y is a partial application, so it will be updated, and this
is Bad.
--- NOT RELEVANT FOR STG ----
-* All ``lone'' lambda abstractions are lifted. Notably this means lambda
+* All ``lone'' lambda abstractions are lifted. Notably this means lambda
abstractions:
- in a case alternative: case e of True -> (\x->b)
- in the body of a let: let x=e in (\y->b)
%************************************************************************
\begin{code}
-liftProgram :: SplitUniqSupply -> [PlainStgBinding] -> [PlainStgBinding]
+liftProgram :: UniqSupply -> [StgBinding] -> [StgBinding]
liftProgram us prog = concat (runLM Nothing us (mapLM liftTopBind prog))
-liftTopBind :: PlainStgBinding -> LiftM [PlainStgBinding]
+liftTopBind :: StgBinding -> LiftM [StgBinding]
liftTopBind (StgNonRec id rhs)
= dontLiftRhs rhs `thenLM` \ (rhs', rhs_info) ->
returnLM (getScBinds rhs_info ++ [StgNonRec id rhs'])
\begin{code}
-liftExpr :: PlainStgExpr
- -> LiftM (PlainStgExpr, LiftInfo)
+liftExpr :: StgExpr
+ -> LiftM (StgExpr, LiftInfo)
-liftExpr expr@(StgConApp con args lvs) = returnLM (expr, emptyLiftInfo)
-liftExpr expr@(StgPrimApp op args lvs) = returnLM (expr, emptyLiftInfo)
+liftExpr expr@(StgCon con args lvs) = returnLM (expr, emptyLiftInfo)
+liftExpr expr@(StgPrim op args lvs) = returnLM (expr, emptyLiftInfo)
-liftExpr expr@(StgApp (StgLitAtom lit) args lvs) = returnLM (expr, emptyLiftInfo)
-liftExpr expr@(StgApp (StgVarAtom v) args lvs)
+liftExpr expr@(StgApp (StgLitArg lit) args lvs) = returnLM (expr, emptyLiftInfo)
+liftExpr expr@(StgApp (StgVarArg v) args lvs)
= lookup v `thenLM` \ ~(sc, sc_args) -> -- NB the ~. We don't want to
-- poke these bindings too early!
- returnLM (StgApp (StgVarAtom sc) (map StgVarAtom sc_args ++ args) lvs,
+ returnLM (StgApp (StgVarArg sc) (map StgVarArg sc_args ++ args) lvs,
emptyLiftInfo)
- -- The lvs field is probably wrong, but we reconstruct it
+ -- The lvs field is probably wrong, but we reconstruct it
-- anyway following lambda lifting
liftExpr (StgCase scrut lv1 lv2 uniq alts)
liftExpr (StgLetNoEscape _ _ (StgNonRec binder rhs) body)
= dontLiftRhs rhs `thenLM` \ (rhs', rhs_info) ->
liftExpr body `thenLM` \ (body', body_info) ->
- returnLM (StgLet (StgNonRec binder rhs') body',
- rhs_info `unionLiftInfo` body_info)
+ returnLM (StgLet (StgNonRec binder rhs') body',
+ rhs_info `unionLiftInfo` body_info)
liftExpr (StgLetNoEscape _ _ (StgRec pairs) body)
= liftExpr body `thenLM` \ (body', body_info) ->
| not (isLiftable rhs)
= dontLiftRhs rhs `thenLM` \ (rhs', rhs_info) ->
liftExpr body `thenLM` \ (body', body_info) ->
- returnLM (StgLet (StgNonRec binder rhs') body',
- rhs_info `unionLiftInfo` body_info)
+ returnLM (StgLet (StgNonRec binder rhs') body',
+ rhs_info `unionLiftInfo` body_info)
| otherwise -- It's a lambda
= -- Do the body of the let
fixLM (\ ~(sc_inline, _, _) ->
addScInlines [binder] [sc_inline] (
- liftExpr body
+ liftExpr body
) `thenLM` \ (body', body_info) ->
-- Deal with the RHS
- dontLiftRhs rhs `thenLM` \ (rhs', rhs_info) ->
+ dontLiftRhs rhs `thenLM` \ (rhs', rhs_info) ->
-- All occurrences in function position, so lambda lift
getFinalFreeVars (rhsFreeVars rhs) `thenLM` \ final_free_vars ->
- mkScPieces final_free_vars (binder,rhs') `thenLM` \ (sc_inline, sc_bind) ->
+ mkScPieces final_free_vars (binder,rhs') `thenLM` \ (sc_inline, sc_bind) ->
- returnLM (sc_inline,
- body',
+ returnLM (sc_inline,
+ body',
nonRecScBind rhs_info sc_bind `unionLiftInfo` body_info)
) `thenLM` \ (_, expr', final_info) ->
returnLM (expr', final_info)
liftExpr (StgLet (StgRec pairs) body)
---[Andre-testing]
+--[Andre-testing]
| not (all isLiftableRec rhss)
= liftExpr body `thenLM` \ (body', body_info) ->
mapAndUnzipLM dontLiftRhs rhss `thenLM` \ (rhss', rhs_infos) ->
liftExpr body `thenLM` \ (body', body_info) ->
mapAndUnzipLM dontLiftRhs rhss `thenLM` \ (rhss', rhs_infos) ->
let
- -- Find the free vars of all the rhss,
+ -- Find the free vars of all the rhss,
-- excluding the binders themselves.
rhs_free_vars = unionManyUniqSets (map rhsFreeVars rhss)
- `minusUniqSet`
- mkUniqSet binders
+ `minusUniqSet`
+ mkUniqSet binders
rhs_info = unionLiftInfos rhs_infos
in
mapAndUnzipLM (mkScPieces final_free_vars) (binders `zip` rhss')
`thenLM` \ (sc_inlines, sc_pairs) ->
- returnLM (sc_inlines,
- body',
+ returnLM (sc_inlines,
+ body',
recScBind rhs_info sc_pairs `unionLiftInfo` body_info)
)) `thenLM` \ (_, expr', final_info) ->
occurs in an argument position.
\begin{code}
-isLiftable :: PlainStgRhs -> Bool
+isLiftable :: StgRhs -> Bool
-isLiftable (StgRhsClosure _ (StgBinderInfo arg_occ _ _ _ unapplied_occ) fvs _ args _)
+isLiftable (StgRhsClosure _ (StgBinderInfo arg_occ _ _ _ unapplied_occ) fvs _ args _)
-- Experimental evidence suggests we should lift only if we will be
-- abstracting up to 4 fvs.
unapplied_occ || -- Has an occ with no args at all
arg_occ || -- Occurs in arg position
length fvs > 4 -- Too many free variables
- )
+ )
then {-trace ("LL: " ++ show (length fvs))-} True
else False
isLiftable other_rhs = False
-isLiftableRec :: PlainStgRhs -> Bool
+isLiftableRec :: StgRhs -> Bool
-- this is just the same as for non-rec, except we only lift to
-- abstract up to 1 argument this avoids undoing Static Argument
{- Andre's longer comment about isLiftableRec: 1996/01:
-A rec binding is "liftable" (according to our heuristics) if:
-* It is a function,
-* all occurrences have arguments,
+A rec binding is "liftable" (according to our heuristics) if:
+* It is a function,
+* all occurrences have arguments,
* does not occur in an argument position and
* has up to *2* free variables (including the rec binding variable
itself!)
here).
-}
-isLiftableRec (StgRhsClosure _ (StgBinderInfo arg_occ _ _ _ unapplied_occ) fvs _ args _)
+isLiftableRec (StgRhsClosure _ (StgBinderInfo arg_occ _ _ _ unapplied_occ) fvs _ args _)
= if not (null args || -- Not a function
unapplied_occ || -- Has an occ with no args at all
arg_occ || -- Occurs in arg position
length fvs > 2 -- Too many free variables
- )
+ )
then {-trace ("LLRec: " ++ show (length fvs))-} True
else False
isLiftableRec other_rhs = False
-rhsFreeVars :: PlainStgRhs -> IdSet
+rhsFreeVars :: StgRhs -> IdSet
rhsFreeVars (StgRhsClosure _ _ fvs _ _ _) = mkUniqSet fvs
rhsFreeVars other = panic "rhsFreeVars"
\end{code}
ones or mutually-recursive ones where not all are lambdas.
\begin{code}
-dontLiftRhs :: PlainStgRhs -> LiftM (PlainStgRhs, LiftInfo)
+dontLiftRhs :: StgRhs -> LiftM (StgRhs, LiftInfo)
dontLiftRhs rhs@(StgRhsCon cc v args) = returnLM (rhs, emptyLiftInfo)
-dontLiftRhs (StgRhsClosure cc bi fvs upd args body)
+dontLiftRhs (StgRhsClosure cc bi fvs upd args body)
= liftExpr body `thenLM` \ (body', body_info) ->
returnLM (StgRhsClosure cc bi fvs upd args body', body_info)
\end{code}
\begin{code}
mkScPieces :: IdSet -- Extra args for the supercombinator
- -> (Id, PlainStgRhs) -- The processed RHS and original Id
+ -> (Id, StgRhs) -- The processed RHS and original Id
-> LiftM ((Id,[Id]), -- Replace abstraction with this;
-- the set is its free vars
- (Id,PlainStgRhs)) -- Binding for supercombinator
+ (Id,StgRhs)) -- Binding for supercombinator
mkScPieces extra_arg_set (id, StgRhsClosure cc bi _ upd args body)
= ASSERT( n_args > 0 )
arity = n_args + length extra_args
-- Construct the supercombinator type
- type_of_original_id = getIdUniType id
- extra_arg_tys = map getIdUniType extra_args
+ type_of_original_id = idType id
+ extra_arg_tys = map idType extra_args
(tyvars, rest) = splitForalls type_of_original_id
sc_ty = mkForallTy tyvars (glueTyArgs extra_arg_tys rest)
\begin{code}
type LiftM a = LiftFlags
- -> SplitUniqSupply
+ -> UniqSupply
-> (IdEnv -- Domain = candidates for lifting
(Id, -- The supercombinator
- [Id]) -- Args to apply it to
+ [Id]) -- Args to apply it to
)
-> a
-- binding; Nothing == infinity
-runLM :: LiftFlags -> SplitUniqSupply -> LiftM a -> a
+runLM :: LiftFlags -> UniqSupply -> LiftM a -> a
runLM flags us m = m flags us nullIdEnv
thenLM :: LiftM a -> (a -> LiftM b) -> LiftM b
\end{code}
\begin{code}
-newSupercombinator :: UniType
+newSupercombinator :: Type
-> Int -- Arity
-> LiftM Id
`addIdArity` arity
-- ToDo: rm the addIdArity? Just let subsequent stg-saturation pass do it?
where
- uniq = getSUnique us
-
+ uniq = getUnique us
+
lookup :: Id -> LiftM (Id,[Id])
-lookup v ci us idenv
+lookup v ci us idenv
= case lookupIdEnv idenv v of
Just result -> result
Nothing -> (v, [])
getFinalFreeVars :: IdSet -> LiftM IdSet
-getFinalFreeVars free_vars ci us idenv
+getFinalFreeVars free_vars ci us idenv
= unionManyUniqSets (map munge_it (uniqSetToList free_vars))
where
munge_it :: Id -> IdSet -- Takes a free var and maps it to the "real"
munge_it id = case lookupIdEnv idenv id of
Just (_, args) -> mkUniqSet args
Nothing -> singletonUniqSet id
-
+
\end{code}
%************************************************************************
\begin{code}
-type LiftInfo = Bag PlainStgBinding -- Float to top
+type LiftInfo = Bag StgBinding -- Float to top
emptyLiftInfo = emptyBag
-
+
unionLiftInfo :: LiftInfo -> LiftInfo -> LiftInfo
unionLiftInfo binds1 binds2 = binds1 `unionBags` binds2
unionLiftInfos :: [LiftInfo] -> LiftInfo
unionLiftInfos infos = foldr unionLiftInfo emptyLiftInfo infos
-mkScInfo :: PlainStgBinding -> LiftInfo
+mkScInfo :: StgBinding -> LiftInfo
mkScInfo bind = unitBag bind
nonRecScBind :: LiftInfo -- From body of supercombinator
- -> (Id, PlainStgRhs) -- Supercombinator and its rhs
+ -> (Id, StgRhs) -- Supercombinator and its rhs
-> LiftInfo
nonRecScBind binds (sc_id,sc_rhs) = binds `snocBag` (StgNonRec sc_id sc_rhs)
-- So we flatten the whole lot into a single recursive group.
recScBind :: LiftInfo -- From body of supercombinator
- -> [(Id,PlainStgRhs)] -- Supercombinator rhs
+ -> [(Id,StgRhs)] -- Supercombinator rhs
-> LiftInfo
recScBind binds pairs = unitBag (co_rec_ify (StgRec pairs : bagToList binds))
-co_rec_ify :: [PlainStgBinding] -> PlainStgBinding
+co_rec_ify :: [StgBinding] -> StgBinding
co_rec_ify binds = StgRec (concat (map f binds))
where
f (StgNonRec id rhs) = [(id,rhs)]
f (StgRec pairs) = pairs
-getScBinds :: LiftInfo -> [PlainStgBinding]
+getScBinds :: LiftInfo -> [StgBinding]
getScBinds binds = bagToList binds
-looksLikeSATRhs [(f,StgRhsClosure _ _ _ _ ls _)] (StgApp (StgVarAtom f') args _)
+looksLikeSATRhs [(f,StgRhsClosure _ _ _ _ ls _)] (StgApp (StgVarArg f') args _)
= (f == f') && (length args == length ls)
looksLikeSATRhs _ _ = False
\end{code}
projects / ghc-hetmet.git / blobdiff