1 module StateArray ( stateArray,updateArray) where
18 these functions accept vectors of Array requests (reads or writes)
22 stateArray :: (Ix a, Enum a) => ((a,a),[(a,a,b)]) ->
23 Signal [ArrReq a b] -> Signal [ArrResp a b]
25 updateArray :: Ix a => Signal (Array a b) ->
26 [(Signal Bool,(Signal a,Signal b))] ->
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.
35 stateArray (bounds@(loBound,hiBound),initWrites) input =
37 do arr <- newSTArray bounds initVal
39 loop (input) $ \input -> performRequests arr input
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
47 error "uninitialized value read from stateArray")
49 maxRange@(_,_,initVal) = maxWriteRange contigWrites
50 reducedInitWrites = removeWriteRange maxRange contigWrites
53 -- Initialize the array according to 'initWrites'
55 = strictSequence [ writeSTArray arr index val |
56 (lowIdx,hiIdx,val) <- reducedInitWrites,
57 index <- range (lowIdx,hiIdx) ]
59 -- Perform the requested writes, reads, and freezes for each clock cycle
60 performRequests arr reqs = performReqs reqs
63 = mapM performReq reqs
65 performReq (ReadArr i)
66 = do val <- readSTArray arr i
69 performReq (WriteArr loAddr hiAddr val)
70 = do sequence [ writeSTArray arr loc val |
71 loc <- range (loAddr,hiAddr) ]
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)
81 = do arr <- freezeSTArray arr
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 ())
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.
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 []
111 insertWrite writeRange@(lo,hi,v) (first@(firstLo,firstHi,firstVal):rest)
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
127 | firstLo < lo = (firstLo,pred lo,firstVal) : insertWrite writeRange ((lo,firstHi,firstVal):rest)
128 | True = error "bug in insertWrite"
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)
141 -- Finds the largest write-range in a list of write-ranges.
142 maxWriteRange :: (Ix i,Enum i) => [(i,i,a)] -> (i,i,a)
144 = foldr1 (\a@(loA,hiA,_) b@(loB,hiB,_) ->
145 if rangeSize (loA,hiA) >= rangeSize (loB,hiB)
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)
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 ->
161 then' (lift2 (//) prevArray (singleton (bundle2 updater)))
166 where singleton = lift1 $ \x -> [x]