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, mkImported )
14 import SpecEnv ( SpecEnv, emptySpecEnv )
22 import CoreSyn -- quite a bit
23 import IdInfo -- quite a bit
24 import Name ( mkWiredInIdName, Module )
27 import TyVar ( openAlphaTyVar, alphaTyVar, betaTyVar, TyVar )
28 import Unique -- lots of *Keys
35 mk_inline_unfolding = mkUnfolding IWantToBeINLINEd
37 pcMiscPrelId :: Unique{-IdKey-} -> Module -> FAST_STRING -> Type -> IdInfo -> Id
39 pcMiscPrelId key mod occ ty info
41 name = mkWiredInIdName key mod occ imp
42 imp = mkImported name ty info -- the usual case...
45 -- We lie and say the thing is imported; otherwise, we get into
46 -- a mess with dependency analysis; e.g., core2stg may heave in
47 -- random calls to GHCbase.unpackPS__. If GHCbase is the module
48 -- being compiled, then it's just a matter of luck if the definition
49 -- will be in "the right place" to be in scope.
52 %************************************************************************
54 \subsection[PrelVals-error-related]{@error@ and friends; @trace@}
56 %************************************************************************
58 GHC randomly injects these into the code.
60 @patError@ is just a version of @error@ for pattern-matching
61 failures. It knows various ``codes'' which expand to longer
62 strings---this saves space!
64 @absentErr@ is a thing we put in for ``absent'' arguments. They jolly
65 well shouldn't be yanked on, but if one is, then you will get a
66 friendly message from @absentErr@ (rather a totally random crash).
68 @parError@ is a special version of @error@ which the compiler does
69 not know to be a bottoming Id. It is used in the @_par_@ and @_seq_@
70 templates, but we don't ever expect to generate code for it.
73 pc_bottoming_Id key mod name ty
74 = pcMiscPrelId key mod name ty bottoming_info
76 bottoming_info = noIdInfo `addStrictnessInfo` mkBottomStrictnessInfo
77 -- these "bottom" out, no matter what their arguments
80 = pc_bottoming_Id errorIdKey pREL_ERR SLIT("error") errorTy
83 = pc_bottoming_Id u pREL_ERR n errorTy
86 = generic_ERROR_ID patErrorIdKey SLIT("patError")
88 = generic_ERROR_ID recConErrorIdKey SLIT("recConError")
90 = generic_ERROR_ID recUpdErrorIdKey SLIT("recUpdError")
92 = generic_ERROR_ID irrefutPatErrorIdKey SLIT("irrefutPatError")
93 nON_EXHAUSTIVE_GUARDS_ERROR_ID
94 = generic_ERROR_ID nonExhaustiveGuardsErrorIdKey SLIT("nonExhaustiveGuardsError")
95 nO_METHOD_BINDING_ERROR_ID
96 = generic_ERROR_ID noMethodBindingErrorIdKey SLIT("noMethodBindingError")
99 = pc_bottoming_Id absentErrorIdKey pREL_ERR SLIT("absentErr")
100 (mkSigmaTy [openAlphaTyVar] [] openAlphaTy)
103 = pcMiscPrelId parErrorIdKey pREL_ERR SLIT("parError")
104 (mkSigmaTy [openAlphaTyVar] [] openAlphaTy) noIdInfo
106 openAlphaTy = mkTyVarTy openAlphaTyVar
109 errorTy = mkSigmaTy [openAlphaTyVar] [] (mkFunTys [mkListTy charTy] openAlphaTy)
110 -- Notice the openAlphaTyVar. It says that "error" can be applied
111 -- to unboxed as well as boxed types. This is OK because it never
112 -- returns, so the return type is irrelevant.
115 We want \tr{GHCbase.trace} to be wired in
116 because we don't want the strictness analyser to get ahold of it,
117 decide that the second argument is strict, evaluate that first (!!),
118 and make a jolly old mess.
121 = pcMiscPrelId traceIdKey pREL_IO_BASE SLIT("trace") traceTy
122 (noIdInfo `setSpecInfo` pcGenerateSpecs traceIdKey tRACE_ID noIdInfo traceTy)
124 traceTy = mkSigmaTy [alphaTyVar] [] (mkFunTys [mkListTy charTy, alphaTy] alphaTy)
127 %************************************************************************
129 \subsection[PrelVals-Integer-support]{To support @Integer@ and @String@ literals}
131 %************************************************************************
135 = pcMiscPrelId packCStringIdKey{-ToDo:rename-} pREL_PACK SLIT("packCString#")
136 (mkFunTys [stringTy] byteArrayPrimTy) noIdInfo
138 --------------------------------------------------------------------
141 = pcMiscPrelId unpackCStringIdKey pREL_PACK SLIT("unpackCString#")
142 (mkFunTys [addrPrimTy{-a char *-}] stringTy) noIdInfo
144 -- (FunTy addrPrimTy{-a char *-} stringTy) (noIdInfo `addInfo` exactArity 1)
145 -- but I don't like wired-in IdInfos (WDP)
147 unpackCString2Id -- for cases when a string has a NUL in it
148 = pcMiscPrelId unpackCString2IdKey pREL_PACK SLIT("unpackNBytes#")
149 (mkFunTys [addrPrimTy{-a char *-}, intPrimTy{-length-}] stringTy)
152 --------------------------------------------------------------------
153 unpackCStringAppendId
154 = pcMiscPrelId unpackCStringAppendIdKey pREL_PACK SLIT("unpackAppendCString#")
155 (mkFunTys [addrPrimTy{-a "char *" pointer-},stringTy] stringTy)
157 {-LATER:`addUnfoldInfo` mkMagicUnfolding unpackCStringAppendIdKey-})
158 `addArityInfo` exactArity 2)
161 = pcMiscPrelId unpackCStringFoldrIdKey pREL_PACK SLIT("unpackFoldrCString#")
162 (mkSigmaTy [alphaTyVar] []
163 (mkFunTys [addrPrimTy{-a "char *" pointer-},
164 mkFunTys [charTy, alphaTy] alphaTy,
168 {-LATER:`addUnfoldInfo` mkMagicUnfolding unpackCStringFoldrIdKey-})
169 `addArityInfo` exactArity 3)
172 OK, this is Will's idea: we should have magic values for Integers 0,
173 +1, +2, and -1 (go ahead, fire me):
177 = pcMiscPrelId integerZeroIdKey pREL_NUM SLIT("integer_0") integerTy noIdInfo
179 = pcMiscPrelId integerPlusOneIdKey pREL_NUM SLIT("integer_1") integerTy noIdInfo
181 = pcMiscPrelId integerPlusTwoIdKey pREL_NUM SLIT("integer_2") integerTy noIdInfo
183 = pcMiscPrelId integerMinusOneIdKey pREL_NUM SLIT("integer_m1") integerTy noIdInfo
186 %************************************************************************
188 \subsection[PrelVals-parallel]{@seq@ and @par@: for parallel operation (only)}
190 %************************************************************************
194 --------------------------------------------------------------------
195 -- seqId :: "seq", used w/ GRIP, etc., is really quite similar to
199 seq = /\ a b -> \ x y -> case x of { _ -> y }
202 seq = /\ a b -> \ x y -> case seq# x y of { _Lift y' -> y' }
205 seq = /\ a b -> \ x::a y::b -> case seq# x of { 0# -> parError#; _ -> y; }
209 seqId = pcMiscPrelId seqIdKey pRELUDE SLIT("seq")
210 (mkSigmaTy [alphaTyVar, betaTyVar] []
211 (mkFunTys [alphaTy, betaTy] betaTy))
212 (noIdInfo `addUnfoldInfo` (mk_inline_unfolding seq_template))
222 = mkLam [alphaTyVar, betaTyVar] [x, y] (
223 Case (Prim SeqOp [TyArg alphaTy, VarArg x]) (
225 [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [betaTy])]
226 (BindDefault z (Var y))))
228 --------------------------------------------------------------------
229 -- parId :: "par", also used w/ GRIP, etc.
233 par = /\ a b -> \ x y -> case (par# (case x of { _ -> () })) of { _ -> y }
237 par = /\ a b -> \ x y -> case par# x y of { _Lift y' -> y' }
241 par = /\ a b -> \ x::a y::b -> case par# x of { 0# -> parError#; _ -> y; }
244 parId = pcMiscPrelId parIdKey cONC_BASE SLIT("par")
245 (mkSigmaTy [alphaTyVar, betaTyVar] []
246 (mkFunTys [alphaTy, betaTy] betaTy))
247 (noIdInfo `addUnfoldInfo` (mk_inline_unfolding par_template))
257 = mkLam [alphaTyVar, betaTyVar] [x, y] (
258 Case (Prim ParOp [TyArg alphaTy, VarArg x]) (
260 [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [betaTy])]
261 (BindDefault z (Var y))))
263 -- forkId :: "fork", for *required* concurrent threads
265 _fork_ = /\ a b -> \ x::a y::b -> case fork# x of { 0# -> parError#; _ -> y; }
267 forkId = pcMiscPrelId forkIdKey cONC_BASE SLIT("fork")
268 (mkSigmaTy [alphaTyVar, betaTyVar] []
269 (mkFunTys [alphaTy, betaTy] betaTy))
270 (noIdInfo `addUnfoldInfo` (mk_inline_unfolding fork_template))
280 = mkLam [alphaTyVar, betaTyVar] [x, y] (
281 Case (Prim ForkOp [TyArg alphaTy, VarArg x]) (
283 [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [betaTy])]
284 (BindDefault z (Var y))))
291 parLocalId = pcMiscPrelId parLocalIdKey cONC_BASE SLIT("parLocal")
292 (mkSigmaTy [alphaTyVar, betaTyVar] []
293 (mkFunTys [intPrimTy, intPrimTy, intPrimTy, intPrimTy, alphaTy, betaTy] betaTy))
294 (noIdInfo `addUnfoldInfo` (mk_inline_unfolding parLocal_template))
296 -- Annotations: w: name, g: gran. info, s: size info, p: par info -- HWL
297 [w, g, s, p, x, y, z]
309 = mkLam [alphaTyVar, betaTyVar] [w, g, s, p, x, y] (
310 Case (Prim ParLocalOp [TyArg alphaTy, TyArg betaTy, VarArg x, VarArg w, VarArg g, VarArg s, VarArg p, VarArg y]) (
312 [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [betaTy])]
313 (BindDefault z (Var y))))
315 parGlobalId = pcMiscPrelId parGlobalIdKey cONC_BASE SLIT("parGlobal")
316 (mkSigmaTy [alphaTyVar, betaTyVar] []
317 (mkFunTys [intPrimTy, intPrimTy, intPrimTy, intPrimTy, alphaTy, betaTy] betaTy))
318 (noIdInfo `addUnfoldInfo` (mk_inline_unfolding parGlobal_template))
320 -- Annotations: w: name, g: gran. info, s: size info, p: par info -- HWL
321 [w, g, s, p, x, y, z]
333 = mkLam [alphaTyVar, betaTyVar] [w, g, s, p, x, y] (
334 Case (Prim ParGlobalOp [TyArg alphaTy, TyArg betaTy, VarArg x, VarArg w, VarArg g, VarArg s, VarArg p, VarArg y]) (
336 [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [betaTy])]
337 (BindDefault z (Var y))))
340 parAtId = pcMiscPrelId parAtIdKey cONC_BASE SLIT("parAt")
341 (mkSigmaTy [alphaTyVar, betaTyVar] []
342 (mkFunTys [intPrimTy, intPrimTy, intPrimTy, intPrimTy,
343 alphaTy, betaTy, gammaTy] gammaTy))
344 (noIdInfo `addUnfoldInfo` (mk_inline_unfolding parAt_template))
346 -- Annotations: w: name, g: gran. info, s: size info, p: par info -- HWL
347 [w, g, s, p, v, x, y, z]
360 = mkLam [alphaTyVar, betaTyVar, gammaTyVar] [w, g, s, p, v, x, y] (
361 Case (Prim ParAtOp [TyArg alphaTy, TyArg betaTy, TyArg gammaTy, VarArg x, VarArg v, VarArg w, VarArg g, VarArg s, VarArg p, VarArg y]) (
363 [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [gammaTy])]
364 (BindDefault z (Var y))))
366 parAtAbsId = pcMiscPrelId parAtAbsIdKey cONC_BASE SLIT("parAtAbs")
367 (mkSigmaTy [alphaTyVar, betaTyVar] []
368 (mkFunTys [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, alphaTy, betaTy] betaTy))
369 (noIdInfo `addUnfoldInfo` (mk_inline_unfolding parAtAbs_template))
371 -- Annotations: w: name, g: gran. info, s: size info, p: par info -- HWL
372 [w, g, s, p, v, x, y, z]
385 = mkLam [alphaTyVar, betaTyVar] [w, g, s, p, v, x, y] (
386 Case (Prim ParAtAbsOp [TyArg alphaTy, TyArg betaTy, VarArg x, VarArg v, VarArg w, VarArg g, VarArg s, VarArg p, VarArg y]) (
388 [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [betaTy])]
389 (BindDefault z (Var y))))
391 parAtRelId = pcMiscPrelId parAtRelIdKey cONC_BASE SLIT("parAtRel")
392 (mkSigmaTy [alphaTyVar, betaTyVar] []
393 (mkFunTys [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, alphaTy, betaTy] betaTy))
394 (noIdInfo `addUnfoldInfo` (mk_inline_unfolding parAtRel_template))
396 -- Annotations: w: name, g: gran. info, s: size info, p: par info -- HWL
397 [w, g, s, p, v, x, y, z]
410 = mkLam [alphaTyVar, betaTyVar] [w, g, s, p, v, x, y] (
411 Case (Prim ParAtRelOp [TyArg alphaTy, TyArg betaTy, VarArg x, VarArg v, VarArg w, VarArg g, VarArg s, VarArg p, VarArg y]) (
413 [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [betaTy])]
414 (BindDefault z (Var y))))
416 parAtForNowId = pcMiscPrelId parAtForNowIdKey cONC_BASE SLIT("parAtForNow")
417 (mkSigmaTy [alphaTyVar, betaTyVar] []
418 (mkFunTys [intPrimTy, intPrimTy, intPrimTy, intPrimTy,
419 alphaTy, betaTy, gammaTy] gammaTy))
420 (noIdInfo `addUnfoldInfo` (mk_inline_unfolding parAtForNow_template))
422 -- Annotations: w: name, g: gran. info, s: size info, p: par info -- HWL
423 [w, g, s, p, v, x, y, z]
436 = mkLam [alphaTyVar, betaTyVar, gammaTyVar] [w, g, s, p, v, x, y] (
437 Case (Prim ParAtForNowOp [TyArg alphaTy, TyArg betaTy, TyArg gammaTy, VarArg x, VarArg v, VarArg w, VarArg g, VarArg s, VarArg p, VarArg y]) (
439 [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [gammaTy])]
440 (BindDefault z (Var y))))
442 -- copyable and noFollow are currently merely hooks: they are translated into
443 -- calls to the macros COPYABLE and NOFOLLOW -- HWL
445 copyableId = pcMiscPrelId copyableIdKey cONC_BASE SLIT("copyable")
446 (mkSigmaTy [alphaTyVar] []
448 (noIdInfo `addUnfoldInfo` (mk_inline_unfolding copyable_template))
450 -- Annotations: x: closure that's tagged to by copyable
458 = mkLam [alphaTyVar] [x] ( Prim CopyableOp [TyArg alphaTy, VarArg x] )
460 noFollowId = pcMiscPrelId noFollowIdKey cONC_BASE SLIT("noFollow")
461 (mkSigmaTy [alphaTyVar] []
463 (noIdInfo `addUnfoldInfo` (mk_inline_unfolding noFollow_template))
465 -- Annotations: x: closure that's tagged to not follow
473 = mkLam [alphaTyVar] [x] ( Prim NoFollowOp [TyArg alphaTy, VarArg x] )
477 @realWorld#@ used to be a magic literal, \tr{void#}. If things get
478 nasty as-is, change it back to a literal (@Literal@).
481 = pcMiscPrelId realWorldPrimIdKey pREL_GHC SLIT("realWorld#")
487 voidId = pc_bottoming_Id voidIdKey pREL_BASE SLIT("void") voidTy
490 %************************************************************************
492 \subsection[PrelVals-foldr-build]{Values known about for ``foldr/build''}
494 %************************************************************************
498 = pcMiscPrelId buildIdKey pREL_ERR SLIT("build") buildTy
500 {-LATER:`addUnfoldInfo` mkMagicUnfolding buildIdKey-})
501 `addStrictnessInfo` mkStrictnessInfo [WwStrict] False)
502 `addArgUsageInfo` mkArgUsageInfo [ArgUsage 2])
503 `setSpecInfo` pcGenerateSpecs buildIdKey buildId noIdInfo{-ToDo-} buildTy)
504 -- cheating, but since _build never actually exists ...
506 -- The type of this strange object is:
507 -- \/ a . (\/ b . (a -> b -> b) -> b -> b) -> [a]
509 buildTy = mkSigmaTy [alphaTyVar] [] (mkFunTys [build_ty] (mkListTy alphaTy))
511 build_ty = mkSigmaTy [betaTyVar] []
512 (mkFunTys [mkFunTys [alphaTy, betaTy] betaTy, betaTy] betaTy)
515 @mkBuild@ is sugar for building a build!
517 @mkbuild ty tv c n e@ $Rightarrow$ @build ty (/\ tv -> \ c n -> e)@
518 @ty@ is the type of the list.
519 @tv@ is always a new type variable.
520 @c,n@ are Id's for the abstract cons and nil, @g@ for let binding the argument argument.
523 v :: (\/ b . (a -> b -> b) -> b -> b) -> [a]
524 -- \/ a . (\/ b . (a -> b -> b) -> b -> b) -> [a]
525 @e@ is the object right inside the @build@
533 -> CoreExpr -- template
534 -> CoreExpr -- template
536 mkBuild ty tv c n g expr
537 = Let (NonRec g (mkLam [tv] [c,n] expr))
538 (App (mkTyApp (Var buildId) [ty]) (VarArg g))
543 = pcMiscPrelId augmentIdKey pREL_ERR SLIT("augment") augmentTy
545 {-LATER:`addUnfoldInfo` mkMagicUnfolding augmentIdKey-})
546 `addStrictnessInfo` mkStrictnessInfo [WwStrict,WwLazy False] False)
547 `addArgUsageInfo` mkArgUsageInfo [ArgUsage 2,UnknownArgUsage])
548 -- cheating, but since _augment never actually exists ...
550 -- The type of this strange object is:
551 -- \/ a . (\/ b . (a -> b -> b) -> b -> b) -> [a] -> [a]
553 augmentTy = mkSigmaTy [alphaTyVar] [] (mkFunTys [aug_ty, mkListTy alphaTy] (mkListTy alphaTy))
555 aug_ty = mkSigmaTy [betaTyVar] []
556 (mkFunTys [mkFunTys [alphaTy, betaTy] betaTy, betaTy] betaTy)
560 foldrId = pcMiscPrelId foldrIdKey pREL_BASE SLIT("foldr")
564 mkSigmaTy [alphaTyVar, betaTyVar] []
565 (mkFunTys [mkFunTys [alphaTy, betaTy] betaTy, betaTy, mkListTy alphaTy] betaTy)
567 idInfo = (((((noIdInfo
568 {-LATER:`addUnfoldInfo` mkMagicUnfolding foldrIdKey-})
569 `addStrictnessInfo` mkStrictnessInfo [WwLazy False,WwLazy False,WwStrict] False)
570 `addArityInfo` exactArity 3)
571 `addUpdateInfo` mkUpdateInfo [2,2,1])
572 `setSpecInfo` pcGenerateSpecs foldrIdKey foldrId noIdInfo{-ToDo-} foldrTy)
574 foldlId = pcMiscPrelId foldlIdKey pREL_LIST SLIT("foldl")
578 mkSigmaTy [alphaTyVar, betaTyVar] []
579 (mkFunTys [mkFunTys [alphaTy, betaTy] alphaTy, alphaTy, mkListTy betaTy] alphaTy)
581 idInfo = (((((noIdInfo
582 {-LATER:`addUnfoldInfo` mkMagicUnfolding foldlIdKey-})
583 `addStrictnessInfo` mkStrictnessInfo [WwLazy False,WwLazy False,WwStrict] False)
584 `addArityInfo` exactArity 3)
585 `addUpdateInfo` mkUpdateInfo [2,2,1])
586 `setSpecInfo` pcGenerateSpecs foldlIdKey foldlId noIdInfo{-ToDo-} foldlTy)
588 -- A bit of magic goes no here. We translate appendId into ++,
589 -- you have to be carefull when you actually compile append:
590 -- xs ++ ys = augment (\ c n -> foldr c n xs) ys
591 -- {- unfold augment -}
593 -- {- fold foldr to append -}
594 -- = ys `appendId` xs
595 -- = ys ++ xs -- ugg!
596 -- *BUT* you want (++) and not _append in your interfaces.
598 -- So you have to turn *off* unfolding of foldr inside FoldrBuild.hs inside
601 {- OLD: doesn't apply with 1.3
603 = pcMiscPrelId appendIdKey mONAD SLIT("++") appendTy idInfo
606 (mkSigmaTy [alphaTyVar] []
607 (mkFunTys [mkListTy alphaTy, mkListTy alphaTy] (mkListTy alphaTy)))
609 `addStrictnessInfo` mkStrictnessInfo [WwStrict,WwLazy False] False)
610 `addArityInfo` exactArity 2)
611 `addUpdateInfo` mkUpdateInfo [1,2])
615 %************************************************************************
617 \subsection[PrelUtils-specialisations]{Specialisations for builtin values}
619 %************************************************************************
621 The specialisations which exist for the builtin values must be recorded in
624 NOTE: THE USES OF THE pcGenerate... FUNCTIONS MUST CORRESPOND
625 TO THE SPECIALISATIONS DECLARED IN THE PRELUDE !!!
627 HACK: We currently use the same unique for the specialised Ids.
629 The list @specing_types@ determines the types for which specialised
630 versions are created. Note: This should correspond with the
631 types passed to the pre-processor with the -genSPECS arg (see ghc.lprl).
633 ToDo: Create single mkworld definition which is grabbed here and in ghc.lprl
636 pcGenerateSpecs :: Unique -> Id -> IdInfo -> Type -> IdSpecEnv
637 pcGenerateSpecs key id info ty
642 pc_gen_specs True key id info ty
644 pc_gen_specs is_id key id info ty
645 = mkSpecEnv spec_infos
647 spec_infos = [ let spec_ty = specialiseTy ty spec_tys 0
649 then mkSpecId key {- HACK WARNING: same unique! -}
650 id spec_tys spec_ty info
651 else panic "SpecData:SpecInfo:SpecId"
653 SpecInfo spec_tys (length ctxts) spec_id
654 | spec_tys <- specialisations ]
656 (tyvars, ctxts, _) = splitSigmaTy ty
657 no_tyvars = length tyvars
659 specialisations = if no_tyvars == 0
661 else tail (cross_product no_tyvars specing_types)
663 -- N.B. tail removes fully polymorphic specialisation
665 cross_product 0 tys = []
666 cross_product 1 tys = map (:[]) tys
667 cross_product n tys = concat [map (:cp) tys | cp <- cross_product (n-1) tys]
670 specing_types = [Nothing,