MkId.lhs 41.8 KB
Newer Older
Thomas Schilling's avatar
Thomas Schilling committed
1
%
Simon Marlow's avatar
Simon Marlow committed
2
% (c) The University of Glasgow 2006
3
% (c) The AQUA Project, Glasgow University, 1998
4
5
6
7
8
%

This module contains definitions for the IdInfo for things that
have a standard form, namely:

Thomas Schilling's avatar
Thomas Schilling committed
9
10
11
12
- data constructors
- record selectors
- method and superclass selectors
- primitive operations
13
14

\begin{code}
Ian Lynagh's avatar
Ian Lynagh committed
15
16
17
18
19
20
21
{-# OPTIONS -fno-warn-tabs #-}
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and
-- detab the module (please do the detabbing in a separate patch). See
--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
-- for details

22
module MkId (
23
        mkDictFunId, mkDictFunTy, mkDictSelId,
24

25
        mkDataConIds, mkPrimOpId, mkFCallId,
26

Ian Lynagh's avatar
Ian Lynagh committed
27
        mkReboxingAlt, wrapNewTypeBody, unwrapNewTypeBody,
28
        wrapFamInstBody, unwrapFamInstScrut,
29
        wrapTypeFamInstBody, unwrapTypeFamInstScrut,
30
        mkUnpackCase, mkProductBox,
31

Ian Lynagh's avatar
Ian Lynagh committed
32
33
        -- And some particular Ids; see below for why they are wired in
        wiredInIds, ghcPrimIds,
34
        unsafeCoerceName, unsafeCoerceId, realWorldPrimId, 
35
36
37
38
39
        voidArgId, nullAddrId, seqId, lazyId, lazyIdKey,
        coercionTokenId,

	-- Re-export error Ids
	module PrelRules
40
41
42
43
    ) where

#include "HsVersions.h"

Simon Marlow's avatar
Simon Marlow committed
44
45
import Rules
import TysPrim
46
import TysWiredIn
Simon Marlow's avatar
Simon Marlow committed
47
48
49
50
import PrelRules
import Type
import Coercion
import TcType
51
import MkCore
52
import CoreUtils	( exprType, mkCast )
Simon Marlow's avatar
Simon Marlow committed
53
54
55
56
57
58
59
60
61
62
import CoreUnfold
import Literal
import TyCon
import Class
import VarSet
import Name
import PrimOp
import ForeignCall
import DataCon
import Id
63
import Var              ( mkExportedLocalVar )
Simon Marlow's avatar
Simon Marlow committed
64
import IdInfo
65
import Demand
66
import CoreSyn
Simon Marlow's avatar
Simon Marlow committed
67
import Unique
68
import PrelNames
Simon Marlow's avatar
Simon Marlow committed
69
70
import BasicTypes       hiding ( SuccessFlag(..) )
import Util
71
import Pair
Ian Lynagh's avatar
Ian Lynagh committed
72
import DynFlags
73
import Outputable
74
import FastString
Simon Marlow's avatar
Simon Marlow committed
75
import ListSetOps
76
77

import Data.Maybe       ( maybeToList )
78
\end{code}
79

80
%************************************************************************
Ian Lynagh's avatar
Ian Lynagh committed
81
%*                                                                      *
82
\subsection{Wired in Ids}
Ian Lynagh's avatar
Ian Lynagh committed
83
%*                                                                      *
84
85
%************************************************************************

86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
Note [Wired-in Ids]
~~~~~~~~~~~~~~~~~~~
There are several reasons why an Id might appear in the wiredInIds:

(1) The ghcPrimIds are wired in because they can't be defined in
    Haskell at all, although the can be defined in Core.  They have
    compulsory unfoldings, so they are always inlined and they  have
    no definition site.  Their home module is GHC.Prim, so they
    also have a description in primops.txt.pp, where they are called
    'pseudoops'.

(2) The 'error' function, eRROR_ID, is wired in because we don't yet have
    a way to express in an interface file that the result type variable
    is 'open'; that is can be unified with an unboxed type

    [The interface file format now carry such information, but there's
    no way yet of expressing at the definition site for these 
    error-reporting functions that they have an 'open' 
    result type. -- sof 1/99]

(3) Other error functions (rUNTIME_ERROR_ID) are wired in (a) because
    the desugarer generates code that mentiones them directly, and
    (b) for the same reason as eRROR_ID

(4) lazyId is wired in because the wired-in version overrides the
    strictness of the version defined in GHC.Base

In cases (2-4), the function has a definition in a library module, and
can be called; but the wired-in version means that the details are 
never read from that module's interface file; instead, the full definition
is right here.

118
\begin{code}
119
wiredInIds :: [Id]
120
wiredInIds
121
122
123
  =  [lazyId]
  ++ errorIds		-- Defined in MkCore
  ++ ghcPrimIds
124
125

-- These Ids are exported from GHC.Prim
126
ghcPrimIds :: [Id]
127
ghcPrimIds
Ian Lynagh's avatar
Ian Lynagh committed
128
129
  = [   -- These can't be defined in Haskell, but they have
        -- perfectly reasonable unfoldings in Core
130
131
132
133
    realWorldPrimId,
    unsafeCoerceId,
    nullAddrId,
    seqId
134
135
136
    ]
\end{code}

137
%************************************************************************
Ian Lynagh's avatar
Ian Lynagh committed
138
%*                                                                      *
139
\subsection{Data constructors}
Ian Lynagh's avatar
Ian Lynagh committed
140
%*                                                                      *
141
142
%************************************************************************

143
144
145
146
The wrapper for a constructor is an ordinary top-level binding that evaluates
any strict args, unboxes any args that are going to be flattened, and calls
the worker.

147
148
We're going to build a constructor that looks like:

Ian Lynagh's avatar
Ian Lynagh committed
149
        data (Data a, C b) =>  T a b = T1 !a !Int b
150

Ian Lynagh's avatar
Ian Lynagh committed
151
152
153
154
155
        T1 = /\ a b -> 
             \d1::Data a, d2::C b ->
             \p q r -> case p of { p ->
                       case q of { q ->
                       Con T1 [a,b] [p,q,r]}}
156
157
158
159
160
161
162
163
164
165

Notice that

* d2 is thrown away --- a context in a data decl is used to make sure
  one *could* construct dictionaries at the site the constructor
  is used, but the dictionary isn't actually used.

* We have to check that we can construct Data dictionaries for
  the types a and Int.  Once we've done that we can throw d1 away too.

166
* We use (case p of q -> ...) to evaluate p, rather than "seq" because
167
168
169
170
  all that matters is that the arguments are evaluated.  "seq" is 
  very careful to preserve evaluation order, which we don't need
  to be here.

171
172
173
174
175
176
177
178
179
  You might think that we could simply give constructors some strictness
  info, like PrimOps, and let CoreToStg do the let-to-case transformation.
  But we don't do that because in the case of primops and functions strictness
  is a *property* not a *requirement*.  In the case of constructors we need to
  do something active to evaluate the argument.

  Making an explicit case expression allows the simplifier to eliminate
  it in the (common) case where the constructor arg is already evaluated.

180
181
Note [Wrappers for data instance tycons]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
182
183
In the case of data instances, the wrapper also applies the coercion turning
the representation type into the family instance type to cast the result of
184
185
186
187
188
the wrapper.  For example, consider the declarations

  data family Map k :: * -> *
  data instance Map (a, b) v = MapPair (Map a (Pair b v))

189
190
191
192
193
194
195
The tycon to which the datacon MapPair belongs gets a unique internal
name of the form :R123Map, and we call it the representation tycon.
In contrast, Map is the family tycon (accessible via
tyConFamInst_maybe). A coercion allows you to move between
representation and family type.  It is accessible from :R123Map via
tyConFamilyCoercion_maybe and has kind

196
  Co123Map a b v :: {Map (a, b) v ~ :R123Map a b v}
197
198

The wrapper and worker of MapPair get the types
199

Ian Lynagh's avatar
Ian Lynagh committed
200
        -- Wrapper
201
  $WMapPair :: forall a b v. Map a (Map a b v) -> Map (a, b) v
202
  $WMapPair a b v = MapPair a b v `cast` sym (Co123Map a b v)
203

Ian Lynagh's avatar
Ian Lynagh committed
204
        -- Worker
205
  MapPair :: forall a b v. Map a (Map a b v) -> :R123Map a b v
206

207
This coercion is conditionally applied by wrapFamInstBody.
208

209
It's a bit more complicated if the data instance is a GADT as well!
210

211
   data instance T [a] where
Ian Lynagh's avatar
Ian Lynagh committed
212
        T1 :: forall b. b -> T [Maybe b]
213

simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
214
Hence we translate to
215

Ian Lynagh's avatar
Ian Lynagh committed
216
        -- Wrapper
217
  $WT1 :: forall b. b -> T [Maybe b]
218
  $WT1 b v = T1 (Maybe b) b (Maybe b) v
Ian Lynagh's avatar
Ian Lynagh committed
219
                        `cast` sym (Co7T (Maybe b))
220

Ian Lynagh's avatar
Ian Lynagh committed
221
        -- Worker
222
  T1 :: forall c b. (c ~ Maybe b) => b -> :R7T c
223

simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
224
225
226
        -- Coercion from family type to representation type
  Co7T a :: T [a] ~ :R7T a

227
\begin{code}
228
229
mkDataConIds :: Name -> Name -> DataCon -> DataConIds
mkDataConIds wrap_name wkr_name data_con
Ian Lynagh's avatar
Ian Lynagh committed
230
  | isNewTyCon tycon                    -- Newtype, only has a worker
231
  = DCIds Nothing nt_work_id                 
232

233
  | any isBanged all_strict_marks      -- Algebraic, needs wrapper
234
    || not (null eq_spec)              -- NB: LoadIface.ifaceDeclImplicitBndrs
235
    || isFamInstTyCon tycon            --     depends on this test
236
  = DCIds (Just alg_wrap_id) wrk_id
237

Ian Lynagh's avatar
Ian Lynagh committed
238
  | otherwise                                -- Algebraic, no wrapper
239
  = DCIds Nothing wrk_id
240
  where
241
    (univ_tvs, ex_tvs, eq_spec, 
242
     other_theta, orig_arg_tys, res_ty) = dataConFullSig data_con
Ian Lynagh's avatar
Ian Lynagh committed
243
    tycon = dataConTyCon data_con       -- The representation TyCon (not family)
244

Ian Lynagh's avatar
Ian Lynagh committed
245
246
247
        ----------- Worker (algebraic data types only) --------------
        -- The *worker* for the data constructor is the function that
        -- takes the representation arguments and builds the constructor.
248
    wrk_id = mkGlobalId (DataConWorkId data_con) wkr_name
Ian Lynagh's avatar
Ian Lynagh committed
249
                        (dataConRepType data_con) wkr_info
250
251
252

    wkr_arity = dataConRepArity data_con
    wkr_info  = noCafIdInfo
253
                `setArityInfo`       wkr_arity
254
                `setStrictnessInfo`  Just wkr_sig
255
                `setUnfoldingInfo`   evaldUnfolding  -- Record that it's evaluated,
Ian Lynagh's avatar
Ian Lynagh committed
256
                                                        -- even if arity = 0
257
258

    wkr_sig = mkStrictSig (mkTopDmdType (replicate wkr_arity topDmd) cpr_info)
Ian Lynagh's avatar
Ian Lynagh committed
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
        --      Note [Data-con worker strictness]
        -- Notice that we do *not* say the worker is strict
        -- even if the data constructor is declared strict
        --      e.g.    data T = MkT !(Int,Int)
        -- Why?  Because the *wrapper* is strict (and its unfolding has case
        -- expresssions that do the evals) but the *worker* itself is not.
        -- If we pretend it is strict then when we see
        --      case x of y -> $wMkT y
        -- the simplifier thinks that y is "sure to be evaluated" (because
        --  $wMkT is strict) and drops the case.  No, $wMkT is not strict.
        --
        -- When the simplifer sees a pattern 
        --      case e of MkT x -> ...
        -- it uses the dataConRepStrictness of MkT to mark x as evaluated;
        -- but that's fine... dataConRepStrictness comes from the data con
        -- not from the worker Id.
275
276

    cpr_info | isProductTyCon tycon && 
Ian Lynagh's avatar
Ian Lynagh committed
277
278
279
280
281
282
283
284
               isDataTyCon tycon    &&
               wkr_arity > 0        &&
               wkr_arity <= mAX_CPR_SIZE        = retCPR
             | otherwise                        = TopRes
        -- RetCPR is only true for products that are real data types;
        -- that is, not unboxed tuples or [non-recursive] newtypes

        ----------- Workers for newtypes --------------
285
    nt_work_id   = mkGlobalId (DataConWrapId data_con) wkr_name wrap_ty nt_work_info
Ian Lynagh's avatar
Ian Lynagh committed
286
287
    nt_work_info = noCafIdInfo          -- The NoCaf-ness is set by noCafIdInfo
                  `setArityInfo` 1      -- Arity 1
288
                  `setInlinePragInfo`    alwaysInlinePragma
Ian Lynagh's avatar
Ian Lynagh committed
289
                  `setUnfoldingInfo`     newtype_unf
290
291
292
293
    id_arg1      = mkTemplateLocal 1 (head orig_arg_tys)
    newtype_unf  = ASSERT2( isVanillaDataCon data_con &&
                            isSingleton orig_arg_tys, ppr data_con  )
			      -- Note [Newtype datacons]
Ian Lynagh's avatar
Ian Lynagh committed
294
295
                   mkCompulsoryUnfolding $ 
                   mkLams wrap_tvs $ Lam id_arg1 $ 
296
                   wrapNewTypeBody tycon res_ty_args (Var id_arg1)
297

Ian Lynagh's avatar
Ian Lynagh committed
298
299
300
301
302

        ----------- Wrapper --------------
        -- We used to include the stupid theta in the wrapper's args
        -- but now we don't.  Instead the type checker just injects these
        -- extra constraints where necessary.
303
    wrap_tvs    = (univ_tvs `minusList` map fst eq_spec) ++ ex_tvs
Ian Lynagh's avatar
Ian Lynagh committed
304
    res_ty_args = substTyVars (mkTopTvSubst eq_spec) univ_tvs
batterseapower's avatar
batterseapower committed
305
    ev_tys      = other_theta
306
307
308
    wrap_ty     = mkForAllTys wrap_tvs $ 
                  mkFunTys ev_tys $
                  mkFunTys orig_arg_tys $ res_ty
309

Ian Lynagh's avatar
Ian Lynagh committed
310
        ----------- Wrappers for algebraic data types -------------- 
311
    alg_wrap_id = mkGlobalId (DataConWrapId data_con) wrap_name wrap_ty alg_wrap_info
batterseapower's avatar
batterseapower committed
312
    alg_wrap_info = noCafIdInfo
Ian Lynagh's avatar
Ian Lynagh committed
313
314
315
                    `setArityInfo`         wrap_arity
                        -- It's important to specify the arity, so that partial
                        -- applications are treated as values
316
		    `setInlinePragInfo`    alwaysInlinePragma
Ian Lynagh's avatar
Ian Lynagh committed
317
                    `setUnfoldingInfo`     wrap_unf
318
                    `setStrictnessInfo` Just wrap_sig
batterseapower's avatar
batterseapower committed
319
320
321
                        -- We need to get the CAF info right here because TidyPgm
                        -- does not tidy the IdInfo of implicit bindings (like the wrapper)
                        -- so it not make sure that the CAF info is sane
322
323

    all_strict_marks = dataConExStricts data_con ++ dataConStrictMarks data_con
324
325
326
    wrap_sig = mkStrictSig (mkTopDmdType wrap_arg_dmds cpr_info)
    wrap_stricts = dropList eq_spec all_strict_marks
    wrap_arg_dmds = map mk_dmd wrap_stricts
327
328
    mk_dmd str | isBanged str = evalDmd
               | otherwise    = lazyDmd
Ian Lynagh's avatar
Ian Lynagh committed
329
330
331
332
333
334
335
336
        -- The Cpr info can be important inside INLINE rhss, where the
        -- wrapper constructor isn't inlined.
        -- And the argument strictness can be important too; we
        -- may not inline a contructor when it is partially applied.
        -- For example:
        --      data W = C !Int !Int !Int
        --      ...(let w = C x in ...(w p q)...)...
        -- we want to see that w is strict in its two arguments
337

338
    wrap_unf = mkInlineUnfolding (Just (length ev_args + length id_args)) wrap_rhs
339
    wrap_rhs = mkLams wrap_tvs $ 
340
341
               mkLams ev_args $
               mkLams id_args $
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
342
               foldr mk_case con_app 
343
                     (zip (ev_args ++ id_args) wrap_stricts)
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
344
                     i3 []
345
346
347
	     -- The ev_args is the evidence arguments *other than* the eq_spec
	     -- Because we are going to apply the eq_spec args manually in the
	     -- wrapper
348

349
    con_app _ rep_ids = wrapFamInstBody tycon res_ty_args $
Ian Lynagh's avatar
Ian Lynagh committed
350
351
                          Var wrk_id `mkTyApps`  res_ty_args
                                     `mkVarApps` ex_tvs                 
352
                                     `mkCoApps`  map (mkReflCo . snd) eq_spec
Ian Lynagh's avatar
Ian Lynagh committed
353
                                     `mkVarApps` reverse rep_ids
batterseapower's avatar
batterseapower committed
354
355
                            -- Dont box the eq_spec coercions since they are
                            -- marked as HsUnpack by mk_dict_strict_mark
356

357
358
359
    (ev_args,i2) = mkLocals 1  ev_tys
    (id_args,i3) = mkLocals i2 orig_arg_tys
    wrap_arity   = i3-1
360
361

    mk_case 
362
           :: (Id, HsBang)      -- Arg, strictness
Ian Lynagh's avatar
Ian Lynagh committed
363
364
365
366
           -> (Int -> [Id] -> CoreExpr) -- Body
           -> Int                       -- Next rep arg id
           -> [Id]                      -- Rep args so far, reversed
           -> CoreExpr
367
    mk_case (arg,strict) body i rep_args
Ian Lynagh's avatar
Ian Lynagh committed
368
          = case strict of
369
370
                HsNoBang -> body i (arg:rep_args)
                HsUnpack -> unboxProduct i (Var arg) (idType arg) the_body 
371
372
                      where
                        the_body i con_args = body i (reverse con_args ++ rep_args)
373
374
375
376
                _other  -- HsUnpackFailed and HsStrict
                   | isUnLiftedType (idType arg) -> body i (arg:rep_args)
                   | otherwise -> Case (Var arg) arg res_ty 
                                       [(DEFAULT,[], body i (arg:rep_args))]
377
378
379
380

mAX_CPR_SIZE :: Arity
mAX_CPR_SIZE = 10
-- We do not treat very big tuples as CPR-ish:
Ian Lynagh's avatar
Ian Lynagh committed
381
382
383
384
385
386
387
--      a) for a start we get into trouble because there aren't 
--         "enough" unboxed tuple types (a tiresome restriction, 
--         but hard to fix), 
--      b) more importantly, big unboxed tuples get returned mainly
--         on the stack, and are often then allocated in the heap
--         by the caller.  So doing CPR for them may in fact make
--         things worse.
388

