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.*
--- /dev/null
+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.
--- /dev/null
+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
+++ /dev/null
-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
--- /dev/null
+{-# 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
--- /dev/null
+{-# 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 ()
+
+
projects / gcs.git / commitdiff