# define USE_FAST_STRINGS 1
# define FAST_STRING FastString.FastString
# define SLIT(x) (FastString.mkFastCharString# (x#))
+# define FSLIT(x) (FastString.mkFastString# (x#))
# define _NULL_ FastString.nullFastString
# define _NIL_ (FastString.mkFastString "")
# define _CONS_ FastString.consFS
# -----------------------------------------------------------------------------
-# $Id: Makefile,v 1.212 2002/02/14 08:23:25 sof Exp $
+# $Id: Makefile,v 1.213 2002/03/04 17:01:27 simonmar Exp $
TOP = ..
INSTALL_PROGS += $(HS_PROG)
endif
+# ----------------------------------------------------------------------------
+# profiling.
+
+rename/Rename_HC_OPTS += -auto-all
+rename/RnEnv_HC_OPTS += -auto-all
+rename/RnHiFiles_HC_OPTS += -auto-all
+rename/RnSource_HC_OPTS += -auto-all
+
#-----------------------------------------------------------------------------
# clean
mkSysLocalName, mkLocalName,
getOccName, getSrcLoc
)
-import OccName ( UserFS, mkWorkerOcc )
+import OccName ( EncodedFS, UserFS, mkWorkerOcc )
import PrimRep ( PrimRep )
import TysPrim ( statePrimTyCon )
import FieldLabel ( FieldLabel )
-- SysLocal: for an Id being created by the compiler out of thin air...
-- UserLocal: an Id with a name the user might recognize...
mkUserLocal :: OccName -> Unique -> Type -> SrcLoc -> Id
-mkSysLocal :: UserFS -> Unique -> Type -> Id
+mkSysLocal :: EncodedFS -> Unique -> Type -> Id
mkVanillaGlobal :: Name -> Type -> IdInfo -> Id
+-- for SysLocal, we assume the base name is already encoded, to avoid
+-- re-encoding the same string over and over again.
mkSysLocal fs uniq ty = mkLocalId (mkSysLocalName uniq fs) ty
mkUserLocal occ uniq ty loc = mkLocalId (mkLocalName uniq occ loc) ty
mkVanillaGlobal = mkGlobalId VanillaGlobal
\begin{code}
-- "Wild Id" typically used when you need a binder that you don't expect to use
mkWildId :: Type -> Id
-mkWildId ty = mkSysLocal SLIT("wild") (mkBuiltinUnique 1) ty
+mkWildId ty = mkSysLocal FSLIT("wild") (mkBuiltinUnique 1) ty
mkWorkerId :: Unique -> Id -> Type -> Id
-- A worker gets a local name. CoreTidy will globalise it if necessary.
mkTemplateLocalsNum n tys = zipWith mkTemplateLocal [n..] tys
mkTemplateLocal :: Int -> Type -> Id
-mkTemplateLocal i ty = mkSysLocal SLIT("tpl") (mkBuiltinUnique i) ty
+mkTemplateLocal i ty = mkSysLocal FSLIT("tpl") (mkBuiltinUnique i) ty
\end{code}
import Outputable
import FastTypes
+import Binary
import Util ( thenCmp )
import Ratio ( numerator )
| MachLitLit FAST_STRING Type -- Type might be Addr# or Int# etc
\end{code}
+Binary instance: must do this manually, because we don't want the type
+arg of MachLitLit involved.
+
+\begin{code}
+instance Binary Literal where
+ put_ bh (MachChar aa) = do putByte bh 0; put_ bh aa
+ put_ bh (MachStr ab) = do putByte bh 1; put_ bh ab
+ put_ bh (MachAddr ac) = do putByte bh 2; put_ bh ac
+ put_ bh (MachInt ad) = do putByte bh 3; put_ bh ad
+ put_ bh (MachInt64 ae) = do putByte bh 4; put_ bh ae
+ put_ bh (MachWord af) = do putByte bh 5; put_ bh af
+ put_ bh (MachWord64 ag) = do putByte bh 6; put_ bh ag
+ put_ bh (MachFloat ah) = do putByte bh 7; put_ bh ah
+ put_ bh (MachDouble ai) = do putByte bh 8; put_ bh ai
+ put_ bh (MachLabel aj) = do putByte bh 9; put_ bh aj
+ put_ bh (MachLitLit ak _) = do putByte bh 10; put_ bh ak
+ get bh = do
+ h <- getByte bh
+ case h of
+ 0 -> do
+ aa <- get bh
+ return (MachChar aa)
+ 1 -> do
+ ab <- get bh
+ return (MachStr ab)
+ 2 -> do
+ ac <- get bh
+ return (MachAddr ac)
+ 3 -> do
+ ad <- get bh
+ return (MachInt ad)
+ 4 -> do
+ ae <- get bh
+ return (MachInt64 ae)
+ 5 -> do
+ af <- get bh
+ return (MachWord af)
+ 6 -> do
+ ag <- get bh
+ return (MachWord64 ag)
+ 7 -> do
+ ah <- get bh
+ return (MachFloat ah)
+ 8 -> do
+ ai <- get bh
+ return (MachDouble ai)
+ 9 -> do
+ aj <- get bh
+ return (MachLabel aj)
+ 10 -> do
+ ak <- get bh
+ return (MachLitLit ak (error "MachLitLit: no type"))
+\end{code}
+
\begin{code}
instance Outputable Literal where
ppr lit = pprLit lit
(_, tycon_args, pack_con, con_arg_tys)
= splitProductType "rebuildConArgs" arg_ty
- unpacked_args = zipWith (mkSysLocal SLIT("rb")) us con_arg_tys
+ unpacked_args = zipWith (mkSysLocal FSLIT("rb")) us con_arg_tys
(binds, args') = rebuildConArgs args stricts (dropList con_arg_tys us)
con_app = mkConApp pack_con (map Type tycon_args ++ map Var unpacked_args)
in
\begin{code}
-- unsafeCoerce# :: forall a b. a -> b
unsafeCoerceId
- = pcMiscPrelId unsafeCoerceIdKey pREL_GHC SLIT("unsafeCoerce#") ty info
+ = pcMiscPrelId unsafeCoerceIdKey pREL_GHC FSLIT("unsafeCoerce#") ty info
where
info = noCafNoTyGenIdInfo `setUnfoldingInfo` mkCompulsoryUnfolding rhs
-- The reason is is here is because we don't provide
-- a way to write this literal in Haskell.
nullAddrId
- = pcMiscPrelId nullAddrIdKey pREL_GHC SLIT("nullAddr#") addrPrimTy info
+ = pcMiscPrelId nullAddrIdKey pREL_GHC FSLIT("nullAddr#") addrPrimTy info
where
info = noCafNoTyGenIdInfo `setUnfoldingInfo`
mkCompulsoryUnfolding (Lit nullAddrLit)
seqId
- = pcMiscPrelId seqIdKey pREL_GHC SLIT("seq") ty info
+ = pcMiscPrelId seqIdKey pREL_GHC FSLIT("seq") ty info
where
info = noCafNoTyGenIdInfo `setUnfoldingInfo` mkCompulsoryUnfolding rhs
\begin{code}
getTagId
- = pcMiscPrelId getTagIdKey pREL_GHC SLIT("getTag#") ty info
+ = pcMiscPrelId getTagIdKey pREL_GHC FSLIT("getTag#") ty info
where
info = noCafNoTyGenIdInfo `setUnfoldingInfo` mkCompulsoryUnfolding rhs
-- We don't provide a defn for this; you must inline it
\begin{code}
realWorldPrimId -- :: State# RealWorld
- = pcMiscPrelId realWorldPrimIdKey pREL_GHC SLIT("realWorld#")
+ = pcMiscPrelId realWorldPrimIdKey pREL_GHC FSLIT("realWorld#")
realWorldStatePrimTy
(noCafNoTyGenIdInfo `setUnfoldingInfo` mkOtherCon [])
-- The mkOtherCon makes it look that realWorld# is evaluated
-- to be inlined
voidArgId -- :: State# RealWorld
- = mkSysLocal SLIT("void") voidArgIdKey realWorldStatePrimTy
+ = mkSysLocal FSLIT("void") voidArgIdKey realWorldStatePrimTy
\end{code}
\begin{code}
eRROR_ID
- = pc_bottoming_Id errorIdKey pREL_ERR SLIT("error") errorTy
+ = pc_bottoming_Id errorIdKey pREL_ERR FSLIT("error") errorTy
eRROR_CSTRING_ID
- = pc_bottoming_Id errorCStringIdKey pREL_ERR SLIT("errorCString")
+ = pc_bottoming_Id errorCStringIdKey pREL_ERR FSLIT("errorCString")
(mkSigmaTy [openAlphaTyVar] [] (mkFunTy addrPrimTy openAlphaTy))
pAT_ERROR_ID
- = generic_ERROR_ID patErrorIdKey SLIT("patError")
+ = generic_ERROR_ID patErrorIdKey FSLIT("patError")
rEC_SEL_ERROR_ID
- = generic_ERROR_ID recSelErrIdKey SLIT("recSelError")
+ = generic_ERROR_ID recSelErrIdKey FSLIT("recSelError")
rEC_CON_ERROR_ID
- = generic_ERROR_ID recConErrorIdKey SLIT("recConError")
+ = generic_ERROR_ID recConErrorIdKey FSLIT("recConError")
rEC_UPD_ERROR_ID
- = generic_ERROR_ID recUpdErrorIdKey SLIT("recUpdError")
+ = generic_ERROR_ID recUpdErrorIdKey FSLIT("recUpdError")
iRREFUT_PAT_ERROR_ID
- = generic_ERROR_ID irrefutPatErrorIdKey SLIT("irrefutPatError")
+ = generic_ERROR_ID irrefutPatErrorIdKey FSLIT("irrefutPatError")
nON_EXHAUSTIVE_GUARDS_ERROR_ID
- = generic_ERROR_ID nonExhaustiveGuardsErrorIdKey SLIT("nonExhaustiveGuardsError")
+ = generic_ERROR_ID nonExhaustiveGuardsErrorIdKey FSLIT("nonExhaustiveGuardsError")
nO_METHOD_BINDING_ERROR_ID
- = generic_ERROR_ID noMethodBindingErrorIdKey SLIT("noMethodBindingError")
+ = generic_ERROR_ID noMethodBindingErrorIdKey FSLIT("noMethodBindingError")
aBSENT_ERROR_ID
- = pc_bottoming_Id absentErrorIdKey pREL_ERR SLIT("absentErr")
+ = pc_bottoming_Id absentErrorIdKey pREL_ERR FSLIT("absentErr")
(mkSigmaTy [openAlphaTyVar] [] openAlphaTy)
pAR_ERROR_ID
- = pcMiscPrelId parErrorIdKey pREL_ERR SLIT("parError")
+ = pcMiscPrelId parErrorIdKey pREL_ERR FSLIT("parError")
(mkSigmaTy [openAlphaTyVar] [] openAlphaTy) noCafNoTyGenIdInfo
\end{code}
--- /dev/null
+__interface Module 1 0 where
+__export Module Module ;
+1 data Module ;
+
--- /dev/null
+__interface Module 1 0 where
+__export Module Module ;
+1 data Module ;
+
import Unique ( Uniquable(..) )
import UniqFM
import UniqSet
+import Binary
\end{code}
\begin{code}
data Module = Module ModuleName !PackageInfo
+instance Binary Module where
+ put_ bh (Module m p) = put_ bh m
+ get bh = do m <- get bh; return (Module m DunnoYet)
+
data PackageInfo
= ThisPackage -- A module from the same package
-- as the one being compiled
type PackageName = FastString -- No encoding at all
preludePackage :: PackageName
-preludePackage = SLIT("std")
+preludePackage = FSLIT("std")
packageInfoPackage :: PackageInfo -> PackageName
packageInfoPackage ThisPackage = opt_InPackage
-packageInfoPackage DunnoYet = SLIT("<?>")
-packageInfoPackage AnotherPackage = SLIT("<pkg>")
+packageInfoPackage DunnoYet = FSLIT("<?>")
+packageInfoPackage AnotherPackage = FSLIT("<pkg>")
instance Outputable PackageInfo where
-- Just used in debug prints of lex tokens and in debug modde
-- Haskell module names can include the quote character ',
-- so the module names have the z-encoding applied to them
+instance Binary ModuleName where
+ put_ bh (ModuleName m) = put_ bh m
+ get bh = do m <- get bh; return (ModuleName m)
+
instance Uniquable ModuleName where
getUnique (ModuleName nm) = getUnique nm
import OccName -- All of it
import Module ( Module, moduleName, mkVanillaModule, isHomeModule )
-import RdrName ( RdrName, mkRdrOrig, mkRdrUnqual, rdrNameOcc, rdrNameModule )
+import RdrName ( RdrName, mkRdrOrig, mkRdrUnqual, rdrNameOcc,
+ rdrNameModule, mkRdrQual )
import CmdLineOpts ( opt_Static )
import SrcLoc ( builtinSrcLoc, noSrcLoc, SrcLoc )
import Unique ( Unique, Uniquable(..), u2i, pprUnique )
import FastTypes
+import Binary
import Outputable
\end{code}
mkWiredInName :: Module -> OccName -> Unique -> Name
mkWiredInName mod occ uniq = mkGlobalName uniq mod occ builtinSrcLoc
-mkSysLocalName :: Unique -> UserFS -> Name
+mkSysLocalName :: Unique -> EncodedFS -> Name
mkSysLocalName uniq fs = Name { n_uniq = uniq, n_sort = System,
n_occ = mkVarOcc fs, n_loc = noSrcLoc }
getName n = n
\end{code}
+%************************************************************************
+%* *
+\subsection{Binary output}
+%* *
+%************************************************************************
+
+\begin{code}
+instance Binary Name where
+ -- we must print these as RdrNames, because that's how they will be read in
+ put_ bh Name {n_sort = sort, n_uniq = uniq, n_occ = occ} =
+ case sort of
+ Global mod
+ | this_mod == mod -> put_ bh (mkRdrUnqual occ)
+ | otherwise -> put_ bh (mkRdrOrig (moduleName mod) occ)
+ where (this_mod,_,_,_) = getUserData bh
+ _ -> do
+ put_ bh (mkRdrUnqual occ)
+
+ get bh = error "can't Binary.get a Name"
+\end{code}
%************************************************************************
%* *
+{-% DrIFT (Automatic class derivations for Haskell) v1.1 %-}
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
OccName, -- Abstract, instance of Outputable
pprOccName,
- mkOccFS, mkSysOcc, mkSysOccFS, mkFCallOcc, mkVarOcc, mkKindOccFS,
+ mkOccFS, mkSysOcc, mkSysOccFS, mkFCallOcc, mkKindOccFS,
+ mkVarOcc, mkVarOccEncoded,
mkSuperDictSelOcc, mkDFunOcc, mkForeignExportOcc,
mkDictOcc, mkIPOcc, mkWorkerOcc, mkMethodOcc, mkDefaultMethodOcc,
mkDerivedTyConOcc, mkClassTyConOcc, mkClassDataConOcc, mkSpecOcc,
import Unique ( Unique )
import FiniteMap ( FiniteMap, emptyFM, lookupFM, addToFM, elemFM )
import Outputable
+import Binary
+
import GlaExts
\end{code}
| TcClsName -- Type constructors and classes; Haskell has them
-- in the same name space for now.
deriving( Eq, Ord )
+ {-! derive: Binary !-}
-- Though type constructors and classes are in the same name space now,
-- the NameSpace type is abstract, so we can easily separate them later
data OccName = OccName
NameSpace
EncodedFS
+ {-! derive : Binary !-}
\end{code}
mkVarOcc :: UserFS -> OccName
mkVarOcc fs = mkSysOccFS varName (encodeFS fs)
+
+mkVarOccEncoded :: EncodedFS -> OccName
+mkVarOccEncoded fs = mkSysOccFS varName fs
\end{code}
-------------
isLexConId cs -- Prefix type or data constructors
- | _NULL_ cs = False -- e.g. "Foo", "[]", "(,)"
- | cs == SLIT("[]") = True
- | otherwise = startsConId (_HEAD_ cs)
+ | _NULL_ cs = False -- e.g. "Foo", "[]", "(,)"
+ | cs == FSLIT("[]") = True
+ | otherwise = startsConId (_HEAD_ cs)
isLexVarId cs -- Ordinary prefix identifiers
| _NULL_ cs = False -- e.g. "x", "_x"
isLexConSym cs -- Infix type or data constructors
| _NULL_ cs = False -- e.g. ":-:", ":", "->"
- | cs == SLIT("->") = True
+ | cs == FSLIT("->") = True
| otherwise = startsConSym (_HEAD_ cs)
isLexVarSym cs -- Infix identifiers
isLowerISO (C# c#) = c# `geChar#` '\xdf'# && c# `leChar#` '\xff'# && c# `neChar#` '\xf7'#
--0xdf <= oc && oc <= 0xff && oc /= 0xf7 where oc = ord c
\end{code}
+\begin{code}
+{-* Generated by DrIFT-v1.0 : Look, but Don't Touch. *-}
+instance Binary NameSpace where
+ put_ bh VarName = do
+ putByte bh 0
+ put_ bh DataName = do
+ putByte bh 1
+ put_ bh TvName = do
+ putByte bh 2
+ put_ bh TcClsName = do
+ putByte bh 3
+ get bh = do
+ h <- getByte bh
+ case h of
+ 0 -> do return VarName
+ 1 -> do return DataName
+ 2 -> do return TvName
+ _ -> do return TcClsName
+
+instance Binary OccName where
+ put_ bh (OccName aa ab) = do
+ put_ bh aa
+ put_ bh ab
+ get bh = do
+ aa <- get bh
+ ab <- get bh
+ return (OccName aa ab)
+
+-- Imported from other files :-
+
+\end{code}
+{-% DrIFT (Automatic class derivations for Haskell) v1.1 %-}
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
)
import FiniteMap
import Outputable
+import Binary
import Util ( thenCmp )
\end{code}
\begin{code}
data RdrName = RdrName Qual OccName
+ {-! derive: Binary !-}
-data Qual = Unqual
+data Qual
+ = Unqual
- | Qual ModuleName -- A qualified name written by the user in source code
- -- The module isn't necessarily the module where
- -- the thing is defined; just the one from which it
- -- is imported
+ | Qual ModuleName -- A qualified name written by the user in source code
+ -- The module isn't necessarily the module where
+ -- the thing is defined; just the one from which it
+ -- is imported
+
+ | Orig ModuleName -- This is an *original* name; the module is the place
+ -- where the thing was defined
+ {-! derive: Binary !-}
- | Orig ModuleName -- This is an *original* name; the module is the place
- -- where the thing was defined
\end{code}
-- the renamer. We can't just put "error..." because
-- we sometimes want to print out stuff after reading but
-- before renaming
-dummyRdrVarName = RdrName Unqual (mkVarOcc SLIT("V-DUMMY"))
-dummyRdrTcName = RdrName Unqual (mkOccFS tcName SLIT("TC-DUMMY"))
+dummyRdrVarName = RdrName Unqual (mkVarOcc FSLIT("V-DUMMY"))
+dummyRdrTcName = RdrName Unqual (mkOccFS tcName FSLIT("TC-DUMMY"))
\end{code}
elemRdrEnv = elemFM
foldRdrEnv = foldFM
\end{code}
+\begin{code}
+{-* Generated by DrIFT-v1.0 : Look, but Don't Touch. *-}
+instance Binary RdrName where
+ put_ bh (RdrName aa ab) = do
+ put_ bh aa
+ put_ bh ab
+ get bh = do
+ aa <- get bh
+ ab <- get bh
+ return (RdrName aa ab)
+
+instance Binary Qual where
+ put_ bh Unqual = do
+ putByte bh 0
+ put_ bh (Qual aa) = do
+ putByte bh 1
+ put_ bh aa
+ put_ bh (Orig ab) = do
+ putByte bh 2
+ put_ bh ab
+ get bh = do
+ h <- getByte bh
+ case h of
+ 0 -> do return Unqual
+ 1 -> do aa <- get bh
+ return (Qual aa)
+ _ -> do ab <- get bh
+ return (Orig ab)
+
+-- Imported from other files :-
+
+\end{code}
, varInfo = pprPanic "mkSysTyVar" (ppr name)
}
where
- name = mkSysLocalName uniq SLIT("t")
+ name = mkSysLocalName uniq FSLIT("t")
newMutTyVar :: Name -> Kind -> TyVarDetails -> IO TyVar
newMutTyVar name kind details
newVar ty
= seqType ty `seq`
getUniqueUs `thenUs` \ uniq ->
- returnUs (mkSysLocal SLIT("sat") uniq ty)
+ returnUs (mkSysLocal FSLIT("sat") uniq ty)
\end{code}
case splitFunTy_maybe ty of {
Just (arg_ty, res_ty) -> Lam arg1 (eta_expand (n-1) us2 (App expr (Var arg1)) res_ty)
where
- arg1 = mkSysLocal SLIT("eta") uniq arg_ty
+ arg1 = mkSysLocal FSLIT("eta") uniq arg_ty
(uniq:us2) = us
; Nothing ->
mkForeignExportOcc, isLocalName,
NamedThing(..),
)
+import OccName ( encodeFS )
import Type ( repType, eqType )
import TcType ( Type, mkFunTys, mkForAllTys, mkTyConApp,
mkFunTy, applyTy,
worker_ty = mkForAllTys tvs (mkFunTys (map idType work_arg_ids) ccall_result_ty)
the_ccall_app = mkFCall ccall_uniq fcall val_args ccall_result_ty
work_rhs = mkLams tvs (mkLams work_arg_ids the_ccall_app)
- work_id = mkSysLocal SLIT("$wccall") work_uniq worker_ty
+ work_id = mkSysLocal (encodeFS SLIT("$wccall")) work_uniq worker_ty
-- Build the wrapper
work_app = mkApps (mkVarApps (Var work_id) tvs) val_args
newSysLocalDs, newFailLocalDs :: Type -> DsM Id
newSysLocalDs ty dflags us genv loc mod warns
= case uniqFromSupply us of { assigned_uniq ->
- (mkSysLocal SLIT("ds") assigned_uniq ty, warns) }
+ (mkSysLocal FSLIT("ds") assigned_uniq ty, warns) }
newSysLocalsDs tys = mapDs newSysLocalDs tys
newFailLocalDs ty dflags us genv loc mod warns
= case uniqFromSupply us of { assigned_uniq ->
- (mkSysLocal SLIT("fail") assigned_uniq ty, warns) }
+ (mkSysLocal FSLIT("fail") assigned_uniq ty, warns) }
-- The UserLocal bit just helps make the code a little clearer
getUniqueDs :: DsM Unique
-- create a totally bogus name for the top-level BCO; this
-- should be harmless, since it's never used for anything
- let invented_id = mkSysLocal SLIT("Expr-Top-Level") (mkPseudoUnique3 0)
- (panic "invented_id's type")
+ let invented_id = mkSysLocal FSLIT("Expr-Top-Level")
+ (mkPseudoUnique3 0)
+ (panic "invented_id's type")
let invented_name = idName invented_id
annexpr = freeVars expr
)
-- Case 2
- | let isVoidRepAtom (_, AnnVar v) = VoidRep == typePrimRep (idType v)
+ | [arg1,arg2] <- args_r_to_l,
+ let isVoidRepAtom (_, AnnVar v) = VoidRep == typePrimRep (idType v)
isVoidRepAtom (_, AnnNote n e) = isVoidRepAtom e
- in is_con_call && isUnboxedTupleCon con
- && ( (args_r_to_l `lengthIs` 2 && isVoidRepAtom (last (args_r_to_l)))
- || (isSingleton args_r_to_l)
- )
+ in isVoidRepAtom arg2
= --trace (if isSingleton args_r_to_l
-- then "schemeT: unboxed singleton"
-- else "schemeT: unboxed pair with Void first component") (
- schemeT d s p (head args_r_to_l)
+ schemeT d s p arg1
--)
-- Case 3
import Constants -- Default values for some flags
import Util
import FastTypes
+import FastString ( FastString, mkFastString )
import Config
import Maybes ( firstJust )
-- main/DriverState.
GLOBAL_VAR(v_Static_hsc_opts, [], [String])
-lookUp :: FAST_STRING -> Bool
+lookUp :: FastString -> Bool
lookup_int :: String -> Maybe Int
lookup_def_int :: String -> Int -> Int
lookup_def_float :: String -> Float -> Float
lookup_str :: String -> Maybe String
unpacked_static_opts = unsafePerformIO (readIORef v_Static_hsc_opts)
-packed_static_opts = map _PK_ unpacked_static_opts
+packed_static_opts = map mkFastString unpacked_static_opts
lookUp sw = sw `elem` packed_static_opts
\begin{code}
-- debugging opts
-opt_PprStyle_NoPrags = lookUp SLIT("-dppr-noprags")
-opt_PprStyle_Debug = lookUp SLIT("-dppr-debug")
-opt_PprStyle_RawTypes = lookUp SLIT("-dppr-rawtypes")
+opt_PprStyle_NoPrags = lookUp FSLIT("-dppr-noprags")
+opt_PprStyle_Debug = lookUp FSLIT("-dppr-debug")
+opt_PprStyle_RawTypes = lookUp FSLIT("-dppr-rawtypes")
opt_PprUserLength = lookup_def_int "-dppr-user-length" 5 --ToDo: give this a name
-- profiling opts
-opt_AutoSccsOnAllToplevs = lookUp SLIT("-fauto-sccs-on-all-toplevs")
-opt_AutoSccsOnExportedToplevs = lookUp SLIT("-fauto-sccs-on-exported-toplevs")
-opt_AutoSccsOnIndividualCafs = lookUp SLIT("-fauto-sccs-on-individual-cafs")
-opt_AutoSccsOnDicts = lookUp SLIT("-fauto-sccs-on-dicts")
-opt_SccProfilingOn = lookUp SLIT("-fscc-profiling")
-opt_DoTickyProfiling = lookUp SLIT("-fticky-ticky")
+opt_AutoSccsOnAllToplevs = lookUp FSLIT("-fauto-sccs-on-all-toplevs")
+opt_AutoSccsOnExportedToplevs = lookUp FSLIT("-fauto-sccs-on-exported-toplevs")
+opt_AutoSccsOnIndividualCafs = lookUp FSLIT("-fauto-sccs-on-individual-cafs")
+opt_AutoSccsOnDicts = lookUp FSLIT("-fauto-sccs-on-dicts")
+opt_SccProfilingOn = lookUp FSLIT("-fscc-profiling")
+opt_DoTickyProfiling = lookUp FSLIT("-fticky-ticky")
-- language opts
-opt_AllStrict = lookUp SLIT("-fall-strict")
-opt_DictsStrict = lookUp SLIT("-fdicts-strict")
-opt_IrrefutableTuples = lookUp SLIT("-firrefutable-tuples")
+opt_AllStrict = lookUp FSLIT("-fall-strict")
+opt_DictsStrict = lookUp FSLIT("-fdicts-strict")
+opt_IrrefutableTuples = lookUp FSLIT("-firrefutable-tuples")
opt_MaxContextReductionDepth = lookup_def_int "-fcontext-stack" mAX_CONTEXT_REDUCTION_DEPTH
-opt_NumbersStrict = lookUp SLIT("-fnumbers-strict")
-opt_Parallel = lookUp SLIT("-fparallel")
-opt_SMP = lookUp SLIT("-fsmp")
-opt_Flatten = lookUp SLIT("-fflatten")
+opt_NumbersStrict = lookUp FSLIT("-fnumbers-strict")
+opt_Parallel = lookUp FSLIT("-fparallel")
+opt_SMP = lookUp FSLIT("-fsmp")
+opt_Flatten = lookUp FSLIT("-fflatten")
-- optimisation opts
-opt_NoMethodSharing = lookUp SLIT("-fno-method-sharing")
-opt_DoSemiTagging = lookUp SLIT("-fsemi-tagging")
-opt_FoldrBuildOn = lookUp SLIT("-ffoldr-build-on")
+opt_NoMethodSharing = lookUp FSLIT("-fno-method-sharing")
+opt_DoSemiTagging = lookUp FSLIT("-fsemi-tagging")
+opt_FoldrBuildOn = lookUp FSLIT("-ffoldr-build-on")
opt_LiberateCaseThreshold = lookup_def_int "-fliberate-case-threshold" (10::Int)
-opt_StgDoLetNoEscapes = lookUp SLIT("-flet-no-escape")
-opt_UnfoldCasms = lookUp SLIT("-funfold-casms-in-hi-file")
-opt_UsageSPOn = lookUp SLIT("-fusagesp-on")
-opt_UnboxStrictFields = lookUp SLIT("-funbox-strict-fields")
+opt_StgDoLetNoEscapes = lookUp FSLIT("-flet-no-escape")
+opt_UnfoldCasms = lookUp FSLIT("-funfold-casms-in-hi-file")
+opt_UsageSPOn = lookUp FSLIT("-fusagesp-on")
+opt_UnboxStrictFields = lookUp FSLIT("-funbox-strict-fields")
opt_MaxWorkerArgs = lookup_def_int "-fmax-worker-args" (10::Int)
{-
-}
opt_InPackage = case lookup_str "-inpackage=" of
Just p -> _PK_ p
- Nothing -> SLIT("Main") -- The package name if none is specified
+ Nothing -> FSLIT("Main") -- The package name if none is specified
-opt_EmitCExternDecls = lookUp SLIT("-femit-extern-decls")
-opt_EnsureSplittableC = lookUp SLIT("-fglobalise-toplev-names")
-opt_GranMacros = lookUp SLIT("-fgransim")
+opt_EmitCExternDecls = lookUp FSLIT("-femit-extern-decls")
+opt_EnsureSplittableC = lookUp FSLIT("-fglobalise-toplev-names")
+opt_GranMacros = lookUp FSLIT("-fgransim")
opt_HiVersion = read (cProjectVersionInt ++ cProjectPatchLevel) :: Int
opt_HistorySize = lookup_def_int "-fhistory-size" 20
-opt_IgnoreAsserts = lookUp SLIT("-fignore-asserts")
-opt_IgnoreIfacePragmas = lookUp SLIT("-fignore-interface-pragmas")
-opt_NoHiCheck = lookUp SLIT("-fno-hi-version-check")
-opt_OmitBlackHoling = lookUp SLIT("-dno-black-holing")
-opt_OmitInterfacePragmas = lookUp SLIT("-fomit-interface-pragmas")
-opt_RuntimeTypes = lookUp SLIT("-fruntime-types")
+opt_IgnoreAsserts = lookUp FSLIT("-fignore-asserts")
+opt_IgnoreIfacePragmas = lookUp FSLIT("-fignore-interface-pragmas")
+opt_NoHiCheck = lookUp FSLIT("-fno-hi-version-check")
+opt_OmitBlackHoling = lookUp FSLIT("-dno-black-holing")
+opt_OmitInterfacePragmas = lookUp FSLIT("-fomit-interface-pragmas")
+opt_RuntimeTypes = lookUp FSLIT("-fruntime-types")
-- Simplifier switches
-opt_SimplNoPreInlining = lookUp SLIT("-fno-pre-inlining")
+opt_SimplNoPreInlining = lookUp FSLIT("-fno-pre-inlining")
-- NoPreInlining is there just to see how bad things
-- get if you don't do it!
-opt_SimplDoEtaReduction = lookUp SLIT("-fdo-eta-reduction")
-opt_SimplDoLambdaEtaExpansion = lookUp SLIT("-fdo-lambda-eta-expansion")
-opt_SimplCaseMerge = lookUp SLIT("-fcase-merge")
-opt_SimplExcessPrecision = lookUp SLIT("-fexcess-precision")
+opt_SimplDoEtaReduction = lookUp FSLIT("-fdo-eta-reduction")
+opt_SimplDoLambdaEtaExpansion = lookUp FSLIT("-fdo-lambda-eta-expansion")
+opt_SimplCaseMerge = lookUp FSLIT("-fcase-merge")
+opt_SimplExcessPrecision = lookUp FSLIT("-fexcess-precision")
-- Unfolding control
opt_UF_CreationThreshold = lookup_def_int "-funfolding-creation-threshold" (45::Int)
opt_UF_UseThreshold = lookup_def_int "-funfolding-use-threshold" (8::Int) -- Discounts can be big
opt_UF_FunAppDiscount = lookup_def_int "-funfolding-fun-discount" (6::Int) -- It's great to inline a fn
opt_UF_KeenessFactor = lookup_def_float "-funfolding-keeness-factor" (1.5::Float)
-opt_UF_UpdateInPlace = lookUp SLIT("-funfolding-update-in-place")
+opt_UF_UpdateInPlace = lookUp FSLIT("-funfolding-update-in-place")
opt_UF_CheapOp = ( 1 :: Int) -- Only one instruction; and the args are charged for
opt_UF_DearOp = ( 4 :: Int)
-opt_NoPruneDecls = lookUp SLIT("-fno-prune-decls")
-opt_NoPruneTyDecls = lookUp SLIT("-fno-prune-tydecls")
-opt_Static = lookUp SLIT("-static")
-opt_Unregisterised = lookUp SLIT("-funregisterised")
-opt_EmitExternalCore = lookUp SLIT("-fext-core")
+opt_NoPruneDecls = lookUp FSLIT("-fno-prune-decls")
+opt_NoPruneTyDecls = lookUp FSLIT("-fno-prune-tydecls")
+opt_Static = lookUp FSLIT("-static")
+opt_Unregisterised = lookUp FSLIT("-funregisterised")
+opt_EmitExternalCore = lookUp FSLIT("-fext-core")
\end{code}
%************************************************************************
"fno-hi-version-check",
"dno-black-holing",
"fno-method-sharing",
- "fno-monomorphism-restriction",
"fomit-interface-pragmas",
"fruntime-types",
"fno-pre-inlining",
{-# OPTIONS -#include "hschooks.h" #-}
-----------------------------------------------------------------------------
--- $Id: DriverFlags.hs,v 1.86 2002/02/11 08:20:41 chak Exp $
+-- $Id: DriverFlags.hs,v 1.87 2002/03/04 17:01:30 simonmar Exp $
--
-- Driver flags
--
#include "HsVersions.h"
#include "../includes/config.h"
+import BinIface ( compileIface )
+import MkIface ( showIface )
import DriverState
import DriverPhases
import DriverUtil
, ( "-numeric-version", NoArg (do putStrLn cProjectVersion
exitWith ExitSuccess))
+ ------- interfaces ----------------------------------------------------
+ , ( "-show-iface" , HasArg (\f -> do showIface f
+ exitWith ExitSuccess))
+ , ( "-compile-iface" , HasArg (\f -> do compileIface f
+ exitWith ExitSuccess))
+
------- verbosity ----------------------------------------------------
, ( "n" , NoArg setDryRun )
, ( "syslib" , HasArg (addPackage) ) -- for compatibility w/ old vsns
------- Specific phases --------------------------------------------
- , ( "pgm" , HasArg setPgm )
+ , ( "pgmP" , HasArg setPgmP )
+ , ( "pgmF" , HasArg setPgmF )
+ , ( "pgmc" , HasArg setPgmc )
+ , ( "pgmm" , HasArg setPgmm )
+ , ( "pgms" , HasArg setPgms )
+ , ( "pgma" , HasArg setPgma )
+ , ( "pgml" , HasArg setPgml )
+#ifdef ILX
+ , ( "pgmI" , HasArg setPgmI )
+ , ( "pgmi" , HasArg setPgmi )
+#endif
, ( "optdep" , HasArg (add v_Opt_dep) )
, ( "optl" , HasArg (add v_Opt_l) )
-----------------------------------------------------------------------------
--- $Id: DriverPhases.hs,v 1.15 2002/01/04 16:02:04 simonmar Exp $
+-- $Id: DriverPhases.hs,v 1.16 2002/03/04 17:01:30 simonmar Exp $
--
-- GHC Driver
--
haskellish_file, haskellish_suffix,
haskellish_src_file, haskellish_src_suffix,
+ hsbootish_file, hsbootish_suffix,
objish_file, objish_suffix,
cish_file, cish_suffix
) where
| Cpp
| HsPp
| Hsc
+ | HsBoot
| Cc
| HCc -- Haskellised C (as opposed to vanilla C) compilation
| Mangle -- assembly mangling, now done by a separate script.
startPhase "hs" = Cpp
startPhase "hscpp" = HsPp
startPhase "hspp" = Hsc
+startPhase "hs-boot" = HsBoot
startPhase "hc" = HCc
startPhase "c" = Cc
startPhase "cpp" = Cc
phaseInputExt SplitAs = "split_s" -- not really generated
phaseInputExt Ln = "o"
phaseInputExt MkDependHS = "dep"
+phaseInputExt HsBoot = "hs-boot"
#ifdef ILX
phaseInputExt Ilx2Il = "ilx"
phaseInputExt Ilasm = "il"
haskellish_suffix = (`elem` [ "hs", "hspp", "hscpp", "lhs", "hc", "raw_s" ])
haskellish_src_suffix = (`elem` [ "hs", "hspp", "hscpp", "lhs" ])
cish_suffix = (`elem` [ "c", "cpp", "C", "cc", "cxx", "s", "S" ])
+hsbootish_suffix = (`elem` [ "hs-boot" ])
#if mingw32_TARGET_OS || cygwin32_TARGET_OS
objish_suffix = (`elem` [ "o", "O", "obj", "OBJ" ])
haskellish_src_file = haskellish_src_suffix . getFileSuffix
cish_file = cish_suffix . getFileSuffix
objish_file = objish_suffix . getFileSuffix
+hsbootish_file = hsbootish_suffix . getFileSuffix
IfaceDecls, mkIfaceDecls, dcl_tycl, dcl_rules, dcl_insts,
VersionInfo(..), initialVersionInfo, lookupVersion,
- FixityEnv, lookupFixity,
+ FixityEnv, lookupFixity, collectFixities,
TyThing(..), isTyClThing, implicitTyThingIds,
NameSupply(..), OrigNameCache, OrigIParamCache,
Avails, AvailEnv, emptyAvailEnv,
GenAvailInfo(..), AvailInfo, RdrAvailInfo,
+ ExportItem, RdrExportItem,
PersistentCompilerState(..),
Deprecations(..), lookupDeprec,
import BasicTypes ( Version, initialVersion, Fixity, defaultFixity, IPName )
-import HsSyn ( DeprecTxt, tyClDeclName, ifaceRuleDeclName )
+import HsSyn ( DeprecTxt, TyClDecl, tyClDeclName, ifaceRuleDeclName,
+ tyClDeclNames )
import RdrHsSyn ( RdrNameInstDecl, RdrNameRuleDecl, RdrNameTyClDecl )
import RnHsSyn ( RenamedTyClDecl, RenamedRuleDecl, RenamedInstDecl )
import CoreSyn ( IdCoreRule )
-import FiniteMap ( FiniteMap )
+import FiniteMap
import Bag ( Bag )
import Maybes ( seqMaybe, orElse )
import Outputable
-- whether to write a new iface file (changing usages
-- doesn't affect the version of this module)
- mi_exports :: ![(ModuleName,Avails)],
+ mi_exports :: ![ExportItem],
-- What it exports Kept sorted by (mod,occ), to make
-- version comparisons easier
deriving( Eq )
-- Equality used when deciding if the interface has changed
+type RdrExportItem = (ModuleName, [RdrAvailInfo])
+type ExportItem = (ModuleName, [AvailInfo])
+
type AvailEnv = NameEnv AvailInfo -- Maps a Name to the AvailInfo that contains it
emptyAvailEnv :: AvailEnv
emptyAvailEnv = emptyNameEnv
-
+
instance Outputable n => Outputable (GenAvailInfo n) where
ppr = pprAvail
lookupFixity :: FixityEnv -> Name -> Fixity
lookupFixity env n = lookupNameEnv env n `orElse` defaultFixity
+
+collectFixities :: FixityEnv -> [TyClDecl Name pat] -> [(Name,Fixity)]
+collectFixities env decls
+ = [ (n, fix)
+ | d <- decls, (n,_) <- tyClDeclNames d,
+ Just fix <- [lookupNameEnv env n]
+ ]
\end{code}
{-# OPTIONS -fno-warn-incomplete-patterns -optc-DNON_POSIX_SOURCE #-}
-----------------------------------------------------------------------------
--- $Id: Main.hs,v 1.95 2002/03/04 14:40:54 simonmar Exp $
+-- $Id: Main.hs,v 1.96 2002/03/04 17:01:30 simonmar Exp $
--
-- GHC Driver program
--
case exception of
-- an IO exception probably isn't our fault, so don't panic
IOException _ -> hPutStr stderr (show exception)
- _other -> hPutStr stderr (show (Panic (show exception)))
+ AsyncException StackOverflow ->
+ hPutStrLn stderr "stack overflow: use +RTS -K<size> \
+ \to increase it"
+ _other -> hPutStr stderr (show (Panic (show exception)))
exitWith (ExitFailure 1)
) $ do
\begin{code}
module MkIface (
- mkFinalIface,
- pprModDetails, pprIface, pprUsage,
+ showIface, mkFinalIface,
+ pprModDetails, pprIface, pprUsage, pprUsages, pprExports,
ifaceTyThing,
) where
import RnMonad
import RnHsSyn ( RenamedInstDecl, RenamedTyClDecl )
import HscTypes ( VersionInfo(..), ModIface(..), ModDetails(..),
- ModuleLocation(..), GhciMode(..), FixityEnv, lookupFixity,
+ ModuleLocation(..), GhciMode(..),
+ FixityEnv, lookupFixity, collectFixities,
IfaceDecls, mkIfaceDecls, dcl_tycl, dcl_rules, dcl_insts,
- TyThing(..), DFunId, Avails, TypeEnv,
+ TyThing(..), DFunId, TypeEnv,
+ GenAvailInfo,
WhatsImported(..), GenAvailInfo(..),
ImportVersion, AvailInfo, Deprecations(..),
lookupVersion, typeEnvIds
import Outputable
import Module ( ModuleName )
import Util ( sortLt, dropList )
+import Binary ( getBinFileWithDict )
+import BinIface ( writeBinIface )
import ErrUtils ( dumpIfSet_dyn )
import Monad ( when )
import Maybe ( catMaybes )
-import IO ( IOMode(..), openFile, hClose )
+import IO ( IOMode(..), openFile, hClose, putStrLn )
\end{code}
%************************************************************************
%* *
+\subsection{Print out the contents of a binary interface}
+%* *
+%************************************************************************
+
+\begin{code}
+showIface :: FilePath -> IO ()
+showIface filename = do
+ parsed_iface <- Binary.getBinFileWithDict filename
+ let ParsedIface{
+ pi_mod=pi_mod, pi_pkg=pi_pkg, pi_vers=pi_vers,
+ pi_orphan=pi_orphan, pi_usages=pi_usages,
+ pi_exports=pi_exports, pi_decls=pi_decls,
+ pi_fixity=pi_fixity, pi_insts=pi_insts,
+ pi_rules=pi_rules, pi_deprecs=pi_deprecs } = parsed_iface
+ putStrLn (showSDoc (vcat [
+ text "__interface" <+> doubleQuotes (ppr pi_pkg)
+ <+> ppr pi_mod <+> ppr pi_vers
+ <+> (if pi_orphan then char '!' else empty)
+ <+> ptext SLIT("where"),
+ -- no instance Outputable (WhatsImported):
+ pprExports id (snd pi_exports),
+ pprUsages id pi_usages,
+ hsep (map ppr_fix pi_fixity) <> semi,
+ vcat (map ppr_inst pi_insts),
+ vcat (map ppr_decl pi_decls),
+ ppr pi_rules
+ -- no instance Outputable (Either):
+ -- ppr pi_deprecs
+ ]))
+ where
+ ppr_fix (n,f) = ppr f <+> ppr n
+ ppr_inst i = ppr i <+> semi
+ ppr_decl (v,d) = int v <+> ppr d <> semi
+\end{code}
+
+%************************************************************************
+%* *
\subsection{Completing an interface}
%* *
%************************************************************************
-- Write the interface file, if necessary
; when (must_write_hi_file maybe_diffs)
- (writeIface hi_file_path final_iface)
+ (writeBinIface hi_file_path final_iface)
+-- (writeIface hi_file_path final_iface)
-- Debug printing
; write_diffs dflags final_iface maybe_diffs
-- Print names unqualified if they are from this module
from_this_mod n = nameModule n == this_mod
this_mod = mi_module mod_iface
-
+
pprIface :: ModIface -> SDoc
pprIface iface
= vcat [ ptext SLIT("__interface")
<+> int opt_HiVersion
<+> ptext SLIT("where")
- , vcat (map pprExport (mi_exports iface))
- , vcat (map pprUsage (mi_usages iface))
+ , pprExports nameOccName (mi_exports iface)
+ , pprUsages nameOccName (mi_usages iface)
, pprFixities (mi_fixities iface) (dcl_tycl decls)
, pprIfaceDecls (vers_decls version_info) decls
version_info = mi_version iface
decls = mi_decls iface
exp_vers = vers_exports version_info
+
rule_vers = vers_rules version_info
pp_sub_vers | exp_vers == initialVersion && rule_vers == initialVersion = empty
AvailTC C [x, y] C!(x,y) -- Exporting x, y but not C
\begin{code}
-pprExport :: (ModuleName, Avails) -> SDoc
-pprExport (mod, items)
+pprExports :: Eq a => (a -> OccName) -> [(ModuleName, [GenAvailInfo a])] -> SDoc
+pprExports getOcc exports = vcat (map (pprExport getOcc) exports)
+
+pprExport :: Eq a => (a -> OccName) -> (ModuleName, [GenAvailInfo a]) -> SDoc
+pprExport getOcc (mod, items)
= hsep [ ptext SLIT("__export "), ppr mod, hsep (map pp_avail items) ] <> semi
where
- pp_avail :: AvailInfo -> SDoc
- pp_avail (Avail name) = pprOcc name
+ --pp_avail :: GenAvailInfo a -> SDoc
+ pp_avail (Avail name) = ppr (getOcc name)
pp_avail (AvailTC _ []) = empty
- pp_avail (AvailTC n (n':ns)) | n==n' = pprOcc n <> pp_export ns
- | otherwise = pprOcc n <> char '|' <> pp_export (n':ns)
+ pp_avail (AvailTC n (n':ns))
+ | n==n' = ppr (getOcc n) <> pp_export ns
+ | otherwise = ppr (getOcc n) <> char '|' <> pp_export (n':ns)
pp_export [] = empty
- pp_export names = braces (hsep (map pprOcc names))
+ pp_export names = braces (hsep (map (ppr.getOcc) names))
pprOcc :: Name -> SDoc -- Print the occurrence name only
pprOcc n = pprOccName (nameOccName n)
\begin{code}
-pprUsage :: ImportVersion Name -> SDoc
-pprUsage (m, has_orphans, is_boot, whats_imported)
+pprUsages :: (a -> OccName) -> [ImportVersion a] -> SDoc
+pprUsages getOcc usages = vcat (map (pprUsage getOcc) usages)
+
+pprUsage :: (a -> OccName) -> ImportVersion a -> SDoc
+pprUsage getOcc (m, has_orphans, is_boot, whats_imported)
= hsep [ptext SLIT("import"), ppr m,
pp_orphan, pp_boot,
pp_versions whats_imported
-- Importing the whole module is indicated by an empty list
pp_versions NothingAtAll = empty
pp_versions (Everything v) = dcolon <+> int v
- pp_versions (Specifically vm ve nvs vr) = dcolon <+> int vm <+> pp_export_version ve <+> int vr
- <+> hsep [ pprOcc n <+> int v | (n,v) <- nvs ]
+ pp_versions (Specifically vm ve nvs vr) =
+ dcolon <+> int vm <+> pp_export_version ve <+> int vr
+ <+> hsep [ ppr (getOcc n) <+> int v | (n,v) <- nvs ]
pp_export_version Nothing = empty
pp_export_version (Just v) = int v
\end{code}
\begin{code}
-pprFixities :: (Outputable a)
- => NameEnv a
+pprFixities :: NameEnv Fixity
-> [TyClDecl Name pat]
-> SDoc
pprFixities fixity_map decls
= hsep [ ppr fix <+> ppr n
- | d <- decls,
- (n,_) <- tyClDeclNames d,
- Just fix <- [lookupNameEnv fixity_map n]] <> semi
+ | (n,fix) <- collectFixities fixity_map decls ] <> semi
-- Disgusting to print these two together, but that's
-- the way the interface parser currently expects them.
module SysTools (
-- Initialisation
initSysTools,
- setPgm, -- String -> IO ()
+
+ setPgmP, -- String -> IO ()
+ setPgmF,
+ setPgmc,
+ setPgmm,
+ setPgms,
+ setPgma,
+ setPgml,
+#ifdef ILX
+ setPgmI,
+ setPgmi,
+#endif
-- Command-line override
setDryRun,
#endif
\end{code}
-setPgm is called when a command-line option like
+The various setPgm functions are called when a command-line option
+like
+
-pgmLld
+
is used to override a particular program with a new one
\begin{code}
-setPgm :: String -> IO ()
--- The string is the flag, minus the '-pgm' prefix
--- So the first character says which program to override
-
-setPgm ('P' : pgm) = writeIORef v_Pgm_P pgm
-setPgm ('F' : pgm) = writeIORef v_Pgm_F pgm
-setPgm ('c' : pgm) = writeIORef v_Pgm_c pgm
-setPgm ('m' : pgm) = writeIORef v_Pgm_m pgm
-setPgm ('s' : pgm) = writeIORef v_Pgm_s pgm
-setPgm ('a' : pgm) = writeIORef v_Pgm_a pgm
-setPgm ('l' : pgm) = writeIORef v_Pgm_l pgm
+setPgmP = writeIORef v_Pgm_P
+setPgmF = writeIORef v_Pgm_F
+setPgmc = writeIORef v_Pgm_c
+setPgmm = writeIORef v_Pgm_m
+setPgms = writeIORef v_Pgm_s
+setPgma = writeIORef v_Pgm_a
+setPgml = writeIORef v_Pgm_l
#ifdef ILX
-setPgm ('I' : pgm) = writeIORef v_Pgm_I pgm
-setPgm ('i' : pgm) = writeIORef v_Pgm_i pgm
+setPgmI = writeIORef v_Pgm_I
+setPgmi = writeIORef v_Pgm_i
#endif
-setPgm pgm = unknownFlagErr ("-pgm" ++ pgm)
\end{code}
TyThing(..), lookupType)
import PrelNames (charPrimTyConName, intPrimTyConName, floatPrimTyConName,
doublePrimTyConName, fstName, andName, orName,
- eqCharName, eqIntName, eqFloatName, eqDoubleName,
- neqCharName, neqIntName, neqFloatName, neqDoubleName,
lengthPName, replicatePName, mapPName, bpermutePName,
bpermuteDftPName, indexOfPName)
+import PrimOp (eqCharName, eqIntName, eqFloatName, eqDoubleName,
+ neqIntName)
+ -- neqCharName, neqFloatName,neqDoubleName,
import CoreSyn (Expr(..), Bind(..), CoreBndr, CoreExpr, CoreBind, mkApps,
bindersOfBinds)
import CoreUtils (exprType)
where
name = tyConName . tyConAppTyCon $ ty
--
- neqName | name == charPrimTyConName = neqCharName
+ neqName {- | name == charPrimTyConName = neqCharName -}
| name == intPrimTyConName = neqIntName
- | name == floatPrimTyConName = neqFloatName
- | name == doublePrimTyConName = neqDoubleName
+ {- | name == floatPrimTyConName = neqFloatName -}
+ {- | name == doublePrimTyConName = neqDoubleName -}
| otherwise =
pprPanic "FlattenMonad.mk'neq: " (ppr ty)
| plus == plus_RDR
-> returnP (mkNPlusKPat n lit)
where
- plus_RDR = mkUnqual varName SLIT("+") -- Hack
+ plus_RDR = mkUnqual varName FSLIT("+") -- Hack
OpApp l op fix r -> checkPat l [] `thenP` \l ->
checkPat r [] `thenP` \r ->
-> P ForeignImport
parseCImport entity cconv safety v
-- FIXME: we should allow white space around `dynamic' and `wrapper' -=chak
- | entity == SLIT ("dynamic") =
+ | entity == FSLIT ("dynamic") =
returnP $ CImport cconv safety _NIL_ _NIL_ (CFunction DynamicTarget)
- | entity == SLIT ("wrapper") =
+ | entity == FSLIT ("wrapper") =
returnP $ CImport cconv safety _NIL_ _NIL_ CWrapper
| otherwise = parse0 (_UNPK_ entity)
where
{- -*-haskell-*-
-----------------------------------------------------------------------------
-$Id: Parser.y,v 1.91 2002/03/03 03:59:03 sof Exp $
+$Id: Parser.y,v 1.92 2002/03/04 17:01:31 simonmar Exp $
Haskell grammar.
varid :: { RdrName }
: varid_no_unsafe { $1 }
- | 'unsafe' { mkUnqual varName SLIT("unsafe") }
- | 'safe' { mkUnqual varName SLIT("safe") }
- | 'threadsafe' { mkUnqual varName SLIT("threadsafe") }
+ | 'unsafe' { mkUnqual varName FSLIT("unsafe") }
+ | 'safe' { mkUnqual varName FSLIT("safe") }
+ | 'threadsafe' { mkUnqual varName FSLIT("threadsafe") }
varid_no_unsafe :: { RdrName }
: VARID { mkUnqual varName $1 }
| special_id { mkUnqual varName $1 }
- | 'forall' { mkUnqual varName SLIT("forall") }
+ | 'forall' { mkUnqual varName FSLIT("forall") }
tyvar :: { RdrName }
: VARID { mkUnqual tvName $1 }
| special_id { mkUnqual tvName $1 }
- | 'unsafe' { mkUnqual tvName SLIT("unsafe") }
- | 'safe' { mkUnqual tvName SLIT("safe") }
- | 'threadsafe' { mkUnqual tvName SLIT("threadsafe") }
+ | 'unsafe' { mkUnqual tvName FSLIT("unsafe") }
+ | 'safe' { mkUnqual tvName FSLIT("safe") }
+ | 'threadsafe' { mkUnqual tvName FSLIT("threadsafe") }
-- These special_ids are treated as keywords in various places,
-- but as ordinary ids elsewhere. 'special_id' collects all these
-- except 'unsafe' and 'forall' whose treatment differs depending on context
special_id :: { UserFS }
special_id
- : 'as' { SLIT("as") }
- | 'qualified' { SLIT("qualified") }
- | 'hiding' { SLIT("hiding") }
- | 'export' { SLIT("export") }
- | 'label' { SLIT("label") }
- | 'dynamic' { SLIT("dynamic") }
- | 'stdcall' { SLIT("stdcall") }
- | 'ccall' { SLIT("ccall") }
+ : 'as' { FSLIT("as") }
+ | 'qualified' { FSLIT("qualified") }
+ | 'hiding' { FSLIT("hiding") }
+ | 'export' { FSLIT("export") }
+ | 'label' { FSLIT("label") }
+ | 'dynamic' { FSLIT("dynamic") }
+ | 'stdcall' { FSLIT("stdcall") }
+ | 'ccall' { FSLIT("ccall") }
-----------------------------------------------------------------------------
-- ConIds
varsym :: { RdrName }
: varsym_no_minus { $1 }
- | '-' { mkUnqual varName SLIT("-") }
+ | '-' { mkUnqual varName FSLIT("-") }
varsym_no_minus :: { RdrName } -- varsym not including '-'
: VARSYM { mkUnqual varName $1 }
-- See comments with special_id
special_sym :: { UserFS }
-special_sym : '!' { SLIT("!") }
- | '.' { SLIT(".") }
- | '*' { SLIT("*") }
+special_sym : '!' { FSLIT("!") }
+ | '.' { FSLIT(".") }
+ | '*' { FSLIT("*") }
-----------------------------------------------------------------------------
-- Literals
+{-% DrIFT (Automatic class derivations for Haskell) v1.1 %-}
+{-% DrIFT (Automatic class derivations for Haskell) v1.1 %-}
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
import CStrings ( CLabelString, pprCLabelString )
import FastString ( FastString )
+import Binary
import Outputable
\end{code}
| DNCall DNCallSpec
deriving( Eq ) -- We compare them when seeing if an interface
-- has changed (for versioning purposes)
+ {-! derive: Binary !-}
-- We may need more clues to distinguish foreign calls
-- but this simple printer will do for now
-- without interacting with the runtime system at all
deriving( Eq, Show )
-- Show used just for Show Lex.Token, I think
+ {-! derive: Binary !-}
instance Outputable Safety where
ppr (PlaySafe False) = ptext SLIT("safe")
= CExportStatic -- foreign export ccall foo :: ty
CLabelString -- C Name of exported function
CCallConv
+ {-! derive: Binary !-}
data CCallSpec
= CCallSpec CCallTarget -- What to call
CCallConv -- Calling convention to use.
Safety
deriving( Eq )
+ {-! derive: Binary !-}
\end{code}
The call target:
| DynamicTarget -- First argument (an Addr#) is the function pointer
| CasmTarget CLabelString -- Inline C code (now seriously deprecated)
deriving( Eq )
+ {-! derive: Binary !-}
isDynamicTarget, isCasmTarget :: CCallTarget -> Bool
isDynamicTarget DynamicTarget = True
\begin{code}
data CCallConv = CCallConv | StdCallConv
- deriving (Eq)
+ deriving (Eq)
+ {-! derive: Binary !-}
instance Outputable CCallConv where
ppr StdCallConv = ptext SLIT("stdcall")
\begin{code}
data DNCallSpec = DNCallSpec FastString
- deriving (Eq)
+ deriving (Eq)
+ {-! derive: Binary !-}
instance Outputable DNCallSpec where
ppr (DNCallSpec s) = char '"' <> ptext s <> char '"'
okToExposeFCall (CCall (CCallSpec target _ _)) = not (isCasmTarget target)
okToExposeFCall other = True
\end{code}
+\begin{code}
+{-* Generated by DrIFT-v1.0 : Look, but Don't Touch. *-}
+instance Binary ForeignCall where
+ put_ bh (CCall aa) = do
+ putByte bh 0
+ put_ bh aa
+ put_ bh (DNCall ab) = do
+ putByte bh 1
+ put_ bh ab
+ get bh = do
+ h <- getByte bh
+ case h of
+ 0 -> do aa <- get bh
+ return (CCall aa)
+ _ -> do ab <- get bh
+ return (DNCall ab)
+
+instance Binary Safety where
+ put_ bh (PlaySafe aa) = do
+ putByte bh 0
+ put_ bh aa
+ put_ bh PlayRisky = do
+ putByte bh 1
+ get bh = do
+ h <- getByte bh
+ case h of
+ 0 -> do aa <- get bh
+ return (PlaySafe aa)
+ _ -> do return PlayRisky
+
+instance Binary CExportSpec where
+ put_ bh (CExportStatic aa ab) = do
+ put_ bh aa
+ put_ bh ab
+ get bh = do
+ aa <- get bh
+ ab <- get bh
+ return (CExportStatic aa ab)
+
+instance Binary CCallSpec where
+ put_ bh (CCallSpec aa ab ac) = do
+ put_ bh aa
+ put_ bh ab
+ put_ bh ac
+ get bh = do
+ aa <- get bh
+ ab <- get bh
+ ac <- get bh
+ return (CCallSpec aa ab ac)
+
+instance Binary CCallTarget where
+ put_ bh (StaticTarget aa) = do
+ putByte bh 0
+ put_ bh aa
+ put_ bh DynamicTarget = do
+ putByte bh 1
+ put_ bh (CasmTarget ab) = do
+ putByte bh 2
+ put_ bh ab
+ get bh = do
+ h <- getByte bh
+ case h of
+ 0 -> do aa <- get bh
+ return (StaticTarget aa)
+ 1 -> do return DynamicTarget
+ _ -> do ab <- get bh
+ return (CasmTarget ab)
+
+instance Binary CCallConv where
+ put_ bh CCallConv = do
+ putByte bh 0
+ put_ bh StdCallConv = do
+ putByte bh 1
+ get bh = do
+ h <- getByte bh
+ case h of
+ 0 -> do return CCallConv
+ _ -> do return StdCallConv
+
+instance Binary DNCallSpec where
+ put_ bh (DNCallSpec aa) = do
+ put_ bh aa
+ get bh = do
+ aa <- get bh
+ return (DNCallSpec aa)
+
+-- Imported from other files :-
+
+\end{code}
This *local* name is used by the interactive stuff
\begin{code}
-itName uniq = mkLocalName uniq (mkOccFS varName SLIT("it")) noSrcLoc
+itName uniq = mkLocalName uniq (mkOccFS varName FSLIT("it")) noSrcLoc
\end{code}
\begin{code}
-- Others (needed for flattening and not mentioned before)
andName,
- orName,
- eqCharName,
- eqIntName,
- eqFloatName,
- eqDoubleName,
- neqCharName,
- neqIntName,
- neqFloatName,
- neqDoubleName
+ orName
]
\end{code}
\begin{code}
pRELUDE_Name = mkModuleName "Prelude"
-pREL_GHC_Name = mkModuleName "GHC.Prim" -- Primitive types and values
+gHC_PRIM_Name = mkModuleName "GHC.Prim" -- Primitive types and values
+gHC_BUILTIN_Name = mkModuleName "GHC.Builtin"
pREL_BASE_Name = mkModuleName "GHC.Base"
pREL_ENUM_Name = mkModuleName "GHC.Enum"
pREL_SHOW_Name = mkModuleName "GHC.Show"
gLA_EXTS_Name = mkModuleName "GlaExts"
-pREL_GHC = mkPrelModule pREL_GHC_Name
+gHC_PRIM = mkPrelModule gHC_PRIM_Name
+gHC_BUILTIN = mkPrelModule gHC_BUILTIN_Name
pREL_BASE = mkPrelModule pREL_BASE_Name
pREL_ADDR = mkPrelModule pREL_ADDR_Name
pREL_PTR = mkPrelModule pREL_PTR_Name
\begin{code}
mkTupNameStr :: Boxity -> Int -> (ModuleName, UserFS)
-mkTupNameStr Boxed 0 = (pREL_BASE_Name, SLIT("()"))
+mkTupNameStr Boxed 0 = (pREL_BASE_Name, FSLIT("()"))
mkTupNameStr Boxed 1 = panic "Name.mkTupNameStr: 1 ???"
mkTupNameStr Boxed 2 = (pREL_TUP_Name, _PK_ "(,)") -- not strictly necessary
mkTupNameStr Boxed 3 = (pREL_TUP_Name, _PK_ "(,,)") -- ditto
mkTupNameStr Boxed n = (pREL_TUP_Name, _PK_ ("(" ++ nOfThem (n-1) ',' ++ ")"))
mkTupNameStr Unboxed 0 = panic "Name.mkUbxTupNameStr: 0 ???"
-mkTupNameStr Unboxed 1 = (pREL_GHC_Name, _PK_ "(# #)") -- 1 and 0 both make sense!!!
-mkTupNameStr Unboxed 2 = (pREL_GHC_Name, _PK_ "(#,#)")
-mkTupNameStr Unboxed 3 = (pREL_GHC_Name, _PK_ "(#,,#)")
-mkTupNameStr Unboxed 4 = (pREL_GHC_Name, _PK_ "(#,,,#)")
-mkTupNameStr Unboxed n = (pREL_GHC_Name, _PK_ ("(#" ++ nOfThem (n-1) ',' ++ "#)"))
+mkTupNameStr Unboxed 1 = (gHC_PRIM_Name, _PK_ "(# #)") -- 1 and 0 both make sense!!!
+mkTupNameStr Unboxed 2 = (gHC_PRIM_Name, _PK_ "(#,#)")
+mkTupNameStr Unboxed 3 = (gHC_PRIM_Name, _PK_ "(#,,#)")
+mkTupNameStr Unboxed 4 = (gHC_PRIM_Name, _PK_ "(#,,,#)")
+mkTupNameStr Unboxed n = (gHC_PRIM_Name, _PK_ ("(#" ++ nOfThem (n-1) ',' ++ "#)"))
mkTupConRdrName :: NameSpace -> Boxity -> Arity -> RdrName
mkTupConRdrName space boxity arity = case mkTupNameStr boxity arity of
\begin{code}
main_RDR_Unqual :: RdrName
-main_RDR_Unqual = mkUnqual varName SLIT("main")
+main_RDR_Unqual = mkUnqual varName FSLIT("main")
-- Don't get a RdrName from PrelNames.mainName, because nameRdrName
-- gets an Orig RdrName, and we want a Qual or Unqual one. An Unqual
-- one will do fine.
and it's convenient to write them all down in one place.
\begin{code}
-dollarMainName = varQual mAIN_Name SLIT("$main") dollarMainKey
-runMainName = varQual pREL_TOP_HANDLER_Name SLIT("runMain") runMainKey
+dollarMainName = varQual mAIN_Name FSLIT("$main") dollarMainKey
+runMainName = varQual pREL_TOP_HANDLER_Name FSLIT("runMain") runMainKey
-- Stuff from PrelGHC
-usOnceTyConName = kindQual SLIT(".") usOnceTyConKey
-usManyTyConName = kindQual SLIT("!") usManyTyConKey
-superKindName = kindQual SLIT("KX") kindConKey
-superBoxityName = kindQual SLIT("BX") boxityConKey
-liftedConName = kindQual SLIT("*") liftedConKey
-unliftedConName = kindQual SLIT("#") unliftedConKey
-openKindConName = kindQual SLIT("?") anyBoxConKey
-usageKindConName = kindQual SLIT("$") usageConKey
-typeConName = kindQual SLIT("Type") typeConKey
-
-funTyConName = tcQual pREL_GHC_Name SLIT("(->)") funTyConKey
-charPrimTyConName = tcQual pREL_GHC_Name SLIT("Char#") charPrimTyConKey
-intPrimTyConName = tcQual pREL_GHC_Name SLIT("Int#") intPrimTyConKey
-int32PrimTyConName = tcQual pREL_GHC_Name SLIT("Int32#") int32PrimTyConKey
-int64PrimTyConName = tcQual pREL_GHC_Name SLIT("Int64#") int64PrimTyConKey
-wordPrimTyConName = tcQual pREL_GHC_Name SLIT("Word#") wordPrimTyConKey
-word32PrimTyConName = tcQual pREL_GHC_Name SLIT("Word32#") word32PrimTyConKey
-word64PrimTyConName = tcQual pREL_GHC_Name SLIT("Word64#") word64PrimTyConKey
-addrPrimTyConName = tcQual pREL_GHC_Name SLIT("Addr#") addrPrimTyConKey
-floatPrimTyConName = tcQual pREL_GHC_Name SLIT("Float#") floatPrimTyConKey
-doublePrimTyConName = tcQual pREL_GHC_Name SLIT("Double#") doublePrimTyConKey
-statePrimTyConName = tcQual pREL_GHC_Name SLIT("State#") statePrimTyConKey
-realWorldTyConName = tcQual pREL_GHC_Name SLIT("RealWorld") realWorldTyConKey
-arrayPrimTyConName = tcQual pREL_GHC_Name SLIT("Array#") arrayPrimTyConKey
-byteArrayPrimTyConName = tcQual pREL_GHC_Name SLIT("ByteArray#") byteArrayPrimTyConKey
-mutableArrayPrimTyConName = tcQual pREL_GHC_Name SLIT("MutableArray#") mutableArrayPrimTyConKey
-mutableByteArrayPrimTyConName = tcQual pREL_GHC_Name SLIT("MutableByteArray#") mutableByteArrayPrimTyConKey
-mutVarPrimTyConName = tcQual pREL_GHC_Name SLIT("MutVar#") mutVarPrimTyConKey
-mVarPrimTyConName = tcQual pREL_GHC_Name SLIT("MVar#") mVarPrimTyConKey
-stablePtrPrimTyConName = tcQual pREL_GHC_Name SLIT("StablePtr#") stablePtrPrimTyConKey
-stableNamePrimTyConName = tcQual pREL_GHC_Name SLIT("StableName#") stableNamePrimTyConKey
-foreignObjPrimTyConName = tcQual pREL_GHC_Name SLIT("ForeignObj#") foreignObjPrimTyConKey
-bcoPrimTyConName = tcQual pREL_GHC_Name SLIT("BCO#") bcoPrimTyConKey
-weakPrimTyConName = tcQual pREL_GHC_Name SLIT("Weak#") weakPrimTyConKey
-threadIdPrimTyConName = tcQual pREL_GHC_Name SLIT("ThreadId#") threadIdPrimTyConKey
-cCallableClassName = clsQual pREL_GHC_Name SLIT("CCallable") cCallableClassKey
-cReturnableClassName = clsQual pREL_GHC_Name SLIT("CReturnable") cReturnableClassKey
+usOnceTyConName = kindQual FSLIT(".") usOnceTyConKey
+usManyTyConName = kindQual FSLIT("!") usManyTyConKey
+superKindName = kindQual FSLIT("KX") kindConKey
+superBoxityName = kindQual FSLIT("BX") boxityConKey
+liftedConName = kindQual FSLIT("*") liftedConKey
+unliftedConName = kindQual FSLIT("#") unliftedConKey
+openKindConName = kindQual FSLIT("?") anyBoxConKey
+usageKindConName = kindQual FSLIT("$") usageConKey
+typeConName = kindQual FSLIT("Type") typeConKey
+
+funTyConName = tcQual gHC_PRIM_Name FSLIT("(->)") funTyConKey
+charPrimTyConName = tcQual gHC_PRIM_Name FSLIT("Char#") charPrimTyConKey
+intPrimTyConName = tcQual gHC_PRIM_Name FSLIT("Int#") intPrimTyConKey
+int32PrimTyConName = tcQual gHC_PRIM_Name FSLIT("Int32#") int32PrimTyConKey
+int64PrimTyConName = tcQual gHC_PRIM_Name FSLIT("Int64#") int64PrimTyConKey
+wordPrimTyConName = tcQual gHC_PRIM_Name FSLIT("Word#") wordPrimTyConKey
+word32PrimTyConName = tcQual gHC_PRIM_Name FSLIT("Word32#") word32PrimTyConKey
+word64PrimTyConName = tcQual gHC_PRIM_Name FSLIT("Word64#") word64PrimTyConKey
+addrPrimTyConName = tcQual gHC_PRIM_Name FSLIT("Addr#") addrPrimTyConKey
+floatPrimTyConName = tcQual gHC_PRIM_Name FSLIT("Float#") floatPrimTyConKey
+doublePrimTyConName = tcQual gHC_PRIM_Name FSLIT("Double#") doublePrimTyConKey
+statePrimTyConName = tcQual gHC_PRIM_Name FSLIT("State#") statePrimTyConKey
+realWorldTyConName = tcQual gHC_PRIM_Name FSLIT("RealWorld") realWorldTyConKey
+arrayPrimTyConName = tcQual gHC_PRIM_Name FSLIT("Array#") arrayPrimTyConKey
+byteArrayPrimTyConName = tcQual gHC_PRIM_Name FSLIT("ByteArray#") byteArrayPrimTyConKey
+mutableArrayPrimTyConName = tcQual gHC_PRIM_Name FSLIT("MutableArray#") mutableArrayPrimTyConKey
+mutableByteArrayPrimTyConName = tcQual gHC_PRIM_Name FSLIT("MutableByteArray#") mutableByteArrayPrimTyConKey
+mutVarPrimTyConName = tcQual gHC_PRIM_Name FSLIT("MutVar#") mutVarPrimTyConKey
+mVarPrimTyConName = tcQual gHC_PRIM_Name FSLIT("MVar#") mVarPrimTyConKey
+stablePtrPrimTyConName = tcQual gHC_PRIM_Name FSLIT("StablePtr#") stablePtrPrimTyConKey
+stableNamePrimTyConName = tcQual gHC_PRIM_Name FSLIT("StableName#") stableNamePrimTyConKey
+foreignObjPrimTyConName = tcQual gHC_PRIM_Name FSLIT("ForeignObj#") foreignObjPrimTyConKey
+bcoPrimTyConName = tcQual gHC_PRIM_Name FSLIT("BCO#") bcoPrimTyConKey
+weakPrimTyConName = tcQual gHC_PRIM_Name FSLIT("Weak#") weakPrimTyConKey
+threadIdPrimTyConName = tcQual gHC_PRIM_Name FSLIT("ThreadId#") threadIdPrimTyConKey
+cCallableClassName = clsQual gHC_BUILTIN_Name FSLIT("CCallable") cCallableClassKey
+cReturnableClassName = clsQual gHC_BUILTIN_Name FSLIT("CReturnable") cReturnableClassKey
-- PrelBase data types and constructors
-charTyConName = tcQual pREL_BASE_Name SLIT("Char") charTyConKey
-charDataConName = dataQual pREL_BASE_Name SLIT("C#") charDataConKey
-intTyConName = tcQual pREL_BASE_Name SLIT("Int") intTyConKey
-intDataConName = dataQual pREL_BASE_Name SLIT("I#") intDataConKey
-orderingTyConName = tcQual pREL_BASE_Name SLIT("Ordering") orderingTyConKey
-boolTyConName = tcQual pREL_BASE_Name SLIT("Bool") boolTyConKey
-falseDataConName = dataQual pREL_BASE_Name SLIT("False") falseDataConKey
-trueDataConName = dataQual pREL_BASE_Name SLIT("True") trueDataConKey
-listTyConName = tcQual pREL_BASE_Name SLIT("[]") listTyConKey
-nilDataConName = dataQual pREL_BASE_Name SLIT("[]") nilDataConKey
-consDataConName = dataQual pREL_BASE_Name SLIT(":") consDataConKey
+charTyConName = tcQual pREL_BASE_Name FSLIT("Char") charTyConKey
+charDataConName = dataQual pREL_BASE_Name FSLIT("C#") charDataConKey
+intTyConName = tcQual pREL_BASE_Name FSLIT("Int") intTyConKey
+intDataConName = dataQual pREL_BASE_Name FSLIT("I#") intDataConKey
+orderingTyConName = tcQual pREL_BASE_Name FSLIT("Ordering") orderingTyConKey
+boolTyConName = tcQual pREL_BASE_Name FSLIT("Bool") boolTyConKey
+falseDataConName = dataQual pREL_BASE_Name FSLIT("False") falseDataConKey
+trueDataConName = dataQual pREL_BASE_Name FSLIT("True") trueDataConKey
+listTyConName = tcQual pREL_BASE_Name FSLIT("[]") listTyConKey
+nilDataConName = dataQual pREL_BASE_Name FSLIT("[]") nilDataConKey
+consDataConName = dataQual pREL_BASE_Name FSLIT(":") consDataConKey
-- PrelTup
-fstName = varQual pREL_TUP_Name SLIT("fst") fstIdKey
-sndName = varQual pREL_TUP_Name SLIT("snd") sndIdKey
+fstName = varQual pREL_TUP_Name FSLIT("fst") fstIdKey
+sndName = varQual pREL_TUP_Name FSLIT("snd") sndIdKey
-- Generics
-crossTyConName = tcQual pREL_BASE_Name SLIT(":*:") crossTyConKey
-crossDataConName = dataQual pREL_BASE_Name SLIT(":*:") crossDataConKey
-plusTyConName = tcQual pREL_BASE_Name SLIT(":+:") plusTyConKey
-inlDataConName = dataQual pREL_BASE_Name SLIT("Inl") inlDataConKey
-inrDataConName = dataQual pREL_BASE_Name SLIT("Inr") inrDataConKey
-genUnitTyConName = tcQual pREL_BASE_Name SLIT("Unit") genUnitTyConKey
-genUnitDataConName = dataQual pREL_BASE_Name SLIT("Unit") genUnitDataConKey
+crossTyConName = tcQual pREL_BASE_Name FSLIT(":*:") crossTyConKey
+crossDataConName = dataQual pREL_BASE_Name FSLIT(":*:") crossDataConKey
+plusTyConName = tcQual pREL_BASE_Name FSLIT(":+:") plusTyConKey
+inlDataConName = dataQual pREL_BASE_Name FSLIT("Inl") inlDataConKey
+inrDataConName = dataQual pREL_BASE_Name FSLIT("Inr") inrDataConKey
+genUnitTyConName = tcQual pREL_BASE_Name FSLIT("Unit") genUnitTyConKey
+genUnitDataConName = dataQual pREL_BASE_Name FSLIT("Unit") genUnitDataConKey
-- Random PrelBase functions
-unsafeCoerceName = varQual pREL_BASE_Name SLIT("unsafeCoerce")
+unsafeCoerceName = varQual pREL_BASE_Name FSLIT("unsafeCoerce")
unsafeCoerceIdKey
-otherwiseIdName = varQual pREL_BASE_Name SLIT("otherwise") otherwiseIdKey
-appendName = varQual pREL_BASE_Name SLIT("++") appendIdKey
-foldrName = varQual pREL_BASE_Name SLIT("foldr") foldrIdKey
-mapName = varQual pREL_BASE_Name SLIT("map") mapIdKey
-buildName = varQual pREL_BASE_Name SLIT("build") buildIdKey
-augmentName = varQual pREL_BASE_Name SLIT("augment") augmentIdKey
-eqStringName = varQual pREL_BASE_Name SLIT("eqString") eqStringIdKey
-andName = varQual pREL_BASE_Name SLIT("&&") andIdKey
-orName = varQual pREL_BASE_Name SLIT("||") orIdKey
-eqCharName = varQual pREL_GHC_Name SLIT("eqChar#") eqCharIdKey
-eqIntName = varQual pREL_GHC_Name SLIT("==#") eqIntIdKey
-eqFloatName = varQual pREL_GHC_Name SLIT("eqFloat#") eqFloatIdKey
-eqDoubleName = varQual pREL_GHC_Name SLIT("==##") eqDoubleIdKey
-neqCharName = varQual pREL_GHC_Name SLIT("neqChar#") neqCharIdKey
-neqIntName = varQual pREL_GHC_Name SLIT("/=#") neqIntIdKey
-neqFloatName = varQual pREL_GHC_Name SLIT("neqFloat#") neqFloatIdKey
-neqDoubleName = varQual pREL_GHC_Name SLIT("/=##") neqDoubleIdKey
+otherwiseIdName = varQual pREL_BASE_Name FSLIT("otherwise") otherwiseIdKey
+appendName = varQual pREL_BASE_Name FSLIT("++") appendIdKey
+foldrName = varQual pREL_BASE_Name FSLIT("foldr") foldrIdKey
+mapName = varQual pREL_BASE_Name FSLIT("map") mapIdKey
+buildName = varQual pREL_BASE_Name FSLIT("build") buildIdKey
+augmentName = varQual pREL_BASE_Name FSLIT("augment") augmentIdKey
+eqStringName = varQual pREL_BASE_Name FSLIT("eqString") eqStringIdKey
+andName = varQual pREL_BASE_Name FSLIT("&&") andIdKey
+orName = varQual pREL_BASE_Name FSLIT("||") orIdKey
-- Strings
-unpackCStringName = varQual pREL_BASE_Name SLIT("unpackCString#") unpackCStringIdKey
-unpackCStringAppendName = varQual pREL_BASE_Name SLIT("unpackAppendCString#") unpackCStringAppendIdKey
-unpackCStringFoldrName = varQual pREL_BASE_Name SLIT("unpackFoldrCString#") unpackCStringFoldrIdKey
-unpackCStringUtf8Name = varQual pREL_BASE_Name SLIT("unpackCStringUtf8#") unpackCStringUtf8IdKey
+unpackCStringName = varQual pREL_BASE_Name FSLIT("unpackCString#") unpackCStringIdKey
+unpackCStringAppendName = varQual pREL_BASE_Name FSLIT("unpackAppendCString#") unpackCStringAppendIdKey
+unpackCStringFoldrName = varQual pREL_BASE_Name FSLIT("unpackFoldrCString#") unpackCStringFoldrIdKey
+unpackCStringUtf8Name = varQual pREL_BASE_Name FSLIT("unpackCStringUtf8#") unpackCStringUtf8IdKey
-- Classes Eq and Ord
-eqClassName = clsQual pREL_BASE_Name SLIT("Eq") eqClassKey
-ordClassName = clsQual pREL_BASE_Name SLIT("Ord") ordClassKey
-eqName = varQual pREL_BASE_Name SLIT("==") eqClassOpKey
-geName = varQual pREL_BASE_Name SLIT(">=") geClassOpKey
+eqClassName = clsQual pREL_BASE_Name FSLIT("Eq") eqClassKey
+ordClassName = clsQual pREL_BASE_Name FSLIT("Ord") ordClassKey
+eqName = varQual pREL_BASE_Name FSLIT("==") eqClassOpKey
+geName = varQual pREL_BASE_Name FSLIT(">=") geClassOpKey
-- Class Monad
-monadClassName = clsQual pREL_BASE_Name SLIT("Monad") monadClassKey
-thenMName = varQual pREL_BASE_Name SLIT(">>=") thenMClassOpKey
-returnMName = varQual pREL_BASE_Name SLIT("return") returnMClassOpKey
-failMName = varQual pREL_BASE_Name SLIT("fail") failMClassOpKey
+monadClassName = clsQual pREL_BASE_Name FSLIT("Monad") monadClassKey
+thenMName = varQual pREL_BASE_Name FSLIT(">>=") thenMClassOpKey
+returnMName = varQual pREL_BASE_Name FSLIT("return") returnMClassOpKey
+failMName = varQual pREL_BASE_Name FSLIT("fail") failMClassOpKey
-- Class Functor
-functorClassName = clsQual pREL_BASE_Name SLIT("Functor") functorClassKey
+functorClassName = clsQual pREL_BASE_Name FSLIT("Functor") functorClassKey
-- Class Show
-showClassName = clsQual pREL_SHOW_Name SLIT("Show") showClassKey
+showClassName = clsQual pREL_SHOW_Name FSLIT("Show") showClassKey
-- Class Read
-readClassName = clsQual pREL_READ_Name SLIT("Read") readClassKey
+readClassName = clsQual pREL_READ_Name FSLIT("Read") readClassKey
-- Module PrelNum
-numClassName = clsQual pREL_NUM_Name SLIT("Num") numClassKey
-fromIntegerName = varQual pREL_NUM_Name SLIT("fromInteger") fromIntegerClassOpKey
-minusName = varQual pREL_NUM_Name SLIT("-") minusClassOpKey
-negateName = varQual pREL_NUM_Name SLIT("negate") negateClassOpKey
-plusIntegerName = varQual pREL_NUM_Name SLIT("plusInteger") plusIntegerIdKey
-timesIntegerName = varQual pREL_NUM_Name SLIT("timesInteger") timesIntegerIdKey
-integerTyConName = tcQual pREL_NUM_Name SLIT("Integer") integerTyConKey
-smallIntegerDataConName = dataQual pREL_NUM_Name SLIT("S#") smallIntegerDataConKey
-largeIntegerDataConName = dataQual pREL_NUM_Name SLIT("J#") largeIntegerDataConKey
+numClassName = clsQual pREL_NUM_Name FSLIT("Num") numClassKey
+fromIntegerName = varQual pREL_NUM_Name FSLIT("fromInteger") fromIntegerClassOpKey
+minusName = varQual pREL_NUM_Name FSLIT("-") minusClassOpKey
+negateName = varQual pREL_NUM_Name FSLIT("negate") negateClassOpKey
+plusIntegerName = varQual pREL_NUM_Name FSLIT("plusInteger") plusIntegerIdKey
+timesIntegerName = varQual pREL_NUM_Name FSLIT("timesInteger") timesIntegerIdKey
+integerTyConName = tcQual pREL_NUM_Name FSLIT("Integer") integerTyConKey
+smallIntegerDataConName = dataQual pREL_NUM_Name FSLIT("S#") smallIntegerDataConKey
+largeIntegerDataConName = dataQual pREL_NUM_Name FSLIT("J#") largeIntegerDataConKey
-- PrelReal types and classes
-rationalTyConName = tcQual pREL_REAL_Name SLIT("Rational") rationalTyConKey
-ratioTyConName = tcQual pREL_REAL_Name SLIT("Ratio") ratioTyConKey
-ratioDataConName = dataQual pREL_REAL_Name SLIT(":%") ratioDataConKey
-realClassName = clsQual pREL_REAL_Name SLIT("Real") realClassKey
-integralClassName = clsQual pREL_REAL_Name SLIT("Integral") integralClassKey
-realFracClassName = clsQual pREL_REAL_Name SLIT("RealFrac") realFracClassKey
-fractionalClassName = clsQual pREL_REAL_Name SLIT("Fractional") fractionalClassKey
-fromRationalName = varQual pREL_REAL_Name SLIT("fromRational") fromRationalClassOpKey
+rationalTyConName = tcQual pREL_REAL_Name FSLIT("Rational") rationalTyConKey
+ratioTyConName = tcQual pREL_REAL_Name FSLIT("Ratio") ratioTyConKey
+ratioDataConName = dataQual pREL_REAL_Name FSLIT(":%") ratioDataConKey
+realClassName = clsQual pREL_REAL_Name FSLIT("Real") realClassKey
+integralClassName = clsQual pREL_REAL_Name FSLIT("Integral") integralClassKey
+realFracClassName = clsQual pREL_REAL_Name FSLIT("RealFrac") realFracClassKey
+fractionalClassName = clsQual pREL_REAL_Name FSLIT("Fractional") fractionalClassKey
+fromRationalName = varQual pREL_REAL_Name FSLIT("fromRational") fromRationalClassOpKey
-- PrelFloat classes
-floatTyConName = tcQual pREL_FLOAT_Name SLIT("Float") floatTyConKey
-floatDataConName = dataQual pREL_FLOAT_Name SLIT("F#") floatDataConKey
-doubleTyConName = tcQual pREL_FLOAT_Name SLIT("Double") doubleTyConKey
-doubleDataConName = dataQual pREL_FLOAT_Name SLIT("D#") doubleDataConKey
-floatingClassName = clsQual pREL_FLOAT_Name SLIT("Floating") floatingClassKey
-realFloatClassName = clsQual pREL_FLOAT_Name SLIT("RealFloat") realFloatClassKey
+floatTyConName = tcQual pREL_FLOAT_Name FSLIT("Float") floatTyConKey
+floatDataConName = dataQual pREL_FLOAT_Name FSLIT("F#") floatDataConKey
+doubleTyConName = tcQual pREL_FLOAT_Name FSLIT("Double") doubleTyConKey
+doubleDataConName = dataQual pREL_FLOAT_Name FSLIT("D#") doubleDataConKey
+floatingClassName = clsQual pREL_FLOAT_Name FSLIT("Floating") floatingClassKey
+realFloatClassName = clsQual pREL_FLOAT_Name FSLIT("RealFloat") realFloatClassKey
-- Class Ix
-ixClassName = clsQual pREL_ARR_Name SLIT("Ix") ixClassKey
+ixClassName = clsQual pREL_ARR_Name FSLIT("Ix") ixClassKey
-- Class Enum
-enumClassName = clsQual pREL_ENUM_Name SLIT("Enum") enumClassKey
-toEnumName = varQual pREL_ENUM_Name SLIT("toEnum") toEnumClassOpKey
-fromEnumName = varQual pREL_ENUM_Name SLIT("fromEnum") fromEnumClassOpKey
-enumFromName = varQual pREL_ENUM_Name SLIT("enumFrom") enumFromClassOpKey
-enumFromToName = varQual pREL_ENUM_Name SLIT("enumFromTo") enumFromToClassOpKey
-enumFromThenName = varQual pREL_ENUM_Name SLIT("enumFromThen") enumFromThenClassOpKey
-enumFromThenToName = varQual pREL_ENUM_Name SLIT("enumFromThenTo") enumFromThenToClassOpKey
+enumClassName = clsQual pREL_ENUM_Name FSLIT("Enum") enumClassKey
+toEnumName = varQual pREL_ENUM_Name FSLIT("toEnum") toEnumClassOpKey
+fromEnumName = varQual pREL_ENUM_Name FSLIT("fromEnum") fromEnumClassOpKey
+enumFromName = varQual pREL_ENUM_Name FSLIT("enumFrom") enumFromClassOpKey
+enumFromToName = varQual pREL_ENUM_Name FSLIT("enumFromTo") enumFromToClassOpKey
+enumFromThenName = varQual pREL_ENUM_Name FSLIT("enumFromThen") enumFromThenClassOpKey
+enumFromThenToName = varQual pREL_ENUM_Name FSLIT("enumFromThenTo") enumFromThenToClassOpKey
-- Overloaded via Class Enum
-enumFromToPName = varQual pREL_PARR_Name SLIT("enumFromToP") enumFromToPIdKey
-enumFromThenToPName= varQual pREL_PARR_Name SLIT("enumFromThenToP") enumFromThenToPIdKey
+enumFromToPName = varQual pREL_PARR_Name FSLIT("enumFromToP") enumFromToPIdKey
+enumFromThenToPName= varQual pREL_PARR_Name FSLIT("enumFromThenToP") enumFromThenToPIdKey
-- Class Bounded
-boundedClassName = clsQual pREL_ENUM_Name SLIT("Bounded") boundedClassKey
+boundedClassName = clsQual pREL_ENUM_Name FSLIT("Bounded") boundedClassKey
-- List functions
-concatName = varQual pREL_LIST_Name SLIT("concat") concatIdKey
-filterName = varQual pREL_LIST_Name SLIT("filter") filterIdKey
-zipName = varQual pREL_LIST_Name SLIT("zip") zipIdKey
+concatName = varQual pREL_LIST_Name FSLIT("concat") concatIdKey
+filterName = varQual pREL_LIST_Name FSLIT("filter") filterIdKey
+zipName = varQual pREL_LIST_Name FSLIT("zip") zipIdKey
-- parallel array types and functions
-parrTyConName = tcQual pREL_PARR_Name SLIT("[::]") parrTyConKey
-parrDataConName = dataQual pREL_PARR_Name SLIT("PArr") parrDataConKey
-nullPName = varQual pREL_PARR_Name SLIT("nullP") nullPIdKey
-lengthPName = varQual pREL_PARR_Name SLIT("lengthP") lengthPIdKey
-replicatePName = varQual pREL_PARR_Name SLIT("replicateP") replicatePIdKey
-mapPName = varQual pREL_PARR_Name SLIT("mapP") mapPIdKey
-filterPName = varQual pREL_PARR_Name SLIT("filterP") filterPIdKey
-zipPName = varQual pREL_PARR_Name SLIT("zipP") zipPIdKey
-crossPName = varQual pREL_PARR_Name SLIT("crossP") crossPIdKey
-indexPName = varQual pREL_PARR_Name SLIT("!:") indexPIdKey
-toPName = varQual pREL_PARR_Name SLIT("toP") toPIdKey
-bpermutePName = varQual pREL_PARR_Name SLIT("bpermuteP") bpermutePIdKey
-bpermuteDftPName = varQual pREL_PARR_Name SLIT("bpermuteDftP")
+parrTyConName = tcQual pREL_PARR_Name FSLIT("[::]") parrTyConKey
+parrDataConName = dataQual pREL_PARR_Name FSLIT("PArr") parrDataConKey
+nullPName = varQual pREL_PARR_Name FSLIT("nullP") nullPIdKey
+lengthPName = varQual pREL_PARR_Name FSLIT("lengthP") lengthPIdKey
+replicatePName = varQual pREL_PARR_Name FSLIT("replicateP") replicatePIdKey
+mapPName = varQual pREL_PARR_Name FSLIT("mapP") mapPIdKey
+filterPName = varQual pREL_PARR_Name FSLIT("filterP") filterPIdKey
+zipPName = varQual pREL_PARR_Name FSLIT("zipP") zipPIdKey
+crossPName = varQual pREL_PARR_Name FSLIT("crossP") crossPIdKey
+indexPName = varQual pREL_PARR_Name FSLIT("!:") indexPIdKey
+toPName = varQual pREL_PARR_Name FSLIT("toP") toPIdKey
+bpermutePName = varQual pREL_PARR_Name FSLIT("bpermuteP") bpermutePIdKey
+bpermuteDftPName = varQual pREL_PARR_Name FSLIT("bpermuteDftP")
bpermuteDftPIdKey
-indexOfPName = varQual pREL_PARR_Name SLIT("indexOfP") indexOfPIdKey
+indexOfPName = varQual pREL_PARR_Name FSLIT("indexOfP") indexOfPIdKey
-- IOBase things
-ioTyConName = tcQual pREL_IO_BASE_Name SLIT("IO") ioTyConKey
-ioDataConName = dataQual pREL_IO_BASE_Name SLIT("IO") ioDataConKey
-bindIOName = varQual pREL_IO_BASE_Name SLIT("bindIO") bindIOIdKey
-returnIOName = varQual pREL_IO_BASE_Name SLIT("returnIO") returnIOIdKey
-failIOName = varQual pREL_IO_BASE_Name SLIT("failIO") failIOIdKey
+ioTyConName = tcQual pREL_IO_BASE_Name FSLIT("IO") ioTyConKey
+ioDataConName = dataQual pREL_IO_BASE_Name FSLIT("IO") ioDataConKey
+bindIOName = varQual pREL_IO_BASE_Name FSLIT("bindIO") bindIOIdKey
+returnIOName = varQual pREL_IO_BASE_Name FSLIT("returnIO") returnIOIdKey
+failIOName = varQual pREL_IO_BASE_Name FSLIT("failIO") failIOIdKey
-- IO things
-printName = varQual sYSTEM_IO_Name SLIT("print") printIdKey
+printName = varQual sYSTEM_IO_Name FSLIT("print") printIdKey
-- Int, Word, and Addr things
-int8TyConName = tcQual pREL_INT_Name SLIT("Int8") int8TyConKey
-int16TyConName = tcQual pREL_INT_Name SLIT("Int16") int16TyConKey
-int32TyConName = tcQual pREL_INT_Name SLIT("Int32") int32TyConKey
-int64TyConName = tcQual pREL_INT_Name SLIT("Int64") int64TyConKey
+int8TyConName = tcQual pREL_INT_Name FSLIT("Int8") int8TyConKey
+int16TyConName = tcQual pREL_INT_Name FSLIT("Int16") int16TyConKey
+int32TyConName = tcQual pREL_INT_Name FSLIT("Int32") int32TyConKey
+int64TyConName = tcQual pREL_INT_Name FSLIT("Int64") int64TyConKey
-word8TyConName = tcQual pREL_WORD_Name SLIT("Word8") word8TyConKey
-word16TyConName = tcQual pREL_WORD_Name SLIT("Word16") word16TyConKey
-word32TyConName = tcQual pREL_WORD_Name SLIT("Word32") word32TyConKey
-word64TyConName = tcQual pREL_WORD_Name SLIT("Word64") word64TyConKey
+word8TyConName = tcQual pREL_WORD_Name FSLIT("Word8") word8TyConKey
+word16TyConName = tcQual pREL_WORD_Name FSLIT("Word16") word16TyConKey
+word32TyConName = tcQual pREL_WORD_Name FSLIT("Word32") word32TyConKey
+word64TyConName = tcQual pREL_WORD_Name FSLIT("Word64") word64TyConKey
-wordTyConName = tcQual pREL_WORD_Name SLIT("Word") wordTyConKey
-wordDataConName = dataQual pREL_WORD_Name SLIT("W#") wordDataConKey
+wordTyConName = tcQual pREL_WORD_Name FSLIT("Word") wordTyConKey
+wordDataConName = dataQual pREL_WORD_Name FSLIT("W#") wordDataConKey
-addrTyConName = tcQual aDDR_Name SLIT("Addr") addrTyConKey
-addrDataConName = dataQual aDDR_Name SLIT("A#") addrDataConKey
+addrTyConName = tcQual aDDR_Name FSLIT("Addr") addrTyConKey
+addrDataConName = dataQual aDDR_Name FSLIT("A#") addrDataConKey
-ptrTyConName = tcQual pREL_PTR_Name SLIT("Ptr") ptrTyConKey
-ptrDataConName = dataQual pREL_PTR_Name SLIT("Ptr") ptrDataConKey
+ptrTyConName = tcQual pREL_PTR_Name FSLIT("Ptr") ptrTyConKey
+ptrDataConName = dataQual pREL_PTR_Name FSLIT("Ptr") ptrDataConKey
-funPtrTyConName = tcQual pREL_PTR_Name SLIT("FunPtr") funPtrTyConKey
-funPtrDataConName = dataQual pREL_PTR_Name SLIT("FunPtr") funPtrDataConKey
+funPtrTyConName = tcQual pREL_PTR_Name FSLIT("FunPtr") funPtrTyConKey
+funPtrDataConName = dataQual pREL_PTR_Name FSLIT("FunPtr") funPtrDataConKey
-- Byte array types
-byteArrayTyConName = tcQual pREL_BYTEARR_Name SLIT("ByteArray") byteArrayTyConKey
-mutableByteArrayTyConName = tcQual pREL_BYTEARR_Name SLIT("MutableByteArray") mutableByteArrayTyConKey
+byteArrayTyConName = tcQual pREL_BYTEARR_Name FSLIT("ByteArray") byteArrayTyConKey
+mutableByteArrayTyConName = tcQual pREL_BYTEARR_Name FSLIT("MutableByteArray") mutableByteArrayTyConKey
-- Foreign objects and weak pointers
-foreignObjTyConName = tcQual fOREIGNOBJ_Name SLIT("ForeignObj") foreignObjTyConKey
-foreignObjDataConName = dataQual fOREIGNOBJ_Name SLIT("ForeignObj") foreignObjDataConKey
-foreignPtrTyConName = tcQual fOREIGN_PTR_Name SLIT("ForeignPtr") foreignPtrTyConKey
-foreignPtrDataConName = dataQual fOREIGN_PTR_Name SLIT("ForeignPtr") foreignPtrDataConKey
-stablePtrTyConName = tcQual pREL_STABLE_Name SLIT("StablePtr") stablePtrTyConKey
-stablePtrDataConName = dataQual pREL_STABLE_Name SLIT("StablePtr") stablePtrDataConKey
-deRefStablePtrName = varQual pREL_STABLE_Name SLIT("deRefStablePtr") deRefStablePtrIdKey
-newStablePtrName = varQual pREL_STABLE_Name SLIT("newStablePtr") newStablePtrIdKey
-
-errorName = varQual pREL_ERR_Name SLIT("error") errorIdKey
-assertName = varQual pREL_GHC_Name SLIT("assert") assertIdKey
-getTagName = varQual pREL_GHC_Name SLIT("getTag#") getTagIdKey
-runSTRepName = varQual pREL_ST_Name SLIT("runSTRep") runSTRepIdKey
+foreignObjTyConName = tcQual fOREIGNOBJ_Name FSLIT("ForeignObj") foreignObjTyConKey
+foreignObjDataConName = dataQual fOREIGNOBJ_Name FSLIT("ForeignObj") foreignObjDataConKey
+foreignPtrTyConName = tcQual fOREIGN_PTR_Name FSLIT("ForeignPtr") foreignPtrTyConKey
+foreignPtrDataConName = dataQual fOREIGN_PTR_Name FSLIT("ForeignPtr") foreignPtrDataConKey
+stablePtrTyConName = tcQual pREL_STABLE_Name FSLIT("StablePtr") stablePtrTyConKey
+stablePtrDataConName = dataQual pREL_STABLE_Name FSLIT("StablePtr") stablePtrDataConKey
+deRefStablePtrName = varQual pREL_STABLE_Name FSLIT("deRefStablePtr") deRefStablePtrIdKey
+newStablePtrName = varQual pREL_STABLE_Name FSLIT("newStablePtr") newStablePtrIdKey
+
+errorName = varQual pREL_ERR_Name FSLIT("error") errorIdKey
+assertName = varQual gHC_BUILTIN_Name FSLIT("assert") assertIdKey
+getTagName = varQual gHC_BUILTIN_Name FSLIT("getTag#") getTagIdKey
+runSTRepName = varQual pREL_ST_Name FSLIT("runSTRep") runSTRepIdKey
-- The "split" Id for splittable implicit parameters
-splitName = varQual pREL_SPLIT_Name SLIT("split") splitIdKey
+splitName = varQual pREL_SPLIT_Name FSLIT("split") splitIdKey
\end{code}
%************************************************************************
ubxTupleCon_RDR = mkTupConRdrName dataName Unboxed
ubxTupleTyCon_RDR = mkTupConRdrName tcName Unboxed
-unitCon_RDR = dataQual_RDR pREL_BASE_Name SLIT("()")
-unitTyCon_RDR = tcQual_RDR pREL_BASE_Name SLIT("()")
-
-and_RDR = varQual_RDR pREL_BASE_Name SLIT("&&")
-not_RDR = varQual_RDR pREL_BASE_Name SLIT("not")
-compose_RDR = varQual_RDR pREL_BASE_Name SLIT(".")
-ne_RDR = varQual_RDR pREL_BASE_Name SLIT("/=")
-le_RDR = varQual_RDR pREL_BASE_Name SLIT("<=")
-lt_RDR = varQual_RDR pREL_BASE_Name SLIT("<")
-gt_RDR = varQual_RDR pREL_BASE_Name SLIT(">")
-ltTag_RDR = dataQual_RDR pREL_BASE_Name SLIT("LT")
-eqTag_RDR = dataQual_RDR pREL_BASE_Name SLIT("EQ")
-gtTag_RDR = dataQual_RDR pREL_BASE_Name SLIT("GT")
-max_RDR = varQual_RDR pREL_BASE_Name SLIT("max")
-min_RDR = varQual_RDR pREL_BASE_Name SLIT("min")
-compare_RDR = varQual_RDR pREL_BASE_Name SLIT("compare")
-showList_RDR = varQual_RDR pREL_SHOW_Name SLIT("showList")
-showList___RDR = varQual_RDR pREL_SHOW_Name SLIT("showList__")
-showsPrec_RDR = varQual_RDR pREL_SHOW_Name SLIT("showsPrec")
-showSpace_RDR = varQual_RDR pREL_SHOW_Name SLIT("showSpace")
-showString_RDR = varQual_RDR pREL_SHOW_Name SLIT("showString")
-showParen_RDR = varQual_RDR pREL_SHOW_Name SLIT("showParen")
-readsPrec_RDR = varQual_RDR pREL_READ_Name SLIT("readsPrec")
-readList_RDR = varQual_RDR pREL_READ_Name SLIT("readList")
-readParen_RDR = varQual_RDR pREL_READ_Name SLIT("readParen")
-lex_RDR = varQual_RDR pREL_READ_Name SLIT("lex")
-readList___RDR = varQual_RDR pREL_READ_Name SLIT("readList__")
-times_RDR = varQual_RDR pREL_NUM_Name SLIT("*")
-plus_RDR = varQual_RDR pREL_NUM_Name SLIT("+")
-negate_RDR = varQual_RDR pREL_NUM_Name SLIT("negate")
-range_RDR = varQual_RDR pREL_ARR_Name SLIT("range")
-index_RDR = varQual_RDR pREL_ARR_Name SLIT("index")
-inRange_RDR = varQual_RDR pREL_ARR_Name SLIT("inRange")
-succ_RDR = varQual_RDR pREL_ENUM_Name SLIT("succ")
-pred_RDR = varQual_RDR pREL_ENUM_Name SLIT("pred")
-minBound_RDR = varQual_RDR pREL_ENUM_Name SLIT("minBound")
-maxBound_RDR = varQual_RDR pREL_ENUM_Name SLIT("maxBound")
-assertErr_RDR = varQual_RDR pREL_ERR_Name SLIT("assertError")
+unitCon_RDR = dataQual_RDR pREL_BASE_Name FSLIT("()")
+unitTyCon_RDR = tcQual_RDR pREL_BASE_Name FSLIT("()")
+
+and_RDR = varQual_RDR pREL_BASE_Name FSLIT("&&")
+not_RDR = varQual_RDR pREL_BASE_Name FSLIT("not")
+compose_RDR = varQual_RDR pREL_BASE_Name FSLIT(".")
+ne_RDR = varQual_RDR pREL_BASE_Name FSLIT("/=")
+le_RDR = varQual_RDR pREL_BASE_Name FSLIT("<=")
+lt_RDR = varQual_RDR pREL_BASE_Name FSLIT("<")
+gt_RDR = varQual_RDR pREL_BASE_Name FSLIT(">")
+ltTag_RDR = dataQual_RDR pREL_BASE_Name FSLIT("LT")
+eqTag_RDR = dataQual_RDR pREL_BASE_Name FSLIT("EQ")
+gtTag_RDR = dataQual_RDR pREL_BASE_Name FSLIT("GT")
+max_RDR = varQual_RDR pREL_BASE_Name FSLIT("max")
+min_RDR = varQual_RDR pREL_BASE_Name FSLIT("min")
+compare_RDR = varQual_RDR pREL_BASE_Name FSLIT("compare")
+showList_RDR = varQual_RDR pREL_SHOW_Name FSLIT("showList")
+showList___RDR = varQual_RDR pREL_SHOW_Name FSLIT("showList__")
+showsPrec_RDR = varQual_RDR pREL_SHOW_Name FSLIT("showsPrec")
+showSpace_RDR = varQual_RDR pREL_SHOW_Name FSLIT("showSpace")
+showString_RDR = varQual_RDR pREL_SHOW_Name FSLIT("showString")
+showParen_RDR = varQual_RDR pREL_SHOW_Name FSLIT("showParen")
+readsPrec_RDR = varQual_RDR pREL_READ_Name FSLIT("readsPrec")
+readList_RDR = varQual_RDR pREL_READ_Name FSLIT("readList")
+readParen_RDR = varQual_RDR pREL_READ_Name FSLIT("readParen")
+lex_RDR = varQual_RDR pREL_READ_Name FSLIT("lex")
+readList___RDR = varQual_RDR pREL_READ_Name FSLIT("readList__")
+times_RDR = varQual_RDR pREL_NUM_Name FSLIT("*")
+plus_RDR = varQual_RDR pREL_NUM_Name FSLIT("+")
+negate_RDR = varQual_RDR pREL_NUM_Name FSLIT("negate")
+range_RDR = varQual_RDR pREL_ARR_Name FSLIT("range")
+index_RDR = varQual_RDR pREL_ARR_Name FSLIT("index")
+inRange_RDR = varQual_RDR pREL_ARR_Name FSLIT("inRange")
+succ_RDR = varQual_RDR pREL_ENUM_Name FSLIT("succ")
+pred_RDR = varQual_RDR pREL_ENUM_Name FSLIT("pred")
+minBound_RDR = varQual_RDR pREL_ENUM_Name FSLIT("minBound")
+maxBound_RDR = varQual_RDR pREL_ENUM_Name FSLIT("maxBound")
+assertErr_RDR = varQual_RDR pREL_ERR_Name FSLIT("assertError")
\end{code}
These RDR names also have known keys, so we need to get back the RDR names to
andIdKey = mkPreludeMiscIdUnique 57
orIdKey = mkPreludeMiscIdUnique 58
-eqCharIdKey = mkPreludeMiscIdUnique 59
-eqIntIdKey = mkPreludeMiscIdUnique 60
-eqFloatIdKey = mkPreludeMiscIdUnique 61
-eqDoubleIdKey = mkPreludeMiscIdUnique 62
-neqCharIdKey = mkPreludeMiscIdUnique 63
-neqIntIdKey = mkPreludeMiscIdUnique 64
-neqFloatIdKey = mkPreludeMiscIdUnique 65
-neqDoubleIdKey = mkPreludeMiscIdUnique 66
-
--- NB: Currently a gap of four slots
-- Parallel array functions
nullPIdKey = mkPreludeMiscIdUnique 70
primOpOkForSpeculation, primOpIsCheap, primOpIsDupable,
primOpHasSideEffects,
- getPrimOpResultInfo, PrimOpResultInfo(..)
+ getPrimOpResultInfo, PrimOpResultInfo(..),
+
+ eqCharName, eqIntName, eqFloatName, eqDoubleName, neqIntName,
) where
#include "HsVersions.h"
occ = primOpOcc other_op
\end{code}
+Names for some primops (for ndpFlatten/FlattenMonad.lhs)
+\begin{code}
+eqCharName = mkPrimOpIdName CharEqOp
+eqIntName = mkPrimOpIdName IntEqOp
+eqFloatName = mkPrimOpIdName FloatEqOp
+eqDoubleName = mkPrimOpIdName DoubleEqOp
+neqIntName = mkPrimOpIdName IntNeOp
+\end{code}
= -- make a trivial let-binding for the top-level function
getUniqueMM `thenMM` \ uniq ->
let
- new_var = mkSysLocal SLIT("sf") uniq var_type
+ new_var = mkSysLocal FSLIT("sf") uniq var_type
in
returnMM ( (new_var, old_var) : bindings, StgVarArg new_var )
where
import ForeignCall ( ForeignCall(..), CCallConv(..), CCallSpec(..), CCallTarget(..) )
import Lex
-import RnMonad ( ParsedIface(..), ExportItem, IfaceDeprecs )
+import RnMonad ( ParsedIface(..), IfaceDeprecs )
import HscTypes ( WhetherHasOrphans, IsBootInterface, GenAvailInfo(..),
ImportVersion, WhatsImported(..),
- RdrAvailInfo )
+ RdrAvailInfo, RdrExportItem )
import RdrName ( RdrName, mkRdrUnqual, mkIfaceOrig )
import TyCon ( DataConDetails(..) )
--------------------------------------------------------------------------
-exports_part :: { [ExportItem] }
+exports_part :: { [RdrExportItem] }
exports_part : { [] }
| '__export' mod_name entities ';'
exports_part { ({-mkSysModuleNameFS-} $2, $3) : $5 }
--------------------------------------------------------------------------
-fix_decl_part :: { [RdrNameFixitySig] }
+fix_decl_part :: { [(RdrName,Fixity)] }
fix_decl_part : {- empty -} { [] }
| fix_decls ';' { $1 }
-fix_decls :: { [RdrNameFixitySig] }
+fix_decls :: { [(RdrName,Fixity)] }
fix_decls : { [] }
| fix_decl fix_decls { $1 : $2 }
-fix_decl :: { RdrNameFixitySig }
-fix_decl : src_loc fixity prec var_or_data_name { FixitySig $4 (Fixity $3 $2) $1 }
+fix_decl :: { (RdrName,Fixity) }
+fix_decl : fixity prec var_or_data_name { ($3, Fixity $2 $1) }
fixity :: { FixityDirection }
fixity : 'infixl' { InfixL }
---------------------------------------------------
var_fs :: { EncodedFS }
: VARID { $1 }
- | 'as' { SLIT("as") }
- | 'qualified' { SLIT("qualified") }
- | 'hiding' { SLIT("hiding") }
- | 'forall' { SLIT("forall") }
- | 'foreign' { SLIT("foreign") }
- | 'export' { SLIT("export") }
- | 'label' { SLIT("label") }
- | 'dynamic' { SLIT("dynamic") }
- | 'unsafe' { SLIT("unsafe") }
- | 'with' { SLIT("with") }
- | 'ccall' { SLIT("ccall") }
- | 'stdcall' { SLIT("stdcall") }
+ | 'as' { FSLIT("as") }
+ | 'qualified' { FSLIT("qualified") }
+ | 'hiding' { FSLIT("hiding") }
+ | 'forall' { FSLIT("forall") }
+ | 'foreign' { FSLIT("foreign") }
+ | 'export' { FSLIT("export") }
+ | 'label' { FSLIT("label") }
+ | 'dynamic' { FSLIT("dynamic") }
+ | 'unsafe' { FSLIT("unsafe") }
+ | 'with' { FSLIT("with") }
+ | 'ccall' { FSLIT("ccall") }
+ | 'stdcall' { FSLIT("stdcall") }
var_occ :: { OccName }
: var_fs { mkSysOccFS varName $1 }
akind :: { Kind }
: '*' { liftedTypeKind }
- | VARSYM { if $1 == SLIT("?") then
+ | VARSYM { if $1 == FSLIT("?") then
openTypeKind
- else if $1 == SLIT("\36") then
+ else if $1 == FSLIT("\36") then
usageTypeKind -- dollar
else panic "ParseInterface: akind"
}
if opt_IgnoreAsserts then
getUniqRn `thenRn` \ uniq ->
let
- vname = mkSysLocalName uniq SLIT("v")
+ vname = mkSysLocalName uniq FSLIT("v")
expr = HsLam ignorePredMatch
loc = nameSrcLoc vname
ignorePredMatch = mkSimpleMatch [WildPatIn, VarPatIn vname] (HsVar vname) placeHolderType loc
import HscTypes ( ModuleLocation(..),
ModIface(..), emptyModIface,
VersionInfo(..), ImportedModuleInfo,
- lookupIfaceByModName,
+ lookupIfaceByModName, RdrExportItem,
ImportVersion, WhetherHasOrphans, IsBootInterface,
DeclsMap, GatedDecl, IfaceInsts, IfaceRules,
AvailInfo, GenAvailInfo(..), Avails, Deprecations(..)
)
-import HsSyn ( TyClDecl(..), InstDecl(..),
- FixitySig(..), RuleDecl(..),
- tyClDeclNames, tyClDeclSysNames, hsTyVarNames, getHsInstHead,
+import HsSyn ( TyClDecl(..), InstDecl(..), RuleDecl(..),
+ tyClDeclNames, tyClDeclSysNames, hsTyVarNames,
+ getHsInstHead,
)
import RdrHsSyn ( RdrNameTyClDecl, RdrNameInstDecl, RdrNameRuleDecl )
import RnHsSyn ( extractHsTyNames_s )
import ListSetOps ( minusList )
import Outputable
import Bag
+import BinIface ( {- just instances -} )
+import qualified Binary
+import Panic
import Config
import IOExts
+import Exception ( tryAllIO, Exception(DynException) )
+import Dynamic ( fromDynamic )
import Directory
+import List ( isSuffixOf )
\end{code}
-- Loading the export list
-----------------------------------------------------
-loadExports :: (Version, [ExportItem]) -> RnM d (Version, [(ModuleName,Avails)])
+loadExports :: (Version, [RdrExportItem]) -> RnM d (Version, [(ModuleName,Avails)])
loadExports (vers, items)
= mapRn loadExport items `thenRn` \ avails_s ->
returnRn (vers, avails_s)
-loadExport :: ExportItem -> RnM d (ModuleName, Avails)
+loadExport :: RdrExportItem -> RnM d (ModuleName, Avails)
loadExport (mod, entities)
= mapRn (load_entity mod) entities `thenRn` \ avails ->
returnRn (mod, avails)
where
mod_name = moduleName mod
-loadFixDecl mod_name sig@(FixitySig rdr_name fixity loc)
+loadFixDecl mod_name (rdr_name, fixity)
= newGlobalName mod_name (rdrNameOcc rdr_name) `thenRn` \ name ->
returnRn (name, fixity)
= --ioToRnM (putStrLn ("reading iface " ++ file_path)) `thenRn_`
traceRn (ptext SLIT("readIFace") <+> text file_path) `thenRn_`
- ioToRnM (hGetStringBuffer False file_path) `thenRn` \ read_result ->
- case read_result of {
- Left io_error -> bale_out (text (show io_error)) ;
+ let hi_boot_ver = "hi-boot-" ++ cHscIfaceFileVersion in
+ if ".hi-boot" `isSuffixOf` file_path
+ || hi_boot_ver `isSuffixOf` file_path then
+
+ ioToRnM (hGetStringBuffer False file_path) `thenRn` \ read_result ->
+ case read_result of {
+ Left io_error -> bale_out (text (show io_error));
Right contents ->
- case parseIface contents (mkPState loc exts) of
- POk _ iface -> returnRn (Right iface)
+ case parseIface contents (mkPState loc exts) of {
+ POk _ iface -> returnRn (Right iface);
PFailed err -> bale_out err
- }
+ }}
+
+ else
+ ioToRnM_no_fail (tryAllIO (Binary.getBinFileWithDict file_path))
+ `thenRn` \ either_iface ->
+
+ case either_iface of
+ Right iface -> returnRn (Right iface)
+ Left (DynException d) | Just e <- fromDynamic d
+ -> bale_out (text (show (e :: GhcException)))
+
+ Left err -> bale_out (text (show err))
+
where
exts = ExtFlags {glasgowExtsEF = True,
parrEF = True}
import HscTypes ( AvailEnv, emptyAvailEnv, lookupType,
NameSupply(..),
ImportedModuleInfo, WhetherHasOrphans, ImportVersion,
- PersistentRenamerState(..),
+ PersistentRenamerState(..), RdrExportItem,
DeclsMap, IfaceInsts, IfaceRules,
HomeSymbolTable, TyThing,
- PersistentCompilerState(..), GlobalRdrEnv, LocalRdrEnv,
- HomeIfaceTable, PackageIfaceTable,
- RdrAvailInfo )
+ PersistentCompilerState(..), GlobalRdrEnv,
+ LocalRdrEnv,
+ HomeIfaceTable, PackageIfaceTable )
import BasicTypes ( Version, defaultFixity )
import ErrUtils ( addShortErrLocLine, addShortWarnLocLine,
Message, Messages, errorsFound, warningsFound,
Nothing -> defaultFixity
\end{code}
-
-%===================================================
-\subsubsection{ INTERFACE FILE STUFF}
-%===================================================
+%************************************************************************
+%* *
+\subsection{Interface file stuff}
+%* *
+%************************************************************************
\begin{code}
-type ExportItem = (ModuleName, [RdrAvailInfo])
type IfaceDeprecs = Maybe (Either DeprecTxt [(RdrName,DeprecTxt)])
-- Nothing => NoDeprecs
-- Just (Left t) => DeprecAll
pi_vers :: Version, -- Module version number
pi_orphan :: WhetherHasOrphans, -- Whether this module has orphans
pi_usages :: [ImportVersion OccName], -- Usages
- pi_exports :: (Version, [ExportItem]), -- Exports
+ pi_exports :: (Version, [RdrExportItem]), -- Exports
pi_decls :: [(Version, RdrNameTyClDecl)], -- Local definitions
- pi_fixity :: [RdrNameFixitySig], -- Local fixity declarations,
+ pi_fixity :: [(RdrName,Fixity)], -- Local fixity declarations,
pi_insts :: [RdrNameInstDecl], -- Local instance declarations
pi_rules :: (Version, [RdrNameRuleDecl]), -- Rules, with their version
pi_deprecs :: IfaceDeprecs -- Deprecations
splitTyConApp_maybe, tyConAppArgs, mkTyVarTys
)
import TcType ( isDictTy )
-import OccName ( UserFS )
+import OccName ( EncodedFS )
import TyCon ( tyConDataCons_maybe, isAlgTyCon, isNewTyCon )
import DataCon ( dataConRepArity, dataConSig, dataConArgTys )
import Var ( mkSysTyVar, tyVarKind )
\begin{code}
-newId :: UserFS -> Type -> SimplM Id
+newId :: EncodedFS -> Type -> SimplM Id
newId fs ty = getUniqueSmpl `thenSmpl` \ uniq ->
returnSmpl (mkSysLocal fs uniq ty)
\end{code}
ex_tyvars' = zipWith mk tv_uniqs ex_tyvars
mk uniq tv = mkSysTyVar uniq (tyVarKind tv)
arg_tys = dataConArgTys missing_con (inst_tys ++ mkTyVarTys ex_tyvars')
- arg_ids = zipWith (mkSysLocal SLIT("a")) id_uniqs arg_tys
+ arg_ids = zipWith (mkSysLocal FSLIT("a")) id_uniqs arg_tys
in
returnSmpl (ex_tyvars' ++ arg_ids)
\end{code}
idNewDemandInfo, setIdInfo,
setIdOccInfo, zapLamIdInfo, setOneShotLambda,
)
+import OccName ( encodeFS )
import IdInfo ( OccInfo(..), isLoopBreaker,
setArityInfo,
setUnfoldingInfo,
| otherwise -- Don't forget to do it recursively
-- E.g. x = a:b:c:[]
= mkAtomicArgs is_strict ok_float_unlifted arg `thenSmpl` \ (arg_binds, arg') ->
- newId SLIT("a") arg_ty `thenSmpl` \ arg_id ->
+ newId FSLIT("a") arg_ty `thenSmpl` \ arg_id ->
go fun ((arg_binds `snocOL` (arg_id,arg')) `appOL` binds)
(Var arg_id : rev_args) args
where
if exprIsDupable arg' then
returnSmpl (emptyFloats env, (ApplyTo OkToDup arg' (zapSubstEnv se) dup_cont, nondup_cont))
else
- newId SLIT("a") (exprType arg') `thenSmpl` \ arg_id ->
+ newId FSLIT("a") (exprType arg') `thenSmpl` \ arg_id ->
tick (CaseOfCase arg_id) `thenSmpl_`
-- Want to tick here so that we go round again,
-- (the \v alone is enough to make CPR happy) but I think it's rare
( if null used_bndrs'
- then newId SLIT("w") realWorldStatePrimTy `thenSmpl` \ rw_id ->
+ then newId FSLIT("w") realWorldStatePrimTy `thenSmpl` \ rw_id ->
returnSmpl ([rw_id], [Var realWorldPrimId])
else
returnSmpl (used_bndrs', map varToCoreExpr used_bndrs')
) `thenSmpl` \ (final_bndrs', final_args) ->
-- See comment about "$j" name above
- newId SLIT("$j") (mkPiTypes final_bndrs' rhs_ty') `thenSmpl` \ join_bndr ->
+ newId (encodeFS SLIT("$j")) (mkPiTypes final_bndrs' rhs_ty') `thenSmpl` \ join_bndr ->
-- Notice the funky mkPiTypes. If the contructor has existentials
-- it's possible that the join point will be abstracted over
-- type varaibles as well as term variables.
= (us, Var v) -- so that we can spot when we pass them twice
argToPat env us arg
- = (us1, Var (mkSysLocal SLIT("sc") (uniqFromSupply us2) (exprType arg)))
+ = (us1, Var (mkSysLocal FSLIT("sc") (uniqFromSupply us2) (exprType arg)))
where
(us1,us2) = splitUniqSupply us
applyToVars vars fn = mkVarApps fn vars
mk_wrap_arg uniq ty dmd one_shot
- = set_one_shot one_shot (setIdNewDemandInfo (mkSysLocal SLIT("w") uniq ty) dmd)
+ = set_one_shot one_shot (setIdNewDemandInfo (mkSysLocal FSLIT("w") uniq ty) dmd)
where
set_one_shot True id = setOneShotLambda id
set_one_shot False id = id
-- like (x+y) `seq` ....
sanitiseCaseBndr id = id `setIdInfo` vanillaIdInfo
-mk_ww_local uniq ty = mkSysLocal SLIT("ww") uniq ty
+mk_ww_local uniq ty = mkSysLocal FSLIT("ww") uniq ty
\end{code}
tcGetUnique `thenNF_Tc` \ new_uniq ->
let
lit_inst = LitInst lit_id lit ty loc
- lit_id = mkSysLocal SLIT("lit") new_uniq ty
+ lit_id = mkSysLocal FSLIT("lit") new_uniq ty
in
returnNF_Tc (HsVar (instToId lit_inst), unitLIE lit_inst)
qual_orig_name n = nameRdrName (getName n)
varUnqual n = mkUnqual varName n
-zz_a_RDR = varUnqual SLIT("_a")
-a_RDR = varUnqual SLIT("a")
-b_RDR = varUnqual SLIT("b")
-c_RDR = varUnqual SLIT("c")
-d_RDR = varUnqual SLIT("d")
-ah_RDR = varUnqual SLIT("a#")
-bh_RDR = varUnqual SLIT("b#")
-ch_RDR = varUnqual SLIT("c#")
-dh_RDR = varUnqual SLIT("d#")
-cmp_eq_RDR = varUnqual SLIT("cmp_eq")
-rangeSize_RDR = varUnqual SLIT("rangeSize")
+zz_a_RDR = varUnqual FSLIT("_a")
+a_RDR = varUnqual FSLIT("a")
+b_RDR = varUnqual FSLIT("b")
+c_RDR = varUnqual FSLIT("c")
+d_RDR = varUnqual FSLIT("d")
+ah_RDR = varUnqual FSLIT("a#")
+bh_RDR = varUnqual FSLIT("b#")
+ch_RDR = varUnqual FSLIT("c#")
+dh_RDR = varUnqual FSLIT("d#")
+cmp_eq_RDR = varUnqual FSLIT("cmp_eq")
+rangeSize_RDR = varUnqual FSLIT("rangeSize")
as_RDRs = [ varUnqual (_PK_ ("a"++show i)) | i <- [(1::Int) .. ] ]
bs_RDRs = [ varUnqual (_PK_ ("b"++show i)) | i <- [(1::Int) .. ] ]
newTyVar :: Kind -> NF_TcM TcTyVar
newTyVar kind
= tcGetUnique `thenNF_Tc` \ uniq ->
- tcNewMutTyVar (mkSysLocalName uniq SLIT("t")) kind VanillaTv
+ tcNewMutTyVar (mkSysLocalName uniq FSLIT("t")) kind VanillaTv
newTyVarTy :: Kind -> NF_TcM TcType
newTyVarTy kind
newHoleTyVarTy :: NF_TcM TcType
= tcGetUnique `thenNF_Tc` \ uniq ->
- tcNewMutTyVar (mkSysLocalName uniq SLIT("h")) openTypeKind HoleTv `thenNF_Tc` \ tv ->
+ tcNewMutTyVar (mkSysLocalName uniq FSLIT("h")) openTypeKind HoleTv `thenNF_Tc` \ tv ->
returnNF_Tc (TyVarTy tv)
newTyVarTys :: Int -> Kind -> NF_TcM [TcType]
newKindVar :: NF_TcM TcKind
newKindVar
= tcGetUnique `thenNF_Tc` \ uniq ->
- tcNewMutTyVar (mkSysLocalName uniq SLIT("k")) superKind VanillaTv `thenNF_Tc` \ kv ->
+ tcNewMutTyVar (mkSysLocalName uniq FSLIT("k")) superKind VanillaTv `thenNF_Tc` \ kv ->
returnNF_Tc (TyVarTy kv)
newKindVars :: Int -> NF_TcM [TcKind]
newBoxityVar :: NF_TcM TcKind
newBoxityVar
= tcGetUnique `thenNF_Tc` \ uniq ->
- tcNewMutTyVar (mkSysLocalName uniq SLIT("bx")) superBoxity VanillaTv `thenNF_Tc` \ kv ->
+ tcNewMutTyVar (mkSysLocalName uniq FSLIT("bx")) superBoxity VanillaTv `thenNF_Tc` \ kv ->
returnNF_Tc (TyVarTy kv)
\end{code}
else
tcGetUnique `thenNF_Tc` \ uniq ->
let
- arg_id = mkSysLocal SLIT("sub") uniq exp_ty
+ arg_id = mkSysLocal FSLIT("sub") uniq exp_ty
the_fn = DictLam [arg_id] (co_fn <$> HsVar arg_id)
pat_co_fn p = SigPat p exp_ty the_fn
in
-- co_fn_arg :: HsExpr exp_arg -> HsExpr act_arg
-- co_fn_res :: HsExpr act_res -> HsExpr exp_res
-- co_fn :: HsExpr (act_arg -> act_res) -> HsExpr (exp_arg -> exp_res)
- arg_id = mkSysLocal SLIT("sub") uniq exp_arg
+ arg_id = mkSysLocal FSLIT("sub") uniq exp_arg
coercion | isIdCoercion co_fn_arg,
isIdCoercion co_fn_res = idCoercion
| otherwise = mkCoercion co_fn
import BasicTypes ( IPName )
import TyCon ( TyCon, KindCon, mkFunTyCon, mkKindCon, mkSuperKindCon )
import Class ( Class )
+import Binary
-- others
import PrelNames ( superKindName, superBoxityName, liftedConName,
| SynNote Type -- Used for type synonyms
-- The Type is always a TyConApp, and is the un-expanded form.
-- The type to which the note is attached is the expanded form.
+
\end{code}
-------------------------------------
\begin{code}
liftedBoxity, unliftedBoxity :: Kind -- :: BX
-liftedBoxity = TyConApp (mkKindCon liftedConName superBoxity) []
+liftedBoxity = TyConApp liftedBoxityCon []
+unliftedBoxity = TyConApp unliftedBoxityCon []
-unliftedBoxity = TyConApp (mkKindCon unliftedConName superBoxity) []
+liftedBoxityCon = mkKindCon liftedConName superBoxity
+unliftedBoxityCon = mkKindCon unliftedConName superBoxity
\end{code}
------------------------------------------
mkArrowKinds arg_kinds result_kind = foldr mkArrowKind result_kind arg_kinds
\end{code}
+-----------------------------------------------------------------------------
+Binary kinds for interface files
+
+\begin{code}
+instance Binary Kind where
+ put_ bh k@(TyConApp tc [])
+ | tc == openKindCon = putByte bh 0
+ | tc == usageKindCon = putByte bh 1
+ put_ bh k@(TyConApp tc [TyConApp bc _])
+ | tc == typeCon && bc == liftedBoxityCon = putByte bh 2
+ | tc == typeCon && bc == unliftedBoxityCon = putByte bh 3
+ put_ bh (FunTy f a) = do putByte bh 4; put_ bh f; put_ bh a
+ put_ bh _ = error "Binary.put(Kind): strange-looking Kind"
+
+ get bh = do
+ b <- getByte bh
+ case b of
+ 0 -> return openTypeKind
+ 1 -> return usageTypeKind
+ 2 -> return liftedTypeKind
+ 3 -> return unliftedTypeKind
+ _ -> do f <- get bh; a <- get bh; return (FunTy f a)
+\end{code}
%************************************************************************
%* *
--- /dev/null
+{-# OPTIONS -cpp #-}
+--
+-- (c) The University of Glasgow 2002
+--
+-- Binary I/O library, with special tweaks for GHC
+
+module Binary
+ ( {-type-} Bin,
+ {-class-} Binary(..),
+ {-type-} BinHandle,
+
+ openBinIO, openBinIO_,
+ openBinMem,
+-- closeBin,
+
+ getUserData,
+
+ seekBin,
+ tellBin,
+ castBin,
+
+ writeBinMem,
+ readBinMem,
+
+ isEOFBin,
+
+ -- for writing instances:
+ putByte,
+ getByte,
+
+ -- lazy Bin I/O
+ lazyGet,
+ lazyPut,
+
+ -- GHC only:
+ ByteArray(..),
+ getByteArray,
+ putByteArray,
+
+ getBinFileWithDict, -- :: Binary a => FilePath -> IO a
+ putBinFileWithDict, -- :: Binary a => FilePath -> Module -> a -> IO ()
+
+ ) where
+
+#include "MachDeps.h"
+
+import {-# SOURCE #-} Module
+import FastString
+import Unique
+import UniqFM
+
+#if __GLASGOW_HASKELL__ < 503
+import IOExts
+import Bits
+import Int
+import Word
+import Char
+import Monad
+import Exception
+import GlaExts hiding (ByteArray, newByteArray, freezeByteArray)
+import Array
+import IO
+import PrelIOBase ( IOError(..), IOErrorType(..) )
+import PrelReal ( Ratio(..) )
+import PrelIOBase ( IO(..) )
+#else
+import Data.Array.IO
+import Data.Array
+import Data.Bits
+import Data.Int
+import Data.Word
+import Data.IORef
+import Data.Char ( ord, chr )
+import Data.Array.Base ( unsafeRead, unsafeWrite )
+import Control.Monad ( when )
+import Control.Exception ( throw )
+import System.IO as IO
+import System.IO.Unsafe ( unsafeInterleaveIO )
+import System.IO.Error ( mkIOError, eofErrorType )
+import GHC.Real ( Ratio(..) )
+import GHC.Exts
+import GHC.IOBase ( IO(..) )
+import GHC.Word ( Word8(..) )
+#endif
+
+#if __GLASGOW_HASKELL__ < 503
+type BinArray = MutableByteArray RealWorld Int
+newArray_ bounds = stToIO (newCharArray bounds)
+unsafeWrite arr ix e = stToIO (writeWord8Array arr ix e)
+unsafeRead arr ix = stToIO (readWord8Array arr ix)
+newByteArray# = newCharArray#
+hPutArray h arr sz = hPutBufBAFull h arr sz
+hGetArray h sz = hGetBufBAFull h sz
+
+mkIOError :: IOErrorType -> String -> Maybe Handle -> Maybe FilePath -> Exception
+mkIOError t location maybe_hdl maybe_filename
+ = IOException (IOError maybe_hdl t location "")
+
+eofErrorType = EOF
+
+#ifndef SIZEOF_HSINT
+#define SIZEOF_HSINT INT_SIZE_IN_BYTES
+#endif
+
+#ifndef SIZEOF_HSWORD
+#define SIZEOF_HSWORD WORD_SIZE_IN_BYTES
+#endif
+
+#else
+type BinArray = IOUArray Int Word8
+#endif
+
+data BinHandle
+ = BinMem { -- binary data stored in an unboxed array
+ state :: BinHandleState, -- sigh, need parameterized modules :-)
+ off_r :: !FastMutInt, -- the current offset
+ sz_r :: !FastMutInt, -- size of the array (cached)
+ arr_r :: !(IORef BinArray) -- the array (bounds: (0,size-1))
+ }
+ -- XXX: should really store a "high water mark" for dumping out
+ -- the binary data to a file.
+
+ | BinIO { -- binary data stored in a file
+ state :: BinHandleState,
+ off_r :: !FastMutInt, -- the current offset (cached)
+ hdl :: !IO.Handle -- the file handle (must be seekable)
+ }
+ -- cache the file ptr in BinIO; using hTell is too expensive
+ -- to call repeatedly. If anyone else is modifying this Handle
+ -- at the same time, we'll be screwed.
+
+newtype Bin a = BinPtr Int
+ deriving (Eq, Ord, Show, Bounded)
+
+castBin :: Bin a -> Bin b
+castBin (BinPtr i) = BinPtr i
+
+class Binary a where
+ put_ :: BinHandle -> a -> IO ()
+ put :: BinHandle -> a -> IO (Bin a)
+ get :: BinHandle -> IO a
+
+ -- define one of put_, put. Use of put_ is recommended because it
+ -- is more likely that tail-calls can kick in, and we rarely need the
+ -- position return value.
+ put_ bh a = do put bh a; return ()
+ put bh a = do p <- tellBin bh; put_ bh a; return p
+
+putAt :: Binary a => BinHandle -> Bin a -> a -> IO ()
+putAt bh p x = do seekBin bh p; put bh x; return ()
+
+getAt :: Binary a => BinHandle -> Bin a -> IO a
+getAt bh p = do seekBin bh p; get bh
+
+openBinIO_ :: IO.Handle -> IO BinHandle
+openBinIO_ h = openBinIO h noBinHandleUserData
+
+openBinIO :: IO.Handle -> Module -> IO BinHandle
+openBinIO h mod = do
+ r <- newFastMutInt
+ writeFastMutInt r 0
+ state <- newWriteState mod
+ return (BinIO state r h)
+
+openBinMem :: Int -> Module -> IO BinHandle
+openBinMem size mod
+ | size <= 0 = error "Data.Binary.openBinMem: size must be >= 0"
+ | otherwise = do
+ arr <- newArray_ (0,size-1)
+ arr_r <- newIORef arr
+ ix_r <- newFastMutInt
+ writeFastMutInt ix_r 0
+ sz_r <- newFastMutInt
+ writeFastMutInt sz_r size
+ state <- newWriteState mod
+ return (BinMem state ix_r sz_r arr_r)
+
+noBinHandleUserData = error "Binary.BinHandle: no user data"
+
+getUserData :: BinHandle -> BinHandleState
+getUserData bh = state bh
+
+tellBin :: BinHandle -> IO (Bin a)
+tellBin (BinIO _ r _) = do ix <- readFastMutInt r; return (BinPtr ix)
+tellBin (BinMem _ r _ _) = do ix <- readFastMutInt r; return (BinPtr ix)
+
+seekBin :: BinHandle -> Bin a -> IO ()
+seekBin (BinIO _ ix_r h) (BinPtr p) = do
+ writeFastMutInt ix_r p
+ hSeek h AbsoluteSeek (fromIntegral p)
+seekBin h@(BinMem _ ix_r sz_r a) (BinPtr p) = do
+ sz <- readFastMutInt sz_r
+ if (p >= sz)
+ then do expandBin h p; writeFastMutInt ix_r p
+ else writeFastMutInt ix_r p
+
+isEOFBin :: BinHandle -> IO Bool
+isEOFBin (BinMem _ ix_r sz_r a) = do
+ ix <- readFastMutInt ix_r
+ sz <- readFastMutInt sz_r
+ return (ix >= sz)
+isEOFBin (BinIO _ ix_r h) = hIsEOF h
+
+writeBinMem :: BinHandle -> FilePath -> IO ()
+writeBinMem (BinIO _ _ _) _ = error "Data.Binary.writeBinMem: not a memory handle"
+writeBinMem (BinMem _ ix_r sz_r arr_r) fn = do
+ h <- openFile fn WriteMode
+ arr <- readIORef arr_r
+ ix <- readFastMutInt ix_r
+ hPutArray h arr ix
+#if __GLASGOW_HASKELL__ < 500
+ -- workaround a bug in ghc 4.08's implementation of hPutBuf (it doesn't
+ -- set the FILEOBJ_RW_WRITTEN flag on the file object, so the file doens't
+ -- get flushed properly). Adding an extra '\0' doens't do any harm.
+ hPutChar h '\0'
+#endif
+ hClose h
+
+readBinMem :: FilePath -> IO BinHandle
+readBinMem filename = do
+ h <- openFile filename ReadMode
+ filesize' <- hFileSize h
+ let filesize = fromIntegral filesize'
+ arr <- newArray_ (0,filesize-1)
+ count <- hGetArray h arr filesize
+ when (count /= filesize)
+ (error ("Binary.readBinMem: only read " ++ show count ++ " bytes"))
+ hClose h
+ arr_r <- newIORef arr
+ ix_r <- newFastMutInt
+ writeFastMutInt ix_r 0
+ sz_r <- newFastMutInt
+ writeFastMutInt sz_r filesize
+ return (BinMem initReadState ix_r sz_r arr_r)
+
+-- expand the size of the array to include a specified offset
+expandBin :: BinHandle -> Int -> IO ()
+expandBin (BinMem _ ix_r sz_r arr_r) off = do
+ sz <- readFastMutInt sz_r
+ let sz' = head (dropWhile (<= off) (iterate (* 2) sz))
+ arr <- readIORef arr_r
+ arr' <- newArray_ (0,sz'-1)
+ sequence_ [ unsafeRead arr i >>= unsafeWrite arr' i
+ | i <- [ 0 .. sz-1 ] ]
+ writeFastMutInt sz_r sz'
+ writeIORef arr_r arr'
+ hPutStrLn stderr ("expanding to size: " ++ show sz')
+ return ()
+expandBin (BinIO _ _ _) _ = return ()
+ -- no need to expand a file, we'll assume they expand by themselves.
+
+-- -----------------------------------------------------------------------------
+-- Low-level reading/writing of bytes
+
+putWord8 :: BinHandle -> Word8 -> IO ()
+putWord8 h@(BinMem _ ix_r sz_r arr_r) w = do
+ ix <- readFastMutInt ix_r
+ sz <- readFastMutInt sz_r
+ -- double the size of the array if it overflows
+ if (ix >= sz)
+ then do expandBin h ix
+ putWord8 h w
+ else do arr <- readIORef arr_r
+ unsafeWrite arr ix w
+ writeFastMutInt ix_r (ix+1)
+ return ()
+putWord8 (BinIO _ ix_r h) w = do
+ ix <- readFastMutInt ix_r
+ hPutChar h (chr (fromIntegral w)) -- XXX not really correct
+ writeFastMutInt ix_r (ix+1)
+ return ()
+
+getWord8 :: BinHandle -> IO Word8
+getWord8 (BinMem _ ix_r sz_r arr_r) = do
+ ix <- readFastMutInt ix_r
+ sz <- readFastMutInt sz_r
+ when (ix >= sz) $
+ throw (mkIOError eofErrorType "Data.Binary.getWord8" Nothing Nothing)
+ arr <- readIORef arr_r
+ w <- unsafeRead arr ix
+ writeFastMutInt ix_r (ix+1)
+ return w
+getWord8 (BinIO _ ix_r h) = do
+ ix <- readFastMutInt ix_r
+ c <- hGetChar h
+ writeFastMutInt ix_r (ix+1)
+ return (fromIntegral (ord c)) -- XXX not really correct
+
+putByte :: BinHandle -> Word8 -> IO ()
+putByte bh w = put_ bh w
+
+getByte :: BinHandle -> IO Word8
+getByte = getWord8
+
+-- -----------------------------------------------------------------------------
+-- Primitve Word writes
+
+instance Binary Word8 where
+ put_ = putWord8
+ get = getWord8
+
+instance Binary Word16 where
+ put_ h w = do -- XXX too slow.. inline putWord8?
+ putByte h (fromIntegral (w `shiftR` 8))
+ putByte h (fromIntegral (w .&. 0xff))
+ get h = do
+ w1 <- getWord8 h
+ w2 <- getWord8 h
+ return ((fromIntegral w1 `shiftL` 8) .|. fromIntegral w2)
+
+
+instance Binary Word32 where
+ put_ h w = do
+ putByte h (fromIntegral (w `shiftR` 24))
+ putByte h (fromIntegral ((w `shiftR` 16) .&. 0xff))
+ putByte h (fromIntegral ((w `shiftR` 8) .&. 0xff))
+ putByte h (fromIntegral (w .&. 0xff))
+ get h = do
+ w1 <- getWord8 h
+ w2 <- getWord8 h
+ w3 <- getWord8 h
+ w4 <- getWord8 h
+ return ((fromIntegral w1 `shiftL` 24) .|.
+ (fromIntegral w2 `shiftL` 16) .|.
+ (fromIntegral w3 `shiftL` 8) .|.
+ (fromIntegral w4))
+
+
+instance Binary Word64 where
+ put_ h w = do
+ putByte h (fromIntegral (w `shiftR` 56))
+ putByte h (fromIntegral ((w `shiftR` 48) .&. 0xff))
+ putByte h (fromIntegral ((w `shiftR` 40) .&. 0xff))
+ putByte h (fromIntegral ((w `shiftR` 32) .&. 0xff))
+ putByte h (fromIntegral ((w `shiftR` 24) .&. 0xff))
+ putByte h (fromIntegral ((w `shiftR` 16) .&. 0xff))
+ putByte h (fromIntegral ((w `shiftR` 8) .&. 0xff))
+ putByte h (fromIntegral (w .&. 0xff))
+ get h = do
+ w1 <- getWord8 h
+ w2 <- getWord8 h
+ w3 <- getWord8 h
+ w4 <- getWord8 h
+ w5 <- getWord8 h
+ w6 <- getWord8 h
+ w7 <- getWord8 h
+ w8 <- getWord8 h
+ return ((fromIntegral w1 `shiftL` 56) .|.
+ (fromIntegral w2 `shiftL` 48) .|.
+ (fromIntegral w3 `shiftL` 40) .|.
+ (fromIntegral w4 `shiftL` 32) .|.
+ (fromIntegral w5 `shiftL` 24) .|.
+ (fromIntegral w6 `shiftL` 16) .|.
+ (fromIntegral w7 `shiftL` 8) .|.
+ (fromIntegral w8))
+
+-- -----------------------------------------------------------------------------
+-- Primitve Int writes
+
+instance Binary Int8 where
+ put_ h w = put_ h (fromIntegral w :: Word8)
+ get h = do w <- get h; return (fromIntegral (w::Word8))
+
+instance Binary Int16 where
+ put_ h w = put_ h (fromIntegral w :: Word16)
+ get h = do w <- get h; return (fromIntegral (w::Word16))
+
+instance Binary Int32 where
+ put_ h w = put_ h (fromIntegral w :: Word32)
+ get h = do w <- get h; return (fromIntegral (w::Word32))
+
+instance Binary Int64 where
+ put_ h w = put_ h (fromIntegral w :: Word64)
+ get h = do w <- get h; return (fromIntegral (w::Word64))
+
+-- -----------------------------------------------------------------------------
+-- Instances for standard types
+
+instance Binary () where
+ put_ bh () = return ()
+ get _ = return ()
+-- getF bh p = case getBitsF bh 0 p of (_,b) -> ((),b)
+
+instance Binary Bool where
+ put_ bh b = putByte bh (fromIntegral (fromEnum b))
+ get bh = do x <- getWord8 bh; return (toEnum (fromIntegral x))
+-- getF bh p = case getBitsF bh 1 p of (x,b) -> (toEnum x,b)
+
+instance Binary Char where
+ put_ bh c = put_ bh (fromIntegral (ord c) :: Word32)
+ get bh = do x <- get bh; return (chr (fromIntegral (x :: Word32)))
+-- getF bh p = case getBitsF bh 8 p of (x,b) -> (toEnum x,b)
+
+instance Binary Int where
+#if SIZEOF_HSINT == 4
+ put_ bh i = put_ bh (fromIntegral i :: Int32)
+ get bh = do
+ x <- get bh
+ return (fromIntegral (x :: Int32))
+#elif SIZEOF_HSINT == 8
+ put_ bh i = put_ bh (fromIntegral i :: Int64)
+ get bh = do
+ x <- get bh
+ return (fromIntegral (x :: Int64))
+#else
+#error "unsupported sizeof(HsInt)"
+#endif
+-- getF bh = getBitsF bh 32
+
+instance Binary a => Binary [a] where
+ put_ bh [] = putByte bh 0
+ put_ bh (x:xs) = do putByte bh 1; put_ bh x; put_ bh xs
+ get bh = do h <- getWord8 bh
+ case h of
+ 0 -> return []
+ _ -> do x <- get bh
+ xs <- get bh
+ return (x:xs)
+
+instance (Binary a, Binary b) => Binary (a,b) where
+ put_ bh (a,b) = do put_ bh a; put_ bh b
+ get bh = do a <- get bh
+ b <- get bh
+ return (a,b)
+
+instance (Binary a, Binary b, Binary c) => Binary (a,b,c) where
+ put_ bh (a,b,c) = do put_ bh a; put_ bh b; put_ bh c
+ get bh = do a <- get bh
+ b <- get bh
+ c <- get bh
+ return (a,b,c)
+
+instance (Binary a, Binary b, Binary c, Binary d) => Binary (a,b,c,d) where
+ put_ bh (a,b,c,d) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d
+ get bh = do a <- get bh
+ b <- get bh
+ c <- get bh
+ d <- get bh
+ return (a,b,c,d)
+
+instance Binary a => Binary (Maybe a) where
+ put_ bh Nothing = putByte bh 0
+ put_ bh (Just a) = do putByte bh 1; put_ bh a
+ get bh = do h <- getWord8 bh
+ case h of
+ 0 -> return Nothing
+ _ -> do x <- get bh; return (Just x)
+
+instance (Binary a, Binary b) => Binary (Either a b) where
+ put_ bh (Left a) = do putByte bh 0; put_ bh a
+ put_ bh (Right b) = do putByte bh 1; put_ bh b
+ get bh = do h <- getWord8 bh
+ case h of
+ 0 -> do a <- get bh ; return (Left a)
+ _ -> do b <- get bh ; return (Right b)
+
+#ifdef __GLASGOW_HASKELL__
+instance Binary Integer where
+ put_ bh (S# i#) = do putByte bh 0; put_ bh (I# i#)
+ put_ bh (J# s# a#) = do
+ p <- putByte bh 1;
+ put_ bh (I# s#)
+ let sz# = sizeofByteArray# a# -- in *bytes*
+ put_ bh (I# sz#) -- in *bytes*
+ putByteArray bh a# sz#
+
+ get bh = do
+ b <- getByte bh
+ case b of
+ 0 -> do (I# i#) <- get bh
+ return (S# i#)
+ _ -> do (I# s#) <- get bh
+ sz <- get bh
+ (BA a#) <- getByteArray bh sz
+ return (J# s# a#)
+
+putByteArray :: BinHandle -> ByteArray# -> Int# -> IO ()
+putByteArray bh a s# = loop 0#
+ where loop n#
+ | n# ==# s# = return ()
+ | otherwise = do
+ putByte bh (indexByteArray a n#)
+ loop (n# +# 1#)
+
+getByteArray :: BinHandle -> Int -> IO ByteArray
+getByteArray bh (I# sz) = do
+ (MBA arr) <- newByteArray sz
+ let loop n
+ | n ==# sz = return ()
+ | otherwise = do
+ w <- getByte bh
+ writeByteArray arr n w
+ loop (n +# 1#)
+ loop 0#
+ freezeByteArray arr
+
+
+data ByteArray = BA ByteArray#
+data MBA = MBA (MutableByteArray# RealWorld)
+
+newByteArray :: Int# -> IO MBA
+newByteArray sz = IO $ \s ->
+ case newByteArray# sz s of { (# s, arr #) ->
+ (# s, MBA arr #) }
+
+freezeByteArray :: MutableByteArray# RealWorld -> IO ByteArray
+freezeByteArray arr = IO $ \s ->
+ case unsafeFreezeByteArray# arr s of { (# s, arr #) ->
+ (# s, BA arr #) }
+
+writeByteArray :: MutableByteArray# RealWorld -> Int# -> Word8 -> IO ()
+
+#if __GLASGOW_HASKELL__ < 503
+writeByteArray arr i w8 = IO $ \s ->
+ case word8ToWord w8 of { W# w# ->
+ case writeCharArray# arr i (chr# (word2Int# w#)) s of { s ->
+ (# s , () #) }}
+#else
+writeByteArray arr i (W8# w) = IO $ \s ->
+ case writeWord8Array# arr i w s of { s ->
+ (# s, () #) }
+#endif
+
+#if __GLASGOW_HASKELL__ < 503
+indexByteArray a# n# = fromIntegral (I# (ord# (indexCharArray# a# n#)))
+#else
+indexByteArray a# n# = W8# (indexWord8Array# a# n#)
+#endif
+
+instance (Integral a, Binary a) => Binary (Ratio a) where
+ put_ bh (a :% b) = do put_ bh a; put_ bh b
+ get bh = do a <- get bh; b <- get bh; return (a :% b)
+#endif
+
+instance Binary (Bin a) where
+ put_ bh (BinPtr i) = put_ bh i
+ get bh = do i <- get bh; return (BinPtr i)
+
+-- -----------------------------------------------------------------------------
+-- unboxed mutable Ints
+
+#ifdef __GLASGOW_HASKELL__
+data FastMutInt = FastMutInt (MutableByteArray# RealWorld)
+
+newFastMutInt = IO $ \s ->
+ case newByteArray# size s of { (# s, arr #) ->
+ (# s, FastMutInt arr #) }
+ where I# size = SIZEOF_HSWORD
+
+readFastMutInt (FastMutInt arr) = IO $ \s ->
+ case readIntArray# arr 0# s of { (# s, i #) ->
+ (# s, I# i #) }
+
+writeFastMutInt (FastMutInt arr) (I# i) = IO $ \s ->
+ case writeIntArray# arr 0# i s of { s ->
+ (# s, () #) }
+#endif
+
+-- -----------------------------------------------------------------------------
+-- Lazy reading/writing
+
+lazyPut :: Binary a => BinHandle -> a -> IO ()
+lazyPut bh a = do
+ -- output the obj with a ptr to skip over it:
+ pre_a <- tellBin bh
+ put_ bh pre_a -- save a slot for the ptr
+ put_ bh a -- dump the object
+ q <- tellBin bh -- q = ptr to after object
+ putAt bh pre_a q -- fill in slot before a with ptr to q
+ seekBin bh q -- finally carry on writing at q
+
+lazyGet :: Binary a => BinHandle -> IO a
+lazyGet bh = do
+ p <- get bh -- a BinPtr
+ p_a <- tellBin bh
+ a <- unsafeInterleaveIO (getAt bh p_a)
+ seekBin bh p -- skip over the object for now
+ return a
+
+-- -----------------------------------------------------------------------------
+-- BinHandleState
+
+type BinHandleState =
+ (Module,
+ IORef Int,
+ IORef (UniqFM (Int,FastString)),
+ Array Int FastString)
+
+initReadState :: BinHandleState
+initReadState = (undef, undef, undef, undef)
+
+newWriteState :: Module -> IO BinHandleState
+newWriteState m = do
+ j_r <- newIORef 0
+ out_r <- newIORef emptyUFM
+ return (m,j_r,out_r,undef)
+
+undef = error "Binary.BinHandleState"
+
+-- -----------------------------------------------------------------------------
+-- FastString binary interface
+
+getBinFileWithDict :: Binary a => FilePath -> IO a
+getBinFileWithDict file_path = do
+ bh <- Binary.readBinMem file_path
+ dict_p <- Binary.get bh -- get the dictionary ptr
+ data_p <- tellBin bh
+ seekBin bh dict_p
+ dict <- getDictionary bh
+ seekBin bh data_p
+ let (mod, j_r, out_r, _) = state bh
+ get bh{ state = (mod,j_r,out_r,dict) }
+
+initBinMemSize = (1024*1024) :: Int
+
+putBinFileWithDict :: Binary a => FilePath -> Module -> a -> IO ()
+putBinFileWithDict file_path mod a = do
+ bh <- openBinMem initBinMemSize mod
+ p <- tellBin bh
+ put_ bh p -- placeholder for ptr to dictionary
+ put_ bh a
+ let (_, j_r, fm_r, _) = state bh
+ j <- readIORef j_r
+ fm <- readIORef fm_r
+ dict_p <- tellBin bh
+ putAt bh p dict_p -- fill in the placeholder
+ seekBin bh dict_p -- seek back to the end of the file
+ putDictionary bh j (constructDictionary j fm)
+ writeBinMem bh file_path
+
+type Dictionary = Array Int FastString
+ -- should be 0-indexed
+
+putDictionary :: BinHandle -> Int -> Dictionary -> IO ()
+putDictionary bh sz dict = do
+ put_ bh sz
+ mapM_ (putFS bh) (elems dict)
+
+getDictionary :: BinHandle -> IO Dictionary
+getDictionary bh = do
+ sz <- get bh
+ elems <- sequence (take sz (repeat (getFS bh)))
+ return (listArray (0,sz-1) elems)
+
+constructDictionary :: Int -> UniqFM (Int,FastString) -> Dictionary
+constructDictionary j fm = array (0,j-1) (eltsUFM fm)
+
+putFS bh (FastString id l ba) = do
+ put_ bh (I# l)
+ putByteArray bh ba l
+putFS bh s = error ("Binary.put_(FastString): " ++ unpackFS s)
+ -- Note: the length of the FastString is *not* the same as
+ -- the size of the ByteArray: the latter is rounded up to a
+ -- multiple of the word size.
+
+getFS bh = do
+ (I# l) <- get bh
+ (BA ba) <- getByteArray bh (I# l)
+ return (mkFastSubStringBA# ba 0# l)
+ -- XXX ToDo: one too many copies here
+
+instance Binary FastString where
+ put_ bh f@(FastString id l ba) =
+ case getUserData bh of { (_, j_r, out_r, dict) -> do
+ out <- readIORef out_r
+ let uniq = getUnique f
+ case lookupUFM out uniq of
+ Just (j,f) -> put_ bh j
+ Nothing -> do
+ j <- readIORef j_r
+ put_ bh j
+ writeIORef j_r (j+1)
+ writeIORef out_r (addToUFM out uniq (j,f))
+ }
+ put_ bh s = error ("Binary.put_(FastString): " ++ show (unpackFS s))
+
+ get bh = do
+ j <- get bh
+ case getUserData bh of (_, _, _, arr) -> return (arr ! j)
mkFastCharString#, -- :: Addr# -> FastString
mkFastCharString2, -- :: Addr -> Int -> FastString
- mkFastString#, -- :: Addr# -> Int# -> FastString
+ mkFastString#, -- :: Addr# -> FastString
mkFastSubStringBA#, -- :: ByteArray# -> Int# -> Int# -> FastString
mkFastSubString#, -- :: Addr# -> Int# -> Int# -> FastString
[Int] -- character numbers
instance Eq FastString where
- a == b = case cmpFS a b of { LT -> False; EQ -> True; GT -> False }
- a /= b = case cmpFS a b of { LT -> True; EQ -> False; GT -> True }
+ -- shortcut for real FastStrings
+ (FastString u1 _ _) == (FastString u2 _ _) = u1 ==# u2
+ a == b =
+#ifdef DEBUG
+ trace ("slow FastString comparison: " ++
+ unpackFS a ++ "/" ++ unpackFS b) $
+#endif
+ case cmpFS a b of { LT -> False; EQ -> True; GT -> False }
+
+ (FastString u1 _ _) == (FastString u2 _ _) = u1 /=# u2
+ a /= b =
+#ifdef DEBUG
+ trace ("slow FastString comparison: " ++
+ unpackFS a ++ "/" ++ unpackFS b) $
+#endif
+ case cmpFS a b of { LT -> True; EQ -> False; GT -> True }
instance Ord FastString where
a <= b = case cmpFS a b of { LT -> True; EQ -> True; GT -> False }
uniqueOfFS :: FastString -> Int#
uniqueOfFS (FastString u# _ _) = u#
-uniqueOfFS (CharStr a# l#) = case mkFastString# a# l# of { FastString u# _ _ -> u#} -- Ugh!
+uniqueOfFS (CharStr a# l#) = case mkFastStringLen# a# l# of { FastString u# _ _ -> u#} -- Ugh!
{-
[A somewhat moby hack]: to avoid entering all sorts
of junk into the hash table, all C char strings
(# s2#, () #) }) >>
writeIORef fs_table_var (FastStringTable (uid# +# 1#) arr#)
-mkFastString# :: Addr# -> Int# -> FastString
-mkFastString# a# len# =
+mkFastString# :: Addr# -> FastString
+mkFastString# a# =
+ case strLength (A# a#) of { (I# len#) -> mkFastStringLen# a# len# }
+
+mkFastStringLen# :: Addr# -> Int# -> FastString
+mkFastStringLen# a# len# =
unsafePerformIO (
readIORef string_table >>= \ ft@(FastStringTable uid# tbl#) ->
let
mkFastSubString :: Addr -> Int -> Int -> FastString
mkFastSubString (A# a#) (I# start#) (I# len#) =
- mkFastString# (addrOffset# a# start#) len#
+ mkFastStringLen# (addrOffset# a# start#) len#
\end{code}
\begin{code}
lexemeToFastString :: StringBuffer -> FastString
lexemeToFastString (StringBuffer fo l# start_pos# current#) =
if start_pos# ==# current# then
- mkFastCharString2 (A# fo) (I# 0#)
+ mkFastString ""
else
mkFastSubString (A# fo) (I# start_pos#) (I# (current# -# start_pos#))
projects / ghc-hetmet.git / commitdiff