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