diff --git a/ghc/compiler/HsVersions.h b/ghc/compiler/HsVersions.h
index 4900e5663abbd9bd6b4339a9682c1c60131576ad..40a58517b4e080000e58f4b8ac7fa6374504063b 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 36d3db7e6e92c7fa42cb27a1caae02cf07b20d84..2389512c771831c3dc561a4826734d861388b4b3 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 5643da830965b76879b97d4e37b81d3532f59863..90988cdebccc1541a9c826f2e315e9d47bc6c25b 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 b56db8d269fe8f2943828ed15f34a2ae1a8e2b10..a26d9d7a5101e3d2844b41889058dbddba709d1c 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 6f2a0e3570f131416d9b51a12f18e257725e8e1f..f25e6c204f04f70677fcee659e25b346a918744c 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 df937262274531c6fc53d121021622503a99eba1..c08740cdd54b15874fca4d676d03afdcda59bb80 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 7954743ac6b7836742aecd680b5703867c7ab762..45a3dc5286e4e24d57adb8f4e2c9f20c4c68a2ce 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 80d4622e7f3acd0e14724502b80df244e0012a26..e83e491c2b6ac7f403b1f34121bd345a2a69f3d6 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 5fdfe343a57d176b5d54e1038ee035a22c220672..0387f97237edfa4f3d569c34d71b61d55952712b 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 66e158cedc49cbba98f887793fa712166ce9d39c..e10d43fc27c178020fbaa6adaa6871f09f5c16a0 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 3f89e97e3f7305c49081c44724fc363d76f41785..c3fca1db6434dd0ea1e4cd035792a04a801aafb0 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 8201952cd699079f38715eb032158f7b94f8f9f5..df2e165a89e8808318f67ad62580cd3a0df39d0e 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 e7d70e4fa56d7fadc1af55e8f07bf26969a4d386..43b4146a566cb482b38207137ea7925ecfc757b3 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 3d732636d35ef224fa30d1485eee6072c735d11f..ce9e675e0cc646c3db32773cc73720488ca12684 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 eec28262e61af8b548ba0e72e7e358b350490fcf..b61e43380fa5898e884ca2694a3ed095e0519298 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 c350218ab45e82034665b47e8b9cef217f0bc492..2076a071a4bee917f3bc4d1e33467d9b48ab5dab 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 ebc51019da243f5fda1e79d641d251c99d798fbb..a040d32c0018111af5abdafcb5c43e5963c1d16c 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 25c36cd3f58c16fcb6e9df8f75c5829d4c580386..5c24825a9e47832e69a80bc4863f15f7dd143133 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 73e7aaa93f340bbd98d64a9e8a7d7b6b40a89511..4468eead66cd3f483c2dcfa76715281967c0d0af 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 8c40c9a47084db7281b91a6f413ab870722bdd7e..7030629106363ab1602c2b0e23e57570610c7ad2 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 29d6037c4394a342f1f01c21c79fb1e39543b0c7..58408813308cc01d6777ac1ec393d34b593361fe 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 5d08357b73a5c39536b24b5bb4c8ed9b6049bfdf..477790d0c11e7c5fa004e7bb8df03f6b56f70e05 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 42640f9ac0438df7a443187494834f2fdb988cd8..f603969a63d244eb21682c238d2fb1e72a98a551 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 bfe63808be8b8c1e665500cceabffaa7befe2102..bab0c159cff4ba8d0903ce962761a63048ed33d5 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 8639a9307b4b8eccf467b1999dcbb04a4f93b9ab..d6b3a6e2824b8daeb15422ff2cbd3074f72060be 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 23a818d97dbed3ebb1f4b9b3ab2819d28124dfbd..1f64cf69c70012fe3a729ae9272700863a465389 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 3965a361af287be424a6a6966041a07d1beb5766..55152d9e84b32a42df9cdb2fdfe255d603a412e2 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 3707cd063282d975fc602efb9719e5d7c3007a5d..e379d2606b964db5a4ebdaf64e199c455705a480 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 5d3b93291432af2f5bc4342c7adc15957acdef08..a89b70655da239107bafb281e0b229229d885b96 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 5ff1a7320b3ec6e96900cc312e09dff083b1263b..ac9e85b35cd61b9a44560717e4d901a0a4b03fee 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 73134d813cb0520152711aaac1f48bcece97e012..d76fccf7e3885b0dc30cc904ea3a378d8fd08504 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 eeb1580ae67fe0e7d10ae2301730edc6a7ac14fa..56f64fcc3dda79ae86484fd0312c9312824873ec 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 6c0ed01cda0babee47a461142854801e8193e8b6..04e84339f859c860a5a3eca8dd25410a7b775d5e 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 b5456d23520e1c40c52312b8ebe0b581e0990077..bb2c8b2bb78f1ee25a4ad9d32f344e03039e1ed3 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 8d1da8f75189ee652672ad89d5140dccc7bada39..0f5a02037073941ce3173300eca51ba5d9fc6726 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 848ef57f2602cbebcc824ad5227efde80c20a6bc..036a427318de764afa667b73c7921f7233cd2e14 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 2e899c08eabbdab52021f91d5d79fddc363edc68..fa817757857004ef19082cb7fd96056623d3333d 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 e483914619369de1da630a0b3daddae08dcff8ab..b33fb2bcd730467c1a43a41b5ecbfcda13b17de3 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 aa19b6416411a152aa5ebd48a5a1a3ecba17882e..2675810465a228eb14fc6714c65c5eceff7cae07 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 3c4262989c6ba9679928acc5d79ceb9246e013af..837dc91b4512ef2c6bb572f03d4a1f45a334aecf 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 3f1cdd9dd9edafbda0a8266d23063749e1893248..b2c424c5717034611afd4857c4d29fce41857b2d 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 ae6d19a4ca76e9a4e22bd3c31645ea6707533d31..55b2b716c128734d9951dd31d662f22df7c7863c 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 94dd35464d32606305611419cb42050c42681c1c..c93dc2f7796b9db1e581df8dffceb2a439b479d8 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 2b2ad0a903ef9d482e0d4b46dad400e1f983ca55..fd99a5e10b150a09e888b353322eb84edbc0b2ca 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 8fe9e6611d8d7625d871104d3deb0547d77b6c67..f2b908e2c7edb444b02589d14364c7bfef7374b9 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 f710b150dd6e7c38e45f5eb915626235cde44a35..995d3009be6445818e1f7b549248c07ce22f8f8a 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 a9ce466713f12c4f5dc7e8a1302ef9b4cd69981b..d3acf164132d866b6cceb0aa648579d09dfd7a59 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 180656577434a25b3edbae30e1968e6b11e77d23..fe8bc6776be3b8f10a8258ad059e824653698548 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 012b319deaa5fee56050708bc4d82021c85fbfbd..aa2e961d9e2238cec96b2bfa67cae7dfeffdb162 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 84374d84d055285edd78af864b09cbd889e3e444..b91597157e543e5fd03b417d70043f0b51ed0c88 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 95c54f1f9fb3ab44a67e14c72d1d69c4695c9539..bae8b64b4fce76350f903fd4a408cdbc61f92bc8 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 a57c95128a33ef37d86a66dbf5ad95a5e677d99f..dfa2eccf07af241b535424d5b8b08aabf8b39594 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 0610bedcc5d9f92f8d34917ea925a9d039e454ac..79d4da2261609953c24697ce651e8ae0daeb1480 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 4733bc43cab3920afaf96288f249a1cbcc7b51f4..796d34e009092dd8088631e608b9216e793dd685 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 6c497cb894b0b8e45ba03b800fa467c4df923d0c..26bcf9dac15080cf40a93ac6c47811fd78ebad46 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 631491468369d7362aea987ce4a05fca33362fc4..a9ae3ffb1b2e85a64f8f5325ed7fa9b585ad8a51 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 39f3335c6cd598bd2b92818a38b640295b92962b..3ecaff1a42630d9db9e1a952a34548287723a4ad 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 e24779a28b15bbf3ab0c58e68085d7085ad9d353..bcedf8c7f4c8fa8d1c668afbe9aa102aee837861 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 55ae70783950d336875d9fa9b9250c8eff02d9fb..81d57052e21aebda01d879c5a93ad29e919be89b 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 0e1f2467a22772de267c904c5901c8b2c1971937..8dc8fb908a20d2772430a1921ccc227384ecbd19 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 a7fa4255c5ad9584e2e6e959ba55adff854fa03a..5f0981c37e38a36c785375ff55dcd28eb740c751 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 872681e9a380359b6ba97d1c6490775069e4cf8f..7c8009b65224981b3cfca56757a7e73352cb62ee 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 506783d73a610ec6688061b56f906901402b3892..eb1a3b94163ccf60fb6a370f6e444379326e7284 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 bb6f9eac464d4868df879abb07b4f93c91f12f47..8bc83e27d8ff78eebb0b5d655619986ff3a90d69 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 992679b0121f368d809cbf6d6afad8bccc2638a5..1a18cb34b9224e720d68e9da6838e206c295285c 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 647cf6cefeac9b860e47b7ab41535bb8f0508394..352df726fd42690992f51d0e3a606c552b9f512e 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 baaa442961c1fce56a1f88af2b86e7c7e850483f..5c9cb1e15bffa375d1766ae71f46d15c7d2901dc 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 266d9ec64fa4a0424e37578e1a04655071a70f9d..f538bf9b755895a3f5831439c3f07180c265d84c 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 0a614180f2fe69bb1414ee608ae2855deeead943..0a30390548188068b85be94cc55d0e505fa2ac2e 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 8a489a0a6d3d126932f242487d37c22c6cc82ea7..34813e7c49410799a1274cc53abe46ee801d00d1 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 c79ec11767bdf3f337935309ba4dbea39a0a3e2f..3812234c39f2452f367b1d075e681d140228bdef 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 16d3748f3adea759ef4dcfa6f4a0caaca3bd0a9f..c9ffa0b1fa8d7b301552b362763842283763352a 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 f3c3d29df5b65bc5de0e4de30bdf5bff63de7e68..58060b0d3e89100b4adf100d28b77a0e3e81f166 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 443459414dab637442198a082b2c47b150e55dc3..79c834dacad627e38ac324a986f009879de0bdba 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 16f41db71e52aa97c7faedc736b4a7dbcae10192..b072bb4645d85b69fb37c58029e7c25d00a2d5ac 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 1da69ecfbba86b833f7d9aabc5539f4fb8d8636a..52ec896aa27867c1b2106fe2f88d11b22c3e74ef 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 b237ca89e62c3482494ac4d6bc162c2bd925226b..0f7400341fb6760e225a7349412930dd76562180 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 7366c3c6c4e0b5a4be3f6bedc0ec1445c445bc88..79ac5401431e065b2e851e24cfdd78924e8314a5 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 6c455a5528bacbac4af56f4dabff4f499f97e59a..f816b7c181321ea77c9f10105c5af2a01a504bf2 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 cf2f5b006578d0fd37d9f4ee5abb5a82be4551ea..f5ddf1eb4468a9e431ef2f15ee8482ad6ff0cb4d 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 744b667980e98a0f7a9455329000112ab62efdb6..b868c2a8ebd672b74f64d367987f39b05ede6cd4 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 a774243398669042216b12f7ac131ec73097071a..6f4876f9ce0e2d79c859593185b2edadda896c51 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 c2c34fb782aea49257dd2b04e6e7f30f8e51fe53..84212580f74cb663b8305459d9d49f9db61960b0 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 d96a14ad9b7a2cffa93740cbc56d7cc5ccf313dd..b3e515d8d6680e815f171ae0b051bf9af9b797f8 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
@@ -390,17 +391,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 08b3671ce35ddec1515ee6b9428725476bba5c06..6f4f6140ed9c55025c8d7ecbfaf70ce2df606be1 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 c8cecffb264cb6092539de7786d2e32b383a9359..db6ac9a711336a83ebd9dfed12b4e322c8c47b6e 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