389
mkLocals :: Int -> [Type] -> ([Id], Int)
390
mkLocals i tys = (zipWith mkTemplateLocal [i..i+n-1] tys, i+n)
Ian Lynagh's avatar
Ian Lynagh committed
391
392
               where
                 n = length tys
393
394
\end{code}

395
396
397
398
399
400
401
402
403
404
405
Note [Newtype datacons]
~~~~~~~~~~~~~~~~~~~~~~~
The "data constructor" for a newtype should always be vanilla.  At one
point this wasn't true, because the newtype arising from
     class C a => D a
looked like
       newtype T:D a = D:D (C a)
so the data constructor for T:C had a single argument, namely the
predicate (C a).  But now we treat that as an ordinary argument, not
part of the theta-type, so all is well.

406
407

%************************************************************************
Ian Lynagh's avatar
Ian Lynagh committed
408
%*                                                                      *
409
\subsection{Dictionary selectors}
Ian Lynagh's avatar
Ian Lynagh committed
410
%*                                                                      *
411
412
%************************************************************************

413
414
Selecting a field for a dictionary.  If there is just one field, then
there's nothing to do.  
415

416
Dictionary selectors may get nested forall-types.  Thus:
417

418
419
        class Foo a where
          op :: forall b. Ord b => a -> b -> b
