X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fstranal%2FWwLib.lhs;h=391c07c0894595954e1b9f42112cae71a68e9765;hp=40a2a26606fb8633009a89bc1e99a60909545ed2;hb=febf1ced754a3996ac1a5877dcded87828560d1c;hpb=d2ce0f52d42edf32bb9f13796e6ba6edba8bd516 diff --git a/compiler/stranal/WwLib.lhs b/compiler/stranal/WwLib.lhs index 40a2a26..391c07c 100644 --- a/compiler/stranal/WwLib.lhs +++ b/compiler/stranal/WwLib.lhs @@ -17,13 +17,15 @@ import Id ( Id, idType, mkSysLocal, idDemandInfo, setIdDemandInfo, import IdInfo ( vanillaIdInfo ) import DataCon import Demand ( Demand(..), DmdResult(..), Demands(..) ) -import MkId ( realWorldPrimId, voidArgId, mkRuntimeErrorApp, rUNTIME_ERROR_ID, +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 ) +import Literal ( absentLiteralOf ) import UniqSupply import Unique import Util ( zipWithEqual ) @@ -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 @@ -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 @@ -336,17 +332,17 @@ mkWWstr (arg : args) = do -- brings into scope wrap_arg (via lets) mkWWstr_one :: Var -> UniqSM ([Var], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr) mkWWstr_one arg - | isTyCoVar arg + | isTyVar arg = return ([arg], nop_fn, nop_fn) | otherwise = 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) @@ -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)]