Add 'hadrian/' from commit '45f3bff7016a2a0cd9a5455a882ced984655e90b'
[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,
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 ( 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 = toposortTyVars 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 (MachStr (fastStringToByteString 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 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 {-
564 ************************************************************************
565 * *
566 \subsection{Common list manipulation expressions}
567 * *
568 ************************************************************************
569
570 Call the constructor Ids when building explicit lists, so that they
571 interact well with rules.
572 -}
573
574 -- | Makes a list @[]@ for lists of the specified type
575 mkNilExpr :: Type -> CoreExpr
576 mkNilExpr ty = mkCoreConApps nilDataCon [Type ty]
577
578 -- | Makes a list @(:)@ for lists of the specified type
579 mkConsExpr :: Type -> CoreExpr -> CoreExpr -> CoreExpr
580 mkConsExpr ty hd tl = mkCoreConApps consDataCon [Type ty, hd, tl]
581
582 -- | Make a list containing the given expressions, where the list has the given type
583 mkListExpr :: Type -> [CoreExpr] -> CoreExpr
584 mkListExpr ty xs = foldr (mkConsExpr ty) (mkNilExpr ty) xs
585
586 -- | Make a fully applied 'foldr' expression
587 mkFoldrExpr :: MonadThings m
588 => Type -- ^ Element type of the list
589 -> Type -- ^ Fold result type
590 -> CoreExpr -- ^ "Cons" function expression for the fold
591 -> CoreExpr -- ^ "Nil" expression for the fold
592 -> CoreExpr -- ^ List expression being folded acress
593 -> m CoreExpr
594 mkFoldrExpr elt_ty result_ty c n list = do
595 foldr_id <- lookupId foldrName
596 return (Var foldr_id `App` Type elt_ty
597 `App` Type result_ty
598 `App` c
599 `App` n
600 `App` list)
601
602 -- | Make a 'build' expression applied to a locally-bound worker function
603 mkBuildExpr :: (MonadFail m, MonadThings m, MonadUnique m)
604 => Type -- ^ Type of list elements to be built
605 -> ((Id, Type) -> (Id, Type) -> m CoreExpr) -- ^ Function that, given information about the 'Id's
606 -- of the binders for the build worker function, returns
607 -- the body of that worker
608 -> m CoreExpr
609 mkBuildExpr elt_ty mk_build_inside = do
610 [n_tyvar] <- newTyVars [alphaTyVar]
611 let n_ty = mkTyVarTy n_tyvar
612 c_ty = mkFunTys [elt_ty, n_ty] n_ty
613 [c, n] <- sequence [mkSysLocalM (fsLit "c") c_ty, mkSysLocalM (fsLit "n") n_ty]
614
615 build_inside <- mk_build_inside (c, c_ty) (n, n_ty)
616
617 build_id <- lookupId buildName
618 return $ Var build_id `App` Type elt_ty `App` mkLams [n_tyvar, c, n] build_inside
619 where
620 newTyVars tyvar_tmpls = do
621 uniqs <- getUniquesM
622 return (zipWith setTyVarUnique tyvar_tmpls uniqs)
623
624 {-
625 ************************************************************************
626 * *
627 Manipulating Maybe data type
628 * *
629 ************************************************************************
630 -}
631
632
633 -- | Makes a Nothing for the specified type
634 mkNothingExpr :: Type -> CoreExpr
635 mkNothingExpr ty = mkConApp nothingDataCon [Type ty]
636
637 -- | Makes a Just from a value of the specified type
638 mkJustExpr :: Type -> CoreExpr -> CoreExpr
639 mkJustExpr ty val = mkConApp justDataCon [Type ty, val]
640
641
642 {-
643 ************************************************************************
644 * *
645 Error expressions
646 * *
647 ************************************************************************
648 -}
649
650 mkRuntimeErrorApp
651 :: Id -- Should be of type (forall a. Addr# -> a)
652 -- where Addr# points to a UTF8 encoded string
653 -> Type -- The type to instantiate 'a'
654 -> String -- The string to print
655 -> CoreExpr
656
657 mkRuntimeErrorApp err_id res_ty err_msg
658 = mkApps (Var err_id) [ Type (getRuntimeRep res_ty)
659 , Type res_ty, err_string ]
660 where
661 err_string = Lit (mkMachString err_msg)
662
663 mkImpossibleExpr :: Type -> CoreExpr
664 mkImpossibleExpr res_ty
665 = mkRuntimeErrorApp rUNTIME_ERROR_ID res_ty "Impossible case alternative"
666
667 {-
668 ************************************************************************
669 * *
670 Error Ids
671 * *
672 ************************************************************************
673
674 GHC randomly injects these into the code.
675
676 @patError@ is just a version of @error@ for pattern-matching
677 failures. It knows various ``codes'' which expand to longer
678 strings---this saves space!
679
680 @absentErr@ is a thing we put in for ``absent'' arguments. They jolly
681 well shouldn't be yanked on, but if one is, then you will get a
682 friendly message from @absentErr@ (rather than a totally random
683 crash).
684
685 @parError@ is a special version of @error@ which the compiler does
686 not know to be a bottoming Id. It is used in the @_par_@ and @_seq_@
687 templates, but we don't ever expect to generate code for it.
688 -}
689
690 errorIds :: [Id]
691 errorIds
692 = [ rUNTIME_ERROR_ID,
693 nON_EXHAUSTIVE_GUARDS_ERROR_ID,
694 nO_METHOD_BINDING_ERROR_ID,
695 pAT_ERROR_ID,
696 rEC_CON_ERROR_ID,
697 rEC_SEL_ERROR_ID,
698 aBSENT_ERROR_ID,
699 tYPE_ERROR_ID -- Used with Opt_DeferTypeErrors, see #10284
700 ]
701
702 recSelErrorName, runtimeErrorName, absentErrorName :: Name
703 recConErrorName, patErrorName :: Name
704 nonExhaustiveGuardsErrorName, noMethodBindingErrorName :: Name
705 typeErrorName :: Name
706 absentSumFieldErrorName :: Name
707
708 recSelErrorName = err_nm "recSelError" recSelErrorIdKey rEC_SEL_ERROR_ID
709 absentErrorName = err_nm "absentError" absentErrorIdKey aBSENT_ERROR_ID
710 absentSumFieldErrorName = err_nm "absentSumFieldError" absentSumFieldErrorIdKey
711 aBSENT_SUM_FIELD_ERROR_ID
712 runtimeErrorName = err_nm "runtimeError" runtimeErrorIdKey rUNTIME_ERROR_ID
713 recConErrorName = err_nm "recConError" recConErrorIdKey rEC_CON_ERROR_ID
714 patErrorName = err_nm "patError" patErrorIdKey pAT_ERROR_ID
715 typeErrorName = err_nm "typeError" typeErrorIdKey tYPE_ERROR_ID
716
717 noMethodBindingErrorName = err_nm "noMethodBindingError"
718 noMethodBindingErrorIdKey nO_METHOD_BINDING_ERROR_ID
719 nonExhaustiveGuardsErrorName = err_nm "nonExhaustiveGuardsError"
720 nonExhaustiveGuardsErrorIdKey nON_EXHAUSTIVE_GUARDS_ERROR_ID
721
722 err_nm :: String -> Unique -> Id -> Name
723 err_nm str uniq id = mkWiredInIdName cONTROL_EXCEPTION_BASE (fsLit str) uniq id
724
725 rEC_SEL_ERROR_ID, rUNTIME_ERROR_ID, rEC_CON_ERROR_ID :: Id
726 pAT_ERROR_ID, nO_METHOD_BINDING_ERROR_ID, nON_EXHAUSTIVE_GUARDS_ERROR_ID :: Id
727 tYPE_ERROR_ID, aBSENT_ERROR_ID, aBSENT_SUM_FIELD_ERROR_ID :: Id
728 rEC_SEL_ERROR_ID = mkRuntimeErrorId recSelErrorName
729 rUNTIME_ERROR_ID = mkRuntimeErrorId runtimeErrorName
730 rEC_CON_ERROR_ID = mkRuntimeErrorId recConErrorName
731 pAT_ERROR_ID = mkRuntimeErrorId patErrorName
732 nO_METHOD_BINDING_ERROR_ID = mkRuntimeErrorId noMethodBindingErrorName
733 nON_EXHAUSTIVE_GUARDS_ERROR_ID = mkRuntimeErrorId nonExhaustiveGuardsErrorName
734 tYPE_ERROR_ID = mkRuntimeErrorId typeErrorName
735
736 -- Note [aBSENT_SUM_FIELD_ERROR_ID]
737 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
738 -- Absent argument error for unused unboxed sum fields are different than absent
739 -- error used in dummy worker functions (see `mkAbsentErrorApp`):
740 --
741 -- - `absentSumFieldError` can't take arguments because it's used in unarise for
742 -- unused pointer fields in unboxed sums, and applying an argument would
743 -- require allocating a thunk.
744 --
745 -- - `absentSumFieldError` can't be CAFFY because that would mean making some
746 -- non-CAFFY definitions that use unboxed sums CAFFY in unarise.
747 --
748 -- To make `absentSumFieldError` non-CAFFY we get a stable pointer to it in
749 -- RtsStartup.c and mark it as non-CAFFY here.
750 --
751 -- Getting this wrong causes hard-to-debug runtime issues, see #15038.
752 --
753 -- TODO: Remove stable pointer hack after fixing #9718.
754 -- However, we should still be careful about not making things CAFFY just
755 -- because they use unboxed sums. Unboxed objects are supposed to be
756 -- efficient, and none of the other unboxed literals make things CAFFY.
757
758 aBSENT_SUM_FIELD_ERROR_ID
759 = mkVanillaGlobalWithInfo absentSumFieldErrorName
760 (mkSpecForAllTys [alphaTyVar] (mkTyVarTy alphaTyVar)) -- forall a . a
761 (vanillaIdInfo `setStrictnessInfo` mkClosedStrictSig [] exnRes
762 `setArityInfo` 0
763 `setCafInfo` NoCafRefs) -- #15038
764
765 mkRuntimeErrorId :: Name -> Id
766 -- Error function
767 -- with type: forall (r:RuntimeRep) (a:TYPE r). Addr# -> a
768 -- with arity: 1
769 -- which diverges after being given one argument
770 -- The Addr# is expected to be the address of
771 -- a UTF8-encoded error string
772 mkRuntimeErrorId name
773 = mkVanillaGlobalWithInfo name runtimeErrorTy bottoming_info
774 where
775 bottoming_info = vanillaIdInfo `setStrictnessInfo` strict_sig
776 `setArityInfo` 1
777 -- Make arity and strictness agree
778
779 -- Do *not* mark them as NoCafRefs, because they can indeed have
780 -- CAF refs. For example, pAT_ERROR_ID calls GHC.Err.untangle,
781 -- which has some CAFs
782 -- In due course we may arrange that these error-y things are
783 -- regarded by the GC as permanently live, in which case we
784 -- can give them NoCaf info. As it is, any function that calls
785 -- any pc_bottoming_Id will itself have CafRefs, which bloats
786 -- SRTs.
787
788 strict_sig = mkClosedStrictSig [evalDmd] exnRes
789 -- exnRes: these throw an exception, not just diverge
790
791 runtimeErrorTy :: Type
792 -- forall (rr :: RuntimeRep) (a :: rr). Addr# -> a
793 -- See Note [Error and friends have an "open-tyvar" forall]
794 runtimeErrorTy = mkSpecForAllTys [runtimeRep1TyVar, openAlphaTyVar]
795 (mkFunTy addrPrimTy openAlphaTy)
796
797 {- Note [Error and friends have an "open-tyvar" forall]
798 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
799 'error' and 'undefined' have types
800 error :: forall (v :: RuntimeRep) (a :: TYPE v). String -> a
801 undefined :: forall (v :: RuntimeRep) (a :: TYPE v). a
802 Notice the runtime-representation polymorphism. This ensures that
803 "error" can be instantiated at unboxed as well as boxed types.
804 This is OK because it never returns, so the return type is irrelevant.
805
806
807 ************************************************************************
808 * *
809 aBSENT_ERROR_ID
810 * *
811 ************************************************************************
812
813 Note [aBSENT_ERROR_ID]
814 ~~~~~~~~~~~~~~~~~~~~~~
815 We use aBSENT_ERROR_ID to build dummy values in workers. E.g.
816
817 f x = (case x of (a,b) -> b) + 1::Int
818
819 The demand analyser figures ot that only the second component of x is
820 used, and does a w/w split thus
821
822 f x = case x of (a,b) -> $wf b
823
824 $wf b = let a = absentError "blah"
825 x = (a,b)
826 in <the original RHS of f>
827
828 After some simplification, the (absentError "blah") thunk goes away.
829
830 ------ Tricky wrinkle -------
831 Trac #14285 had, roughly
832
833 data T a = MkT a !a
834 {-# INLINABLE f #-}
835 f x = case x of MkT a b -> g (MkT b a)
836
837 It turned out that g didn't use the second component, and hence f doesn't use
838 the first. But the stable-unfolding for f looks like
839 \x. case x of MkT a b -> g ($WMkT b a)
840 where $WMkT is the wrapper for MkT that evaluates its arguments. We
841 apply the same w/w split to this unfolding (see Note [Worker-wrapper
842 for INLINEABLE functions] in WorkWrap) so the template ends up like
843 \b. let a = absentError "blah"
844 x = MkT a b
845 in case x of MkT a b -> g ($WMkT b a)
846
847 After doing case-of-known-constructor, and expanding $WMkT we get
848 \b -> g (case absentError "blah" of a -> MkT b a)
849
850 Yikes! That bogusly appears to evaluate the absentError!
851
852 This is extremely tiresome. Another way to think of this is that, in
853 Core, it is an invariant that a strict data contructor, like MkT, must
854 be applied only to an argument in HNF. So (absentError "blah") had
855 better be non-bottom.
856
857 So the "solution" is to add a special case for absentError to exprIsHNFlike.
858 This allows Simplify.rebuildCase, in the Note [Case to let transformation]
859 branch, to convert the case on absentError into a let. We also make
860 absentError *not* be diverging, unlike the other error-ids, so that we
861 can be sure not to remove the case branches before converting the case to
862 a let.
863
864 If, by some bug or bizarre happenstance, we ever call absentError, we should
865 throw an exception. This should never happen, of course, but we definitely
866 can't return anything. e.g. if somehow we had
867 case absentError "foo" of
868 Nothing -> ...
869 Just x -> ...
870 then if we return, the case expression will select a field and continue.
871 Seg fault city. Better to throw an exception. (Even though we've said
872 it is in HNF :-)
873
874 It might seem a bit surprising that seq on absentError is simply erased
875
876 absentError "foo" `seq` x ==> x
877
878 but that should be okay; since there's no pattern match we can't really
879 be relying on anything from it.
880 -}
881
882 aBSENT_ERROR_ID
883 = mkVanillaGlobalWithInfo absentErrorName absent_ty arity_info
884 where
885 absent_ty = mkSpecForAllTys [alphaTyVar] (mkFunTy addrPrimTy alphaTy)
886 -- Not runtime-rep polymorphic. aBSENT_ERROR_ID is only used for
887 -- lifted-type things; see Note [Absent errors] in WwLib
888 arity_info = vanillaIdInfo `setArityInfo` 1
889 -- NB: no bottoming strictness info, unlike other error-ids.
890 -- See Note [aBSENT_ERROR_ID]
891
892 mkAbsentErrorApp :: Type -- The type to instantiate 'a'
893 -> String -- The string to print
894 -> CoreExpr
895
896 mkAbsentErrorApp res_ty err_msg
897 = mkApps (Var aBSENT_ERROR_ID) [ Type res_ty, err_string ]
898 where
899 err_string = Lit (mkMachString err_msg)