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