diff options
86 files changed, 630 insertions, 680 deletions
diff --git a/ghc/compiler/HsVersions.h b/ghc/compiler/HsVersions.h index 4900e5663a..40a58517b4 100644 --- a/ghc/compiler/HsVersions.h +++ b/ghc/compiler/HsVersions.h @@ -37,8 +37,6 @@ name = Util.global (value) :: IORef (ty); \ #define UASSERT2(e,msg) #endif -#if __GLASGOW_HASKELL__ >= 23 - -- This #ifndef lets us switch off the "import FastString" -- when compiling FastString itself #ifndef COMPILING_FAST_STRING @@ -46,36 +44,7 @@ name = Util.global (value) :: IORef (ty); \ import qualified FastString #endif -# 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 -# define _HEAD_ FastString.headFS -# define _HEAD_INT_ FastString.headIntFS -# define _TAIL_ FastString.tailFS -# define _LENGTH_ FastString.lengthFS -# define _PK_ FastString.mkFastString -# define _UNPK_ FastString.unpackFS -# define _UNPK_INT_ FastString.unpackIntFS -# define _APPEND_ `FastString.appendFS` -#else -# error I think that FastString is now always used. If not, fix this. -# define FAST_STRING String -# define SLIT(x) (x) -# define _CMP_STRING_ cmpString -# define _NULL_ null -# define _NIL_ "" -# define _CONS_ (:) -# define _HEAD_ head -# define _TAIL_ tail -# define _LENGTH_ length -# define _PK_ (\x->x) -# define _UNPK_ (\x->x) -# define _SUBSTR_ substr{-from Utils-} -# define _APPEND_ ++ -#endif +#define SLIT(x) (FastString.mkLitString# (x#)) +#define FSLIT(x) (FastString.mkFastString# (x#)) -#endif +#endif // HSVERSIONS_H diff --git a/ghc/compiler/absCSyn/AbsCSyn.lhs b/ghc/compiler/absCSyn/AbsCSyn.lhs index 36d3db7e6e..2389512c77 100644 --- a/ghc/compiler/absCSyn/AbsCSyn.lhs +++ b/ghc/compiler/absCSyn/AbsCSyn.lhs @@ -1,7 +1,7 @@ % % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -% $Id: AbsCSyn.lhs,v 1.46 2002/03/02 18:02:30 sof Exp $ +% $Id: AbsCSyn.lhs,v 1.47 2002/04/29 14:03:39 simonmar Exp $ % \section[AbstractC]{Abstract C: the last stop before machine code} @@ -53,8 +53,7 @@ import StgSyn ( StgOp ) import TyCon ( TyCon ) import BitSet -- for liveness masks import FastTypes - -import Outputable +import FastString \end{code} @AbstractC@ is a list of Abstract~C statements, but the data structure @@ -174,8 +173,8 @@ stored in a mixed type location.) -- see the notes about these next few; they follow below... | CMacroStmt CStmtMacro [CAddrMode] - | CCallProfCtrMacro FAST_STRING [CAddrMode] - | CCallProfCCMacro FAST_STRING [CAddrMode] + | CCallProfCtrMacro FastString [CAddrMode] + | CCallProfCCMacro FastString [CAddrMode] {- The presence of this constructor is a makeshift solution; it being used to work around a gcc-related problem of @@ -401,7 +400,7 @@ Convenience functions: mkIntCLit :: Int -> CAddrMode mkIntCLit i = CLit (mkMachInt (toInteger i)) -mkCString :: FAST_STRING -> CAddrMode +mkCString :: FastString -> CAddrMode mkCString s = CLit (MachStr s) mkCCostCentre :: CostCentre -> CAddrMode diff --git a/ghc/compiler/absCSyn/AbsCUtils.lhs b/ghc/compiler/absCSyn/AbsCUtils.lhs index 5643da8309..90988cdebc 100644 --- a/ghc/compiler/absCSyn/AbsCUtils.lhs +++ b/ghc/compiler/absCSyn/AbsCUtils.lhs @@ -367,7 +367,7 @@ flatAbsC stmt@(CCheck macro amodes code) -- the TICKY_CTR macro always needs to be hoisted out to the top level. -- This is a HACK. flatAbsC stmt@(CCallProfCtrMacro str amodes) - | str == SLIT("TICK_CTR") = returnFlt (AbsCNop, stmt) + | str == FSLIT("TICK_CTR") = returnFlt (AbsCNop, stmt) | otherwise = returnFlt (stmt, AbsCNop) -- Some statements need no flattening at all: @@ -401,7 +401,7 @@ flatAbsC stmt@(COpStmt results (StgPrimOp op) args vol_regs) = COpStmt [] (StgFCallOp - (CCall (CCallSpec (CasmTarget (_PK_ (mktxt op_str))) + (CCall (CCallSpec (CasmTarget (mkFastString (mktxt op_str))) defaultCCallConv (PlaySafe False))) uu ) diff --git a/ghc/compiler/absCSyn/CLabel.lhs b/ghc/compiler/absCSyn/CLabel.lhs index b56db8d269..a26d9d7a51 100644 --- a/ghc/compiler/absCSyn/CLabel.lhs +++ b/ghc/compiler/absCSyn/CLabel.lhs @@ -1,7 +1,7 @@ % % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -% $Id: CLabel.lhs,v 1.51 2002/03/14 15:27:15 simonpj Exp $ +% $Id: CLabel.lhs,v 1.52 2002/04/29 14:03:39 simonmar Exp $ % \section[CLabel]{@CLabel@: Information to make C Labels} @@ -90,6 +90,7 @@ import Unique ( pprUnique, Unique ) import PrimOp ( PrimOp ) import CostCentre ( CostCentre, CostCentreStack ) import Outputable +import FastString \end{code} things we want to find out: @@ -126,7 +127,7 @@ data CLabel | RtsLabel RtsLabelInfo - | ForeignLabel FAST_STRING Bool -- a 'C' (or otherwise foreign) label + | ForeignLabel FastString Bool -- a 'C' (or otherwise foreign) label -- Bool <=> is dynamic | CC_Label CostCentre @@ -173,7 +174,7 @@ data CaseLabelInfo data RtsLabelInfo = RtsShouldNeverHappenCode - | RtsBlackHoleInfoTbl FAST_STRING -- black hole with info table name + | RtsBlackHoleInfoTbl FastString -- black hole with info table name | RtsUpdInfo -- upd_frame_info | RtsSeqInfo -- seq_frame_info @@ -254,10 +255,10 @@ mkMAP_FROZEN_infoLabel = RtsLabel (Rts_Info "stg_MUT_ARR_PTRS_FROZEN_info") mkEMPTY_MVAR_infoLabel = RtsLabel (Rts_Info "stg_EMPTY_MVAR_info") mkTopTickyCtrLabel = RtsLabel RtsTopTickyCtr -mkBlackHoleInfoTableLabel = RtsLabel (RtsBlackHoleInfoTbl SLIT("stg_BLACKHOLE_info")) -mkCAFBlackHoleInfoTableLabel = RtsLabel (RtsBlackHoleInfoTbl SLIT("stg_CAF_BLACKHOLE_info")) +mkBlackHoleInfoTableLabel = RtsLabel (RtsBlackHoleInfoTbl FSLIT("stg_BLACKHOLE_info")) +mkCAFBlackHoleInfoTableLabel = RtsLabel (RtsBlackHoleInfoTbl FSLIT("stg_CAF_BLACKHOLE_info")) mkSECAFBlackHoleInfoTableLabel = if opt_DoTickyProfiling then - RtsLabel (RtsBlackHoleInfoTbl SLIT("stg_SE_CAF_BLACKHOLE_info")) + RtsLabel (RtsBlackHoleInfoTbl FSLIT("stg_SE_CAF_BLACKHOLE_info")) else -- RTS won't have info table unless -ticky is on panic "mkSECAFBlackHoleInfoTableLabel requires -ticky" mkRtsPrimOpLabel primop = RtsLabel (RtsPrimOp primop) @@ -272,7 +273,7 @@ mkApEntryLabel upd off = RtsLabel (RtsApEntry upd off) -- Foreign labels -mkForeignLabel :: FAST_STRING -> Bool -> CLabel +mkForeignLabel :: FastString -> Bool -> CLabel mkForeignLabel str is_dynamic = ForeignLabel str is_dynamic -- Cost centres etc. @@ -472,7 +473,7 @@ pprCLbl (RtsLabel (Rts_Code str)) = text str pprCLbl (RtsLabel RtsTopTickyCtr) = ptext SLIT("top_ct") -pprCLbl (RtsLabel (RtsBlackHoleInfoTbl info)) = ptext info +pprCLbl (RtsLabel (RtsBlackHoleInfoTbl info)) = ftext info pprCLbl (RtsLabel (RtsSelectorInfoTbl upd_reqd offset)) = hcat [ptext SLIT("stg_sel_"), text (show offset), @@ -509,7 +510,7 @@ pprCLbl (RtsLabel RtsModuleRegd) = ptext SLIT("module_registered") pprCLbl (ForeignLabel str _) - = ptext str + = ftext str pprCLbl (TyConLabel tc) = hcat [ppr tc, pp_cSEP, ptext SLIT("closure_tbl")] @@ -521,7 +522,7 @@ pprCLbl (CC_Label cc) = ppr cc pprCLbl (CCS_Label ccs) = ppr ccs pprCLbl (ModuleInitLabel mod) - = ptext SLIT("__stginit_") <> ptext (moduleNameFS (moduleName mod)) + = ptext SLIT("__stginit_") <> ftext (moduleNameFS (moduleName mod)) ppIdFlavor :: IdLabelInfo -> SDoc diff --git a/ghc/compiler/absCSyn/CStrings.lhs b/ghc/compiler/absCSyn/CStrings.lhs index 6f2a0e3570..f25e6c204f 100644 --- a/ghc/compiler/absCSyn/CStrings.lhs +++ b/ghc/compiler/absCSyn/CStrings.lhs @@ -4,7 +4,7 @@ This module deals with printing C string literals module CStrings( CLabelString, isCLabelString, pprCLabelString, - cSEP, pp_cSEP, + pp_cSEP, pprFSInCStyle, pprStringInCStyle ) where @@ -12,31 +12,32 @@ module CStrings( #include "HsVersions.h" import Char ( ord, chr, isAlphaNum ) +import FastString import Outputable \end{code} \begin{code} -type CLabelString = FAST_STRING -- A C label, completely unencoded +type CLabelString = FastString -- A C label, completely unencoded -pprCLabelString lbl = ptext lbl +pprCLabelString :: CLabelString -> SDoc +pprCLabelString lbl = ftext lbl isCLabelString :: CLabelString -> Bool -- Checks to see if this is a valid C label isCLabelString lbl - = all ok (_UNPK_ lbl) + = all ok (unpackFS lbl) where ok c = isAlphaNum c || c == '_' || c == '.' -- The '.' appears in e.g. "foo.so" in the -- module part of a ExtName. Maybe it should be separate -cSEP = SLIT("_") -- official C separator pp_cSEP = char '_' \end{code} \begin{code} -pprFSInCStyle :: FAST_STRING -> SDoc +pprFSInCStyle :: FastString -> SDoc -- Assumes it contains only characters '\0'..'\xFF'! -pprFSInCStyle fs = pprStringInCStyle (_UNPK_ fs) +pprFSInCStyle fs = pprStringInCStyle (unpackFS fs) pprStringInCStyle :: String -> SDoc pprStringInCStyle s = doubleQuotes (text (concatMap charToC s)) diff --git a/ghc/compiler/absCSyn/PprAbsC.lhs b/ghc/compiler/absCSyn/PprAbsC.lhs index df93726227..c08740cdd5 100644 --- a/ghc/compiler/absCSyn/PprAbsC.lhs +++ b/ghc/compiler/absCSyn/PprAbsC.lhs @@ -59,6 +59,7 @@ import StgSyn ( StgOp(..) ) import BitSet ( BitSet, intBS ) import Outputable import GlaExts +import FastString import Util ( lengthExceeds, listLengthCmp ) import ST @@ -309,10 +310,10 @@ pprAbsC (CMacroStmt macro as) _ = hcat [ptext (cStmtMacroText macro), lparen, hcat (punctuate comma (map ppr_amode as)),pp_paren_semi] -- no casting pprAbsC (CCallProfCtrMacro op as) _ - = hcat [ptext op, lparen, + = hcat [ftext op, lparen, hcat (punctuate comma (map ppr_amode as)),pp_paren_semi] pprAbsC (CCallProfCCMacro op as) _ - = hcat [ptext op, lparen, + = hcat [ftext op, lparen, hcat (punctuate comma (map ppr_amode as)),pp_paren_semi] pprAbsC stmt@(CCallTypedef is_tdef (CCallSpec op_str cconv _) uniq results args) _ = hsep [ ptext (if is_tdef then SLIT("typedef") else SLIT("extern")) @@ -971,7 +972,7 @@ pprFCall call@(CCall (CCallSpec target cconv safety)) uniq args results vol_regs = ppr_casm_results non_void_results call_str = case target of - CasmTarget str -> _UNPK_ str + CasmTarget str -> unpackFS str StaticTarget fn -> mk_ccall_str (pprCLabelString fn) ccall_args DynamicTarget -> mk_ccall_str dyn_fun (tail ccall_args) diff --git a/ghc/compiler/basicTypes/Literal.lhs b/ghc/compiler/basicTypes/Literal.lhs index 7954743ac6..45a3dc5286 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 FastString import Binary import Util ( thenCmp ) @@ -98,7 +99,7 @@ data Literal = ------------------ -- First the primitive guys MachChar Int -- Char# At least 31 bits - | MachStr FAST_STRING + | MachStr FastString | MachAddr Integer -- Whatever this machine thinks is a "pointer" @@ -114,13 +115,13 @@ data Literal -- "foreign label" declaration. -- string argument is the name of a symbol. This literal -- refers to the *address* of the label. - | MachLabel FAST_STRING -- always an Addr# + | MachLabel FastString -- always an Addr# -- lit-lits only work for via-C compilation, hence they -- are deprecated. The string is emitted verbatim into -- the C file, and can therefore be any C expression, -- macro call, #defined constant etc. - | MachLitLit FAST_STRING Type -- Type might be Addr# or Int# etc + | MachLitLit FastString Type -- Type might be Addr# or Int# etc \end{code} Binary instance: must do this manually, because we don't want the type @@ -399,10 +400,10 @@ pprLit lit MachAddr p | code_style -> ptext SLIT("(void*)") <> integer p | otherwise -> ptext SLIT("__addr") <+> integer p - MachLabel l | code_style -> ptext SLIT("(&") <> ptext l <> char ')' + MachLabel l | code_style -> ptext SLIT("(&") <> ftext l <> char ')' | otherwise -> ptext SLIT("__label") <+> pprHsString l - MachLitLit s ty | code_style -> ptext s + MachLitLit s ty | code_style -> ftext s | otherwise -> parens (hsep [ptext SLIT("__litlit"), pprHsString s, pprParendType ty]) @@ -457,6 +458,6 @@ hashInteger i = 1 + abs (fromInteger (i `rem` 10000)) -- The 1+ is to avoid zero, which is a Bad Number -- since we use * to combine hash values -hashFS :: FAST_STRING -> Int +hashFS :: FastString -> Int hashFS s = iBox (uniqueOfFS s) \end{code} diff --git a/ghc/compiler/basicTypes/MkId.lhs b/ghc/compiler/basicTypes/MkId.lhs index 80d4622e7f..e83e491c2b 100644 --- a/ghc/compiler/basicTypes/MkId.lhs +++ b/ghc/compiler/basicTypes/MkId.lhs @@ -93,6 +93,7 @@ import PrelNames import Maybe ( isJust ) import Util ( dropList, isSingleton ) import Outputable +import FastString import ListSetOps ( assoc, assocMaybe ) import UnicodeUtil ( stringToUtf8 ) import List ( nubBy ) @@ -914,7 +915,7 @@ mkRuntimeErrorApp mkRuntimeErrorApp err_id res_ty err_msg = mkApps (Var err_id) [Type res_ty, err_string] where - err_string = Lit (MachStr (_PK_ (stringToUtf8 err_msg))) + err_string = Lit (MachStr (mkFastString (stringToUtf8 err_msg))) rEC_SEL_ERROR_ID = mkRuntimeErrorId recSelErrIdKey FSLIT("recSelError") rUNTIME_ERROR_ID = mkRuntimeErrorId runtimeErrorIdKey FSLIT("runtimeError") @@ -948,7 +949,7 @@ errorTy = mkSigmaTy [openAlphaTyVar] [] (mkFunTys [mkListTy charTy] openAlphaTy %************************************************************************ \begin{code} -pcMiscPrelId :: Unique{-IdKey-} -> Module -> FAST_STRING -> Type -> IdInfo -> Id +pcMiscPrelId :: Unique{-IdKey-} -> Module -> FastString -> Type -> IdInfo -> Id pcMiscPrelId key mod str ty info = let name = mkWiredInName mod (mkVarOcc str) key diff --git a/ghc/compiler/basicTypes/Module.lhs b/ghc/compiler/basicTypes/Module.lhs index 5fdfe343a5..0387f97237 100644 --- a/ghc/compiler/basicTypes/Module.lhs +++ b/ghc/compiler/basicTypes/Module.lhs @@ -93,6 +93,7 @@ import Unique ( Uniquable(..) ) import UniqFM import UniqSet import Binary +import FastString \end{code} @@ -212,14 +213,14 @@ moduleNameFS :: ModuleName -> EncodedFS moduleNameFS (ModuleName mod) = mod moduleNameString :: ModuleName -> EncodedString -moduleNameString (ModuleName mod) = _UNPK_ mod +moduleNameString (ModuleName mod) = unpackFS mod moduleNameUserString :: ModuleName -> UserString -moduleNameUserString (ModuleName mod) = decode (_UNPK_ mod) +moduleNameUserString (ModuleName mod) = decode (unpackFS mod) -- used to be called mkSrcModule mkModuleName :: UserString -> ModuleName -mkModuleName s = ModuleName (_PK_ (encode s)) +mkModuleName s = ModuleName (mkFastString (encode s)) -- used to be called mkSrcModuleFS mkModuleNameFS :: UserFS -> ModuleName @@ -294,7 +295,7 @@ mkPrelModule :: ModuleName -> Module mkPrelModule name = mkModule name preludePackage moduleString :: Module -> EncodedString -moduleString (Module (ModuleName fs) _) = _UNPK_ fs +moduleString (Module (ModuleName fs) _) = unpackFS fs moduleName :: Module -> ModuleName moduleName (Module mod pkg_info) = mod diff --git a/ghc/compiler/basicTypes/OccName.lhs b/ghc/compiler/basicTypes/OccName.lhs index 66e158cedc..e10d43fc27 100644 --- a/ghc/compiler/basicTypes/OccName.lhs +++ b/ghc/compiler/basicTypes/OccName.lhs @@ -46,6 +46,7 @@ import Char ( isDigit, isUpper, isLower, isAlphaNum, ord, chr, digitToInt ) import Util ( thenCmp ) import Unique ( Unique ) import FiniteMap ( FiniteMap, emptyFM, lookupFM, addToFM, elemFM ) +import FastString import Outputable import Binary @@ -64,8 +65,8 @@ code the encoding operation is not performed on each occurrence. These type synonyms help documentation. \begin{code} -type UserFS = FAST_STRING -- As the user typed it -type EncodedFS = FAST_STRING -- Encoded form +type UserFS = FastString -- As the user typed it +type EncodedFS = FastString -- Encoded form type UserString = String -- As the user typed it type EncodedString = String -- Encoded form @@ -75,9 +76,9 @@ pprEncodedFS :: EncodedFS -> SDoc pprEncodedFS fs = getPprStyle $ \ sty -> if userStyle sty - -- ptext (decodeFS fs) would needlessly pack the string again - then text (decode (_UNPK_ fs)) - else ptext fs + -- ftext (decodeFS fs) would needlessly pack the string again + then text (decode (unpackFS fs)) + else ftext fs \end{code} %************************************************************************ @@ -165,7 +166,7 @@ already encoded \begin{code} mkSysOcc :: NameSpace -> EncodedString -> OccName mkSysOcc occ_sp str = ASSERT2( alreadyEncoded str, text str ) - OccName occ_sp (_PK_ str) + OccName occ_sp (mkFastString str) mkSysOccFS :: NameSpace -> EncodedFS -> OccName mkSysOccFS occ_sp fs = ASSERT2( alreadyEncodedFS fs, ppr fs ) @@ -176,7 +177,7 @@ mkFCallOcc :: EncodedString -> OccName -- because it will be something like "{__ccall f dyn Int# -> Int#}" -- This encodes a lot into something that then parses like an Id. -- But then alreadyEncoded complains about the braces! -mkFCallOcc str = OccName varName (_PK_ str) +mkFCallOcc str = OccName varName (mkFastString str) -- Kind constructors get a special function. Uniquely, they are not encoded, -- so that they have names like '*'. This means that *even in interface files* @@ -212,7 +213,7 @@ occNameFS :: OccName -> EncodedFS occNameFS (OccName _ s) = s occNameString :: OccName -> EncodedString -occNameString (OccName _ s) = _UNPK_ s +occNameString (OccName _ s) = unpackFS s occNameUserString :: OccName -> UserString occNameUserString occ = decode (occNameString occ) @@ -384,7 +385,7 @@ because that isn't a single lexeme. So we encode it to 'lle' and *then* tack on the '1', if necessary. \begin{code} -type TidyOccEnv = FiniteMap FAST_STRING Int -- The in-scope OccNames +type TidyOccEnv = FiniteMap FastString Int -- The in-scope OccNames emptyTidyOccEnv = emptyFM initTidyOccEnv :: [OccName] -> TidyOccEnv -- Initialise with names to avoid! @@ -397,7 +398,7 @@ tidyOccName in_scope occ@(OccName occ_sp fs) = (addToFM in_scope fs 1, occ) -- First occurrence | otherwise -- Already occurs - = go in_scope (_UNPK_ fs) + = go in_scope (unpackFS fs) where go in_scope str = case lookupFM in_scope pk_str of @@ -408,7 +409,7 @@ tidyOccName in_scope occ@(OccName occ_sp fs) Nothing -> (addToFM in_scope pk_str 1, mkSysOccFS occ_sp pk_str) -- str is now unique where - pk_str = _PK_ str + pk_str = mkFastString str \end{code} @@ -469,8 +470,8 @@ alreadyEncoded s = all ok s -- reject them here ok ch = isAlphaNum ch -alreadyEncodedFS :: FAST_STRING -> Bool -alreadyEncodedFS fs = alreadyEncoded (_UNPK_ fs) +alreadyEncodedFS :: FastString -> Bool +alreadyEncodedFS fs = alreadyEncoded (unpackFS fs) encode :: UserString -> EncodedString encode cs = case maybe_tuple cs of @@ -496,9 +497,9 @@ count_commas n cs = (n,cs) encodeFS :: UserFS -> EncodedFS encodeFS fast_str | all unencodedChar str = fast_str - | otherwise = _PK_ (encode str) + | otherwise = mkFastString (encode str) where - str = _UNPK_ fast_str + str = unpackFS fast_str unencodedChar :: Char -> Bool -- True for chars that don't need encoding unencodedChar 'Z' = False @@ -544,8 +545,8 @@ encode_ch c = 'z' : shows (ord c) "U" Decode is used for user printing. \begin{code} -decodeFS :: FAST_STRING -> FAST_STRING -decodeFS fs = _PK_ (decode (_UNPK_ fs)) +decodeFS :: FastString -> FastString +decodeFS fs = mkFastString (decode (unpackFS fs)) decode :: EncodedString -> UserString decode [] = [] @@ -610,8 +611,8 @@ These functions test strings to see if they fit the lexical categories defined in the Haskell report. \begin{code} -isLexCon, isLexVar, isLexId, isLexSym :: FAST_STRING -> Bool -isLexConId, isLexConSym, isLexVarId, isLexVarSym :: FAST_STRING -> Bool +isLexCon, isLexVar, isLexId, isLexSym :: FastString -> Bool +isLexConId, isLexConSym, isLexVarId, isLexVarSym :: FastString -> Bool isLexCon cs = isLexConId cs || isLexConSym cs isLexVar cs = isLexVarId cs || isLexVarSym cs @@ -622,22 +623,22 @@ isLexSym cs = isLexConSym cs || isLexVarSym cs ------------- isLexConId cs -- Prefix type or data constructors - | _NULL_ cs = False -- e.g. "Foo", "[]", "(,)" + | nullFastString cs = False -- e.g. "Foo", "[]", "(,)" | cs == FSLIT("[]") = True - | otherwise = startsConId (_HEAD_ cs) + | otherwise = startsConId (headFS cs) isLexVarId cs -- Ordinary prefix identifiers - | _NULL_ cs = False -- e.g. "x", "_x" - | otherwise = startsVarId (_HEAD_ cs) + | nullFastString cs = False -- e.g. "x", "_x" + | otherwise = startsVarId (headFS cs) isLexConSym cs -- Infix type or data constructors - | _NULL_ cs = False -- e.g. ":-:", ":", "->" + | nullFastString cs = False -- e.g. ":-:", ":", "->" | cs == FSLIT("->") = True - | otherwise = startsConSym (_HEAD_ cs) + | otherwise = startsConSym (headFS cs) isLexVarSym cs -- Infix identifiers - | _NULL_ cs = False -- e.g. "+" - | otherwise = startsVarSym (_HEAD_ cs) + | nullFastString cs = False -- e.g. "+" + | otherwise = startsVarSym (headFS cs) ------------- startsVarSym, startsVarId, startsConSym, startsConId :: Char -> Bool diff --git a/ghc/compiler/basicTypes/SrcLoc.lhs b/ghc/compiler/basicTypes/SrcLoc.lhs index 3f89e97e3f..c3fca1db64 100644 --- a/ghc/compiler/basicTypes/SrcLoc.lhs +++ b/ghc/compiler/basicTypes/SrcLoc.lhs @@ -30,6 +30,7 @@ import Util ( thenCmp ) import Outputable import FastString ( unpackFS ) import FastTypes +import FastString import GlaExts ( (+#) ) \end{code} @@ -43,10 +44,10 @@ We keep information about the {\em definition} point for each entity; this is the obvious stuff: \begin{code} data SrcLoc - = SrcLoc FAST_STRING -- A precise location (file name) + = SrcLoc FastString -- A precise location (file name) FastInt - | UnhelpfulSrcLoc FAST_STRING -- Just a general indication + | UnhelpfulSrcLoc FastString -- Just a general indication | NoSrcLoc \end{code} @@ -66,14 +67,14 @@ Things to make 'em: \begin{code} mkSrcLoc x y = SrcLoc x (iUnbox y) noSrcLoc = NoSrcLoc -importedSrcLoc = UnhelpfulSrcLoc SLIT("<imported>") -builtinSrcLoc = UnhelpfulSrcLoc SLIT("<built-into-the-compiler>") -generatedSrcLoc = UnhelpfulSrcLoc SLIT("<compiler-generated-code>") +importedSrcLoc = UnhelpfulSrcLoc FSLIT("<imported>") +builtinSrcLoc = UnhelpfulSrcLoc FSLIT("<built-into-the-compiler>") +generatedSrcLoc = UnhelpfulSrcLoc FSLIT("<compiler-generated-code>") isGoodSrcLoc (SrcLoc _ _) = True isGoodSrcLoc other = False -srcLocFile :: SrcLoc -> FAST_STRING +srcLocFile :: SrcLoc -> FastString srcLocFile (SrcLoc fname _) = fname srcLocLine :: SrcLoc -> FastInt @@ -120,18 +121,15 @@ cmpSrcLoc (SrcLoc s1 l1) (SrcLoc s2 l2) = (s1 `compare` s2) `thenCmp` (l1 ` instance Outputable SrcLoc where ppr (SrcLoc src_path src_line) = getPprStyle $ \ sty -> - if userStyle sty then - hcat [ text src_file, char ':', int (iBox src_line) ] - else - if debugStyle sty then - hcat [ ptext src_path, char ':', int (iBox src_line) ] + if userStyle sty || debugStyle sty then + hcat [ ftext src_path, char ':', int (iBox src_line) ] else hcat [text "{-# LINE ", int (iBox src_line), space, - char '\"', ptext src_path, text " #-}"] + char '\"', ftext src_path, text " #-}"] where src_file = unpackFS src_path -- Leave the directory prefix intact, -- so emacs can find the file - ppr (UnhelpfulSrcLoc s) = ptext s + ppr (UnhelpfulSrcLoc s) = ftext s ppr NoSrcLoc = ptext SLIT("<No locn>") \end{code} diff --git a/ghc/compiler/codeGen/CgCase.lhs b/ghc/compiler/codeGen/CgCase.lhs index 8201952cd6..df2e165a89 100644 --- a/ghc/compiler/codeGen/CgCase.lhs +++ b/ghc/compiler/codeGen/CgCase.lhs @@ -1,7 +1,7 @@ % % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -% $Id: CgCase.lhs,v 1.56 2001/12/17 12:33:45 simonmar Exp $ +% $Id: CgCase.lhs,v 1.57 2002/04/29 14:03:41 simonmar Exp $ % %******************************************************** %* * @@ -638,14 +638,14 @@ cgSemiTaggedAlts binder alts deflt st_deflt (StgBindDefault _) = Just (Just binder, - (CCallProfCtrMacro SLIT("RET_SEMI_BY_DEFAULT") [], -- ToDo: monadise? + (CCallProfCtrMacro FSLIT("RET_SEMI_BY_DEFAULT") [], -- ToDo: monadise? mkDefaultLabel uniq) ) st_alt (con, args, use_mask, _) = -- Ha! Nothing to do; Node already points to the thing (con_tag, - (CCallProfCtrMacro SLIT("RET_SEMI_IN_HEAP") -- ToDo: monadise? + (CCallProfCtrMacro FSLIT("RET_SEMI_IN_HEAP") -- ToDo: monadise? [mkIntCLit (length args)], -- how big the thing in the heap is join_label) ) @@ -798,7 +798,7 @@ restoreCurrentCostCentre Nothing = returnFC AbsCNop restoreCurrentCostCentre (Just slot) = getSpRelOffset slot `thenFC` \ sp_rel -> freeStackSlots [slot] `thenC` - returnFC (CCallProfCCMacro SLIT("RESTORE_CCCS") [CVal sp_rel CostCentreRep]) + returnFC (CCallProfCCMacro FSLIT("RESTORE_CCCS") [CVal sp_rel CostCentreRep]) -- we use the RESTORE_CCCS macro, rather than just -- assigning into CurCostCentre, in case RESTORE_CCCS -- has some sanity-checking in it. diff --git a/ghc/compiler/codeGen/CgClosure.lhs b/ghc/compiler/codeGen/CgClosure.lhs index e7d70e4fa5..43b4146a56 100644 --- a/ghc/compiler/codeGen/CgClosure.lhs +++ b/ghc/compiler/codeGen/CgClosure.lhs @@ -1,7 +1,7 @@ % % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -% $Id: CgClosure.lhs,v 1.56 2002/03/14 15:27:17 simonpj Exp $ +% $Id: CgClosure.lhs,v 1.57 2002/04/29 14:03:41 simonmar Exp $ % \section[CgClosure]{Code generation for closures} @@ -54,6 +54,7 @@ import PprType ( showTypeCategory ) import Util ( isIn, splitAtList ) import CmdLineOpts ( opt_SccProfilingOn ) import Outputable +import FastString import Name ( nameOccName ) import OccName ( occNameFS ) @@ -262,8 +263,8 @@ closureCodeBody binder_info closure_info cc [] body is_box = case body of { StgApp fun [] -> True; _ -> False } ticky_ent_lit = if (isStaticClosure closure_info) - then SLIT("TICK_ENT_STATIC_THK") - else SLIT("TICK_ENT_DYN_THK") + then FSLIT("TICK_ENT_STATIC_THK") + else FSLIT("TICK_ENT_DYN_THK") body_code = profCtrC ticky_ent_lit [] `thenC` -- node always points when profiling, so this is ok: @@ -372,12 +373,12 @@ closureCodeBody binder_info closure_info cc all_args body fast_entry_code = do mod_name <- moduleName - profCtrC SLIT("TICK_CTR") [ + profCtrC FSLIT("TICK_CTR") [ CLbl ticky_ctr_label DataPtrRep, - mkCString (_PK_ (ppr_for_ticky_name mod_name name)), + mkCString (mkFastString (ppr_for_ticky_name mod_name name)), mkIntCLit stg_arity, -- total # of args mkIntCLit sp_stk_args, -- # passed on stk - mkCString (_PK_ (map (showTypeCategory . idType) all_args)) + mkCString (mkFastString (map (showTypeCategory . idType) all_args)) ] let prof = profCtrC fast_ticky_ent_lit [ @@ -385,8 +386,8 @@ closureCodeBody binder_info closure_info cc all_args body ] -- Nuked for now; see comment at end of file --- CString (_PK_ (show_wrapper_name wrapper_maybe)), --- CString (_PK_ (show_wrapper_arg_kinds wrapper_maybe)) +-- CString (mkFastString (show_wrapper_name wrapper_maybe)), +-- CString (mkFastString (show_wrapper_arg_kinds wrapper_maybe)) -- Bind args to regs/stack as appropriate, and @@ -431,8 +432,8 @@ closureCodeBody binder_info closure_info cc all_args body (slow_ticky_ent_lit, fast_ticky_ent_lit) = if (isStaticClosure closure_info) - then (SLIT("TICK_ENT_STATIC_FUN_STD"), SLIT("TICK_ENT_STATIC_FUN_DIRECT")) - else (SLIT("TICK_ENT_DYN_FUN_STD"), SLIT("TICK_ENT_DYN_FUN_DIRECT")) + then (FSLIT("TICK_ENT_STATIC_FUN_STD"), FSLIT("TICK_ENT_STATIC_FUN_DIRECT")) + else (FSLIT("TICK_ENT_DYN_FUN_STD"), FSLIT("TICK_ENT_DYN_FUN_DIRECT")) stg_arity = length all_args lf_info = closureLFInfo closure_info @@ -481,20 +482,20 @@ enterCostCentreCode closure_info ccs is_thunk is_box if isSubsumedCCS ccs then ASSERT(isToplevClosure closure_info) ASSERT(is_thunk == IsFunction) - costCentresC SLIT("ENTER_CCS_FSUB") [] + costCentresC FSLIT("ENTER_CCS_FSUB") [] else if isDerivedFromCurrentCCS ccs then if re_entrant && not is_box - then costCentresC SLIT("ENTER_CCS_FCL") [CReg node] - else costCentresC SLIT("ENTER_CCS_TCL") [CReg node] + then costCentresC FSLIT("ENTER_CCS_FCL") [CReg node] + else costCentresC FSLIT("ENTER_CCS_TCL") [CReg node] else if isCafCCS ccs then ASSERT(isToplevClosure closure_info) ASSERT(is_thunk == IsThunk) -- might be a PAP, in which case we want to subsume costs if re_entrant - then costCentresC SLIT("ENTER_CCS_FSUB") [] - else costCentresC SLIT("ENTER_CCS_CAF") c_ccs + then costCentresC FSLIT("ENTER_CCS_FSUB") [] + else costCentresC FSLIT("ENTER_CCS_CAF") c_ccs else panic "enterCostCentreCode" @@ -652,7 +653,7 @@ setupUpdate closure_info code code else case (closureUpdReqd closure_info, isStaticClosure closure_info) of - (False,False) -> profCtrC SLIT("TICK_UPDF_OMITTED") [] `thenC` + (False,False) -> profCtrC FSLIT("TICK_UPDF_OMITTED") [] `thenC` code (False,True ) -> (if opt_DoTickyProfiling then @@ -660,16 +661,16 @@ setupUpdate closure_info code link_caf seCafBlackHoleClosureInfo `thenFC` \ _ -> nopC else nopC) `thenC` - profCtrC SLIT("TICK_UPD_CAF_BH_SINGLE_ENTRY") [mkCString cl_name] `thenC` - profCtrC SLIT("TICK_UPDF_OMITTED") [] `thenC` + profCtrC FSLIT("TICK_UPD_CAF_BH_SINGLE_ENTRY") [mkCString cl_name] `thenC` + profCtrC FSLIT("TICK_UPDF_OMITTED") [] `thenC` code (True ,False) -> pushUpdateFrame (CReg node) code (True ,True ) -> -- blackhole the (updatable) CAF: link_caf cafBlackHoleClosureInfo `thenFC` \ update_closure -> - profCtrC SLIT("TICK_UPD_CAF_BH_UPDATABLE") [mkCString cl_name] `thenC` + profCtrC FSLIT("TICK_UPD_CAF_BH_UPDATABLE") [mkCString cl_name] `thenC` pushUpdateFrame update_closure code where - cl_name :: FAST_STRING + cl_name :: FastString cl_name = (occNameFS . nameOccName . closureName) closure_info link_caf :: (ClosureInfo -> ClosureInfo) -- function yielding BH closure_info diff --git a/ghc/compiler/codeGen/CgCon.lhs b/ghc/compiler/codeGen/CgCon.lhs index 3d732636d3..ce9e675e0c 100644 --- a/ghc/compiler/codeGen/CgCon.lhs +++ b/ghc/compiler/codeGen/CgCon.lhs @@ -316,7 +316,7 @@ cgReturnDataCon con amodes temp = CTemp uniq PtrRep in - profCtrC SLIT("TICK_UPD_CON_IN_PLACE") + profCtrC FSLIT("TICK_UPD_CON_IN_PLACE") [mkIntCLit (length amodes)] `thenC` getSpRelOffset args_sp `thenFC` \ sp_rel -> @@ -352,7 +352,7 @@ cgReturnDataCon con amodes let (ret_regs, leftovers) = assignRegs [] (map getAmodeRep amodes) in - profCtrC SLIT("TICK_RET_UNBOXED_TUP") + profCtrC FSLIT("TICK_RET_UNBOXED_TUP") [mkIntCLit (length amodes)] `thenC` doTailCall amodes ret_regs @@ -384,7 +384,7 @@ cgReturnDataCon con amodes -- RETURN - profCtrC SLIT("TICK_RET_NEW") [mkIntCLit (length amodes)] `thenC` + profCtrC FSLIT("TICK_RET_NEW") [mkIntCLit (length amodes)] `thenC` -- could use doTailCall here. performReturn (move_to_reg amode node) return \end{code} diff --git a/ghc/compiler/codeGen/CgConTbls.lhs b/ghc/compiler/codeGen/CgConTbls.lhs index eec28262e6..b61e43380f 100644 --- a/ghc/compiler/codeGen/CgConTbls.lhs +++ b/ghc/compiler/codeGen/CgConTbls.lhs @@ -118,11 +118,11 @@ genConInfo comp_info data_con (static_ci,_) = layOutStaticConstr con_name data_con typePrimRep arg_tys static_body = initC comp_info ( - profCtrC SLIT("TICK_ENT_STATIC_CON") [CReg node] `thenC` + profCtrC FSLIT("TICK_ENT_STATIC_CON") [CReg node] `thenC` ldv_enter_and_body_code) closure_body = initC comp_info ( - profCtrC SLIT("TICK_ENT_DYN_CON") [CReg node] `thenC` + profCtrC FSLIT("TICK_ENT_DYN_CON") [CReg node] `thenC` ldv_enter_and_body_code) ldv_enter_and_body_code = ldvEnter `thenC` body_code @@ -159,7 +159,7 @@ mkConCodeAndInfo con body_code = -- NB: We don't set CC when entering data (WDP 94/06) - profCtrC SLIT("TICK_RET_OLD") + profCtrC FSLIT("TICK_RET_OLD") [mkIntCLit (length arg_things)] `thenC` performReturn AbsCNop -- Ptr to thing already in Node diff --git a/ghc/compiler/codeGen/CgExpr.lhs b/ghc/compiler/codeGen/CgExpr.lhs index c350218ab4..2076a071a4 100644 --- a/ghc/compiler/codeGen/CgExpr.lhs +++ b/ghc/compiler/codeGen/CgExpr.lhs @@ -1,7 +1,7 @@ % % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -% $Id: CgExpr.lhs,v 1.47 2001/11/19 16:34:12 simonpj Exp $ +% $Id: CgExpr.lhs,v 1.48 2002/04/29 14:03:41 simonmar Exp $ % %******************************************************** %* * @@ -257,7 +257,7 @@ centre. cgExpr (StgSCC cc expr) = ASSERT(sccAbleCostCentre cc) costCentresC - SLIT("SET_CCC") + FSLIT("SET_CCC") [mkCCostCentre cc, mkIntCLit (if isSccCountCostCentre cc then 1 else 0)] `thenC` cgExpr expr diff --git a/ghc/compiler/codeGen/CgHeapery.lhs b/ghc/compiler/codeGen/CgHeapery.lhs index ebc51019da..a040d32c00 100644 --- a/ghc/compiler/codeGen/CgHeapery.lhs +++ b/ghc/compiler/codeGen/CgHeapery.lhs @@ -1,7 +1,7 @@ % % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -% $Id: CgHeapery.lhs,v 1.30 2002/02/05 14:39:24 simonpj Exp $ +% $Id: CgHeapery.lhs,v 1.31 2002/04/29 14:03:41 simonmar Exp $ % \section[CgHeapery]{Heap management functions} @@ -118,7 +118,7 @@ fastEntryChecks regs tags ret node_points code = mkAbstractCs [ real_check, if hp == 0 then AbsCNop - else profCtrAbsC SLIT("TICK_ALLOC_HEAP") + else profCtrAbsC FSLIT("TICK_ALLOC_HEAP") [ mkIntCLit hp, CLbl ctr DataPtrRep ] ] @@ -258,7 +258,7 @@ altHeapCheck is_fun regs tags fail_code (Just ret_addr) code then AbsCNop else mkAbstractCs [ checking_code tag_assts, - profCtrAbsC SLIT("TICK_ALLOC_HEAP") + profCtrAbsC FSLIT("TICK_ALLOC_HEAP") [ mkIntCLit words_required, CLbl ctr DataPtrRep ] ] ) `thenC` @@ -317,7 +317,7 @@ altHeapCheck is_fun regs [] AbsCNop Nothing code then AbsCNop else mkAbstractCs [ checking_code, - profCtrAbsC SLIT("TICK_ALLOC_HEAP") + profCtrAbsC FSLIT("TICK_ALLOC_HEAP") [ mkIntCLit words_required, CLbl ctr DataPtrRep ] ] ) `thenC` diff --git a/ghc/compiler/codeGen/CgMonad.lhs b/ghc/compiler/codeGen/CgMonad.lhs index 25c36cd3f5..5c24825a9e 100644 --- a/ghc/compiler/codeGen/CgMonad.lhs +++ b/ghc/compiler/codeGen/CgMonad.lhs @@ -1,7 +1,7 @@ % % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -% $Id: CgMonad.lhs,v 1.33 2002/01/03 11:44:17 simonmar Exp $ +% $Id: CgMonad.lhs,v 1.34 2002/04/29 14:03:42 simonmar Exp $ % \section[CgMonad]{The code generation monad} @@ -62,6 +62,7 @@ import DataCon ( ConTag ) import Id ( Id ) import VarEnv import PrimRep ( PrimRep(..) ) +import FastString import Outputable infixr 9 `thenC` -- Right-associative! @@ -549,23 +550,23 @@ info (whether SCC profiling or profiling-ctrs going) and possibly emit nothing. \begin{code} -costCentresC :: FAST_STRING -> [CAddrMode] -> Code +costCentresC :: FastString -> [CAddrMode] -> Code costCentresC macro args | opt_SccProfilingOn = absC (CCallProfCCMacro macro args) | otherwise = nopC -profCtrC :: FAST_STRING -> [CAddrMode] -> Code +profCtrC :: FastString -> [CAddrMode] -> Code profCtrC macro args | opt_DoTickyProfiling = absC (CCallProfCtrMacro macro args) | otherwise = nopC -profCtrAbsC :: FAST_STRING -> [CAddrMode] -> AbstractC +profCtrAbsC :: FastString -> [CAddrMode] -> AbstractC profCtrAbsC macro args | opt_DoTickyProfiling = CCallProfCtrMacro macro args | otherwise = AbsCNop ldvEnter :: Code -ldvEnter = costCentresC SLIT("LDV_ENTER") [CReg node] +ldvEnter = costCentresC FSLIT("LDV_ENTER") [CReg node] {- Try to avoid adding too many special compilation strategies here. It's better to modify the header files as necessary for particular diff --git a/ghc/compiler/codeGen/CgTailCall.lhs b/ghc/compiler/codeGen/CgTailCall.lhs index 73e7aaa93f..4468eead66 100644 --- a/ghc/compiler/codeGen/CgTailCall.lhs +++ b/ghc/compiler/codeGen/CgTailCall.lhs @@ -1,7 +1,7 @@ % % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -% $Id: CgTailCall.lhs,v 1.32 2002/03/14 15:27:17 simonpj Exp $ +% $Id: CgTailCall.lhs,v 1.33 2002/04/29 14:03:42 simonmar Exp $ % %******************************************************** %* * @@ -147,7 +147,7 @@ mkStaticAlgReturnCode :: DataCon -- The constructor mkStaticAlgReturnCode con sequel = -- Generate profiling code if necessary (case return_convention of - VectoredReturn sz -> profCtrC SLIT("TICK_VEC_RETURN") [mkIntCLit sz] + VectoredReturn sz -> profCtrC FSLIT("TICK_VEC_RETURN") [mkIntCLit sz] other -> nopC ) `thenC` @@ -226,7 +226,7 @@ mkDynamicAlgReturnCode tycon dyn_tag sequel = case ctrlReturnConvAlg tycon of VectoredReturn sz -> - profCtrC SLIT("TICK_VEC_RETURN") [mkIntCLit sz] `thenC` + profCtrC FSLIT("TICK_VEC_RETURN") [mkIntCLit sz] `thenC` sequelToAmode sequel `thenFC` \ ret_addr -> absC (CReturn ret_addr (DynamicVectoredReturn dyn_tag)) @@ -308,7 +308,7 @@ returnUnboxedTuple amodes before_jump let (ret_regs, leftovers) = assignRegs [] (map getAmodeRep amodes) in - profCtrC SLIT("TICK_RET_UNBOXED_TUP") [mkIntCLit (length amodes)] `thenC` + profCtrC FSLIT("TICK_RET_UNBOXED_TUP") [mkIntCLit (length amodes)] `thenC` doTailCall amodes ret_regs mkUnboxedTupleReturnCode @@ -360,7 +360,7 @@ tailCallFun fun fun_amode lf_info arg_amodes pending_assts = case entry_conv of ViaNode -> ([], - profCtrC SLIT("TICK_ENT_VIA_NODE") [] `thenC` + profCtrC FSLIT("TICK_ENT_VIA_NODE") [] `thenC` absC (CJump (CMacroExpr CodePtrRep ENTRY_CODE [CVal (nodeRel 0) DataPtrRep])) , 0) @@ -518,7 +518,7 @@ doTailCall arg_amodes arg_regs finish_code arity pending_assts enter_jump -- Enter Node (we know infoptr will have the info ptr in it)! = mkAbstractCs [ - CCallProfCtrMacro SLIT("RET_SEMI_FAILED") + CCallProfCtrMacro FSLIT("RET_SEMI_FAILED") [CMacroExpr IntRep INFO_TAG [CReg infoptr]], CJump (CMacroExpr CodePtrRep ENTRY_CODE [CReg infoptr]) ] in diff --git a/ghc/compiler/codeGen/CgUsages.lhs b/ghc/compiler/codeGen/CgUsages.lhs index 8c40c9a470..7030629106 100644 --- a/ghc/compiler/codeGen/CgUsages.lhs +++ b/ghc/compiler/codeGen/CgUsages.lhs @@ -162,7 +162,7 @@ adjustSpAndHp newRealSp = do if (rHp == vHp) then AbsCNop else mkAbstractCs [ CAssign (CReg Hp) (CAddr (hpRel rHp vHp)), - profCtrAbsC SLIT("TICK_ALLOC_HEAP") + profCtrAbsC FSLIT("TICK_ALLOC_HEAP") [ mkIntCLit (vHp - rHp), CLbl ticky_ctr DataPtrRep ] ] let new_usage = ((vSp, fSp, newRealSp, hwSp), (vHp,vHp)) diff --git a/ghc/compiler/codeGen/ClosureInfo.lhs b/ghc/compiler/codeGen/ClosureInfo.lhs index 29d6037c43..5840881330 100644 --- a/ghc/compiler/codeGen/ClosureInfo.lhs +++ b/ghc/compiler/codeGen/ClosureInfo.lhs @@ -1,7 +1,7 @@ % % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -% $Id: ClosureInfo.lhs,v 1.51 2002/01/02 12:32:19 simonmar Exp $ +% $Id: ClosureInfo.lhs,v 1.52 2002/04/29 14:03:43 simonmar Exp $ % \section[ClosureInfo]{Data structures which describe closures} @@ -90,6 +90,7 @@ import SMRep -- all of it import Type ( isUnLiftedType, Type ) import BasicTypes ( TopLevelFlag(..), isNotTopLevel, isTopLevel ) import Util ( mapAccumL, listLengthCmp, lengthIs ) +import FastString import Outputable \end{code} @@ -999,16 +1000,16 @@ thunkEntryLabel thunk_id _ is_updatable \end{code} \begin{code} -allocProfilingMsg :: ClosureInfo -> FAST_STRING +allocProfilingMsg :: ClosureInfo -> FastString allocProfilingMsg cl_info = case closureLFInfo cl_info of - LFReEntrant _ _ _ _ -> SLIT("TICK_ALLOC_FUN") - LFCon _ _ -> SLIT("TICK_ALLOC_CON") - LFTuple _ _ -> SLIT("TICK_ALLOC_CON") - LFThunk _ _ _ True _ -> SLIT("TICK_ALLOC_UP_THK") -- updatable - LFThunk _ _ _ False _ -> SLIT("TICK_ALLOC_SE_THK") -- nonupdatable - LFBlackHole _ -> SLIT("TICK_ALLOC_BH") + LFReEntrant _ _ _ _ -> FSLIT("TICK_ALLOC_FUN") + LFCon _ _ -> FSLIT("TICK_ALLOC_CON") + LFTuple _ _ -> FSLIT("TICK_ALLOC_CON") + LFThunk _ _ _ True _ -> FSLIT("TICK_ALLOC_UP_THK") -- updatable + LFThunk _ _ _ False _ -> FSLIT("TICK_ALLOC_SE_THK") -- nonupdatable + LFBlackHole _ -> FSLIT("TICK_ALLOC_BH") LFImported -> panic "TICK_ALLOC_IMP" \end{code} diff --git a/ghc/compiler/codeGen/CodeGen.lhs b/ghc/compiler/codeGen/CodeGen.lhs index 5d08357b73..477790d0c1 100644 --- a/ghc/compiler/codeGen/CodeGen.lhs +++ b/ghc/compiler/codeGen/CodeGen.lhs @@ -156,10 +156,10 @@ mkCostCentreStuff (local_CCs, extern_CCs, singleton_CCSs) [ register_ccs, register_cc_stacks ] where mk_register cc - = CCallProfCCMacro SLIT("REGISTER_CC") [mkCCostCentre cc] + = CCallProfCCMacro FSLIT("REGISTER_CC") [mkCCostCentre cc] mk_register_ccs ccs - = CCallProfCCMacro SLIT("REGISTER_CCS") [mkCCostCentreStack ccs] + = CCallProfCCMacro FSLIT("REGISTER_CCS") [mkCCostCentreStack ccs] \end{code} %************************************************************************ diff --git a/ghc/compiler/coreSyn/CoreSyn.lhs b/ghc/compiler/coreSyn/CoreSyn.lhs index 42640f9ac0..f603969a63 100644 --- a/ghc/compiler/coreSyn/CoreSyn.lhs +++ b/ghc/compiler/coreSyn/CoreSyn.lhs @@ -57,6 +57,7 @@ import Literal ( Literal, mkMachInt ) import DataCon ( DataCon, dataConWorkId ) import BasicTypes ( Activation ) import VarSet +import FastString import Outputable \end{code} @@ -165,7 +166,7 @@ rulesRules (Rules rules _) = rules \end{code} \begin{code} -type RuleName = FAST_STRING +type RuleName = FastString type IdCoreRule = (Id,CoreRule) -- Rules don't have their leading Id inside them data CoreRule diff --git a/ghc/compiler/coreSyn/MkExternalCore.lhs b/ghc/compiler/coreSyn/MkExternalCore.lhs index bfe63808be..bab0c159cf 100644 --- a/ghc/compiler/coreSyn/MkExternalCore.lhs +++ b/ghc/compiler/coreSyn/MkExternalCore.lhs @@ -29,6 +29,7 @@ import ForeignCall import PprExternalCore import CmdLineOpts import IO +import FastString emitExternalCore :: DynFlags -> ModIface -> ModDetails -> IO () emitExternalCore dflags iface details @@ -95,10 +96,10 @@ make_exp (Var v) = case globalIdDetails v of -- a DataConId represents the Id of a worker, which is a varName. -- sof 4/02 -- DataConId _ -> C.Dcon (make_con_qid (Var.varName v)) - FCallId (CCall (CCallSpec (StaticTarget nm) _ _)) -> C.External (_UNPK_ nm) (make_ty (varType v)) + FCallId (CCall (CCallSpec (StaticTarget nm) _ _)) -> C.External (unpackFS nm) (make_ty (varType v)) FCallId _ -> error "MkExternalCore died: can't handle non-static-C foreign call" _ -> C.Var (make_var_qid (Var.varName v)) -make_exp (Lit (l@(MachLabel s))) = C.External (_UNPK_ s) (make_ty (literalType l)) +make_exp (Lit (l@(MachLabel s))) = C.External (unpackFS s) (make_ty (literalType l)) make_exp (Lit l) = C.Lit (make_lit l) make_exp (App e (Type t)) = C.Appt (make_exp e) (make_ty t) make_exp (App e1 e2) = C.App (make_exp e1) (make_exp e2) @@ -127,7 +128,7 @@ make_lit l = case l of MachChar i | i <= 0xff -> C.Lchar (chr i) t MachChar i | otherwise -> C.Lint (toEnum i) t - MachStr s -> C.Lstring (_UNPK_ s) t + MachStr s -> C.Lstring (unpackFS s) t MachAddr i -> C.Lint i t MachInt i -> C.Lint i t MachInt64 i -> C.Lint i t diff --git a/ghc/compiler/coreSyn/PprCore.lhs b/ghc/compiler/coreSyn/PprCore.lhs index 8639a9307b..d6b3a6e282 100644 --- a/ghc/compiler/coreSyn/PprCore.lhs +++ b/ghc/compiler/coreSyn/PprCore.lhs @@ -386,10 +386,11 @@ pprIdRule (id,rule) = pprCoreRule (ppr id) rule pprCoreRule :: SDoc -> CoreRule -> SDoc pprCoreRule pp_fn (BuiltinRule name _) - = ifPprDebug (ptext SLIT("Built in rule for") <+> pp_fn <> colon <+> doubleQuotes (ptext name)) + = ifPprDebug (ptext SLIT("Built in rule for") <+> pp_fn <> colon + <+> doubleQuotes (ftext name)) pprCoreRule pp_fn (Rule name act tpl_vars tpl_args rhs) - = doubleQuotes (ptext name) <+> ppr act <+> + = doubleQuotes (ftext name) <+> ppr act <+> sep [ ptext SLIT("__forall") <+> braces (sep (map pprTypedBinder tpl_vars)), nest 2 (pp_fn <+> sep (map pprArg tpl_args)), diff --git a/ghc/compiler/deSugar/Check.lhs b/ghc/compiler/deSugar/Check.lhs index 23a818d97d..1f64cf69c7 100644 --- a/ghc/compiler/deSugar/Check.lhs +++ b/ghc/compiler/deSugar/Check.lhs @@ -30,6 +30,7 @@ import SrcLoc ( noSrcLoc ) import UniqSet import Util ( takeList, splitAtList, notNull ) import Outputable +import FastString #include "HsVersions.h" \end{code} @@ -376,7 +377,7 @@ make_row_vars used_lits (EqnInfo _ _ pats _ ) = where new_var = hash_x hash_x = mkInternalName unboundKey {- doesn't matter much -} - (mkVarOcc SLIT("#x")) + (mkVarOcc FSLIT("#x")) noSrcLoc make_row_vars_for_constructor :: EquationInfo -> [WarningPat] @@ -640,7 +641,7 @@ simplify_pat pat@(LitPat lit lit_ty) = tidyLitPat lit pat -- each other, or even explicit lists of Chars. simplify_pat pat@(NPat (HsString s) _ _) = foldr (\c pat -> ConPat consDataCon stringTy [] [] [mk_char_lit c,pat]) - (ConPat nilDataCon stringTy [] [] []) (_UNPK_INT_ s) + (ConPat nilDataCon stringTy [] [] []) (unpackIntFS s) where mk_char_lit c = ConPat charDataCon charTy [] [] [LitPat (HsCharPrim c) charPrimTy] diff --git a/ghc/compiler/deSugar/Desugar.lhs b/ghc/compiler/deSugar/Desugar.lhs index 3965a361af..55152d9e84 100644 --- a/ghc/compiler/deSugar/Desugar.lhs +++ b/ghc/compiler/deSugar/Desugar.lhs @@ -37,6 +37,7 @@ import ErrUtils ( doIfSet, dumpIfSet_dyn, pprBagOfWarnings ) import Outputable import UniqSupply ( mkSplitUniqSupply ) import HscTypes ( HomeSymbolTable, PersistentCompilerState(..), TyThing(..), lookupType, ) +import FastString \end{code} %************************************************************************ @@ -53,7 +54,7 @@ deSugar :: DynFlags -> PersistentCompilerState -> HomeSymbolTable -> Module -> PrintUnqualified -> TcResults - -> IO (ModDetails, (SDoc, SDoc, [FAST_STRING], [CoreBndr])) + -> IO (ModDetails, (SDoc, SDoc, [FastString], [CoreBndr])) deSugar dflags pcs hst mod_name unqual (TcResults {tc_env = type_env, @@ -159,7 +160,7 @@ Simplest thing in the world, desugaring External Core: \begin{code} deSugarCore :: (TypeEnv, [TypecheckedCoreBind], [TypecheckedRuleDecl]) - -> IO (ModDetails, (SDoc, SDoc, [FAST_STRING], [CoreBndr])) + -> IO (ModDetails, (SDoc, SDoc, [FastString], [CoreBndr])) deSugarCore (type_env, pairs, rules) = return (mod_details, no_foreign_stuff) where diff --git a/ghc/compiler/deSugar/DsExpr.lhs b/ghc/compiler/deSugar/DsExpr.lhs index 3707cd0632..e379d2606b 100644 --- a/ghc/compiler/deSugar/DsExpr.lhs +++ b/ghc/compiler/deSugar/DsExpr.lhs @@ -52,6 +52,7 @@ import Maybes ( maybeToBool ) import PrelNames ( hasKey, ratioTyConKey, toPName ) import Util ( zipEqual, zipWithEqual ) import Outputable +import FastString import Ratio ( numerator, denominator ) \end{code} @@ -603,7 +604,7 @@ dsDo do_or_lc stmts ids@[return_id, fail_id, bind_id, then_id] result_ty let a_ty = outPatType pat fail_expr = HsApp (TyApp (HsVar fail_id) [b_ty]) - (HsLit (HsString (_PK_ msg))) + (HsLit (HsString (mkFastString msg))) msg = "Pattern match failure in do expression, " ++ showSDoc (ppr locn) main_match = mkSimpleMatch [pat] (HsDoOut do_or_lc stmts ids result_ty locn) diff --git a/ghc/compiler/deSugar/DsForeign.lhs b/ghc/compiler/deSugar/DsForeign.lhs index 5d3b932914..a89b70655d 100644 --- a/ghc/compiler/deSugar/DsForeign.lhs +++ b/ghc/compiler/deSugar/DsForeign.lhs @@ -44,6 +44,7 @@ import BasicTypes ( Activation( NeverActive ) ) import ErrUtils ( addShortWarnLocLine ) import Outputable import Maybe ( fromJust ) +import FastString \end{code} Desugaring of @foreign@ declarations is naturally split up into @@ -72,7 +73,7 @@ dsForeigns :: Module -- "foreign exported" functions. , SDoc -- C stubs to use when calling -- "foreign exported" functions. - , [FAST_STRING] -- headers that need to be included + , [FastString] -- headers that need to be included -- into C code generated for this module ) dsForeigns mod_name fos @@ -126,13 +127,13 @@ because it exposes the boxing to the call site. dsFImport :: Module -> Id -> ForeignImport - -> DsM ([Binding], SDoc, SDoc, [FAST_STRING]) + -> DsM ([Binding], SDoc, SDoc, [FastString]) dsFImport modName id (CImport cconv safety header lib spec) = dsCImport modName id spec cconv safety `thenDs` \(ids, h, c) -> - returnDs (ids, h, c, if _NULL_ header then [] else [header]) + returnDs (ids, h, c, if nullFastString header then [] else [header]) -- FIXME: the `lib' field is needed for .NET ILX generation when invoking -- routines that are external to the .NET runtime, but GHC doesn't - -- support such calls yet; if `_NULL_ lib', the value was not given + -- support such calls yet; if `nullFastString lib', the value was not given dsFImport modName id (DNImport spec) = dsFCall modName id (DNCall spec) `thenDs` \(ids, h, c) -> returnDs (ids, h, c, []) @@ -192,7 +193,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 (encodeFS SLIT("$wccall")) work_uniq worker_ty + work_id = mkSysLocal (encodeFS FSLIT("$wccall")) work_uniq worker_ty -- Build the wrapper work_app = mkApps (mkVarApps (Var work_id) tvs) val_args @@ -306,7 +307,7 @@ dsFExportDynamic mod_name id cconv = newSysLocalDs ty `thenDs` \ fe_id -> let -- hack: need to get at the name of the C stub we're about to generate. - fe_nm = _PK_ (moduleUserString mod_name ++ "_" ++ toCName fe_id) + fe_nm = mkFastString (moduleUserString mod_name ++ "_" ++ toCName fe_id) in dsFExport mod_name id export_ty fe_nm cconv True `thenDs` \ (h_code, c_code) -> newSysLocalDs arg_ty `thenDs` \ cback -> @@ -338,7 +339,7 @@ dsFExportDynamic mod_name id cconv ] -- name of external entry point providing these services. -- (probably in the RTS.) - adjustor = SLIT("createAdjustor") + adjustor = FSLIT("createAdjustor") in dsCCall adjustor adj_args PlayRisky False io_res_ty `thenDs` \ ccall_adj -> -- PlayRisky: the adjustor doesn't allocate in the Haskell heap or do a callback @@ -379,7 +380,7 @@ using the hugs/ghc rts invocation API. \begin{code} mkFExportCBits :: String - -> FAST_STRING + -> FastString -> Maybe Id -- Just==static, Nothing==dynamic -> [Type] -> Type @@ -422,7 +423,7 @@ mkFExportCBits mod_nm c_nm maybe_target arg_htys res_hty is_IO_res_ty cc header_bits = ptext SLIT("extern") <+> fun_proto <> semi - fun_proto = cResType <+> pprCconv <+> ptext c_nm <> + fun_proto = cResType <+> pprCconv <+> ftext c_nm <> parens (hsep (punctuate comma (map (\(nm,ty) -> ty <+> nm) all_cnames_and_ctys))) @@ -465,7 +466,7 @@ mkFExportCBits mod_nm c_nm maybe_target arg_htys res_hty is_IO_res_ty cc , text (if is_IO_res_ty then "rc=rts_evalIO" else "rc=rts_eval") <> parens (expr_to_run <+> comma <> text "&ret") <> semi - , text "rts_checkSchedStatus" <> parens (doubleQuotes (ptext c_nm) + , text "rts_checkSchedStatus" <> parens (doubleQuotes (ftext c_nm) <> comma <> text "rc") <> semi , text "return" <> return_what <> semi , rbrace diff --git a/ghc/compiler/deSugar/DsUtils.lhs b/ghc/compiler/deSugar/DsUtils.lhs index 5ff1a7320b..ac9e85b35c 100644 --- a/ghc/compiler/deSugar/DsUtils.lhs +++ b/ghc/compiler/deSugar/DsUtils.lhs @@ -64,6 +64,7 @@ import PrelNames ( unpackCStringName, unpackCStringUtf8Name, import Outputable import UnicodeUtil ( intsToUtf8, stringToUtf8 ) import Util ( isSingleton, notNull ) +import FastString \end{code} @@ -81,9 +82,9 @@ tidyLitPat lit pat = pat tidyNPat :: HsLit -> Type -> TypecheckedPat -> TypecheckedPat tidyNPat (HsString s) _ pat - | _LENGTH_ s <= 1 -- Short string literals only + | lengthFS s <= 1 -- Short string literals only = foldr (\c pat -> ConPat consDataCon stringTy [] [] [mk_char_lit c,pat]) - (ConPat nilDataCon stringTy [] [] []) (_UNPK_INT_ s) + (ConPat nilDataCon stringTy [] [] []) (unpackIntFS s) -- The stringTy is the type of the whole pattern, not -- the type to instantiate (:) or [] with! where @@ -389,7 +390,7 @@ mkErrorAppDs err_id ty msg = getSrcLocDs `thenDs` \ src_loc -> let full_msg = showSDoc (hcat [ppr src_loc, text "|", text msg]) - core_msg = Lit (MachStr (_PK_ (stringToUtf8 full_msg))) + core_msg = Lit (MachStr (mkFastString (stringToUtf8 full_msg))) in returnDs (mkApps (Var err_id) [Type ty, core_msg]) \end{code} @@ -434,16 +435,16 @@ mkIntegerLit i mkSmallIntegerLit i = mkConApp smallIntegerDataCon [mkIntLit i] mkStringLit :: String -> DsM CoreExpr -mkStringLit str = mkStringLitFS (_PK_ str) +mkStringLit str = mkStringLitFS (mkFastString str) -mkStringLitFS :: FAST_STRING -> DsM CoreExpr +mkStringLitFS :: FastString -> DsM CoreExpr mkStringLitFS str - | _NULL_ str + | nullFastString str = returnDs (mkNilExpr charTy) - | _LENGTH_ str == 1 + | lengthFS str == 1 = let - the_char = mkConApp charDataCon [mkLit (MachChar (_HEAD_INT_ str))] + the_char = mkConApp charDataCon [mkLit (MachChar (headIntFS str))] in returnDs (mkConsExpr charTy the_char (mkNilExpr charTy)) @@ -453,10 +454,10 @@ mkStringLitFS str | otherwise = dsLookupGlobalValue unpackCStringUtf8Name `thenDs` \ unpack_id -> - returnDs (App (Var unpack_id) (Lit (MachStr (_PK_ (intsToUtf8 int_chars))))) + returnDs (App (Var unpack_id) (Lit (MachStr (mkFastString (intsToUtf8 int_chars))))) where - int_chars = _UNPK_INT_ str + int_chars = unpackIntFS str safeChar c = c >= 1 && c <= 0xFF \end{code} diff --git a/ghc/compiler/deSugar/Match.lhs b/ghc/compiler/deSugar/Match.lhs index 73134d813c..d76fccf7e3 100644 --- a/ghc/compiler/deSugar/Match.lhs +++ b/ghc/compiler/deSugar/Match.lhs @@ -125,7 +125,7 @@ pp_context (DsMatchContext kind pats loc) msg rest_of_msg_fun ppr_pats pats = sep (map ppr pats) ppr_shadow_pats kind pats - = sep [ppr_pats pats, ptext (matchSeparator kind), ptext SLIT("...")] + = sep [ppr_pats pats, matchSeparator kind, ptext SLIT("...")] ppr_incomplete_pats kind (pats,[]) = ppr_pats pats ppr_incomplete_pats kind (pats,constraints) = diff --git a/ghc/compiler/ghci/ByteCodeGen.lhs b/ghc/compiler/ghci/ByteCodeGen.lhs index eeb1580ae6..56f64fcc3d 100644 --- a/ghc/compiler/ghci/ByteCodeGen.lhs +++ b/ghc/compiler/ghci/ByteCodeGen.lhs @@ -883,7 +883,7 @@ generateCCall d0 s p ccall_spec@(CCallSpec target cconv safety) fn args_r_to_l DynamicTarget -> returnBc (False, panic "ByteCodeGen.generateCCall(dyn)") StaticTarget target - -> let sym_to_find = _UNPK_ target in + -> let sym_to_find = unpackFS target in ioToBc (lookupSymbol sym_to_find) `thenBc` \res -> case res of Just aa -> returnBc (True, aa) diff --git a/ghc/compiler/ghci/ByteCodeLink.lhs b/ghc/compiler/ghci/ByteCodeLink.lhs index 6c0ed01cda..04e84339f8 100644 --- a/ghc/compiler/ghci/ByteCodeLink.lhs +++ b/ghc/compiler/ghci/ByteCodeLink.lhs @@ -123,7 +123,7 @@ linkSomeBCOs toplevs_only ie ce_in ul_bcos data UnlinkedBCO = UnlinkedBCO Name (SizedSeq Word16) -- insns - (SizedSeq (Either Word FAST_STRING)) -- literals + (SizedSeq (Either Word FastString)) -- literals -- Either literal words or a pointer to a asciiz -- string, denoting a label whose *address* should -- be determined at link time @@ -195,7 +195,7 @@ assembleBCO (ProtoBCO nm instrs origin malloced) in do -- pass 2: generate the instruction, ptr and nonptr bits insns <- return emptySS :: IO (SizedSeq Word16) - lits <- return emptySS :: IO (SizedSeq (Either Word FAST_STRING)) + lits <- return emptySS :: IO (SizedSeq (Either Word FastString)) ptrs <- return emptySS :: IO (SizedSeq (Either Name PrimOp)) itbls <- return emptySS :: IO (SizedSeq Name) let init_asm_state = (insns,lits,ptrs,itbls) @@ -216,7 +216,7 @@ assembleBCO (ProtoBCO nm instrs origin malloced) -- instrs nonptrs ptrs itbls type AsmState = (SizedSeq Word16, - SizedSeq (Either Word FAST_STRING), + SizedSeq (Either Word FastString), SizedSeq (Either Name PrimOp), SizedSeq Name) @@ -578,10 +578,10 @@ newBCO a b c d = IO (\s -> case newBCO# a b c d s of (# s1, bco #) -> (# s1, BCO bco #)) -lookupLiteral :: Either Word FAST_STRING -> IO Word +lookupLiteral :: Either Word FastString -> IO Word lookupLiteral (Left w) = return w lookupLiteral (Right addr_of_label_string) - = do let label_to_find = _UNPK_ addr_of_label_string + = do let label_to_find = unpackFS addr_of_label_string m <- lookupSymbol label_to_find case m of -- Can't be bothered to find the official way to convert Addr# to Word#; @@ -649,7 +649,7 @@ linkFail who what -- HACKS!!! ToDo: cleaner nameToCLabel :: Name -> String{-suffix-} -> String nameToCLabel n suffix - = _UNPK_(moduleNameFS (rdrNameModule rn)) + = unpackFS(moduleNameFS (rdrNameModule rn)) ++ '_':occNameString(rdrNameOcc rn) ++ '_':suffix where rn = toRdrName n diff --git a/ghc/compiler/hsSyn/HsBinds.lhs b/ghc/compiler/hsSyn/HsBinds.lhs index b5456d2352..bb2c8b2bb7 100644 --- a/ghc/compiler/hsSyn/HsBinds.lhs +++ b/ghc/compiler/hsSyn/HsBinds.lhs @@ -317,13 +317,13 @@ isPragSig other = False \end{code} \begin{code} -hsSigDoc (Sig _ _ loc) = (SLIT("type signature"),loc) -hsSigDoc (ClassOpSig _ _ _ loc) = (SLIT("class-method type signature"), loc) -hsSigDoc (SpecSig _ _ loc) = (SLIT("SPECIALISE pragma"),loc) -hsSigDoc (InlineSig True _ _ loc) = (SLIT("INLINE pragma"),loc) -hsSigDoc (InlineSig False _ _ loc) = (SLIT("NOINLINE pragma"),loc) -hsSigDoc (SpecInstSig _ loc) = (SLIT("SPECIALISE instance pragma"),loc) -hsSigDoc (FixSig (FixitySig _ _ loc)) = (SLIT("fixity declaration"), loc) +hsSigDoc (Sig _ _ loc) = (ptext SLIT("type signature"),loc) +hsSigDoc (ClassOpSig _ _ _ loc) = (ptext SLIT("class-method type signature"), loc) +hsSigDoc (SpecSig _ _ loc) = (ptext SLIT("SPECIALISE pragma"),loc) +hsSigDoc (InlineSig True _ _ loc) = (ptext SLIT("INLINE pragma"),loc) +hsSigDoc (InlineSig False _ _ loc) = (ptext SLIT("NOINLINE pragma"),loc) +hsSigDoc (SpecInstSig _ loc) = (ptext SLIT("SPECIALISE instance pragma"),loc) +hsSigDoc (FixSig (FixitySig _ _ loc)) = (ptext SLIT("fixity declaration"), loc) \end{code} \begin{code} diff --git a/ghc/compiler/hsSyn/HsCore.lhs b/ghc/compiler/hsSyn/HsCore.lhs index 8d1da8f751..0f5a020370 100644 --- a/ghc/compiler/hsSyn/HsCore.lhs +++ b/ghc/compiler/hsSyn/HsCore.lhs @@ -50,6 +50,7 @@ import FiniteMap ( lookupFM ) import CostCentre import Util ( eqListBy, lengthIs ) import Outputable +import FastString \end{code} %************************************************************************ @@ -69,7 +70,7 @@ data UfExpr name | UfLet (UfBinding name) (UfExpr name) | UfNote (UfNote name) (UfExpr name) | UfLit Literal - | UfLitLit FAST_STRING (HsType name) + | UfLitLit FastString (HsType name) | UfFCall ForeignCall (HsType name) data UfNote name = UfSCC CostCentre @@ -83,7 +84,7 @@ data UfConAlt name = UfDefault | UfDataAlt name | UfTupleAlt (HsTupCon name) | UfLitAlt Literal - | UfLitLitAlt FAST_STRING (HsType name) + | UfLitLitAlt FastString (HsType name) data UfBinding name = UfNonRec (UfBinder name) diff --git a/ghc/compiler/hsSyn/HsDecls.lhs b/ghc/compiler/hsSyn/HsDecls.lhs index 848ef57f26..036a427318 100644 --- a/ghc/compiler/hsSyn/HsDecls.lhs +++ b/ghc/compiler/hsSyn/HsDecls.lhs @@ -829,10 +829,10 @@ instance Outputable ForeignImport where char '"' <> pprCEntity header lib spec <> char '"' where pprCEntity header lib (CLabel lbl) = - ptext SLIT("static") <+> ptext header <+> char '&' <> + ptext SLIT("static") <+> ftext header <+> char '&' <> pprLib lib <> ppr lbl pprCEntity header lib (CFunction (StaticTarget lbl)) = - ptext SLIT("static") <+> ptext header <+> char '&' <> + ptext SLIT("static") <+> ftext header <+> char '&' <> pprLib lib <> ppr lbl pprCEntity header lib (CFunction (DynamicTarget)) = ptext SLIT("dynamic") @@ -905,7 +905,7 @@ instance (NamedThing name, Ord name) => Eq (RuleDecl name pat) where instance (NamedThing name, Outputable name, Outputable pat) => Outputable (RuleDecl name pat) where ppr (HsRule name act ns lhs rhs loc) - = sep [text "{-# RULES" <+> doubleQuotes (ptext name) <+> ppr act, + = sep [text "{-# RULES" <+> doubleQuotes (ftext name) <+> ppr act, pp_forall, ppr lhs, equals <+> ppr rhs, text "#-}" ] where @@ -913,7 +913,7 @@ instance (NamedThing name, Outputable name, Outputable pat) | otherwise = text "forall" <+> fsep (map ppr ns) <> dot ppr (IfaceRule name act tpl_vars fn tpl_args rhs loc) - = hsep [ doubleQuotes (ptext name), ppr act, + = hsep [ doubleQuotes (ftext name), ppr act, ptext SLIT("__forall") <+> braces (interppSP tpl_vars), ppr fn <+> sep (map (pprUfExpr parens) tpl_args), ptext SLIT("=") <+> ppr rhs @@ -938,7 +938,7 @@ We use exported entities for things to deprecate. \begin{code} data DeprecDecl name = Deprecation name DeprecTxt SrcLoc -type DeprecTxt = FAST_STRING -- reason/explanation for deprecation +type DeprecTxt = FastString -- reason/explanation for deprecation instance Outputable name => Outputable (DeprecDecl name) where ppr (Deprecation thing txt _) diff --git a/ghc/compiler/hsSyn/HsExpr.lhs b/ghc/compiler/hsSyn/HsExpr.lhs index 2e899c08ea..fa81775785 100644 --- a/ghc/compiler/hsSyn/HsExpr.lhs +++ b/ghc/compiler/hsSyn/HsExpr.lhs @@ -27,6 +27,7 @@ import DataCon ( DataCon ) import CStrings ( CLabelString, pprCLabelString ) import BasicTypes ( IPName, Boxity, tupleParens ) import SrcLoc ( SrcLoc ) +import FastString \end{code} %************************************************************************ @@ -160,7 +161,7 @@ data HsExpr id pat PostTcType -- The result type; will be *bottom* -- until the typechecker gets ahold of it - | HsSCC FAST_STRING -- "set cost centre" (_scc_) annotation + | HsSCC FastString -- "set cost centre" (_scc_) annotation (HsExpr id pat) -- expr whose cost is to be measured \end{code} @@ -356,7 +357,7 @@ ppr_expr (HsCCall fun args _ is_asm result_ty) 4 (sep (map pprParendExpr args)) ppr_expr (HsSCC lbl expr) - = sep [ ptext SLIT("_scc_") <+> doubleQuotes (ptext lbl), pprParendExpr expr ] + = sep [ ptext SLIT("_scc_") <+> doubleQuotes (ftext lbl), pprParendExpr expr ] ppr_expr (TyLam tyvars expr) = hang (hsep [ptext SLIT("/\\"), interppSP tyvars, ptext SLIT("->")]) @@ -554,7 +555,7 @@ pprGRHS ctxt (GRHS guarded locn) ResultStmt expr _ = last guarded -- Last stmt should be a ResultStmt for guards guards = init guarded -pp_rhs ctxt rhs = ptext (matchSeparator ctxt) <+> pprDeeper (ppr rhs) +pp_rhs ctxt rhs = matchSeparator ctxt <+> pprDeeper (ppr rhs) \end{code} @@ -708,11 +709,11 @@ isDoExpr other = False \end{code} \begin{code} -matchSeparator (FunRhs _) = SLIT("=") -matchSeparator CaseAlt = SLIT("->") -matchSeparator LambdaExpr = SLIT("->") -matchSeparator PatBindRhs = SLIT("=") -matchSeparator (DoCtxt _) = SLIT("<-") +matchSeparator (FunRhs _) = ptext SLIT("=") +matchSeparator CaseAlt = ptext SLIT("->") +matchSeparator LambdaExpr = ptext SLIT("->") +matchSeparator PatBindRhs = ptext SLIT("=") +matchSeparator (DoCtxt _) = ptext SLIT("<-") matchSeparator RecUpd = panic "When is this used?" \end{code} diff --git a/ghc/compiler/hsSyn/HsImpExp.lhs b/ghc/compiler/hsSyn/HsImpExp.lhs index e483914619..b33fb2bcd7 100644 --- a/ghc/compiler/hsSyn/HsImpExp.lhs +++ b/ghc/compiler/hsSyn/HsImpExp.lhs @@ -11,6 +11,7 @@ module HsImpExp where import Name ( isLexSym ) import Module ( ModuleName, WhereFrom ) import Outputable +import FastString import SrcLoc ( SrcLoc ) \end{code} @@ -99,7 +100,7 @@ ppr_var v | isOperator v = parens (ppr v) \begin{code} isOperator :: Outputable a => a -> Bool -isOperator v = isLexSym (_PK_ (showSDocUnqual (ppr v))) +isOperator v = isLexSym (mkFastString (showSDocUnqual (ppr v))) -- We use (showSDoc (ppr v)), rather than isSymOcc (getOccName v) simply so -- that we don't need NamedThing in the context of all these functions. -- Gruesome, but simple. diff --git a/ghc/compiler/hsSyn/HsLit.lhs b/ghc/compiler/hsSyn/HsLit.lhs index aa19b64164..2675810465 100644 --- a/ghc/compiler/hsSyn/HsLit.lhs +++ b/ghc/compiler/hsSyn/HsLit.lhs @@ -12,6 +12,7 @@ import Type ( Type ) import Name ( Name ) import HsTypes ( PostTcType ) import Outputable +import FastString import Ratio ( Rational ) \end{code} @@ -27,8 +28,8 @@ import Ratio ( Rational ) data HsLit = HsChar Int -- Character | HsCharPrim Int -- Unboxed character - | HsString FAST_STRING -- String - | HsStringPrim FAST_STRING -- Packed string + | HsString FastString -- String + | HsStringPrim FastString -- Packed string | HsInt Integer -- Genuinely an Int; arises from TcGenDeriv, -- and from TRANSLATION | HsIntPrim Integer -- Unboxed Int @@ -36,7 +37,7 @@ data HsLit | HsRat Rational Type -- Genuinely a rational; arises only from TRANSLATION | HsFloatPrim Rational -- Unboxed Float | HsDoublePrim Rational -- Unboxed Double - | HsLitLit FAST_STRING PostTcType -- to pass ``literal literals'' through to C + | HsLitLit FastString PostTcType -- to pass ``literal literals'' through to C -- also: "overloaded" type; but -- must resolve to boxed-primitive! -- The Type in HsLitLit is needed when desuaring; @@ -86,7 +87,7 @@ instance Outputable HsLit where ppr (HsFloatPrim f) = rational f <> char '#' ppr (HsDoublePrim d) = rational d <> text "##" ppr (HsIntPrim i) = integer i <> char '#' - ppr (HsLitLit s _) = hcat [text "``", ptext s, text "''"] + ppr (HsLitLit s _) = hcat [text "``", ftext s, text "''"] instance Outputable HsOverLit where ppr (HsIntegral i _) = integer i diff --git a/ghc/compiler/hsSyn/HsTypes.lhs b/ghc/compiler/hsSyn/HsTypes.lhs index 3c4262989c..837dc91b45 100644 --- a/ghc/compiler/hsSyn/HsTypes.lhs +++ b/ghc/compiler/hsSyn/HsTypes.lhs @@ -115,8 +115,8 @@ data HsType name ----------------------- hsUsOnce, hsUsMany :: HsType RdrName -hsUsOnce = HsTyVar (mkUnqual tvName SLIT(".")) -- deep magic -hsUsMany = HsTyVar (mkUnqual tvName SLIT("!")) -- deep magic +hsUsOnce = HsTyVar (mkUnqual tvName FSLIT(".")) -- deep magic +hsUsMany = HsTyVar (mkUnqual tvName FSLIT("!")) -- deep magic hsUsOnce_Name, hsUsMany_Name :: HsType Name hsUsOnce_Name = HsTyVar usOnceTyConName diff --git a/ghc/compiler/ilxGen/IlxGen.lhs b/ghc/compiler/ilxGen/IlxGen.lhs index 3f1cdd9dd9..b2c424c571 100644 --- a/ghc/compiler/ilxGen/IlxGen.lhs +++ b/ghc/compiler/ilxGen/IlxGen.lhs @@ -1491,8 +1491,8 @@ inPrelude = preludePackage == opt_InPackage -- still a mess though. Also, still have to do the -- right thing for embedded nulls. -pprFSInILStyle :: FAST_STRING -> SDoc -pprFSInILStyle fs = doubleQuotes (text (stringToC (_UNPK_ fs))) +pprFSInILStyle :: FastString -> SDoc +pprFSInILStyle fs = doubleQuotes (text (stringToC (unpackFS fs))) stringToC :: String -> String -- Convert a string to the form required by C in a C literal string diff --git a/ghc/compiler/javaGen/JavaGen.lhs b/ghc/compiler/javaGen/JavaGen.lhs index ae6d19a4ca..55b2b716c1 100644 --- a/ghc/compiler/javaGen/JavaGen.lhs +++ b/ghc/compiler/javaGen/JavaGen.lhs @@ -228,7 +228,7 @@ javaLit (MachInt i) = Literal (IntLit (fromInteger i)) javaLit (MachChar c) = Literal (CharLit c) javaLit (MachStr fs) = Literal (StringLit str) where - str = concatMap renderString (_UNPK_ fs) ++ "\\000" + str = concatMap renderString (unpackFS fs) ++ "\\000" -- This should really handle all the chars 0..31. renderString '\NUL' = "\\000" renderString other = [other] diff --git a/ghc/compiler/main/CmdLineOpts.lhs b/ghc/compiler/main/CmdLineOpts.lhs index 94dd35464d..c93dc2f779 100644 --- a/ghc/compiler/main/CmdLineOpts.lhs +++ b/ghc/compiler/main/CmdLineOpts.lhs @@ -544,7 +544,7 @@ unpacked_opts :: [String] unpacked_opts = concat $ map (expandAts) $ - map _UNPK_ argv -- NOT ARGV any more: v_Static_hsc_opts + map unpackFS argv -- NOT ARGV any more: v_Static_hsc_opts where expandAts ('@':fname) = words (unsafePerformIO (readFile fname)) expandAts l = [l] @@ -601,7 +601,7 @@ opt_MaxWorkerArgs = lookup_def_int "-fmax-worker-args" (10::Int) The Prelude, for example is compiled with '-inpackage std' -} opt_InPackage = case lookup_str "-inpackage=" of - Just p -> _PK_ p + Just p -> mkFastString p Nothing -> FSLIT("Main") -- The package name if none is specified opt_EmitCExternDecls = lookUp FSLIT("-femit-extern-decls") diff --git a/ghc/compiler/main/HscMain.lhs b/ghc/compiler/main/HscMain.lhs index 2b2ad0a903..fd99a5e10b 100644 --- a/ghc/compiler/main/HscMain.lhs +++ b/ghc/compiler/main/HscMain.lhs @@ -85,6 +85,7 @@ import OccName ( OccName ) import Name ( Name, nameModule, nameOccName, getName ) import NameEnv ( emptyNameEnv, mkNameEnv ) import Module ( Module ) +import FastString import IOExts ( newIORef, readIORef, writeIORef, unsafePerformIO ) @@ -321,7 +322,7 @@ hscRecomp ghci_mode dflags have_object -- foreign_headers = unlines - . map (\fname -> "#include \"" ++ _UNPK_ fname ++ "\"") + . map (\fname -> "#include \"" ++ unpackFS fname ++ "\"") . reverse $ headers @@ -486,7 +487,7 @@ myParseModule dflags src_filename let exts = ExtFlags {glasgowExtsEF = dopt Opt_GlasgowExts dflags, parrEF = dopt Opt_PArr dflags} - loc = mkSrcLoc (_PK_ src_filename) 1 + loc = mkSrcLoc (mkFastString src_filename) 1 case parseModule buf (mkPState loc exts) of { diff --git a/ghc/compiler/main/MkIface.lhs b/ghc/compiler/main/MkIface.lhs index 8fe9e6611d..f2b908e2c7 100644 --- a/ghc/compiler/main/MkIface.lhs +++ b/ghc/compiler/main/MkIface.lhs @@ -61,6 +61,7 @@ import Util ( sortLt, dropList ) import Binary ( getBinFileWithDict ) import BinIface ( writeBinIface ) import ErrUtils ( dumpIfSet_dyn ) +import FastString import Monad ( when ) import Maybe ( catMaybes ) @@ -377,7 +378,7 @@ ifaceRule (id, Rule name act bndrs args rhs) bogusIfaceRule :: (NamedThing a) => a -> RuleDecl Name pat bogusIfaceRule id - = IfaceRule SLIT("bogus") NeverActive [] (getName id) [] (UfVar (getName id)) noSrcLoc + = IfaceRule FSLIT("bogus") NeverActive [] (getName id) [] (UfVar (getName id)) noSrcLoc \end{code} @@ -554,7 +555,7 @@ dump_rules rs = vcat [ptext SLIT("{-# RULES"), pprIface :: ModIface -> SDoc pprIface iface = vcat [ ptext SLIT("__interface") - <+> doubleQuotes (ptext (mi_package iface)) + <+> doubleQuotes (ftext (mi_package iface)) <+> ppr (mi_module iface) <+> ppr (vers_module version_info) <+> pp_sub_vers <+> (if mi_orphan iface then char '!' else empty) @@ -671,11 +672,11 @@ pprRulesAndDeprecs rules deprecs pp_deprecs deprecs = ptext SLIT("__D") <+> guts where guts = case deprecs of - DeprecAll txt -> doubleQuotes (ptext txt) + DeprecAll txt -> doubleQuotes (ftext txt) DeprecSome env -> ppr_deprec_env env -ppr_deprec_env :: NameEnv (Name, FAST_STRING) -> SDoc +ppr_deprec_env :: NameEnv (Name, FastString) -> SDoc ppr_deprec_env env = vcat (punctuate semi (map pp_deprec (nameEnvElts env))) where - pp_deprec (name, txt) = pprOcc name <+> doubleQuotes (ptext txt) + pp_deprec (name, txt) = pprOcc name <+> doubleQuotes (ftext txt) \end{code} diff --git a/ghc/compiler/main/ParsePkgConf.y b/ghc/compiler/main/ParsePkgConf.y index f710b150dd..995d3009be 100644 --- a/ghc/compiler/main/ParsePkgConf.y +++ b/ghc/compiler/main/ParsePkgConf.y @@ -81,7 +81,7 @@ happyError buf PState{ loc = loc } = PFailed (srcParseErr buf loc) loadPackageConfig :: FilePath -> IO [PackageConfig] loadPackageConfig conf_filename = do buf <- hGetStringBuffer conf_filename - let loc = mkSrcLoc (_PK_ conf_filename) 1 + let loc = mkSrcLoc (mkFastString conf_filename) 1 exts = ExtFlags {glasgowExtsEF = False, parrEF = False} case parse buf (mkPState loc exts) of diff --git a/ghc/compiler/nativeGen/AsmCodeGen.lhs b/ghc/compiler/nativeGen/AsmCodeGen.lhs index a9ce466713..d3acf16413 100644 --- a/ghc/compiler/nativeGen/AsmCodeGen.lhs +++ b/ghc/compiler/nativeGen/AsmCodeGen.lhs @@ -35,6 +35,7 @@ import MachMisc ( IF_ARCH_i386(i386_insert_ffrees,) ) import qualified Pretty import Outputable +import FastString -- DEBUGGING ONLY --import OrdList @@ -249,7 +250,7 @@ stixStmt_ConFold stmt -> let test_opt = stixExpr_ConFold test in if manifestlyZero test_opt - then StComment (_PK_ ("deleted: " ++ showSDoc (pprStixStmt stmt))) + then StComment (mkFastString ("deleted: " ++ showSDoc (pprStixStmt stmt))) else StCondJump addr (stixExpr_ConFold test) StData pk datas -> StData pk (map stixExpr_ConFold datas) diff --git a/ghc/compiler/nativeGen/MachCode.lhs b/ghc/compiler/nativeGen/MachCode.lhs index 1806565774..fe8bc6776b 100644 --- a/ghc/compiler/nativeGen/MachCode.lhs +++ b/ghc/compiler/nativeGen/MachCode.lhs @@ -50,6 +50,7 @@ import Stix ( pprStixStmt ) -- DEBUGGING ONLY import IOExts ( trace ) import Outputable ( assertPanic ) +import FastString infixr 3 `bind` \end{code} @@ -135,7 +136,7 @@ stmtToInstrs stmt = case stmt of -- Top-level lifted-out string. The segment will already have been set -- (see Stix.liftStrings). StDataString str - -> returnNat (unitOL (ASCII True (_UNPK_ str))) + -> returnNat (unitOL (ASCII True (unpackFS str))) #ifdef DEBUG other -> pprPanic "stmtToInstrs" (pprStixStmt other) @@ -543,7 +544,7 @@ getRegister (StString s) code dst = toOL [ SEGMENT RoDataSegment, LABEL lbl, - ASCII True (_UNPK_ s), + ASCII True (unpackFS s), SEGMENT TextSegment, #if alpha_TARGET_ARCH LDA dst (AddrImm imm_lbl) @@ -600,30 +601,30 @@ getRegister (StPrim primop [x]) -- unary PrimOps other_op -> getRegister (StCall fn CCallConv DoubleRep [x]) where fn = case other_op of - FloatExpOp -> SLIT("exp") - FloatLogOp -> SLIT("log") - FloatSqrtOp -> SLIT("sqrt") - FloatSinOp -> SLIT("sin") - FloatCosOp -> SLIT("cos") - FloatTanOp -> SLIT("tan") - FloatAsinOp -> SLIT("asin") - FloatAcosOp -> SLIT("acos") - FloatAtanOp -> SLIT("atan") - FloatSinhOp -> SLIT("sinh") - FloatCoshOp -> SLIT("cosh") - FloatTanhOp -> SLIT("tanh") - DoubleExpOp -> SLIT("exp") - DoubleLogOp -> SLIT("log") - DoubleSqrtOp -> SLIT("sqrt") - DoubleSinOp -> SLIT("sin") - DoubleCosOp -> SLIT("cos") - DoubleTanOp -> SLIT("tan") - DoubleAsinOp -> SLIT("asin") - DoubleAcosOp -> SLIT("acos") - DoubleAtanOp -> SLIT("atan") - DoubleSinhOp -> SLIT("sinh") - DoubleCoshOp -> SLIT("cosh") - DoubleTanhOp -> SLIT("tanh") + FloatExpOp -> FSLIT("exp") + FloatLogOp -> FSLIT("log") + FloatSqrtOp -> FSLIT("sqrt") + FloatSinOp -> FSLIT("sin") + FloatCosOp -> FSLIT("cos") + FloatTanOp -> FSLIT("tan") + FloatAsinOp -> FSLIT("asin") + FloatAcosOp -> FSLIT("acos") + FloatAtanOp -> FSLIT("atan") + FloatSinhOp -> FSLIT("sinh") + FloatCoshOp -> FSLIT("cosh") + FloatTanhOp -> FSLIT("tanh") + DoubleExpOp -> FSLIT("exp") + DoubleLogOp -> FSLIT("log") + DoubleSqrtOp -> FSLIT("sqrt") + DoubleSinOp -> FSLIT("sin") + DoubleCosOp -> FSLIT("cos") + DoubleTanOp -> FSLIT("tan") + DoubleAsinOp -> FSLIT("asin") + DoubleAcosOp -> FSLIT("acos") + DoubleAtanOp -> FSLIT("atan") + DoubleSinhOp -> FSLIT("sinh") + DoubleCoshOp -> FSLIT("cosh") + DoubleTanhOp -> FSLIT("tanh") where pr = panic "MachCode.getRegister: no primrep needed for Alpha" @@ -707,8 +708,8 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps ISraOp -> trivialCode SRA x y -- was: panic "AlphaGen:isra" ISrlOp -> trivialCode SRL x y -- was: panic "AlphaGen:isrl" - FloatPowerOp -> getRegister (StCall SLIT("pow") CCallConv DoubleRep [x,y]) - DoublePowerOp -> getRegister (StCall SLIT("pow") CCallConv DoubleRep [x,y]) + FloatPowerOp -> getRegister (StCall FSLIT("pow") CCallConv DoubleRep [x,y]) + DoublePowerOp -> getRegister (StCall FSLIT("pow") CCallConv DoubleRep [x,y]) where {- ------------------------------------------------------------ Some bizarre special code for getting condition codes into @@ -902,27 +903,27 @@ getRegister (StMachOp mop [x]) -- unary MachOps demote x = StMachOp MO_Dbl_to_Flt [x] (is_float_op, fn) = case mop of - MO_Flt_Exp -> (True, SLIT("exp")) - MO_Flt_Log -> (True, SLIT("log")) + MO_Flt_Exp -> (True, FSLIT("exp")) + MO_Flt_Log -> (True, FSLIT("log")) - MO_Flt_Asin -> (True, SLIT("asin")) - MO_Flt_Acos -> (True, SLIT("acos")) - MO_Flt_Atan -> (True, SLIT("atan")) + MO_Flt_Asin -> (True, FSLIT("asin")) + MO_Flt_Acos -> (True, FSLIT("acos")) + MO_Flt_Atan -> (True, FSLIT("atan")) - MO_Flt_Sinh -> (True, SLIT("sinh")) - MO_Flt_Cosh -> (True, SLIT("cosh")) - MO_Flt_Tanh -> (True, SLIT("tanh")) + MO_Flt_Sinh -> (True, FSLIT("sinh")) + MO_Flt_Cosh -> (True, FSLIT("cosh")) + MO_Flt_Tanh -> (True, FSLIT("tanh")) - MO_Dbl_Exp -> (False, SLIT("exp")) - MO_Dbl_Log -> (False, SLIT("log")) + MO_Dbl_Exp -> (False, FSLIT("exp")) + MO_Dbl_Log -> (False, FSLIT("log")) - MO_Dbl_Asin -> (False, SLIT("asin")) - MO_Dbl_Acos -> (False, SLIT("acos")) - MO_Dbl_Atan -> (False, SLIT("atan")) + MO_Dbl_Asin -> (False, FSLIT("asin")) + MO_Dbl_Acos -> (False, FSLIT("acos")) + MO_Dbl_Atan -> (False, FSLIT("atan")) - MO_Dbl_Sinh -> (False, SLIT("sinh")) - MO_Dbl_Cosh -> (False, SLIT("cosh")) - MO_Dbl_Tanh -> (False, SLIT("tanh")) + MO_Dbl_Sinh -> (False, FSLIT("sinh")) + MO_Dbl_Cosh -> (False, FSLIT("cosh")) + MO_Dbl_Tanh -> (False, FSLIT("tanh")) other -> pprPanic "getRegister(x86) - binary StMachOp (2)" (pprMachOp mop) @@ -997,10 +998,10 @@ getRegister (StMachOp mop [x, y]) -- dyadic MachOps MO_Nat_Sar -> shift_code (SAR L) x y {-False-} MO_Flt_Pwr -> getRegister (demote - (StCall (Left SLIT("pow")) CCallConv DoubleRep + (StCall (Left FSLIT("pow")) CCallConv DoubleRep [promote x, promote y]) ) - MO_Dbl_Pwr -> getRegister (StCall (Left SLIT("pow")) CCallConv DoubleRep + MO_Dbl_Pwr -> getRegister (StCall (Left FSLIT("pow")) CCallConv DoubleRep [x, y]) other -> pprPanic "getRegister(x86) - binary StMachOp (1)" (pprMachOp mop) where @@ -1089,7 +1090,7 @@ getRegister (StMachOp mop [x, y]) -- dyadic MachOps code_val `snocOL` MOV L (OpReg src_val) r_dst `appOL` toOL [ - COMMENT (_PK_ "begin shift sequence"), + COMMENT (mkFastString "begin shift sequence"), MOV L (OpReg src_val) r_dst, MOV L (OpReg src_amt) r_tmp, @@ -1118,7 +1119,7 @@ getRegister (StMachOp mop [x, y]) -- dyadic MachOps instr (ImmInt 1) r_dst, LABEL lbl_after, - COMMENT (_PK_ "end shift sequence") + COMMENT (mkFastString "end shift sequence") ] in returnNat (Any IntRep code__2) @@ -1290,37 +1291,37 @@ getRegister (StMachOp mop [x]) -- unary PrimOps (is_float_op, fn) = case mop of - MO_Flt_Exp -> (True, SLIT("exp")) - MO_Flt_Log -> (True, SLIT("log")) - MO_Flt_Sqrt -> (True, SLIT("sqrt")) + MO_Flt_Exp -> (True, FSLIT("exp")) + MO_Flt_Log -> (True, FSLIT("log")) + MO_Flt_Sqrt -> (True, FSLIT("sqrt")) - MO_Flt_Sin -> (True, SLIT("sin")) - MO_Flt_Cos -> (True, SLIT("cos")) - MO_Flt_Tan -> (True, SLIT("tan")) + MO_Flt_Sin -> (True, FSLIT("sin")) + MO_Flt_Cos -> (True, FSLIT("cos")) + MO_Flt_Tan -> (True, FSLIT("tan")) - MO_Flt_Asin -> (True, SLIT("asin")) - MO_Flt_Acos -> (True, SLIT("acos")) - MO_Flt_Atan -> (True, SLIT("atan")) + MO_Flt_Asin -> (True, FSLIT("asin")) + MO_Flt_Acos -> (True, FSLIT("acos")) + MO_Flt_Atan -> (True, FSLIT("atan")) - MO_Flt_Sinh -> (True, SLIT("sinh")) - MO_Flt_Cosh -> (True, SLIT("cosh")) - MO_Flt_Tanh -> (True, SLIT("tanh")) + MO_Flt_Sinh -> (True, FSLIT("sinh")) + MO_Flt_Cosh -> (True, FSLIT("cosh")) + MO_Flt_Tanh -> (True, FSLIT("tanh")) - MO_Dbl_Exp -> (False, SLIT("exp")) - MO_Dbl_Log -> (False, SLIT("log")) - MO_Dbl_Sqrt -> (False, SLIT("sqrt")) + MO_Dbl_Exp -> (False, FSLIT("exp")) + MO_Dbl_Log -> (False, FSLIT("log")) + MO_Dbl_Sqrt -> (False, FSLIT("sqrt")) - MO_Dbl_Sin -> (False, SLIT("sin")) - MO_Dbl_Cos -> (False, SLIT("cos")) - MO_Dbl_Tan -> (False, SLIT("tan")) + MO_Dbl_Sin -> (False, FSLIT("sin")) + MO_Dbl_Cos -> (False, FSLIT("cos")) + MO_Dbl_Tan -> (False, FSLIT("tan")) - MO_Dbl_Asin -> (False, SLIT("asin")) - MO_Dbl_Acos -> (False, SLIT("acos")) - MO_Dbl_Atan -> (False, SLIT("atan")) + MO_Dbl_Asin -> (False, FSLIT("asin")) + MO_Dbl_Acos -> (False, FSLIT("acos")) + MO_Dbl_Atan -> (False, FSLIT("atan")) - MO_Dbl_Sinh -> (False, SLIT("sinh")) - MO_Dbl_Cosh -> (False, SLIT("cosh")) - MO_Dbl_Tanh -> (False, SLIT("tanh")) + MO_Dbl_Sinh -> (False, FSLIT("sinh")) + MO_Dbl_Cosh -> (False, FSLIT("cosh")) + MO_Dbl_Tanh -> (False, FSLIT("tanh")) other -> pprPanic "getRegister(sparc) - binary StMachOp (2)" (pprMachOp mop) @@ -1370,10 +1371,10 @@ getRegister (StMachOp mop [x, y]) -- dyadic PrimOps MO_NatS_MulMayOflo -> imulMayOflo x y -- ToDo: teach about V8+ SPARC div instructions - MO_NatS_Quot -> idiv SLIT(".div") x y - MO_NatS_Rem -> idiv SLIT(".rem") x y - MO_NatU_Quot -> idiv SLIT(".udiv") x y - MO_NatU_Rem -> idiv SLIT(".urem") x y + MO_NatS_Quot -> idiv FSLIT(".div") x y + MO_NatS_Rem -> idiv FSLIT(".rem") x y + MO_NatU_Quot -> idiv FSLIT(".udiv") x y + MO_NatU_Rem -> idiv FSLIT(".urem") x y MO_Flt_Add -> trivialFCode FloatRep FADD x y MO_Flt_Sub -> trivialFCode FloatRep FSUB x y @@ -1393,10 +1394,10 @@ getRegister (StMachOp mop [x, y]) -- dyadic PrimOps MO_Nat_Shr -> trivialCode SRL x y MO_Nat_Sar -> trivialCode SRA x y - MO_Flt_Pwr -> getRegister (StCall (Left SLIT("pow")) CCallConv DoubleRep + MO_Flt_Pwr -> getRegister (StCall (Left FSLIT("pow")) CCallConv DoubleRep [promote x, promote y]) where promote x = StMachOp MO_Flt_to_Dbl [x] - MO_Dbl_Pwr -> getRegister (StCall (Left SLIT("pow")) CCallConv DoubleRep + MO_Dbl_Pwr -> getRegister (StCall (Left FSLIT("pow")) CCallConv DoubleRep [x, y]) other -> pprPanic "getRegister(sparc) - binary StMachOp (1)" (pprMachOp mop) @@ -2625,7 +2626,7 @@ register allocator. \begin{code} genCCall - :: (Either FAST_STRING StixExpr) -- function to call + :: (Either FastString StixExpr) -- function to call -> CCallConv -> PrimRep -- type of the result -> [StixExpr] -- arguments (of mixed type) @@ -2741,7 +2742,7 @@ genCCall fn cconv ret_rep args -- internally generated names like '.mul,' which don't get an -- underscore prefix -- ToDo:needed (WDP 96/03) ??? - fn_u = _UNPK_ (unLeft fn) + fn_u = unpackFS (unLeft fn) fn__2 tot_arg_size | head fn_u == '.' = ImmLit (text (fn_u ++ stdcallsize tot_arg_size)) @@ -2886,7 +2887,7 @@ genCCall fn cconv kind args -- underscore prefix -- ToDo:needed (WDP 96/03) ??? fn_static = unLeft fn - fn__2 = case (_HEAD_ fn_static) of + fn__2 = case (headFS fn_static) of '.' -> ImmLit (ptext fn_static) _ -> ImmLab False (ptext fn_static) diff --git a/ghc/compiler/nativeGen/MachMisc.lhs b/ghc/compiler/nativeGen/MachMisc.lhs index 012b319dea..aa2e961d9e 100644 --- a/ghc/compiler/nativeGen/MachMisc.lhs +++ b/ghc/compiler/nativeGen/MachMisc.lhs @@ -58,6 +58,7 @@ import Outputable ( pprPanic, ppr, showSDoc ) import IOExts ( trace ) import Config ( cLeadingUnderscore ) import FastTypes +import FastString import Maybe ( catMaybes ) \end{code} @@ -328,7 +329,7 @@ mostly all of @Instr@ is machine-specific. \begin{code} data Instr - = COMMENT FAST_STRING -- comment pseudo-op + = COMMENT FastString -- comment pseudo-op | SEGMENT CodeSegment -- {data,text} segment pseudo-op | LABEL CLabel -- global label pseudo-op | ASCII Bool -- True <=> needs backslash conversion diff --git a/ghc/compiler/nativeGen/PprMach.lhs b/ghc/compiler/nativeGen/PprMach.lhs index 84374d84d0..b91597157e 100644 --- a/ghc/compiler/nativeGen/PprMach.lhs +++ b/ghc/compiler/nativeGen/PprMach.lhs @@ -28,6 +28,7 @@ import ST import MutableArray import Char ( chr, ord ) import Maybe ( isJust ) +import FastString asmSDoc d = Outputable.withPprStyleDoc ( Outputable.mkCodeStyle Outputable.AsmStyle) d @@ -387,13 +388,13 @@ pprInstr :: Instr -> Doc --pprInstr (COMMENT s) = empty -- nuke 'em pprInstr (COMMENT s) - = IF_ARCH_alpha( ((<>) (ptext SLIT("\t# ")) (ptext s)) - ,IF_ARCH_sparc( ((<>) (ptext SLIT("! ")) (ptext s)) - ,IF_ARCH_i386( ((<>) (ptext SLIT("# ")) (ptext s)) + = IF_ARCH_alpha( ((<>) (ptext SLIT("\t# ")) (ftext s)) + ,IF_ARCH_sparc( ((<>) (ptext SLIT("! ")) (ftext s)) + ,IF_ARCH_i386( ((<>) (ptext SLIT("# ")) (ftext s)) ,))) pprInstr (DELTA d) - = pprInstr (COMMENT (_PK_ ("\tdelta = " ++ show d))) + = pprInstr (COMMENT (mkFastString ("\tdelta = " ++ show d))) pprInstr (SEGMENT TextSegment) = IF_ARCH_alpha(ptext SLIT("\t.text\n\t.align 3") {-word boundary-} @@ -868,8 +869,7 @@ pprRI :: RI -> Doc pprRI (RIReg r) = pprReg r pprRI (RIImm r) = pprImm r -pprRegRIReg :: FAST_STRING -> Reg -> RI -> Reg -> Doc - +pprRegRIReg :: LitString -> Reg -> RI -> Reg -> Doc pprRegRIReg name reg1 ri reg2 = hcat [ char '\t', @@ -882,8 +882,7 @@ pprRegRIReg name reg1 ri reg2 pprReg reg2 ] -pprSizeRegRegReg :: FAST_STRING -> Size -> Reg -> Reg -> Reg -> Doc - +pprSizeRegRegReg :: LitString -> Size -> Reg -> Reg -> Reg -> Doc pprSizeRegRegReg name size reg1 reg2 reg3 = hcat [ char '\t', @@ -1293,7 +1292,7 @@ pprOperand s (OpReg r) = pprReg s r pprOperand s (OpImm i) = pprDollImm i pprOperand s (OpAddr ea) = pprAddr ea -pprSizeImmOp :: FAST_STRING -> Size -> Imm -> Operand -> Doc +pprSizeImmOp :: LitString -> Size -> Imm -> Operand -> Doc pprSizeImmOp name size imm op1 = hcat [ char '\t', @@ -1306,7 +1305,7 @@ pprSizeImmOp name size imm op1 pprOperand size op1 ] -pprSizeOp :: FAST_STRING -> Size -> Operand -> Doc +pprSizeOp :: LitString -> Size -> Operand -> Doc pprSizeOp name size op1 = hcat [ char '\t', @@ -1316,7 +1315,7 @@ pprSizeOp name size op1 pprOperand size op1 ] -pprSizeOpOp :: FAST_STRING -> Size -> Operand -> Operand -> Doc +pprSizeOpOp :: LitString -> Size -> Operand -> Operand -> Doc pprSizeOpOp name size op1 op2 = hcat [ char '\t', @@ -1328,7 +1327,7 @@ pprSizeOpOp name size op1 op2 pprOperand size op2 ] -pprSizeByteOpOp :: FAST_STRING -> Size -> Operand -> Operand -> Doc +pprSizeByteOpOp :: LitString -> Size -> Operand -> Operand -> Doc pprSizeByteOpOp name size op1 op2 = hcat [ char '\t', @@ -1340,7 +1339,7 @@ pprSizeByteOpOp name size op1 op2 pprOperand size op2 ] -pprSizeOpReg :: FAST_STRING -> Size -> Operand -> Reg -> Doc +pprSizeOpReg :: LitString -> Size -> Operand -> Reg -> Doc pprSizeOpReg name size op1 reg = hcat [ char '\t', @@ -1352,7 +1351,7 @@ pprSizeOpReg name size op1 reg pprReg size reg ] -pprSizeReg :: FAST_STRING -> Size -> Reg -> Doc +pprSizeReg :: LitString -> Size -> Reg -> Doc pprSizeReg name size reg1 = hcat [ char '\t', @@ -1362,7 +1361,7 @@ pprSizeReg name size reg1 pprReg size reg1 ] -pprSizeRegReg :: FAST_STRING -> Size -> Reg -> Reg -> Doc +pprSizeRegReg :: LitString -> Size -> Reg -> Reg -> Doc pprSizeRegReg name size reg1 reg2 = hcat [ char '\t', @@ -1374,7 +1373,7 @@ pprSizeRegReg name size reg1 reg2 pprReg size reg2 ] -pprCondRegReg :: FAST_STRING -> Size -> Cond -> Reg -> Reg -> Doc +pprCondRegReg :: LitString -> Size -> Cond -> Reg -> Reg -> Doc pprCondRegReg name size cond reg1 reg2 = hcat [ char '\t', @@ -1386,7 +1385,7 @@ pprCondRegReg name size cond reg1 reg2 pprReg size reg2 ] -pprSizeSizeRegReg :: FAST_STRING -> Size -> Size -> Reg -> Reg -> Doc +pprSizeSizeRegReg :: LitString -> Size -> Size -> Reg -> Reg -> Doc pprSizeSizeRegReg name size1 size2 reg1 reg2 = hcat [ char '\t', @@ -1395,11 +1394,12 @@ pprSizeSizeRegReg name size1 size2 reg1 reg2 pprSize size2, space, pprReg size1 reg1, + comma, pprReg size2 reg2 ] -pprSizeRegRegReg :: FAST_STRING -> Size -> Reg -> Reg -> Reg -> Doc +pprSizeRegRegReg :: LitString -> Size -> Reg -> Reg -> Reg -> Doc pprSizeRegRegReg name size reg1 reg2 reg3 = hcat [ char '\t', @@ -1413,7 +1413,7 @@ pprSizeRegRegReg name size reg1 reg2 reg3 pprReg size reg3 ] -pprSizeAddr :: FAST_STRING -> Size -> MachRegsAddr -> Doc +pprSizeAddr :: LitString -> Size -> MachRegsAddr -> Doc pprSizeAddr name size op = hcat [ char '\t', @@ -1423,7 +1423,7 @@ pprSizeAddr name size op pprAddr op ] -pprSizeAddrReg :: FAST_STRING -> Size -> MachRegsAddr -> Reg -> Doc +pprSizeAddrReg :: LitString -> Size -> MachRegsAddr -> Reg -> Doc pprSizeAddrReg name size op dst = hcat [ char '\t', @@ -1435,7 +1435,7 @@ pprSizeAddrReg name size op dst pprReg size dst ] -pprSizeRegAddr :: FAST_STRING -> Size -> Reg -> MachRegsAddr -> Doc +pprSizeRegAddr :: LitString -> Size -> Reg -> MachRegsAddr -> Doc pprSizeRegAddr name size src op = hcat [ char '\t', @@ -1447,7 +1447,7 @@ pprSizeRegAddr name size src op pprAddr op ] -pprOpOp :: FAST_STRING -> Size -> Operand -> Operand -> Doc +pprOpOp :: LitString -> Size -> Operand -> Operand -> Doc pprOpOp name size op1 op2 = hcat [ char '\t', @@ -1457,7 +1457,7 @@ pprOpOp name size op1 op2 pprOperand size op2 ] -pprSizeOpOpCoerce :: FAST_STRING -> Size -> Size -> Operand -> Operand -> Doc +pprSizeOpOpCoerce :: LitString -> Size -> Size -> Operand -> Operand -> Doc pprSizeOpOpCoerce name size1 size2 op1 op2 = hcat [ char '\t', ptext name, pprSize size1, pprSize size2, space, pprOperand size1 op1, @@ -1465,7 +1465,7 @@ pprSizeOpOpCoerce name size1 size2 op1 op2 pprOperand size2 op2 ] -pprCondInstr :: FAST_STRING -> Cond -> Doc -> Doc +pprCondInstr :: LitString -> Cond -> Doc -> Doc pprCondInstr name cond arg = hcat [ char '\t', ptext name, pprCond cond, space, arg] @@ -1699,7 +1699,7 @@ pprRI :: RI -> Doc pprRI (RIReg r) = pprReg r pprRI (RIImm r) = pprImm r -pprSizeRegReg :: FAST_STRING -> Size -> Reg -> Reg -> Doc +pprSizeRegReg :: LitString -> Size -> Reg -> Reg -> Doc pprSizeRegReg name size reg1 reg2 = hcat [ char '\t', @@ -1712,7 +1712,7 @@ pprSizeRegReg name size reg1 reg2 pprReg reg2 ] -pprSizeRegRegReg :: FAST_STRING -> Size -> Reg -> Reg -> Reg -> Doc +pprSizeRegRegReg :: LitString -> Size -> Reg -> Reg -> Reg -> Doc pprSizeRegRegReg name size reg1 reg2 reg3 = hcat [ char '\t', @@ -1727,7 +1727,7 @@ pprSizeRegRegReg name size reg1 reg2 reg3 pprReg reg3 ] -pprRegRIReg :: FAST_STRING -> Bool -> Reg -> RI -> Reg -> Doc +pprRegRIReg :: LitString -> Bool -> Reg -> RI -> Reg -> Doc pprRegRIReg name b reg1 ri reg2 = hcat [ char '\t', @@ -1740,7 +1740,7 @@ pprRegRIReg name b reg1 ri reg2 pprReg reg2 ] -pprRIReg :: FAST_STRING -> Bool -> RI -> Reg -> Doc +pprRIReg :: LitString -> Bool -> RI -> Reg -> Doc pprRIReg name b ri reg1 = hcat [ char '\t', diff --git a/ghc/compiler/nativeGen/Stix.lhs b/ghc/compiler/nativeGen/Stix.lhs index 95c54f1f9f..bae8b64b4f 100644 --- a/ghc/compiler/nativeGen/Stix.lhs +++ b/ghc/compiler/nativeGen/Stix.lhs @@ -49,6 +49,7 @@ import UniqSupply ( UniqSupply, splitUniqSupply, uniqFromSupply, import Constants ( wORD_SIZE ) import Outputable import FastTypes +import FastString \end{code} Two types, StixStmt and StixValue, define Stix. @@ -62,7 +63,7 @@ data StixStmt StSegment CodeSegment -- Assembly-language comments - | StComment FAST_STRING + | StComment FastString -- Assignments are typed to determine size and register placement. -- Assign a value to a StixReg @@ -98,7 +99,7 @@ data StixStmt -- Raw data (as in an info table). | StData PrimRep [StixExpr] -- String which has been lifted to the top level (sigh). - | StDataString FAST_STRING + | StDataString FastString -- A value computed only for its side effects; result is discarded -- (A handy trapdoor to allow CCalls with no results to appear as @@ -134,7 +135,7 @@ data StixExpr StInt Integer -- ** add Kind at some point | StFloat Rational | StDouble Rational - | StString FAST_STRING + | StString FastString | StCLbl CLabel -- labels that we might index into -- Abstract registers of various kinds @@ -150,7 +151,7 @@ data StixExpr | StMachOp MachOp [StixExpr] -- Calls to C functions - | StCall (Either FAST_STRING StixExpr) -- Left: static, Right: dynamic + | StCall (Either FastString StixExpr) -- Left: static, Right: dynamic CCallConv PrimRep [StixExpr] @@ -197,7 +198,7 @@ pprStixExpr t StInt i -> (if i < 0 then parens else id) (integer i) StFloat rat -> parens (text "Float" <+> rational rat) StDouble rat -> parens (text "Double" <+> rational rat) - StString str -> parens (text "Str `" <> ptext str <> char '\'') + StString str -> parens (text "Str `" <> ftext str <> char '\'') StIndex k b o -> parens (pprStixExpr b <+> char '+' <> ppr k <+> pprStixExpr o) StInd k t -> ppr k <> char '[' <> pprStixExpr t <> char ']' @@ -210,14 +211,14 @@ pprStixExpr t hsep (map pprStixExpr args)) where targ = case fn of - Left t_static -> ptext t_static + Left t_static -> ftext t_static Right t_dyn -> parens (pprStixExpr t_dyn) pprStixStmt :: StixStmt -> SDoc pprStixStmt t = case t of StSegment cseg -> parens (ppCodeSegment cseg) - StComment str -> parens (text "Comment" <+> ptext str) + StComment str -> parens (text "Comment" <+> ftext str) StAssignReg pr reg rhs -> pprStixReg reg <> text " :=" <> ppr pr <> text " " <> pprStixExpr rhs @@ -493,7 +494,7 @@ liftStrings stmts liftStrings_wrk :: [StixStmt] -- originals -> [StixStmt] -- (reverse) originals with strings lifted out - -> [(CLabel, FAST_STRING)] -- lifted strs, and their new labels + -> [(CLabel, FastString)] -- lifted strs, and their new labels -> UniqSM [StixStmt] -- First, examine the original trees and lift out strings in top-level StDatas. @@ -619,4 +620,4 @@ ncg_target_is_32bit :: Bool ncg_target_is_32bit | wORD_SIZE == 4 = True | wORD_SIZE == 8 = False -\end{code}
\ No newline at end of file +\end{code} diff --git a/ghc/compiler/nativeGen/StixMacro.lhs b/ghc/compiler/nativeGen/StixMacro.lhs index a57c95128a..dfa2eccf07 100644 --- a/ghc/compiler/nativeGen/StixMacro.lhs +++ b/ghc/compiler/nativeGen/StixMacro.lhs @@ -72,7 +72,7 @@ adding an indirection. macroCode UPD_CAF args = let [cafptr,bhptr] = map amodeToStix args - new_caf = StVoidable (StCall (Left SLIT("newCAF")) CCallConv VoidRep [cafptr]) + new_caf = StVoidable (StCall (Left FSLIT("newCAF")) CCallConv VoidRep [cafptr]) a1 = StAssignMem PtrRep (StIndex PtrRep cafptr fixedHS) bhptr a2 = StAssignMem PtrRep cafptr ind_static_info in @@ -178,7 +178,7 @@ macroCode REGISTER_IMPORT [arg] macroCode REGISTER_FOREIGN_EXPORT [arg] = returnUs ( \xs -> StVoidable ( - StCall (Left SLIT("getStablePtr")) CCallConv VoidRep + StCall (Left FSLIT("getStablePtr")) CCallConv VoidRep [amodeToStix arg] ) : xs diff --git a/ghc/compiler/nativeGen/StixPrim.lhs b/ghc/compiler/nativeGen/StixPrim.lhs index 0610bedcc5..79d4da2261 100644 --- a/ghc/compiler/nativeGen/StixPrim.lhs +++ b/ghc/compiler/nativeGen/StixPrim.lhs @@ -82,10 +82,10 @@ foreignCallCode lhs call@(CCall (CCallSpec ctarget cconv safety)) rhs | otherwise = 0 suspend = StAssignReg IntRep id - (StCall (Left SLIT("suspendThread")) {-no:cconv-} CCallConv + (StCall (Left FSLIT("suspendThread")) {-no:cconv-} CCallConv IntRep [StReg stgBaseReg, StInt is_threadSafe ]) resume = StVoidable - (StCall (Left SLIT("resumeThread")) {-no:cconv-} CCallConv + (StCall (Left FSLIT("resumeThread")) {-no:cconv-} CCallConv VoidRep [StReg id, StInt is_threadSafe ]) in returnUs (\xs -> save (suspend : ccall : resume : load xs)) diff --git a/ghc/compiler/ndpFlatten/Flattening.hs b/ghc/compiler/ndpFlatten/Flattening.hs index 4733bc43ca..796d34e009 100644 --- a/ghc/compiler/ndpFlatten/Flattening.hs +++ b/ghc/compiler/ndpFlatten/Flattening.hs @@ -79,7 +79,7 @@ import VarEnv (IdEnv, mkVarEnv, zipVarEnv, extendVarEnv) import TysWiredIn (mkTupleTy) import BasicTypes (Boxity(..)) import Outputable (showSDoc, Outputable(..)) - +import FastString -- friends import NDPCoreUtils (tupleTyArgs, funTyArgs, parrElemTy, isDefault, @@ -94,9 +94,6 @@ import IOExts (trace) #include "HsVersions.h" -{-# INLINE slit #-} -slit x = FastString.mkFastCharString# x --- FIXME: SLIT() doesn't work for some strange reason -- toplevel transformation @@ -505,10 +502,10 @@ liftSingleDataCon b dcon bnds expr = do let dconId = dataConTag dcon indexExpr <- mkIndexOfExprDCon (varType b) b dconId - (b', bbind) <- mkBind (slit "is"#) indexExpr + (bb, bbind) <- mkBind FSLIT("is") indexExpr lbnds <- mapM liftBinderType bnds - ((lExpr, _), bnds') <- packContext b' (extendContext lbnds (lift expr)) - (_, vbind) <- mkBind (slit "r"#) lExpr + ((lExpr, _), bnds') <- packContext bb (extendContext lbnds (lift expr)) + (_, vbind) <- mkBind FSLIT("r") lExpr return (bbind, vbind, bnds') -- FIXME: clean this up. the datacon and the literal case are so @@ -521,9 +518,9 @@ liftCaseDataConDefault b (_, _, def) alts = do let dconIds = map (\(DataAlt d, _, _) -> dataConTag d) alts indexExpr <- mkIndexOfExprDConDft (varType b) b dconIds - (b', bbind) <- mkBind (slit "is"#) indexExpr - ((lDef, _), bnds) <- packContext b' (lift def) - (_, vbind) <- mkBind (slit "r"#) lDef + (bb, bbind) <- mkBind FSLIT("is") indexExpr + ((lDef, _), bnds) <- packContext bb (lift def) + (_, vbind) <- mkBind FSLIT("r") lDef return (bbind, vbind, bnds) -- liftCaseLit: checks if we have a default case and handles it @@ -552,9 +549,9 @@ liftCaseLitDefault b (_, _, def) alts = do let lits = map (\(LitAlt l, _, _) -> l) alts indexExpr <- mkIndexOfExprDft (varType b) b lits - (b', bbind) <- mkBind (slit "is"#) indexExpr - ((lDef, _), bnds) <- packContext b' (lift def) - (_, vbind) <- mkBind (slit "r"#) lDef + (bb, bbind) <- mkBind FSLIT("is") indexExpr + ((lDef, _), bnds) <- packContext bb (lift def) + (_, vbind) <- mkBind FSLIT("r") lDef return (bbind, vbind, bnds) -- FIXME: @@ -591,9 +588,9 @@ liftSingleCaseLit:: CoreBndr -> Literal -> CoreExpr -> liftSingleCaseLit b lit expr = do indexExpr <- mkIndexOfExpr (varType b) b lit -- (a) - (b', bbind) <- mkBind (slit "is"#) indexExpr - ((lExpr, t), bnds) <- packContext b' (lift expr) -- (b) - (_, vbind) <- mkBind (slit "r"#) lExpr + (bb, bbind) <- mkBind FSLIT("is") indexExpr + ((lExpr, t), bnds) <- packContext bb (lift expr) -- (b) + (_, vbind) <- mkBind FSLIT("r") lExpr return (bbind, vbind, bnds) -- letWrapper lExpr b ([indexbnd_i], [exprbnd_i], [pckbnd_ij]) @@ -767,7 +764,7 @@ mkDftBackpermute :: Type -> Var -> Var -> Var -> Flatten CoreBind mkDftBackpermute ty idx src dft = do rhs <- mk'bpermuteDftP ty (Var idx) (Var src) (Var dft) - liftM snd $ mkBind (slit "dbp"#) rhs + liftM snd $ mkBind FSLIT("dbp") rhs -- create a dummy array with elements of the given type, which can be used as -- default array for the combination of the subresults of the lifted case @@ -781,7 +778,7 @@ createDftArrayBind e = let ty = parrElemTy . exprType $ expr len <- mk'lengthP e rhs <- mk'replicateP ty len err?? - lift snd $ mkBind (slit "dft"#) rhs + lift snd $ mkBind FSLIT("dft") rhs FIXME: nicht so einfach; man kann kein "error"-Wert nehmen, denn der w"urde beim bpermuteDftP sofort evaluiert, aber es ist auch schwer m"oglich einen generischen Wert f"ur jeden beliebigen Typ zu erfinden. @@ -809,4 +806,4 @@ showCoreExpr (Case ex b alts) = "Case b = " ++ (showCoreExpr ex) ++ " of \n" ++ (showAlts alts) where showAlts _ = "" showCoreExpr (Note _ ex) = "Note n " ++ (showCoreExpr ex) -showCoreExpr (Type t) = "Type"
\ No newline at end of file +showCoreExpr (Type t) = "Type" diff --git a/ghc/compiler/parser/Lex.lhs b/ghc/compiler/parser/Lex.lhs index 6c497cb894..26bcf9dac1 100644 --- a/ghc/compiler/parser/Lex.lhs +++ b/ghc/compiler/parser/Lex.lhs @@ -169,31 +169,31 @@ data Token | ITunderscore | ITbackquote - | ITvarid FAST_STRING -- identifiers - | ITconid FAST_STRING - | ITvarsym FAST_STRING - | ITconsym FAST_STRING - | ITqvarid (FAST_STRING,FAST_STRING) - | ITqconid (FAST_STRING,FAST_STRING) - | ITqvarsym (FAST_STRING,FAST_STRING) - | ITqconsym (FAST_STRING,FAST_STRING) - - | ITdupipvarid FAST_STRING -- GHC extension: implicit param: ?x - | ITsplitipvarid FAST_STRING -- GHC extension: implicit param: %x + | ITvarid FastString -- identifiers + | ITconid FastString + | ITvarsym FastString + | ITconsym FastString + | ITqvarid (FastString,FastString) + | ITqconid (FastString,FastString) + | ITqvarsym (FastString,FastString) + | ITqconsym (FastString,FastString) + + | ITdupipvarid FastString -- GHC extension: implicit param: ?x + | ITsplitipvarid FastString -- GHC extension: implicit param: %x | ITpragma StringBuffer | ITchar Int - | ITstring FAST_STRING + | ITstring FastString | ITinteger Integer | ITrational Rational | ITprimchar Int - | ITprimstring FAST_STRING + | ITprimstring FastString | ITprimint Integer | ITprimfloat Rational | ITprimdouble Rational - | ITlitlit FAST_STRING + | ITlitlit FastString | ITunknown String -- Used when the lexer can't make sense of it | ITeof -- end of file token @@ -205,7 +205,7 @@ Keyword Lists \begin{code} pragmaKeywordsFM = listToUFM $ - map (\ (x,y) -> (_PK_ x,y)) + map (\ (x,y) -> (mkFastString x,y)) [( "SPECIALISE", ITspecialise_prag ), ( "SPECIALIZE", ITspecialise_prag ), ( "SOURCE", ITsource_prag ), @@ -220,7 +220,7 @@ pragmaKeywordsFM = listToUFM $ ] haskellKeywordsFM = listToUFM $ - map (\ (x,y) -> (_PK_ x,y)) + map (\ (x,y) -> (mkFastString x,y)) [( "_", ITunderscore ), ( "as", ITas ), ( "case", ITcase ), @@ -270,7 +270,7 @@ isSpecial _ = False -- IMPORTANT: Keep this in synch with ParseIface.y's var_fs production! (SUP) ghcExtensionKeywordsFM = listToUFM $ - map (\ (x,y) -> (_PK_ x,y)) + map (\ (x,y) -> (mkFastString x,y)) [ ( "forall", ITforall ), ( "foreign", ITforeign ), ( "export", ITexport ), @@ -291,7 +291,7 @@ ghcExtensionKeywordsFM = listToUFM $ haskellKeySymsFM = listToUFM $ - map (\ (x,y) -> (_PK_ x,y)) + map (\ (x,y) -> (mkFastString x,y)) [ ("..", ITdotdot) ,("::", ITdcolon) ,("=", ITequal) @@ -873,7 +873,7 @@ lex_id cont exts buf = let lexeme = lexemeToFastString buf' in case _scc_ "haskellKeyword" lookupUFM haskellKeywordsFM lexeme of { - Just kwd_token -> --trace ("hkeywd: "++_UNPK_(lexeme)) $ + Just kwd_token -> --trace ("hkeywd: "++unpackFS(lexeme)) $ cont kwd_token buf'; Nothing -> @@ -934,7 +934,7 @@ maybe_qualified cont exts mod buf just_a_conid = case currentChar# buf of '['# -> -- Special case for [] case lookAhead# buf 1# of - ']'# -> cont (ITqconid (mod,SLIT("[]"))) (setCurrentPos# buf 2#) + ']'# -> cont (ITqconid (mod,FSLIT("[]"))) (setCurrentPos# buf 2#) _ -> just_a_conid '('# -> -- Special case for (,,,) @@ -944,12 +944,12 @@ maybe_qualified cont exts mod buf just_a_conid = ','# -> lex_ubx_tuple cont mod (setCurrentPos# buf 3#) just_a_conid _ -> just_a_conid - ')'# -> cont (ITqconid (mod,SLIT("()"))) (setCurrentPos# buf 2#) + ')'# -> cont (ITqconid (mod,FSLIT("()"))) (setCurrentPos# buf 2#) ','# -> lex_tuple cont mod (setCurrentPos# buf 2#) just_a_conid _ -> just_a_conid '-'# -> case lookAhead# buf 1# of - '>'# -> cont (ITqconid (mod,SLIT("(->)"))) (setCurrentPos# buf 2#) + '>'# -> cont (ITqconid (mod,FSLIT("(->)"))) (setCurrentPos# buf 2#) _ -> lex_id3 cont exts mod buf just_a_conid _ -> lex_id3 cont exts mod buf just_a_conid @@ -1011,7 +1011,7 @@ mk_var_token pk_str | f `eqChar#` ':'# = ITconsym pk_str | otherwise = ITvarsym pk_str where - (C# f) = _HEAD_ pk_str + (C# f) = headFS pk_str -- tl = _TAIL_ pk_str mk_qvar_token m token = @@ -1112,7 +1112,7 @@ setSrcLocP new_loc p buf s = POk _ a -> POk s a PFailed e -> PFailed e -getSrcFile :: P FAST_STRING +getSrcFile :: P FastString getSrcFile buf s@(PState{ loc = loc }) = POk s (srcLocFile loc) pushContext :: LayoutContext -> P () diff --git a/ghc/compiler/parser/ParseUtil.lhs b/ghc/compiler/parser/ParseUtil.lhs index 6314914683..a9ae3ffb1b 100644 --- a/ghc/compiler/parser/ParseUtil.lhs +++ b/ghc/compiler/parser/ParseUtil.lhs @@ -15,11 +15,11 @@ module ParseUtil ( , CallConv(..) , mkImport -- CallConv -> Safety - -- -> (FAST_STRING, RdrName, RdrNameHsType) + -- -> (FastString, RdrName, RdrNameHsType) -- -> SrcLoc -- -> P RdrNameHsDecl , mkExport -- CallConv - -- -> (FAST_STRING, RdrName, RdrNameHsType) + -- -> (FastString, RdrName, RdrNameHsType) -- -> SrcLoc -- -> P RdrNameHsDecl , mkExtName -- RdrName -> CLabelString @@ -52,7 +52,7 @@ import PrelNames ( unitTyCon_RDR ) import OccName ( dataName, varName, tcClsName, isDataOcc, occNameSpace, setOccNameSpace, occNameUserString ) import CStrings ( CLabelString ) -import FastString ( nullFastString ) +import FastString import Outputable ----------------------------------------------------------------------------- @@ -319,7 +319,7 @@ data CallConv = CCall CCallConv -- ccall or stdcall -- mkImport :: CallConv -> Safety - -> (FAST_STRING, RdrName, RdrNameHsType) + -> (FastString, RdrName, RdrNameHsType) -> SrcLoc -> P RdrNameHsDecl mkImport (CCall cconv) safety (entity, v, ty) loc = @@ -331,7 +331,7 @@ mkImport (DNCall ) _ (entity, v, ty) loc = -- parse the entity string of a foreign import declaration for the `ccall' or -- `stdcall' calling convention' -- -parseCImport :: FAST_STRING +parseCImport :: FastString -> CCallConv -> Safety -> RdrName @@ -339,43 +339,43 @@ parseCImport :: FAST_STRING parseCImport entity cconv safety v -- FIXME: we should allow white space around `dynamic' and `wrapper' -=chak | entity == FSLIT ("dynamic") = - returnP $ CImport cconv safety _NIL_ _NIL_ (CFunction DynamicTarget) + returnP $ CImport cconv safety nilFS nilFS (CFunction DynamicTarget) | entity == FSLIT ("wrapper") = - returnP $ CImport cconv safety _NIL_ _NIL_ CWrapper - | otherwise = parse0 (_UNPK_ entity) + returnP $ CImport cconv safety nilFS nilFS CWrapper + | otherwise = parse0 (unpackFS entity) where -- using the static keyword? parse0 (' ': rest) = parse0 rest parse0 ('s':'t':'a':'t':'i':'c':rest) = parse1 rest parse0 rest = parse1 rest -- check for header file name - parse1 "" = parse4 "" _NIL_ False _NIL_ + parse1 "" = parse4 "" nilFS False nilFS parse1 (' ':rest) = parse1 rest - parse1 str@('&':_ ) = parse2 str _NIL_ - parse1 str@('[':_ ) = parse3 str _NIL_ False + parse1 str@('&':_ ) = parse2 str nilFS + parse1 str@('[':_ ) = parse3 str nilFS False parse1 str - | ".h" `isSuffixOf` first = parse2 rest (_PK_ first) - | otherwise = parse4 str _NIL_ False _NIL_ + | ".h" `isSuffixOf` first = parse2 rest (mkFastString first) + | otherwise = parse4 str nilFS False nilFS where (first, rest) = break (\c -> c == ' ' || c == '&' || c == '[') str -- check for address operator (indicating a label import) - parse2 "" header = parse4 "" header False _NIL_ + parse2 "" header = parse4 "" header False nilFS parse2 (' ':rest) header = parse2 rest header parse2 ('&':rest) header = parse3 rest header True parse2 str@('[':_ ) header = parse3 str header False - parse2 str header = parse4 str header False _NIL_ + parse2 str header = parse4 str header False nilFS -- check for library object name parse3 (' ':rest) header isLbl = parse3 rest header isLbl parse3 ('[':rest) header isLbl = case break (== ']') rest of - (lib, ']':rest) -> parse4 rest header isLbl (_PK_ lib) + (lib, ']':rest) -> parse4 rest header isLbl (mkFastString lib) _ -> parseError "Missing ']' in entity" - parse3 str header isLbl = parse4 str header isLbl _NIL_ + parse3 str header isLbl = parse4 str header isLbl nilFS -- check for name of C function parse4 "" header isLbl lib = build (mkExtName v) header isLbl lib parse4 (' ':rest) header isLbl lib = parse4 rest header isLbl lib parse4 str header isLbl lib - | all (== ' ') rest = build (_PK_ first) header isLbl lib + | all (== ' ') rest = build (mkFastString first) header isLbl lib | otherwise = parseError "Malformed entity string" where (first, rest) = break (== ' ') str @@ -388,7 +388,7 @@ parseCImport entity cconv safety v -- construct a foreign export declaration -- mkExport :: CallConv - -> (FAST_STRING, RdrName, RdrNameHsType) + -> (FastString, RdrName, RdrNameHsType) -> SrcLoc -> P RdrNameHsDecl mkExport (CCall cconv) (entity, v, ty) loc = returnP $ @@ -407,7 +407,7 @@ mkExport DNCall (entity, v, ty) loc = -- (This is why we use occNameUserString.) -- mkExtName :: RdrName -> CLabelString -mkExtName rdrNm = _PK_ (occNameUserString (rdrNameOcc rdrNm)) +mkExtName rdrNm = mkFastString (occNameUserString (rdrNameOcc rdrNm)) ----------------------------------------------------------------------------- -- group function bindings into equation groups diff --git a/ghc/compiler/parser/Parser.y b/ghc/compiler/parser/Parser.y index 39f3335c6c..3ecaff1a42 100644 --- a/ghc/compiler/parser/Parser.y +++ b/ghc/compiler/parser/Parser.y @@ -1,6 +1,6 @@ {- -*-haskell-*- ----------------------------------------------------------------------------- -$Id: Parser.y,v 1.95 2002/04/02 13:56:32 simonmar Exp $ +$Id: Parser.y,v 1.96 2002/04/29 14:03:57 simonmar Exp $ Haskell grammar. @@ -597,7 +597,7 @@ fdecl1DEPRECATED :: { Bool -> SrcLoc -> ForeignDecl RdrName } fdecl1DEPRECATED ----------- DEPRECATED label decls ------------ : 'label' ext_name varid '::' sigtype - { ForeignImport $3 $5 (CImport defaultCCallConv (PlaySafe False) _NIL_ _NIL_ + { ForeignImport $3 $5 (CImport defaultCCallConv (PlaySafe False) nilFS nilFS (CLabel ($2 `orElse` mkExtName $3))) } ----------- DEPRECATED ccall/stdcall decls ------------ @@ -611,7 +611,7 @@ fdecl1DEPRECATED { let target = StaticTarget ($2 `orElse` mkExtName $4) in - ForeignImport $4 $6 (CImport defaultCCallConv $3 _NIL_ _NIL_ + ForeignImport $4 $6 (CImport defaultCCallConv $3 nilFS nilFS (CFunction target)) } -- DEPRECATED variant #2: external name consists of two separate strings @@ -623,7 +623,7 @@ fdecl1DEPRECATED let imp = CFunction (StaticTarget $4) in - ForeignImport $6 $8 (CImport cconv $5 _NIL_ _NIL_ imp) } + ForeignImport $6 $8 (CImport cconv $5 nilFS nilFS imp) } -- DEPRECATED variant #3: `unsafe' after entity | 'import' callconv STRING 'unsafe' varid_no_unsafe '::' sigtype @@ -633,12 +633,12 @@ fdecl1DEPRECATED let imp = CFunction (StaticTarget $3) in - ForeignImport $5 $7 (CImport cconv PlayRisky _NIL_ _NIL_ imp) } + ForeignImport $5 $7 (CImport cconv PlayRisky nilFS nilFS imp) } -- DEPRECATED variant #4: use of the special identifier `dynamic' without -- an explicit calling convention (import) | 'import' {-no callconv-} 'dynamic' safety varid_no_unsafe '::' sigtype - { ForeignImport $4 $6 (CImport defaultCCallConv $3 _NIL_ _NIL_ + { ForeignImport $4 $6 (CImport defaultCCallConv $3 nilFS nilFS (CFunction DynamicTarget)) } -- DEPRECATED variant #5: use of the special identifier `dynamic' (import) @@ -646,7 +646,7 @@ fdecl1DEPRECATED {% case $2 of DNCall -> parseError "Illegal format of .NET foreign import" CCall cconv -> returnP $ - ForeignImport $5 $7 (CImport cconv $4 _NIL_ _NIL_ + ForeignImport $5 $7 (CImport cconv $4 nilFS nilFS (CFunction DynamicTarget)) } -- DEPRECATED variant #6: lack of a calling convention specification @@ -667,7 +667,7 @@ fdecl1DEPRECATED -- DEPRECATED variant #8: use of the special identifier `dynamic' without -- an explicit calling convention (export) | 'export' {-no callconv-} 'dynamic' varid '::' sigtype - { ForeignImport $3 $5 (CImport defaultCCallConv (PlaySafe False) _NIL_ _NIL_ + { ForeignImport $3 $5 (CImport defaultCCallConv (PlaySafe False) nilFS nilFS CWrapper) } -- DEPRECATED variant #9: use of the special identifier `dynamic' (export) @@ -675,7 +675,7 @@ fdecl1DEPRECATED {% case $2 of DNCall -> parseError "Illegal format of .NET foreign import" CCall cconv -> returnP $ - ForeignImport $4 $6 (CImport cconv (PlaySafe False) _NIL_ _NIL_ CWrapper) } + ForeignImport $4 $6 (CImport cconv (PlaySafe False) nilFS nilFS CWrapper) } ----------- DEPRECATED .NET decls ------------ -- NB: removed the .NET call declaration, as it is entirely subsumed @@ -706,9 +706,9 @@ safety1 :: { Safety } | 'threadsafe' { PlaySafe True } -- only needed to avoid conflicts with the DEPRECATED rules -fspec :: { (FAST_STRING, RdrName, RdrNameHsType) } +fspec :: { (FastString, RdrName, RdrNameHsType) } : STRING varid '::' sigtype { ($1 , $2, $4) } - | varid '::' sigtype { (SLIT(""), $1, $3) } + | varid '::' sigtype { (nilFS, $1, $3) } -- if the entity string is missing, it defaults to the empty string; -- the meaning of an empty entity string depends on the calling -- convention @@ -981,11 +981,11 @@ exp10 :: { RdrNameHsExpr } | fexp { $1 } -scc_annot :: { FAST_STRING } +scc_annot :: { FastString } : '_scc_' STRING { $2 } | '{-# SCC' STRING '#-}' { $2 } -ccallid :: { FAST_STRING } +ccallid :: { FastString } : VARID { $1 } | CONID { $1 } diff --git a/ghc/compiler/parser/ParserCore.y b/ghc/compiler/parser/ParserCore.y index e24779a28b..bcedf8c7f4 100644 --- a/ghc/compiler/parser/ParserCore.y +++ b/ghc/compiler/parser/ParserCore.y @@ -15,6 +15,7 @@ import Literal import BasicTypes import Type import SrcLoc +import FastString #include "../HsVersions.h" @@ -203,10 +204,10 @@ lit :: { Literal } : '(' INTEGER '::' aty ')' { MachInt $2 } | '(' RATIONAL '::' aty ')' { MachDouble $2 } | '(' CHAR '::' aty ')' { MachChar (fromEnum $2) } - | '(' STRING '::' aty ')' { MachStr (_PK_ $2) } + | '(' STRING '::' aty ')' { MachStr (mkFastString $2) } name :: { RdrName } - : NAME { mkRdrUnqual (mkVarOccEncoded (_PK_ $1)) } + : NAME { mkRdrUnqual (mkVarOccEncoded (mkFastString $1)) } cname :: { String } : CNAME { $1 } @@ -215,22 +216,22 @@ mname :: { String } : CNAME { $1 } modid :: { ModuleName } - : CNAME { mkSysModuleNameFS (_PK_ $1) } + : CNAME { mkSysModuleNameFS (mkFastString $1) } qname :: { RdrName } : name { $1 } | mname '.' NAME - { mkIfaceOrig varName (_PK_ $1,_PK_ $3) } + { mkIfaceOrig varName (mkFastString $1,mkFastString $3) } -- Type constructor q_tc_name :: { RdrName } : mname '.' cname - { mkIfaceOrig tcName (_PK_ $1,_PK_ $3) } + { mkIfaceOrig tcName (mkFastString $1,mkFastString $3) } -- Data constructor q_d_name :: { RdrName } : mname '.' cname - { mkIfaceOrig dataName (_PK_ $1,_PK_ $3) } + { mkIfaceOrig dataName (mkFastString $1,mkFastString $3) } { diff --git a/ghc/compiler/prelude/ForeignCall.lhs b/ghc/compiler/prelude/ForeignCall.lhs index 55ae707839..81d57052e2 100644 --- a/ghc/compiler/prelude/ForeignCall.lhs +++ b/ghc/compiler/prelude/ForeignCall.lhs @@ -193,7 +193,7 @@ data DNCallSpec = DNCallSpec FastString {-! derive: Binary !-} instance Outputable DNCallSpec where - ppr (DNCallSpec s) = char '"' <> ptext s <> char '"' + ppr (DNCallSpec s) = char '"' <> ftext s <> char '"' \end{code} diff --git a/ghc/compiler/prelude/PrelNames.lhs b/ghc/compiler/prelude/PrelNames.lhs index 0e1f2467a2..8dc8fb908a 100644 --- a/ghc/compiler/prelude/PrelNames.lhs +++ b/ghc/compiler/prelude/PrelNames.lhs @@ -54,6 +54,7 @@ import RdrName ( rdrNameOcc ) import SrcLoc ( builtinSrcLoc, noSrcLoc ) import Util ( nOfThem ) import Panic ( panic ) +import FastString \end{code} @@ -290,17 +291,17 @@ mkTupNameStr :: Boxity -> Int -> (ModuleName, UserFS) mkTupNameStr Boxed 0 = (pREL_BASE_Name, FSLIT("()")) mkTupNameStr Boxed 1 = panic "Name.mkTupNameStr: 1 ???" -mkTupNameStr Boxed 2 = (pREL_TUP_Name, _PK_ "(,)") -- not strictly necessary -mkTupNameStr Boxed 3 = (pREL_TUP_Name, _PK_ "(,,)") -- ditto -mkTupNameStr Boxed 4 = (pREL_TUP_Name, _PK_ "(,,,)") -- ditto -mkTupNameStr Boxed n = (pREL_TUP_Name, _PK_ ("(" ++ nOfThem (n-1) ',' ++ ")")) +mkTupNameStr Boxed 2 = (pREL_TUP_Name, mkFastString "(,)") -- not strictly necessary +mkTupNameStr Boxed 3 = (pREL_TUP_Name, mkFastString "(,,)") -- ditto +mkTupNameStr Boxed 4 = (pREL_TUP_Name, mkFastString "(,,,)") -- ditto +mkTupNameStr Boxed n = (pREL_TUP_Name, mkFastString ("(" ++ nOfThem (n-1) ',' ++ ")")) mkTupNameStr Unboxed 0 = panic "Name.mkUbxTupNameStr: 0 ???" -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) ',' ++ "#)")) +mkTupNameStr Unboxed 1 = (gHC_PRIM_Name, mkFastString "(# #)") -- 1 and 0 both make sense!!! +mkTupNameStr Unboxed 2 = (gHC_PRIM_Name, mkFastString "(#,#)") +mkTupNameStr Unboxed 3 = (gHC_PRIM_Name, mkFastString "(#,,#)") +mkTupNameStr Unboxed 4 = (gHC_PRIM_Name, mkFastString "(#,,,#)") +mkTupNameStr Unboxed n = (gHC_PRIM_Name, mkFastString ("(#" ++ nOfThem (n-1) ',' ++ "#)")) mkTupConRdrName :: NameSpace -> Boxity -> Arity -> RdrName mkTupConRdrName space boxity arity = case mkTupNameStr boxity arity of diff --git a/ghc/compiler/prelude/PrelRules.lhs b/ghc/compiler/prelude/PrelRules.lhs index a7fa4255c5..5f0981c37e 100644 --- a/ghc/compiler/prelude/PrelRules.lhs +++ b/ghc/compiler/prelude/PrelRules.lhs @@ -48,6 +48,7 @@ import Word ( Word ) import Word ( Word64 ) #endif import Outputable +import FastString import CmdLineOpts ( opt_SimplExcessPrecision ) \end{code} @@ -56,8 +57,8 @@ import CmdLineOpts ( opt_SimplExcessPrecision ) primOpRules :: PrimOp -> [CoreRule] primOpRules op = primop_rule op where - op_name = _PK_ (occNameUserString (primOpOcc op)) - op_name_case = op_name _APPEND_ SLIT("->case") + op_name = mkFastString (occNameUserString (primOpOcc op)) + op_name_case = op_name `appendFS` FSLIT("->case") -- A useful shorthand one_rule rule_fn = [BuiltinRule op_name rule_fn] @@ -459,8 +460,8 @@ dataToTagRule other = Nothing builtinRules :: [(Name, CoreRule)] -- Rules for non-primops that can't be expressed using a RULE pragma builtinRules - = [ (unpackCStringFoldrName, BuiltinRule SLIT("AppendLitString") match_append_lit), - (eqStringName, BuiltinRule SLIT("EqString") match_eq_string) + = [ (unpackCStringFoldrName, BuiltinRule FSLIT("AppendLitString") match_append_lit), + (eqStringName, BuiltinRule FSLIT("EqString") match_eq_string) ] @@ -479,7 +480,7 @@ match_append_lit [Type ty1, c1 `cheapEqExpr` c2 = ASSERT( ty1 `eqType` ty2 ) Just (Var unpk `App` Type ty1 - `App` Lit (MachStr (s1 _APPEND_ s2)) + `App` Lit (MachStr (s1 `appendFS` s2)) `App` c1 `App` n) diff --git a/ghc/compiler/prelude/TysWiredIn.lhs b/ghc/compiler/prelude/TysWiredIn.lhs index 872681e9a3..7c8009b652 100644 --- a/ghc/compiler/prelude/TysWiredIn.lhs +++ b/ghc/compiler/prelude/TysWiredIn.lhs @@ -107,6 +107,7 @@ import Unique ( incrUnique, mkTupleTyConUnique, mkTupleDataConUnique, mkPArrDataConUnique ) import PrelNames import Array +import FastString alpha_tyvar = [alphaTyVar] alpha_ty = [alphaTy] @@ -626,7 +627,7 @@ mkPArrFakeCon arity = pcDataCon name [tyvar] [] tyvarTys parrTyCon where tyvar = head alphaTyVars tyvarTys = replicate arity $ mkTyVarTy tyvar - nameStr = _PK_ ("MkPArr" ++ show arity) + nameStr = mkFastString ("MkPArr" ++ show arity) name = mkWiredInName mod (mkOccFS dataName nameStr) uniq uniq = mkPArrDataConUnique arity mod = mkPrelModule pREL_PARR_Name diff --git a/ghc/compiler/profiling/CostCentre.lhs b/ghc/compiler/profiling/CostCentre.lhs index 506783d73a..eb1a3b9416 100644 --- a/ghc/compiler/profiling/CostCentre.lhs +++ b/ghc/compiler/profiling/CostCentre.lhs @@ -39,6 +39,7 @@ import Module ( Module, ModuleName, moduleName, import Outputable import CStrings ( pprStringInCStyle ) import FastTypes +import FastString import Util ( thenCmp ) \end{code} @@ -361,7 +362,7 @@ pprCostCentreCore (AllCafsCC {cc_mod = m}) pprCostCentreCore (NormalCC {cc_name = n, cc_mod = m, cc_is_caf = caf, cc_is_dupd = dup}) = text "__scc" <+> braces (hsep [ - ptext n, + ftext n, ppr m, pp_dup dup, pp_caf caf @@ -378,7 +379,7 @@ pp_caf other = empty ppCostCentreLbl (NoCostCentre) = text "NONE_cc" ppCostCentreLbl (AllCafsCC {cc_mod = m}) = ppr m <> text "_CAFs_cc" ppCostCentreLbl (NormalCC {cc_name = n, cc_mod = m, cc_is_caf = is_caf}) - = ppr m <> ptext n <> + = ppr m <> ftext n <> text (case is_caf of { CafCC -> "_CAF"; _ -> "" }) <> text "_cc" -- This is the name to go in the user-displayed string, @@ -386,7 +387,7 @@ ppCostCentreLbl (NormalCC {cc_name = n, cc_mod = m, cc_is_caf = is_caf}) costCentreUserName (NoCostCentre) = "NO_CC" costCentreUserName (AllCafsCC {}) = "CAF" costCentreUserName cc@(NormalCC {cc_name = name, cc_is_caf = is_caf}) - = case is_caf of { CafCC -> "CAF:"; _ -> "" } ++ decode (_UNPK_ name) + = case is_caf of { CafCC -> "CAF:"; _ -> "" } ++ decode (unpackFS name) \end{code} Cost Centre Declarations @@ -403,7 +404,7 @@ pprCostCentreDecl is_local cc cc_ident, comma, pprStringInCStyle (costCentreUserName cc), comma, pprStringInCStyle (moduleNameUserString mod_name), comma, - ptext is_subsumed, comma, + is_subsumed, comma, empty, -- Now always externally visible text ");"] else @@ -413,7 +414,7 @@ pprCostCentreDecl is_local cc mod_name = cc_mod cc is_subsumed = ccSubsumed cc -ccSubsumed :: CostCentre -> FAST_STRING -- subsumed value -ccSubsumed cc | isCafCC cc = SLIT("CC_IS_CAF") - | otherwise = SLIT("CC_IS_BORING") +ccSubsumed :: CostCentre -> SDoc -- subsumed value +ccSubsumed cc | isCafCC cc = ptext SLIT("CC_IS_CAF") + | otherwise = ptext SLIT("CC_IS_BORING") \end{code} diff --git a/ghc/compiler/rename/RnBinds.lhs b/ghc/compiler/rename/RnBinds.lhs index bb6f9eac46..8bc83e27d8 100644 --- a/ghc/compiler/rename/RnBinds.lhs +++ b/ghc/compiler/rename/RnBinds.lhs @@ -556,14 +556,14 @@ renameSig (InlineSig b v p src_loc) \begin{code} dupSigDeclErr sig = pushSrcLocRn loc $ - addErrRn (sep [ptext SLIT("Duplicate") <+> ptext what_it_is <> colon, + addErrRn (sep [ptext SLIT("Duplicate") <+> what_it_is <> colon, ppr sig]) where (what_it_is, loc) = hsSigDoc sig unknownSigErr sig = pushSrcLocRn loc $ - addErrRn (sep [ptext SLIT("Misplaced") <+> ptext what_it_is <> colon, + addErrRn (sep [ptext SLIT("Misplaced") <+> what_it_is <> colon, ppr sig]) where (what_it_is, loc) = hsSigDoc sig diff --git a/ghc/compiler/rename/RnExpr.lhs b/ghc/compiler/rename/RnExpr.lhs index 992679b012..1a18cb34b9 100644 --- a/ghc/compiler/rename/RnExpr.lhs +++ b/ghc/compiler/rename/RnExpr.lhs @@ -52,6 +52,7 @@ import UniqSet ( emptyUniqSet ) import List ( intersectBy ) import ListSetOps ( removeDups ) import Outputable +import FastString \end{code} @@ -918,7 +919,7 @@ mkAssertExpr = let expr = HsApp (HsVar name) - (HsLit (HsStringPrim (_PK_ (stringToUtf8 (showSDoc (ppr sloc)))))) + (HsLit (HsStringPrim (mkFastString (stringToUtf8 (showSDoc (ppr sloc)))))) in returnRn (expr, unitFV name) \end{code} diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs index 647cf6cefe..352df726fd 100644 --- a/ghc/compiler/rename/RnSource.lhs +++ b/ghc/compiler/rename/RnSource.lhs @@ -246,7 +246,7 @@ rnHsRuleDecl (HsRule rule_name act vars lhs rhs src_loc) returnRn (HsRule rule_name act vars' lhs' rhs' src_loc, fv_vars `plusFV` fv_lhs `plusFV` fv_rhs) where - doc = text "In the transformation rule" <+> ptext rule_name + doc = text "In the transformation rule" <+> ftext rule_name get_var (RuleBndr v) = v get_var (RuleBndrSig v _) = v @@ -734,13 +734,13 @@ badDataCon name = hsep [ptext SLIT("Illegal data constructor name"), quotes (ppr name)] badRuleLhsErr name lhs - = sep [ptext SLIT("Rule") <+> ptext name <> colon, + = sep [ptext SLIT("Rule") <+> ftext name <> colon, nest 4 (ptext SLIT("Illegal left-hand side:") <+> ppr lhs)] $$ ptext SLIT("LHS must be of form (f e1 .. en) where f is not forall'd") badRuleVar name var - = sep [ptext SLIT("Rule") <+> doubleQuotes (ptext name) <> colon, + = sep [ptext SLIT("Rule") <+> doubleQuotes (ftext name) <> colon, ptext SLIT("Forall'd variable") <+> quotes (ppr var) <+> ptext SLIT("does not appear on left hand side")] diff --git a/ghc/compiler/simplCore/SetLevels.lhs b/ghc/compiler/simplCore/SetLevels.lhs index baaa442961..5c9cb1e15b 100644 --- a/ghc/compiler/simplCore/SetLevels.lhs +++ b/ghc/compiler/simplCore/SetLevels.lhs @@ -72,6 +72,7 @@ import BasicTypes ( TopLevelFlag(..) ) import UniqSupply import Util ( sortLt, isSingleton, count ) import Outputable +import FastString \end{code} %************************************************************************ @@ -770,7 +771,7 @@ newPolyBndrs dest_lvl env abs_vars bndrs in returnLvl (extendPolyLvlEnv dest_lvl env abs_vars (bndrs `zip` new_bndrs), new_bndrs) where - mk_poly_bndr bndr uniq = mkSysLocal (_PK_ str) uniq poly_ty + mk_poly_bndr bndr uniq = mkSysLocal (mkFastString str) uniq poly_ty where str = "poly_" ++ occNameUserString (getOccName bndr) poly_ty = mkPiTypes abs_vars (idType bndr) @@ -781,7 +782,7 @@ newLvlVar :: String -> LvlM Id newLvlVar str vars body_ty = getUniqueUs `thenLvl` \ uniq -> - returnUs (mkSysLocal (_PK_ str) uniq (mkPiTypes vars body_ty)) + returnUs (mkSysLocal (mkFastString str) uniq (mkPiTypes vars body_ty)) -- The deeply tiresome thing is that we have to apply the substitution -- to the rules inside each Id. Grr. But it matters. diff --git a/ghc/compiler/simplCore/SimplMonad.lhs b/ghc/compiler/simplCore/SimplMonad.lhs index 266d9ec64f..f538bf9b75 100644 --- a/ghc/compiler/simplCore/SimplMonad.lhs +++ b/ghc/compiler/simplCore/SimplMonad.lhs @@ -85,6 +85,7 @@ import Outputable import Array ( array, (//) ) import FastTypes import GlaExts ( indexArray# ) +import FastString #if __GLASGOW_HASKELL__ < 503 import PrelArr ( Array(..) ) @@ -446,7 +447,7 @@ data Tick | PostInlineUnconditionally Id | UnfoldingDone Id - | RuleFired FAST_STRING -- Rule name + | RuleFired FastString -- Rule name | LetFloatFromLet | EtaExpansion Id -- LHS binder @@ -964,7 +965,7 @@ type SwitchChecker = SimplifierSwitch -> SwitchResult data SwitchResult = SwBool Bool -- on/off - | SwString FAST_STRING -- nothing or a String + | SwString FastString -- nothing or a String | SwInt Int -- nothing or an Int isAmongSimpl :: [SimplifierSwitch] -> SimplifierSwitch -> SwitchResult diff --git a/ghc/compiler/simplCore/Simplify.lhs b/ghc/compiler/simplCore/Simplify.lhs index 0a614180f2..0a30390548 100644 --- a/ghc/compiler/simplCore/Simplify.lhs +++ b/ghc/compiler/simplCore/Simplify.lhs @@ -916,7 +916,7 @@ completeCall env var occ_info cont tick (RuleFired rule_name) `thenSmpl_` (if dopt Opt_D_dump_inlinings dflags then pprTrace "Rule fired" (vcat [ - text "Rule:" <+> ptext rule_name, + text "Rule:" <+> ftext rule_name, text "Before:" <+> ppr var <+> sep (map pprParendExpr args), text "After: " <+> pprCoreExpr rule_rhs, text "Cont: " <+> ppr call_cont]) @@ -1687,7 +1687,7 @@ mkDupableAlt env case_bndr' cont alt@(con, bndrs, rhs) ) `thenSmpl` \ (final_bndrs', final_args) -> -- See comment about "$j" name above - newId (encodeFS SLIT("$j")) (mkPiTypes final_bndrs' rhs_ty') `thenSmpl` \ join_bndr -> + newId (encodeFS FSLIT("$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/Rules.lhs b/ghc/compiler/specialise/Rules.lhs index 8a489a0a6d..34813e7c49 100644 --- a/ghc/compiler/specialise/Rules.lhs +++ b/ghc/compiler/specialise/Rules.lhs @@ -34,6 +34,7 @@ import qualified TcType ( match ) import BasicTypes ( Activation, CompilerPhase, isActive ) import Outputable +import FastString import Maybe ( isJust, isNothing, fromMaybe ) import Util ( sortLt ) import Bag @@ -541,7 +542,7 @@ ruleCheckFun (phase, pat) fn args where name_match_rules = case idSpecialisation fn of Rules rules _ -> filter match rules - match rule = pat `isPrefixOf` _UNPK_ (ruleName rule) + match rule = pat `isPrefixOf` unpackFS (ruleName rule) ruleAppCheck_help :: CompilerPhase -> Id -> [CoreExpr] -> [CoreRule] -> SDoc ruleAppCheck_help phase fn args rules @@ -554,8 +555,10 @@ ruleAppCheck_help phase fn args rules check_rule rule = rule_herald rule <> colon <+> rule_info rule - rule_herald (BuiltinRule name _) = text "Builtin rule" <+> doubleQuotes (ptext name) - rule_herald (Rule name _ _ _ _) = text "Rule" <+> doubleQuotes (ptext name) + rule_herald (BuiltinRule name _) = + ptext SLIT("Builtin rule") <+> doubleQuotes (ftext name) + rule_herald (Rule name _ _ _ _) = + ptext SLIT("Rule") <+> doubleQuotes (ftext name) rule_info rule | Just (name,_) <- matchRule noBlackList emptyInScopeSet rule args diff --git a/ghc/compiler/specialise/SpecConstr.lhs b/ghc/compiler/specialise/SpecConstr.lhs index c79ec11767..3812234c39 100644 --- a/ghc/compiler/specialise/SpecConstr.lhs +++ b/ghc/compiler/specialise/SpecConstr.lhs @@ -37,6 +37,7 @@ import Util ( mapAccumL, lengthAtLeast, notNull ) import List ( nubBy, partition ) import UniqSupply import Outputable +import FastString \end{code} ----------------------------------------------------- @@ -508,7 +509,7 @@ spec_one env fn rhs (pats, rule_number) -- Usual w/w hack to avoid generating -- a spec_rhs of unlifted type and no args - rule_name = _PK_ ("SC:" ++ showSDoc (ppr fn <> int rule_number)) + rule_name = mkFastString ("SC:" ++ showSDoc (ppr fn <> int rule_number)) spec_rhs = mkLams spec_lam_args spec_body spec_id = mkUserLocal spec_occ spec_uniq (mkPiTypes spec_lam_args body_ty) fn_loc rule = Rule rule_name specConstrActivation diff --git a/ghc/compiler/specialise/Specialise.lhs b/ghc/compiler/specialise/Specialise.lhs index 16d3748f3a..c9ffa0b1fa 100644 --- a/ghc/compiler/specialise/Specialise.lhs +++ b/ghc/compiler/specialise/Specialise.lhs @@ -43,7 +43,7 @@ import List ( partition ) import Util ( zipEqual, zipWithEqual, cmpList, lengthIs, equalLength, lengthAtLeast, notNull ) import Outputable - +import FastString infixr 9 `thenSM` \end{code} @@ -887,7 +887,7 @@ specDefn subst calls (fn, rhs) let -- The rule to put in the function's specialisation is: -- forall b,d, d1',d2'. f t1 b t3 d d1' d2' = f1 b d - spec_env_rule = Rule (_PK_ ("SPEC " ++ showSDoc (ppr fn))) + spec_env_rule = Rule (mkFastString ("SPEC " ++ showSDoc (ppr fn))) AlwaysActive (poly_tyvars ++ rhs_dicts') inst_args diff --git a/ghc/compiler/stranal/WwLib.lhs b/ghc/compiler/stranal/WwLib.lhs index f3c3d29df5..58060b0d3e 100644 --- a/ghc/compiler/stranal/WwLib.lhs +++ b/ghc/compiler/stranal/WwLib.lhs @@ -22,7 +22,6 @@ import TysWiredIn ( tupleCon ) import Type ( Type, isUnLiftedType, mkFunTys, splitForAllTys, splitFunTys, splitNewType_maybe, isAlgType ) -import Literal ( Literal(MachStr) ) import BasicTypes ( Boxity(..) ) import Var ( Var, isId ) import UniqSupply ( returnUs, thenUs, getUniquesUs, UniqSM ) diff --git a/ghc/compiler/typecheck/TcClassDcl.lhs b/ghc/compiler/typecheck/TcClassDcl.lhs index 443459414d..79c834daca 100644 --- a/ghc/compiler/typecheck/TcClassDcl.lhs +++ b/ghc/compiler/typecheck/TcClassDcl.lhs @@ -59,6 +59,7 @@ import ErrUtils ( dumpIfSet ) import Util ( count, lengthIs, equalLength ) import Maybes ( seqMaybe ) import Maybe ( isJust ) +import FastString \end{code} @@ -528,7 +529,7 @@ mkDefMethRhs origin clas inst_tys sel_id loc NoDefMeth returnTc error_rhs where error_rhs = HsApp (HsVar (getName nO_METHOD_BINDING_ERROR_ID)) - (HsLit (HsStringPrim (_PK_ (stringToUtf8 error_msg)))) + (HsLit (HsStringPrim (mkFastString (stringToUtf8 error_msg)))) error_msg = showSDoc (hcat [ppr loc, text "|", ppr sel_id ]) diff --git a/ghc/compiler/typecheck/TcDeriv.lhs b/ghc/compiler/typecheck/TcDeriv.lhs index 16f41db71e..b072bb4645 100644 --- a/ghc/compiler/typecheck/TcDeriv.lhs +++ b/ghc/compiler/typecheck/TcDeriv.lhs @@ -55,7 +55,6 @@ import Util ( zipWithEqual, sortLt, notNull ) import ListSetOps ( removeDups, assoc ) import Outputable import Maybe ( isJust ) -import FastString ( FastString ) \end{code} %************************************************************************ @@ -436,13 +435,12 @@ makeDerivEqns tycl_decls && (tyVarsOfTypes args_to_keep `subVarSet` mkVarSet tyvars_to_keep) cant_derive_err = derivingThingErr clas tys tycon tyvars_to_keep - SLIT("too hard for cunning newtype deriving") - + (ptext SLIT("too hard for cunning newtype deriving")) bale_out err = addErrTc err `thenNF_Tc_` returnNF_Tc (Nothing, Nothing) ------------------------------------------------------------------ - chk_out :: Class -> TyCon -> [TcType] -> Maybe FastString + chk_out :: Class -> TyCon -> [TcType] -> Maybe SDoc chk_out clas tycon tys | notNull tys = Just non_std_why | not (getUnique clas `elem` derivableClassKeys) = Just non_std_why @@ -458,11 +456,11 @@ makeDerivEqns tycl_decls is_single_con = maybeToBool (maybeTyConSingleCon tycon) is_enumeration_or_single = is_enumeration || is_single_con - single_nullary_why = SLIT("one constructor data type or type with all nullary constructors expected") - nullary_why = SLIT("data type with all nullary constructors expected") - no_cons_why = SLIT("type has no data constructors") - non_std_why = SLIT("not a derivable class") - existential_why = SLIT("it has existentially-quantified constructor(s)") + single_nullary_why = ptext SLIT("one constructor data type or type with all nullary constructors expected") + nullary_why = ptext SLIT("data type with all nullary constructors expected") + no_cons_why = ptext SLIT("type has no data constructors") + non_std_why = ptext SLIT("not a derivable class") + existential_why = ptext SLIT("it has existentially-quantified constructor(s)") new_dfun_name clas tycon -- Just a simple wrapper = newDFunName clas [mkTyConApp tycon []] (getSrcLoc tycon) @@ -728,7 +726,7 @@ gen_taggery_Names dfuns \begin{code} derivingThingErr clas tys tycon tyvars why = sep [hsep [ptext SLIT("Can't make a derived instance of"), quotes (ppr pred)], - parens (ptext why)] + parens why] where pred = mkClassPred clas (tys ++ [mkTyConApp tycon (mkTyVarTys tyvars)]) diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs index 1da69ecfbb..52ec896aa2 100644 --- a/ghc/compiler/typecheck/TcExpr.lhs +++ b/ghc/compiler/typecheck/TcExpr.lhs @@ -62,12 +62,13 @@ import PrelNames ( cCallableClassName, enumFromToPName, enumFromThenToPName, thenMName, bindMName, failMName, returnMName, ioTyConName ) -import Outputable import ListSetOps ( minusList ) -import Util import CmdLineOpts import HscTypes ( TyThing(..) ) +import Util +import Outputable +import FastString \end{code} %************************************************************************ @@ -239,11 +240,11 @@ tcMonoExpr e0@(HsCCall lbl args may_gc is_casm ignored_fake_result_ty) res_ty tcLookupTyCon ioTyConName `thenNF_Tc` \ ioTyCon -> let new_arg_dict (arg, arg_ty) - = newDicts (CCallOrigin (_UNPK_ lbl) (Just arg)) + = newDicts (CCallOrigin (unpackFS lbl) (Just arg)) [mkClassPred cCallableClass [arg_ty]] `thenNF_Tc` \ arg_dicts -> returnNF_Tc arg_dicts -- Actually a singleton bag - result_origin = CCallOrigin (_UNPK_ lbl) Nothing {- Not an arg -} + result_origin = CCallOrigin (unpackFS lbl) Nothing {- Not an arg -} in -- Arguments @@ -993,7 +994,7 @@ Overloaded literals. tcLit :: HsLit -> TcType -> TcM (TcExpr, LIE) tcLit (HsLitLit s _) res_ty = tcLookupClass cCallableClassName `thenNF_Tc` \ cCallableClass -> - newDicts (LitLitOrigin (_UNPK_ s)) + newDicts (LitLitOrigin (unpackFS s)) [mkClassPred cCallableClass [res_ty]] `thenNF_Tc` \ dicts -> returnTc (HsLit (HsLitLit s res_ty), mkLIE dicts) diff --git a/ghc/compiler/typecheck/TcGenDeriv.lhs b/ghc/compiler/typecheck/TcGenDeriv.lhs index b237ca89e6..0f7400341f 100644 --- a/ghc/compiler/typecheck/TcGenDeriv.lhs +++ b/ghc/compiler/typecheck/TcGenDeriv.lhs @@ -65,6 +65,7 @@ import Maybes ( maybeToBool ) import Char ( ord ) import Constants import List ( partition, intersperse ) +import FastString \end{code} %************************************************************************ @@ -640,7 +641,7 @@ gen_Ix_binds tycon tycon_loc )) ) {-else-} ( - HsApp (HsVar error_RDR) (HsLit (HsString (_PK_ ("Ix."++tycon_str++".index: out of range\n")))) + HsApp (HsVar error_RDR) (HsLit (HsString (mkFastString ("Ix."++tycon_str++".index: out of range\n")))) ) tycon_loc) @@ -1138,7 +1139,7 @@ mkHsApps f xs = foldl HsApp (HsVar f) xs mkHsVarApps f xs = foldl HsApp (HsVar f) (map HsVar xs) mkHsIntLit n = HsLit (HsInt n) -mkHsString s = HsString (_PK_ s) +mkHsString s = HsString (mkFastString s) mkHsChar c = HsChar (ord c) \end{code} @@ -1264,31 +1265,31 @@ nested_compose_Expr (e:es) -- impossible_Expr is used in case RHSs that should never happen. -- We generate these to keep the desugarer from complaining that they *might* happen! -impossible_Expr = HsApp (HsVar error_RDR) (HsLit (HsString (_PK_ "Urk! in TcGenDeriv"))) +impossible_Expr = HsApp (HsVar error_RDR) (HsLit (HsString (mkFastString "Urk! in TcGenDeriv"))) -- illegal_Expr is used when signalling error conditions in the RHS of a derived -- method. It is currently only used by Enum.{succ,pred} illegal_Expr meth tp msg = - HsApp (HsVar error_RDR) (HsLit (HsString (_PK_ (meth ++ '{':tp ++ "}: " ++ msg)))) + HsApp (HsVar error_RDR) (HsLit (HsString (mkFastString (meth ++ '{':tp ++ "}: " ++ msg)))) -- illegal_toEnum_tag is an extended version of illegal_Expr, which also allows you -- to include the value of a_RDR in the error string. illegal_toEnum_tag tp maxtag = HsApp (HsVar error_RDR) (HsApp (HsApp (HsVar append_RDR) - (HsLit (HsString (_PK_ ("toEnum{" ++ tp ++ "}: tag ("))))) + (HsLit (HsString (mkFastString ("toEnum{" ++ tp ++ "}: tag ("))))) (HsApp (HsApp (HsApp (HsVar showsPrec_RDR) (mkHsIntLit 0)) (HsVar a_RDR)) (HsApp (HsApp (HsVar append_RDR) - (HsLit (HsString (_PK_ ") is outside of enumeration's range (0,")))) + (HsLit (HsString (mkFastString ") is outside of enumeration's range (0,")))) (HsApp (HsApp (HsApp (HsVar showsPrec_RDR) (mkHsIntLit 0)) (HsVar maxtag)) - (HsLit (HsString (_PK_ ")"))))))) + (HsLit (HsString (mkFastString ")"))))))) parenify e@(HsVar _) = e parenify e = HsPar e @@ -1317,9 +1318,9 @@ 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) .. ] ] -cs_RDRs = [ varUnqual (_PK_ ("c"++show i)) | i <- [(1::Int) .. ] ] +as_RDRs = [ varUnqual (mkFastString ("a"++show i)) | i <- [(1::Int) .. ] ] +bs_RDRs = [ varUnqual (mkFastString ("b"++show i)) | i <- [(1::Int) .. ] ] +cs_RDRs = [ varUnqual (mkFastString ("c"++show i)) | i <- [(1::Int) .. ] ] zz_a_Expr = HsVar zz_a_RDR a_Expr = HsVar a_RDR @@ -1345,7 +1346,7 @@ d_Pat = VarPatIn d_RDR con2tag_RDR, tag2con_RDR, maxtag_RDR :: TyCon -> RdrName -con2tag_RDR tycon = varUnqual (_PK_ ("con2tag_" ++ occNameString (getOccName tycon) ++ "#")) -tag2con_RDR tycon = varUnqual (_PK_ ("tag2con_" ++ occNameString (getOccName tycon) ++ "#")) -maxtag_RDR tycon = varUnqual (_PK_ ("maxtag_" ++ occNameString (getOccName tycon) ++ "#")) +con2tag_RDR tycon = varUnqual (mkFastString ("con2tag_" ++ occNameString (getOccName tycon) ++ "#")) +tag2con_RDR tycon = varUnqual (mkFastString ("tag2con_" ++ occNameString (getOccName tycon) ++ "#")) +maxtag_RDR tycon = varUnqual (mkFastString ("maxtag_" ++ occNameString (getOccName tycon) ++ "#")) \end{code} diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs index 7366c3c6c4..79ac540143 100644 --- a/ghc/compiler/typecheck/TcInstDcls.lhs +++ b/ghc/compiler/typecheck/TcInstDcls.lhs @@ -72,6 +72,7 @@ import ListSetOps ( Assoc, emptyAssoc, plusAssoc_C, mapAssoc, ) import Maybe ( catMaybes ) import Outputable +import FastString \end{code} Typechecking instance declarations is done in two passes. The first @@ -619,7 +620,7 @@ tcInstDecl2 (InstInfo { iDFunId = dfun_id, iBinds = monobinds, iPrags = uprags } -- mention the constructor, which doesn't exist for CCallable, CReturnable -- Hardly beautiful, but only three extra lines. HsApp (TyApp (HsVar rUNTIME_ERROR_ID) [idType this_dict_id]) - (HsLit (HsStringPrim (_PK_ (stringToUtf8 msg)))) + (HsLit (HsStringPrim (mkFastString (stringToUtf8 msg)))) | otherwise -- The common case = mkHsConApp dict_constr inst_tys' (map HsVar scs_and_meths) diff --git a/ghc/compiler/typecheck/TcPat.lhs b/ghc/compiler/typecheck/TcPat.lhs index 6c455a5528..f816b7c181 100644 --- a/ghc/compiler/typecheck/TcPat.lhs +++ b/ghc/compiler/typecheck/TcPat.lhs @@ -39,6 +39,7 @@ import PrelNames ( eqStringName, eqName, geName, cCallableClassName ) import BasicTypes ( isBoxed ) import Bag import Outputable +import FastString \end{code} @@ -291,7 +292,7 @@ tcPat tc_bndr pat@(RecPatIn name rpats) pat_ty tcPat tc_bndr (LitPatIn lit@(HsLitLit s _)) pat_ty -- cf tcExpr on LitLits = tcLookupClass cCallableClassName `thenNF_Tc` \ cCallableClass -> - newDicts (LitLitOrigin (_UNPK_ s)) + newDicts (LitLitOrigin (unpackFS s)) [mkClassPred cCallableClass [pat_ty]] `thenNF_Tc` \ dicts -> returnTc (LitPat (HsLitLit s pat_ty) pat_ty, mkLIE dicts, emptyBag, emptyBag, emptyLIE) diff --git a/ghc/compiler/typecheck/TcRules.lhs b/ghc/compiler/typecheck/TcRules.lhs index cf2f5b0065..f5ddf1eb44 100644 --- a/ghc/compiler/typecheck/TcRules.lhs +++ b/ghc/compiler/typecheck/TcRules.lhs @@ -124,7 +124,7 @@ tcSourceRule (HsRule name act vars lhs rhs src_loc) returnNF_Tc (mkLocalId var ty) ruleCtxt name = ptext SLIT("When checking the transformation rule") <+> - doubleQuotes (ptext name) + doubleQuotes (ftext name) \end{code} diff --git a/ghc/compiler/types/Generics.lhs b/ghc/compiler/types/Generics.lhs index 744b667980..b868c2a8eb 100644 --- a/ghc/compiler/types/Generics.lhs +++ b/ghc/compiler/types/Generics.lhs @@ -39,6 +39,7 @@ import SrcLoc ( builtinSrcLoc ) import Unique ( Unique, builtinUniques, mkBuiltinUnique ) import Util ( takeList, dropList ) import Outputable +import FastString #include "HsVersions.h" \end{code} @@ -554,7 +555,7 @@ bimapTuple eps ------------------- genericNames :: [Name] -genericNames = [mkSystemName (mkBuiltinUnique i) (_PK_ ('g' : show i)) | i <- [1..]] +genericNames = [mkSystemName (mkBuiltinUnique i) (mkFastString ('g' : show i)) | i <- [1..]] (g1:g2:g3:_) = genericNames mk_hs_lam pats body = HsPar (HsLam (mkSimpleMatch pats body placeHolderType builtinSrcLoc)) diff --git a/ghc/compiler/utils/FastString.lhs b/ghc/compiler/utils/FastString.lhs index a774243398..6f4876f9ce 100644 --- a/ghc/compiler/utils/FastString.lhs +++ b/ghc/compiler/utils/FastString.lhs @@ -11,20 +11,12 @@ module FastString ( FastString(..), -- not abstract, for now. - --names? mkFastString, -- :: String -> FastString mkFastStringNarrow, -- :: String -> FastString mkFastSubString, -- :: Addr -> Int -> Int -> FastString - -- These ones hold on to the Addr after they return, and aren't hashed; - -- they are used for literals - mkFastCharString, -- :: Addr -> FastString - mkFastCharString#, -- :: Addr# -> FastString - mkFastCharString2, -- :: Addr -> Int -> FastString - mkFastString#, -- :: Addr# -> FastString mkFastSubStringBA#, -- :: ByteArray# -> Int# -> Int# -> FastString - mkFastSubString#, -- :: Addr# -> Int# -> Int# -> FastString mkFastStringInt, -- :: [Int] -> FastString @@ -41,8 +33,12 @@ module FastString concatFS, -- :: [FastString] -> FastString consFS, -- :: Char -> FastString -> FastString indexFS, -- :: FastString -> Int -> Char + nilFS, -- :: FastString + + hPutFS, -- :: Handle -> FastString -> IO () - hPutFS -- :: Handle -> FastString -> IO () + LitString, + mkLitString# -- :: Addr# -> Addr ) where -- This #define suppresses the "import FastString" that @@ -68,10 +64,9 @@ import Ptr ( Ptr(..) ) #endif #if __GLASGOW_HASKELL__ < 503 import PrelArr ( STArray(..), newSTArray ) -import IOExts ( hPutBufFull, hPutBufBAFull ) +import IOExts ( hPutBufBAFull ) #else import GHC.Arr ( STArray(..), newSTArray ) -import System.IO ( hPutBuf ) import IOExts ( hPutBufBA ) import CString ( unpackNBytesBA# ) #endif @@ -83,7 +78,6 @@ import Char ( chr, ord ) #define hASH_TBL_SIZE 993 #if __GLASGOW_HASKELL__ < 503 -hPutBuf = hPutBufFull hPutBufBA = hPutBufBAFull #endif \end{code} @@ -103,10 +97,6 @@ data FastString Int# -- length ByteArray# -- stuff - | CharStr -- external C string - Addr# -- pointer to the (null-terminated) bytes in C land. - Int# -- length (cached) - | UnicodeStr -- if contains characters outside '\1'..'\xFF' Int# -- unique id [Int] -- character numbers @@ -114,20 +104,10 @@ data FastString instance Eq FastString where -- 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 } + a == b = 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 } + (FastString u1 _ _) /= (FastString u2 _ _) = u1 /=# u2 + a /= b = 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 } @@ -142,25 +122,15 @@ instance Ord FastString where lengthFS :: FastString -> Int lengthFS (FastString _ l# _) = I# l# -lengthFS (CharStr a# l#) = I# l# lengthFS (UnicodeStr _ s) = length s nullFastString :: FastString -> Bool nullFastString (FastString _ l# _) = l# ==# 0# -nullFastString (CharStr _ l#) = l# ==# 0# nullFastString (UnicodeStr _ []) = True nullFastString (UnicodeStr _ (_:_)) = False unpackFS :: FastString -> String unpackFS (FastString _ l# ba#) = unpackNBytesBA# ba# l# -unpackFS (CharStr addr len#) = - unpack 0# - where - unpack nh - | nh ==# len# = [] - | otherwise = C# ch : unpack (nh +# 1#) - where - ch = indexCharOffAddr# addr nh unpackFS (UnicodeStr _ s) = map chr s unpackIntFS :: FastString -> [Int] @@ -176,8 +146,6 @@ concatFS ls = mkFastStringInt (concat (map unpackIntFS ls)) -- ToDo: do better headFS :: FastString -> Char headFS (FastString _ l# ba#) = if l# ># 0# then C# (indexCharArray# ba# 0#) else error ("headFS: empty FS") -headFS (CharStr a# l#) = - if l# ># 0# then C# (indexCharOffAddr# a# 0#) else error ("headFS: empty FS") headFS (UnicodeStr _ (c:_)) = chr c headFS (UnicodeStr _ []) = error ("headFS: empty FS") @@ -191,9 +159,6 @@ indexFS f i@(I# i#) = FastString _ l# ba# | l# ># 0# && l# ># i# -> C# (indexCharArray# ba# i#) | otherwise -> error (msg (I# l#)) - CharStr a# l# - | l# ># 0# && l# ># i# -> C# (indexCharOffAddr# a# i#) - | otherwise -> error (msg (I# l#)) UnicodeStr _ s -> chr (s!!i) where msg l = "indexFS: out of range: " ++ show (l,i) @@ -207,20 +172,9 @@ consFS c fs = mkFastStringInt (ord c : unpackIntFS fs) uniqueOfFS :: FastString -> Int# uniqueOfFS (FastString u# _ _) = u# -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 - are by default left out. The benefit of being in - the table is that string comparisons are lightning fast, - just an Int# comparison. - - But, if you want to get the Unique of a CharStr, we - enter it into the table and return that unique. This - works, but causes the CharStr to be looked up in the hash - table each time it is accessed.. - -} uniqueOfFS (UnicodeStr u# _) = u# + +nilFS = mkFastString "" \end{code} Internally, the compiler will maintain a fast string symbol @@ -303,9 +257,6 @@ mkFastStringLen# a# len# = bucket_match (UnicodeStr _ _ : ls) len# a# = bucket_match ls len# a# -mkFastSubString# :: Addr# -> Int# -> Int# -> FastString -mkFastSubString# a# start# len# = mkFastCharString2 (A# (addrOffset# a# start#)) (I# len#) - mkFastSubStringBA# :: ByteArray# -> Int# -> Int# -> FastString mkFastSubStringBA# barr# start# len# = unsafePerformIO ( @@ -392,17 +343,6 @@ mkFastStringUnicode s = if s' == s then Just v else bucket_match ls bucket_match (FastString _ _ _ : ls) = bucket_match ls -mkFastCharString :: Addr -> FastString -mkFastCharString a@(A# a#) = - case strLength a of{ (I# len#) -> CharStr a# len# } - -mkFastCharString# :: Addr# -> FastString -mkFastCharString# a# = - case strLength (A# a#) of { (I# len#) -> CharStr a# len# } - -mkFastCharString2 :: Addr -> Int -> FastString -mkFastCharString2 a@(A# a#) (I# len#) = CharStr a# len# - mkFastStringNarrow :: String -> FastString mkFastStringNarrow str = case packString str of @@ -498,33 +438,6 @@ cmpFS (FastString u1# _ b1#) (FastString u2# _ b2#) = -- assume non-null chars where bot :: Int bot = error "tagCmp" -cmpFS (CharStr bs1 len1) (CharStr bs2 len2) - = unsafePerformIO ( - _ccall_ strcmp ba1 ba2 >>= \ (I# res) -> - return ( - if res <# 0# then LT - else if res ==# 0# then EQ - else GT - )) - where - ba1 = A# bs1 - ba2 = A# bs2 -cmpFS (FastString _ len1 bs1) (CharStr bs2 len2) - = unsafePerformIO ( - _ccall_ strcmp ba1 ba2 >>= \ (I# res) -> - return ( - if res <# 0# then LT - else if res ==# 0# then EQ - else GT - )) - where - ba1 = ByteArray (error "") ((error "")::Int) bs1 - ba2 = A# bs2 - -cmpFS a@(CharStr _ _) b@(FastString _ _ _) - = -- try them the other way 'round - case (cmpFS b a) of { LT -> GT; EQ -> EQ; GT -> LT } - \end{code} Outputting @FastString@s is quick, just block copying the chunk (using @@ -539,18 +452,18 @@ hPutFS handle (FastString _ l# ba#) where bot = error "hPutFS.ba" ---ToDo: avoid silly code duplic. - -hPutFS handle (CharStr a# l#) - | l# ==# 0# = return () -#if __GLASGOW_HASKELL__ < 411 - | otherwise = hPutBuf handle (A# a#) (I# l#) -#else - | otherwise = hPutBuf handle (Ptr a#) (I# l#) -#endif - -- ONLY here for debugging the NCG (so -ddump-stix works for string -- literals); no idea if this is really necessary. JRS, 010131 hPutFS handle (UnicodeStr _ is) = hPutStr handle ("(UnicodeStr " ++ show is ++ ")") \end{code} + +Here for convenience only. + +\begin{code} +type LitString = Addr +-- ToDo: make it a Ptr when we don't have to support 4.08 any more + +mkLitString# :: Addr# -> LitString +mkLitString# a# = A# a# +\end{code} diff --git a/ghc/compiler/utils/FiniteMap.lhs b/ghc/compiler/utils/FiniteMap.lhs index c2c34fb782..84212580f7 100644 --- a/ghc/compiler/utils/FiniteMap.lhs +++ b/ghc/compiler/utils/FiniteMap.lhs @@ -684,61 +684,61 @@ When the FiniteMap module is used in GHC, we specialise it for #if __GLASGOW_HASKELL__ {-# SPECIALIZE addListToFM - :: FiniteMap (FAST_STRING, FAST_STRING) elt -> [((FAST_STRING, FAST_STRING),elt)] -> FiniteMap (FAST_STRING, FAST_STRING) elt + :: FiniteMap (FastString, FAST_STRING) elt -> [((FAST_STRING, FAST_STRING),elt)] -> FiniteMap (FAST_STRING, FAST_STRING) elt , FiniteMap RdrName elt -> [(RdrName,elt)] -> FiniteMap RdrName elt IF_NCG(COMMA FiniteMap Reg elt -> [(Reg COMMA elt)] -> FiniteMap Reg elt) #-} {-# SPECIALIZE addListToFM_C :: (elt -> elt -> elt) -> FiniteMap TyCon elt -> [(TyCon,elt)] -> FiniteMap TyCon elt - , (elt -> elt -> elt) -> FiniteMap FAST_STRING elt -> [(FAST_STRING,elt)] -> FiniteMap FAST_STRING elt + , (elt -> elt -> elt) -> FiniteMap FastString elt -> [(FAST_STRING,elt)] -> FiniteMap FAST_STRING elt IF_NCG(COMMA (elt -> elt -> elt) -> FiniteMap Reg elt -> [(Reg COMMA elt)] -> FiniteMap Reg elt) #-} {-# SPECIALIZE addToFM :: FiniteMap CLabel elt -> CLabel -> elt -> FiniteMap CLabel elt - , FiniteMap FAST_STRING elt -> FAST_STRING -> elt -> FiniteMap FAST_STRING elt - , FiniteMap (FAST_STRING, FAST_STRING) elt -> (FAST_STRING, FAST_STRING) -> elt -> FiniteMap (FAST_STRING, FAST_STRING) elt + , FiniteMap FastString elt -> FAST_STRING -> elt -> FiniteMap FAST_STRING elt + , FiniteMap (FastString, FAST_STRING) elt -> (FAST_STRING, FAST_STRING) -> elt -> FiniteMap (FAST_STRING, FAST_STRING) elt , FiniteMap RdrName elt -> RdrName -> elt -> FiniteMap RdrName elt IF_NCG(COMMA FiniteMap Reg elt -> Reg -> elt -> FiniteMap Reg elt) #-} {-# SPECIALIZE addToFM_C :: (elt -> elt -> elt) -> FiniteMap (RdrName, RdrName) elt -> (RdrName, RdrName) -> elt -> FiniteMap (RdrName, RdrName) elt - , (elt -> elt -> elt) -> FiniteMap FAST_STRING elt -> FAST_STRING -> elt -> FiniteMap FAST_STRING elt + , (elt -> elt -> elt) -> FiniteMap FastString elt -> FAST_STRING -> elt -> FiniteMap FAST_STRING elt IF_NCG(COMMA (elt -> elt -> elt) -> FiniteMap Reg elt -> Reg -> elt -> FiniteMap Reg elt) #-} {-# SPECIALIZE bagToFM - :: Bag (FAST_STRING,elt) -> FiniteMap FAST_STRING elt + :: Bag (FastString,elt) -> FiniteMap FAST_STRING elt #-} {-# SPECIALIZE delListFromFM :: FiniteMap RdrName elt -> [RdrName] -> FiniteMap RdrName elt - , FiniteMap FAST_STRING elt -> [FAST_STRING] -> FiniteMap FAST_STRING elt + , FiniteMap FastString elt -> [FAST_STRING] -> FiniteMap FAST_STRING elt IF_NCG(COMMA FiniteMap Reg elt -> [Reg] -> FiniteMap Reg elt) #-} {-# SPECIALIZE listToFM :: [([Char],elt)] -> FiniteMap [Char] elt - , [(FAST_STRING,elt)] -> FiniteMap FAST_STRING elt - , [((FAST_STRING,FAST_STRING),elt)] -> FiniteMap (FAST_STRING, FAST_STRING) elt + , [(FastString,elt)] -> FiniteMap FAST_STRING elt + , [((FastString,FAST_STRING),elt)] -> FiniteMap (FAST_STRING, FAST_STRING) elt IF_NCG(COMMA [(Reg COMMA elt)] -> FiniteMap Reg elt) #-} {-# SPECIALIZE lookupFM :: FiniteMap CLabel elt -> CLabel -> Maybe elt , FiniteMap [Char] elt -> [Char] -> Maybe elt - , FiniteMap FAST_STRING elt -> FAST_STRING -> Maybe elt - , FiniteMap (FAST_STRING,FAST_STRING) elt -> (FAST_STRING,FAST_STRING) -> Maybe elt + , FiniteMap FastString elt -> FAST_STRING -> Maybe elt + , FiniteMap (FastString,FAST_STRING) elt -> (FAST_STRING,FAST_STRING) -> Maybe elt , FiniteMap RdrName elt -> RdrName -> Maybe elt , FiniteMap (RdrName,RdrName) elt -> (RdrName,RdrName) -> Maybe elt IF_NCG(COMMA FiniteMap Reg elt -> Reg -> Maybe elt) #-} {-# SPECIALIZE lookupWithDefaultFM - :: FiniteMap FAST_STRING elt -> elt -> FAST_STRING -> elt + :: FiniteMap FastString elt -> elt -> FAST_STRING -> elt IF_NCG(COMMA FiniteMap Reg elt -> elt -> Reg -> elt) #-} {-# SPECIALIZE plusFM :: FiniteMap RdrName elt -> FiniteMap RdrName elt -> FiniteMap RdrName elt - , FiniteMap FAST_STRING elt -> FiniteMap FAST_STRING elt -> FiniteMap FAST_STRING elt + , FiniteMap FastString elt -> FiniteMap FAST_STRING elt -> FiniteMap FAST_STRING elt IF_NCG(COMMA FiniteMap Reg elt -> FiniteMap Reg elt -> FiniteMap Reg elt) #-} {-# SPECIALIZE plusFM_C - :: (elt -> elt -> elt) -> FiniteMap FAST_STRING elt -> FiniteMap FAST_STRING elt -> FiniteMap FAST_STRING elt + :: (elt -> elt -> elt) -> FiniteMap FastString elt -> FiniteMap FAST_STRING elt -> FiniteMap FAST_STRING elt IF_NCG(COMMA (elt -> elt -> elt) -> FiniteMap Reg elt -> FiniteMap Reg elt -> FiniteMap Reg elt) #-} diff --git a/ghc/compiler/utils/Outputable.lhs b/ghc/compiler/utils/Outputable.lhs index d96a14ad9b..b3e515d8d6 100644 --- a/ghc/compiler/utils/Outputable.lhs +++ b/ghc/compiler/utils/Outputable.lhs @@ -20,7 +20,7 @@ module Outputable ( docToSDoc, interppSP, interpp'SP, pprQuotedList, pprWithCommas, empty, nest, - text, char, ptext, + text, char, ftext, ptext, int, integer, float, double, rational, parens, brackets, braces, quotes, doubleQuotes, angleBrackets, semi, comma, colon, dcolon, space, equals, dot, @@ -53,7 +53,7 @@ import {-# SOURCE #-} Name( Name ) import CmdLineOpts ( opt_PprStyle_Debug, opt_PprUserLength ) import FastString import qualified Pretty -import Pretty ( Doc, Mode(..), TextDetails(..), fullRender ) +import Pretty ( Doc, Mode(..) ) import Panic import Word ( Word32 ) @@ -227,6 +227,7 @@ docToSDoc d = \_ -> d empty sty = Pretty.empty text s sty = Pretty.text s char c sty = Pretty.char c +ftext s sty = Pretty.ftext s ptext s sty = Pretty.ptext s int n sty = Pretty.int n integer n sty = Pretty.integer n @@ -346,8 +347,8 @@ instance Outputable FastString where pprHsChar :: Int -> SDoc pprHsChar c = char '\'' <> text (showCharLit c "") <> char '\'' -pprHsString :: FAST_STRING -> SDoc -pprHsString fs = doubleQuotes (text (foldr showCharLit "" (_UNPK_INT_ fs))) +pprHsString :: FastString -> SDoc +pprHsString fs = doubleQuotes (text (foldr showCharLit "" (unpackIntFS fs))) showCharLit :: Int -> String -> String showCharLit c rest @@ -391,17 +392,6 @@ instance Show FastString where %************************************************************************ \begin{code} -showDocWith :: Mode -> Doc -> String -showDocWith mode doc - = fullRender mode 100 1.5 put "" doc - where - put (Chr c) s = c:s - put (Str s1) s2 = s1 ++ s2 - put (PStr s1) s2 = _UNPK_ s1 ++ s2 -\end{code} - - -\begin{code} pprWithCommas :: (a -> SDoc) -> [a] -> SDoc pprWithCommas pp xs = hsep (punctuate comma (map pp xs)) diff --git a/ghc/compiler/utils/Pretty.lhs b/ghc/compiler/utils/Pretty.lhs index 08b3671ce3..6f4f6140ed 100644 --- a/ghc/compiler/utils/Pretty.lhs +++ b/ghc/compiler/utils/Pretty.lhs @@ -55,10 +55,10 @@ Version 3.0 28 May 1997 The "fragments" are encapsulated in the TextDetails data type: data TextDetails = Chr Char | Str String - | PStr FAST_STRING + | PStr FastString The Chr and Str constructors are obvious enough. The PStr constructor has a packed - string (FAST_STRING) inside it. It's generated by using the new "ptext" export. + string (FastString) inside it. It's generated by using the new "ptext" export. An advantage of this new setup is that you can get the renderer to do output directly (by passing in a function of type (TextDetails -> IO () -> IO ()), @@ -158,7 +158,7 @@ module Pretty ( empty, isEmpty, nest, - text, char, ptext, + text, char, ftext, ptext, int, integer, float, double, rational, parens, brackets, braces, quotes, doubleQuotes, semi, comma, colon, space, equals, @@ -172,7 +172,7 @@ module Pretty ( hang, punctuate, -- renderStyle, -- Haskell 1.3 only - render, fullRender, printDoc + render, fullRender, printDoc, showDocWith ) where #include "HsVersions.h" @@ -180,8 +180,17 @@ module Pretty ( import FastString import GlaExts import Numeric (fromRat) +import PrimPacked ( strLength ) import IO +#if __GLASGOW_HASKELL__ < 503 +import IOExts ( hPutBufFull ) +#else +import System.IO ( hPutBuf ) +#endif + +import PrimPacked ( strLength ) + -- Don't import Util( assertPanic ) because it makes a loop in the module structure infixl 6 <> @@ -493,7 +502,9 @@ reduceDoc p = p data TextDetails = Chr Char | Str String - | PStr FAST_STRING + | PStr FastString -- a hashed string + | LStr Addr# Int# -- a '\0'-terminated array of bytes + space_text = Chr ' ' nl_text = Chr '\n' \end{code} @@ -581,7 +592,8 @@ isEmpty _ = False char c = textBeside_ (Chr c) 1# Empty text s = case length s of {IBOX(sl) -> textBeside_ (Str s) sl Empty} -ptext s = case _LENGTH_ s of {IBOX(sl) -> textBeside_ (PStr s) sl Empty} +ftext s = case lengthFS s of {IBOX(sl) -> textBeside_ (PStr s) sl Empty} +ptext (A# s) = case strLength (A# s) of {IBOX(sl) -> textBeside_ (LStr s sl) sl Empty} nest IBOX(k) p = mkNest k (reduceDoc p) -- Externally callable version @@ -884,12 +896,28 @@ renderStyle Style{mode, lineLength, ribbonsPerLine} doc = fullRender mode lineLength ribbonsPerLine doc "" -} -render doc = showDoc doc "" -showDoc doc rest = fullRender PageMode 100 1.5 string_txt rest doc +render doc = showDocWith PageMode doc +showDoc doc rest = showDocWithAppend PageMode doc rest + +showDocWithAppend :: Mode -> Doc -> String -> String +showDocWithAppend mode doc rest = fullRender mode 100 1.5 string_txt rest doc + +showDocWith :: Mode -> Doc -> String +showDocWith mode doc = showDocWithAppend mode doc "" string_txt (Chr c) s = c:s string_txt (Str s1) s2 = s1 ++ s2 -string_txt (PStr s1) s2 = _UNPK_ s1 ++ s2 +string_txt (PStr s1) s2 = unpackFS s1 ++ s2 +string_txt (LStr s1 _) s2 = unpackLitString s1 ++ s2 + +unpackLitString addr = + unpack 0# + where + unpack nh + | ch `eqChar#` '\0'# = [] + | otherwise = C# ch : unpack (nh +# 1#) + where + ch = indexCharOffAddr# addr nh \end{code} \begin{code} @@ -980,6 +1008,18 @@ printDoc mode hdl doc put (Chr c) next = hPutChar hdl c >> next put (Str s) next = hPutStr hdl s >> next put (PStr s) next = hPutFS hdl s >> next + put (LStr s l) next = hPutLitString hdl s l >> next done = hPutChar hdl '\n' + +#if __GLASGOW_HASKELL__ < 503 +hPutBuf = hPutBufFull +#endif + +hPutLitString handle a# l# +#if __GLASGOW_HASKELL__ < 411 + = hPutBuf handle (A# a#) (I# l#) +#else + = hPutBuf handle (Ptr a#) (I# l#) +#endif \end{code} diff --git a/ghc/compiler/utils/PrimPacked.lhs b/ghc/compiler/utils/PrimPacked.lhs index c8cecffb26..db6ac9a711 100644 --- a/ghc/compiler/utils/PrimPacked.lhs +++ b/ghc/compiler/utils/PrimPacked.lhs @@ -161,6 +161,7 @@ eqStrPrefix a# barr# len# = x <- memcmp_ba a# barr# (I# len#) return (x == 0) +-- unused??? eqCharStrPrefix :: Addr# -> Addr# -> Int# -> Bool eqCharStrPrefix a1# a2# len# = unsafePerformIO $ do |