diff options
48 files changed, 1630 insertions, 518 deletions
diff --git a/ghc/compiler/HsVersions.h b/ghc/compiler/HsVersions.h index 72c1185e09..4900e5663a 100644 --- a/ghc/compiler/HsVersions.h +++ b/ghc/compiler/HsVersions.h @@ -49,6 +49,7 @@ import qualified FastString # 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 diff --git a/ghc/compiler/Makefile b/ghc/compiler/Makefile index daa95bc0d1..d496a08992 100644 --- a/ghc/compiler/Makefile +++ b/ghc/compiler/Makefile @@ -1,5 +1,5 @@ # ----------------------------------------------------------------------------- -# $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 = .. @@ -362,6 +362,14 @@ else 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 diff --git a/ghc/compiler/basicTypes/Id.lhs b/ghc/compiler/basicTypes/Id.lhs index 75cce86472..52b05e1157 100644 --- a/ghc/compiler/basicTypes/Id.lhs +++ b/ghc/compiler/basicTypes/Id.lhs @@ -104,7 +104,7 @@ import Name ( Name, OccName, mkSysLocalName, mkLocalName, getOccName, getSrcLoc ) -import OccName ( UserFS, mkWorkerOcc ) +import OccName ( EncodedFS, UserFS, mkWorkerOcc ) import PrimRep ( PrimRep ) import TysPrim ( statePrimTyCon ) import FieldLabel ( FieldLabel ) @@ -160,9 +160,11 @@ mkLocalId name ty = mkLocalIdWithInfo name ty vanillaIdInfo -- 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 @@ -175,7 +177,7 @@ instantiated before use. \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. @@ -193,7 +195,7 @@ mkTemplateLocalsNum :: Int -> [Type] -> [Id] 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} diff --git a/ghc/compiler/basicTypes/Literal.lhs b/ghc/compiler/basicTypes/Literal.lhs index 2167ba0257..76b7e48895 100644 --- a/ghc/compiler/basicTypes/Literal.lhs +++ b/ghc/compiler/basicTypes/Literal.lhs @@ -36,6 +36,7 @@ import CStrings ( pprFSInCStyle ) import Outputable import FastTypes +import Binary import Util ( thenCmp ) import Ratio ( numerator ) @@ -122,6 +123,60 @@ data Literal | 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 diff --git a/ghc/compiler/basicTypes/MkId.lhs b/ghc/compiler/basicTypes/MkId.lhs index 8562ea7ba2..acf6d19e21 100644 --- a/ghc/compiler/basicTypes/MkId.lhs +++ b/ghc/compiler/basicTypes/MkId.lhs @@ -547,7 +547,7 @@ rebuildConArgs (arg:args) (str:stricts) us (_, 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 @@ -787,7 +787,7 @@ another gun with which to shoot yourself in the foot. \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 @@ -802,13 +802,13 @@ unsafeCoerceId -- 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 @@ -824,7 +824,7 @@ evaluate its argument and call the dataToTag# primitive. \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 @@ -849,7 +849,7 @@ This comes up in strictness analysis \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 @@ -858,7 +858,7 @@ realWorldPrimId -- :: State# RealWorld -- to be inlined voidArgId -- :: State# RealWorld - = mkSysLocal SLIT("void") voidArgIdKey realWorldStatePrimTy + = mkSysLocal FSLIT("void") voidArgIdKey realWorldStatePrimTy \end{code} @@ -885,31 +885,31 @@ templates, but we don't ever expect to generate code for it. \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} diff --git a/ghc/compiler/basicTypes/Module.hi-boot-5 b/ghc/compiler/basicTypes/Module.hi-boot-5 new file mode 100644 index 0000000000..cdc5fbf581 --- /dev/null +++ b/ghc/compiler/basicTypes/Module.hi-boot-5 @@ -0,0 +1,4 @@ +__interface Module 1 0 where +__export Module Module ; +1 data Module ; + diff --git a/ghc/compiler/basicTypes/Module.hi-boot-6 b/ghc/compiler/basicTypes/Module.hi-boot-6 new file mode 100644 index 0000000000..cdc5fbf581 --- /dev/null +++ b/ghc/compiler/basicTypes/Module.hi-boot-6 @@ -0,0 +1,4 @@ +__interface Module 1 0 where +__export Module Module ; +1 data Module ; + diff --git a/ghc/compiler/basicTypes/Module.lhs b/ghc/compiler/basicTypes/Module.lhs index ad73495e6f..0e81b9d10e 100644 --- a/ghc/compiler/basicTypes/Module.lhs +++ b/ghc/compiler/basicTypes/Module.lhs @@ -92,6 +92,7 @@ import FastString ( FastString ) import Unique ( Uniquable(..) ) import UniqFM import UniqSet +import Binary \end{code} @@ -117,6 +118,10 @@ renamer href here.) \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 @@ -131,12 +136,12 @@ data PackageInfo 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 @@ -180,6 +185,10 @@ newtype ModuleName = ModuleName EncodedFS -- 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 diff --git a/ghc/compiler/basicTypes/Name.lhs b/ghc/compiler/basicTypes/Name.lhs index c47d4802d7..79c9625a0e 100644 --- a/ghc/compiler/basicTypes/Name.lhs +++ b/ghc/compiler/basicTypes/Name.lhs @@ -35,11 +35,13 @@ module Name ( 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} @@ -180,7 +182,7 @@ mkKnownKeyGlobal rdr_name uniq 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 } @@ -267,6 +269,26 @@ instance NamedThing Name where 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} %************************************************************************ %* * diff --git a/ghc/compiler/basicTypes/OccName.lhs b/ghc/compiler/basicTypes/OccName.lhs index faf7aa8988..66e158cedc 100644 --- a/ghc/compiler/basicTypes/OccName.lhs +++ b/ghc/compiler/basicTypes/OccName.lhs @@ -1,3 +1,4 @@ +{-% DrIFT (Automatic class derivations for Haskell) v1.1 %-} % % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % @@ -14,7 +15,8 @@ module OccName ( 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, @@ -45,6 +47,8 @@ import Util ( thenCmp ) import Unique ( Unique ) import FiniteMap ( FiniteMap, emptyFM, lookupFM, addToFM, elemFM ) import Outputable +import Binary + import GlaExts \end{code} @@ -89,6 +93,7 @@ data NameSpace = VarName -- Variables | 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 @@ -119,6 +124,7 @@ nameSpaceString TcClsName = "Type constructor or class" data OccName = OccName NameSpace EncodedFS + {-! derive : Binary !-} \end{code} @@ -188,6 +194,9 @@ mkOccFS occ_sp fs = mkSysOccFS occ_sp (encodeFS fs) mkVarOcc :: UserFS -> OccName mkVarOcc fs = mkSysOccFS varName (encodeFS fs) + +mkVarOccEncoded :: EncodedFS -> OccName +mkVarOccEncoded fs = mkSysOccFS varName fs \end{code} @@ -613,9 +622,9 @@ isLexSym cs = isLexConSym cs || isLexVarSym cs ------------- 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" @@ -623,7 +632,7 @@ isLexVarId cs -- Ordinary prefix identifiers 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 @@ -645,3 +654,34 @@ isUpperISO (C# c#) = c# `geChar#` '\xc0'# && c# `leChar#` '\xde'# && c# `neCh 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} diff --git a/ghc/compiler/basicTypes/RdrName.lhs b/ghc/compiler/basicTypes/RdrName.lhs index aa54142bbc..6903e6c4a2 100644 --- a/ghc/compiler/basicTypes/RdrName.lhs +++ b/ghc/compiler/basicTypes/RdrName.lhs @@ -1,3 +1,4 @@ +{-% DrIFT (Automatic class derivations for Haskell) v1.1 %-} % % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % @@ -40,6 +41,7 @@ import Module ( ModuleName, ) import FiniteMap import Outputable +import Binary import Util ( thenCmp ) \end{code} @@ -52,16 +54,20 @@ import Util ( thenCmp ) \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} @@ -126,8 +132,8 @@ mkRdrNameWkr (RdrName qual occ) = RdrName qual (mkWorkerOcc occ) -- 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} @@ -214,3 +220,35 @@ rdrEnvToList = fmToList 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} diff --git a/ghc/compiler/basicTypes/Var.lhs b/ghc/compiler/basicTypes/Var.lhs index 6e481a763d..3d3f9c962b 100644 --- a/ghc/compiler/basicTypes/Var.lhs +++ b/ghc/compiler/basicTypes/Var.lhs @@ -195,7 +195,7 @@ mkSysTyVar uniq kind = Var { varName = name , 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 diff --git a/ghc/compiler/coreSyn/CorePrep.lhs b/ghc/compiler/coreSyn/CorePrep.lhs index 3d4caf236d..957eeb009c 100644 --- a/ghc/compiler/coreSyn/CorePrep.lhs +++ b/ghc/compiler/coreSyn/CorePrep.lhs @@ -764,5 +764,5 @@ newVar :: Type -> UniqSM Id newVar ty = seqType ty `seq` getUniqueUs `thenUs` \ uniq -> - returnUs (mkSysLocal SLIT("sat") uniq ty) + returnUs (mkSysLocal FSLIT("sat") uniq ty) \end{code} diff --git a/ghc/compiler/coreSyn/CoreUtils.lhs b/ghc/compiler/coreSyn/CoreUtils.lhs index 87709fdfcc..ab99d49a64 100644 --- a/ghc/compiler/coreSyn/CoreUtils.lhs +++ b/ghc/compiler/coreSyn/CoreUtils.lhs @@ -863,7 +863,7 @@ eta_expand n us expr ty 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 -> diff --git a/ghc/compiler/deSugar/DsForeign.lhs b/ghc/compiler/deSugar/DsForeign.lhs index d5b25f5257..93debb9717 100644 --- a/ghc/compiler/deSugar/DsForeign.lhs +++ b/ghc/compiler/deSugar/DsForeign.lhs @@ -28,6 +28,7 @@ import Name ( mkGlobalName, nameModule, nameOccName, getOccString, mkForeignExportOcc, isLocalName, NamedThing(..), ) +import OccName ( encodeFS ) import Type ( repType, eqType ) import TcType ( Type, mkFunTys, mkForAllTys, mkTyConApp, mkFunTy, applyTy, @@ -200,7 +201,7 @@ dsFCall mod_Name fn_id fcall 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 diff --git a/ghc/compiler/deSugar/DsMonad.lhs b/ghc/compiler/deSugar/DsMonad.lhs index 6fc4aa7494..d15f621ff3 100644 --- a/ghc/compiler/deSugar/DsMonad.lhs +++ b/ghc/compiler/deSugar/DsMonad.lhs @@ -139,13 +139,13 @@ it easier to read debugging output. 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 diff --git a/ghc/compiler/ghci/ByteCodeGen.lhs b/ghc/compiler/ghci/ByteCodeGen.lhs index 6d587bb007..1f631d87e4 100644 --- a/ghc/compiler/ghci/ByteCodeGen.lhs +++ b/ghc/compiler/ghci/ByteCodeGen.lhs @@ -115,8 +115,9 @@ coreExprToBCOs dflags expr -- 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 @@ -641,16 +642,14 @@ schemeT d s p app ) -- 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 diff --git a/ghc/compiler/main/CmdLineOpts.lhs b/ghc/compiler/main/CmdLineOpts.lhs index ea6ea711ec..7137d6345c 100644 --- a/ghc/compiler/main/CmdLineOpts.lhs +++ b/ghc/compiler/main/CmdLineOpts.lhs @@ -120,6 +120,7 @@ import IOExts ( IORef, readIORef, writeIORef ) import Constants -- Default values for some flags import Util import FastTypes +import FastString ( FastString, mkFastString ) import Config import Maybes ( firstJust ) @@ -496,14 +497,14 @@ minusWallOpts -- 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 @@ -547,38 +548,38 @@ unpacked_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) {- @@ -588,44 +589,44 @@ 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} %************************************************************************ @@ -664,7 +665,6 @@ isStaticHscFlag f = "fno-hi-version-check", "dno-black-holing", "fno-method-sharing", - "fno-monomorphism-restriction", "fomit-interface-pragmas", "fruntime-types", "fno-pre-inlining", diff --git a/ghc/compiler/main/DriverFlags.hs b/ghc/compiler/main/DriverFlags.hs index bfb3c00880..ec885f944e 100644 --- a/ghc/compiler/main/DriverFlags.hs +++ b/ghc/compiler/main/DriverFlags.hs @@ -1,7 +1,7 @@ {-# 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 -- @@ -19,6 +19,8 @@ module DriverFlags ( #include "HsVersions.h" #include "../includes/config.h" +import BinIface ( compileIface ) +import MkIface ( showIface ) import DriverState import DriverPhases import DriverUtil @@ -163,6 +165,12 @@ static_flags = , ( "-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 ) @@ -268,7 +276,17 @@ static_flags = , ( "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) ) diff --git a/ghc/compiler/main/DriverPhases.hs b/ghc/compiler/main/DriverPhases.hs index f212947857..64344958e5 100644 --- a/ghc/compiler/main/DriverPhases.hs +++ b/ghc/compiler/main/DriverPhases.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- $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 -- @@ -16,6 +16,7 @@ module DriverPhases ( haskellish_file, haskellish_suffix, haskellish_src_file, haskellish_src_suffix, + hsbootish_file, hsbootish_suffix, objish_file, objish_suffix, cish_file, cish_suffix ) where @@ -43,6 +44,7 @@ data Phase | Cpp | HsPp | Hsc + | HsBoot | Cc | HCc -- Haskellised C (as opposed to vanilla C) compilation | Mangle -- assembly mangling, now done by a separate script. @@ -62,6 +64,7 @@ startPhase "lhs" = Unlit startPhase "hs" = Cpp startPhase "hscpp" = HsPp startPhase "hspp" = Hsc +startPhase "hs-boot" = HsBoot startPhase "hc" = HCc startPhase "c" = Cc startPhase "cpp" = Cc @@ -88,6 +91,7 @@ phaseInputExt As = "s" 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" @@ -96,6 +100,7 @@ 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" ]) @@ -107,3 +112,4 @@ haskellish_file = haskellish_suffix . getFileSuffix haskellish_src_file = haskellish_src_suffix . getFileSuffix cish_file = cish_suffix . getFileSuffix objish_file = objish_suffix . getFileSuffix +hsbootish_file = hsbootish_suffix . getFileSuffix diff --git a/ghc/compiler/main/HscTypes.lhs b/ghc/compiler/main/HscTypes.lhs index 6077dda10c..ad4344a3cd 100644 --- a/ghc/compiler/main/HscTypes.lhs +++ b/ghc/compiler/main/HscTypes.lhs @@ -21,7 +21,7 @@ module HscTypes ( IfaceDecls, mkIfaceDecls, dcl_tycl, dcl_rules, dcl_insts, VersionInfo(..), initialVersionInfo, lookupVersion, - FixityEnv, lookupFixity, + FixityEnv, lookupFixity, collectFixities, TyThing(..), isTyClThing, implicitTyThingIds, @@ -35,6 +35,7 @@ module HscTypes ( NameSupply(..), OrigNameCache, OrigIParamCache, Avails, AvailEnv, emptyAvailEnv, GenAvailInfo(..), AvailInfo, RdrAvailInfo, + ExportItem, RdrExportItem, PersistentCompilerState(..), Deprecations(..), lookupDeprec, @@ -70,13 +71,14 @@ import DataCon ( dataConId, dataConWrapId ) 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 @@ -170,7 +172,7 @@ data ModIface -- 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 @@ -477,11 +479,14 @@ data GenAvailInfo name = Avail name -- An ordinary identifier 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 @@ -498,6 +503,13 @@ type FixityEnv = NameEnv Fixity 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} diff --git a/ghc/compiler/main/Main.hs b/ghc/compiler/main/Main.hs index 1e7e16a12c..cc7e80f08e 100644 --- a/ghc/compiler/main/Main.hs +++ b/ghc/compiler/main/Main.hs @@ -1,7 +1,7 @@ {-# 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 -- @@ -107,7 +107,10 @@ main = 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 diff --git a/ghc/compiler/main/MkIface.lhs b/ghc/compiler/main/MkIface.lhs index bce2bb3c3e..fc7de58d29 100644 --- a/ghc/compiler/main/MkIface.lhs +++ b/ghc/compiler/main/MkIface.lhs @@ -6,8 +6,8 @@ \begin{code} module MkIface ( - mkFinalIface, - pprModDetails, pprIface, pprUsage, + showIface, mkFinalIface, + pprModDetails, pprIface, pprUsage, pprUsages, pprExports, ifaceTyThing, ) where @@ -24,9 +24,11 @@ import NewDemand ( isTopSig ) 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 @@ -56,16 +58,55 @@ import SrcLoc ( noSrcLoc ) 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} %* * %************************************************************************ @@ -100,7 +141,8 @@ mkFinalIface ghci_mode dflags location maybe_old_iface -- 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 @@ -519,7 +561,7 @@ writeIface hi_path mod_iface -- 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") @@ -530,8 +572,8 @@ pprIface iface <+> 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 @@ -541,6 +583,7 @@ pprIface iface 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 @@ -553,18 +596,22 @@ When printing export lists, we print like this: 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) @@ -572,8 +619,11 @@ 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 @@ -587,8 +637,9 @@ pprUsage (m, has_orphans, is_boot, 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 @@ -610,15 +661,12 @@ pprIfaceDecls version_map decls \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. diff --git a/ghc/compiler/main/SysTools.lhs b/ghc/compiler/main/SysTools.lhs index cb4a6e73d2..38766257bc 100644 --- a/ghc/compiler/main/SysTools.lhs +++ b/ghc/compiler/main/SysTools.lhs @@ -10,7 +10,18 @@ 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, @@ -408,27 +419,25 @@ foreign import stdcall "GetTempPathA" unsafe getTempPath :: Int -> CString -> IO #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} diff --git a/ghc/compiler/ndpFlatten/FlattenMonad.hs b/ghc/compiler/ndpFlatten/FlattenMonad.hs index 1a6955e26a..874f02048b 100644 --- a/ghc/compiler/ndpFlatten/FlattenMonad.hs +++ b/ghc/compiler/ndpFlatten/FlattenMonad.hs @@ -82,10 +82,11 @@ import HscTypes (HomeSymbolTable, PersistentCompilerState(..), 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) @@ -384,10 +385,10 @@ mk'neq ty a1 a2 = mkFunApp neqName [a1, a2] 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) diff --git a/ghc/compiler/parser/ParseUtil.lhs b/ghc/compiler/parser/ParseUtil.lhs index 04fd6dfaf8..f65fdd2b8c 100644 --- a/ghc/compiler/parser/ParseUtil.lhs +++ b/ghc/compiler/parser/ParseUtil.lhs @@ -210,7 +210,7 @@ checkPat e [] = case e of | 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 -> @@ -340,9 +340,9 @@ parseCImport :: FAST_STRING -> 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 diff --git a/ghc/compiler/parser/Parser.y b/ghc/compiler/parser/Parser.y index 481500f53d..38a2daee4e 100644 --- a/ghc/compiler/parser/Parser.y +++ b/ghc/compiler/parser/Parser.y @@ -1,6 +1,6 @@ {- -*-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. @@ -1217,35 +1217,35 @@ qvarid :: { RdrName } 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 @@ -1283,7 +1283,7 @@ qvarsym1 : QVARSYM { mkQual varName $1 } varsym :: { RdrName } : varsym_no_minus { $1 } - | '-' { mkUnqual varName SLIT("-") } + | '-' { mkUnqual varName FSLIT("-") } varsym_no_minus :: { RdrName } -- varsym not including '-' : VARSYM { mkUnqual varName $1 } @@ -1292,9 +1292,9 @@ varsym_no_minus :: { RdrName } -- varsym not including '-' -- See comments with special_id special_sym :: { UserFS } -special_sym : '!' { SLIT("!") } - | '.' { SLIT(".") } - | '*' { SLIT("*") } +special_sym : '!' { FSLIT("!") } + | '.' { FSLIT(".") } + | '*' { FSLIT("*") } ----------------------------------------------------------------------------- -- Literals diff --git a/ghc/compiler/prelude/ForeignCall.lhs b/ghc/compiler/prelude/ForeignCall.lhs index 6be1b5e3b6..55ae707839 100644 --- a/ghc/compiler/prelude/ForeignCall.lhs +++ b/ghc/compiler/prelude/ForeignCall.lhs @@ -1,3 +1,5 @@ +{-% 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 % @@ -22,6 +24,7 @@ module ForeignCall ( import CStrings ( CLabelString, pprCLabelString ) import FastString ( FastString ) +import Binary import Outputable \end{code} @@ -38,6 +41,7 @@ data ForeignCall | 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 @@ -61,6 +65,7 @@ data Safety -- 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") @@ -88,12 +93,14 @@ data CExportSpec = 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: @@ -104,6 +111,7 @@ data CCallTarget | 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 @@ -128,7 +136,8 @@ platforms. \begin{code} data CCallConv = CCallConv | StdCallConv - deriving (Eq) + deriving (Eq) + {-! derive: Binary !-} instance Outputable CCallConv where ppr StdCallConv = ptext SLIT("stdcall") @@ -180,7 +189,8 @@ instance Outputable CCallSpec where \begin{code} data DNCallSpec = DNCallSpec FastString - deriving (Eq) + deriving (Eq) + {-! derive: Binary !-} instance Outputable DNCallSpec where ppr (DNCallSpec s) = char '"' <> ptext s <> char '"' @@ -201,3 +211,92 @@ okToExposeFCall :: ForeignCall -> Bool 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} diff --git a/ghc/compiler/prelude/PrelNames.lhs b/ghc/compiler/prelude/PrelNames.lhs index daa0495185..883ce56fa1 100644 --- a/ghc/compiler/prelude/PrelNames.lhs +++ b/ghc/compiler/prelude/PrelNames.lhs @@ -66,7 +66,7 @@ import Panic ( panic ) 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} @@ -211,15 +211,7 @@ knownKeyNames -- Others (needed for flattening and not mentioned before) andName, - orName, - eqCharName, - eqIntName, - eqFloatName, - eqDoubleName, - neqCharName, - neqIntName, - neqFloatName, - neqDoubleName + orName ] \end{code} @@ -232,7 +224,8 @@ knownKeyNames \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" @@ -267,7 +260,8 @@ aDDR_Name = mkModuleName "Addr" 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 @@ -292,7 +286,7 @@ iNTERACTIVE = mkHomeModule (mkModuleName "$Interactive") \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 @@ -300,11 +294,11 @@ mkTupNameStr Boxed 4 = (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 @@ -320,7 +314,7 @@ 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. @@ -338,246 +332,238 @@ compiler (notably the deriving mechanism) need to mention their names, 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} %************************************************************************ @@ -602,44 +588,44 @@ tupleTyCon_RDR = mkTupConRdrName tcName Boxed 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 @@ -938,16 +924,6 @@ runMainKey = mkPreludeMiscIdUnique 56 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 diff --git a/ghc/compiler/prelude/PrimOp.lhs b/ghc/compiler/prelude/PrimOp.lhs index 4b4f0cc1f2..c087f391d9 100644 --- a/ghc/compiler/prelude/PrimOp.lhs +++ b/ghc/compiler/prelude/PrimOp.lhs @@ -15,7 +15,9 @@ module PrimOp ( primOpOkForSpeculation, primOpIsCheap, primOpIsDupable, primOpHasSideEffects, - getPrimOpResultInfo, PrimOpResultInfo(..) + getPrimOpResultInfo, PrimOpResultInfo(..), + + eqCharName, eqIntName, eqFloatName, eqDoubleName, neqIntName, ) where #include "HsVersions.h" @@ -477,4 +479,12 @@ pprPrimOp other_op 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} diff --git a/ghc/compiler/profiling/SCCfinal.lhs b/ghc/compiler/profiling/SCCfinal.lhs index 38ca2bda2e..41de1f9101 100644 --- a/ghc/compiler/profiling/SCCfinal.lhs +++ b/ghc/compiler/profiling/SCCfinal.lhs @@ -295,7 +295,7 @@ boxHigherOrderArgs almost_expr args = -- 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 diff --git a/ghc/compiler/rename/ParseIface.y b/ghc/compiler/rename/ParseIface.y index 0d01d6a637..0cc4a48a4d 100644 --- a/ghc/compiler/rename/ParseIface.y +++ b/ghc/compiler/rename/ParseIface.y @@ -46,10 +46,10 @@ import Type ( Kind, mkArrowKind, liftedTypeKind, openTypeKind, usageTypeKind ) 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(..) ) @@ -244,7 +244,7 @@ name_version_pair : var_occ version { ($1, $2) } -------------------------------------------------------------------------- -exports_part :: { [ExportItem] } +exports_part :: { [RdrExportItem] } exports_part : { [] } | '__export' mod_name entities ';' exports_part { ({-mkSysModuleNameFS-} $2, $3) : $5 } @@ -274,16 +274,16 @@ val_occs :: { [OccName] } -------------------------------------------------------------------------- -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 } @@ -590,18 +590,18 @@ mod_name :: { ModuleName } --------------------------------------------------- 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 } @@ -686,9 +686,9 @@ kind :: { Kind } 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" } diff --git a/ghc/compiler/rename/RnExpr.lhs b/ghc/compiler/rename/RnExpr.lhs index def67b5fd5..136ad85fdb 100644 --- a/ghc/compiler/rename/RnExpr.lhs +++ b/ghc/compiler/rename/RnExpr.lhs @@ -906,7 +906,7 @@ mkAssertExpr = 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 diff --git a/ghc/compiler/rename/RnHiFiles.lhs b/ghc/compiler/rename/RnHiFiles.lhs index 7c405de334..87bbbeb44c 100644 --- a/ghc/compiler/rename/RnHiFiles.lhs +++ b/ghc/compiler/rename/RnHiFiles.lhs @@ -22,14 +22,14 @@ import CmdLineOpts ( opt_IgnoreIfacePragmas ) 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 ) @@ -57,10 +57,16 @@ import FiniteMap 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} @@ -278,13 +284,13 @@ addModDeps mod is_loaded new_deps mod_deps -- 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) @@ -336,7 +342,7 @@ loadFixDecls mod decls 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) @@ -554,15 +560,31 @@ readIface file_path = --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} diff --git a/ghc/compiler/rename/RnMonad.lhs b/ghc/compiler/rename/RnMonad.lhs index 35a5a568fa..5fff141b20 100644 --- a/ghc/compiler/rename/RnMonad.lhs +++ b/ghc/compiler/rename/RnMonad.lhs @@ -39,12 +39,12 @@ import RnHsSyn ( RenamedFixitySig ) 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, @@ -202,13 +202,13 @@ lookupLocalFixity env name 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 @@ -221,9 +221,9 @@ data ParsedIface 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 diff --git a/ghc/compiler/simplCore/SimplUtils.lhs b/ghc/compiler/simplCore/SimplUtils.lhs index 6a1034f011..9fcfb707d5 100644 --- a/ghc/compiler/simplCore/SimplUtils.lhs +++ b/ghc/compiler/simplCore/SimplUtils.lhs @@ -40,7 +40,7 @@ import Type ( Type, seqType, splitRepFunTys, isStrictType, 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 ) @@ -471,7 +471,7 @@ seqBndr b | isTyVar b = b `seq` () \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} @@ -889,7 +889,7 @@ mk_args missing_con inst_tys 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} diff --git a/ghc/compiler/simplCore/Simplify.lhs b/ghc/compiler/simplCore/Simplify.lhs index 293f1be0d4..f5af0d1693 100644 --- a/ghc/compiler/simplCore/Simplify.lhs +++ b/ghc/compiler/simplCore/Simplify.lhs @@ -26,6 +26,7 @@ import Id ( Id, idType, idInfo, idArity, isDataConId, idNewDemandInfo, setIdInfo, setIdOccInfo, zapLamIdInfo, setOneShotLambda, ) +import OccName ( encodeFS ) import IdInfo ( OccInfo(..), isLoopBreaker, setArityInfo, setUnfoldingInfo, @@ -1139,7 +1140,7 @@ mkAtomicArgs is_strict ok_float_unlifted rhs | 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 @@ -1552,7 +1553,7 @@ mkDupableCont env (ApplyTo _ arg se cont) 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, @@ -1671,14 +1672,14 @@ mkDupableAlt env case_bndr' cont alt@(con, bndrs, rhs) -- (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. diff --git a/ghc/compiler/specialise/SpecConstr.lhs b/ghc/compiler/specialise/SpecConstr.lhs index 45f946986c..6622764ca9 100644 --- a/ghc/compiler/specialise/SpecConstr.lhs +++ b/ghc/compiler/specialise/SpecConstr.lhs @@ -561,7 +561,7 @@ argToPat env us (Var v) -- Don't uniqify existing vars, = (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 diff --git a/ghc/compiler/stranal/WwLib.lhs b/ghc/compiler/stranal/WwLib.lhs index b18202830a..fa6c806b6f 100644 --- a/ghc/compiler/stranal/WwLib.lhs +++ b/ghc/compiler/stranal/WwLib.lhs @@ -281,7 +281,7 @@ applyToVars :: [Var] -> CoreExpr -> CoreExpr 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 @@ -506,5 +506,5 @@ sanitiseCaseBndr :: 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} diff --git a/ghc/compiler/typecheck/Inst.lhs b/ghc/compiler/typecheck/Inst.lhs index 3805b9b3d3..3e93da167d 100644 --- a/ghc/compiler/typecheck/Inst.lhs +++ b/ghc/compiler/typecheck/Inst.lhs @@ -424,7 +424,7 @@ newOverloadedLit orig lit ty 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) diff --git a/ghc/compiler/typecheck/TcGenDeriv.lhs b/ghc/compiler/typecheck/TcGenDeriv.lhs index 175973b308..4f20887c95 100644 --- a/ghc/compiler/typecheck/TcGenDeriv.lhs +++ b/ghc/compiler/typecheck/TcGenDeriv.lhs @@ -1326,17 +1326,17 @@ genOpApp e1 op e2 = mkHsOpApp e1 op e2 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) .. ] ] diff --git a/ghc/compiler/typecheck/TcMType.lhs b/ghc/compiler/typecheck/TcMType.lhs index d91312d67c..4df29b264d 100644 --- a/ghc/compiler/typecheck/TcMType.lhs +++ b/ghc/compiler/typecheck/TcMType.lhs @@ -101,7 +101,7 @@ import Outputable 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 @@ -110,7 +110,7 @@ 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] @@ -119,7 +119,7 @@ newTyVarTys n kind = mapNF_Tc newTyVarTy (nOfThem n kind) 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] @@ -128,7 +128,7 @@ newKindVars n = mapNF_Tc (\ _ -> newKindVar) (nOfThem n ()) 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} diff --git a/ghc/compiler/typecheck/TcPat.lhs b/ghc/compiler/typecheck/TcPat.lhs index a662f3c61a..e436485ea9 100644 --- a/ghc/compiler/typecheck/TcPat.lhs +++ b/ghc/compiler/typecheck/TcPat.lhs @@ -473,7 +473,7 @@ tcSubPat sig_ty exp_ty 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 diff --git a/ghc/compiler/typecheck/TcUnify.lhs b/ghc/compiler/typecheck/TcUnify.lhs index 2cf985ed3a..100b2f260e 100644 --- a/ghc/compiler/typecheck/TcUnify.lhs +++ b/ghc/compiler/typecheck/TcUnify.lhs @@ -221,7 +221,7 @@ tcSub_fun exp_arg exp_res act_arg act_res -- 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 diff --git a/ghc/compiler/types/TypeRep.lhs b/ghc/compiler/types/TypeRep.lhs index cf1d440c56..17ae62fbf9 100644 --- a/ghc/compiler/types/TypeRep.lhs +++ b/ghc/compiler/types/TypeRep.lhs @@ -36,6 +36,7 @@ import Name ( Name ) import BasicTypes ( IPName ) import TyCon ( TyCon, KindCon, mkFunTyCon, mkKindCon, mkSuperKindCon ) import Class ( Class ) +import Binary -- others import PrelNames ( superKindName, superBoxityName, liftedConName, @@ -172,6 +173,7 @@ data TyNote | 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} ------------------------------------- @@ -286,9 +288,11 @@ Define boxities: @*@ and @#@ \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} ------------------------------------------ @@ -321,6 +325,29 @@ mkArrowKinds :: [Kind] -> Kind -> Kind 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} %************************************************************************ %* * diff --git a/ghc/compiler/utils/Binary.hs b/ghc/compiler/utils/Binary.hs new file mode 100644 index 0000000000..a963c0c7d3 --- /dev/null +++ b/ghc/compiler/utils/Binary.hs @@ -0,0 +1,679 @@ +{-# 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) diff --git a/ghc/compiler/utils/FastString.lhs b/ghc/compiler/utils/FastString.lhs index 86b2a8a444..a774243398 100644 --- a/ghc/compiler/utils/FastString.lhs +++ b/ghc/compiler/utils/FastString.lhs @@ -22,7 +22,7 @@ module FastString mkFastCharString#, -- :: Addr# -> FastString mkFastCharString2, -- :: Addr -> Int -> FastString - mkFastString#, -- :: Addr# -> Int# -> FastString + mkFastString#, -- :: Addr# -> FastString mkFastSubStringBA#, -- :: ByteArray# -> Int# -> Int# -> FastString mkFastSubString#, -- :: Addr# -> Int# -> Int# -> FastString @@ -112,8 +112,22 @@ data 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 } @@ -193,7 +207,7 @@ consFS c fs = mkFastStringInt (ord c : unpackIntFS fs) 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 @@ -244,8 +258,12 @@ updTbl fs_table_var (FastStringTable uid# arr#) i# ls = (# 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 @@ -409,7 +427,7 @@ mkFastStringInt str = if all good str 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} diff --git a/ghc/compiler/utils/StringBuffer.lhs b/ghc/compiler/utils/StringBuffer.lhs index d5ea832a82..d89b9386c2 100644 --- a/ghc/compiler/utils/StringBuffer.lhs +++ b/ghc/compiler/utils/StringBuffer.lhs @@ -523,7 +523,7 @@ lexemeToByteArray (StringBuffer fo _ start_pos# current#) = 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#)) |