Warn on inferred polymorphic recursion
[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 mkSingleAltCase,
11 sortQuantVars, castBottomExpr,
12
13 -- * Constructing boxed literals
14 mkWordExpr, mkWordExprWord,
15 mkIntExpr, mkIntExprInt,
16 mkIntegerExpr, mkNaturalExpr,
17 mkFloatExpr, mkDoubleExpr,
18 mkCharExpr, mkStringExpr, mkStringExprFS, mkStringExprFSWith,
19
20 -- * Floats
21 FloatBind(..), wrapFloat, wrapFloats, floatBindings,
22
23 -- * Constructing small tuples
24 mkCoreVarTupTy, mkCoreTup, mkCoreUbxTup,
25 mkCoreTupBoxity, unitExpr,
26
27 -- * Constructing big tuples
28 mkBigCoreVarTup, mkBigCoreVarTup1,
29 mkBigCoreVarTupTy, mkBigCoreTupTy,
30 mkBigCoreTup,
31
32 -- * Deconstructing small tuples
33 mkSmallTupleSelector, mkSmallTupleCase,
34
35 -- * Deconstructing big tuples
36 mkTupleSelector, mkTupleSelector1, mkTupleCase,
37
38 -- * Constructing list expressions
39 mkNilExpr, mkConsExpr, mkListExpr,
40 mkFoldrExpr, mkBuildExpr,
41
42 -- * Constructing Maybe expressions
43 mkNothingExpr, mkJustExpr,
44
45 -- * Error Ids
46 mkRuntimeErrorApp, mkImpossibleExpr, mkAbsentErrorApp, errorIds,
47 rEC_CON_ERROR_ID, rUNTIME_ERROR_ID,
48 nON_EXHAUSTIVE_GUARDS_ERROR_ID, nO_METHOD_BINDING_ERROR_ID,
49 pAT_ERROR_ID, rEC_SEL_ERROR_ID, aBSENT_ERROR_ID,
50 tYPE_ERROR_ID, aBSENT_SUM_FIELD_ERROR_ID
51 ) where
52
53 #include "HsVersions.h"
54
55 import GhcPrelude
56
57 import Id
58 import Var ( EvVar, setTyVarUnique )
59
60 import CoreSyn
61 import CoreUtils ( exprType, needsCaseBinding, mkSingleAltCase, bindNonRec )
62 import Literal
63 import HscTypes
64
65 import TysWiredIn
66 import PrelNames
67
68 import GHC.Hs.Utils ( mkChunkified, chunkify )
69 import Type
70 import Coercion ( isCoVar )
71 import TysPrim
72 import DataCon ( DataCon, dataConWorkId )
73 import IdInfo
74 import Demand
75 import Name hiding ( varName )
76 import Outputable
77 import FastString
78 import UniqSupply
79 import BasicTypes
80 import Util
81 import DynFlags
82 import Data.List
83
84 import Data.Char ( ord )
85 import Control.Monad.Fail as MonadFail ( MonadFail )
86
87 infixl 4 `mkCoreApp`, `mkCoreApps`
88
89 {-
90 ************************************************************************
91 * *
92 \subsection{Basic CoreSyn construction}
93 * *
94 ************************************************************************
95 -}
96 sortQuantVars :: [Var] -> [Var]
97 -- Sort the variables, putting type and covars first, in scoped order,
98 -- and then other Ids
99 -- It is a deterministic sort, meaining it doesn't look at the values of
100 -- Uniques. For explanation why it's important See Note [Unique Determinism]
101 -- in Unique.
102 sortQuantVars vs = sorted_tcvs ++ ids
103 where
104 (tcvs, ids) = partition (isTyVar <||> isCoVar) vs
105 sorted_tcvs = scopedSort tcvs
106
107 -- | Bind a binding group over an expression, using a @let@ or @case@ as
108 -- appropriate (see "CoreSyn#let_app_invariant")
109 mkCoreLet :: CoreBind -> CoreExpr -> CoreExpr
110 mkCoreLet (NonRec bndr rhs) body -- See Note [CoreSyn let/app invariant]
111 = bindNonRec bndr rhs body
112 mkCoreLet bind body
113 = Let bind body
114
115 -- | Create a lambda where the given expression has a number of variables
116 -- bound over it. The leftmost binder is that bound by the outermost
117 -- lambda in the result
118 mkCoreLams :: [CoreBndr] -> CoreExpr -> CoreExpr
119 mkCoreLams = mkLams
120
121 -- | Bind a list of binding groups over an expression. The leftmost binding
122 -- group becomes the outermost group in the resulting expression
123 mkCoreLets :: [CoreBind] -> CoreExpr -> CoreExpr
124 mkCoreLets binds body = foldr mkCoreLet body binds
125
126 -- | Construct an expression which represents the application of a number of
127 -- expressions to that of a data constructor expression. The leftmost expression
128 -- in the list is applied first
129 mkCoreConApps :: DataCon -> [CoreExpr] -> CoreExpr
130 mkCoreConApps con args = mkCoreApps (Var (dataConWorkId con)) args
131
132 -- | Construct an expression which represents the application of a number of
133 -- expressions to another. The leftmost expression in the list is applied first
134 -- Respects the let/app invariant by building a case expression where necessary
135 -- See CoreSyn Note [CoreSyn let/app invariant]
136 mkCoreApps :: CoreExpr -> [CoreExpr] -> CoreExpr
137 mkCoreApps fun args
138 = fst $
139 foldl' (mkCoreAppTyped doc_string) (fun, fun_ty) args
140 where
141 doc_string = ppr fun_ty $$ ppr fun $$ ppr args
142 fun_ty = exprType fun
143
144 -- | Construct an expression which represents the application of one expression
145 -- to the other
146 -- Respects the let/app invariant by building a case expression where necessary
147 -- See CoreSyn Note [CoreSyn let/app invariant]
148 mkCoreApp :: SDoc -> CoreExpr -> CoreExpr -> CoreExpr
149 mkCoreApp s fun arg
150 = fst $ mkCoreAppTyped s (fun, exprType fun) arg
151
152 -- | Construct an expression which represents the application of one expression
153 -- paired with its type to an argument. The result is paired with its type. This
154 -- function is not exported and used in the definition of 'mkCoreApp' and
155 -- 'mkCoreApps'.
156 -- Respects the let/app invariant by building a case expression where necessary
157 -- See CoreSyn Note [CoreSyn let/app invariant]
158 mkCoreAppTyped :: SDoc -> (CoreExpr, Type) -> CoreExpr -> (CoreExpr, Type)
159 mkCoreAppTyped _ (fun, fun_ty) (Type ty)
160 = (App fun (Type ty), piResultTy fun_ty ty)
161 mkCoreAppTyped _ (fun, fun_ty) (Coercion co)
162 = (App fun (Coercion co), funResultTy fun_ty)
163 mkCoreAppTyped d (fun, fun_ty) arg
164 = ASSERT2( isFunTy fun_ty, ppr fun $$ ppr arg $$ d )
165 (mkValApp fun arg arg_ty res_ty, res_ty)
166 where
167 (arg_ty, res_ty) = splitFunTy fun_ty
168
169 mkValApp :: CoreExpr -> CoreExpr -> Type -> Type -> CoreExpr
170 -- Build an application (e1 e2),
171 -- or a strict binding (case e2 of x -> e1 x)
172 -- using the latter when necessary to respect the let/app invariant
173 -- See Note [CoreSyn let/app invariant]
174 mkValApp fun arg arg_ty res_ty
175 | not (needsCaseBinding arg_ty arg)
176 = App fun arg -- The vastly common case
177 | otherwise
178 = mkStrictApp fun arg arg_ty res_ty
179
180 {- *********************************************************************
181 * *
182 Building case expressions
183 * *
184 ********************************************************************* -}
185
186 mkWildEvBinder :: PredType -> EvVar
187 mkWildEvBinder pred = mkWildValBinder pred
188
189 -- | Make a /wildcard binder/. This is typically used when you need a binder
190 -- that you expect to use only at a *binding* site. Do not use it at
191 -- occurrence sites because it has a single, fixed unique, and it's very
192 -- easy to get into difficulties with shadowing. That's why it is used so little.
193 -- See Note [WildCard binders] in SimplEnv
194 mkWildValBinder :: Type -> Id
195 mkWildValBinder ty = mkLocalIdOrCoVar wildCardName ty
196
197 mkWildCase :: CoreExpr -> Type -> Type -> [CoreAlt] -> CoreExpr
198 -- Make a case expression whose case binder is unused
199 -- The alts and res_ty should not have any occurrences of WildId
200 mkWildCase scrut scrut_ty res_ty alts
201 = Case scrut (mkWildValBinder scrut_ty) res_ty alts
202
203 mkStrictApp :: CoreExpr -> CoreExpr -> Type -> Type -> CoreExpr
204 -- Build a strict application (case e2 of x -> e1 x)
205 mkStrictApp fun arg arg_ty res_ty
206 = Case arg arg_id res_ty [(DEFAULT,[],App fun (Var arg_id))]
207 -- mkDefaultCase looks attractive here, and would be sound.
208 -- But it uses (exprType alt_rhs) to compute the result type,
209 -- whereas here we already know that the result type is res_ty
210 where
211 arg_id = mkWildValBinder arg_ty
212 -- Lots of shadowing, but it doesn't matter,
213 -- because 'fun' and 'res_ty' should not have a free wild-id
214 --
215 -- This is Dangerous. But this is the only place we play this
216 -- game, mkStrictApp returns an expression that does not have
217 -- a free wild-id. So the only way 'fun' could get a free wild-id
218 -- would be if you take apart this case expression (or some other
219 -- expression that uses mkWildValBinder, of which there are not
220 -- many), and pass a fragment of it as the fun part of a 'mkStrictApp'.
221
222 mkIfThenElse :: CoreExpr -> CoreExpr -> CoreExpr -> CoreExpr
223 mkIfThenElse guard then_expr else_expr
224 -- Not going to be refining, so okay to take the type of the "then" clause
225 = mkWildCase guard boolTy (exprType then_expr)
226 [ (DataAlt falseDataCon, [], else_expr), -- Increasing order of tag!
227 (DataAlt trueDataCon, [], then_expr) ]
228
229 castBottomExpr :: CoreExpr -> Type -> CoreExpr
230 -- (castBottomExpr e ty), assuming that 'e' diverges,
231 -- return an expression of type 'ty'
232 -- See Note [Empty case alternatives] in CoreSyn
233 castBottomExpr e res_ty
234 | e_ty `eqType` res_ty = e
235 | otherwise = Case e (mkWildValBinder e_ty) res_ty []
236 where
237 e_ty = exprType e
238
239 {-
240 ************************************************************************
241 * *
242 \subsection{Making literals}
243 * *
244 ************************************************************************
245 -}
246
247 -- | Create a 'CoreExpr' which will evaluate to the given @Int@
248 mkIntExpr :: DynFlags -> Integer -> CoreExpr -- Result = I# i :: Int
249 mkIntExpr dflags i = mkCoreConApps intDataCon [mkIntLit dflags i]
250
251 -- | Create a 'CoreExpr' which will evaluate to the given @Int@
252 mkIntExprInt :: DynFlags -> Int -> CoreExpr -- Result = I# i :: Int
253 mkIntExprInt dflags i = mkCoreConApps intDataCon [mkIntLitInt dflags i]
254
255 -- | Create a 'CoreExpr' which will evaluate to the a @Word@ with the given value
256 mkWordExpr :: DynFlags -> Integer -> CoreExpr
257 mkWordExpr dflags w = mkCoreConApps wordDataCon [mkWordLit dflags w]
258
259 -- | Create a 'CoreExpr' which will evaluate to the given @Word@
260 mkWordExprWord :: DynFlags -> Word -> CoreExpr
261 mkWordExprWord dflags w = mkCoreConApps wordDataCon [mkWordLitWord dflags w]
262
263 -- | Create a 'CoreExpr' which will evaluate to the given @Integer@
264 mkIntegerExpr :: MonadThings m => Integer -> m CoreExpr -- Result :: Integer
265 mkIntegerExpr i = do t <- lookupTyCon integerTyConName
266 return (Lit (mkLitInteger i (mkTyConTy t)))
267
268 -- | Create a 'CoreExpr' which will evaluate to the given @Natural@
269 mkNaturalExpr :: MonadThings m => Integer -> m CoreExpr
270 mkNaturalExpr i = do t <- lookupTyCon naturalTyConName
271 return (Lit (mkLitNatural i (mkTyConTy t)))
272
273 -- | Create a 'CoreExpr' which will evaluate to the given @Float@
274 mkFloatExpr :: Float -> CoreExpr
275 mkFloatExpr f = mkCoreConApps floatDataCon [mkFloatLitFloat f]
276
277 -- | Create a 'CoreExpr' which will evaluate to the given @Double@
278 mkDoubleExpr :: Double -> CoreExpr
279 mkDoubleExpr d = mkCoreConApps doubleDataCon [mkDoubleLitDouble d]
280
281
282 -- | Create a 'CoreExpr' which will evaluate to the given @Char@
283 mkCharExpr :: Char -> CoreExpr -- Result = C# c :: Int
284 mkCharExpr c = mkCoreConApps charDataCon [mkCharLit c]
285
286 -- | Create a 'CoreExpr' which will evaluate to the given @String@
287 mkStringExpr :: MonadThings m => String -> m CoreExpr -- Result :: String
288
289 -- | Create a 'CoreExpr' which will evaluate to a string morally equivalent to the given @FastString@
290 mkStringExprFS :: MonadThings m => FastString -> m CoreExpr -- Result :: String
291
292 mkStringExpr str = mkStringExprFS (mkFastString str)
293
294 mkStringExprFS = mkStringExprFSWith lookupId
295
296 mkStringExprFSWith :: Monad m => (Name -> m Id) -> FastString -> m CoreExpr
297 mkStringExprFSWith lookupM str
298 | nullFS str
299 = return (mkNilExpr charTy)
300
301 | all safeChar chars
302 = do unpack_id <- lookupM unpackCStringName
303 return (App (Var unpack_id) lit)
304
305 | otherwise
306 = do unpack_utf8_id <- lookupM unpackCStringUtf8Name
307 return (App (Var unpack_utf8_id) lit)
308
309 where
310 chars = unpackFS str
311 safeChar c = ord c >= 1 && ord c <= 0x7F
312 lit = Lit (LitString (bytesFS str))
313
314 {-
315 ************************************************************************
316 * *
317 \subsection{Tuple constructors}
318 * *
319 ************************************************************************
320 -}
321
322 {-
323 Creating tuples and their types for Core expressions
324
325 @mkBigCoreVarTup@ builds a tuple; the inverse to @mkTupleSelector@.
326
327 * If it has only one element, it is the identity function.
328
329 * If there are more elements than a big tuple can have, it nests
330 the tuples.
331
332 Note [Flattening one-tuples]
333 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
334 This family of functions creates a tuple of variables/expressions/types.
335 mkCoreTup [e1,e2,e3] = (e1,e2,e3)
336 What if there is just one variable/expression/type in the argument?
337 We could do one of two things:
338
339 * Flatten it out, so that
340 mkCoreTup [e1] = e1
341
342 * Build a one-tuple (see Note [One-tuples] in TysWiredIn)
343 mkCoreTup1 [e1] = Unit e1
344 We use a suffix "1" to indicate this.
345
346 Usually we want the former, but occasionally the latter.
347
348 NB: The logic in tupleDataCon knows about () and Unit and (,), etc.
349
350 Note [Don't flatten tuples from HsSyn]
351 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
352 If we get an explicit 1-tuple from HsSyn somehow (likely: Template Haskell),
353 we should treat it really as a 1-tuple, without flattening. Note that a
354 1-tuple and a flattened value have different performance and laziness
355 characteristics, so should just do what we're asked.
356
357 This arose from discussions in #16881.
358
359 One-tuples that arise internally depend on the circumstance; often flattening
360 is a good idea. Decisions are made on a case-by-case basis.
361
362 -}
363
364 -- | Build the type of a small tuple that holds the specified variables
365 -- One-tuples are flattened; see Note [Flattening one-tuples]
366 mkCoreVarTupTy :: [Id] -> Type
367 mkCoreVarTupTy ids = mkBoxedTupleTy (map idType ids)
368
369 -- | Build a small tuple holding the specified expressions
370 -- One-tuples are flattened; see Note [Flattening one-tuples]
371 mkCoreTup :: [CoreExpr] -> CoreExpr
372 mkCoreTup [c] = c
373 mkCoreTup cs = mkCoreTup1 cs -- non-1-tuples are uniform
374
375 -- | Build a small tuple holding the specified expressions
376 -- One-tuples are *not* flattened; see Note [Flattening one-tuples]
377 -- See also Note [Don't flatten tuples from HsSyn]
378 mkCoreTup1 :: [CoreExpr] -> CoreExpr
379 mkCoreTup1 cs = mkCoreConApps (tupleDataCon Boxed (length cs))
380 (map (Type . exprType) cs ++ cs)
381
382 -- | Build a small unboxed tuple holding the specified expressions,
383 -- with the given types. The types must be the types of the expressions.
384 -- Do not include the RuntimeRep specifiers; this function calculates them
385 -- for you.
386 -- Does /not/ flatten one-tuples; see Note [Flattening one-tuples]
387 mkCoreUbxTup :: [Type] -> [CoreExpr] -> CoreExpr
388 mkCoreUbxTup tys exps
389 = ASSERT( tys `equalLength` exps)
390 mkCoreConApps (tupleDataCon Unboxed (length tys))
391 (map (Type . getRuntimeRep) tys ++ map Type tys ++ exps)
392
393 -- | Make a core tuple of the given boxity; don't flatten 1-tuples
394 mkCoreTupBoxity :: Boxity -> [CoreExpr] -> CoreExpr
395 mkCoreTupBoxity Boxed exps = mkCoreTup1 exps
396 mkCoreTupBoxity Unboxed exps = mkCoreUbxTup (map exprType exps) exps
397
398 -- | Build a big tuple holding the specified variables
399 -- One-tuples are flattened; see Note [Flattening one-tuples]
400 mkBigCoreVarTup :: [Id] -> CoreExpr
401 mkBigCoreVarTup ids = mkBigCoreTup (map Var ids)
402
403 mkBigCoreVarTup1 :: [Id] -> CoreExpr
404 -- Same as mkBigCoreVarTup, but one-tuples are NOT flattened
405 -- see Note [Flattening one-tuples]
406 mkBigCoreVarTup1 [id] = mkCoreConApps (tupleDataCon Boxed 1)
407 [Type (idType id), Var id]
408 mkBigCoreVarTup1 ids = mkBigCoreTup (map Var ids)
409
410 -- | Build the type of a big tuple that holds the specified variables
411 -- One-tuples are flattened; see Note [Flattening one-tuples]
412 mkBigCoreVarTupTy :: [Id] -> Type
413 mkBigCoreVarTupTy ids = mkBigCoreTupTy (map idType ids)
414
415 -- | Build a big tuple holding the specified expressions
416 -- One-tuples are flattened; see Note [Flattening one-tuples]
417 mkBigCoreTup :: [CoreExpr] -> CoreExpr
418 mkBigCoreTup = mkChunkified mkCoreTup
419
420 -- | Build the type of a big tuple that holds the specified type of thing
421 -- One-tuples are flattened; see Note [Flattening one-tuples]
422 mkBigCoreTupTy :: [Type] -> Type
423 mkBigCoreTupTy = mkChunkified mkBoxedTupleTy
424
425 -- | The unit expression
426 unitExpr :: CoreExpr
427 unitExpr = Var unitDataConId
428
429 {-
430 ************************************************************************
431 * *
432 \subsection{Tuple destructors}
433 * *
434 ************************************************************************
435 -}
436
437 -- | Builds a selector which scrutises the given
438 -- expression and extracts the one name from the list given.
439 -- If you want the no-shadowing rule to apply, the caller
440 -- is responsible for making sure that none of these names
441 -- are in scope.
442 --
443 -- If there is just one 'Id' in the tuple, then the selector is
444 -- just the identity.
445 --
446 -- If necessary, we pattern match on a \"big\" tuple.
447 mkTupleSelector, mkTupleSelector1
448 :: [Id] -- ^ The 'Id's to pattern match the tuple against
449 -> Id -- ^ The 'Id' to select
450 -> Id -- ^ A variable of the same type as the scrutinee
451 -> CoreExpr -- ^ Scrutinee
452 -> CoreExpr -- ^ Selector expression
453
454 -- mkTupleSelector [a,b,c,d] b v e
455 -- = case e of v {
456 -- (p,q) -> case p of p {
457 -- (a,b) -> b }}
458 -- We use 'tpl' vars for the p,q, since shadowing does not matter.
459 --
460 -- In fact, it's more convenient to generate it innermost first, getting
461 --
462 -- case (case e of v
463 -- (p,q) -> p) of p
464 -- (a,b) -> b
465 mkTupleSelector vars the_var scrut_var scrut
466 = mk_tup_sel (chunkify vars) the_var
467 where
468 mk_tup_sel [vars] the_var = mkSmallTupleSelector vars the_var scrut_var scrut
469 mk_tup_sel vars_s the_var = mkSmallTupleSelector group the_var tpl_v $
470 mk_tup_sel (chunkify tpl_vs) tpl_v
471 where
472 tpl_tys = [mkBoxedTupleTy (map idType gp) | gp <- vars_s]
473 tpl_vs = mkTemplateLocals tpl_tys
474 [(tpl_v, group)] = [(tpl,gp) | (tpl,gp) <- zipEqual "mkTupleSelector" tpl_vs vars_s,
475 the_var `elem` gp ]
476 -- ^ 'mkTupleSelector1' is like 'mkTupleSelector'
477 -- but one-tuples are NOT flattened (see Note [Flattening one-tuples])
478 mkTupleSelector1 vars the_var scrut_var scrut
479 | [_] <- vars
480 = mkSmallTupleSelector1 vars the_var scrut_var scrut
481 | otherwise
482 = mkTupleSelector vars the_var scrut_var scrut
483
484 -- | Like 'mkTupleSelector' but for tuples that are guaranteed
485 -- never to be \"big\".
486 --
487 -- > mkSmallTupleSelector [x] x v e = [| e |]
488 -- > mkSmallTupleSelector [x,y,z] x v e = [| case e of v { (x,y,z) -> x } |]
489 mkSmallTupleSelector, mkSmallTupleSelector1
490 :: [Id] -- The tuple args
491 -> Id -- The selected one
492 -> Id -- A variable of the same type as the scrutinee
493 -> CoreExpr -- Scrutinee
494 -> CoreExpr
495 mkSmallTupleSelector [var] should_be_the_same_var _ scrut
496 = ASSERT(var == should_be_the_same_var)
497 scrut -- Special case for 1-tuples
498 mkSmallTupleSelector vars the_var scrut_var scrut
499 = mkSmallTupleSelector1 vars the_var scrut_var scrut
500
501 -- ^ 'mkSmallTupleSelector1' is like 'mkSmallTupleSelector'
502 -- but one-tuples are NOT flattened (see Note [Flattening one-tuples])
503 mkSmallTupleSelector1 vars the_var scrut_var scrut
504 = ASSERT( notNull vars )
505 Case scrut scrut_var (idType the_var)
506 [(DataAlt (tupleDataCon Boxed (length vars)), vars, Var the_var)]
507
508 -- | A generalization of 'mkTupleSelector', allowing the body
509 -- of the case to be an arbitrary expression.
510 --
511 -- To avoid shadowing, we use uniques to invent new variables.
512 --
513 -- If necessary we pattern match on a \"big\" tuple.
514 mkTupleCase :: UniqSupply -- ^ For inventing names of intermediate variables
515 -> [Id] -- ^ The tuple identifiers to pattern match on
516 -> CoreExpr -- ^ Body of the case
517 -> Id -- ^ A variable of the same type as the scrutinee
518 -> CoreExpr -- ^ Scrutinee
519 -> CoreExpr
520 -- ToDo: eliminate cases where none of the variables are needed.
521 --
522 -- mkTupleCase uniqs [a,b,c,d] body v e
523 -- = case e of v { (p,q) ->
524 -- case p of p { (a,b) ->
525 -- case q of q { (c,d) ->
526 -- body }}}
527 mkTupleCase uniqs vars body scrut_var scrut
528 = mk_tuple_case uniqs (chunkify vars) body
529 where
530 -- This is the case where don't need any nesting
531 mk_tuple_case _ [vars] body
532 = mkSmallTupleCase vars body scrut_var scrut
533
534 -- This is the case where we must make nest tuples at least once
535 mk_tuple_case us vars_s body
536 = let (us', vars', body') = foldr one_tuple_case (us, [], body) vars_s
537 in mk_tuple_case us' (chunkify vars') body'
538
539 one_tuple_case chunk_vars (us, vs, body)
540 = let (uniq, us') = takeUniqFromSupply us
541 scrut_var = mkSysLocal (fsLit "ds") uniq
542 (mkBoxedTupleTy (map idType chunk_vars))
543 body' = mkSmallTupleCase chunk_vars body scrut_var (Var scrut_var)
544 in (us', scrut_var:vs, body')
545
546 -- | As 'mkTupleCase', but for a tuple that is small enough to be guaranteed
547 -- not to need nesting.
548 mkSmallTupleCase
549 :: [Id] -- ^ The tuple args
550 -> CoreExpr -- ^ Body of the case
551 -> Id -- ^ A variable of the same type as the scrutinee
552 -> CoreExpr -- ^ Scrutinee
553 -> CoreExpr
554
555 mkSmallTupleCase [var] body _scrut_var scrut
556 = bindNonRec var scrut body
557 mkSmallTupleCase vars body scrut_var scrut
558 -- One branch no refinement?
559 = Case scrut scrut_var (exprType body)
560 [(DataAlt (tupleDataCon Boxed (length vars)), vars, body)]
561
562 {-
563 ************************************************************************
564 * *
565 Floats
566 * *
567 ************************************************************************
568 -}
569
570 data FloatBind
571 = FloatLet CoreBind
572 | FloatCase CoreExpr Id AltCon [Var]
573 -- case e of y { C ys -> ... }
574 -- See Note [Floating single-alternative cases] in SetLevels
575
576 instance Outputable FloatBind where
577 ppr (FloatLet b) = text "LET" <+> ppr b
578 ppr (FloatCase e b c bs) = hang (text "CASE" <+> ppr e <+> ptext (sLit "of") <+> ppr b)
579 2 (ppr c <+> ppr bs)
580
581 wrapFloat :: FloatBind -> CoreExpr -> CoreExpr
582 wrapFloat (FloatLet defns) body = Let defns body
583 wrapFloat (FloatCase e b con bs) body = mkSingleAltCase e b con bs body
584
585 -- | Applies the floats from right to left. That is @wrapFloats [b1, b2, …, bn]
586 -- u = let b1 in let b2 in … in let bn in u@
587 wrapFloats :: [FloatBind] -> CoreExpr -> CoreExpr
588 wrapFloats floats expr = foldr wrapFloat expr floats
589
590 bindBindings :: CoreBind -> [Var]
591 bindBindings (NonRec b _) = [b]
592 bindBindings (Rec bnds) = map fst bnds
593
594 floatBindings :: FloatBind -> [Var]
595 floatBindings (FloatLet bnd) = bindBindings bnd
596 floatBindings (FloatCase _ b _ bs) = b:bs
597
598 {-
599 ************************************************************************
600 * *
601 \subsection{Common list manipulation expressions}
602 * *
603 ************************************************************************
604
605 Call the constructor Ids when building explicit lists, so that they
606 interact well with rules.
607 -}
608
609 -- | Makes a list @[]@ for lists of the specified type
610 mkNilExpr :: Type -> CoreExpr
611 mkNilExpr ty = mkCoreConApps nilDataCon [Type ty]
612
613 -- | Makes a list @(:)@ for lists of the specified type
614 mkConsExpr :: Type -> CoreExpr -> CoreExpr -> CoreExpr
615 mkConsExpr ty hd tl = mkCoreConApps consDataCon [Type ty, hd, tl]
616
617 -- | Make a list containing the given expressions, where the list has the given type
618 mkListExpr :: Type -> [CoreExpr] -> CoreExpr
619 mkListExpr ty xs = foldr (mkConsExpr ty) (mkNilExpr ty) xs
620
621 -- | Make a fully applied 'foldr' expression
622 mkFoldrExpr :: MonadThings m
623 => Type -- ^ Element type of the list
624 -> Type -- ^ Fold result type
625 -> CoreExpr -- ^ "Cons" function expression for the fold
626 -> CoreExpr -- ^ "Nil" expression for the fold
627 -> CoreExpr -- ^ List expression being folded acress
628 -> m CoreExpr
629 mkFoldrExpr elt_ty result_ty c n list = do
630 foldr_id <- lookupId foldrName
631 return (Var foldr_id `App` Type elt_ty
632 `App` Type result_ty
633 `App` c
634 `App` n
635 `App` list)
636
637 -- | Make a 'build' expression applied to a locally-bound worker function
638 mkBuildExpr :: (MonadFail.MonadFail m, MonadThings m, MonadUnique m)
639 => Type -- ^ Type of list elements to be built
640 -> ((Id, Type) -> (Id, Type) -> m CoreExpr) -- ^ Function that, given information about the 'Id's
641 -- of the binders for the build worker function, returns
642 -- the body of that worker
643 -> m CoreExpr
644 mkBuildExpr elt_ty mk_build_inside = do
645 [n_tyvar] <- newTyVars [alphaTyVar]
646 let n_ty = mkTyVarTy n_tyvar
647 c_ty = mkVisFunTys [elt_ty, n_ty] n_ty
648 [c, n] <- sequence [mkSysLocalM (fsLit "c") c_ty, mkSysLocalM (fsLit "n") n_ty]
649
650 build_inside <- mk_build_inside (c, c_ty) (n, n_ty)
651
652 build_id <- lookupId buildName
653 return $ Var build_id `App` Type elt_ty `App` mkLams [n_tyvar, c, n] build_inside
654 where
655 newTyVars tyvar_tmpls = do
656 uniqs <- getUniquesM
657 return (zipWith setTyVarUnique tyvar_tmpls uniqs)
658
659 {-
660 ************************************************************************
661 * *
662 Manipulating Maybe data type
663 * *
664 ************************************************************************
665 -}
666
667
668 -- | Makes a Nothing for the specified type
669 mkNothingExpr :: Type -> CoreExpr
670 mkNothingExpr ty = mkConApp nothingDataCon [Type ty]
671
672 -- | Makes a Just from a value of the specified type
673 mkJustExpr :: Type -> CoreExpr -> CoreExpr
674 mkJustExpr ty val = mkConApp justDataCon [Type ty, val]
675
676
677 {-
678 ************************************************************************
679 * *
680 Error expressions
681 * *
682 ************************************************************************
683 -}
684
685 mkRuntimeErrorApp
686 :: Id -- Should be of type (forall a. Addr# -> a)
687 -- where Addr# points to a UTF8 encoded string
688 -> Type -- The type to instantiate 'a'
689 -> String -- The string to print
690 -> CoreExpr
691
692 mkRuntimeErrorApp err_id res_ty err_msg
693 = mkApps (Var err_id) [ Type (getRuntimeRep res_ty)
694 , Type res_ty, err_string ]
695 where
696 err_string = Lit (mkLitString err_msg)
697
698 mkImpossibleExpr :: Type -> CoreExpr
699 mkImpossibleExpr res_ty
700 = mkRuntimeErrorApp rUNTIME_ERROR_ID res_ty "Impossible case alternative"
701
702 {-
703 ************************************************************************
704 * *
705 Error Ids
706 * *
707 ************************************************************************
708
709 GHC randomly injects these into the code.
710
711 @patError@ is just a version of @error@ for pattern-matching
712 failures. It knows various ``codes'' which expand to longer
713 strings---this saves space!
714
715 @absentErr@ is a thing we put in for ``absent'' arguments. They jolly
716 well shouldn't be yanked on, but if one is, then you will get a
717 friendly message from @absentErr@ (rather than a totally random
718 crash).
719
720 @parError@ is a special version of @error@ which the compiler does
721 not know to be a bottoming Id. It is used in the @_par_@ and @_seq_@
722 templates, but we don't ever expect to generate code for it.
723 -}
724
725 errorIds :: [Id]
726 errorIds
727 = [ rUNTIME_ERROR_ID,
728 nON_EXHAUSTIVE_GUARDS_ERROR_ID,
729 nO_METHOD_BINDING_ERROR_ID,
730 pAT_ERROR_ID,
731 rEC_CON_ERROR_ID,
732 rEC_SEL_ERROR_ID,
733 aBSENT_ERROR_ID,
734 tYPE_ERROR_ID -- Used with Opt_DeferTypeErrors, see #10284
735 ]
736
737 recSelErrorName, runtimeErrorName, absentErrorName :: Name
738 recConErrorName, patErrorName :: Name
739 nonExhaustiveGuardsErrorName, noMethodBindingErrorName :: Name
740 typeErrorName :: Name
741 absentSumFieldErrorName :: Name
742
743 recSelErrorName = err_nm "recSelError" recSelErrorIdKey rEC_SEL_ERROR_ID
744 absentErrorName = err_nm "absentError" absentErrorIdKey aBSENT_ERROR_ID
745 absentSumFieldErrorName = err_nm "absentSumFieldError" absentSumFieldErrorIdKey
746 aBSENT_SUM_FIELD_ERROR_ID
747 runtimeErrorName = err_nm "runtimeError" runtimeErrorIdKey rUNTIME_ERROR_ID
748 recConErrorName = err_nm "recConError" recConErrorIdKey rEC_CON_ERROR_ID
749 patErrorName = err_nm "patError" patErrorIdKey pAT_ERROR_ID
750 typeErrorName = err_nm "typeError" typeErrorIdKey tYPE_ERROR_ID
751
752 noMethodBindingErrorName = err_nm "noMethodBindingError"
753 noMethodBindingErrorIdKey nO_METHOD_BINDING_ERROR_ID
754 nonExhaustiveGuardsErrorName = err_nm "nonExhaustiveGuardsError"
755 nonExhaustiveGuardsErrorIdKey nON_EXHAUSTIVE_GUARDS_ERROR_ID
756
757 err_nm :: String -> Unique -> Id -> Name
758 err_nm str uniq id = mkWiredInIdName cONTROL_EXCEPTION_BASE (fsLit str) uniq id
759
760 rEC_SEL_ERROR_ID, rUNTIME_ERROR_ID, rEC_CON_ERROR_ID :: Id
761 pAT_ERROR_ID, nO_METHOD_BINDING_ERROR_ID, nON_EXHAUSTIVE_GUARDS_ERROR_ID :: Id
762 tYPE_ERROR_ID, aBSENT_ERROR_ID, aBSENT_SUM_FIELD_ERROR_ID :: Id
763 rEC_SEL_ERROR_ID = mkRuntimeErrorId recSelErrorName
764 rUNTIME_ERROR_ID = mkRuntimeErrorId runtimeErrorName
765 rEC_CON_ERROR_ID = mkRuntimeErrorId recConErrorName
766 pAT_ERROR_ID = mkRuntimeErrorId patErrorName
767 nO_METHOD_BINDING_ERROR_ID = mkRuntimeErrorId noMethodBindingErrorName
768 nON_EXHAUSTIVE_GUARDS_ERROR_ID = mkRuntimeErrorId nonExhaustiveGuardsErrorName
769 tYPE_ERROR_ID = mkRuntimeErrorId typeErrorName
770
771 -- Note [aBSENT_SUM_FIELD_ERROR_ID]
772 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
773 -- Absent argument error for unused unboxed sum fields are different than absent
774 -- error used in dummy worker functions (see `mkAbsentErrorApp`):
775 --
776 -- - `absentSumFieldError` can't take arguments because it's used in unarise for
777 -- unused pointer fields in unboxed sums, and applying an argument would
778 -- require allocating a thunk.
779 --
780 -- - `absentSumFieldError` can't be CAFFY because that would mean making some
781 -- non-CAFFY definitions that use unboxed sums CAFFY in unarise.
782 --
783 -- To make `absentSumFieldError` non-CAFFY we get a stable pointer to it in
784 -- RtsStartup.c and mark it as non-CAFFY here.
785 --
786 -- Getting this wrong causes hard-to-debug runtime issues, see #15038.
787 --
788 -- TODO: Remove stable pointer hack after fixing #9718.
789 -- However, we should still be careful about not making things CAFFY just
790 -- because they use unboxed sums. Unboxed objects are supposed to be
791 -- efficient, and none of the other unboxed literals make things CAFFY.
792
793 aBSENT_SUM_FIELD_ERROR_ID
794 = mkVanillaGlobalWithInfo absentSumFieldErrorName
795 (mkSpecForAllTys [alphaTyVar] (mkTyVarTy alphaTyVar)) -- forall a . a
796 (vanillaIdInfo `setStrictnessInfo` mkClosedStrictSig [] botRes
797 `setArityInfo` 0
798 `setCafInfo` NoCafRefs) -- #15038
799
800 mkRuntimeErrorId :: Name -> Id
801 -- Error function
802 -- with type: forall (r:RuntimeRep) (a:TYPE r). Addr# -> a
803 -- with arity: 1
804 -- which diverges after being given one argument
805 -- The Addr# is expected to be the address of
806 -- a UTF8-encoded error string
807 mkRuntimeErrorId name
808 = mkVanillaGlobalWithInfo name runtimeErrorTy bottoming_info
809 where
810 bottoming_info = vanillaIdInfo `setStrictnessInfo` strict_sig
811 `setArityInfo` 1
812 -- Make arity and strictness agree
813
814 -- Do *not* mark them as NoCafRefs, because they can indeed have
815 -- CAF refs. For example, pAT_ERROR_ID calls GHC.Err.untangle,
816 -- which has some CAFs
817 -- In due course we may arrange that these error-y things are
818 -- regarded by the GC as permanently live, in which case we
819 -- can give them NoCaf info. As it is, any function that calls
820 -- any pc_bottoming_Id will itself have CafRefs, which bloats
821 -- SRTs.
822
823 strict_sig = mkClosedStrictSig [evalDmd] botRes
824
825 runtimeErrorTy :: Type
826 -- forall (rr :: RuntimeRep) (a :: rr). Addr# -> a
827 -- See Note [Error and friends have an "open-tyvar" forall]
828 runtimeErrorTy = mkSpecForAllTys [runtimeRep1TyVar, openAlphaTyVar]
829 (mkVisFunTy addrPrimTy openAlphaTy)
830
831 {- Note [Error and friends have an "open-tyvar" forall]
832 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
833 'error' and 'undefined' have types
834 error :: forall (v :: RuntimeRep) (a :: TYPE v). String -> a
835 undefined :: forall (v :: RuntimeRep) (a :: TYPE v). a
836 Notice the runtime-representation polymorphism. This ensures that
837 "error" can be instantiated at unboxed as well as boxed types.
838 This is OK because it never returns, so the return type is irrelevant.
839
840
841 ************************************************************************
842 * *
843 aBSENT_ERROR_ID
844 * *
845 ************************************************************************
846
847 Note [aBSENT_ERROR_ID]
848 ~~~~~~~~~~~~~~~~~~~~~~
849 We use aBSENT_ERROR_ID to build dummy values in workers. E.g.
850
851 f x = (case x of (a,b) -> b) + 1::Int
852
853 The demand analyser figures ot that only the second component of x is
854 used, and does a w/w split thus
855
856 f x = case x of (a,b) -> $wf b
857
858 $wf b = let a = absentError "blah"
859 x = (a,b)
860 in <the original RHS of f>
861
862 After some simplification, the (absentError "blah") thunk goes away.
863
864 ------ Tricky wrinkle -------
865 #14285 had, roughly
866
867 data T a = MkT a !a
868 {-# INLINABLE f #-}
869 f x = case x of MkT a b -> g (MkT b a)
870
871 It turned out that g didn't use the second component, and hence f doesn't use
872 the first. But the stable-unfolding for f looks like
873 \x. case x of MkT a b -> g ($WMkT b a)
874 where $WMkT is the wrapper for MkT that evaluates its arguments. We
875 apply the same w/w split to this unfolding (see Note [Worker-wrapper
876 for INLINEABLE functions] in WorkWrap) so the template ends up like
877 \b. let a = absentError "blah"
878 x = MkT a b
879 in case x of MkT a b -> g ($WMkT b a)
880
881 After doing case-of-known-constructor, and expanding $WMkT we get
882 \b -> g (case absentError "blah" of a -> MkT b a)
883
884 Yikes! That bogusly appears to evaluate the absentError!
885
886 This is extremely tiresome. Another way to think of this is that, in
887 Core, it is an invariant that a strict data contructor, like MkT, must
888 be applied only to an argument in HNF. So (absentError "blah") had
889 better be non-bottom.
890
891 So the "solution" is to add a special case for absentError to exprIsHNFlike.
892 This allows Simplify.rebuildCase, in the Note [Case to let transformation]
893 branch, to convert the case on absentError into a let. We also make
894 absentError *not* be diverging, unlike the other error-ids, so that we
895 can be sure not to remove the case branches before converting the case to
896 a let.
897
898 If, by some bug or bizarre happenstance, we ever call absentError, we should
899 throw an exception. This should never happen, of course, but we definitely
900 can't return anything. e.g. if somehow we had
901 case absentError "foo" of
902 Nothing -> ...
903 Just x -> ...
904 then if we return, the case expression will select a field and continue.
905 Seg fault city. Better to throw an exception. (Even though we've said
906 it is in HNF :-)
907
908 It might seem a bit surprising that seq on absentError is simply erased
909
910 absentError "foo" `seq` x ==> x
911
912 but that should be okay; since there's no pattern match we can't really
913 be relying on anything from it.
914 -}
915
916 aBSENT_ERROR_ID
917 = mkVanillaGlobalWithInfo absentErrorName absent_ty arity_info
918 where
919 absent_ty = mkSpecForAllTys [alphaTyVar] (mkVisFunTy addrPrimTy alphaTy)
920 -- Not runtime-rep polymorphic. aBSENT_ERROR_ID is only used for
921 -- lifted-type things; see Note [Absent errors] in WwLib
922 arity_info = vanillaIdInfo `setArityInfo` 1
923 -- NB: no bottoming strictness info, unlike other error-ids.
924 -- See Note [aBSENT_ERROR_ID]
925
926 mkAbsentErrorApp :: Type -- The type to instantiate 'a'
927 -> String -- The string to print
928 -> CoreExpr
929
930 mkAbsentErrorApp res_ty err_msg
931 = mkApps (Var aBSENT_ERROR_ID) [ Type res_ty, err_string ]
932 where
933 err_string = Lit (mkLitString err_msg)