From 2d5d6bb38430cab79ab873e21ebba22a9f65b3d5 Mon Sep 17 00:00:00 2001 From: Evgenii Akentev Date: Sat, 14 Sep 2024 23:05:51 +0400 Subject: [PATCH] Refactor marksweep a bit --- .gitignore | 24 +++++ LICENSE | 29 ++++++ gcs.cabal | 25 +++++ mark-sweep/MarkSweep.hs | 116 --------------------- mark-sweep/basic.c => mark_sweep.c | 0 src/MarkSweep/Basic.hs | 162 +++++++++++++++++++++++++++++ src/Mutator.hs | 22 ++++ 7 files changed, 262 insertions(+), 116 deletions(-) create mode 100644 LICENSE create mode 100644 gcs.cabal delete mode 100644 mark-sweep/MarkSweep.hs rename mark-sweep/basic.c => mark_sweep.c (100%) create mode 100644 src/MarkSweep/Basic.hs create mode 100644 src/Mutator.hs diff --git a/.gitignore b/.gitignore index cba7efc..c576973 100644 --- a/.gitignore +++ b/.gitignore @@ -1 +1,25 @@ a.out + +dist +dist-* +cabal-dev +*.o +*.hi +*.hie +*.chi +*.chs.h +*.dyn_o +*.dyn_hi +.hpc +.hsenv +.cabal-sandbox/ +cabal.sandbox.config +*.prof +*.aux +*.hp +*.eventlog +.stack-work/ +cabal.project.local +cabal.project.local~ +.HTF/ +.ghc.environment.* diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..e20cce1 --- /dev/null +++ b/LICENSE @@ -0,0 +1,29 @@ +Copyright (c) 2024, Evgenii Akentev + + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of the copyright holder nor the names of its + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/gcs.cabal b/gcs.cabal new file mode 100644 index 0000000..a5c3a1a --- /dev/null +++ b/gcs.cabal @@ -0,0 +1,25 @@ +cabal-version: 3.0 +name: gcs +version: 0.1.0.0 +-- synopsis: +-- description: +license: BSD-3-Clause +license-file: LICENSE +author: Evgenii Akentev +maintainer: hi@ak3n.com +-- copyright: +build-type: Simple +extra-doc-files: CHANGELOG.md +-- extra-source-files: + +common warnings + ghc-options: -Wall + +library + import: warnings + exposed-modules: MarkSweep.Basic, Mutator + -- other-modules: + -- other-extensions: + build-depends: base ^>=4.18.2.1, mtl + hs-source-dirs: src + default-language: Haskell2010 diff --git a/mark-sweep/MarkSweep.hs b/mark-sweep/MarkSweep.hs deleted file mode 100644 index 0bb07f0..0000000 --- a/mark-sweep/MarkSweep.hs +++ /dev/null @@ -1,116 +0,0 @@ -module MarkSweep where - -import Debug.Trace - --- run as ghci MarkSweep.hs -package unordered-containers - -data Value = IntVal Int - deriving (Eq, Show) - -data Object = Object { - val :: Value, - fields :: [ObjectPtr], - marked :: Bool -} deriving (Eq, Show) - -data ObjectPtr = ObjectPtr Int | NullPtr - deriving (Eq, Show) - -increment :: ObjectPtr -> ObjectPtr -increment (ObjectPtr p) = ObjectPtr $ p + 1 -increment NullPtr = NullPtr - -newtype Heap = Heap { heapObjects :: [Maybe Object] } - deriving (Eq, Show) - -newHeap :: Heap -newHeap = Heap [Nothing | x <- [1..8]] - -isMarked :: ObjectPtr -> Heap -> Bool -isMarked NullPtr _ = False -isMarked (ObjectPtr p) h = Just True == (marked <$> (heapObjects h !! p)) - -setMarked :: ObjectPtr -> Heap -> Heap -setMarked NullPtr h = h -setMarked (ObjectPtr p) (Heap hs) = Heap $ reverse $ foldl step [] $ zip [0..] hs - where - step res (idx, Nothing) = Nothing : res - step res (idx, Just obj) - | p == idx = (Just $ obj { marked = True }) : res - | otherwise = (Just obj) : res - -newtype Roots = Roots { rootsObjects :: [ObjectPtr]} - deriving (Eq, Show) - -data MarkSweepGC = MarkSweepGC { - roots :: Roots, - heap :: Heap -} deriving (Eq, Show) - -allocate :: Value -> Heap -> Either String (ObjectPtr, Heap) -allocate v (Heap objs) = case foldl step (False, -1, []) objs of - (True, idx, res) -> Right $ (ObjectPtr idx, Heap $ reverse res) - _ -> Left "Out of memory" - where - step (True, idx, res) obj = (True, idx, obj : res) - step (_, idx, res) Nothing = (True, idx + 1, (Just $ Object v [] False) : res) - step (ok, idx, res) obj = (ok, idx + 1, obj : res) - -mark :: [ObjectPtr] -> Heap -> Heap -mark [] h = h -mark ((ObjectPtr p):rest) h = case heapObjects h !! p of - Just obj -> - let - step acc NullPtr = acc - step (wl, heap) child - | not (isMarked child h) = (child : wl, setMarked child heap) - step acc _ = acc - - (workList, newH) = foldl step ([], h) $ fields obj - in mark (workList ++ rest) newH - Nothing -> mark rest h - -markFromRoots :: Heap -> Roots -> (Heap, Roots) -markFromRoots h rs = - let newHeap = foldl step h $ rootsObjects rs - in (newHeap, rs) - where - step heap ptr - | not (isMarked ptr heap) = - let newH = setMarked ptr heap - in mark [ptr] newH - step heap ptr = heap - -collect :: Heap -> Roots -> (Heap, Roots) -collect h r = - let (h', r') = markFromRoots h r - in (sweep h', r') - -sweep :: Heap -> Heap -sweep (Heap hs) = Heap $ map step hs - where - step Nothing = Nothing - step (Just o) = if marked o then Just (o { marked = False }) else Nothing - -newObject :: Value -> MarkSweepGC -> Either String (ObjectPtr, MarkSweepGC) -newObject v (MarkSweepGC roots heap) = - case allocate v heap of - Right (ptr, heap') -> Right (ptr, MarkSweepGC roots heap') - Left s -> - let (heap', roots') = collect heap roots - in case allocate v heap' of - Right (ptr, heap'') -> Right (ptr, MarkSweepGC roots' heap'') - Left s -> Left s - -main :: IO () -main = do - let gc = MarkSweepGC (Roots []) newHeap - let - res = do - (ptr, gc') <- newObject (IntVal 3) gc - (ptr2, MarkSweepGC (Roots roots) h) <- newObject (IntVal 5) gc' - - let (r'', h'') = collect h (Roots $ ptr2 : roots) - let newGc = MarkSweepGC h'' r'' - return ([ptr, ptr2], newGc) - print res diff --git a/mark-sweep/basic.c b/mark_sweep.c similarity index 100% rename from mark-sweep/basic.c rename to mark_sweep.c diff --git a/src/MarkSweep/Basic.hs b/src/MarkSweep/Basic.hs new file mode 100644 index 0000000..a608a36 --- /dev/null +++ b/src/MarkSweep/Basic.hs @@ -0,0 +1,162 @@ +{-# language ImportQualifiedPost, InstanceSigs, DuplicateRecordFields + , LambdaCase, RecordWildCards, NamedFieldPuns, TypeSynonymInstances + , DerivingStrategies, GeneralizedNewtypeDeriving #-} + +module MarkSweep.Basic where + +import Control.Monad.State +import Control.Monad.Identity +import Mutator + +instance Mutator GcM where + new :: Value -> GcM ObjectPtr + new v = do + allocate v >>= \case + Right ptr -> pure ptr + _ -> do + collect + allocate v >>= \case + Right ptr -> pure ptr + Left s -> error s + + readFromRoots :: Int -> GcM ObjectPtr + readFromRoots i = do + GCState{roots} <- get + return $ roots !! i + + readFromObject :: ObjectPtr -> GcM Value + readFromObject (ObjectPtr i) = do + GCState{heap} <- get + case heap !! i of + Just o -> pure $ val o + Nothing -> error "Incorrect pointer" + + readFromField :: Int -> ObjectPtr -> GcM ObjectPtr + readFromField f (ObjectPtr i) = do + GCState{heap} <- get + case heap !! i of + Just o -> pure $ (fields o) !! f + Nothing -> error "Incorrect pointer" + + writeToRoots :: Int -> ObjectPtr -> GcM () + writeToRoots i ptr = do + s@GCState{roots} <- get + case splitAt i roots of + ([], []) -> put $ s { roots = [ptr] } + (before, _:after) -> put $ s { roots = before ++ [ptr] ++ after } + + writeToObject :: Value -> ObjectPtr -> GcM () + writeToObject v (ObjectPtr i) = do + s@GCState{heap} <- get + let (before, o:after) = splitAt i heap + case o of + Nothing -> error "Object is null" + Just obj -> + put $ s { heap = before ++ [Just $ obj { val = v } ] ++ after } + + writeToField :: Int -> ObjectPtr -> ObjectPtr -> GcM () + writeToField i ptr (ObjectPtr p) = do + s@GCState{heap} <- get + let (before, o:after) = splitAt p heap + case o of + Nothing -> error "Object is null" + Just obj -> do + let (fBefore, _:fAfter) = splitAt i $ fields obj + put $ s { heap = (before ++ [Just $ obj { fields = fBefore ++ [ptr] ++ fAfter } ] ++ after) } + +data Object = Object { + val :: Value, + fields :: [ObjectPtr], + marked :: Bool +} deriving (Eq, Show) + +data GCState = GCState { + roots :: [ObjectPtr], + heap :: Heap +} deriving (Eq,Show) + +type Heap = [Maybe Object] + +initState :: GCState +initState = GCState [] [Nothing | _ <- [1 :: Int ..8]] + +newtype GcM a = GcM { unGcM :: StateT GCState Identity a } + deriving (Functor, Applicative, Monad, MonadState GCState) + +isMarked :: ObjectPtr -> Heap -> Bool +isMarked NullPtr _ = False +isMarked (ObjectPtr p) h = Just True == (marked <$> (h !! p)) + +setMarked :: ObjectPtr -> Heap -> Heap +setMarked NullPtr h = h +setMarked (ObjectPtr p) hs = reverse $ foldl step [] $ zip [0..] hs + where + step res (_, Nothing) = Nothing : res + step res (idx, Just obj) + | p == idx = (Just $ obj { marked = True }) : res + | otherwise = (Just obj) : res + +allocate :: Value -> GcM (Either String ObjectPtr) +allocate v = do + s@GCState{heap} <- get + case foldl step (False, -1, []) heap of + (True, idx, res) -> do + put $ s { heap = reverse res} + pure $ Right $ ObjectPtr idx + _ -> pure $ Left "Out of memory" + where + step (True, idx, res) obj = (True, idx, obj : res) + step (_, idx, res) Nothing = (True, idx + 1, (Just $ Object v [] False) : res) + step (ok, idx, res) obj = (ok, idx + 1, obj : res) + +mark :: [ObjectPtr] -> Heap -> Heap +mark [] h = h +mark ((ObjectPtr p):rest) h = case h !! p of + Just obj -> + let + step acc NullPtr = acc + step (wl, heap) child + | not (isMarked child h) = (child : wl, setMarked child heap) + step acc _ = acc + + (workList, newH) = foldl step ([], h) $ fields obj + in mark (workList ++ rest) newH + Nothing -> mark rest h + +markFromRoots :: GcM () +markFromRoots = do + GCState{..} <- get + let newHeap = foldl step heap roots + put $ GCState roots newHeap + where + step heap ptr + | not (isMarked ptr heap) = + let newH = setMarked ptr heap + in mark [ptr] newH + step heap _ = heap + +collect :: GcM () +collect = do + markFromRoots + sweep + +sweep :: GcM () +sweep = do + s@GCState{heap} <- get + put $ s { heap = map step heap } + where + step Nothing = Nothing + step (Just o) = if marked o then Just (o { marked = False }) else Nothing + +main :: IO () +main = do + let + res = flip runState initState $ unGcM $ do + ptr <- new (IntVal 3) + ptr2 <- new (IntVal 5) + + writeToRoots 0 ptr + + collect + return [ptr, ptr2] + print res diff --git a/src/Mutator.hs b/src/Mutator.hs new file mode 100644 index 0000000..ad0bdb0 --- /dev/null +++ b/src/Mutator.hs @@ -0,0 +1,22 @@ +{-# language MultiParamTypeClasses #-} + +module Mutator where + +data Value = IntVal Int | PtrVal ObjectPtr + deriving (Eq, Show) + +data ObjectPtr = ObjectPtr Int | NullPtr + deriving (Eq, Show) + +class Monad m => Mutator m where + new :: Value -> m ObjectPtr + + readFromRoots :: Int -> m ObjectPtr + readFromObject :: ObjectPtr -> m Value + readFromField :: Int -> ObjectPtr -> m ObjectPtr + + writeToRoots :: Int -> ObjectPtr -> m () + writeToObject :: Value -> ObjectPtr -> m () + writeToField :: Int -> ObjectPtr -> ObjectPtr -> m () + + -- 2.34.1