Evgenii Akentev
·
2024-09-17
TwoFinger.hs
1{-# language ImportQualifiedPost, InstanceSigs, DuplicateRecordFields
2 , LambdaCase, RecordWildCards, NamedFieldPuns, TypeSynonymInstances
3 , DerivingStrategies, GeneralizedNewtypeDeriving #-}
4
5module MarkCompact.TwoFinger where
6
7import Debug.Trace
8import Data.Ord (Down(..))
9import Data.List
10import Data.Function (on)
11import Data.Array
12import Control.Monad.State
13import Control.Monad.Identity
14import Mutator
15
16instance Mutator GcM where
17 new :: Value -> GcM ObjectPtr
18 new v = do
19 allocate v >>= \case
20 Right ptr -> pure ptr
21 _ -> do
22 collect
23 allocate v >>= \case
24 Right ptr -> pure ptr
25 Left s -> error s
26
27 readFromRoots :: Int -> GcM ObjectPtr
28 readFromRoots i = do
29 GCState{roots} <- get
30 return $ roots ! i
31
32 readFromObject :: ObjectPtr -> GcM Value
33 readFromObject NullPtr = error "Null pointer"
34 readFromObject (ObjectPtr i) = do
35 GCState{heap} <- get
36 case heap ! i of
37 Just o -> pure $ val o
38 Nothing -> error "Incorrect pointer"
39
40 readFromField :: Int -> ObjectPtr -> GcM ObjectPtr
41 readFromField _ NullPtr = error "Null pointer"
42 readFromField f (ObjectPtr i) = do
43 GCState{heap} <- get
44 case heap ! i of
45 Just o -> pure $ (fields o) ! f
46 Nothing -> error "Incorrect pointer"
47
48 writeToRoots :: Int -> ObjectPtr -> GcM ()
49 writeToRoots i ptr = do
50 s@GCState{roots} <- get
51 put $ s { roots = roots // [(i, ptr)] }
52
53 writeToObject :: Value -> ObjectPtr -> GcM ()
54 writeToObject _ NullPtr = error "Null pointer"
55 writeToObject v (ObjectPtr i) = do
56 s@GCState{heap} <- get
57 case heap ! i of
58 Nothing -> error "Object is null"
59 Just obj ->
60 put $ s { heap = heap // [(i, Just $ obj { val = v })] }
61
62 writeToField :: Int -> ObjectPtr -> ObjectPtr -> GcM ()
63 writeToField _ _ NullPtr = error "Null pointer"
64 writeToField i ptr (ObjectPtr p) = do
65 s@GCState{heap} <- get
66 case heap ! p of
67 Nothing -> error "Object is null"
68 Just obj -> do
69 put $ s { heap = heap // [(p, Just $ obj { fields = fields obj // [(i, ptr)] })] }
70
71data Object = Object {
72 val :: Value,
73 forwardAddress :: Maybe Int,
74 fields :: Array Int ObjectPtr
75} deriving (Eq, Show)
76
77data GCState = GCState {
78 roots :: Array Int ObjectPtr,
79 heap :: Heap,
80 bitmap :: Bitmap
81} deriving (Eq,Show)
82
83type Heap = Array Int (Maybe Object)
84type Bitmap = Array Int Bool
85
86emptyBM :: Bitmap
87emptyBM = array (1, 8) [(i, False) | i <- [1..8]]
88
89initState :: GCState
90initState = GCState
91 { roots = array (1, 8) [(i, NullPtr) | i <- [1..8]]
92 , heap = array (1, 8) [(i, Nothing) | i <- [1..8]]
93 , bitmap = emptyBM
94 }
95
96newtype GcM a = GcM { unGcM :: StateT GCState Identity a }
97 deriving (Functor, Applicative, Monad, MonadState GCState)
98
99isMarked :: ObjectPtr -> Bitmap -> Bool
100isMarked NullPtr _ = False
101isMarked (ObjectPtr p) bm = bm ! p
102
103setMarked :: ObjectPtr -> Bitmap -> Bitmap
104setMarked NullPtr h = h
105setMarked (ObjectPtr p) bm = bm // [(p, True) ]
106
107allocate :: Value -> GcM (Either String ObjectPtr)
108allocate v = do
109 s@GCState{heap} <- get
110 case findIndexWithNothing heap of
111 Just p -> do
112 put $ s { heap = heap // [(p, Just $ Object v Nothing (array (1,8) [(i, NullPtr) | i <- [1..8]]))] }
113 pure $ Right $ ObjectPtr p
114 Nothing -> pure $ Left "Out of memory"
115 where
116 findIndexWithNothing h = ((+)1) <$> (elemIndex Nothing $ map snd $ sortBy (flip compare `on` Down . fst) $ assocs h)
117
118mark :: [ObjectPtr] -> Heap -> Bitmap -> Bitmap
119mark [] _ bm = bm
120mark (ptr:rest) h bm
121 | (ObjectPtr p) <- ptr
122 , Just obj <- h ! p
123 =
124 let
125 step acc NullPtr = acc
126 step (wl, bm') child
127 | not (isMarked child bm') = (child : wl, setMarked child bm')
128 step acc _ = acc
129
130 (workList, newBm) = foldl step ([], bm) $ fields obj
131 in mark (workList ++ rest) h newBm
132 | otherwise = mark rest h bm
133
134markFromRoots :: GcM ()
135markFromRoots = do
136 GCState{..} <- get
137 let newBm = foldl (step heap) bitmap roots
138 put $ GCState roots heap newBm
139 where
140 step heap bm ptr
141 | ptr /= NullPtr && not (isMarked ptr bm) =
142 let newBm = setMarked ptr bm
143 in mark [ptr] heap newBm
144 step _ bm _ = bm
145
146collect :: GcM ()
147collect = do
148 markFromRoots
149 compact
150
151compact :: GcM ()
152compact = do
153 free <- relocate 1 8
154 updateReferences 1 free
155
156move :: Int -> Int -> Heap -> Heap
157move from to h =
158 let obj = h ! from
159 in h // [ (to, obj) ]
160
161-- slotSize == 1
162relocate :: Int -> Int -> GcM Int
163relocate start end = go start end
164 where
165 go :: Int -> Int -> GcM Int
166 go free scan
167 | free < scan = do
168 gc <- get
169 let bm = bitmap gc
170 let indicesToUnmark = fmap fst $ takeWhile (\(_, marked) -> marked) $ sortBy (flip compare `on` Down . fst) $ assocs bm
171 free' = if indicesToUnmark == [] then 1 + free else 1 + maximum indicesToUnmark
172 bm' = bm // [(i, False) | i <- indicesToUnmark]
173
174 let
175 findIndexStep (_, marked) acc@(found, idx)
176 | found = acc
177 | not marked && idx > free' = (False, idx - 1)
178 | otherwise = (True, idx)
179 scan' = snd $ foldr findIndexStep (False, scan) $ take scan $ sortBy (flip compare `on` Down . fst) $ assocs bm'
180
181 let newH = if indicesToUnmark == [] then heap gc else heap gc // [(i, Nothing) | (i, x) <- assocs bm, x == False]
182 put $ gc { bitmap = bm' -- traceShow ("updating bitmap", free', indicesToUnmark, newH, bm') bm'
183 , heap = newH }
184
185
186 if (scan' > free') then do
187
188 let newHeap = move scan' free' newH
189 let obj = newHeap ! scan'
190 let newnewHeap = newHeap // [ (scan', (\o -> o { forwardAddress = Just free' } ) <$> obj ) ]
191 put $ gc { bitmap = bm' // [(scan', False)], heap = newnewHeap }
192
193 go (free' + 1) (scan' - 1)
194 else go free' scan'
195 | otherwise = do
196 GCState{heap, bitmap} <- get
197 pure free -- traceShow (" leaving", free, scan, heap, bitmap) free
198
199-- slotSize == 1
200updateReferences :: Int -> Int -> GcM ()
201updateReferences start end = do
202 s@GCState{heap, roots} <- get
203
204 let
205 step NullPtr = NullPtr
206 step ptr@(ObjectPtr p) =
207 let newPtr = forwardAddress <$> (heap ! p)
208 in case newPtr of
209 Just (Just newPtr') | p >= end -> ObjectPtr newPtr'
210 _ -> ptr
211
212 let
213 updateStep (scan, res) item
214 | scan < end, Just obj <- item = (scan + 1, (scan, Just $ obj { fields = fmap step $ fields obj }) : res)
215 | otherwise = (scan + 1, res)
216
217 put $ s { roots = fmap step roots, heap = heap // (snd $ foldl updateStep (start, []) heap) }
218
219main :: IO ()
220main = do
221 let
222 res = flip runState initState $ unGcM $ do
223 ptr <- new (IntVal 1)
224
225 writeToRoots 1 ptr
226
227 ptr2 <- new (IntVal 2)
228 ptr3 <- new (IntVal 3)
229 ptr4 <- new (IntVal 4)
230 ptr5 <- new (IntVal 5)
231 ptr6 <- new (IntVal 6)
232 ptr7 <- new (IntVal 7)
233 ptr8 <- new (IntVal 8)
234
235 writeToRoots 5 ptr6
236
237 collect
238
239 ptr2' <- new (IntVal 2)
240 writeToRoots 2 ptr2'
241 collect
242
243 return [ptr, ptr2]
244 putStrLn $ "RESULT:" ++ (show $ snd res)