Remove NOINLINE strictness hack
[ghc.git] / compiler / basicTypes / MkId.lhs
1 %
2 % (c) The AQUA Project, Glasgow University, 1998
3 %
4 \section[StdIdInfo]{Standard unfoldings}
5
6 This module contains definitions for the IdInfo for things that
7 have a standard form, namely:
8
9         * data constructors
10         * record selectors
11         * method and superclass selectors
12         * primitive operations
13
14 \begin{code}
15 module MkId (
16         mkDictFunId, mkDefaultMethodId,
17         mkDictSelId, 
18
19         mkDataConIds,
20         mkRecordSelId, 
21         mkPrimOpId, mkFCallId,
22
23         mkReboxingAlt, mkNewTypeBody,
24
25         -- And some particular Ids; see below for why they are wired in
26         wiredInIds, ghcPrimIds,
27         unsafeCoerceId, realWorldPrimId, voidArgId, nullAddrId, seqId,
28         lazyId, lazyIdUnfolding, lazyIdKey,
29
30         mkRuntimeErrorApp,
31         rEC_CON_ERROR_ID, iRREFUT_PAT_ERROR_ID, rUNTIME_ERROR_ID,
32         nON_EXHAUSTIVE_GUARDS_ERROR_ID, nO_METHOD_BINDING_ERROR_ID,
33         pAT_ERROR_ID, eRROR_ID,
34
35         unsafeCoerceName
36     ) where
37
38 #include "HsVersions.h"
39
40
41 import BasicTypes       ( Arity, StrictnessMark(..), isMarkedUnboxed, isMarkedStrict )
42 import Rules            ( mkSpecInfo )
43 import TysPrim          ( openAlphaTyVars, alphaTyVar, alphaTy, 
44                           realWorldStatePrimTy, addrPrimTy
45                         )
46 import TysWiredIn       ( charTy, mkListTy )
47 import PrelRules        ( primOpRules )
48 import Type             ( TyThing(..), mkForAllTy, tyVarsOfTypes )
49 import TcType           ( Type, ThetaType, mkDictTy, mkPredTys, mkPredTy, 
50                           mkTyConApp, mkTyVarTys, mkClassPred, 
51                           mkFunTys, mkFunTy, mkSigmaTy, tcSplitSigmaTy, 
52                           isUnLiftedType, mkForAllTys, mkTyVarTy, tyVarsOfType,
53                           tcSplitFunTys, tcSplitForAllTys, dataConsStupidTheta
54                         )
55 import CoreUtils        ( exprType )
56 import CoreUnfold       ( mkTopUnfolding, mkCompulsoryUnfolding )
57 import Literal          ( nullAddrLit, mkStringLit )
58 import TyCon            ( TyCon, isNewTyCon, tyConDataCons, FieldLabel,
59                           tyConStupidTheta, isProductTyCon, isDataTyCon, isRecursiveTyCon )
60 import Class            ( Class, classTyCon, classSelIds )
61 import Var              ( Id, TyVar, Var )
62 import VarSet           ( isEmptyVarSet, subVarSet, varSetElems )
63 import Name             ( mkFCallName, mkWiredInName, Name, BuiltInSyntax(..) )
64 import OccName          ( mkOccNameFS, varName )
65 import PrimOp           ( PrimOp, primOpSig, primOpOcc, primOpTag )
66 import ForeignCall      ( ForeignCall )
67 import DataCon          ( DataCon, DataConIds(..), dataConTyVars,
68                           dataConFieldLabels, dataConRepArity, dataConResTys,
69                           dataConRepArgTys, dataConRepType, 
70                           dataConSig, dataConStrictMarks, dataConExStricts, 
71                           splitProductType, isVanillaDataCon, dataConFieldType,
72                           dataConInstOrigArgTys
73                         )
74 import Id               ( idType, mkGlobalId, mkVanillaGlobal, mkSysLocal, 
75                           mkTemplateLocals, mkTemplateLocalsNum, mkExportedLocalId,
76                           mkTemplateLocal, idName
77                         )
78 import IdInfo           ( IdInfo, noCafIdInfo,  setUnfoldingInfo, 
79                           setArityInfo, setSpecInfo, setCafInfo,
80                           setAllStrictnessInfo, vanillaIdInfo,
81                           GlobalIdDetails(..), CafInfo(..)
82                         )
83 import NewDemand        ( mkStrictSig, DmdResult(..),
84                           mkTopDmdType, topDmd, evalDmd, lazyDmd, retCPR,
85                           Demand(..), Demands(..) )
86 import DmdAnal          ( dmdAnalTopRhs )
87 import CoreSyn
88 import Unique           ( mkBuiltinUnique, mkPrimOpIdUnique )
89 import Maybes
90 import PrelNames
91 import Util             ( dropList, isSingleton )
92 import Outputable
93 import FastString
94 import ListSetOps       ( assoc )
95 \end{code}              
96
97 %************************************************************************
98 %*                                                                      *
99 \subsection{Wired in Ids}
100 %*                                                                      *
101 %************************************************************************
102
103 \begin{code}
104 wiredInIds
105   = [   -- These error-y things are wired in because we don't yet have
106         -- a way to express in an interface file that the result type variable
107         -- is 'open'; that is can be unified with an unboxed type
108         -- 
109         -- [The interface file format now carry such information, but there's
110         -- no way yet of expressing at the definition site for these 
111         -- error-reporting functions that they have an 'open' 
112         -- result type. -- sof 1/99]
113
114     eRROR_ID,   -- This one isn't used anywhere else in the compiler
115                 -- But we still need it in wiredInIds so that when GHC
116                 -- compiles a program that mentions 'error' we don't
117                 -- import its type from the interface file; we just get
118                 -- the Id defined here.  Which has an 'open-tyvar' type.
119
120     rUNTIME_ERROR_ID,
121     iRREFUT_PAT_ERROR_ID,
122     nON_EXHAUSTIVE_GUARDS_ERROR_ID,
123     nO_METHOD_BINDING_ERROR_ID,
124     pAT_ERROR_ID,
125     rEC_CON_ERROR_ID,
126
127     lazyId
128     ] ++ ghcPrimIds
129
130 -- These Ids are exported from GHC.Prim
131 ghcPrimIds
132   = [   -- These can't be defined in Haskell, but they have
133         -- perfectly reasonable unfoldings in Core
134     realWorldPrimId,
135     unsafeCoerceId,
136     nullAddrId,
137     seqId
138     ]
139 \end{code}
140
141 %************************************************************************
142 %*                                                                      *
143 \subsection{Data constructors}
144 %*                                                                      *
145 %************************************************************************
146
147 The wrapper for a constructor is an ordinary top-level binding that evaluates
148 any strict args, unboxes any args that are going to be flattened, and calls
149 the worker.
150
151 We're going to build a constructor that looks like:
152
153         data (Data a, C b) =>  T a b = T1 !a !Int b
154
155         T1 = /\ a b -> 
156              \d1::Data a, d2::C b ->
157              \p q r -> case p of { p ->
158                        case q of { q ->
159                        Con T1 [a,b] [p,q,r]}}
160
161 Notice that
162
163 * d2 is thrown away --- a context in a data decl is used to make sure
164   one *could* construct dictionaries at the site the constructor
165   is used, but the dictionary isn't actually used.
166
167 * We have to check that we can construct Data dictionaries for
168   the types a and Int.  Once we've done that we can throw d1 away too.
169
170 * We use (case p of q -> ...) to evaluate p, rather than "seq" because
171   all that matters is that the arguments are evaluated.  "seq" is 
172   very careful to preserve evaluation order, which we don't need
173   to be here.
174
175   You might think that we could simply give constructors some strictness
176   info, like PrimOps, and let CoreToStg do the let-to-case transformation.
177   But we don't do that because in the case of primops and functions strictness
178   is a *property* not a *requirement*.  In the case of constructors we need to
179   do something active to evaluate the argument.
180
181   Making an explicit case expression allows the simplifier to eliminate
182   it in the (common) case where the constructor arg is already evaluated.
183
184
185 \begin{code}
186 mkDataConIds :: Name -> Name -> DataCon -> DataConIds
187         -- Makes the *worker* for the data constructor; that is, the function
188         -- that takes the reprsentation arguments and builds the constructor.
189 mkDataConIds wrap_name wkr_name data_con
190   | isNewTyCon tycon
191   = NewDC nt_wrap_id
192
193   | any isMarkedStrict all_strict_marks         -- Algebraic, needs wrapper
194   = AlgDC (Just alg_wrap_id) wrk_id
195
196   | otherwise                                   -- Algebraic, no wrapper
197   = AlgDC Nothing wrk_id
198   where
199     (tyvars, theta, orig_arg_tys, tycon, res_tys) = dataConSig data_con
200
201     dict_tys    = mkPredTys theta
202     all_arg_tys = dict_tys ++ orig_arg_tys
203     result_ty   = mkTyConApp tycon res_tys
204
205     wrap_ty = mkForAllTys tyvars (mkFunTys all_arg_tys result_ty)
206         -- We used to include the stupid theta in the wrapper's args
207         -- but now we don't.  Instead the type checker just injects these
208         -- extra constraints where necessary.
209
210         ----------- Worker (algebraic data types only) --------------
211     wrk_id = mkGlobalId (DataConWorkId data_con) wkr_name
212                         (dataConRepType data_con) wkr_info
213
214     wkr_arity = dataConRepArity data_con
215     wkr_info  = noCafIdInfo
216                 `setArityInfo`          wkr_arity
217                 `setAllStrictnessInfo`  Just wkr_sig
218                 `setUnfoldingInfo`      evaldUnfolding  -- Record that it's evaluated,
219                                                         -- even if arity = 0
220
221     wkr_sig = mkStrictSig (mkTopDmdType (replicate wkr_arity topDmd) cpr_info)
222         -- Notice that we do *not* say the worker is strict
223         -- even if the data constructor is declared strict
224         --      e.g.    data T = MkT !(Int,Int)
225         -- Why?  Because the *wrapper* is strict (and its unfolding has case
226         -- expresssions that do the evals) but the *worker* itself is not.
227         -- If we pretend it is strict then when we see
228         --      case x of y -> $wMkT y
229         -- the simplifier thinks that y is "sure to be evaluated" (because
230         --  $wMkT is strict) and drops the case.  No, $wMkT is not strict.
231         --
232         -- When the simplifer sees a pattern 
233         --      case e of MkT x -> ...
234         -- it uses the dataConRepStrictness of MkT to mark x as evaluated;
235         -- but that's fine... dataConRepStrictness comes from the data con
236         -- not from the worker Id.
237
238     cpr_info | isProductTyCon tycon && 
239                isDataTyCon tycon    &&
240                wkr_arity > 0        &&
241                wkr_arity <= mAX_CPR_SIZE        = retCPR
242              | otherwise                        = TopRes
243         -- RetCPR is only true for products that are real data types;
244         -- that is, not unboxed tuples or [non-recursive] newtypes
245
246         ----------- Wrappers for newtypes --------------
247     nt_wrap_id   = mkGlobalId (DataConWrapId data_con) wrap_name wrap_ty nt_wrap_info
248     nt_wrap_info = noCafIdInfo          -- The NoCaf-ness is set by noCafIdInfo
249                   `setArityInfo` 1      -- Arity 1
250                   `setUnfoldingInfo`     newtype_unf
251     newtype_unf  = ASSERT( isVanillaDataCon data_con &&
252                            isSingleton orig_arg_tys )
253                    -- No existentials on a newtype, but it can have a context
254                    -- e.g.      newtype Eq a => T a = MkT (...)
255                    mkTopUnfolding $ Note InlineMe $
256                    mkLams tyvars $ Lam id_arg1 $ 
257                    mkNewTypeBody tycon result_ty (Var id_arg1)
258
259     id_arg1 = mkTemplateLocal 1 (head orig_arg_tys)
260
261         ----------- Wrappers for algebraic data types -------------- 
262     alg_wrap_id = mkGlobalId (DataConWrapId data_con) wrap_name wrap_ty alg_wrap_info
263     alg_wrap_info = noCafIdInfo         -- The NoCaf-ness is set by noCafIdInfo
264                     `setArityInfo`         alg_arity
265                         -- It's important to specify the arity, so that partial
266                         -- applications are treated as values
267                     `setUnfoldingInfo`     alg_unf
268                     `setAllStrictnessInfo` Just wrap_sig
269
270     all_strict_marks = dataConExStricts data_con ++ dataConStrictMarks data_con
271     wrap_sig = mkStrictSig (mkTopDmdType arg_dmds cpr_info)
272     arg_dmds = map mk_dmd all_strict_marks
273     mk_dmd str | isMarkedStrict str = evalDmd
274                | otherwise          = lazyDmd
275         -- The Cpr info can be important inside INLINE rhss, where the
276         -- wrapper constructor isn't inlined.
277         -- And the argument strictness can be important too; we
278         -- may not inline a contructor when it is partially applied.
279         -- For example:
280         --      data W = C !Int !Int !Int
281         --      ...(let w = C x in ...(w p q)...)...
282         -- we want to see that w is strict in its two arguments
283
284     alg_unf = mkTopUnfolding $ Note InlineMe $
285               mkLams tyvars $ 
286               mkLams dict_args $ mkLams id_args $
287               foldr mk_case con_app 
288                     (zip (dict_args ++ id_args) all_strict_marks)
289                     i3 []
290
291     con_app i rep_ids = mkApps (Var wrk_id)
292                                (map varToCoreExpr (tyvars ++ reverse rep_ids))
293
294     (dict_args,i2) = mkLocals 1  dict_tys
295     (id_args,i3)   = mkLocals i2 orig_arg_tys
296     alg_arity      = i3-1
297
298     mk_case 
299            :: (Id, StrictnessMark)      -- Arg, strictness
300            -> (Int -> [Id] -> CoreExpr) -- Body
301            -> Int                       -- Next rep arg id
302            -> [Id]                      -- Rep args so far, reversed
303            -> CoreExpr
304     mk_case (arg,strict) body i rep_args
305           = case strict of
306                 NotMarkedStrict -> body i (arg:rep_args)
307                 MarkedStrict 
308                    | isUnLiftedType (idType arg) -> body i (arg:rep_args)
309                    | otherwise ->
310                         Case (Var arg) arg result_ty [(DEFAULT,[], body i (arg:rep_args))]
311
312                 MarkedUnboxed
313                    -> case splitProductType "do_unbox" (idType arg) of
314                            (tycon, tycon_args, con, tys) ->
315                                    Case (Var arg) arg result_ty  
316                                         [(DataAlt con, 
317                                           con_args,
318                                           body i' (reverse con_args ++ rep_args))]
319                               where 
320                                 (con_args, i') = mkLocals i tys
321
322 mAX_CPR_SIZE :: Arity
323 mAX_CPR_SIZE = 10
324 -- We do not treat very big tuples as CPR-ish:
325 --      a) for a start we get into trouble because there aren't 
326 --         "enough" unboxed tuple types (a tiresome restriction, 
327 --         but hard to fix), 
328 --      b) more importantly, big unboxed tuples get returned mainly
329 --         on the stack, and are often then allocated in the heap
330 --         by the caller.  So doing CPR for them may in fact make
331 --         things worse.
332
333 mkLocals i tys = (zipWith mkTemplateLocal [i..i+n-1] tys, i+n)
334                where
335                  n = length tys
336 \end{code}
337
338
339 %************************************************************************
340 %*                                                                      *
341 \subsection{Record selectors}
342 %*                                                                      *
343 %************************************************************************
344
345 We're going to build a record selector unfolding that looks like this:
346
347         data T a b c = T1 { ..., op :: a, ...}
348                      | T2 { ..., op :: a, ...}
349                      | T3
350
351         sel = /\ a b c -> \ d -> case d of
352                                     T1 ... x ... -> x
353                                     T2 ... x ... -> x
354                                     other        -> error "..."
355
356 Similarly for newtypes
357
358         newtype N a = MkN { unN :: a->a }
359
360         unN :: N a -> a -> a
361         unN n = coerce (a->a) n
362         
363 We need to take a little care if the field has a polymorphic type:
364
365         data R = R { f :: forall a. a->a }
366
367 Then we want
368
369         f :: forall a. R -> a -> a
370         f = /\ a \ r = case r of
371                           R f -> f a
372
373 (not f :: R -> forall a. a->a, which gives the type inference mechanism 
374 problems at call sites)
375
376 Similarly for (recursive) newtypes
377
378         newtype N = MkN { unN :: forall a. a->a }
379
380         unN :: forall b. N -> b -> b
381         unN = /\b -> \n:N -> (coerce (forall a. a->a) n)
382
383
384 Note [Naughty record selectors]
385 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
386 A "naughty" field is one for which we can't define a record 
387 selector, because an existential type variable would escape.  For example:
388         data T = forall a. MkT { x,y::a }
389 We obviously can't define       
390         x (MkT v _) = v
391 Nevertheless we *do* put a RecordSelId into the type environment
392 so that if the user tries to use 'x' as a selector we can bleat
393 helpfully, rather than saying unhelpfully that 'x' is not in scope.
394 Hence the sel_naughty flag, to identify record selcectors that don't really exist.
395
396 In general, a field is naughty if its type mentions a type variable that
397 isn't in the result type of the constructor.
398
399 For GADTs, we require that all constructors with a common field 'f' have the same
400 result type (modulo alpha conversion).  [Checked in TcTyClsDecls.checkValidTyCon]
401 E.g. 
402         data T where
403           T1 { f :: a } :: T [a]
404           T2 { f :: a, y :: b  } :: T [a]
405 and now the selector takes that type as its argument:
406         f :: forall a. T [a] -> a
407         f t = case t of
408                 T1 { f = v } -> v
409                 T2 { f = v } -> v
410 Note the forall'd tyvars of the selector are just the free tyvars
411 of the result type; there may be other tyvars in the constructor's
412 type (e.g. 'b' in T2).
413
414 \begin{code}
415
416 -- XXX - autrijus -
417 -- Plan: 1. Determine naughtiness by comparing field type vs result type
418 --       2. Install naughty ones with selector_ty of type _|_ and fill in mzero for info
419 --       3. If it's not naughty, do the normal plan.
420
421 mkRecordSelId :: TyCon -> FieldLabel -> Id
422 mkRecordSelId tycon field_label
423         -- Assumes that all fields with the same field label have the same type
424   | is_naughty = naughty_id
425   | otherwise  = sel_id
426   where
427     is_naughty = not (tyVarsOfType field_ty `subVarSet` tyvar_set)
428     sel_id_details = RecordSelId tycon field_label is_naughty
429
430     -- Escapist case here for naughty construcotrs
431     -- We give it no IdInfo, and a type of forall a.a (never looked at)
432     naughty_id = mkGlobalId sel_id_details field_label forall_a_a noCafIdInfo
433     forall_a_a = mkForAllTy alphaTyVar (mkTyVarTy alphaTyVar)
434
435     -- Normal case starts here
436     sel_id = mkGlobalId sel_id_details field_label selector_ty info
437     data_cons         = tyConDataCons tycon     
438     data_cons_w_field = filter has_field data_cons      -- Can't be empty!
439     has_field con     = field_label `elem` dataConFieldLabels con
440
441     con1        = head data_cons_w_field
442     res_tys     = dataConResTys con1
443     tyvar_set   = tyVarsOfTypes res_tys
444     tyvars      = varSetElems tyvar_set
445     data_ty     = mkTyConApp tycon res_tys
446     field_ty    = dataConFieldType con1 field_label
447     
448         -- *Very* tiresomely, the selectors are (unnecessarily!) overloaded over
449         -- just the dictionaries in the types of the constructors that contain
450         -- the relevant field.  [The Report says that pattern matching on a
451         -- constructor gives the same constraints as applying it.]  Urgh.  
452         --
453         -- However, not all data cons have all constraints (because of
454         -- BuildTyCl.mkDataConStupidTheta).  So we need to find all the data cons 
455         -- involved in the pattern match and take the union of their constraints.
456     stupid_dict_tys = mkPredTys (dataConsStupidTheta data_cons_w_field)
457     n_stupid_dicts  = length stupid_dict_tys
458
459     (field_tyvars,field_theta,field_tau) = tcSplitSigmaTy field_ty
460     field_dict_tys                       = mkPredTys field_theta
461     n_field_dict_tys                     = length field_dict_tys
462         -- If the field has a universally quantified type we have to 
463         -- be a bit careful.  Suppose we have
464         --      data R = R { op :: forall a. Foo a => a -> a }
465         -- Then we can't give op the type
466         --      op :: R -> forall a. Foo a => a -> a
467         -- because the typechecker doesn't understand foralls to the
468         -- right of an arrow.  The "right" type to give it is
469         --      op :: forall a. Foo a => R -> a -> a
470         -- But then we must generate the right unfolding too:
471         --      op = /\a -> \dfoo -> \ r ->
472         --           case r of
473         --              R op -> op a dfoo
474         -- Note that this is exactly the type we'd infer from a user defn
475         --      op (R op) = op
476
477     selector_ty :: Type
478     selector_ty  = mkForAllTys tyvars $ mkForAllTys field_tyvars $
479                    mkFunTys stupid_dict_tys  $  mkFunTys field_dict_tys $
480                    mkFunTy data_ty field_tau
481       
482     arity = 1 + n_stupid_dicts + n_field_dict_tys
483
484     (strict_sig, rhs_w_str) = dmdAnalTopRhs sel_rhs
485         -- Use the demand analyser to work out strictness.
486         -- With all this unpackery it's not easy!
487
488     info = noCafIdInfo
489            `setCafInfo`           caf_info
490            `setArityInfo`         arity
491            `setUnfoldingInfo`     mkTopUnfolding rhs_w_str
492            `setAllStrictnessInfo` Just strict_sig
493
494         -- Allocate Ids.  We do it a funny way round because field_dict_tys is
495         -- almost always empty.  Also note that we use max_dict_tys
496         -- rather than n_dict_tys, because the latter gives an infinite loop:
497         -- n_dict tys depends on the_alts, which depens on arg_ids, which depends
498         -- on arity, which depends on n_dict tys.  Sigh!  Mega sigh!
499     stupid_dict_ids  = mkTemplateLocalsNum 1 stupid_dict_tys
500     max_stupid_dicts = length (tyConStupidTheta tycon)
501     field_dict_base  = max_stupid_dicts + 1
502     field_dict_ids   = mkTemplateLocalsNum field_dict_base field_dict_tys
503     dict_id_base     = field_dict_base + n_field_dict_tys
504     data_id          = mkTemplateLocal dict_id_base data_ty
505     arg_base         = dict_id_base + 1
506
507     the_alts :: [CoreAlt]
508     the_alts   = map mk_alt data_cons_w_field   -- Already sorted by data-con
509     no_default = length data_cons == length data_cons_w_field   -- No default needed
510
511     default_alt | no_default = []
512                 | otherwise  = [(DEFAULT, [], error_expr)]
513
514         -- The default branch may have CAF refs, because it calls recSelError etc.
515     caf_info    | no_default = NoCafRefs
516                 | otherwise  = MayHaveCafRefs
517
518     sel_rhs = mkLams tyvars   $ mkLams field_tyvars $ 
519               mkLams stupid_dict_ids $ mkLams field_dict_ids $
520               Lam data_id     $ sel_body
521
522     sel_body | isNewTyCon tycon = mk_result (mkNewTypeBody tycon field_ty (Var data_id))
523              | otherwise        = Case (Var data_id) data_id field_tau (default_alt ++ the_alts)
524
525     mk_result poly_result = mkVarApps (mkVarApps poly_result field_tyvars) field_dict_ids
526         -- We pull the field lambdas to the top, so we need to 
527         -- apply them in the body.  For example:
528         --      data T = MkT { foo :: forall a. a->a }
529         --
530         --      foo :: forall a. T -> a -> a
531         --      foo = /\a. \t:T. case t of { MkT f -> f a }
532
533     mk_alt data_con 
534       =         -- In the non-vanilla case, the pattern must bind type variables and
535                 -- the context stuff; hence the arg_prefix binding below
536           mkReboxingAlt uniqs data_con (arg_prefix ++ arg_ids)
537                         (mk_result (Var the_arg_id))
538       where
539         (arg_prefix, arg_ids)
540            | isVanillaDataCon data_con          -- Instantiate from commmon base
541            = ([], mkTemplateLocalsNum arg_base (dataConInstOrigArgTys data_con res_tys))
542            | otherwise          -- The case pattern binds type variables, which are used
543                                 -- in the types of the arguments of the pattern
544            = (dc_tyvars ++ mkTemplateLocalsNum arg_base (mkPredTys dc_theta),
545               mkTemplateLocalsNum arg_base' dc_arg_tys)
546
547         (dc_tyvars, dc_theta, dc_arg_tys, _, _) = dataConSig data_con
548         arg_base' = arg_base + length dc_theta
549
550         unpack_base = arg_base' + length dc_arg_tys
551         uniqs = map mkBuiltinUnique [unpack_base..]
552
553         the_arg_id  = assoc "mkRecordSelId:mk_alt" (field_lbls `zip` arg_ids) field_label
554         field_lbls  = dataConFieldLabels data_con
555
556     error_expr = mkRuntimeErrorApp rEC_SEL_ERROR_ID field_tau full_msg
557     full_msg   = showSDoc (sep [text "No match in record selector", ppr sel_id]) 
558
559
560 -- (mkReboxingAlt us con xs rhs) basically constructs the case
561 -- alternative  (con, xs, rhs)
562 -- but it does the reboxing necessary to construct the *source* 
563 -- arguments, xs, from the representation arguments ys.
564 -- For example:
565 --      data T = MkT !(Int,Int) Bool
566 --
567 -- mkReboxingAlt MkT [x,b] r 
568 --      = (DataAlt MkT, [y::Int,z::Int,b], let x = (y,z) in r)
569 --
570 -- mkDataAlt should really be in DataCon, but it can't because
571 -- it manipulates CoreSyn.
572
573 mkReboxingAlt
574   :: [Unique]                   -- Uniques for the new Ids
575   -> DataCon
576   -> [Var]                      -- Source-level args, including existential dicts
577   -> CoreExpr                   -- RHS
578   -> CoreAlt
579
580 mkReboxingAlt us con args rhs
581   | not (any isMarkedUnboxed stricts)
582   = (DataAlt con, args, rhs)
583
584   | otherwise
585   = let
586         (binds, args') = go args stricts us
587     in
588     (DataAlt con, args', mkLets binds rhs)
589
590   where
591     stricts = dataConExStricts con ++ dataConStrictMarks con
592
593     go [] stricts us = ([], [])
594
595         -- Type variable case
596     go (arg:args) stricts us 
597       | isTyVar arg
598       = let (binds, args') = go args stricts us
599         in  (binds, arg:args')
600
601         -- Term variable case
602     go (arg:args) (str:stricts) us
603       | isMarkedUnboxed str
604       = let
605           (_, tycon_args, pack_con, con_arg_tys)
606                  = splitProductType "mkReboxingAlt" (idType arg)
607
608           unpacked_args  = zipWith (mkSysLocal FSLIT("rb")) us con_arg_tys
609           (binds, args') = go args stricts (dropList con_arg_tys us)
610           con_app        = mkConApp pack_con (map Type tycon_args ++ map Var unpacked_args)
611         in
612         (NonRec arg con_app : binds, unpacked_args ++ args')
613
614       | otherwise
615       = let (binds, args') = go args stricts us
616         in  (binds, arg:args')
617 \end{code}
618
619
620 %************************************************************************
621 %*                                                                      *
622 \subsection{Dictionary selectors}
623 %*                                                                      *
624 %************************************************************************
625
626 Selecting a field for a dictionary.  If there is just one field, then
627 there's nothing to do.  
628
629 Dictionary selectors may get nested forall-types.  Thus:
630
631         class Foo a where
632           op :: forall b. Ord b => a -> b -> b
633
634 Then the top-level type for op is
635
636         op :: forall a. Foo a => 
637               forall b. Ord b => 
638               a -> b -> b
639
640 This is unlike ordinary record selectors, which have all the for-alls
641 at the outside.  When dealing with classes it's very convenient to
642 recover the original type signature from the class op selector.
643
644 \begin{code}
645 mkDictSelId :: Name -> Class -> Id
646 mkDictSelId name clas
647   = mkGlobalId (ClassOpId clas) name sel_ty info
648   where
649     sel_ty = mkForAllTys tyvars (mkFunTy (idType dict_id) (idType the_arg_id))
650         -- We can't just say (exprType rhs), because that would give a type
651         --      C a -> C a
652         -- for a single-op class (after all, the selector is the identity)
653         -- But it's type must expose the representation of the dictionary
654         -- to gat (say)         C a -> (a -> a)
655
656     info = noCafIdInfo
657                 `setArityInfo`          1
658                 `setUnfoldingInfo`      mkTopUnfolding rhs
659                 `setAllStrictnessInfo`  Just strict_sig
660
661         -- We no longer use 'must-inline' on record selectors.  They'll
662         -- inline like crazy if they scrutinise a constructor
663
664         -- The strictness signature is of the form U(AAAVAAAA) -> T
665         -- where the V depends on which item we are selecting
666         -- It's worth giving one, so that absence info etc is generated
667         -- even if the selector isn't inlined
668     strict_sig = mkStrictSig (mkTopDmdType [arg_dmd] TopRes)
669     arg_dmd | isNewTyCon tycon = evalDmd
670             | otherwise        = Eval (Prod [ if the_arg_id == id then evalDmd else Abs
671                                             | id <- arg_ids ])
672
673     tycon      = classTyCon clas
674     [data_con] = tyConDataCons tycon
675     tyvars     = dataConTyVars data_con
676     arg_tys    = dataConRepArgTys data_con
677     the_arg_id = assoc "MkId.mkDictSelId" (map idName (classSelIds clas) `zip` arg_ids) name
678
679     pred              = mkClassPred clas (mkTyVarTys tyvars)
680     (dict_id:arg_ids) = mkTemplateLocals (mkPredTy pred : arg_tys)
681
682     rhs | isNewTyCon tycon = mkLams tyvars $ Lam dict_id $ 
683                              mkNewTypeBody tycon (head arg_tys) (Var dict_id)
684         | otherwise        = mkLams tyvars $ Lam dict_id $
685                              Case (Var dict_id) dict_id (idType the_arg_id)
686                                   [(DataAlt data_con, arg_ids, Var the_arg_id)]
687
688 mkNewTypeBody tycon result_ty result_expr
689         -- Adds a coerce where necessary
690         -- Used for both wrapping and unwrapping
691   | isRecursiveTyCon tycon      -- Recursive case; use a coerce
692   = Note (Coerce result_ty (exprType result_expr)) result_expr
693   | otherwise                   -- Normal case
694   = result_expr
695 \end{code}
696
697
698 %************************************************************************
699 %*                                                                      *
700 \subsection{Primitive operations
701 %*                                                                      *
702 %************************************************************************
703
704 \begin{code}
705 mkPrimOpId :: PrimOp -> Id
706 mkPrimOpId prim_op 
707   = id
708   where
709     (tyvars,arg_tys,res_ty, arity, strict_sig) = primOpSig prim_op
710     ty   = mkForAllTys tyvars (mkFunTys arg_tys res_ty)
711     name = mkWiredInName gHC_PRIM (primOpOcc prim_op) 
712                          (mkPrimOpIdUnique (primOpTag prim_op))
713                          Nothing (AnId id) UserSyntax
714     id   = mkGlobalId (PrimOpId prim_op) name ty info
715                 
716     info = noCafIdInfo
717            `setSpecInfo`          mkSpecInfo (primOpRules prim_op name)
718            `setArityInfo`         arity
719            `setAllStrictnessInfo` Just strict_sig
720
721 -- For each ccall we manufacture a separate CCallOpId, giving it
722 -- a fresh unique, a type that is correct for this particular ccall,
723 -- and a CCall structure that gives the correct details about calling
724 -- convention etc.  
725 --
726 -- The *name* of this Id is a local name whose OccName gives the full
727 -- details of the ccall, type and all.  This means that the interface 
728 -- file reader can reconstruct a suitable Id
729
730 mkFCallId :: Unique -> ForeignCall -> Type -> Id
731 mkFCallId uniq fcall ty
732   = ASSERT( isEmptyVarSet (tyVarsOfType ty) )
733         -- A CCallOpId should have no free type variables; 
734         -- when doing substitutions won't substitute over it
735     mkGlobalId (FCallId fcall) name ty info
736   where
737     occ_str = showSDoc (braces (ppr fcall <+> ppr ty))
738         -- The "occurrence name" of a ccall is the full info about the
739         -- ccall; it is encoded, but may have embedded spaces etc!
740
741     name = mkFCallName uniq occ_str
742
743     info = noCafIdInfo
744            `setArityInfo`               arity
745            `setAllStrictnessInfo`       Just strict_sig
746
747     (_, tau)     = tcSplitForAllTys ty
748     (arg_tys, _) = tcSplitFunTys tau
749     arity        = length arg_tys
750     strict_sig   = mkStrictSig (mkTopDmdType (replicate arity evalDmd) TopRes)
751 \end{code}
752
753
754 %************************************************************************
755 %*                                                                      *
756 \subsection{DictFuns and default methods}
757 %*                                                                      *
758 %************************************************************************
759
760 Important notes about dict funs and default methods
761 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
762 Dict funs and default methods are *not* ImplicitIds.  Their definition
763 involves user-written code, so we can't figure out their strictness etc
764 based on fixed info, as we can for constructors and record selectors (say).
765
766 We build them as LocalIds, but with External Names.  This ensures that
767 they are taken to account by free-variable finding and dependency
768 analysis (e.g. CoreFVs.exprFreeVars).
769
770 Why shouldn't they be bound as GlobalIds?  Because, in particular, if
771 they are globals, the specialiser floats dict uses above their defns,
772 which prevents good simplifications happening.  Also the strictness
773 analyser treats a occurrence of a GlobalId as imported and assumes it
774 contains strictness in its IdInfo, which isn't true if the thing is
775 bound in the same module as the occurrence.
776
777 It's OK for dfuns to be LocalIds, because we form the instance-env to
778 pass on to the next module (md_insts) in CoreTidy, afer tidying
779 and globalising the top-level Ids.
780
781 BUT make sure they are *exported* LocalIds (mkExportedLocalId) so 
782 that they aren't discarded by the occurrence analyser.
783
784 \begin{code}
785 mkDefaultMethodId dm_name ty = mkExportedLocalId dm_name ty
786
787 mkDictFunId :: Name             -- Name to use for the dict fun;
788             -> [TyVar]
789             -> ThetaType
790             -> Class 
791             -> [Type]
792             -> Id
793
794 mkDictFunId dfun_name inst_tyvars dfun_theta clas inst_tys
795   = mkExportedLocalId dfun_name dfun_ty
796   where
797     dfun_ty = mkSigmaTy inst_tyvars dfun_theta (mkDictTy clas inst_tys)
798
799 {-  1 dec 99: disable the Mark Jones optimisation for the sake
800     of compatibility with Hugs.
801     See `types/InstEnv' for a discussion related to this.
802
803     (class_tyvars, sc_theta, _, _) = classBigSig clas
804     not_const (clas, tys) = not (isEmptyVarSet (tyVarsOfTypes tys))
805     sc_theta' = substClasses (zipTopTvSubst class_tyvars inst_tys) sc_theta
806     dfun_theta = case inst_decl_theta of
807                    []    -> []  -- If inst_decl_theta is empty, then we don't
808                                 -- want to have any dict arguments, so that we can
809                                 -- expose the constant methods.
810
811                    other -> nub (inst_decl_theta ++ filter not_const sc_theta')
812                                 -- Otherwise we pass the superclass dictionaries to
813                                 -- the dictionary function; the Mark Jones optimisation.
814                                 --
815                                 -- NOTE the "nub".  I got caught by this one:
816                                 --   class Monad m => MonadT t m where ...
817                                 --   instance Monad m => MonadT (EnvT env) m where ...
818                                 -- Here, the inst_decl_theta has (Monad m); but so
819                                 -- does the sc_theta'!
820                                 --
821                                 -- NOTE the "not_const".  I got caught by this one too:
822                                 --   class Foo a => Baz a b where ...
823                                 --   instance Wob b => Baz T b where..
824                                 -- Now sc_theta' has Foo T
825 -}
826 \end{code}
827
828
829 %************************************************************************
830 %*                                                                      *
831 \subsection{Un-definable}
832 %*                                                                      *
833 %************************************************************************
834
835 These Ids can't be defined in Haskell.  They could be defined in
836 unfoldings in the wired-in GHC.Prim interface file, but we'd have to
837 ensure that they were definitely, definitely inlined, because there is
838 no curried identifier for them.  That's what mkCompulsoryUnfolding
839 does.  If we had a way to get a compulsory unfolding from an interface
840 file, we could do that, but we don't right now.
841
842 unsafeCoerce# isn't so much a PrimOp as a phantom identifier, that
843 just gets expanded into a type coercion wherever it occurs.  Hence we
844 add it as a built-in Id with an unfolding here.
845
846 The type variables we use here are "open" type variables: this means
847 they can unify with both unlifted and lifted types.  Hence we provide
848 another gun with which to shoot yourself in the foot.
849
850 \begin{code}
851 mkWiredInIdName mod fs uniq id
852  = mkWiredInName mod (mkOccNameFS varName fs) uniq Nothing (AnId id) UserSyntax
853
854 unsafeCoerceName = mkWiredInIdName gHC_PRIM FSLIT("unsafeCoerce#") unsafeCoerceIdKey  unsafeCoerceId
855 nullAddrName     = mkWiredInIdName gHC_PRIM FSLIT("nullAddr#")     nullAddrIdKey      nullAddrId
856 seqName          = mkWiredInIdName gHC_PRIM FSLIT("seq")           seqIdKey           seqId
857 realWorldName    = mkWiredInIdName gHC_PRIM FSLIT("realWorld#")    realWorldPrimIdKey realWorldPrimId
858 lazyIdName       = mkWiredInIdName pREL_BASE FSLIT("lazy")         lazyIdKey          lazyId
859
860 errorName                = mkWiredInIdName pREL_ERR FSLIT("error")           errorIdKey eRROR_ID
861 recSelErrorName          = mkWiredInIdName pREL_ERR FSLIT("recSelError")     recSelErrorIdKey rEC_SEL_ERROR_ID
862 runtimeErrorName         = mkWiredInIdName pREL_ERR FSLIT("runtimeError")    runtimeErrorIdKey rUNTIME_ERROR_ID
863 irrefutPatErrorName      = mkWiredInIdName pREL_ERR FSLIT("irrefutPatError") irrefutPatErrorIdKey iRREFUT_PAT_ERROR_ID
864 recConErrorName          = mkWiredInIdName pREL_ERR FSLIT("recConError")     recConErrorIdKey rEC_CON_ERROR_ID
865 patErrorName             = mkWiredInIdName pREL_ERR FSLIT("patError")        patErrorIdKey pAT_ERROR_ID
866 noMethodBindingErrorName = mkWiredInIdName pREL_ERR FSLIT("noMethodBindingError")
867                                            noMethodBindingErrorIdKey nO_METHOD_BINDING_ERROR_ID
868 nonExhaustiveGuardsErrorName 
869   = mkWiredInIdName pREL_ERR FSLIT("nonExhaustiveGuardsError") 
870                     nonExhaustiveGuardsErrorIdKey nON_EXHAUSTIVE_GUARDS_ERROR_ID
871 \end{code}
872
873 \begin{code}
874 -- unsafeCoerce# :: forall a b. a -> b
875 unsafeCoerceId
876   = pcMiscPrelId unsafeCoerceName ty info
877   where
878     info = noCafIdInfo `setUnfoldingInfo` mkCompulsoryUnfolding rhs
879            
880
881     ty  = mkForAllTys [openAlphaTyVar,openBetaTyVar]
882                       (mkFunTy openAlphaTy openBetaTy)
883     [x] = mkTemplateLocals [openAlphaTy]
884     rhs = mkLams [openAlphaTyVar,openBetaTyVar,x] $
885           Note (Coerce openBetaTy openAlphaTy) (Var x)
886
887 -- nullAddr# :: Addr#
888 -- The reason is is here is because we don't provide 
889 -- a way to write this literal in Haskell.
890 nullAddrId 
891   = pcMiscPrelId nullAddrName addrPrimTy info
892   where
893     info = noCafIdInfo `setUnfoldingInfo` 
894            mkCompulsoryUnfolding (Lit nullAddrLit)
895
896 seqId
897   = pcMiscPrelId seqName ty info
898   where
899     info = noCafIdInfo `setUnfoldingInfo` mkCompulsoryUnfolding rhs
900            
901
902     ty  = mkForAllTys [alphaTyVar,openBetaTyVar]
903                       (mkFunTy alphaTy (mkFunTy openBetaTy openBetaTy))
904     [x,y] = mkTemplateLocals [alphaTy, openBetaTy]
905     rhs = mkLams [alphaTyVar,openBetaTyVar,x,y] (Case (Var x) x openBetaTy [(DEFAULT, [], Var y)])
906
907 -- lazy :: forall a?. a? -> a?   (i.e. works for unboxed types too)
908 -- Used to lazify pseq:         pseq a b = a `seq` lazy b
909 -- 
910 -- Also, no strictness: by being a built-in Id, all the info about lazyId comes from here,
911 -- not from GHC.Base.hi.   This is important, because the strictness
912 -- analyser will spot it as strict!
913 --
914 -- Also no unfolding in lazyId: it gets "inlined" by a HACK in the worker/wrapper pass
915 --      (see WorkWrap.wwExpr)   
916 -- We could use inline phases to do this, but that would be vulnerable to changes in 
917 -- phase numbering....we must inline precisely after strictness analysis.
918 lazyId
919   = pcMiscPrelId lazyIdName ty info
920   where
921     info = noCafIdInfo
922     ty  = mkForAllTys [alphaTyVar] (mkFunTy alphaTy alphaTy)
923
924 lazyIdUnfolding :: CoreExpr     -- Used to expand 'lazyId' after strictness anal
925 lazyIdUnfolding = mkLams [openAlphaTyVar,x] (Var x)
926                 where
927                   [x] = mkTemplateLocals [openAlphaTy]
928 \end{code}
929
930 @realWorld#@ used to be a magic literal, \tr{void#}.  If things get
931 nasty as-is, change it back to a literal (@Literal@).
932
933 voidArgId is a Local Id used simply as an argument in functions
934 where we just want an arg to avoid having a thunk of unlifted type.
935 E.g.
936         x = \ void :: State# RealWorld -> (# p, q #)
937
938 This comes up in strictness analysis
939
940 \begin{code}
941 realWorldPrimId -- :: State# RealWorld
942   = pcMiscPrelId realWorldName realWorldStatePrimTy
943                  (noCafIdInfo `setUnfoldingInfo` evaldUnfolding)
944         -- The evaldUnfolding makes it look that realWorld# is evaluated
945         -- which in turn makes Simplify.interestingArg return True,
946         -- which in turn makes INLINE things applied to realWorld# likely
947         -- to be inlined
948
949 voidArgId       -- :: State# RealWorld
950   = mkSysLocal FSLIT("void") voidArgIdKey realWorldStatePrimTy
951 \end{code}
952
953
954 %************************************************************************
955 %*                                                                      *
956 \subsection[PrelVals-error-related]{@error@ and friends; @trace@}
957 %*                                                                      *
958 %************************************************************************
959
960 GHC randomly injects these into the code.
961
962 @patError@ is just a version of @error@ for pattern-matching
963 failures.  It knows various ``codes'' which expand to longer
964 strings---this saves space!
965
966 @absentErr@ is a thing we put in for ``absent'' arguments.  They jolly
967 well shouldn't be yanked on, but if one is, then you will get a
968 friendly message from @absentErr@ (rather than a totally random
969 crash).
970
971 @parError@ is a special version of @error@ which the compiler does
972 not know to be a bottoming Id.  It is used in the @_par_@ and @_seq_@
973 templates, but we don't ever expect to generate code for it.
974
975 \begin{code}
976 mkRuntimeErrorApp 
977         :: Id           -- Should be of type (forall a. Addr# -> a)
978                         --      where Addr# points to a UTF8 encoded string
979         -> Type         -- The type to instantiate 'a'
980         -> String       -- The string to print
981         -> CoreExpr
982
983 mkRuntimeErrorApp err_id res_ty err_msg 
984   = mkApps (Var err_id) [Type res_ty, err_string]
985   where
986     err_string = Lit (mkStringLit err_msg)
987
988 rEC_SEL_ERROR_ID                = mkRuntimeErrorId recSelErrorName
989 rUNTIME_ERROR_ID                = mkRuntimeErrorId runtimeErrorName
990 iRREFUT_PAT_ERROR_ID            = mkRuntimeErrorId irrefutPatErrorName
991 rEC_CON_ERROR_ID                = mkRuntimeErrorId recConErrorName
992 pAT_ERROR_ID                    = mkRuntimeErrorId patErrorName
993 nO_METHOD_BINDING_ERROR_ID      = mkRuntimeErrorId noMethodBindingErrorName
994 nON_EXHAUSTIVE_GUARDS_ERROR_ID  = mkRuntimeErrorId nonExhaustiveGuardsErrorName
995
996 -- The runtime error Ids take a UTF8-encoded string as argument
997 mkRuntimeErrorId name = pc_bottoming_Id name runtimeErrorTy
998 runtimeErrorTy        = mkSigmaTy [openAlphaTyVar] [] (mkFunTy addrPrimTy openAlphaTy)
999 \end{code}
1000
1001 \begin{code}
1002 eRROR_ID = pc_bottoming_Id errorName errorTy
1003
1004 errorTy  :: Type
1005 errorTy  = mkSigmaTy [openAlphaTyVar] [] (mkFunTys [mkListTy charTy] openAlphaTy)
1006     -- Notice the openAlphaTyVar.  It says that "error" can be applied
1007     -- to unboxed as well as boxed types.  This is OK because it never
1008     -- returns, so the return type is irrelevant.
1009 \end{code}
1010
1011
1012 %************************************************************************
1013 %*                                                                      *
1014 \subsection{Utilities}
1015 %*                                                                      *
1016 %************************************************************************
1017
1018 \begin{code}
1019 pcMiscPrelId :: Name -> Type -> IdInfo -> Id
1020 pcMiscPrelId name ty info
1021   = mkVanillaGlobal name ty info
1022     -- We lie and say the thing is imported; otherwise, we get into
1023     -- a mess with dependency analysis; e.g., core2stg may heave in
1024     -- random calls to GHCbase.unpackPS__.  If GHCbase is the module
1025     -- being compiled, then it's just a matter of luck if the definition
1026     -- will be in "the right place" to be in scope.
1027
1028 pc_bottoming_Id name ty
1029  = pcMiscPrelId name ty bottoming_info
1030  where
1031     bottoming_info = vanillaIdInfo `setAllStrictnessInfo` Just strict_sig
1032         -- Do *not* mark them as NoCafRefs, because they can indeed have
1033         -- CAF refs.  For example, pAT_ERROR_ID calls GHC.Err.untangle,
1034         -- which has some CAFs
1035         -- In due course we may arrange that these error-y things are
1036         -- regarded by the GC as permanently live, in which case we
1037         -- can give them NoCaf info.  As it is, any function that calls
1038         -- any pc_bottoming_Id will itself have CafRefs, which bloats
1039         -- SRTs.
1040
1041     strict_sig     = mkStrictSig (mkTopDmdType [evalDmd] BotRes)
1042         -- These "bottom" out, no matter what their arguments
1043
1044 (openAlphaTyVar:openBetaTyVar:_) = openAlphaTyVars
1045 openAlphaTy  = mkTyVarTy openAlphaTyVar
1046 openBetaTy   = mkTyVarTy openBetaTyVar
1047 \end{code}
1048