8bdee4ae5f35c662411b0936f1bb2369cdfcc5f1
[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 equality evidence boxes
23 mkEqBox,
24
25 -- * Constructing general big tuples
26 -- $big_tuples
27 mkChunkified,
28
29 -- * Constructing small tuples
30 mkCoreVarTup, mkCoreVarTupTy, mkCoreTup,
31
32 -- * Constructing big tuples
33 mkBigCoreVarTup, mkBigCoreVarTupTy,
34 mkBigCoreTup, mkBigCoreTupTy,
35
36 -- * Deconstructing small tuples
37 mkSmallTupleSelector, mkSmallTupleCase,
38
39 -- * Deconstructing big tuples
40 mkTupleSelector, mkTupleCase,
41
42 -- * Constructing list expressions
43 mkNilExpr, mkConsExpr, mkListExpr,
44 mkFoldrExpr, mkBuildExpr,
45
46 -- * Error Ids
47 mkRuntimeErrorApp, mkImpossibleExpr, errorIds,
48 rEC_CON_ERROR_ID, iRREFUT_PAT_ERROR_ID, rUNTIME_ERROR_ID,
49 nON_EXHAUSTIVE_GUARDS_ERROR_ID, nO_METHOD_BINDING_ERROR_ID,
50 pAT_ERROR_ID, eRROR_ID, rEC_SEL_ERROR_ID, aBSENT_ERROR_ID,
51 uNDEFINED_ID, tYPE_ERROR_ID, undefinedName
52 ) where
53
54 #include "HsVersions.h"
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 TcType ( mkSigmaTy )
68 import Type
69 import Coercion
70 import TysPrim
71 import DataCon ( DataCon, dataConWorkId )
72 import IdInfo ( vanillaIdInfo, setStrictnessInfo,
73 setArityInfo )
74 import Demand
75 import Name hiding ( varName )
76 import Outputable
77 import FastString
78 import UniqSupply
79 import BasicTypes
80 import Util
81 import Pair
82 import Constants
83 import DynFlags
84
85 import Data.Char ( ord )
86 import Data.List
87 import Data.Ord
88 #if __GLASGOW_HASKELL__ < 709
89 import Data.Word ( Word )
90 #endif
91
92 infixl 4 `mkCoreApp`, `mkCoreApps`
93
94 {-
95 ************************************************************************
96 * *
97 \subsection{Basic CoreSyn construction}
98 * *
99 ************************************************************************
100 -}
101
102 sortQuantVars :: [Var] -> [Var]
103 -- Sort the variables (KindVars, TypeVars, and Ids)
104 -- into order: Kind, then Type, then Id
105 sortQuantVars = sortBy (comparing withCategory)
106 where
107 withCategory v = (category v, v)
108 category :: Var -> Int
109 category v
110 | isKindVar v = 1
111 | isTyVar v = 2
112 | otherwise = 3
113
114 -- | Bind a binding group over an expression, using a @let@ or @case@ as
115 -- appropriate (see "CoreSyn#let_app_invariant")
116 mkCoreLet :: CoreBind -> CoreExpr -> CoreExpr
117 mkCoreLet (NonRec bndr rhs) body -- See Note [CoreSyn let/app invariant]
118 | needsCaseBinding (idType bndr) rhs
119 = Case rhs bndr (exprType body) [(DEFAULT,[],body)]
120 mkCoreLet bind body
121 = Let bind body
122
123 -- | Bind a list of binding groups over an expression. The leftmost binding
124 -- group becomes the outermost group in the resulting expression
125 mkCoreLets :: [CoreBind] -> CoreExpr -> CoreExpr
126 mkCoreLets binds body = foldr mkCoreLet body binds
127
128 -- | Construct an expression which represents the application of one expression
129 -- to the other
130 mkCoreApp :: CoreExpr -> CoreExpr -> CoreExpr
131 -- Respects the let/app invariant by building a case expression where necessary
132 -- See CoreSyn Note [CoreSyn let/app invariant]
133 mkCoreApp fun (Type ty) = App fun (Type ty)
134 mkCoreApp fun (Coercion co) = App fun (Coercion co)
135 mkCoreApp fun arg = ASSERT2( isFunTy fun_ty, ppr fun $$ ppr arg )
136 mk_val_app fun arg arg_ty res_ty
137 where
138 fun_ty = exprType fun
139 (arg_ty, res_ty) = splitFunTy fun_ty
140
141 -- | Construct an expression which represents the application of a number of
142 -- expressions to another. The leftmost expression in the list is applied first
143 -- Respects the let/app invariant by building a case expression where necessary
144 -- See CoreSyn Note [CoreSyn let/app invariant]
145 mkCoreApps :: CoreExpr -> [CoreExpr] -> CoreExpr
146 -- Slightly more efficient version of (foldl mkCoreApp)
147 mkCoreApps orig_fun orig_args
148 = go orig_fun (exprType orig_fun) orig_args
149 where
150 go fun _ [] = fun
151 go fun fun_ty (Type ty : args) = go (App fun (Type ty)) (applyTy fun_ty ty) args
152 go fun fun_ty (Coercion co : args) = go (App fun (Coercion co)) (applyCo fun_ty co) args
153 go fun fun_ty (arg : args) = ASSERT2( isFunTy fun_ty, ppr fun_ty $$ ppr orig_fun
154 $$ ppr orig_args )
155 go (mk_val_app fun arg arg_ty res_ty) res_ty args
156 where
157 (arg_ty, res_ty) = splitFunTy fun_ty
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 -- have 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 -- fragmet 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 = mkLocalId 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 = mkConApp 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 = mkConApp 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 = mkConApp 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 = mkConApp 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 @Float@
263 mkFloatExpr :: Float -> CoreExpr
264 mkFloatExpr f = mkConApp floatDataCon [mkFloatLitFloat f]
265
266 -- | Create a 'CoreExpr' which will evaluate to the given @Double@
267 mkDoubleExpr :: Double -> CoreExpr
268 mkDoubleExpr d = mkConApp doubleDataCon [mkDoubleLitDouble d]
269
270
271 -- | Create a 'CoreExpr' which will evaluate to the given @Char@
272 mkCharExpr :: Char -> CoreExpr -- Result = C# c :: Int
273 mkCharExpr c = mkConApp charDataCon [mkCharLit c]
274
275 -- | Create a 'CoreExpr' which will evaluate to the given @String@
276 mkStringExpr :: MonadThings m => String -> m CoreExpr -- Result :: String
277
278 -- | Create a 'CoreExpr' which will evaluate to a string morally equivalent to the given @FastString@
279 mkStringExprFS :: MonadThings m => FastString -> m CoreExpr -- Result :: String
280
281 mkStringExpr str = mkStringExprFS (mkFastString str)
282
283 mkStringExprFS str
284 | nullFS str
285 = return (mkNilExpr charTy)
286
287 | all safeChar chars
288 = do unpack_id <- lookupId unpackCStringName
289 return (App (Var unpack_id) (Lit (MachStr (fastStringToByteString str))))
290
291 | otherwise
292 = do unpack_id <- lookupId unpackCStringUtf8Name
293 return (App (Var unpack_id) (Lit (MachStr (fastStringToByteString str))))
294
295 where
296 chars = unpackFS str
297 safeChar c = ord c >= 1 && ord c <= 0x7F
298
299 -- This take a ~# b (or a ~# R b) and returns a ~ b (or Coercible a b)
300 mkEqBox :: Coercion -> CoreExpr
301 mkEqBox co = ASSERT2( typeKind ty2 `eqKind` k, ppr co $$ ppr ty1 $$ ppr ty2 $$ ppr (typeKind ty1) $$ ppr (typeKind ty2) )
302 Var (dataConWorkId datacon) `mkTyApps` [k, ty1, ty2] `App` Coercion co
303 where (Pair ty1 ty2, role) = coercionKindRole co
304 k = typeKind ty1
305 datacon = case role of
306 Nominal -> eqBoxDataCon
307 Representational -> coercibleDataCon
308 Phantom -> pprPanic "mkEqBox does not support boxing phantom coercions"
309 (ppr co)
310
311 {-
312 ************************************************************************
313 * *
314 \subsection{Tuple constructors}
315 * *
316 ************************************************************************
317 -}
318
319 -- $big_tuples
320 -- #big_tuples#
321 --
322 -- GHCs built in tuples can only go up to 'mAX_TUPLE_SIZE' in arity, but
323 -- we might concievably want to build such a massive tuple as part of the
324 -- output of a desugaring stage (notably that for list comprehensions).
325 --
326 -- We call tuples above this size \"big tuples\", and emulate them by
327 -- creating and pattern matching on >nested< tuples that are expressible
328 -- by GHC.
329 --
330 -- Nesting policy: it's better to have a 2-tuple of 10-tuples (3 objects)
331 -- than a 10-tuple of 2-tuples (11 objects), so we want the leaves of any
332 -- construction to be big.
333 --
334 -- If you just use the 'mkBigCoreTup', 'mkBigCoreVarTupTy', 'mkTupleSelector'
335 -- and 'mkTupleCase' functions to do all your work with tuples you should be
336 -- fine, and not have to worry about the arity limitation at all.
337
338 -- | Lifts a \"small\" constructor into a \"big\" constructor by recursive decompositon
339 mkChunkified :: ([a] -> a) -- ^ \"Small\" constructor function, of maximum input arity 'mAX_TUPLE_SIZE'
340 -> [a] -- ^ Possible \"big\" list of things to construct from
341 -> a -- ^ Constructed thing made possible by recursive decomposition
342 mkChunkified small_tuple as = mk_big_tuple (chunkify as)
343 where
344 -- Each sub-list is short enough to fit in a tuple
345 mk_big_tuple [as] = small_tuple as
346 mk_big_tuple as_s = mk_big_tuple (chunkify (map small_tuple as_s))
347
348 chunkify :: [a] -> [[a]]
349 -- ^ Split a list into lists that are small enough to have a corresponding
350 -- tuple arity. The sub-lists of the result all have length <= 'mAX_TUPLE_SIZE'
351 -- But there may be more than 'mAX_TUPLE_SIZE' sub-lists
352 chunkify xs
353 | n_xs <= mAX_TUPLE_SIZE = [xs]
354 | otherwise = split xs
355 where
356 n_xs = length xs
357 split [] = []
358 split xs = take mAX_TUPLE_SIZE xs : split (drop mAX_TUPLE_SIZE xs)
359
360 {-
361 Creating tuples and their types for Core expressions
362
363 @mkBigCoreVarTup@ builds a tuple; the inverse to @mkTupleSelector@.
364
365 * If it has only one element, it is the identity function.
366
367 * If there are more elements than a big tuple can have, it nests
368 the tuples.
369 -}
370
371 -- | Build a small tuple holding the specified variables
372 mkCoreVarTup :: [Id] -> CoreExpr
373 mkCoreVarTup ids = mkCoreTup (map Var ids)
374
375 -- | Bulid the type of a small tuple that holds the specified variables
376 mkCoreVarTupTy :: [Id] -> Type
377 mkCoreVarTupTy ids = mkBoxedTupleTy (map idType ids)
378
379 -- | Build a small tuple holding the specified expressions
380 mkCoreTup :: [CoreExpr] -> CoreExpr
381 mkCoreTup [] = Var unitDataConId
382 mkCoreTup [c] = c
383 mkCoreTup cs = mkConApp (tupleDataCon Boxed (length cs))
384 (map (Type . exprType) cs ++ cs)
385
386 -- | Build a big tuple holding the specified variables
387 mkBigCoreVarTup :: [Id] -> CoreExpr
388 mkBigCoreVarTup ids = mkBigCoreTup (map Var ids)
389
390 -- | Build the type of a big tuple that holds the specified variables
391 mkBigCoreVarTupTy :: [Id] -> Type
392 mkBigCoreVarTupTy ids = mkBigCoreTupTy (map idType ids)
393
394 -- | Build a big tuple holding the specified expressions
395 mkBigCoreTup :: [CoreExpr] -> CoreExpr
396 mkBigCoreTup = mkChunkified mkCoreTup
397
398 -- | Build the type of a big tuple that holds the specified type of thing
399 mkBigCoreTupTy :: [Type] -> Type
400 mkBigCoreTupTy = mkChunkified mkBoxedTupleTy
401
402 {-
403 ************************************************************************
404 * *
405 Floats
406 * *
407 ************************************************************************
408 -}
409
410 data FloatBind
411 = FloatLet CoreBind
412 | FloatCase CoreExpr Id AltCon [Var]
413 -- case e of y { C ys -> ... }
414 -- See Note [Floating cases] in SetLevels
415
416 instance Outputable FloatBind where
417 ppr (FloatLet b) = ptext (sLit "LET") <+> ppr b
418 ppr (FloatCase e b c bs) = hang (ptext (sLit "CASE") <+> ppr e <+> ptext (sLit "of") <+> ppr b)
419 2 (ppr c <+> ppr bs)
420
421 wrapFloat :: FloatBind -> CoreExpr -> CoreExpr
422 wrapFloat (FloatLet defns) body = Let defns body
423 wrapFloat (FloatCase e b con bs) body = Case e b (exprType body) [(con, bs, body)]
424
425 {-
426 ************************************************************************
427 * *
428 \subsection{Tuple destructors}
429 * *
430 ************************************************************************
431 -}
432
433 -- | Builds a selector which scrutises the given
434 -- expression and extracts the one name from the list given.
435 -- If you want the no-shadowing rule to apply, the caller
436 -- is responsible for making sure that none of these names
437 -- are in scope.
438 --
439 -- If there is just one 'Id' in the tuple, then the selector is
440 -- just the identity.
441 --
442 -- If necessary, we pattern match on a \"big\" tuple.
443 mkTupleSelector :: [Id] -- ^ The 'Id's to pattern match the tuple against
444 -> Id -- ^ The 'Id' to select
445 -> Id -- ^ A variable of the same type as the scrutinee
446 -> CoreExpr -- ^ Scrutinee
447 -> CoreExpr -- ^ Selector expression
448
449 -- mkTupleSelector [a,b,c,d] b v e
450 -- = case e of v {
451 -- (p,q) -> case p of p {
452 -- (a,b) -> b }}
453 -- We use 'tpl' vars for the p,q, since shadowing does not matter.
454 --
455 -- In fact, it's more convenient to generate it innermost first, getting
456 --
457 -- case (case e of v
458 -- (p,q) -> p) of p
459 -- (a,b) -> b
460 mkTupleSelector vars the_var scrut_var scrut
461 = mk_tup_sel (chunkify vars) the_var
462 where
463 mk_tup_sel [vars] the_var = mkSmallTupleSelector vars the_var scrut_var scrut
464 mk_tup_sel vars_s the_var = mkSmallTupleSelector group the_var tpl_v $
465 mk_tup_sel (chunkify tpl_vs) tpl_v
466 where
467 tpl_tys = [mkBoxedTupleTy (map idType gp) | gp <- vars_s]
468 tpl_vs = mkTemplateLocals tpl_tys
469 [(tpl_v, group)] = [(tpl,gp) | (tpl,gp) <- zipEqual "mkTupleSelector" tpl_vs vars_s,
470 the_var `elem` gp ]
471
472 -- | Like 'mkTupleSelector' but for tuples that are guaranteed
473 -- never to be \"big\".
474 --
475 -- > mkSmallTupleSelector [x] x v e = [| e |]
476 -- > mkSmallTupleSelector [x,y,z] x v e = [| case e of v { (x,y,z) -> x } |]
477 mkSmallTupleSelector :: [Id] -- The tuple args
478 -> Id -- The selected one
479 -> Id -- A variable of the same type as the scrutinee
480 -> CoreExpr -- Scrutinee
481 -> CoreExpr
482 mkSmallTupleSelector [var] should_be_the_same_var _ scrut
483 = ASSERT(var == should_be_the_same_var)
484 scrut
485 mkSmallTupleSelector vars the_var scrut_var scrut
486 = ASSERT( notNull vars )
487 Case scrut scrut_var (idType the_var)
488 [(DataAlt (tupleDataCon Boxed (length vars)), vars, Var the_var)]
489
490 -- | A generalization of 'mkTupleSelector', allowing the body
491 -- of the case to be an arbitrary expression.
492 --
493 -- To avoid shadowing, we use uniques to invent new variables.
494 --
495 -- If necessary we pattern match on a \"big\" tuple.
496 mkTupleCase :: UniqSupply -- ^ For inventing names of intermediate variables
497 -> [Id] -- ^ The tuple identifiers to pattern match on
498 -> CoreExpr -- ^ Body of the case
499 -> Id -- ^ A variable of the same type as the scrutinee
500 -> CoreExpr -- ^ Scrutinee
501 -> CoreExpr
502 -- ToDo: eliminate cases where none of the variables are needed.
503 --
504 -- mkTupleCase uniqs [a,b,c,d] body v e
505 -- = case e of v { (p,q) ->
506 -- case p of p { (a,b) ->
507 -- case q of q { (c,d) ->
508 -- body }}}
509 mkTupleCase uniqs vars body scrut_var scrut
510 = mk_tuple_case uniqs (chunkify vars) body
511 where
512 -- This is the case where don't need any nesting
513 mk_tuple_case _ [vars] body
514 = mkSmallTupleCase vars body scrut_var scrut
515
516 -- This is the case where we must make nest tuples at least once
517 mk_tuple_case us vars_s body
518 = let (us', vars', body') = foldr one_tuple_case (us, [], body) vars_s
519 in mk_tuple_case us' (chunkify vars') body'
520
521 one_tuple_case chunk_vars (us, vs, body)
522 = let (uniq, us') = takeUniqFromSupply us
523 scrut_var = mkSysLocal (fsLit "ds") uniq
524 (mkBoxedTupleTy (map idType chunk_vars))
525 body' = mkSmallTupleCase chunk_vars body scrut_var (Var scrut_var)
526 in (us', scrut_var:vs, body')
527
528 -- | As 'mkTupleCase', but for a tuple that is small enough to be guaranteed
529 -- not to need nesting.
530 mkSmallTupleCase
531 :: [Id] -- ^ The tuple args
532 -> CoreExpr -- ^ Body of the case
533 -> Id -- ^ A variable of the same type as the scrutinee
534 -> CoreExpr -- ^ Scrutinee
535 -> CoreExpr
536
537 mkSmallTupleCase [var] body _scrut_var scrut
538 = bindNonRec var scrut body
539 mkSmallTupleCase vars body scrut_var scrut
540 -- One branch no refinement?
541 = Case scrut scrut_var (exprType body)
542 [(DataAlt (tupleDataCon Boxed (length vars)), vars, body)]
543
544 {-
545 ************************************************************************
546 * *
547 \subsection{Common list manipulation expressions}
548 * *
549 ************************************************************************
550
551 Call the constructor Ids when building explicit lists, so that they
552 interact well with rules.
553 -}
554
555 -- | Makes a list @[]@ for lists of the specified type
556 mkNilExpr :: Type -> CoreExpr
557 mkNilExpr ty = mkConApp nilDataCon [Type ty]
558
559 -- | Makes a list @(:)@ for lists of the specified type
560 mkConsExpr :: Type -> CoreExpr -> CoreExpr -> CoreExpr
561 mkConsExpr ty hd tl = mkConApp consDataCon [Type ty, hd, tl]
562
563 -- | Make a list containing the given expressions, where the list has the given type
564 mkListExpr :: Type -> [CoreExpr] -> CoreExpr
565 mkListExpr ty xs = foldr (mkConsExpr ty) (mkNilExpr ty) xs
566
567 -- | Make a fully applied 'foldr' expression
568 mkFoldrExpr :: MonadThings m
569 => Type -- ^ Element type of the list
570 -> Type -- ^ Fold result type
571 -> CoreExpr -- ^ "Cons" function expression for the fold
572 -> CoreExpr -- ^ "Nil" expression for the fold
573 -> CoreExpr -- ^ List expression being folded acress
574 -> m CoreExpr
575 mkFoldrExpr elt_ty result_ty c n list = do
576 foldr_id <- lookupId foldrName
577 return (Var foldr_id `App` Type elt_ty
578 `App` Type result_ty
579 `App` c
580 `App` n
581 `App` list)
582
583 -- | Make a 'build' expression applied to a locally-bound worker function
584 mkBuildExpr :: (MonadThings m, MonadUnique m)
585 => Type -- ^ Type of list elements to be built
586 -> ((Id, Type) -> (Id, Type) -> m CoreExpr) -- ^ Function that, given information about the 'Id's
587 -- of the binders for the build worker function, returns
588 -- the body of that worker
589 -> m CoreExpr
590 mkBuildExpr elt_ty mk_build_inside = do
591 [n_tyvar] <- newTyVars [alphaTyVar]
592 let n_ty = mkTyVarTy n_tyvar
593 c_ty = mkFunTys [elt_ty, n_ty] n_ty
594 [c, n] <- sequence [mkSysLocalM (fsLit "c") c_ty, mkSysLocalM (fsLit "n") n_ty]
595
596 build_inside <- mk_build_inside (c, c_ty) (n, n_ty)
597
598 build_id <- lookupId buildName
599 return $ Var build_id `App` Type elt_ty `App` mkLams [n_tyvar, c, n] build_inside
600 where
601 newTyVars tyvar_tmpls = do
602 uniqs <- getUniquesM
603 return (zipWith setTyVarUnique tyvar_tmpls uniqs)
604
605 {-
606 ************************************************************************
607 * *
608 Error expressions
609 * *
610 ************************************************************************
611 -}
612
613 mkRuntimeErrorApp
614 :: Id -- Should be of type (forall a. Addr# -> a)
615 -- where Addr# points to a UTF8 encoded string
616 -> Type -- The type to instantiate 'a'
617 -> String -- The string to print
618 -> CoreExpr
619
620 mkRuntimeErrorApp err_id res_ty err_msg
621 = mkApps (Var err_id) [Type res_ty, err_string]
622 where
623 err_string = Lit (mkMachString err_msg)
624
625 mkImpossibleExpr :: Type -> CoreExpr
626 mkImpossibleExpr res_ty
627 = mkRuntimeErrorApp rUNTIME_ERROR_ID res_ty "Impossible case alternative"
628
629 {-
630 ************************************************************************
631 * *
632 Error Ids
633 * *
634 ************************************************************************
635
636 GHC randomly injects these into the code.
637
638 @patError@ is just a version of @error@ for pattern-matching
639 failures. It knows various ``codes'' which expand to longer
640 strings---this saves space!
641
642 @absentErr@ is a thing we put in for ``absent'' arguments. They jolly
643 well shouldn't be yanked on, but if one is, then you will get a
644 friendly message from @absentErr@ (rather than a totally random
645 crash).
646
647 @parError@ is a special version of @error@ which the compiler does
648 not know to be a bottoming Id. It is used in the @_par_@ and @_seq_@
649 templates, but we don't ever expect to generate code for it.
650 -}
651
652 errorIds :: [Id]
653 errorIds
654 = [ eRROR_ID, -- This one isn't used anywhere else in the compiler
655 -- But we still need it in wiredInIds so that when GHC
656 -- compiles a program that mentions 'error' we don't
657 -- import its type from the interface file; we just get
658 -- the Id defined here. Which has an 'open-tyvar' type.
659
660 uNDEFINED_ID, -- Ditto for 'undefined'. The big deal is to give it
661 -- an 'open-tyvar' type.
662
663 rUNTIME_ERROR_ID,
664 iRREFUT_PAT_ERROR_ID,
665 nON_EXHAUSTIVE_GUARDS_ERROR_ID,
666 nO_METHOD_BINDING_ERROR_ID,
667 pAT_ERROR_ID,
668 rEC_CON_ERROR_ID,
669 rEC_SEL_ERROR_ID,
670 aBSENT_ERROR_ID,
671 tYPE_ERROR_ID -- Used with Opt_DeferTypeErrors, see #10284
672 ]
673
674 recSelErrorName, runtimeErrorName, absentErrorName :: Name
675 irrefutPatErrorName, recConErrorName, patErrorName :: Name
676 nonExhaustiveGuardsErrorName, noMethodBindingErrorName :: Name
677 typeErrorName :: Name
678
679 recSelErrorName = err_nm "recSelError" recSelErrorIdKey rEC_SEL_ERROR_ID
680 absentErrorName = err_nm "absentError" absentErrorIdKey aBSENT_ERROR_ID
681 runtimeErrorName = err_nm "runtimeError" runtimeErrorIdKey rUNTIME_ERROR_ID
682 irrefutPatErrorName = err_nm "irrefutPatError" irrefutPatErrorIdKey iRREFUT_PAT_ERROR_ID
683 recConErrorName = err_nm "recConError" recConErrorIdKey rEC_CON_ERROR_ID
684 patErrorName = err_nm "patError" patErrorIdKey pAT_ERROR_ID
685 typeErrorName = err_nm "typeError" typeErrorIdKey tYPE_ERROR_ID
686
687 noMethodBindingErrorName = err_nm "noMethodBindingError"
688 noMethodBindingErrorIdKey nO_METHOD_BINDING_ERROR_ID
689 nonExhaustiveGuardsErrorName = err_nm "nonExhaustiveGuardsError"
690 nonExhaustiveGuardsErrorIdKey nON_EXHAUSTIVE_GUARDS_ERROR_ID
691
692 err_nm :: String -> Unique -> Id -> Name
693 err_nm str uniq id = mkWiredInIdName cONTROL_EXCEPTION_BASE (fsLit str) uniq id
694
695 rEC_SEL_ERROR_ID, rUNTIME_ERROR_ID, iRREFUT_PAT_ERROR_ID, rEC_CON_ERROR_ID :: Id
696 pAT_ERROR_ID, nO_METHOD_BINDING_ERROR_ID, nON_EXHAUSTIVE_GUARDS_ERROR_ID :: Id
697 tYPE_ERROR_ID :: Id
698 aBSENT_ERROR_ID :: Id
699 rEC_SEL_ERROR_ID = mkRuntimeErrorId recSelErrorName
700 rUNTIME_ERROR_ID = mkRuntimeErrorId runtimeErrorName
701 iRREFUT_PAT_ERROR_ID = mkRuntimeErrorId irrefutPatErrorName
702 rEC_CON_ERROR_ID = mkRuntimeErrorId recConErrorName
703 pAT_ERROR_ID = mkRuntimeErrorId patErrorName
704 nO_METHOD_BINDING_ERROR_ID = mkRuntimeErrorId noMethodBindingErrorName
705 nON_EXHAUSTIVE_GUARDS_ERROR_ID = mkRuntimeErrorId nonExhaustiveGuardsErrorName
706 aBSENT_ERROR_ID = mkRuntimeErrorId absentErrorName
707 tYPE_ERROR_ID = mkRuntimeErrorId typeErrorName
708
709 mkRuntimeErrorId :: Name -> Id
710 mkRuntimeErrorId name = pc_bottoming_Id1 name runtimeErrorTy
711
712 runtimeErrorTy :: Type
713 -- The runtime error Ids take a UTF8-encoded string as argument
714 runtimeErrorTy = mkSigmaTy [openAlphaTyVar] [] (mkFunTy addrPrimTy openAlphaTy)
715
716 errorName :: Name
717 errorName = mkWiredInIdName gHC_ERR (fsLit "error") errorIdKey eRROR_ID
718
719 eRROR_ID :: Id
720 eRROR_ID = pc_bottoming_Id1 errorName errorTy
721
722 errorTy :: Type -- See Note [Error and friends have an "open-tyvar" forall]
723 errorTy = mkSigmaTy [openAlphaTyVar] [] (mkFunTys [mkListTy charTy] openAlphaTy)
724
725 undefinedName :: Name
726 undefinedName = mkWiredInIdName gHC_ERR (fsLit "undefined") undefinedKey uNDEFINED_ID
727
728 uNDEFINED_ID :: Id
729 uNDEFINED_ID = pc_bottoming_Id0 undefinedName undefinedTy
730
731 undefinedTy :: Type -- See Note [Error and friends have an "open-tyvar" forall]
732 undefinedTy = mkSigmaTy [openAlphaTyVar] [] openAlphaTy
733
734 {-
735 Note [Error and friends have an "open-tyvar" forall]
736 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
737 'error' and 'undefined' have types
738 error :: forall (a::OpenKind). String -> a
739 undefined :: forall (a::OpenKind). a
740 Notice the 'OpenKind' (manifested as openAlphaTyVar in the code). This ensures that
741 "error" can be instantiated at
742 * unboxed as well as boxed types
743 * polymorphic types
744 This is OK because it never returns, so the return type is irrelevant.
745 See Note [OpenTypeKind accepts foralls] in TcUnify.
746
747
748 ************************************************************************
749 * *
750 \subsection{Utilities}
751 * *
752 ************************************************************************
753 -}
754
755 pc_bottoming_Id1 :: Name -> Type -> Id
756 -- Function of arity 1, which diverges after being given one argument
757 pc_bottoming_Id1 name ty
758 = mkVanillaGlobalWithInfo name ty bottoming_info
759 where
760 bottoming_info = vanillaIdInfo `setStrictnessInfo` strict_sig
761 `setArityInfo` 1
762 -- Make arity and strictness agree
763
764 -- Do *not* mark them as NoCafRefs, because they can indeed have
765 -- CAF refs. For example, pAT_ERROR_ID calls GHC.Err.untangle,
766 -- which has some CAFs
767 -- In due course we may arrange that these error-y things are
768 -- regarded by the GC as permanently live, in which case we
769 -- can give them NoCaf info. As it is, any function that calls
770 -- any pc_bottoming_Id will itself have CafRefs, which bloats
771 -- SRTs.
772
773 strict_sig = mkClosedStrictSig [evalDmd] botRes
774 -- These "bottom" out, no matter what their arguments
775
776 pc_bottoming_Id0 :: Name -> Type -> Id
777 -- Same but arity zero
778 pc_bottoming_Id0 name ty
779 = mkVanillaGlobalWithInfo name ty bottoming_info
780 where
781 bottoming_info = vanillaIdInfo `setStrictnessInfo` strict_sig
782 strict_sig = mkClosedStrictSig [] botRes