- commit
- f53af09
- parent
- 2d5d6bb
- author
- Evgenii Akentev
- date
- 2024-09-16 19:04:13 +0400 +04
Use Data.Array
2 files changed,
+42,
-43
+1,
-3
1@@ -18,8 +18,6 @@ common warnings
2 library
3 import: warnings
4 exposed-modules: MarkSweep.Basic, Mutator
5- -- other-modules:
6- -- other-extensions:
7- build-depends: base ^>=4.18.2.1, mtl
8+ build-depends: base ^>=4.18.2.1, mtl, array
9 hs-source-dirs: src
10 default-language: Haskell2010
+41,
-40
1@@ -4,6 +4,8 @@
2
3 module MarkSweep.Basic where
4
5+
6+import Data.Array
7 import Control.Monad.State
8 import Control.Monad.Identity
9 import Mutator
10@@ -22,97 +24,96 @@ instance Mutator GcM where
11 readFromRoots :: Int -> GcM ObjectPtr
12 readFromRoots i = do
13 GCState{roots} <- get
14- return $ roots !! i
15+ return $ roots ! i
16
17 readFromObject :: ObjectPtr -> GcM Value
18+ readFromObject NullPtr = error "Null pointer"
19 readFromObject (ObjectPtr i) = do
20 GCState{heap} <- get
21- case heap !! i of
22+ case heap ! i of
23 Just o -> pure $ val o
24 Nothing -> error "Incorrect pointer"
25
26 readFromField :: Int -> ObjectPtr -> GcM ObjectPtr
27+ readFromField _ NullPtr = error "Null pointer"
28 readFromField f (ObjectPtr i) = do
29 GCState{heap} <- get
30- case heap !! i of
31- Just o -> pure $ (fields o) !! f
32+ case heap ! i of
33+ Just o -> pure $ (fields o) ! f
34 Nothing -> error "Incorrect pointer"
35
36 writeToRoots :: Int -> ObjectPtr -> GcM ()
37 writeToRoots i ptr = do
38 s@GCState{roots} <- get
39- case splitAt i roots of
40- ([], []) -> put $ s { roots = [ptr] }
41- (before, _:after) -> put $ s { roots = before ++ [ptr] ++ after }
42+ put $ s { roots = roots // [(i, ptr)] }
43
44 writeToObject :: Value -> ObjectPtr -> GcM ()
45+ writeToObject _ NullPtr = error "Null pointer"
46 writeToObject v (ObjectPtr i) = do
47 s@GCState{heap} <- get
48- let (before, o:after) = splitAt i heap
49- case o of
50+ case heap ! i of
51 Nothing -> error "Object is null"
52 Just obj ->
53- put $ s { heap = before ++ [Just $ obj { val = v } ] ++ after }
54+ put $ s { heap = heap // [(i, Just $ obj { val = v })] }
55
56 writeToField :: Int -> ObjectPtr -> ObjectPtr -> GcM ()
57+ writeToField _ _ NullPtr = error "Null pointer"
58 writeToField i ptr (ObjectPtr p) = do
59 s@GCState{heap} <- get
60- let (before, o:after) = splitAt p heap
61- case o of
62+ case heap ! p of
63 Nothing -> error "Object is null"
64 Just obj -> do
65- let (fBefore, _:fAfter) = splitAt i $ fields obj
66- put $ s { heap = (before ++ [Just $ obj { fields = fBefore ++ [ptr] ++ fAfter } ] ++ after) }
67+ put $ s { heap = heap // [(p, Just $ obj { fields = fields obj // [(i, ptr)] })] }
68
69 data Object = Object {
70 val :: Value,
71- fields :: [ObjectPtr],
72+ fields :: Array Int ObjectPtr,
73 marked :: Bool
74 } deriving (Eq, Show)
75
76 data GCState = GCState {
77- roots :: [ObjectPtr],
78+ roots :: Array Int ObjectPtr,
79 heap :: Heap
80 } deriving (Eq,Show)
81
82-type Heap = [Maybe Object]
83+type Heap = Array Int (Maybe Object)
84
85 initState :: GCState
86-initState = GCState [] [Nothing | _ <- [1 :: Int ..8]]
87+initState = GCState
88+ { roots = array (1, 8) [(i, NullPtr) | i <- [1..8]]
89+ , heap = array (1, 8) [(i, Nothing) | i <- [1 :: Int ..8]]
90+ }
91
92 newtype GcM a = GcM { unGcM :: StateT GCState Identity a }
93 deriving (Functor, Applicative, Monad, MonadState GCState)
94
95 isMarked :: ObjectPtr -> Heap -> Bool
96 isMarked NullPtr _ = False
97-isMarked (ObjectPtr p) h = Just True == (marked <$> (h !! p))
98+isMarked (ObjectPtr p) h = Just True == (marked <$> (h ! p))
99
100 setMarked :: ObjectPtr -> Heap -> Heap
101 setMarked NullPtr h = h
102-setMarked (ObjectPtr p) hs = reverse $ foldl step [] $ zip [0..] hs
103- where
104- step res (_, Nothing) = Nothing : res
105- step res (idx, Just obj)
106- | p == idx = (Just $ obj { marked = True }) : res
107- | otherwise = (Just obj) : res
108+setMarked (ObjectPtr p) hs = hs // [(p, (\o -> o { marked = True }) <$> (hs ! p)) ]
109
110 allocate :: Value -> GcM (Either String ObjectPtr)
111 allocate v = do
112 s@GCState{heap} <- get
113- case foldl step (False, -1, []) heap of
114- (True, idx, res) -> do
115- put $ s { heap = reverse res}
116- pure $ Right $ ObjectPtr idx
117- _ -> pure $ Left "Out of memory"
118- where
119- step (True, idx, res) obj = (True, idx, obj : res)
120- step (_, idx, res) Nothing = (True, idx + 1, (Just $ Object v [] False) : res)
121- step (ok, idx, res) obj = (ok, idx + 1, obj : res)
122+ case findIndexWithNothing heap of
123+ Just p -> do
124+ put $ s { heap = heap // [(p, Just $ Object v (array (1,8) [(i, NullPtr) | i <- [1..8]]) False)] }
125+ pure $ Right $ ObjectPtr p
126+ Nothing -> pure $ Left "Out of memory"
127+ where
128+ findIndexWithNothing h = foldl step Nothing $ assocs h
129+ step _ (i, Nothing) = Just i
130+ step acc _ = acc
131
132 mark :: [ObjectPtr] -> Heap -> Heap
133 mark [] h = h
134-mark ((ObjectPtr p):rest) h = case h !! p of
135- Just obj ->
136+mark (ptr:rest) h
137+ | (ObjectPtr p) <- ptr
138+ , Just obj <- h ! p
139+ =
140 let
141 step acc NullPtr = acc
142 step (wl, heap) child
143@@ -121,7 +122,7 @@ mark ((ObjectPtr p):rest) h = case h !! p of
144
145 (workList, newH) = foldl step ([], h) $ fields obj
146 in mark (workList ++ rest) newH
147- Nothing -> mark rest h
148+ | otherwise = mark rest h
149
150 markFromRoots :: GcM ()
151 markFromRoots = do
152@@ -130,7 +131,7 @@ markFromRoots = do
153 put $ GCState roots newHeap
154 where
155 step heap ptr
156- | not (isMarked ptr heap) =
157+ | ptr /= NullPtr && not (isMarked ptr heap) =
158 let newH = setMarked ptr heap
159 in mark [ptr] newH
160 step heap _ = heap
161@@ -143,7 +144,7 @@ collect = do
162 sweep :: GcM ()
163 sweep = do
164 s@GCState{heap} <- get
165- put $ s { heap = map step heap }
166+ put $ s { heap = fmap step heap }
167 where
168 step Nothing = Nothing
169 step (Just o) = if marked o then Just (o { marked = False }) else Nothing
170@@ -155,7 +156,7 @@ main = do
171 ptr <- new (IntVal 3)
172 ptr2 <- new (IntVal 5)
173
174- writeToRoots 0 ptr
175+ writeToRoots 1 ptr
176
177 collect
178 return [ptr, ptr2]