X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fstranal%2FWwLib.lhs;h=391c07c0894595954e1b9f42112cae71a68e9765;hp=faffff296f0a46992f7fbe0143ab16cac1419e93;hb=febf1ced754a3996ac1a5877dcded87828560d1c;hpb=afe4534704e8e0c25e2f90c6c0a2e397ecef24db diff --git a/compiler/stranal/WwLib.lhs b/compiler/stranal/WwLib.lhs index faffff2..391c07c 100644 --- a/compiler/stranal/WwLib.lhs +++ b/compiler/stranal/WwLib.lhs @@ -20,11 +20,12 @@ 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 ) +import Literal ( absentLiteralOf ) import UniqSupply import Unique import Util ( zipWithEqual ) @@ -242,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) } @@ -269,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 @@ -289,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 @@ -337,16 +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 -> 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,26 +488,41 @@ workerCase bndr e args con body = mkUnpackCase bndr e args con body %* * %************************************************************************ - -Note [Absent error Id] -~~~~~~~~~~~~~~~~~~~~~~ +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. -We do this even for *unlifted* types (e.g. Int#). We define -absentError to *not* be a bottoming Id, and we treat it as -"ok for speculation" (see CoreUtils.okForSpeculation). That -means that the let won't get turned into a case, and will -be discarded if (as we fully expect) x turns out to be dead. -Coping with absence for unlifted types is important; see, for -example, Trac #4306. +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 - = Let (NonRec arg abs_rhs) body +mk_absent_let :: Id -> Maybe (CoreExpr -> CoreExpr) +mk_absent_let arg + | not (isUnLiftedType arg_ty) + = 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 + = WARN( True, ptext (sLit "No absent value for") <+> ppr arg_ty ) + Nothing where arg_ty = idType arg abs_rhs = mkRuntimeErrorApp aBSENT_ERROR_ID arg_ty msg