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 )
+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,
+ UsageAnn(..), tyUsg, applyTy, repType, seqType,
splitRepFunTys, mkFunTys
)
-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
\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
= upd `seq`
= 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)
-> 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' ->
Just fn' -> fn'
saturate :: Id -> [StgArg] -> Type -> ([StgArg] -> Type -> UniqSM StgExpr) -> UniqSM StgExpr
+ -- The type should be the type of (id args)
saturate fn args ty thing_inside
| excess_arity == 0 -- Saturated, so nothing to do
= thing_inside args ty
| otherwise -- An unsaturated constructor or primop; eta expand it
- = ASSERT2( excess_arity > 0 && excess_arity <= length extra_arg_tys,
- ppr fn <+> ppr args <+> ppr excess_arity )
+ = ASSERT2( excess_arity > 0 && excess_arity <= length arg_tys,
+ ppr fn <+> ppr args <+> ppr excess_arity <+> parens (ppr ty) <+> ppr arg_tys )
mapUs newStgVar extra_arg_tys `thenUs` \ arg_vars ->
thing_inside (args ++ map StgVarArg arg_vars) final_res_ty `thenUs` \ body ->
returnUs (StgLam ty arg_vars body)
#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 (StgPrimAlts 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 (StgAlgAlts 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 ->
-- 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)
+ = returnUs (StgCase scrut bOGUS_LVs bOGUS_LVs bndr noSRT (StgPrimAlts ty [] 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
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}