X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fprelude%2FPrelVals.lhs;h=37d6f6b746c8d0b4b46825016b884fc28e8b9cf6;hb=f7ecf7234c224489be8a5e63fced903b655d92ee;hp=8aac8e64ceed46cb78f957230f28ce50c94ba8e0;hpb=f01a8e8c9c53bfb5ab3393ed3457ebf25390efa1;p=ghc-hetmet.git diff --git a/ghc/compiler/prelude/PrelVals.lhs b/ghc/compiler/prelude/PrelVals.lhs index 8aac8e6..37d6f6b 100644 --- a/ghc/compiler/prelude/PrelVals.lhs +++ b/ghc/compiler/prelude/PrelVals.lhs @@ -8,10 +8,10 @@ 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 @@ -19,25 +19,34 @@ import TysPrim 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} %************************************************************************ @@ -48,15 +57,15 @@ pcMiscPrelId key mod name ty info 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. @@ -68,48 +77,47 @@ pc_bottoming_Id key mod name ty -- 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#") + = generic_ERROR_ID noDefaultMethodErrorIdKey SLIT("noDefaultMethodError") nO_EXPLICIT_METHOD_ERROR_ID - = generic_ERROR_ID nonExplicitMethodErrorIdKey SLIT("noExplicitMethodError#") + = 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) \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) @@ -123,40 +131,40 @@ tRACE_ID \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} @@ -164,13 +172,13 @@ 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} %************************************************************************ @@ -180,22 +188,23 @@ integerMinusOneId %************************************************************************ \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)) @@ -215,7 +224,7 @@ seqId = pcMiscPrelId seqIdKey pRELUDE_BUILTIN SLIT("_seq_") (BindDefault z (Var y)))) -------------------------------------------------------------------- --- parId :: "_par_", also used w/ GRIP, etc. +-- parId :: "par", also used w/ GRIP, etc. {- OLDER: @@ -223,14 +232,14 @@ seqId = pcMiscPrelId seqIdKey pRELUDE_BUILTIN SLIT("_seq_") 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)) @@ -249,11 +258,11 @@ parId = pcMiscPrelId parIdKey pRELUDE_BUILTIN SLIT("_par_") [(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)) @@ -271,106 +280,218 @@ forkId = pcMiscPrelId forkIdKey pRELUDE_BUILTIN SLIT("_fork_") 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 @@ -407,16 +528,16 @@ runSTId -} \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-} @@ -440,11 +561,15 @@ All calls to @f@ will share a {\em single} array! End SLPJ 95/04. 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''} @@ -453,9 +578,9 @@ realWorldPrimId \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) @@ -498,9 +623,9 @@ mkBuild ty tv c n g expr \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 ... @@ -515,7 +640,7 @@ augmentId \end{code} \begin{code} -foldrId = pcMiscPrelId foldrIdKey pRELUDE_FB{-not "List"-} SLIT("foldr") +foldrId = pcMiscPrelId foldrIdKey pRELUDE SLIT("foldr") foldrTy idInfo where foldrTy = @@ -523,13 +648,13 @@ foldrId = pcMiscPrelId foldrIdKey pRELUDE_FB{-not "List"-} SLIT("foldr") (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 = @@ -537,7 +662,7 @@ foldlId = pcMiscPrelId foldlIdKey pRELUDE_FB{-not "List"-} SLIT("foldl") (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]) @@ -556,7 +681,7 @@ foldlId = pcMiscPrelId foldlIdKey pRELUDE_FB{-not "List"-} SLIT("foldl") -- 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 @@ -567,6 +692,7 @@ appendId `addInfo` mkStrictnessInfo [WwStrict,WwLazy False] Nothing) `addInfo` mkArityInfo 2) `addInfo` mkUpdateInfo [1,2]) +-} \end{code} %************************************************************************