ghc/tests/programs/jeff-bug/AQ.hs

   1 -- Addressable Queues --
   2 module AQ where
   3 import LazyST
   4 import Utils
   5
   6 import Hawk
   7
   8 type AQ s a  = (STArray s Int (Maybe a), Front s,Back s,QSize s,Int)
   9 type Front s = STRef s Int
  10 type Back s  = STRef s Int
  11 type QSize s = STRef s Int
  12 type QAddr   = Int
  13
  14
  15 new          :: Int ->  ST s (AQ s a)
  16 enQueue      :: AQ s a -> a -> ST s QAddr
  17 deQueue      :: AQ s a ->  ST s (a,QAddr)
  18 reQueue      :: AQ s a -> a ->  ST s QAddr
  19 getSize      :: AQ s a ->  ST s Int
  20 getMax       :: AQ s a ->  ST s Int
  21 deQueueWhile :: AQ s a -> (a -> Bool) ->  ST s [a]
  22 enList       :: AQ s a -> [a] -> ST s [QAddr]
  23 update       :: AQ s a -> QAddr -> (a -> a) -> ST s ()
  24 clear        :: AQ s a ->  ST s ()
  25 space        :: AQ s a -> ST s Int
  26
  27 ------------------------------------------------------------------------------
  28
  29 assertM True _ = return ()
  30 assertM False s = error $ s  ++ "\n"
  31
  32 insert x y z = setQVal x y (Just z)
  33
  34 new n
  35   = do { q <- newSTArray (0,n) Nothing
  36        ; f <- newSTRef (-1)
  37        ; b <- newSTRef 0
  38        ; s <- newSTRef 0
  39        ; return (q,f,b,s,n)
  40        }
  41
  42 clear (q,f,b,s,n)
  43   = do { mapM (\x -> writeSTArray q x Nothing) [0 .. n]
  44        ; writeSTRef f (-1)
  45        ; writeSTRef b 0
  46        ; writeSTRef s 0
  47        }
  48
  49 enQueue q elem
  50   = do { sz <- getSize q
  51        ; max <- getMax q
  52        ; () <- assertM (sz < max) "enQueue over max"
  53        ; f <- getFront q
  54        ; let f' = (f+1) `mod` max
  55        ; setQVal q f' (Just elem)
  56        ; setSize q (sz+1)
  57        ; setFront q f'
  58        ; return f'
  59        }
  60
  61 reQueue q elem
  62   = do { sz <- getSize q
  63        ; max <- getMax q
  64        ; assertM (sz < max) "reQueue over max"
  65        ; b <- getBack q
  66        ; let b' = (b-1) `mod` max
  67        ; setQVal q b' (Just elem)
  68        ; setSize q (sz+1)
  69        ; setBack q b'
  70        ; return b'
  71        }
  72
  73 deQueue q
  74   = do { sz <- getSize q
  75        ; max <- getMax q
  76        ; assertM (sz > 0) "deQueue under min"
  77        ; b <- getBack q
  78        ; mj <- getQVal q b
  79        ; let j = mj `catchEx` error "deQueue"
  80        ; setSize q (sz-1)
  81        ; setBack q $ (b+1) `mod` max
  82        ; return (j,b)
  83        }
  84
  85 space q
  86   = do { sz <- getSize q
  87        ; m  <- getMax q
  88        ; return $ m - sz
  89        }
  90
  91 deQueueWhile q f
  92   = do { sz <- getSize q
  93        ; if (sz < 1)
  94            then return []
  95            else do { (elem,addr) <- deQueue q
  96                    ; if (f elem)
  97                        then do { elems <- deQueueWhile q f
  98                                ; return (elem:elems)
  99                                }
 100                        else do { reQueue q elem
 101                                ; return []
 102                                }
 103                    }
 104        }
 105
 106
 107
 108 enList q [] = return []
 109 enList q (x:xs)
 110   = do { sz <- space q
 111        ; if (sz > 0)
 112            then do { a <- enQueue q x
 113                    ; l <- enList q xs
 114                    ; return $ a:l
 115                    }
 116            else return []
 117        }
 118
 119 assignAddrs q l
 120   = do { let len = length l
 121        ; sz <- space q
 122        ; max <- getMax q
 123        ; assertM (sz >= len) "sz < len"
 124        ; f <- getFront q
 125        ; let f' = f+1
 126        ; let addrs = map (`mod` max) [f' .. f'+len]
 127        ; return $ zip l addrs
 128        }
 129
 130 assignAddr q x
 131   = do { ans <- assignAddrs q [x]
 132        ; return $ head ans
 133        }
 134
 135 iterateQueue q f
 136   = do { front <- getFront q
 137        ; back <- getBack q
 138        ; max <- getMax q
 139        ; updateWhile q front front back max f
 140        }
 141   where updateWhile q front n back max f
 142           | n == back = return ()
 143           | otherwise = do { val <- getQVal q n
 144                            ; val <- case val of
 145                                        Just x -> return $ Just $ f x
 146                                        Nothing -> return Nothing
 147                            ; setQVal q n val
 148                            ; updateWhile q front ((n+1) `mod` max) back max f
 149                            }
 150
 151 update q n f
 152   = do { x <- getQVal q n
 153        ; setQVal q n $ fmap f x
 154        }
 155
 156 -------------------------------------------------------------------------
 157
 158 getSize  (q,f,b,s,m)     = readSTRef s
 159 setSize  (q,f,b,s,m) v   = writeSTRef s v
 160 getMax   (q,f,b,s,m)     = return m
 161 getFront (q,f,b,s,m)     = readSTRef f
 162 setFront (q,f,b,s,m) v   = writeSTRef f v
 163 getBack  (q,f,b,s,m)     = readSTRef b
 164 setBack  (q,f,b,s,m) v   = writeSTRef b v
 165 getQVal  (q,f,b,s,m) n   = readSTArray q n
 166 setQVal  (q,f,b,s,m) n e = writeSTArray q n e
 167