import Demand
import Var ( TyVar, setTyVarUnique )
import VarSet
-import PrimOp
import IdInfo
import Id
+import PrimOp
import UniqSupply
import Maybes
import ErrUtils
import CmdLineOpts
import Outputable
+import PprCore
\end{code}
------------------------------------------------------------------------------
-Overview
------------------------------------------------------------------------------
+-- ---------------------------------------------------------------------------
+-- Overview
+-- ---------------------------------------------------------------------------
Most of the contents of this pass used to be in CoreToStg. The
primary goals here are:
simplifier, but it's better done here. It does mean that f needs
to have its strictness info correct!.]
-2. Similarly, convert any unboxed let's into cases.
+2. Similarly, convert any unboxed lets into cases.
[I'm experimenting with leaving 'ok-for-speculation' rhss in let-form
right up to this point.]
mkBinds floats rhs `thenUs` \ new_rhs ->
returnUs (NonRec bndr new_rhs : new_bs)
- -- Keep all the floats inside...
- -- Some might be cases etc
- -- We might want to revisit this decision
+ -- Keep all the floats inside...
+ -- Some might be cases etc
+ -- We might want to revisit this decision
RecF prs -> returnUs (Rec prs : new_bs)
coreSatExprFloat (Case scrut bndr alts)
= coreSatExprFloat scrut `thenUs` \ (floats, scrut) ->
mapUs sat_alt alts `thenUs` \ alts ->
- mkCase scrut bndr alts `thenUs` \ expr ->
- returnUs (floats, expr)
+ returnUs (floats, Case scrut bndr alts)
where
sat_alt (con, bs, rhs)
= coreSatAnExpr rhs `thenUs` \ rhs ->
-- Now deal with the function
case head of
- Var fn_id
- -> maybeSaturate fn_id app depth ty `thenUs` \ app' ->
- returnUs (floats, app')
- _other
- -> returnUs (floats, app)
+ Var fn_id -> maybeSaturate fn_id app depth ty `thenUs` \ app' ->
+ returnUs (floats, app')
+
+ _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 applicaiton, 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
-- Building the saturated syntax
-- ---------------------------------------------------------------------------
+-- maybeSaturate deals with saturating primops and constructors
+-- The type is the type of the entire application
maybeSaturate :: Id -> CoreExpr -> Int -> Type -> UniqSM CoreExpr
- -- mkApp deals with saturating primops and constructors
- -- The type is the type of the entire application
maybeSaturate fn expr n_args ty
- = case idFlavour fn of
- PrimOpId (CCallOp ccall)
- -- Sigh...make a guaranteed unique name for a dynamic ccall
- -- Done here, not earlier, because it's a code-gen thing
- -> getUniqueUs `thenUs` \ uniq ->
- let
- flavour = PrimOpId (CCallOp (setCCallUnique ccall uniq))
- fn' = modifyIdInfo (`setFlavourInfo` flavour) fn
- in
- saturate fn' expr n_args ty
-
- PrimOpId op -> saturate fn expr n_args ty
- DataConId dc -> saturate fn expr n_args ty
+ = case idFlavour fn of
+ PrimOpId op -> saturate_it
+ DataConId dc -> saturate_it
other -> returnUs expr
-
-saturate :: Id -> CoreExpr -> Int -> Type -> UniqSM CoreExpr
- -- The type should be the type of (id args)
- -- The returned expression should also have this type
-saturate fn expr n_args ty
- = go excess_arity expr ty
where
fn_arity = idArity fn
excess_arity = fn_arity - n_args
+ saturate_it = getUs `thenUs` \ us ->
+ returnUs (etaExpand excess_arity us expr ty)
- go n expr ty
- | n == 0 -- Saturated, so nothing to do
- = returnUs expr
-
- | otherwise -- An unsaturated constructor or primop; eta expand it
- = case splitForAllTy_maybe ty of {
- Just (tv,ty') -> go n (App expr (Type (mkTyVarTy tv))) ty' `thenUs` \ expr' ->
- returnUs (Lam tv expr') ;
- Nothing ->
-
- case splitFunTy_maybe ty of {
- Just (arg_ty, res_ty)
- -> newVar arg_ty `thenUs` \ arg' ->
- go (n-1) (App expr (Var arg')) res_ty `thenUs` \ expr' ->
- returnUs (Lam arg' expr') ;
- Nothing ->
-
- case splitNewType_maybe ty of {
- Just ty' -> go n (mkCoerce ty' ty expr) ty' `thenUs` \ expr' ->
- returnUs (mkCoerce ty ty' expr') ;
-
- Nothing -> pprTrace "Bad saturate" ((ppr fn <+> ppr expr) $$ ppr ty)
- returnUs expr
- }}}
-
-
-
------------------------------------------------------------------------------
+-- ---------------------------------------------------------------------------
-- Eliminate Lam as a non-rhs (STG doesn't have such a thing)
------------------------------------------------------------------------------
+-- ---------------------------------------------------------------------------
deLam (Note n e)
= deLam e `thenUs` \ e ->
(bndrs, body) = collectBinders expr
eta expr@(App _ _)
- | n_remaining >= 0 &&
+ | ok_to_eta_reduce f &&
+ n_remaining >= 0 &&
and (zipWith ok bndrs last_args) &&
not (any (`elemVarSet` fvs_remaining) bndrs)
= Just remaining_expr
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)
+ = case idFlavour f of
+ PrimOpId op -> False
+ DataConId dc -> False
+ other -> True
+ ok_to_eta_reduce _ = False --safe. ToDo: generalise
+
eta (Let bind@(NonRec b r) body)
| not (any (`elemVarSet` fvs) bndrs)
= case eta body of
#endif
| isUnLiftedType bndr_rep_ty
= ASSERT( not (isUnboxedTupleType bndr_rep_ty) )
- mkCase rhs bndr [(DEFAULT, [], body)] `thenUs` \ expr' ->
- mkBinds floats expr'
+ mkBinds floats (Case rhs bndr [(DEFAULT, [], body)])
| is_whnf
= if is_strict then
| otherwise -- Not WHNF
= if is_strict then
-- Strict let with non-WHNF rhs
- mkCase rhs bndr [(DEFAULT, [], body)] `thenUs` \ expr' ->
- mkBinds floats expr'
+ mkBinds floats (Case rhs bndr [(DEFAULT, [], body)])
else
-- Lazy let with non-WHNF rhs, so keep the floats in the RHS
mkBinds floats rhs `thenUs` \ new_rhs ->
splitFloats [] = ([], [])
-- -----------------------------------------------------------------------------
--- Making case expressions
--- -----------------------------------------------------------------------------
-
-mkCase scrut bndr alts = returnUs (Case scrut bndr alts) -- ToDo
-
-{-
-mkCase scrut@(App _ _) bndr alts
- = let (f,args) = collectArgs scrut in
-
-
-
-mkCase scrut@(StgPrimApp ParOp _ _) bndr
- (StgPrimAlts tycon _ deflt@(StgBindDefault _))
- = returnUs (StgCase scrut bOGUS_LVs bOGUS_LVs bndr noSRT (StgPrimAlts tycon [] deflt))
-
-mkStgCase (StgPrimApp SeqOp [scrut] _) bndr
- (StgPrimAlts _ _ deflt@(StgBindDefault rhs))
- = mkStgCase scrut_expr new_bndr new_alts
- where
- new_alts | isUnLiftedType scrut_ty = WARN( True, text "mkStgCase" ) mkStgPrimAlts scrut_ty [] deflt
- | otherwise = mkStgAlgAlts scrut_ty [] deflt
- scrut_ty = stgArgType scrut
- new_bndr = setIdType bndr scrut_ty
- -- NB: SeqOp :: forall a. a -> Int#
- -- So bndr has type Int#
- -- But now we are going to scrutinise the SeqOp's argument directly,
- -- so we must change the type of the case binder to match that
- -- of the argument expression e.
-
- scrut_expr = case scrut of
- StgVarArg v -> StgApp v []
- -- Others should not happen because
- -- seq of a value should have disappeared
- StgLitArg l -> WARN( True, text "seq on" <+> ppr l ) StgLit l
-
-mkStgCase scrut bndr alts
- = deStgLam scrut `thenUs` \ scrut' ->
- -- It is (just) possible to get a lambda as a srutinee here
- -- Namely: fromDyn (toDyn ((+1)::Int->Int)) False)
- -- gives: case ...Bool == Int->Int... of
- -- True -> case coerce Bool (\x -> + 1 x) of
- -- True -> ...
- -- False -> ...
- -- False -> ...
- -- The True branch of the outer case will never happen, of course.
-
- returnUs (StgCase scrut' bOGUS_LVs bOGUS_LVs bndr noSRT alts)
--}
-
--------------------------------------------------------------------------
-- Demands
-- -----------------------------------------------------------------------------
projects / ghc-hetmet.git / blobdiff