2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
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 unpackCStringIdKey pRELUDE_PS SLIT("unpackPS#")
119 (addrPrimTy{-a char *-} `UniFun` stringTy) noIdInfo
121 unpackCString2Id -- for cases when a string has a NUL in it
122 = pcMiscPrelId unpackCString2IdKey pRELUDE_PS SLIT("unpackPS2#")
123 (addrPrimTy{-a char *-}
124 `UniFun` (intPrimTy -- length
125 `UniFun` stringTy)) noIdInfo
127 --------------------------------------------------------------------
128 unpackCStringAppendId
129 = pcMiscPrelId unpackCStringAppendIdKey pRELUDE_BUILTIN SLIT("unpackCStringAppend#")
130 (addrPrimTy{-a "char *" pointer-}
132 `UniFun` stringTy)) noIdInfo
134 --------------------------------------------------------------------
137 = pcMiscPrelId packCStringIdKey{-ToDo:rename-} pRELUDE_PS SLIT("_packStringForC")
138 (UniFun stringTy byteArrayPrimTy) noIdInfo
141 OK, this is Will's idea: we should have magic values for Integers 0,
142 +1, and -1 (go ahead, fire me):
145 = pcMiscPrelId integerZeroIdKey pRELUDE_CORE SLIT("_integer_0") integerTy noIdInfo
147 = pcMiscPrelId integerPlusOneIdKey pRELUDE_CORE SLIT("_integer_1") integerTy noIdInfo
149 = pcMiscPrelId integerMinusOneIdKey pRELUDE_CORE SLIT("_integer_m1") integerTy noIdInfo
152 %************************************************************************
154 \subsection[PrelVals-parallel]{@seq@ and @par@: for parallel operation (only)}
156 %************************************************************************
158 In the definitions that follow, we use the @TyVar@-based
159 alpha/beta/gamma types---not the usual @TyVarTemplate@ ones.
161 This is so the @TyVars@ in the @CoTyLams@ (@alpha_tyvar@, etc) match
162 up with those in the types of the {\em lambda-bound} template-locals
163 we create (using types @alpha_ty@, etc.).
166 --------------------------------------------------------------------
167 -- seqId :: "_seq_", used w/ GRIP, etc., is really quite similar to
171 _seq_ = /\ a b -> \ x y -> case x of { _ -> y }
174 _seq_ = /\ a b -> \ x y -> case seq# x y of { _Lift y' -> y' }
177 _seq_ = /\ a b -> \ x::a y::b -> case seq# x of { 0# -> parError#; _ -> y; }
181 seqId = pcMiscPrelId seqIdKey pRELUDE_BUILTIN SLIT("_seq_")
182 (mkSigmaTy [alpha_tv, beta_tv] []
183 (alpha `UniFun` (beta `UniFun` beta)))
184 (noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding seq_template))
194 = CoTyLam alpha_tyvar
197 CoCase (CoPrim SeqOp [alpha_ty] [CoVarAtom x]) (
199 [(mkMachInt 0, CoTyApp (CoVar pAR_ERROR_ID) beta_ty)]
200 (CoBindDefault z (CoVar y))))))
202 --------------------------------------------------------------------
203 -- parId :: "_par_", also used w/ GRIP, etc.
207 par = /\ a b -> \ x y -> case (par# (case x of { _ -> () })) of { _ -> y }
211 _par_ = /\ a b -> \ x y -> case par# x y of { _Lift y' -> y' }
215 _par_ = /\ a b -> \ x::a y::b -> case par# x of { 0# -> parError#; _ -> y; }
218 parId = pcMiscPrelId parIdKey pRELUDE_BUILTIN SLIT("_par_")
219 (mkSigmaTy [alpha_tv, beta_tv] []
220 (alpha `UniFun` (beta `UniFun` beta)))
221 (noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding par_template))
231 = CoTyLam alpha_tyvar
234 CoCase (CoPrim ParOp [alpha_ty] [CoVarAtom x]) (
236 [(mkMachInt 0, CoTyApp (CoVar pAR_ERROR_ID) beta_ty)]
237 (CoBindDefault z (CoVar y))))))
239 -- forkId :: "_fork_", for *required* concurrent threads
241 _fork_ = /\ a b -> \ x::a y::b -> case fork# x of { 0# -> parError#; _ -> y; }
243 forkId = pcMiscPrelId forkIdKey pRELUDE_BUILTIN SLIT("_fork_")
244 (mkSigmaTy [alpha_tv, beta_tv] []
245 (alpha `UniFun` (beta `UniFun` beta)))
246 (noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding fork_template))
256 = CoTyLam alpha_tyvar
259 CoCase (CoPrim ForkOp [alpha_ty] [CoVarAtom x]) (
261 [(mkMachInt 0, CoTyApp (CoVar pAR_ERROR_ID) beta_ty)]
262 (CoBindDefault z (CoVar y))))))
269 parLocalId = pcMiscPrelId parLocalIdKey pRELUDE_BUILTIN SLIT("_parLocal_")
270 (mkSigmaTy [alpha_tv, beta_tv] []
271 (intPrimTy `UniFun` (alpha `UniFun` (beta `UniFun` beta))))
272 (noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding parLocal_template))
283 = CoTyLam alpha_tyvar
286 CoCase (CoPrim ParLocalOp [alpha_ty, beta_ty] [CoVarAtom x, CoVarAtom w, CoVarAtom y]) (
288 [(liftDataCon, [z], CoVar z)]
291 parGlobalId = pcMiscPrelId parGlobalIdKey pRELUDE_BUILTIN SLIT("_parGlobal_")
292 (mkSigmaTy [alpha_tv, beta_tv] []
293 (intPrimTy `UniFun` (alpha `UniFun` (beta `UniFun` beta))))
294 (noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding parGlobal_template))
305 = CoTyLam alpha_tyvar
308 CoCase (CoPrim ParGlobalOp [alpha_ty, beta_ty] [CoVarAtom x, CoVarAtom w, CoVarAtom y]) (
310 [(liftDataCon, [z], CoVar z)]
318 vectorMapId = pcChooseToKnowId vectorMapU pRELUDE "vectorMap"
319 (mkSigmaTy [alpha_tv, beta_tv , gamma_tv]
321 ((beta `UniFun` gamma) `UniFun`
322 ((mkPodTy (mkProcessorTy [alpha] beta)) `UniFun`
323 (mkPodTy (mkProcessorTy [alpha] gamma)))))
324 (panic "vectorMap:unfolding")--ToDo:DPH: (mkUnfoldTemplate vector_map_template)
328 vectorMap fn vec = << (|x;fn y|) | (|x;y|) <<- vec >>
331 vectorMap :: for all a.83, b.82, c.86. <Pid a.83>
336 /\ t83 t82 o86 -> \ dict.127 ->
340 << let si.133 = fn.129 ds.132 in
344 dict.127 ((toDomain t82) dict.127 ds.131)
345 in MkProcessor1! Integer o86 si.134 si.133 |
346 (| ds.131 ; ds.132 |) <<- vec.130 >>
349 NOTE : no need to bother with overloading in class Pid; because the result
350 PID (si.133) is wrapped in fromDomain.toDomain == id . Therefore we
351 use the simplification below.
355 for all d.83, e.82, f.86.
356 <Pid e.82> -> (d.83 -> f.86) -> <<e.82;d.83>> -> <<e.82;f.86>>
358 /\ t83 t82 o86 -> \ dict.127 fn.129 vec.130 ->
359 << MkProcessor1! Integer o86 ds.131 (fn.129 ds.132) |
360 (| ds.131 ; ds.132 |) <<- vec.130 >>
365 [dict,fn,vec,ds131,ds132]
367 [mkDictTy pidClass alpha_ty,
368 beta_ty `UniFun` gamma_ty,
369 mkPodTy (mkProcessorTy [alpha_ty] beta_ty),
376 (mkCoLam [dict,fn,vec]
378 (CoCon (mkProcessorCon 1)
379 [integerTy,mkTyVarTy gamma_tyvar]
381 (CoApp (CoVar fn) (CoVar ds132))])
382 (CoDrawnGen [ds131] ds132 (CoVar vec)) ))))
384 #endif {- Data Parallel Haskell -}
389 -- A function used during podization that produces an index POD for a given
392 primIfromPodNSelectorId :: Int -> Int -> Id
393 primIfromPodNSelectorId i n
397 ("prim"++ show i ++ "fromPod" ++ show n ++ "Selector")
402 #endif {- Data Parallel Haskell -}
405 %************************************************************************
407 \subsection[PrelVals-deriving]{Values known about mainly for doing derived instance decls}
409 %************************************************************************
411 map :: (a -> b) -> [a] -> [b]
412 -- this is up in the here-because-of-unfolding list
414 --??showChar :: Char -> ShowS
415 showSpace :: ShowS -- non-std: == "showChar ' '"
416 showString :: String -> ShowS
417 showParen :: Bool -> ShowS -> ShowS
419 (++) :: [a] -> [a] -> [a]
420 readParen :: Bool -> ReadS a -> ReadS a
425 readS_ty :: UniType -> UniType
427 = UniFun stringTy (mkListTy (mkTupleTy 2 [ty, stringTy]))
430 showS_ty = UniFun stringTy stringTy
436 showSpaceId = pcMiscPrelId showSpaceIdKey pRELUDE_TEXT SLIT("_showSpace")
440 showParenId = pcMiscPrelId showParenIdKey pRELUDE_TEXT SLIT("showParen")
441 (boolTy `UniFun` (showS_ty `UniFun` showS_ty))
444 readParenId = pcMiscPrelId readParenIdKey pRELUDE_TEXT SLIT("readParen")
445 (mkSigmaTy [alpha_tv] [] (
447 (readS_ty alpha) `UniFun` (readS_ty alpha))))
450 lexId = pcMiscPrelId lexIdKey pRELUDE_TEXT SLIT("lex")
451 (readS_ty (mkListTy charTy))
456 %************************************************************************
458 \subsection[PrelVals-void]{@void#@: Magic value of type @Void#@}
460 %************************************************************************
462 I don't think this is available to the user; it's used in the
463 simplifier (WDP 94/06).
466 = pcMiscPrelId voidPrimIdKey pRELUDE_BUILTIN SLIT("void#")
470 %************************************************************************
472 \subsection[PrelVals-runST]{@_runST@: Magic start-state-transformer function}
474 %************************************************************************
476 @_runST@ has a non-Haskell-able type:
478 -- _runST :: forall a. (forall s. _ST s a) -> a
479 -- which is to say ::
480 -- forall a. (forall s. (_State s -> (a, _State s))) -> a
482 _runST a m = case m _RealWorld (S# _RealWorld realWorld#) of
483 (r :: a, wild :: _State _RealWorld) -> r
485 We unfold always, just for simplicity:
488 = pcMiscPrelId runSTIdKey pRELUDE_BUILTIN SLIT("_runST") run_ST_ty id_info
493 st_ty a = mkSigmaTy [s_tv] [] (mkStateTransformerTy s a)
496 = mkSigmaTy [alpha_tv] [] (st_ty alpha `UniFun` alpha)
497 -- NB: rank-2 polymorphism! (forall inside the st_ty...)
501 `addInfo` mkArityInfo 1
502 `addInfo` mkStrictnessInfo [WwStrict] Nothing
503 -- ABSOLUTELY NO UNFOLDING, e.g.: (mkUnfolding EssentialUnfolding run_ST_template)
508 {-m-} st_ty alpha_ty,
509 {-t-} realWorldStateTy,
511 {-_-} realWorldStateTy
515 = CoTyLam alpha_tyvar
517 CoLet (CoNonRec t (CoCon stateDataCon [realWorldTy] [CoVarAtom realWorldPrimId])) (
518 CoCase (CoApp (mkCoTyApp (CoVar m) realWorldTy) (CoVarAtom t)) (
520 [(mkTupleCon 2, [r, wild], CoVar r)]
525 SLPJ 95/04: Why @_runST@ must not have an unfolding; consider:
529 (a, s') = newArray# 100 [] s
530 (_, s'') = fill_in_array_or_something a x s'
534 If we inline @_runST@, we'll get:
537 (a, s') = newArray# 100 [] realWorld#{-NB-}
538 (_, s'') = fill_in_array_or_something a x s'
542 And now the @newArray#@ binding can be floated to become a CAF, which
543 is totally and utterly wrong:
546 (a, s') = newArray# 100 [] realWorld#{-NB-} -- YIKES!!!
549 let (_, s'') = fill_in_array_or_something a x s' in
552 All calls to @f@ will share a {\em single} array! End SLPJ 95/04.
554 @realWorld#@ used to be a magic literal, \tr{void#}. If things get
555 nasty as-is, change it back to a literal (@BasicLit@).
558 = pcMiscPrelId realWorldPrimIdKey pRELUDE_BUILTIN SLIT("realWorld#")
563 %************************************************************************
565 \subsection[PrelVals-foldr-build]{Values known about for ``foldr/build''}
567 %************************************************************************
571 = pcMiscPrelId buildIdKey pRELUDE_CORE SLIT("_build") buildTy
573 `addInfo_UF` mkMagicUnfolding SLIT("build"))
574 `addInfo` mkStrictnessInfo [WwStrict] Nothing)
575 `addInfo` mkArgUsageInfo [ArgUsage 2])
576 -- cheating, but since _build never actually exists ...
578 -- The type of this strange object is:
579 -- \/ a . (\/ b . (a -> b -> b) -> b -> b) -> [a]
581 buildTy = mkSigmaTy [alpha_tv] [] (buildUniTy `UniFun` (mkListTy alpha))
583 buildUniTy = mkSigmaTy [beta_tv] []
584 ((alpha `UniFun` (beta `UniFun` beta))
585 `UniFun` (beta `UniFun` beta))
588 @mkBuild@ is sugar for building a build!
590 @mkbuild ty tv c n e@ $Rightarrow$ @build ty (/\ tv -> \ c n -> e)@
591 @ty@ is the type of the list.
592 @tv@ is always a new type variable.
593 @c,n@ are Id's for the abstract cons and nil, @g@ for let binding the argument argument.
596 v :: (\/ b . (a -> b -> b) -> b -> b) -> [a]
597 -- \/ a . (\/ b . (a -> b -> b) -> b -> b) -> [a]
598 @e@ is the object right inside the @build@
606 -> PlainCoreExpr -- template
607 -> PlainCoreExpr -- template
609 mkBuild ty tv c n g expr
610 = CoLet (CoNonRec g (CoTyLam tv (mkCoLam [c,n] expr)))
611 (CoApp (mkCoTyApp (CoVar buildId) ty) (CoVarAtom g))
614 mkFoldr ty_a ty_b [x,y...] => foldr ty_a ty_b x y ..
617 foldrId = pcMiscPrelId foldrIdKey pRELUDE_FB{-not "List"-} SLIT("foldr")
621 mkSigmaTy [alpha_tv, beta_tv] []
622 ((alpha `UniFun` (beta `UniFun` beta))
624 `UniFun` ((mkListTy alpha)
627 idInfo = ((((noIdInfo
628 `addInfo_UF` mkMagicUnfolding SLIT("foldr"))
629 `addInfo` mkStrictnessInfo [WwLazy False,WwLazy False,WwStrict] Nothing)
630 `addInfo` mkArityInfo 3)
631 `addInfo` mkUpdateInfo [2,2,1])
633 mkFoldr a b f z xs = foldl CoApp
634 (mkCoTyApps (CoVar foldrId) [a, b])
635 [CoVarAtom f,CoVarAtom z,CoVarAtom xs]
637 foldlId = pcMiscPrelId foldlIdKey pRELUDE_FB{-not "List"-} SLIT("foldl")
641 mkSigmaTy [alpha_tv, beta_tv] []
642 ((alpha `UniFun` (beta `UniFun` alpha))
644 `UniFun` ((mkListTy beta)
647 idInfo = ((((noIdInfo
648 `addInfo_UF` mkMagicUnfolding SLIT("foldl"))
649 `addInfo` mkStrictnessInfo [WwLazy False,WwLazy False,WwStrict] Nothing)
650 `addInfo` mkArityInfo 3)
651 `addInfo` mkUpdateInfo [2,2,1])
653 mkFoldl a b f z xs = foldl CoApp
654 (mkCoTyApps (CoVar foldlId) [a, b])
655 [CoVarAtom f,CoVarAtom z,CoVarAtom xs]
657 pRELUDE_FB = SLIT("PreludeFoldrBuild")