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.
#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
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
%
% (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}
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
-- 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
mkIntCLit :: Int -> CAddrMode
mkIntCLit i = CLit (mkMachInt (toInteger i))
-mkCString :: FAST_STRING -> CAddrMode
+mkCString :: FastString -> CAddrMode
mkCString s = CLit (MachStr s)
mkCCostCentre :: CostCentre -> CAddrMode
-- 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:
= COpStmt
[]
(StgFCallOp
- (CCall (CCallSpec (CasmTarget (_PK_ (mktxt op_str)))
+ (CCall (CCallSpec (CasmTarget (mkFastString (mktxt op_str)))
defaultCCallConv (PlaySafe False)))
uu
)
%
% (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}
import PrimOp ( PrimOp )
import CostCentre ( CostCentre, CostCentreStack )
import Outputable
+import FastString
\end{code}
things we want to find out:
| 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
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
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)
-- Foreign labels
-mkForeignLabel :: FAST_STRING -> Bool -> CLabel
+mkForeignLabel :: FastString -> Bool -> CLabel
mkForeignLabel str is_dynamic = ForeignLabel str is_dynamic
-- Cost centres etc.
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),
= ptext SLIT("module_registered")
pprCLbl (ForeignLabel str _)
- = ptext str
+ = ftext str
pprCLbl (TyConLabel tc)
= hcat [ppr tc, pp_cSEP, ptext SLIT("closure_tbl")]
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
module CStrings(
CLabelString, isCLabelString, pprCLabelString,
- cSEP, pp_cSEP,
+ pp_cSEP,
pprFSInCStyle, pprStringInCStyle
) where
#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))
import BitSet ( BitSet, intBS )
import Outputable
import GlaExts
+import FastString
import Util ( lengthExceeds, listLengthCmp )
import ST
= 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"))
= 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)
import Outputable
import FastTypes
+import FastString
import Binary
import Util ( thenCmp )
= ------------------
-- 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"
-- "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
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])
-- 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}
import Maybe ( isJust )
import Util ( dropList, isSingleton )
import Outputable
+import FastString
import ListSetOps ( assoc, assocMaybe )
import UnicodeUtil ( stringToUtf8 )
import List ( nubBy )
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")
%************************************************************************
\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
import UniqFM
import UniqSet
import Binary
+import FastString
\end{code}
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
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
import Util ( thenCmp )
import Unique ( Unique )
import FiniteMap ( FiniteMap, emptyFM, lookupFM, addToFM, elemFM )
+import FastString
import Outputable
import Binary
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
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}
%************************************************************************
\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 )
-- 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*
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)
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!
= (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
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}
-- 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
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
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 [] = []
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
-------------
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
import Outputable
import FastString ( unpackFS )
import FastTypes
+import FastString
import GlaExts ( (+#) )
\end{code}
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}
\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
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}
%
% (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 $
%
%********************************************************
%* *
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)
)
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.
%
% (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}
import Util ( isIn, splitAtList )
import CmdLineOpts ( opt_SccProfilingOn )
import Outputable
+import FastString
import Name ( nameOccName )
import OccName ( occNameFS )
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:
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 [
]
-- 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
(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
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"
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
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
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 ->
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
-- 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}
(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
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
%
% (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 $
%
%********************************************************
%* *
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
%
% (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}
= 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 ]
]
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`
then AbsCNop
else mkAbstractCs
[ checking_code,
- profCtrAbsC SLIT("TICK_ALLOC_HEAP")
+ profCtrAbsC FSLIT("TICK_ALLOC_HEAP")
[ mkIntCLit words_required, CLbl ctr DataPtrRep ]
]
) `thenC`
%
% (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}
import Id ( Id )
import VarEnv
import PrimRep ( PrimRep(..) )
+import FastString
import Outputable
infixr 9 `thenC` -- Right-associative!
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
%
% (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 $
%
%********************************************************
%* *
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`
= 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))
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
= 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)
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
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))
%
% (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}
import Type ( isUnLiftedType, Type )
import BasicTypes ( TopLevelFlag(..), isNotTopLevel, isTopLevel )
import Util ( mapAccumL, listLengthCmp, lengthIs )
+import FastString
import Outputable
\end{code}
\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}
[ 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}
%************************************************************************
import DataCon ( DataCon, dataConWorkId )
import BasicTypes ( Activation )
import VarSet
+import FastString
import Outputable
\end{code}
\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
import PprExternalCore
import CmdLineOpts
import IO
+import FastString
emitExternalCore :: DynFlags -> ModIface -> ModDetails -> IO ()
emitExternalCore dflags iface details
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)
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
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)),
import UniqSet
import Util ( takeList, splitAtList, notNull )
import Outputable
+import FastString
#include "HsVersions.h"
\end{code}
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]
-- 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]
import Outputable
import UniqSupply ( mkSplitUniqSupply )
import HscTypes ( HomeSymbolTable, PersistentCompilerState(..), TyThing(..), lookupType, )
+import FastString
\end{code}
%************************************************************************
-> 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,
\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
import PrelNames ( hasKey, ratioTyConKey, toPName )
import Util ( zipEqual, zipWithEqual )
import Outputable
+import FastString
import Ratio ( numerator, denominator )
\end{code}
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)
import ErrUtils ( addShortWarnLocLine )
import Outputable
import Maybe ( fromJust )
+import FastString
\end{code}
Desugaring of @foreign@ declarations is naturally split up into
-- "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
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, [])
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
= 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 ->
]
-- 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
\begin{code}
mkFExportCBits :: String
- -> FAST_STRING
+ -> FastString
-> Maybe Id -- Just==static, Nothing==dynamic
-> [Type]
-> Type
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)))
, 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
import Outputable
import UnicodeUtil ( intsToUtf8, stringToUtf8 )
import Util ( isSingleton, notNull )
+import FastString
\end{code}
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
= 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}
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))
| 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}
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) =
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)
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
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)
-- instrs nonptrs ptrs itbls
type AsmState = (SizedSeq Word16,
- SizedSeq (Either Word FAST_STRING),
+ SizedSeq (Either Word FastString),
SizedSeq (Either Name PrimOp),
SizedSeq Name)
= 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#;
-- 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
\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}
import CostCentre
import Util ( eqListBy, lengthIs )
import Outputable
+import FastString
\end{code}
%************************************************************************
| 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
| UfDataAlt name
| UfTupleAlt (HsTupCon name)
| UfLitAlt Literal
- | UfLitLitAlt FAST_STRING (HsType name)
+ | UfLitLitAlt FastString (HsType name)
data UfBinding name
= UfNonRec (UfBinder name)
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")
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
| 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
\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 _)
import CStrings ( CLabelString, pprCLabelString )
import BasicTypes ( IPName, Boxity, tupleParens )
import SrcLoc ( SrcLoc )
+import FastString
\end{code}
%************************************************************************
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}
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("->")])
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}
\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}
import Name ( isLexSym )
import Module ( ModuleName, WhereFrom )
import Outputable
+import FastString
import SrcLoc ( SrcLoc )
\end{code}
\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.
import Name ( Name )
import HsTypes ( PostTcType )
import Outputable
+import FastString
import Ratio ( Rational )
\end{code}
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
| 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;
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
-----------------------
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
-- 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
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]
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]
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")
import Name ( Name, nameModule, nameOccName, getName )
import NameEnv ( emptyNameEnv, mkNameEnv )
import Module ( Module )
+import FastString
import IOExts ( newIORef, readIORef, writeIORef,
unsafePerformIO )
--
foreign_headers =
unlines
- . map (\fname -> "#include \"" ++ _UNPK_ fname ++ "\"")
+ . map (\fname -> "#include \"" ++ unpackFS fname ++ "\"")
. reverse
$ headers
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 {
import Binary ( getBinFileWithDict )
import BinIface ( writeBinIface )
import ErrUtils ( dumpIfSet_dyn )
+import FastString
import Monad ( when )
import Maybe ( catMaybes )
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}
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)
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}
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
import qualified Pretty
import Outputable
+import FastString
-- DEBUGGING ONLY
--import OrdList
-> 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)
-- DEBUGGING ONLY
import IOExts ( trace )
import Outputable ( assertPanic )
+import FastString
infixr 3 `bind`
\end{code}
-- 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)
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)
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"
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
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)
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
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,
instr (ImmInt 1) r_dst,
LABEL lbl_after,
- COMMENT (_PK_ "end shift sequence")
+ COMMENT (mkFastString "end shift sequence")
]
in
returnNat (Any IntRep code__2)
(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)
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
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)
\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)
-- 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))
-- 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)
import IOExts ( trace )
import Config ( cLeadingUnderscore )
import FastTypes
+import FastString
import Maybe ( catMaybes )
\end{code}
\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
import MutableArray
import Char ( chr, ord )
import Maybe ( isJust )
+import FastString
asmSDoc d = Outputable.withPprStyleDoc (
Outputable.mkCodeStyle Outputable.AsmStyle) d
--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-}
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',
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',
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',
pprOperand size op1
]
-pprSizeOp :: FAST_STRING -> Size -> Operand -> Doc
+pprSizeOp :: LitString -> Size -> Operand -> Doc
pprSizeOp name size op1
= hcat [
char '\t',
pprOperand size op1
]
-pprSizeOpOp :: FAST_STRING -> Size -> Operand -> Operand -> Doc
+pprSizeOpOp :: LitString -> Size -> Operand -> Operand -> Doc
pprSizeOpOp name size op1 op2
= hcat [
char '\t',
pprOperand size op2
]
-pprSizeByteOpOp :: FAST_STRING -> Size -> Operand -> Operand -> Doc
+pprSizeByteOpOp :: LitString -> Size -> Operand -> Operand -> Doc
pprSizeByteOpOp name size op1 op2
= hcat [
char '\t',
pprOperand size op2
]
-pprSizeOpReg :: FAST_STRING -> Size -> Operand -> Reg -> Doc
+pprSizeOpReg :: LitString -> Size -> Operand -> Reg -> Doc
pprSizeOpReg name size op1 reg
= hcat [
char '\t',
pprReg size reg
]
-pprSizeReg :: FAST_STRING -> Size -> Reg -> Doc
+pprSizeReg :: LitString -> Size -> Reg -> Doc
pprSizeReg name size reg1
= hcat [
char '\t',
pprReg size reg1
]
-pprSizeRegReg :: FAST_STRING -> Size -> Reg -> Reg -> Doc
+pprSizeRegReg :: LitString -> Size -> Reg -> Reg -> Doc
pprSizeRegReg name size reg1 reg2
= hcat [
char '\t',
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',
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',
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',
pprReg size reg3
]
-pprSizeAddr :: FAST_STRING -> Size -> MachRegsAddr -> Doc
+pprSizeAddr :: LitString -> Size -> MachRegsAddr -> Doc
pprSizeAddr name size op
= hcat [
char '\t',
pprAddr op
]
-pprSizeAddrReg :: FAST_STRING -> Size -> MachRegsAddr -> Reg -> Doc
+pprSizeAddrReg :: LitString -> Size -> MachRegsAddr -> Reg -> Doc
pprSizeAddrReg name size op dst
= hcat [
char '\t',
pprReg size dst
]
-pprSizeRegAddr :: FAST_STRING -> Size -> Reg -> MachRegsAddr -> Doc
+pprSizeRegAddr :: LitString -> Size -> Reg -> MachRegsAddr -> Doc
pprSizeRegAddr name size src op
= hcat [
char '\t',
pprAddr op
]
-pprOpOp :: FAST_STRING -> Size -> Operand -> Operand -> Doc
+pprOpOp :: LitString -> Size -> Operand -> Operand -> Doc
pprOpOp name size op1 op2
= hcat [
char '\t',
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,
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]
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',
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',
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',
pprReg reg2
]
-pprRIReg :: FAST_STRING -> Bool -> RI -> Reg -> Doc
+pprRIReg :: LitString -> Bool -> RI -> Reg -> Doc
pprRIReg name b ri reg1
= hcat [
char '\t',
import Constants ( wORD_SIZE )
import Outputable
import FastTypes
+import FastString
\end{code}
Two types, StixStmt and StixValue, define Stix.
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
-- 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
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
| 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]
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 ']'
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
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.
ncg_target_is_32bit | wORD_SIZE == 4 = True
| wORD_SIZE == 8 = False
-\end{code}
\ No newline at end of file
+\end{code}
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
macroCode REGISTER_FOREIGN_EXPORT [arg]
= returnUs (
\xs -> StVoidable (
- StCall (Left SLIT("getStablePtr")) CCallConv VoidRep
+ StCall (Left FSLIT("getStablePtr")) CCallConv VoidRep
[amodeToStix arg]
)
: xs
| 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))
import TysWiredIn (mkTupleTy)
import BasicTypes (Boxity(..))
import Outputable (showSDoc, Outputable(..))
-
+import FastString
-- friends
import NDPCoreUtils (tupleTyArgs, funTyArgs, parrElemTy, isDefault,
#include "HsVersions.h"
-{-# INLINE slit #-}
-slit x = FastString.mkFastCharString# x
--- FIXME: SLIT() doesn't work for some strange reason
-- toplevel transformation
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
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
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:
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])
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
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.
"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"
| 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
\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 ),
]
haskellKeywordsFM = listToUFM $
- map (\ (x,y) -> (_PK_ x,y))
+ map (\ (x,y) -> (mkFastString x,y))
[( "_", ITunderscore ),
( "as", ITas ),
( "case", ITcase ),
-- 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 ),
haskellKeySymsFM = listToUFM $
- map (\ (x,y) -> (_PK_ x,y))
+ map (\ (x,y) -> (mkFastString x,y))
[ ("..", ITdotdot)
,("::", ITdcolon)
,("=", ITequal)
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 ->
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 (,,,)
','# -> 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
| 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 =
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 ()
, 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
import OccName ( dataName, varName, tcClsName, isDataOcc,
occNameSpace, setOccNameSpace, occNameUserString )
import CStrings ( CLabelString )
-import FastString ( nullFastString )
+import FastString
import Outputable
-----------------------------------------------------------------------------
--
mkImport :: CallConv
-> Safety
- -> (FAST_STRING, RdrName, RdrNameHsType)
+ -> (FastString, RdrName, RdrNameHsType)
-> SrcLoc
-> P RdrNameHsDecl
mkImport (CCall cconv) safety (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
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
-- 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 $
-- (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
{- -*-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.
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 ------------
{ 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
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
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)
{% 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
-- 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)
{% 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
| '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
| fexp { $1 }
-scc_annot :: { FAST_STRING }
+scc_annot :: { FastString }
: '_scc_' STRING { $2 }
| '{-# SCC' STRING '#-}' { $2 }
-ccallid :: { FAST_STRING }
+ccallid :: { FastString }
: VARID { $1 }
| CONID { $1 }
import BasicTypes
import Type
import SrcLoc
+import FastString
#include "../HsVersions.h"
: '(' 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 }
: 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) }
{
{-! derive: Binary !-}
instance Outputable DNCallSpec where
- ppr (DNCallSpec s) = char '"' <> ptext s <> char '"'
+ ppr (DNCallSpec s) = char '"' <> ftext s <> char '"'
\end{code}
import SrcLoc ( builtinSrcLoc, noSrcLoc )
import Util ( nOfThem )
import Panic ( panic )
+import FastString
\end{code}
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
import Word ( Word64 )
#endif
import Outputable
+import FastString
import CmdLineOpts ( opt_SimplExcessPrecision )
\end{code}
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]
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)
]
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)
mkTupleDataConUnique, mkPArrDataConUnique )
import PrelNames
import Array
+import FastString
alpha_tyvar = [alphaTyVar]
alpha_ty = [alphaTy]
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
import Outputable
import CStrings ( pprStringInCStyle )
import FastTypes
+import FastString
import Util ( thenCmp )
\end{code}
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
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,
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
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
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}
\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
import List ( intersectBy )
import ListSetOps ( removeDups )
import Outputable
+import FastString
\end{code}
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}
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
= 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")]
import UniqSupply
import Util ( sortLt, isSingleton, count )
import Outputable
+import FastString
\end{code}
%************************************************************************
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)
-> 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.
import Array ( array, (//) )
import FastTypes
import GlaExts ( indexArray# )
+import FastString
#if __GLASGOW_HASKELL__ < 503
import PrelArr ( Array(..) )
| PostInlineUnconditionally Id
| UnfoldingDone Id
- | RuleFired FAST_STRING -- Rule name
+ | RuleFired FastString -- Rule name
| LetFloatFromLet
| EtaExpansion Id -- LHS binder
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
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])
) `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.
import BasicTypes ( Activation, CompilerPhase, isActive )
import Outputable
+import FastString
import Maybe ( isJust, isNothing, fromMaybe )
import Util ( sortLt )
import Bag
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
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
import List ( nubBy, partition )
import UniqSupply
import Outputable
+import FastString
\end{code}
-----------------------------------------------------
-- 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
import Util ( zipEqual, zipWithEqual, cmpList, lengthIs,
equalLength, lengthAtLeast, notNull )
import Outputable
-
+import FastString
infixr 9 `thenSM`
\end{code}
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
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 )
import Util ( count, lengthIs, equalLength )
import Maybes ( seqMaybe )
import Maybe ( isJust )
+import FastString
\end{code}
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 ])
import ListSetOps ( removeDups, assoc )
import Outputable
import Maybe ( isJust )
-import FastString ( FastString )
\end{code}
%************************************************************************
&& (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
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)
\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)])
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}
%************************************************************************
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
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)
import Char ( ord )
import Constants
import List ( partition, intersperse )
+import FastString
\end{code}
%************************************************************************
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)
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}
-- 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
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
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}
)
import Maybe ( catMaybes )
import Outputable
+import FastString
\end{code}
Typechecking instance declarations is done in two passes. The first
-- 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)
import BasicTypes ( isBoxed )
import Bag
import Outputable
+import FastString
\end{code}
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)
returnNF_Tc (mkLocalId var ty)
ruleCtxt name = ptext SLIT("When checking the transformation rule") <+>
- doubleQuotes (ptext name)
+ doubleQuotes (ftext name)
\end{code}
import Unique ( Unique, builtinUniques, mkBuiltinUnique )
import Util ( takeList, dropList )
import Outputable
+import FastString
#include "HsVersions.h"
\end{code}
-------------------
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))
(
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
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
#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
#define hASH_TBL_SIZE 993
#if __GLASGOW_HASKELL__ < 503
-hPutBuf = hPutBufFull
hPutBufBA = hPutBufBAFull
#endif
\end{code}
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
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 }
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]
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")
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)
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
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 (
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
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
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}
#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)
#-}
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,
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 )
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
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
%************************************************************************
\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))
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 ()),
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,
hang, punctuate,
-- renderStyle, -- Haskell 1.3 only
- render, fullRender, printDoc
+ render, fullRender, printDoc, showDocWith
) where
#include "HsVersions.h"
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 <>
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}
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
= 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}
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}
x <- memcmp_ba a# barr# (I# len#)
return (x == 0)
+-- unused???
eqCharStrPrefix :: Addr# -> Addr# -> Int# -> Bool
eqCharStrPrefix a1# a2# len# =
unsafePerformIO $ do
projects / ghc-hetmet.git / commitdiff