2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
4 \section[PrelVals]{Prelude values the compiler ``knows about''}
7 #include "HsVersions.h"
11 import PrelFuns -- help functions, types and things
12 import BasicLit ( mkMachInt, BasicLit(..), PrimKind )
16 import TyPod ( mkPodNTy ,mkPodTy )
17 import TyProcs ( mkProcessorTy )
18 #endif {- Data Parallel Haskell -}
22 import Id ( mkTemplateLocals, mkTupleCon, getIdUniType,
26 import AbsUniType ( mkSigmaTy, mkDictTy, mkTyVarTy , SigmaType(..),
27 applyTyCon, splitType, specialiseTy
29 import Id ( mkTemplateLocals, mkTupleCon, getIdUniType,
30 mkSpecId, mkProcessorCon
32 #endif {- Data Parallel Haskell -}
35 import Maybes ( Maybe(..) )
36 import PlainCore -- to make unfolding templates
37 import Unique -- *Key things
41 %************************************************************************
43 \subsection[PrelVals-error-related]{@error@ and friends; @trace@}
45 %************************************************************************
47 GHC randomly injects these into the code.
49 @patError#@ is just a version of @error@ for pattern-matching
50 failures. It knows various ``codes'' which expand to longer
51 strings---this saves space!
53 @absent#@ is a thing we put in for ``absent'' arguments. They jolly
54 well shouldn't be yanked on, but if one is, then you will get a
55 friendly message from @absent#@ (rather a totally random crash).
57 @parError#@ is a special version of @error@ which the compiler does
58 not know to be a bottoming Id. It is used in the @_par_@ and @_seq_@
59 templates, but we don't ever expect to generate code for it.
62 pc_bottoming_Id key mod name ty
63 = pcMiscPrelId key mod name ty bottoming_info
65 bottoming_info = noIdInfo `addInfo` mkBottomStrictnessInfo
66 -- these "bottom" out, no matter what their arguments
69 = pc_bottoming_Id errorIdKey pRELUDE_BUILTIN SLIT("error") errorTy
72 = pc_bottoming_Id patErrorIdKey pRELUDE_BUILTIN SLIT("patError#") errorTy
75 = pc_bottoming_Id absentErrorIdKey pRELUDE_BUILTIN SLIT("absent#")
76 (mkSigmaTy [alpha_tv] [] alpha)
79 = pcMiscPrelId parErrorIdKey pRELUDE_BUILTIN SLIT("parError#")
80 (mkSigmaTy [alpha_tv] [] alpha) noIdInfo
83 errorTy = mkSigmaTy [alpha_tv] [] (UniFun (mkListTy charTy) alpha)
86 We want \tr{_trace} (NB: name not in user namespace) to be wired in
87 because we don't want the strictness analyser to get ahold of it,
88 decide that the second argument is strict, evaluate that first (!!),
89 and make a jolly old mess. Having \tr{_trace} wired in also helps when
90 attempting to re-export it---because it's in \tr{PreludeBuiltin}, it
91 won't get an \tr{import} declaration in the interface file, so the
92 importing-subsequently module needs to know it's magic.
95 = pcMiscPrelId traceIdKey pRELUDE_BUILTIN SLIT("_trace") traceTy
96 (noIdInfo `addInfo` pcGenerateSpecs traceIdKey tRACE_ID noIdInfo traceTy)
98 traceTy = mkSigmaTy [alpha_tv] [] (UniFun (mkListTy charTy) (UniFun alpha alpha))
101 %************************************************************************
103 \subsection[PrelVals-Integer-support]{To support @Integer@ and @String@ literals}
105 %************************************************************************
110 = pcMiscPrelId int2IntegerIdKey pRELUDE_BUILTIN SLIT("_int2Integer")
111 (UniFun intTy integerTy)
115 --------------------------------------------------------------------
118 = pcMiscPrelId packCStringIdKey{-ToDo:rename-} pRELUDE_PS SLIT("_packStringForC")
119 (UniFun stringTy byteArrayPrimTy) noIdInfo
121 --------------------------------------------------------------------
124 = pcMiscPrelId unpackCStringIdKey pRELUDE_BUILTIN SLIT("unpackPS#")
125 (addrPrimTy{-a char *-} `UniFun` stringTy) noIdInfo
127 -- (UniFun addrPrimTy{-a char *-} stringTy) (noIdInfo `addInfo` mkArityInfo 1)
128 -- but I don't like wired-in IdInfos (WDP)
130 unpackCString2Id -- for cases when a string has a NUL in it
131 = pcMiscPrelId unpackCString2IdKey pRELUDE_BUILTIN SLIT("unpackPS2#")
132 (addrPrimTy{-a char *-}
133 `UniFun` (intPrimTy -- length
134 `UniFun` stringTy)) noIdInfo
137 --------------------------------------------------------------------
138 unpackCStringAppendId
139 = pcMiscPrelId unpackCStringAppendIdKey pRELUDE_BUILTIN SLIT("unpackAppendPS#")
140 (addrPrimTy{-a "char *" pointer-}
142 `UniFun` stringTy)) ((noIdInfo
143 `addInfo_UF` mkMagicUnfolding SLIT("unpackAppendPS#"))
144 `addInfo` mkArityInfo 2)
147 = pcMiscPrelId unpackCStringFoldrIdKey pRELUDE_BUILTIN SLIT("unpackFoldrPS#")
148 (mkSigmaTy [alpha_tv] []
149 (addrPrimTy{-a "char *" pointer-}
150 `UniFun` ((charTy `UniFun` (alpha `UniFun` alpha))
152 `UniFun` alpha)))) ((noIdInfo
153 `addInfo_UF` mkMagicUnfolding SLIT("unpackFoldrPS#"))
154 `addInfo` mkArityInfo 3)
157 OK, this is Will's idea: we should have magic values for Integers 0,
158 +1, +2, and -1 (go ahead, fire me):
161 = pcMiscPrelId integerZeroIdKey pRELUDE_CORE SLIT("__integer0") integerTy noIdInfo
163 = pcMiscPrelId integerPlusOneIdKey pRELUDE_CORE SLIT("__integer1") integerTy noIdInfo
165 = pcMiscPrelId integerPlusTwoIdKey pRELUDE_CORE SLIT("__integer2") integerTy noIdInfo
167 = pcMiscPrelId integerMinusOneIdKey pRELUDE_CORE SLIT("__integerm1") integerTy noIdInfo
170 %************************************************************************
172 \subsection[PrelVals-parallel]{@seq@ and @par@: for parallel operation (only)}
174 %************************************************************************
176 In the definitions that follow, we use the @TyVar@-based
177 alpha/beta/gamma types---not the usual @TyVarTemplate@ ones.
179 This is so the @TyVars@ in the @CoTyLams@ (@alpha_tyvar@, etc) match
180 up with those in the types of the {\em lambda-bound} template-locals
181 we create (using types @alpha_ty@, etc.).
184 --------------------------------------------------------------------
185 -- seqId :: "_seq_", used w/ GRIP, etc., is really quite similar to
189 _seq_ = /\ a b -> \ x y -> case x of { _ -> y }
192 _seq_ = /\ a b -> \ x y -> case seq# x y of { _Lift y' -> y' }
195 _seq_ = /\ a b -> \ x::a y::b -> case seq# x of { 0# -> parError#; _ -> y; }
199 seqId = pcMiscPrelId seqIdKey pRELUDE_BUILTIN SLIT("_seq_")
200 (mkSigmaTy [alpha_tv, beta_tv] []
201 (alpha `UniFun` (beta `UniFun` beta)))
202 (noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding seq_template))
212 = CoTyLam alpha_tyvar
215 CoCase (CoPrim SeqOp [alpha_ty] [CoVarAtom x]) (
217 [(mkMachInt 0, CoTyApp (CoVar pAR_ERROR_ID) beta_ty)]
218 (CoBindDefault z (CoVar y))))))
220 --------------------------------------------------------------------
221 -- parId :: "_par_", also used w/ GRIP, etc.
225 par = /\ a b -> \ x y -> case (par# (case x of { _ -> () })) of { _ -> y }
229 _par_ = /\ a b -> \ x y -> case par# x y of { _Lift y' -> y' }
233 _par_ = /\ a b -> \ x::a y::b -> case par# x of { 0# -> parError#; _ -> y; }
236 parId = pcMiscPrelId parIdKey pRELUDE_BUILTIN SLIT("_par_")
237 (mkSigmaTy [alpha_tv, beta_tv] []
238 (alpha `UniFun` (beta `UniFun` beta)))
239 (noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding par_template))
249 = CoTyLam alpha_tyvar
252 CoCase (CoPrim ParOp [alpha_ty] [CoVarAtom x]) (
254 [(mkMachInt 0, CoTyApp (CoVar pAR_ERROR_ID) beta_ty)]
255 (CoBindDefault z (CoVar y))))))
257 -- forkId :: "_fork_", for *required* concurrent threads
259 _fork_ = /\ a b -> \ x::a y::b -> case fork# x of { 0# -> parError#; _ -> y; }
261 forkId = pcMiscPrelId forkIdKey pRELUDE_BUILTIN SLIT("_fork_")
262 (mkSigmaTy [alpha_tv, beta_tv] []
263 (alpha `UniFun` (beta `UniFun` beta)))
264 (noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding fork_template))
274 = CoTyLam alpha_tyvar
277 CoCase (CoPrim ForkOp [alpha_ty] [CoVarAtom x]) (
279 [(mkMachInt 0, CoTyApp (CoVar pAR_ERROR_ID) beta_ty)]
280 (CoBindDefault z (CoVar y))))))
287 parLocalId = pcMiscPrelId parLocalIdKey pRELUDE_BUILTIN SLIT("_parLocal_")
288 (mkSigmaTy [alpha_tv, beta_tv] []
289 (intPrimTy `UniFun` (alpha `UniFun` (beta `UniFun` beta))))
290 (noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding parLocal_template))
301 = CoTyLam alpha_tyvar
304 CoCase (CoPrim ParLocalOp [alpha_ty, beta_ty] [CoVarAtom x, CoVarAtom w, CoVarAtom y]) (
306 [(liftDataCon, [z], CoVar z)]
309 parGlobalId = pcMiscPrelId parGlobalIdKey pRELUDE_BUILTIN SLIT("_parGlobal_")
310 (mkSigmaTy [alpha_tv, beta_tv] []
311 (intPrimTy `UniFun` (alpha `UniFun` (beta `UniFun` beta))))
312 (noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding parGlobal_template))
323 = CoTyLam alpha_tyvar
326 CoCase (CoPrim ParGlobalOp [alpha_ty, beta_ty] [CoVarAtom x, CoVarAtom w, CoVarAtom y]) (
328 [(liftDataCon, [z], CoVar z)]
336 vectorMapId = pcChooseToKnowId vectorMapU pRELUDE "vectorMap"
337 (mkSigmaTy [alpha_tv, beta_tv , gamma_tv]
339 ((beta `UniFun` gamma) `UniFun`
340 ((mkPodTy (mkProcessorTy [alpha] beta)) `UniFun`
341 (mkPodTy (mkProcessorTy [alpha] gamma)))))
342 (panic "vectorMap:unfolding")--ToDo:DPH: (mkUnfoldTemplate vector_map_template)
346 vectorMap fn vec = << (|x;fn y|) | (|x;y|) <<- vec >>
349 vectorMap :: for all a.83, b.82, c.86. <Pid a.83>
354 /\ t83 t82 o86 -> \ dict.127 ->
358 << let si.133 = fn.129 ds.132 in
362 dict.127 ((toDomain t82) dict.127 ds.131)
363 in MkProcessor1! Integer o86 si.134 si.133 |
364 (| ds.131 ; ds.132 |) <<- vec.130 >>
367 NOTE : no need to bother with overloading in class Pid; because the result
368 PID (si.133) is wrapped in fromDomain.toDomain == id . Therefore we
369 use the simplification below.
373 for all d.83, e.82, f.86.
374 <Pid e.82> -> (d.83 -> f.86) -> <<e.82;d.83>> -> <<e.82;f.86>>
376 /\ t83 t82 o86 -> \ dict.127 fn.129 vec.130 ->
377 << MkProcessor1! Integer o86 ds.131 (fn.129 ds.132) |
378 (| ds.131 ; ds.132 |) <<- vec.130 >>
383 [dict,fn,vec,ds131,ds132]
385 [mkDictTy pidClass alpha_ty,
386 beta_ty `UniFun` gamma_ty,
387 mkPodTy (mkProcessorTy [alpha_ty] beta_ty),
394 (mkCoLam [dict,fn,vec]
396 (CoCon (mkProcessorCon 1)
397 [integerTy,mkTyVarTy gamma_tyvar]
399 (CoApp (CoVar fn) (CoVar ds132))])
400 (CoDrawnGen [ds131] ds132 (CoVar vec)) ))))
402 #endif {- Data Parallel Haskell -}
407 -- A function used during podization that produces an index POD for a given
410 primIfromPodNSelectorId :: Int -> Int -> Id
411 primIfromPodNSelectorId i n
415 ("prim"++ show i ++ "fromPod" ++ show n ++ "Selector")
420 #endif {- Data Parallel Haskell -}
423 %************************************************************************
425 \subsection[PrelVals-deriving]{Values known about mainly for doing derived instance decls}
427 %************************************************************************
429 map :: (a -> b) -> [a] -> [b]
430 -- this is up in the here-because-of-unfolding list
432 --??showChar :: Char -> ShowS
433 showSpace :: ShowS -- non-std: == "showChar ' '"
434 showString :: String -> ShowS
435 showParen :: Bool -> ShowS -> ShowS
437 (++) :: [a] -> [a] -> [a]
438 readParen :: Bool -> ReadS a -> ReadS a
443 readS_ty :: UniType -> UniType
445 = UniFun stringTy (mkListTy (mkTupleTy 2 [ty, stringTy]))
448 showS_ty = UniFun stringTy stringTy
454 showSpaceId = pcMiscPrelId showSpaceIdKey pRELUDE_TEXT SLIT("_showSpace")
458 showParenId = pcMiscPrelId showParenIdKey pRELUDE_TEXT SLIT("showParen")
459 (boolTy `UniFun` (showS_ty `UniFun` showS_ty))
462 readParenId = pcMiscPrelId readParenIdKey pRELUDE_TEXT SLIT("readParen")
463 (mkSigmaTy [alpha_tv] [] (
465 (readS_ty alpha) `UniFun` (readS_ty alpha))))
468 lexId = pcMiscPrelId lexIdKey pRELUDE_TEXT SLIT("lex")
469 (readS_ty (mkListTy charTy))
474 %************************************************************************
476 \subsection[PrelVals-void]{@void#@: Magic value of type @Void#@}
478 %************************************************************************
480 I don't think this is available to the user; it's used in the
481 simplifier (WDP 94/06).
484 = pcMiscPrelId voidPrimIdKey pRELUDE_BUILTIN SLIT("void#")
488 %************************************************************************
490 \subsection[PrelVals-runST]{@_runST@: Magic start-state-transformer function}
492 %************************************************************************
494 @_runST@ has a non-Haskell-able type:
496 -- _runST :: forall a. (forall s. _ST s a) -> a
497 -- which is to say ::
498 -- forall a. (forall s. (_State s -> (a, _State s))) -> a
500 _runST a m = case m _RealWorld (S# _RealWorld realWorld#) of
501 (r :: a, wild :: _State _RealWorld) -> r
503 We unfold always, just for simplicity:
506 = pcMiscPrelId runSTIdKey pRELUDE_BUILTIN SLIT("_runST") run_ST_ty id_info
511 st_ty a = mkSigmaTy [s_tv] [] (mkStateTransformerTy s a)
514 = mkSigmaTy [alpha_tv] [] (st_ty alpha `UniFun` alpha)
515 -- NB: rank-2 polymorphism! (forall inside the st_ty...)
519 `addInfo` mkArityInfo 1
520 `addInfo` mkStrictnessInfo [WwStrict] Nothing
521 `addInfo` mkArgUsageInfo [ArgUsage 1]
522 -- ABSOLUTELY NO UNFOLDING, e.g.: (mkUnfolding EssentialUnfolding run_ST_template)
527 {-m-} st_ty alpha_ty,
528 {-t-} realWorldStateTy,
530 {-_-} realWorldStateTy
534 = CoTyLam alpha_tyvar
536 CoLet (CoNonRec t (CoCon stateDataCon [realWorldTy] [CoVarAtom realWorldPrimId])) (
537 CoCase (CoApp (mkCoTyApp (CoVar m) realWorldTy) (CoVarAtom t)) (
539 [(mkTupleCon 2, [r, wild], CoVar r)]
544 SLPJ 95/04: Why @_runST@ must not have an unfolding; consider:
548 (a, s') = newArray# 100 [] s
549 (_, s'') = fill_in_array_or_something a x s'
553 If we inline @_runST@, we'll get:
556 (a, s') = newArray# 100 [] realWorld#{-NB-}
557 (_, s'') = fill_in_array_or_something a x s'
561 And now the @newArray#@ binding can be floated to become a CAF, which
562 is totally and utterly wrong:
565 (a, s') = newArray# 100 [] realWorld#{-NB-} -- YIKES!!!
568 let (_, s'') = fill_in_array_or_something a x s' in
571 All calls to @f@ will share a {\em single} array! End SLPJ 95/04.
573 @realWorld#@ used to be a magic literal, \tr{void#}. If things get
574 nasty as-is, change it back to a literal (@BasicLit@).
577 = pcMiscPrelId realWorldPrimIdKey pRELUDE_BUILTIN SLIT("realWorld#")
582 %************************************************************************
584 \subsection[PrelVals-foldr-build]{Values known about for ``foldr/build''}
586 %************************************************************************
590 rangeComplaint_Ix_IntId
591 = pcMiscPrelId rangeComplaintIdKey pRELUDE_BUILTIN SLIT("_rangeComplaint_Ix_Int") my_ty id_info
594 = mkSigmaTy [alpha_tv] [] (
597 intPrimTy `UniFun` alpha)))
600 `addInfo` mkArityInfo 3
601 `addInfo` mkBottomStrictnessInfo
607 = pcMiscPrelId buildIdKey pRELUDE_CORE SLIT("_build") buildTy
609 `addInfo_UF` mkMagicUnfolding SLIT("build"))
610 `addInfo` mkStrictnessInfo [WwStrict] Nothing)
611 `addInfo` mkArgUsageInfo [ArgUsage 2])
612 `addInfo` pcGenerateSpecs buildIdKey buildId noIdInfo{-ToDo-} buildTy)
613 -- cheating, but since _build never actually exists ...
615 -- The type of this strange object is:
616 -- \/ a . (\/ b . (a -> b -> b) -> b -> b) -> [a]
618 buildTy = mkSigmaTy [alpha_tv] [] (buildUniTy `UniFun` (mkListTy alpha))
620 buildUniTy = mkSigmaTy [beta_tv] []
621 ((alpha `UniFun` (beta `UniFun` beta))
622 `UniFun` (beta `UniFun` beta))
625 @mkBuild@ is sugar for building a build!
627 @mkbuild ty tv c n e@ $Rightarrow$ @build ty (/\ tv -> \ c n -> e)@
628 @ty@ is the type of the list.
629 @tv@ is always a new type variable.
630 @c,n@ are Id's for the abstract cons and nil, @g@ for let binding the argument argument.
633 v :: (\/ b . (a -> b -> b) -> b -> b) -> [a]
634 -- \/ a . (\/ b . (a -> b -> b) -> b -> b) -> [a]
635 @e@ is the object right inside the @build@
643 -> PlainCoreExpr -- template
644 -> PlainCoreExpr -- template
646 mkBuild ty tv c n g expr
647 = CoLet (CoNonRec g (CoTyLam tv (mkCoLam [c,n] expr)))
648 (CoApp (mkCoTyApp (CoVar buildId) ty) (CoVarAtom g))
653 = pcMiscPrelId buildIdKey pRELUDE_CORE SLIT("_augment") augmentTy
655 `addInfo_UF` mkMagicUnfolding SLIT("augment"))
656 `addInfo` mkStrictnessInfo [WwStrict,WwLazy False] Nothing)
657 `addInfo` mkArgUsageInfo [ArgUsage 2,UnknownArgUsage])
658 -- cheating, but since _build never actually exists ...
660 -- The type of this strange object is:
661 -- \/ a . (\/ b . (a -> b -> b) -> b -> b) -> [a] -> [a]
663 augmentTy = mkSigmaTy [alpha_tv] [] (buildUniTy `UniFun`
664 (mkListTy alpha `UniFun` mkListTy alpha))
666 buildUniTy = mkSigmaTy [beta_tv] []
667 ((alpha `UniFun` (beta `UniFun` beta))
668 `UniFun` (beta `UniFun` beta))
671 mkFoldr ty_a ty_b [x,y...] => foldr ty_a ty_b x y ..
674 foldrId = pcMiscPrelId foldrIdKey pRELUDE_FB{-not "List"-} SLIT("foldr")
678 mkSigmaTy [alpha_tv, beta_tv] []
679 ((alpha `UniFun` (beta `UniFun` beta))
681 `UniFun` ((mkListTy alpha)
684 idInfo = (((((noIdInfo
685 `addInfo_UF` mkMagicUnfolding SLIT("foldr"))
686 `addInfo` mkStrictnessInfo [WwLazy False,WwLazy False,WwStrict] Nothing)
687 `addInfo` mkArityInfo 3)
688 `addInfo` mkUpdateInfo [2,2,1])
689 `addInfo` pcGenerateSpecs foldrIdKey foldrId noIdInfo{-ToDo-} foldrTy)
691 mkFoldr a b f z xs = foldl CoApp
692 (mkCoTyApps (CoVar foldrId) [a, b])
693 [CoVarAtom f,CoVarAtom z,CoVarAtom xs]
695 foldlId = pcMiscPrelId foldlIdKey pRELUDE_FB{-not "List"-} SLIT("foldl")
699 mkSigmaTy [alpha_tv, beta_tv] []
700 ((alpha `UniFun` (beta `UniFun` alpha))
702 `UniFun` ((mkListTy beta)
705 idInfo = (((((noIdInfo
706 `addInfo_UF` mkMagicUnfolding SLIT("foldl"))
707 `addInfo` mkStrictnessInfo [WwLazy False,WwLazy False,WwStrict] Nothing)
708 `addInfo` mkArityInfo 3)
709 `addInfo` mkUpdateInfo [2,2,1])
710 `addInfo` pcGenerateSpecs foldlIdKey foldlId noIdInfo{-ToDo-} foldlTy)
712 mkFoldl a b f z xs = foldl CoApp
713 (mkCoTyApps (CoVar foldlId) [a, b])
714 [CoVarAtom f,CoVarAtom z,CoVarAtom xs]
716 -- A bit of magic goes no here. We translate appendId into ++,
717 -- you have to be carefull when you actually compile append:
718 -- xs ++ ys = augment (\ c n -> foldr c n xs) ys
719 -- {- unfold augment -}
721 -- {- fold foldr to append -}
722 -- = ys `appendId` xs
723 -- = ys ++ xs -- ugg!
724 -- *BUT* you want (++) and not _append in your interfaces.
726 -- So you have to turn *off* unfolding of foldr inside FoldrBuild.hs inside
731 = pcMiscPrelId appendIdKey pRELUDE_LIST SLIT("++") appendTy idInfo
734 (mkSigmaTy [alpha_tv] []
735 ((mkListTy alpha) `UniFun` ((mkListTy alpha) `UniFun` (mkListTy alpha))))
737 `addInfo` mkStrictnessInfo [WwStrict,WwLazy False] Nothing)
738 `addInfo` mkArityInfo 2)
739 `addInfo` mkUpdateInfo [1,2])
741 pRELUDE_FB = SLIT("PreludeFoldrBuild")