MkCore.hs 35.4 KB
Newer Older
1
{-# LANGUAGE CPP #-}
Ian Lynagh's avatar
Ian Lynagh committed
2

3
4
5
6
7
-- | Handy functions for creating much Core syntax
module MkCore (
        -- * Constructing normal syntax
        mkCoreLet, mkCoreLets,
        mkCoreApp, mkCoreApps, mkCoreConApps,
8
9
        mkCoreLams, mkWildCase, mkIfThenElse,
        mkWildValBinder, mkWildEvBinder,
10
        sortQuantVars, castBottomExpr,
11

12
        -- * Constructing boxed literals
13
14
        mkWordExpr, mkWordExprWord,
        mkIntExpr, mkIntExprInt,
15
        mkIntegerExpr, mkNaturalExpr,
16
        mkFloatExpr, mkDoubleExpr,
17
        mkCharExpr, mkStringExpr, mkStringExprFS, mkStringExprFSWith,
batterseapower's avatar
batterseapower committed
18

19
20
21
        -- * Floats
        FloatBind(..), wrapFloat,

22
        -- * Constructing small tuples
23
        mkCoreVarTup, mkCoreVarTupTy, mkCoreTup, mkCoreUbxTup,
24
        mkCoreTupBoxity, unitExpr,
25

26
        -- * Constructing big tuples
27
28
29
        mkBigCoreVarTup, mkBigCoreVarTup1,
        mkBigCoreVarTupTy, mkBigCoreTupTy,
        mkBigCoreTup,
30

31
32
        -- * Deconstructing small tuples
        mkSmallTupleSelector, mkSmallTupleCase,
33

34
        -- * Deconstructing big tuples
35
        mkTupleSelector, mkTupleSelector1, mkTupleCase,
36

37
        -- * Constructing list expressions
38
        mkNilExpr, mkConsExpr, mkListExpr,
39
40
        mkFoldrExpr, mkBuildExpr,

Jan Stolarek's avatar
Jan Stolarek committed
41
42
43
        -- * Constructing Maybe expressions
        mkNothingExpr, mkJustExpr,

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,
Ömer Sinan Ağacan's avatar
Ömer Sinan Ağacan committed
49
        tYPE_ERROR_ID, aBSENT_SUM_FIELD_ERROR_ID
50
51
52
53
    ) where

#include "HsVersions.h"

54
55
import GhcPrelude

56
import Id
57
import Var      ( EvVar, setTyVarUnique )
58
59
60
61
62
63
64
65
66

import CoreSyn
import CoreUtils        ( exprType, needsCaseBinding, bindNonRec )
import Literal
import HscTypes

import TysWiredIn
import PrelNames

Simon Marlow's avatar
Simon Marlow committed
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
batterseapower's avatar
batterseapower committed
74
import Name      hiding ( varName )
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
75
import Outputable
76
77
78
import FastString
import UniqSupply
import BasicTypes
79
import Util
80
import DynFlags
Ian Lynagh's avatar
Ian Lynagh committed
81
import Data.List
82
83

import Data.Char        ( ord )
84
import Control.Monad.Fail ( MonadFail )
85
86
87

infixl 4 `mkCoreApp`, `mkCoreApps`

Austin Seipp's avatar
Austin Seipp committed
88
89
90
{-
************************************************************************
*                                                                      *
91
\subsection{Basic CoreSyn construction}
Austin Seipp's avatar
Austin Seipp committed
92
93
94
*                                                                      *
************************************************************************
-}
95
sortQuantVars :: [Var] -> [Var]
96
97
-- Sort the variables, putting type and covars first, in scoped order,
-- and then other Ids
98
99
100
-- It is a deterministic sort, meaining it doesn't look at the values of
-- Uniques. For explanation why it's important See Note [Unique Determinism]
-- in Unique.
101
sortQuantVars vs = sorted_tcvs ++ ids
102
  where
103
    (tcvs, ids) = partition (isTyVar <||> isCoVar) vs
Tobias Dammers's avatar
Tobias Dammers committed
104
    sorted_tcvs = scopedSort tcvs
105

106
107
108
109
-- | Bind a binding group over an expression, using a @let@ or @case@ as
-- appropriate (see "CoreSyn#let_app_invariant")
mkCoreLet :: CoreBind -> CoreExpr -> CoreExpr
mkCoreLet (NonRec bndr rhs) body        -- See Note [CoreSyn let/app invariant]
110
  = bindNonRec bndr rhs body
111
112
113
114
115
116
117
118
mkCoreLet bind body
  = Let bind body

-- | Bind a list of binding groups over an expression. The leftmost binding
-- group becomes the outermost group in the resulting expression
mkCoreLets :: [CoreBind] -> CoreExpr -> CoreExpr
mkCoreLets binds body = foldr mkCoreLet body binds

119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
-- | Construct an expression which represents the application of one expression
-- paired with its type to an argument. The result is paired with its type. This
-- function is not exported and used in the definition of 'mkCoreApp' and
-- 'mkCoreApps'.
-- Respects the let/app invariant by building a case expression where necessary
--   See CoreSyn Note [CoreSyn let/app invariant]
mkCoreAppTyped :: SDoc -> (CoreExpr, Type) -> CoreExpr -> (CoreExpr, Type)
mkCoreAppTyped _ (fun, fun_ty) (Type ty)
  = (App fun (Type ty), piResultTy fun_ty ty)
mkCoreAppTyped _ (fun, fun_ty) (Coercion co)
  = (App fun (Coercion co), res_ty)
  where
    (_, res_ty) = splitFunTy fun_ty
mkCoreAppTyped d (fun, fun_ty) arg
  = ASSERT2( isFunTy fun_ty, ppr fun $$ ppr arg $$ d )
    (mk_val_app fun arg arg_ty res_ty, res_ty)
  where
    (arg_ty, res_ty) = splitFunTy fun_ty

138
139
-- | Construct an expression which represents the application of one expression
-- to the other
140
141
-- Respects the let/app invariant by building a case expression where necessary
--   See CoreSyn Note [CoreSyn let/app invariant]
142
143
144
mkCoreApp :: SDoc -> CoreExpr -> CoreExpr -> CoreExpr
mkCoreApp s fun arg
  = fst $ mkCoreAppTyped s (fun, exprType fun) arg
145
146
147

-- | Construct an expression which represents the application of a number of
-- expressions to another. The leftmost expression in the list is applied first
148
149
-- Respects the let/app invariant by building a case expression where necessary
--   See CoreSyn Note [CoreSyn let/app invariant]
150
mkCoreApps :: CoreExpr -> [CoreExpr] -> CoreExpr
151
152
153
mkCoreApps fun args
  = fst $
    foldl' (mkCoreAppTyped doc_string) (fun, fun_ty) args
154
  where
155
156
    doc_string = ppr fun_ty $$ ppr fun $$ ppr args
    fun_ty = exprType fun
157
158
159
160
161
162
163
164

-- | Construct an expression which represents the application of a number of
-- expressions to that of a data constructor expression. The leftmost expression
-- in the list is applied first
mkCoreConApps :: DataCon -> [CoreExpr] -> CoreExpr
mkCoreConApps con args = mkCoreApps (Var (dataConWorkId con)) args

mk_val_app :: CoreExpr -> CoreExpr -> Type -> Type -> CoreExpr
165
166
167
168
169
-- Build an application (e1 e2),
-- or a strict binding  (case e2 of x -> e1 x)
-- using the latter when necessary to respect the let/app invariant
--   See Note [CoreSyn let/app invariant]
mk_val_app fun arg arg_ty res_ty
170
171
172
  | not (needsCaseBinding arg_ty arg)
  = App fun arg                -- The vastly common case

173
  | otherwise
174
  = Case arg arg_id res_ty [(DEFAULT,[],App fun (Var arg_id))]
175
  where
176
177
    arg_id = mkWildValBinder arg_ty
        -- Lots of shadowing, but it doesn't matter,
178
        -- because 'fun ' should not have a free wild-id
179
180
181
        --
        -- This is Dangerous.  But this is the only place we play this
        -- game, mk_val_app returns an expression that does not have
Gabor Greif's avatar
Gabor Greif committed
182
        -- a free wild-id.  So the only thing that can go wrong
183
        -- is if you take apart this case expression, and pass a
Richard Eisenberg's avatar
Richard Eisenberg committed
184
        -- fragment of it as the fun part of a 'mk_val_app'.
185

186
-----------
187
mkWildEvBinder :: PredType -> EvVar
batterseapower's avatar
batterseapower committed
188
mkWildEvBinder pred = mkWildValBinder pred
189

190
-- | Make a /wildcard binder/. This is typically used when you need a binder
191
192
193
-- that you expect to use only at a *binding* site.  Do not use it at
-- occurrence sites because it has a single, fixed unique, and it's very
-- easy to get into difficulties with shadowing.  That's why it is used so little.
194
-- See Note [WildCard binders] in SimplEnv
195
mkWildValBinder :: Type -> Id
196
mkWildValBinder ty = mkLocalIdOrCoVar wildCardName ty
197
198
199
200

mkWildCase :: CoreExpr -> Type -> Type -> [CoreAlt] -> CoreExpr
-- Make a case expression whose case binder is unused
-- The alts should not have any occurrences of WildId
201
mkWildCase scrut scrut_ty res_ty alts
202
  = Case scrut (mkWildValBinder scrut_ty) res_ty alts
203
204
205
206

mkIfThenElse :: CoreExpr -> CoreExpr -> CoreExpr -> CoreExpr
mkIfThenElse guard then_expr else_expr
-- Not going to be refining, so okay to take the type of the "then" clause
207
208
209
  = mkWildCase guard boolTy (exprType then_expr)
         [ (DataAlt falseDataCon, [], else_expr),       -- Increasing order of tag!
           (DataAlt trueDataCon,  [], then_expr) ]
210
211

castBottomExpr :: CoreExpr -> Type -> CoreExpr
212
-- (castBottomExpr e ty), assuming that 'e' diverges,
213
214
215
216
217
218
219
-- return an expression of type 'ty'
-- See Note [Empty case alternatives] in CoreSyn
castBottomExpr e res_ty
  | e_ty `eqType` res_ty = e
  | otherwise            = Case e (mkWildValBinder e_ty) res_ty []
  where
    e_ty = exprType e
220

Austin Seipp's avatar
Austin Seipp committed
221
{-
222
223
The functions from this point don't really do anything cleverer than
their counterparts in CoreSyn, but they are here for consistency
Austin Seipp's avatar
Austin Seipp committed
224
-}
225
226
227
228
229
230
231

-- | Create a lambda where the given expression has a number of variables
-- bound over it. The leftmost binder is that bound by the outermost
-- lambda in the result
mkCoreLams :: [CoreBndr] -> CoreExpr -> CoreExpr
mkCoreLams = mkLams

Austin Seipp's avatar
Austin Seipp committed
232
233
234
{-
************************************************************************
*                                                                      *
235
\subsection{Making literals}
Austin Seipp's avatar
Austin Seipp committed
236
237
238
*                                                                      *
************************************************************************
-}
239
240

-- | Create a 'CoreExpr' which will evaluate to the given @Int@
241
mkIntExpr :: DynFlags -> Integer -> CoreExpr        -- Result = I# i :: Int
242
mkIntExpr dflags i = mkCoreConApps intDataCon  [mkIntLit dflags i]
243
244

-- | Create a 'CoreExpr' which will evaluate to the given @Int@
245
mkIntExprInt :: DynFlags -> Int -> CoreExpr         -- Result = I# i :: Int
246
mkIntExprInt dflags i = mkCoreConApps intDataCon  [mkIntLitInt dflags i]
247
248

-- | Create a 'CoreExpr' which will evaluate to the a @Word@ with the given value
249
mkWordExpr :: DynFlags -> Integer -> CoreExpr
250
mkWordExpr dflags w = mkCoreConApps wordDataCon [mkWordLit dflags w]
251
252

-- | Create a 'CoreExpr' which will evaluate to the given @Word@
253
mkWordExprWord :: DynFlags -> Word -> CoreExpr
254
mkWordExprWord dflags w = mkCoreConApps wordDataCon [mkWordLitWord dflags w]
255
256

-- | Create a 'CoreExpr' which will evaluate to the given @Integer@
257
mkIntegerExpr  :: MonadThings m => Integer -> m CoreExpr  -- Result :: Integer
258
259
mkIntegerExpr i = do t <- lookupTyCon integerTyConName
                     return (Lit (mkLitInteger i (mkTyConTy t)))
260

261
-- | Create a 'CoreExpr' which will evaluate to the given @Natural@
262
263
264
mkNaturalExpr  :: MonadThings m => Integer -> m CoreExpr
mkNaturalExpr i = do t <- lookupTyCon naturalTyConName
                     return (Lit (mkLitNatural i (mkTyConTy t)))
265

266
267
-- | Create a 'CoreExpr' which will evaluate to the given @Float@
mkFloatExpr :: Float -> CoreExpr
268
mkFloatExpr f = mkCoreConApps floatDataCon [mkFloatLitFloat f]
269
270
271

-- | Create a 'CoreExpr' which will evaluate to the given @Double@
mkDoubleExpr :: Double -> CoreExpr
272
mkDoubleExpr d = mkCoreConApps doubleDataCon [mkDoubleLitDouble d]
273
274
275
276


-- | Create a 'CoreExpr' which will evaluate to the given @Char@
mkCharExpr     :: Char             -> CoreExpr      -- Result = C# c :: Int
277
mkCharExpr c = mkCoreConApps charDataCon [mkCharLit c]
278
279
280

-- | Create a 'CoreExpr' which will evaluate to the given @String@
mkStringExpr   :: MonadThings m => String     -> m CoreExpr  -- Result :: String
Simon Peyton Jones's avatar
Simon Peyton Jones committed
281

282
283
284
285
286
-- | Create a 'CoreExpr' which will evaluate to a string morally equivalent to the given @FastString@
mkStringExprFS :: MonadThings m => FastString -> m CoreExpr  -- Result :: String

mkStringExpr str = mkStringExprFS (mkFastString str)

287
288
289
290
mkStringExprFS = mkStringExprFSWith lookupId

mkStringExprFSWith :: Monad m => (Name -> m Id) -> FastString -> m CoreExpr
mkStringExprFSWith lookupM str
291
292
293
294
  | nullFS str
  = return (mkNilExpr charTy)

  | all safeChar chars
295
  = do unpack_id <- lookupM unpackCStringName
296
       return (App (Var unpack_id) lit)
297
298

  | otherwise
299
  = do unpack_utf8_id <- lookupM unpackCStringUtf8Name
300
       return (App (Var unpack_utf8_id) lit)
301
302
303
304

  where
    chars = unpackFS str
    safeChar c = ord c >= 1 && ord c <= 0x7F
Sylvain Henry's avatar
Sylvain Henry committed
305
    lit = Lit (LitString (fastStringToByteString str))
batterseapower's avatar
batterseapower committed
306

Austin Seipp's avatar
Austin Seipp committed
307
308
309
{-
************************************************************************
*                                                                      *
310
\subsection{Tuple constructors}
Austin Seipp's avatar
Austin Seipp committed
311
312
313
*                                                                      *
************************************************************************
-}
314

Austin Seipp's avatar
Austin Seipp committed
315
{-
316
Creating tuples and their types for Core expressions
317

318
@mkBigCoreVarTup@ builds a tuple; the inverse to @mkTupleSelector@.
319
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
  the tuples.
324
325
326
327
328

Note [Flattening one-tuples]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
This family of functions creates a tuple of variables/expressions/types.
  mkCoreTup [e1,e2,e3] = (e1,e2,e3)
Gabor Greif's avatar
Gabor Greif committed
329
What if there is just one variable/expression/type in the argument?
330
331
332
333
334
We could do one of two things:

* Flatten it out, so that
    mkCoreTup [e1] = e1

Gabor Greif's avatar
Gabor Greif committed
335
* Build a one-tuple (see Note [One-tuples] in TysWiredIn)
336
337
338
339
    mkCoreTup1 [e1] = Unit e1
  We use a suffix "1" to indicate this.

Usually we want the former, but occasionally the latter.
Austin Seipp's avatar
Austin Seipp committed
340
-}
341
342

-- | Build a small tuple holding the specified variables
343
-- One-tuples are flattened; see Note [Flattening one-tuples]
344
345
346
mkCoreVarTup :: [Id] -> CoreExpr
mkCoreVarTup ids = mkCoreTup (map Var ids)

Gabor Greif's avatar
Gabor Greif committed
347
-- | Build the type of a small tuple that holds the specified variables
348
-- One-tuples are flattened; see Note [Flattening one-tuples]
349
mkCoreVarTupTy :: [Id] -> Type
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
350
mkCoreVarTupTy ids = mkBoxedTupleTy (map idType ids)
351
352

-- | Build a small tuple holding the specified expressions
353
-- One-tuples are flattened; see Note [Flattening one-tuples]
354
355
356
mkCoreTup :: [CoreExpr] -> CoreExpr
mkCoreTup []  = Var unitDataConId
mkCoreTup [c] = c
357
358
359
360
361
mkCoreTup cs  = mkCoreConApps (tupleDataCon Boxed (length cs))
                              (map (Type . exprType) cs ++ cs)

-- | Build a small unboxed tuple holding the specified expressions,
-- with the given types. The types must be the types of the expressions.
362
-- Do not include the RuntimeRep specifiers; this function calculates them
363
-- for you.
364
-- Does /not/ flatten one-tuples; see Note [Flattening one-tuples]
365
366
367
368
mkCoreUbxTup :: [Type] -> [CoreExpr] -> CoreExpr
mkCoreUbxTup tys exps
  = ASSERT( tys `equalLength` exps)
    mkCoreConApps (tupleDataCon Unboxed (length tys))
369
             (map (Type . getRuntimeRep) tys ++ map Type tys ++ exps)
370
371
372
373
374

-- | Make a core tuple of the given boxity
mkCoreTupBoxity :: Boxity -> [CoreExpr] -> CoreExpr
mkCoreTupBoxity Boxed   exps = mkCoreTup exps
mkCoreTupBoxity Unboxed exps = mkCoreUbxTup (map exprType exps) exps
375
376

-- | Build a big tuple holding the specified variables
377
-- One-tuples are flattened; see Note [Flattening one-tuples]
378
379
380
mkBigCoreVarTup :: [Id] -> CoreExpr
mkBigCoreVarTup ids = mkBigCoreTup (map Var ids)

381
382
383
384
385
386
387
mkBigCoreVarTup1 :: [Id] -> CoreExpr
-- Same as mkBigCoreVarTup, but one-tuples are NOT flattened
--                          see Note [Flattening one-tuples]
mkBigCoreVarTup1 [id] = mkCoreConApps (tupleDataCon Boxed 1)
                                      [Type (idType id), Var id]
mkBigCoreVarTup1 ids  = mkBigCoreTup (map Var ids)

388
-- | Build the type of a big tuple that holds the specified variables
389
-- One-tuples are flattened; see Note [Flattening one-tuples]
390
391
392
393
mkBigCoreVarTupTy :: [Id] -> Type
mkBigCoreVarTupTy ids = mkBigCoreTupTy (map idType ids)

-- | Build a big tuple holding the specified expressions
394
-- One-tuples are flattened; see Note [Flattening one-tuples]
395
396
397
398
mkBigCoreTup :: [CoreExpr] -> CoreExpr
mkBigCoreTup = mkChunkified mkCoreTup

-- | Build the type of a big tuple that holds the specified type of thing
399
-- One-tuples are flattened; see Note [Flattening one-tuples]
400
mkBigCoreTupTy :: [Type] -> Type
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
401
mkBigCoreTupTy = mkChunkified mkBoxedTupleTy
402

403
404
405
-- | The unit expression
unitExpr :: CoreExpr
unitExpr = Var unitDataConId
406

Austin Seipp's avatar
Austin Seipp committed
407
408
409
{-
************************************************************************
*                                                                      *
410
\subsection{Tuple destructors}
Austin Seipp's avatar
Austin Seipp committed
411
412
413
*                                                                      *
************************************************************************
-}
414
415
416
417
418
419
420
421
422
423
424

-- | Builds a selector which scrutises the given
-- expression and extracts the one name from the list given.
-- If you want the no-shadowing rule to apply, the caller
-- is responsible for making sure that none of these names
-- are in scope.
--
-- If there is just one 'Id' in the tuple, then the selector is
-- just the identity.
--
-- If necessary, we pattern match on a \"big\" tuple.
425
426
427
428
429
430
mkTupleSelector, mkTupleSelector1
    :: [Id]         -- ^ The 'Id's to pattern match the tuple against
    -> Id           -- ^ The 'Id' to select
    -> Id           -- ^ A variable of the same type as the scrutinee
    -> CoreExpr     -- ^ Scrutinee
    -> CoreExpr     -- ^ Selector expression
431
432

-- mkTupleSelector [a,b,c,d] b v e
433
--          = case e of v {
434
435
436
437
438
439
--                (p,q) -> case p of p {
--                           (a,b) -> b }}
-- We use 'tpl' vars for the p,q, since shadowing does not matter.
--
-- In fact, it's more convenient to generate it innermost first, getting
--
440
--        case (case e of v
441
442
443
444
445
446
447
448
449
--                (p,q) -> p) of p
--          (a,b) -> b
mkTupleSelector vars the_var scrut_var scrut
  = mk_tup_sel (chunkify vars) the_var
  where
    mk_tup_sel [vars] the_var = mkSmallTupleSelector vars the_var scrut_var scrut
    mk_tup_sel vars_s the_var = mkSmallTupleSelector group the_var tpl_v $
                                mk_tup_sel (chunkify tpl_vs) tpl_v
        where
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
450
          tpl_tys = [mkBoxedTupleTy (map idType gp) | gp <- vars_s]
451
452
453
          tpl_vs  = mkTemplateLocals tpl_tys
          [(tpl_v, group)] = [(tpl,gp) | (tpl,gp) <- zipEqual "mkTupleSelector" tpl_vs vars_s,
                                         the_var `elem` gp ]
454
455
456
457
458
459
460
-- ^ 'mkTupleSelector1' is like 'mkTupleSelector'
-- but one-tuples are NOT flattened (see Note [Flattening one-tuples])
mkTupleSelector1 vars the_var scrut_var scrut
  | [_] <- vars
  = mkSmallTupleSelector1 vars the_var scrut_var scrut
  | otherwise
  = mkTupleSelector vars the_var scrut_var scrut
461
462
463
464
465
466

-- | Like 'mkTupleSelector' but for tuples that are guaranteed
-- never to be \"big\".
--
-- > mkSmallTupleSelector [x] x v e = [| e |]
-- > mkSmallTupleSelector [x,y,z] x v e = [| case e of v { (x,y,z) -> x } |]
467
468
469
470
471
mkSmallTupleSelector, mkSmallTupleSelector1
          :: [Id]        -- The tuple args
          -> Id          -- The selected one
          -> Id          -- A variable of the same type as the scrutinee
          -> CoreExpr    -- Scrutinee
472
473
474
          -> CoreExpr
mkSmallTupleSelector [var] should_be_the_same_var _ scrut
  = ASSERT(var == should_be_the_same_var)
475
    scrut  -- Special case for 1-tuples
476
mkSmallTupleSelector vars the_var scrut_var scrut
477
478
479
480
481
  = mkSmallTupleSelector1 vars the_var scrut_var scrut

-- ^ 'mkSmallTupleSelector1' is like 'mkSmallTupleSelector'
-- but one-tuples are NOT flattened (see Note [Flattening one-tuples])
mkSmallTupleSelector1 vars the_var scrut_var scrut
482
483
  = ASSERT( notNull vars )
    Case scrut scrut_var (idType the_var)
484
         [(DataAlt (tupleDataCon Boxed (length vars)), vars, Var the_var)]
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510

-- | A generalization of 'mkTupleSelector', allowing the body
-- of the case to be an arbitrary expression.
--
-- To avoid shadowing, we use uniques to invent new variables.
--
-- If necessary we pattern match on a \"big\" tuple.
mkTupleCase :: UniqSupply       -- ^ For inventing names of intermediate variables
            -> [Id]             -- ^ The tuple identifiers to pattern match on
            -> CoreExpr         -- ^ Body of the case
            -> Id               -- ^ A variable of the same type as the scrutinee
            -> CoreExpr         -- ^ Scrutinee
            -> CoreExpr
-- ToDo: eliminate cases where none of the variables are needed.
--
--         mkTupleCase uniqs [a,b,c,d] body v e
--           = case e of v { (p,q) ->
--             case p of p { (a,b) ->
--             case q of q { (c,d) ->
--             body }}}
mkTupleCase uniqs vars body scrut_var scrut
  = mk_tuple_case uniqs (chunkify vars) body
  where
    -- This is the case where don't need any nesting
    mk_tuple_case _ [vars] body
      = mkSmallTupleCase vars body scrut_var scrut
511

512
513
514
515
    -- This is the case where we must make nest tuples at least once
    mk_tuple_case us vars_s body
      = let (us', vars', body') = foldr one_tuple_case (us, [], body) vars_s
            in mk_tuple_case us' (chunkify vars') body'
516

517
    one_tuple_case chunk_vars (us, vs, body)
518
519
      = let (uniq, us') = takeUniqFromSupply us
            scrut_var = mkSysLocal (fsLit "ds") uniq
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
520
              (mkBoxedTupleTy (map idType chunk_vars))
521
            body' = mkSmallTupleCase chunk_vars body scrut_var (Var scrut_var)
522
        in (us', scrut_var:vs, body')
523
524
525
526
527
528
529
530
531
532
533
534
535
536

-- | As 'mkTupleCase', but for a tuple that is small enough to be guaranteed
-- not to need nesting.
mkSmallTupleCase
        :: [Id]         -- ^ The tuple args
        -> CoreExpr     -- ^ Body of the case
        -> Id           -- ^ A variable of the same type as the scrutinee
        -> CoreExpr     -- ^ Scrutinee
        -> CoreExpr

mkSmallTupleCase [var] body _scrut_var scrut
  = bindNonRec var scrut body
mkSmallTupleCase vars body scrut_var scrut
-- One branch no refinement?
537
538
  = Case scrut scrut_var (exprType body)
         [(DataAlt (tupleDataCon Boxed (length vars)), vars, body)]
539

540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
{-
************************************************************************
*                                                                      *
                Floats
*                                                                      *
************************************************************************
-}

data FloatBind
  = FloatLet  CoreBind
  | FloatCase CoreExpr Id AltCon [Var]
      -- case e of y { C ys -> ... }
      -- See Note [Floating cases] in SetLevels

instance Outputable FloatBind where
  ppr (FloatLet b) = text "LET" <+> ppr b
  ppr (FloatCase e b c bs) = hang (text "CASE" <+> ppr e <+> ptext (sLit "of") <+> ppr b)
                                2 (ppr c <+> ppr bs)

wrapFloat :: FloatBind -> CoreExpr -> CoreExpr
wrapFloat (FloatLet defns)       body = Let defns body
wrapFloat (FloatCase e b con bs) body = Case e b (exprType body) [(con, bs, body)]

Austin Seipp's avatar
Austin Seipp committed
563
564
565
{-
************************************************************************
*                                                                      *
566
\subsection{Common list manipulation expressions}
Austin Seipp's avatar
Austin Seipp committed
567
568
*                                                                      *
************************************************************************
569
570
571

Call the constructor Ids when building explicit lists, so that they
interact well with rules.
Austin Seipp's avatar
Austin Seipp committed
572
-}
573
574
575

-- | Makes a list @[]@ for lists of the specified type
mkNilExpr :: Type -> CoreExpr
576
mkNilExpr ty = mkCoreConApps nilDataCon [Type ty]
577
578
579

-- | Makes a list @(:)@ for lists of the specified type
mkConsExpr :: Type -> CoreExpr -> CoreExpr -> CoreExpr
580
mkConsExpr ty hd tl = mkCoreConApps consDataCon [Type ty, hd, tl]
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595

-- | Make a list containing the given expressions, where the list has the given type
mkListExpr :: Type -> [CoreExpr] -> CoreExpr
mkListExpr ty xs = foldr (mkConsExpr ty) (mkNilExpr ty) xs

-- | Make a fully applied 'foldr' expression
mkFoldrExpr :: MonadThings m
            => Type             -- ^ Element type of the list
            -> Type             -- ^ Fold result type
            -> CoreExpr         -- ^ "Cons" function expression for the fold
            -> CoreExpr         -- ^ "Nil" expression for the fold
            -> CoreExpr         -- ^ List expression being folded acress
            -> m CoreExpr
mkFoldrExpr elt_ty result_ty c n list = do
    foldr_id <- lookupId foldrName
596
    return (Var foldr_id `App` Type elt_ty
597
598
599
600
601
602
           `App` Type result_ty
           `App` c
           `App` n
           `App` list)

-- | Make a 'build' expression applied to a locally-bound worker function
603
mkBuildExpr :: (MonadFail m, MonadThings m, MonadUnique m)
604
605
606
607
608
609
610
611
612
613
            => Type                                     -- ^ Type of list elements to be built
            -> ((Id, Type) -> (Id, Type) -> m CoreExpr) -- ^ Function that, given information about the 'Id's
                                                        -- of the binders for the build worker function, returns
                                                        -- the body of that worker
            -> m CoreExpr
mkBuildExpr elt_ty mk_build_inside = do
    [n_tyvar] <- newTyVars [alphaTyVar]
    let n_ty = mkTyVarTy n_tyvar
        c_ty = mkFunTys [elt_ty, n_ty] n_ty
    [c, n] <- sequence [mkSysLocalM (fsLit "c") c_ty, mkSysLocalM (fsLit "n") n_ty]
614

615
    build_inside <- mk_build_inside (c, c_ty) (n, n_ty)
616

617
618
619
620
621
622
    build_id <- lookupId buildName
    return $ Var build_id `App` Type elt_ty `App` mkLams [n_tyvar, c, n] build_inside
  where
    newTyVars tyvar_tmpls = do
      uniqs <- getUniquesM
      return (zipWith setTyVarUnique tyvar_tmpls uniqs)
623

Jan Stolarek's avatar
Jan Stolarek committed
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
{-
************************************************************************
*                                                                      *
             Manipulating Maybe data type
*                                                                      *
************************************************************************
-}


-- | Makes a Nothing for the specified type
mkNothingExpr :: Type -> CoreExpr
mkNothingExpr ty = mkConApp nothingDataCon [Type ty]

-- | Makes a Just from a value of the specified type
mkJustExpr :: Type -> CoreExpr -> CoreExpr
mkJustExpr ty val = mkConApp justDataCon [Type ty, val]


Austin Seipp's avatar
Austin Seipp committed
642
643
644
{-
************************************************************************
*                                                                      *
645
                      Error expressions
Austin Seipp's avatar
Austin Seipp committed
646
647
648
*                                                                      *
************************************************************************
-}
649

650
mkRuntimeErrorApp
651
652
653
654
655
656
        :: Id           -- Should be of type (forall a. Addr# -> a)
                        --      where Addr# points to a UTF8 encoded string
        -> Type         -- The type to instantiate 'a'
        -> String       -- The string to print
        -> CoreExpr

657
mkRuntimeErrorApp err_id res_ty err_msg
658
  = mkApps (Var err_id) [ Type (getRuntimeRep res_ty)
659
                        , Type res_ty, err_string ]
660
  where
Sylvain Henry's avatar
Sylvain Henry committed
661
    err_string = Lit (mkLitString err_msg)
662
663
664
665
666

mkImpossibleExpr :: Type -> CoreExpr
mkImpossibleExpr res_ty
  = mkRuntimeErrorApp rUNTIME_ERROR_ID res_ty "Impossible case alternative"

Austin Seipp's avatar
Austin Seipp committed
667
668
669
{-
************************************************************************
*                                                                      *
670
                     Error Ids
Austin Seipp's avatar
Austin Seipp committed
671
672
*                                                                      *
************************************************************************
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687

GHC randomly injects these into the code.

@patError@ is just a version of @error@ for pattern-matching
failures.  It knows various ``codes'' which expand to longer
strings---this saves space!

@absentErr@ is a thing we put in for ``absent'' arguments.  They jolly
well shouldn't be yanked on, but if one is, then you will get a
friendly message from @absentErr@ (rather than a totally random
crash).

@parError@ is a special version of @error@ which the compiler does
not know to be a bottoming Id.  It is used in the @_par_@ and @_seq_@
templates, but we don't ever expect to generate code for it.
Austin Seipp's avatar
Austin Seipp committed
688
-}
689
690

errorIds :: [Id]
691
errorIds
692
  = [ rUNTIME_ERROR_ID,
693
694
695
696
697
      nON_EXHAUSTIVE_GUARDS_ERROR_ID,
      nO_METHOD_BINDING_ERROR_ID,
      pAT_ERROR_ID,
      rEC_CON_ERROR_ID,
      rEC_SEL_ERROR_ID,
698
699
700
      aBSENT_ERROR_ID,
      tYPE_ERROR_ID   -- Used with Opt_DeferTypeErrors, see #10284
      ]
701
702

recSelErrorName, runtimeErrorName, absentErrorName :: Name
703
recConErrorName, patErrorName :: Name
704
nonExhaustiveGuardsErrorName, noMethodBindingErrorName :: Name
705
typeErrorName :: Name
Ömer Sinan Ağacan's avatar
Ömer Sinan Ağacan committed
706
absentSumFieldErrorName :: Name
707
708
709

recSelErrorName     = err_nm "recSelError"     recSelErrorIdKey     rEC_SEL_ERROR_ID
absentErrorName     = err_nm "absentError"     absentErrorIdKey     aBSENT_ERROR_ID
Ömer Sinan Ağacan's avatar
Ömer Sinan Ağacan committed
710
711
absentSumFieldErrorName = err_nm "absentSumFieldError"  absentSumFieldErrorIdKey
                            aBSENT_SUM_FIELD_ERROR_ID
712
713
714
runtimeErrorName    = err_nm "runtimeError"    runtimeErrorIdKey    rUNTIME_ERROR_ID
recConErrorName     = err_nm "recConError"     recConErrorIdKey     rEC_CON_ERROR_ID
patErrorName        = err_nm "patError"        patErrorIdKey        pAT_ERROR_ID
715
typeErrorName       = err_nm "typeError"       typeErrorIdKey       tYPE_ERROR_ID
716
717
718

noMethodBindingErrorName     = err_nm "noMethodBindingError"
                                  noMethodBindingErrorIdKey nO_METHOD_BINDING_ERROR_ID
719
nonExhaustiveGuardsErrorName = err_nm "nonExhaustiveGuardsError"
720
721
722
723
724
                                  nonExhaustiveGuardsErrorIdKey nON_EXHAUSTIVE_GUARDS_ERROR_ID

err_nm :: String -> Unique -> Id -> Name
err_nm str uniq id = mkWiredInIdName cONTROL_EXCEPTION_BASE (fsLit str) uniq id

725
rEC_SEL_ERROR_ID, rUNTIME_ERROR_ID, rEC_CON_ERROR_ID :: Id
726
pAT_ERROR_ID, nO_METHOD_BINDING_ERROR_ID, nON_EXHAUSTIVE_GUARDS_ERROR_ID :: Id
Ömer Sinan Ağacan's avatar
Ömer Sinan Ağacan committed
727
tYPE_ERROR_ID, aBSENT_ERROR_ID, aBSENT_SUM_FIELD_ERROR_ID :: Id
728
729
730
731
732
733
rEC_SEL_ERROR_ID                = mkRuntimeErrorId recSelErrorName
rUNTIME_ERROR_ID                = mkRuntimeErrorId runtimeErrorName
rEC_CON_ERROR_ID                = mkRuntimeErrorId recConErrorName
pAT_ERROR_ID                    = mkRuntimeErrorId patErrorName
nO_METHOD_BINDING_ERROR_ID      = mkRuntimeErrorId noMethodBindingErrorName
nON_EXHAUSTIVE_GUARDS_ERROR_ID  = mkRuntimeErrorId nonExhaustiveGuardsErrorName
734
tYPE_ERROR_ID                   = mkRuntimeErrorId typeErrorName
735

Ömer Sinan Ağacan's avatar
Ömer Sinan Ağacan committed
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
-- Note [aBSENT_SUM_FIELD_ERROR_ID]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- Absent argument error for unused unboxed sum fields are different than absent
-- error used in dummy worker functions (see `mkAbsentErrorApp`):
--
-- - `absentSumFieldError` can't take arguments because it's used in unarise for
--   unused pointer fields in unboxed sums, and applying an argument would
--   require allocating a thunk.
--
-- - `absentSumFieldError` can't be CAFFY because that would mean making some
--   non-CAFFY definitions that use unboxed sums CAFFY in unarise.
--
--   To make `absentSumFieldError` non-CAFFY we get a stable pointer to it in
--   RtsStartup.c and mark it as non-CAFFY here.
--
-- Getting this wrong causes hard-to-debug runtime issues, see #15038.
--
-- TODO: Remove stable pointer hack after fixing #9718.
--       However, we should still be careful about not making things CAFFY just
--       because they use unboxed sums. Unboxed objects are supposed to be
--       efficient, and none of the other unboxed literals make things CAFFY.

aBSENT_SUM_FIELD_ERROR_ID
  = mkVanillaGlobalWithInfo absentSumFieldErrorName
      (mkSpecForAllTys [alphaTyVar] (mkTyVarTy alphaTyVar)) -- forall a . a
      (vanillaIdInfo `setStrictnessInfo` mkClosedStrictSig [] exnRes
                     `setArityInfo` 0
                     `setCafInfo` NoCafRefs) -- #15038

765
mkRuntimeErrorId :: Name -> Id
766
767
768
769
770
771
772
-- Error function
--   with type:  forall (r:RuntimeRep) (a:TYPE r). Addr# -> a
--   with arity: 1
-- which diverges after being given one argument
-- The Addr# is expected to be the address of
--   a UTF8-encoded error string
mkRuntimeErrorId name
773
 = mkVanillaGlobalWithInfo name runtimeErrorTy bottoming_info
774
 where
775
    bottoming_info = vanillaIdInfo `setStrictnessInfo`    strict_sig
776
777
                                   `setArityInfo`         1
                        -- Make arity and strictness agree
778
779
780
781
782
783
784
785
786
787

        -- Do *not* mark them as NoCafRefs, because they can indeed have
        -- CAF refs.  For example, pAT_ERROR_ID calls GHC.Err.untangle,
        -- which has some CAFs
        -- In due course we may arrange that these error-y things are
        -- regarded by the GC as permanently live, in which case we
        -- can give them NoCaf info.  As it is, any function that calls
        -- any pc_bottoming_Id will itself have CafRefs, which bloats
        -- SRTs.

788
    strict_sig = mkClosedStrictSig [evalDmd] exnRes
789
              -- exnRes: these throw an exception, not just diverge
790

791
792
793
794
795
runtimeErrorTy :: Type
-- forall (rr :: RuntimeRep) (a :: rr). Addr# -> a
--   See Note [Error and friends have an "open-tyvar" forall]
runtimeErrorTy = mkSpecForAllTys [runtimeRep1TyVar, openAlphaTyVar]
                                 (mkFunTy addrPrimTy openAlphaTy)
796
797
798
799
800
801

{- Note [Error and friends have an "open-tyvar" forall]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'error' and 'undefined' have types
        error     :: forall (v :: RuntimeRep) (a :: TYPE v). String -> a
        undefined :: forall (v :: RuntimeRep) (a :: TYPE v). a
Gabor Greif's avatar
Gabor Greif committed
802
Notice the runtime-representation polymorphism. This ensures that
803
804
"error" can be instantiated at unboxed as well as boxed types.
This is OK because it never returns, so the return type is irrelevant.
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853


************************************************************************
*                                                                      *
                     aBSENT_ERROR_ID
*                                                                      *
************************************************************************

Note [aBSENT_ERROR_ID]
~~~~~~~~~~~~~~~~~~~~~~
We use aBSENT_ERROR_ID to build dummy values in workers.  E.g.

   f x = (case x of (a,b) -> b) + 1::Int

The demand analyser figures ot that only the second component of x is
used, and does a w/w split thus

   f x = case x of (a,b) -> $wf b

   $wf b = let a = absentError "blah"
               x = (a,b)
           in <the original RHS of f>

After some simplification, the (absentError "blah") thunk goes away.

------ Tricky wrinkle -------
Trac #14285 had, roughly

   data T a = MkT a !a
   {-# INLINABLE f #-}
   f x = case x of MkT a b -> g (MkT b a)

It turned out that g didn't use the second component, and hence f doesn't use
the first.  But the stable-unfolding for f looks like
   \x. case x of MkT a b -> g ($WMkT b a)
where $WMkT is the wrapper for MkT that evaluates its arguments.  We
apply the same w/w split to this unfolding (see Note [Worker-wrapper
for INLINEABLE functions] in WorkWrap) so the template ends up like
   \b. let a = absentError "blah"
           x = MkT a b
        in case x of MkT a b -> g ($WMkT b a)

After doing case-of-known-constructor, and expanding $WMkT we get
   \b -> g (case absentError "blah" of a -> MkT b a)

Yikes!  That bogusly appears to evaluate the absentError!

This is extremely tiresome.  Another way to think of this is that, in
Core, it is an invariant that a strict data contructor, like MkT, must
David Feuer's avatar
David Feuer committed
854
be applied only to an argument in HNF. So (absentError "blah") had
855
856
better be non-bottom.

David Feuer's avatar
David Feuer committed
857
858
859
860
861
862
So the "solution" is to add a special case for absentError to exprIsHNFlike.
This allows Simplify.rebuildCase, in the Note [Case to let transformation]
branch, to convert the case on absentError into a let. We also make
absentError *not* be diverging, unlike the other error-ids, so that we
can be sure not to remove the case branches before converting the case to
a let.
863

David Feuer's avatar
David Feuer committed
864
865
866
If, by some bug or bizarre happenstance, we ever call absentError, we should
throw an exception.  This should never happen, of course, but we definitely
can't return anything.  e.g. if somehow we had
867
868
869
870
    case absentError "foo" of
       Nothing -> ...
       Just x  -> ...
then if we return, the case expression will select a field and continue.
David Feuer's avatar
David Feuer committed
871
872
873
874
875
876
877
878
879
Seg fault city. Better to throw an exception. (Even though we've said
it is in HNF :-)

It might seem a bit surprising that seq on absentError is simply erased

    absentError "foo" `seq` x ==> x

but that should be okay; since there's no pattern match we can't really
be relying on anything from it.
880
-}
881
882

aBSENT_ERROR_ID
David Feuer's avatar
David Feuer committed
883
 = mkVanillaGlobalWithInfo absentErrorName absent_ty arity_info
884
885
886
887
 where
   absent_ty = mkSpecForAllTys [alphaTyVar] (mkFunTy addrPrimTy alphaTy)
   -- Not runtime-rep polymorphic. aBSENT_ERROR_ID is only used for
   -- lifted-type things; see Note [Absent errors] in WwLib
David Feuer's avatar
David Feuer committed
888
889
890
   arity_info = vanillaIdInfo `setArityInfo` 1
   -- NB: no bottoming strictness info, unlike other error-ids.
   -- See Note [aBSENT_ERROR_ID]
891
892
893
894
895
896
897
898

mkAbsentErrorApp :: Type         -- The type to instantiate 'a'
                 -> String       -- The string to print
                 -> CoreExpr

mkAbsentErrorApp res_ty err_msg
  = mkApps (Var aBSENT_ERROR_ID) [ Type res_ty, err_string ]
  where
Sylvain Henry's avatar
Sylvain Henry committed
899
    err_string = Lit (mkLitString err_msg)