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