420

421
Then the top-level type for op is
422

423
424
425
        op :: forall a. Foo a => 
              forall b. Ord b => 
              a -> b -> b
426

427
428
429
This is unlike ordinary record selectors, which have all the for-alls
at the outside.  When dealing with classes it's very convenient to
recover the original type signature from the class op selector.
430

431
\begin{code}
432
433
434
435
436
437
mkDictSelId :: Bool	     -- True <=> don't include the unfolding
			     -- Little point on imports without -O, because the
			     -- dictionary itself won't be visible
 	    -> Name	     -- Name of one of the *value* selectors 
	       		     -- (dictionary superclass or method)
            -> Class -> Id
438
439
440
441
442
443
444
445
446
mkDictSelId no_unf name clas
  = mkGlobalId (ClassOpId clas) name sel_ty info
  where
    sel_ty = mkForAllTys tyvars (mkFunTy (idType dict_id) (idType the_arg_id))
        -- We can't just say (exprType rhs), because that would give a type
        --      C a -> C a
        -- for a single-op class (after all, the selector is the identity)
        -- But it's type must expose the representation of the dictionary
        -- to get (say)         C a -> (a -> a)
447

448
449
    base_info = noCafIdInfo
                `setArityInfo`      1
450
                `setStrictnessInfo` Just strict_sig
