module PrelVals where
-import Ubiq
-import IdLoop ( UnfoldingGuidance(..) )
-import Id ( Id(..), GenId, mkPreludeId, mkTemplateLocals )
-import PrelLoop
+IMP_Ubiq()
+IMPORT_DELOOPER(IdLoop) ( UnfoldingGuidance(..), nullSpecEnv, SpecEnv )
+import Id ( SYN_IE(Id), GenId, mkImported, mkUserId, mkTemplateLocals )
+IMPORT_DELOOPER(PrelLoop)
-- friends:
import PrelMods
import TysWiredIn
-- 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 SpecEnv ( SpecEnv(..), nullSpecEnv )
-import TyVar ( alphaTyVar, betaTyVar )
+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 mod name ty info
- = mkPreludeId (mkBuiltinName key mod name) ty info
+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 pRELUDE_BUILTIN n errorTy
+ = pc_bottoming_Id u SLIT("GHCerr") n errorTy
pAT_ERROR_ID
- = generic_ERROR_ID patErrorIdKey SLIT("patError#")
+ = generic_ERROR_ID patErrorIdKey SLIT("patError")
rEC_CON_ERROR_ID
- = generic_ERROR_ID recConErrorIdKey SLIT("recConError#")
+ = generic_ERROR_ID recConErrorIdKey SLIT("recConError")
rEC_UPD_ERROR_ID
- = generic_ERROR_ID recUpdErrorIdKey SLIT("recUpdError#")
+ = generic_ERROR_ID recUpdErrorIdKey SLIT("recUpdError")
iRREFUT_PAT_ERROR_ID
- = generic_ERROR_ID irrefutPatErrorIdKey SLIT("irrefutPatError#")
+ = generic_ERROR_ID irrefutPatErrorIdKey SLIT("irrefutPatError")
nON_EXHAUSTIVE_GUARDS_ERROR_ID
- = generic_ERROR_ID nonExhaustiveGuardsErrorIdKey SLIT("nonExhaustiveGuardsError#")
+ = 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 [alphaTyVar] [] alphaTy)
+ = pc_bottoming_Id absentErrorIdKey SLIT("GHCerr") SLIT("absentErr")
+ (mkSigmaTy [openAlphaTyVar] [] openAlphaTy)
pAR_ERROR_ID
- = pcMiscPrelId parErrorIdKey pRELUDE_BUILTIN SLIT("parError#")
- (mkSigmaTy [alphaTyVar] [] alphaTy) noIdInfo
+ = pcMiscPrelId parErrorIdKey SLIT("GHCerr") SLIT("parError")
+ (mkSigmaTy [openAlphaTyVar] [] openAlphaTy) noIdInfo
+
+openAlphaTy = mkTyVarTy openAlphaTyVar
errorTy :: Type
-errorTy = mkSigmaTy [alphaTyVar] [] (mkFunTys [mkListTy charTy] alphaTy)
+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 [alphaTyVar] [] (mkFunTys [mkListTy charTy, alphaTy] alphaTy)
\begin{code}
packStringForCId
- = pcMiscPrelId packCStringIdKey{-ToDo:rename-} pRELUDE_PS SLIT("_packStringForC")
+ = pcMiscPrelId packCStringIdKey{-ToDo:rename-} gHC__ SLIT("packStringForC__")
(mkFunTys [stringTy] byteArrayPrimTy) noIdInfo
--------------------------------------------------------------------
unpackCStringId
- = pcMiscPrelId unpackCStringIdKey pRELUDE_BUILTIN SLIT("unpackPS#")
+ = 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_BUILTIN SLIT("unpackPS2#")
+ = pcMiscPrelId unpackCString2IdKey gHC__ SLIT("unpackPS2__")
(mkFunTys [addrPrimTy{-a char *-}, intPrimTy{-length-}] stringTy)
noIdInfo
--------------------------------------------------------------------
unpackCStringAppendId
- = pcMiscPrelId unpackCStringAppendIdKey pRELUDE_BUILTIN SLIT("unpackAppendPS#")
+ = pcMiscPrelId unpackCStringAppendIdKey gHC__ SLIT("unpackAppendPS__")
(mkFunTys [addrPrimTy{-a "char *" pointer-},stringTy] stringTy)
((noIdInfo
- `addInfo_UF` mkMagicUnfolding unpackCStringAppendIdKey)
+ {-LATER:`addInfo_UF` mkMagicUnfolding unpackCStringAppendIdKey-})
`addInfo` mkArityInfo 2)
unpackCStringFoldrId
- = pcMiscPrelId unpackCStringFoldrIdKey pRELUDE_BUILTIN SLIT("unpackFoldrPS#")
+ = pcMiscPrelId unpackCStringFoldrIdKey gHC__ SLIT("unpackFoldrPS__")
(mkSigmaTy [alphaTyVar] []
(mkFunTys [addrPrimTy{-a "char *" pointer-},
mkFunTys [charTy, alphaTy] alphaTy,
alphaTy]
alphaTy))
((noIdInfo
- `addInfo_UF` mkMagicUnfolding unpackCStringFoldrIdKey)
+ {-LATER:`addInfo_UF` mkMagicUnfolding unpackCStringFoldrIdKey-})
`addInfo` mkArityInfo 3)
\end{code}
+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}
%************************************************************************
%************************************************************************
\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_")
+seqId = pcMiscPrelId seqIdKey gHC__ SLIT("seq")
(mkSigmaTy [alphaTyVar, betaTyVar] []
(mkFunTys [alphaTy, betaTy] betaTy))
(noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding seq_template))
(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_")
+parId = pcMiscPrelId parIdKey gHC__ SLIT("par")
(mkSigmaTy [alphaTyVar, betaTyVar] []
(mkFunTys [alphaTy, betaTy] betaTy))
(noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding par_template))
[(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [betaTy])]
(BindDefault z (Var y))))
--- forkId :: "_fork_", for *required* concurrent threads
+-- 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_")
+forkId = pcMiscPrelId forkIdKey gHC__ SLIT("fork")
(mkSigmaTy [alphaTyVar, betaTyVar] []
(mkFunTys [alphaTy, betaTy] betaTy))
(noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding fork_template))
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_")
+{- OUT:
+parLocalId = pcMiscPrelId parLocalIdKey gHC__ SLIT("parLocal")
(mkSigmaTy [alphaTyVar, betaTyVar] []
- (mkFunTys [intPrimTy, alphaTy, betaTy] betaTy))
+ (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,
+ {-g-} intPrimTy,
+ {-s-} intPrimTy,
+ {-p-} intPrimTy,
{-x-} alphaTy,
{-y-} betaTy,
- {-z-} betaTy
+ {-z-} intPrimTy
]
parLocal_template
- = mkLam [alphaTyVar, betaTyVar] [w, x, y] (
- Case (Prim ParLocalOp [TyArg alphaTy, TyArg betaTy, VarArg x, VarArg w, VarArg y]) (
- AlgAlts
- [(liftDataCon, [z], Var z)]
- (NoDefault)))
+ = 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 pRELUDE_BUILTIN SLIT("_parGlobal_")
+parGlobalId = pcMiscPrelId parGlobalIdKey gHC__ SLIT("parGlobal")
(mkSigmaTy [alphaTyVar, betaTyVar] []
- (mkFunTys [intPrimTy,alphaTy,betaTy] betaTy))
+ (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,
+ {-g-} intPrimTy,
+ {-s-} intPrimTy,
+ {-p-} intPrimTy,
{-x-} alphaTy,
{-y-} betaTy,
- {-z-} betaTy
+ {-z-} intPrimTy
]
parGlobal_template
- = mkLam [alphaTyVar, betaTyVar] [w, x, y] (
- Case (Prim ParGlobalOp [TyArg alphaTy, TyArg betaTy, VarArg x, VarArg w, VarArg y]) (
- AlgAlts
- [(liftDataCon, [z], Var z)]
- (NoDefault)))
+ = 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))))
-#endif {-GRAN-}
-\end{code}
-%************************************************************************
-%* *
-\subsection[PrelVals-deriving]{Values known about mainly for doing derived instance decls}
-%* *
-%************************************************************************
+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
+ ]
-map :: (a -> b) -> [a] -> [b]
- -- this is up in the here-because-of-unfolding list
+ 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))))
---??showChar :: Char -> ShowS
-showSpace :: ShowS -- non-std: == "showChar ' '"
-showString :: String -> ShowS
-showParen :: Bool -> ShowS -> ShowS
+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
+ ]
-(++) :: [a] -> [a] -> [a]
-readParen :: Bool -> ReadS a -> ReadS a
-lex :: ReadS String
+ 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))))
-%************************************************************************
-%* *
-\subsection[PrelVals-void]{@void#@: Magic value of type @Void#@}
-%* *
-%************************************************************************
+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
+ ]
-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
+ 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) [gammaTy])]
+ (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}
%************************************************************************
%* *
-\subsection[PrelVals-runST]{@_runST@: Magic start-state-transformer function}
+\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
+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 = betaTyVar
s = betaTy
-}
\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-}
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
+ = pcMiscPrelId buildIdKey SLIT("GHCerr") SLIT("build") buildTy
((((noIdInfo
- `addInfo_UF` mkMagicUnfolding buildIdKey)
+ {-LATER:`addInfo_UF` mkMagicUnfolding buildIdKey-})
`addInfo` mkStrictnessInfo [WwStrict] Nothing)
`addInfo` mkArgUsageInfo [ArgUsage 2])
`addInfo` pcGenerateSpecs buildIdKey buildId noIdInfo{-ToDo-} buildTy)
buildTy = mkSigmaTy [alphaTyVar] [] (mkFunTys [build_ty] (mkListTy alphaTy))
where
build_ty = mkSigmaTy [betaTyVar] []
- (mkFunTys [alphaTy, mkFunTys [betaTy] betaTy, betaTy] betaTy)
+ (mkFunTys [mkFunTys [alphaTy, betaTy] betaTy, betaTy] betaTy)
\end{code}
@mkBuild@ is sugar for building a build!
\begin{code}
augmentId
- = pcMiscPrelId augmentIdKey pRELUDE_CORE SLIT("_augment") augmentTy
+ = pcMiscPrelId augmentIdKey SLIT("GHCerr") SLIT("augment") augmentTy
(((noIdInfo
- `addInfo_UF` mkMagicUnfolding augmentIdKey)
+ {-LATER:`addInfo_UF` mkMagicUnfolding augmentIdKey-})
`addInfo` mkStrictnessInfo [WwStrict,WwLazy False] Nothing)
`addInfo` mkArgUsageInfo [ArgUsage 2,UnknownArgUsage])
-- cheating, but since _augment never actually exists ...
augmentTy = mkSigmaTy [alphaTyVar] [] (mkFunTys [aug_ty, mkListTy alphaTy] (mkListTy alphaTy))
where
aug_ty = mkSigmaTy [betaTyVar] []
- (mkFunTys [alphaTy, mkFunTys [betaTy] betaTy, betaTy] betaTy)
+ (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 [alphaTyVar, betaTyVar] []
- (mkFunTys [alphaTy, mkFunTys [betaTy] betaTy, betaTy, mkListTy alphaTy] betaTy)
+ (mkFunTys [mkFunTys [alphaTy, betaTy] betaTy, betaTy, mkListTy alphaTy] betaTy)
idInfo = (((((noIdInfo
- `addInfo_UF` mkMagicUnfolding foldrIdKey)
+ {-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)
-foldlId = pcMiscPrelId foldlIdKey pRELUDE_FB{-not "List"-} SLIT("foldl")
+foldlId = pcMiscPrelId foldlIdKey pRELUDE SLIT("foldl")
foldlTy idInfo
where
foldlTy =
mkSigmaTy [alphaTyVar, betaTyVar] []
- (mkFunTys [alphaTy, mkFunTys [betaTy] betaTy, alphaTy, mkListTy betaTy] alphaTy)
+ (mkFunTys [mkFunTys [alphaTy, betaTy] alphaTy, alphaTy, mkListTy betaTy] alphaTy)
idInfo = (((((noIdInfo
- `addInfo_UF` mkMagicUnfolding foldlIdKey)
+ {-LATER:`addInfo_UF` mkMagicUnfolding foldlIdKey-})
`addInfo` mkStrictnessInfo [WwLazy False,WwLazy False,WwStrict] Nothing)
`addInfo` mkArityInfo 3)
`addInfo` mkUpdateInfo [2,2,1])
-- 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
`addInfo` mkStrictnessInfo [WwStrict,WwLazy False] Nothing)
`addInfo` mkArityInfo 2)
`addInfo` mkUpdateInfo [1,2])
+-}
\end{code}
%************************************************************************
projects / ghc-hetmet.git / blobdiff