MkCore.hs 30.9 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 45 46 47
        -- * Error Ids
        mkRuntimeErrorApp, mkImpossibleExpr, errorIds,
        rEC_CON_ERROR_ID, iRREFUT_PAT_ERROR_ID, rUNTIME_ERROR_ID,
        nON_EXHAUSTIVE_GUARDS_ERROR_ID, nO_METHOD_BINDING_ERROR_ID,
48
        pAT_ERROR_ID, rEC_SEL_ERROR_ID, aBSENT_ERROR_ID,
49
        tYPE_ERROR_ID,
50 51 52 53 54
    ) where

#include "HsVersions.h"

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

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

import TysWiredIn
import PrelNames

Simon Marlow's avatar
Simon Marlow committed
65
import HsUtils          ( mkChunkified, chunkify )
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
66
import TcType           ( mkSpecSigmaTy )
67
import Type
68
import Coercion         ( isCoVar )
69
import TysPrim
70
import DataCon          ( DataCon, dataConWorkId )
71
import IdInfo           ( vanillaIdInfo, setStrictnessInfo,
72
                          setArityInfo )
73
import Demand
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 85 86

infixl 4 `mkCoreApp`, `mkCoreApps`

Austin Seipp's avatar
Austin Seipp committed
87 88 89
{-
************************************************************************
*                                                                      *
90
\subsection{Basic CoreSyn construction}
Austin Seipp's avatar
Austin Seipp committed
91 92 93
*                                                                      *
************************************************************************
-}
94
sortQuantVars :: [Var] -> [Var]
95 96
-- Sort the variables, putting type and covars first, in scoped order,
-- and then other Ids
97 98 99
-- 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.
100
sortQuantVars vs = sorted_tcvs ++ ids
101
  where
102 103
    (tcvs, ids) = partition (isTyVar <||> isCoVar) vs
    sorted_tcvs = toposortTyVars tcvs
104

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]
  | needsCaseBinding (idType bndr) rhs
lukemaurer's avatar
lukemaurer committed
110
  , not (isJoinId bndr)
111 112 113 114 115 116 117 118 119 120 121
  = Case rhs bndr (exprType body) [(DEFAULT,[],body)]
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

-- | Construct an expression which represents the application of one expression
-- to the other
122
mkCoreApp :: SDoc -> CoreExpr -> CoreExpr -> CoreExpr
123 124
-- Respects the let/app invariant by building a case expression where necessary
--   See CoreSyn Note [CoreSyn let/app invariant]
125
mkCoreApp _ fun (Type ty)     = App fun (Type ty)
126
mkCoreApp _ fun (Coercion co) = App fun (Coercion co)
127 128 129 130 131
mkCoreApp d fun arg           = ASSERT2( isFunTy fun_ty, ppr fun $$ ppr arg $$ d )
                                mk_val_app fun arg arg_ty res_ty
                              where
                                fun_ty = exprType fun
                                (arg_ty, res_ty) = splitFunTy fun_ty
132 133 134

-- | Construct an expression which represents the application of a number of
-- expressions to another. The leftmost expression in the list is applied first
135 136
-- Respects the let/app invariant by building a case expression where necessary
--   See CoreSyn Note [CoreSyn let/app invariant]
137 138
mkCoreApps :: CoreExpr -> [CoreExpr] -> CoreExpr
-- Slightly more efficient version of (foldl mkCoreApp)
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
139 140
mkCoreApps orig_fun orig_args
  = go orig_fun (exprType orig_fun) orig_args
141
  where
142 143 144 145 146 147 148
    go fun _      []               = fun
    go fun fun_ty (Type ty : args) = go (App fun (Type ty)) (piResultTy fun_ty ty) args
    go fun fun_ty (arg     : args) = ASSERT2( isFunTy fun_ty, ppr fun_ty $$ ppr orig_fun
                                                              $$ ppr orig_args )
                                     go (mk_val_app fun arg arg_ty res_ty) res_ty args
                                   where
                                     (arg_ty, res_ty) = splitFunTy fun_ty
149 150 151 152 153 154 155 156

-- | 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
157 158 159 160 161
-- 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
162 163 164
  | not (needsCaseBinding arg_ty arg)
  = App fun arg                -- The vastly common case

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

178
-----------
179
mkWildEvBinder :: PredType -> EvVar
batterseapower's avatar
batterseapower committed
180
mkWildEvBinder pred = mkWildValBinder pred
181

182
-- | Make a /wildcard binder/. This is typically used when you need a binder
183 184 185
-- 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.
186
-- See Note [WildCard binders] in SimplEnv
187
mkWildValBinder :: Type -> Id
188
mkWildValBinder ty = mkLocalIdOrCoVar wildCardName ty
189 190 191 192

