%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
\section[PrelVals]{Prelude values the compiler ``knows about''}
module PrelVals where
-import PrelFuns -- help functions, types and things
-import BasicLit ( mkMachInt, BasicLit(..), PrimKind )
+IMP_Ubiq()
+IMPORT_DELOOPER(IdLoop) ( UnfoldingGuidance(..), nullSpecEnv, SpecEnv )
+import Id ( SYN_IE(Id), GenId, mkImported, mkUserId, mkTemplateLocals )
+IMPORT_DELOOPER(PrelLoop)
+
+-- friends:
+import PrelMods
import TysPrim
import TysWiredIn
-#ifdef DPH
-import TyPod ( mkPodNTy ,mkPodTy )
-import TyProcs ( mkProcessorTy )
-#endif {- Data Parallel Haskell -}
-
-#ifndef DPH
-import AbsUniType
-import Id ( mkTemplateLocals, mkTupleCon, getIdUniType,
- mkSpecId
- )
-#else
-import AbsUniType ( mkSigmaTy, mkDictTy, mkTyVarTy , SigmaType(..),
- applyTyCon, splitType, specialiseTy
- )
-import Id ( mkTemplateLocals, mkTupleCon, getIdUniType,
- mkSpecId, mkProcessorCon
- )
-#endif {- Data Parallel Haskell -}
-import IdInfo
-
-import Maybes ( Maybe(..) )
-import PlainCore -- to make unfolding templates
-import Unique -- *Key things
-import Util
+
+-- others:
+import CmdLineOpts ( maybe_CompilingGhcInternals )
+import CoreSyn -- quite a bit
+import IdInfo -- quite a bit
+import Literal ( mkMachInt )
+import Name ( ExportFlag(..) )
+import PragmaInfo
+import PrimOp ( PrimOp(..) )
+import Type ( mkTyVarTy )
+import TyVar ( openAlphaTyVar, alphaTyVar, betaTyVar, gammaTyVar )
+import Unique -- lots of *Keys
+import Util ( panic )
+\end{code}
+
+\begin{code}
+-- only used herein:
+pcMiscPrelId :: Unique{-IdKey-} -> FAST_STRING -> FAST_STRING -> Type -> IdInfo -> Id
+
+pcMiscPrelId key m n ty info
+ = let
+ name = mkWiredInName key (OrigName m n) ExportAll
+ imp = mkImported name ty info -- the usual case...
+ in
+ imp
+ -- We lie and say the thing is imported; otherwise, we get into
+ -- a mess with dependency analysis; e.g., core2stg may heave in
+ -- random calls to GHCbase.unpackPS__. If GHCbase is the module
+ -- being compiled, then it's just a matter of luck if the definition
+ -- will be in "the right place" to be in scope.
\end{code}
%************************************************************************
GHC randomly injects these into the code.
-@patError#@ is just a version of @error@ for pattern-matching
+@patError@ is just a version of @error@ for pattern-matching
failures. It knows various ``codes'' which expand to longer
strings---this saves space!
-@absent#@ is a thing we put in for ``absent'' arguments. They jolly
+@absentErr@ is a thing we put in for ``absent'' arguments. They jolly
well shouldn't be yanked on, but if one is, then you will get a
-friendly message from @absent#@ (rather a totally random crash).
+friendly message from @absentErr@ (rather a totally random crash).
-@parError#@ is a special version of @error@ which the compiler does
+@parError@ is a special version of @error@ which the compiler does
not know to be a bottoming Id. It is used in the @_par_@ and @_seq_@
templates, but we don't ever expect to generate code for it.
-- these "bottom" out, no matter what their arguments
eRROR_ID
- = pc_bottoming_Id errorIdKey pRELUDE_BUILTIN SLIT("error") errorTy
+ = pc_bottoming_Id errorIdKey pRELUDE SLIT("error") errorTy
+
+generic_ERROR_ID u n
+ = pc_bottoming_Id u SLIT("GHCerr") n errorTy
pAT_ERROR_ID
- = pc_bottoming_Id patErrorIdKey pRELUDE_BUILTIN SLIT("patError#") errorTy
+ = generic_ERROR_ID patErrorIdKey SLIT("patError")
+rEC_CON_ERROR_ID
+ = generic_ERROR_ID recConErrorIdKey SLIT("recConError")
+rEC_UPD_ERROR_ID
+ = generic_ERROR_ID recUpdErrorIdKey SLIT("recUpdError")
+iRREFUT_PAT_ERROR_ID
+ = generic_ERROR_ID irrefutPatErrorIdKey SLIT("irrefutPatError")
+nON_EXHAUSTIVE_GUARDS_ERROR_ID
+ = generic_ERROR_ID nonExhaustiveGuardsErrorIdKey SLIT("nonExhaustiveGuardsError")
+nO_DEFAULT_METHOD_ERROR_ID
+ = generic_ERROR_ID noDefaultMethodErrorIdKey SLIT("noDefaultMethodError")
+nO_EXPLICIT_METHOD_ERROR_ID
+ = generic_ERROR_ID nonExplicitMethodErrorIdKey SLIT("noExplicitMethodError")
aBSENT_ERROR_ID
- = pc_bottoming_Id absentErrorIdKey pRELUDE_BUILTIN SLIT("absent#")
- (mkSigmaTy [alpha_tv] [] alpha)
+ = pc_bottoming_Id absentErrorIdKey SLIT("GHCerr") SLIT("absentErr")
+ (mkSigmaTy [openAlphaTyVar] [] openAlphaTy)
pAR_ERROR_ID
- = pcMiscPrelId parErrorIdKey pRELUDE_BUILTIN SLIT("parError#")
- (mkSigmaTy [alpha_tv] [] alpha) noIdInfo
+ = pcMiscPrelId parErrorIdKey SLIT("GHCerr") SLIT("parError")
+ (mkSigmaTy [openAlphaTyVar] [] openAlphaTy) noIdInfo
+
+openAlphaTy = mkTyVarTy openAlphaTyVar
-errorTy :: UniType
-errorTy = mkSigmaTy [alpha_tv] [] (UniFun (mkListTy charTy) alpha)
+errorTy :: Type
+errorTy = mkSigmaTy [openAlphaTyVar] [] (mkFunTys [mkListTy charTy] openAlphaTy)
+ -- Notice the openAlphaTyVar. It says that "error" can be applied
+ -- to unboxed as well as boxed types. This is OK because it never
+ -- returns, so the return type is irrelevant.
\end{code}
-We want \tr{_trace} (NB: name not in user namespace) to be wired in
+We want \tr{GHCbase.trace} to be wired in
because we don't want the strictness analyser to get ahold of it,
decide that the second argument is strict, evaluate that first (!!),
-and make a jolly old mess. Having \tr{_trace} wired in also helps when
-attempting to re-export it---because it's in \tr{PreludeBuiltin}, it
-won't get an \tr{import} declaration in the interface file, so the
-importing-subsequently module needs to know it's magic.
+and make a jolly old mess.
\begin{code}
tRACE_ID
- = pcMiscPrelId traceIdKey pRELUDE_BUILTIN SLIT("_trace") traceTy
+ = pcMiscPrelId traceIdKey gHC__ SLIT("trace") traceTy
(noIdInfo `addInfo` pcGenerateSpecs traceIdKey tRACE_ID noIdInfo traceTy)
where
- traceTy = mkSigmaTy [alpha_tv] [] (UniFun (mkListTy charTy) (UniFun alpha alpha))
+ traceTy = mkSigmaTy [alphaTyVar] [] (mkFunTys [mkListTy charTy, alphaTy] alphaTy)
\end{code}
%************************************************************************
%************************************************************************
\begin{code}
-{- OLD:
-int2IntegerId
- = pcMiscPrelId int2IntegerIdKey pRELUDE_BUILTIN SLIT("_int2Integer")
- (UniFun intTy integerTy)
- noIdInfo
--}
+packStringForCId
+ = pcMiscPrelId packCStringIdKey{-ToDo:rename-} gHC__ SLIT("packStringForC__")
+ (mkFunTys [stringTy] byteArrayPrimTy) noIdInfo
--------------------------------------------------------------------
unpackCStringId
- = pcMiscPrelId unpackCStringIdKey pRELUDE_PS SLIT("unpackPS#")
- (addrPrimTy{-a char *-} `UniFun` stringTy) noIdInfo
+ = pcMiscPrelId unpackCStringIdKey gHC__ SLIT("unpackPS__")
+ (mkFunTys [addrPrimTy{-a char *-}] stringTy) noIdInfo
+-- Andy says:
+-- (FunTy addrPrimTy{-a char *-} stringTy) (noIdInfo `addInfo` mkArityInfo 1)
+-- but I don't like wired-in IdInfos (WDP)
unpackCString2Id -- for cases when a string has a NUL in it
- = pcMiscPrelId unpackCString2IdKey pRELUDE_PS SLIT("unpackPS2#")
- (addrPrimTy{-a char *-}
- `UniFun` (intPrimTy -- length
- `UniFun` stringTy)) noIdInfo
+ = pcMiscPrelId unpackCString2IdKey gHC__ SLIT("unpackPS2__")
+ (mkFunTys [addrPrimTy{-a char *-}, intPrimTy{-length-}] stringTy)
+ noIdInfo
--------------------------------------------------------------------
unpackCStringAppendId
- = pcMiscPrelId unpackCStringAppendIdKey pRELUDE_BUILTIN SLIT("unpackCStringAppend#")
- (addrPrimTy{-a "char *" pointer-}
- `UniFun` (stringTy
- `UniFun` stringTy)) noIdInfo
-
---------------------------------------------------------------------
-
-packStringForCId
- = pcMiscPrelId packCStringIdKey{-ToDo:rename-} pRELUDE_PS SLIT("_packStringForC")
- (UniFun stringTy byteArrayPrimTy) noIdInfo
+ = pcMiscPrelId unpackCStringAppendIdKey gHC__ SLIT("unpackAppendPS__")
+ (mkFunTys [addrPrimTy{-a "char *" pointer-},stringTy] stringTy)
+ ((noIdInfo
+ {-LATER:`addInfo_UF` mkMagicUnfolding unpackCStringAppendIdKey-})
+ `addInfo` mkArityInfo 2)
+
+unpackCStringFoldrId
+ = pcMiscPrelId unpackCStringFoldrIdKey gHC__ SLIT("unpackFoldrPS__")
+ (mkSigmaTy [alphaTyVar] []
+ (mkFunTys [addrPrimTy{-a "char *" pointer-},
+ mkFunTys [charTy, alphaTy] alphaTy,
+ alphaTy]
+ alphaTy))
+ ((noIdInfo
+ {-LATER:`addInfo_UF` mkMagicUnfolding unpackCStringFoldrIdKey-})
+ `addInfo` mkArityInfo 3)
\end{code}
OK, this is Will's idea: we should have magic values for Integers 0,
-+1, and -1 (go ahead, fire me):
++1, +2, and -1 (go ahead, fire me):
\begin{code}
integerZeroId
- = pcMiscPrelId integerZeroIdKey pRELUDE_CORE SLIT("_integer_0") integerTy noIdInfo
+ = pcMiscPrelId integerZeroIdKey gHC__ SLIT("integer_0") integerTy noIdInfo
integerPlusOneId
- = pcMiscPrelId integerPlusOneIdKey pRELUDE_CORE SLIT("_integer_1") integerTy noIdInfo
+ = pcMiscPrelId integerPlusOneIdKey gHC__ SLIT("integer_1") integerTy noIdInfo
+integerPlusTwoId
+ = pcMiscPrelId integerPlusTwoIdKey gHC__ SLIT("integer_2") integerTy noIdInfo
integerMinusOneId
- = pcMiscPrelId integerMinusOneIdKey pRELUDE_CORE SLIT("_integer_m1") integerTy noIdInfo
+ = pcMiscPrelId integerMinusOneIdKey gHC__ SLIT("integer_m1") integerTy noIdInfo
\end{code}
%************************************************************************
%* *
%************************************************************************
-In the definitions that follow, we use the @TyVar@-based
-alpha/beta/gamma types---not the usual @TyVarTemplate@ ones.
-
-This is so the @TyVars@ in the @CoTyLams@ (@alpha_tyvar@, etc) match
-up with those in the types of the {\em lambda-bound} template-locals
-we create (using types @alpha_ty@, etc.).
-
\begin{code}
+{- OUT:
--------------------------------------------------------------------
--- seqId :: "_seq_", used w/ GRIP, etc., is really quite similar to
+-- seqId :: "seq", used w/ GRIP, etc., is really quite similar to
-- dangerousEval
{-
OLDER:
- _seq_ = /\ a b -> \ x y -> case x of { _ -> y }
+ seq = /\ a b -> \ x y -> case x of { _ -> y }
OLD:
- _seq_ = /\ a b -> \ x y -> case seq# x y of { _Lift y' -> y' }
+ seq = /\ a b -> \ x y -> case seq# x y of { _Lift y' -> y' }
NEW (95/05):
- _seq_ = /\ a b -> \ x::a y::b -> case seq# x of { 0# -> parError#; _ -> y; }
+ seq = /\ a b -> \ x::a y::b -> case seq# x of { 0# -> parError#; _ -> y; }
-}
-seqId = pcMiscPrelId seqIdKey pRELUDE_BUILTIN SLIT("_seq_")
- (mkSigmaTy [alpha_tv, beta_tv] []
- (alpha `UniFun` (beta `UniFun` beta)))
+seqId = pcMiscPrelId seqIdKey gHC__ SLIT("seq")
+ (mkSigmaTy [alphaTyVar, betaTyVar] []
+ (mkFunTys [alphaTy, betaTy] betaTy))
(noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding seq_template))
where
[x, y, z]
= mkTemplateLocals [
- {-x-} alpha_ty,
- {-y-} beta_ty,
- {-z-} intPrimTy
+ {-x-} alphaTy,
+ {-y-} betaTy,
+ {-z-} intPrimTy
]
seq_template
- = CoTyLam alpha_tyvar
- (CoTyLam beta_tyvar
- (mkCoLam [x, y] (
- CoCase (CoPrim SeqOp [alpha_ty] [CoVarAtom x]) (
- CoPrimAlts
- [(mkMachInt 0, CoTyApp (CoVar pAR_ERROR_ID) beta_ty)]
- (CoBindDefault z (CoVar y))))))
+ = mkLam [alphaTyVar, betaTyVar] [x, y] (
+ Case (Prim SeqOp [TyArg alphaTy, VarArg x]) (
+ PrimAlts
+ [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [betaTy])]
+ (BindDefault z (Var y))))
--------------------------------------------------------------------
--- parId :: "_par_", also used w/ GRIP, etc.
+-- parId :: "par", also used w/ GRIP, etc.
{-
OLDER:
OLD:
- _par_ = /\ a b -> \ x y -> case par# x y of { _Lift y' -> y' }
+ par = /\ a b -> \ x y -> case par# x y of { _Lift y' -> y' }
NEW (95/05):
- _par_ = /\ a b -> \ x::a y::b -> case par# x of { 0# -> parError#; _ -> y; }
+ par = /\ a b -> \ x::a y::b -> case par# x of { 0# -> parError#; _ -> y; }
-}
-parId = pcMiscPrelId parIdKey pRELUDE_BUILTIN SLIT("_par_")
- (mkSigmaTy [alpha_tv, beta_tv] []
- (alpha `UniFun` (beta `UniFun` beta)))
+parId = pcMiscPrelId parIdKey gHC__ SLIT("par")
+ (mkSigmaTy [alphaTyVar, betaTyVar] []
+ (mkFunTys [alphaTy, betaTy] betaTy))
(noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding par_template))
where
[x, y, z]
= mkTemplateLocals [
- {-x-} alpha_ty,
- {-y-} beta_ty,
- {-z-} intPrimTy
+ {-x-} alphaTy,
+ {-y-} betaTy,
+ {-z-} intPrimTy
]
par_template
- = CoTyLam alpha_tyvar
- (CoTyLam beta_tyvar
- (mkCoLam [x, y] (
- CoCase (CoPrim ParOp [alpha_ty] [CoVarAtom x]) (
- CoPrimAlts
- [(mkMachInt 0, CoTyApp (CoVar pAR_ERROR_ID) beta_ty)]
- (CoBindDefault z (CoVar y))))))
-
--- forkId :: "_fork_", for *required* concurrent threads
+ = mkLam [alphaTyVar, betaTyVar] [x, y] (
+ Case (Prim ParOp [TyArg alphaTy, VarArg x]) (
+ PrimAlts
+ [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [betaTy])]
+ (BindDefault z (Var y))))
+
+-- forkId :: "fork", for *required* concurrent threads
{-
_fork_ = /\ a b -> \ x::a y::b -> case fork# x of { 0# -> parError#; _ -> y; }
-}
-forkId = pcMiscPrelId forkIdKey pRELUDE_BUILTIN SLIT("_fork_")
- (mkSigmaTy [alpha_tv, beta_tv] []
- (alpha `UniFun` (beta `UniFun` beta)))
+forkId = pcMiscPrelId forkIdKey gHC__ SLIT("fork")
+ (mkSigmaTy [alphaTyVar, betaTyVar] []
+ (mkFunTys [alphaTy, betaTy] betaTy))
(noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding fork_template))
where
[x, y, z]
= mkTemplateLocals [
- {-x-} alpha_ty,
- {-y-} beta_ty,
- {-z-} intPrimTy
+ {-x-} alphaTy,
+ {-y-} betaTy,
+ {-z-} intPrimTy
]
fork_template
- = CoTyLam alpha_tyvar
- (CoTyLam beta_tyvar
- (mkCoLam [x, y] (
- CoCase (CoPrim ForkOp [alpha_ty] [CoVarAtom x]) (
- CoPrimAlts
- [(mkMachInt 0, CoTyApp (CoVar pAR_ERROR_ID) beta_ty)]
- (CoBindDefault z (CoVar y))))))
-
+ = mkLam [alphaTyVar, betaTyVar] [x, y] (
+ Case (Prim ForkOp [TyArg alphaTy, VarArg x]) (
+ PrimAlts
+ [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [betaTy])]
+ (BindDefault z (Var y))))
+-}
\end{code}
+GranSim ones:
\begin{code}
-#ifdef GRAN
-
-parLocalId = pcMiscPrelId parLocalIdKey pRELUDE_BUILTIN SLIT("_parLocal_")
- (mkSigmaTy [alpha_tv, beta_tv] []
- (intPrimTy `UniFun` (alpha `UniFun` (beta `UniFun` beta))))
+{- OUT:
+parLocalId = pcMiscPrelId parLocalIdKey gHC__ SLIT("parLocal")
+ (mkSigmaTy [alphaTyVar, betaTyVar] []
+ (mkFunTys [intPrimTy, intPrimTy, intPrimTy, intPrimTy, alphaTy, betaTy] betaTy))
(noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding parLocal_template))
where
- [w, x, y, z]
+ -- Annotations: w: name, g: gran. info, s: size info, p: par info -- HWL
+ [w, g, s, p, x, y, z]
= mkTemplateLocals [
{-w-} intPrimTy,
- {-x-} alpha_ty,
- {-y-} beta_ty,
- {-z-} beta_ty
+ {-g-} intPrimTy,
+ {-s-} intPrimTy,
+ {-p-} intPrimTy,
+ {-x-} alphaTy,
+ {-y-} betaTy,
+ {-z-} intPrimTy
]
parLocal_template
- = CoTyLam alpha_tyvar
- (CoTyLam beta_tyvar
- (mkCoLam [w, x, y] (
- CoCase (CoPrim ParLocalOp [alpha_ty, beta_ty] [CoVarAtom x, CoVarAtom w, CoVarAtom y]) (
- CoAlgAlts
- [(liftDataCon, [z], CoVar z)]
- (CoNoDefault)))))
-
-parGlobalId = pcMiscPrelId parGlobalIdKey pRELUDE_BUILTIN SLIT("_parGlobal_")
- (mkSigmaTy [alpha_tv, beta_tv] []
- (intPrimTy `UniFun` (alpha `UniFun` (beta `UniFun` beta))))
+ = mkLam [alphaTyVar, betaTyVar] [w, g, s, p, x, y] (
+ Case (Prim ParLocalOp [TyArg alphaTy, TyArg betaTy, VarArg x, VarArg w, VarArg g, VarArg s, VarArg p, VarArg y]) (
+ PrimAlts
+ [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [betaTy])]
+ (BindDefault z (Var y))))
+
+parGlobalId = pcMiscPrelId parGlobalIdKey gHC__ SLIT("parGlobal")
+ (mkSigmaTy [alphaTyVar, betaTyVar] []
+ (mkFunTys [intPrimTy, intPrimTy, intPrimTy, intPrimTy, alphaTy, betaTy] betaTy))
(noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding parGlobal_template))
where
- [w, x, y, z]
+ -- Annotations: w: name, g: gran. info, s: size info, p: par info -- HWL
+ [w, g, s, p, x, y, z]
= mkTemplateLocals [
{-w-} intPrimTy,
- {-x-} alpha_ty,
- {-y-} beta_ty,
- {-z-} beta_ty
+ {-g-} intPrimTy,
+ {-s-} intPrimTy,
+ {-p-} intPrimTy,
+ {-x-} alphaTy,
+ {-y-} betaTy,
+ {-z-} intPrimTy
]
parGlobal_template
- = CoTyLam alpha_tyvar
- (CoTyLam beta_tyvar
- (mkCoLam [w, x, y] (
- CoCase (CoPrim ParGlobalOp [alpha_ty, beta_ty] [CoVarAtom x, CoVarAtom w, CoVarAtom y]) (
- CoAlgAlts
- [(liftDataCon, [z], CoVar z)]
- (CoNoDefault)))))
-
-#endif {-GRAN-}
-\end{code}
-
-\begin{code}
-#ifdef DPH
-vectorMapId = pcChooseToKnowId vectorMapU pRELUDE "vectorMap"
- (mkSigmaTy [alpha_tv, beta_tv , gamma_tv]
- [(pidClass,alpha)]
- ((beta `UniFun` gamma) `UniFun`
- ((mkPodTy (mkProcessorTy [alpha] beta)) `UniFun`
- (mkPodTy (mkProcessorTy [alpha] gamma)))))
- (panic "vectorMap:unfolding")--ToDo:DPH: (mkUnfoldTemplate vector_map_template)
- [(2,"","")]
- where
-{-
-vectorMap fn vec = << (|x;fn y|) | (|x;y|) <<- vec >>
-
-Simplified :
-vectorMap :: for all a.83, b.82, c.86. <Pid a.83>
- -> (b.82 -> c.86)
- -> <<a.83;b.82>>
- -> <<a.83;c.86>>
-vectorMap =
- /\ t83 t82 o86 -> \ dict.127 ->
- let
- vecMap.128 =
- \ fn.129 vec.130 ->
- << let si.133 = fn.129 ds.132 in
- let
- si.134 =
- (fromDomain t82)
- dict.127 ((toDomain t82) dict.127 ds.131)
- in MkProcessor1! Integer o86 si.134 si.133 |
- (| ds.131 ; ds.132 |) <<- vec.130 >>
- in vecMap.128
-
- NOTE : no need to bother with overloading in class Pid; because the result
- PID (si.133) is wrapped in fromDomain.toDomain == id . Therefore we
- use the simplification below.
-
-Simplified:
-vectorMap ::
- for all d.83, e.82, f.86.
- <Pid e.82> -> (d.83 -> f.86) -> <<e.82;d.83>> -> <<e.82;f.86>>
-vectorMap =
- /\ t83 t82 o86 -> \ dict.127 fn.129 vec.130 ->
- << MkProcessor1! Integer o86 ds.131 (fn.129 ds.132) |
- (| ds.131 ; ds.132 |) <<- vec.130 >>
--}
+ = mkLam [alphaTyVar, betaTyVar] [w, g, s, p, x, y] (
+ Case (Prim ParGlobalOp [TyArg alphaTy, TyArg betaTy, VarArg x, VarArg w, VarArg g, VarArg s, VarArg p, VarArg y]) (
+ PrimAlts
+ [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [betaTy])]
+ (BindDefault z (Var y))))
+
+
+parAtId = pcMiscPrelId parAtIdKey gHC__ SLIT("parAt")
+ (mkSigmaTy [alphaTyVar, betaTyVar] []
+ (mkFunTys [intPrimTy, intPrimTy, intPrimTy, intPrimTy,
+ alphaTy, betaTy, gammaTy] gammaTy))
+ (noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding parAt_template))
+ where
+ -- Annotations: w: name, g: gran. info, s: size info, p: par info -- HWL
+ [w, g, s, p, v, x, y, z]
+ = mkTemplateLocals [
+ {-w-} intPrimTy,
+ {-g-} intPrimTy,
+ {-s-} intPrimTy,
+ {-p-} intPrimTy,
+ {-v-} alphaTy,
+ {-x-} betaTy,
+ {-y-} gammaTy,
+ {-z-} intPrimTy
+ ]
- vector_map_template
- = let
- [dict,fn,vec,ds131,ds132]
- = mkTemplateLocals
- [mkDictTy pidClass alpha_ty,
- beta_ty `UniFun` gamma_ty,
- mkPodTy (mkProcessorTy [alpha_ty] beta_ty),
- integerTy,
- beta_ty]
- in
- CoTyLam alpha_tyvar
- (CoTyLam beta_tyvar
- (CoTyLam gamma_tyvar
- (mkCoLam [dict,fn,vec]
- (CoZfExpr
- (CoCon (mkProcessorCon 1)
- [integerTy,mkTyVarTy gamma_tyvar]
- [CoVar ds131,
- (CoApp (CoVar fn) (CoVar ds132))])
- (CoDrawnGen [ds131] ds132 (CoVar vec)) ))))
-
-#endif {- Data Parallel Haskell -}
-\end{code}
+ parAt_template
+ = mkLam [alphaTyVar, betaTyVar, gammaTyVar] [w, g, s, p, v, x, y] (
+ Case (Prim ParAtOp [TyArg alphaTy, TyArg betaTy, TyArg gammaTy, VarArg x, VarArg v, VarArg w, VarArg g, VarArg s, VarArg p, VarArg y]) (
+ PrimAlts
+ [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [gammaTy])]
+ (BindDefault z (Var y))))
+
+parAtAbsId = pcMiscPrelId parAtAbsIdKey gHC__ SLIT("parAtAbs")
+ (mkSigmaTy [alphaTyVar, betaTyVar] []
+ (mkFunTys [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, alphaTy, betaTy] betaTy))
+ (noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding parAtAbs_template))
+ where
+ -- Annotations: w: name, g: gran. info, s: size info, p: par info -- HWL
+ [w, g, s, p, v, x, y, z]
+ = mkTemplateLocals [
+ {-w-} intPrimTy,
+ {-g-} intPrimTy,
+ {-s-} intPrimTy,
+ {-p-} intPrimTy,
+ {-v-} intPrimTy,
+ {-x-} alphaTy,
+ {-y-} betaTy,
+ {-z-} intPrimTy
+ ]
-\begin{code}
-#ifdef DPH
--- A function used during podization that produces an index POD for a given
--- POD as argument.
-
-primIfromPodNSelectorId :: Int -> Int -> Id
-primIfromPodNSelectorId i n
- = pcMiscPrelId
- podSelectorIdKey
- pRELUDE_BUILTIN
- ("prim"++ show i ++ "fromPod" ++ show n ++ "Selector")
- (UniFun
- (mkPodNTy n alpha)
- (mkPodNTy n alpha))
- noIdInfo
-#endif {- Data Parallel Haskell -}
-\end{code}
+ parAtAbs_template
+ = mkLam [alphaTyVar, betaTyVar] [w, g, s, p, v, x, y] (
+ Case (Prim ParAtAbsOp [TyArg alphaTy, TyArg betaTy, VarArg x, VarArg v, VarArg w, VarArg g, VarArg s, VarArg p, VarArg y]) (
+ PrimAlts
+ [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [betaTy])]
+ (BindDefault z (Var y))))
+
+parAtRelId = pcMiscPrelId parAtRelIdKey gHC__ SLIT("parAtRel")
+ (mkSigmaTy [alphaTyVar, betaTyVar] []
+ (mkFunTys [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, alphaTy, betaTy] betaTy))
+ (noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding parAtRel_template))
+ where
+ -- Annotations: w: name, g: gran. info, s: size info, p: par info -- HWL
+ [w, g, s, p, v, x, y, z]
+ = mkTemplateLocals [
+ {-w-} intPrimTy,
+ {-g-} intPrimTy,
+ {-s-} intPrimTy,
+ {-p-} intPrimTy,
+ {-v-} intPrimTy,
+ {-x-} alphaTy,
+ {-y-} betaTy,
+ {-z-} intPrimTy
+ ]
-%************************************************************************
-%* *
-\subsection[PrelVals-deriving]{Values known about mainly for doing derived instance decls}
-%* *
-%************************************************************************
+ parAtRel_template
+ = mkLam [alphaTyVar, betaTyVar] [w, g, s, p, v, x, y] (
+ Case (Prim ParAtRelOp [TyArg alphaTy, TyArg betaTy, VarArg x, VarArg v, VarArg w, VarArg g, VarArg s, VarArg p, VarArg y]) (
+ PrimAlts
+ [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [betaTy])]
+ (BindDefault z (Var y))))
+
+parAtForNowId = pcMiscPrelId parAtForNowIdKey gHC__ SLIT("parAtForNow")
+ (mkSigmaTy [alphaTyVar, betaTyVar] []
+ (mkFunTys [intPrimTy, intPrimTy, intPrimTy, intPrimTy,
+ alphaTy, betaTy, gammaTy] gammaTy))
+ (noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding parAtForNow_template))
+ where
+ -- Annotations: w: name, g: gran. info, s: size info, p: par info -- HWL
+ [w, g, s, p, v, x, y, z]
+ = mkTemplateLocals [
+ {-w-} intPrimTy,
+ {-g-} intPrimTy,
+ {-s-} intPrimTy,
+ {-p-} intPrimTy,
+ {-v-} alphaTy,
+ {-x-} betaTy,
+ {-y-} gammaTy,
+ {-z-} intPrimTy
+ ]
-map :: (a -> b) -> [a] -> [b]
- -- this is up in the here-because-of-unfolding list
+ parAtForNow_template
+ = mkLam [alphaTyVar, betaTyVar, gammaTyVar] [w, g, s, p, v, x, y] (
+ Case (Prim ParAtForNowOp [TyArg alphaTy, TyArg betaTy, TyArg gammaTy, VarArg x, VarArg v, VarArg w, VarArg g, VarArg s, VarArg p, VarArg y]) (
+ PrimAlts
+ [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [gammaTy])]
+ (BindDefault z (Var y))))
---??showChar :: Char -> ShowS
-showSpace :: ShowS -- non-std: == "showChar ' '"
-showString :: String -> ShowS
-showParen :: Bool -> ShowS -> ShowS
+-- copyable and noFollow are currently merely hooks: they are translated into
+-- calls to the macros COPYABLE and NOFOLLOW -- HWL
-(++) :: [a] -> [a] -> [a]
-readParen :: Bool -> ReadS a -> ReadS a
-lex :: ReadS String
+copyableId = pcMiscPrelId copyableIdKey gHC__ SLIT("copyable")
+ (mkSigmaTy [alphaTyVar] []
+ alphaTy)
+ (noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding copyable_template))
+ where
+ -- Annotations: x: closure that's tagged to by copyable
+ [x, z]
+ = mkTemplateLocals [
+ {-x-} alphaTy,
+ {-z-} alphaTy
+ ]
-\begin{code}
-{- OLD:
-readS_ty :: UniType -> UniType
-readS_ty ty
- = UniFun stringTy (mkListTy (mkTupleTy 2 [ty, stringTy]))
+ copyable_template
+ = mkLam [alphaTyVar] [x] ( Prim CopyableOp [TyArg alphaTy, VarArg x] )
-showS_ty :: UniType
-showS_ty = UniFun stringTy stringTy
--}
-\end{code}
+noFollowId = pcMiscPrelId noFollowIdKey gHC__ SLIT("noFollow")
+ (mkSigmaTy [alphaTyVar] []
+ alphaTy)
+ (noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding noFollow_template))
+ where
+ -- Annotations: x: closure that's tagged to not follow
+ [x, z]
+ = mkTemplateLocals [
+ {-x-} alphaTy,
+ {-z-} alphaTy
+ ]
-\begin{code}
-{- OLD:
-showSpaceId = pcMiscPrelId showSpaceIdKey pRELUDE_TEXT SLIT("_showSpace")
- showS_ty
- noIdInfo
-
-showParenId = pcMiscPrelId showParenIdKey pRELUDE_TEXT SLIT("showParen")
- (boolTy `UniFun` (showS_ty `UniFun` showS_ty))
- noIdInfo
-
-readParenId = pcMiscPrelId readParenIdKey pRELUDE_TEXT SLIT("readParen")
- (mkSigmaTy [alpha_tv] [] (
- boolTy `UniFun` (
- (readS_ty alpha) `UniFun` (readS_ty alpha))))
- noIdInfo
-
-lexId = pcMiscPrelId lexIdKey pRELUDE_TEXT SLIT("lex")
- (readS_ty (mkListTy charTy))
- noIdInfo
+ noFollow_template
+ = mkLam [alphaTyVar] [x] ( Prim NoFollowOp [TyArg alphaTy, VarArg x] )
-}
\end{code}
%************************************************************************
%* *
-\subsection[PrelVals-void]{@void#@: Magic value of type @Void#@}
+\subsection[PrelVals-runST]{@runST@: Magic start-state-transformer function}
%* *
%************************************************************************
-I don't think this is available to the user; it's used in the
-simplifier (WDP 94/06).
-\begin{code}
-voidPrimId
- = pcMiscPrelId voidPrimIdKey pRELUDE_BUILTIN SLIT("void#")
- voidPrimTy noIdInfo
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[PrelVals-runST]{@_runST@: Magic start-state-transformer function}
-%* *
-%************************************************************************
-
-@_runST@ has a non-Haskell-able type:
+@runST@ has a non-Haskell-able type:
\begin{verbatim}
--- _runST :: forall a. (forall s. _ST s a) -> a
+-- runST :: forall a. (forall s. _ST s a) -> a
-- which is to say ::
-- forall a. (forall s. (_State s -> (a, _State s))) -> a
-_runST a m = case m _RealWorld (S# _RealWorld realWorld#) of
- (r :: a, wild :: _State _RealWorld) -> r
+runST a m = case m _RealWorld (S# _RealWorld realWorld#) of
+ (r :: a, wild :: _State _RealWorld) -> r
\end{verbatim}
+
We unfold always, just for simplicity:
\begin{code}
runSTId
- = pcMiscPrelId runSTIdKey pRELUDE_BUILTIN SLIT("_runST") run_ST_ty id_info
+ = pcMiscPrelId runSTIdKey gHC__ SLIT("runST") run_ST_ty id_info
where
- s_tv = beta_tv
- s = beta
+ s_tv = betaTyVar
+ s = betaTy
st_ty a = mkSigmaTy [s_tv] [] (mkStateTransformerTy s a)
run_ST_ty
- = mkSigmaTy [alpha_tv] [] (st_ty alpha `UniFun` alpha)
+ = mkSigmaTy [alphaTyVar] [] (mkFunTys [st_ty alphaTy] alphaTy)
-- NB: rank-2 polymorphism! (forall inside the st_ty...)
id_info
= noIdInfo
`addInfo` mkArityInfo 1
- `addInfo` mkStrictnessInfo [WwStrict] Nothing
+ `addInfo` mkStrictnessInfo [WwStrict] Nothing
+ `addInfo` mkArgUsageInfo [ArgUsage 1]
-- ABSOLUTELY NO UNFOLDING, e.g.: (mkUnfolding EssentialUnfolding run_ST_template)
-- see example below
{- OUT:
[m, t, r, wild]
= mkTemplateLocals [
- {-m-} st_ty alpha_ty,
+ {-m-} st_ty alphaTy,
{-t-} realWorldStateTy,
- {-r-} alpha_ty,
+ {-r-} alphaTy,
{-_-} realWorldStateTy
]
run_ST_template
- = CoTyLam alpha_tyvar
- (mkCoLam [m] (
- CoLet (CoNonRec t (CoCon stateDataCon [realWorldTy] [CoVarAtom realWorldPrimId])) (
- CoCase (CoApp (mkCoTyApp (CoVar m) realWorldTy) (CoVarAtom t)) (
- CoAlgAlts
- [(mkTupleCon 2, [r, wild], CoVar r)]
- CoNoDefault))))
+ = mkLam [alphaTyVar] [m] (
+ Let (NonRec t (Con stateDataCon [TyArg realWorldTy, VarArg realWorldPrimId])) (
+ Case (App (mkTyApp (Var m) [realWorldTy]) (VarArg t)) (
+ AlgAlts
+ [(mkTupleCon 2, [r, wild], Var r)]
+ NoDefault)))
-}
\end{code}
-SLPJ 95/04: Why @_runST@ must not have an unfolding; consider:
+SLPJ 95/04: Why @runST@ must not have an unfolding; consider:
\begin{verbatim}
f x =
- _runST ( \ s -> let
+ runST ( \ s -> let
(a, s') = newArray# 100 [] s
(_, s'') = fill_in_array_or_something a x s'
in
freezeArray# a s'' )
\end{verbatim}
-If we inline @_runST@, we'll get:
+If we inline @runST@, we'll get:
\begin{verbatim}
f x = let
(a, s') = newArray# 100 [] realWorld#{-NB-}
All calls to @f@ will share a {\em single} array! End SLPJ 95/04.
@realWorld#@ used to be a magic literal, \tr{void#}. If things get
-nasty as-is, change it back to a literal (@BasicLit@).
+nasty as-is, change it back to a literal (@Literal@).
\begin{code}
realWorldPrimId
- = pcMiscPrelId realWorldPrimIdKey pRELUDE_BUILTIN SLIT("realWorld#")
+ = pcMiscPrelId realWorldPrimIdKey gHC_BUILTINS SLIT("realWorld#")
realWorldStatePrimTy
noIdInfo
\end{code}
+\begin{code}
+voidId = pcMiscPrelId voidIdKey gHC_BUILTINS SLIT("void") voidTy noIdInfo
+\end{code}
+
%************************************************************************
%* *
\subsection[PrelVals-foldr-build]{Values known about for ``foldr/build''}
\begin{code}
buildId
- = pcMiscPrelId buildIdKey pRELUDE_CORE SLIT("_build") buildTy
- (((noIdInfo
- `addInfo_UF` mkMagicUnfolding SLIT("build"))
+ = pcMiscPrelId buildIdKey SLIT("GHCerr") SLIT("build") buildTy
+ ((((noIdInfo
+ {-LATER:`addInfo_UF` mkMagicUnfolding buildIdKey-})
`addInfo` mkStrictnessInfo [WwStrict] Nothing)
`addInfo` mkArgUsageInfo [ArgUsage 2])
+ `addInfo` pcGenerateSpecs buildIdKey buildId noIdInfo{-ToDo-} buildTy)
-- cheating, but since _build never actually exists ...
where
-- The type of this strange object is:
-- \/ a . (\/ b . (a -> b -> b) -> b -> b) -> [a]
- buildTy = mkSigmaTy [alpha_tv] [] (buildUniTy `UniFun` (mkListTy alpha))
+ buildTy = mkSigmaTy [alphaTyVar] [] (mkFunTys [build_ty] (mkListTy alphaTy))
where
- buildUniTy = mkSigmaTy [beta_tv] []
- ((alpha `UniFun` (beta `UniFun` beta))
- `UniFun` (beta `UniFun` beta))
+ build_ty = mkSigmaTy [betaTyVar] []
+ (mkFunTys [mkFunTys [alphaTy, betaTy] betaTy, betaTy] betaTy)
\end{code}
@mkBuild@ is sugar for building a build!
@e@ is the object right inside the @build@
\begin{code}
-mkBuild :: UniType
+mkBuild :: Type
-> TyVar
-> Id
-> Id
-> Id
- -> PlainCoreExpr -- template
- -> PlainCoreExpr -- template
+ -> CoreExpr -- template
+ -> CoreExpr -- template
mkBuild ty tv c n g expr
- = CoLet (CoNonRec g (CoTyLam tv (mkCoLam [c,n] expr)))
- (CoApp (mkCoTyApp (CoVar buildId) ty) (CoVarAtom g))
+ = Let (NonRec g (mkLam [tv] [c,n] expr))
+ (App (mkTyApp (Var buildId) [ty]) (VarArg g))
\end{code}
-mkFoldr ty_a ty_b [x,y...] => foldr ty_a ty_b x y ..
+\begin{code}
+augmentId
+ = pcMiscPrelId augmentIdKey SLIT("GHCerr") SLIT("augment") augmentTy
+ (((noIdInfo
+ {-LATER:`addInfo_UF` mkMagicUnfolding augmentIdKey-})
+ `addInfo` mkStrictnessInfo [WwStrict,WwLazy False] Nothing)
+ `addInfo` mkArgUsageInfo [ArgUsage 2,UnknownArgUsage])
+ -- cheating, but since _augment never actually exists ...
+ where
+ -- The type of this strange object is:
+ -- \/ a . (\/ b . (a -> b -> b) -> b -> b) -> [a] -> [a]
+
+ augmentTy = mkSigmaTy [alphaTyVar] [] (mkFunTys [aug_ty, mkListTy alphaTy] (mkListTy alphaTy))
+ where
+ aug_ty = mkSigmaTy [betaTyVar] []
+ (mkFunTys [mkFunTys [alphaTy, betaTy] betaTy, betaTy] betaTy)
+\end{code}
\begin{code}
-foldrId = pcMiscPrelId foldrIdKey pRELUDE_FB{-not "List"-} SLIT("foldr")
+foldrId = pcMiscPrelId foldrIdKey pRELUDE SLIT("foldr")
foldrTy idInfo
where
foldrTy =
- mkSigmaTy [alpha_tv, beta_tv] []
- ((alpha `UniFun` (beta `UniFun` beta))
- `UniFun` (beta
- `UniFun` ((mkListTy alpha)
- `UniFun` beta)))
-
- idInfo = ((((noIdInfo
- `addInfo_UF` mkMagicUnfolding SLIT("foldr"))
+ mkSigmaTy [alphaTyVar, betaTyVar] []
+ (mkFunTys [mkFunTys [alphaTy, betaTy] betaTy, betaTy, mkListTy alphaTy] betaTy)
+
+ idInfo = (((((noIdInfo
+ {-LATER:`addInfo_UF` mkMagicUnfolding foldrIdKey-})
`addInfo` mkStrictnessInfo [WwLazy False,WwLazy False,WwStrict] Nothing)
`addInfo` mkArityInfo 3)
`addInfo` mkUpdateInfo [2,2,1])
+ `addInfo` pcGenerateSpecs foldrIdKey foldrId noIdInfo{-ToDo-} foldrTy)
-mkFoldr a b f z xs = foldl CoApp
- (mkCoTyApps (CoVar foldrId) [a, b])
- [CoVarAtom f,CoVarAtom z,CoVarAtom xs]
-
-foldlId = pcMiscPrelId foldlIdKey pRELUDE_FB{-not "List"-} SLIT("foldl")
+foldlId = pcMiscPrelId foldlIdKey pRELUDE SLIT("foldl")
foldlTy idInfo
where
foldlTy =
- mkSigmaTy [alpha_tv, beta_tv] []
- ((alpha `UniFun` (beta `UniFun` alpha))
- `UniFun` (alpha
- `UniFun` ((mkListTy beta)
- `UniFun` alpha)))
-
- idInfo = ((((noIdInfo
- `addInfo_UF` mkMagicUnfolding SLIT("foldl"))
+ mkSigmaTy [alphaTyVar, betaTyVar] []
+ (mkFunTys [mkFunTys [alphaTy, betaTy] alphaTy, alphaTy, mkListTy betaTy] alphaTy)
+
+ idInfo = (((((noIdInfo
+ {-LATER:`addInfo_UF` mkMagicUnfolding foldlIdKey-})
`addInfo` mkStrictnessInfo [WwLazy False,WwLazy False,WwStrict] Nothing)
`addInfo` mkArityInfo 3)
`addInfo` mkUpdateInfo [2,2,1])
+ `addInfo` pcGenerateSpecs foldlIdKey foldlId noIdInfo{-ToDo-} foldlTy)
+
+-- A bit of magic goes no here. We translate appendId into ++,
+-- you have to be carefull when you actually compile append:
+-- xs ++ ys = augment (\ c n -> foldr c n xs) ys
+-- {- unfold augment -}
+-- = foldr (:) ys xs
+-- {- fold foldr to append -}
+-- = ys `appendId` xs
+-- = ys ++ xs -- ugg!
+-- *BUT* you want (++) and not _append in your interfaces.
+--
+-- So you have to turn *off* unfolding of foldr inside FoldrBuild.hs inside
+-- the prelude.
+--
+{- OLD: doesn't apply with 1.3
+appendId
+ = pcMiscPrelId appendIdKey pRELUDE_LIST SLIT("++") appendTy idInfo
+ where
+ appendTy =
+ (mkSigmaTy [alphaTyVar] []
+ (mkFunTys [mkListTy alphaTy, mkListTy alphaTy] (mkListTy alphaTy)))
+ idInfo = (((noIdInfo
+ `addInfo` mkStrictnessInfo [WwStrict,WwLazy False] Nothing)
+ `addInfo` mkArityInfo 2)
+ `addInfo` mkUpdateInfo [1,2])
+-}
+\end{code}
+
+%************************************************************************
+%* *
+\subsection[PrelUtils-specialisations]{Specialisations for builtin values}
+%* *
+%************************************************************************
+
+The specialisations which exist for the builtin values must be recorded in
+their IdInfos.
+
+NOTE: THE USES OF THE pcGenerate... FUNCTIONS MUST CORRESPOND
+ TO THE SPECIALISATIONS DECLARED IN THE PRELUDE !!!
+
+HACK: We currently use the same unique for the specialised Ids.
+
+The list @specing_types@ determines the types for which specialised
+versions are created. Note: This should correspond with the
+types passed to the pre-processor with the -genSPECS arg (see ghc.lprl).
-mkFoldl a b f z xs = foldl CoApp
- (mkCoTyApps (CoVar foldlId) [a, b])
- [CoVarAtom f,CoVarAtom z,CoVarAtom xs]
+ToDo: Create single mkworld definition which is grabbed here and in ghc.lprl
-pRELUDE_FB = SLIT("PreludeFoldrBuild")
+\begin{code}
+pcGenerateSpecs :: Unique -> Id -> IdInfo -> Type -> SpecEnv
+pcGenerateSpecs key id info ty
+ = nullSpecEnv
+
+{- LATER:
+
+pc_gen_specs True key id info ty
+
+pc_gen_specs is_id key id info ty
+ = mkSpecEnv spec_infos
+ where
+ spec_infos = [ let spec_ty = specialiseTy ty spec_tys 0
+ spec_id = if is_id
+ then mkSpecId key {- HACK WARNING: same unique! -}
+ id spec_tys spec_ty info
+ else panic "SpecData:SpecInfo:SpecId"
+ in
+ SpecInfo spec_tys (length ctxts) spec_id
+ | spec_tys <- specialisations ]
+
+ (tyvars, ctxts, _) = splitSigmaTy ty
+ no_tyvars = length tyvars
+
+ specialisations = if no_tyvars == 0
+ then []
+ else tail (cross_product no_tyvars specing_types)
+
+ -- N.B. tail removes fully polymorphic specialisation
+
+cross_product 0 tys = []
+cross_product 1 tys = map (:[]) tys
+cross_product n tys = concat [map (:cp) tys | cp <- cross_product (n-1) tys]
+
+
+specing_types = [Nothing,
+ Just charPrimTy,
+ Just doublePrimTy,
+ Just intPrimTy ]
+-}
\end{code}
projects / ghc-hetmet.git / blobdiff