X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=compiler%2FcoreSyn%2FMkCore.lhs;h=789abe48c09d5958e6544d1f4f73f0680bf41e63;hb=69f8ed93800605d8df011388450d6d3bb9ca6071;hp=b930f880e18690ca51f40f5814ac00147eb27b9f;hpb=da90115af458147437479017f2992e482a1a028e;p=ghc-hetmet.git diff --git a/compiler/coreSyn/MkCore.lhs b/compiler/coreSyn/MkCore.lhs index b930f88..789abe4 100644 --- a/compiler/coreSyn/MkCore.lhs +++ b/compiler/coreSyn/MkCore.lhs @@ -4,11 +4,12 @@ module MkCore ( -- * Constructing normal syntax mkCoreLet, mkCoreLets, mkCoreApp, mkCoreApps, mkCoreConApps, - mkCoreLams, + mkCoreLams, mkWildCase, mkWildBinder, mkIfThenElse, -- * Constructing boxed literals - mkWordExpr, - mkIntExpr, mkIntegerExpr, + mkWordExpr, mkWordExprWord, + mkIntExpr, mkIntExprInt, + mkIntegerExpr, mkFloatExpr, mkDoubleExpr, mkCharExpr, mkStringExpr, mkStringExprFS, @@ -47,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 @@ -119,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 @@ -216,12 +177,20 @@ mkCoreLams = mkLams \begin{code} -- | Create a 'CoreExpr' which will evaluate to the given @Int@ -mkIntExpr :: Int -> CoreExpr -- Result = I# i :: Int -mkIntExpr i = mkConApp intDataCon [mkIntLitInt i] +mkIntExpr :: Integer -> CoreExpr -- Result = I# i :: Int +mkIntExpr i = mkConApp intDataCon [mkIntLit i] + +-- | Create a 'CoreExpr' which will evaluate to the given @Int@ +mkIntExprInt :: Int -> CoreExpr -- Result = I# i :: Int +mkIntExprInt i = mkConApp intDataCon [mkIntLitInt i] + +-- | Create a 'CoreExpr' which will evaluate to the a @Word@ with the given value +mkWordExpr :: Integer -> CoreExpr +mkWordExpr w = mkConApp wordDataCon [mkWordLit w] -- | Create a 'CoreExpr' which will evaluate to the given @Word@ -mkWordExpr :: Word -> CoreExpr -mkWordExpr w = mkConApp wordDataCon [mkWordLitWord w] +mkWordExprWord :: Word -> CoreExpr +mkWordExprWord w = mkConApp wordDataCon [mkWordLitWord w] -- | Create a 'CoreExpr' which will evaluate to the given @Integer@ mkIntegerExpr :: MonadThings m => Integer -> m CoreExpr -- Result :: Integer @@ -379,9 +348,7 @@ mkCoreTup cs = mkConApp (tupleCon Boxed (length cs)) -- | Build the type of a small tuple that holds the specified type of thing mkCoreTupTy :: [Type] -> Type -mkCoreTupTy [ty] = ty -mkCoreTupTy tys = mkTupleTy Boxed (length tys) tys - +mkCoreTupTy tys = mkTupleTy Boxed tys -- | Build a big tuple holding the specified variables mkBigCoreVarTup :: [Id] -> CoreExpr