X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fstranal%2FWwLib.lhs;h=391c07c0894595954e1b9f42112cae71a68e9765;hp=a7050dc0d0166ce643c8f7b5682d03f6e7a0f122;hb=febf1ced754a3996ac1a5877dcded87828560d1c;hpb=9ffadf219cbc4f8ec57264786df936a3cee88aec diff --git a/compiler/stranal/WwLib.lhs b/compiler/stranal/WwLib.lhs index a7050dc..391c07c 100644 --- a/compiler/stranal/WwLib.lhs +++ b/compiler/stranal/WwLib.lhs @@ -10,20 +10,22 @@ module WwLib ( mkWwBodies, mkWWstr, mkWorkerArgs ) where import CoreSyn import CoreUtils ( exprType ) -import Id ( Id, idType, mkSysLocal, idNewDemandInfo, setIdNewDemandInfo, +import Id ( Id, idType, mkSysLocal, idDemandInfo, setIdDemandInfo, isOneShotLambda, setOneShotLambda, setIdUnfolding, setIdInfo ) import IdInfo ( vanillaIdInfo ) import DataCon -import NewDemand ( Demand(..), DmdResult(..), Demands(..) ) -import MkId ( realWorldPrimId, voidArgId, mkRuntimeErrorApp, rUNTIME_ERROR_ID, +import Demand ( Demand(..), DmdResult(..), Demands(..) ) +import MkCore ( mkRuntimeErrorApp, aBSENT_ERROR_ID ) +import MkId ( realWorldPrimId, voidArgId, mkUnpackCase, mkProductBox ) +import TysPrim ( realWorldStatePrimTy ) import TysWiredIn ( tupleCon ) import Type -import Coercion ( mkSymCoercion, splitNewTypeRepCo_maybe ) +import Coercion ( mkSymCo, splitNewTypeRepCo_maybe ) import BasicTypes ( Boxity(..) ) -import Var ( Var, isId ) +import Literal ( absentLiteralOf ) import UniqSupply import Unique import Util ( zipWithEqual ) @@ -133,8 +135,8 @@ mkWwBodies fun_ty demands res_info one_shots return (id, id, res_ty) ; let (work_lam_args, work_call_args) = mkWorkerArgs work_args res_ty - ; return ([idNewDemandInfo v | v <- work_call_args, isId v], - Note InlineMe . wrap_fn_args . wrap_fn_cpr . wrap_fn_str . applyToVars work_call_args . Var, + ; return ([idDemandInfo v | v <- work_call_args, isId v], + 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 -- something trivial like @@ -241,7 +243,7 @@ mkWWargs subst fun_ty arg_info = do { (wrap_args, wrap_fn_args, work_fn_args, res_ty) <- mkWWargs subst rep_ty arg_info ; return (wrap_args, - \e -> Cast (wrap_fn_args e) (mkSymCoercion co), + \e -> Cast (wrap_fn_args e) (mkSymCo co), \e -> work_fn_args (Cast e co), res_ty) } @@ -268,7 +270,7 @@ mkWWargs subst fun_ty arg_info <- mkWWargs subst fun_ty' arg_info' ; return (id : wrap_args, Lam id . wrap_fn_args, - work_fn_args . (`App` Var id), + work_fn_args . (`App` varToCoreExpr id), res_ty) } | otherwise @@ -278,9 +280,9 @@ mkWWargs subst fun_ty arg_info applyToVars :: [Var] -> CoreExpr -> CoreExpr applyToVars vars fn = mkVarApps fn vars -mk_wrap_arg :: Unique -> Type -> NewDemand.Demand -> Bool -> Id +mk_wrap_arg :: Unique -> Type -> Demand -> Bool -> Id mk_wrap_arg uniq ty dmd one_shot - = set_one_shot one_shot (setIdNewDemandInfo (mkSysLocal (fsLit "w") uniq ty) dmd) + = set_one_shot one_shot (setIdDemandInfo (mkSysLocal (fsLit "w") uniq ty) dmd) where set_one_shot True id = setOneShotLambda id set_one_shot False id = id @@ -288,18 +290,12 @@ mk_wrap_arg uniq ty dmd one_shot Note [Freshen type variables] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -mkWWargs may be given a type like (a~b) => -Which really means forall (co:a~b). -Because the name of the coercion variable, 'co', isn't mentioned in , -nested coercion foralls may all use the same variable; and sometimes do -see Var.mkWildCoVar. - -However, when we do a worker/wrapper split, we must not use shadowed names, +Wen we do a worker/wrapper split, we must not use shadowed names, else we'll get - f = /\ co /\co. fw co co -which is obviously wrong. Actually, the same is true of type variables, which -can in principle shadow, within a type (e.g. forall a. a -> forall a. a->a). -But type variables *are* mentioned in , so we must substitute. + f = /\ a /\a. fw a a +which is obviously wrong. Type variables can can in principle shadow, +within a type (e.g. forall a. a -> forall a. a->a). But type +variables *are* mentioned in , so we must substitute. That's why we carry the TvSubst through mkWWargs @@ -340,13 +336,13 @@ mkWWstr_one arg = return ([arg], nop_fn, nop_fn) | otherwise - = case idNewDemandInfo arg of + = case idDemandInfo arg of - -- Absent case. We don't deal with absence for unlifted types, - -- though, because it's not so easy to manufacture a placeholder - -- We'll see if this turns out to be a problem - Abs | not (isUnLiftedType (idType arg)) -> - return ([], nop_fn, mk_absent_let arg) + -- Absent case. We can't always handle absence for arbitrary + -- unlifted types, so we need to choose just the cases we can + -- (that's what mk_absent_let does) + Abs | Just work_fn <- mk_absent_let arg + -> return ([], nop_fn, work_fn) -- Unpack case Eval (Prod cs) @@ -392,7 +388,7 @@ mkWWstr_one arg -- If the wrapper argument is a one-shot lambda, then -- so should (all) the corresponding worker arguments be -- This bites when we do w/w on a case join point - set_worker_arg_info worker_arg demand = set_one_shot (setIdNewDemandInfo worker_arg demand) + set_worker_arg_info worker_arg demand = set_one_shot (setIdDemandInfo worker_arg demand) set_one_shot | isOneShotLambda arg = setOneShotLambda | otherwise = \x -> x @@ -492,18 +488,45 @@ workerCase bndr e args con body = mkUnpackCase bndr e args con body %* * %************************************************************************ +Note [Absent errors] +~~~~~~~~~~~~~~~~~~~~ +We make a new binding for Ids that are marked absent, thus + let x = absentError "x :: Int" +The idea is that this binding will never be used; but if it +buggily is used we'll get a runtime error message. + +Coping with absence for *unlifted* types is important; see, for +example, Trac #4306. For these we find a suitable literal, +using Literal.absentLiteralOf. We don't have literals for +every primitive type, so the function is partial. + + [I did try the experiment of using an error thunk for unlifted + things too, relying on the simplifier to drop it as dead code, + by making absentError + (a) *not* be a bottoming Id, + (b) be "ok for speculation" + But that relies on the simplifier finding that it really + is dead code, which is fragile, and indeed failed when + profiling is on, which disables various optimisations. So + using a literal will do.] \begin{code} -mk_absent_let :: Id -> CoreExpr -> CoreExpr -mk_absent_let arg body +mk_absent_let :: Id -> Maybe (CoreExpr -> CoreExpr) +mk_absent_let arg | not (isUnLiftedType arg_ty) - = Let (NonRec arg abs_rhs) body + = Just (Let (NonRec arg abs_rhs)) + | Just (tc, _) <- splitTyConApp_maybe arg_ty + , Just lit <- absentLiteralOf tc + = Just (Let (NonRec arg (Lit lit))) + | arg_ty `eqType` realWorldStatePrimTy + = Just (Let (NonRec arg (Var realWorldPrimId))) | otherwise - = panic "WwLib: haven't done mk_absent_let for primitives yet" + = WARN( True, ptext (sLit "No absent value for") <+> ppr arg_ty ) + Nothing where - arg_ty = idType arg - abs_rhs = mkRuntimeErrorApp rUNTIME_ERROR_ID arg_ty msg - msg = "Oops! Entered absent arg " ++ showSDocDebug (ppr arg <+> ppr (idType arg)) + arg_ty = idType arg + abs_rhs = mkRuntimeErrorApp aBSENT_ERROR_ID arg_ty msg + msg = 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)]