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