X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FcoreSyn%2FMkCore.lhs;h=f7c0f9ab6f427a33b1c1c3ec995333a58fef5b3d;hb=2662dbc5b2c30fc11ccb99e7f9b2dba794d680ba;hp=b930f880e18690ca51f40f5814ac00147eb27b9f;hpb=da90115af458147437479017f2992e482a1a028e;p=ghc-hetmet.git diff --git a/compiler/coreSyn/MkCore.lhs b/compiler/coreSyn/MkCore.lhs index b930f88..f7c0f9a 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, @@ -17,8 +18,7 @@ module MkCore ( mkChunkified, -- * Constructing small tuples - mkCoreVarTup, mkCoreVarTupTy, - mkCoreTup, mkCoreTupTy, + mkCoreVarTup, mkCoreVarTupTy, mkCoreTup, -- * Constructing big tuples mkBigCoreVarTup, mkBigCoreVarTupTy, @@ -47,15 +47,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 +118,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 +176,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 @@ -368,7 +336,7 @@ mkCoreVarTup ids = mkCoreTup (map Var ids) -- | Bulid the type of a small tuple that holds the specified variables mkCoreVarTupTy :: [Id] -> Type -mkCoreVarTupTy ids = mkCoreTupTy (map idType ids) +mkCoreVarTupTy ids = mkBoxedTupleTy (map idType ids) -- | Build a small tuple holding the specified expressions mkCoreTup :: [CoreExpr] -> CoreExpr @@ -377,12 +345,6 @@ mkCoreTup [c] = c mkCoreTup cs = mkConApp (tupleCon Boxed (length cs)) (map (Type . exprType) cs ++ 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 - - -- | Build a big tuple holding the specified variables mkBigCoreVarTup :: [Id] -> CoreExpr mkBigCoreVarTup ids = mkBigCoreTup (map Var ids) @@ -397,7 +359,7 @@ mkBigCoreTup = mkChunkified mkCoreTup -- | Build the type of a big tuple that holds the specified type of thing mkBigCoreTupTy :: [Type] -> Type -mkBigCoreTupTy = mkChunkified mkCoreTupTy +mkBigCoreTupTy = mkChunkified mkBoxedTupleTy \end{code} %************************************************************************ @@ -441,7 +403,7 @@ mkTupleSelector vars the_var scrut_var scrut mk_tup_sel vars_s the_var = mkSmallTupleSelector group the_var tpl_v $ mk_tup_sel (chunkify tpl_vs) tpl_v where - tpl_tys = [mkCoreTupTy (map idType gp) | gp <- vars_s] + tpl_tys = [mkBoxedTupleTy (map idType gp) | gp <- vars_s] tpl_vs = mkTemplateLocals tpl_tys [(tpl_v, group)] = [(tpl,gp) | (tpl,gp) <- zipEqual "mkTupleSelector" tpl_vs vars_s, the_var `elem` gp ] @@ -502,7 +464,7 @@ mkTupleCase uniqs vars body scrut_var scrut one_tuple_case chunk_vars (us, vs, body) = let (us1, us2) = splitUniqSupply us scrut_var = mkSysLocal (fsLit "ds") (uniqFromSupply us1) - (mkCoreTupTy (map idType chunk_vars)) + (mkBoxedTupleTy (map idType chunk_vars)) body' = mkSmallTupleCase chunk_vars body scrut_var (Var scrut_var) in (us2, scrut_var:vs, body') \end{code}