ghc/compiler/utils/FastString.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1997
   3 %
   4 \section{Fast strings}
   5
   6 Compact representations of character strings with
   7 unique identifiers (hash-cons'ish).
   8
   9 \begin{code}
  10 module FastString
  11        (
  12         FastString(..),     -- not abstract, for now.
  13
  14          --names?
  15         mkFastString,       -- :: String -> FastString
  16         mkFastSubString,    -- :: Addr -> Int -> Int -> FastString
  17         mkFastSubStringFO,  -- :: ForeignObj -> Int -> Int -> FastString
  18
  19         -- These ones hold on to the Addr after they return, and aren't hashed;
  20         -- they are used for literals
  21         mkFastCharString,   -- :: Addr -> FastString
  22         mkFastCharString#,  -- :: Addr# -> FastString
  23         mkFastCharString2,  -- :: Addr -> Int -> FastString
  24
  25         mkFastString#,      -- :: Addr# -> Int# -> FastString
  26         mkFastSubStringBA#, -- :: ByteArray# -> Int# -> Int# -> FastString
  27         mkFastSubString#,   -- :: Addr# -> Int# -> Int# -> FastString
  28         mkFastSubStringFO#, -- :: ForeignObj# -> Int# -> Int# -> FastString
  29
  30         uniqueOfFS,         -- :: FastString -> Int#
  31         lengthFS,           -- :: FastString -> Int
  32         nullFastString,     -- :: FastString -> Bool
  33
  34         getByteArray#,      -- :: FastString -> ByteArray#
  35         getByteArray,       -- :: FastString -> _ByteArray Int
  36         unpackFS,           -- :: FastString -> String
  37         appendFS,           -- :: FastString -> FastString -> FastString
  38         headFS,             -- :: FastString -> Char
  39         tailFS,             -- :: FastString -> FastString
  40         concatFS,           -- :: [FastString] -> FastString
  41         consFS,             -- :: Char -> FastString -> FastString
  42
  43         hPutFS              -- :: Handle -> FastString -> IO ()
  44        ) where
  45
  46 -- This #define suppresses the "import FastString" that
  47 -- HsVersions otherwise produces
  48 #define COMPILING_FAST_STRING
  49 #include "HsVersions.h"
  50
  51 #if __GLASGOW_HASKELL__ < 301
  52 import PackBase
  53 import STBase           ( StateAndPtr#(..) )
  54 import IOHandle         ( filePtr, readHandle, writeHandle )
  55 import IOBase           ( Handle__(..), IOError(..), IOErrorType(..),
  56                           IOResult(..), IO(..),
  57                           constructError
  58                         )
  59 #else
  60 import PrelPack
  61 import PrelST           ( StateAndPtr#(..) )
  62 import PrelHandle       ( readHandle,
  63 #if __GLASGOW_HASKELL__ < 303
  64                           filePtr, flushBuf,
  65 #endif
  66                           writeHandle
  67                         )
  68 import PrelIOBase       ( Handle__(..), IOError(..), IOErrorType(..),
  69                           IOResult(..), IO(..),
  70 #if __GLASGOW_HASKELL__ >= 303
  71                           Handle__Type(..),
  72 #endif
  73                           constructError
  74                         )
  75 #endif
  76
  77 import PrimPacked
  78 import GlaExts
  79 import Addr             ( Addr(..) )
  80 import MutableArray     ( MutableArray(..) )
  81 import Foreign          ( ForeignObj(..) )
  82 import IOExts           ( IORef, newIORef, readIORef, writeIORef )
  83 import IO
  84
  85 #define hASH_TBL_SIZE 993
  86 \end{code}
  87
  88 @FastString@s are packed representations of strings
  89 with a unique id for fast comparisons. The unique id
  90 is assigned when creating the @FastString@, using
  91 a hash table to map from the character string representation
  92 to the unique ID.
  93
  94 \begin{code}
  95 data FastString
  96   = FastString   -- packed repr. on the heap.
  97       Int#       -- unique id
  98                  --  0 => string literal, comparison
  99                  --  will
 100       Int#       -- length
 101       ByteArray# -- stuff
 102
 103   | CharStr      -- external C string
 104       Addr#      -- pointer to the (null-terminated) bytes in C land.
 105       Int#       -- length  (cached)
 106
 107 instance Eq FastString where
 108   a == b = case cmpFS a b of { LT -> False; EQ -> True;  GT -> False }
 109   a /= b = case cmpFS a b of { LT -> True;  EQ -> False; GT -> True  }
 110
 111 instance Ord FastString where
 112     a <= b = case cmpFS a b of { LT -> True;  EQ -> True;  GT -> False }
 113     a <  b = case cmpFS a b of { LT -> True;  EQ -> False; GT -> False }
 114     a >= b = case cmpFS a b of { LT -> False; EQ -> True;  GT -> True  }
 115     a >  b = case cmpFS a b of { LT -> False; EQ -> False; GT -> True  }
 116     max x y | x >= y    =  x
 117             | otherwise =  y
 118     min x y | x <= y    =  x
 119             | otherwise =  y
 120     compare a b = cmpFS a b
 121
 122 instance Text FastString  where
 123     showsPrec p ps@(FastString u# _ _) r = showsPrec p (unpackFS ps) r
 124     showsPrec p ps r = showsPrec p (unpackFS ps) r
 125
 126 getByteArray# :: FastString -> ByteArray#
 127 getByteArray# (FastString _ _ ba#) = ba#
 128
 129 getByteArray :: FastString -> ByteArray Int
 130 getByteArray (FastString _ l# ba#) = ByteArray (0,I# l#) ba#
 131
 132 lengthFS :: FastString -> Int
 133 lengthFS (FastString _ l# _) = I# l#
 134 lengthFS (CharStr a# l#) = I# l#
 135
 136 nullFastString :: FastString -> Bool
 137 nullFastString (FastString _ l# _) = l# ==# 0#
 138 nullFastString (CharStr _ l#) = l# ==# 0#
 139
 140 unpackFS :: FastString -> String
 141 unpackFS (FastString _ l# ba#) = unpackCStringBA# ba# l#
 142 unpackFS (CharStr addr len#) =
 143  unpack 0#
 144  where
 145     unpack nh
 146       | nh ==# len# = []
 147       | otherwise   = C# ch : unpack (nh +# 1#)
 148       where
 149         ch = indexCharOffAddr# addr nh
 150
 151 appendFS :: FastString -> FastString -> FastString
 152 appendFS fs1 fs2 = mkFastString (unpackFS fs1 ++ unpackFS fs2)
 153
 154 concatFS :: [FastString] -> FastString
 155 concatFS ls = mkFastString (concat (map (unpackFS) ls)) -- ToDo: do better
 156
 157 headFS :: FastString -> Char
 158 headFS f@(FastString _ l# ba#) =
 159  if l# ># 0# then C# (indexCharArray# ba# 0#) else error ("headFS: empty FS: " ++ unpackFS f)
 160 headFS f@(CharStr a# l#) =
 161  if l# ># 0# then C# (indexCharOffAddr# a# 0#) else error ("headFS: empty FS: " ++ unpackFS f)
 162
 163 tailFS :: FastString -> FastString
 164 tailFS (FastString _ l# ba#) = mkFastSubStringBA# ba# 1# (l# -# 1#)
 165
 166 consFS :: Char -> FastString -> FastString
 167 consFS c fs = mkFastString (c:unpackFS fs)
 168
 169 uniqueOfFS :: FastString -> Int#
 170 uniqueOfFS (FastString u# _ _) = u#
 171 uniqueOfFS (CharStr a# l#)     = case mkFastString# a# l# of { FastString u# _ _ -> u#} -- Ugh!
 172    {-
 173      [A somewhat moby hack]: to avoid entering all sorts
 174      of junk into the hash table, all C char strings
 175      are by default left out. The benefit of being in
 176      the table is that string comparisons are lightning fast,
 177      just an Int# comparison.
 178
 179      But, if you want to get the Unique of a CharStr, we
 180      enter it into the table and return that unique. This
 181      works, but causes the CharStr to be looked up in the hash
 182      table each time it is accessed..
 183    -}
 184 \end{code}
 185
 186 Internally, the compiler will maintain a fast string symbol
 187 table, providing sharing and fast comparison. Creation of
 188 new @FastString@s then covertly does a lookup, re-using the
 189 @FastString@ if there was a hit.
 190
 191 \begin{code}
 192 data FastStringTable =
 193  FastStringTable
 194     Int#
 195     (MutableArray# RealWorld [FastString])
 196
 197 type FastStringTableVar = IORef FastStringTable
 198
 199 string_table :: FastStringTableVar
 200 string_table =
 201  unsafePerformIO (
 202    stToIO (newArray (0::Int,hASH_TBL_SIZE) [])          >>= \ (MutableArray _ arr#) ->
 203    newIORef (FastStringTable 0# arr#))
 204
 205 lookupTbl :: FastStringTable -> Int# -> IO [FastString]
 206 lookupTbl (FastStringTable _ arr#) i# =
 207   IO ( \ s# ->
 208   case readArray# arr# i# s# of { StateAndPtr# s2# r ->
 209   IOok s2# r })
 210
 211 updTbl :: FastStringTableVar -> FastStringTable -> Int# -> [FastString] -> IO ()
 212 updTbl fs_table_var (FastStringTable uid# arr#) i# ls =
 213  IO (\ s# -> case writeArray# arr# i# ls s# of { s2# -> IOok s2# () })  >>
 214  writeIORef fs_table_var (FastStringTable (uid# +# 1#) arr#)
 215
 216 mkFastString# :: Addr# -> Int# -> FastString
 217 mkFastString# a# len# =
 218  unsafePerformIO  (
 219   readIORef string_table        >>= \ ft@(FastStringTable uid# tbl#) ->
 220   let
 221    h = hashStr a# len#
 222   in
 223 --  _trace ("hashed: "++show (I# h)) $
 224   lookupTbl ft h        >>= \ lookup_result ->
 225   case lookup_result of
 226     [] ->
 227        -- no match, add it to table by copying out the
 228        -- the string into a ByteArray
 229        -- _trace "empty bucket" $
 230        case copyPrefixStr (A# a#) (I# len#) of
 231          (ByteArray _ barr#) ->
 232            let f_str = FastString uid# len# barr# in
 233            updTbl string_table ft h [f_str] >>
 234            ({- _trace ("new: " ++ show f_str)   $ -} return f_str)
 235     ls ->
 236        -- non-empty `bucket', scan the list looking
 237        -- entry with same length and compare byte by byte.
 238        -- _trace ("non-empty bucket"++show ls) $
 239        case bucket_match ls len# a# of
 240          Nothing ->
 241            case copyPrefixStr (A# a#) (I# len#) of
 242             (ByteArray _ barr#) ->
 243               let f_str = FastString uid# len# barr# in
 244               updTbl string_table ft h (f_str:ls) >>
 245               ( {- _trace ("new: " ++ show f_str)  $ -} return f_str)
 246          Just v  -> {- _trace ("re-use: "++show v) $ -} return v)
 247   where
 248    bucket_match [] _ _ = Nothing
 249    bucket_match (v@(FastString _ l# ba#):ls) len# a# =
 250       if len# ==# l# && eqStrPrefix a# ba# l# then
 251          Just v
 252       else
 253          bucket_match ls len# a#
 254
 255 mkFastSubString# :: Addr# -> Int# -> Int# -> FastString
 256 mkFastSubString# a# start# len# = mkFastCharString2 (A# (addrOffset# a# start#)) (I# len#)
 257
 258 mkFastSubStringFO# :: ForeignObj# -> Int# -> Int# -> FastString
 259 mkFastSubStringFO# fo# start# len# =
 260  unsafePerformIO  (
 261   readIORef string_table >>= \ ft@(FastStringTable uid# tbl#) ->
 262   let
 263    h = hashSubStrFO fo# start# len#
 264   in
 265   lookupTbl ft h        >>= \ lookup_result ->
 266   case lookup_result of
 267     [] ->
 268        -- no match, add it to table by copying out the
 269        -- the string into a ByteArray
 270        case copySubStrFO (_ForeignObj fo#) (I# start#) (I# len#) of
 271          (ByteArray _ barr#) ->
 272            let f_str = FastString uid# len# barr# in
 273            updTbl string_table ft h [f_str]       >>
 274            return f_str
 275     ls ->
 276        -- non-empty `bucket', scan the list looking
 277        -- entry with same length and compare byte by byte.
 278        case bucket_match ls start# len# fo# of
 279          Nothing ->
 280            case copySubStrFO (_ForeignObj fo#) (I# start#) (I# len#) of
 281              (ByteArray _ barr#) ->
 282               let f_str = FastString uid# len# barr# in
 283               updTbl string_table ft  h (f_str:ls) >>
 284               ( {- _trace ("new: " ++ show f_str) $ -} return f_str)
 285          Just v  -> {- _trace ("re-use: "++show v) $ -} return v)
 286   where
 287    bucket_match [] _ _ _ = Nothing
 288    bucket_match (v@(FastString _ l# barr#):ls) start# len# fo# =
 289       if len# ==# l# && eqStrPrefixFO fo# barr# start# len# then
 290          Just v
 291       else
 292          bucket_match ls start# len# fo#
 293
 294
 295 mkFastSubStringBA# :: ByteArray# -> Int# -> Int# -> FastString
 296 mkFastSubStringBA# barr# start# len# =
 297  unsafePerformIO  (
 298   readIORef string_table        >>= \ ft@(FastStringTable uid# tbl#) ->
 299   let
 300    h = hashSubStrBA barr# start# len#
 301   in
 302 --  _trace ("hashed(b): "++show (I# h)) $
 303   lookupTbl ft h                >>= \ lookup_result ->
 304   case lookup_result of
 305     [] ->
 306        -- no match, add it to table by copying out the
 307        -- the string into a ByteArray
 308        -- _trace "empty bucket(b)" $
 309        case copySubStrBA (ByteArray btm barr#) (I# start#) (I# len#) of
 310          (ByteArray _ ba#) ->
 311           let f_str = FastString uid# len# ba# in
 312           updTbl string_table ft h [f_str]     >>
 313           -- _trace ("new(b): " ++ show f_str)   $
 314           return f_str
 315     ls ->
 316        -- non-empty `bucket', scan the list looking
 317        -- entry with same length and compare byte by byte.
 318        -- _trace ("non-empty bucket(b)"++show ls) $
 319        case bucket_match ls start# len# barr# of
 320          Nothing ->
 321           case copySubStrBA (ByteArray (error "") barr#) (I# start#) (I# len#) of
 322             (ByteArray _ ba#) ->
 323               let f_str = FastString uid# len# ba# in
 324               updTbl string_table ft h (f_str:ls) >>
 325               -- _trace ("new(b): " ++ show f_str)   $
 326               return f_str
 327          Just v  ->
 328               -- _trace ("re-use(b): "++show v) $
 329               return v
 330   )
 331  where
 332    btm = error ""
 333
 334    bucket_match [] _ _ _ = Nothing
 335    bucket_match (v:ls) start# len# ba# =
 336     case v of
 337      FastString _ l# barr# ->
 338       if len# ==# l# && eqStrPrefixBA barr# ba# start# len# then
 339          Just v
 340       else
 341          bucket_match ls start# len# ba#
 342
 343 mkFastCharString :: Addr -> FastString
 344 mkFastCharString a@(A# a#) =
 345  case strLength a of{ (I# len#) -> CharStr a# len# }
 346
 347 mkFastCharString# :: Addr# -> FastString
 348 mkFastCharString# a# =
 349  case strLength (A# a#) of { (I# len#) -> CharStr a# len# }
 350
 351 mkFastCharString2 :: Addr -> Int -> FastString
 352 mkFastCharString2 a@(A# a#) (I# len#) = CharStr a# len#
 353
 354 mkFastString :: String -> FastString
 355 mkFastString str =
 356  case packString str of
 357   (ByteArray (_,I# len#) frozen#) ->
 358     mkFastSubStringBA# frozen# 0# len#
 359     {- 0-indexed array, len# == index to one beyond end of string,
 360        i.e., (0,1) => empty string.    -}
 361
 362 mkFastSubString :: Addr -> Int -> Int -> FastString
 363 mkFastSubString (A# a#) (I# start#) (I# len#) =
 364  mkFastString# (addrOffset# a# start#) len#
 365
 366 mkFastSubStringFO :: _ForeignObj -> Int -> Int -> FastString
 367 mkFastSubStringFO (_ForeignObj fo#) (I# start#) (I# len#) =
 368  mkFastSubStringFO# fo# start# len#
 369 \end{code}
 370
 371 \begin{code}
 372 hashStr  :: Addr# -> Int# -> Int#
 373  -- use the Addr to produce a hash value between 0 & m (inclusive)
 374 hashStr a# len# =
 375   case len# of
 376    0# -> 0#
 377    1# -> ((ord# c0 *# 631#) +# len#) `remInt#` hASH_TBL_SIZE#
 378    2# -> ((ord# c0 *# 631#) +# (ord# c1 *# 217#) +# len#) `remInt#` hASH_TBL_SIZE#
 379    _  -> ((ord# c0 *# 631#) +# (ord# c1 *# 217#) +# (ord# c2 *# 43#) +# len#) `remInt#` hASH_TBL_SIZE#
 380   where
 381     c0 = indexCharOffAddr# a# 0#
 382     c1 = indexCharOffAddr# a# (len# `quotInt#` 2# -# 1#)
 383     c2 = indexCharOffAddr# a# (len# -# 1#)
 384 {-
 385     c1 = indexCharOffAddr# a# 1#
 386     c2 = indexCharOffAddr# a# 2#
 387 -}
 388
 389 hashSubStrFO  :: ForeignObj# -> Int# -> Int# -> Int#
 390  -- use the FO to produce a hash value between 0 & m (inclusive)
 391 hashSubStrFO fo# start# len# =
 392   case len# of
 393    0# -> 0#
 394    1# -> ((ord# c0 *# 631#) +# len#) `remInt#` hASH_TBL_SIZE#
 395    2# -> ((ord# c0 *# 631#) +# (ord# c1 *# 217#) +# len#) `remInt#` hASH_TBL_SIZE#
 396    _  -> ((ord# c0 *# 631#) +# (ord# c1 *# 217#) +# (ord# c2 *# 43#) +# len#) `remInt#` hASH_TBL_SIZE#
 397   where
 398     c0 = indexCharOffForeignObj# fo# 0#
 399     c1 = indexCharOffForeignObj# fo# (len# `quotInt#` 2# -# 1#)
 400     c2 = indexCharOffForeignObj# fo# (len# -# 1#)
 401
 402 --    c1 = indexCharOffFO# fo# 1#
 403 --    c2 = indexCharOffFO# fo# 2#
 404
 405
 406 hashSubStrBA  :: ByteArray# -> Int# -> Int# -> Int#
 407  -- use the byte array to produce a hash value between 0 & m (inclusive)
 408 hashSubStrBA ba# start# len# =
 409   case len# of
 410    0# -> 0#
 411    1# -> ((ord# c0 *# 631#) +# len#) `remInt#` hASH_TBL_SIZE#
 412    2# -> ((ord# c0 *# 631#) +# (ord# c1 *# 217#) +# len#) `remInt#` hASH_TBL_SIZE#
 413    _  -> ((ord# c0 *# 631#) +# (ord# c1 *# 217#) +# (ord# c2 *# 43#) +# len#) `remInt#` hASH_TBL_SIZE#
 414   where
 415     c0 = indexCharArray# ba# 0#
 416     c1 = indexCharArray# ba# (len# `quotInt#` 2# -# 1#)
 417     c2 = indexCharArray# ba# (len# -# 1#)
 418
 419 --    c1 = indexCharArray# ba# 1#
 420 --    c2 = indexCharArray# ba# 2#
 421
 422 \end{code}
 423
 424 \begin{code}
 425 cmpFS :: FastString -> FastString -> Ordering
 426 cmpFS (FastString u1# _ b1#) (FastString u2# _ b2#) = -- assume non-null chars
 427   if u1# ==# u2# then
 428      EQ
 429   else
 430    unsafePerformIO (
 431     _ccall_ strcmp (ByteArray bottom b1#) (ByteArray bottom b2#)        >>= \ (I# res) ->
 432     return (
 433     if      res <#  0# then LT
 434     else if res ==# 0# then EQ
 435     else                    GT
 436     ))
 437   where
 438    bottom :: (Int,Int)
 439    bottom = error "tagCmp"
 440 cmpFS (CharStr bs1 len1) (CharStr bs2 len2)
 441   = unsafePerformIO (
 442     _ccall_ strcmp ba1 ba2      >>= \ (I# res) ->
 443     return (
 444     if      res <#  0# then LT
 445     else if res ==# 0# then EQ
 446     else                    GT
 447     ))
 448   where
 449     ba1 = A# bs1
 450     ba2 = A# bs2
 451 cmpFS (FastString _ len1 bs1) (CharStr bs2 len2)
 452  = unsafePerformIO (
 453     _ccall_ strcmp ba1 ba2      >>= \ (I# res) ->
 454     return (
 455      if      res <#  0# then LT
 456      else if res ==# 0# then EQ
 457      else                    GT
 458     ))
 459   where
 460     ba1 = ByteArray ((error "")::(Int,Int)) bs1
 461     ba2 = A# bs2
 462
 463 cmpFS a@(CharStr _ _) b@(FastString _ _ _)
 464   = -- try them the other way 'round
 465     case (cmpFS b a) of { LT -> GT; EQ -> EQ; GT -> LT }
 466
 467 \end{code}
 468
 469 Outputting @FastString@s is quick, just block copying the chunk (using
 470 @fwrite@).
 471
 472 \begin{code}
 473 hPutFS :: Handle -> FastString -> IO ()
 474 #if __GLASGOW_HASKELL__ <= 302
 475 hPutFS handle (FastString _ l# ba#) =
 476  if l# ==# 0# then
 477     return ()
 478  else
 479     readHandle handle                               >>= \ htype ->
 480     case htype of
 481       ErrorHandle ioError ->
 482           writeHandle handle htype                  >>
 483           fail ioError
 484       ClosedHandle ->
 485           writeHandle handle htype                  >>
 486           fail MkIOError(handle,IllegalOperation,"handle is closed")
 487       SemiClosedHandle _ _ ->
 488           writeHandle handle htype                  >>
 489           fail MkIOError(handle,IllegalOperation,"handle is closed")
 490       ReadHandle _ _ _ ->
 491           writeHandle handle htype                  >>
 492           fail MkIOError(handle,IllegalOperation,"handle is not open for writing")
 493       other ->
 494           let fp = filePtr htype in
 495            -- here we go..
 496           _ccall_ writeFile (ByteArray ((error "")::(Int,Int)) ba#) fp (I# l#) >>= \rc ->
 497           if rc==0 then
 498               return ()
 499           else
 500               constructError "hPutFS"   >>= \ err ->
 501               fail err
 502 hPutFS handle (CharStr a# l#) =
 503  if l# ==# 0# then
 504     return ()
 505  else
 506     readHandle handle                               >>= \ htype ->
 507     case htype of
 508       ErrorHandle ioError ->
 509           writeHandle handle htype                  >>
 510           fail ioError
 511       ClosedHandle ->
 512           writeHandle handle htype                  >>
 513           fail MkIOError(handle,IllegalOperation,"handle is closed")
 514       SemiClosedHandle _ _ ->
 515           writeHandle handle htype                  >>
 516           fail MkIOError(handle,IllegalOperation,"handle is closed")
 517       ReadHandle _ _ _ ->
 518           writeHandle handle htype                  >>
 519           fail MkIOError(handle,IllegalOperation,"handle is not open for writing")
 520       other ->
 521           let fp = filePtr htype in
 522            -- here we go..
 523           _ccall_ writeFile (A# a#) fp (I# l#)  >>= \rc ->
 524           if rc==0 then
 525               return ()
 526           else
 527               constructError "hPutFS"           >>= \ err ->
 528               fail err
 529 #else
 530 hPutFS handle (FastString _ l# ba#)
 531   | l# ==# 0#  = return ()
 532   | otherwise  = hPutBufBA handle (ByteArray bottom ba#) (I# l#)
 533  where
 534   bottom = error "hPutFS.ba"
 535
 536 hPutFS handle (CharStr a# l#)
 537   | l# ==# 0#  = return ()
 538   | otherwise  = hPutBuf handle (A# a#) (I# l#)
 539
 540 #endif
 541 \end{code}