\section[PrelVals]{Prelude values the compiler ``knows about''}
\begin{code}
-#include "HsVersions.h"
-
module PrelVals where
-IMP_Ubiq()
-#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201
-IMPORT_DELOOPER(IdLoop) ( UnfoldingGuidance(..), mkUnfolding, nullSpecEnv, SpecEnv )
-#else
-import {-# SOURCE #-} CoreUnfold ( UnfoldingGuidance(..), mkUnfolding )
-import {-# SOURCE #-} SpecEnv ( SpecEnv, nullSpecEnv )
-#endif
+#include "HsVersions.h"
-#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201
-IMPORT_DELOOPER(PrelLoop)
-#endif
+import {-# SOURCE #-} CoreUnfold ( mkUnfolding )
-import Id ( SYN_IE(Id), GenId, mkImported, mkTemplateLocals )
+import Id ( Id, mkImported )
+import SpecEnv ( SpecEnv, emptySpecEnv )
-- 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 ( mkWiredInIdName, SYN_IE(Module) )
+import Name ( mkWiredInIdName, Module )
import PragmaInfo
-import PrimOp ( PrimOp(..) )
-#if __GLASGOW_HASKELL__ >= 202
import Type
-#else
-import Type ( mkTyVarTy )
-#endif
-import TyVar ( openAlphaTyVar, alphaTyVar, betaTyVar, gammaTyVar, SYN_IE(TyVar) )
+import TyVar ( openAlphaTyVar, alphaTyVar, betaTyVar, TyVar )
import Unique -- lots of *Keys
import Util ( panic )
\end{code}
-- these "bottom" out, no matter what their arguments
eRROR_ID
- = pc_bottoming_Id errorIdKey iO_BASE SLIT("error") errorTy
+ = pc_bottoming_Id errorIdKey pREL_ERR SLIT("error") errorTy
generic_ERROR_ID u n
- = pc_bottoming_Id u gHC_ERR n errorTy
+ = pc_bottoming_Id u pREL_ERR n errorTy
pAT_ERROR_ID
= generic_ERROR_ID patErrorIdKey SLIT("patError")
= 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")
+nO_METHOD_BINDING_ERROR_ID
+ = generic_ERROR_ID noMethodBindingErrorIdKey SLIT("noMethodBindingError")
aBSENT_ERROR_ID
- = pc_bottoming_Id absentErrorIdKey gHC_ERR SLIT("absentErr")
+ = pc_bottoming_Id absentErrorIdKey pREL_ERR SLIT("absentErr")
(mkSigmaTy [openAlphaTyVar] [] openAlphaTy)
pAR_ERROR_ID
- = pcMiscPrelId parErrorIdKey gHC_ERR SLIT("parError")
+ = pcMiscPrelId parErrorIdKey pREL_ERR SLIT("parError")
(mkSigmaTy [openAlphaTyVar] [] openAlphaTy) noIdInfo
openAlphaTy = mkTyVarTy openAlphaTyVar
and make a jolly old mess.
\begin{code}
tRACE_ID
- = pcMiscPrelId traceIdKey iO_BASE SLIT("trace") 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)
\begin{code}
packStringForCId
- = pcMiscPrelId packCStringIdKey{-ToDo:rename-} pACKED_STRING SLIT("packCString#")
+ = pcMiscPrelId packCStringIdKey{-ToDo:rename-} pREL_PACK SLIT("packCString#")
(mkFunTys [stringTy] byteArrayPrimTy) noIdInfo
--------------------------------------------------------------------
unpackCStringId
- = pcMiscPrelId unpackCStringIdKey pACKED_STRING SLIT("unpackCString#")
+ = pcMiscPrelId unpackCStringIdKey pREL_PACK SLIT("unpackCString#")
(mkFunTys [addrPrimTy{-a char *-}] stringTy) noIdInfo
-- Andy says:
-- (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 pACKED_STRING SLIT("unpackNBytes#")
+ = pcMiscPrelId unpackCString2IdKey pREL_PACK SLIT("unpackNBytes#")
(mkFunTys [addrPrimTy{-a char *-}, intPrimTy{-length-}] stringTy)
noIdInfo
--------------------------------------------------------------------
unpackCStringAppendId
- = pcMiscPrelId unpackCStringAppendIdKey pACKED_STRING SLIT("unpackAppendCString#")
+ = pcMiscPrelId unpackCStringAppendIdKey pREL_PACK SLIT("unpackAppendCString#")
(mkFunTys [addrPrimTy{-a "char *" pointer-},stringTy] stringTy)
((noIdInfo
{-LATER:`addUnfoldInfo` mkMagicUnfolding unpackCStringAppendIdKey-})
`addArityInfo` exactArity 2)
unpackCStringFoldrId
- = pcMiscPrelId unpackCStringFoldrIdKey pACKED_STRING SLIT("unpackFoldrCString#")
+ = pcMiscPrelId unpackCStringFoldrIdKey pREL_PACK SLIT("unpackFoldrCString#")
(mkSigmaTy [alphaTyVar] []
(mkFunTys [addrPrimTy{-a "char *" pointer-},
mkFunTys [charTy, alphaTy] alphaTy,
-}
\end{code}
-%************************************************************************
-%* *
-\subsection[PrelVals-runST]{@runST@: Magic start-state-transformer function}
-%* *
-%************************************************************************
-
-@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
-
-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 sT_BASE SLIT("runST") run_ST_ty id_info
- 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
- `addArityInfo` exactArity 1
- `addStrictnessInfo` mkStrictnessInfo [WwStrict] False
- `addArgUsageInfo` mkArgUsageInfo [ArgUsage 1]
- -- ABSOLUTELY NO UNFOLDING, e.g.: (mk_inline_unfolding run_ST_template)
- -- see example below
-{- OUT:
- [m, t, r, wild]
- = 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
- [(pairDataCon, [r, wild], Var r)]
- NoDefault)))
--}
-\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 gHC__ SLIT("realWorld#")
+ = pcMiscPrelId realWorldPrimIdKey pREL_GHC SLIT("realWorld#")
realWorldStatePrimTy
noIdInfo
\end{code}
\begin{code}
buildId
- = pcMiscPrelId buildIdKey gHC_ERR SLIT("build") buildTy
+ = pcMiscPrelId buildIdKey pREL_ERR SLIT("build") buildTy
((((noIdInfo
{-LATER:`addUnfoldInfo` mkMagicUnfolding buildIdKey-})
`addStrictnessInfo` mkStrictnessInfo [WwStrict] False)
\begin{code}
augmentId
- = pcMiscPrelId augmentIdKey gHC_ERR SLIT("augment") augmentTy
+ = pcMiscPrelId augmentIdKey pREL_ERR SLIT("augment") augmentTy
(((noIdInfo
{-LATER:`addUnfoldInfo` mkMagicUnfolding augmentIdKey-})
`addStrictnessInfo` mkStrictnessInfo [WwStrict,WwLazy False] False)
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:
projects / ghc-hetmet.git / blobdiff