mkWildCase :: CoreExpr -> Type -> Type -> [CoreAlt] -> CoreExpr
-- Make a case expression whose case binder is unused
-- The alts should not have any occurrences of WildId
193
mkWildCase scrut scrut_ty res_ty alts
194
  = Case scrut (mkWildValBinder scrut_ty) res_ty alts
195 196 197 198

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
199 200 201
  = mkWildCase guard boolTy (exprType then_expr)
         [ (DataAlt falseDataCon, [], else_expr),       -- Increasing order of tag!
           (DataAlt trueDataCon,  [], then_expr) ]
202 203

castBottomExpr :: CoreExpr -> Type -> CoreExpr
204
-- (castBottomExpr e ty), assuming that 'e' diverges,
205 206 207 208 209 210 211
-- 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
212

Austin Seipp's avatar
Austin Seipp committed
213
{-
214 215
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
216
-}
217 218 219 220 221 222 223

-- | 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
224 225 226
{-
************************************************************************
*                                                                      *
227
\subsection{Making literals}
Austin Seipp's avatar
Austin Seipp committed
228 229 230
*                                                                      *
************************************************************************
-}
231 232

-- | Create a 'CoreExpr' which will evaluate to the given @Int@
233
mkIntExpr :: DynFlags -> Integer -> CoreExpr        -- Result = I# i :: Int
234
mkIntExpr dflags i = mkCoreConApps intDataCon  [mkIntLit dflags i]
235 236

-- | Create a 'CoreExpr' which will evaluate to the given @Int@
237
mkIntExprInt :: DynFlags -> Int -> CoreExpr         -- Result = I# i :: Int
238
mkIntExprInt dflags i = mkCoreConApps intDataCon  [mkIntLitInt dflags i]
239 240

-- | Create a 'CoreExpr' which will evaluate to the a @Word@ with the given value
241
mkWordExpr :: DynFlags -> Integer -> CoreExpr
242
mkWordExpr dflags w = mkCoreConApps wordDataCon [mkWordLit dflags w]
243 244

-- | Create a 'CoreExpr' which will evaluate to the given @Word@
245
mkWordExprWord :: DynFlags -> Word -> CoreExpr
246
mkWordExprWord dflags w = mkCoreConApps wordDataCon [mkWordLitWord dflags w]
247 248

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

253 254 255 256 257 258 259 260 261
-- | Create a 'CoreExpr' which will evaluate to the given @Natural@
--
-- TODO: should we add LitNatural to Core?
mkNaturalExpr  :: MonadThings m => Integer -> m CoreExpr  -- Result :: Natural
mkNaturalExpr i = do iExpr <- mkIntegerExpr i
                     fiExpr <- lookupId naturalFromIntegerName
                     return (mkCoreApps (Var fiExpr) [iExpr])


262 263
-- | Create a 'CoreExpr' which will evaluate to the given @Float@
mkFloatExpr :: Float -> CoreExpr
264
mkFloatExpr f = mkCoreConApps floatDataCon [mkFloatLitFloat f]
265 266 267

-- | Create a 'CoreExpr' which will evaluate to the given @Double@
mkDoubleExpr :: Double -> CoreExpr
268
mkDoubleExpr d = mkCoreConApps doubleDataCon [mkDoubleLitDouble d]
269 270 271 272


-- | Create a 'CoreExpr' which will evaluate to the given @Char@
mkCharExpr     :: Char             -> CoreExpr      -- Result = C# c :: Int
273
mkCharExpr c = mkCoreConApps charDataCon [mkCharLit c]
274 275 276

-- | 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
277

278 279 280 281 282
-- | 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)

283 284 285 286
mkStringExprFS = mkStringExprFSWith lookupId

mkStringExprFSWith :: Monad m => (Name -> m Id) -> FastString -> m CoreExpr
mkStringExprFSWith lookupM str
287 288 289 290
  | nullFS str
  = return (mkNilExpr charTy)

  | all safeChar chars
291
  = do unpack_id <- lookupM unpackCStringName
292
       return (App (Var unpack_id) lit)
293 294

  | otherwise
295
  = do unpack_utf8_id <- lookupM unpackCStringUtf8Name
296
       return (App (Var unpack_utf8_id) lit)
297 298 299 300

  where
    chars = unpackFS str
    safeChar c = ord c >= 1 && ord c <= 0x7F
301
    lit = Lit (MachStr (fastStringToByteString str))
batterseapower's avatar
batterseapower committed
302

Austin Seipp's avatar
Austin Seipp committed
303 304 305
{-
************************************************************************
*                                                                      *
306
\subsection{Tuple constructors}
Austin Seipp's avatar
Austin Seipp committed
307 308 309
*                                                                      *
************************************************************************
-}
310

Austin Seipp's avatar
Austin Seipp committed
311
{-
312
Creating tuples and their types for Core expressions
313

314
@mkBigCoreVarTup@ builds a tuple; the inverse to @mkTupleSelector@.
315 316 317

* If it has only one element, it is the identity function.

318 319
* If there are more elements than a big tuple can have, it nests
  the tuples.
320 321 322 323 324

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
325
What if there is just one variable/expression/type in the argument?
326 327 328 329 330 331 332 333 334 335
We could do one of two things:

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

* Built a one-tuple (see Note [One-tuples] in TysWiredIn)
    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
336
-}
337 338

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

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

-- | Build a small tuple holding the specified expressions
349
-- One-tuples are flattened; see Note [Flattening one-tuples]
350 351 352
mkCoreTup :: [CoreExpr] -> CoreExpr
mkCoreTup []  = Var unitDataConId
mkCoreTup [c] = c
353 354 355 356 357
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.
358
-- Do not include the RuntimeRep specifiers; this function calculates them
359
-- for you.
360
-- Does /not/ flatten one-tuples; see Note [Flattening one-tuples]
361 362 363 364
mkCoreUbxTup :: [Type] -> [CoreExpr] -> CoreExpr
mkCoreUbxTup tys exps
  = ASSERT( tys `equalLength` exps)
    mkCoreConApps (tupleDataCon Unboxed (length tys))
365
             (map (Type . getRuntimeRep) tys ++ map Type tys ++ exps)
366 367 368 369 370

-- | 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
371 372

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

377 378 379 380 381 382 383
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)

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

-- | Build a big tuple holding the specified expressions
390
-- One-tuples are flattened; see Note [Flattening one-tuples]
391 392 393 394
mkBigCoreTup :: [CoreExpr] -> CoreExpr
mkBigCoreTup = mkChunkified mkCoreTup

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

399 400 401
-- | The unit expression
unitExpr :: CoreExpr
unitExpr = Var unitDataConId
402

Austin Seipp's avatar
Austin Seipp committed
403 404 405
{-
************************************************************************
*                                                                      *
406
\subsection{Tuple destructors}
Austin Seipp's avatar
Austin Seipp committed
407 408 409
*                                                                      *
************************************************************************
-}
410 411 412 413 414 415 416 417 418 419 420

-- | 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.
421 422 423 424 425 426
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
427 428

