X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fstranal%2FWwLib.lhs;h=54a167ddcbf7bb741cb09a6c7c5dfc3a54d06bbe;hb=e7c3f957fd36fd9f6369183b7a31e2a4a4c21b43;hp=b18202830af0ce1305ce2b9868d006727b876164;hpb=41a0f74e7b3e215b8f3eb6738c7ae50baea9d82c;p=ghc-hetmet.git diff --git a/ghc/compiler/stranal/WwLib.lhs b/ghc/compiler/stranal/WwLib.lhs index b182028..54a167d 100644 --- a/ghc/compiler/stranal/WwLib.lhs +++ b/ghc/compiler/stranal/WwLib.lhs @@ -17,16 +17,15 @@ import Id ( Id, idType, mkSysLocal, idNewDemandInfo, setIdNewDemandInfo, 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} @@ -224,7 +223,7 @@ mkWWargs :: Type 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 @@ -241,11 +240,11 @@ mkWWargs fun_ty demands one_shots 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 @@ -258,7 +257,7 @@ mkWWargs fun_ty demands one_shots 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) @@ -281,7 +280,7 @@ applyToVars :: [Var] -> CoreExpr -> CoreExpr 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 @@ -359,7 +358,7 @@ mkWWstr_one arg -- 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 @@ -421,17 +420,22 @@ mkWWcpr body_ty RetCPR | 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) @@ -441,8 +445,8 @@ mkWWcpr body_ty RetCPR 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 @@ -463,8 +467,8 @@ mkWWcpr body_ty other -- No CPR info -- 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} @@ -483,17 +487,17 @@ mk_absent_let arg body = 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 @@ -506,5 +510,5 @@ sanitiseCaseBndr :: Id -> Id -- 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}