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