-- mkTupleSelector [a,b,c,d] b v e
429
--          = case e of v {
430 431 432 433 434 435
--                (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
--
436
--        case (case e of v
437 438 439 440 441 442 443 444 445
--                (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
446
          tpl_tys = [mkBoxedTupleTy (map idType gp) | gp <- vars_s]
447 448 449
          tpl_vs  = mkTemplateLocals tpl_tys
          [(tpl_v, group)] = [(tpl,gp) | (tpl,gp) <- zipEqual "mkTupleSelector" tpl_vs vars_s,
                                         the_var `elem` gp ]
450 451 452 453 454 455 456
-- ^ '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
457 458 459 460 461 462

-- | 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 } |]
463 464 465 466 467
mkSmallTupleSelector, mkSmallTupleSelector1
          :: [Id]        -- The tuple args
          -> Id          -- The selected one
          -> Id          -- A variable of the same type as the scrutinee
          -> CoreExpr    -- Scrutinee
468 469 470
          -> CoreExpr
mkSmallTupleSelector [var] should_be_the_same_var _ scrut
  = ASSERT(var == should_be_the_same_var)
471
    scrut  -- Special case for 1-tuples
472
mkSmallTupleSelector vars the_var scrut_var scrut
473 474 475 476 477
  = 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
478 479
  = ASSERT( notNull vars )
    Case scrut scrut_var (idType the_var)
480
         [(DataAlt (tupleDataCon Boxed (length vars)), vars, Var the_var)]
481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506

-- | 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
507

508 509 510 511
    -- 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'
512

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

-- | 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?
533 534
  = Case scrut scrut_var (exprType body)
         [(DataAlt (tupleDataCon Boxed (length vars)), vars, body)]
535

536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558
{-
************************************************************************
*                                                                      *
                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
559 560 561
{-
************************************************************************
*                                                                      *
562
\subsection{Common list manipulation expressions}
Austin Seipp's avatar
Austin Seipp committed
563 564
*                                                                      *
************************************************************************
565 566 567

Call the constructor Ids when building explicit lists, so that they
interact well with rules.
Austin Seipp's avatar
Austin Seipp committed
568
-}
569 570 571

-- | Makes a list @[]@ for lists of the specified type
mkNilExpr :: Type -> CoreExpr
572
mkNilExpr ty = mkCoreConApps nilDataCon [Type ty]
573 574 575

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

-- | 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
592
    return (Var foldr_id `App` Type elt_ty
593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609
           `App` Type result_ty
           `App` c
           `App` n
           `App` list)

-- | Make a 'build' expression applied to a locally-bound worker function
mkBuildExpr :: (MonadThings m, MonadUnique m)
            => 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]
610

611
    build_inside <- mk_build_inside (c, c_ty) (n, n_ty)
612

613 614 615 616 617 618
    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)
619

Jan Stolarek's avatar
Jan Stolarek committed
620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637
{-
************************************************************************
*                                                                      *
             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
638 639 640
{-
************************************************************************
*                                                                      *
641
                      Error expressions
Austin Seipp's avatar
Austin Seipp committed
642 643 644
*                                                                      *
************************************************************************
-}
645

646
mkRuntimeErrorApp
647 648 649 650 651 652
        :: 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

653
mkRuntimeErrorApp err_id res_ty err_msg
654
  = mkApps (Var err_id) [ Type (getRuntimeRep res_ty)
655
                        , Type res_ty, err_string ]
656 657 658 659 660 661 662
  where
    err_string = Lit (mkMachString err_msg)

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

Austin Seipp's avatar
Austin Seipp committed
663 664 665
{-
************************************************************************
*                                                                      *
666
                     Error Ids
Austin Seipp's avatar
Austin Seipp committed
667 668
*                                                                      *
************************************************************************
669 670 671 672 673 674 675 676 677 678 679 680 681 682 683

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
684
-}
685 686

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

recSelErrorName, runtimeErrorName, absentErrorName :: Name
irrefutPatErrorName, recConErrorName, patErrorName :: Name
nonExhaustiveGuardsErrorName, noMethodBindingErrorName :: Name
702
typeErrorName :: Name
703 704 705 706 707 708 709

recSelErrorName     = err_nm "recSelError"     recSelErrorIdKey     rEC_SEL_ERROR_ID
absentErrorName     = err_nm "absentError"     absentErrorIdKey     aBSENT_ERROR_ID
runtimeErrorName    = err_nm "runtimeError"    runtimeErrorIdKey    rUNTIME_ERROR_ID
irrefutPatErrorName = err_nm "irrefutPatError" irrefutPatErrorIdKey iRREFUT_PAT_ERROR_ID
recConErrorName     = err_nm "recConError"     recConErrorIdKey     rEC_CON_ERROR_ID
patErrorName        = err_nm "patError"        patErrorIdKey        pAT_ERROR_ID
710
typeErrorName       = err_nm "typeError"       typeErrorIdKey       tYPE_ERROR_ID
711 712 713

noMethodBindingErrorName     = err_nm "noMethodBindingError"
                                  noMethodBindingErrorIdKey nO_METHOD_BINDING_ERROR_ID
714
nonExhaustiveGuardsErrorName = err_nm "nonExhaustiveGuardsError"
715 716 717 718 719 720 721
                                  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

rEC_SEL_ERROR_ID, rUNTIME_ERROR_ID, iRREFUT_PAT_ERROR_ID, rEC_CON_ERROR_ID :: Id
pAT_ERROR_ID, nO_METHOD_BINDING_ERROR_ID, nON_EXHAUSTIVE_GUARDS_ERROR_ID :: Id
722
tYPE_ERROR_ID, aBSENT_ERROR_ID :: Id
723 724 725 726 727 728 729
rEC_SEL_ERROR_ID                = mkRuntimeErrorId recSelErrorName
rUNTIME_ERROR_ID                = mkRuntimeErrorId runtimeErrorName
iRREFUT_PAT_ERROR_ID            = mkRuntimeErrorId irrefutPatErrorName
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
730
aBSENT_ERROR_ID                 = mkRuntimeErrorId absentErrorName
731
tYPE_ERROR_ID                   = mkRuntimeErrorId typeErrorName
732 733

mkRuntimeErrorId :: Name -> Id
734 735 736 737 738 739 740 741
-- 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
 = mkVanillaGlobalWithInfo name runtime_err_ty bottoming_info
742
 where
743
    bottoming_info = vanillaIdInfo `setStrictnessInfo`    strict_sig
744 745
                                   `setArityInfo`         1
                        -- Make arity and strictness agree
746 747 748 749 750 751 752 753 754 755

        -- 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.

756
    strict_sig = mkClosedStrictSig [evalDmd] exnRes
757
              -- exnRes: these throw an exception, not just diverge
758

Simon Peyton Jones's avatar
Simon Peyton Jones committed
759 760
    -- forall (rr :: RuntimeRep) (a :: rr). Addr# -> a
    --   See Note [Error and friends have an "open-tyvar" forall]
761 762 763 764 765 766 767 768
    runtime_err_ty = mkSpecSigmaTy [runtimeRep1TyVar, openAlphaTyVar] []
                                   (mkFunTy addrPrimTy openAlphaTy)

{- 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
769
Notice the runtime-representation polymorphism. This ensures that
770 771 772
"error" can be instantiated at unboxed as well as boxed types.
This is OK because it never returns, so the return type is irrelevant.
-}