Small refactoring for FastZStrings
authorIan Lynagh <igloo@earth.li>
Sun, 15 Jul 2012 17:53:04 +0000 (18:53 +0100)
committerIan Lynagh <igloo@earth.li>
Sun, 15 Jul 2012 17:53:04 +0000 (18:53 +0100)
compiler/parser/Lexer.x
compiler/rename/RnExpr.lhs
compiler/typecheck/TcInstDcls.lhs
compiler/typecheck/TcTyClsDecls.lhs
compiler/utils/FastString.lhs

index 24a5a4a..df400f5 100644 (file)
@@ -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
index c81243a..1868be9 100644 (file)
@@ -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")
index 8fa67f0..64f961c 100644 (file)
@@ -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
index 9a694cf..6d48c20 100644 (file)
@@ -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)
 
 ---------------
index ba07840..e6b432d 100644 (file)
@@ -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