X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fstranal%2FWwLib.lhs;h=da32c4813cf3892582491a49cfecc2e8f425c124;hb=246e8946ca7ceb207ec94c7edcb737a49581a6f5;hp=8b4f6aa2240dd3868ee678091dc2f43b508ca6f2;hpb=a4c34367ce3e836f52f0ffb1e379ce81b8d65316;p=ghc-hetmet.git diff --git a/compiler/stranal/WwLib.lhs b/compiler/stranal/WwLib.lhs index 8b4f6aa..da32c48 100644 --- a/compiler/stranal/WwLib.lhs +++ b/compiler/stranal/WwLib.lhs @@ -15,18 +15,17 @@ import Id ( Id, idType, mkSysLocal, idNewDemandInfo, setIdNewDemandInfo, setIdInfo ) import IdInfo ( vanillaIdInfo ) -import DataCon ( deepSplitProductType_maybe, splitProductType ) +import DataCon import NewDemand ( Demand(..), DmdResult(..), Demands(..) ) import MkId ( realWorldPrimId, voidArgId, mkRuntimeErrorApp, rUNTIME_ERROR_ID, mkUnpackCase, mkProductBox ) import TysWiredIn ( tupleCon ) -import Type ( Type, isUnLiftedType, mkFunTys, - splitForAllTys, splitFunTys, splitRecNewType_maybe, isAlgType - ) -import Coercion ( Coercion, mkSymCoercion, splitRecNewTypeCo_maybe ) +import Type +import Coercion ( mkSymCoercion, splitNewTypeRepCo_maybe ) import BasicTypes ( Boxity(..) ) import Var ( Var, isId ) import UniqSupply ( returnUs, thenUs, getUniquesUs, UniqSM ) +import Unique import Util ( zipWithEqual, notNull ) import Outputable import List ( zipWith4 ) @@ -132,9 +131,9 @@ mkWwBodies fun_ty demands res_info one_shots mkWWcpr res_ty res_info else returnUs (id, id, res_ty) - ) `thenUs` \ (wrap_fn_cpr, work_fn_cpr, cpr_res_ty) -> + ) `thenUs` \ (wrap_fn_cpr, work_fn_cpr, _cpr_res_ty) -> - returnUs ([idNewDemandInfo v | v <- work_args, isId v], + returnUs ([idNewDemandInfo v | v <- work_call_args, isId v], Note InlineMe . wrap_fn_args . wrap_fn_cpr . wrap_fn_str . applyToVars work_call_args . Var, mkLams work_lam_args. work_fn_str . work_fn_cpr . work_fn_args) -- We use an INLINE unconditionally, even if the wrapper turns out to be @@ -225,7 +224,7 @@ mkWWargs :: Type Type) -- Type of wrapper body mkWWargs fun_ty demands one_shots - | Just (rep_ty, co) <- splitRecNewTypeCo_maybe fun_ty + | Just (rep_ty, co) <- splitNewTypeRepCo_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 @@ -238,8 +237,8 @@ mkWWargs fun_ty demands one_shots -- simply coerces. = mkWWargs rep_ty demands one_shots `thenUs` \ (wrap_args, wrap_fn_args, work_fn_args, res_ty) -> returnUs (wrap_args, - \ e -> Cast (wrap_fn_args e) co, - \ e -> work_fn_args (Cast e (mkSymCoercion co)), + \ e -> Cast (wrap_fn_args e) (mkSymCoercion co), + \ e -> work_fn_args (Cast e co), res_ty) | notNull demands = getUniquesUs `thenUs` \ wrap_uniqs -> @@ -280,6 +279,7 @@ mkWWargs fun_ty demands one_shots applyToVars :: [Var] -> CoreExpr -> CoreExpr applyToVars vars fn = mkVarApps fn vars +mk_wrap_arg :: Unique -> Type -> NewDemand.Demand -> Bool -> Id mk_wrap_arg uniq ty dmd one_shot = set_one_shot one_shot (setIdNewDemandInfo (mkSysLocal FSLIT("w") uniq ty) dmd) where @@ -305,11 +305,6 @@ mkWWstr :: [Var] -- Wrapper args; have their demand info on them CoreExpr -> CoreExpr) -- Worker body, lacking the original body of the function, -- and lacking its lambdas. -- This fn does the reboxing - ----------------------- -nop_fn body = body - ----------------------- mkWWstr [] = returnUs ([], nop_fn, nop_fn) @@ -318,14 +313,13 @@ mkWWstr (arg : args) mkWWstr args `thenUs` \ (args2, wrap_fn2, work_fn2) -> returnUs (args1 ++ args2, wrap_fn1 . wrap_fn2, work_fn1 . work_fn2) - ---------------------- -- mkWWstr_one wrap_arg = (work_args, wrap_fn, work_fn) -- * wrap_fn assumes wrap_arg is in scope, -- brings into scope work_args (via cases) -- * work_fn assumes work_args are in scope, a -- brings into scope wrap_arg (via lets) - +mkWWstr_one :: Var -> UniqSM ([Var], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr) mkWWstr_one arg | isTyVar arg = returnUs ([arg], nop_fn, nop_fn) @@ -341,7 +335,7 @@ mkWWstr_one arg -- Unpack case Eval (Prod cs) - | Just (arg_tycon, tycon_arg_tys, data_con, inst_con_arg_tys) + | Just (_arg_tycon, _tycon_arg_tys, data_con, inst_con_arg_tys) <- deepSplitProductType_maybe (idType arg) -> getUniquesUs `thenUs` \ uniqs -> let @@ -378,7 +372,7 @@ mkWWstr_one arg -- during simplification, so for now I've just nuked this whole case -- Other cases - other_demand -> returnUs ([arg], nop_fn, nop_fn) + _other_demand -> returnUs ([arg], nop_fn, nop_fn) where -- If the wrapper argument is a one-shot lambda, then @@ -388,6 +382,10 @@ mkWWstr_one arg set_one_shot | isOneShotLambda arg = setOneShotLambda | otherwise = \x -> x + +---------------------- +nop_fn :: CoreExpr -> CoreExpr +nop_fn body = body \end{code} @@ -415,8 +413,9 @@ mkWWcpr :: Type -- function body type Type) -- Type of worker's body mkWWcpr body_ty RetCPR - | not (isAlgType body_ty) - = WARN( True, text "mkWWcpr: non-algebraic body type" <+> ppr body_ty ) + | not (isClosedAlgType body_ty) + = WARN( True, + text "mkWWcpr: non-algebraic or open body type" <+> ppr body_ty ) returnUs (id, id, body_ty) | n_con_args == 1 && isUnLiftedType con_arg_ty1 @@ -428,10 +427,10 @@ mkWWcpr body_ty RetCPR 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]) + con_app = mkProductBox [arg] body_ty in - 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)], + returnUs (\ wkr_call -> Case wkr_call (arg) (exprType con_app) [(DEFAULT, [], con_app)], + \ body -> workerCase (work_wild) body [arg] data_con (Var arg), con_arg_ty1) | otherwise -- The general case @@ -444,17 +443,17 @@ mkWWcpr body_ty RetCPR ubx_tup_con = tupleCon Unboxed n_con_args ubx_tup_ty = exprType ubx_tup_app ubx_tup_app = mkConApp ubx_tup_con (map Type con_arg_tys ++ arg_vars) - con_app = mkProductBox arg_vars body_ty + con_app = mkProductBox args body_ty in - 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)], + returnUs (\ wkr_call -> Case wkr_call (wrap_wild) (exprType con_app) [(DataAlt ubx_tup_con, args, con_app)], + \ body -> workerCase (work_wild) body args data_con ubx_tup_app, ubx_tup_ty) where - (_, tycon_arg_tys, data_con, con_arg_tys) = deepSplitProductType "mkWWcpr" body_ty + (_arg_tycon, _tycon_arg_tys, data_con, con_arg_tys) = deepSplitProductType "mkWWcpr" body_ty n_con_args = length con_arg_tys con_arg_ty1 = head con_arg_tys -mkWWcpr body_ty other -- No CPR info +mkWWcpr body_ty _other -- No CPR info = returnUs (id, id, body_ty) -- If the original function looked like @@ -467,9 +466,9 @@ 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 ty alts = Note (SCC cc) (Case e arg ty alts) -workerCase e arg ty alts = Case e arg ty alts +workerCase :: Id -> CoreExpr -> [Id] -> DataCon -> CoreExpr -> CoreExpr +workerCase bndr (Note (SCC cc) e) args con body = Note (SCC cc) (mkUnpackCase bndr e args con body) +workerCase bndr e args con body = mkUnpackCase bndr e args con body \end{code} @@ -481,6 +480,7 @@ workerCase e arg ty alts = Case e arg ty alts \begin{code} +mk_absent_let :: Id -> CoreExpr -> CoreExpr mk_absent_let arg body | not (isUnLiftedType arg_ty) = Let (NonRec arg abs_rhs) body @@ -491,13 +491,7 @@ mk_absent_let arg body 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 :: Id -> CoreExpr -> CoreExpr mk_seq_case arg body = Case (Var arg) (sanitiseCaseBndr arg) (exprType body) [(DEFAULT, [], body)] sanitiseCaseBndr :: Id -> Id @@ -511,5 +505,6 @@ sanitiseCaseBndr :: Id -> Id -- like (x+y) `seq` .... sanitiseCaseBndr id = id `setIdInfo` vanillaIdInfo +mk_ww_local :: Unique -> Type -> Id mk_ww_local uniq ty = mkSysLocal FSLIT("ww") uniq ty \end{code}