diff options
-rw-r--r-- | compiler/deSugar/Check.lhs | 2 | ||||
-rw-r--r-- | compiler/deSugar/MatchLit.lhs | 4 | ||||
-rw-r--r-- | compiler/hsSyn/Convert.lhs | 2 | ||||
-rw-r--r-- | compiler/hsSyn/HsLit.lhs | 4 | ||||
-rw-r--r-- | compiler/parser/Lexer.x | 8 | ||||
-rw-r--r-- | compiler/rename/RnExpr.lhs | 3 | ||||
-rw-r--r-- | compiler/typecheck/TcInstDcls.lhs | 3 | ||||
-rw-r--r-- | compiler/typecheck/TcTyClsDecls.lhs | 3 | ||||
-rw-r--r-- | compiler/utils/FastString.lhs | 20 |
9 files changed, 34 insertions, 15 deletions
diff --git a/compiler/deSugar/Check.lhs b/compiler/deSugar/Check.lhs index 4910e1f4f3..75c3d11b91 100644 --- a/compiler/deSugar/Check.lhs +++ b/compiler/deSugar/Check.lhs @@ -445,7 +445,7 @@ get_lit :: Pat id -> Maybe HsLit 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 = 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 mb_neg :: (a -> a) -> Maybe b -> a -> a diff --git a/compiler/deSugar/MatchLit.lhs b/compiler/deSugar/MatchLit.lhs index a3fe356660..4032093541 100644 --- a/compiler/deSugar/MatchLit.lhs +++ b/compiler/deSugar/MatchLit.lhs @@ -69,7 +69,7 @@ See also below where we look for @DictApps@ for \tr{plusInt}, etc. \begin{code} 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 (HsIntPrim i) = return (Lit (MachInt i)) dsLit (HsWordPrim w) = return (Lit (MachWord w)) @@ -124,7 +124,7 @@ hsLitKey (HsWordPrim w) = mkMachWord w hsLitKey (HsInt64Prim i) = mkMachInt64 i hsLitKey (HsWord64Prim w) = mkMachWord64 w hsLitKey (HsCharPrim c) = MachChar c -hsLitKey (HsStringPrim s) = MachStr (fastStringToFastBytes s) +hsLitKey (HsStringPrim s) = MachStr s hsLitKey (HsFloatPrim f) = MachFloat (fl_value f) hsLitKey (HsDoublePrim d) = MachDouble (fl_value d) hsLitKey (HsString s) = MachStr (fastStringToFastBytes s) diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs index a5839c2406..3ad5aa03fa 100644 --- a/compiler/hsSyn/Convert.lhs +++ b/compiler/hsSyn/Convert.lhs @@ -719,7 +719,7 @@ cvtLit (CharL c) = do { force c; return $ HsChar c } cvtLit (StringL s) = do { let { s' = mkFastString s } ; force s' ; return $ HsString s' } -cvtLit (StringPrimL s) = do { let { s' = mkFastStringByteList s } +cvtLit (StringPrimL s) = do { let { s' = mkFastBytesByteList s } ; force s' ; return $ HsStringPrim s' } cvtLit _ = panic "Convert.cvtLit: Unexpected literal" diff --git a/compiler/hsSyn/HsLit.lhs b/compiler/hsSyn/HsLit.lhs index efa61dde67..6ed92eb8a9 100644 --- a/compiler/hsSyn/HsLit.lhs +++ b/compiler/hsSyn/HsLit.lhs @@ -60,7 +60,7 @@ data HsLit = HsChar Char -- Character | HsCharPrim Char -- Unboxed character | HsString FastString -- String - | HsStringPrim FastString -- Packed string + | HsStringPrim FastBytes -- Packed bytes | HsInt Integer -- Genuinely an Int; arises from TcGenDeriv, -- and from TRANSLATION | HsIntPrim Integer -- literal Int# @@ -170,7 +170,7 @@ instance Outputable HsLit where ppr (HsChar c) = pprHsChar c ppr (HsCharPrim c) = pprHsChar c <> char '#' ppr (HsString s) = pprHsString s - ppr (HsStringPrim s) = pprHsString s <> char '#' + ppr (HsStringPrim s) = pprHsBytes s <> char '#' ppr (HsInt i) = integer i ppr (HsInteger i _) = integer i ppr (HsRat f _) = ppr f diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x index 114f7f6b32..24a5a4ad54 100644 --- a/compiler/parser/Lexer.x +++ b/compiler/parser/Lexer.x @@ -551,7 +551,7 @@ data Token | ITrational FractionalLit | ITprimchar Char - | ITprimstring FastString + | ITprimstring FastBytes | ITprimint Integer | ITprimword Integer | ITprimfloat FractionalLit @@ -1227,10 +1227,8 @@ lex_string s = do setInput i if any (> '\xFF') s then failMsgP "primitive string literal must contain only characters <= \'\\xFF\'" - else let s' = mkZFastString (reverse s) in - return (ITprimstring s') - -- mkZFastString is a hack to avoid encoding the - -- string in UTF-8. We just want the exact bytes. + else let bs = map (fromIntegral . ord) (reverse s) + in return (ITprimstring (mkFastBytesByteList bs)) _other -> return (ITstring (mkFastString (reverse s))) else diff --git a/compiler/rename/RnExpr.lhs b/compiler/rename/RnExpr.lhs index d27ef98e80..c81243a3d4 100644 --- a/compiler/rename/RnExpr.lhs +++ b/compiler/rename/RnExpr.lhs @@ -45,6 +45,7 @@ import NameSet import RdrName import LoadIface ( loadInterfaceForName ) import UniqSet +import Data.Char import Data.List import Util import ListSetOps ( removeDups ) @@ -1167,7 +1168,7 @@ segsToStmts empty_rec_stmt ((defs, uses, fwds, ss) : segs) fvs_later \begin{code} srcSpanPrimLit :: DynFlags -> SrcSpan -> HsExpr Name srcSpanPrimLit dflags span - = HsLit (HsStringPrim (mkFastString (showSDocOneLine dflags (ppr span)))) + = HsLit (HsStringPrim (mkFastBytesByteList (map (fromIntegral . ord) (showSDocOneLine dflags (ppr span))))) mkAssertErrorExpr :: RnM (HsExpr Name) -- Return an expression for (assertError "Foo.hs:27") diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs index 9eb747ad51..8fa67f0705 100644 --- a/compiler/typecheck/TcInstDcls.lhs +++ b/compiler/typecheck/TcInstDcls.lhs @@ -67,6 +67,7 @@ import SrcLoc import Util import Control.Monad +import Data.Char import Maybes ( orElse ) \end{code} @@ -1107,7 +1108,7 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys where 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_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) error_string dflags = showSDoc dflags (hcat [ppr loc, text "|", ppr sel_id ]) lam_wrapper = mkWpTyLams tyvars <.> mkWpLams dfun_ev_vars diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs index 2872f46a3e..9a694cff4e 100644 --- a/compiler/typecheck/TcTyClsDecls.lhs +++ b/compiler/typecheck/TcTyClsDecls.lhs @@ -66,6 +66,7 @@ import BasicTypes import Bag import Control.Monad +import Data.Char import Data.List \end{code} @@ -1627,7 +1628,7 @@ mkRecSelBind (tycon, sel_name) inst_tys = tyConAppArgs data_ty unit_rhs = mkLHsTupleExpr [] - msg_lit = HsStringPrim $ mkFastString $ + msg_lit = HsStringPrim $ mkFastBytesByteList $ map (fromIntegral . ord) $ occNameString (getOccName sel_name) --------------- diff --git a/compiler/utils/FastString.lhs b/compiler/utils/FastString.lhs index 05a379808e..a340e6eedb 100644 --- a/compiler/utils/FastString.lhs +++ b/compiler/utils/FastString.lhs @@ -31,6 +31,7 @@ module FastString mkFastStringFastBytes, foreignPtrToFastBytes, fastStringToFastBytes, + mkFastBytesByteList, bytesFB, hashFB, lengthFB, @@ -109,7 +110,7 @@ import System.IO.Unsafe ( unsafePerformIO ) import Data.Data import Data.IORef ( IORef, newIORef, readIORef, writeIORef ) import Data.Maybe ( isJust ) -import Data.Char ( ord ) +import Data.Char import GHC.IO ( IO(..) ) @@ -144,6 +145,14 @@ instance Eq FastBytes where instance Ord FastBytes where 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 fp len = FastBytes len fp @@ -154,6 +163,15 @@ mkFastStringFastBytes (FastBytes len fp) fastStringToFastBytes :: FastString -> FastBytes 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' bytesFB :: FastBytes -> [Word8] bytesFB (FastBytes n_bytes buf) = |