X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FcoreSyn%2FMkCore.lhs;h=f67c78ad0526d4f2380fb38b00ea7abd024437c7;hp=0844a0a8ccee79724607463221907d8000e4bfb4;hb=703ca1542c8e0983cc9d8eebce6e9f3dd3fd71e2;hpb=393f26621b762225b204b3dc78b05a3ecf08871e diff --git a/compiler/coreSyn/MkCore.lhs b/compiler/coreSyn/MkCore.lhs index 0844a0a..f67c78a 100644 --- a/compiler/coreSyn/MkCore.lhs +++ b/compiler/coreSyn/MkCore.lhs @@ -4,7 +4,7 @@ module MkCore ( -- * Constructing normal syntax mkCoreLet, mkCoreLets, mkCoreApp, mkCoreApps, mkCoreConApps, - mkCoreLams, + mkCoreLams, mkWildCase, mkWildBinder, mkIfThenElse, -- * Constructing boxed literals mkWordExpr, mkWordExprWord, @@ -48,15 +48,14 @@ import HscTypes import TysWiredIn import PrelNames -import MkId ( seqId ) import Type -import TypeRep import TysPrim ( alphaTyVar ) import DataCon ( DataCon, dataConWorkId ) import FastString import UniqSupply +import Unique ( mkBuiltinUnique ) import BasicTypes import Util ( notNull, zipEqual ) import Panic @@ -120,88 +119,49 @@ mkCoreConApps con args = mkCoreApps (Var (dataConWorkId con)) args ----------- mk_val_app :: CoreExpr -> CoreExpr -> Type -> Type -> CoreExpr -mk_val_app (Var f `App` Type ty1 `App` Type _ `App` arg1) arg2 _ res_ty - | f == seqId -- Note [Desugaring seq (1), (2)] - = Case arg1 case_bndr res_ty [(DEFAULT,[],arg2)] - where - case_bndr = case arg1 of - Var v1 | isLocalId v1 -> v1 -- Note [Desugaring seq (2) and (3)] - _ -> mkWildId ty1 - mk_val_app fun arg arg_ty _ -- See Note [CoreSyn let/app invariant] | not (needsCaseBinding arg_ty arg) = App fun arg -- The vastly common case mk_val_app fun arg arg_ty res_ty - = Case arg (mkWildId arg_ty) res_ty [(DEFAULT,[],App fun (Var arg_id))] + = Case arg arg_id res_ty [(DEFAULT,[],App fun (Var arg_id))] where - arg_id = mkWildId arg_ty -- Lots of shadowing, but it doesn't matter, - -- because 'fun ' should not have a free wild-id + arg_id = mkWildBinder arg_ty + -- Lots of shadowing, but it doesn't matter, + -- because 'fun ' should not have a free wild-id + -- + -- This is Dangerous. But this is the only place we play this + -- game, mk_val_app returns an expression that does not have + -- have a free wild-id. So the only thing that can go wrong + -- is if you take apart this case expression, and pass a + -- fragmet of it as the fun part of a 'mk_val_app'. + + +-- | Make a /wildcard binder/. This is typically used when you need a binder +-- that you expect to use only at a *binding* site. Do not use it at +-- occurrence sites because it has a single, fixed unique, and it's very +-- easy to get into difficulties with shadowing. That's why it is used so little. +mkWildBinder :: Type -> Id +mkWildBinder ty = mkSysLocal (fsLit "wild") (mkBuiltinUnique 1) ty + +mkWildCase :: CoreExpr -> Type -> Type -> [CoreAlt] -> CoreExpr +-- Make a case expression whose case binder is unused +-- The alts should not have any occurrences of WildId +mkWildCase scrut scrut_ty res_ty alts + = Case scrut (mkWildBinder scrut_ty) res_ty alts + +mkIfThenElse :: CoreExpr -> CoreExpr -> CoreExpr -> CoreExpr +mkIfThenElse guard then_expr else_expr +-- Not going to be refining, so okay to take the type of the "then" clause + = mkWildCase guard boolTy (exprType then_expr) + [ (DataAlt falseDataCon, [], else_expr), -- Increasing order of tag! + (DataAlt trueDataCon, [], then_expr) ] \end{code} -Note [Desugaring seq (1)] cf Trac #1031 -~~~~~~~~~~~~~~~~~~~~~~~~~ - f x y = x `seq` (y `seq` (# x,y #)) - -The [CoreSyn let/app invariant] means that, other things being equal, because -the argument to the outer 'seq' has an unlifted type, we'll use call-by-value thus: - - f x y = case (y `seq` (# x,y #)) of v -> x `seq` v - -But that is bad for two reasons: - (a) we now evaluate y before x, and - (b) we can't bind v to an unboxed pair - -Seq is very, very special! So we recognise it right here, and desugar to - case x of _ -> case y of _ -> (# x,y #) - -Note [Desugaring seq (2)] cf Trac #2231 -~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - let chp = case b of { True -> fst x; False -> 0 } - in chp `seq` ...chp... -Here the seq is designed to plug the space leak of retaining (snd x) -for too long. - -If we rely on the ordinary inlining of seq, we'll get - let chp = case b of { True -> fst x; False -> 0 } - case chp of _ { I# -> ...chp... } - -But since chp is cheap, and the case is an alluring contet, we'll -inline chp into the case scrutinee. Now there is only one use of chp, -so we'll inline a second copy. Alas, we've now ruined the purpose of -the seq, by re-introducing the space leak: - case (case b of {True -> fst x; False -> 0}) of - I# _ -> ...case b of {True -> fst x; False -> 0}... - -We can try to avoid doing this by ensuring that the binder-swap in the -case happens, so we get his at an early stage: - case chp of chp2 { I# -> ...chp2... } -But this is fragile. The real culprit is the source program. Perhaps we -should have said explicitly - let !chp2 = chp in ...chp2... - -But that's painful. So the code here does a little hack to make seq -more robust: a saturated application of 'seq' is turned *directly* into -the case expression. So we desugar to: - let chp = case b of { True -> fst x; False -> 0 } - case chp of chp { I# -> ...chp... } -Notice the shadowing of the case binder! And now all is well. - -The reason it's a hack is because if you define mySeq=seq, the hack -won't work on mySeq. - -Note [Desugaring seq (3)] cf Trac #2409 -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The isLocalId ensures that we don't turn - True `seq` e -into - case True of True { ... } -which stupidly tries to bind the datacon 'True'. -\begin{code} --- The functions from this point don't really do anything cleverer than --- their counterparts in CoreSyn, but they are here for consistency +The functions from this point don't really do anything cleverer than +their counterparts in CoreSyn, but they are here for consistency +\begin{code} -- | Create a lambda where the given expression has a number of variables -- bound over it. The leftmost binder is that bound by the outermost -- lambda in the result