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 IdInfo -- quite a bit
24 import Literal ( mkMachInt )
25 import PrimOp ( PrimOp(..) )
26 import SpecEnv ( SpecEnv(..), nullSpecEnv )
27 import TyVar ( alphaTyVar, betaTyVar )
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#")
88 = pc_bottoming_Id absentErrorIdKey pRELUDE_BUILTIN SLIT("absent#")
89 (mkSigmaTy [alphaTyVar] [] alphaTy)
92 = pcMiscPrelId parErrorIdKey pRELUDE_BUILTIN SLIT("parError#")
93 (mkSigmaTy [alphaTyVar] [] alphaTy) noIdInfo
96 errorTy = mkSigmaTy [alphaTyVar] [] (mkFunTys [mkListTy charTy] alphaTy)
99 We want \tr{_trace} (NB: name not in user namespace) to be wired in
100 because we don't want the strictness analyser to get ahold of it,
101 decide that the second argument is strict, evaluate that first (!!),
102 and make a jolly old mess. Having \tr{_trace} wired in also helps when
103 attempting to re-export it---because it's in \tr{PreludeBuiltin}, it
104 won't get an \tr{import} declaration in the interface file, so the
105 importing-subsequently module needs to know it's magic.
108 = pcMiscPrelId traceIdKey pRELUDE_BUILTIN SLIT("_trace") traceTy
109 (noIdInfo `addInfo` pcGenerateSpecs traceIdKey tRACE_ID noIdInfo traceTy)
111 traceTy = mkSigmaTy [alphaTyVar] [] (mkFunTys [mkListTy charTy, alphaTy] alphaTy)
114 %************************************************************************
116 \subsection[PrelVals-Integer-support]{To support @Integer@ and @String@ literals}
118 %************************************************************************
122 = pcMiscPrelId packCStringIdKey{-ToDo:rename-} pRELUDE_PS SLIT("_packStringForC")
123 (mkFunTys [stringTy] byteArrayPrimTy) noIdInfo
125 --------------------------------------------------------------------
128 = pcMiscPrelId unpackCStringIdKey pRELUDE_BUILTIN SLIT("unpackPS#")
129 (mkFunTys [addrPrimTy{-a char *-}] stringTy) noIdInfo
131 -- (FunTy addrPrimTy{-a char *-} stringTy) (noIdInfo `addInfo` mkArityInfo 1)
132 -- but I don't like wired-in IdInfos (WDP)
134 unpackCString2Id -- for cases when a string has a NUL in it
135 = pcMiscPrelId unpackCString2IdKey pRELUDE_BUILTIN SLIT("unpackPS2#")
136 (mkFunTys [addrPrimTy{-a char *-}, intPrimTy{-length-}] stringTy)
139 --------------------------------------------------------------------
140 unpackCStringAppendId
141 = pcMiscPrelId unpackCStringAppendIdKey pRELUDE_BUILTIN SLIT("unpackAppendPS#")
142 (mkFunTys [addrPrimTy{-a "char *" pointer-},stringTy] stringTy)
144 `addInfo_UF` mkMagicUnfolding unpackCStringAppendIdKey)
145 `addInfo` mkArityInfo 2)
148 = pcMiscPrelId unpackCStringFoldrIdKey pRELUDE_BUILTIN SLIT("unpackFoldrPS#")
149 (mkSigmaTy [alphaTyVar] []
150 (mkFunTys [addrPrimTy{-a "char *" pointer-},
151 mkFunTys [charTy, alphaTy] alphaTy,
155 `addInfo_UF` mkMagicUnfolding unpackCStringFoldrIdKey)
156 `addInfo` mkArityInfo 3)
159 OK, this is Will's idea: we should have magic values for Integers 0,
160 +1, +2, and -1 (go ahead, fire me):
163 = pcMiscPrelId integerZeroIdKey pRELUDE_CORE SLIT("__integer0") integerTy noIdInfo
165 = pcMiscPrelId integerPlusOneIdKey pRELUDE_CORE SLIT("__integer1") integerTy noIdInfo
167 = pcMiscPrelId integerPlusTwoIdKey pRELUDE_CORE SLIT("__integer2") integerTy noIdInfo
169 = pcMiscPrelId integerMinusOneIdKey pRELUDE_CORE SLIT("__integerm1") integerTy noIdInfo
172 %************************************************************************
174 \subsection[PrelVals-parallel]{@seq@ and @par@: for parallel operation (only)}
176 %************************************************************************
179 --------------------------------------------------------------------
180 -- seqId :: "_seq_", used w/ GRIP, etc., is really quite similar to
184 _seq_ = /\ a b -> \ x y -> case x of { _ -> y }
187 _seq_ = /\ a b -> \ x y -> case seq# x y of { _Lift y' -> y' }
190 _seq_ = /\ a b -> \ x::a y::b -> case seq# x of { 0# -> parError#; _ -> y; }
194 seqId = pcMiscPrelId seqIdKey pRELUDE_BUILTIN SLIT("_seq_")
195 (mkSigmaTy [alphaTyVar, betaTyVar] []
196 (mkFunTys [alphaTy, betaTy] betaTy))
197 (noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding seq_template))
207 = mkLam [alphaTyVar, betaTyVar] [x, y] (
208 Case (Prim SeqOp [TyArg alphaTy, VarArg x]) (
210 [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [betaTy])]
211 (BindDefault z (Var y))))
213 --------------------------------------------------------------------
214 -- parId :: "_par_", also used w/ GRIP, etc.
218 par = /\ a b -> \ x y -> case (par# (case x of { _ -> () })) of { _ -> y }
222 _par_ = /\ a b -> \ x y -> case par# x y of { _Lift y' -> y' }
226 _par_ = /\ a b -> \ x::a y::b -> case par# x of { 0# -> parError#; _ -> y; }
229 parId = pcMiscPrelId parIdKey pRELUDE_BUILTIN SLIT("_par_")
230 (mkSigmaTy [alphaTyVar, betaTyVar] []
231 (mkFunTys [alphaTy, betaTy] betaTy))
232 (noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding par_template))
242 = mkLam [alphaTyVar, betaTyVar] [x, y] (
243 Case (Prim ParOp [TyArg alphaTy, VarArg x]) (
245 [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [betaTy])]
246 (BindDefault z (Var y))))
248 -- forkId :: "_fork_", for *required* concurrent threads
250 _fork_ = /\ a b -> \ x::a y::b -> case fork# x of { 0# -> parError#; _ -> y; }
252 forkId = pcMiscPrelId forkIdKey pRELUDE_BUILTIN SLIT("_fork_")
253 (mkSigmaTy [alphaTyVar, betaTyVar] []
254 (mkFunTys [alphaTy, betaTy] betaTy))
255 (noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding fork_template))
265 = mkLam [alphaTyVar, betaTyVar] [x, y] (
266 Case (Prim ForkOp [TyArg alphaTy, VarArg x]) (
268 [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [betaTy])]
269 (BindDefault z (Var y))))
276 parLocalId = pcMiscPrelId parLocalIdKey pRELUDE_BUILTIN SLIT("_parLocal_")
277 (mkSigmaTy [alphaTyVar, betaTyVar] []
278 (mkFunTys [intPrimTy, alphaTy, betaTy] betaTy))
279 (noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding parLocal_template))
290 = mkLam [alphaTyVar, betaTyVar] [w, x, y] (
291 Case (Prim ParLocalOp [TyArg alphaTy, TyArg betaTy, VarArg x, VarArg w, VarArg y]) (
293 [(liftDataCon, [z], Var z)]
296 parGlobalId = pcMiscPrelId parGlobalIdKey pRELUDE_BUILTIN SLIT("_parGlobal_")
297 (mkSigmaTy [alphaTyVar, betaTyVar] []
298 (mkFunTys [intPrimTy,alphaTy,betaTy] betaTy))
299 (noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding parGlobal_template))
310 = mkLam [alphaTyVar, betaTyVar] [w, x, y] (
311 Case (Prim ParGlobalOp [TyArg alphaTy, TyArg betaTy, VarArg x, VarArg w, VarArg y]) (
313 [(liftDataCon, [z], Var z)]
319 %************************************************************************
321 \subsection[PrelVals-deriving]{Values known about mainly for doing derived instance decls}
323 %************************************************************************
325 map :: (a -> b) -> [a] -> [b]
326 -- this is up in the here-because-of-unfolding list
328 --??showChar :: Char -> ShowS
329 showSpace :: ShowS -- non-std: == "showChar ' '"
330 showString :: String -> ShowS
331 showParen :: Bool -> ShowS -> ShowS
333 (++) :: [a] -> [a] -> [a]
334 readParen :: Bool -> ReadS a -> ReadS a
337 %************************************************************************
339 \subsection[PrelVals-void]{@void#@: Magic value of type @Void#@}
341 %************************************************************************
343 I don't think this is available to the user; it's used in the
344 simplifier (WDP 94/06).
347 = pcMiscPrelId voidPrimIdKey pRELUDE_BUILTIN SLIT("void#")
351 %************************************************************************
353 \subsection[PrelVals-runST]{@_runST@: Magic start-state-transformer function}
355 %************************************************************************
357 @_runST@ has a non-Haskell-able type:
359 -- _runST :: forall a. (forall s. _ST s a) -> a
360 -- which is to say ::
361 -- forall a. (forall s. (_State s -> (a, _State s))) -> a
363 _runST a m = case m _RealWorld (S# _RealWorld realWorld#) of
364 (r :: a, wild :: _State _RealWorld) -> r
366 We unfold always, just for simplicity:
369 = pcMiscPrelId runSTIdKey pRELUDE_BUILTIN SLIT("_runST") run_ST_ty id_info
374 st_ty a = mkSigmaTy [s_tv] [] (mkStateTransformerTy s a)
377 = mkSigmaTy [alphaTyVar] [] (mkFunTys [st_ty alphaTy] alphaTy)
378 -- NB: rank-2 polymorphism! (forall inside the st_ty...)
382 `addInfo` mkArityInfo 1
383 `addInfo` mkStrictnessInfo [WwStrict] Nothing
384 `addInfo` mkArgUsageInfo [ArgUsage 1]
385 -- ABSOLUTELY NO UNFOLDING, e.g.: (mkUnfolding EssentialUnfolding run_ST_template)
391 {-t-} realWorldStateTy,
393 {-_-} realWorldStateTy
397 = mkLam [alphaTyVar] [m] (
398 Let (NonRec t (Con stateDataCon [TyArg realWorldTy, VarArg realWorldPrimId])) (
399 Case (App (mkTyApp (Var m) [realWorldTy]) (VarArg t)) (
401 [(mkTupleCon 2, [r, wild], Var r)]
406 SLPJ 95/04: Why @_runST@ must not have an unfolding; consider:
410 (a, s') = newArray# 100 [] s
411 (_, s'') = fill_in_array_or_something a x s'
415 If we inline @_runST@, we'll get:
418 (a, s') = newArray# 100 [] realWorld#{-NB-}
419 (_, s'') = fill_in_array_or_something a x s'
423 And now the @newArray#@ binding can be floated to become a CAF, which
424 is totally and utterly wrong:
427 (a, s') = newArray# 100 [] realWorld#{-NB-} -- YIKES!!!
430 let (_, s'') = fill_in_array_or_something a x s' in
433 All calls to @f@ will share a {\em single} array! End SLPJ 95/04.
435 @realWorld#@ used to be a magic literal, \tr{void#}. If things get
436 nasty as-is, change it back to a literal (@Literal@).
439 = pcMiscPrelId realWorldPrimIdKey pRELUDE_BUILTIN SLIT("realWorld#")
444 %************************************************************************
446 \subsection[PrelVals-foldr-build]{Values known about for ``foldr/build''}
448 %************************************************************************
452 = pcMiscPrelId buildIdKey pRELUDE_CORE SLIT("_build") buildTy
454 `addInfo_UF` mkMagicUnfolding buildIdKey)
455 `addInfo` mkStrictnessInfo [WwStrict] Nothing)
456 `addInfo` mkArgUsageInfo [ArgUsage 2])
457 `addInfo` pcGenerateSpecs buildIdKey buildId noIdInfo{-ToDo-} buildTy)
458 -- cheating, but since _build never actually exists ...
460 -- The type of this strange object is:
461 -- \/ a . (\/ b . (a -> b -> b) -> b -> b) -> [a]
463 buildTy = mkSigmaTy [alphaTyVar] [] (mkFunTys [build_ty] (mkListTy alphaTy))
465 build_ty = mkSigmaTy [betaTyVar] []
466 (mkFunTys [alphaTy, mkFunTys [betaTy] betaTy, betaTy] betaTy)
469 @mkBuild@ is sugar for building a build!
471 @mkbuild ty tv c n e@ $Rightarrow$ @build ty (/\ tv -> \ c n -> e)@
472 @ty@ is the type of the list.
473 @tv@ is always a new type variable.
474 @c,n@ are Id's for the abstract cons and nil, @g@ for let binding the argument argument.
477 v :: (\/ b . (a -> b -> b) -> b -> b) -> [a]
478 -- \/ a . (\/ b . (a -> b -> b) -> b -> b) -> [a]
479 @e@ is the object right inside the @build@
487 -> CoreExpr -- template
488 -> CoreExpr -- template
490 mkBuild ty tv c n g expr
491 = Let (NonRec g (mkLam [tv] [c,n] expr))
492 (App (mkTyApp (Var buildId) [ty]) (VarArg g))
497 = pcMiscPrelId augmentIdKey pRELUDE_CORE SLIT("_augment") augmentTy
499 `addInfo_UF` mkMagicUnfolding augmentIdKey)
500 `addInfo` mkStrictnessInfo [WwStrict,WwLazy False] Nothing)
501 `addInfo` mkArgUsageInfo [ArgUsage 2,UnknownArgUsage])
502 -- cheating, but since _augment never actually exists ...
504 -- The type of this strange object is:
505 -- \/ a . (\/ b . (a -> b -> b) -> b -> b) -> [a] -> [a]
507 augmentTy = mkSigmaTy [alphaTyVar] [] (mkFunTys [aug_ty, mkListTy alphaTy] (mkListTy alphaTy))
509 aug_ty = mkSigmaTy [betaTyVar] []
510 (mkFunTys [alphaTy, mkFunTys [betaTy] betaTy, betaTy] betaTy)
514 foldrId = pcMiscPrelId foldrIdKey pRELUDE_FB{-not "List"-} SLIT("foldr")
518 mkSigmaTy [alphaTyVar, betaTyVar] []
519 (mkFunTys [alphaTy, mkFunTys [betaTy] betaTy, betaTy, mkListTy alphaTy] betaTy)
521 idInfo = (((((noIdInfo
522 `addInfo_UF` mkMagicUnfolding foldrIdKey)
523 `addInfo` mkStrictnessInfo [WwLazy False,WwLazy False,WwStrict] Nothing)
524 `addInfo` mkArityInfo 3)
525 `addInfo` mkUpdateInfo [2,2,1])
526 `addInfo` pcGenerateSpecs foldrIdKey foldrId noIdInfo{-ToDo-} foldrTy)
528 foldlId = pcMiscPrelId foldlIdKey pRELUDE_FB{-not "List"-} SLIT("foldl")
532 mkSigmaTy [alphaTyVar, betaTyVar] []
533 (mkFunTys [alphaTy, mkFunTys [betaTy] betaTy, alphaTy, mkListTy betaTy] alphaTy)
535 idInfo = (((((noIdInfo
536 `addInfo_UF` mkMagicUnfolding foldlIdKey)
537 `addInfo` mkStrictnessInfo [WwLazy False,WwLazy False,WwStrict] Nothing)
538 `addInfo` mkArityInfo 3)
539 `addInfo` mkUpdateInfo [2,2,1])
540 `addInfo` pcGenerateSpecs foldlIdKey foldlId noIdInfo{-ToDo-} foldlTy)
542 -- A bit of magic goes no here. We translate appendId into ++,
543 -- you have to be carefull when you actually compile append:
544 -- xs ++ ys = augment (\ c n -> foldr c n xs) ys
545 -- {- unfold augment -}
547 -- {- fold foldr to append -}
548 -- = ys `appendId` xs
549 -- = ys ++ xs -- ugg!
550 -- *BUT* you want (++) and not _append in your interfaces.
552 -- So you have to turn *off* unfolding of foldr inside FoldrBuild.hs inside
557 = pcMiscPrelId appendIdKey pRELUDE_LIST SLIT("++") appendTy idInfo
560 (mkSigmaTy [alphaTyVar] []
561 (mkFunTys [mkListTy alphaTy, mkListTy alphaTy] (mkListTy alphaTy)))
563 `addInfo` mkStrictnessInfo [WwStrict,WwLazy False] Nothing)
564 `addInfo` mkArityInfo 2)
565 `addInfo` mkUpdateInfo [1,2])
568 %************************************************************************
570 \subsection[PrelUtils-specialisations]{Specialisations for builtin values}
572 %************************************************************************
574 The specialisations which exist for the builtin values must be recorded in
577 NOTE: THE USES OF THE pcGenerate... FUNCTIONS MUST CORRESPOND
578 TO THE SPECIALISATIONS DECLARED IN THE PRELUDE !!!
580 HACK: We currently use the same unique for the specialised Ids.
582 The list @specing_types@ determines the types for which specialised
583 versions are created. Note: This should correspond with the
584 types passed to the pre-processor with the -genSPECS arg (see ghc.lprl).
586 ToDo: Create single mkworld definition which is grabbed here and in ghc.lprl
589 pcGenerateSpecs :: Unique -> Id -> IdInfo -> Type -> SpecEnv
590 pcGenerateSpecs key id info ty
595 pc_gen_specs True key id info ty
597 pc_gen_specs is_id key id info ty
598 = mkSpecEnv spec_infos
600 spec_infos = [ let spec_ty = specialiseTy ty spec_tys 0
602 then mkSpecId key {- HACK WARNING: same unique! -}
603 id spec_tys spec_ty info
604 else panic "SpecData:SpecInfo:SpecId"
606 SpecInfo spec_tys (length ctxts) spec_id
607 | spec_tys <- specialisations ]
609 (tyvars, ctxts, _) = splitSigmaTy ty
610 no_tyvars = length tyvars
612 specialisations = if no_tyvars == 0
614 else tail (cross_product no_tyvars specing_types)
616 -- N.B. tail removes fully polymorphic specialisation
618 cross_product 0 tys = []
619 cross_product 1 tys = map (:[]) tys
620 cross_product n tys = concat [map (:cp) tys | cp <- cross_product (n-1) tys]
623 specing_types = [Nothing,