X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fprelude%2FPrelVals.lhs;h=9f6930b269c9cd7717e03853b139c83a3f5eb595;hb=28139aea50376444d56f43f0914291348a51a7e7;hp=5c5375a5900d16df6c86baae32e3c25f4f40827d;hpb=f9120c200bcf613b58d742802172fb4c08171f0d;p=ghc-hetmet.git diff --git a/ghc/compiler/prelude/PrelVals.lhs b/ghc/compiler/prelude/PrelVals.lhs index 5c5375a..9f6930b 100644 --- a/ghc/compiler/prelude/PrelVals.lhs +++ b/ghc/compiler/prelude/PrelVals.lhs @@ -4,14 +4,14 @@ \section[PrelVals]{Prelude values the compiler ``knows about''} \begin{code} +module PrelVals where + #include "HsVersions.h" -module PrelVals where +import {-# SOURCE #-} CoreUnfold ( UnfoldingGuidance(..), mkUnfolding ) -import Ubiq -import IdLoop ( UnfoldingGuidance(..) ) -import Id ( Id(..), GenId, mkPreludeId, mkTemplateLocals ) -import PrelLoop +import Id ( Id, mkImported, mkTemplateLocals ) +import SpecEnv ( SpecEnv, emptySpecEnv ) -- friends: import PrelMods @@ -19,25 +19,37 @@ import TysPrim import TysWiredIn -- others: +import CmdLineOpts ( maybe_CompilingGhcInternals ) import CoreSyn -- quite a bit import IdInfo -- quite a bit import Literal ( mkMachInt ) +import Name ( mkWiredInIdName, Module ) +import PragmaInfo import PrimOp ( PrimOp(..) ) -import SpecEnv ( SpecEnv(..), nullSpecEnv ) -import TyVar ( alphaTyVar, betaTyVar ) +import Type +import TyVar ( openAlphaTyVar, alphaTyVar, betaTyVar, gammaTyVar, TyVar ) 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 +mk_inline_unfolding = mkUnfolding IWantToBeINLINEd + +pcMiscPrelId :: Unique{-IdKey-} -> Module -> FAST_STRING -> Type -> IdInfo -> Id + +pcMiscPrelId key mod occ ty info + = let + name = mkWiredInIdName key mod occ imp + 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 +60,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. @@ -64,38 +76,53 @@ templates, but we don't ever expect to generate code for it. pc_bottoming_Id key mod name ty = pcMiscPrelId key mod name ty bottoming_info where - bottoming_info = noIdInfo `addInfo` mkBottomStrictnessInfo + bottoming_info = noIdInfo `addStrictnessInfo` mkBottomStrictnessInfo -- these "bottom" out, no matter what their arguments eRROR_ID - = pc_bottoming_Id errorIdKey pRELUDE_BUILTIN SLIT("error") errorTy + = pc_bottoming_Id errorIdKey pREL_ERR SLIT("error") errorTy + +generic_ERROR_ID u n + = pc_bottoming_Id u pREL_ERR 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_METHOD_BINDING_ERROR_ID + = generic_ERROR_ID noMethodBindingErrorIdKey SLIT("noMethodBindingError") aBSENT_ERROR_ID - = pc_bottoming_Id absentErrorIdKey pRELUDE_BUILTIN SLIT("absent#") - (mkSigmaTy [alphaTyVar] [] alphaTy) + = pc_bottoming_Id absentErrorIdKey pREL_ERR SLIT("absentErr") + (mkSigmaTy [openAlphaTyVar] [] openAlphaTy) pAR_ERROR_ID - = pcMiscPrelId parErrorIdKey pRELUDE_BUILTIN SLIT("parError#") - (mkSigmaTy [alphaTyVar] [] alphaTy) noIdInfo + = pcMiscPrelId parErrorIdKey pREL_ERR 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 - (noIdInfo `addInfo` pcGenerateSpecs traceIdKey tRACE_ID noIdInfo traceTy) + = pcMiscPrelId traceIdKey pREL_IO_BASE SLIT("trace") traceTy + (noIdInfo `addSpecInfo` pcGenerateSpecs traceIdKey tRACE_ID noIdInfo traceTy) where traceTy = mkSigmaTy [alphaTyVar] [] (mkFunTys [mkListTy charTy, alphaTy] alphaTy) \end{code} @@ -108,54 +135,55 @@ tRACE_ID \begin{code} packStringForCId - = pcMiscPrelId packCStringIdKey{-ToDo:rename-} pRELUDE_PS SLIT("_packStringForC") + = pcMiscPrelId packCStringIdKey{-ToDo:rename-} pREL_PACK SLIT("packCString#") (mkFunTys [stringTy] byteArrayPrimTy) noIdInfo -------------------------------------------------------------------- unpackCStringId - = pcMiscPrelId unpackCStringIdKey pRELUDE_BUILTIN SLIT("unpackPS#") + = pcMiscPrelId unpackCStringIdKey pREL_PACK SLIT("unpackCString#") (mkFunTys [addrPrimTy{-a char *-}] stringTy) noIdInfo -- Andy says: --- (FunTy addrPrimTy{-a char *-} stringTy) (noIdInfo `addInfo` mkArityInfo 1) +-- (FunTy addrPrimTy{-a char *-} stringTy) (noIdInfo `addInfo` exactArity 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 pREL_PACK SLIT("unpackNBytes#") (mkFunTys [addrPrimTy{-a char *-}, intPrimTy{-length-}] stringTy) noIdInfo -------------------------------------------------------------------- unpackCStringAppendId - = pcMiscPrelId unpackCStringAppendIdKey pRELUDE_BUILTIN SLIT("unpackAppendPS#") + = pcMiscPrelId unpackCStringAppendIdKey pREL_PACK SLIT("unpackAppendCString#") (mkFunTys [addrPrimTy{-a "char *" pointer-},stringTy] stringTy) ((noIdInfo - `addInfo_UF` mkMagicUnfolding unpackCStringAppendIdKey) - `addInfo` mkArityInfo 2) + {-LATER:`addUnfoldInfo` mkMagicUnfolding unpackCStringAppendIdKey-}) + `addArityInfo` exactArity 2) unpackCStringFoldrId - = pcMiscPrelId unpackCStringFoldrIdKey pRELUDE_BUILTIN SLIT("unpackFoldrPS#") + = pcMiscPrelId unpackCStringFoldrIdKey pREL_PACK SLIT("unpackFoldrCString#") (mkSigmaTy [alphaTyVar] [] (mkFunTys [addrPrimTy{-a "char *" pointer-}, mkFunTys [charTy, alphaTy] alphaTy, alphaTy] alphaTy)) ((noIdInfo - `addInfo_UF` mkMagicUnfolding unpackCStringFoldrIdKey) - `addInfo` mkArityInfo 3) + {-LATER:`addUnfoldInfo` mkMagicUnfolding unpackCStringFoldrIdKey-}) + `addArityInfo` exactArity 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 pREL_NUM SLIT("integer_0") integerTy noIdInfo integerPlusOneId - = pcMiscPrelId integerPlusOneIdKey pRELUDE_CORE SLIT("__integer1") integerTy noIdInfo + = pcMiscPrelId integerPlusOneIdKey pREL_NUM SLIT("integer_1") integerTy noIdInfo integerPlusTwoId - = pcMiscPrelId integerPlusTwoIdKey pRELUDE_CORE SLIT("__integer2") integerTy noIdInfo + = pcMiscPrelId integerPlusTwoIdKey pREL_NUM SLIT("integer_2") integerTy noIdInfo integerMinusOneId - = pcMiscPrelId integerMinusOneIdKey pRELUDE_CORE SLIT("__integerm1") integerTy noIdInfo + = pcMiscPrelId integerMinusOneIdKey pREL_NUM SLIT("integer_m1") integerTy noIdInfo \end{code} %************************************************************************ @@ -165,25 +193,26 @@ 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 pRELUDE SLIT("seq") (mkSigmaTy [alphaTyVar, betaTyVar] [] (mkFunTys [alphaTy, betaTy] betaTy)) - (noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding seq_template)) + (noIdInfo `addUnfoldInfo` (mk_inline_unfolding seq_template)) where [x, y, z] = mkTemplateLocals [ @@ -200,7 +229,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: @@ -208,17 +237,17 @@ 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 cONC_BASE SLIT("par") (mkSigmaTy [alphaTyVar, betaTyVar] [] (mkFunTys [alphaTy, betaTy] betaTy)) - (noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding par_template)) + (noIdInfo `addUnfoldInfo` (mk_inline_unfolding par_template)) where [x, y, z] = mkTemplateLocals [ @@ -234,14 +263,14 @@ 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 cONC_BASE SLIT("fork") (mkSigmaTy [alphaTyVar, betaTyVar] [] (mkFunTys [alphaTy, betaTy] betaTy)) - (noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding fork_template)) + (noIdInfo `addUnfoldInfo` (mk_inline_unfolding fork_template)) where [x, y, z] = mkTemplateLocals [ @@ -256,180 +285,211 @@ 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 cONC_BASE SLIT("parLocal") (mkSigmaTy [alphaTyVar, betaTyVar] [] - (mkFunTys [intPrimTy, alphaTy, betaTy] betaTy)) - (noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding parLocal_template)) + (mkFunTys [intPrimTy, intPrimTy, intPrimTy, intPrimTy, alphaTy, betaTy] betaTy)) + (noIdInfo `addUnfoldInfo` (mk_inline_unfolding 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 cONC_BASE SLIT("parGlobal") (mkSigmaTy [alphaTyVar, betaTyVar] [] - (mkFunTys [intPrimTy,alphaTy,betaTy] betaTy)) - (noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding parGlobal_template)) + (mkFunTys [intPrimTy, intPrimTy, intPrimTy, intPrimTy, alphaTy, betaTy] betaTy)) + (noIdInfo `addUnfoldInfo` (mk_inline_unfolding 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 cONC_BASE SLIT("parAt") + (mkSigmaTy [alphaTyVar, betaTyVar] [] + (mkFunTys [intPrimTy, intPrimTy, intPrimTy, intPrimTy, + alphaTy, betaTy, gammaTy] gammaTy)) + (noIdInfo `addUnfoldInfo` (mk_inline_unfolding 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 + ] + + 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 cONC_BASE SLIT("parAtAbs") + (mkSigmaTy [alphaTyVar, betaTyVar] [] + (mkFunTys [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, alphaTy, betaTy] betaTy)) + (noIdInfo `addUnfoldInfo` (mk_inline_unfolding 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 + ] + + 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)))) -map :: (a -> b) -> [a] -> [b] - -- this is up in the here-because-of-unfolding list +parAtRelId = pcMiscPrelId parAtRelIdKey cONC_BASE SLIT("parAtRel") + (mkSigmaTy [alphaTyVar, betaTyVar] [] + (mkFunTys [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, alphaTy, betaTy] betaTy)) + (noIdInfo `addUnfoldInfo` (mk_inline_unfolding 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 + ] ---??showChar :: Char -> ShowS -showSpace :: ShowS -- non-std: == "showChar ' '" -showString :: String -> ShowS -showParen :: Bool -> ShowS -> ShowS + 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)))) -(++) :: [a] -> [a] -> [a] -readParen :: Bool -> ReadS a -> ReadS a -lex :: ReadS String +parAtForNowId = pcMiscPrelId parAtForNowIdKey cONC_BASE SLIT("parAtForNow") + (mkSigmaTy [alphaTyVar, betaTyVar] [] + (mkFunTys [intPrimTy, intPrimTy, intPrimTy, intPrimTy, + alphaTy, betaTy, gammaTy] gammaTy)) + (noIdInfo `addUnfoldInfo` (mk_inline_unfolding 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 + ] -%************************************************************************ -%* * -\subsection[PrelVals-void]{@void#@: Magic value of type @Void#@} -%* * -%************************************************************************ + 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)))) -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} +-- copyable and noFollow are currently merely hooks: they are translated into +-- calls to the macros COPYABLE and NOFOLLOW -- HWL -%************************************************************************ -%* * -\subsection[PrelVals-runST]{@_runST@: Magic start-state-transformer function} -%* * -%************************************************************************ +copyableId = pcMiscPrelId copyableIdKey cONC_BASE SLIT("copyable") + (mkSigmaTy [alphaTyVar] [] + alphaTy) + (noIdInfo `addUnfoldInfo` (mk_inline_unfolding copyable_template)) + where + -- Annotations: x: closure that's tagged to by copyable + [x, z] + = mkTemplateLocals [ + {-x-} alphaTy, + {-z-} alphaTy + ] -@_runST@ has a non-Haskell-able type: -\begin{verbatim} --- _runST :: forall a. (forall s. _ST s a) -> a --- which is to say :: --- forall a. (forall s. (_State s -> (a, _State s))) -> a + copyable_template + = mkLam [alphaTyVar] [x] ( Prim CopyableOp [TyArg alphaTy, VarArg x] ) -_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 +noFollowId = pcMiscPrelId noFollowIdKey cONC_BASE SLIT("noFollow") + (mkSigmaTy [alphaTyVar] [] + alphaTy) + (noIdInfo `addUnfoldInfo` (mk_inline_unfolding noFollow_template)) where - s_tv = betaTyVar - s = betaTy - - st_ty a = mkSigmaTy [s_tv] [] (mkStateTransformerTy s a) - - run_ST_ty - = 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` mkArgUsageInfo [ArgUsage 1] - -- ABSOLUTELY NO UNFOLDING, e.g.: (mkUnfolding EssentialUnfolding run_ST_template) - -- see example below -{- OUT: - [m, t, r, wild] + -- Annotations: x: closure that's tagged to not follow + [x, z] = mkTemplateLocals [ - {-m-} st_ty alphaTy, - {-t-} realWorldStateTy, - {-r-} alphaTy, - {-_-} realWorldStateTy - ] - - run_ST_template - = 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))) + {-x-} alphaTy, + {-z-} alphaTy + ] + + noFollow_template + = mkLam [alphaTyVar] [x] ( Prim NoFollowOp [TyArg alphaTy, VarArg x] ) -} \end{code} -SLPJ 95/04: Why @_runST@ must not have an unfolding; consider: -\begin{verbatim} -f x = - _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: -\begin{verbatim} -f x = let - (a, s') = newArray# 100 [] realWorld#{-NB-} - (_, s'') = fill_in_array_or_something a x s' - in - freezeArray# a s'' -\end{verbatim} -And now the @newArray#@ binding can be floated to become a CAF, which -is totally and utterly wrong: -\begin{verbatim} -f = let - (a, s') = newArray# 100 [] realWorld#{-NB-} -- YIKES!!! - in - \ x -> - let (_, s'') = fill_in_array_or_something a x s' in - freezeArray# a s'' -\end{verbatim} -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 (@Literal@). \begin{code} realWorldPrimId - = pcMiscPrelId realWorldPrimIdKey pRELUDE_BUILTIN SLIT("realWorld#") + = pcMiscPrelId realWorldPrimIdKey pREL_GHC SLIT("realWorld#") realWorldStatePrimTy noIdInfo \end{code} +\begin{code} +voidId = pc_bottoming_Id voidIdKey pREL_BASE SLIT("void") voidTy +\end{code} + %************************************************************************ %* * \subsection[PrelVals-foldr-build]{Values known about for ``foldr/build''} @@ -438,12 +498,12 @@ realWorldPrimId \begin{code} buildId - = pcMiscPrelId buildIdKey pRELUDE_CORE SLIT("_build") buildTy + = pcMiscPrelId buildIdKey pREL_ERR SLIT("build") buildTy ((((noIdInfo - `addInfo_UF` mkMagicUnfolding buildIdKey) - `addInfo` mkStrictnessInfo [WwStrict] Nothing) - `addInfo` mkArgUsageInfo [ArgUsage 2]) - `addInfo` pcGenerateSpecs buildIdKey buildId noIdInfo{-ToDo-} buildTy) + {-LATER:`addUnfoldInfo` mkMagicUnfolding buildIdKey-}) + `addStrictnessInfo` mkStrictnessInfo [WwStrict] False) + `addArgUsageInfo` mkArgUsageInfo [ArgUsage 2]) + `addSpecInfo` pcGenerateSpecs buildIdKey buildId noIdInfo{-ToDo-} buildTy) -- cheating, but since _build never actually exists ... where -- The type of this strange object is: @@ -452,7 +512,7 @@ buildId 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! @@ -483,11 +543,11 @@ mkBuild ty tv c n g expr \begin{code} augmentId - = pcMiscPrelId augmentIdKey pRELUDE_CORE SLIT("_augment") augmentTy + = pcMiscPrelId augmentIdKey pREL_ERR SLIT("augment") augmentTy (((noIdInfo - `addInfo_UF` mkMagicUnfolding augmentIdKey) - `addInfo` mkStrictnessInfo [WwStrict,WwLazy False] Nothing) - `addInfo` mkArgUsageInfo [ArgUsage 2,UnknownArgUsage]) + {-LATER:`addUnfoldInfo` mkMagicUnfolding augmentIdKey-}) + `addStrictnessInfo` mkStrictnessInfo [WwStrict,WwLazy False] False) + `addArgUsageInfo` mkArgUsageInfo [ArgUsage 2,UnknownArgUsage]) -- cheating, but since _augment never actually exists ... where -- The type of this strange object is: @@ -496,37 +556,37 @@ augmentId 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 pREL_BASE 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) - `addInfo` mkStrictnessInfo [WwLazy False,WwLazy False,WwStrict] Nothing) - `addInfo` mkArityInfo 3) - `addInfo` mkUpdateInfo [2,2,1]) - `addInfo` pcGenerateSpecs foldrIdKey foldrId noIdInfo{-ToDo-} foldrTy) + {-LATER:`addUnfoldInfo` mkMagicUnfolding foldrIdKey-}) + `addStrictnessInfo` mkStrictnessInfo [WwLazy False,WwLazy False,WwStrict] False) + `addArityInfo` exactArity 3) + `addUpdateInfo` mkUpdateInfo [2,2,1]) + `addSpecInfo` pcGenerateSpecs foldrIdKey foldrId noIdInfo{-ToDo-} foldrTy) -foldlId = pcMiscPrelId foldlIdKey pRELUDE_FB{-not "List"-} SLIT("foldl") +foldlId = pcMiscPrelId foldlIdKey pREL_LIST 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) - `addInfo` mkStrictnessInfo [WwLazy False,WwLazy False,WwStrict] Nothing) - `addInfo` mkArityInfo 3) - `addInfo` mkUpdateInfo [2,2,1]) - `addInfo` pcGenerateSpecs foldlIdKey foldlId noIdInfo{-ToDo-} foldlTy) + {-LATER:`addUnfoldInfo` mkMagicUnfolding foldlIdKey-}) + `addStrictnessInfo` mkStrictnessInfo [WwLazy False,WwLazy False,WwStrict] False) + `addArityInfo` exactArity 3) + `addUpdateInfo` mkUpdateInfo [2,2,1]) + `addSpecInfo` 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: @@ -541,17 +601,18 @@ 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 + = pcMiscPrelId appendIdKey mONAD 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]) + `addStrictnessInfo` mkStrictnessInfo [WwStrict,WwLazy False] False) + `addArityInfo` exactArity 2) + `addUpdateInfo` mkUpdateInfo [1,2]) +-} \end{code} %************************************************************************ @@ -575,9 +636,9 @@ types passed to the pre-processor with the -genSPECS arg (see ghc.lprl). ToDo: Create single mkworld definition which is grabbed here and in ghc.lprl \begin{code} -pcGenerateSpecs :: Unique -> Id -> IdInfo -> Type -> SpecEnv +pcGenerateSpecs :: Unique -> Id -> IdInfo -> Type -> IdSpecEnv pcGenerateSpecs key id info ty - = nullSpecEnv + = emptySpecEnv {- LATER: