+++ /dev/null
-%
-% (c) The University of Glasgow, 1994-2000
-%
-\section{Core pass to saturate constructors and PrimOps}
-
-\begin{code}
-module CorePrep (
- corePrepPgm, corePrepExpr
- ) where
-
-#include "HsVersions.h"
-
-import CoreUtils( exprType, exprIsHNF, etaExpand, exprArity, exprOkForSpeculation )
-import CoreFVs ( exprFreeVars )
-import CoreLint ( endPass )
-import CoreSyn
-import Type ( Type, applyTy, splitFunTy_maybe,
- isUnLiftedType, isUnboxedTupleType, seqType )
-import TyCon ( TyCon, tyConDataCons )
-import NewDemand ( Demand, isStrictDmd, lazyDmd, StrictSig(..), DmdType(..) )
-import Var ( Var, Id, setVarUnique )
-import VarSet
-import VarEnv
-import Id ( mkSysLocal, idType, idNewDemandInfo, idArity, setIdUnfolding, setIdType,
- isFCallId, isGlobalId,
- isLocalId, hasNoBinding, idNewStrictness,
- isPrimOpId_maybe
- )
-import DataCon ( isVanillaDataCon, dataConWorkId )
-import PrimOp ( PrimOp( DataToTagOp ) )
-import BasicTypes ( TopLevelFlag(..), isTopLevel, isNotTopLevel,
- RecFlag(..), isNonRec
- )
-import UniqSupply
-import Maybes
-import OrdList
-import ErrUtils
-import DynFlags
-import Util ( listLengthCmp )
-import Outputable
-\end{code}
-
--- ---------------------------------------------------------------------------
--- Overview
--- ---------------------------------------------------------------------------
-
-The goal of this pass is to prepare for code generation.
-
-1. Saturate constructor and primop applications.
-
-2. Convert to A-normal form:
-
- * Use case for strict arguments:
- f E ==> case E of x -> f x
- (where f is strict)
-
- * Use let for non-trivial lazy arguments
- f E ==> let x = E in f x
- (were f is lazy and x is non-trivial)
-
-3. Similarly, convert any unboxed lets into cases.
- [I'm experimenting with leaving 'ok-for-speculation'
- rhss in let-form right up to this point.]
-
-4. Ensure that lambdas only occur as the RHS of a binding
- (The code generator can't deal with anything else.)
-
-5. [Not any more; nuked Jun 2002] Do the seq/par munging.
-
-6. Clone all local Ids.
- This means that all such Ids are unique, rather than the
- weaker guarantee of no clashes which the simplifier provides.
- And that is what the code generator needs.
-
- We don't clone TyVars. The code gen doesn't need that,
- and doing so would be tiresome because then we'd need
- to substitute in types.
-
-
-7. Give each dynamic CCall occurrence a fresh unique; this is
- rather like the cloning step above.
-
-8. Inject bindings for the "implicit" Ids:
- * Constructor wrappers
- * Constructor workers
- * Record selectors
- We want curried definitions for all of these in case they
- aren't inlined by some caller.
-
-This is all done modulo type applications and abstractions, so that
-when type erasure is done for conversion to STG, we don't end up with
-any trivial or useless bindings.
-
-
-
--- -----------------------------------------------------------------------------
--- Top level stuff
--- -----------------------------------------------------------------------------
-
-\begin{code}
-corePrepPgm :: DynFlags -> [CoreBind] -> [TyCon] -> IO [CoreBind]
-corePrepPgm dflags binds data_tycons
- = do showPass dflags "CorePrep"
- us <- mkSplitUniqSupply 's'
-
- let implicit_binds = mkDataConWorkers data_tycons
- -- NB: we must feed mkImplicitBinds through corePrep too
- -- so that they are suitably cloned and eta-expanded
-
- binds_out = initUs_ us (
- corePrepTopBinds binds `thenUs` \ floats1 ->
- corePrepTopBinds implicit_binds `thenUs` \ floats2 ->
- returnUs (deFloatTop (floats1 `appendFloats` floats2))
- )
-
- endPass dflags "CorePrep" Opt_D_dump_prep binds_out
- return binds_out
-
-corePrepExpr :: DynFlags -> CoreExpr -> IO CoreExpr
-corePrepExpr dflags expr
- = do showPass dflags "CorePrep"
- us <- mkSplitUniqSupply 's'
- let new_expr = initUs_ us (corePrepAnExpr emptyCorePrepEnv expr)
- dumpIfSet_dyn dflags Opt_D_dump_prep "CorePrep"
- (ppr new_expr)
- return new_expr
-\end{code}
-
--- -----------------------------------------------------------------------------
--- Implicit bindings
--- -----------------------------------------------------------------------------
-
-Create any necessary "implicit" bindings for data con workers. We
-create the rather strange (non-recursive!) binding
-
- $wC = \x y -> $wC x y
-
-i.e. a curried constructor that allocates. This means that we can
-treat the worker for a constructor like any other function in the rest
-of the compiler. The point here is that CoreToStg will generate a
-StgConApp for the RHS, rather than a call to the worker (which would
-give a loop). As Lennart says: the ice is thin here, but it works.
-
-Hmm. Should we create bindings for dictionary constructors? They are
-always fully applied, and the bindings are just there to support
-partial applications. But it's easier to let them through.
-
-\begin{code}
-mkDataConWorkers data_tycons
- = [ NonRec id (Var id) -- The ice is thin here, but it works
- | tycon <- data_tycons, -- CorePrep will eta-expand it
- data_con <- tyConDataCons tycon,
- let id = dataConWorkId data_con ]
-\end{code}
-
-
-\begin{code}
--- ---------------------------------------------------------------------------
--- Dealing with bindings
--- ---------------------------------------------------------------------------
-
-data FloatingBind = FloatLet CoreBind
- | FloatCase Id CoreExpr Bool
- -- The bool indicates "ok-for-speculation"
-
-data Floats = Floats OkToSpec (OrdList FloatingBind)
-
--- Can we float these binds out of the rhs of a let? We cache this decision
--- to avoid having to recompute it in a non-linear way when there are
--- deeply nested lets.
-data OkToSpec
- = NotOkToSpec -- definitely not
- | OkToSpec -- yes
- | IfUnboxedOk -- only if floating an unboxed binding is ok
-
-emptyFloats :: Floats
-emptyFloats = Floats OkToSpec nilOL
-
-addFloat :: Floats -> FloatingBind -> Floats
-addFloat (Floats ok_to_spec floats) new_float
- = Floats (combine ok_to_spec (check new_float)) (floats `snocOL` new_float)
- where
- check (FloatLet _) = OkToSpec
- check (FloatCase _ _ ok_for_spec)
- | ok_for_spec = IfUnboxedOk
- | otherwise = NotOkToSpec
- -- The ok-for-speculation flag says that it's safe to
- -- float this Case out of a let, and thereby do it more eagerly
- -- We need the top-level flag because it's never ok to float
- -- an unboxed binding to the top level
-
-unitFloat :: FloatingBind -> Floats
-unitFloat = addFloat emptyFloats
-
-appendFloats :: Floats -> Floats -> Floats
-appendFloats (Floats spec1 floats1) (Floats spec2 floats2)
- = Floats (combine spec1 spec2) (floats1 `appOL` floats2)
-
-concatFloats :: [Floats] -> Floats
-concatFloats = foldr appendFloats emptyFloats
-
-combine NotOkToSpec _ = NotOkToSpec
-combine _ NotOkToSpec = NotOkToSpec
-combine IfUnboxedOk _ = IfUnboxedOk
-combine _ IfUnboxedOk = IfUnboxedOk
-combine _ _ = OkToSpec
-
-instance Outputable FloatingBind where
- ppr (FloatLet bind) = text "FloatLet" <+> ppr bind
- ppr (FloatCase b rhs spec) = text "FloatCase" <+> ppr b <+> ppr spec <+> equals <+> ppr rhs
-
-deFloatTop :: Floats -> [CoreBind]
--- For top level only; we don't expect any FloatCases
-deFloatTop (Floats _ floats)
- = foldrOL get [] floats
- where
- get (FloatLet b) bs = b:bs
- get b bs = pprPanic "corePrepPgm" (ppr b)
-
-allLazy :: TopLevelFlag -> RecFlag -> Floats -> Bool
-allLazy top_lvl is_rec (Floats ok_to_spec _)
- = case ok_to_spec of
- OkToSpec -> True
- NotOkToSpec -> False
- IfUnboxedOk -> isNotTopLevel top_lvl && isNonRec is_rec
-
--- ---------------------------------------------------------------------------
--- Bindings
--- ---------------------------------------------------------------------------
-
-corePrepTopBinds :: [CoreBind] -> UniqSM Floats
-corePrepTopBinds binds
- = go emptyCorePrepEnv binds
- where
- go env [] = returnUs emptyFloats
- go env (bind : binds) = corePrepTopBind env bind `thenUs` \ (env', bind') ->
- go env' binds `thenUs` \ binds' ->
- returnUs (bind' `appendFloats` binds')
-
--- NB: we do need to float out of top-level bindings
--- Consider x = length [True,False]
--- We want to get
--- s1 = False : []
--- s2 = True : s1
--- x = length s2
-
--- We return a *list* of bindings, because we may start with
--- x* = f (g y)
--- where x is demanded, in which case we want to finish with
--- a = g y
--- x* = f a
--- And then x will actually end up case-bound
---
--- What happens to the CafInfo on the floated bindings? By
--- default, all the CafInfos will be set to MayHaveCafRefs,
--- which is safe.
---
--- This might be pessimistic, because eg. s1 & s2
--- might not refer to any CAFs and the GC will end up doing
--- more traversal than is necessary, but it's still better
--- than not floating the bindings at all, because then
--- the GC would have to traverse the structure in the heap
--- instead. Given this, we decided not to try to get
--- the CafInfo on the floated bindings correct, because
--- it looks difficult.
-
---------------------------------
-corePrepTopBind :: CorePrepEnv -> CoreBind -> UniqSM (CorePrepEnv, Floats)
-corePrepTopBind env (NonRec bndr rhs)
- = cloneBndr env bndr `thenUs` \ (env', bndr') ->
- corePrepRhs TopLevel NonRecursive env (bndr, rhs) `thenUs` \ (floats, rhs') ->
- returnUs (env', addFloat floats (FloatLet (NonRec bndr' rhs')))
-
-corePrepTopBind env (Rec pairs) = corePrepRecPairs TopLevel env pairs
-
---------------------------------
-corePrepBind :: CorePrepEnv -> CoreBind -> UniqSM (CorePrepEnv, Floats)
- -- This one is used for *local* bindings
-corePrepBind env (NonRec bndr rhs)
- = etaExpandRhs bndr rhs `thenUs` \ rhs1 ->
- corePrepExprFloat env rhs1 `thenUs` \ (floats, rhs2) ->
- cloneBndr env bndr `thenUs` \ (_, bndr') ->
- mkLocalNonRec bndr' (bdrDem bndr) floats rhs2 `thenUs` \ (floats', bndr'') ->
- -- We want bndr'' in the envt, because it records
- -- the evaluated-ness of the binder
- returnUs (extendCorePrepEnv env bndr bndr'', floats')
-
-corePrepBind env (Rec pairs) = corePrepRecPairs NotTopLevel env pairs
-
---------------------------------
-corePrepRecPairs :: TopLevelFlag -> CorePrepEnv
- -> [(Id,CoreExpr)] -- Recursive bindings
- -> UniqSM (CorePrepEnv, Floats)
--- Used for all recursive bindings, top level and otherwise
-corePrepRecPairs lvl env pairs
- = cloneBndrs env (map fst pairs) `thenUs` \ (env', bndrs') ->
- mapAndUnzipUs (corePrepRhs lvl Recursive env') pairs `thenUs` \ (floats_s, rhss') ->
- returnUs (env', unitFloat (FloatLet (Rec (flatten (concatFloats floats_s) bndrs' rhss'))))
- where
- -- Flatten all the floats, and the currrent
- -- group into a single giant Rec
- flatten (Floats _ floats) bndrs rhss = foldrOL get (bndrs `zip` rhss) floats
-
- get (FloatLet (NonRec b r)) prs2 = (b,r) : prs2
- get (FloatLet (Rec prs1)) prs2 = prs1 ++ prs2
- get b prs2 = pprPanic "corePrepRecPairs" (ppr b)
-
---------------------------------
-corePrepRhs :: TopLevelFlag -> RecFlag
- -> CorePrepEnv -> (Id, CoreExpr)
- -> UniqSM (Floats, CoreExpr)
--- Used for top-level bindings, and local recursive bindings
-corePrepRhs top_lvl is_rec env (bndr, rhs)
- = etaExpandRhs bndr rhs `thenUs` \ rhs' ->
- corePrepExprFloat env rhs' `thenUs` \ floats_w_rhs ->
- floatRhs top_lvl is_rec bndr floats_w_rhs
-
-
--- ---------------------------------------------------------------------------
--- Making arguments atomic (function args & constructor args)
--- ---------------------------------------------------------------------------
-
--- This is where we arrange that a non-trivial argument is let-bound
-corePrepArg :: CorePrepEnv -> CoreArg -> RhsDemand
- -> UniqSM (Floats, CoreArg)
-corePrepArg env arg dem
- = corePrepExprFloat env arg `thenUs` \ (floats, arg') ->
- if exprIsTrivial arg'
- then returnUs (floats, arg')
- else newVar (exprType arg') `thenUs` \ v ->
- mkLocalNonRec v dem floats arg' `thenUs` \ (floats', v') ->
- returnUs (floats', Var v')
-
--- version that doesn't consider an scc annotation to be trivial.
-exprIsTrivial (Var v) = True
-exprIsTrivial (Type _) = True
-exprIsTrivial (Lit lit) = True
-exprIsTrivial (App e arg) = isTypeArg arg && exprIsTrivial e
-exprIsTrivial (Note (SCC _) e) = False
-exprIsTrivial (Note _ e) = exprIsTrivial e
-exprIsTrivial (Lam b body) | isTyVar b = exprIsTrivial body
-exprIsTrivial other = False
-
--- ---------------------------------------------------------------------------
--- Dealing with expressions
--- ---------------------------------------------------------------------------
-
-corePrepAnExpr :: CorePrepEnv -> CoreExpr -> UniqSM CoreExpr
-corePrepAnExpr env expr
- = corePrepExprFloat env expr `thenUs` \ (floats, expr) ->
- mkBinds floats expr
-
-
-corePrepExprFloat :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CoreExpr)
--- If
--- e ===> (bs, e')
--- then
--- e = let bs in e' (semantically, that is!)
---
--- For example
--- f (g x) ===> ([v = g x], f v)
-
-corePrepExprFloat env (Var v)
- = fiddleCCall v `thenUs` \ v1 ->
- let
- v2 = lookupCorePrepEnv env v1
- in
- maybeSaturate v2 (Var v2) 0 emptyFloats (idType v2)
-
-corePrepExprFloat env expr@(Type _)
- = returnUs (emptyFloats, expr)
-
-corePrepExprFloat env expr@(Lit lit)
- = returnUs (emptyFloats, expr)
-
-corePrepExprFloat env (Let bind body)
- = corePrepBind env bind `thenUs` \ (env', new_binds) ->
- corePrepExprFloat env' body `thenUs` \ (floats, new_body) ->
- returnUs (new_binds `appendFloats` floats, new_body)
-
-corePrepExprFloat env (Note n@(SCC _) expr)
- = corePrepAnExpr env expr `thenUs` \ expr1 ->
- deLamFloat expr1 `thenUs` \ (floats, expr2) ->
- returnUs (floats, Note n expr2)
-
-corePrepExprFloat env (Note other_note expr)
- = corePrepExprFloat env expr `thenUs` \ (floats, expr') ->
- returnUs (floats, Note other_note expr')
-
-corePrepExprFloat env expr@(Lam _ _)
- = cloneBndrs env bndrs `thenUs` \ (env', bndrs') ->
- corePrepAnExpr env' body `thenUs` \ body' ->
- returnUs (emptyFloats, mkLams bndrs' body')
- where
- (bndrs,body) = collectBinders expr
-
-corePrepExprFloat env (Case scrut bndr ty alts)
- = corePrepExprFloat env scrut `thenUs` \ (floats1, scrut1) ->
- deLamFloat scrut1 `thenUs` \ (floats2, scrut2) ->
- let
- bndr1 = bndr `setIdUnfolding` evaldUnfolding
- -- Record that the case binder is evaluated in the alternatives
- in
- cloneBndr env bndr1 `thenUs` \ (env', bndr2) ->
- mapUs (sat_alt env') alts `thenUs` \ alts' ->
- returnUs (floats1 `appendFloats` floats2 , Case scrut2 bndr2 ty alts')
- where
- sat_alt env (con, bs, rhs)
- = let
- env1 = setGadt env con
- in
- cloneBndrs env1 bs `thenUs` \ (env2, bs') ->
- corePrepAnExpr env2 rhs `thenUs` \ rhs1 ->
- deLam rhs1 `thenUs` \ rhs2 ->
- returnUs (con, bs', rhs2)
-
-corePrepExprFloat env expr@(App _ _)
- = collect_args expr 0 `thenUs` \ (app, (head,depth), ty, floats, ss) ->
- ASSERT(null ss) -- make sure we used all the strictness info
-
- -- Now deal with the function
- case head of
- Var fn_id -> maybeSaturate fn_id app depth floats ty
- _other -> returnUs (floats, app)
-
- where
-
- -- Deconstruct and rebuild the application, floating any non-atomic
- -- arguments to the outside. We collect the type of the expression,
- -- the head of the application, and the number of actual value arguments,
- -- all of which are used to possibly saturate this application if it
- -- has a constructor or primop at the head.
-
- collect_args
- :: CoreExpr
- -> Int -- current app depth
- -> UniqSM (CoreExpr, -- the rebuilt expression
- (CoreExpr,Int), -- the head of the application,
- -- and no. of args it was applied to
- Type, -- type of the whole expr
- Floats, -- any floats we pulled out
- [Demand]) -- remaining argument demands
-
- collect_args (App fun arg@(Type arg_ty)) depth
- = collect_args fun depth `thenUs` \ (fun',hd,fun_ty,floats,ss) ->
- returnUs (App fun' arg, hd, applyTy fun_ty arg_ty, floats, ss)
-
- collect_args (App fun arg) depth
- = collect_args fun (depth+1) `thenUs` \ (fun',hd,fun_ty,floats,ss) ->
- let
- (ss1, ss_rest) = case ss of
- (ss1:ss_rest) -> (ss1, ss_rest)
- [] -> (lazyDmd, [])
- (arg_ty, res_ty) = expectJust "corePrepExprFloat:collect_args" $
- splitFunTy_maybe fun_ty
- in
- corePrepArg env arg (mkDemTy ss1 arg_ty) `thenUs` \ (fs, arg') ->
- returnUs (App fun' arg', hd, res_ty, fs `appendFloats` floats, ss_rest)
-
- collect_args (Var v) depth
- = fiddleCCall v `thenUs` \ v1 ->
- let
- v2 = lookupCorePrepEnv env v1
- in
- returnUs (Var v2, (Var v2, depth), idType v2, emptyFloats, stricts)
- where
- stricts = case idNewStrictness v of
- StrictSig (DmdType _ demands _)
- | listLengthCmp demands depth /= GT -> demands
- -- length demands <= depth
- | otherwise -> []
- -- If depth < length demands, then we have too few args to
- -- satisfy strictness info so we have to ignore all the
- -- strictness info, e.g. + (error "urk")
- -- Here, we can't evaluate the arg strictly, because this
- -- partial application might be seq'd
-
-
- collect_args (Note (Coerce ty1 ty2) fun) depth
- = collect_args fun depth `thenUs` \ (fun', hd, fun_ty, floats, ss) ->
- returnUs (Note (Coerce ty1 ty2) fun', hd, ty1, floats, ss)
-
- collect_args (Note note fun) depth
- | ignore_note note -- Drop these notes altogether
- -- They aren't used by the code generator
- = collect_args fun depth `thenUs` \ (fun', hd, fun_ty, floats, ss) ->
- returnUs (fun', hd, fun_ty, floats, ss)
-
- -- N-variable fun, better let-bind it
- -- ToDo: perhaps we can case-bind rather than let-bind this closure,
- -- since it is sure to be evaluated.
- collect_args fun depth
- = corePrepExprFloat env fun `thenUs` \ (fun_floats, fun') ->
- newVar ty `thenUs` \ fn_id ->
- mkLocalNonRec fn_id onceDem fun_floats fun' `thenUs` \ (floats, fn_id') ->
- returnUs (Var fn_id', (Var fn_id', depth), ty, floats, [])
- where
- ty = exprType fun
-
- ignore_note (CoreNote _) = True
- ignore_note InlineCall = True
- ignore_note InlineMe = True
- ignore_note _other = False
- -- We don't ignore SCCs, since they require some code generation
-
-------------------------------------------------------------------------------
--- Building the saturated syntax
--- ---------------------------------------------------------------------------
-
--- maybeSaturate deals with saturating primops and constructors
--- The type is the type of the entire application
-maybeSaturate :: Id -> CoreExpr -> Int -> Floats -> Type -> UniqSM (Floats, CoreExpr)
-maybeSaturate fn expr n_args floats ty
- | Just DataToTagOp <- isPrimOpId_maybe fn -- DataToTag must have an evaluated arg
- -- A gruesome special case
- = saturate_it `thenUs` \ sat_expr ->
-
- -- OK, now ensure that the arg is evaluated.
- -- But (sigh) take into account the lambdas we've now introduced
- let
- (eta_bndrs, eta_body) = collectBinders sat_expr
- in
- eval_data2tag_arg eta_body `thenUs` \ (eta_floats, eta_body') ->
- if null eta_bndrs then
- returnUs (floats `appendFloats` eta_floats, eta_body')
- else
- mkBinds eta_floats eta_body' `thenUs` \ eta_body'' ->
- returnUs (floats, mkLams eta_bndrs eta_body'')
-
- | hasNoBinding fn = saturate_it `thenUs` \ sat_expr ->
- returnUs (floats, sat_expr)
-
- | otherwise = returnUs (floats, expr)
-
- where
- fn_arity = idArity fn
- excess_arity = fn_arity - n_args
-
- saturate_it :: UniqSM CoreExpr
- saturate_it | excess_arity == 0 = returnUs expr
- | otherwise = getUniquesUs `thenUs` \ us ->
- returnUs (etaExpand excess_arity us expr ty)
-
- -- Ensure that the argument of DataToTagOp is evaluated
- eval_data2tag_arg :: CoreExpr -> UniqSM (Floats, CoreExpr)
- eval_data2tag_arg app@(fun `App` arg)
- | exprIsHNF arg -- Includes nullary constructors
- = returnUs (emptyFloats, app) -- The arg is evaluated
- | otherwise -- Arg not evaluated, so evaluate it
- = newVar (exprType arg) `thenUs` \ arg_id ->
- let
- arg_id1 = setIdUnfolding arg_id evaldUnfolding
- in
- returnUs (unitFloat (FloatCase arg_id1 arg False ),
- fun `App` Var arg_id1)
-
- eval_data2tag_arg (Note note app) -- Scc notes can appear
- = eval_data2tag_arg app `thenUs` \ (floats, app') ->
- returnUs (floats, Note note app')
-
- eval_data2tag_arg other -- Should not happen
- = pprPanic "eval_data2tag" (ppr other)
-
-
--- ---------------------------------------------------------------------------
--- Precipitating the floating bindings
--- ---------------------------------------------------------------------------
-
-floatRhs :: TopLevelFlag -> RecFlag
- -> Id
- -> (Floats, CoreExpr) -- Rhs: let binds in body
- -> UniqSM (Floats, -- Floats out of this bind
- CoreExpr) -- Final Rhs
-
-floatRhs top_lvl is_rec bndr (floats, rhs)
- | isTopLevel top_lvl || exprIsHNF rhs, -- Float to expose value or
- allLazy top_lvl is_rec floats -- at top level
- = -- Why the test for allLazy?
- -- v = f (x `divInt#` y)
- -- we don't want to float the case, even if f has arity 2,
- -- because floating the case would make it evaluated too early
- returnUs (floats, rhs)
-
- | otherwise
- -- Don't float; the RHS isn't a value
- = mkBinds floats rhs `thenUs` \ rhs' ->
- returnUs (emptyFloats, rhs')
-
--- mkLocalNonRec is used only for *nested*, *non-recursive* bindings
-mkLocalNonRec :: Id -> RhsDemand -- Lhs: id with demand
- -> Floats -> CoreExpr -- Rhs: let binds in body
- -> UniqSM (Floats, Id) -- The new Id may have an evaldUnfolding,
- -- to record that it's been evaluated
-
-mkLocalNonRec bndr dem floats rhs
- | isUnLiftedType (idType bndr)
- -- If this is an unlifted binding, we always make a case for it.
- = ASSERT( not (isUnboxedTupleType (idType bndr)) )
- let
- float = FloatCase bndr rhs (exprOkForSpeculation rhs)
- in
- returnUs (addFloat floats float, evald_bndr)
-
- | isStrict dem
- -- It's a strict let so we definitely float all the bindings
- = let -- Don't make a case for a value binding,
- -- even if it's strict. Otherwise we get
- -- case (\x -> e) of ...!
- float | exprIsHNF rhs = FloatLet (NonRec bndr rhs)
- | otherwise = FloatCase bndr rhs (exprOkForSpeculation rhs)
- in
- returnUs (addFloat floats float, evald_bndr)
-
- | otherwise
- = floatRhs NotTopLevel NonRecursive bndr (floats, rhs) `thenUs` \ (floats', rhs') ->
- returnUs (addFloat floats' (FloatLet (NonRec bndr rhs')),
- if exprIsHNF rhs' then evald_bndr else bndr)
-
- where
- evald_bndr = bndr `setIdUnfolding` evaldUnfolding
- -- Record if the binder is evaluated
-
-
-mkBinds :: Floats -> CoreExpr -> UniqSM CoreExpr
-mkBinds (Floats _ binds) body
- | isNilOL binds = returnUs body
- | otherwise = deLam body `thenUs` \ body' ->
- -- Lambdas are not allowed as the body of a 'let'
- returnUs (foldrOL mk_bind body' binds)
- where
- mk_bind (FloatCase bndr rhs _) body = Case rhs bndr (exprType body) [(DEFAULT, [], body)]
- mk_bind (FloatLet bind) body = Let bind body
-
-etaExpandRhs bndr rhs
- = -- Eta expand to match the arity claimed by the binder
- -- Remember, after CorePrep we must not change arity
- --
- -- Eta expansion might not have happened already,
- -- because it is done by the simplifier only when
- -- there at least one lambda already.
- --
- -- NB1:we could refrain when the RHS is trivial (which can happen
- -- for exported things). This would reduce the amount of code
- -- generated (a little) and make things a little words for
- -- code compiled without -O. The case in point is data constructor
- -- wrappers.
- --
- -- NB2: we have to be careful that the result of etaExpand doesn't
- -- invalidate any of the assumptions that CorePrep is attempting
- -- to establish. One possible cause is eta expanding inside of
- -- an SCC note - we're now careful in etaExpand to make sure the
- -- SCC is pushed inside any new lambdas that are generated.
- --
- -- NB3: It's important to do eta expansion, and *then* ANF-ising
- -- f = /\a -> g (h 3) -- h has arity 2
- -- If we ANF first we get
- -- f = /\a -> let s = h 3 in g s
- -- and now eta expansion gives
- -- f = /\a -> \ y -> (let s = h 3 in g s) y
- -- which is horrible.
- -- Eta expanding first gives
- -- f = /\a -> \y -> let s = h 3 in g s y
- --
- getUniquesUs `thenUs` \ us ->
- returnUs (etaExpand arity us rhs (idType bndr))
- where
- -- For a GlobalId, take the Arity from the Id.
- -- It was set in CoreTidy and must not change
- -- For all others, just expand at will
- arity | isGlobalId bndr = idArity bndr
- | otherwise = exprArity rhs
-
--- ---------------------------------------------------------------------------
--- Eliminate Lam as a non-rhs (STG doesn't have such a thing)
--- We arrange that they only show up as the RHS of a let(rec)
--- ---------------------------------------------------------------------------
-
-deLam :: CoreExpr -> UniqSM CoreExpr
-deLam expr =
- deLamFloat expr `thenUs` \ (floats, expr) ->
- mkBinds floats expr
-
-
-deLamFloat :: CoreExpr -> UniqSM (Floats, CoreExpr)
--- Remove top level lambdas by let-bindinig
-
-deLamFloat (Note n expr)
- = -- You can get things like
- -- case e of { p -> coerce t (\s -> ...) }
- deLamFloat expr `thenUs` \ (floats, expr') ->
- returnUs (floats, Note n expr')
-
-deLamFloat expr
- | null bndrs = returnUs (emptyFloats, expr)
- | otherwise
- = case tryEta bndrs body of
- Just no_lam_result -> returnUs (emptyFloats, no_lam_result)
- Nothing -> newVar (exprType expr) `thenUs` \ fn ->
- returnUs (unitFloat (FloatLet (NonRec fn expr)),
- Var fn)
- where
- (bndrs,body) = collectBinders expr
-
--- Why try eta reduction? Hasn't the simplifier already done eta?
--- But the simplifier only eta reduces if that leaves something
--- trivial (like f, or f Int). But for deLam it would be enough to
--- get to a partial application, like (map f).
-
-tryEta bndrs expr@(App _ _)
- | ok_to_eta_reduce f &&
- n_remaining >= 0 &&
- and (zipWith ok bndrs last_args) &&
- not (any (`elemVarSet` fvs_remaining) bndrs)
- = Just remaining_expr
- where
- (f, args) = collectArgs expr
- remaining_expr = mkApps f remaining_args
- fvs_remaining = exprFreeVars remaining_expr
- (remaining_args, last_args) = splitAt n_remaining args
- n_remaining = length args - length bndrs
-
- ok bndr (Var arg) = bndr == arg
- ok bndr other = False
-
- -- we can't eta reduce something which must be saturated.
- ok_to_eta_reduce (Var f) = not (hasNoBinding f)
- ok_to_eta_reduce _ = False --safe. ToDo: generalise
-
-tryEta bndrs (Let bind@(NonRec b r) body)
- | not (any (`elemVarSet` fvs) bndrs)
- = case tryEta bndrs body of
- Just e -> Just (Let bind e)
- Nothing -> Nothing
- where
- fvs = exprFreeVars r
-
-tryEta bndrs _ = Nothing
-\end{code}
-
-
--- -----------------------------------------------------------------------------
--- Demands
--- -----------------------------------------------------------------------------
-
-\begin{code}
-data RhsDemand
- = RhsDemand { isStrict :: Bool, -- True => used at least once
- isOnceDem :: Bool -- True => used at most once
- }
-
-mkDem :: Demand -> Bool -> RhsDemand
-mkDem strict once = RhsDemand (isStrictDmd strict) once
-
-mkDemTy :: Demand -> Type -> RhsDemand
-mkDemTy strict ty = RhsDemand (isStrictDmd strict)
- False {- For now -}
-
-bdrDem :: Id -> RhsDemand
-bdrDem id = mkDem (idNewDemandInfo id)
- False {- For now -}
-
--- safeDem :: RhsDemand
--- safeDem = RhsDemand False False -- always safe to use this
-
-onceDem :: RhsDemand
-onceDem = RhsDemand False True -- used at most once
-\end{code}
-
-
-
-
-%************************************************************************
-%* *
-\subsection{Cloning}
-%* *
-%************************************************************************
-
-\begin{code}
--- ---------------------------------------------------------------------------
--- The environment
--- ---------------------------------------------------------------------------
-
-data CorePrepEnv = CPE (IdEnv Id) -- Clone local Ids
- Bool -- True <=> inside a GADT case; see Note [GADT]
-
--- Note [GADT]
---
--- Be careful with cloning inside GADTs. For example,
--- /\a. \f::a. \x::T a. case x of { T -> f True; ... }
--- The case on x may refine the type of f to be a function type.
--- Without this type refinement, exprType (f True) may simply fail,
--- which is bad.
---
--- Solution: remember when we are inside a potentially-type-refining case,
--- and in that situation use the type from the old occurrence
--- when looking up occurrences
-
-emptyCorePrepEnv :: CorePrepEnv
-emptyCorePrepEnv = CPE emptyVarEnv False
-
-extendCorePrepEnv :: CorePrepEnv -> Id -> Id -> CorePrepEnv
-extendCorePrepEnv (CPE env gadt) id id' = CPE (extendVarEnv env id id') gadt
-
-lookupCorePrepEnv :: CorePrepEnv -> Id -> Id
--- See Note [GADT] above
-lookupCorePrepEnv (CPE env gadt) id
- = case lookupVarEnv env id of
- Nothing -> id
- Just id' | gadt -> setIdType id' (idType id)
- | otherwise -> id'
-
-setGadt :: CorePrepEnv -> AltCon -> CorePrepEnv
-setGadt env@(CPE id_env _) (DataAlt data_con) | not (isVanillaDataCon data_con) = CPE id_env True
-setGadt env other = env
-
-
-------------------------------------------------------------------------------
--- Cloning binders
--- ---------------------------------------------------------------------------
-
-cloneBndrs :: CorePrepEnv -> [Var] -> UniqSM (CorePrepEnv, [Var])
-cloneBndrs env bs = mapAccumLUs cloneBndr env bs
-
-cloneBndr :: CorePrepEnv -> Var -> UniqSM (CorePrepEnv, Var)
-cloneBndr env bndr
- | isLocalId bndr
- = getUniqueUs `thenUs` \ uniq ->
- let
- bndr' = setVarUnique bndr uniq
- in
- returnUs (extendCorePrepEnv env bndr bndr', bndr')
-
- | otherwise -- Top level things, which we don't want
- -- to clone, have become GlobalIds by now
- -- And we don't clone tyvars
- = returnUs (env, bndr)
-
-
-------------------------------------------------------------------------------
--- Cloning ccall Ids; each must have a unique name,
--- to give the code generator a handle to hang it on
--- ---------------------------------------------------------------------------
-
-fiddleCCall :: Id -> UniqSM Id
-fiddleCCall id
- | isFCallId id = getUniqueUs `thenUs` \ uniq ->
- returnUs (id `setVarUnique` uniq)
- | otherwise = returnUs id
-
-------------------------------------------------------------------------------
--- Generating new binders
--- ---------------------------------------------------------------------------
-
-newVar :: Type -> UniqSM Id
-newVar ty
- = seqType ty `seq`
- getUniqueUs `thenUs` \ uniq ->
- returnUs (mkSysLocal FSLIT("sat") uniq ty)
-\end{code}
projects / ghc-hetmet.git / blobdiff