-- * 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,
mkChunkified,
-- * Constructing small tuples
- mkCoreVarTup, mkCoreVarTupTy,
- mkCoreTup, mkCoreTupTy,
+ mkCoreVarTup, mkCoreVarTupTy, mkCoreTup,
-- * Constructing big tuples
mkBigCoreVarTup, mkBigCoreVarTupTy,
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
-----------
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
\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
-- | 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
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)
-- | 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}
%************************************************************************
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 ]
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}