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, 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 ( mkWiredInIdName )
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-} -> Module -> FAST_STRING -> Type -> IdInfo -> Id
39 pcMiscPrelId key mod occ ty info
41 name = mkWiredInIdName key mod occ imp
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 `addStrictnessInfo` mkBottomStrictnessInfo
77 -- these "bottom" out, no matter what their arguments
80 = pc_bottoming_Id errorIdKey iO_BASE SLIT("error") errorTy
83 = pc_bottoming_Id u gHC_ERR 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 gHC_ERR SLIT("absentErr")
102 (mkSigmaTy [openAlphaTyVar] [] openAlphaTy)
105 = pcMiscPrelId parErrorIdKey gHC_ERR SLIT("parError")
106 (mkSigmaTy [openAlphaTyVar] [] openAlphaTy) noIdInfo
108 openAlphaTy = mkTyVarTy openAlphaTyVar
111 errorTy = mkSigmaTy [openAlphaTyVar] [] (mkFunTys [mkListTy charTy] openAlphaTy)
112 -- Notice the openAlphaTyVar. It says that "error" can be applied
113 -- to unboxed as well as boxed types. This is OK because it never
114 -- returns, so the return type is irrelevant.
117 We want \tr{GHCbase.trace} to be wired in
118 because we don't want the strictness analyser to get ahold of it,
119 decide that the second argument is strict, evaluate that first (!!),
120 and make a jolly old mess.
123 = pcMiscPrelId traceIdKey iO_BASE SLIT("trace") traceTy
124 (noIdInfo `addSpecInfo` pcGenerateSpecs traceIdKey tRACE_ID noIdInfo traceTy)
126 traceTy = mkSigmaTy [alphaTyVar] [] (mkFunTys [mkListTy charTy, alphaTy] alphaTy)
129 %************************************************************************
131 \subsection[PrelVals-Integer-support]{To support @Integer@ and @String@ literals}
133 %************************************************************************
137 = pcMiscPrelId packCStringIdKey{-ToDo:rename-} pACKED_STRING SLIT("packCString#")
138 (mkFunTys [stringTy] byteArrayPrimTy) noIdInfo
140 --------------------------------------------------------------------
143 = pcMiscPrelId unpackCStringIdKey pACKED_STRING SLIT("unpackCString#")
144 (mkFunTys [addrPrimTy{-a char *-}] stringTy) noIdInfo
146 -- (FunTy addrPrimTy{-a char *-} stringTy) (noIdInfo `addInfo` exactArity 1)
147 -- but I don't like wired-in IdInfos (WDP)
149 unpackCString2Id -- for cases when a string has a NUL in it
150 = pcMiscPrelId unpackCString2IdKey pACKED_STRING SLIT("unpackCString2#")
151 (mkFunTys [addrPrimTy{-a char *-}, intPrimTy{-length-}] stringTy)
154 --------------------------------------------------------------------
155 unpackCStringAppendId
156 = pcMiscPrelId unpackCStringAppendIdKey pACKED_STRING SLIT("unpackAppendCString#")
157 (mkFunTys [addrPrimTy{-a "char *" pointer-},stringTy] stringTy)
159 {-LATER:`addUnfoldInfo` mkMagicUnfolding unpackCStringAppendIdKey-})
160 `addArityInfo` exactArity 2)
163 = pcMiscPrelId unpackCStringFoldrIdKey pACKED_STRING SLIT("unpackFoldrCString#")
164 (mkSigmaTy [alphaTyVar] []
165 (mkFunTys [addrPrimTy{-a "char *" pointer-},
166 mkFunTys [charTy, alphaTy] alphaTy,
170 {-LATER:`addUnfoldInfo` mkMagicUnfolding unpackCStringFoldrIdKey-})
171 `addArityInfo` exactArity 3)
174 OK, this is Will's idea: we should have magic values for Integers 0,
175 +1, +2, and -1 (go ahead, fire me):
179 = pcMiscPrelId integerZeroIdKey pREL_NUM SLIT("integer_0") integerTy noIdInfo
181 = pcMiscPrelId integerPlusOneIdKey pREL_NUM SLIT("integer_1") integerTy noIdInfo
183 = pcMiscPrelId integerPlusTwoIdKey pREL_NUM SLIT("integer_2") integerTy noIdInfo
185 = pcMiscPrelId integerMinusOneIdKey pREL_NUM SLIT("integer_m1") integerTy noIdInfo
188 %************************************************************************
190 \subsection[PrelVals-parallel]{@seq@ and @par@: for parallel operation (only)}
192 %************************************************************************
196 --------------------------------------------------------------------
197 -- seqId :: "seq", used w/ GRIP, etc., is really quite similar to
201 seq = /\ a b -> \ x y -> case x of { _ -> y }
204 seq = /\ a b -> \ x y -> case seq# x y of { _Lift y' -> y' }
207 seq = /\ a b -> \ x::a y::b -> case seq# x of { 0# -> parError#; _ -> y; }
211 seqId = pcMiscPrelId seqIdKey pRELUDE SLIT("seq")
212 (mkSigmaTy [alphaTyVar, betaTyVar] []
213 (mkFunTys [alphaTy, betaTy] betaTy))
214 (noIdInfo `addUnfoldInfo` (mkUnfolding True seq_template))
224 = mkLam [alphaTyVar, betaTyVar] [x, y] (
225 Case (Prim SeqOp [TyArg alphaTy, VarArg x]) (
227 [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [betaTy])]
228 (BindDefault z (Var y))))
230 --------------------------------------------------------------------
231 -- parId :: "par", also used w/ GRIP, etc.
235 par = /\ a b -> \ x y -> case (par# (case x of { _ -> () })) of { _ -> y }
239 par = /\ a b -> \ x y -> case par# x y of { _Lift y' -> y' }
243 par = /\ a b -> \ x::a y::b -> case par# x of { 0# -> parError#; _ -> y; }
246 parId = pcMiscPrelId parIdKey cONC_BASE SLIT("par")
247 (mkSigmaTy [alphaTyVar, betaTyVar] []
248 (mkFunTys [alphaTy, betaTy] betaTy))
249 (noIdInfo `addUnfoldInfo` (mkUnfolding True par_template))
259 = mkLam [alphaTyVar, betaTyVar] [x, y] (
260 Case (Prim ParOp [TyArg alphaTy, VarArg x]) (
262 [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [betaTy])]
263 (BindDefault z (Var y))))
265 -- forkId :: "fork", for *required* concurrent threads
267 _fork_ = /\ a b -> \ x::a y::b -> case fork# x of { 0# -> parError#; _ -> y; }
269 forkId = pcMiscPrelId forkIdKey cONC_BASE SLIT("fork")
270 (mkSigmaTy [alphaTyVar, betaTyVar] []
271 (mkFunTys [alphaTy, betaTy] betaTy))
272 (noIdInfo `addUnfoldInfo` (mkUnfolding True fork_template))
282 = mkLam [alphaTyVar, betaTyVar] [x, y] (
283 Case (Prim ForkOp [TyArg alphaTy, VarArg x]) (
285 [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [betaTy])]
286 (BindDefault z (Var y))))
293 parLocalId = pcMiscPrelId parLocalIdKey cONC_BASE SLIT("parLocal")
294 (mkSigmaTy [alphaTyVar, betaTyVar] []
295 (mkFunTys [intPrimTy, intPrimTy, intPrimTy, intPrimTy, alphaTy, betaTy] betaTy))
296 (noIdInfo `addUnfoldInfo` (mkUnfolding True parLocal_template))
298 -- Annotations: w: name, g: gran. info, s: size info, p: par info -- HWL
299 [w, g, s, p, x, y, z]
311 = mkLam [alphaTyVar, betaTyVar] [w, g, s, p, x, y] (
312 Case (Prim ParLocalOp [TyArg alphaTy, TyArg betaTy, VarArg x, VarArg w, VarArg g, VarArg s, VarArg p, VarArg y]) (
314 [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [betaTy])]
315 (BindDefault z (Var y))))
317 parGlobalId = pcMiscPrelId parGlobalIdKey cONC_BASE SLIT("parGlobal")
318 (mkSigmaTy [alphaTyVar, betaTyVar] []
319 (mkFunTys [intPrimTy, intPrimTy, intPrimTy, intPrimTy, alphaTy, betaTy] betaTy))
320 (noIdInfo `addUnfoldInfo` (mkUnfolding True parGlobal_template))
322 -- Annotations: w: name, g: gran. info, s: size info, p: par info -- HWL
323 [w, g, s, p, x, y, z]
335 = mkLam [alphaTyVar, betaTyVar] [w, g, s, p, x, y] (
336 Case (Prim ParGlobalOp [TyArg alphaTy, TyArg betaTy, VarArg x, VarArg w, VarArg g, VarArg s, VarArg p, VarArg y]) (
338 [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [betaTy])]
339 (BindDefault z (Var y))))
342 parAtId = pcMiscPrelId parAtIdKey cONC_BASE SLIT("parAt")
343 (mkSigmaTy [alphaTyVar, betaTyVar] []
344 (mkFunTys [intPrimTy, intPrimTy, intPrimTy, intPrimTy,
345 alphaTy, betaTy, gammaTy] gammaTy))
346 (noIdInfo `addUnfoldInfo` (mkUnfolding True parAt_template))
348 -- Annotations: w: name, g: gran. info, s: size info, p: par info -- HWL
349 [w, g, s, p, v, x, y, z]
362 = mkLam [alphaTyVar, betaTyVar, gammaTyVar] [w, g, s, p, v, x, y] (
363 Case (Prim ParAtOp [TyArg alphaTy, TyArg betaTy, TyArg gammaTy, VarArg x, VarArg v, VarArg w, VarArg g, VarArg s, VarArg p, VarArg y]) (
365 [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [gammaTy])]
366 (BindDefault z (Var y))))
368 parAtAbsId = pcMiscPrelId parAtAbsIdKey cONC_BASE SLIT("parAtAbs")
369 (mkSigmaTy [alphaTyVar, betaTyVar] []
370 (mkFunTys [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, alphaTy, betaTy] betaTy))
371 (noIdInfo `addUnfoldInfo` (mkUnfolding True parAtAbs_template))
373 -- Annotations: w: name, g: gran. info, s: size info, p: par info -- HWL
374 [w, g, s, p, v, x, y, z]
387 = mkLam [alphaTyVar, betaTyVar] [w, g, s, p, v, x, y] (
388 Case (Prim ParAtAbsOp [TyArg alphaTy, TyArg betaTy, VarArg x, VarArg v, VarArg w, VarArg g, VarArg s, VarArg p, VarArg y]) (
390 [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [betaTy])]
391 (BindDefault z (Var y))))
393 parAtRelId = pcMiscPrelId parAtRelIdKey cONC_BASE SLIT("parAtRel")
394 (mkSigmaTy [alphaTyVar, betaTyVar] []
395 (mkFunTys [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, alphaTy, betaTy] betaTy))
396 (noIdInfo `addUnfoldInfo` (mkUnfolding True parAtRel_template))
398 -- Annotations: w: name, g: gran. info, s: size info, p: par info -- HWL
399 [w, g, s, p, v, x, y, z]
412 = mkLam [alphaTyVar, betaTyVar] [w, g, s, p, v, x, y] (
413 Case (Prim ParAtRelOp [TyArg alphaTy, TyArg betaTy, VarArg x, VarArg v, VarArg w, VarArg g, VarArg s, VarArg p, VarArg y]) (
415 [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [betaTy])]
416 (BindDefault z (Var y))))
418 parAtForNowId = pcMiscPrelId parAtForNowIdKey cONC_BASE SLIT("parAtForNow")
419 (mkSigmaTy [alphaTyVar, betaTyVar] []
420 (mkFunTys [intPrimTy, intPrimTy, intPrimTy, intPrimTy,
421 alphaTy, betaTy, gammaTy] gammaTy))
422 (noIdInfo `addUnfoldInfo` (mkUnfolding True parAtForNow_template))
424 -- Annotations: w: name, g: gran. info, s: size info, p: par info -- HWL
425 [w, g, s, p, v, x, y, z]
438 = mkLam [alphaTyVar, betaTyVar, gammaTyVar] [w, g, s, p, v, x, y] (
439 Case (Prim ParAtForNowOp [TyArg alphaTy, TyArg betaTy, TyArg gammaTy, VarArg x, VarArg v, VarArg w, VarArg g, VarArg s, VarArg p, VarArg y]) (
441 [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [gammaTy])]
442 (BindDefault z (Var y))))
444 -- copyable and noFollow are currently merely hooks: they are translated into
445 -- calls to the macros COPYABLE and NOFOLLOW -- HWL
447 copyableId = pcMiscPrelId copyableIdKey cONC_BASE SLIT("copyable")
448 (mkSigmaTy [alphaTyVar] []
450 (noIdInfo `addUnfoldInfo` (mkUnfolding True copyable_template))
452 -- Annotations: x: closure that's tagged to by copyable
460 = mkLam [alphaTyVar] [x] ( Prim CopyableOp [TyArg alphaTy, VarArg x] )
462 noFollowId = pcMiscPrelId noFollowIdKey cONC_BASE SLIT("noFollow")
463 (mkSigmaTy [alphaTyVar] []
465 (noIdInfo `addUnfoldInfo` (mkUnfolding True noFollow_template))
467 -- Annotations: x: closure that's tagged to not follow
475 = mkLam [alphaTyVar] [x] ( Prim NoFollowOp [TyArg alphaTy, VarArg x] )
479 %************************************************************************
481 \subsection[PrelVals-runST]{@runST@: Magic start-state-transformer function}
483 %************************************************************************
485 @runST@ has a non-Haskell-able type:
487 -- runST :: forall a. (forall s. _ST s a) -> a
488 -- which is to say ::
489 -- forall a. (forall s. (_State s -> (a, _State s))) -> a
491 runST a m = case m _RealWorld (S# _RealWorld realWorld#) of
492 (r :: a, wild :: _State _RealWorld) -> r
495 We unfold always, just for simplicity:
498 = pcMiscPrelId runSTIdKey sT_BASE SLIT("runST") run_ST_ty id_info
503 st_ty a = mkSigmaTy [s_tv] [] (mkStateTransformerTy s a)
506 = mkSigmaTy [alphaTyVar] [] (mkFunTys [st_ty alphaTy] alphaTy)
507 -- NB: rank-2 polymorphism! (forall inside the st_ty...)
511 `addArityInfo` exactArity 1
512 `addStrictnessInfo` mkStrictnessInfo [WwStrict] Nothing
513 `addArgUsageInfo` mkArgUsageInfo [ArgUsage 1]
514 -- ABSOLUTELY NO UNFOLDING, e.g.: (mkUnfolding True run_ST_template)
520 {-t-} realWorldStateTy,
522 {-_-} realWorldStateTy
526 = mkLam [alphaTyVar] [m] (
527 Let (NonRec t (Con stateDataCon [TyArg realWorldTy, VarArg realWorldPrimId])) (
528 Case (App (mkTyApp (Var m) [realWorldTy]) (VarArg t)) (
530 [(pairDataCon, [r, wild], Var r)]
535 SLPJ 95/04: Why @runST@ must not have an unfolding; consider:
539 (a, s') = newArray# 100 [] s
540 (_, s'') = fill_in_array_or_something a x s'
544 If we inline @runST@, we'll get:
547 (a, s') = newArray# 100 [] realWorld#{-NB-}
548 (_, s'') = fill_in_array_or_something a x s'
552 And now the @newArray#@ binding can be floated to become a CAF, which
553 is totally and utterly wrong:
556 (a, s') = newArray# 100 [] realWorld#{-NB-} -- YIKES!!!
559 let (_, s'') = fill_in_array_or_something a x s' in
562 All calls to @f@ will share a {\em single} array! End SLPJ 95/04.
564 @realWorld#@ used to be a magic literal, \tr{void#}. If things get
565 nasty as-is, change it back to a literal (@Literal@).
568 = pcMiscPrelId realWorldPrimIdKey gHC__ SLIT("realWorld#")
574 voidId = pc_bottoming_Id voidIdKey gHC__ SLIT("void") voidTy
577 %************************************************************************
579 \subsection[PrelVals-foldr-build]{Values known about for ``foldr/build''}
581 %************************************************************************
585 = pcMiscPrelId buildIdKey gHC_ERR SLIT("build") buildTy
587 {-LATER:`addUnfoldInfo` mkMagicUnfolding buildIdKey-})
588 `addStrictnessInfo` mkStrictnessInfo [WwStrict] Nothing)
589 `addArgUsageInfo` mkArgUsageInfo [ArgUsage 2])
590 `addSpecInfo` pcGenerateSpecs buildIdKey buildId noIdInfo{-ToDo-} buildTy)
591 -- cheating, but since _build never actually exists ...
593 -- The type of this strange object is:
594 -- \/ a . (\/ b . (a -> b -> b) -> b -> b) -> [a]
596 buildTy = mkSigmaTy [alphaTyVar] [] (mkFunTys [build_ty] (mkListTy alphaTy))
598 build_ty = mkSigmaTy [betaTyVar] []
599 (mkFunTys [mkFunTys [alphaTy, betaTy] betaTy, betaTy] betaTy)
602 @mkBuild@ is sugar for building a build!
604 @mkbuild ty tv c n e@ $Rightarrow$ @build ty (/\ tv -> \ c n -> e)@
605 @ty@ is the type of the list.
606 @tv@ is always a new type variable.
607 @c,n@ are Id's for the abstract cons and nil, @g@ for let binding the argument argument.
610 v :: (\/ b . (a -> b -> b) -> b -> b) -> [a]
611 -- \/ a . (\/ b . (a -> b -> b) -> b -> b) -> [a]
612 @e@ is the object right inside the @build@
620 -> CoreExpr -- template
621 -> CoreExpr -- template
623 mkBuild ty tv c n g expr
624 = Let (NonRec g (mkLam [tv] [c,n] expr))
625 (App (mkTyApp (Var buildId) [ty]) (VarArg g))
630 = pcMiscPrelId augmentIdKey gHC_ERR SLIT("augment") augmentTy
632 {-LATER:`addUnfoldInfo` mkMagicUnfolding augmentIdKey-})
633 `addStrictnessInfo` mkStrictnessInfo [WwStrict,WwLazy False] Nothing)
634 `addArgUsageInfo` mkArgUsageInfo [ArgUsage 2,UnknownArgUsage])
635 -- cheating, but since _augment never actually exists ...
637 -- The type of this strange object is:
638 -- \/ a . (\/ b . (a -> b -> b) -> b -> b) -> [a] -> [a]
640 augmentTy = mkSigmaTy [alphaTyVar] [] (mkFunTys [aug_ty, mkListTy alphaTy] (mkListTy alphaTy))
642 aug_ty = mkSigmaTy [betaTyVar] []
643 (mkFunTys [mkFunTys [alphaTy, betaTy] betaTy, betaTy] betaTy)
647 foldrId = pcMiscPrelId foldrIdKey pREL_BASE SLIT("foldr")
651 mkSigmaTy [alphaTyVar, betaTyVar] []
652 (mkFunTys [mkFunTys [alphaTy, betaTy] betaTy, betaTy, mkListTy alphaTy] betaTy)
654 idInfo = (((((noIdInfo
655 {-LATER:`addUnfoldInfo` mkMagicUnfolding foldrIdKey-})
656 `addStrictnessInfo` mkStrictnessInfo [WwLazy False,WwLazy False,WwStrict] Nothing)
657 `addArityInfo` exactArity 3)
658 `addUpdateInfo` mkUpdateInfo [2,2,1])
659 `addSpecInfo` pcGenerateSpecs foldrIdKey foldrId noIdInfo{-ToDo-} foldrTy)
661 foldlId = pcMiscPrelId foldlIdKey pREL_LIST SLIT("foldl")
665 mkSigmaTy [alphaTyVar, betaTyVar] []
666 (mkFunTys [mkFunTys [alphaTy, betaTy] alphaTy, alphaTy, mkListTy betaTy] alphaTy)
668 idInfo = (((((noIdInfo
669 {-LATER:`addUnfoldInfo` mkMagicUnfolding foldlIdKey-})
670 `addStrictnessInfo` mkStrictnessInfo [WwLazy False,WwLazy False,WwStrict] Nothing)
671 `addArityInfo` exactArity 3)
672 `addUpdateInfo` mkUpdateInfo [2,2,1])
673 `addSpecInfo` pcGenerateSpecs foldlIdKey foldlId noIdInfo{-ToDo-} foldlTy)
675 -- A bit of magic goes no here. We translate appendId into ++,
676 -- you have to be carefull when you actually compile append:
677 -- xs ++ ys = augment (\ c n -> foldr c n xs) ys
678 -- {- unfold augment -}
680 -- {- fold foldr to append -}
681 -- = ys `appendId` xs
682 -- = ys ++ xs -- ugg!
683 -- *BUT* you want (++) and not _append in your interfaces.
685 -- So you have to turn *off* unfolding of foldr inside FoldrBuild.hs inside
688 {- OLD: doesn't apply with 1.3
690 = pcMiscPrelId appendIdKey mONAD SLIT("++") appendTy idInfo
693 (mkSigmaTy [alphaTyVar] []
694 (mkFunTys [mkListTy alphaTy, mkListTy alphaTy] (mkListTy alphaTy)))
696 `addStrictnessInfo` mkStrictnessInfo [WwStrict,WwLazy False] Nothing)
697 `addArityInfo` exactArity 2)
698 `addUpdateInfo` mkUpdateInfo [1,2])
702 %************************************************************************
704 \subsection[PrelUtils-specialisations]{Specialisations for builtin values}
706 %************************************************************************
708 The specialisations which exist for the builtin values must be recorded in
711 NOTE: THE USES OF THE pcGenerate... FUNCTIONS MUST CORRESPOND
712 TO THE SPECIALISATIONS DECLARED IN THE PRELUDE !!!
714 HACK: We currently use the same unique for the specialised Ids.
716 The list @specing_types@ determines the types for which specialised
717 versions are created. Note: This should correspond with the
718 types passed to the pre-processor with the -genSPECS arg (see ghc.lprl).
720 ToDo: Create single mkworld definition which is grabbed here and in ghc.lprl
723 pcGenerateSpecs :: Unique -> Id -> IdInfo -> Type -> SpecEnv
724 pcGenerateSpecs key id info ty
729 pc_gen_specs True key id info ty
731 pc_gen_specs is_id key id info ty
732 = mkSpecEnv spec_infos
734 spec_infos = [ let spec_ty = specialiseTy ty spec_tys 0
736 then mkSpecId key {- HACK WARNING: same unique! -}
737 id spec_tys spec_ty info
738 else panic "SpecData:SpecInfo:SpecId"
740 SpecInfo spec_tys (length ctxts) spec_id
741 | spec_tys <- specialisations ]
743 (tyvars, ctxts, _) = splitSigmaTy ty
744 no_tyvars = length tyvars
746 specialisations = if no_tyvars == 0
748 else tail (cross_product no_tyvars specing_types)
750 -- N.B. tail removes fully polymorphic specialisation
752 cross_product 0 tys = []
753 cross_product 1 tys = map (:[]) tys
754 cross_product n tys = concat [map (:cp) tys | cp <- cross_product (n-1) tys]
757 specing_types = [Nothing,