lvmlib-1.0: Lvm/Common/Id.hs
--------------------------------------------------------------------------------
-- Copyright 2001-2012, Daan Leijen, Bastiaan Heeren, Jurriaan Hage. This file
-- is distributed under the terms of the BSD3 License. For more information,
-- see the file "LICENSE.txt", which is included in the distribution.
--------------------------------------------------------------------------------
-- $Id: Id.hs 291 2012-11-08 11:27:33Z heere112 $
module Lvm.Common.Id
( Id
-- essential used in "asm" and "lvm"
, stringFromId, idFromString, idFromStringEx, dummyId
-- exotic: only used in the core compiler
, freshIdFromId, getNameSpace, setNameSpace, NameSupply, newNameSupply
, splitNameSupply, splitNameSupplies, freshId, mapWithSupply
-- very exotic: only used internally for IdMap's that use IntMap
, intFromId, idFromInt
) where
import Data.IORef
import Data.Int (Int32)
import Data.List
import System.IO.Unsafe
import Text.PrettyPrint.Leijen
import qualified Data.IntMap as IntMap
----------------------------------------------------------------
-- Types
----------------------------------------------------------------
newtype Id = Id Int32
intFromId :: Id -> Int
intFromId (Id i) = fromIntegral i
idFromInt :: Int -> Id
idFromInt i = Id (fromIntegral i)
----------------------------------------------------------------
-- Names: the symbol table
----------------------------------------------------------------
data Names = Names Int (IntMap.IntMap [String])
namesRef :: IORef Names
namesRef = unsafePerformIO (newIORef emptyNames)
emptyNames :: Names
emptyNames = Names 0 IntMap.empty
idFromString :: String -> Id
idFromString = idFromStringEx (0::Int)
idFromStringEx :: Enum a => a -> String -> Id
idFromStringEx ns name
= unsafePerformIO $
do{ names <- readIORef namesRef
; let (x, names') = insertName (fromEnum ns) name names
; writeIORef namesRef names'
; return x
}
stringFromId :: Id -> String
stringFromId x@(Id i)
| isUniq i = '.' : show (extractUniq i)
| otherwise = unsafePerformIO $
do{ names <- readIORef namesRef
; case lookupId x names of
Nothing -> error "Id.nameFromId: unknown id"
Just name -> return name
}
----------------------------------------------------------------
-- fresh identifiers without a nice name
-- but the advantage of a pure interface
----------------------------------------------------------------
newtype NameSupply = NameSupply (IORef Int32)
newNameSupply :: IO NameSupply
newNameSupply
= do{ ref <- newIORef 0
; return (NameSupply ref)
}
splitNameSupply :: NameSupply -> (NameSupply,NameSupply)
splitNameSupply supply = (supply,supply)
splitNameSupplies :: NameSupply -> [NameSupply]
splitNameSupplies = repeat
freshIdFromId :: Id -> NameSupply -> (Id,NameSupply)
freshIdFromId x supply@(NameSupply ref)
= unsafePerformIO (do{ i <- readIORef ref
; writeIORef ref (i+1)
; let name = stringFromId x ++ "." ++ show i
x1 = idFromString name
x2 = setNameSpace (getNameSpace x :: Int) x1
; seq name $ seq x2 $ return (x2,supply)
})
freshId :: NameSupply -> (Id,NameSupply)
freshId supply@(NameSupply ref)
= unsafePerformIO (do{ i <- readIORef ref
; writeIORef ref (i+1)
; return (Id (initUniq i), supply)
})
mapWithSupply :: (NameSupply -> a -> b) -> NameSupply -> [a] -> [b]
mapWithSupply f = zipWith f . splitNameSupplies
----------------------------------------------------------------
-- Bit masks used within an Id
--
-- 0x | 0 0 0 0 | 0 0 0 0 |
-- | | F E | sort (=namespace) of the id (TODO: just 128 entries is too few)
-- | F | F F | hash index in the hash table
-- | 7 F F | | index in the list of id's in the leaves of the hash table
-- | | 1 | unique id (no name available)
-- | 7 F F F | F F | unique number of unique id
----------------------------------------------------------------
dummyId :: Id
dummyId = Id 0x7FFFFFF1
shiftSort, maxSort :: Int32
shiftSort = 0x00000002
maxSort = 0x7F
maxHash, shiftHash :: Int32
maxHash = 0xFFF
shiftHash = 0x00000100
shiftIdx, maxIdx :: Int32
shiftIdx = 0x00100000
maxIdx = 0x7FF
shiftUniq,maxUniq :: Int32
shiftUniq = 0x00000100
maxUniq = 0x007FFFFF
-- flagUniq = 0x00000001
extractBits, clearBits, initBits :: Int32 -> Int32 -> Int32 -> Int32
extractBits shift maxb i
= (i `div` shift) `mod` (maxb+1)
clearBits shift maxb i
= i - (extractBits shift maxb i * shift)
initBits shift v i
= i + (shift * v)
extractSort :: Int32 -> Int32
extractSort = extractBits shiftSort maxSort
clearSort :: Int32 -> Int32
clearSort = clearBits shiftSort maxSort
initSort :: Int32 -> Int32 -> Int32
initSort = initBits shiftSort
extractHash :: Int32 -> Int32
extractHash = extractBits shiftHash maxHash
initHash :: Int32 -> Int32
initHash h = initBits shiftHash h 0
extractIdx :: Int32 -> Int32
extractIdx = extractBits shiftIdx maxIdx
initIdx :: Int32 -> Int32 -> Int32
initIdx = initBits shiftIdx
extractUniq :: Int32 -> Int32
extractUniq = extractBits shiftUniq maxUniq
initUniq :: Int32 -> Int32
initUniq u = initBits shiftUniq u 1
isUniq :: Int32 -> Bool
isUniq = odd
----------------------------------------------------------------
-- The core of the symbol table: lookupId and insertName
----------------------------------------------------------------
instance Eq Id where
Id i1 == Id i2 = i1 == i2
-- fast, but predictable
instance Ord Id where
compare x1@(Id i1) x2@(Id i2) =
case compare (extractHash i1) (extractHash i2) of
LT -> LT
EQ | i1 == i2 -> EQ
| otherwise -> compare (stringFromId x1) (stringFromId x2)
GT -> GT
instance Show Id where
show x = "\"" ++ stringFromId x ++ "\""
instance Pretty Id where
pretty = string . stringFromId
getNameSpace :: Enum a => Id -> a
getNameSpace (Id i)
= toEnum (fromIntegral (extractSort i))
setNameSpace :: Enum a => a -> Id -> Id
setNameSpace srt (Id i)
| s > maxSort = error "Id.setIdSort: sort index out of range"
| otherwise = Id (initSort s (clearSort i))
where
s = fromIntegral (fromEnum srt)
lookupId :: Id -> Names -> Maybe String
lookupId (Id i) (Names _ m)
= let idx = extractIdx i
h = extractHash i
in case IntMap.lookup (fromIntegral h) m of
Nothing -> Nothing
Just xs -> Just (index idx xs)
where
index 0 (x:_) = x
index idx (_:xx) = index (idx-1) xx
index _ [] = error "Id.lookupId: corrupted symbol table"
insertName :: Int -> String -> Names -> (Id, Names)
insertName srt name names
= let (x, names') = insertName' name names
in (setNameSpace srt x, names')
insertName' :: String -> Names -> (Id,Names)
insertName' name (Names fresh m)
| idx > maxIdx = error ("Id.insertName: too many names with the same hash value (" ++ show name ++ ")")
| otherwise = (Id (initIdx idx h), Names fresh m1)
where
hname = hash name
h = initHash hname
(old, m1) = IntMap.insertLookupWithKey upd (fromIntegral hname) [name] m
(idx, new) = maybe (0, [name]) (insertIdx name) old
upd _ _ _ = new
-- [insertIdx] returns the index of an element if it exists already, or
-- appends the element and returns its index.
insertIdx :: Eq a => a -> [a] -> (Int32,[a])
insertIdx y = walk 0
where
walk idx [] = (idx,[y])
walk idx xs@(x:xx) | x == y = (idx,xs)
| otherwise = let (idx',xx') = walk (idx+1) xx
in (idx',x:xx')
----------------------------------------------------------------
-- Hashing
----------------------------------------------------------------
hash :: String -> Int32
hash name
= (hashx name `mod` prime) `mod` maxHash
where
prime = 32537 --65599 -- require: prime < maxHash
-- simple hash function that performs quite good in practice
hashx :: String -> Int32
hashx = foldl' gobble 0
where
gobble n c = n*65599 + fromIntegral (fromEnum c)
-----------------------------------------------------------------------------
{-
import Bits
import Word
-- the [hashpjw] algorithm, see dragon book, section 7.6, page 436.
hashpjw :: String -> Int
hashpjw name
= word32ToInt (foldlStrict gobble (intToWord32 0) name)
where
gobble n c = let h = (shiftL n 4) + intToWord32 (fromEnum c)
high = shiftR h 24
g = shiftL high 24
in if (g /= 0)
then xor (xor h high) g
else h
-}
{-
primes xs = case xs of
[] -> []
(x:xx) -> x:primes (filter ((/=0).(`mod`x)) xx)
-}
{-
,32537,32561,32563,32569,32573,32579,32587,32603,32609,32611,32621,32633,32647,3
2653,32687,32693,32707,32713,32717,32719,32749,32771,32779,32783,32789,32797,328
01,32803,32831,32833,32839,32843,32869,32887,32909,32911,32917,32933,32939,32941
,32957,32969,32971,32983,32987,32993,32999,33013,33023,33029,33037,33049,33053,3
3071,33073,33083,33091,33107,33113,33119,33149,33151,33161,33179,33181,33191,331
99,33203,33211,33223,33247,33287,33289,33301,33311,33317,33329,33331,33343,33347
,33349,33353,33359,33377,33391,33403,33409,33413,33427,33457,33461,33469,33479,3
3487,33493,33503,33521,33529,33533,33547,33563,33569,33577,33581,33587,33589,335
99,33601,33613,33617,33619,33623,33629,33637,33641,33647,33679,33703,33713,33721
,50891,50893,50909,50923,50929,50951,50957,50969,50971,50989,50993,51001,51031,5
1043,51047,51059,51061,51071,51109,51131,51133,51137,51151,51157,51169,51193,511
97,51199,51203,51217,51229,51239,51241,51257,51263,51283,51287,51307,51329,51341
,51343,51347,51349,51361,51383,51407,51413,51419,51421,51427,51431,51437,51439,5
1449,51461,51473,51479,51481,51487,51503,51511,51517,51521,51539,51551,51563,515
77,51581,51593,51599,51607,51613,51631,51637,51647,51659,51673,51679,51683,51691
,51713,51719,51721,51749,51767,51769,51787,51797,51803,51817,51827,51829,51839,5
1853,51859,51869,51871,51893,51899,51907,51913,51929,51941,51949,51971,51973,519
77,51991,52009,52021,52027
-}