2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
4 \section[PrelVals]{Prelude values the compiler ``knows about''}
9 #include "HsVersions.h"
11 import {-# SOURCE #-} CoreUnfold ( mkUnfolding )
13 import Id ( Id, mkVanillaId, mkTemplateLocals )
14 import SpecEnv ( SpecEnv, emptySpecEnv )
22 import CoreSyn -- quite a bit
23 import IdInfo -- quite a bit
24 import Name ( mkWiredInIdName, Module )
26 import TyVar ( openAlphaTyVar, openAlphaTyVars, alphaTyVar, betaTyVar, TyVar )
27 import Unique -- lots of *Keys
34 mk_inline_unfolding expr = setUnfoldingInfo (mkUnfolding expr) $
35 setInlinePragInfo IWantToBeINLINEd noIdInfo
37 exactArityInfo n = exactArity n `setArityInfo` noIdInfo
39 pcMiscPrelId :: Unique{-IdKey-} -> Module -> FAST_STRING -> Type -> IdInfo -> Id
41 pcMiscPrelId key mod occ ty info
43 name = mkWiredInIdName key mod occ imp
44 imp = mkVanillaId name ty info -- the usual case...
47 -- We lie and say the thing is imported; otherwise, we get into
48 -- a mess with dependency analysis; e.g., core2stg may heave in
49 -- random calls to GHCbase.unpackPS__. If GHCbase is the module
50 -- being compiled, then it's just a matter of luck if the definition
51 -- will be in "the right place" to be in scope.
54 %************************************************************************
56 \subsection[PrelVals-error-related]{@error@ and friends; @trace@}
58 %************************************************************************
60 GHC randomly injects these into the code.
62 @patError@ is just a version of @error@ for pattern-matching
63 failures. It knows various ``codes'' which expand to longer
64 strings---this saves space!
66 @absentErr@ is a thing we put in for ``absent'' arguments. They jolly
67 well shouldn't be yanked on, but if one is, then you will get a
68 friendly message from @absentErr@ (rather a totally random crash).
70 @parError@ is a special version of @error@ which the compiler does
71 not know to be a bottoming Id. It is used in the @_par_@ and @_seq_@
72 templates, but we don't ever expect to generate code for it.
75 pc_bottoming_Id key mod name ty
76 = pcMiscPrelId key mod name ty bottoming_info
78 bottoming_info = mkBottomStrictnessInfo `setStrictnessInfo` noIdInfo
79 -- these "bottom" out, no matter what their arguments
82 = pc_bottoming_Id errorIdKey pREL_ERR SLIT("error") errorTy
85 = pc_bottoming_Id u pREL_ERR n errorTy
88 = generic_ERROR_ID recSelErrIdKey SLIT("patError")
90 = generic_ERROR_ID patErrorIdKey SLIT("patError")
92 = generic_ERROR_ID recConErrorIdKey SLIT("recConError")
94 = generic_ERROR_ID recUpdErrorIdKey SLIT("recUpdError")
96 = generic_ERROR_ID irrefutPatErrorIdKey SLIT("irrefutPatError")
97 nON_EXHAUSTIVE_GUARDS_ERROR_ID
98 = generic_ERROR_ID nonExhaustiveGuardsErrorIdKey SLIT("nonExhaustiveGuardsError")
99 nO_METHOD_BINDING_ERROR_ID
100 = generic_ERROR_ID noMethodBindingErrorIdKey SLIT("noMethodBindingError")
103 = pc_bottoming_Id absentErrorIdKey pREL_ERR SLIT("absentErr")
104 (mkSigmaTy [openAlphaTyVar] [] openAlphaTy)
107 = pcMiscPrelId parErrorIdKey pREL_ERR SLIT("parError")
108 (mkSigmaTy [openAlphaTyVar] [] openAlphaTy) noIdInfo
110 openAlphaTy = mkTyVarTy openAlphaTyVar
113 errorTy = mkSigmaTy [openAlphaTyVar] [] (mkFunTys [mkListTy charTy] openAlphaTy)
114 -- Notice the openAlphaTyVar. It says that "error" can be applied
115 -- to unboxed as well as boxed types. This is OK because it never
116 -- returns, so the return type is irrelevant.
119 unsafeCoerce# isn't so much a PrimOp as a phantom identifier, that
120 just gets expanded into a type coercion wherever it occurs. Hence we
121 add it as a built-in Id with an unfolding here.
125 = pcMiscPrelId unsafeCoerceIdKey pREL_GHC SLIT("unsafeCoerce#") ty
126 (mk_inline_unfolding template)
128 (alphaTyVar:betaTyVar:_) = openAlphaTyVars
129 alphaTy = mkTyVarTy alphaTyVar
130 betaTy = mkTyVarTy betaTyVar
131 ty = mkForAllTys [alphaTyVar,betaTyVar] (mkFunTy alphaTy betaTy)
132 [x] = mkTemplateLocals [alphaTy]
133 template = mkLam [alphaTyVar,betaTyVar] [x] $
134 Note (Coerce betaTy alphaTy) (Var x)
138 We want \tr{GHCbase.trace} to be wired in
139 because we don't want the strictness analyser to get ahold of it,
140 decide that the second argument is strict, evaluate that first (!!),
141 and make a jolly old mess.
144 = pcMiscPrelId traceIdKey pREL_IO_BASE SLIT("trace") traceTy
145 (pcGenerateSpecs traceIdKey tRACE_ID noIdInfo traceTy `setSpecInfo` noIdInfo)
147 traceTy = mkSigmaTy [alphaTyVar] [] (mkFunTys [mkListTy charTy, alphaTy] alphaTy)
150 %************************************************************************
152 \subsection[PrelVals-Integer-support]{To support @Integer@ and @String@ literals}
154 %************************************************************************
158 = pcMiscPrelId packCStringIdKey{-ToDo:rename-} pREL_PACK SLIT("packCString#")
159 (mkFunTys [stringTy] byteArrayPrimTy) noIdInfo
161 --------------------------------------------------------------------
164 = pcMiscPrelId unpackCStringIdKey pREL_PACK SLIT("unpackCString#")
165 (mkFunTys [addrPrimTy{-a char *-}] stringTy) noIdInfo
167 -- (FunTy addrPrimTy{-a char *-} stringTy) (exactArityInfo 1)
168 -- but I don't like wired-in IdInfos (WDP)
170 unpackCString2Id -- for cases when a string has a NUL in it
171 = pcMiscPrelId unpackCString2IdKey pREL_PACK SLIT("unpackNBytes#")
172 (mkFunTys [addrPrimTy{-a char *-}, intPrimTy{-length-}] stringTy)
175 --------------------------------------------------------------------
176 unpackCStringAppendId
177 = pcMiscPrelId unpackCStringAppendIdKey pREL_PACK SLIT("unpackAppendCString#")
178 (mkFunTys [addrPrimTy{-a "char *" pointer-},stringTy] stringTy)
182 = pcMiscPrelId unpackCStringFoldrIdKey pREL_PACK SLIT("unpackFoldrCString#")
183 (mkSigmaTy [alphaTyVar] []
184 (mkFunTys [addrPrimTy{-a "char *" pointer-},
185 mkFunTys [charTy, alphaTy] alphaTy,
191 OK, this is Will's idea: we should have magic values for Integers 0,
192 +1, +2, and -1 (go ahead, fire me):
196 = pcMiscPrelId integerZeroIdKey pREL_NUM SLIT("integer_0") integerTy noIdInfo
198 = pcMiscPrelId integerPlusOneIdKey pREL_NUM SLIT("integer_1") integerTy noIdInfo
200 = pcMiscPrelId integerPlusTwoIdKey pREL_NUM SLIT("integer_2") integerTy noIdInfo
202 = pcMiscPrelId integerMinusOneIdKey pREL_NUM SLIT("integer_m1") integerTy noIdInfo
205 %************************************************************************
207 \subsection[PrelVals-parallel]{@seq@ and @par@: for parallel operation (only)}
209 %************************************************************************
213 --------------------------------------------------------------------
214 -- seqId :: "seq", used w/ GRIP, etc., is really quite similar to
218 seq = /\ a b -> \ x y -> case x of { _ -> y }
221 seq = /\ a b -> \ x y -> case seq# x y of { _Lift y' -> y' }
224 seq = /\ a b -> \ x::a y::b -> case seq# x of { 0# -> parError#; _ -> y; }
228 seqId = pcMiscPrelId seqIdKey pRELUDE SLIT("seq")
229 (mkSigmaTy [alphaTyVar, betaTyVar] []
230 (mkFunTys [alphaTy, betaTy] betaTy))
231 (mk_inline_unfolding seq_template)
241 = mkLam [alphaTyVar, betaTyVar] [x, y] (
242 Case (Prim SeqOp [TyArg alphaTy, VarArg x]) (
244 [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [betaTy])]
245 (BindDefault z (Var y))))
247 --------------------------------------------------------------------
248 -- parId :: "par", also used w/ GRIP, etc.
252 par = /\ a b -> \ x y -> case (par# (case x of { _ -> () })) of { _ -> y }
256 par = /\ a b -> \ x y -> case par# x y of { _Lift y' -> y' }
260 par = /\ a b -> \ x::a y::b -> case par# x of { 0# -> parError#; _ -> y; }
263 parId = pcMiscPrelId parIdKey cONC_BASE SLIT("par")
264 (mkSigmaTy [alphaTyVar, betaTyVar] []
265 (mkFunTys [alphaTy, betaTy] betaTy))
266 (mk_inline_unfolding par_template)
276 = mkLam [alphaTyVar, betaTyVar] [x, y] (
277 Case (Prim ParOp [TyArg alphaTy, VarArg x]) (
279 [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [betaTy])]
280 (BindDefault z (Var y))))
282 -- forkId :: "fork", for *required* concurrent threads
284 _fork_ = /\ a b -> \ x::a y::b -> case fork# x of { 0# -> parError#; _ -> y; }
286 forkId = pcMiscPrelId forkIdKey cONC_BASE SLIT("fork")
287 (mkSigmaTy [alphaTyVar, betaTyVar] []
288 (mkFunTys [alphaTy, betaTy] betaTy))
289 (mk_inline_unfolding fork_template)
299 = mkLam [alphaTyVar, betaTyVar] [x, y] (
300 Case (Prim ForkOp [TyArg alphaTy, VarArg x]) (
302 [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [betaTy])]
303 (BindDefault z (Var y))))
310 parLocalId = pcMiscPrelId parLocalIdKey cONC_BASE SLIT("parLocal")
311 (mkSigmaTy [alphaTyVar, betaTyVar] []
312 (mkFunTys [intPrimTy, intPrimTy, intPrimTy, intPrimTy, alphaTy, betaTy] betaTy))
313 (mk_inline_unfolding parLocal_template)
315 -- Annotations: w: name, g: gran. info, s: size info, p: par info -- HWL
316 [w, g, s, p, x, y, z]
328 = mkLam [alphaTyVar, betaTyVar] [w, g, s, p, x, y] (
329 Case (Prim ParLocalOp [TyArg alphaTy, TyArg betaTy, VarArg x, VarArg w, VarArg g, VarArg s, VarArg p, VarArg y]) (
331 [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [betaTy])]
332 (BindDefault z (Var y))))
334 parGlobalId = pcMiscPrelId parGlobalIdKey cONC_BASE SLIT("parGlobal")
335 (mkSigmaTy [alphaTyVar, betaTyVar] []
336 (mkFunTys [intPrimTy, intPrimTy, intPrimTy, intPrimTy, alphaTy, betaTy] betaTy))
337 (mk_inline_unfolding parGlobal_template)
339 -- Annotations: w: name, g: gran. info, s: size info, p: par info -- HWL
340 [w, g, s, p, x, y, z]
352 = mkLam [alphaTyVar, betaTyVar] [w, g, s, p, x, y] (
353 Case (Prim ParGlobalOp [TyArg alphaTy, TyArg betaTy, VarArg x, VarArg w, VarArg g, VarArg s, VarArg p, VarArg y]) (
355 [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [betaTy])]
356 (BindDefault z (Var y))))
359 parAtId = pcMiscPrelId parAtIdKey cONC_BASE SLIT("parAt")
360 (mkSigmaTy [alphaTyVar, betaTyVar] []
361 (mkFunTys [intPrimTy, intPrimTy, intPrimTy, intPrimTy,
362 alphaTy, betaTy, gammaTy] gammaTy))
363 (mk_inline_unfolding parAt_template)
365 -- Annotations: w: name, g: gran. info, s: size info, p: par info -- HWL
366 [w, g, s, p, v, x, y, z]
379 = mkLam [alphaTyVar, betaTyVar, gammaTyVar] [w, g, s, p, v, x, y] (
380 Case (Prim ParAtOp [TyArg alphaTy, TyArg betaTy, TyArg gammaTy, VarArg x, VarArg v, VarArg w, VarArg g, VarArg s, VarArg p, VarArg y]) (
382 [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [gammaTy])]
383 (BindDefault z (Var y))))
385 parAtAbsId = pcMiscPrelId parAtAbsIdKey cONC_BASE SLIT("parAtAbs")
386 (mkSigmaTy [alphaTyVar, betaTyVar] []
387 (mkFunTys [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, alphaTy, betaTy] betaTy))
388 (mk_inline_unfolding parAtAbs_template)
390 -- Annotations: w: name, g: gran. info, s: size info, p: par info -- HWL
391 [w, g, s, p, v, x, y, z]
404 = mkLam [alphaTyVar, betaTyVar] [w, g, s, p, v, x, y] (
405 Case (Prim ParAtAbsOp [TyArg alphaTy, TyArg betaTy, VarArg x, VarArg v, VarArg w, VarArg g, VarArg s, VarArg p, VarArg y]) (
407 [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [betaTy])]
408 (BindDefault z (Var y))))
410 parAtRelId = pcMiscPrelId parAtRelIdKey cONC_BASE SLIT("parAtRel")
411 (mkSigmaTy [alphaTyVar, betaTyVar] []
412 (mkFunTys [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, alphaTy, betaTy] betaTy))
413 (mk_inline_unfolding parAtRel_template)
415 -- Annotations: w: name, g: gran. info, s: size info, p: par info -- HWL
416 [w, g, s, p, v, x, y, z]
429 = mkLam [alphaTyVar, betaTyVar] [w, g, s, p, v, x, y] (
430 Case (Prim ParAtRelOp [TyArg alphaTy, TyArg betaTy, VarArg x, VarArg v, VarArg w, VarArg g, VarArg s, VarArg p, VarArg y]) (
432 [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [betaTy])]
433 (BindDefault z (Var y))))
435 parAtForNowId = pcMiscPrelId parAtForNowIdKey cONC_BASE SLIT("parAtForNow")
436 (mkSigmaTy [alphaTyVar, betaTyVar] []
437 (mkFunTys [intPrimTy, intPrimTy, intPrimTy, intPrimTy,
438 alphaTy, betaTy, gammaTy] gammaTy))
439 (mk_inline_unfolding parAtForNow_template)
441 -- Annotations: w: name, g: gran. info, s: size info, p: par info -- HWL
442 [w, g, s, p, v, x, y, z]
455 = mkLam [alphaTyVar, betaTyVar, gammaTyVar] [w, g, s, p, v, x, y] (
456 Case (Prim ParAtForNowOp [TyArg alphaTy, TyArg betaTy, TyArg gammaTy, VarArg x, VarArg v, VarArg w, VarArg g, VarArg s, VarArg p, VarArg y]) (
458 [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [gammaTy])]
459 (BindDefault z (Var y))))
461 -- copyable and noFollow are currently merely hooks: they are translated into
462 -- calls to the macros COPYABLE and NOFOLLOW -- HWL
464 copyableId = pcMiscPrelId copyableIdKey cONC_BASE SLIT("copyable")
465 (mkSigmaTy [alphaTyVar] []
467 (mk_inline_unfolding copyable_template)
469 -- Annotations: x: closure that's tagged to by copyable
477 = mkLam [alphaTyVar] [x] ( Prim CopyableOp [TyArg alphaTy, VarArg x] )
479 noFollowId = pcMiscPrelId noFollowIdKey cONC_BASE SLIT("noFollow")
480 (mkSigmaTy [alphaTyVar] []
482 (mk_inline_unfolding noFollow_template)
484 -- Annotations: x: closure that's tagged to not follow
492 = mkLam [alphaTyVar] [x] ( Prim NoFollowOp [TyArg alphaTy, VarArg x] )
496 @realWorld#@ used to be a magic literal, \tr{void#}. If things get
497 nasty as-is, change it back to a literal (@Literal@).
500 = pcMiscPrelId realWorldPrimIdKey pREL_GHC SLIT("realWorld#")
506 voidId = pc_bottoming_Id voidIdKey pREL_BASE SLIT("void") voidTy
509 %************************************************************************
511 \subsection[PrelVals-foldr-build]{Values known about for ``foldr/build''}
513 %************************************************************************
517 = pcMiscPrelId buildIdKey pREL_ERR SLIT("build") buildTy
519 {- LATER:`addUnfoldInfo` mkMagicUnfolding buildIdKey)
520 `addStrictnessInfo` mkStrictnessInfo [WwStrict] False)
521 `addArgUsageInfo` mkArgUsageInfo [ArgUsage 2])
522 `setSpecInfo` pcGenerateSpecs buildIdKey buildId noIdInfo{-ToDo-} buildTy)
524 -- cheating, but since _build never actually exists ...
526 -- The type of this strange object is:
527 -- \/ a . (\/ b . (a -> b -> b) -> b -> b) -> [a]
529 buildTy = mkSigmaTy [alphaTyVar] [] (mkFunTys [build_ty] (mkListTy alphaTy))
531 build_ty = mkSigmaTy [betaTyVar] []
532 (mkFunTys [mkFunTys [alphaTy, betaTy] betaTy, betaTy] betaTy)
535 @mkBuild@ is sugar for building a build!
537 @mkbuild ty tv c n e@ $Rightarrow$ @build ty (/\ tv -> \ c n -> e)@
538 @ty@ is the type of the list.
539 @tv@ is always a new type variable.
540 @c,n@ are Id's for the abstract cons and nil, @g@ for let binding the argument argument.
543 v :: (\/ b . (a -> b -> b) -> b -> b) -> [a]
544 -- \/ a . (\/ b . (a -> b -> b) -> b -> b) -> [a]
545 @e@ is the object right inside the @build@
553 -> CoreExpr -- template
554 -> CoreExpr -- template
556 mkBuild ty tv c n g expr
557 = Let (NonRec g (mkLam [tv] [c,n] expr))
558 (App (mkTyApp (Var buildId) [ty]) (VarArg g))
563 = pcMiscPrelId augmentIdKey pREL_ERR SLIT("augment") augmentTy
565 {- LATER:`addUnfoldInfo` mkMagicUnfolding augmentIdKey)
566 `addStrictnessInfo` mkStrictnessInfo [WwStrict,WwLazy False] False)
567 `addArgUsageInfo` mkArgUsageInfo [ArgUsage 2,UnknownArgUsage])
569 -- cheating, but since _augment never actually exists ...
571 -- The type of this strange object is:
572 -- \/ a . (\/ b . (a -> b -> b) -> b -> b) -> [a] -> [a]
574 augmentTy = mkSigmaTy [alphaTyVar] [] (mkFunTys [aug_ty, mkListTy alphaTy] (mkListTy alphaTy))
576 aug_ty = mkSigmaTy [betaTyVar] []
577 (mkFunTys [mkFunTys [alphaTy, betaTy] betaTy, betaTy] betaTy)
581 foldrId = pcMiscPrelId foldrIdKey pREL_BASE SLIT("foldr")
585 mkSigmaTy [alphaTyVar, betaTyVar] []
586 (mkFunTys [mkFunTys [alphaTy, betaTy] betaTy, betaTy, mkListTy alphaTy] betaTy)
589 {- LATER: mkStrictnessInfo [WwLazy False,WwLazy False,WwStrict] False `setStrictnessInfo`
590 exactArity 3 `setArityInfo`
591 mkUpdateInfo [2,2,1] `setUpdateInfo`
592 pcGenerateSpecs foldrIdKey foldrId noIdInfo{-ToDo-} foldrTy `setSpecInfo`
596 foldlId = pcMiscPrelId foldlIdKey pREL_LIST SLIT("foldl")
600 mkSigmaTy [alphaTyVar, betaTyVar] []
601 (mkFunTys [mkFunTys [alphaTy, betaTy] alphaTy, alphaTy, mkListTy betaTy] alphaTy)
604 {- LATER: `addUnfoldInfo` mkMagicUnfolding foldlIdKey)
605 `addStrictnessInfo` mkStrictnessInfo [WwLazy False,WwLazy False,WwStrict] False)
606 `addArityInfo` exactArity 3)
607 `addUpdateInfo` mkUpdateInfo [2,2,1])
608 `setSpecInfo` pcGenerateSpecs foldlIdKey foldlId noIdInfo{-ToDo-} foldlTy)
611 -- A bit of magic goes no here. We translate appendId into ++,
612 -- you have to be carefull when you actually compile append:
613 -- xs ++ ys = augment (\ c n -> foldr c n xs) ys
614 -- {- unfold augment -}
616 -- {- fold foldr to append -}
617 -- = ys `appendId` xs
618 -- = ys ++ xs -- ugg!
619 -- *BUT* you want (++) and not _append in your interfaces.
621 -- So you have to turn *off* unfolding of foldr inside FoldrBuild.hs inside
624 {- OLD: doesn't apply with 1.3
626 = pcMiscPrelId appendIdKey mONAD SLIT("++") appendTy idInfo
629 (mkSigmaTy [alphaTyVar] []
630 (mkFunTys [mkListTy alphaTy, mkListTy alphaTy] (mkListTy alphaTy)))
632 `addStrictnessInfo` mkStrictnessInfo [WwStrict,WwLazy False] False)
633 `addArityInfo` exactArity 2)
634 `addUpdateInfo` mkUpdateInfo [1,2])
638 %************************************************************************
640 \subsection[PrelUtils-specialisations]{Specialisations for builtin values}
642 %************************************************************************
644 The specialisations which exist for the builtin values must be recorded in
647 NOTE: THE USES OF THE pcGenerate... FUNCTIONS MUST CORRESPOND
648 TO THE SPECIALISATIONS DECLARED IN THE PRELUDE !!!
650 HACK: We currently use the same unique for the specialised Ids.
652 The list @specing_types@ determines the types for which specialised
653 versions are created. Note: This should correspond with the
654 types passed to the pre-processor with the -genSPECS arg (see ghc.lprl).
656 ToDo: Create single mkworld definition which is grabbed here and in ghc.lprl
659 pcGenerateSpecs :: Unique -> Id -> IdInfo -> Type -> IdSpecEnv
660 pcGenerateSpecs key id info ty
665 pc_gen_specs True key id info ty
667 pc_gen_specs is_id key id info ty
668 = mkSpecEnv spec_infos
670 spec_infos = [ let spec_ty = specialiseTy ty spec_tys 0
672 then mkSpecId key {- HACK WARNING: same unique! -}
673 id spec_tys spec_ty info
674 else panic "SpecData:SpecInfo:SpecId"
676 SpecInfo spec_tys (length ctxts) spec_id
677 | spec_tys <- specialisations ]
679 (tyvars, ctxts, _) = splitSigmaTy ty
680 no_tyvars = length tyvars
682 specialisations = if no_tyvars == 0
684 else tail (cross_product no_tyvars specing_types)
686 -- N.B. tail removes fully polymorphic specialisation
688 cross_product 0 tys = []
689 cross_product 1 tys = map (:[]) tys
690 cross_product n tys = concat [map (:cp) tys | cp <- cross_product (n-1) tys]
693 specing_types = [Nothing,