451
                `setUnfoldingInfo`  (if no_unf then noUnfolding
452
	                             else mkImplicitUnfolding rhs)
453
454
455
456
457
		   -- In module where class op is defined, we must add
		   -- the unfolding, even though it'll never be inlined
		   -- becuase we use that to generate a top-level binding
		   -- for the ClassOp

458
    info | new_tycon = base_info `setInlinePragInfo` alwaysInlinePragma
Simon Peyton Jones's avatar
Simon Peyton Jones committed
459
460
    	   	   -- See Note [Single-method classes] in TcInstDcls
		   -- for why alwaysInlinePragma
461
462
463
464
465
         | otherwise = base_info  `setSpecInfo`       mkSpecInfo [rule]
		       		  `setInlinePragInfo` neverInlinePragma
		   -- Add a magic BuiltinRule, and never inline it
		   -- so that the rule is always available to fire.
		   -- See Note [ClassOp/DFun selection] in TcInstDcls
466

467
468
469
470
471
472
473
474
    n_ty_args = length tyvars

    -- This is the built-in rule that goes
    -- 	    op (dfT d1 d2) --->  opT d1 d2
    rule = BuiltinRule { ru_name = fsLit "Class op " `appendFS` 
    	   	       	 	     occNameFS (getOccName name)
                       , ru_fn    = name
    	               , ru_nargs = n_ty_args + 1
475
                       , ru_try   = dictSelRule val_index n_ty_args }
476

477
478
479
480
481
        -- The strictness signature is of the form U(AAAVAAAA) -> T
        -- where the V depends on which item we are selecting
        -- It's worth giving one, so that absence info etc is generated
        -- even if the selector isn't inlined
    strict_sig = mkStrictSig (mkTopDmdType [arg_dmd] TopRes)
482
483
484
    arg_dmd | new_tycon = evalDmd
            | otherwise = Eval (Prod [ if the_arg_id == id then evalDmd else Abs
                                     | id <- arg_ids ])
485

486
487
488
489
490
    tycon      	   = classTyCon clas
    new_tycon  	   = isNewTyCon tycon
    [data_con] 	   = tyConDataCons tycon
    tyvars     	   = dataConUnivTyVars data_con
    arg_tys    	   = dataConRepArgTys data_con	-- Includes the dictionary superclasses
491

492
493
494
    -- 'index' is a 0-index into the *value* arguments of the dictionary
    val_index      = assoc "MkId.mkDictSelId" sel_index_prs name
    sel_index_prs  = map idName (classAllSelIds clas) `zip` [0..]
495

496
497
    the_arg_id     = arg_ids !! val_index
    pred       	   = mkClassPred clas (mkTyVarTys tyvars)
batterseapower's avatar
batterseapower committed
498
    dict_id    	   = mkTemplateLocal 1 pred
499
    arg_ids    	   = mkTemplateLocalsNum 2 arg_tys
500

501
    rhs = mkLams tyvars  (Lam dict_id   rhs_body)
