Evgenii Akentev
·
2024-09-18
Lisp2.hs
1{-# language ImportQualifiedPost, InstanceSigs, DuplicateRecordFields
2 , LambdaCase, RecordWildCards, NamedFieldPuns, TypeSynonymInstances
3 , DerivingStrategies, GeneralizedNewtypeDeriving #-}
4
5module MarkCompact.Lisp2 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 computeLocations 1 8 1
154 updateReferences 1 8
155 relocate 1 8
156
157computeLocations :: Int -> Int -> Int -> GcM ()
158computeLocations start end toRegion = go start toRegion end
159 where
160 go :: Int -> Int -> Int -> GcM ()
161 go scan free end
162 | scan < end = do
163 s@GCState{..} <- get
164 newFree <- if isMarked (ObjectPtr scan) bitmap then do
165 put $ s { heap = heap // [ (scan, (\o -> o { forwardAddress = Just free } ) <$> (heap ! scan) ) ] }
166 pure (free + 1)
167 else pure free
168 go (scan + 1) newFree end
169 | otherwise = pure ()
170
171move :: Int -> Int -> Heap -> Heap
172move from to h =
173 let obj = h ! from
174 in h // [ (to, obj) ]
175
176-- slotSize == 1
177relocate :: Int -> Int -> GcM ()
178relocate start end = go start end
179 where
180 go :: Int -> Int -> GcM ()
181 go scan end
182 | scan < end = do
183 s@GCState{..} <- get
184 if isMarked (ObjectPtr scan) bitmap then do
185 case forwardAddress <$> (heap ! scan) of
186 Just (Just dest) -> do
187 put $ s { heap = move scan dest heap, bitmap = bitmap // [(dest, False)] }
188 Nothing -> pure ()
189 else pure ()
190 go (scan + 1) end
191 | otherwise = pure ()
192
193-- slotSize == 1
194updateReferences :: Int -> Int -> GcM ()
195updateReferences start end = do
196 s@GCState{heap, roots} <- get
197
198 let
199 step NullPtr = NullPtr
200 step ptr@(ObjectPtr p) =
201 let newPtr = forwardAddress <$> (heap ! p)
202 in case newPtr of
203 Just (Just newPtr') -> ObjectPtr newPtr'
204 _ -> ptr
205
206 let
207 updateStep (scan, res) item
208 | scan < end, Just obj <- item = (scan + 1, (scan, Just $ obj { fields = fmap step $ fields obj }) : res)
209 | otherwise = (scan + 1, res)
210
211 put $ s { roots = fmap step roots, heap = heap // (snd $ foldl updateStep (start, []) heap) }
212
213main :: IO ()
214main = do
215 let
216 res = flip runState initState $ unGcM $ do
217 ptr <- new (IntVal 1)
218
219 writeToRoots 1 ptr
220
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 5 ptr6
230
231 collect
232
233-- ptr2' <- new (IntVal 2)
234 -- writeToRoots 2 ptr2'
235 -- collect
236
237 return [ptr, ptr2]
238 putStrLn $ "RESULT:" ++ (show $ snd res)