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