Store.hs 6.79 KB
Newer Older
1
2
{-# LANGUAGE DeriveDataTypeable #-}

3
module Curry.RunTimeSystem.Store
bbr's avatar
bbr committed
4
  (Store,
bbr's avatar
bbr committed
5
  
6
   emptyStore,changeStore, storeSize,
bbr's avatar
bbr committed
7
8


bbr's avatar
bbr committed
9
   OrRef,OrRefKind(..),
bbr's avatar
bbr committed
10
   deref,genInfo,cover,uncover,mkRef,isCovered,
bbr's avatar
bbr committed
11
   manipulateStore,
bbr's avatar
bbr committed
12

13
   mkRefWithGenInfo,equalFromTo,
bbr's avatar
bbr committed
14
   
bbr's avatar
bbr committed
15
   isGenerator, isConstr,updRef, 
16

bbr's avatar
bbr committed
17

18
19
   narrowOrRef
   ) where
bbr's avatar
bbr committed
20

21
import Data.Generics (Data,Typeable)
bbr's avatar
bbr committed
22
23
24
25
import Data.IntMap
import Prelude hiding (lookup)
import System.IO.Unsafe

bbr's avatar
bbr committed
26
trace s x = unsafePerformIO (putStrLn s >> return x) 
bbr's avatar
bbr committed
27
trace' x = trace (show x) x
bbr's avatar
bbr committed
28

bbr's avatar
bbr committed
29
30
31
32
----------------------------
-- or references
----------------------------

bbr's avatar
bbr committed
33
data OrRefKind = Generator Int Int | Narrowed Int Int | NoGenerator
34
                 deriving (Data,Typeable,Eq,Ord,Show,Read)
35

36
37
38
39
40
minMax :: OrRefKind -> (Int->Entry,Maybe (Int,Int))
minMax NoGenerator     = (Choice,Nothing)
minMax (Generator a b) = (Binding a b,Just (a,b))
minMax (Narrowed a b)  = (Binding a b,Just (a,b))

41
data OrRef = OrRef OrRefKind Int 
bbr's avatar
bbr committed
42
           | Layer OrRef 
43
           | Equality Int Int Int Int Int Int deriving (Data,Typeable,Eq,Ord,Show,Read)
bbr's avatar
bbr committed
44
45
46

uncover :: OrRef -> OrRef
uncover (Layer x)   = x
bbr's avatar
bbr committed
47
uncover x           = x
bbr's avatar
bbr committed
48

bbr's avatar
bbr committed
49
-- constructors
bbr's avatar
bbr committed
50
51
52
cover :: OrRef -> OrRef
cover = Layer

bbr's avatar
bbr committed
53
mkRef :: Int -> Int -> Int -> OrRef
bbr's avatar
bbr committed
54
mkRef i j = OrRef (Generator i (i+j-1))
55
56
57
58
59

mkRefWithGenInfo :: OrRefKind -> Int -> OrRef
mkRefWithGenInfo = OrRef

-- selectors
bbr's avatar
bbr committed
60
deref :: OrRef -> Int
bbr's avatar
bbr committed
61
62
deref r = case uncover r of
  OrRef _ i -> i
bbr's avatar
bbr committed
63
  _         -> (-42)
bbr's avatar
bbr committed
64
  
bbr's avatar
bbr committed
65
66
67
genInfo :: OrRef -> (Int,Int,Int)
genInfo r = case uncover r of
  OrRef (Generator i j) k -> (i,j,k)
bbr's avatar
bbr committed
68

bbr's avatar
bbr committed
69
70
--refKind :: OrRef -> OrRefKind
--refKind r = (\ (OrRef x _) -> x) (uncover r)
bbr's avatar
bbr committed
71

72
-- tester
bbr's avatar
bbr committed
73
isCovered :: OrRef -> Bool
74
isCovered (Layer _)   = True
bbr's avatar
bbr committed
75
isCovered _           = False
76
77

isGenerator :: OrRef -> Bool
bbr's avatar
bbr committed
78
isGenerator r = case uncover r of
bbr's avatar
bbr committed
79
80
  OrRef (Generator _ _) _ -> True
  _                       -> False
81
82
83


--operations
Bernd Brassel's avatar
Bernd Brassel committed
84
85
86
updKind :: (OrRefKind -> OrRefKind) -> OrRef -> OrRef
updKind f (Layer r)   = Layer (updKind f r)
updKind f (OrRef k i) = OrRef (f k) i
bbr's avatar
bbr committed
87
updKind f c@(Equality _ _ _ _ _ _) = c
88

bbr's avatar
bbr committed
89
90
91
92
93
94
updRef :: (Int -> Int) -> OrRef -> OrRef
updRef f (Layer r)   = Layer (updRef f r)
updRef f (OrRef k i) = OrRef k (f i)
updRef f c@(Equality _ _ _ _ _ _) = c


bbr's avatar
bbr committed
95
96
narrowOrRef :: OrRef -> OrRef
narrowOrRef = updKind narrow
bbr's avatar
bbr committed
97
98
99
100
101
  where 
    narrow o@NoGenerator    = o
    narrow o@(Narrowed _ _)= o
    narrow (Generator i j) = Narrowed i j

bbr's avatar
bbr committed
102

bbr's avatar
bbr committed
103
104
equalFromTo :: Int -> Int -> Int -> Int -> Int -> Int -> OrRef 
equalFromTo = Equality
bbr's avatar
bbr committed
105

bbr's avatar
bbr committed
106
107
108
isConstr :: OrRef -> Bool
isConstr (Equality _ _ _ _ _ _)  = True
isConstr _                       = False
bbr's avatar
bbr committed
109

bbr's avatar
bbr committed
110
-------------------------------------------------------
bbr's avatar
bbr committed
111
-- finally: the store
bbr's avatar
bbr committed
112
113
114
-------------------------------------------------------
-- negative numbers are references to other variables
-------------------------------------------------------
bbr's avatar
bbr committed
115

bbr's avatar
bbr committed
116
117
118
119
data Entry = Equal Int
           | Choice Int
           | Binding Int Int Int deriving (Eq,Ord,Show)

120
121
122
choice :: Entry -> Int
choice (Choice i) = i
choice (Binding _ _ i) = i
bbr's avatar
bbr committed
123

124
newtype Store = Store (IntMap Entry) deriving (Eq,Ord,Show)
bbr's avatar
bbr committed
125

126
127
emptyStore :: Store
emptyStore = Store empty 
bbr's avatar
bbr committed
128

129
data StoreResult = Inconsistent
130
                 | NoBinding OrRef (Int -> Store)
131
                 | Found Int
132
133
                 | NewInfo OrRef Store 
                 | FoundAndNewInfo Int OrRef Store 
134

135

bbr's avatar
bbr committed
136
137
138
139
140
141
142
instance Show StoreResult where
  show Inconsistent = "I"
  show (NoBinding i _) = "no"++show i
  show (Found i) = "f "++show i
  show (NewInfo r st) = "n"++show (r,st)
  show (FoundAndNewInfo i r st) = "fn"++show (i,r,st)

143
144
145
changeStore :: OrRef -> Store -> StoreResult
changeStore r st = 
  case uncover r of
146
147
148
149
150
151
    ref@(OrRef k r) -> let (toEntry,mima) = minMax k in
                 access (\ i -> updRef (\_->i) ref) 
                        toEntry 
                        (mima >>= \ (i,j) -> Just (i,j,r)) 
                        r 
                        st
152
153
154
155
156
157
    eq        -> chainInStore eq st
    
chainInStore :: OrRef -> Store -> StoreResult
chainInStore r@(Equality fromMin fromMax from toMin toMax to) = 
   maybe Inconsistent (NewInfo r) .
   foldChain (from:[fromMin .. fromMax]) (to:[toMin .. toMax])
bbr's avatar
bbr committed
158
159

 
160
161
foldChain :: [Int] -> [Int] -> Store -> Maybe Store
foldChain xs@(x:_) ys@(y:_) st = foldl (>>=) (Just st) $
162
163
164
165
  case compare x y of
    EQ -> [Just]
    LT -> zipWith insertChain xs ys
    GT -> zipWith insertChain ys xs
166
167
168

---------------------------------------------------------------
-- insert a chain, i.e. one variable referring to another
169
170
-- for future work:
-- result should have shortest chains and maximal entries
171
-- implement occur check along the line
172
173
---------------------------------------------------------------

174
insertChain :: Int -> Int -> Store -> Maybe Store
175
insertChain key val st@(Store store) = 
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
  case lookup key store of
    Nothing        -> Just (Store (insert key (Equal val) store))
    Just (Equal i) -> case compare i val of
                        EQ -> Just st
                        LT -> insertChain i val st
                        GT -> insertChain val i st
    Just e         -> insertEntry val e st


insertEntry :: Int -> Entry -> Store -> Maybe Store
insertEntry key e st@(Store store) = case lookup key store of
  Nothing -> Just (Store (insert key e store))
  Just (Equal key') -> insertEntry key' e st
  Just e' -> if   choice e==choice e' 
             then Just st
             else Nothing

---------------------------------------------------------------
-- access a reference, i.e. give back entry or insert function 
-- for future work:
-- result should have shortest chains and maximal entries
---------------------------------------------------------------

199
200
201
202
access :: (Int->OrRef) -> (Int->Entry) -> Maybe (Int,Int,Int) -> Int -> Store -> StoreResult
access toOrRef toEntry mima key st@(Store store) = case lookup key store of
  Nothing -> NoBinding (toOrRef key) (\ i -> Store (insert key (toEntry i) store))
  Just (Equal key') -> access toOrRef toEntry mima key' st
203
204
205
  Just (Choice i)   -> Found i
  Just (Binding bmin bmax i) -> case mima of
    Nothing               -> Found i
bbr's avatar
bbr committed
206
    Just (amin,amax,key0) -> case compare amin bmin of
bbr's avatar
bbr committed
207
208
      EQ -> Found i
      _  -> let info = Equality amin amax key0 bmin bmax key in
209
            maybe Inconsistent (FoundAndNewInfo i info) $
bbr's avatar
bbr committed
210
            foldChain [amin .. amax] [bmin .. bmax] st        
211

bbr's avatar
bbr committed
212
                                 
213
storeSize :: Store -> Int
bbr's avatar
bbr committed
214
215
216
storeSize (Store st) = size st


217
-- this is the way to access store from outside
bbr's avatar
bbr committed
218
manipulateStore :: a -> (b -> Store -> a) 
219
220
                     -> (OrRef -> (Int -> Store) -> a)
                     -> (OrRef -> b -> Store -> a)
bbr's avatar
bbr committed
221
222
223
224
225
226
                     -> OrRef -> [b] -> Store -> a
manipulateStore err det br new ref bs st = case changeStore ref st of
  Inconsistent             -> err
  Found i                  -> det (bs!!i) st
  NoBinding i contSt       -> br i contSt
  NewInfo ref st           -> new ref (head bs) st
227
  FoundAndNewInfo i ref st -> new ref (bs!!i)   st