X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fstranal%2FWwLib.lhs;h=da32c4813cf3892582491a49cfecc2e8f425c124;hb=62f6cc1dec4223532fbd15de64db4fb036932944;hp=3383cb433fa9198ba38f16fd1268b0496a1511eb;hpb=35a557b0606d842bb204cff215eac16f8cb8647d;p=ghc-hetmet.git diff --git a/compiler/stranal/WwLib.lhs b/compiler/stranal/WwLib.lhs index 3383cb4..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, deepSplitProductType ) +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, isAlgType - ) +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 ) @@ -134,7 +133,7 @@ mkWwBodies fun_ty demands res_info one_shots returnUs (id, id, 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 @@ -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) @@ -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 @@ -454,7 +453,7 @@ mkWWcpr body_ty RetCPR 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,7 +466,7 @@ mkWWcpr body_ty other -- No CPR info -- -- This transform doesn't move work or allocation -- from one cost centre to another - +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 bndr e args con body = mkUnpackCase bndr e args con body \begin{code} +mk_absent_let :: Id -> CoreExpr -> CoreExpr mk_absent_let arg body | not (isUnLiftedType arg_ty) = Let (NonRec arg abs_rhs) body @@ -491,6 +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_seq_case :: Id -> CoreExpr -> CoreExpr mk_seq_case arg body = Case (Var arg) (sanitiseCaseBndr arg) (exprType body) [(DEFAULT, [], body)] sanitiseCaseBndr :: Id -> Id @@ -504,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}