From b085ee40c7f265a5977ea6ec1c415e573be5ff8c Mon Sep 17 00:00:00 2001
From: simonmar <unknown>
Date: Mon, 29 Apr 2002 14:04:11 +0000
Subject: [PATCH] [project @ 2002-04-29 14:03:38 by simonmar] FastString
cleanup, stage 1.
The FastString type is no longer a mixture of hashed strings and
literal strings, it contains hashed strings only with O(1) comparison
(except for UnicodeStr, but that will also go away in due course). To
create a literal instance of FastString, use FSLIT("..").
By far the most common use of the old literal version of FastString
was in the pattern
ptext SLIT("...")
this combination still works, although it doesn't go via FastString
any more. The next stage will be to remove the need to use this
special combination at all, using a RULE.
To convert a FastString into an SDoc, now use 'ftext' instead of
'ptext'.
I've also removed all the FAST_STRING related macros from HsVersions.h
except for SLIT and FSLIT, just use the relevant functions from
FastString instead.
---
ghc/compiler/HsVersions.h | 37 +-----
ghc/compiler/absCSyn/AbsCSyn.lhs | 11 +-
ghc/compiler/absCSyn/AbsCUtils.lhs | 4 +-
ghc/compiler/absCSyn/CLabel.lhs | 21 +--
ghc/compiler/absCSyn/CStrings.lhs | 15 ++-
ghc/compiler/absCSyn/PprAbsC.lhs | 7 +-
ghc/compiler/basicTypes/Literal.lhs | 13 +-
ghc/compiler/basicTypes/MkId.lhs | 5 +-
ghc/compiler/basicTypes/Module.lhs | 9 +-
ghc/compiler/basicTypes/OccName.lhs | 55 ++++----
ghc/compiler/basicTypes/SrcLoc.lhs | 24 ++--
ghc/compiler/codeGen/CgCase.lhs | 8 +-
ghc/compiler/codeGen/CgClosure.lhs | 41 +++---
ghc/compiler/codeGen/CgCon.lhs | 6 +-
ghc/compiler/codeGen/CgConTbls.lhs | 6 +-
ghc/compiler/codeGen/CgExpr.lhs | 4 +-
ghc/compiler/codeGen/CgHeapery.lhs | 8 +-
ghc/compiler/codeGen/CgMonad.lhs | 11 +-
ghc/compiler/codeGen/CgTailCall.lhs | 12 +-
ghc/compiler/codeGen/CgUsages.lhs | 2 +-
ghc/compiler/codeGen/ClosureInfo.lhs | 17 +--
ghc/compiler/codeGen/CodeGen.lhs | 4 +-
ghc/compiler/coreSyn/CoreSyn.lhs | 3 +-
ghc/compiler/coreSyn/MkExternalCore.lhs | 7 +-
ghc/compiler/coreSyn/PprCore.lhs | 5 +-
ghc/compiler/deSugar/Check.lhs | 5 +-
ghc/compiler/deSugar/Desugar.lhs | 5 +-
ghc/compiler/deSugar/DsExpr.lhs | 3 +-
ghc/compiler/deSugar/DsForeign.lhs | 21 +--
ghc/compiler/deSugar/DsUtils.lhs | 21 +--
ghc/compiler/deSugar/Match.lhs | 2 +-
ghc/compiler/ghci/ByteCodeGen.lhs | 2 +-
ghc/compiler/ghci/ByteCodeLink.lhs | 12 +-
ghc/compiler/hsSyn/HsBinds.lhs | 14 +-
ghc/compiler/hsSyn/HsCore.lhs | 5 +-
ghc/compiler/hsSyn/HsDecls.lhs | 10 +-
ghc/compiler/hsSyn/HsExpr.lhs | 17 +--
ghc/compiler/hsSyn/HsImpExp.lhs | 3 +-
ghc/compiler/hsSyn/HsLit.lhs | 9 +-
ghc/compiler/hsSyn/HsTypes.lhs | 4 +-
ghc/compiler/ilxGen/IlxGen.lhs | 4 +-
ghc/compiler/javaGen/JavaGen.lhs | 2 +-
ghc/compiler/main/CmdLineOpts.lhs | 4 +-
ghc/compiler/main/HscMain.lhs | 5 +-
ghc/compiler/main/MkIface.lhs | 11 +-
ghc/compiler/main/ParsePkgConf.y | 2 +-
ghc/compiler/nativeGen/AsmCodeGen.lhs | 3 +-
ghc/compiler/nativeGen/MachCode.lhs | 163 ++++++++++++------------
ghc/compiler/nativeGen/MachMisc.lhs | 3 +-
ghc/compiler/nativeGen/PprMach.lhs | 56 ++++----
ghc/compiler/nativeGen/Stix.lhs | 19 +--
ghc/compiler/nativeGen/StixMacro.lhs | 4 +-
ghc/compiler/nativeGen/StixPrim.lhs | 4 +-
ghc/compiler/ndpFlatten/Flattening.hs | 35 +++--
ghc/compiler/parser/Lex.lhs | 48 +++----
ghc/compiler/parser/ParseUtil.lhs | 40 +++---
ghc/compiler/parser/Parser.y | 26 ++--
ghc/compiler/parser/ParserCore.y | 13 +-
ghc/compiler/prelude/ForeignCall.lhs | 2 +-
ghc/compiler/prelude/PrelNames.lhs | 19 +--
ghc/compiler/prelude/PrelRules.lhs | 11 +-
ghc/compiler/prelude/TysWiredIn.lhs | 3 +-
ghc/compiler/profiling/CostCentre.lhs | 15 ++-
ghc/compiler/rename/RnBinds.lhs | 4 +-
ghc/compiler/rename/RnExpr.lhs | 3 +-
ghc/compiler/rename/RnSource.lhs | 6 +-
ghc/compiler/simplCore/SetLevels.lhs | 5 +-
ghc/compiler/simplCore/SimplMonad.lhs | 5 +-
ghc/compiler/simplCore/Simplify.lhs | 4 +-
ghc/compiler/specialise/Rules.lhs | 9 +-
ghc/compiler/specialise/SpecConstr.lhs | 3 +-
ghc/compiler/specialise/Specialise.lhs | 4 +-
ghc/compiler/stranal/WwLib.lhs | 1 -
ghc/compiler/typecheck/TcClassDcl.lhs | 3 +-
ghc/compiler/typecheck/TcDeriv.lhs | 18 ++-
ghc/compiler/typecheck/TcExpr.lhs | 11 +-
ghc/compiler/typecheck/TcGenDeriv.lhs | 27 ++--
ghc/compiler/typecheck/TcInstDcls.lhs | 3 +-
ghc/compiler/typecheck/TcPat.lhs | 3 +-
ghc/compiler/typecheck/TcRules.lhs | 2 +-
ghc/compiler/types/Generics.lhs | 3 +-
ghc/compiler/utils/FastString.lhs | 129 +++----------------
ghc/compiler/utils/FiniteMap.lhs | 28 ++--
ghc/compiler/utils/Outputable.lhs | 20 +--
ghc/compiler/utils/Pretty.lhs | 58 +++++++--
ghc/compiler/utils/PrimPacked.lhs | 1 +
86 files changed, 630 insertions(+), 680 deletions(-)
diff --git a/ghc/compiler/HsVersions.h b/ghc/compiler/HsVersions.h
index 4900e5663ab..40a58517b4e 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 36d3db7e6e9..2389512c771 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 5643da83096..90988cdebcc 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 b56db8d269f..a26d9d7a510 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 6f2a0e3570f..f25e6c204f0 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 df937262274..c08740cdd54 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 7954743ac6b..45a3dc5286e 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 80d4622e7f3..e83e491c2b6 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 5fdfe343a57..0387f97237e 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 66e158cedc4..e10d43fc27c 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 3f89e97e3f7..c3fca1db643 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 8201952cd69..df2e165a89e 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 e7d70e4fa56..43b4146a566 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 3d732636d35..ce9e675e0cc 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 eec28262e61..b61e43380fa 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 c350218ab45..2076a071a4b 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 ebc51019da2..a040d32c001 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 25c36cd3f58..5c24825a9e4 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 73e7aaa93f3..4468eead66c 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 8c40c9a4708..70306291063 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 29d6037c439..58408813308 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 5d08357b73a..477790d0c11 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 42640f9ac04..f603969a63d 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 bfe63808be8..bab0c159cff 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 8639a9307b4..d6b3a6e2824 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 23a818d97db..1f64cf69c70 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 3965a361af2..55152d9e84b 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 3707cd06328..e379d2606b9 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 5d3b9329143..a89b70655da 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 5ff1a7320b3..ac9e85b35cd 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 73134d813cb..d76fccf7e38 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 eeb1580ae67..56f64fcc3dd 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 6c0ed01cda0..04e84339f85 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 b5456d23520..bb2c8b2bb78 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 8d1da8f7518..0f5a0203707 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 848ef57f260..036a427318d 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 2e899c08eab..fa817757857 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 e4839146193..b33fb2bcd73 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 aa19b641641..2675810465a 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 3c4262989c6..837dc91b451 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 3f1cdd9dd9e..b2c424c5717 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 ae6d19a4ca7..55b2b716c12 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 94dd35464d3..c93dc2f7796 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 2b2ad0a903e..fd99a5e10b1 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 8fe9e6611d8..f2b908e2c7e 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 f710b150dd6..995d3009be6 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 a9ce466713f..d3acf164132 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 18065657743..fe8bc6776be 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 012b319deaa..aa2e961d9e2 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 84374d84d05..b91597157e5 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 95c54f1f9fb..bae8b64b4fc 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 a57c95128a3..dfa2eccf07a 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 0610bedcc5d..79d4da22616 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 4733bc43cab..796d34e0090 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 6c497cb894b..26bcf9dac15 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 63149146836..a9ae3ffb1b2 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 39f3335c6cd..3ecaff1a426 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 e24779a28b1..bcedf8c7f4c 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 55ae7078395..81d57052e21 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 0e1f2467a22..8dc8fb908a2 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 a7fa4255c5a..5f0981c37e3 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 872681e9a38..7c8009b6522 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 506783d73a6..eb1a3b94163 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 bb6f9eac464..8bc83e27d8f 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 992679b0121..1a18cb34b92 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 647cf6cefea..352df726fd4 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 baaa442961c..5c9cb1e15bf 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 266d9ec64fa..f538bf9b755 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 0a614180f2f..0a303905481 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 8a489a0a6d3..34813e7c494 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 c79ec11767b..3812234c39f 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 16d3748f3ad..c9ffa0b1fa8 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 f3c3d29df5b..58060b0d3e8 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 443459414da..79c834dacad 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 16f41db71e5..b072bb4645d 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 1da69ecfbba..52ec896aa27 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 b237ca89e62..0f7400341fb 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 7366c3c6c4e..79ac5401431 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 6c455a5528b..f816b7c1813 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 cf2f5b00657..f5ddf1eb446 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 744b667980e..b868c2a8ebd 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 a7742433986..6f4876f9ce0 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 c2c34fb782a..84212580f74 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 d96a14ad9b7..b3e515d8d66 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 08b3671ce35..6f4f6140ed9 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 c8cecffb264..db6ac9a7113 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
--
GitLab