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