23376f4e907f896e7dcc4bdb38b46d27b535c1e0
[ghc-hetmet.git] / ghc / 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         mkDataConId, mkDataConWrapId,
20         mkRecordSelId, rebuildConArgs,
21         mkPrimOpId, mkCCallOpId,
22
23         -- And some particular Ids; see below for why they are wired in
24         wiredInIds,
25         unsafeCoerceId, realWorldPrimId,
26         eRROR_ID, rEC_SEL_ERROR_ID, pAT_ERROR_ID, rEC_CON_ERROR_ID,
27         rEC_UPD_ERROR_ID, iRREFUT_PAT_ERROR_ID, nON_EXHAUSTIVE_GUARDS_ERROR_ID,
28         nO_METHOD_BINDING_ERROR_ID, aBSENT_ERROR_ID, pAR_ERROR_ID
29     ) where
30
31 #include "HsVersions.h"
32
33
34 import BasicTypes       ( Arity )
35 import TysPrim          ( openAlphaTyVars, alphaTyVar, alphaTy, 
36                           intPrimTy, realWorldStatePrimTy
37                         )
38 import TysWiredIn       ( charTy, mkListTy )
39 import PrelNames        ( pREL_ERR, pREL_GHC )
40 import PrelRules        ( primOpRule )
41 import Rules            ( addRule )
42 import Type             ( Type, ThetaType, mkDictTy, mkPredTys, mkTyConApp,
43                           mkTyVarTys, repType, isNewType,
44                           mkFunTys, mkFunTy, mkSigmaTy, splitSigmaTy, 
45                           isUnLiftedType, mkForAllTys, mkTyVarTy, tyVarsOfType,
46                           splitFunTys, splitForAllTys, mkPredTy
47                         )
48 import Module           ( Module )
49 import CoreUtils        ( exprType, mkInlineMe )
50 import CoreUnfold       ( mkTopUnfolding, mkCompulsoryUnfolding, mkOtherCon )
51 import Literal          ( Literal(..) )
52 import TyCon            ( TyCon, isNewTyCon, tyConTyVars, tyConDataCons,
53                           tyConTheta, isProductTyCon, isDataTyCon )
54 import Class            ( Class, classTyCon, classTyVars, classSelIds )
55 import Var              ( Id, TyVar )
56 import VarSet           ( isEmptyVarSet )
57 import Name             ( mkWiredInName, mkCCallName, Name )
58 import OccName          ( mkVarOcc )
59 import PrimOp           ( PrimOp(DataToTagOp, CCallOp), 
60                           primOpSig, mkPrimOpIdName,
61                           CCall, pprCCallOp
62                         )
63 import Demand           ( wwStrict, wwPrim, mkStrictnessInfo, 
64                           StrictnessMark(..), isMarkedUnboxed, isMarkedStrict )
65 import DataCon          ( DataCon, 
66                           dataConFieldLabels, dataConRepArity, dataConTyCon,
67                           dataConArgTys, dataConRepType, dataConRepStrictness, 
68                           dataConInstOrigArgTys,
69                           dataConName, dataConTheta,
70                           dataConSig, dataConStrictMarks, dataConId,
71                           splitProductType
72                         )
73 import Id               ( idType, mkGlobalId, mkVanillaGlobal, mkSysLocal,
74                           mkTemplateLocals, mkTemplateLocalsNum,
75                           mkTemplateLocal, idCprInfo
76                         )
77 import IdInfo           ( IdInfo, noCafNoTyGenIdInfo,
78                           exactArity, setUnfoldingInfo, setCprInfo,
79                           setArityInfo, setSpecInfo,  setCgInfo,
80                           mkStrictnessInfo, setStrictnessInfo,
81                           GlobalIdDetails(..), CafInfo(..), CprInfo(..), 
82                           CgInfo(..), setCgArity
83                         )
84 import FieldLabel       ( mkFieldLabel, fieldLabelName, 
85                           firstFieldLabelTag, allFieldLabelTags, fieldLabelType
86                         )
87 import CoreSyn
88 import Unique           ( mkBuiltinUnique )
89 import Maybes
90 import PrelNames
91 import Maybe            ( isJust )
92 import Outputable
93 import ListSetOps       ( assoc, assocMaybe )
94 import UnicodeUtil      ( stringToUtf8 )
95 import Char             ( ord )
96 \end{code}              
97
98 %************************************************************************
99 %*                                                                      *
100 \subsection{Wired in Ids}
101 %*                                                                      *
102 %************************************************************************
103
104 \begin{code}
105 wiredInIds
106   = [   -- These error-y things are wired in because we don't yet have
107         -- a way to express in an interface file that the result type variable
108         -- is 'open'; that is can be unified with an unboxed type
109         -- 
110         -- [The interface file format now carry such information, but there's
111         -- no way yet of expressing at the definition site for these 
112         -- error-reporting
113         -- functions that they have an 'open' result type. -- sof 1/99]
114
115       aBSENT_ERROR_ID
116     , eRROR_ID
117     , iRREFUT_PAT_ERROR_ID
118     , nON_EXHAUSTIVE_GUARDS_ERROR_ID
119     , nO_METHOD_BINDING_ERROR_ID
120     , pAR_ERROR_ID
121     , pAT_ERROR_ID
122     , rEC_CON_ERROR_ID
123     , rEC_UPD_ERROR_ID
124
125         -- These three can't be defined in Haskell
126     , realWorldPrimId
127     , unsafeCoerceId
128     , getTagId
129     ]
130 \end{code}
131
132 %************************************************************************
133 %*                                                                      *
134 \subsection{Data constructors}
135 %*                                                                      *
136 %************************************************************************
137
138 \begin{code}
139 mkDataConId :: Name -> DataCon -> Id
140         -- Makes the *worker* for the data constructor; that is, the function
141         -- that takes the reprsentation arguments and builds the constructor.
142 mkDataConId work_name data_con
143   = mkGlobalId (DataConId data_con) work_name (dataConRepType data_con) info
144   where
145     info = noCafNoTyGenIdInfo
146            `setCgArity`         arity
147            `setArityInfo`       exactArity arity
148            `setStrictnessInfo`  strict_info
149            `setCprInfo`         cpr_info
150
151     arity = dataConRepArity data_con
152
153     strict_info = mkStrictnessInfo (dataConRepStrictness data_con, False)
154
155     tycon = dataConTyCon data_con
156     cpr_info | isProductTyCon tycon && 
157                isDataTyCon tycon    &&
158                arity > 0            &&
159                arity <= mAX_CPR_SIZE    = ReturnsCPR
160              | otherwise                = NoCPRInfo
161         -- ReturnsCPR is only true for products that are real data types;
162         -- that is, not unboxed tuples or newtypes
163
164 mAX_CPR_SIZE :: Arity
165 mAX_CPR_SIZE = 10
166 -- We do not treat very big tuples as CPR-ish:
167 --      a) for a start we get into trouble because there aren't 
168 --         "enough" unboxed tuple types (a tiresome restriction, 
169 --         but hard to fix), 
170 --      b) more importantly, big unboxed tuples get returned mainly
171 --         on the stack, and are often then allocated in the heap
172 --         by the caller.  So doing CPR for them may in fact make
173 --         things worse.
174 \end{code}
175
176 The wrapper for a constructor is an ordinary top-level binding that evaluates
177 any strict args, unboxes any args that are going to be flattened, and calls
178 the worker.
179
180 We're going to build a constructor that looks like:
181
182         data (Data a, C b) =>  T a b = T1 !a !Int b
183
184         T1 = /\ a b -> 
185              \d1::Data a, d2::C b ->
186              \p q r -> case p of { p ->
187                        case q of { q ->
188                        Con T1 [a,b] [p,q,r]}}
189
190 Notice that
191
192 * d2 is thrown away --- a context in a data decl is used to make sure
193   one *could* construct dictionaries at the site the constructor
194   is used, but the dictionary isn't actually used.
195
196 * We have to check that we can construct Data dictionaries for
197   the types a and Int.  Once we've done that we can throw d1 away too.
198
199 * We use (case p of q -> ...) to evaluate p, rather than "seq" because
200   all that matters is that the arguments are evaluated.  "seq" is 
201   very careful to preserve evaluation order, which we don't need
202   to be here.
203
204   You might think that we could simply give constructors some strictness
205   info, like PrimOps, and let CoreToStg do the let-to-case transformation.
206   But we don't do that because in the case of primops and functions strictness
207   is a *property* not a *requirement*.  In the case of constructors we need to
208   do something active to evaluate the argument.
209
210   Making an explicit case expression allows the simplifier to eliminate
211   it in the (common) case where the constructor arg is already evaluated.
212
213 \begin{code}
214 mkDataConWrapId data_con
215   = wrap_id
216   where
217     wrap_id = mkGlobalId (DataConWrapId data_con) (dataConName data_con) wrap_ty info
218     work_id = dataConId data_con
219
220     info = noCafNoTyGenIdInfo
221            `setUnfoldingInfo`   mkTopUnfolding (mkInlineMe wrap_rhs)
222            `setCprInfo`         cpr_info
223                 -- The Cpr info can be important inside INLINE rhss, where the
224                 -- wrapper constructor isn't inlined
225            `setCgArity`         arity
226                 -- The NoCaf-ness is set by noCafNoTyGenIdInfo
227            `setArityInfo`       exactArity arity
228                 -- It's important to specify the arity, so that partial
229                 -- applications are treated as values
230
231     wrap_ty = mkForAllTys all_tyvars $
232               mkFunTys all_arg_tys
233               result_ty
234
235     cpr_info = idCprInfo work_id
236
237     wrap_rhs | isNewTyCon tycon
238              = ASSERT( null ex_tyvars && null ex_dict_args && length orig_arg_tys == 1 )
239                 -- No existentials on a newtype, but it can have a context
240                 -- e.g.         newtype Eq a => T a = MkT (...)
241
242                mkLams tyvars $ mkLams dict_args $ Lam id_arg1 $
243                Note (Coerce result_ty (head orig_arg_tys)) (Var id_arg1)
244
245              | null dict_args && not (any isMarkedStrict strict_marks)
246              = Var work_id      -- The common case.  Not only is this efficient,
247                                 -- but it also ensures that the wrapper is replaced
248                                 -- by the worker even when there are no args.
249                                 --              f (:) x
250                                 -- becomes 
251                                 --              f $w: x
252                                 -- This is really important in rule matching,
253                                 -- (We could match on the wrappers,
254                                 -- but that makes it less likely that rules will match
255                                 -- when we bring bits of unfoldings together.)
256                 --
257                 -- NB:  because of this special case, (map (:) ys) turns into
258                 --      (map $w: ys), and thence into (map (\x xs. $w: x xs) ys)
259                 --      in core-to-stg.  The top-level defn for (:) is never used.
260                 --      This is somewhat of a bore, but I'm currently leaving it 
261                 --      as is, so that there still is a top level curried (:) for
262                 --      the interpreter to call.
263
264              | otherwise
265              = mkLams all_tyvars $ mkLams dict_args $ 
266                mkLams ex_dict_args $ mkLams id_args $
267                foldr mk_case con_app 
268                      (zip (ex_dict_args++id_args) strict_marks) i3 []
269
270     con_app i rep_ids = mkApps (Var work_id)
271                                (map varToCoreExpr (all_tyvars ++ reverse rep_ids))
272
273     (tyvars, theta, ex_tyvars, ex_theta, orig_arg_tys, tycon) = dataConSig data_con
274     all_tyvars   = tyvars ++ ex_tyvars
275
276     dict_tys     = mkPredTys theta
277     ex_dict_tys  = mkPredTys ex_theta
278     all_arg_tys  = dict_tys ++ ex_dict_tys ++ orig_arg_tys
279     result_ty    = mkTyConApp tycon (mkTyVarTys tyvars)
280
281     mkLocals i tys = (zipWith mkTemplateLocal [i..i+n-1] tys, i+n)
282                    where
283                      n = length tys
284
285     (dict_args, i1)    = mkLocals 1  dict_tys
286     (ex_dict_args,i2)  = mkLocals i1 ex_dict_tys
287     (id_args,i3)       = mkLocals i2 orig_arg_tys
288     arity              = i3-1
289     (id_arg1:_)   = id_args             -- Used for newtype only
290
291     strict_marks  = dataConStrictMarks data_con
292
293     mk_case 
294            :: (Id, StrictnessMark)      -- Arg, strictness
295            -> (Int -> [Id] -> CoreExpr) -- Body
296            -> Int                       -- Next rep arg id
297            -> [Id]                      -- Rep args so far, reversed
298            -> CoreExpr
299     mk_case (arg,strict) body i rep_args
300           = case strict of
301                 NotMarkedStrict -> body i (arg:rep_args)
302                 MarkedStrict 
303                    | isUnLiftedType (idType arg) -> body i (arg:rep_args)
304                    | otherwise ->
305                         Case (Var arg) arg [(DEFAULT,[], body i (arg:rep_args))]
306
307                 MarkedUnboxed
308                    | isNewType arg_ty ->
309                         Let (NonRec coerced_arg 
310                                 (Note (Coerce rep_ty arg_ty) (Var arg)))
311                               (do_unbox coerced_arg rep_ty i')
312                    | otherwise ->
313                         do_unbox arg arg_ty i
314                   where
315                     ([coerced_arg],i') = mkLocals i [rep_ty]
316                     arg_ty = idType arg
317                     rep_ty = repType arg_ty
318
319                     do_unbox arg ty i = 
320                         case splitProductType "do_unbox" ty of
321                            (tycon, tycon_args, con, tys) ->
322                                    Case (Var arg) arg [(DataAlt con, con_args,
323                                         body i' (reverse con_args ++ rep_args))]
324                               where 
325                                 (con_args, i')   = mkLocals i tys
326 \end{code}
327
328
329 %************************************************************************
330 %*                                                                      *
331 \subsection{Record selectors}
332 %*                                                                      *
333 %************************************************************************
334
335 We're going to build a record selector unfolding that looks like this:
336
337         data T a b c = T1 { ..., op :: a, ...}
338                      | T2 { ..., op :: a, ...}
339                      | T3
340
341         sel = /\ a b c -> \ d -> case d of
342                                     T1 ... x ... -> x
343                                     T2 ... x ... -> x
344                                     other        -> error "..."
345
346 Similarly for newtypes
347
348         newtype N a = MkN { unN :: a->a }
349
350         unN :: N a -> a -> a
351         unN n = coerce (a->a) n
352         
353 We need to take a little care if the field has a polymorphic type:
354
355         data R = R { f :: forall a. a->a }
356
357 Then we want
358
359         f :: forall a. R -> a -> a
360         f = /\ a \ r = case r of
361                           R f -> f a
362
363 (not f :: R -> forall a. a->a, which gives the type inference mechanism 
364 problems at call sites)
365
366 Similarly for newtypes
367
368         newtype N = MkN { unN :: forall a. a->a }
369
370         unN :: forall a. N -> a -> a
371         unN = /\a -> \n:N -> coerce (a->a) n
372
373 \begin{code}
374 mkRecordSelId tycon field_label unpack_id unpackUtf8_id
375         -- Assumes that all fields with the same field label have the same type
376         --
377         -- Annoyingly, we have to pass in the unpackCString# Id, because
378         -- we can't conjure it up out of thin air
379   = sel_id
380   where
381     sel_id     = mkGlobalId (RecordSelId field_label) (fieldLabelName field_label) selector_ty info
382     field_ty   = fieldLabelType field_label
383     data_cons  = tyConDataCons tycon
384     tyvars     = tyConTyVars tycon      -- These scope over the types in 
385                                         -- the FieldLabels of constructors of this type
386     data_ty   = mkTyConApp tycon tyvar_tys
387     tyvar_tys = mkTyVarTys tyvars
388
389     tycon_theta = tyConTheta tycon      -- The context on the data decl
390                                         --   eg data (Eq a, Ord b) => T a b = ...
391     dict_tys  = [mkPredTy pred | pred <- tycon_theta, 
392                                  needed_dict pred]
393     needed_dict pred = or [ pred `elem` (dataConTheta dc) 
394                           | (DataAlt dc, _, _) <- the_alts]
395     n_dict_tys = length dict_tys
396
397     (field_tyvars,field_theta,field_tau) = splitSigmaTy field_ty
398     field_dict_tys                       = map mkPredTy field_theta
399     n_field_dict_tys                     = length field_dict_tys
400         -- If the field has a universally quantified type we have to 
401         -- be a bit careful.  Suppose we have
402         --      data R = R { op :: forall a. Foo a => a -> a }
403         -- Then we can't give op the type
404         --      op :: R -> forall a. Foo a => a -> a
405         -- because the typechecker doesn't understand foralls to the
406         -- right of an arrow.  The "right" type to give it is
407         --      op :: forall a. Foo a => R -> a -> a
408         -- But then we must generate the right unfolding too:
409         --      op = /\a -> \dfoo -> \ r ->
410         --           case r of
411         --              R op -> op a dfoo
412         -- Note that this is exactly the type we'd infer from a user defn
413         --      op (R op) = op
414
415         -- Very tiresomely, the selectors are (unnecessarily!) overloaded over
416         -- just the dictionaries in the types of the constructors that contain
417         -- the relevant field.  Urgh.  
418         -- NB: this code relies on the fact that DataCons are quantified over
419         -- the identical type variables as their parent TyCon
420
421     selector_ty :: Type
422     selector_ty  = mkForAllTys tyvars $ mkForAllTys field_tyvars $
423                    mkFunTys dict_tys  $  mkFunTys field_dict_tys $
424                    mkFunTy data_ty field_tau
425       
426     arity = 1 + n_dict_tys + n_field_dict_tys
427     info = noCafNoTyGenIdInfo
428            `setCgInfo`          (CgInfo arity caf_info)
429            `setArityInfo`       exactArity arity
430            `setUnfoldingInfo`   unfolding       
431         -- ToDo: consider adding further IdInfo
432
433     unfolding = mkTopUnfolding sel_rhs
434
435         -- Allocate Ids.  We do it a funny way round because field_dict_tys is
436         -- almost always empty.  Also note that we use length_tycon_theta
437         -- rather than n_dict_tys, because the latter gives an infinite loop:
438         -- n_dict tys depends on the_alts, which depens on arg_ids, which depends
439         -- on arity, which depends on n_dict tys.  Sigh!  Mega sigh!
440     field_dict_base    = length tycon_theta + 1
441     dict_id_base       = field_dict_base + n_field_dict_tys
442     field_base         = dict_id_base + 1
443     dict_ids           = mkTemplateLocalsNum  1               dict_tys
444     field_dict_ids     = mkTemplateLocalsNum  field_dict_base field_dict_tys
445     data_id            = mkTemplateLocal      dict_id_base    data_ty
446
447     alts      = map mk_maybe_alt data_cons
448     the_alts  = catMaybes alts
449
450     no_default = all isJust alts        -- No default needed
451     default_alt | no_default = []
452                 | otherwise  = [(DEFAULT, [], error_expr)]
453
454         -- the default branch may have CAF refs, because it calls recSelError etc.
455     caf_info    | no_default = NoCafRefs
456                 | otherwise  = MayHaveCafRefs
457
458     sel_rhs = mkLams tyvars   $ mkLams field_tyvars $ 
459               mkLams dict_ids $ mkLams field_dict_ids $
460               Lam data_id     $ sel_body
461
462     sel_body | isNewTyCon tycon = Note (Coerce field_tau data_ty) (Var data_id)
463              | otherwise        = Case (Var data_id) data_id (the_alts ++ default_alt)
464
465     mk_maybe_alt data_con 
466           = case maybe_the_arg_id of
467                 Nothing         -> Nothing
468                 Just the_arg_id -> Just (DataAlt data_con, real_args, mkLets binds body)
469                   where
470                     body               = mkVarApps (mkVarApps (Var the_arg_id) field_tyvars) field_dict_ids
471                     strict_marks       = dataConStrictMarks data_con
472                     (binds, real_args) = rebuildConArgs arg_ids strict_marks
473                                                         (map mkBuiltinUnique [unpack_base..])
474         where
475             arg_ids = mkTemplateLocalsNum field_base (dataConInstOrigArgTys data_con tyvar_tys)
476
477             unpack_base = field_base + length arg_ids
478
479                                 -- arity+1 avoids all shadowing
480             maybe_the_arg_id  = assocMaybe (field_lbls `zip` arg_ids) field_label
481             field_lbls        = dataConFieldLabels data_con
482
483     error_expr = mkApps (Var rEC_SEL_ERROR_ID) [Type field_tau, err_string]
484     err_string
485         | all safeChar full_msg
486             = App (Var unpack_id) (Lit (MachStr (_PK_ full_msg)))
487         | otherwise
488             = App (Var unpackUtf8_id) (Lit (MachStr (_PK_ (stringToUtf8 (map ord full_msg)))))
489         where
490         safeChar c = c >= '\1' && c <= '\xFF'
491         -- TODO: Putting this Unicode stuff here is ugly. Find a better
492         -- generic place to make string literals. This logic is repeated
493         -- in DsUtils.
494     full_msg   = showSDoc (sep [text "No match in record selector", ppr sel_id]) 
495
496
497 -- This rather ugly function converts the unpacked data con 
498 -- arguments back into their packed form.
499
500 rebuildConArgs
501   :: [Id]                       -- Source-level args
502   -> [StrictnessMark]           -- Strictness annotations (per-arg)
503   -> [Unique]                   -- Uniques for the new Ids
504   -> ([CoreBind], [Id])         -- A binding for each source-level arg, plus
505                                 -- a list of the representation-level arguments 
506 -- e.g.   data T = MkT Int !Int
507 --
508 -- rebuild [x::Int, y::Int] [Not, Unbox]
509 --  = ([ y = I# t ], [x,t])
510
511 rebuildConArgs []         stricts us = ([], [])
512
513 -- Type variable case
514 rebuildConArgs (arg:args) stricts us 
515   | isTyVar arg
516   = let (binds, args') = rebuildConArgs args stricts us
517     in  (binds, arg:args')
518
519 -- Term variable case
520 rebuildConArgs (arg:args) (str:stricts) us
521   | isMarkedUnboxed str
522   = let
523         arg_ty  = idType arg
524         prod_ty | isNewType arg_ty = repType arg_ty
525                 | otherwise        = arg_ty
526
527         (_, tycon_args, pack_con, con_arg_tys)
528                  = splitProductType "rebuildConArgs" prod_ty
529
530         unpacked_args  = zipWith (mkSysLocal SLIT("rb")) us con_arg_tys
531
532         (binds, args') = rebuildConArgs args stricts 
533                                 (drop (length con_arg_tys) us)
534
535         coerce | isNewType arg_ty = Note (Coerce arg_ty prod_ty) con_app
536                | otherwise        = con_app
537
538         con_app        = mkConApp pack_con (map Type tycon_args ++ 
539                                             map Var  unpacked_args)
540     in
541     (NonRec arg coerce : binds, unpacked_args ++ args')
542
543   | otherwise
544   = let (binds, args') = rebuildConArgs args stricts us
545     in  (binds, arg:args')
546 \end{code}
547
548
549 %************************************************************************
550 %*                                                                      *
551 \subsection{Dictionary selectors}
552 %*                                                                      *
553 %************************************************************************
554
555 Selecting a field for a dictionary.  If there is just one field, then
556 there's nothing to do.  
557
558 ToDo: unify with mkRecordSelId.
559
560 \begin{code}
561 mkDictSelId :: Name -> Class -> Id
562 mkDictSelId name clas
563   = sel_id
564   where
565     ty        = exprType rhs
566     sel_id    = mkGlobalId (RecordSelId field_lbl) name ty info
567     field_lbl = mkFieldLabel name tycon ty tag
568     tag       = assoc "MkId.mkDictSelId" (classSelIds clas `zip` allFieldLabelTags) sel_id
569
570     info      = noCafNoTyGenIdInfo
571                 `setCgArity`        1
572                 `setArityInfo`      exactArity 1
573                 `setUnfoldingInfo`  unfolding
574                 
575         -- We no longer use 'must-inline' on record selectors.  They'll
576         -- inline like crazy if they scrutinise a constructor
577
578     unfolding = mkTopUnfolding rhs
579
580     tyvars  = classTyVars clas
581
582     tycon      = classTyCon clas
583     [data_con] = tyConDataCons tycon
584     tyvar_tys  = mkTyVarTys tyvars
585     arg_tys    = dataConArgTys data_con tyvar_tys
586     the_arg_id = arg_ids !! (tag - firstFieldLabelTag)
587
588     dict_ty    = mkDictTy clas tyvar_tys
589     (dict_id:arg_ids) = mkTemplateLocals (dict_ty : arg_tys)
590
591     rhs | isNewTyCon tycon = mkLams tyvars $ Lam dict_id $
592                              Note (Coerce (head arg_tys) dict_ty) (Var dict_id)
593         | otherwise        = mkLams tyvars $ Lam dict_id $
594                              Case (Var dict_id) dict_id
595                                   [(DataAlt data_con, arg_ids, Var the_arg_id)]
596 \end{code}
597
598
599 %************************************************************************
600 %*                                                                      *
601 \subsection{Primitive operations
602 %*                                                                      *
603 %************************************************************************
604
605 \begin{code}
606 mkPrimOpId :: PrimOp -> Id
607 mkPrimOpId prim_op 
608   = id
609   where
610     (tyvars,arg_tys,res_ty, arity, strict_info) = primOpSig prim_op
611     ty   = mkForAllTys tyvars (mkFunTys arg_tys res_ty)
612     name = mkPrimOpIdName prim_op
613     id   = mkGlobalId (PrimOpId prim_op) name ty info
614                 
615     info = noCafNoTyGenIdInfo
616            `setSpecInfo`        rules
617            `setCgArity`         arity
618            `setArityInfo`       exactArity arity
619            `setStrictnessInfo`  strict_info
620
621     rules = maybe emptyCoreRules (addRule emptyCoreRules id)
622                 (primOpRule prim_op)
623
624
625 -- For each ccall we manufacture a separate CCallOpId, giving it
626 -- a fresh unique, a type that is correct for this particular ccall,
627 -- and a CCall structure that gives the correct details about calling
628 -- convention etc.  
629 --
630 -- The *name* of this Id is a local name whose OccName gives the full
631 -- details of the ccall, type and all.  This means that the interface 
632 -- file reader can reconstruct a suitable Id
633
634 mkCCallOpId :: Unique -> CCall -> Type -> Id
635 mkCCallOpId uniq ccall ty
636   = ASSERT( isEmptyVarSet (tyVarsOfType ty) )
637         -- A CCallOpId should have no free type variables; 
638         -- when doing substitutions won't substitute over it
639     mkGlobalId (PrimOpId prim_op) name ty info
640   where
641     occ_str = showSDocIface (braces (pprCCallOp ccall <+> ppr ty))
642         -- The "occurrence name" of a ccall is the full info about the
643         -- ccall; it is encoded, but may have embedded spaces etc!
644
645     name    = mkCCallName uniq occ_str
646     prim_op = CCallOp ccall
647
648     info = noCafNoTyGenIdInfo
649            `setCgArity`         arity
650            `setArityInfo`       exactArity arity
651            `setStrictnessInfo`  strict_info
652
653     (_, tau)     = splitForAllTys ty
654     (arg_tys, _) = splitFunTys tau
655     arity        = length arg_tys
656     strict_info  = mkStrictnessInfo (take arity (repeat wwPrim), False)
657 \end{code}
658
659
660 %************************************************************************
661 %*                                                                      *
662 \subsection{DictFuns and default methods}
663 %*                                                                      *
664 %************************************************************************
665
666 \begin{code}
667 mkDefaultMethodId dm_name ty
668   = mkVanillaGlobal dm_name ty noCafNoTyGenIdInfo
669
670 mkDictFunId :: Name             -- Name to use for the dict fun;
671             -> Class 
672             -> [TyVar]
673             -> [Type]
674             -> ThetaType
675             -> Id
676
677 mkDictFunId dfun_name clas inst_tyvars inst_tys dfun_theta
678   = mkVanillaGlobal dfun_name dfun_ty noCafNoTyGenIdInfo
679   where
680     dfun_ty = mkSigmaTy inst_tyvars dfun_theta (mkDictTy clas inst_tys)
681
682 {-  1 dec 99: disable the Mark Jones optimisation for the sake
683     of compatibility with Hugs.
684     See `types/InstEnv' for a discussion related to this.
685
686     (class_tyvars, sc_theta, _, _) = classBigSig clas
687     not_const (clas, tys) = not (isEmptyVarSet (tyVarsOfTypes tys))
688     sc_theta' = substClasses (mkTopTyVarSubst class_tyvars inst_tys) sc_theta
689     dfun_theta = case inst_decl_theta of
690                    []    -> []  -- If inst_decl_theta is empty, then we don't
691                                 -- want to have any dict arguments, so that we can
692                                 -- expose the constant methods.
693
694                    other -> nub (inst_decl_theta ++ filter not_const sc_theta')
695                                 -- Otherwise we pass the superclass dictionaries to
696                                 -- the dictionary function; the Mark Jones optimisation.
697                                 --
698                                 -- NOTE the "nub".  I got caught by this one:
699                                 --   class Monad m => MonadT t m where ...
700                                 --   instance Monad m => MonadT (EnvT env) m where ...
701                                 -- Here, the inst_decl_theta has (Monad m); but so
702                                 -- does the sc_theta'!
703                                 --
704                                 -- NOTE the "not_const".  I got caught by this one too:
705                                 --   class Foo a => Baz a b where ...
706                                 --   instance Wob b => Baz T b where..
707                                 -- Now sc_theta' has Foo T
708 -}
709 \end{code}
710
711
712 %************************************************************************
713 %*                                                                      *
714 \subsection{Un-definable}
715 %*                                                                      *
716 %************************************************************************
717
718 These two can't be defined in Haskell.
719
720 unsafeCoerce# isn't so much a PrimOp as a phantom identifier, that
721 just gets expanded into a type coercion wherever it occurs.  Hence we
722 add it as a built-in Id with an unfolding here.
723
724 The type variables we use here are "open" type variables: this means
725 they can unify with both unlifted and lifted types.  Hence we provide
726 another gun with which to shoot yourself in the foot.
727
728 \begin{code}
729 unsafeCoerceId
730   = pcMiscPrelId unsafeCoerceIdKey pREL_GHC SLIT("unsafeCoerce#") ty info
731   where
732     info = noCafNoTyGenIdInfo `setUnfoldingInfo` mkCompulsoryUnfolding rhs
733            
734
735     ty  = mkForAllTys [openAlphaTyVar,openBetaTyVar]
736                       (mkFunTy openAlphaTy openBetaTy)
737     [x] = mkTemplateLocals [openAlphaTy]
738     rhs = mkLams [openAlphaTyVar,openBetaTyVar,x] $
739           Note (Coerce openBetaTy openAlphaTy) (Var x)
740 \end{code}
741
742
743 @getTag#@ is another function which can't be defined in Haskell.  It needs to
744 evaluate its argument and call the dataToTag# primitive.
745
746 \begin{code}
747 getTagId
748   = pcMiscPrelId getTagIdKey pREL_GHC SLIT("getTag#") ty info
749   where
750     info = noCafNoTyGenIdInfo `setUnfoldingInfo` mkCompulsoryUnfolding rhs
751         -- We don't provide a defn for this; you must inline it
752
753     ty = mkForAllTys [alphaTyVar] (mkFunTy alphaTy intPrimTy)
754     [x,y] = mkTemplateLocals [alphaTy,alphaTy]
755     rhs = mkLams [alphaTyVar,x] $
756           Case (Var x) y [ (DEFAULT, [], mkApps (Var dataToTagId) [Type alphaTy, Var y]) ]
757
758 dataToTagId = mkPrimOpId DataToTagOp
759 \end{code}
760
761 @realWorld#@ used to be a magic literal, \tr{void#}.  If things get
762 nasty as-is, change it back to a literal (@Literal@).
763
764 \begin{code}
765 realWorldPrimId -- :: State# RealWorld
766   = pcMiscPrelId realWorldPrimIdKey pREL_GHC SLIT("realWorld#")
767                  realWorldStatePrimTy
768                  (noCafNoTyGenIdInfo `setUnfoldingInfo` mkOtherCon [])
769         -- The mkOtherCon makes it look that realWorld# is evaluated
770         -- which in turn makes Simplify.interestingArg return True,
771         -- which in turn makes INLINE things applied to realWorld# likely
772         -- to be inlined
773 \end{code}
774
775
776 %************************************************************************
777 %*                                                                      *
778 \subsection[PrelVals-error-related]{@error@ and friends; @trace@}
779 %*                                                                      *
780 %************************************************************************
781
782 GHC randomly injects these into the code.
783
784 @patError@ is just a version of @error@ for pattern-matching
785 failures.  It knows various ``codes'' which expand to longer
786 strings---this saves space!
787
788 @absentErr@ is a thing we put in for ``absent'' arguments.  They jolly
789 well shouldn't be yanked on, but if one is, then you will get a
790 friendly message from @absentErr@ (rather than a totally random
791 crash).
792
793 @parError@ is a special version of @error@ which the compiler does
794 not know to be a bottoming Id.  It is used in the @_par_@ and @_seq_@
795 templates, but we don't ever expect to generate code for it.
796
797 \begin{code}
798 eRROR_ID
799   = pc_bottoming_Id errorIdKey pREL_ERR SLIT("error") errorTy
800 pAT_ERROR_ID
801   = generic_ERROR_ID patErrorIdKey SLIT("patError")
802 rEC_SEL_ERROR_ID
803   = generic_ERROR_ID recSelErrIdKey SLIT("recSelError")
804 rEC_CON_ERROR_ID
805   = generic_ERROR_ID recConErrorIdKey SLIT("recConError")
806 rEC_UPD_ERROR_ID
807   = generic_ERROR_ID recUpdErrorIdKey SLIT("recUpdError")
808 iRREFUT_PAT_ERROR_ID
809   = generic_ERROR_ID irrefutPatErrorIdKey SLIT("irrefutPatError")
810 nON_EXHAUSTIVE_GUARDS_ERROR_ID
811   = generic_ERROR_ID nonExhaustiveGuardsErrorIdKey SLIT("nonExhaustiveGuardsError")
812 nO_METHOD_BINDING_ERROR_ID
813   = generic_ERROR_ID noMethodBindingErrorIdKey SLIT("noMethodBindingError")
814
815 aBSENT_ERROR_ID
816   = pc_bottoming_Id absentErrorIdKey pREL_ERR SLIT("absentErr")
817         (mkSigmaTy [openAlphaTyVar] [] openAlphaTy)
818
819 pAR_ERROR_ID
820   = pcMiscPrelId parErrorIdKey pREL_ERR SLIT("parError")
821     (mkSigmaTy [openAlphaTyVar] [] openAlphaTy) noCafNoTyGenIdInfo
822 \end{code}
823
824
825 %************************************************************************
826 %*                                                                      *
827 \subsection{Utilities}
828 %*                                                                      *
829 %************************************************************************
830
831 \begin{code}
832 pcMiscPrelId :: Unique{-IdKey-} -> Module -> FAST_STRING -> Type -> IdInfo -> Id
833 pcMiscPrelId key mod str ty info
834   = let
835         name = mkWiredInName mod (mkVarOcc str) key
836         imp  = mkVanillaGlobal name ty info -- the usual case...
837     in
838     imp
839     -- We lie and say the thing is imported; otherwise, we get into
840     -- a mess with dependency analysis; e.g., core2stg may heave in
841     -- random calls to GHCbase.unpackPS__.  If GHCbase is the module
842     -- being compiled, then it's just a matter of luck if the definition
843     -- will be in "the right place" to be in scope.
844
845 pc_bottoming_Id key mod name ty
846  = pcMiscPrelId key mod name ty bottoming_info
847  where
848     bottoming_info = noCafNoTyGenIdInfo 
849                      `setStrictnessInfo` mkStrictnessInfo ([wwStrict], True)
850
851         -- these "bottom" out, no matter what their arguments
852
853 generic_ERROR_ID u n = pc_bottoming_Id u pREL_ERR n errorTy
854
855 (openAlphaTyVar:openBetaTyVar:_) = openAlphaTyVars
856 openAlphaTy  = mkTyVarTy openAlphaTyVar
857 openBetaTy   = mkTyVarTy openBetaTyVar
858
859 errorTy  :: Type
860 errorTy  = mkSigmaTy [openAlphaTyVar] [] (mkFunTys [mkListTy charTy] 
861                                                    openAlphaTy)
862     -- Notice the openAlphaTyVar.  It says that "error" can be applied
863     -- to unboxed as well as boxed types.  This is OK because it never
864     -- returns, so the return type is irrelevant.
865 \end{code}
866