Typofixes in docs and comments [ci skip]
[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, mkNaturalExpr,
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, unitExpr,
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, mkAbsentErrorApp, errorIds,
46 rEC_CON_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, aBSENT_SUM_FIELD_ERROR_ID
50 ) where
51
52 #include "HsVersions.h"
53
54 import GhcPrelude
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 HsUtils ( mkChunkified, chunkify )
68 import Type
69 import Coercion ( isCoVar )
70 import TysPrim
71 import DataCon ( DataCon, dataConWorkId )
72 import IdInfo
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 -- paired with its type to an argument. The result is paired with its type. This
122 -- function is not exported and used in the definition of 'mkCoreApp' and
123 -- 'mkCoreApps'.
124 -- Respects the let/app invariant by building a case expression where necessary
125 -- See CoreSyn Note [CoreSyn let/app invariant]
126 mkCoreAppTyped :: SDoc -> (CoreExpr, Type) -> CoreExpr -> (CoreExpr, Type)
127 mkCoreAppTyped _ (fun, fun_ty) (Type ty)
128 = (App fun (Type ty), piResultTy fun_ty ty)
129 mkCoreAppTyped _ (fun, fun_ty) (Coercion co)
130 = (App fun (Coercion co), res_ty)
131 where
132 (_, res_ty) = splitFunTy fun_ty
133 mkCoreAppTyped d (fun, fun_ty) arg
134 = ASSERT2( isFunTy fun_ty, ppr fun $$ ppr arg $$ d )
135 (mk_val_app fun arg arg_ty res_ty, res_ty)
136 where
137 (arg_ty, res_ty) = splitFunTy fun_ty
138
139 -- | Construct an expression which represents the application of one expression
140 -- to the other
141 -- Respects the let/app invariant by building a case expression where necessary
142 -- See CoreSyn Note [CoreSyn let/app invariant]
143 mkCoreApp :: SDoc -> CoreExpr -> CoreExpr -> CoreExpr
144 mkCoreApp s fun arg
145 = fst $ mkCoreAppTyped s (fun, exprType fun) arg
146
147 -- | Construct an expression which represents the application of a number of
148 -- expressions to another. The leftmost expression in the list is applied first
149 -- Respects the let/app invariant by building a case expression where necessary
150 -- See CoreSyn Note [CoreSyn let/app invariant]
151 mkCoreApps :: CoreExpr -> [CoreExpr] -> CoreExpr
152 mkCoreApps fun args
153 = fst $
154 foldl' (mkCoreAppTyped doc_string) (fun, fun_ty) args
155 where
156 doc_string = ppr fun_ty $$ ppr fun $$ ppr args
157 fun_ty = exprType fun
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 -- 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 -- fragment 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 = mkLocalIdOrCoVar 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 = mkCoreConApps 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 = mkCoreConApps 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 = mkCoreConApps 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 = mkCoreConApps 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 @Natural@
263 mkNaturalExpr :: MonadThings m => Integer -> m CoreExpr
264 mkNaturalExpr i = do t <- lookupTyCon naturalTyConName
265 return (Lit (mkLitNatural i (mkTyConTy t)))
266
267 -- | Create a 'CoreExpr' which will evaluate to the given @Float@
268 mkFloatExpr :: Float -> CoreExpr
269 mkFloatExpr f = mkCoreConApps floatDataCon [mkFloatLitFloat f]
270
271 -- | Create a 'CoreExpr' which will evaluate to the given @Double@
272 mkDoubleExpr :: Double -> CoreExpr
273 mkDoubleExpr d = mkCoreConApps doubleDataCon [mkDoubleLitDouble d]
274
275
276 -- | Create a 'CoreExpr' which will evaluate to the given @Char@
277 mkCharExpr :: Char -> CoreExpr -- Result = C# c :: Int
278 mkCharExpr c = mkCoreConApps charDataCon [mkCharLit c]
279
280 -- | Create a 'CoreExpr' which will evaluate to the given @String@
281 mkStringExpr :: MonadThings m => String -> m CoreExpr -- Result :: String
282
283 -- | Create a 'CoreExpr' which will evaluate to a string morally equivalent to the given @FastString@
284 mkStringExprFS :: MonadThings m => FastString -> m CoreExpr -- Result :: String
285
286 mkStringExpr str = mkStringExprFS (mkFastString str)
287
288 mkStringExprFS = mkStringExprFSWith lookupId
289
290 mkStringExprFSWith :: Monad m => (Name -> m Id) -> FastString -> m CoreExpr
291 mkStringExprFSWith lookupM str
292 | nullFS str
293 = return (mkNilExpr charTy)
294
295 | all safeChar chars
296 = do unpack_id <- lookupM unpackCStringName
297 return (App (Var unpack_id) lit)
298
299 | otherwise
300 = do unpack_utf8_id <- lookupM unpackCStringUtf8Name
301 return (App (Var unpack_utf8_id) lit)
302
303 where
304 chars = unpackFS str
305 safeChar c = ord c >= 1 && ord c <= 0x7F
306 lit = Lit (MachStr (fastStringToByteString str))
307
308 {-
309 ************************************************************************
310 * *
311 \subsection{Tuple constructors}
312 * *
313 ************************************************************************
314 -}
315
316 {-
317 Creating tuples and their types for Core expressions
318
319 @mkBigCoreVarTup@ builds a tuple; the inverse to @mkTupleSelector@.
320
321 * If it has only one element, it is the identity function.
322
323 * If there are more elements than a big tuple can have, it nests
324 the tuples.
325
326 Note [Flattening one-tuples]
327 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
328 This family of functions creates a tuple of variables/expressions/types.
329 mkCoreTup [e1,e2,e3] = (e1,e2,e3)
330 What if there is just one variable/expression/type in the argument?
331 We could do one of two things:
332
333 * Flatten it out, so that
334 mkCoreTup [e1] = e1
335
336 * Build a one-tuple (see Note [One-tuples] in TysWiredIn)
337 mkCoreTup1 [e1] = Unit e1
338 We use a suffix "1" to indicate this.
339
340 Usually we want the former, but occasionally the latter.
341 -}
342
343 -- | Build a small tuple holding the specified variables
344 -- One-tuples are flattened; see Note [Flattening one-tuples]
345 mkCoreVarTup :: [Id] -> CoreExpr
346 mkCoreVarTup ids = mkCoreTup (map Var ids)
347
348 -- | Build the type of a small tuple that holds the specified variables
349 -- One-tuples are flattened; see Note [Flattening one-tuples]
350 mkCoreVarTupTy :: [Id] -> Type
351 mkCoreVarTupTy ids = mkBoxedTupleTy (map idType ids)
352
353 -- | Build a small tuple holding the specified expressions
354 -- One-tuples are flattened; see Note [Flattening one-tuples]
355 mkCoreTup :: [CoreExpr] -> CoreExpr
356 mkCoreTup [] = Var unitDataConId
357 mkCoreTup [c] = c
358 mkCoreTup cs = mkCoreConApps (tupleDataCon Boxed (length cs))
359 (map (Type . exprType) cs ++ cs)
360
361 -- | Build a small unboxed tuple holding the specified expressions,
362 -- with the given types. The types must be the types of the expressions.
363 -- Do not include the RuntimeRep specifiers; this function calculates them
364 -- for you.
365 -- Does /not/ flatten one-tuples; see Note [Flattening one-tuples]
366 mkCoreUbxTup :: [Type] -> [CoreExpr] -> CoreExpr
367 mkCoreUbxTup tys exps
368 = ASSERT( tys `equalLength` exps)
369 mkCoreConApps (tupleDataCon Unboxed (length tys))
370 (map (Type . getRuntimeRep) tys ++ map Type tys ++ exps)
371
372 -- | Make a core tuple of the given boxity
373 mkCoreTupBoxity :: Boxity -> [CoreExpr] -> CoreExpr
374 mkCoreTupBoxity Boxed exps = mkCoreTup exps
375 mkCoreTupBoxity Unboxed exps = mkCoreUbxTup (map exprType exps) exps
376
377 -- | Build a big tuple holding the specified variables
378 -- One-tuples are flattened; see Note [Flattening one-tuples]
379 mkBigCoreVarTup :: [Id] -> CoreExpr
380 mkBigCoreVarTup ids = mkBigCoreTup (map Var ids)
381
382 mkBigCoreVarTup1 :: [Id] -> CoreExpr
383 -- Same as mkBigCoreVarTup, but one-tuples are NOT flattened
384 -- see Note [Flattening one-tuples]
385 mkBigCoreVarTup1 [id] = mkCoreConApps (tupleDataCon Boxed 1)
386 [Type (idType id), Var id]
387 mkBigCoreVarTup1 ids = mkBigCoreTup (map Var ids)
388
389 -- | Build the type of a big tuple that holds the specified variables
390 -- One-tuples are flattened; see Note [Flattening one-tuples]
391 mkBigCoreVarTupTy :: [Id] -> Type
392 mkBigCoreVarTupTy ids = mkBigCoreTupTy (map idType ids)
393
394 -- | Build a big tuple holding the specified expressions
395 -- One-tuples are flattened; see Note [Flattening one-tuples]
396 mkBigCoreTup :: [CoreExpr] -> CoreExpr
397 mkBigCoreTup = mkChunkified mkCoreTup
398
399 -- | Build the type of a big tuple that holds the specified type of thing
400 -- One-tuples are flattened; see Note [Flattening one-tuples]
401 mkBigCoreTupTy :: [Type] -> Type
402 mkBigCoreTupTy = mkChunkified mkBoxedTupleTy
403
404 -- | The unit expression
405 unitExpr :: CoreExpr
406 unitExpr = Var unitDataConId
407
408 {-
409 ************************************************************************
410 * *
411 \subsection{Tuple destructors}
412 * *
413 ************************************************************************
414 -}
415
416 -- | Builds a selector which scrutises the given
417 -- expression and extracts the one name from the list given.
418 -- If you want the no-shadowing rule to apply, the caller
419 -- is responsible for making sure that none of these names
420 -- are in scope.
421 --
422 -- If there is just one 'Id' in the tuple, then the selector is
423 -- just the identity.
424 --
425 -- If necessary, we pattern match on a \"big\" tuple.
426 mkTupleSelector, mkTupleSelector1
427 :: [Id] -- ^ The 'Id's to pattern match the tuple against
428 -> Id -- ^ The 'Id' to select
429 -> Id -- ^ A variable of the same type as the scrutinee
430 -> CoreExpr -- ^ Scrutinee
431 -> CoreExpr -- ^ Selector expression
432
433 -- mkTupleSelector [a,b,c,d] b v e
434 -- = case e of v {
435 -- (p,q) -> case p of p {
436 -- (a,b) -> b }}
437 -- We use 'tpl' vars for the p,q, since shadowing does not matter.
438 --
439 -- In fact, it's more convenient to generate it innermost first, getting
440 --
441 -- case (case e of v
442 -- (p,q) -> p) of p
443 -- (a,b) -> b
444 mkTupleSelector vars the_var scrut_var scrut
445 = mk_tup_sel (chunkify vars) the_var
446 where
447 mk_tup_sel [vars] the_var = mkSmallTupleSelector vars the_var scrut_var scrut
448 mk_tup_sel vars_s the_var = mkSmallTupleSelector group the_var tpl_v $
449 mk_tup_sel (chunkify tpl_vs) tpl_v
450 where
451 tpl_tys = [mkBoxedTupleTy (map idType gp) | gp <- vars_s]
452 tpl_vs = mkTemplateLocals tpl_tys
453 [(tpl_v, group)] = [(tpl,gp) | (tpl,gp) <- zipEqual "mkTupleSelector" tpl_vs vars_s,
454 the_var `elem` gp ]
455 -- ^ 'mkTupleSelector1' is like 'mkTupleSelector'
456 -- but one-tuples are NOT flattened (see Note [Flattening one-tuples])
457 mkTupleSelector1 vars the_var scrut_var scrut
458 | [_] <- vars
459 = mkSmallTupleSelector1 vars the_var scrut_var scrut
460 | otherwise
461 = mkTupleSelector vars the_var scrut_var scrut
462
463 -- | Like 'mkTupleSelector' but for tuples that are guaranteed
464 -- never to be \"big\".
465 --
466 -- > mkSmallTupleSelector [x] x v e = [| e |]
467 -- > mkSmallTupleSelector [x,y,z] x v e = [| case e of v { (x,y,z) -> x } |]
468 mkSmallTupleSelector, mkSmallTupleSelector1
469 :: [Id] -- The tuple args
470 -> Id -- The selected one
471 -> Id -- A variable of the same type as the scrutinee
472 -> CoreExpr -- Scrutinee
473 -> CoreExpr
474 mkSmallTupleSelector [var] should_be_the_same_var _ scrut
475 = ASSERT(var == should_be_the_same_var)
476 scrut -- Special case for 1-tuples
477 mkSmallTupleSelector vars the_var scrut_var scrut
478 = mkSmallTupleSelector1 vars the_var scrut_var scrut
479
480 -- ^ 'mkSmallTupleSelector1' is like 'mkSmallTupleSelector'
481 -- but one-tuples are NOT flattened (see Note [Flattening one-tuples])
482 mkSmallTupleSelector1 vars the_var scrut_var scrut
483 = ASSERT( notNull vars )
484 Case scrut scrut_var (idType the_var)
485 [(DataAlt (tupleDataCon Boxed (length vars)), vars, Var the_var)]
486
487 -- | A generalization of 'mkTupleSelector', allowing the body
488 -- of the case to be an arbitrary expression.
489 --
490 -- To avoid shadowing, we use uniques to invent new variables.
491 --
492 -- If necessary we pattern match on a \"big\" tuple.
493 mkTupleCase :: UniqSupply -- ^ For inventing names of intermediate variables
494 -> [Id] -- ^ The tuple identifiers to pattern match on
495 -> CoreExpr -- ^ Body of the case
496 -> Id -- ^ A variable of the same type as the scrutinee
497 -> CoreExpr -- ^ Scrutinee
498 -> CoreExpr
499 -- ToDo: eliminate cases where none of the variables are needed.
500 --
501 -- mkTupleCase uniqs [a,b,c,d] body v e
502 -- = case e of v { (p,q) ->
503 -- case p of p { (a,b) ->
504 -- case q of q { (c,d) ->
505 -- body }}}
506 mkTupleCase uniqs vars body scrut_var scrut
507 = mk_tuple_case uniqs (chunkify vars) body
508 where
509 -- This is the case where don't need any nesting
510 mk_tuple_case _ [vars] body
511 = mkSmallTupleCase vars body scrut_var scrut
512
513 -- This is the case where we must make nest tuples at least once
514 mk_tuple_case us vars_s body
515 = let (us', vars', body') = foldr one_tuple_case (us, [], body) vars_s
516 in mk_tuple_case us' (chunkify vars') body'
517
518 one_tuple_case chunk_vars (us, vs, body)
519 = let (uniq, us') = takeUniqFromSupply us
520 scrut_var = mkSysLocal (fsLit "ds") uniq
521 (mkBoxedTupleTy (map idType chunk_vars))
522 body' = mkSmallTupleCase chunk_vars body scrut_var (Var scrut_var)
523 in (us', scrut_var:vs, body')
524
525 -- | As 'mkTupleCase', but for a tuple that is small enough to be guaranteed
526 -- not to need nesting.
527 mkSmallTupleCase
528 :: [Id] -- ^ The tuple args
529 -> CoreExpr -- ^ Body of the case
530 -> Id -- ^ A variable of the same type as the scrutinee
531 -> CoreExpr -- ^ Scrutinee
532 -> CoreExpr
533
534 mkSmallTupleCase [var] body _scrut_var scrut
535 = bindNonRec var scrut body
536 mkSmallTupleCase vars body scrut_var scrut
537 -- One branch no refinement?
538 = Case scrut scrut_var (exprType body)
539 [(DataAlt (tupleDataCon Boxed (length vars)), vars, body)]
540
541 {-
542 ************************************************************************
543 * *
544 Floats
545 * *
546 ************************************************************************
547 -}
548
549 data FloatBind
550 = FloatLet CoreBind
551 | FloatCase CoreExpr Id AltCon [Var]
552 -- case e of y { C ys -> ... }
553 -- See Note [Floating cases] in SetLevels
554
555 instance Outputable FloatBind where
556 ppr (FloatLet b) = text "LET" <+> ppr b
557 ppr (FloatCase e b c bs) = hang (text "CASE" <+> ppr e <+> ptext (sLit "of") <+> ppr b)
558 2 (ppr c <+> ppr bs)
559
560 wrapFloat :: FloatBind -> CoreExpr -> CoreExpr
561 wrapFloat (FloatLet defns) body = Let defns body
562 wrapFloat (FloatCase e b con bs) body = Case e b (exprType body) [(con, bs, body)]
563
564 {-
565 ************************************************************************
566 * *
567 \subsection{Common list manipulation expressions}
568 * *
569 ************************************************************************
570
571 Call the constructor Ids when building explicit lists, so that they
572 interact well with rules.
573 -}
574
575 -- | Makes a list @[]@ for lists of the specified type
576 mkNilExpr :: Type -> CoreExpr
577 mkNilExpr ty = mkCoreConApps nilDataCon [Type ty]
578
579 -- | Makes a list @(:)@ for lists of the specified type
580 mkConsExpr :: Type -> CoreExpr -> CoreExpr -> CoreExpr
581 mkConsExpr ty hd tl = mkCoreConApps consDataCon [Type ty, hd, tl]
582
583 -- | Make a list containing the given expressions, where the list has the given type
584 mkListExpr :: Type -> [CoreExpr] -> CoreExpr
585 mkListExpr ty xs = foldr (mkConsExpr ty) (mkNilExpr ty) xs
586
587 -- | Make a fully applied 'foldr' expression
588 mkFoldrExpr :: MonadThings m
589 => Type -- ^ Element type of the list
590 -> Type -- ^ Fold result type
591 -> CoreExpr -- ^ "Cons" function expression for the fold
592 -> CoreExpr -- ^ "Nil" expression for the fold
593 -> CoreExpr -- ^ List expression being folded acress
594 -> m CoreExpr
595 mkFoldrExpr elt_ty result_ty c n list = do
596 foldr_id <- lookupId foldrName
597 return (Var foldr_id `App` Type elt_ty
598 `App` Type result_ty
599 `App` c
600 `App` n
601 `App` list)
602
603 -- | Make a 'build' expression applied to a locally-bound worker function
604 mkBuildExpr :: (MonadThings m, MonadUnique m)
605 => Type -- ^ Type of list elements to be built
606 -> ((Id, Type) -> (Id, Type) -> m CoreExpr) -- ^ Function that, given information about the 'Id's
607 -- of the binders for the build worker function, returns
608 -- the body of that worker
609 -> m CoreExpr
610 mkBuildExpr elt_ty mk_build_inside = do
611 [n_tyvar] <- newTyVars [alphaTyVar]
612 let n_ty = mkTyVarTy n_tyvar
613 c_ty = mkFunTys [elt_ty, n_ty] n_ty
614 [c, n] <- sequence [mkSysLocalM (fsLit "c") c_ty, mkSysLocalM (fsLit "n") n_ty]
615
616 build_inside <- mk_build_inside (c, c_ty) (n, n_ty)
617
618 build_id <- lookupId buildName
619 return $ Var build_id `App` Type elt_ty `App` mkLams [n_tyvar, c, n] build_inside
620 where
621 newTyVars tyvar_tmpls = do
622 uniqs <- getUniquesM
623 return (zipWith setTyVarUnique tyvar_tmpls uniqs)
624
625 {-
626 ************************************************************************
627 * *
628 Manipulating Maybe data type
629 * *
630 ************************************************************************
631 -}
632
633
634 -- | Makes a Nothing for the specified type
635 mkNothingExpr :: Type -> CoreExpr
636 mkNothingExpr ty = mkConApp nothingDataCon [Type ty]
637
638 -- | Makes a Just from a value of the specified type
639 mkJustExpr :: Type -> CoreExpr -> CoreExpr
640 mkJustExpr ty val = mkConApp justDataCon [Type ty, val]
641
642
643 {-
644 ************************************************************************
645 * *
646 Error expressions
647 * *
648 ************************************************************************
649 -}
650
651 mkRuntimeErrorApp
652 :: Id -- Should be of type (forall a. Addr# -> a)
653 -- where Addr# points to a UTF8 encoded string
654 -> Type -- The type to instantiate 'a'
655 -> String -- The string to print
656 -> CoreExpr
657
658 mkRuntimeErrorApp err_id res_ty err_msg
659 = mkApps (Var err_id) [ Type (getRuntimeRep res_ty)
660 , Type res_ty, err_string ]
661 where
662 err_string = Lit (mkMachString err_msg)
663
664 mkImpossibleExpr :: Type -> CoreExpr
665 mkImpossibleExpr res_ty
666 = mkRuntimeErrorApp rUNTIME_ERROR_ID res_ty "Impossible case alternative"
667
668 {-
669 ************************************************************************
670 * *
671 Error Ids
672 * *
673 ************************************************************************
674
675 GHC randomly injects these into the code.
676
677 @patError@ is just a version of @error@ for pattern-matching
678 failures. It knows various ``codes'' which expand to longer
679 strings---this saves space!
680
681 @absentErr@ is a thing we put in for ``absent'' arguments. They jolly
682 well shouldn't be yanked on, but if one is, then you will get a
683 friendly message from @absentErr@ (rather than a totally random
684 crash).
685
686 @parError@ is a special version of @error@ which the compiler does
687 not know to be a bottoming Id. It is used in the @_par_@ and @_seq_@
688 templates, but we don't ever expect to generate code for it.
689 -}
690
691 errorIds :: [Id]
692 errorIds
693 = [ rUNTIME_ERROR_ID,
694 nON_EXHAUSTIVE_GUARDS_ERROR_ID,
695 nO_METHOD_BINDING_ERROR_ID,
696 pAT_ERROR_ID,
697 rEC_CON_ERROR_ID,
698 rEC_SEL_ERROR_ID,
699 aBSENT_ERROR_ID,
700 tYPE_ERROR_ID -- Used with Opt_DeferTypeErrors, see #10284
701 ]
702
703 recSelErrorName, runtimeErrorName, absentErrorName :: Name
704 recConErrorName, patErrorName :: Name
705 nonExhaustiveGuardsErrorName, noMethodBindingErrorName :: Name
706 typeErrorName :: Name
707 absentSumFieldErrorName :: Name
708
709 recSelErrorName = err_nm "recSelError" recSelErrorIdKey rEC_SEL_ERROR_ID
710 absentErrorName = err_nm "absentError" absentErrorIdKey aBSENT_ERROR_ID
711 absentSumFieldErrorName = err_nm "absentSumFieldError" absentSumFieldErrorIdKey
712 aBSENT_SUM_FIELD_ERROR_ID
713 runtimeErrorName = err_nm "runtimeError" runtimeErrorIdKey rUNTIME_ERROR_ID
714 recConErrorName = err_nm "recConError" recConErrorIdKey rEC_CON_ERROR_ID
715 patErrorName = err_nm "patError" patErrorIdKey pAT_ERROR_ID
716 typeErrorName = err_nm "typeError" typeErrorIdKey tYPE_ERROR_ID
717
718 noMethodBindingErrorName = err_nm "noMethodBindingError"
719 noMethodBindingErrorIdKey nO_METHOD_BINDING_ERROR_ID
720 nonExhaustiveGuardsErrorName = err_nm "nonExhaustiveGuardsError"
721 nonExhaustiveGuardsErrorIdKey nON_EXHAUSTIVE_GUARDS_ERROR_ID
722
723 err_nm :: String -> Unique -> Id -> Name
724 err_nm str uniq id = mkWiredInIdName cONTROL_EXCEPTION_BASE (fsLit str) uniq id
725
726 rEC_SEL_ERROR_ID, rUNTIME_ERROR_ID, rEC_CON_ERROR_ID :: Id
727 pAT_ERROR_ID, nO_METHOD_BINDING_ERROR_ID, nON_EXHAUSTIVE_GUARDS_ERROR_ID :: Id
728 tYPE_ERROR_ID, aBSENT_ERROR_ID, aBSENT_SUM_FIELD_ERROR_ID :: Id
729 rEC_SEL_ERROR_ID = mkRuntimeErrorId recSelErrorName
730 rUNTIME_ERROR_ID = mkRuntimeErrorId runtimeErrorName
731 rEC_CON_ERROR_ID = mkRuntimeErrorId recConErrorName
732 pAT_ERROR_ID = mkRuntimeErrorId patErrorName
733 nO_METHOD_BINDING_ERROR_ID = mkRuntimeErrorId noMethodBindingErrorName
734 nON_EXHAUSTIVE_GUARDS_ERROR_ID = mkRuntimeErrorId nonExhaustiveGuardsErrorName
735 tYPE_ERROR_ID = mkRuntimeErrorId typeErrorName
736
737 -- Note [aBSENT_SUM_FIELD_ERROR_ID]
738 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
739 -- Absent argument error for unused unboxed sum fields are different than absent
740 -- error used in dummy worker functions (see `mkAbsentErrorApp`):
741 --
742 -- - `absentSumFieldError` can't take arguments because it's used in unarise for
743 -- unused pointer fields in unboxed sums, and applying an argument would
744 -- require allocating a thunk.
745 --
746 -- - `absentSumFieldError` can't be CAFFY because that would mean making some
747 -- non-CAFFY definitions that use unboxed sums CAFFY in unarise.
748 --
749 -- To make `absentSumFieldError` non-CAFFY we get a stable pointer to it in
750 -- RtsStartup.c and mark it as non-CAFFY here.
751 --
752 -- Getting this wrong causes hard-to-debug runtime issues, see #15038.
753 --
754 -- TODO: Remove stable pointer hack after fixing #9718.
755 -- However, we should still be careful about not making things CAFFY just
756 -- because they use unboxed sums. Unboxed objects are supposed to be
757 -- efficient, and none of the other unboxed literals make things CAFFY.
758
759 aBSENT_SUM_FIELD_ERROR_ID
760 = mkVanillaGlobalWithInfo absentSumFieldErrorName
761 (mkSpecForAllTys [alphaTyVar] (mkTyVarTy alphaTyVar)) -- forall a . a
762 (vanillaIdInfo `setStrictnessInfo` mkClosedStrictSig [] exnRes
763 `setArityInfo` 0
764 `setCafInfo` NoCafRefs) -- #15038
765
766 mkRuntimeErrorId :: Name -> Id
767 -- Error function
768 -- with type: forall (r:RuntimeRep) (a:TYPE r). Addr# -> a
769 -- with arity: 1
770 -- which diverges after being given one argument
771 -- The Addr# is expected to be the address of
772 -- a UTF8-encoded error string
773 mkRuntimeErrorId name
774 = mkVanillaGlobalWithInfo name runtimeErrorTy bottoming_info
775 where
776 bottoming_info = vanillaIdInfo `setStrictnessInfo` strict_sig
777 `setArityInfo` 1
778 -- Make arity and strictness agree
779
780 -- Do *not* mark them as NoCafRefs, because they can indeed have
781 -- CAF refs. For example, pAT_ERROR_ID calls GHC.Err.untangle,
782 -- which has some CAFs
783 -- In due course we may arrange that these error-y things are
784 -- regarded by the GC as permanently live, in which case we
785 -- can give them NoCaf info. As it is, any function that calls
786 -- any pc_bottoming_Id will itself have CafRefs, which bloats
787 -- SRTs.
788
789 strict_sig = mkClosedStrictSig [evalDmd] exnRes
790 -- exnRes: these throw an exception, not just diverge
791
792 runtimeErrorTy :: Type
793 -- forall (rr :: RuntimeRep) (a :: rr). Addr# -> a
794 -- See Note [Error and friends have an "open-tyvar" forall]
795 runtimeErrorTy = mkSpecForAllTys [runtimeRep1TyVar, openAlphaTyVar]
796 (mkFunTy addrPrimTy openAlphaTy)
797
798 {- Note [Error and friends have an "open-tyvar" forall]
799 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
800 'error' and 'undefined' have types
801 error :: forall (v :: RuntimeRep) (a :: TYPE v). String -> a
802 undefined :: forall (v :: RuntimeRep) (a :: TYPE v). a
803 Notice the runtime-representation polymorphism. This ensures that
804 "error" can be instantiated at unboxed as well as boxed types.
805 This is OK because it never returns, so the return type is irrelevant.
806
807
808 ************************************************************************
809 * *
810 aBSENT_ERROR_ID
811 * *
812 ************************************************************************
813
814 Note [aBSENT_ERROR_ID]
815 ~~~~~~~~~~~~~~~~~~~~~~
816 We use aBSENT_ERROR_ID to build dummy values in workers. E.g.
817
818 f x = (case x of (a,b) -> b) + 1::Int
819
820 The demand analyser figures ot that only the second component of x is
821 used, and does a w/w split thus
822
823 f x = case x of (a,b) -> $wf b
824
825 $wf b = let a = absentError "blah"
826 x = (a,b)
827 in <the original RHS of f>
828
829 After some simplification, the (absentError "blah") thunk goes away.
830
831 ------ Tricky wrinkle -------
832 Trac #14285 had, roughly
833
834 data T a = MkT a !a
835 {-# INLINABLE f #-}
836 f x = case x of MkT a b -> g (MkT b a)
837
838 It turned out that g didn't use the second component, and hence f doesn't use
839 the first. But the stable-unfolding for f looks like
840 \x. case x of MkT a b -> g ($WMkT b a)
841 where $WMkT is the wrapper for MkT that evaluates its arguments. We
842 apply the same w/w split to this unfolding (see Note [Worker-wrapper
843 for INLINEABLE functions] in WorkWrap) so the template ends up like
844 \b. let a = absentError "blah"
845 x = MkT a b
846 in case x of MkT a b -> g ($WMkT b a)
847
848 After doing case-of-known-constructor, and expanding $WMkT we get
849 \b -> g (case absentError "blah" of a -> MkT b a)
850
851 Yikes! That bogusly appears to evaluate the absentError!
852
853 This is extremely tiresome. Another way to think of this is that, in
854 Core, it is an invariant that a strict data contructor, like MkT, must
855 be applied only to an argument in HNF. So (absentError "blah") had
856 better be non-bottom.
857
858 So the "solution" is to add a special case for absentError to exprIsHNFlike.
859 This allows Simplify.rebuildCase, in the Note [Case to let transformation]
860 branch, to convert the case on absentError into a let. We also make
861 absentError *not* be diverging, unlike the other error-ids, so that we
862 can be sure not to remove the case branches before converting the case to
863 a let.
864
865 If, by some bug or bizarre happenstance, we ever call absentError, we should
866 throw an exception. This should never happen, of course, but we definitely
867 can't return anything. e.g. if somehow we had
868 case absentError "foo" of
869 Nothing -> ...
870 Just x -> ...
871 then if we return, the case expression will select a field and continue.
872 Seg fault city. Better to throw an exception. (Even though we've said
873 it is in HNF :-)
874
875 It might seem a bit surprising that seq on absentError is simply erased
876
877 absentError "foo" `seq` x ==> x
878
879 but that should be okay; since there's no pattern match we can't really
880 be relying on anything from it.
881 -}
882
883 aBSENT_ERROR_ID
884 = mkVanillaGlobalWithInfo absentErrorName absent_ty arity_info
885 where
886 absent_ty = mkSpecForAllTys [alphaTyVar] (mkFunTy addrPrimTy alphaTy)
887 -- Not runtime-rep polymorphic. aBSENT_ERROR_ID is only used for
888 -- lifted-type things; see Note [Absent errors] in WwLib
889 arity_info = vanillaIdInfo `setArityInfo` 1
890 -- NB: no bottoming strictness info, unlike other error-ids.
891 -- See Note [aBSENT_ERROR_ID]
892
893 mkAbsentErrorApp :: Type -- The type to instantiate 'a'
894 -> String -- The string to print
895 -> CoreExpr
896
897 mkAbsentErrorApp res_ty err_msg
898 = mkApps (Var aBSENT_ERROR_ID) [ Type res_ty, err_string ]
899 where
900 err_string = Lit (mkMachString err_msg)