502
503
    rhs_body | new_tycon = unwrapNewTypeBody tycon (map mkTyVarTy tyvars) (Var dict_id)
             | otherwise = Case (Var dict_id) dict_id (idType the_arg_id)
Simon Peyton Jones's avatar
Simon Peyton Jones committed
504
505
506
                                [(DataAlt data_con, arg_ids, varToCoreExpr the_arg_id)]
				-- varToCoreExpr needed for equality superclass selectors
				--   sel a b d = case x of { MkC _ (g:a~b) _ -> CO g }
507

508
dictSelRule :: Int -> Arity 
509
            -> Id -> IdUnfoldingFun -> [CoreExpr] -> Maybe CoreExpr
510
511
512
-- Tries to persuade the argument to look like a constructor
-- application, using exprIsConApp_maybe, and then selects
-- from it
513
--       sel_i t1..tk (D t1..tk op1 ... opm) = opi
514
--
515
dictSelRule val_index n_ty_args _ id_unf args
516
  | (dict_arg : _) <- drop n_ty_args args
517
  , Just (_, _, con_args) <- exprIsConApp_maybe id_unf dict_arg
518
  = Just (con_args !! val_index)
519
520
  | otherwise
  = Nothing
521
\end{code}
522
523


524
525
526
527
528
%************************************************************************
%*                                                                      *
        Boxing and unboxing
%*                                                                      *
%************************************************************************
529
530

\begin{code}
531
532
533
534
535
536
537
538
539
540
541
-- unbox a product type...
-- we will recurse into newtypes, casting along the way, and unbox at the
-- first product data constructor we find. e.g.
--  
--   data PairInt = PairInt Int Int
--   newtype S = MkS PairInt
--   newtype T = MkT S
--
-- If we have e = MkT (MkS (PairInt 0 1)) and some body expecting a list of
-- ids, we get (modulo int passing)
--
542
--   case (e `cast` CoT) `cast` CoS of
543
544
545
--     PairInt a b -> body [a,b]
--
-- The Ints passed around are just for creating fresh locals
546
547
unboxProduct :: Int -> CoreExpr -> Type -> (Int -> [Id] -> CoreExpr) -> CoreExpr
unboxProduct i arg arg_ty body
548
  = result
549
  where 
550
    result = mkUnpackCase the_id arg con_args boxing_con rhs
551
    (_tycon, _tycon_args, boxing_con, tys) = deepSplitProductType "unboxProduct" arg_ty
