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