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(..) )
13 import Id ( Id(..), GenId, mkPreludeId, mkTemplateLocals )
14 IMPORT_DELOOPER(PrelLoop)
22 import CoreSyn -- quite a bit
23 import IdInfo -- quite a bit
24 import Literal ( mkMachInt )
25 import PrimOp ( PrimOp(..) )
26 import SpecEnv ( SpecEnv(..), nullSpecEnv )
27 import TyVar ( openAlphaTyVar, alphaTyVar, betaTyVar, gammaTyVar )
28 import Unique -- lots of *Keys
37 pcMiscPrelId :: Unique{-IdKey-} -> FAST_STRING -> FAST_STRING -> Type -> IdInfo -> Id
39 pcMiscPrelId key mod name ty info
40 = mkPreludeId (mkBuiltinName key mod name) ty info
43 %************************************************************************
45 \subsection[PrelVals-error-related]{@error@ and friends; @trace@}
47 %************************************************************************
49 GHC randomly injects these into the code.
51 @patError#@ is just a version of @error@ for pattern-matching
52 failures. It knows various ``codes'' which expand to longer
53 strings---this saves space!
55 @absent#@ is a thing we put in for ``absent'' arguments. They jolly
56 well shouldn't be yanked on, but if one is, then you will get a
57 friendly message from @absent#@ (rather a totally random crash).
59 @parError#@ is a special version of @error@ which the compiler does
60 not know to be a bottoming Id. It is used in the @_par_@ and @_seq_@
61 templates, but we don't ever expect to generate code for it.
64 pc_bottoming_Id key mod name ty
65 = pcMiscPrelId key mod name ty bottoming_info
67 bottoming_info = noIdInfo `addInfo` mkBottomStrictnessInfo
68 -- these "bottom" out, no matter what their arguments
71 = pc_bottoming_Id errorIdKey pRELUDE_BUILTIN SLIT("error") errorTy
74 = pc_bottoming_Id u pRELUDE_BUILTIN n errorTy
77 = generic_ERROR_ID patErrorIdKey SLIT("patError#")
79 = generic_ERROR_ID recConErrorIdKey SLIT("recConError#")
81 = generic_ERROR_ID recUpdErrorIdKey SLIT("recUpdError#")
83 = generic_ERROR_ID irrefutPatErrorIdKey SLIT("irrefutPatError#")
84 nON_EXHAUSTIVE_GUARDS_ERROR_ID
85 = generic_ERROR_ID nonExhaustiveGuardsErrorIdKey SLIT("nonExhaustiveGuardsError#")
86 nO_DEFAULT_METHOD_ERROR_ID
87 = generic_ERROR_ID noDefaultMethodErrorIdKey SLIT("noDefaultMethodError#")
88 nO_EXPLICIT_METHOD_ERROR_ID
89 = generic_ERROR_ID nonExplicitMethodErrorIdKey SLIT("noExplicitMethodError#")
92 = pc_bottoming_Id absentErrorIdKey pRELUDE_BUILTIN SLIT("absent#")
93 (mkSigmaTy [alphaTyVar] [] alphaTy)
96 = pcMiscPrelId parErrorIdKey pRELUDE_BUILTIN SLIT("parError#")
97 (mkSigmaTy [alphaTyVar] [] alphaTy) noIdInfo
100 errorTy = mkSigmaTy [openAlphaTyVar] [] (mkFunTys [mkListTy charTy] alphaTy)
103 We want \tr{_trace} (NB: name not in user namespace) to be wired in
104 because we don't want the strictness analyser to get ahold of it,
105 decide that the second argument is strict, evaluate that first (!!),
106 and make a jolly old mess. Having \tr{_trace} wired in also helps when
107 attempting to re-export it---because it's in \tr{PreludeBuiltin}, it
108 won't get an \tr{import} declaration in the interface file, so the
109 importing-subsequently module needs to know it's magic.
112 = pcMiscPrelId traceIdKey pRELUDE_BUILTIN SLIT("_trace") traceTy
113 (noIdInfo `addInfo` pcGenerateSpecs traceIdKey tRACE_ID noIdInfo traceTy)
115 traceTy = mkSigmaTy [alphaTyVar] [] (mkFunTys [mkListTy charTy, alphaTy] alphaTy)
118 %************************************************************************
120 \subsection[PrelVals-Integer-support]{To support @Integer@ and @String@ literals}
122 %************************************************************************
126 = pcMiscPrelId packCStringIdKey{-ToDo:rename-} pRELUDE_PS SLIT("_packStringForC")
127 (mkFunTys [stringTy] byteArrayPrimTy) noIdInfo
129 --------------------------------------------------------------------
132 = pcMiscPrelId unpackCStringIdKey pRELUDE_BUILTIN SLIT("unpackPS#")
133 (mkFunTys [addrPrimTy{-a char *-}] stringTy) noIdInfo
135 -- (FunTy addrPrimTy{-a char *-} stringTy) (noIdInfo `addInfo` mkArityInfo 1)
136 -- but I don't like wired-in IdInfos (WDP)
138 unpackCString2Id -- for cases when a string has a NUL in it
139 = pcMiscPrelId unpackCString2IdKey pRELUDE_BUILTIN SLIT("unpackPS2#")
140 (mkFunTys [addrPrimTy{-a char *-}, intPrimTy{-length-}] stringTy)
143 --------------------------------------------------------------------
144 unpackCStringAppendId
145 = pcMiscPrelId unpackCStringAppendIdKey pRELUDE_BUILTIN SLIT("unpackAppendPS#")
146 (mkFunTys [addrPrimTy{-a "char *" pointer-},stringTy] stringTy)
148 {-LATER:`addInfo_UF` mkMagicUnfolding unpackCStringAppendIdKey-})
149 `addInfo` mkArityInfo 2)
152 = pcMiscPrelId unpackCStringFoldrIdKey pRELUDE_BUILTIN SLIT("unpackFoldrPS#")
153 (mkSigmaTy [alphaTyVar] []
154 (mkFunTys [addrPrimTy{-a "char *" pointer-},
155 mkFunTys [charTy, alphaTy] alphaTy,
159 {-LATER:`addInfo_UF` mkMagicUnfolding unpackCStringFoldrIdKey-})
160 `addInfo` mkArityInfo 3)
163 OK, this is Will's idea: we should have magic values for Integers 0,
164 +1, +2, and -1 (go ahead, fire me):
167 = pcMiscPrelId integerZeroIdKey pRELUDE SLIT("__integer0") integerTy noIdInfo
169 = pcMiscPrelId integerPlusOneIdKey pRELUDE SLIT("__integer1") integerTy noIdInfo
171 = pcMiscPrelId integerPlusTwoIdKey pRELUDE SLIT("__integer2") integerTy noIdInfo
173 = pcMiscPrelId integerMinusOneIdKey pRELUDE SLIT("__integerm1") integerTy noIdInfo
176 %************************************************************************
178 \subsection[PrelVals-parallel]{@seq@ and @par@: for parallel operation (only)}
180 %************************************************************************
183 --------------------------------------------------------------------
184 -- seqId :: "_seq_", used w/ GRIP, etc., is really quite similar to
188 _seq_ = /\ a b -> \ x y -> case x of { _ -> y }
191 _seq_ = /\ a b -> \ x y -> case seq# x y of { _Lift y' -> y' }
194 _seq_ = /\ a b -> \ x::a y::b -> case seq# x of { 0# -> parError#; _ -> y; }
198 seqId = pcMiscPrelId seqIdKey pRELUDE_BUILTIN SLIT("_seq_")
199 (mkSigmaTy [alphaTyVar, betaTyVar] []
200 (mkFunTys [alphaTy, betaTy] betaTy))
201 (noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding seq_template))
211 = mkLam [alphaTyVar, betaTyVar] [x, y] (
212 Case (Prim SeqOp [TyArg alphaTy, VarArg x]) (
214 [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [betaTy])]
215 (BindDefault z (Var y))))
217 --------------------------------------------------------------------
218 -- parId :: "_par_", also used w/ GRIP, etc.
222 par = /\ a b -> \ x y -> case (par# (case x of { _ -> () })) of { _ -> y }
226 _par_ = /\ a b -> \ x y -> case par# x y of { _Lift y' -> y' }
230 _par_ = /\ a b -> \ x::a y::b -> case par# x of { 0# -> parError#; _ -> y; }
233 parId = pcMiscPrelId parIdKey pRELUDE_BUILTIN SLIT("_par_")
234 (mkSigmaTy [alphaTyVar, betaTyVar] []
235 (mkFunTys [alphaTy, betaTy] betaTy))
236 (noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding par_template))
246 = mkLam [alphaTyVar, betaTyVar] [x, y] (
247 Case (Prim ParOp [TyArg alphaTy, VarArg x]) (
249 [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [betaTy])]
250 (BindDefault z (Var y))))
252 -- forkId :: "_fork_", for *required* concurrent threads
254 _fork_ = /\ a b -> \ x::a y::b -> case fork# x of { 0# -> parError#; _ -> y; }
256 forkId = pcMiscPrelId forkIdKey pRELUDE_BUILTIN SLIT("_fork_")
257 (mkSigmaTy [alphaTyVar, betaTyVar] []
258 (mkFunTys [alphaTy, betaTy] betaTy))
259 (noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding fork_template))
269 = mkLam [alphaTyVar, betaTyVar] [x, y] (
270 Case (Prim ForkOp [TyArg alphaTy, VarArg x]) (
272 [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [betaTy])]
273 (BindDefault z (Var y))))
279 parLocalId = pcMiscPrelId parLocalIdKey pRELUDE_BUILTIN SLIT("_parLocal_")
280 (mkSigmaTy [alphaTyVar, betaTyVar] []
281 (mkFunTys [intPrimTy, intPrimTy, intPrimTy, intPrimTy, alphaTy, betaTy] betaTy))
282 (noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding parLocal_template))
284 -- Annotations: w: name, g: gran. info, s: size info, p: par info -- HWL
285 [w, g, s, p, x, y, z]
297 = mkLam [alphaTyVar, betaTyVar] [w, g, s, p, x, y] (
298 Case (Prim ParLocalOp [TyArg alphaTy, TyArg betaTy, VarArg x, VarArg w, VarArg g, VarArg s, VarArg p, VarArg y]) (
300 [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [betaTy])]
301 (BindDefault z (Var y))))
303 parGlobalId = pcMiscPrelId parGlobalIdKey pRELUDE_BUILTIN SLIT("_parGlobal_")
304 (mkSigmaTy [alphaTyVar, betaTyVar] []
305 (mkFunTys [intPrimTy, intPrimTy, intPrimTy, intPrimTy, alphaTy, betaTy] betaTy))
306 (noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding parGlobal_template))
308 -- Annotations: w: name, g: gran. info, s: size info, p: par info -- HWL
309 [w, g, s, p, x, y, z]
321 = mkLam [alphaTyVar, betaTyVar] [w, g, s, p, x, y] (
322 Case (Prim ParGlobalOp [TyArg alphaTy, TyArg betaTy, VarArg x, VarArg w, VarArg g, VarArg s, VarArg p, VarArg y]) (
324 [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [betaTy])]
325 (BindDefault z (Var y))))
328 parAtId = pcMiscPrelId parAtIdKey pRELUDE_BUILTIN SLIT("_parAt_")
329 (mkSigmaTy [alphaTyVar, betaTyVar] []
330 (mkFunTys [intPrimTy, intPrimTy, intPrimTy, intPrimTy,
331 alphaTy, betaTy, gammaTy] gammaTy))
332 (noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding parAt_template))
334 -- Annotations: w: name, g: gran. info, s: size info, p: par info -- HWL
335 [w, g, s, p, v, x, y, z]
348 = mkLam [alphaTyVar, betaTyVar, gammaTyVar] [w, g, s, p, v, x, y] (
349 Case (Prim ParAtOp [TyArg alphaTy, TyArg betaTy, TyArg gammaTy, VarArg x, VarArg v, VarArg w, VarArg g, VarArg s, VarArg p, VarArg y]) (
351 [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [betaTy])]
352 (BindDefault z (Var y))))
354 parAtAbsId = pcMiscPrelId parAtAbsIdKey pRELUDE_BUILTIN SLIT("_parAtAbs_")
355 (mkSigmaTy [alphaTyVar, betaTyVar] []
356 (mkFunTys [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, alphaTy, betaTy] betaTy))
357 (noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding parAtAbs_template))
359 -- Annotations: w: name, g: gran. info, s: size info, p: par info -- HWL
360 [w, g, s, p, v, x, y, z]
373 = mkLam [alphaTyVar, betaTyVar] [w, g, s, p, v, x, y] (
374 Case (Prim ParAtAbsOp [TyArg alphaTy, TyArg betaTy, VarArg x, VarArg v, VarArg w, VarArg g, VarArg s, VarArg p, VarArg y]) (
376 [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [betaTy])]
377 (BindDefault z (Var y))))
379 parAtRelId = pcMiscPrelId parAtRelIdKey pRELUDE_BUILTIN SLIT("_parAtRel_")
380 (mkSigmaTy [alphaTyVar, betaTyVar] []
381 (mkFunTys [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, alphaTy, betaTy] betaTy))
382 (noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding parAtRel_template))
384 -- Annotations: w: name, g: gran. info, s: size info, p: par info -- HWL
385 [w, g, s, p, v, x, y, z]
398 = mkLam [alphaTyVar, betaTyVar] [w, g, s, p, v, x, y] (
399 Case (Prim ParAtRelOp [TyArg alphaTy, TyArg betaTy, VarArg x, VarArg v, VarArg w, VarArg g, VarArg s, VarArg p, VarArg y]) (
401 [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [betaTy])]
402 (BindDefault z (Var y))))
404 parAtForNowId = pcMiscPrelId parAtForNowIdKey pRELUDE_BUILTIN SLIT("_parAtForNow_")
405 (mkSigmaTy [alphaTyVar, betaTyVar] []
406 (mkFunTys [intPrimTy, intPrimTy, intPrimTy, intPrimTy,
407 alphaTy, betaTy, gammaTy] gammaTy))
408 (noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding parAtForNow_template))
410 -- Annotations: w: name, g: gran. info, s: size info, p: par info -- HWL
411 [w, g, s, p, v, x, y, z]
424 = mkLam [alphaTyVar, betaTyVar, gammaTyVar] [w, g, s, p, v, x, y] (
425 Case (Prim ParAtForNowOp [TyArg alphaTy, TyArg betaTy, TyArg gammaTy, VarArg x, VarArg v, VarArg w, VarArg g, VarArg s, VarArg p, VarArg y]) (
427 [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [betaTy])]
428 (BindDefault z (Var y))))
430 -- copyable and noFollow are currently merely hooks: they are translated into
431 -- calls to the macros COPYABLE and NOFOLLOW -- HWL
433 copyableId = pcMiscPrelId copyableIdKey pRELUDE_BUILTIN SLIT("_copyable_")
434 (mkSigmaTy [alphaTyVar] []
436 (noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding copyable_template))
438 -- Annotations: x: closure that's tagged to by copyable
446 = mkLam [alphaTyVar] [x] ( Prim CopyableOp [TyArg alphaTy, VarArg x] )
448 noFollowId = pcMiscPrelId noFollowIdKey pRELUDE_BUILTIN SLIT("_noFollow_")
449 (mkSigmaTy [alphaTyVar] []
451 (noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding noFollow_template))
453 -- Annotations: x: closure that's tagged to not follow
461 = mkLam [alphaTyVar] [x] ( Prim NoFollowOp [TyArg alphaTy, VarArg x] )
464 %************************************************************************
466 \subsection[PrelVals-deriving]{Values known about mainly for doing derived instance decls}
468 %************************************************************************
470 map :: (a -> b) -> [a] -> [b]
471 -- this is up in the here-because-of-unfolding list
473 --??showChar :: Char -> ShowS
474 showSpace :: ShowS -- non-std: == "showChar ' '"
475 showString :: String -> ShowS
476 showParen :: Bool -> ShowS -> ShowS
478 (++) :: [a] -> [a] -> [a]
479 readParen :: Bool -> ReadS a -> ReadS a
482 %************************************************************************
484 \subsection[PrelVals-void]{@void@: Magic value of type @Void@}
486 %************************************************************************
489 voidId = pcMiscPrelId voidIdKey pRELUDE_BUILTIN SLIT("_void") voidTy noIdInfo
492 %************************************************************************
494 \subsection[PrelVals-runST]{@_runST@: Magic start-state-transformer function}
496 %************************************************************************
498 @_runST@ has a non-Haskell-able type:
500 -- _runST :: forall a. (forall s. _ST s a) -> a
501 -- which is to say ::
502 -- forall a. (forall s. (_State s -> (a, _State s))) -> a
504 _runST a m = case m _RealWorld (S# _RealWorld realWorld#) of
505 (r :: a, wild :: _State _RealWorld) -> r
507 We unfold always, just for simplicity:
510 = pcMiscPrelId runSTIdKey pRELUDE_BUILTIN SLIT("_runST") run_ST_ty id_info
515 st_ty a = mkSigmaTy [s_tv] [] (mkStateTransformerTy s a)
518 = mkSigmaTy [alphaTyVar] [] (mkFunTys [st_ty alphaTy] alphaTy)
519 -- NB: rank-2 polymorphism! (forall inside the st_ty...)
523 `addInfo` mkArityInfo 1
524 `addInfo` mkStrictnessInfo [WwStrict] Nothing
525 `addInfo` mkArgUsageInfo [ArgUsage 1]
526 -- ABSOLUTELY NO UNFOLDING, e.g.: (mkUnfolding EssentialUnfolding run_ST_template)
532 {-t-} realWorldStateTy,
534 {-_-} realWorldStateTy
538 = mkLam [alphaTyVar] [m] (
539 Let (NonRec t (Con stateDataCon [TyArg realWorldTy, VarArg realWorldPrimId])) (
540 Case (App (mkTyApp (Var m) [realWorldTy]) (VarArg t)) (
542 [(mkTupleCon 2, [r, wild], Var r)]
547 SLPJ 95/04: Why @_runST@ must not have an unfolding; consider:
551 (a, s') = newArray# 100 [] s
552 (_, s'') = fill_in_array_or_something a x s'
556 If we inline @_runST@, we'll get:
559 (a, s') = newArray# 100 [] realWorld#{-NB-}
560 (_, s'') = fill_in_array_or_something a x s'
564 And now the @newArray#@ binding can be floated to become a CAF, which
565 is totally and utterly wrong:
568 (a, s') = newArray# 100 [] realWorld#{-NB-} -- YIKES!!!
571 let (_, s'') = fill_in_array_or_something a x s' in
574 All calls to @f@ will share a {\em single} array! End SLPJ 95/04.
576 @realWorld#@ used to be a magic literal, \tr{void#}. If things get
577 nasty as-is, change it back to a literal (@Literal@).
580 = pcMiscPrelId realWorldPrimIdKey pRELUDE_BUILTIN SLIT("realWorld#")
585 %************************************************************************
587 \subsection[PrelVals-foldr-build]{Values known about for ``foldr/build''}
589 %************************************************************************
593 = pcMiscPrelId buildIdKey pRELUDE_BUILTIN SLIT("_build") buildTy
595 {-LATER:`addInfo_UF` mkMagicUnfolding buildIdKey-})
596 `addInfo` mkStrictnessInfo [WwStrict] Nothing)
597 `addInfo` mkArgUsageInfo [ArgUsage 2])
598 `addInfo` pcGenerateSpecs buildIdKey buildId noIdInfo{-ToDo-} buildTy)
599 -- cheating, but since _build never actually exists ...
601 -- The type of this strange object is:
602 -- \/ a . (\/ b . (a -> b -> b) -> b -> b) -> [a]
604 buildTy = mkSigmaTy [alphaTyVar] [] (mkFunTys [build_ty] (mkListTy alphaTy))
606 build_ty = mkSigmaTy [betaTyVar] []
607 (mkFunTys [mkFunTys [alphaTy, betaTy] betaTy, betaTy] betaTy)
610 @mkBuild@ is sugar for building a build!
612 @mkbuild ty tv c n e@ $Rightarrow$ @build ty (/\ tv -> \ c n -> e)@
613 @ty@ is the type of the list.
614 @tv@ is always a new type variable.
615 @c,n@ are Id's for the abstract cons and nil, @g@ for let binding the argument argument.
618 v :: (\/ b . (a -> b -> b) -> b -> b) -> [a]
619 -- \/ a . (\/ b . (a -> b -> b) -> b -> b) -> [a]
620 @e@ is the object right inside the @build@
628 -> CoreExpr -- template
629 -> CoreExpr -- template
631 mkBuild ty tv c n g expr
632 = Let (NonRec g (mkLam [tv] [c,n] expr))
633 (App (mkTyApp (Var buildId) [ty]) (VarArg g))
638 = pcMiscPrelId augmentIdKey pRELUDE_BUILTIN SLIT("_augment") augmentTy
640 {-LATER:`addInfo_UF` mkMagicUnfolding augmentIdKey-})
641 `addInfo` mkStrictnessInfo [WwStrict,WwLazy False] Nothing)
642 `addInfo` mkArgUsageInfo [ArgUsage 2,UnknownArgUsage])
643 -- cheating, but since _augment never actually exists ...
645 -- The type of this strange object is:
646 -- \/ a . (\/ b . (a -> b -> b) -> b -> b) -> [a] -> [a]
648 augmentTy = mkSigmaTy [alphaTyVar] [] (mkFunTys [aug_ty, mkListTy alphaTy] (mkListTy alphaTy))
650 aug_ty = mkSigmaTy [betaTyVar] []
651 (mkFunTys [mkFunTys [alphaTy, betaTy] betaTy, betaTy] betaTy)
655 foldrId = pcMiscPrelId foldrIdKey pRELUDE_FB{-not "List"-} SLIT("foldr")
659 mkSigmaTy [alphaTyVar, betaTyVar] []
660 (mkFunTys [mkFunTys [alphaTy, betaTy] betaTy, betaTy, mkListTy alphaTy] betaTy)
662 idInfo = (((((noIdInfo
663 {-LATER:`addInfo_UF` mkMagicUnfolding foldrIdKey-})
664 `addInfo` mkStrictnessInfo [WwLazy False,WwLazy False,WwStrict] Nothing)
665 `addInfo` mkArityInfo 3)
666 `addInfo` mkUpdateInfo [2,2,1])
667 `addInfo` pcGenerateSpecs foldrIdKey foldrId noIdInfo{-ToDo-} foldrTy)
669 foldlId = pcMiscPrelId foldlIdKey pRELUDE_FB{-not "List"-} SLIT("foldl")
673 mkSigmaTy [alphaTyVar, betaTyVar] []
674 (mkFunTys [mkFunTys [alphaTy, betaTy] alphaTy, alphaTy, mkListTy betaTy] alphaTy)
676 idInfo = (((((noIdInfo
677 {-LATER:`addInfo_UF` mkMagicUnfolding foldlIdKey-})
678 `addInfo` mkStrictnessInfo [WwLazy False,WwLazy False,WwStrict] Nothing)
679 `addInfo` mkArityInfo 3)
680 `addInfo` mkUpdateInfo [2,2,1])
681 `addInfo` pcGenerateSpecs foldlIdKey foldlId noIdInfo{-ToDo-} foldlTy)
683 -- A bit of magic goes no here. We translate appendId into ++,
684 -- you have to be carefull when you actually compile append:
685 -- xs ++ ys = augment (\ c n -> foldr c n xs) ys
686 -- {- unfold augment -}
688 -- {- fold foldr to append -}
689 -- = ys `appendId` xs
690 -- = ys ++ xs -- ugg!
691 -- *BUT* you want (++) and not _append in your interfaces.
693 -- So you have to turn *off* unfolding of foldr inside FoldrBuild.hs inside
698 = pcMiscPrelId appendIdKey pRELUDE_LIST SLIT("++") appendTy idInfo
701 (mkSigmaTy [alphaTyVar] []
702 (mkFunTys [mkListTy alphaTy, mkListTy alphaTy] (mkListTy alphaTy)))
704 `addInfo` mkStrictnessInfo [WwStrict,WwLazy False] Nothing)
705 `addInfo` mkArityInfo 2)
706 `addInfo` mkUpdateInfo [1,2])
709 %************************************************************************
711 \subsection[PrelUtils-specialisations]{Specialisations for builtin values}
713 %************************************************************************
715 The specialisations which exist for the builtin values must be recorded in
718 NOTE: THE USES OF THE pcGenerate... FUNCTIONS MUST CORRESPOND
719 TO THE SPECIALISATIONS DECLARED IN THE PRELUDE !!!
721 HACK: We currently use the same unique for the specialised Ids.
723 The list @specing_types@ determines the types for which specialised
724 versions are created. Note: This should correspond with the
725 types passed to the pre-processor with the -genSPECS arg (see ghc.lprl).
727 ToDo: Create single mkworld definition which is grabbed here and in ghc.lprl
730 pcGenerateSpecs :: Unique -> Id -> IdInfo -> Type -> SpecEnv
731 pcGenerateSpecs key id info ty
736 pc_gen_specs True key id info ty
738 pc_gen_specs is_id key id info ty
739 = mkSpecEnv spec_infos
741 spec_infos = [ let spec_ty = specialiseTy ty spec_tys 0
743 then mkSpecId key {- HACK WARNING: same unique! -}
744 id spec_tys spec_ty info
745 else panic "SpecData:SpecInfo:SpecId"
747 SpecInfo spec_tys (length ctxts) spec_id
748 | spec_tys <- specialisations ]
750 (tyvars, ctxts, _) = splitSigmaTy ty
751 no_tyvars = length tyvars
753 specialisations = if no_tyvars == 0
755 else tail (cross_product no_tyvars specing_types)
757 -- N.B. tail removes fully polymorphic specialisation
759 cross_product 0 tys = []
760 cross_product 1 tys = map (:[]) tys
761 cross_product n tys = concat [map (:cp) tys | cp <- cross_product (n-1) tys]
764 specing_types = [Nothing,