--------------------------------------------------------------------------------
-- 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$

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
-}