999cfc7db5117e75384c6e8a37fed7b381d445bb
[ghc.git] / compiler / coreSyn / MkCore.hs
1 {-# LANGUAGE CPP #-}
2
3 -- | Handy functions for creating much Core syntax
4 module MkCore (
5 -- * Constructing normal syntax
6 mkCoreLet, mkCoreLets,
7 mkCoreApp, mkCoreApps, mkCoreConApps,
8 mkCoreLams, mkWildCase, mkIfThenElse,
9 mkWildValBinder, mkWildEvBinder,
10 sortQuantVars, castBottomExpr,
11
12 -- * Constructing boxed literals
13 mkWordExpr, mkWordExprWord,
14 mkIntExpr, mkIntExprInt,
15 mkIntegerExpr, mkNaturalExpr,
16 mkFloatExpr, mkDoubleExpr,
17 mkCharExpr, mkStringExpr, mkStringExprFS, mkStringExprFSWith,
18
19 -- * Floats
20 FloatBind(..), wrapFloat, wrapFloats, floatBindings,
21
22 -- * Constructing small tuples
23 mkCoreVarTup, mkCoreVarTupTy, mkCoreTup, mkCoreUbxTup,
24 mkCoreTupBoxity, unitExpr,
25
26 -- * Constructing big tuples
27 mkBigCoreVarTup, mkBigCoreVarTup1,
28 mkBigCoreVarTupTy, mkBigCoreTupTy,
29 mkBigCoreTup,
30
31 -- * Deconstructing small tuples
32 mkSmallTupleSelector, mkSmallTupleCase,
33
34 -- * Deconstructing big tuples
35 mkTupleSelector, mkTupleSelector1, mkTupleCase,
36
37 -- * Constructing list expressions
38 mkNilExpr, mkConsExpr, mkListExpr,
39 mkFoldrExpr, mkBuildExpr,
40
41 -- * Constructing Maybe expressions
42 mkNothingExpr, mkJustExpr,
43
44 -- * Error Ids
45 mkRuntimeErrorApp, mkImpossibleExpr, mkAbsentErrorApp, errorIds,
46 rEC_CON_ERROR_ID, rUNTIME_ERROR_ID,
47 nON_EXHAUSTIVE_GUARDS_ERROR_ID, nO_METHOD_BINDING_ERROR_ID,
48 pAT_ERROR_ID, rEC_SEL_ERROR_ID, aBSENT_ERROR_ID,
49 tYPE_ERROR_ID, aBSENT_SUM_FIELD_ERROR_ID
50 ) where
51
52 #include "HsVersions.h"
53
54 import GhcPrelude
55
56 import Id
57 import Var ( EvVar, setTyVarUnique )
58
59 import CoreSyn
60 import CoreUtils ( exprType, needsCaseBinding, bindNonRec )
61 import Literal
62 import HscTypes
63
64 import TysWiredIn
65 import PrelNames
66
67 import HsUtils ( mkChunkified, chunkify )
68 import Type
69 import Coercion ( isCoVar )
70 import TysPrim
71 import DataCon ( DataCon, dataConWorkId )
72 import IdInfo
73 import Demand
74 import Name hiding ( varName )
75 import Outputable
76 import FastString
77 import UniqSupply
78 import BasicTypes
79 import Util
80 import DynFlags
81 import Data.List
82
83 import Data.Char ( ord )
84 import Control.Monad.Fail as MonadFail ( MonadFail )
85
86 infixl 4 `mkCoreApp`, `mkCoreApps`
87
88 {-
89 ************************************************************************
90 * *
91 \subsection{Basic CoreSyn construction}
92 * *
93 ************************************************************************
94 -}
95 sortQuantVars :: [Var] -> [Var]
96 -- Sort the variables, putting type and covars first, in scoped order,
97 -- and then other Ids
98 -- It is a deterministic sort, meaining it doesn't look at the values of
99 -- Uniques. For explanation why it's important See Note [Unique Determinism]
100 -- in Unique.
101 sortQuantVars vs = sorted_tcvs ++ ids
102 where
103 (tcvs, ids) = partition (isTyVar <||> isCoVar) vs
104 sorted_tcvs = scopedSort tcvs
105
106 -- | Bind a binding group over an expression, using a @let@ or @case@ as
107 -- appropriate (see "CoreSyn#let_app_invariant")
108 mkCoreLet :: CoreBind -> CoreExpr -> CoreExpr
109 mkCoreLet (NonRec bndr rhs) body -- See Note [CoreSyn let/app invariant]
110 = bindNonRec bndr rhs body
111 mkCoreLet bind body
112 = Let bind body
113
114 -- | Bind a list of binding groups over an expression. The leftmost binding
115 -- group becomes the outermost group in the resulting expression
116 mkCoreLets :: [CoreBind] -> CoreExpr -> CoreExpr
117 mkCoreLets binds body = foldr mkCoreLet body binds
118
119 -- | Construct an expression which represents the application of one expression
120 -- paired with its type to an argument. The result is paired with its type. This
121 -- function is not exported and used in the definition of 'mkCoreApp' and
122 -- 'mkCoreApps'.
123 -- Respects the let/app invariant by building a case expression where necessary
124 -- See CoreSyn Note [CoreSyn let/app invariant]
125 mkCoreAppTyped :: SDoc -> (CoreExpr, Type) -> CoreExpr -> (CoreExpr, Type)
126 mkCoreAppTyped _ (fun, fun_ty) (Type ty)
127 = (App fun (Type ty), piResultTy fun_ty ty)
128 mkCoreAppTyped _ (fun, fun_ty) (Coercion co)
129 = (App fun (Coercion co), res_ty)
130 where
131 (_, res_ty) = splitFunTy fun_ty
132 mkCoreAppTyped d (fun, fun_ty) arg
133 = ASSERT2( isFunTy fun_ty, ppr fun $$ ppr arg $$ d )
134 (mk_val_app fun arg arg_ty res_ty, res_ty)
135 where
136 (arg_ty, res_ty) = splitFunTy fun_ty
137
138 -- | Construct an expression which represents the application of one expression
139 -- to the other
140 -- Respects the let/app invariant by building a case expression where necessary
141 -- See CoreSyn Note [CoreSyn let/app invariant]
142 mkCoreApp :: SDoc -> CoreExpr -> CoreExpr -> CoreExpr
143 mkCoreApp s fun arg
144 = fst $ mkCoreAppTyped s (fun, exprType fun) arg
145
146 -- | Construct an expression which represents the application of a number of
147 -- expressions to another. The leftmost expression in the list is applied first
148 -- Respects the let/app invariant by building a case expression where necessary
149 -- See CoreSyn Note [CoreSyn let/app invariant]
150 mkCoreApps :: CoreExpr -> [CoreExpr] -> CoreExpr
151 mkCoreApps fun args
152 = fst $
153 foldl' (mkCoreAppTyped doc_string) (fun, fun_ty) args
154 where
155 doc_string = ppr fun_ty $$ ppr fun $$ ppr args
156 fun_ty = exprType fun
157
158 -- | Construct an expression which represents the application of a number of
159 -- expressions to that of a data constructor expression. The leftmost expression
160 -- in the list is applied first
161 mkCoreConApps :: DataCon -> [CoreExpr] -> CoreExpr
162 mkCoreConApps con args = mkCoreApps (Var (dataConWorkId con)) args
163
164 mk_val_app :: CoreExpr -> CoreExpr -> Type -> Type -> CoreExpr
165 -- Build an application (e1 e2),
166 -- or a strict binding (case e2 of x -> e1 x)
167 -- using the latter when necessary to respect the let/app invariant
168 -- See Note [CoreSyn let/app invariant]
169 mk_val_app fun arg arg_ty res_ty
170 | not (needsCaseBinding arg_ty arg)
171 = App fun arg -- The vastly common case
172
173 | otherwise
174 = Case arg arg_id res_ty [(DEFAULT,[],App fun (Var arg_id))]
175 where
176 arg_id = mkWildValBinder arg_ty
177 -- Lots of shadowing, but it doesn't matter,
178 -- because 'fun ' should not have a free wild-id
179 --
180 -- This is Dangerous. But this is the only place we play this
181 -- game, mk_val_app returns an expression that does not have
182 -- a free wild-id. So the only thing that can go wrong
183 -- is if you take apart this case expression, and pass a
184 -- fragment of it as the fun part of a 'mk_val_app'.
185
186 -----------
187 mkWildEvBinder :: PredType -> EvVar
188 mkWildEvBinder pred = mkWildValBinder pred
189
190 -- | Make a /wildcard binder/. This is typically used when you need a binder
191 -- that you expect to use only at a *binding* site. Do not use it at
192 -- occurrence sites because it has a single, fixed unique, and it's very
193 -- easy to get into difficulties with shadowing. That's why it is used so little.
194 -- See Note [WildCard binders] in SimplEnv
195 mkWildValBinder :: Type -> Id
196 mkWildValBinder ty = mkLocalIdOrCoVar wildCardName ty
197
198 mkWildCase :: CoreExpr -> Type -> Type -> [CoreAlt] -> CoreExpr
199 -- Make a case expression whose case binder is unused
200 -- The alts should not have any occurrences of WildId
201 mkWildCase scrut scrut_ty res_ty alts
202 = Case scrut (mkWildValBinder scrut_ty) res_ty alts
203
204 mkIfThenElse :: CoreExpr -> CoreExpr -> CoreExpr -> CoreExpr
205 mkIfThenElse guard then_expr else_expr
206 -- Not going to be refining, so okay to take the type of the "then" clause
207 = mkWildCase guard boolTy (exprType then_expr)
208 [ (DataAlt falseDataCon, [], else_expr), -- Increasing order of tag!
209 (DataAlt trueDataCon, [], then_expr) ]
210
211 castBottomExpr :: CoreExpr -> Type -> CoreExpr
212 -- (castBottomExpr e ty), assuming that 'e' diverges,
213 -- return an expression of type 'ty'
214 -- See Note [Empty case alternatives] in CoreSyn
215 castBottomExpr e res_ty
216 | e_ty `eqType` res_ty = e
217 | otherwise = Case e (mkWildValBinder e_ty) res_ty []
218 where
219 e_ty = exprType e
220
221 {-
222 The functions from this point don't really do anything cleverer than
223 their counterparts in CoreSyn, but they are here for consistency
224 -}
225
226 -- | Create a lambda where the given expression has a number of variables
227 -- bound over it. The leftmost binder is that bound by the outermost
228 -- lambda in the result
229 mkCoreLams :: [CoreBndr] -> CoreExpr -> CoreExpr
230 mkCoreLams = mkLams
231
232 {-
233 ************************************************************************
234 * *
235 \subsection{Making literals}
236 * *
237 ************************************************************************
238 -}
239
240 -- | Create a 'CoreExpr' which will evaluate to the given @Int@
241 mkIntExpr :: DynFlags -> Integer -> CoreExpr -- Result = I# i :: Int
242 mkIntExpr dflags i = mkCoreConApps intDataCon [mkIntLit dflags i]
243
244 -- | Create a 'CoreExpr' which will evaluate to the given @Int@
245 mkIntExprInt :: DynFlags -> Int -> CoreExpr -- Result = I# i :: Int
246 mkIntExprInt dflags i = mkCoreConApps intDataCon [mkIntLitInt dflags i]
247
248 -- | Create a 'CoreExpr' which will evaluate to the a @Word@ with the given value
249 mkWordExpr :: DynFlags -> Integer -> CoreExpr
250 mkWordExpr dflags w = mkCoreConApps wordDataCon [mkWordLit dflags w]
251
252 -- | Create a 'CoreExpr' which will evaluate to the given @Word@
253 mkWordExprWord :: DynFlags -> Word -> CoreExpr
254 mkWordExprWord dflags w = mkCoreConApps wordDataCon [mkWordLitWord dflags w]
255
256 -- | Create a 'CoreExpr' which will evaluate to the given @Integer@
257 mkIntegerExpr :: MonadThings m => Integer -> m CoreExpr -- Result :: Integer
258 mkIntegerExpr i = do t <- lookupTyCon integerTyConName
259 return (Lit (mkLitInteger i (mkTyConTy t)))
260
261 -- | Create a 'CoreExpr' which will evaluate to the given @Natural@
262 mkNaturalExpr :: MonadThings m => Integer -> m CoreExpr
263 mkNaturalExpr i = do t <- lookupTyCon naturalTyConName
264 return (Lit (mkLitNatural i (mkTyConTy t)))
265
266 -- | Create a 'CoreExpr' which will evaluate to the given @Float@
267 mkFloatExpr :: Float -> CoreExpr
268 mkFloatExpr f = mkCoreConApps floatDataCon [mkFloatLitFloat f]
269
270 -- | Create a 'CoreExpr' which will evaluate to the given @Double@
271 mkDoubleExpr :: Double -> CoreExpr
272 mkDoubleExpr d = mkCoreConApps doubleDataCon [mkDoubleLitDouble d]
273
274
275 -- | Create a 'CoreExpr' which will evaluate to the given @Char@
276 mkCharExpr :: Char -> CoreExpr -- Result = C# c :: Int
277 mkCharExpr c = mkCoreConApps charDataCon [mkCharLit c]
278
279 -- | Create a 'CoreExpr' which will evaluate to the given @String@
280 mkStringExpr :: MonadThings m => String -> m CoreExpr -- Result :: String
281
282 -- | Create a 'CoreExpr' which will evaluate to a string morally equivalent to the given @FastString@
283 mkStringExprFS :: MonadThings m => FastString -> m CoreExpr -- Result :: String
284
285 mkStringExpr str = mkStringExprFS (mkFastString str)
286
287 mkStringExprFS = mkStringExprFSWith lookupId
288
289 mkStringExprFSWith :: Monad m => (Name -> m Id) -> FastString -> m CoreExpr
290 mkStringExprFSWith lookupM str
291 | nullFS str
292 = return (mkNilExpr charTy)
293
294 | all safeChar chars
295 = do unpack_id <- lookupM unpackCStringName
296 return (App (Var unpack_id) lit)
297
298 | otherwise
299 = do unpack_utf8_id <- lookupM unpackCStringUtf8Name
300 return (App (Var unpack_utf8_id) lit)
301
302 where
303 chars = unpackFS str
304 safeChar c = ord c >= 1 && ord c <= 0x7F
305 lit = Lit (LitString (bytesFS str))
306
307 {-
308 ************************************************************************
309 * *
310 \subsection{Tuple constructors}
311 * *
312 ************************************************************************
313 -}
314
315 {-
316 Creating tuples and their types for Core expressions
317
318 @mkBigCoreVarTup@ builds a tuple; the inverse to @mkTupleSelector@.
319
320 * If it has only one element, it is the identity function.
321
322 * If there are more elements than a big tuple can have, it nests
323 the tuples.
324
325 Note [Flattening one-tuples]
326 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
327 This family of functions creates a tuple of variables/expressions/types.
328 mkCoreTup [e1,e2,e3] = (e1,e2,e3)
329 What if there is just one variable/expression/type in the argument?
330 We could do one of two things:
331
332 * Flatten it out, so that
333 mkCoreTup [e1] = e1
334
335 * Build a one-tuple (see Note [One-tuples] in TysWiredIn)
336 mkCoreTup1 [e1] = Unit e1
337 We use a suffix "1" to indicate this.
338
339 Usually we want the former, but occasionally the latter.
340 -}
341
342 -- | Build a small tuple holding the specified variables
343 -- One-tuples are flattened; see Note [Flattening one-tuples]
344 mkCoreVarTup :: [Id] -> CoreExpr
345 mkCoreVarTup ids = mkCoreTup (map Var ids)
346
347 -- | Build the type of a small tuple that holds the specified variables
348 -- One-tuples are flattened; see Note [Flattening one-tuples]
349 mkCoreVarTupTy :: [Id] -> Type
350 mkCoreVarTupTy ids = mkBoxedTupleTy (map idType ids)
351
352 -- | Build a small tuple holding the specified expressions
353 -- One-tuples are flattened; see Note [Flattening one-tuples]
354 mkCoreTup :: [CoreExpr] -> CoreExpr
355 mkCoreTup [] = Var unitDataConId
356 mkCoreTup [c] = c
357 mkCoreTup cs = mkCoreConApps (tupleDataCon Boxed (length cs))
358 (map (Type . exprType) cs ++ cs)
359
360 -- | Build a small unboxed tuple holding the specified expressions,
361 -- with the given types. The types must be the types of the expressions.
362 -- Do not include the RuntimeRep specifiers; this function calculates them
363 -- for you.
364 -- Does /not/ flatten one-tuples; see Note [Flattening one-tuples]
365 mkCoreUbxTup :: [Type] -> [CoreExpr] -> CoreExpr
366 mkCoreUbxTup tys exps
367 = ASSERT( tys `equalLength` exps)
368 mkCoreConApps (tupleDataCon Unboxed (length tys))
369 (map (Type . getRuntimeRep) tys ++ map Type tys ++ exps)
370
371 -- | Make a core tuple of the given boxity
372 mkCoreTupBoxity :: Boxity -> [CoreExpr] -> CoreExpr
373 mkCoreTupBoxity Boxed exps = mkCoreTup exps
374 mkCoreTupBoxity Unboxed exps = mkCoreUbxTup (map exprType exps) exps
375
376 -- | Build a big tuple holding the specified variables
377 -- One-tuples are flattened; see Note [Flattening one-tuples]
378 mkBigCoreVarTup :: [Id] -> CoreExpr
379 mkBigCoreVarTup ids = mkBigCoreTup (map Var ids)
380
381 mkBigCoreVarTup1 :: [Id] -> CoreExpr
382 -- Same as mkBigCoreVarTup, but one-tuples are NOT flattened
383 -- see Note [Flattening one-tuples]
384 mkBigCoreVarTup1 [id] = mkCoreConApps (tupleDataCon Boxed 1)
385 [Type (idType id), Var id]
386 mkBigCoreVarTup1 ids = mkBigCoreTup (map Var ids)
387
388 -- | Build the type of a big tuple that holds the specified variables
389 -- One-tuples are flattened; see Note [Flattening one-tuples]
390 mkBigCoreVarTupTy :: [Id] -> Type
391 mkBigCoreVarTupTy ids = mkBigCoreTupTy (map idType ids)
392
393 -- | Build a big tuple holding the specified expressions
394 -- One-tuples are flattened; see Note [Flattening one-tuples]
395 mkBigCoreTup :: [CoreExpr] -> CoreExpr
396 mkBigCoreTup = mkChunkified mkCoreTup
397
398 -- | Build the type of a big tuple that holds the specified type of thing
399 -- One-tuples are flattened; see Note [Flattening one-tuples]
400 mkBigCoreTupTy :: [Type] -> Type
401 mkBigCoreTupTy = mkChunkified mkBoxedTupleTy
402
403 -- | The unit expression
404 unitExpr :: CoreExpr
405 unitExpr = Var unitDataConId
406
407 {-
408 ************************************************************************
409 * *
410 \subsection{Tuple destructors}
411 * *
412 ************************************************************************
413 -}
414
415 -- | Builds a selector which scrutises the given
416 -- expression and extracts the one name from the list given.
417 -- If you want the no-shadowing rule to apply, the caller
418 -- is responsible for making sure that none of these names
419 -- are in scope.
420 --
421 -- If there is just one 'Id' in the tuple, then the selector is
422 -- just the identity.
423 --
424 -- If necessary, we pattern match on a \"big\" tuple.
425 mkTupleSelector, mkTupleSelector1
426 :: [Id] -- ^ The 'Id's to pattern match the tuple against
427 -> Id -- ^ The 'Id' to select
428 -> Id -- ^ A variable of the same type as the scrutinee
429 -> CoreExpr -- ^ Scrutinee
430 -> CoreExpr -- ^ Selector expression
431
432 -- mkTupleSelector [a,b,c,d] b v e
433 -- = case e of v {
434 -- (p,q) -> case p of p {
435 -- (a,b) -> b }}
436 -- We use 'tpl' vars for the p,q, since shadowing does not matter.
437 --
438 -- In fact, it's more convenient to generate it innermost first, getting
439 --
440 -- case (case e of v
441 -- (p,q) -> p) of p
442 -- (a,b) -> b
443 mkTupleSelector vars the_var scrut_var scrut
444 = mk_tup_sel (chunkify vars) the_var
445 where
446 mk_tup_sel [vars] the_var = mkSmallTupleSelector vars the_var scrut_var scrut
447 mk_tup_sel vars_s the_var = mkSmallTupleSelector group the_var tpl_v $
448 mk_tup_sel (chunkify tpl_vs) tpl_v
449 where
450 tpl_tys = [mkBoxedTupleTy (map idType gp) | gp <- vars_s]
451 tpl_vs = mkTemplateLocals tpl_tys
452 [(tpl_v, group)] = [(tpl,gp) | (tpl,gp) <- zipEqual "mkTupleSelector" tpl_vs vars_s,
453 the_var `elem` gp ]
454 -- ^ 'mkTupleSelector1' is like 'mkTupleSelector'
455 -- but one-tuples are NOT flattened (see Note [Flattening one-tuples])
456 mkTupleSelector1 vars the_var scrut_var scrut
457 | [_] <- vars
458 = mkSmallTupleSelector1 vars the_var scrut_var scrut
459 | otherwise
460 = mkTupleSelector vars the_var scrut_var scrut
461
462 -- | Like 'mkTupleSelector' but for tuples that are guaranteed
463 -- never to be \"big\".
464 --
465 -- > mkSmallTupleSelector [x] x v e = [| e |]
466 -- > mkSmallTupleSelector [x,y,z] x v e = [| case e of v { (x,y,z) -> x } |]
467 mkSmallTupleSelector, mkSmallTupleSelector1
468 :: [Id] -- The tuple args
469 -> Id -- The selected one
470 -> Id -- A variable of the same type as the scrutinee
471 -> CoreExpr -- Scrutinee
472 -> CoreExpr
473 mkSmallTupleSelector [var] should_be_the_same_var _ scrut
474 = ASSERT(var == should_be_the_same_var)
475 scrut -- Special case for 1-tuples
476 mkSmallTupleSelector vars the_var scrut_var scrut
477 = mkSmallTupleSelector1 vars the_var scrut_var scrut
478
479 -- ^ 'mkSmallTupleSelector1' is like 'mkSmallTupleSelector'
480 -- but one-tuples are NOT flattened (see Note [Flattening one-tuples])
481 mkSmallTupleSelector1 vars the_var scrut_var scrut
482 = ASSERT( notNull vars )
483 Case scrut scrut_var (idType the_var)
484 [(DataAlt (tupleDataCon Boxed (length vars)), vars, Var the_var)]
485
486 -- | A generalization of 'mkTupleSelector', allowing the body
487 -- of the case to be an arbitrary expression.
488 --
489 -- To avoid shadowing, we use uniques to invent new variables.
490 --
491 -- If necessary we pattern match on a \"big\" tuple.
492 mkTupleCase :: UniqSupply -- ^ For inventing names of intermediate variables
493 -> [Id] -- ^ The tuple identifiers to pattern match on
494 -> CoreExpr -- ^ Body of the case
495 -> Id -- ^ A variable of the same type as the scrutinee
496 -> CoreExpr -- ^ Scrutinee
497 -> CoreExpr
498 -- ToDo: eliminate cases where none of the variables are needed.
499 --
500 -- mkTupleCase uniqs [a,b,c,d] body v e
501 -- = case e of v { (p,q) ->
502 -- case p of p { (a,b) ->
503 -- case q of q { (c,d) ->
504 -- body }}}
505 mkTupleCase uniqs vars body scrut_var scrut
506 = mk_tuple_case uniqs (chunkify vars) body
507 where
508 -- This is the case where don't need any nesting
509 mk_tuple_case _ [vars] body
510 = mkSmallTupleCase vars body scrut_var scrut
511
512 -- This is the case where we must make nest tuples at least once
513 mk_tuple_case us vars_s body
514 = let (us', vars', body') = foldr one_tuple_case (us, [], body) vars_s
515 in mk_tuple_case us' (chunkify vars') body'
516
517 one_tuple_case chunk_vars (us, vs, body)
518 = let (uniq, us') = takeUniqFromSupply us
519 scrut_var = mkSysLocal (fsLit "ds") uniq
520 (mkBoxedTupleTy (map idType chunk_vars))
521 body' = mkSmallTupleCase chunk_vars body scrut_var (Var scrut_var)
522 in (us', scrut_var:vs, body')
523
524 -- | As 'mkTupleCase', but for a tuple that is small enough to be guaranteed
525 -- not to need nesting.
526 mkSmallTupleCase
527 :: [Id] -- ^ The tuple args
528 -> CoreExpr -- ^ Body of the case
529 -> Id -- ^ A variable of the same type as the scrutinee
530 -> CoreExpr -- ^ Scrutinee
531 -> CoreExpr
532
533 mkSmallTupleCase [var] body _scrut_var scrut
534 = bindNonRec var scrut body
535 mkSmallTupleCase vars body scrut_var scrut
536 -- One branch no refinement?
537 = Case scrut scrut_var (exprType body)
538 [(DataAlt (tupleDataCon Boxed (length vars)), vars, body)]
539
540 {-
541 ************************************************************************
542 * *
543 Floats
544 * *
545 ************************************************************************
546 -}
547
548 data FloatBind
549 = FloatLet CoreBind
550 | FloatCase CoreExpr Id AltCon [Var]
551 -- case e of y { C ys -> ... }
552 -- See Note [Floating single-alternative cases] in SetLevels
553
554 instance Outputable FloatBind where
555 ppr (FloatLet b) = text "LET" <+> ppr b
556 ppr (FloatCase e b c bs) = hang (text "CASE" <+> ppr e <+> ptext (sLit "of") <+> ppr b)
557 2 (ppr c <+> ppr bs)
558
559 wrapFloat :: FloatBind -> CoreExpr -> CoreExpr
560 wrapFloat (FloatLet defns) body = Let defns body
561 wrapFloat (FloatCase e b con bs) body = Case e b (exprType body) [(con, bs, body)]
562
563 -- | Applies the floats from right to left. That is @wrapFloats [b1, b2, …, bn]
564 -- u = let b1 in let b2 in … in let bn in u@
565 wrapFloats :: [FloatBind] -> CoreExpr -> CoreExpr
566 wrapFloats floats expr = foldr wrapFloat expr floats
567
568 bindBindings :: CoreBind -> [Var]
569 bindBindings (NonRec b _) = [b]
570 bindBindings (Rec bnds) = map fst bnds
571
572 floatBindings :: FloatBind -> [Var]
573 floatBindings (FloatLet bnd) = bindBindings bnd
574 floatBindings (FloatCase _ b _ bs) = b:bs
575
576 {-
577 ************************************************************************
578 * *
579 \subsection{Common list manipulation expressions}
580 * *
581 ************************************************************************
582
583 Call the constructor Ids when building explicit lists, so that they
584 interact well with rules.
585 -}
586
587 -- | Makes a list @[]@ for lists of the specified type
588 mkNilExpr :: Type -> CoreExpr
589 mkNilExpr ty = mkCoreConApps nilDataCon [Type ty]
590
591 -- | Makes a list @(:)@ for lists of the specified type
592 mkConsExpr :: Type -> CoreExpr -> CoreExpr -> CoreExpr
593 mkConsExpr ty hd tl = mkCoreConApps consDataCon [Type ty, hd, tl]
594
595 -- | Make a list containing the given expressions, where the list has the given type
596 mkListExpr :: Type -> [CoreExpr] -> CoreExpr
597 mkListExpr ty xs = foldr (mkConsExpr ty) (mkNilExpr ty) xs
598
599 -- | Make a fully applied 'foldr' expression
600 mkFoldrExpr :: MonadThings m
601 => Type -- ^ Element type of the list
602 -> Type -- ^ Fold result type
603 -> CoreExpr -- ^ "Cons" function expression for the fold
604 -> CoreExpr -- ^ "Nil" expression for the fold
605 -> CoreExpr -- ^ List expression being folded acress
606 -> m CoreExpr
607 mkFoldrExpr elt_ty result_ty c n list = do
608 foldr_id <- lookupId foldrName
609 return (Var foldr_id `App` Type elt_ty
610 `App` Type result_ty
611 `App` c
612 `App` n
613 `App` list)
614
615 -- | Make a 'build' expression applied to a locally-bound worker function
616 mkBuildExpr :: (MonadFail.MonadFail m, MonadThings m, MonadUnique m)
617 => Type -- ^ Type of list elements to be built
618 -> ((Id, Type) -> (Id, Type) -> m CoreExpr) -- ^ Function that, given information about the 'Id's
619 -- of the binders for the build worker function, returns
620 -- the body of that worker
621 -> m CoreExpr
622 mkBuildExpr elt_ty mk_build_inside = do
623 [n_tyvar] <- newTyVars [alphaTyVar]
624 let n_ty = mkTyVarTy n_tyvar
625 c_ty = mkVisFunTys [elt_ty, n_ty] n_ty
626 [c, n] <- sequence [mkSysLocalM (fsLit "c") c_ty, mkSysLocalM (fsLit "n") n_ty]
627
628 build_inside <- mk_build_inside (c, c_ty) (n, n_ty)
629
630 build_id <- lookupId buildName
631 return $ Var build_id `App` Type elt_ty `App` mkLams [n_tyvar, c, n] build_inside
632 where
633 newTyVars tyvar_tmpls = do
634 uniqs <- getUniquesM
635 return (zipWith setTyVarUnique tyvar_tmpls uniqs)
636
637 {-
638 ************************************************************************
639 * *
640 Manipulating Maybe data type
641 * *
642 ************************************************************************
643 -}
644
645
646 -- | Makes a Nothing for the specified type
647 mkNothingExpr :: Type -> CoreExpr
648 mkNothingExpr ty = mkConApp nothingDataCon [Type ty]
649
650 -- | Makes a Just from a value of the specified type
651 mkJustExpr :: Type -> CoreExpr -> CoreExpr
652 mkJustExpr ty val = mkConApp justDataCon [Type ty, val]
653
654
655 {-
656 ************************************************************************
657 * *
658 Error expressions
659 * *
660 ************************************************************************
661 -}
662
663 mkRuntimeErrorApp
664 :: Id -- Should be of type (forall a. Addr# -> a)
665 -- where Addr# points to a UTF8 encoded string
666 -> Type -- The type to instantiate 'a'
667 -> String -- The string to print
668 -> CoreExpr
669
670 mkRuntimeErrorApp err_id res_ty err_msg
671 = mkApps (Var err_id) [ Type (getRuntimeRep res_ty)
672 , Type res_ty, err_string ]
673 where
674 err_string = Lit (mkLitString err_msg)
675
676 mkImpossibleExpr :: Type -> CoreExpr
677 mkImpossibleExpr res_ty
678 = mkRuntimeErrorApp rUNTIME_ERROR_ID res_ty "Impossible case alternative"
679
680 {-
681 ************************************************************************
682 * *
683 Error Ids
684 * *
685 ************************************************************************
686
687 GHC randomly injects these into the code.
688
689 @patError@ is just a version of @error@ for pattern-matching
690 failures. It knows various ``codes'' which expand to longer
691 strings---this saves space!
692
693 @absentErr@ is a thing we put in for ``absent'' arguments. They jolly
694 well shouldn't be yanked on, but if one is, then you will get a
695 friendly message from @absentErr@ (rather than a totally random
696 crash).
697
698 @parError@ is a special version of @error@ which the compiler does
699 not know to be a bottoming Id. It is used in the @_par_@ and @_seq_@
700 templates, but we don't ever expect to generate code for it.
701 -}
702
703 errorIds :: [Id]
704 errorIds
705 = [ rUNTIME_ERROR_ID,
706 nON_EXHAUSTIVE_GUARDS_ERROR_ID,
707 nO_METHOD_BINDING_ERROR_ID,
708 pAT_ERROR_ID,
709 rEC_CON_ERROR_ID,
710 rEC_SEL_ERROR_ID,
711 aBSENT_ERROR_ID,
712 tYPE_ERROR_ID -- Used with Opt_DeferTypeErrors, see #10284
713 ]
714
715 recSelErrorName, runtimeErrorName, absentErrorName :: Name
716 recConErrorName, patErrorName :: Name
717 nonExhaustiveGuardsErrorName, noMethodBindingErrorName :: Name
718 typeErrorName :: Name
719 absentSumFieldErrorName :: Name
720
721 recSelErrorName = err_nm "recSelError" recSelErrorIdKey rEC_SEL_ERROR_ID
722 absentErrorName = err_nm "absentError" absentErrorIdKey aBSENT_ERROR_ID
723 absentSumFieldErrorName = err_nm "absentSumFieldError" absentSumFieldErrorIdKey
724 aBSENT_SUM_FIELD_ERROR_ID
725 runtimeErrorName = err_nm "runtimeError" runtimeErrorIdKey rUNTIME_ERROR_ID
726 recConErrorName = err_nm "recConError" recConErrorIdKey rEC_CON_ERROR_ID
727 patErrorName = err_nm "patError" patErrorIdKey pAT_ERROR_ID
728 typeErrorName = err_nm "typeError" typeErrorIdKey tYPE_ERROR_ID
729
730 noMethodBindingErrorName = err_nm "noMethodBindingError"
731 noMethodBindingErrorIdKey nO_METHOD_BINDING_ERROR_ID
732 nonExhaustiveGuardsErrorName = err_nm "nonExhaustiveGuardsError"
733 nonExhaustiveGuardsErrorIdKey nON_EXHAUSTIVE_GUARDS_ERROR_ID
734
735 err_nm :: String -> Unique -> Id -> Name
736 err_nm str uniq id = mkWiredInIdName cONTROL_EXCEPTION_BASE (fsLit str) uniq id
737
738 rEC_SEL_ERROR_ID, rUNTIME_ERROR_ID, rEC_CON_ERROR_ID :: Id
739 pAT_ERROR_ID, nO_METHOD_BINDING_ERROR_ID, nON_EXHAUSTIVE_GUARDS_ERROR_ID :: Id
740 tYPE_ERROR_ID, aBSENT_ERROR_ID, aBSENT_SUM_FIELD_ERROR_ID :: Id
741 rEC_SEL_ERROR_ID = mkRuntimeErrorId recSelErrorName
742 rUNTIME_ERROR_ID = mkRuntimeErrorId runtimeErrorName
743 rEC_CON_ERROR_ID = mkRuntimeErrorId recConErrorName
744 pAT_ERROR_ID = mkRuntimeErrorId patErrorName
745 nO_METHOD_BINDING_ERROR_ID = mkRuntimeErrorId noMethodBindingErrorName
746 nON_EXHAUSTIVE_GUARDS_ERROR_ID = mkRuntimeErrorId nonExhaustiveGuardsErrorName
747 tYPE_ERROR_ID = mkRuntimeErrorId typeErrorName
748
749 -- Note [aBSENT_SUM_FIELD_ERROR_ID]
750 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
751 -- Absent argument error for unused unboxed sum fields are different than absent
752 -- error used in dummy worker functions (see `mkAbsentErrorApp`):
753 --
754 -- - `absentSumFieldError` can't take arguments because it's used in unarise for
755 -- unused pointer fields in unboxed sums, and applying an argument would
756 -- require allocating a thunk.
757 --
758 -- - `absentSumFieldError` can't be CAFFY because that would mean making some
759 -- non-CAFFY definitions that use unboxed sums CAFFY in unarise.
760 --
761 -- To make `absentSumFieldError` non-CAFFY we get a stable pointer to it in
762 -- RtsStartup.c and mark it as non-CAFFY here.
763 --
764 -- Getting this wrong causes hard-to-debug runtime issues, see #15038.
765 --
766 -- TODO: Remove stable pointer hack after fixing #9718.
767 -- However, we should still be careful about not making things CAFFY just
768 -- because they use unboxed sums. Unboxed objects are supposed to be
769 -- efficient, and none of the other unboxed literals make things CAFFY.
770
771 aBSENT_SUM_FIELD_ERROR_ID
772 = mkVanillaGlobalWithInfo absentSumFieldErrorName
773 (mkSpecForAllTys [alphaTyVar] (mkTyVarTy alphaTyVar)) -- forall a . a
774 (vanillaIdInfo `setStrictnessInfo` mkClosedStrictSig [] botRes
775 `setArityInfo` 0
776 `setCafInfo` NoCafRefs) -- #15038
777
778 mkRuntimeErrorId :: Name -> Id
779 -- Error function
780 -- with type: forall (r:RuntimeRep) (a:TYPE r). Addr# -> a
781 -- with arity: 1
782 -- which diverges after being given one argument
783 -- The Addr# is expected to be the address of
784 -- a UTF8-encoded error string
785 mkRuntimeErrorId name
786 = mkVanillaGlobalWithInfo name runtimeErrorTy bottoming_info
787 where
788 bottoming_info = vanillaIdInfo `setStrictnessInfo` strict_sig
789 `setArityInfo` 1
790 -- Make arity and strictness agree
791
792 -- Do *not* mark them as NoCafRefs, because they can indeed have
793 -- CAF refs. For example, pAT_ERROR_ID calls GHC.Err.untangle,
794 -- which has some CAFs
795 -- In due course we may arrange that these error-y things are
796 -- regarded by the GC as permanently live, in which case we
797 -- can give them NoCaf info. As it is, any function that calls
798 -- any pc_bottoming_Id will itself have CafRefs, which bloats
799 -- SRTs.
800
801 strict_sig = mkClosedStrictSig [evalDmd] botRes
802
803 runtimeErrorTy :: Type
804 -- forall (rr :: RuntimeRep) (a :: rr). Addr# -> a
805 -- See Note [Error and friends have an "open-tyvar" forall]
806 runtimeErrorTy = mkSpecForAllTys [runtimeRep1TyVar, openAlphaTyVar]
807 (mkVisFunTy addrPrimTy openAlphaTy)
808
809 {- Note [Error and friends have an "open-tyvar" forall]
810 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
811 'error' and 'undefined' have types
812 error :: forall (v :: RuntimeRep) (a :: TYPE v). String -> a
813 undefined :: forall (v :: RuntimeRep) (a :: TYPE v). a
814 Notice the runtime-representation polymorphism. This ensures that
815 "error" can be instantiated at unboxed as well as boxed types.
816 This is OK because it never returns, so the return type is irrelevant.
817
818
819 ************************************************************************
820 * *
821 aBSENT_ERROR_ID
822 * *
823 ************************************************************************
824
825 Note [aBSENT_ERROR_ID]
826 ~~~~~~~~~~~~~~~~~~~~~~
827 We use aBSENT_ERROR_ID to build dummy values in workers. E.g.
828
829 f x = (case x of (a,b) -> b) + 1::Int
830
831 The demand analyser figures ot that only the second component of x is
832 used, and does a w/w split thus
833
834 f x = case x of (a,b) -> $wf b
835
836 $wf b = let a = absentError "blah"
837 x = (a,b)
838 in <the original RHS of f>
839
840 After some simplification, the (absentError "blah") thunk goes away.
841
842 ------ Tricky wrinkle -------
843 Trac #14285 had, roughly
844
845 data T a = MkT a !a
846 {-# INLINABLE f #-}
847 f x = case x of MkT a b -> g (MkT b a)
848
849 It turned out that g didn't use the second component, and hence f doesn't use
850 the first. But the stable-unfolding for f looks like
851 \x. case x of MkT a b -> g ($WMkT b a)
852 where $WMkT is the wrapper for MkT that evaluates its arguments. We
853 apply the same w/w split to this unfolding (see Note [Worker-wrapper
854 for INLINEABLE functions] in WorkWrap) so the template ends up like
855 \b. let a = absentError "blah"
856 x = MkT a b
857 in case x of MkT a b -> g ($WMkT b a)
858
859 After doing case-of-known-constructor, and expanding $WMkT we get
860 \b -> g (case absentError "blah" of a -> MkT b a)
861
862 Yikes! That bogusly appears to evaluate the absentError!
863
864 This is extremely tiresome. Another way to think of this is that, in
865 Core, it is an invariant that a strict data contructor, like MkT, must
866 be applied only to an argument in HNF. So (absentError "blah") had
867 better be non-bottom.
868
869 So the "solution" is to add a special case for absentError to exprIsHNFlike.
870 This allows Simplify.rebuildCase, in the Note [Case to let transformation]
871 branch, to convert the case on absentError into a let. We also make
872 absentError *not* be diverging, unlike the other error-ids, so that we
873 can be sure not to remove the case branches before converting the case to
874 a let.
875
876 If, by some bug or bizarre happenstance, we ever call absentError, we should
877 throw an exception. This should never happen, of course, but we definitely
878 can't return anything. e.g. if somehow we had
879 case absentError "foo" of
880 Nothing -> ...
881 Just x -> ...
882 then if we return, the case expression will select a field and continue.
883 Seg fault city. Better to throw an exception. (Even though we've said
884 it is in HNF :-)
885
886 It might seem a bit surprising that seq on absentError is simply erased
887
888 absentError "foo" `seq` x ==> x
889
890 but that should be okay; since there's no pattern match we can't really
891 be relying on anything from it.
892 -}
893
894 aBSENT_ERROR_ID
895 = mkVanillaGlobalWithInfo absentErrorName absent_ty arity_info
896 where
897 absent_ty = mkSpecForAllTys [alphaTyVar] (mkVisFunTy addrPrimTy alphaTy)
898 -- Not runtime-rep polymorphic. aBSENT_ERROR_ID is only used for
899 -- lifted-type things; see Note [Absent errors] in WwLib
900 arity_info = vanillaIdInfo `setArityInfo` 1
901 -- NB: no bottoming strictness info, unlike other error-ids.
902 -- See Note [aBSENT_ERROR_ID]
903
904 mkAbsentErrorApp :: Type -- The type to instantiate 'a'
905 -> String -- The string to print
906 -> CoreExpr
907
908 mkAbsentErrorApp res_ty err_msg
909 = mkApps (Var aBSENT_ERROR_ID) [ Type res_ty, err_string ]
910 where
911 err_string = Lit (mkLitString err_msg)