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 IdLoop ( UnfoldingGuidance(..) )
13 import Id ( Id(..), GenId, mkPreludeId, mkTemplateLocals )
22 import CoreSyn -- quite a bit
23 --import CoreUnfold ( UnfoldingGuidance(..), mkMagicUnfolding )
24 import IdInfo -- quite a bit
25 import Literal ( mkMachInt )
26 --import NameTypes ( mkPreludeCoreName )
27 import PrimOp ( PrimOp(..) )
28 import SpecEnv ( SpecEnv(..), nullSpecEnv )
29 --import Type ( mkSigmaTy, mkFunTys, GenType(..) )
30 import TyVar ( alphaTyVar, betaTyVar )
31 import Unique -- lots of *Keys
40 pcMiscPrelId :: Unique{-IdKey-} -> FAST_STRING -> FAST_STRING -> Type -> IdInfo -> Id
42 pcMiscPrelId key mod name ty info
43 = mkPreludeId key (mkPreludeCoreName mod name) ty info
46 %************************************************************************
48 \subsection[PrelVals-error-related]{@error@ and friends; @trace@}
50 %************************************************************************
52 GHC randomly injects these into the code.
54 @patError#@ is just a version of @error@ for pattern-matching
55 failures. It knows various ``codes'' which expand to longer
56 strings---this saves space!
58 @absent#@ is a thing we put in for ``absent'' arguments. They jolly
59 well shouldn't be yanked on, but if one is, then you will get a
60 friendly message from @absent#@ (rather a totally random crash).
62 @parError#@ is a special version of @error@ which the compiler does
63 not know to be a bottoming Id. It is used in the @_par_@ and @_seq_@
64 templates, but we don't ever expect to generate code for it.
67 pc_bottoming_Id key mod name ty
68 = pcMiscPrelId key mod name ty bottoming_info
70 bottoming_info = noIdInfo `addInfo` mkBottomStrictnessInfo
71 -- these "bottom" out, no matter what their arguments
74 = pc_bottoming_Id errorIdKey pRELUDE_BUILTIN SLIT("error") errorTy
77 = pc_bottoming_Id patErrorIdKey pRELUDE_BUILTIN SLIT("patError#") errorTy
80 = pc_bottoming_Id absentErrorIdKey pRELUDE_BUILTIN SLIT("absent#")
81 (mkSigmaTy [alphaTyVar] [] alphaTy)
84 = pcMiscPrelId parErrorIdKey pRELUDE_BUILTIN SLIT("parError#")
85 (mkSigmaTy [alphaTyVar] [] alphaTy) noIdInfo
88 errorTy = mkSigmaTy [alphaTyVar] [] (mkFunTys [mkListTy charTy] alphaTy)
91 We want \tr{_trace} (NB: name not in user namespace) to be wired in
92 because we don't want the strictness analyser to get ahold of it,
93 decide that the second argument is strict, evaluate that first (!!),
94 and make a jolly old mess. Having \tr{_trace} wired in also helps when
95 attempting to re-export it---because it's in \tr{PreludeBuiltin}, it
96 won't get an \tr{import} declaration in the interface file, so the
97 importing-subsequently module needs to know it's magic.
100 = pcMiscPrelId traceIdKey pRELUDE_BUILTIN SLIT("_trace") traceTy
101 (noIdInfo `addInfo` pcGenerateSpecs traceIdKey tRACE_ID noIdInfo traceTy)
103 traceTy = mkSigmaTy [alphaTyVar] [] (mkFunTys [mkListTy charTy, alphaTy] alphaTy)
106 %************************************************************************
108 \subsection[PrelVals-Integer-support]{To support @Integer@ and @String@ literals}
110 %************************************************************************
114 = pcMiscPrelId packCStringIdKey{-ToDo:rename-} pRELUDE_PS SLIT("_packStringForC")
115 (mkFunTys [stringTy] byteArrayPrimTy) noIdInfo
117 --------------------------------------------------------------------
120 = pcMiscPrelId unpackCStringIdKey pRELUDE_BUILTIN SLIT("unpackPS#")
121 (mkFunTys [addrPrimTy{-a char *-}] stringTy) noIdInfo
123 -- (FunTy addrPrimTy{-a char *-} stringTy) (noIdInfo `addInfo` mkArityInfo 1)
124 -- but I don't like wired-in IdInfos (WDP)
126 unpackCString2Id -- for cases when a string has a NUL in it
127 = pcMiscPrelId unpackCString2IdKey pRELUDE_BUILTIN SLIT("unpackPS2#")
128 (mkFunTys [addrPrimTy{-a char *-}, intPrimTy{-length-}] stringTy)
131 --------------------------------------------------------------------
132 unpackCStringAppendId
133 = pcMiscPrelId unpackCStringAppendIdKey pRELUDE_BUILTIN SLIT("unpackAppendPS#")
134 (mkFunTys [addrPrimTy{-a "char *" pointer-},stringTy] stringTy)
136 `addInfo_UF` mkMagicUnfolding unpackCStringAppendIdKey)
137 `addInfo` mkArityInfo 2)
140 = pcMiscPrelId unpackCStringFoldrIdKey pRELUDE_BUILTIN SLIT("unpackFoldrPS#")
141 (mkSigmaTy [alphaTyVar] []
142 (mkFunTys [addrPrimTy{-a "char *" pointer-},
143 mkFunTys [charTy, alphaTy] alphaTy,
147 `addInfo_UF` mkMagicUnfolding unpackCStringFoldrIdKey)
148 `addInfo` mkArityInfo 3)
151 OK, this is Will's idea: we should have magic values for Integers 0,
152 +1, +2, and -1 (go ahead, fire me):
155 = pcMiscPrelId integerZeroIdKey pRELUDE_CORE SLIT("__integer0") integerTy noIdInfo
157 = pcMiscPrelId integerPlusOneIdKey pRELUDE_CORE SLIT("__integer1") integerTy noIdInfo
159 = pcMiscPrelId integerPlusTwoIdKey pRELUDE_CORE SLIT("__integer2") integerTy noIdInfo
161 = pcMiscPrelId integerMinusOneIdKey pRELUDE_CORE SLIT("__integerm1") integerTy noIdInfo
164 %************************************************************************
166 \subsection[PrelVals-parallel]{@seq@ and @par@: for parallel operation (only)}
168 %************************************************************************
171 --------------------------------------------------------------------
172 -- seqId :: "_seq_", used w/ GRIP, etc., is really quite similar to
176 _seq_ = /\ a b -> \ x y -> case x of { _ -> y }
179 _seq_ = /\ a b -> \ x y -> case seq# x y of { _Lift y' -> y' }
182 _seq_ = /\ a b -> \ x::a y::b -> case seq# x of { 0# -> parError#; _ -> y; }
186 seqId = pcMiscPrelId seqIdKey pRELUDE_BUILTIN SLIT("_seq_")
187 (mkSigmaTy [alphaTyVar, betaTyVar] []
188 (mkFunTys [alphaTy, betaTy] betaTy))
189 (noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding seq_template))
199 = mkLam [alphaTyVar, betaTyVar] [x, y] (
200 Case (Prim SeqOp [TyArg alphaTy, VarArg x]) (
202 [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [betaTy])]
203 (BindDefault z (Var y))))
205 --------------------------------------------------------------------
206 -- parId :: "_par_", also used w/ GRIP, etc.
210 par = /\ a b -> \ x y -> case (par# (case x of { _ -> () })) of { _ -> y }
214 _par_ = /\ a b -> \ x y -> case par# x y of { _Lift y' -> y' }
218 _par_ = /\ a b -> \ x::a y::b -> case par# x of { 0# -> parError#; _ -> y; }
221 parId = pcMiscPrelId parIdKey pRELUDE_BUILTIN SLIT("_par_")
222 (mkSigmaTy [alphaTyVar, betaTyVar] []
223 (mkFunTys [alphaTy, betaTy] betaTy))
224 (noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding par_template))
234 = mkLam [alphaTyVar, betaTyVar] [x, y] (
235 Case (Prim ParOp [TyArg alphaTy, VarArg x]) (
237 [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [betaTy])]
238 (BindDefault z (Var y))))
240 -- forkId :: "_fork_", for *required* concurrent threads
242 _fork_ = /\ a b -> \ x::a y::b -> case fork# x of { 0# -> parError#; _ -> y; }
244 forkId = pcMiscPrelId forkIdKey pRELUDE_BUILTIN SLIT("_fork_")
245 (mkSigmaTy [alphaTyVar, betaTyVar] []
246 (mkFunTys [alphaTy, betaTy] betaTy))
247 (noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding fork_template))
257 = mkLam [alphaTyVar, betaTyVar] [x, y] (
258 Case (Prim ForkOp [TyArg alphaTy, VarArg x]) (
260 [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [betaTy])]
261 (BindDefault z (Var y))))
268 parLocalId = pcMiscPrelId parLocalIdKey pRELUDE_BUILTIN SLIT("_parLocal_")
269 (mkSigmaTy [alphaTyVar, betaTyVar] []
270 (mkFunTys [intPrimTy, alphaTy, betaTy] betaTy))
271 (noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding parLocal_template))
282 = mkLam [alphaTyVar, betaTyVar] [w, x, y] (
283 Case (Prim ParLocalOp [TyArg alphaTy, TyArg betaTy, VarArg x, VarArg w, VarArg y]) (
285 [(liftDataCon, [z], Var z)]
288 parGlobalId = pcMiscPrelId parGlobalIdKey pRELUDE_BUILTIN SLIT("_parGlobal_")
289 (mkSigmaTy [alphaTyVar, betaTyVar] []
290 (mkFunTys [intPrimTy,alphaTy,betaTy] betaTy))
291 (noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding parGlobal_template))
302 = mkLam [alphaTyVar, betaTyVar] [w, x, y] (
303 Case (Prim ParGlobalOp [TyArg alphaTy, TyArg betaTy, VarArg x, VarArg w, VarArg y]) (
305 [(liftDataCon, [z], Var z)]
311 %************************************************************************
313 \subsection[PrelVals-deriving]{Values known about mainly for doing derived instance decls}
315 %************************************************************************
317 map :: (a -> b) -> [a] -> [b]
318 -- this is up in the here-because-of-unfolding list
320 --??showChar :: Char -> ShowS
321 showSpace :: ShowS -- non-std: == "showChar ' '"
322 showString :: String -> ShowS
323 showParen :: Bool -> ShowS -> ShowS
325 (++) :: [a] -> [a] -> [a]
326 readParen :: Bool -> ReadS a -> ReadS a
329 %************************************************************************
331 \subsection[PrelVals-void]{@void#@: Magic value of type @Void#@}
333 %************************************************************************
335 I don't think this is available to the user; it's used in the
336 simplifier (WDP 94/06).
339 = pcMiscPrelId voidPrimIdKey pRELUDE_BUILTIN SLIT("void#")
343 %************************************************************************
345 \subsection[PrelVals-runST]{@_runST@: Magic start-state-transformer function}
347 %************************************************************************
349 @_runST@ has a non-Haskell-able type:
351 -- _runST :: forall a. (forall s. _ST s a) -> a
352 -- which is to say ::
353 -- forall a. (forall s. (_State s -> (a, _State s))) -> a
355 _runST a m = case m _RealWorld (S# _RealWorld realWorld#) of
356 (r :: a, wild :: _State _RealWorld) -> r
358 We unfold always, just for simplicity:
361 = pcMiscPrelId runSTIdKey pRELUDE_BUILTIN SLIT("_runST") run_ST_ty id_info
366 st_ty a = mkSigmaTy [s_tv] [] (mkStateTransformerTy s a)
369 = mkSigmaTy [alphaTyVar] [] (mkFunTys [st_ty alphaTy] alphaTy)
370 -- NB: rank-2 polymorphism! (forall inside the st_ty...)
374 `addInfo` mkArityInfo 1
375 `addInfo` mkStrictnessInfo [WwStrict] Nothing
376 `addInfo` mkArgUsageInfo [ArgUsage 1]
377 -- ABSOLUTELY NO UNFOLDING, e.g.: (mkUnfolding EssentialUnfolding run_ST_template)
383 {-t-} realWorldStateTy,
385 {-_-} realWorldStateTy
389 = mkLam [alphaTyVar] [m] (
390 Let (NonRec t (Con stateDataCon [TyArg realWorldTy, VarArg realWorldPrimId])) (
391 Case (App (mkTyApp (Var m) [realWorldTy]) (VarArg t)) (
393 [(mkTupleCon 2, [r, wild], Var r)]
398 SLPJ 95/04: Why @_runST@ must not have an unfolding; consider:
402 (a, s') = newArray# 100 [] s
403 (_, s'') = fill_in_array_or_something a x s'
407 If we inline @_runST@, we'll get:
410 (a, s') = newArray# 100 [] realWorld#{-NB-}
411 (_, s'') = fill_in_array_or_something a x s'
415 And now the @newArray#@ binding can be floated to become a CAF, which
416 is totally and utterly wrong:
419 (a, s') = newArray# 100 [] realWorld#{-NB-} -- YIKES!!!
422 let (_, s'') = fill_in_array_or_something a x s' in
425 All calls to @f@ will share a {\em single} array! End SLPJ 95/04.
427 @realWorld#@ used to be a magic literal, \tr{void#}. If things get
428 nasty as-is, change it back to a literal (@Literal@).
431 = pcMiscPrelId realWorldPrimIdKey pRELUDE_BUILTIN SLIT("realWorld#")
436 %************************************************************************
438 \subsection[PrelVals-foldr-build]{Values known about for ``foldr/build''}
440 %************************************************************************
444 = pcMiscPrelId buildIdKey pRELUDE_CORE SLIT("_build") buildTy
446 `addInfo_UF` mkMagicUnfolding buildIdKey)
447 `addInfo` mkStrictnessInfo [WwStrict] Nothing)
448 `addInfo` mkArgUsageInfo [ArgUsage 2])
449 `addInfo` pcGenerateSpecs buildIdKey buildId noIdInfo{-ToDo-} buildTy)
450 -- cheating, but since _build never actually exists ...
452 -- The type of this strange object is:
453 -- \/ a . (\/ b . (a -> b -> b) -> b -> b) -> [a]
455 buildTy = mkSigmaTy [alphaTyVar] [] (mkFunTys [build_ty] (mkListTy alphaTy))
457 build_ty = mkSigmaTy [betaTyVar] []
458 (mkFunTys [alphaTy, mkFunTys [betaTy] betaTy, betaTy] betaTy)
461 @mkBuild@ is sugar for building a build!
463 @mkbuild ty tv c n e@ $Rightarrow$ @build ty (/\ tv -> \ c n -> e)@
464 @ty@ is the type of the list.
465 @tv@ is always a new type variable.
466 @c,n@ are Id's for the abstract cons and nil, @g@ for let binding the argument argument.
469 v :: (\/ b . (a -> b -> b) -> b -> b) -> [a]
470 -- \/ a . (\/ b . (a -> b -> b) -> b -> b) -> [a]
471 @e@ is the object right inside the @build@
479 -> CoreExpr -- template
480 -> CoreExpr -- template
482 mkBuild ty tv c n g expr
483 = Let (NonRec g (mkLam [tv] [c,n] expr))
484 (App (mkTyApp (Var buildId) [ty]) (VarArg g))
489 = pcMiscPrelId augmentIdKey pRELUDE_CORE SLIT("_augment") augmentTy
491 `addInfo_UF` mkMagicUnfolding augmentIdKey)
492 `addInfo` mkStrictnessInfo [WwStrict,WwLazy False] Nothing)
493 `addInfo` mkArgUsageInfo [ArgUsage 2,UnknownArgUsage])
494 -- cheating, but since _augment never actually exists ...
496 -- The type of this strange object is:
497 -- \/ a . (\/ b . (a -> b -> b) -> b -> b) -> [a] -> [a]
499 augmentTy = mkSigmaTy [alphaTyVar] [] (mkFunTys [aug_ty, mkListTy alphaTy] (mkListTy alphaTy))
501 aug_ty = mkSigmaTy [betaTyVar] []
502 (mkFunTys [alphaTy, mkFunTys [betaTy] betaTy, betaTy] betaTy)
506 foldrId = pcMiscPrelId foldrIdKey pRELUDE_FB{-not "List"-} SLIT("foldr")
510 mkSigmaTy [alphaTyVar, betaTyVar] []
511 (mkFunTys [alphaTy, mkFunTys [betaTy] betaTy, betaTy, mkListTy alphaTy] betaTy)
513 idInfo = (((((noIdInfo
514 `addInfo_UF` mkMagicUnfolding foldrIdKey)
515 `addInfo` mkStrictnessInfo [WwLazy False,WwLazy False,WwStrict] Nothing)
516 `addInfo` mkArityInfo 3)
517 `addInfo` mkUpdateInfo [2,2,1])
518 `addInfo` pcGenerateSpecs foldrIdKey foldrId noIdInfo{-ToDo-} foldrTy)
520 foldlId = pcMiscPrelId foldlIdKey pRELUDE_FB{-not "List"-} SLIT("foldl")
524 mkSigmaTy [alphaTyVar, betaTyVar] []
525 (mkFunTys [alphaTy, mkFunTys [betaTy] betaTy, alphaTy, mkListTy betaTy] alphaTy)
527 idInfo = (((((noIdInfo
528 `addInfo_UF` mkMagicUnfolding foldlIdKey)
529 `addInfo` mkStrictnessInfo [WwLazy False,WwLazy False,WwStrict] Nothing)
530 `addInfo` mkArityInfo 3)
531 `addInfo` mkUpdateInfo [2,2,1])
532 `addInfo` pcGenerateSpecs foldlIdKey foldlId noIdInfo{-ToDo-} foldlTy)
534 -- A bit of magic goes no here. We translate appendId into ++,
535 -- you have to be carefull when you actually compile append:
536 -- xs ++ ys = augment (\ c n -> foldr c n xs) ys
537 -- {- unfold augment -}
539 -- {- fold foldr to append -}
540 -- = ys `appendId` xs
541 -- = ys ++ xs -- ugg!
542 -- *BUT* you want (++) and not _append in your interfaces.
544 -- So you have to turn *off* unfolding of foldr inside FoldrBuild.hs inside
549 = pcMiscPrelId appendIdKey pRELUDE_LIST SLIT("++") appendTy idInfo
552 (mkSigmaTy [alphaTyVar] []
553 (mkFunTys [mkListTy alphaTy, mkListTy alphaTy] (mkListTy alphaTy)))
555 `addInfo` mkStrictnessInfo [WwStrict,WwLazy False] Nothing)
556 `addInfo` mkArityInfo 2)
557 `addInfo` mkUpdateInfo [1,2])
560 %************************************************************************
562 \subsection[PrelUtils-specialisations]{Specialisations for builtin values}
564 %************************************************************************
566 The specialisations which exist for the builtin values must be recorded in
569 NOTE: THE USES OF THE pcGenerate... FUNCTIONS MUST CORRESPOND
570 TO THE SPECIALISATIONS DECLARED IN THE PRELUDE !!!
572 HACK: We currently use the same unique for the specialised Ids.
574 The list @specing_types@ determines the types for which specialised
575 versions are created. Note: This should correspond with the
576 types passed to the pre-processor with the -genSPECS arg (see ghc.lprl).
578 ToDo: Create single mkworld definition which is grabbed here and in ghc.lprl
581 pcGenerateSpecs :: Unique -> Id -> IdInfo -> Type -> SpecEnv
582 pcGenerateSpecs key id info ty
587 pc_gen_specs True key id info ty
589 pc_gen_specs is_id key id info ty
590 = mkSpecEnv spec_infos
592 spec_infos = [ let spec_ty = specialiseTy ty spec_tys 0
594 then mkSpecId key {- HACK WARNING: same unique! -}
595 id spec_tys spec_ty info
596 else panic "SpecData:SpecInfo:SpecId"
598 SpecInfo spec_tys (length ctxts) spec_id
599 | spec_tys <- specialisations ]
601 (tyvars, ctxts, _) = splitSigmaTy ty
602 no_tyvars = length tyvars
604 specialisations = if no_tyvars == 0
606 else tail (cross_product no_tyvars specing_types)
608 -- N.B. tail removes fully polymorphic specialisation
610 cross_product 0 tys = []
611 cross_product 1 tys = map (:[]) tys
612 cross_product n tys = concat [map (:cp) tys | cp <- cross_product (n-1) tys]
615 specing_types = [Nothing,