2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
4 \section[PrelVals]{Prelude values the compiler ``knows about''}
7 #include "HsVersions.h"
12 IMPORT_DELOOPER(IdLoop) ( UnfoldingGuidance(..), nullSpecEnv, SpecEnv )
13 import Id ( SYN_IE(Id), GenId, mkImported, mkUserId, mkTemplateLocals )
14 IMPORT_DELOOPER(PrelLoop)
22 import CmdLineOpts ( maybe_CompilingGhcInternals )
23 import CoreSyn -- quite a bit
24 import IdInfo -- quite a bit
25 import Literal ( mkMachInt )
26 import Name ( ExportFlag(..) )
28 import PrimOp ( PrimOp(..) )
29 import Type ( mkTyVarTy )
30 import TyVar ( openAlphaTyVar, alphaTyVar, betaTyVar, gammaTyVar )
31 import Unique -- lots of *Keys
37 pcMiscPrelId :: Unique{-IdKey-} -> FAST_STRING -> FAST_STRING -> Type -> IdInfo -> Id
39 pcMiscPrelId key m n ty info
41 name = mkWiredInName key (OrigName m n) ExportAll
42 imp = mkImported name ty info -- the usual case...
45 -- We lie and say the thing is imported; otherwise, we get into
46 -- a mess with dependency analysis; e.g., core2stg may heave in
47 -- random calls to GHCbase.unpackPS__. If GHCbase is the module
48 -- being compiled, then it's just a matter of luck if the definition
49 -- will be in "the right place" to be in scope.
52 %************************************************************************
54 \subsection[PrelVals-error-related]{@error@ and friends; @trace@}
56 %************************************************************************
58 GHC randomly injects these into the code.
60 @patError@ is just a version of @error@ for pattern-matching
61 failures. It knows various ``codes'' which expand to longer
62 strings---this saves space!
64 @absentErr@ is a thing we put in for ``absent'' arguments. They jolly
65 well shouldn't be yanked on, but if one is, then you will get a
66 friendly message from @absentErr@ (rather a totally random crash).
68 @parError@ is a special version of @error@ which the compiler does
69 not know to be a bottoming Id. It is used in the @_par_@ and @_seq_@
70 templates, but we don't ever expect to generate code for it.
73 pc_bottoming_Id key mod name ty
74 = pcMiscPrelId key mod name ty bottoming_info
76 bottoming_info = noIdInfo `addInfo` mkBottomStrictnessInfo
77 -- these "bottom" out, no matter what their arguments
80 = pc_bottoming_Id errorIdKey pRELUDE SLIT("error") errorTy
83 = pc_bottoming_Id u SLIT("GHCerr") n errorTy
86 = generic_ERROR_ID patErrorIdKey SLIT("patError")
88 = generic_ERROR_ID recConErrorIdKey SLIT("recConError")
90 = generic_ERROR_ID recUpdErrorIdKey SLIT("recUpdError")
92 = generic_ERROR_ID irrefutPatErrorIdKey SLIT("irrefutPatError")
93 nON_EXHAUSTIVE_GUARDS_ERROR_ID
94 = generic_ERROR_ID nonExhaustiveGuardsErrorIdKey SLIT("nonExhaustiveGuardsError")
95 nO_DEFAULT_METHOD_ERROR_ID
96 = generic_ERROR_ID noDefaultMethodErrorIdKey SLIT("noDefaultMethodError")
97 nO_EXPLICIT_METHOD_ERROR_ID
98 = generic_ERROR_ID nonExplicitMethodErrorIdKey SLIT("noExplicitMethodError")
101 = pc_bottoming_Id absentErrorIdKey SLIT("GHCerr") SLIT("absentErr")
102 (mkSigmaTy [openAlphaTyVar] [] openAlphaTy)
105 = pcMiscPrelId parErrorIdKey SLIT("GHCerr") SLIT("parError")
106 (mkSigmaTy [openAlphaTyVar] [] openAlphaTy) noIdInfo
108 openAlphaTy = mkTyVarTy openAlphaTyVar
111 errorTy = mkSigmaTy [openAlphaTyVar] [] (mkFunTys [mkListTy charTy] openAlphaTy)
114 We want \tr{GHCbase.trace} to be wired in
115 because we don't want the strictness analyser to get ahold of it,
116 decide that the second argument is strict, evaluate that first (!!),
117 and make a jolly old mess.
120 = pcMiscPrelId traceIdKey gHC__ SLIT("trace") traceTy
121 (noIdInfo `addInfo` pcGenerateSpecs traceIdKey tRACE_ID noIdInfo traceTy)
123 traceTy = mkSigmaTy [alphaTyVar] [] (mkFunTys [mkListTy charTy, alphaTy] alphaTy)
126 %************************************************************************
128 \subsection[PrelVals-Integer-support]{To support @Integer@ and @String@ literals}
130 %************************************************************************
134 = pcMiscPrelId packCStringIdKey{-ToDo:rename-} gHC__ SLIT("packStringForC__")
135 (mkFunTys [stringTy] byteArrayPrimTy) noIdInfo
137 --------------------------------------------------------------------
140 = pcMiscPrelId unpackCStringIdKey gHC__ SLIT("unpackPS__")
141 (mkFunTys [addrPrimTy{-a char *-}] stringTy) noIdInfo
143 -- (FunTy addrPrimTy{-a char *-} stringTy) (noIdInfo `addInfo` mkArityInfo 1)
144 -- but I don't like wired-in IdInfos (WDP)
146 unpackCString2Id -- for cases when a string has a NUL in it
147 = pcMiscPrelId unpackCString2IdKey gHC__ SLIT("unpackPS2__")
148 (mkFunTys [addrPrimTy{-a char *-}, intPrimTy{-length-}] stringTy)
151 --------------------------------------------------------------------
152 unpackCStringAppendId
153 = pcMiscPrelId unpackCStringAppendIdKey gHC__ SLIT("unpackAppendPS__")
154 (mkFunTys [addrPrimTy{-a "char *" pointer-},stringTy] stringTy)
156 {-LATER:`addInfo_UF` mkMagicUnfolding unpackCStringAppendIdKey-})
157 `addInfo` mkArityInfo 2)
160 = pcMiscPrelId unpackCStringFoldrIdKey gHC__ SLIT("unpackFoldrPS__")
161 (mkSigmaTy [alphaTyVar] []
162 (mkFunTys [addrPrimTy{-a "char *" pointer-},
163 mkFunTys [charTy, alphaTy] alphaTy,
167 {-LATER:`addInfo_UF` mkMagicUnfolding unpackCStringFoldrIdKey-})
168 `addInfo` mkArityInfo 3)
171 OK, this is Will's idea: we should have magic values for Integers 0,
172 +1, +2, and -1 (go ahead, fire me):
175 = pcMiscPrelId integerZeroIdKey gHC__ SLIT("integer_0") integerTy noIdInfo
177 = pcMiscPrelId integerPlusOneIdKey gHC__ SLIT("integer_1") integerTy noIdInfo
179 = pcMiscPrelId integerPlusTwoIdKey gHC__ SLIT("integer_2") integerTy noIdInfo
181 = pcMiscPrelId integerMinusOneIdKey gHC__ SLIT("integer_m1") integerTy noIdInfo
184 %************************************************************************
186 \subsection[PrelVals-parallel]{@seq@ and @par@: for parallel operation (only)}
188 %************************************************************************
192 --------------------------------------------------------------------
193 -- seqId :: "seq", used w/ GRIP, etc., is really quite similar to
197 seq = /\ a b -> \ x y -> case x of { _ -> y }
200 seq = /\ a b -> \ x y -> case seq# x y of { _Lift y' -> y' }
203 seq = /\ a b -> \ x::a y::b -> case seq# x of { 0# -> parError#; _ -> y; }
207 seqId = pcMiscPrelId seqIdKey gHC__ SLIT("seq")
208 (mkSigmaTy [alphaTyVar, betaTyVar] []
209 (mkFunTys [alphaTy, betaTy] betaTy))
210 (noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding seq_template))
220 = mkLam [alphaTyVar, betaTyVar] [x, y] (
221 Case (Prim SeqOp [TyArg alphaTy, VarArg x]) (
223 [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [betaTy])]
224 (BindDefault z (Var y))))
226 --------------------------------------------------------------------
227 -- parId :: "par", also used w/ GRIP, etc.
231 par = /\ a b -> \ x y -> case (par# (case x of { _ -> () })) of { _ -> y }
235 par = /\ a b -> \ x y -> case par# x y of { _Lift y' -> y' }
239 par = /\ a b -> \ x::a y::b -> case par# x of { 0# -> parError#; _ -> y; }
242 parId = pcMiscPrelId parIdKey gHC__ SLIT("par")
243 (mkSigmaTy [alphaTyVar, betaTyVar] []
244 (mkFunTys [alphaTy, betaTy] betaTy))
245 (noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding par_template))
255 = mkLam [alphaTyVar, betaTyVar] [x, y] (
256 Case (Prim ParOp [TyArg alphaTy, VarArg x]) (
258 [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [betaTy])]
259 (BindDefault z (Var y))))
261 -- forkId :: "fork", for *required* concurrent threads
263 _fork_ = /\ a b -> \ x::a y::b -> case fork# x of { 0# -> parError#; _ -> y; }
265 forkId = pcMiscPrelId forkIdKey gHC__ SLIT("fork")
266 (mkSigmaTy [alphaTyVar, betaTyVar] []
267 (mkFunTys [alphaTy, betaTy] betaTy))
268 (noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding fork_template))
278 = mkLam [alphaTyVar, betaTyVar] [x, y] (
279 Case (Prim ForkOp [TyArg alphaTy, VarArg x]) (
281 [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [betaTy])]
282 (BindDefault z (Var y))))
289 parLocalId = pcMiscPrelId parLocalIdKey gHC__ SLIT("parLocal")
290 (mkSigmaTy [alphaTyVar, betaTyVar] []
291 (mkFunTys [intPrimTy, intPrimTy, intPrimTy, intPrimTy, alphaTy, betaTy] betaTy))
292 (noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding parLocal_template))
294 -- Annotations: w: name, g: gran. info, s: size info, p: par info -- HWL
295 [w, g, s, p, x, y, z]
307 = mkLam [alphaTyVar, betaTyVar] [w, g, s, p, x, y] (
308 Case (Prim ParLocalOp [TyArg alphaTy, TyArg betaTy, VarArg x, VarArg w, VarArg g, VarArg s, VarArg p, VarArg y]) (
310 [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [betaTy])]
311 (BindDefault z (Var y))))
313 parGlobalId = pcMiscPrelId parGlobalIdKey gHC__ SLIT("parGlobal")
314 (mkSigmaTy [alphaTyVar, betaTyVar] []
315 (mkFunTys [intPrimTy, intPrimTy, intPrimTy, intPrimTy, alphaTy, betaTy] betaTy))
316 (noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding parGlobal_template))
318 -- Annotations: w: name, g: gran. info, s: size info, p: par info -- HWL
319 [w, g, s, p, x, y, z]
331 = mkLam [alphaTyVar, betaTyVar] [w, g, s, p, x, y] (
332 Case (Prim ParGlobalOp [TyArg alphaTy, TyArg betaTy, VarArg x, VarArg w, VarArg g, VarArg s, VarArg p, VarArg y]) (
334 [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [betaTy])]
335 (BindDefault z (Var y))))
338 parAtId = pcMiscPrelId parAtIdKey gHC__ SLIT("parAt")
339 (mkSigmaTy [alphaTyVar, betaTyVar] []
340 (mkFunTys [intPrimTy, intPrimTy, intPrimTy, intPrimTy,
341 alphaTy, betaTy, gammaTy] gammaTy))
342 (noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding parAt_template))
344 -- Annotations: w: name, g: gran. info, s: size info, p: par info -- HWL
345 [w, g, s, p, v, x, y, z]
358 = mkLam [alphaTyVar, betaTyVar, gammaTyVar] [w, g, s, p, v, x, y] (
359 Case (Prim ParAtOp [TyArg alphaTy, TyArg betaTy, TyArg gammaTy, VarArg x, VarArg v, VarArg w, VarArg g, VarArg s, VarArg p, VarArg y]) (
361 [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [gammaTy])]
362 (BindDefault z (Var y))))
364 parAtAbsId = pcMiscPrelId parAtAbsIdKey gHC__ SLIT("parAtAbs")
365 (mkSigmaTy [alphaTyVar, betaTyVar] []
366 (mkFunTys [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, alphaTy, betaTy] betaTy))
367 (noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding parAtAbs_template))
369 -- Annotations: w: name, g: gran. info, s: size info, p: par info -- HWL
370 [w, g, s, p, v, x, y, z]
383 = mkLam [alphaTyVar, betaTyVar] [w, g, s, p, v, x, y] (
384 Case (Prim ParAtAbsOp [TyArg alphaTy, TyArg betaTy, VarArg x, VarArg v, VarArg w, VarArg g, VarArg s, VarArg p, VarArg y]) (
386 [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [betaTy])]
387 (BindDefault z (Var y))))
389 parAtRelId = pcMiscPrelId parAtRelIdKey gHC__ SLIT("parAtRel")
390 (mkSigmaTy [alphaTyVar, betaTyVar] []
391 (mkFunTys [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, alphaTy, betaTy] betaTy))
392 (noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding parAtRel_template))
394 -- Annotations: w: name, g: gran. info, s: size info, p: par info -- HWL
395 [w, g, s, p, v, x, y, z]
408 = mkLam [alphaTyVar, betaTyVar] [w, g, s, p, v, x, y] (
409 Case (Prim ParAtRelOp [TyArg alphaTy, TyArg betaTy, VarArg x, VarArg v, VarArg w, VarArg g, VarArg s, VarArg p, VarArg y]) (
411 [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [betaTy])]
412 (BindDefault z (Var y))))
414 parAtForNowId = pcMiscPrelId parAtForNowIdKey gHC__ SLIT("parAtForNow")
415 (mkSigmaTy [alphaTyVar, betaTyVar] []
416 (mkFunTys [intPrimTy, intPrimTy, intPrimTy, intPrimTy,
417 alphaTy, betaTy, gammaTy] gammaTy))
418 (noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding parAtForNow_template))
420 -- Annotations: w: name, g: gran. info, s: size info, p: par info -- HWL
421 [w, g, s, p, v, x, y, z]
434 = mkLam [alphaTyVar, betaTyVar, gammaTyVar] [w, g, s, p, v, x, y] (
435 Case (Prim ParAtForNowOp [TyArg alphaTy, TyArg betaTy, TyArg gammaTy, VarArg x, VarArg v, VarArg w, VarArg g, VarArg s, VarArg p, VarArg y]) (
437 [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [gammaTy])]
438 (BindDefault z (Var y))))
440 -- copyable and noFollow are currently merely hooks: they are translated into
441 -- calls to the macros COPYABLE and NOFOLLOW -- HWL
443 copyableId = pcMiscPrelId copyableIdKey gHC__ SLIT("copyable")
444 (mkSigmaTy [alphaTyVar] []
446 (noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding copyable_template))
448 -- Annotations: x: closure that's tagged to by copyable
456 = mkLam [alphaTyVar] [x] ( Prim CopyableOp [TyArg alphaTy, VarArg x] )
458 noFollowId = pcMiscPrelId noFollowIdKey gHC__ SLIT("noFollow")
459 (mkSigmaTy [alphaTyVar] []
461 (noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding noFollow_template))
463 -- Annotations: x: closure that's tagged to not follow
471 = mkLam [alphaTyVar] [x] ( Prim NoFollowOp [TyArg alphaTy, VarArg x] )
475 %************************************************************************
477 \subsection[PrelVals-runST]{@runST@: Magic start-state-transformer function}
479 %************************************************************************
481 @runST@ has a non-Haskell-able type:
483 -- runST :: forall a. (forall s. _ST s a) -> a
484 -- which is to say ::
485 -- forall a. (forall s. (_State s -> (a, _State s))) -> a
487 runST a m = case m _RealWorld (S# _RealWorld realWorld#) of
488 (r :: a, wild :: _State _RealWorld) -> r
491 We unfold always, just for simplicity:
494 = pcMiscPrelId runSTIdKey gHC__ SLIT("runST") run_ST_ty id_info
499 st_ty a = mkSigmaTy [s_tv] [] (mkStateTransformerTy s a)
502 = mkSigmaTy [alphaTyVar] [] (mkFunTys [st_ty alphaTy] alphaTy)
503 -- NB: rank-2 polymorphism! (forall inside the st_ty...)
507 `addInfo` mkArityInfo 1
508 `addInfo` mkStrictnessInfo [WwStrict] Nothing
509 `addInfo` mkArgUsageInfo [ArgUsage 1]
510 -- ABSOLUTELY NO UNFOLDING, e.g.: (mkUnfolding EssentialUnfolding run_ST_template)
516 {-t-} realWorldStateTy,
518 {-_-} realWorldStateTy
522 = mkLam [alphaTyVar] [m] (
523 Let (NonRec t (Con stateDataCon [TyArg realWorldTy, VarArg realWorldPrimId])) (
524 Case (App (mkTyApp (Var m) [realWorldTy]) (VarArg t)) (
526 [(mkTupleCon 2, [r, wild], Var r)]
531 SLPJ 95/04: Why @runST@ must not have an unfolding; consider:
535 (a, s') = newArray# 100 [] s
536 (_, s'') = fill_in_array_or_something a x s'
540 If we inline @runST@, we'll get:
543 (a, s') = newArray# 100 [] realWorld#{-NB-}
544 (_, s'') = fill_in_array_or_something a x s'
548 And now the @newArray#@ binding can be floated to become a CAF, which
549 is totally and utterly wrong:
552 (a, s') = newArray# 100 [] realWorld#{-NB-} -- YIKES!!!
555 let (_, s'') = fill_in_array_or_something a x s' in
558 All calls to @f@ will share a {\em single} array! End SLPJ 95/04.
560 @realWorld#@ used to be a magic literal, \tr{void#}. If things get
561 nasty as-is, change it back to a literal (@Literal@).
564 = pcMiscPrelId realWorldPrimIdKey gHC_BUILTINS SLIT("realWorld#")
570 voidId = pcMiscPrelId voidIdKey gHC_BUILTINS SLIT("void") voidTy noIdInfo
573 %************************************************************************
575 \subsection[PrelVals-foldr-build]{Values known about for ``foldr/build''}
577 %************************************************************************
581 = pcMiscPrelId buildIdKey SLIT("GHCerr") SLIT("build") buildTy
583 {-LATER:`addInfo_UF` mkMagicUnfolding buildIdKey-})
584 `addInfo` mkStrictnessInfo [WwStrict] Nothing)
585 `addInfo` mkArgUsageInfo [ArgUsage 2])
586 `addInfo` pcGenerateSpecs buildIdKey buildId noIdInfo{-ToDo-} buildTy)
587 -- cheating, but since _build never actually exists ...
589 -- The type of this strange object is:
590 -- \/ a . (\/ b . (a -> b -> b) -> b -> b) -> [a]
592 buildTy = mkSigmaTy [alphaTyVar] [] (mkFunTys [build_ty] (mkListTy alphaTy))
594 build_ty = mkSigmaTy [betaTyVar] []
595 (mkFunTys [mkFunTys [alphaTy, betaTy] betaTy, betaTy] betaTy)
598 @mkBuild@ is sugar for building a build!
600 @mkbuild ty tv c n e@ $Rightarrow$ @build ty (/\ tv -> \ c n -> e)@
601 @ty@ is the type of the list.
602 @tv@ is always a new type variable.
603 @c,n@ are Id's for the abstract cons and nil, @g@ for let binding the argument argument.
606 v :: (\/ b . (a -> b -> b) -> b -> b) -> [a]
607 -- \/ a . (\/ b . (a -> b -> b) -> b -> b) -> [a]
608 @e@ is the object right inside the @build@
616 -> CoreExpr -- template
617 -> CoreExpr -- template
619 mkBuild ty tv c n g expr
620 = Let (NonRec g (mkLam [tv] [c,n] expr))
621 (App (mkTyApp (Var buildId) [ty]) (VarArg g))
626 = pcMiscPrelId augmentIdKey SLIT("GHCerr") SLIT("augment") augmentTy
628 {-LATER:`addInfo_UF` mkMagicUnfolding augmentIdKey-})
629 `addInfo` mkStrictnessInfo [WwStrict,WwLazy False] Nothing)
630 `addInfo` mkArgUsageInfo [ArgUsage 2,UnknownArgUsage])
631 -- cheating, but since _augment never actually exists ...
633 -- The type of this strange object is:
634 -- \/ a . (\/ b . (a -> b -> b) -> b -> b) -> [a] -> [a]
636 augmentTy = mkSigmaTy [alphaTyVar] [] (mkFunTys [aug_ty, mkListTy alphaTy] (mkListTy alphaTy))
638 aug_ty = mkSigmaTy [betaTyVar] []
639 (mkFunTys [mkFunTys [alphaTy, betaTy] betaTy, betaTy] betaTy)
643 foldrId = pcMiscPrelId foldrIdKey pRELUDE SLIT("foldr")
647 mkSigmaTy [alphaTyVar, betaTyVar] []
648 (mkFunTys [mkFunTys [alphaTy, betaTy] betaTy, betaTy, mkListTy alphaTy] betaTy)
650 idInfo = (((((noIdInfo
651 {-LATER:`addInfo_UF` mkMagicUnfolding foldrIdKey-})
652 `addInfo` mkStrictnessInfo [WwLazy False,WwLazy False,WwStrict] Nothing)
653 `addInfo` mkArityInfo 3)
654 `addInfo` mkUpdateInfo [2,2,1])
655 `addInfo` pcGenerateSpecs foldrIdKey foldrId noIdInfo{-ToDo-} foldrTy)
657 foldlId = pcMiscPrelId foldlIdKey pRELUDE SLIT("foldl")
661 mkSigmaTy [alphaTyVar, betaTyVar] []
662 (mkFunTys [mkFunTys [alphaTy, betaTy] alphaTy, alphaTy, mkListTy betaTy] alphaTy)
664 idInfo = (((((noIdInfo
665 {-LATER:`addInfo_UF` mkMagicUnfolding foldlIdKey-})
666 `addInfo` mkStrictnessInfo [WwLazy False,WwLazy False,WwStrict] Nothing)
667 `addInfo` mkArityInfo 3)
668 `addInfo` mkUpdateInfo [2,2,1])
669 `addInfo` pcGenerateSpecs foldlIdKey foldlId noIdInfo{-ToDo-} foldlTy)
671 -- A bit of magic goes no here. We translate appendId into ++,
672 -- you have to be carefull when you actually compile append:
673 -- xs ++ ys = augment (\ c n -> foldr c n xs) ys
674 -- {- unfold augment -}
676 -- {- fold foldr to append -}
677 -- = ys `appendId` xs
678 -- = ys ++ xs -- ugg!
679 -- *BUT* you want (++) and not _append in your interfaces.
681 -- So you have to turn *off* unfolding of foldr inside FoldrBuild.hs inside
684 {- OLD: doesn't apply with 1.3
686 = pcMiscPrelId appendIdKey pRELUDE_LIST SLIT("++") appendTy idInfo
689 (mkSigmaTy [alphaTyVar] []
690 (mkFunTys [mkListTy alphaTy, mkListTy alphaTy] (mkListTy alphaTy)))
692 `addInfo` mkStrictnessInfo [WwStrict,WwLazy False] Nothing)
693 `addInfo` mkArityInfo 2)
694 `addInfo` mkUpdateInfo [1,2])
698 %************************************************************************
700 \subsection[PrelUtils-specialisations]{Specialisations for builtin values}
702 %************************************************************************
704 The specialisations which exist for the builtin values must be recorded in
707 NOTE: THE USES OF THE pcGenerate... FUNCTIONS MUST CORRESPOND
708 TO THE SPECIALISATIONS DECLARED IN THE PRELUDE !!!
710 HACK: We currently use the same unique for the specialised Ids.
712 The list @specing_types@ determines the types for which specialised
713 versions are created. Note: This should correspond with the
714 types passed to the pre-processor with the -genSPECS arg (see ghc.lprl).
716 ToDo: Create single mkworld definition which is grabbed here and in ghc.lprl
719 pcGenerateSpecs :: Unique -> Id -> IdInfo -> Type -> SpecEnv
720 pcGenerateSpecs key id info ty
725 pc_gen_specs True key id info ty
727 pc_gen_specs is_id key id info ty
728 = mkSpecEnv spec_infos
730 spec_infos = [ let spec_ty = specialiseTy ty spec_tys 0
732 then mkSpecId key {- HACK WARNING: same unique! -}
733 id spec_tys spec_ty info
734 else panic "SpecData:SpecInfo:SpecId"
736 SpecInfo spec_tys (length ctxts) spec_id
737 | spec_tys <- specialisations ]
739 (tyvars, ctxts, _) = splitSigmaTy ty
740 no_tyvars = length tyvars
742 specialisations = if no_tyvars == 0
744 else tail (cross_product no_tyvars specing_types)
746 -- N.B. tail removes fully polymorphic specialisation
748 cross_product 0 tys = []
749 cross_product 1 tys = map (:[]) tys
750 cross_product n tys = concat [map (:cp) tys | cp <- cross_product (n-1) tys]
753 specing_types = [Nothing,