import CoreUtils ( exprType )
import SimplUtils ( findDefault )
import CostCentre ( noCCS )
-import Id ( Id, mkSysLocal, idType, idStrictness, idUnique, isExportedId, mkVanillaId,
- externallyVisibleId, setIdUnique, idName,
- idDemandInfo, idArity, setIdType, idFlavour
+import Id ( Id, mkSysLocal, idType, idStrictness, isExportedId,
+ mkVanillaId, idName, idDemandInfo, idArity, setIdType,
+ idFlavour
)
-import Var ( Var, varType, modifyIdInfo )
-import IdInfo ( setDemandInfo, StrictnessInfo(..), IdFlavour(..) )
-import UsageSPUtils ( primOpUsgTys )
-import DataCon ( DataCon, dataConName, isDynDataCon, dataConWrapId )
-import Demand ( Demand, isStrict, wwStrict, wwLazy )
-import Name ( Name, nameModule, isLocallyDefinedName, setNameUnique )
-import Module ( isDynamicModule )
-import Literal ( Literal(..) )
+import IdInfo ( StrictnessInfo(..), IdFlavour(..) )
+import DataCon ( dataConWrapId, dataConTyCon )
+import TyCon ( isAlgTyCon )
+import Demand ( Demand, isStrict, wwLazy )
+import Name ( setNameUnique )
import VarEnv
-import PrimOp ( PrimOp(..), CCall(..), CCallTarget(..), primOpUsg )
+import PrimOp ( PrimOp(..), setCCallUnique )
import Type ( isUnLiftedType, isUnboxedTupleType, Type, splitFunTy_maybe,
- UsageAnn(..), tyUsg, applyTy, mkUsgTy, repType, seqType,
- splitRepFunTys, mkFunTys
+ applyTy, repType, seqType, splitTyConApp_maybe, splitTyConApp,
+ splitRepFunTys, mkFunTys,
+ uaUTy, usOnce, usMany, isTyVarTy
)
-import TysPrim ( intPrimTy )
import UniqSupply -- all of it, really
-import Util ( lengthExceeds )
-import BasicTypes ( TopLevelFlag(..), isNotTopLevel, Arity )
-import CmdLineOpts ( opt_D_verbose_stg2stg, opt_UsageSPOn )
+import BasicTypes ( TopLevelFlag(..), isNotTopLevel )
import UniqSet ( emptyUniqSet )
import Maybes
import Outputable
#ifdef USMANY
opt_UsageSPOn && -- can't expect annotations if -fusagesp is off
#endif
- case tyUsg ty of
- UsOnce -> True
- UsMany -> False
- UsVar uv -> pprPanic "CoreToStg: unexpected uvar annot:" (ppr uv)
+ once
+ where
+ u = uaUTy ty
+ once | u == usOnce = True
+ | u == usMany = False
+ | isTyVarTy u = False -- if unknown at compile-time, is Top ie usMany
bdrDem :: Id -> RhsDemand
bdrDem id = mkDem (idDemandInfo id) (isOnceTy (idType id))
\begin{code}
bOGUS_LVs :: StgLiveVars
-bOGUS_LVs | opt_D_verbose_stg2stg = emptyUniqSet
- | otherwise =panic "bOGUS_LVs"
+bOGUS_LVs = emptyUniqSet
bOGUS_FVs :: [Id]
-bOGUS_FVs | opt_D_verbose_stg2stg = []
- | otherwise = panic "bOGUS_FVs"
+bOGUS_FVs = []
\end{code}
\begin{code}
then be run at load time to fix up static closures.
-}
exprToRhs dem toplev (StgConApp con args)
- | isNotTopLevel toplev ||
- (not is_dynamic &&
- all (not . isLitLitArg) args)
+ | isNotTopLevel toplev || not (isDllConApp con args)
+ -- isDllConApp checks for LitLit args too
= StgRhsCon noCCS con args
- where
- is_dynamic = isDynDataCon con || any (isDynArg) args
-exprToRhs dem _ expr
+exprToRhs dem toplev expr
= upd `seq`
StgRhsClosure noCCS -- No cost centre (ToDo?)
stgArgOcc -- safe
[]
expr
where
- upd = if isOnceDem dem then SingleEntry else Updatable
- -- HA! Paydirt for "dem"
+ upd = if isOnceDem dem
+ then (if isNotTopLevel toplev
+ then SingleEntry -- HA! Paydirt for "dem"
+ else
+#ifdef DEBUG
+ trace "WARNING: SE CAFs unsupported, forcing UPD instead" $
+#endif
+ Updatable)
+ else Updatable
+ -- For now we forbid SingleEntry CAFs; they tickle the
+ -- ASSERT in rts/Storage.c line 215 at newCAF() re mut_link,
+ -- and I don't understand why. There's only one SE_CAF (well,
+ -- only one that tickled a great gaping bug in an earlier attempt
+ -- at ClosureInfo.getEntryConvention) in the whole of nofib,
+ -- specifically Main.lvl6 in spectral/cryptarithm2.
+ -- So no great loss. KSW 2000-07.
\end{code}
(binders, body) = collectBinders expr
id_binders = filter isId binders
in
- if null id_binders then -- It was all type/usage binders; tossed
+ if null id_binders then -- It was all type binders; tossed
coreExprToStgFloat env body
else
-- At least some value binders
collect_args (Note (Coerce ty _) e) = let (the_fun,ads,_,ss) = collect_args e
in (the_fun,ads,ty,ss)
collect_args (Note InlineCall e) = collect_args e
- collect_args (Note (TermUsg _) e) = collect_args e
collect_args (App fun (Type tyarg)) = let (the_fun,ads,fun_ty,ss) = collect_args fun
in (the_fun,ads,applyTy fun_ty tyarg,ss)
= coreExprToStgFloat env scrut `thenUs` \ (binds, scrut') ->
newLocalId NotTopLevel env bndr `thenUs` \ (env', bndr') ->
alts_to_stg env' (findDefault alts) `thenUs` \ alts' ->
- returnUs (binds, mkStgCase scrut' bndr' alts')
+ mkStgCase scrut' bndr' alts' `thenUs` \ expr' ->
+ returnUs (binds, expr')
where
scrut_ty = idType bndr
prim_case = isUnLiftedType scrut_ty && not (isUnboxedTupleType scrut_ty)
default_to_stg env (Just rhs)
= coreExprToStg env rhs `thenUs` \ stg_rhs ->
returnUs (StgBindDefault stg_rhs)
- -- The binder is used for prim cases and not otherwise
- -- (hack for old code gen)
\end{code}
%************************************************************************
\begin{code}
-mkStgAlgAlts ty alts deflt = seqType ty `seq` StgAlgAlts ty alts deflt
-mkStgPrimAlts ty alts deflt = seqType ty `seq` StgPrimAlts ty alts deflt
-mkStgLam ty bndrs body = seqType ty `seq` StgLam ty bndrs body
+-- There are two things going on in mkStgAlgAlts
+-- a) We pull out the type constructor for the case, from the data
+-- constructor, if there is one. See notes with the StgAlgAlts data type
+-- b) We force the type constructor to avoid space leaks
+
+mkStgAlgAlts ty alts deflt
+ = case alts of
+ -- Get the tycon from the data con
+ (dc, _, _, _):_ -> StgAlgAlts (Just (dataConTyCon dc)) alts deflt
+
+ -- Otherwise just do your best
+ [] -> case splitTyConApp_maybe (repType ty) of
+ Just (tc,_) | isAlgTyCon tc -> StgAlgAlts (Just tc) alts deflt
+ other -> StgAlgAlts Nothing alts deflt
+
+mkStgPrimAlts ty alts deflt
+ = case splitTyConApp ty of
+ (tc,_) -> StgPrimAlts tc alts deflt
+
+mkStgLam ty bndrs body = seqType ty `seq` StgLam ty bndrs body
mkStgApp :: StgEnv -> Id -> [StgArg] -> Type -> UniqSM StgExpr
-- The type is the type of the entire application
-> saturate fn_alias args ty $ \ args' ty' ->
returnUs (StgConApp dc args')
- PrimOpId (CCallOp (CCall (DynamicTarget _) a b c))
+ PrimOpId (CCallOp ccall)
-- Sigh...make a guaranteed unique name for a dynamic ccall
+ -- Done here, not earlier, because it's a code-gen thing
-> saturate fn_alias args ty $ \ args' ty' ->
- getUniqueUs `thenUs` \ u ->
- returnUs (StgPrimApp (CCallOp (CCall (DynamicTarget u) a b c)) args' ty')
+ getUniqueUs `thenUs` \ uniq ->
+ let ccall' = setCCallUnique ccall uniq in
+ returnUs (StgPrimApp (CCallOp ccall') args' ty')
+
PrimOpId op
-> saturate fn_alias args ty $ \ args' ty' ->
#endif
| isUnLiftedType bndr_rep_ty -- Use a case/PrimAlts
= ASSERT( not (isUnboxedTupleType bndr_rep_ty) )
- mkStgBinds floats $
- mkStgCase rhs bndr (StgPrimAlts bndr_rep_ty [] (StgBindDefault body))
+ mkStgCase rhs bndr (mkStgPrimAlts bndr_rep_ty [] (StgBindDefault body)) `thenUs` \ expr' ->
+ mkStgBinds floats expr'
| is_whnf
= if is_strict then
| otherwise -- Not WHNF
= if is_strict then
-- Strict let with non-WHNF rhs
- mkStgBinds floats $
- mkStgCase rhs bndr (StgAlgAlts bndr_rep_ty [] (StgBindDefault body))
+ mkStgCase rhs bndr (mkStgAlgAlts bndr_rep_ty [] (StgBindDefault body)) `thenUs` \ expr' ->
+ mkStgBinds floats expr'
else
-- Lazy let with non-WHNF rhs, so keep the floats in the RHS
mkStgBinds floats rhs `thenUs` \ new_rhs ->
\begin{code}
-- Discard alernatives in case (par# ..) of
mkStgCase scrut@(StgPrimApp ParOp _ _) bndr
- (StgPrimAlts ty _ deflt@(StgBindDefault _))
- = StgCase scrut bOGUS_LVs bOGUS_LVs bndr noSRT (StgPrimAlts ty [] deflt)
+ (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 (StgAlgAlts scrut_ty [] (StgBindDefault rhs))
+ = mkStgCase scrut_expr new_bndr new_alts
where
- new_alts | isUnLiftedType scrut_ty = WARN( True, text "mkStgCase" ) StgPrimAlts scrut_ty [] deflt
- | otherwise = StgAlgAlts scrut_ty [] deflt
+ 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#
StgLitArg l -> WARN( True, text "seq on" <+> ppr l ) StgLit l
mkStgCase scrut bndr alts
- = ASSERT( case scrut of { StgLam _ _ _ -> False; other -> True } )
- -- We should never find
- -- case (\x->e) of { ... }
- -- The simplifier eliminates such things
- StgCase scrut bOGUS_LVs bOGUS_LVs bndr noSRT 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)
\end{code}
projects / ghc-hetmet.git / blobdiff