2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
4 \section[PrelVals]{Prelude values the compiler ``knows about''}
7 #include "HsVersions.h"
12 #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201
13 IMPORT_DELOOPER(IdLoop) ( UnfoldingGuidance(..), mkUnfolding, nullSpecEnv, SpecEnv )
15 import {-# SOURCE #-} CoreUnfold ( UnfoldingGuidance(..), mkUnfolding )
16 import {-# SOURCE #-} SpecEnv ( SpecEnv, nullSpecEnv )
19 #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201
20 IMPORT_DELOOPER(PrelLoop)
23 import Id ( SYN_IE(Id), GenId, mkImported, mkTemplateLocals )
31 import CmdLineOpts ( maybe_CompilingGhcInternals )
32 import CoreSyn -- quite a bit
33 import IdInfo -- quite a bit
34 import Literal ( mkMachInt )
35 import Name ( mkWiredInIdName, SYN_IE(Module) )
37 import PrimOp ( PrimOp(..) )
38 #if __GLASGOW_HASKELL__ >= 202
41 import Type ( mkTyVarTy )
43 import TyVar ( openAlphaTyVar, alphaTyVar, betaTyVar, gammaTyVar, SYN_IE(TyVar) )
44 import Unique -- lots of *Keys
51 mk_inline_unfolding = mkUnfolding IWantToBeINLINEd
53 pcMiscPrelId :: Unique{-IdKey-} -> Module -> FAST_STRING -> Type -> IdInfo -> Id
55 pcMiscPrelId key mod occ ty info
57 name = mkWiredInIdName key mod occ imp
58 imp = mkImported name ty info -- the usual case...
61 -- We lie and say the thing is imported; otherwise, we get into
62 -- a mess with dependency analysis; e.g., core2stg may heave in
63 -- random calls to GHCbase.unpackPS__. If GHCbase is the module
64 -- being compiled, then it's just a matter of luck if the definition
65 -- will be in "the right place" to be in scope.
68 %************************************************************************
70 \subsection[PrelVals-error-related]{@error@ and friends; @trace@}
72 %************************************************************************
74 GHC randomly injects these into the code.
76 @patError@ is just a version of @error@ for pattern-matching
77 failures. It knows various ``codes'' which expand to longer
78 strings---this saves space!
80 @absentErr@ is a thing we put in for ``absent'' arguments. They jolly
81 well shouldn't be yanked on, but if one is, then you will get a
82 friendly message from @absentErr@ (rather a totally random crash).
84 @parError@ is a special version of @error@ which the compiler does
85 not know to be a bottoming Id. It is used in the @_par_@ and @_seq_@
86 templates, but we don't ever expect to generate code for it.
89 pc_bottoming_Id key mod name ty
90 = pcMiscPrelId key mod name ty bottoming_info
92 bottoming_info = noIdInfo `addStrictnessInfo` mkBottomStrictnessInfo
93 -- these "bottom" out, no matter what their arguments
96 = pc_bottoming_Id errorIdKey iO_BASE SLIT("error") errorTy
99 = pc_bottoming_Id u gHC_ERR n errorTy
102 = generic_ERROR_ID patErrorIdKey SLIT("patError")
104 = generic_ERROR_ID recConErrorIdKey SLIT("recConError")
106 = generic_ERROR_ID recUpdErrorIdKey SLIT("recUpdError")
108 = generic_ERROR_ID irrefutPatErrorIdKey SLIT("irrefutPatError")
109 nON_EXHAUSTIVE_GUARDS_ERROR_ID
110 = generic_ERROR_ID nonExhaustiveGuardsErrorIdKey SLIT("nonExhaustiveGuardsError")
111 nO_DEFAULT_METHOD_ERROR_ID
112 = generic_ERROR_ID noDefaultMethodErrorIdKey SLIT("noDefaultMethodError")
113 nO_EXPLICIT_METHOD_ERROR_ID
114 = generic_ERROR_ID nonExplicitMethodErrorIdKey SLIT("noExplicitMethodError")
117 = pc_bottoming_Id absentErrorIdKey gHC_ERR SLIT("absentErr")
118 (mkSigmaTy [openAlphaTyVar] [] openAlphaTy)
121 = pcMiscPrelId parErrorIdKey gHC_ERR SLIT("parError")
122 (mkSigmaTy [openAlphaTyVar] [] openAlphaTy) noIdInfo
124 openAlphaTy = mkTyVarTy openAlphaTyVar
127 errorTy = mkSigmaTy [openAlphaTyVar] [] (mkFunTys [mkListTy charTy] openAlphaTy)
128 -- Notice the openAlphaTyVar. It says that "error" can be applied
129 -- to unboxed as well as boxed types. This is OK because it never
130 -- returns, so the return type is irrelevant.
133 We want \tr{GHCbase.trace} to be wired in
134 because we don't want the strictness analyser to get ahold of it,
135 decide that the second argument is strict, evaluate that first (!!),
136 and make a jolly old mess.
139 = pcMiscPrelId traceIdKey iO_BASE SLIT("trace") traceTy
140 (noIdInfo `addSpecInfo` pcGenerateSpecs traceIdKey tRACE_ID noIdInfo traceTy)
142 traceTy = mkSigmaTy [alphaTyVar] [] (mkFunTys [mkListTy charTy, alphaTy] alphaTy)
145 %************************************************************************
147 \subsection[PrelVals-Integer-support]{To support @Integer@ and @String@ literals}
149 %************************************************************************
153 = pcMiscPrelId packCStringIdKey{-ToDo:rename-} pACKED_STRING SLIT("packCString#")
154 (mkFunTys [stringTy] byteArrayPrimTy) noIdInfo
156 --------------------------------------------------------------------
159 = pcMiscPrelId unpackCStringIdKey pACKED_STRING SLIT("unpackCString#")
160 (mkFunTys [addrPrimTy{-a char *-}] stringTy) noIdInfo
162 -- (FunTy addrPrimTy{-a char *-} stringTy) (noIdInfo `addInfo` exactArity 1)
163 -- but I don't like wired-in IdInfos (WDP)
165 unpackCString2Id -- for cases when a string has a NUL in it
166 = pcMiscPrelId unpackCString2IdKey pACKED_STRING SLIT("unpackNBytes#")
167 (mkFunTys [addrPrimTy{-a char *-}, intPrimTy{-length-}] stringTy)
170 --------------------------------------------------------------------
171 unpackCStringAppendId
172 = pcMiscPrelId unpackCStringAppendIdKey pACKED_STRING SLIT("unpackAppendCString#")
173 (mkFunTys [addrPrimTy{-a "char *" pointer-},stringTy] stringTy)
175 {-LATER:`addUnfoldInfo` mkMagicUnfolding unpackCStringAppendIdKey-})
176 `addArityInfo` exactArity 2)
179 = pcMiscPrelId unpackCStringFoldrIdKey pACKED_STRING SLIT("unpackFoldrCString#")
180 (mkSigmaTy [alphaTyVar] []
181 (mkFunTys [addrPrimTy{-a "char *" pointer-},
182 mkFunTys [charTy, alphaTy] alphaTy,
186 {-LATER:`addUnfoldInfo` mkMagicUnfolding unpackCStringFoldrIdKey-})
187 `addArityInfo` exactArity 3)
190 OK, this is Will's idea: we should have magic values for Integers 0,
191 +1, +2, and -1 (go ahead, fire me):
195 = pcMiscPrelId integerZeroIdKey pREL_NUM SLIT("integer_0") integerTy noIdInfo
197 = pcMiscPrelId integerPlusOneIdKey pREL_NUM SLIT("integer_1") integerTy noIdInfo
199 = pcMiscPrelId integerPlusTwoIdKey pREL_NUM SLIT("integer_2") integerTy noIdInfo
201 = pcMiscPrelId integerMinusOneIdKey pREL_NUM SLIT("integer_m1") integerTy noIdInfo
204 %************************************************************************
206 \subsection[PrelVals-parallel]{@seq@ and @par@: for parallel operation (only)}
208 %************************************************************************
212 --------------------------------------------------------------------
213 -- seqId :: "seq", used w/ GRIP, etc., is really quite similar to
217 seq = /\ a b -> \ x y -> case x of { _ -> y }
220 seq = /\ a b -> \ x y -> case seq# x y of { _Lift y' -> y' }
223 seq = /\ a b -> \ x::a y::b -> case seq# x of { 0# -> parError#; _ -> y; }
227 seqId = pcMiscPrelId seqIdKey pRELUDE SLIT("seq")
228 (mkSigmaTy [alphaTyVar, betaTyVar] []
229 (mkFunTys [alphaTy, betaTy] betaTy))
230 (noIdInfo `addUnfoldInfo` (mk_inline_unfolding seq_template))
240 = mkLam [alphaTyVar, betaTyVar] [x, y] (
241 Case (Prim SeqOp [TyArg alphaTy, VarArg x]) (
243 [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [betaTy])]
244 (BindDefault z (Var y))))
246 --------------------------------------------------------------------
247 -- parId :: "par", also used w/ GRIP, etc.
251 par = /\ a b -> \ x y -> case (par# (case x of { _ -> () })) of { _ -> y }
255 par = /\ a b -> \ x y -> case par# x y of { _Lift y' -> y' }
259 par = /\ a b -> \ x::a y::b -> case par# x of { 0# -> parError#; _ -> y; }
262 parId = pcMiscPrelId parIdKey cONC_BASE SLIT("par")
263 (mkSigmaTy [alphaTyVar, betaTyVar] []
264 (mkFunTys [alphaTy, betaTy] betaTy))
265 (noIdInfo `addUnfoldInfo` (mk_inline_unfolding par_template))
275 = mkLam [alphaTyVar, betaTyVar] [x, y] (
276 Case (Prim ParOp [TyArg alphaTy, VarArg x]) (
278 [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [betaTy])]
279 (BindDefault z (Var y))))
281 -- forkId :: "fork", for *required* concurrent threads
283 _fork_ = /\ a b -> \ x::a y::b -> case fork# x of { 0# -> parError#; _ -> y; }
285 forkId = pcMiscPrelId forkIdKey cONC_BASE SLIT("fork")
286 (mkSigmaTy [alphaTyVar, betaTyVar] []
287 (mkFunTys [alphaTy, betaTy] betaTy))
288 (noIdInfo `addUnfoldInfo` (mk_inline_unfolding fork_template))
298 = mkLam [alphaTyVar, betaTyVar] [x, y] (
299 Case (Prim ForkOp [TyArg alphaTy, VarArg x]) (
301 [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [betaTy])]
302 (BindDefault z (Var y))))
309 parLocalId = pcMiscPrelId parLocalIdKey cONC_BASE SLIT("parLocal")
310 (mkSigmaTy [alphaTyVar, betaTyVar] []
311 (mkFunTys [intPrimTy, intPrimTy, intPrimTy, intPrimTy, alphaTy, betaTy] betaTy))
312 (noIdInfo `addUnfoldInfo` (mk_inline_unfolding parLocal_template))
314 -- Annotations: w: name, g: gran. info, s: size info, p: par info -- HWL
315 [w, g, s, p, x, y, z]
327 = mkLam [alphaTyVar, betaTyVar] [w, g, s, p, x, y] (
328 Case (Prim ParLocalOp [TyArg alphaTy, TyArg betaTy, VarArg x, VarArg w, VarArg g, VarArg s, VarArg p, VarArg y]) (
330 [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [betaTy])]
331 (BindDefault z (Var y))))
333 parGlobalId = pcMiscPrelId parGlobalIdKey cONC_BASE SLIT("parGlobal")
334 (mkSigmaTy [alphaTyVar, betaTyVar] []
335 (mkFunTys [intPrimTy, intPrimTy, intPrimTy, intPrimTy, alphaTy, betaTy] betaTy))
336 (noIdInfo `addUnfoldInfo` (mk_inline_unfolding parGlobal_template))
338 -- Annotations: w: name, g: gran. info, s: size info, p: par info -- HWL
339 [w, g, s, p, x, y, z]
351 = mkLam [alphaTyVar, betaTyVar] [w, g, s, p, x, y] (
352 Case (Prim ParGlobalOp [TyArg alphaTy, TyArg betaTy, VarArg x, VarArg w, VarArg g, VarArg s, VarArg p, VarArg y]) (
354 [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [betaTy])]
355 (BindDefault z (Var y))))
358 parAtId = pcMiscPrelId parAtIdKey cONC_BASE SLIT("parAt")
359 (mkSigmaTy [alphaTyVar, betaTyVar] []
360 (mkFunTys [intPrimTy, intPrimTy, intPrimTy, intPrimTy,
361 alphaTy, betaTy, gammaTy] gammaTy))
362 (noIdInfo `addUnfoldInfo` (mk_inline_unfolding parAt_template))
364 -- Annotations: w: name, g: gran. info, s: size info, p: par info -- HWL
365 [w, g, s, p, v, x, y, z]
378 = mkLam [alphaTyVar, betaTyVar, gammaTyVar] [w, g, s, p, v, x, y] (
379 Case (Prim ParAtOp [TyArg alphaTy, TyArg betaTy, TyArg gammaTy, VarArg x, VarArg v, VarArg w, VarArg g, VarArg s, VarArg p, VarArg y]) (
381 [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [gammaTy])]
382 (BindDefault z (Var y))))
384 parAtAbsId = pcMiscPrelId parAtAbsIdKey cONC_BASE SLIT("parAtAbs")
385 (mkSigmaTy [alphaTyVar, betaTyVar] []
386 (mkFunTys [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, alphaTy, betaTy] betaTy))
387 (noIdInfo `addUnfoldInfo` (mk_inline_unfolding parAtAbs_template))
389 -- Annotations: w: name, g: gran. info, s: size info, p: par info -- HWL
390 [w, g, s, p, v, x, y, z]
403 = mkLam [alphaTyVar, betaTyVar] [w, g, s, p, v, x, y] (
404 Case (Prim ParAtAbsOp [TyArg alphaTy, TyArg betaTy, VarArg x, VarArg v, VarArg w, VarArg g, VarArg s, VarArg p, VarArg y]) (
406 [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [betaTy])]
407 (BindDefault z (Var y))))
409 parAtRelId = pcMiscPrelId parAtRelIdKey cONC_BASE SLIT("parAtRel")
410 (mkSigmaTy [alphaTyVar, betaTyVar] []
411 (mkFunTys [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, alphaTy, betaTy] betaTy))
412 (noIdInfo `addUnfoldInfo` (mk_inline_unfolding parAtRel_template))
414 -- Annotations: w: name, g: gran. info, s: size info, p: par info -- HWL
415 [w, g, s, p, v, x, y, z]
428 = mkLam [alphaTyVar, betaTyVar] [w, g, s, p, v, x, y] (
429 Case (Prim ParAtRelOp [TyArg alphaTy, TyArg betaTy, VarArg x, VarArg v, VarArg w, VarArg g, VarArg s, VarArg p, VarArg y]) (
431 [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [betaTy])]
432 (BindDefault z (Var y))))
434 parAtForNowId = pcMiscPrelId parAtForNowIdKey cONC_BASE SLIT("parAtForNow")
435 (mkSigmaTy [alphaTyVar, betaTyVar] []
436 (mkFunTys [intPrimTy, intPrimTy, intPrimTy, intPrimTy,
437 alphaTy, betaTy, gammaTy] gammaTy))
438 (noIdInfo `addUnfoldInfo` (mk_inline_unfolding parAtForNow_template))
440 -- Annotations: w: name, g: gran. info, s: size info, p: par info -- HWL
441 [w, g, s, p, v, x, y, z]
454 = mkLam [alphaTyVar, betaTyVar, gammaTyVar] [w, g, s, p, v, x, y] (
455 Case (Prim ParAtForNowOp [TyArg alphaTy, TyArg betaTy, TyArg gammaTy, VarArg x, VarArg v, VarArg w, VarArg g, VarArg s, VarArg p, VarArg y]) (
457 [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [gammaTy])]
458 (BindDefault z (Var y))))
460 -- copyable and noFollow are currently merely hooks: they are translated into
461 -- calls to the macros COPYABLE and NOFOLLOW -- HWL
463 copyableId = pcMiscPrelId copyableIdKey cONC_BASE SLIT("copyable")
464 (mkSigmaTy [alphaTyVar] []
466 (noIdInfo `addUnfoldInfo` (mk_inline_unfolding copyable_template))
468 -- Annotations: x: closure that's tagged to by copyable
476 = mkLam [alphaTyVar] [x] ( Prim CopyableOp [TyArg alphaTy, VarArg x] )
478 noFollowId = pcMiscPrelId noFollowIdKey cONC_BASE SLIT("noFollow")
479 (mkSigmaTy [alphaTyVar] []
481 (noIdInfo `addUnfoldInfo` (mk_inline_unfolding noFollow_template))
483 -- Annotations: x: closure that's tagged to not follow
491 = mkLam [alphaTyVar] [x] ( Prim NoFollowOp [TyArg alphaTy, VarArg x] )
495 %************************************************************************
497 \subsection[PrelVals-runST]{@runST@: Magic start-state-transformer function}
499 %************************************************************************
501 @runST@ has a non-Haskell-able type:
503 -- runST :: forall a. (forall s. _ST s a) -> a
504 -- which is to say ::
505 -- forall a. (forall s. (_State s -> (a, _State s))) -> a
507 runST a m = case m _RealWorld (S# _RealWorld realWorld#) of
508 (r :: a, wild :: _State _RealWorld) -> r
511 We unfold always, just for simplicity:
514 = pcMiscPrelId runSTIdKey sT_BASE SLIT("runST") run_ST_ty id_info
519 st_ty a = mkSigmaTy [s_tv] [] (mkStateTransformerTy s a)
522 = mkSigmaTy [alphaTyVar] [] (mkFunTys [st_ty alphaTy] alphaTy)
523 -- NB: rank-2 polymorphism! (forall inside the st_ty...)
527 `addArityInfo` exactArity 1
528 `addStrictnessInfo` mkStrictnessInfo [WwStrict] False
529 `addArgUsageInfo` mkArgUsageInfo [ArgUsage 1]
530 -- ABSOLUTELY NO UNFOLDING, e.g.: (mk_inline_unfolding run_ST_template)
536 {-t-} realWorldStateTy,
538 {-_-} realWorldStateTy
542 = mkLam [alphaTyVar] [m] (
543 Let (NonRec t (Con stateDataCon [TyArg realWorldTy, VarArg realWorldPrimId])) (
544 Case (App (mkTyApp (Var m) [realWorldTy]) (VarArg t)) (
546 [(pairDataCon, [r, wild], Var r)]
551 SLPJ 95/04: Why @runST@ must not have an unfolding; consider:
555 (a, s') = newArray# 100 [] s
556 (_, s'') = fill_in_array_or_something a x s'
560 If we inline @runST@, we'll get:
563 (a, s') = newArray# 100 [] realWorld#{-NB-}
564 (_, s'') = fill_in_array_or_something a x s'
568 And now the @newArray#@ binding can be floated to become a CAF, which
569 is totally and utterly wrong:
572 (a, s') = newArray# 100 [] realWorld#{-NB-} -- YIKES!!!
575 let (_, s'') = fill_in_array_or_something a x s' in
578 All calls to @f@ will share a {\em single} array! End SLPJ 95/04.
580 @realWorld#@ used to be a magic literal, \tr{void#}. If things get
581 nasty as-is, change it back to a literal (@Literal@).
584 = pcMiscPrelId realWorldPrimIdKey gHC__ SLIT("realWorld#")
590 voidId = pc_bottoming_Id voidIdKey pREL_BASE SLIT("void") voidTy
593 %************************************************************************
595 \subsection[PrelVals-foldr-build]{Values known about for ``foldr/build''}
597 %************************************************************************
601 = pcMiscPrelId buildIdKey gHC_ERR SLIT("build") buildTy
603 {-LATER:`addUnfoldInfo` mkMagicUnfolding buildIdKey-})
604 `addStrictnessInfo` mkStrictnessInfo [WwStrict] False)
605 `addArgUsageInfo` mkArgUsageInfo [ArgUsage 2])
606 `addSpecInfo` pcGenerateSpecs buildIdKey buildId noIdInfo{-ToDo-} buildTy)
607 -- cheating, but since _build never actually exists ...
609 -- The type of this strange object is:
610 -- \/ a . (\/ b . (a -> b -> b) -> b -> b) -> [a]
612 buildTy = mkSigmaTy [alphaTyVar] [] (mkFunTys [build_ty] (mkListTy alphaTy))
614 build_ty = mkSigmaTy [betaTyVar] []
615 (mkFunTys [mkFunTys [alphaTy, betaTy] betaTy, betaTy] betaTy)
618 @mkBuild@ is sugar for building a build!
620 @mkbuild ty tv c n e@ $Rightarrow$ @build ty (/\ tv -> \ c n -> e)@
621 @ty@ is the type of the list.
622 @tv@ is always a new type variable.
623 @c,n@ are Id's for the abstract cons and nil, @g@ for let binding the argument argument.
626 v :: (\/ b . (a -> b -> b) -> b -> b) -> [a]
627 -- \/ a . (\/ b . (a -> b -> b) -> b -> b) -> [a]
628 @e@ is the object right inside the @build@
636 -> CoreExpr -- template
637 -> CoreExpr -- template
639 mkBuild ty tv c n g expr
640 = Let (NonRec g (mkLam [tv] [c,n] expr))
641 (App (mkTyApp (Var buildId) [ty]) (VarArg g))
646 = pcMiscPrelId augmentIdKey gHC_ERR SLIT("augment") augmentTy
648 {-LATER:`addUnfoldInfo` mkMagicUnfolding augmentIdKey-})
649 `addStrictnessInfo` mkStrictnessInfo [WwStrict,WwLazy False] False)
650 `addArgUsageInfo` mkArgUsageInfo [ArgUsage 2,UnknownArgUsage])
651 -- cheating, but since _augment never actually exists ...
653 -- The type of this strange object is:
654 -- \/ a . (\/ b . (a -> b -> b) -> b -> b) -> [a] -> [a]
656 augmentTy = mkSigmaTy [alphaTyVar] [] (mkFunTys [aug_ty, mkListTy alphaTy] (mkListTy alphaTy))
658 aug_ty = mkSigmaTy [betaTyVar] []
659 (mkFunTys [mkFunTys [alphaTy, betaTy] betaTy, betaTy] betaTy)
663 foldrId = pcMiscPrelId foldrIdKey pREL_BASE SLIT("foldr")
667 mkSigmaTy [alphaTyVar, betaTyVar] []
668 (mkFunTys [mkFunTys [alphaTy, betaTy] betaTy, betaTy, mkListTy alphaTy] betaTy)
670 idInfo = (((((noIdInfo
671 {-LATER:`addUnfoldInfo` mkMagicUnfolding foldrIdKey-})
672 `addStrictnessInfo` mkStrictnessInfo [WwLazy False,WwLazy False,WwStrict] False)
673 `addArityInfo` exactArity 3)
674 `addUpdateInfo` mkUpdateInfo [2,2,1])
675 `addSpecInfo` pcGenerateSpecs foldrIdKey foldrId noIdInfo{-ToDo-} foldrTy)
677 foldlId = pcMiscPrelId foldlIdKey pREL_LIST SLIT("foldl")
681 mkSigmaTy [alphaTyVar, betaTyVar] []
682 (mkFunTys [mkFunTys [alphaTy, betaTy] alphaTy, alphaTy, mkListTy betaTy] alphaTy)
684 idInfo = (((((noIdInfo
685 {-LATER:`addUnfoldInfo` mkMagicUnfolding foldlIdKey-})
686 `addStrictnessInfo` mkStrictnessInfo [WwLazy False,WwLazy False,WwStrict] False)
687 `addArityInfo` exactArity 3)
688 `addUpdateInfo` mkUpdateInfo [2,2,1])
689 `addSpecInfo` pcGenerateSpecs foldlIdKey foldlId noIdInfo{-ToDo-} foldlTy)
691 -- A bit of magic goes no here. We translate appendId into ++,
692 -- you have to be carefull when you actually compile append:
693 -- xs ++ ys = augment (\ c n -> foldr c n xs) ys
694 -- {- unfold augment -}
696 -- {- fold foldr to append -}
697 -- = ys `appendId` xs
698 -- = ys ++ xs -- ugg!
699 -- *BUT* you want (++) and not _append in your interfaces.
701 -- So you have to turn *off* unfolding of foldr inside FoldrBuild.hs inside
704 {- OLD: doesn't apply with 1.3
706 = pcMiscPrelId appendIdKey mONAD SLIT("++") appendTy idInfo
709 (mkSigmaTy [alphaTyVar] []
710 (mkFunTys [mkListTy alphaTy, mkListTy alphaTy] (mkListTy alphaTy)))
712 `addStrictnessInfo` mkStrictnessInfo [WwStrict,WwLazy False] False)
713 `addArityInfo` exactArity 2)
714 `addUpdateInfo` mkUpdateInfo [1,2])
718 %************************************************************************
720 \subsection[PrelUtils-specialisations]{Specialisations for builtin values}
722 %************************************************************************
724 The specialisations which exist for the builtin values must be recorded in
727 NOTE: THE USES OF THE pcGenerate... FUNCTIONS MUST CORRESPOND
728 TO THE SPECIALISATIONS DECLARED IN THE PRELUDE !!!
730 HACK: We currently use the same unique for the specialised Ids.
732 The list @specing_types@ determines the types for which specialised
733 versions are created. Note: This should correspond with the
734 types passed to the pre-processor with the -genSPECS arg (see ghc.lprl).
736 ToDo: Create single mkworld definition which is grabbed here and in ghc.lprl
739 pcGenerateSpecs :: Unique -> Id -> IdInfo -> Type -> SpecEnv
740 pcGenerateSpecs key id info ty
745 pc_gen_specs True key id info ty
747 pc_gen_specs is_id key id info ty
748 = mkSpecEnv spec_infos
750 spec_infos = [ let spec_ty = specialiseTy ty spec_tys 0
752 then mkSpecId key {- HACK WARNING: same unique! -}
753 id spec_tys spec_ty info
754 else panic "SpecData:SpecInfo:SpecId"
756 SpecInfo spec_tys (length ctxts) spec_id
757 | spec_tys <- specialisations ]
759 (tyvars, ctxts, _) = splitSigmaTy ty
760 no_tyvars = length tyvars
762 specialisations = if no_tyvars == 0
764 else tail (cross_product no_tyvars specing_types)
766 -- N.B. tail removes fully polymorphic specialisation
768 cross_product 0 tys = []
769 cross_product 1 tys = map (:[]) tys
770 cross_product n tys = concat [map (:cp) tys | cp <- cross_product (n-1) tys]
773 specing_types = [Nothing,