552
553
554
555
    ([the_id], i') = mkLocals i [arg_ty]
    (con_args, i'') = mkLocals i' tys
    rhs = body i'' con_args

556
mkUnpackCase ::  Id -> CoreExpr -> [Id] -> DataCon -> CoreExpr -> CoreExpr
chak@cse.unsw.edu.au.'s avatar
Comment    
chak@cse.unsw.edu.au. committed
557
-- (mkUnpackCase x e args Con body)
Ian Lynagh's avatar
Ian Lynagh committed
558
--      returns
chak@cse.unsw.edu.au.'s avatar
Comment    
chak@cse.unsw.edu.au. committed
559
-- case (e `cast` ...) of bndr { Con args -> body }
560
561
-- 
-- the type of the bndr passed in is irrelevent
562
mkUnpackCase bndr arg unpk_args boxing_con body
563
  = Case cast_arg (setIdType bndr bndr_ty) (exprType body) [(DataAlt boxing_con, unpk_args, body)]
564
  where
565
  (cast_arg, bndr_ty) = go (idType bndr) arg
566
  go ty arg 
567
    | (tycon, tycon_args, _, _)  <- splitProductType "mkUnpackCase" ty
568
569
570
    , isNewTyCon tycon && not (isRecursiveTyCon tycon)
    = go (newTyConInstRhs tycon tycon_args) 
         (unwrapNewTypeBody tycon tycon_args arg)
571
    | otherwise = (arg, ty)
572
573
574
575
576
577
578
579
580

-- ...and the dual
reboxProduct :: [Unique]     -- uniques to create new local binders
             -> Type         -- type of product to box
             -> ([Unique],   -- remaining uniques
                 CoreExpr,   -- boxed product
                 [Id])       -- Ids being boxed into product
reboxProduct us ty
  = let 
Ian Lynagh's avatar
Ian Lynagh committed
581
        (_tycon, _tycon_args, _pack_con, con_arg_tys) = deepSplitProductType "reboxProduct" ty
582
583
584
 
        us' = dropList con_arg_tys us

Ian Lynagh's avatar
Ian Lynagh committed
585
        arg_ids  = zipWith (mkSysLocal (fsLit "rb")) us con_arg_tys
586
587
588
589
590
591
592
593
594
595

        bind_rhs = mkProductBox arg_ids ty

    in
      (us', bind_rhs, arg_ids)

mkProductBox :: [Id] -> Type -> CoreExpr
mkProductBox arg_ids ty 
  = result_expr
  where 
596
    (tycon, tycon_args, pack_con, _con_arg_tys) = splitProductType "mkProductBox" ty
597
598

    result_expr
599
      | isNewTyCon tycon && not (isRecursiveTyCon tycon) 
600
      = wrap (mkProductBox arg_ids (newTyConInstRhs tycon tycon_args))
601
      | otherwise = mkConApp pack_con (map Type tycon_args ++ varsToCoreExprs arg_ids)
602
603

    wrap expr = wrapNewTypeBody tycon tycon_args expr
604
605


606
-- (mkReboxingAlt us con xs rhs) basically constructs the case
Ian Lynagh's avatar
Ian Lynagh committed
607
-- alternative (con, xs, rhs)
608
609
610
-- but it does the reboxing necessary to construct the *source* 
-- arguments, xs, from the representation arguments ys.
-- For example:
Ian Lynagh's avatar
Ian Lynagh committed
611
--      data T = MkT !(Int,Int) Bool
612
613
--
-- mkReboxingAlt MkT [x,b] r 
Ian Lynagh's avatar
Ian Lynagh committed
614
--      = (DataAlt MkT, [y::Int,z::Int,b], let x = (y,z) in r)
615
--
616
617
-- mkDataAlt should really be in DataCon, but it can't because
-- it manipulates CoreSyn.
618

619
mkReboxingAlt
Ian Lynagh's avatar
Ian Lynagh committed
620
  :: [Unique] -- Uniques for the new Ids
621
  -> DataCon
622
  -> [Var]    -- Source-level args, *including* all evidence vars 
Ian Lynagh's avatar
Ian Lynagh committed
623
  -> CoreExpr -- RHS
624
  -> CoreAlt
625

626
627
628
mkReboxingAlt us con args rhs
  | not (any isMarkedUnboxed stricts)
  = (DataAlt con, args, rhs)
629

630
  | otherwise
631
  = let
Ian Lynagh's avatar
Ian Lynagh committed
632
        (binds, args') = go args stricts us
633
    in
634
    (DataAlt con, args', mkLets binds rhs)
635

636
  where
637
    stricts = dataConExStricts con ++ dataConStrictMarks con
638

639
    go [] _stricts _us = ([], [])
640

Ian Lynagh's avatar
Ian Lynagh committed
641
    -- Type variable case
642
    go (arg:args) stricts us 
643
      | isTyVar arg
644
      = let (binds, args') = go args stricts us
Ian Lynagh's avatar
Ian Lynagh committed
645
        in  (binds, arg:args')
646

Ian Lynagh's avatar
Ian Lynagh committed
647
        -- Term variable case
648
649
    go (arg:args) (str:stricts) us
      | isMarkedUnboxed str
650
      = let (binds, unpacked_args')        = go args stricts us'
651
652
653
            (us', bind_rhs, unpacked_args) = reboxProduct us (idType arg)
        in
            (NonRec arg bind_rhs : binds, unpacked_args ++ unpacked_args')
654
655
656
      | otherwise
      = let (binds, args') = go args stricts us
        in  (binds, arg:args')
657
    go (_ : _) [] _ = panic "mkReboxingAlt"
658
659
660
\end{code}


661
%************************************************************************
Ian Lynagh's avatar
Ian Lynagh committed
662
663
664
%*                                                                      *
        Wrapping and unwrapping newtypes and type families
%*                                                                      *
665
666
667
%************************************************************************

\begin{code}
668
669
wrapNewTypeBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr
-- The wrapper for the data constructor for a newtype looks like this:
Ian Lynagh's avatar
Ian Lynagh committed
670
671
672
--      newtype T a = MkT (a,Int)
--      MkT :: forall a. (a,Int) -> T a
--      MkT = /\a. \(x:(a,Int)). x `cast` sym (CoT a)
673
674
675
676
-- where CoT is the coercion TyCon assoicated with the newtype
--
-- The call (wrapNewTypeBody T [a] e) returns the
-- body of the wrapper, namely
Ian Lynagh's avatar
Ian Lynagh committed
677
--      e `cast` (CoT [a])
678
--
679
-- If a coercion constructor is provided in the newtype, then we use
680
-- it, otherwise the wrap/unwrap are both no-ops 
681
--
682
-- If the we are dealing with a newtype *instance*, we have a second coercion
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
683
684
685
-- identifying the family instance with the constructor of the newtype
-- instance.  This coercion is applied in any case (ie, composed with the
-- coercion constructor of the newtype or applied by itself).
686

687
wrapNewTypeBody tycon args result_expr
688
689
  = ASSERT( isNewTyCon tycon )
    wrapFamInstBody tycon args $
690
    mkCast result_expr (mkSymCo co)
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
691
  where
692
    co = mkAxInstCo (newTyConCo tycon) args
693

chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
694
695
696
697
-- When unwrapping, we do *not* apply any family coercion, because this will
-- be done via a CoPat by the type checker.  We have to do it this way as
-- computing the right type arguments for the coercion requires more than just
-- a spliting operation (cf, TcPat.tcConPat).
698

699
700
unwrapNewTypeBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr
unwrapNewTypeBody tycon args result_expr
701
  = ASSERT( isNewTyCon tycon )
702
    mkCast result_expr (mkAxInstCo (newTyConCo tycon) args)
703

704
705
706
707
708
709
710
711
-- If the type constructor is a representation type of a data instance, wrap
-- the expression into a cast adjusting the expression type, which is an
-- instance of the representation type, to the corresponding instance of the
-- family instance type.
-- See Note [Wrappers for data instance tycons]
wrapFamInstBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr
wrapFamInstBody tycon args body
  | Just co_con <- tyConFamilyCoercion_maybe tycon
712
  = mkCast body (mkSymCo (mkAxInstCo co_con args))
713
714
  | otherwise
  = body
715

716
717
718
719
720
721
-- Same as `wrapFamInstBody`, but for type family instances, which are
-- represented by a `CoAxiom`, and not a `TyCon`
wrapTypeFamInstBody :: CoAxiom -> [Type] -> CoreExpr -> CoreExpr
wrapTypeFamInstBody axiom args body
  = mkCast body (mkSymCo (mkAxInstCo axiom args))

722
723
724
unwrapFamInstScrut :: TyCon -> [Type] -> CoreExpr -> CoreExpr
unwrapFamInstScrut tycon args scrut
  | Just co_con <- tyConFamilyCoercion_maybe tycon
725
  = mkCast scrut (mkAxInstCo co_con args)
726
727
  | otherwise
  = scrut
728
729
730
731

unwrapTypeFamInstScrut :: CoAxiom -> [Type] -> CoreExpr -> CoreExpr
unwrapTypeFamInstScrut axiom args scrut
  = mkCast scrut (mkAxInstCo axiom args)
732
733
734
735
\end{code}


%************************************************************************
Ian Lynagh's avatar
Ian Lynagh committed
736
%*                                                                      *
737
\subsection{Primitive operations}
Ian Lynagh's avatar
Ian Lynagh committed
738
%*                                                                      *
739
740
741
%************************************************************************

\begin{code}
742
743
mkPrimOpId :: PrimOp -> Id
mkPrimOpId prim_op 
744
  = id
745
  where
746
    (tyvars,arg_tys,res_ty, arity, strict_sig) = primOpSig prim_op
747
    ty   = mkForAllTys tyvars (mkFunTys arg_tys res_ty)
748
    name = mkWiredInName gHC_PRIM (primOpOcc prim_op) 
Ian Lynagh's avatar
Ian Lynagh committed
749
750
                         (mkPrimOpIdUnique (primOpTag prim_op))
                         (AnId id) UserSyntax
751
    id   = mkGlobalId (PrimOpId prim_op) name ty info
Ian Lynagh's avatar
Ian Lynagh committed
752
                
753
    info = noCafIdInfo
754
           `setSpecInfo`          mkSpecInfo (maybeToList $ primOpRules name prim_op)
Ian Lynagh's avatar
Ian Lynagh committed
755
           `setArityInfo`         arity
756
           `setStrictnessInfo` Just strict_sig
757

758
759
760
761
762
763
764
765
766
-- For each ccall we manufacture a separate CCallOpId, giving it
-- a fresh unique, a type that is correct for this particular ccall,
-- and a CCall structure that gives the correct details about calling
-- convention etc.  
--
-- The *name* of this Id is a local name whose OccName gives the full
-- details of the ccall, type and all.  This means that the interface 
-- file reader can reconstruct a suitable Id

Ian Lynagh's avatar
Ian Lynagh committed
767
768
mkFCallId :: DynFlags -> Unique -> ForeignCall -> Type -> Id
mkFCallId dflags uniq fcall ty
769
  = ASSERT( isEmptyVarSet (tyVarsOfType ty) )
Ian Lynagh's avatar
Ian Lynagh committed
770
771
    -- A CCallOpId should have no free type variables; 
    -- when doing substitutions won't substitute over it
772
    mkGlobalId (FCallId fcall) name ty info
773
  where
Ian Lynagh's avatar
Ian Lynagh committed
774
    occ_str = showSDoc dflags (braces (ppr fcall <+> ppr ty))
Ian Lynagh's avatar
Ian Lynagh committed
775
776
    -- The "occurrence name" of a ccall is the full info about the
    -- ccall; it is encoded, but may have embedded spaces etc!
777

778
    name = mkFCallName uniq occ_str
779

780
    info = noCafIdInfo
Ian Lynagh's avatar
Ian Lynagh committed
781
           `setArityInfo`         arity
782
           `setStrictnessInfo` Just strict_sig
783

Ian Lynagh's avatar
Ian Lynagh committed
784
    (_, tau)     = tcSplitForAllTys ty
785
    (arg_tys, _) = tcSplitFunTys tau
Ian Lynagh's avatar
Ian Lynagh committed
786
    arity        = length arg_tys
787
    strict_sig   = mkStrictSig (mkTopDmdType (replicate arity evalDmd) TopRes)
788
789
\end{code}

790
791

%************************************************************************
Ian Lynagh's avatar
Ian Lynagh committed
792
%*                                                                      *
793
\subsection{DictFuns and default methods}
Ian Lynagh's avatar
Ian Lynagh committed
794
%*                                                                      *
795
796
%************************************************************************

797
798
799
800
801
802
Important notes about dict funs and default methods
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Dict funs and default methods are *not* ImplicitIds.  Their definition
involves user-written code, so we can't figure out their strictness etc
based on fixed info, as we can for constructors and record selectors (say).

803
804
805
We build them as LocalIds, but with External Names.  This ensures that
they are taken to account by free-variable finding and dependency
analysis (e.g. CoreFVs.exprFreeVars).
806
807
808
809
810
811
812
813
814
815
816
817

Why shouldn't they be bound as GlobalIds?  Because, in particular, if
they are globals, the specialiser floats dict uses above their defns,
which prevents good simplifications happening.  Also the strictness
analyser treats a occurrence of a GlobalId as imported and assumes it
contains strictness in its IdInfo, which isn't true if the thing is
bound in the same module as the occurrence.

It's OK for dfuns to be LocalIds, because we form the instance-env to
pass on to the next module (md_insts) in CoreTidy, afer tidying
and globalising the top-level Ids.

818
BUT make sure they are *exported* LocalIds (mkExportedLocalId) so 
819
820
that they aren't discarded by the occurrence analyser.

821
\begin{code}
Ian Lynagh's avatar
Ian Lynagh committed
822
823
824
825
826
827
mkDictFunId :: Name      -- Name to use for the dict fun;
            -> [TyVar]
            -> ThetaType
            -> Class 
            -> [Type]
            -> Id
828
-- Implements the DFun Superclass Invariant (see TcInstDcls)
829

830
mkDictFunId dfun_name tvs theta clas tys
831
  = mkExportedLocalVar (DFunId n_silent is_nt)
832
833
834
                       dfun_name
                       dfun_ty
                       vanillaIdInfo
835
  where
836
    is_nt = isNewTyCon (classTyCon clas)
837
    (n_silent, dfun_ty) = mkDictFunTy tvs theta clas tys
838

839
mkDictFunTy :: [TyVar] -> ThetaType -> Class -> [Type] -> (Int, Type)
840
mkDictFunTy tvs theta clas tys
841
842
843
844
845
846
847
848
849
850
851
852
853
  = (length silent_theta, dfun_ty)
  where
    dfun_ty = mkSigmaTy tvs (silent_theta ++ theta) (mkClassPred clas tys)
    silent_theta 
      | null tvs, null theta 
      = []
      | otherwise
      = filterOut discard $
        substTheta (zipTopTvSubst (classTyVars clas) tys)
                   (classSCTheta clas)
                   -- See Note [Silent Superclass Arguments]
    discard pred = any (`eqPred` pred) theta
                 -- See the DFun Superclass Invariant in TcInstDcls
854
\end{code}
855
856
857


%************************************************************************
Ian Lynagh's avatar
Ian Lynagh committed
858
%*                                                                      *
859
\subsection{Un-definable}
Ian Lynagh's avatar
Ian Lynagh committed
860
%*                                                                      *
861
862
%************************************************************************

863
864
865
866
867
868
These Ids can't be defined in Haskell.  They could be defined in
unfoldings in the wired-in GHC.Prim interface file, but we'd have to
ensure that they were definitely, definitely inlined, because there is
no curried identifier for them.  That's what mkCompulsoryUnfolding
does.  If we had a way to get a compulsory unfolding from an interface
file, we could do that, but we don't right now.
869
870
871
872
873
874
875
876
877

unsafeCoerce# isn't so much a PrimOp as a phantom identifier, that
just gets expanded into a type coercion wherever it occurs.  Hence we
add it as a built-in Id with an unfolding here.

The type variables we use here are "open" type variables: this means
they can unify with both unlifted and lifted types.  Hence we provide
another gun with which to shoot yourself in the foot.

878
\begin{code}
879
880
881
882
883
884
885
lazyIdName, unsafeCoerceName, nullAddrName, seqName, realWorldName, coercionTokenName :: Name
unsafeCoerceName  = mkWiredInIdName gHC_PRIM (fsLit "unsafeCoerce#") unsafeCoerceIdKey  unsafeCoerceId
nullAddrName      = mkWiredInIdName gHC_PRIM (fsLit "nullAddr#")     nullAddrIdKey      nullAddrId
seqName           = mkWiredInIdName gHC_PRIM (fsLit "seq")           seqIdKey           seqId
realWorldName     = mkWiredInIdName gHC_PRIM (fsLit "realWorld#")    realWorldPrimIdKey realWorldPrimId
lazyIdName        = mkWiredInIdName gHC_BASE (fsLit "lazy")         lazyIdKey           lazyId
coercionTokenName = mkWiredInIdName gHC_PRIM (fsLit "coercionToken#") coercionTokenIdKey coercionTokenId
886
887
\end{code}

888
\begin{code}
889
------------------------------------------------
890
-- unsafeCoerce# :: forall a b. a -> b
891
unsafeCoerceId :: Id
892
unsafeCoerceId
893
  = pcMiscPrelId unsafeCoerceName ty info
894
  where
895
896
    info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma
                       `setUnfoldingInfo`  mkCompulsoryUnfolding rhs
Ian Lynagh's avatar
Ian Lynagh committed
897
           
898

899
900
901
902
903
    ty  = mkForAllTys [openAlphaTyVar,openBetaTyVar]
                      (mkFunTy openAlphaTy openBetaTy)
    [x] = mkTemplateLocals [openAlphaTy]
    rhs = mkLams [openAlphaTyVar,openBetaTyVar,x] $
          Cast (Var x) (mkUnsafeCo openAlphaTy openBetaTy)
904

905
906
------------------------------------------------
nullAddrId :: Id
907
908
909
-- nullAddr# :: Addr#
-- The reason is is here is because we don't provide 
-- a way to write this literal in Haskell.
910
nullAddrId = pcMiscPrelId nullAddrName addrPrimTy info
911
  where
912
913
    info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma
                       `setUnfoldingInfo`  mkCompulsoryUnfolding (Lit nullAddrLit)
914

915
------------------------------------------------
916
seqId :: Id	-- See Note [seqId magic]
917
seqId = pcMiscPrelId seqName ty info
918
  where
919
920
921
    info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma
                       `setUnfoldingInfo`  mkCompulsoryUnfolding rhs
                       `setSpecInfo`       mkSpecInfo [seq_cast_rule]
Ian Lynagh's avatar
Ian Lynagh committed
922
           
923

924
925
926
927
928
929
    ty  = mkForAllTys [alphaTyVar,betaTyVar]
                      (mkFunTy alphaTy (mkFunTy betaTy betaTy))
              -- NB argBetaTyVar; see Note [seqId magic]

    [x,y] = mkTemplateLocals [alphaTy, betaTy]
    rhs = mkLams [alphaTyVar,betaTyVar,x,y] (Case (Var x) x betaTy [(DEFAULT, [], Var y)])
930

931
    -- See Note [Built-in RULES for seq]
932
933
934
935
936
937
    seq_cast_rule = BuiltinRule { ru_name  = fsLit "seq of cast"
                                , ru_fn    = seqName
                                , ru_nargs = 4
                                , ru_try   = match_seq_of_cast
                                }

938
match_seq_of_cast :: Id -> IdUnfoldingFun -> [CoreExpr] -> Maybe CoreExpr
939
    -- See Note [Built-in RULES for seq]
940
match_seq_of_cast _ _ [Type _, Type res_ty, Cast scrut co, expr]
941
  = Just (Var seqId `mkApps` [Type (pFst (coercionKind co)), Type res_ty,
942
                              scrut, expr])
943
match_seq_of_cast _ _ _ = Nothing
944

945
------------------------------------------------
946
lazyId :: Id	-- See Note [lazyId magic]
947
lazyId = pcMiscPrelId lazyIdName ty info
948
949
950
  where
    info = noCafIdInfo
    ty  = mkForAllTys [alphaTyVar] (mkFunTy alphaTy alphaTy)
951
\end{code}
952

953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
Note [Unsafe coerce magic]
~~~~~~~~~~~~~~~~~~~~~~~~~~
We define a *primitive*
   GHC.Prim.unsafeCoerce#
and then in the base library we define the ordinary function
   Unsafe.Coerce.unsafeCoerce :: forall (a:*) (b:*). a -> b
   unsafeCoerce x = unsafeCoerce# x

Notice that unsafeCoerce has a civilized (albeit still dangerous)
polymorphic type, whose type args have kind *.  So you can't use it on
unboxed values (unsafeCoerce 3#).

In contrast unsafeCoerce# is even more dangerous because you *can* use
it on unboxed things, (unsafeCoerce# 3#) :: Int. Its type is
   forall (a:OpenKind) (b:OpenKind). a -> b

969
970
Note [seqId magic]
~~~~~~~~~~~~~~~~~~
971
'GHC.Prim.seq' is special in several ways. 
972
973
974

a) Its second arg can have an unboxed type
      x `seq` (v +# w)
975
   Hence its second type variable has ArgKind
976
977
978
979
980
981

b) Its fixity is set in LoadIface.ghcPrimIface

c) It has quite a bit of desugaring magic. 
   See DsUtils.lhs Note [Desugaring seq (1)] and (2) and (3)

982
d) There is some special rule handing: Note [User-defined RULES for seq]
983

984
985
e) See Note [Typing rule for seq] in TcExpr.

986
987
Note [User-defined RULES for seq]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
988
989
990
991
992
993
994
995
996
997
998
999
1000
Roman found situations where he had
      case (f n) of _ -> e
where he knew that f (which was strict in n) would terminate if n did.
Notice that the result of (f n) is discarded. So it makes sense to
transform to
      case n of _ -> e

Rather than attempt some general analysis to support this, I've added
enough support that you can do this using a rewrite rule:

  RULE "f/seq" forall n.  seq (f n) e = seq n e

You write that rule.  When GHC sees a case expression that discards
For faster browsing, not all history is shown. View entire blame