Commit 4fa32293 authored by Sylvain Henry's avatar Sylvain Henry Committed by Ben Gamari

Use ByteString to represent Cmm string literals (#16198)

Also used ByteString in some other relevant places
parent deab6d64
......@@ -84,9 +84,11 @@ import Binary
import UniqSet
import Unique( mkAlphaTyVarUnique )
import Data.ByteString (ByteString)
import qualified Data.ByteString.Builder as BSB
import qualified Data.ByteString.Lazy as LBS
import qualified Data.Data as Data
import Data.Char
import Data.Word
import Data.List( find )
{-
......@@ -1356,11 +1358,15 @@ dataConRepArgTys (MkData { dcRep = rep
-- | The string @package:module.name@ identifying a constructor, which is attached
-- to its info table and used by the GHCi debugger and the heap profiler
dataConIdentity :: DataCon -> [Word8]
dataConIdentity :: DataCon -> ByteString
-- We want this string to be UTF-8, so we get the bytes directly from the FastStrings.
dataConIdentity dc = bytesFS (unitIdFS (moduleUnitId mod)) ++
fromIntegral (ord ':') : bytesFS (moduleNameFS (moduleName mod)) ++
fromIntegral (ord '.') : bytesFS (occNameFS (nameOccName name))
dataConIdentity dc = LBS.toStrict $ BSB.toLazyByteString $ mconcat
[ BSB.byteString $ bytesFS (unitIdFS (moduleUnitId mod))
, BSB.int8 $ fromIntegral (ord ':')
, BSB.byteString $ bytesFS (moduleNameFS (moduleName mod))
, BSB.int8 $ fromIntegral (ord '.')
, BSB.byteString $ bytesFS (occNameFS (nameOccName name))
]
where name = dataConName dc
mod = ASSERT( isExternalName name ) nameModule name
......
......@@ -418,7 +418,7 @@ mkLitChar = LitChar
-- e.g. some of the \"error\" functions in GHC.Err such as @GHC.Err.runtimeError@
mkLitString :: String -> Literal
-- stored UTF-8 encoded
mkLitString s = LitString (fastStringToByteString $ mkFastString s)
mkLitString s = LitString (bytesFS $ mkFastString s)
mkLitInteger :: Integer -> Type -> Literal
mkLitInteger x ty = LitNumber LitNumInteger x ty
......
......@@ -344,7 +344,7 @@ instance Binary ModuleName where
instance BinaryStringRep ModuleName where
fromStringRep = mkModuleNameFS . mkFastStringByteString
toStringRep = fastStringToByteString . moduleNameFS
toStringRep = bytesFS . moduleNameFS
instance Data ModuleName where
-- don't traverse?
......@@ -519,7 +519,7 @@ newtype ComponentId = ComponentId FastString deriving (Eq, Ord)
instance BinaryStringRep ComponentId where
fromStringRep = ComponentId . mkFastStringByteString
toStringRep (ComponentId s) = fastStringToByteString s
toStringRep (ComponentId s) = bytesFS s
instance Uniquable ComponentId where
getUnique (ComponentId n) = getUnique n
......@@ -849,7 +849,7 @@ rawHashUnitId sorted_holes =
. BS.concat $ do
(m, b) <- sorted_holes
[ toStringRep m, BS.Char8.singleton ' ',
fastStringToByteString (unitIdFS (moduleUnitId b)), BS.Char8.singleton ':',
bytesFS (unitIdFS (moduleUnitId b)), BS.Char8.singleton ':',
toStringRep (moduleName b), BS.Char8.singleton '\n']
fingerprintUnitId :: BS.ByteString -> Fingerprint -> BS.ByteString
......
......@@ -39,8 +39,7 @@ import Hoopl.Collections
import Hoopl.Graph
import Hoopl.Label
import Outputable
import Data.Word ( Word8 )
import Data.ByteString (ByteString)
-----------------------------------------------------------------------------
-- Cmm, GenCmm
......@@ -159,7 +158,7 @@ data CmmInfoTable
data ProfilingInfo
= NoProfilingInfo
| ProfilingInfo [Word8] [Word8] -- closure_type, closure_desc
| ProfilingInfo ByteString ByteString -- closure_type, closure_desc
-----------------------------------------------------------------------------
-- Static Data
......@@ -195,7 +194,7 @@ data CmmStatic
-- a literal value, size given by cmmLitRep of the literal.
| CmmUninitialised Int
-- uninitialised data, N bytes long
| CmmString [Word8]
| CmmString ByteString
-- string of 8-bit values only, not zero terminated.
data CmmStatics
......
......@@ -54,8 +54,8 @@ import MonadUtils
import Util
import Outputable
import Data.ByteString (ByteString)
import Data.Bits
import Data.Word
-- When we split at proc points, we need an empty info table.
mkEmptyContInfoTable :: CLabel -> CmmInfoTable
......@@ -416,7 +416,7 @@ mkProfLits _ (ProfilingInfo td cd)
; (cd_lit, cd_decl) <- newStringLit cd
; return ((td_lit,cd_lit), [td_decl,cd_decl]) }
newStringLit :: [Word8] -> UniqSM (CmmLit, GenCmmDecl CmmStatics info stmt)
newStringLit :: ByteString -> UniqSM (CmmLit, GenCmmDecl CmmStatics info stmt)
newStringLit bytes
= do { uniq <- getUniqueM
; return (mkByteStringCLit (mkStringLitLabel uniq) bytes) }
......
......@@ -257,6 +257,7 @@ import Data.Char ( ord )
import System.Exit
import Data.Maybe
import qualified Data.Map as M
import qualified Data.ByteString.Char8 as BS8
#include "HsVersions.h"
}
......@@ -497,7 +498,7 @@ info :: { CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg]) }
do dflags <- getDynFlags
let prof = profilingInfo dflags $13 $15
ty = Constr (fromIntegral $9) -- Tag
(stringToWord8s $13)
(BS8.pack $13)
rep = mkRTSRep (fromIntegral $11) $
mkHeapRep dflags False (fromIntegral $5)
(fromIntegral $7) ty
......@@ -868,7 +869,7 @@ section "bss" = UninitialisedData
section s = OtherSection s
mkString :: String -> CmmStatic
mkString s = CmmString (map (fromIntegral.ord) s)
mkString s = CmmString (BS8.pack s)
-- |
-- Given an info table, decide what the entry convention for the proc
......@@ -1165,8 +1166,7 @@ reserveStackFrame psize preg body = do
profilingInfo dflags desc_str ty_str
= if not (gopt Opt_SccProfilingOn dflags)
then NoProfilingInfo
else ProfilingInfo (stringToWord8s desc_str)
(stringToWord8s ty_str)
else ProfilingInfo (BS8.pack desc_str) (BS8.pack ty_str)
staticClosure :: UnitId -> FastString -> FastString -> [CmmLit] -> CmmParse ()
staticClosure pkg cl_label info payload
......
......@@ -78,7 +78,8 @@ import Outputable
import DynFlags
import CodeGen.Platform
import Data.Word
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import Data.Bits
import Hoopl.Graph
import Hoopl.Label
......@@ -181,7 +182,7 @@ mkWordCLit :: DynFlags -> Integer -> CmmLit
mkWordCLit dflags wd = CmmInt wd (wordWidth dflags)
mkByteStringCLit
:: CLabel -> [Word8] -> (CmmLit, GenCmmDecl CmmStatics info stmt)
:: CLabel -> ByteString -> (CmmLit, GenCmmDecl CmmStatics info stmt)
-- We have to make a top-level decl for the string,
-- and return a literal pointing to it
mkByteStringCLit lbl bytes
......@@ -189,7 +190,7 @@ mkByteStringCLit lbl bytes
where
-- This can not happen for String literals (as there \NUL is replaced by
-- C0 80). However, it can happen with Addr# literals.
sec = if 0 `elem` bytes then ReadOnlyData else CString
sec = if 0 `BS.elem` bytes then ReadOnlyData else CString
mkDataLits :: Section -> CLabel -> [CmmLit] -> GenCmmDecl CmmStatics info stmt
-- Build a data-segment data block
......
......@@ -51,6 +51,8 @@ import Unique
import Util
-- The rest
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import Control.Monad.ST
import Data.Bits
import Data.Char
......@@ -1224,8 +1226,8 @@ machRep_S_CType w
-- ---------------------------------------------------------------------
-- print strings as valid C strings
pprStringInCStyle :: [Word8] -> SDoc
pprStringInCStyle s = doubleQuotes (text (concatMap charToC s))
pprStringInCStyle :: ByteString -> SDoc
pprStringInCStyle s = doubleQuotes (text (concatMap charToC (BS.unpack s)))
-- ---------------------------------------------------------------------------
-- Initialising static objects with floating-point numbers. We can't
......
......@@ -50,8 +50,7 @@ import FastString
import Data.List
import System.IO
-- Temp Jan08
import SMRep
import qualified Data.ByteString as BS
pprCmms :: (Outputable info, Outputable g)
......@@ -121,8 +120,8 @@ pprInfoTable (CmmInfoTable { cit_lbl = lbl, cit_rep = rep
, case prof_info of
NoProfilingInfo -> empty
ProfilingInfo ct cd ->
vcat [ text "type: " <> pprWord8String ct
, text "desc: " <> pprWord8String cd ]
vcat [ text "type: " <> text (show (BS.unpack ct))
, text "desc: " <> text (show (BS.unpack cd)) ]
, text "srt: " <> ppr srt ]
instance Outputable ForeignHint where
......
......@@ -41,10 +41,7 @@ module SMRep (
aRG_GEN, aRG_GEN_BIG,
-- ** Arrays
card, cardRoundUp, cardTableSizeB, cardTableSizeW,
-- * Operations over [Word8] strings that don't belong here
pprWord8String, stringToWord8s
card, cardRoundUp, cardTableSizeB, cardTableSizeW
) where
import GhcPrelude
......@@ -55,9 +52,9 @@ import Outputable
import Platform
import FastString
import Data.Char( ord )
import Data.Word
import Data.Bits
import Data.ByteString (ByteString)
{-
************************************************************************
......@@ -195,7 +192,7 @@ data ClosureTypeInfo
| BlackHole
| IndStatic
type ConstrDescription = [Word8] -- result of dataConIdentity
type ConstrDescription = ByteString -- result of dataConIdentity
type FunArity = Int
type SelectorOffset = Int
......@@ -564,11 +561,3 @@ pprTypeInfo (ThunkSelector offset)
pprTypeInfo Thunk = text "Thunk"
pprTypeInfo BlackHole = text "BlackHole"
pprTypeInfo IndStatic = text "IndStatic"
-- XXX Does not belong here!!
stringToWord8s :: String -> [Word8]
stringToWord8s s = map (fromIntegral . ord) s
pprWord8String :: [Word8] -> SDoc
-- Debug printing. Not very clever right now.
pprWord8String ws = text (show ws)
......@@ -50,7 +50,6 @@ import VarSet ( isEmptyDVarSet )
import OrdList
import MkGraph
import qualified Data.ByteString as BS
import Data.IORef
import Control.Monad (when,void)
import Util
......@@ -141,7 +140,7 @@ cgTopBinding dflags (StgTopLifted (StgRec pairs))
cgTopBinding dflags (StgTopStringLit id str)
= do { id' <- maybeExternaliseId dflags id
; let label = mkBytesLabel (idName id')
; let (lit, decl) = mkByteStringCLit label (BS.unpack str)
; let (lit, decl) = mkByteStringCLit label str
; emitDecl decl
; addBindC (litIdInfo dflags id' mkLFStringLit lit)
}
......
......@@ -91,6 +91,7 @@ import DynFlags
import Util
import Data.Coerce (coerce)
import qualified Data.ByteString.Char8 as BS8
-----------------------------------------------------------------------------
-- Data types and synonyms
......@@ -916,10 +917,9 @@ enterIdLabel dflags id c
mkProfilingInfo :: DynFlags -> Id -> String -> ProfilingInfo
mkProfilingInfo dflags id val_descr
| not (gopt Opt_SccProfilingOn dflags) = NoProfilingInfo
| otherwise = ProfilingInfo ty_descr_w8 val_descr_w8
| otherwise = ProfilingInfo ty_descr_w8 (BS8.pack val_descr)
where
ty_descr_w8 = stringToWord8s (getTyDescription (idType id))
val_descr_w8 = stringToWord8s val_descr
ty_descr_w8 = BS8.pack (getTyDescription (idType id))
getTyDescription :: Type -> String
getTyDescription ty
......@@ -966,8 +966,8 @@ mkDataConInfoTable dflags data_con is_static ptr_wds nonptr_wds
prof | not (gopt Opt_SccProfilingOn dflags) = NoProfilingInfo
| otherwise = ProfilingInfo ty_descr val_descr
ty_descr = stringToWord8s $ occNameString $ getOccName $ dataConTyCon data_con
val_descr = stringToWord8s $ occNameString $ getOccName data_con
ty_descr = BS8.pack $ occNameString $ getOccName $ dataConTyCon data_con
val_descr = BS8.pack $ occNameString $ getOccName data_con
-- We need a black-hole closure info to pass to @allocDynClosure@ when we
-- want to allocate the black hole on entry to a CAF.
......
......@@ -71,12 +71,12 @@ import FastString
import Outputable
import RepType
import qualified Data.ByteString as BS
import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as BS8
import qualified Data.Map as M
import Data.Char
import Data.List
import Data.Ord
import Data.Word
-------------------------------------------------------------------------
......@@ -86,7 +86,7 @@ import Data.Word
-------------------------------------------------------------------------
cgLit :: Literal -> FCode CmmLit
cgLit (LitString s) = newByteStringCLit (BS.unpack s)
cgLit (LitString s) = newByteStringCLit s
-- not unpackFS; we want the UTF-8 byte stream.
cgLit other_lit = do dflags <- getDynFlags
return (mkSimpleLit dflags other_lit)
......@@ -320,9 +320,9 @@ emitRODataLits lbl lits = emitDecl (mkRODataLits lbl lits)
newStringCLit :: String -> FCode CmmLit
-- Make a global definition for the string,
-- and return its label
newStringCLit str = newByteStringCLit (map (fromIntegral . ord) str)
newStringCLit str = newByteStringCLit (BS8.pack str)
newByteStringCLit :: [Word8] -> FCode CmmLit
newByteStringCLit :: ByteString -> FCode CmmLit
newByteStringCLit bytes
= do { uniq <- newUnique
; let (lit, decl) = mkByteStringCLit (mkStringLitLabel uniq) bytes
......
......@@ -852,7 +852,7 @@ dealWithStringLiteral fun str co
= let strFS = mkFastStringByteString str
char = mkConApp charDataCon [mkCharLit (headFS strFS)]
charTail = fastStringToByteString (tailFS strFS)
charTail = bytesFS (tailFS strFS)
-- In singleton strings, just add [] instead of unpackCstring# ""#.
rest = if BS.null charTail
......
......@@ -302,7 +302,7 @@ mkStringExprFSWith lookupM str
where
chars = unpackFS str
safeChar c = ord c >= 1 && ord c <= 0x7F
lit = Lit (LitString (fastStringToByteString str))
lit = Lit (LitString (bytesFS str))
{-
************************************************************************
......
......@@ -49,6 +49,7 @@ import System.Directory
import Trace.Hpc.Mix
import Trace.Hpc.Util
import qualified Data.ByteString as BS
import Data.Map (Map)
import qualified Data.Map as Map
......@@ -1352,9 +1353,9 @@ hpcInitCode this_mod (HpcInfo tickCount hashNo)
where
tickboxes = ppr (mkHpcTicksLabel $ this_mod)
module_name = hcat (map (text.charToC) $
module_name = hcat (map (text.charToC) $ BS.unpack $
bytesFS (moduleNameFS (Module.moduleName this_mod)))
package_name = hcat (map (text.charToC) $
package_name = hcat (map (text.charToC) $ BS.unpack $
bytesFS (unitIdFS (moduleUnitId this_mod)))
full_name_str
| moduleUnitId this_mod == mainUnitId
......
......@@ -456,7 +456,7 @@ hsLitKey dflags (HsWord64Prim _ w) = mkLitWord64Wrap dflags w
hsLitKey _ (HsCharPrim _ c) = mkLitChar c
hsLitKey _ (HsFloatPrim _ f) = mkLitFloat (fl_value f)
hsLitKey _ (HsDoublePrim _ d) = mkLitDouble (fl_value d)
hsLitKey _ (HsString _ s) = LitString (fastStringToByteString s)
hsLitKey _ (HsString _ s) = LitString (bytesFS s)
hsLitKey _ l = pprPanic "hsLitKey" (ppr l)
{-
......
......@@ -370,8 +370,7 @@ mkHsString :: String -> HsLit (GhcPass p)
mkHsString s = HsString NoSourceText (mkFastString s)
mkHsStringPrimLit :: FastString -> HsLit (GhcPass p)
mkHsStringPrimLit fs
= HsStringPrim NoSourceText (fastStringToByteString fs)
mkHsStringPrimLit fs = HsStringPrim NoSourceText (bytesFS fs)
-------------
userHsLTyVarBndrs :: SrcSpan -> [Located (IdP (GhcPass p))]
......
......@@ -22,6 +22,7 @@ import Platform
import FastString
import Outputable
import qualified Data.ByteString as BS
-- ----------------------------------------------------------------------------
-- * Constants
......@@ -102,7 +103,8 @@ llvmSection (Section t suffix) = do
genData :: CmmStatic -> LlvmM LlvmStatic
genData (CmmString str) = do
let v = map (\x -> LMStaticLit $ LMIntLit (fromIntegral x) i8) str
let v = map (\x -> LMStaticLit $ LMIntLit (fromIntegral x) i8)
(BS.unpack str)
ve = v ++ [LMStaticLit $ LMIntLit 0 i8]
return $ LMStaticArray ve (LMArray (length ve) i8)
......
......@@ -62,11 +62,11 @@ newtype PackageName = PackageName FastString deriving (Eq, Ord)
instance BinaryStringRep SourcePackageId where
fromStringRep = SourcePackageId . mkFastStringByteString
toStringRep (SourcePackageId s) = fastStringToByteString s
toStringRep (SourcePackageId s) = bytesFS s
instance BinaryStringRep PackageName where
fromStringRep = PackageName . mkFastStringByteString
toStringRep (PackageName s) = fastStringToByteString s
toStringRep (PackageName s) = bytesFS s
instance Uniquable SourcePackageId where
getUnique (SourcePackageId n) = getUnique n
......
......@@ -38,6 +38,7 @@ import Util
import Dwarf.Constants
import qualified Data.ByteString as BS
import qualified Control.Monad.Trans.State.Strict as S
import Control.Monad (zipWithM, join)
import Data.Bits
......@@ -583,7 +584,7 @@ pprString str
= pprString' $ hcat $ map escapeChar $
if str `lengthIs` utf8EncodedLength str
then str
else map (chr . fromIntegral) $ bytesFS $ mkFastString str
else map (chr . fromIntegral) $ BS.unpack $ bytesFS $ mkFastString str
-- | Escape a single non-unicode character
escapeChar :: Char -> SDoc
......
......@@ -34,6 +34,8 @@ import Control.Monad.ST
import Data.Word
import Data.Char
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
......@@ -90,13 +92,13 @@ doubleToBytes d
-- Print as a string and escape non-printable characters.
-- This is similar to charToC in Utils.
pprASCII :: [Word8] -> SDoc
pprASCII :: ByteString -> SDoc
pprASCII str
-- Transform this given literal bytestring to escaped string and construct
-- the literal SDoc directly.
-- See Trac #14741
-- and Note [Pretty print ASCII when AsmCodeGen]
= text $ foldr (\w s -> (do1 . fromIntegral) w ++ s) "" str
= text $ foldr (\w s -> (do1 . fromIntegral) w ++ s) "" (BS.unpack str)
where
do1 :: Int -> String
do1 w | '\t' <- chr w = "\\t"
......
......@@ -50,6 +50,7 @@ import Outputable
import Platform
import FastString
import Data.Word
import qualified Data.ByteString as BS
-- -----------------------------------------------------------------------------
-- Printing this stuff out
......@@ -110,7 +111,7 @@ pprDatas (Statics lbl dats) = vcat (pprLabel lbl : map pprData dats)
pprData :: CmmStatic -> SDoc
pprData (CmmString str)
= vcat (map do1 str) $$ do1 0
= vcat (map do1 (BS.unpack str)) $$ do1 0
where
do1 :: Word8 -> SDoc
do1 w = text "\t.byte\t" <> int (fromIntegral w)
......
......@@ -738,7 +738,7 @@ isBuiltInOcc_maybe occ =
in Just $ dataConName $ sumDataCon alt arity
_ -> Nothing
where
name = fastStringToByteString $ occNameFS occ
name = bytesFS $ occNameFS occ
choose_ns :: Name -> Name -> Name
choose_ns tc dc
......
......@@ -29,7 +29,7 @@ evDelayedError ty msg
Var errorId `mkTyApps` [getRuntimeRep ty, ty] `mkApps` [litMsg]
where
errorId = tYPE_ERROR_ID
litMsg = Lit (LitString (fastStringToByteString msg))
litMsg = Lit (LitString (bytesFS msg))
-- Dictionary for CallStack implicit parameters
evCallStack :: (MonadThings m, HasModule m, HasDynFlags m) =>
......
......@@ -938,7 +938,7 @@ mkOneRecordSelector all_cons idDetails fl
inst_tys = substTyVars eq_subst univ_tvs
unit_rhs = mkLHsTupleExpr []
msg_lit = HsStringPrim NoSourceText (fastStringToByteString lbl)
msg_lit = HsStringPrim NoSourceText (bytesFS lbl)
{-
Note [Polymorphic selectors]
......
......@@ -916,7 +916,7 @@ type SymbolTable = Array Int Name
---------------------------------------------------------
putFS :: BinHandle -> FastString -> IO ()
putFS bh fs = putBS bh $ fastStringToByteString fs
putFS bh fs = putBS bh $ bytesFS fs
getFS :: BinHandle -> IO FastString
getFS bh = do
......
......@@ -77,7 +77,7 @@ bPutStr (BufHandle buf r hdl) !str = do
loop cs (i+1)
bPutFS :: BufHandle -> FastString -> IO ()
bPutFS b fs = bPutBS b $ fastStringToByteString fs
bPutFS b fs = bPutBS b $ bytesFS fs
bPutFZS :: BufHandle -> FastZString -> IO ()
bPutFZS b fs = bPutBS b $ fastZStringToByteString fs
......
......@@ -32,7 +32,8 @@
module FastString
(
-- * ByteString
fastStringToByteString,
bytesFS, -- :: FastString -> ByteString
fastStringToByteString, -- = bytesFS (kept for haddock)
mkFastStringByteString,
fastZStringToByteString,
unsafeMkByteString,
......@@ -56,7 +57,6 @@ module FastString
-- ** Deconstruction
unpackFS, -- :: FastString -> String
bytesFS, -- :: FastString -> [Word8]
-- ** Encoding
zEncodeFS,
......@@ -132,8 +132,13 @@ import GHC.Conc.Sync (sharedCAF)
import GHC.Base ( unpackCString#, unpackNBytes# )
-- | Gives the UTF-8 encoded bytes corresponding to a 'FastString'
bytesFS :: FastString -> ByteString
bytesFS f = fs_bs f
{-# DEPRECATED fastStringToByteString "Use `bytesFS` instead" #-}
fastStringToByteString :: FastString -> ByteString
fastStringToByteString f = fs_bs f
fastStringToByteString = bytesFS
fastZStringToByteString :: FastZString -> ByteString
fastZStringToByteString (FastZString bs) = bs
......@@ -221,7 +226,7 @@ instance Data FastString where
cmpFS :: FastString -> FastString -> Ordering
cmpFS f1@(FastString u1 _ _ _) f2@(FastString u2 _ _ _) =
if u1 == u2 then EQ else
compare (fastStringToByteString f1) (fastStringToByteString f2)
compare (bytesFS f1) (bytesFS f2)
foreign import ccall unsafe "memcmp"
memcmp :: Ptr a -> Ptr b -> Int -> IO Int
......@@ -475,13 +480,7 @@ mkFastString str =
-- | Creates a 'FastString' from a UTF-8 encoded @[Word8]@
mkFastStringByteList :: [Word8] -> FastString
mkFastStringByteList str =
inlinePerformIO $ do
let l = Prelude.length str
buf <- mallocForeignPtrBytes l
withForeignPtr buf $ \ptr -> do
pokeArray (castPtr ptr) str
mkFastStringForeignPtr ptr buf l
mkFastStringByteList str = mkFastStringByteString (BS.pack str)
-- | Creates a Z-encoded 'FastString' from a 'String'
mkZFastString :: String -> FastZString
......@@ -553,10 +552,6 @@ nullFS f = BS.null (fs_bs f)
unpackFS :: FastString -> String
unpackFS (FastString _ _ bs _) = utf8DecodeByteString bs
-- | Gives the UTF-8 encoded bytes corresponding to a 'FastString'
bytesFS :: FastString -> [Word8]
bytesFS fs = BS.unpack $ fastStringToByteString fs
-- | Returns a Z-encoded version of a 'FastString'. This might be the
-- original, if it was already Z-encoded. The first time this
-- function is applied to a particular 'FastString', the results are
......@@ -576,8 +571,7 @@ zEncodeFS fs@(FastString _ _ _ ref) =
appendFS :: FastString -> FastString -> FastString
appendFS fs1 fs2 = mkFastStringByteString
$ BS.append (fastStringToByteString fs1)
(fastStringToByteString fs2)
$ BS.append (bytesFS fs1) (bytesFS fs2)
concatFS :: [FastString] -> FastString
concatFS = mkFastStringByteString . BS.concat . map fs_bs
......@@ -627,7 +621,7 @@ getFastStringTable =
-- |Outputs a 'FastString' with /no decoding at all/, that is, you
-- get the actual bytes in the 'FastString' written to the 'Handle'.
hPutFS :: Handle -> FastString -> IO ()
hPutFS handle fs = BS.hPut handle $ fastStringToByteString fs
hPutFS handle fs = BS.hPut handle $ bytesFS fs
-- ToDo: we'll probably want an hPutFSLocal, or something, to output
-- in the current locale's encoding (for error messages and suchlike).
......
......@@ -22,6 +22,8 @@ import Foreign.C
import GHC.Ptr
import GHC.Exts
import GHC.Exts.Heap
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
#endif
ghciTablesNextToCode :: Bool
......@@ -40,7 +42,7 @@ mkConInfoTable
-> Int -- non-ptr words
-> Int -- constr tag
-> Int -- pointer tag
-> [Word8] -- con desc
-> ByteString -- con desc
-> IO (Ptr StgInfoTable)
-- resulting info table is allocated with allocateExec(), and
-- should be freed with freeExec().
......@@ -344,10 +346,10 @@ sizeOfEntryCode
Right xs -> sizeOf (head xs) * length xs
-- Note: Must return proper pointer for use in a closure
newExecConItbl :: StgInfoTable -> [Word8] -> IO (FunPtr ())
newExecConItbl :: StgInfoTable -> ByteString -> IO (FunPtr ())
newExecConItbl obj con_desc
= alloca $ \pcode -> do
let lcon_desc = length con_desc + 1{- null terminator -}
let lcon_desc = BS.length con_desc + 1{- null terminator -}
-- SCARY
-- This size represents the number of bytes in an StgConInfoTable.
sz = fromIntegral (conInfoTableSizeB + sizeOfEntryCode)
......@@ -360,7 +362,10 @@ newExecConItbl obj con_desc
let cinfo = StgConInfoTable { conDesc = ex_ptr `plusPtr` fromIntegral sz
, infoTable = obj }
pokeConItbl wr_ptr ex_ptr cinfo
pokeArray0 0 (castPtr wr_ptr `plusPtr` fromIntegral sz) con_desc
BS.useAsCStringLen con_desc $ \(src, len) ->
copyBytes (castPtr wr_ptr `plusPtr` fromIntegral sz) src len
let null_off = fromIntegral sz + fromIntegral (BS.length con_desc)
poke (castPtr wr_ptr `plusPtr` null_off) (0 :: Word8)
_flushExec sz ex_ptr -- Cache flush (if needed)
#if defined(TABLES_NEXT_TO_CODE)
return (castPtrToFunPtr (ex_ptr `plusPtr` conInfoTableSizeB))
......
......@@ -107,7 +107,7 @@ data Message a where
-> Int -- non-ptr words
-> Int -- constr tag
-> Int -- pointer tag
-> [Word8] -- constructor desccription
-> ByteString -- constructor desccription
-> Message (RemotePtr StgInfoTable)
-- | Evaluate a statement
......
......@@ -71,7 +71,7 @@ changeExpr anns mb_replacement e = let go = changeExpr anns mb_replacement in ca
Nothing -> return e
Just replacement -> do
putMsgS "Performing Replacement"
return $ Lit (LitString (fastStringToByteString (mkFastString replacement)))
return $ Lit (LitString (bytesFS (mkFastString replacement)))
App e1 e2 -> liftM2 App (go e1) (go e2)
Lam b e -> liftM (Lam b) (go e)
Let bind e -> liftM2 Let (changeBind anns mb_replacement bind) (go e)
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment