module PrelVals where
-import PrelFuns -- help functions, types and things
-import BasicLit ( mkMachInt, BasicLit(..), PrimKind )
+IMP_Ubiq()
+IMPORT_DELOOPER(IdLoop) ( UnfoldingGuidance(..) )
+import Id ( 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_CompilingPrelude )
+import CoreSyn -- quite a bit
+import IdInfo -- quite a bit
+import Literal ( mkMachInt )
+import PragmaInfo
+import PrimOp ( PrimOp(..) )
+import SpecEnv ( SpecEnv(..), nullSpecEnv )
+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)
+ 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.
+{- ???
+ case maybe_CompilingPrelude of
+ Nothing -> imp
+ Just modname ->
+ if modname == _UNPK_ m -- we are compiling the module where this thing is defined...
+ then mkUserId name ty NoPragmaInfo
+ else imp
+-}
\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 gHC__ 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 gHC__ SLIT("absentErr")
+ (mkSigmaTy [alphaTyVar] [] alphaTy)
pAR_ERROR_ID
- = pcMiscPrelId parErrorIdKey pRELUDE_BUILTIN SLIT("parError#")
- (mkSigmaTy [alpha_tv] [] alpha) noIdInfo
+ = pcMiscPrelId parErrorIdKey gHC__ SLIT("parError")
+ (mkSigmaTy [alphaTyVar] [] alphaTy) noIdInfo
-errorTy :: UniType
-errorTy = mkSigmaTy [alpha_tv] [] (UniFun (mkListTy charTy) alpha)
+errorTy :: Type
+errorTy = mkSigmaTy [openAlphaTyVar] [] (mkFunTys [mkListTy charTy] (mkTyVarTy openAlphaTyVar))
\end{code}
We want \tr{_trace} (NB: name not in user namespace) to be wired in
importing-subsequently module needs to know it's magic.
\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-} pRELUDE_PS SLIT("_packStringForC")
- (UniFun stringTy byteArrayPrimTy) noIdInfo
+ = pcMiscPrelId packCStringIdKey{-ToDo:rename-} gHC__ SLIT("packStringForC")
+ (mkFunTys [stringTy] byteArrayPrimTy) noIdInfo
--------------------------------------------------------------------
unpackCStringId
- = pcMiscPrelId unpackCStringIdKey pRELUDE_BUILTIN SLIT("unpackPS#")
- (addrPrimTy{-a char *-} `UniFun` stringTy) noIdInfo
+ = pcMiscPrelId unpackCStringIdKey gHC__ SLIT("unpackPS")
+ (mkFunTys [addrPrimTy{-a char *-}] stringTy) noIdInfo
-- Andy says:
--- (UniFun addrPrimTy{-a char *-} stringTy) (noIdInfo `addInfo` mkArityInfo 1)
+-- (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_BUILTIN 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("unpackAppendPS#")
- (addrPrimTy{-a "char *" pointer-}
- `UniFun` (stringTy
- `UniFun` stringTy)) ((noIdInfo
- `addInfo_UF` mkMagicUnfolding SLIT("unpackAppendPS#"))
- `addInfo` mkArityInfo 2)
-
+ = pcMiscPrelId unpackCStringAppendIdKey gHC__ SLIT("unpackAppendPS")
+ (mkFunTys [addrPrimTy{-a "char *" pointer-},stringTy] stringTy)
+ ((noIdInfo
+ {-LATER:`addInfo_UF` mkMagicUnfolding unpackCStringAppendIdKey-})
+ `addInfo` mkArityInfo 2)
+
unpackCStringFoldrId
- = pcMiscPrelId unpackCStringFoldrIdKey pRELUDE_BUILTIN SLIT("unpackFoldrPS#")
- (mkSigmaTy [alpha_tv] []
- (addrPrimTy{-a "char *" pointer-}
- `UniFun` ((charTy `UniFun` (alpha `UniFun` alpha))
- `UniFun` (alpha
- `UniFun` alpha)))) ((noIdInfo
- `addInfo_UF` mkMagicUnfolding SLIT("unpackFoldrPS#"))
- `addInfo` mkArityInfo 3)
+ = 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, +2, and -1 (go ahead, fire me):
\begin{code}
integerZeroId
- = pcMiscPrelId integerZeroIdKey pRELUDE_CORE SLIT("__integer0") integerTy noIdInfo
+ = pcMiscPrelId integerZeroIdKey gHC__ SLIT("integer_0") integerTy noIdInfo
integerPlusOneId
- = pcMiscPrelId integerPlusOneIdKey pRELUDE_CORE SLIT("__integer1") integerTy noIdInfo
+ = pcMiscPrelId integerPlusOneIdKey gHC__ SLIT("integer_1") integerTy noIdInfo
integerPlusTwoId
- = pcMiscPrelId integerPlusTwoIdKey pRELUDE_CORE SLIT("__integer2") integerTy noIdInfo
+ = pcMiscPrelId integerPlusTwoIdKey gHC__ SLIT("integer_2") integerTy noIdInfo
integerMinusOneId
- = pcMiscPrelId integerMinusOneIdKey pRELUDE_CORE SLIT("__integerm1") 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}
--------------------------------------------------------------------
--- 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))))
+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}
+ = 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
+ ]
-\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 >>
--}
+ 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) [betaTy])]
+ (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
+ ]
- 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}
+ 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
+ ]
-\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 -}
+ 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
+ ]
+
+ 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) [betaTy])]
+ (BindDefault z (Var y))))
+
+-- copyable and noFollow are currently merely hooks: they are translated into
+-- calls to the macros COPYABLE and NOFOLLOW -- HWL
+
+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
+ ]
+
+ copyable_template
+ = mkLam [alphaTyVar] [x] ( Prim CopyableOp [TyArg alphaTy, VarArg x] )
+
+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
+ ]
+
+ noFollow_template
+ = mkLam [alphaTyVar] [x] ( Prim NoFollowOp [TyArg alphaTy, VarArg x] )
\end{code}
%************************************************************************
readParen :: Bool -> ReadS a -> ReadS a
lex :: ReadS String
-\begin{code}
-{- OLD:
-readS_ty :: UniType -> UniType
-readS_ty ty
- = UniFun stringTy (mkListTy (mkTupleTy 2 [ty, stringTy]))
-
-showS_ty :: UniType
-showS_ty = UniFun stringTy stringTy
--}
-\end{code}
-
-\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
--}
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[PrelVals-void]{@void#@: Magic value of type @Void#@}
-%* *
-%************************************************************************
-
-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}
-- 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
+ (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}
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}
-{- NO:
-rangeComplaint_Ix_IntId
- = pcMiscPrelId rangeComplaintIdKey pRELUDE_BUILTIN SLIT("_rangeComplaint_Ix_Int") my_ty id_info
- where
- my_ty
- = mkSigmaTy [alpha_tv] [] (
- intPrimTy `UniFun` (
- intPrimTy `UniFun` (
- intPrimTy `UniFun` alpha)))
- id_info
- = noIdInfo
- `addInfo` mkArityInfo 3
- `addInfo` mkBottomStrictnessInfo
--}
-\end{code}
-
-\begin{code}
buildId
- = pcMiscPrelId buildIdKey pRELUDE_CORE SLIT("_build") buildTy
- ((((noIdInfo
- `addInfo_UF` mkMagicUnfolding SLIT("build"))
+ = pcMiscPrelId buildIdKey gHC__ SLIT("build") buildTy
+ ((((noIdInfo
+ {-LATER:`addInfo_UF` mkMagicUnfolding buildIdKey-})
`addInfo` mkStrictnessInfo [WwStrict] Nothing)
`addInfo` mkArgUsageInfo [ArgUsage 2])
- `addInfo` pcGenerateSpecs buildIdKey buildId noIdInfo{-ToDo-} buildTy)
+ `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}
\begin{code}
augmentId
- = pcMiscPrelId buildIdKey pRELUDE_CORE SLIT("_augment") augmentTy
- (((noIdInfo
- `addInfo_UF` mkMagicUnfolding SLIT("augment"))
+ = pcMiscPrelId augmentIdKey gHC__ SLIT("augment") augmentTy
+ (((noIdInfo
+ {-LATER:`addInfo_UF` mkMagicUnfolding augmentIdKey-})
`addInfo` mkStrictnessInfo [WwStrict,WwLazy False] Nothing)
`addInfo` mkArgUsageInfo [ArgUsage 2,UnknownArgUsage])
- -- cheating, but since _build never actually exists ...
+ -- 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 [alpha_tv] [] (buildUniTy `UniFun`
- (mkListTy alpha `UniFun` mkListTy alpha))
+ augmentTy = mkSigmaTy [alphaTyVar] [] (mkFunTys [aug_ty, mkListTy alphaTy] (mkListTy alphaTy))
where
- buildUniTy = mkSigmaTy [beta_tv] []
- ((alpha `UniFun` (beta `UniFun` beta))
- `UniFun` (beta `UniFun` beta))
+ aug_ty = mkSigmaTy [betaTyVar] []
+ (mkFunTys [mkFunTys [alphaTy, betaTy] betaTy, betaTy] betaTy)
\end{code}
-mkFoldr ty_a ty_b [x,y...] => foldr ty_a ty_b x y ..
-
\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)
+ `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)
-
-mkFoldl a b f z xs = foldl CoApp
- (mkCoTyApps (CoVar foldlId) [a, b])
- [CoVarAtom f,CoVarAtom z,CoVarAtom xs]
+ `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:
-- {- unfold augment -}
-- = foldr (:) ys xs
-- {- fold foldr to append -}
--- = ys `appendId` xs
+-- = 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 [alpha_tv] []
- ((mkListTy alpha) `UniFun` ((mkListTy alpha) `UniFun` (mkListTy alpha))))
- idInfo = (((noIdInfo
+ (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).
-pRELUDE_FB = SLIT("PreludeFoldrBuild")
+ToDo: Create single mkworld definition which is grabbed here and in ghc.lprl
+
+\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}