import IdInfo ( vanillaIdInfo )
import DataCon ( splitProductType_maybe, splitProductType )
import NewDemand ( Demand(..), DmdResult(..), Demands(..) )
-import MkId ( realWorldPrimId, voidArgId, eRROR_CSTRING_ID )
+import MkId ( realWorldPrimId, voidArgId, mkRuntimeErrorApp, rUNTIME_ERROR_ID )
import TysWiredIn ( tupleCon )
import Type ( Type, isUnLiftedType, mkFunTys,
- splitForAllTys, splitFunTys, splitNewType_maybe, isAlgType
+ splitForAllTys, splitFunTys, splitRecNewType_maybe, isAlgType
)
-import Literal ( Literal(MachStr) )
import BasicTypes ( Boxity(..) )
import Var ( Var, isId )
import UniqSupply ( returnUs, thenUs, getUniquesUs, UniqSM )
-import Util ( zipWithEqual )
+import Util ( zipWithEqual, notNull )
import Outputable
import List ( zipWith4 )
\end{code}
Type) -- Type of wrapper body
mkWWargs fun_ty demands one_shots
- | Just rep_ty <- splitNewType_maybe fun_ty
+ | Just rep_ty <- splitRecNewType_maybe fun_ty
-- The newtype case is for when the function has
-- a recursive newtype after the arrow (rare)
-- We check for arity >= 0 to avoid looping in the case
work_fn_args . Note (Coerce rep_ty fun_ty),
res_ty)
- | not (null demands)
+ | notNull demands
= getUniquesUs `thenUs` \ wrap_uniqs ->
let
- (tyvars, tau) = splitForAllTys fun_ty
- (arg_tys, body_ty) = splitFunTys tau
+ (tyvars, tau) = splitForAllTys fun_ty
+ (arg_tys, body_ty) = splitFunTys tau
n_demands = length demands
n_arg_tys = length arg_tys
val_args = zipWith4 mk_wrap_arg wrap_uniqs arg_tys demands one_shots
wrap_args = tyvars ++ val_args
in
-{- ASSERT( not (null tyvars) || not (null arg_tys) ) -}
+{- ASSERT( notNull tyvars || notNull arg_tys ) -}
if (null tyvars) && (null arg_tys) then
pprTrace "mkWWargs" (ppr fun_ty $$ ppr demands)
returnUs ([], id, id, fun_ty)
applyToVars vars fn = mkVarApps fn vars
mk_wrap_arg uniq ty dmd one_shot
- = set_one_shot one_shot (setIdNewDemandInfo (mkSysLocal SLIT("w") uniq ty) dmd)
+ = set_one_shot one_shot (setIdNewDemandInfo (mkSysLocal FSLIT("w") uniq ty) dmd)
where
set_one_shot True id = setOneShotLambda id
set_one_shot False id = id
-- of dropping seqs in the worker
Eval (Poly Abs)
-> let
- arg_w_unf = arg `setIdUnfolding` mkOtherCon []
+ arg_w_unf = arg `setIdUnfolding` evaldUnfolding
-- Tell the worker arg that it's sure to be evaluated
-- so that internal seqs can be dropped
in
| n_con_args == 1 && isUnLiftedType con_arg_ty1
-- Special case when there is a single result of unlifted type
+ --
+ -- Wrapper: case (..call worker..) of x -> C x
+ -- Worker: case ( ..body.. ) of C x -> x
= getUniquesUs `thenUs` \ (work_uniq : arg_uniq : _) ->
let
work_wild = mk_ww_local work_uniq body_ty
arg = mk_ww_local arg_uniq con_arg_ty1
con_app = mkConApp data_con (map Type tycon_arg_tys ++ [Var arg])
in
- returnUs (\ wkr_call -> Case wkr_call arg [(DEFAULT, [], con_app)],
- \ body -> workerCase body work_wild [(DataAlt data_con, [arg], Var arg)],
+ returnUs (\ wkr_call -> Case wkr_call arg (exprType con_app) [(DEFAULT, [], con_app)],
+ \ body -> workerCase body work_wild con_arg_ty1 [(DataAlt data_con, [arg], Var arg)],
con_arg_ty1)
| otherwise -- The general case
+ -- Wrapper: case (..call worker..) of (# a, b #) -> C a b
+ -- Worker: case ( ...body... ) of C a b -> (# a, b #)
= getUniquesUs `thenUs` \ uniqs ->
let
(wrap_wild : work_wild : args) = zipWith mk_ww_local uniqs (ubx_tup_ty : body_ty : con_arg_tys)
ubx_tup_app = mkConApp ubx_tup_con (map Type con_arg_tys ++ arg_vars)
con_app = mkConApp data_con (map Type tycon_arg_tys ++ arg_vars)
in
- returnUs (\ wkr_call -> Case wkr_call wrap_wild [(DataAlt ubx_tup_con, args, con_app)],
- \ body -> workerCase body work_wild [(DataAlt data_con, args, ubx_tup_app)],
+ returnUs (\ wkr_call -> Case wkr_call wrap_wild (exprType con_app) [(DataAlt ubx_tup_con, args, con_app)],
+ \ body -> workerCase body work_wild ubx_tup_ty [(DataAlt data_con, args, ubx_tup_app)],
ubx_tup_ty)
where
(_, tycon_arg_tys, data_con, con_arg_tys) = splitProductType "mkWWcpr" body_ty
-- This transform doesn't move work or allocation
-- from one cost centre to another
-workerCase (Note (SCC cc) e) arg alts = Note (SCC cc) (Case e arg alts)
-workerCase e arg alts = Case e arg alts
+workerCase (Note (SCC cc) e) arg ty alts = Note (SCC cc) (Case e arg ty alts)
+workerCase e arg ty alts = Case e arg ty alts
\end{code}
= panic "WwLib: haven't done mk_absent_let for primitives yet"
where
arg_ty = idType arg
--- abs_rhs = mkTyApps (Var aBSENT_ERROR_ID) [arg_ty]
- abs_rhs = mkApps (Var eRROR_CSTRING_ID) [Type arg_ty, Lit (MachStr (_PK_ msg))]
+ abs_rhs = mkRuntimeErrorApp rUNTIME_ERROR_ID arg_ty msg
msg = "Oops! Entered absent arg " ++ showSDocDebug (ppr arg <+> ppr (idType arg))
mk_unpk_case arg unpk_args boxing_con boxing_tycon body
-- A data type
= Case (Var arg)
(sanitiseCaseBndr arg)
+ (exprType body)
[(DataAlt boxing_con, unpk_args, body)]
-mk_seq_case arg body = Case (Var arg) (sanitiseCaseBndr arg) [(DEFAULT, [], body)]
+mk_seq_case arg body = Case (Var arg) (sanitiseCaseBndr arg) (exprType body) [(DEFAULT, [], body)]
sanitiseCaseBndr :: Id -> Id
-- The argument we are scrutinising has the right type to be
-- like (x+y) `seq` ....
sanitiseCaseBndr id = id `setIdInfo` vanillaIdInfo
-mk_ww_local uniq ty = mkSysLocal SLIT("ww") uniq ty
+mk_ww_local uniq ty = mkSysLocal FSLIT("ww") uniq ty
\end{code}
projects / ghc-hetmet.git / blobdiff