Commit 3248fd92 authored by Ian Lynagh's avatar Ian Lynagh

HsStringPrim now contains FastBytes, not FastString

parent 7ae1bec5
...@@ -445,7 +445,7 @@ get_lit :: Pat id -> Maybe HsLit ...@@ -445,7 +445,7 @@ get_lit :: Pat id -> Maybe HsLit
get_lit (LitPat lit) = Just lit get_lit (LitPat lit) = Just lit
get_lit (NPat (OverLit { ol_val = HsIntegral i}) mb _) = Just (HsIntPrim (mb_neg negate mb i)) get_lit (NPat (OverLit { ol_val = HsIntegral i}) mb _) = Just (HsIntPrim (mb_neg negate mb i))
get_lit (NPat (OverLit { ol_val = HsFractional f }) mb _) = Just (HsFloatPrim (mb_neg negateFractionalLit mb f)) get_lit (NPat (OverLit { ol_val = HsFractional f }) mb _) = Just (HsFloatPrim (mb_neg negateFractionalLit mb f))
get_lit (NPat (OverLit { ol_val = HsIsString s }) _ _) = Just (HsStringPrim s) get_lit (NPat (OverLit { ol_val = HsIsString s }) _ _) = Just (HsStringPrim (fastStringToFastBytes s))
get_lit _ = Nothing get_lit _ = Nothing
mb_neg :: (a -> a) -> Maybe b -> a -> a mb_neg :: (a -> a) -> Maybe b -> a -> a
......
...@@ -69,7 +69,7 @@ See also below where we look for @DictApps@ for \tr{plusInt}, etc. ...@@ -69,7 +69,7 @@ See also below where we look for @DictApps@ for \tr{plusInt}, etc.
\begin{code} \begin{code}
dsLit :: HsLit -> DsM CoreExpr dsLit :: HsLit -> DsM CoreExpr
dsLit (HsStringPrim s) = return (Lit (MachStr (fastStringToFastBytes s))) dsLit (HsStringPrim s) = return (Lit (MachStr s))
dsLit (HsCharPrim c) = return (Lit (MachChar c)) dsLit (HsCharPrim c) = return (Lit (MachChar c))
dsLit (HsIntPrim i) = return (Lit (MachInt i)) dsLit (HsIntPrim i) = return (Lit (MachInt i))
dsLit (HsWordPrim w) = return (Lit (MachWord w)) dsLit (HsWordPrim w) = return (Lit (MachWord w))
...@@ -124,7 +124,7 @@ hsLitKey (HsWordPrim w) = mkMachWord w ...@@ -124,7 +124,7 @@ hsLitKey (HsWordPrim w) = mkMachWord w
hsLitKey (HsInt64Prim i) = mkMachInt64 i hsLitKey (HsInt64Prim i) = mkMachInt64 i
hsLitKey (HsWord64Prim w) = mkMachWord64 w hsLitKey (HsWord64Prim w) = mkMachWord64 w
hsLitKey (HsCharPrim c) = MachChar c hsLitKey (HsCharPrim c) = MachChar c
hsLitKey (HsStringPrim s) = MachStr (fastStringToFastBytes s) hsLitKey (HsStringPrim s) = MachStr s
hsLitKey (HsFloatPrim f) = MachFloat (fl_value f) hsLitKey (HsFloatPrim f) = MachFloat (fl_value f)
hsLitKey (HsDoublePrim d) = MachDouble (fl_value d) hsLitKey (HsDoublePrim d) = MachDouble (fl_value d)
hsLitKey (HsString s) = MachStr (fastStringToFastBytes s) hsLitKey (HsString s) = MachStr (fastStringToFastBytes s)
......
...@@ -719,7 +719,7 @@ cvtLit (CharL c) = do { force c; return $ HsChar c } ...@@ -719,7 +719,7 @@ cvtLit (CharL c) = do { force c; return $ HsChar c }
cvtLit (StringL s) = do { let { s' = mkFastString s } cvtLit (StringL s) = do { let { s' = mkFastString s }
; force s' ; force s'
; return $ HsString s' } ; return $ HsString s' }
cvtLit (StringPrimL s) = do { let { s' = mkFastStringByteList s } cvtLit (StringPrimL s) = do { let { s' = mkFastBytesByteList s }
; force s' ; force s'
; return $ HsStringPrim s' } ; return $ HsStringPrim s' }
cvtLit _ = panic "Convert.cvtLit: Unexpected literal" cvtLit _ = panic "Convert.cvtLit: Unexpected literal"
......
...@@ -60,7 +60,7 @@ data HsLit ...@@ -60,7 +60,7 @@ data HsLit
= HsChar Char -- Character = HsChar Char -- Character
| HsCharPrim Char -- Unboxed character | HsCharPrim Char -- Unboxed character
| HsString FastString -- String | HsString FastString -- String
| HsStringPrim FastString -- Packed string | HsStringPrim FastBytes -- Packed bytes
| HsInt Integer -- Genuinely an Int; arises from TcGenDeriv, | HsInt Integer -- Genuinely an Int; arises from TcGenDeriv,
-- and from TRANSLATION -- and from TRANSLATION
| HsIntPrim Integer -- literal Int# | HsIntPrim Integer -- literal Int#
...@@ -170,7 +170,7 @@ instance Outputable HsLit where ...@@ -170,7 +170,7 @@ instance Outputable HsLit where
ppr (HsChar c) = pprHsChar c ppr (HsChar c) = pprHsChar c
ppr (HsCharPrim c) = pprHsChar c <> char '#' ppr (HsCharPrim c) = pprHsChar c <> char '#'
ppr (HsString s) = pprHsString s ppr (HsString s) = pprHsString s
ppr (HsStringPrim s) = pprHsString s <> char '#' ppr (HsStringPrim s) = pprHsBytes s <> char '#'
ppr (HsInt i) = integer i ppr (HsInt i) = integer i
ppr (HsInteger i _) = integer i ppr (HsInteger i _) = integer i
ppr (HsRat f _) = ppr f ppr (HsRat f _) = ppr f
......
...@@ -551,7 +551,7 @@ data Token ...@@ -551,7 +551,7 @@ data Token
| ITrational FractionalLit | ITrational FractionalLit
| ITprimchar Char | ITprimchar Char
| ITprimstring FastString | ITprimstring FastBytes
| ITprimint Integer | ITprimint Integer
| ITprimword Integer | ITprimword Integer
| ITprimfloat FractionalLit | ITprimfloat FractionalLit
...@@ -1227,10 +1227,8 @@ lex_string s = do ...@@ -1227,10 +1227,8 @@ lex_string s = do
setInput i setInput i
if any (> '\xFF') s if any (> '\xFF') s
then failMsgP "primitive string literal must contain only characters <= \'\\xFF\'" then failMsgP "primitive string literal must contain only characters <= \'\\xFF\'"
else let s' = mkZFastString (reverse s) in else let bs = map (fromIntegral . ord) (reverse s)
return (ITprimstring s') in return (ITprimstring (mkFastBytesByteList bs))
-- mkZFastString is a hack to avoid encoding the
-- string in UTF-8. We just want the exact bytes.
_other -> _other ->
return (ITstring (mkFastString (reverse s))) return (ITstring (mkFastString (reverse s)))
else else
......
...@@ -45,6 +45,7 @@ import NameSet ...@@ -45,6 +45,7 @@ import NameSet
import RdrName import RdrName
import LoadIface ( loadInterfaceForName ) import LoadIface ( loadInterfaceForName )
import UniqSet import UniqSet
import Data.Char
import Data.List import Data.List
import Util import Util
import ListSetOps ( removeDups ) import ListSetOps ( removeDups )
...@@ -1167,7 +1168,7 @@ segsToStmts empty_rec_stmt ((defs, uses, fwds, ss) : segs) fvs_later ...@@ -1167,7 +1168,7 @@ segsToStmts empty_rec_stmt ((defs, uses, fwds, ss) : segs) fvs_later
\begin{code} \begin{code}
srcSpanPrimLit :: DynFlags -> SrcSpan -> HsExpr Name srcSpanPrimLit :: DynFlags -> SrcSpan -> HsExpr Name
srcSpanPrimLit dflags span srcSpanPrimLit dflags span
= HsLit (HsStringPrim (mkFastString (showSDocOneLine dflags (ppr span)))) = HsLit (HsStringPrim (mkFastBytesByteList (map (fromIntegral . ord) (showSDocOneLine dflags (ppr span)))))
mkAssertErrorExpr :: RnM (HsExpr Name) mkAssertErrorExpr :: RnM (HsExpr Name)
-- Return an expression for (assertError "Foo.hs:27") -- Return an expression for (assertError "Foo.hs:27")
......
...@@ -67,6 +67,7 @@ import SrcLoc ...@@ -67,6 +67,7 @@ import SrcLoc
import Util import Util
import Control.Monad import Control.Monad
import Data.Char
import Maybes ( orElse ) import Maybes ( orElse )
\end{code} \end{code}
...@@ -1107,7 +1108,7 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys ...@@ -1107,7 +1108,7 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys
where where
error_rhs dflags = L loc $ HsApp error_fun (error_msg dflags) error_rhs dflags = L loc $ HsApp error_fun (error_msg dflags)
error_fun = L loc $ wrapId (WpTyApp meth_tau) nO_METHOD_BINDING_ERROR_ID error_fun = L loc $ wrapId (WpTyApp meth_tau) nO_METHOD_BINDING_ERROR_ID
error_msg dflags = L loc (HsLit (HsStringPrim (mkFastString (error_string dflags)))) error_msg dflags = L loc (HsLit (HsStringPrim (mkFastBytesByteList (map (fromIntegral . ord) (error_string dflags)))))
meth_tau = funResultTy (applyTys (idType sel_id) inst_tys) meth_tau = funResultTy (applyTys (idType sel_id) inst_tys)
error_string dflags = showSDoc dflags (hcat [ppr loc, text "|", ppr sel_id ]) error_string dflags = showSDoc dflags (hcat [ppr loc, text "|", ppr sel_id ])
lam_wrapper = mkWpTyLams tyvars <.> mkWpLams dfun_ev_vars lam_wrapper = mkWpTyLams tyvars <.> mkWpLams dfun_ev_vars
......
...@@ -66,6 +66,7 @@ import BasicTypes ...@@ -66,6 +66,7 @@ import BasicTypes
import Bag import Bag
import Control.Monad import Control.Monad
import Data.Char
import Data.List import Data.List
\end{code} \end{code}
...@@ -1627,7 +1628,7 @@ mkRecSelBind (tycon, sel_name) ...@@ -1627,7 +1628,7 @@ mkRecSelBind (tycon, sel_name)
inst_tys = tyConAppArgs data_ty inst_tys = tyConAppArgs data_ty
unit_rhs = mkLHsTupleExpr [] unit_rhs = mkLHsTupleExpr []
msg_lit = HsStringPrim $ mkFastString $ msg_lit = HsStringPrim $ mkFastBytesByteList $ map (fromIntegral . ord) $
occNameString (getOccName sel_name) occNameString (getOccName sel_name)
--------------- ---------------
......
...@@ -31,6 +31,7 @@ module FastString ...@@ -31,6 +31,7 @@ module FastString
mkFastStringFastBytes, mkFastStringFastBytes,
foreignPtrToFastBytes, foreignPtrToFastBytes,
fastStringToFastBytes, fastStringToFastBytes,
mkFastBytesByteList,
bytesFB, bytesFB,
hashFB, hashFB,
lengthFB, lengthFB,
...@@ -109,7 +110,7 @@ import System.IO.Unsafe ( unsafePerformIO ) ...@@ -109,7 +110,7 @@ import System.IO.Unsafe ( unsafePerformIO )
import Data.Data import Data.Data
import Data.IORef ( IORef, newIORef, readIORef, writeIORef ) import Data.IORef ( IORef, newIORef, readIORef, writeIORef )
import Data.Maybe ( isJust ) import Data.Maybe ( isJust )
import Data.Char ( ord ) import Data.Char
import GHC.IO ( IO(..) ) import GHC.IO ( IO(..) )
...@@ -144,6 +145,14 @@ instance Eq FastBytes where ...@@ -144,6 +145,14 @@ instance Eq FastBytes where
instance Ord FastBytes where instance Ord FastBytes where
compare = cmpFB compare = cmpFB
instance Show FastBytes where
show fb = show (concatMap escape $ bytesFB fb) ++ "#"
where escape :: Word8 -> String
escape w = let c = chr (fromIntegral w)
in if isAscii c
then [c]
else '\\' : show w
foreignPtrToFastBytes :: ForeignPtr Word8 -> Int -> FastBytes foreignPtrToFastBytes :: ForeignPtr Word8 -> Int -> FastBytes
foreignPtrToFastBytes fp len = FastBytes len fp foreignPtrToFastBytes fp len = FastBytes len fp
...@@ -154,6 +163,15 @@ mkFastStringFastBytes (FastBytes len fp) ...@@ -154,6 +163,15 @@ mkFastStringFastBytes (FastBytes len fp)
fastStringToFastBytes :: FastString -> FastBytes fastStringToFastBytes :: FastString -> FastBytes
fastStringToFastBytes f = FastBytes (n_bytes f) (buf f) fastStringToFastBytes f = FastBytes (n_bytes f) (buf f)
mkFastBytesByteList :: [Word8] -> FastBytes
mkFastBytesByteList bs =
inlinePerformIO $ do
let l = Prelude.length bs
buf <- mallocForeignPtrBytes l
withForeignPtr buf $ \ptr -> do
pokeArray (castPtr ptr) bs
return $ foreignPtrToFastBytes buf l
-- | Gives the UTF-8 encoded bytes corresponding to a 'FastString' -- | Gives the UTF-8 encoded bytes corresponding to a 'FastString'
bytesFB :: FastBytes -> [Word8] bytesFB :: FastBytes -> [Word8]
bytesFB (FastBytes n_bytes buf) = bytesFB (FastBytes n_bytes buf) =
......
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