diff options
| -rw-r--r-- | compiler/parser/Lexer.x | 4 | ||||
| -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 | 25 |
5 files changed, 28 insertions, 10 deletions
diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x index 24a5a4ad54..df400f574a 100644 --- a/compiler/parser/Lexer.x +++ b/compiler/parser/Lexer.x @@ -1227,8 +1227,8 @@ lex_string s = do setInput i if any (> '\xFF') s then failMsgP "primitive string literal must contain only characters <= \'\\xFF\'" - else let bs = map (fromIntegral . ord) (reverse s) - in return (ITprimstring (mkFastBytesByteList bs)) + else let fb = unsafeMkFastBytesString (reverse s) + in return (ITprimstring fb) _other -> return (ITstring (mkFastString (reverse s))) else diff --git a/compiler/rename/RnExpr.lhs b/compiler/rename/RnExpr.lhs index c81243a3d4..1868be9269 100644 --- a/compiler/rename/RnExpr.lhs +++ b/compiler/rename/RnExpr.lhs @@ -45,7 +45,6 @@ import NameSet import RdrName import LoadIface ( loadInterfaceForName ) import UniqSet -import Data.Char import Data.List import Util import ListSetOps ( removeDups ) @@ -1168,7 +1167,7 @@ segsToStmts empty_rec_stmt ((defs, uses, fwds, ss) : segs) fvs_later \begin{code} srcSpanPrimLit :: DynFlags -> SrcSpan -> HsExpr Name srcSpanPrimLit dflags span - = HsLit (HsStringPrim (mkFastBytesByteList (map (fromIntegral . ord) (showSDocOneLine dflags (ppr span))))) + = HsLit (HsStringPrim (unsafeMkFastBytesString (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 8fa67f0705..64f961cf65 100644 --- a/compiler/typecheck/TcInstDcls.lhs +++ b/compiler/typecheck/TcInstDcls.lhs @@ -67,7 +67,6 @@ import SrcLoc import Util import Control.Monad -import Data.Char import Maybes ( orElse ) \end{code} @@ -1108,7 +1107,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 (mkFastBytesByteList (map (fromIntegral . ord) (error_string dflags))))) + error_msg dflags = L loc (HsLit (HsStringPrim (unsafeMkFastBytesString (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 9a694cff4e..6d48c20287 100644 --- a/compiler/typecheck/TcTyClsDecls.lhs +++ b/compiler/typecheck/TcTyClsDecls.lhs @@ -66,7 +66,6 @@ import BasicTypes import Bag import Control.Monad -import Data.Char import Data.List \end{code} @@ -1628,7 +1627,7 @@ mkRecSelBind (tycon, sel_name) inst_tys = tyConAppArgs data_ty unit_rhs = mkLHsTupleExpr [] - msg_lit = HsStringPrim $ mkFastBytesByteList $ map (fromIntegral . ord) $ + msg_lit = HsStringPrim $ unsafeMkFastBytesString $ occNameString (getOccName sel_name) --------------- diff --git a/compiler/utils/FastString.lhs b/compiler/utils/FastString.lhs index ba078401e7..e6b432dbfa 100644 --- a/compiler/utils/FastString.lhs +++ b/compiler/utils/FastString.lhs @@ -33,6 +33,7 @@ module FastString fastStringToFastBytes, fastZStringToFastBytes, mkFastBytesByteList, + unsafeMkFastBytesString, bytesFB, hashFB, lengthFB, @@ -179,6 +180,24 @@ mkFastBytesByteList bs = pokeArray (castPtr ptr) bs return $ foreignPtrToFastBytes buf l +-- This will drop information if any character > '\xFF' +unsafeMkFastBytesString :: String -> FastBytes +unsafeMkFastBytesString str = + inlinePerformIO $ do + let l = Prelude.length str + buf <- mallocForeignPtrBytes l + withForeignPtr buf $ \ptr -> do + pokeCAString (castPtr ptr) str + return $ foreignPtrToFastBytes buf l + +pokeCAString :: Ptr CChar -> String -> IO () +pokeCAString ptr str = + let + go [] !_ = return () + go (c:cs) n = do pokeElemOff ptr n (castCharToCChar c); go cs (n+1) + in + go str 0 + -- | Gives the UTF-8 encoded bytes corresponding to a 'FastString' bytesFB :: FastBytes -> [Word8] bytesFB (FastBytes n_bytes buf) = @@ -226,6 +245,9 @@ zString (FastZString (FastBytes n_bytes buf)) = lengthFZS :: FastZString -> Int lengthFZS (FastZString fb) = lengthFB fb +mkFastZStringString :: String -> FastZString +mkFastZStringString str = FastZString (unsafeMkFastBytesString str) + -- ----------------------------------------------------------------------------- {-| @@ -395,8 +417,7 @@ mkFastStringByteList str = -- | Creates a Z-encoded 'FastString' from a 'String' mkZFastString :: String -> FastZString -mkZFastString str = FastZString - $ mkFastBytesByteList $ map (fromIntegral . ord) str +mkZFastString = mkFastZStringString bucket_match :: [FastString] -> Int -> Ptr Word8 -> IO (Maybe FastString) bucket_match [] _ _ = return Nothing |