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 ( UnfoldingGuidance(..), mkUnfolding )
13 import Id ( Id, mkImported, mkTemplateLocals )
14 import SpecEnv ( SpecEnv, emptySpecEnv )
22 import CmdLineOpts ( maybe_CompilingGhcInternals )
23 import CoreSyn -- quite a bit
24 import IdInfo -- quite a bit
25 import Literal ( mkMachInt )
26 import Name ( mkWiredInIdName, Module )
28 import PrimOp ( PrimOp(..) )
30 import TyVar ( openAlphaTyVar, alphaTyVar, betaTyVar, gammaTyVar, TyVar )
31 import Unique -- lots of *Keys
38 mk_inline_unfolding = mkUnfolding IWantToBeINLINEd
40 pcMiscPrelId :: Unique{-IdKey-} -> Module -> FAST_STRING -> Type -> IdInfo -> Id
42 pcMiscPrelId key mod occ ty info
44 name = mkWiredInIdName key mod occ imp
45 imp = mkImported name ty info -- the usual case...
48 -- We lie and say the thing is imported; otherwise, we get into
49 -- a mess with dependency analysis; e.g., core2stg may heave in
50 -- random calls to GHCbase.unpackPS__. If GHCbase is the module
51 -- being compiled, then it's just a matter of luck if the definition
52 -- will be in "the right place" to be in scope.
55 %************************************************************************
57 \subsection[PrelVals-error-related]{@error@ and friends; @trace@}
59 %************************************************************************
61 GHC randomly injects these into the code.
63 @patError@ is just a version of @error@ for pattern-matching
64 failures. It knows various ``codes'' which expand to longer
65 strings---this saves space!
67 @absentErr@ is a thing we put in for ``absent'' arguments. They jolly
68 well shouldn't be yanked on, but if one is, then you will get a
69 friendly message from @absentErr@ (rather a totally random crash).
71 @parError@ is a special version of @error@ which the compiler does
72 not know to be a bottoming Id. It is used in the @_par_@ and @_seq_@
73 templates, but we don't ever expect to generate code for it.
76 pc_bottoming_Id key mod name ty
77 = pcMiscPrelId key mod name ty bottoming_info
79 bottoming_info = noIdInfo `addStrictnessInfo` mkBottomStrictnessInfo
80 -- these "bottom" out, no matter what their arguments
83 = pc_bottoming_Id errorIdKey gHC_ERR SLIT("error") errorTy
86 = pc_bottoming_Id u gHC_ERR n errorTy
89 = generic_ERROR_ID patErrorIdKey SLIT("patError")
91 = generic_ERROR_ID recConErrorIdKey SLIT("recConError")
93 = generic_ERROR_ID recUpdErrorIdKey SLIT("recUpdError")
95 = generic_ERROR_ID irrefutPatErrorIdKey SLIT("irrefutPatError")
96 nON_EXHAUSTIVE_GUARDS_ERROR_ID
97 = generic_ERROR_ID nonExhaustiveGuardsErrorIdKey SLIT("nonExhaustiveGuardsError")
98 nO_DEFAULT_METHOD_ERROR_ID
99 = generic_ERROR_ID noDefaultMethodErrorIdKey SLIT("noDefaultMethodError")
100 nO_EXPLICIT_METHOD_ERROR_ID
101 = generic_ERROR_ID nonExplicitMethodErrorIdKey SLIT("noExplicitMethodError")
104 = pc_bottoming_Id absentErrorIdKey gHC_ERR SLIT("absentErr")
105 (mkSigmaTy [openAlphaTyVar] [] openAlphaTy)
108 = pcMiscPrelId parErrorIdKey gHC_ERR SLIT("parError")
109 (mkSigmaTy [openAlphaTyVar] [] openAlphaTy) noIdInfo
111 openAlphaTy = mkTyVarTy openAlphaTyVar
114 errorTy = mkSigmaTy [openAlphaTyVar] [] (mkFunTys [mkListTy charTy] openAlphaTy)
115 -- Notice the openAlphaTyVar. It says that "error" can be applied
116 -- to unboxed as well as boxed types. This is OK because it never
117 -- returns, so the return type is irrelevant.
120 We want \tr{GHCbase.trace} to be wired in
121 because we don't want the strictness analyser to get ahold of it,
122 decide that the second argument is strict, evaluate that first (!!),
123 and make a jolly old mess.
126 = pcMiscPrelId traceIdKey iO_BASE SLIT("trace") traceTy
127 (noIdInfo `addSpecInfo` pcGenerateSpecs traceIdKey tRACE_ID noIdInfo traceTy)
129 traceTy = mkSigmaTy [alphaTyVar] [] (mkFunTys [mkListTy charTy, alphaTy] alphaTy)
132 %************************************************************************
134 \subsection[PrelVals-Integer-support]{To support @Integer@ and @String@ literals}
136 %************************************************************************
140 = pcMiscPrelId packCStringIdKey{-ToDo:rename-} pACKED_STRING SLIT("packCString#")
141 (mkFunTys [stringTy] byteArrayPrimTy) noIdInfo
143 --------------------------------------------------------------------
146 = pcMiscPrelId unpackCStringIdKey pACKED_STRING SLIT("unpackCString#")
147 (mkFunTys [addrPrimTy{-a char *-}] stringTy) noIdInfo
149 -- (FunTy addrPrimTy{-a char *-} stringTy) (noIdInfo `addInfo` exactArity 1)
150 -- but I don't like wired-in IdInfos (WDP)
152 unpackCString2Id -- for cases when a string has a NUL in it
153 = pcMiscPrelId unpackCString2IdKey pACKED_STRING SLIT("unpackNBytes#")
154 (mkFunTys [addrPrimTy{-a char *-}, intPrimTy{-length-}] stringTy)
157 --------------------------------------------------------------------
158 unpackCStringAppendId
159 = pcMiscPrelId unpackCStringAppendIdKey pACKED_STRING SLIT("unpackAppendCString#")
160 (mkFunTys [addrPrimTy{-a "char *" pointer-},stringTy] stringTy)
162 {-LATER:`addUnfoldInfo` mkMagicUnfolding unpackCStringAppendIdKey-})
163 `addArityInfo` exactArity 2)
166 = pcMiscPrelId unpackCStringFoldrIdKey pACKED_STRING SLIT("unpackFoldrCString#")
167 (mkSigmaTy [alphaTyVar] []
168 (mkFunTys [addrPrimTy{-a "char *" pointer-},
169 mkFunTys [charTy, alphaTy] alphaTy,
173 {-LATER:`addUnfoldInfo` mkMagicUnfolding unpackCStringFoldrIdKey-})
174 `addArityInfo` exactArity 3)
177 OK, this is Will's idea: we should have magic values for Integers 0,
178 +1, +2, and -1 (go ahead, fire me):
182 = pcMiscPrelId integerZeroIdKey pREL_NUM SLIT("integer_0") integerTy noIdInfo
184 = pcMiscPrelId integerPlusOneIdKey pREL_NUM SLIT("integer_1") integerTy noIdInfo
186 = pcMiscPrelId integerPlusTwoIdKey pREL_NUM SLIT("integer_2") integerTy noIdInfo
188 = pcMiscPrelId integerMinusOneIdKey pREL_NUM SLIT("integer_m1") integerTy noIdInfo
191 %************************************************************************
193 \subsection[PrelVals-parallel]{@seq@ and @par@: for parallel operation (only)}
195 %************************************************************************
199 --------------------------------------------------------------------
200 -- seqId :: "seq", used w/ GRIP, etc., is really quite similar to
204 seq = /\ a b -> \ x y -> case x of { _ -> y }
207 seq = /\ a b -> \ x y -> case seq# x y of { _Lift y' -> y' }
210 seq = /\ a b -> \ x::a y::b -> case seq# x of { 0# -> parError#; _ -> y; }
214 seqId = pcMiscPrelId seqIdKey pRELUDE SLIT("seq")
215 (mkSigmaTy [alphaTyVar, betaTyVar] []
216 (mkFunTys [alphaTy, betaTy] betaTy))
217 (noIdInfo `addUnfoldInfo` (mk_inline_unfolding seq_template))
227 = mkLam [alphaTyVar, betaTyVar] [x, y] (
228 Case (Prim SeqOp [TyArg alphaTy, VarArg x]) (
230 [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [betaTy])]
231 (BindDefault z (Var y))))
233 --------------------------------------------------------------------
234 -- parId :: "par", also used w/ GRIP, etc.
238 par = /\ a b -> \ x y -> case (par# (case x of { _ -> () })) of { _ -> y }
242 par = /\ a b -> \ x y -> case par# x y of { _Lift y' -> y' }
246 par = /\ a b -> \ x::a y::b -> case par# x of { 0# -> parError#; _ -> y; }
249 parId = pcMiscPrelId parIdKey cONC_BASE SLIT("par")
250 (mkSigmaTy [alphaTyVar, betaTyVar] []
251 (mkFunTys [alphaTy, betaTy] betaTy))
252 (noIdInfo `addUnfoldInfo` (mk_inline_unfolding par_template))
262 = mkLam [alphaTyVar, betaTyVar] [x, y] (
263 Case (Prim ParOp [TyArg alphaTy, VarArg x]) (
265 [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [betaTy])]
266 (BindDefault z (Var y))))
268 -- forkId :: "fork", for *required* concurrent threads
270 _fork_ = /\ a b -> \ x::a y::b -> case fork# x of { 0# -> parError#; _ -> y; }
272 forkId = pcMiscPrelId forkIdKey cONC_BASE SLIT("fork")
273 (mkSigmaTy [alphaTyVar, betaTyVar] []
274 (mkFunTys [alphaTy, betaTy] betaTy))
275 (noIdInfo `addUnfoldInfo` (mk_inline_unfolding fork_template))
285 = mkLam [alphaTyVar, betaTyVar] [x, y] (
286 Case (Prim ForkOp [TyArg alphaTy, VarArg x]) (
288 [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [betaTy])]
289 (BindDefault z (Var y))))
296 parLocalId = pcMiscPrelId parLocalIdKey cONC_BASE SLIT("parLocal")
297 (mkSigmaTy [alphaTyVar, betaTyVar] []
298 (mkFunTys [intPrimTy, intPrimTy, intPrimTy, intPrimTy, alphaTy, betaTy] betaTy))
299 (noIdInfo `addUnfoldInfo` (mk_inline_unfolding parLocal_template))
301 -- Annotations: w: name, g: gran. info, s: size info, p: par info -- HWL
302 [w, g, s, p, x, y, z]
314 = mkLam [alphaTyVar, betaTyVar] [w, g, s, p, x, y] (
315 Case (Prim ParLocalOp [TyArg alphaTy, TyArg betaTy, VarArg x, VarArg w, VarArg g, VarArg s, VarArg p, VarArg y]) (
317 [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [betaTy])]
318 (BindDefault z (Var y))))
320 parGlobalId = pcMiscPrelId parGlobalIdKey cONC_BASE SLIT("parGlobal")
321 (mkSigmaTy [alphaTyVar, betaTyVar] []
322 (mkFunTys [intPrimTy, intPrimTy, intPrimTy, intPrimTy, alphaTy, betaTy] betaTy))
323 (noIdInfo `addUnfoldInfo` (mk_inline_unfolding parGlobal_template))
325 -- Annotations: w: name, g: gran. info, s: size info, p: par info -- HWL
326 [w, g, s, p, x, y, z]
338 = mkLam [alphaTyVar, betaTyVar] [w, g, s, p, x, y] (
339 Case (Prim ParGlobalOp [TyArg alphaTy, TyArg betaTy, VarArg x, VarArg w, VarArg g, VarArg s, VarArg p, VarArg y]) (
341 [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [betaTy])]
342 (BindDefault z (Var y))))
345 parAtId = pcMiscPrelId parAtIdKey cONC_BASE SLIT("parAt")
346 (mkSigmaTy [alphaTyVar, betaTyVar] []
347 (mkFunTys [intPrimTy, intPrimTy, intPrimTy, intPrimTy,
348 alphaTy, betaTy, gammaTy] gammaTy))
349 (noIdInfo `addUnfoldInfo` (mk_inline_unfolding parAt_template))
351 -- Annotations: w: name, g: gran. info, s: size info, p: par info -- HWL
352 [w, g, s, p, v, x, y, z]
365 = mkLam [alphaTyVar, betaTyVar, gammaTyVar] [w, g, s, p, v, x, y] (
366 Case (Prim ParAtOp [TyArg alphaTy, TyArg betaTy, TyArg gammaTy, VarArg x, VarArg v, VarArg w, VarArg g, VarArg s, VarArg p, VarArg y]) (
368 [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [gammaTy])]
369 (BindDefault z (Var y))))
371 parAtAbsId = pcMiscPrelId parAtAbsIdKey cONC_BASE SLIT("parAtAbs")
372 (mkSigmaTy [alphaTyVar, betaTyVar] []
373 (mkFunTys [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, alphaTy, betaTy] betaTy))
374 (noIdInfo `addUnfoldInfo` (mk_inline_unfolding parAtAbs_template))
376 -- Annotations: w: name, g: gran. info, s: size info, p: par info -- HWL
377 [w, g, s, p, v, x, y, z]
390 = mkLam [alphaTyVar, betaTyVar] [w, g, s, p, v, x, y] (
391 Case (Prim ParAtAbsOp [TyArg alphaTy, TyArg betaTy, VarArg x, VarArg v, VarArg w, VarArg g, VarArg s, VarArg p, VarArg y]) (
393 [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [betaTy])]
394 (BindDefault z (Var y))))
396 parAtRelId = pcMiscPrelId parAtRelIdKey cONC_BASE SLIT("parAtRel")
397 (mkSigmaTy [alphaTyVar, betaTyVar] []
398 (mkFunTys [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, alphaTy, betaTy] betaTy))
399 (noIdInfo `addUnfoldInfo` (mk_inline_unfolding parAtRel_template))
401 -- Annotations: w: name, g: gran. info, s: size info, p: par info -- HWL
402 [w, g, s, p, v, x, y, z]
415 = mkLam [alphaTyVar, betaTyVar] [w, g, s, p, v, x, y] (
416 Case (Prim ParAtRelOp [TyArg alphaTy, TyArg betaTy, VarArg x, VarArg v, VarArg w, VarArg g, VarArg s, VarArg p, VarArg y]) (
418 [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [betaTy])]
419 (BindDefault z (Var y))))
421 parAtForNowId = pcMiscPrelId parAtForNowIdKey cONC_BASE SLIT("parAtForNow")
422 (mkSigmaTy [alphaTyVar, betaTyVar] []
423 (mkFunTys [intPrimTy, intPrimTy, intPrimTy, intPrimTy,
424 alphaTy, betaTy, gammaTy] gammaTy))
425 (noIdInfo `addUnfoldInfo` (mk_inline_unfolding parAtForNow_template))
427 -- Annotations: w: name, g: gran. info, s: size info, p: par info -- HWL
428 [w, g, s, p, v, x, y, z]
441 = mkLam [alphaTyVar, betaTyVar, gammaTyVar] [w, g, s, p, v, x, y] (
442 Case (Prim ParAtForNowOp [TyArg alphaTy, TyArg betaTy, TyArg gammaTy, VarArg x, VarArg v, VarArg w, VarArg g, VarArg s, VarArg p, VarArg y]) (
444 [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [gammaTy])]
445 (BindDefault z (Var y))))
447 -- copyable and noFollow are currently merely hooks: they are translated into
448 -- calls to the macros COPYABLE and NOFOLLOW -- HWL
450 copyableId = pcMiscPrelId copyableIdKey cONC_BASE SLIT("copyable")
451 (mkSigmaTy [alphaTyVar] []
453 (noIdInfo `addUnfoldInfo` (mk_inline_unfolding copyable_template))
455 -- Annotations: x: closure that's tagged to by copyable
463 = mkLam [alphaTyVar] [x] ( Prim CopyableOp [TyArg alphaTy, VarArg x] )
465 noFollowId = pcMiscPrelId noFollowIdKey cONC_BASE SLIT("noFollow")
466 (mkSigmaTy [alphaTyVar] []
468 (noIdInfo `addUnfoldInfo` (mk_inline_unfolding noFollow_template))
470 -- Annotations: x: closure that's tagged to not follow
478 = mkLam [alphaTyVar] [x] ( Prim NoFollowOp [TyArg alphaTy, VarArg x] )
482 @realWorld#@ used to be a magic literal, \tr{void#}. If things get
483 nasty as-is, change it back to a literal (@Literal@).
486 = pcMiscPrelId realWorldPrimIdKey gHC__ SLIT("realWorld#")
492 voidId = pc_bottoming_Id voidIdKey pREL_BASE SLIT("void") voidTy
495 %************************************************************************
497 \subsection[PrelVals-foldr-build]{Values known about for ``foldr/build''}
499 %************************************************************************
503 = pcMiscPrelId buildIdKey gHC_ERR SLIT("build") buildTy
505 {-LATER:`addUnfoldInfo` mkMagicUnfolding buildIdKey-})
506 `addStrictnessInfo` mkStrictnessInfo [WwStrict] False)
507 `addArgUsageInfo` mkArgUsageInfo [ArgUsage 2])
508 `addSpecInfo` pcGenerateSpecs buildIdKey buildId noIdInfo{-ToDo-} buildTy)
509 -- cheating, but since _build never actually exists ...
511 -- The type of this strange object is:
512 -- \/ a . (\/ b . (a -> b -> b) -> b -> b) -> [a]
514 buildTy = mkSigmaTy [alphaTyVar] [] (mkFunTys [build_ty] (mkListTy alphaTy))
516 build_ty = mkSigmaTy [betaTyVar] []
517 (mkFunTys [mkFunTys [alphaTy, betaTy] betaTy, betaTy] betaTy)
520 @mkBuild@ is sugar for building a build!
522 @mkbuild ty tv c n e@ $Rightarrow$ @build ty (/\ tv -> \ c n -> e)@
523 @ty@ is the type of the list.
524 @tv@ is always a new type variable.
525 @c,n@ are Id's for the abstract cons and nil, @g@ for let binding the argument argument.
528 v :: (\/ b . (a -> b -> b) -> b -> b) -> [a]
529 -- \/ a . (\/ b . (a -> b -> b) -> b -> b) -> [a]
530 @e@ is the object right inside the @build@
538 -> CoreExpr -- template
539 -> CoreExpr -- template
541 mkBuild ty tv c n g expr
542 = Let (NonRec g (mkLam [tv] [c,n] expr))
543 (App (mkTyApp (Var buildId) [ty]) (VarArg g))
548 = pcMiscPrelId augmentIdKey gHC_ERR SLIT("augment") augmentTy
550 {-LATER:`addUnfoldInfo` mkMagicUnfolding augmentIdKey-})
551 `addStrictnessInfo` mkStrictnessInfo [WwStrict,WwLazy False] False)
552 `addArgUsageInfo` mkArgUsageInfo [ArgUsage 2,UnknownArgUsage])
553 -- cheating, but since _augment never actually exists ...
555 -- The type of this strange object is:
556 -- \/ a . (\/ b . (a -> b -> b) -> b -> b) -> [a] -> [a]
558 augmentTy = mkSigmaTy [alphaTyVar] [] (mkFunTys [aug_ty, mkListTy alphaTy] (mkListTy alphaTy))
560 aug_ty = mkSigmaTy [betaTyVar] []
561 (mkFunTys [mkFunTys [alphaTy, betaTy] betaTy, betaTy] betaTy)
565 foldrId = pcMiscPrelId foldrIdKey pREL_BASE SLIT("foldr")
569 mkSigmaTy [alphaTyVar, betaTyVar] []
570 (mkFunTys [mkFunTys [alphaTy, betaTy] betaTy, betaTy, mkListTy alphaTy] betaTy)
572 idInfo = (((((noIdInfo
573 {-LATER:`addUnfoldInfo` mkMagicUnfolding foldrIdKey-})
574 `addStrictnessInfo` mkStrictnessInfo [WwLazy False,WwLazy False,WwStrict] False)
575 `addArityInfo` exactArity 3)
576 `addUpdateInfo` mkUpdateInfo [2,2,1])
577 `addSpecInfo` pcGenerateSpecs foldrIdKey foldrId noIdInfo{-ToDo-} foldrTy)
579 foldlId = pcMiscPrelId foldlIdKey pREL_LIST SLIT("foldl")
583 mkSigmaTy [alphaTyVar, betaTyVar] []
584 (mkFunTys [mkFunTys [alphaTy, betaTy] alphaTy, alphaTy, mkListTy betaTy] alphaTy)
586 idInfo = (((((noIdInfo
587 {-LATER:`addUnfoldInfo` mkMagicUnfolding foldlIdKey-})
588 `addStrictnessInfo` mkStrictnessInfo [WwLazy False,WwLazy False,WwStrict] False)
589 `addArityInfo` exactArity 3)
590 `addUpdateInfo` mkUpdateInfo [2,2,1])
591 `addSpecInfo` pcGenerateSpecs foldlIdKey foldlId noIdInfo{-ToDo-} foldlTy)
593 -- A bit of magic goes no here. We translate appendId into ++,
594 -- you have to be carefull when you actually compile append:
595 -- xs ++ ys = augment (\ c n -> foldr c n xs) ys
596 -- {- unfold augment -}
598 -- {- fold foldr to append -}
599 -- = ys `appendId` xs
600 -- = ys ++ xs -- ugg!
601 -- *BUT* you want (++) and not _append in your interfaces.
603 -- So you have to turn *off* unfolding of foldr inside FoldrBuild.hs inside
606 {- OLD: doesn't apply with 1.3
608 = pcMiscPrelId appendIdKey mONAD SLIT("++") appendTy idInfo
611 (mkSigmaTy [alphaTyVar] []
612 (mkFunTys [mkListTy alphaTy, mkListTy alphaTy] (mkListTy alphaTy)))
614 `addStrictnessInfo` mkStrictnessInfo [WwStrict,WwLazy False] False)
615 `addArityInfo` exactArity 2)
616 `addUpdateInfo` mkUpdateInfo [1,2])
620 %************************************************************************
622 \subsection[PrelUtils-specialisations]{Specialisations for builtin values}
624 %************************************************************************
626 The specialisations which exist for the builtin values must be recorded in
629 NOTE: THE USES OF THE pcGenerate... FUNCTIONS MUST CORRESPOND
630 TO THE SPECIALISATIONS DECLARED IN THE PRELUDE !!!
632 HACK: We currently use the same unique for the specialised Ids.
634 The list @specing_types@ determines the types for which specialised
635 versions are created. Note: This should correspond with the
636 types passed to the pre-processor with the -genSPECS arg (see ghc.lprl).
638 ToDo: Create single mkworld definition which is grabbed here and in ghc.lprl
641 pcGenerateSpecs :: Unique -> Id -> IdInfo -> Type -> IdSpecEnv
642 pcGenerateSpecs key id info ty
647 pc_gen_specs True key id info ty
649 pc_gen_specs is_id key id info ty
650 = mkSpecEnv spec_infos
652 spec_infos = [ let spec_ty = specialiseTy ty spec_tys 0
654 then mkSpecId key {- HACK WARNING: same unique! -}
655 id spec_tys spec_ty info
656 else panic "SpecData:SpecInfo:SpecId"
658 SpecInfo spec_tys (length ctxts) spec_id
659 | spec_tys <- specialisations ]
661 (tyvars, ctxts, _) = splitSigmaTy ty
662 no_tyvars = length tyvars
664 specialisations = if no_tyvars == 0
666 else tail (cross_product no_tyvars specing_types)
668 -- N.B. tail removes fully polymorphic specialisation
670 cross_product 0 tys = []
671 cross_product 1 tys = map (:[]) tys
672 cross_product n tys = concat [map (:cp) tys | cp <- cross_product (n-1) tys]
675 specing_types = [Nothing,