plugins-1.0: src/Language/Hi/FastString.hs
{-# OPTIONS -cpp -fglasgow-exts #-}
{-# OPTIONS -fno-warn-name-shadowing -fno-warn-unused-matches #-}
{-# OPTIONS -#include "hschooks.h" #-}
--
-- Copyright (C) 2004 Don Stewart - http://www.cse.unsw.edu.au/~dons
--
-- This library is free software; you can redistribute it and/or
-- modify it under the terms of the GNU Lesser General Public
-- License as published by the Free Software Foundation; either
-- version 2.1 of the License, or (at your option) any later version.
--
-- This library is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-- Lesser General Public License for more details.
--
-- You should have received a copy of the GNU Lesser General Public
-- License along with this library; if not, write to the Free Software
-- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307
-- USA
--
-- Based on $fptools/ghc/compiler/utils/FastString.lhs
--
-- (c) The GRASP/AQUA Project, Glasgow University, 1997-1998
--
-- Fast strings
--
-- Compact representations of character strings with
-- unique identifiers (hash-cons'ish).
--
module Language.Hi.FastString
(
FastString(..), -- not abstract, for now.
mkFastString, -- :: String -> FastString
mkFastStringNarrow, -- :: String -> FastString
mkFastSubString, -- :: Addr -> Int -> Int -> FastString
mkFastString#, -- :: Addr# -> FastString
mkFastSubStringBA#, -- :: ByteArray# -> Int# -> Int# -> FastString
mkFastStringInt, -- :: [Int] -> FastString
uniqueOfFS, -- :: FastString -> Int#
lengthFS, -- :: FastString -> Int
nullFastString, -- :: FastString -> Bool
unpackFS, -- :: FastString -> String
unpackIntFS, -- :: FastString -> [Int]
appendFS, -- :: FastString -> FastString -> FastString
headFS, -- :: FastString -> Char
headIntFS, -- :: FastString -> Int
tailFS, -- :: FastString -> FastString
concatFS, -- :: [FastString] -> FastString
consFS, -- :: Char -> FastString -> FastString
indexFS, -- :: FastString -> Int -> Char
nilFS, -- :: FastString
hPutFS, -- :: Handle -> FastString -> IO ()
LitString,
mkLitString# -- :: Addr# -> LitString
) where
import Language.Hi.PrimPacked
import System.IO
import Data.Char ( chr, ord )
import GHC.Exts
import GHC.IOBase
import GHC.Arr ( STArray(..), newSTArray )
import GHC.Handle
import Foreign.C
-- import System.IO.Unsafe ( unsafePerformIO )
-- import Control.Monad.ST ( stToIO )
-- import Data.IORef ( IORef, newIORef, readIORef, writeIORef )
#define hASH_TBL_SIZE 993
{-
@FastString@s are packed representations of strings
with a unique id for fast comparisons. The unique id
is assigned when creating the @FastString@, using
a hash table to map from the character string representation
to the unique ID.
-}
data FastString
= FastString -- packed repr. on the heap.
Int# -- unique id
-- 0 => string literal, comparison
-- will
Int# -- length
ByteArray# -- stuff
| UnicodeStr -- if contains characters outside '\1'..'\xFF'
Int# -- unique id
[Int] -- character numbers
instance Eq FastString where
-- shortcut for real FastStrings
(FastString u1 _ _) == (FastString u2 _ _) = u1 ==# u2
a == b = case cmpFS a b of { LT -> False; EQ -> True; GT -> False }
(FastString u1 _ _) /= (FastString u2 _ _) = u1 /=# u2
a /= b = case cmpFS a b of { LT -> True; EQ -> False; GT -> True }
instance Ord FastString where
-- Compares lexicographically, not by unique
a <= b = case cmpFS a b of { LT -> True; EQ -> True; GT -> False }
a < b = case cmpFS a b of { LT -> True; EQ -> False; GT -> False }
a >= b = case cmpFS a b of { LT -> False; EQ -> True; GT -> True }
a > b = case cmpFS a b of { LT -> False; EQ -> False; GT -> True }
max x y | x >= y = x
| otherwise = y
min x y | x <= y = x
| otherwise = y
compare a b = cmpFS a b
lengthFS :: FastString -> Int
lengthFS (FastString _ l# _) = I# l#
lengthFS (UnicodeStr _ s) = length s
nullFastString :: FastString -> Bool
nullFastString (FastString _ l# _) = l# ==# 0#
nullFastString (UnicodeStr _ []) = True
nullFastString (UnicodeStr _ (_:_)) = False
unpackFS :: FastString -> String
unpackFS (FastString _ l# ba#) = unpackNBytesBA (BA ba#) (I# l#)
unpackFS (UnicodeStr _ s) = map chr s
unpackIntFS :: FastString -> [Int]
unpackIntFS (UnicodeStr _ s) = s
unpackIntFS fs = map ord (unpackFS fs)
appendFS :: FastString -> FastString -> FastString
appendFS fs1 fs2 = mkFastStringInt (unpackIntFS fs1 ++ unpackIntFS fs2)
concatFS :: [FastString] -> FastString
concatFS ls = mkFastStringInt (concat (map unpackIntFS ls)) -- ToDo: do better
headFS :: FastString -> Char
headFS (FastString _ l# ba#) =
if l# ># 0# then C# (indexCharArray# ba# 0#) else error ("headFS: empty FS")
headFS (UnicodeStr _ (c:_)) = chr c
headFS (UnicodeStr _ []) = error ("headFS: empty FS")
headIntFS :: FastString -> Int
headIntFS (UnicodeStr _ (c:_)) = c
headIntFS fs = ord (headFS fs)
indexFS :: FastString -> Int -> Char
indexFS f i@(I# i#) =
case f of
FastString _ l# ba#
| l# ># 0# && l# ># i# -> C# (indexCharArray# ba# i#)
| otherwise -> error (msg (I# l#))
UnicodeStr _ s -> chr (s!!i)
where
msg l = "indexFS: out of range: " ++ show (l,i)
tailFS :: FastString -> FastString
tailFS (FastString _ l# ba#) = mkFastSubStringBA# ba# 1# (l# -# 1#)
tailFS fs = mkFastStringInt (tail (unpackIntFS fs))
consFS :: Char -> FastString -> FastString
consFS c fs = mkFastStringInt (ord c : unpackIntFS fs)
uniqueOfFS :: FastString -> Int#
uniqueOfFS (FastString u# _ _) = u#
uniqueOfFS (UnicodeStr u# _) = u#
nilFS = mkFastString ""
{-
GHC-related stuff:
Internally, the compiler will maintain a fast string symbol
table, providing sharing and fast comparison. Creation of
new @FastString@s then covertly does a lookup, re-using the
@FastString@ if there was a hit.
Caution: mkFastStringUnicode assumes that if the string is in the
table, it sits under the UnicodeStr constructor. Other mkFastString
variants analogously assume the FastString constructor.
-}
data FastStringTable =
FastStringTable
Int#
(MutableArray# RealWorld [FastString])
type FastStringTableVar = IORef FastStringTable
string_table :: FastStringTableVar
string_table =
unsafePerformIO (
stToIO (newSTArray (0::Int,hASH_TBL_SIZE) [])
>>= \ (STArray _ _ arr#) ->
newIORef (FastStringTable 0# arr#))
lookupTbl :: FastStringTable -> Int# -> IO [FastString]
lookupTbl (FastStringTable _ arr#) i# =
IO ( \ s# ->
readArray# arr# i# s#)
updTbl :: FastStringTableVar -> FastStringTable -> Int# -> [FastString] -> IO ()
updTbl fs_table_var (FastStringTable uid# arr#) i# ls =
IO (\ s# -> case writeArray# arr# i# ls s# of { s2# ->
(# s2#, () #) }) >>
writeIORef fs_table_var (FastStringTable (uid# +# 1#) arr#)
mkFastString# :: Addr# -> FastString
mkFastString# a# =
case strLength (Ptr a#) of { (I# len#) -> mkFastStringLen# a# len# }
mkFastStringLen# :: Addr# -> Int# -> FastString
mkFastStringLen# a# len# =
unsafePerformIO (
readIORef string_table >>= \ ft@(FastStringTable uid# tbl#) ->
let
h = hashStr a# len#
in
-- _trace ("hashed: "++show (I# h)) $
lookupTbl ft h >>= \ lookup_result ->
case lookup_result of
[] ->
-- no match, add it to table by copying out the
-- the string into a ByteArray
-- _trace "empty bucket" $
case copyPrefixStr a# (I# len#) of
BA barr# ->
let f_str = FastString uid# len# barr# in
updTbl string_table ft h [f_str] >>
({- _trace ("new: " ++ show f_str) $ -} return f_str)
ls ->
-- non-empty `bucket', scan the list looking
-- entry with same length and compare byte by byte.
-- _trace ("non-empty bucket"++show ls) $
case bucket_match ls len# a# of
Nothing ->
case copyPrefixStr a# (I# len#) of
BA barr# ->
let f_str = FastString uid# len# barr# in
updTbl string_table ft h (f_str:ls) >>
( {- _trace ("new: " ++ show f_str) $ -} return f_str)
Just v -> {- _trace ("re-use: "++show v) $ -} return v)
where
bucket_match [] _ _ = Nothing
bucket_match (v@(FastString _ l# ba#):ls) len# a# =
if len# ==# l# && eqStrPrefix a# ba# l# then
Just v
else
bucket_match ls len# a#
bucket_match (UnicodeStr _ _ : ls) len# a# =
bucket_match ls len# a#
mkFastSubStringBA# :: ByteArray# -> Int# -> Int# -> FastString
mkFastSubStringBA# barr# start# len# =
unsafePerformIO (
readIORef string_table >>= \ ft@(FastStringTable uid# tbl#) ->
let
h = hashSubStrBA barr# start# len#
in
-- _trace ("hashed(b): "++show (I# h)) $
lookupTbl ft h >>= \ lookup_result ->
case lookup_result of
[] ->
-- no match, add it to table by copying out the
-- the string into a ByteArray
-- _trace "empty bucket(b)" $
case copySubStrBA (BA barr#) (I# start#) (I# len#) of
BA ba# ->
let f_str = FastString uid# len# ba# in
updTbl string_table ft h [f_str] >>
-- _trace ("new(b): " ++ show f_str) $
return f_str
ls ->
-- non-empty `bucket', scan the list looking
-- entry with same length and compare byte by byte.
-- _trace ("non-empty bucket(b)"++show ls) $
case bucket_match ls start# len# barr# of
Nothing ->
case copySubStrBA (BA barr#) (I# start#) (I# len#) of
BA ba# ->
let f_str = FastString uid# len# ba# in
updTbl string_table ft h (f_str:ls) >>
-- _trace ("new(b): " ++ show f_str) $
return f_str
Just v ->
-- _trace ("re-use(b): "++show v) $
return v
)
where
bucket_match [] _ _ _ = Nothing
bucket_match (v:ls) start# len# ba# =
case v of
FastString _ l# barr# ->
if len# ==# l# && eqStrPrefixBA barr# ba# start# len# then
Just v
else
bucket_match ls start# len# ba#
UnicodeStr _ _ -> bucket_match ls start# len# ba#
mkFastStringUnicode :: [Int] -> FastString
mkFastStringUnicode s =
unsafePerformIO (
readIORef string_table >>= \ ft@(FastStringTable uid# tbl#) ->
let
h = hashUnicode s
in
-- _trace ("hashed(b): "++show (I# h)) $
lookupTbl ft h >>= \ lookup_result ->
case lookup_result of
[] ->
-- no match, add it to table by copying out the
-- the string into a [Int]
let f_str = UnicodeStr uid# s in
updTbl string_table ft h [f_str] >>
-- _trace ("new(b): " ++ show f_str) $
return f_str
ls ->
-- non-empty `bucket', scan the list looking
-- entry with same length and compare byte by byte.
-- _trace ("non-empty bucket(b)"++show ls) $
case bucket_match ls of
Nothing ->
let f_str = UnicodeStr uid# s in
updTbl string_table ft h (f_str:ls) >>
-- _trace ("new(b): " ++ show f_str) $
return f_str
Just v ->
-- _trace ("re-use(b): "++show v) $
return v
)
where
bucket_match [] = Nothing
bucket_match (v@(UnicodeStr _ s'):ls) =
if s' == s then Just v else bucket_match ls
bucket_match (FastString _ _ _ : ls) = bucket_match ls
mkFastStringNarrow :: String -> FastString
mkFastStringNarrow str =
case packString str of { (I# len#, BA frozen#) ->
mkFastSubStringBA# frozen# 0# len#
}
{- 0-indexed array, len# == index to one beyond end of string,
i.e., (0,1) => empty string. -}
mkFastString :: String -> FastString
mkFastString str = if all good str
then mkFastStringNarrow str
else mkFastStringUnicode (map ord str)
where
good c = c >= '\1' && c <= '\xFF'
mkFastStringInt :: [Int] -> FastString
mkFastStringInt str = if all good str
then mkFastStringNarrow (map chr str)
else mkFastStringUnicode str
where
good c = c >= 1 && c <= 0xFF
mkFastSubString :: Addr# -> Int -> Int -> FastString
mkFastSubString a# (I# start#) (I# len#) =
mkFastStringLen# (a# `plusAddr#` start#) len#
hashStr :: Addr# -> Int# -> Int#
-- use the Addr to produce a hash value between 0 & m (inclusive)
hashStr a# len# =
case len# of
0# -> 0#
1# -> ((ord# c0 *# 631#) +# len#) `remInt#` hASH_TBL_SIZE#
2# -> ((ord# c0 *# 631#) +# (ord# c1 *# 217#) +# len#) `remInt#` hASH_TBL_SIZE#
_ -> ((ord# c0 *# 631#) +# (ord# c1 *# 217#) +# (ord# c2 *# 43#) +# len#) `remInt#` hASH_TBL_SIZE#
where
c0 = indexCharOffAddr# a# 0#
c1 = indexCharOffAddr# a# (len# `quotInt#` 2# -# 1#)
c2 = indexCharOffAddr# a# (len# -# 1#)
{-
c1 = indexCharOffAddr# a# 1#
c2 = indexCharOffAddr# a# 2#
-}
hashSubStrBA :: ByteArray# -> Int# -> Int# -> Int#
-- use the byte array to produce a hash value between 0 & m (inclusive)
hashSubStrBA ba# start# len# =
case len# of
0# -> 0#
1# -> ((ord# c0 *# 631#) +# len#) `remInt#` hASH_TBL_SIZE#
2# -> ((ord# c0 *# 631#) +# (ord# c1 *# 217#) +# len#) `remInt#` hASH_TBL_SIZE#
_ -> ((ord# c0 *# 631#) +# (ord# c1 *# 217#) +# (ord# c2 *# 43#) +# len#) `remInt#` hASH_TBL_SIZE#
where
c0 = indexCharArray# ba# (start# +# 0#)
c1 = indexCharArray# ba# (start# +# (len# `quotInt#` 2# -# 1#))
c2 = indexCharArray# ba# (start# +# (len# -# 1#))
-- c1 = indexCharArray# ba# 1#
-- c2 = indexCharArray# ba# 2#
hashUnicode :: [Int] -> Int#
-- use the Addr to produce a hash value between 0 & m (inclusive)
hashUnicode [] = 0#
hashUnicode [I# c0] = ((c0 *# 631#) +# 1#) `remInt#` hASH_TBL_SIZE#
hashUnicode [I# c0, I# c1] = ((c0 *# 631#) +# (c1 *# 217#) +# 2#) `remInt#` hASH_TBL_SIZE#
hashUnicode s = ((c0 *# 631#) +# (c1 *# 217#) +# (c2 *# 43#) +# len#) `remInt#` hASH_TBL_SIZE#
where
I# len# = length s
I# c0 = s !! 0
I# c1 = s !! (I# (len# `quotInt#` 2# -# 1#))
I# c2 = s !! (I# (len# -# 1#))
cmpFS :: FastString -> FastString -> Ordering
cmpFS (UnicodeStr u1# s1) (UnicodeStr u2# s2) = if u1# ==# u2# then EQ
else compare s1 s2
cmpFS (UnicodeStr _ s1) s2 = compare s1 (unpackIntFS s2)
cmpFS s1 (UnicodeStr _ s2) = compare (unpackIntFS s1) s2
cmpFS (FastString u1# l1# b1#) (FastString u2# l2# b2#) =
if u1# ==# u2# then EQ else
let l# = if l1# <=# l2# then l1# else l2# in
unsafePerformIO (
memcmp b1# b2# l# >>= \ (I# res) ->
return (
if res <# 0# then LT
else if res ==# 0# then
if l1# ==# l2# then EQ
else if l1# <# l2# then LT else GT
else GT
))
foreign import ccall unsafe "memcmp"
memcmp :: ByteArray# -> ByteArray# -> Int# -> IO Int
-- -----------------------------------------------------------------------------
-- Outputting 'FastString's
#if __GLASGOW_HASKELL__ >= 504
-- this is our own version of hPutBuf for FastStrings, because in
-- 5.04+ we don't have mutable byte arrays and therefore hPutBufBA.
-- The closest is hPutArray in Data.Array.IO, but that does some extra
-- range checks that we want to avoid here.
foreign import ccall unsafe "__hscore_memcpy_dst_off"
memcpy_baoff_ba :: RawBuffer -> Int -> RawBuffer -> CSize -> IO (Ptr ())
hPutFS handle (FastString _ l# ba#)
| l# ==# 0# = return ()
| otherwise
= do wantWritableHandle "hPutFS" handle $
\ handle_@Handle__{ haFD=fd, haBuffer=ref, haIsStream=stream } -> do
old_buf@Buffer{ bufBuf=old_raw, bufRPtr=r, bufWPtr=w, bufSize=size }
<- readIORef ref
let count = I# l#
raw = unsafeCoerce# ba# :: MutableByteArray# RealWorld
-- enough room in handle buffer?
if (size - w > count)
-- There's enough room in the buffer:
-- just copy the data in and update bufWPtr.
then do memcpy_baoff_ba old_raw w raw (fromIntegral count)
writeIORef ref old_buf{ bufWPtr = w + count }
return ()
-- else, we have to flush
else do flushed_buf <- flushWriteBuffer fd stream old_buf
writeIORef ref flushed_buf
let this_buf =
Buffer{ bufBuf=raw, bufState=WriteBuffer,
bufRPtr=0, bufWPtr=count, bufSize=count }
flushWriteBuffer fd stream this_buf
return ()
#else
hPutFS :: Handle -> FastString -> IO ()
hPutFS handle (FastString _ l# ba#)
| l# ==# 0# = return ()
| otherwise = do mba <- stToIO $ unsafeThawByteArray (ByteArray (bot::Int) bot ba#)
hPutBufBAFull handle mba (I# l#)
where
bot = error "hPutFS.ba"
#endif
-- ONLY here for debugging the NCG (so -ddump-stix works for string
-- literals); no idea if this is really necessary. JRS, 010131
hPutFS handle (UnicodeStr _ is)
= hPutStr handle ("(UnicodeStr " ++ show is ++ ")")
-- -----------------------------------------------------------------------------
-- LitStrings, here for convenience only.
type LitString = Ptr ()
-- ToDo: make it a Ptr when we don't have to support 4.08 any more
mkLitString# :: Addr# -> LitString
mkLitString# a# = Ptr a#