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

   1 module StateArray ( stateArray,updateArray) where
   2
   3 import List
   4 import Signal
   5 import LazyST
   6
   7 import Array
   8 import Memory
   9 import Words
  10 import Array
  11 import Memory
  12 import Signal
  13 import LazyST
  14 import Words
  15 import Memory
  16
  17 {-
  18   these functions accept vectors of Array requests (reads or writes)
  19   and services them.
  20 -}
  21
  22 stateArray :: (Ix a, Enum a) => ((a,a),[(a,a,b)]) ->
  23               Signal [ArrReq a b] -> Signal [ArrResp a b]
  24
  25 updateArray :: Ix a => Signal (Array a b) ->
  26                        [(Signal Bool,(Signal a,Signal b))] ->
  27                        Signal (Array a b)
  28
  29
  30 -- BEWARE --- unless you're really digging deep into the
  31 -- library you've probably made a wrong turn.
  32 -- Unless you know what you're doing dont be here.
  33
  34
  35 stateArray (bounds@(loBound,hiBound),initWrites) input =
  36     runST (
  37             do arr <- newSTArray bounds initVal
  38                initArray arr
  39                loop (input) $ \input -> performRequests arr input
  40           )
  41       where
  42       -- Determine what the array should be initialized to; remove
  43       --  some of the writes that would initialize the array to the
  44       --  same value to speed up the initialization process.
  45       contigWrites = contigWriteRanges
  46                       (loBound,hiBound,
  47                        error "uninitialized value read from stateArray")
  48                       initWrites
  49       maxRange@(_,_,initVal) = maxWriteRange contigWrites
  50       reducedInitWrites = removeWriteRange maxRange contigWrites
  51
  52
  53       -- Initialize the array according to 'initWrites'
  54       initArray arr
  55         = strictSequence [ writeSTArray arr index val |
  56                                 (lowIdx,hiIdx,val) <- reducedInitWrites,
  57                                 index <- range (lowIdx,hiIdx) ]
  58
  59    -- Perform the requested writes, reads, and freezes for each clock cycle
  60 performRequests arr reqs = performReqs reqs
  61           where
  62             performReqs reqs
  63               = mapM performReq reqs
  64
  65             performReq (ReadArr i)
  66               = do val <- readSTArray arr i
  67                    return (ReadVal val)
  68
  69             performReq (WriteArr loAddr hiAddr val)
  70               = do sequence [ writeSTArray arr loc val |
  71                                 loc <- range (loAddr,hiAddr) ]
  72                    return Written
  73
  74             performReq (WriteFn loc f)
  75               = do readVal <- readSTArray arr loc
  76                    let writeVal = f readVal
  77                    writeSTArray arr loc writeVal
  78                    return (WrittenFn writeVal)
  79
  80             performReq FreezeArr
  81               = do arr <- freezeSTArray arr
  82                    return (ArrayVal arr)
  83
  84 -- Forces each action in its argument list by pattern-matching
  85 --  on the action's output unit. This function is useful in preventing
  86 --  large sequences of actions from being built.
  87 strictSequence :: Monad m => [m ()] -> m ()
  88 strictSequence = foldr (\m n -> do { () <- m; n }) (return ())
  89
  90 {-
  91         The following functions dealing with write-ranges are
  92         needed because the hugs interpreter is very slow in evaluating
  93         lazy monadic expressions involving lots of writes to a MutArr.
  94         Even simple programs output by dlxgcc ask to have about 16K-words
  95         of data to be initialized to zero, while other areas of memory
  96         should be initialized to an error value. These routines
  97         allow me to isolate what the majority of array locations should
  98         be initialized to; I can pass this initialization value to
  99         newArr (which is implemented as a primitive) to avoid most
 100         of the initial writes.
 101 -}
 102
 103 -- Given a write-range and a list of contiguous sorted write ranges,
 104 --  this function outputs a contiguous sorted write range that would
 105 --  result when the first write range is written to an array after the other
 106 --  write ranges are written to an array. Note that the write-range to
 107 --  be inserted must overlap or be contiguous to the write-range list.
 108 insertWrite :: (Ix i,Enum i) => (i,i,a) -> [(i,i,a)] -> [(i,i,a)]
 109 insertWrite writeRange []
 110   = [writeRange]
 111 insertWrite writeRange@(lo,hi,v) (first@(firstLo,firstHi,firstVal):rest)
 112   -- empty writeRange
 113   | hi < lo                     = first : rest
 114   -- writeRange is completely less than first element
 115   | hi < firstLo                = writeRange : first : rest
 116   -- writeRange is completely greater than first element
 117   | firstHi < lo                = first : insertWrite writeRange rest
 118   -- writeRange completely overlaps the first element
 119   | lo <= firstLo && hi >= firstHi = insertWrite writeRange rest
 120   -- writeRange partially overlaps the first element; the leading
 121   --  edge of writeRange is less than or equal to the leading edge
 122   --  of the first element.
 123   | lo <= firstLo               = writeRange : (succ hi,firstHi,firstVal) : rest
 124   -- writeRange partially overlaps the first element; the leading
 125   --  edge of writeRange is greater than the leading edge of the
 126   --  first element.
 127   | firstLo < lo                = (firstLo,pred lo,firstVal) : insertWrite writeRange ((lo,firstHi,firstVal):rest)
 128   | True                        = error "bug in insertWrite"
 129
 130
 131 -- Given a write range 'writeRange' and a list of write-ranges 'ranges' whose
 132 --  elements are subranges of 'writeRange', this function outputs a contiguous,
 133 --  non-overlapping list of write-ranges that is equivalent to writing
 134 --  'writeRange' to an array, followed by writing the elements of 'ranges'
 135 --  in order to the same array.
 136 contigWriteRanges :: (Ix i,Enum i) => (i,i,a) -> [(i,i,a)] -> [(i,i,a)]
 137 contigWriteRanges writeRange ranges
 138   = foldr insertWrite [writeRange] (reverse ranges)
 139
 140
 141 -- Finds the largest write-range in a list of write-ranges.
 142 maxWriteRange :: (Ix i,Enum i) => [(i,i,a)] -> (i,i,a)
 143 maxWriteRange
 144   = foldr1 (\a@(loA,hiA,_) b@(loB,hiB,_) ->
 145                 if rangeSize (loA,hiA) >= rangeSize (loB,hiB)
 146                   then a
 147                   else b)
 148
 149 -- removes a given write-range from a list of write-ranges
 150 removeWriteRange :: (Ix i,Enum i) => (i,i,a) -> [(i,i,a)] -> [(i,i,a)]
 151 removeWriteRange (lo,hi,_) = filter (\(loA,hiA,_) -> lo /= loA || hi /= hiA)
 152
 153
 154
 155 --  Updates an array Signal, given a static list of updaters. Each
 156 --  updater consists of a Boolean enable signal, and a signal pair
 157 --  of the update address and update value.
 158 updateArray arr updaters
 159   = foldr (\(updateEnable,updater) prevArray ->
 160                 if' updateEnable
 161                    then' (lift2 (//) prevArray (singleton (bundle2 updater)))
 162                    else' prevArray
 163           )
 164           arr
 165           updaters
 166     where singleton = lift1 $ \x -> [x]
 167
 168