Merge pull request #5 from p3rsik/allocator

Implementing allocator

.gitignore

@@ -3,3 +3,4 @@
 TAGS
 stack.yaml.lock
 back.stack.yaml
+dist-newstyle/

package.yaml

@@ -25,6 +25,8 @@ dependencies:
 - basement
 - fused-effects
 - ghc-prim
+- unordered-containers
+- hashable
 
 library:
   source-dirs: src
@@ -38,6 +40,10 @@ library:
     - NamedFieldPuns
     - TypeApplications
     - ConstraintKinds
+    - StandaloneDeriving
+    - DerivingVia
+    - FlexibleInstances
+    - RecordWildCards
 
 executables:
   vmanager-exe:

src/Allocator/Allocator.hs

@@ -0,0 +1,70 @@
+module Allocator.Allocator where
+
+import Control.Effect.Error
+import Control.Effect.State
+import Control.Monad
+import Data.HashMap.Lazy
+import Env
+import Foundation
+import Manager
+
+-- map of processes to its pages
+type PMap = HashMap ProcessId [Page 'Ram]
+
+type Ptr = Int
+
+data AllocError = OutOfMemory deriving (Eq, Ord)
+
+type AllocSig sig m =
+  ( Has (State PMap) sig m,
+    Has (Throw AllocError) sig m,
+    Has (Catch AllocError) sig m
+  )
+
+-- TODO mock of env, actually should be exported from somewhere
+env :: Env
+env = Env 1024 0 0
+
+class Allocator a where
+  alloc :: (ManagerSig sig m, Has (State PMap) sig m) => a -> CountOf Word8 -> m (Maybe Ptr)
+  free :: (ManagerSig sig m, Has (State PMap) sig m) => a -> m (Maybe a)
+
+class Pointer a where
+  fromOffs :: (Monad m) => PMap -> ProcessId -> Integer -> m a
+
+instance Pointer Int where
+  fromOffs pm pid np = do
+    return $ (fromCount (length pn) - fromIntegral np) * fromCount (memSize env)
+    where
+      pn = fromMaybe [] $ lookup pid pm
+
+instance Allocator ProcessId where
+  alloc pid sz = do
+    case sz of
+      0 -> return Nothing
+
+    -- number of new pages to alloc
+    let npNotAligned = fromCount sz `div` fromCount (memSize env)
+    let np = npNotAligned + align
+          where
+            align =
+              if npNotAligned < fromCount sz
+                then 1
+                else 0
+
+    -- allocating np number of pages
+    ps <- mapM allocPage [pid | _ <- [1 .. np]]
+    -- add pages to pid map
+    modify @PMap $ adjust (<> ps) pid
+    -- in case at least one page in `ps` exists then return Ptr to it, otherwise Nothing
+
+    let ptr = (fromCount (length ps) - np) * fromCount (memSize env)
+
+    -- if there was allocated zero pages - return nothing
+    return $ case find (const True) ps of
+      (Just _) -> Just ptr
+      Nothing -> Nothing
+
+  free pid = do
+    modify @PMap $ delete pid
+    return Nothing

src/Allocator/Process.hs

@@ -0,0 +1,22 @@
+module Allocator.Process where
+
+import Foundation
+import Manager
+import Control.Effect.State
+
+newtype Mem = Mem [Page 'Ram] deriving Eq
+
+-- list of all processes
+type PTable = [ProcessId]
+type ProcSig sig m = (Has (State PTable) sig m)
+
+
+-- add process to PTable list
+createProcess :: (ProcSig sig m) => ProcessId -> m ()
+createProcess pid = do
+    modify @PTable (pid:)
+
+-- delete process from PTable list
+deleteProcess :: (ProcSig sig m) => ProcessId -> m ()
+deleteProcess pid = do
+    modify @PTable $ filter (/= pid)

src/Manager/Env.hs → src/Env.hs

@@ -1,11 +1,11 @@
-module Manager.Env
+module Env
   ( Env (..)
   ) where
 
 import Foundation
 
 import Manager.Frame (Frame)
-import Manager.Types
+import Types
 
 data Env = Env { memSize :: CountOf Word8 -- Size of memory in one Frame
                , ramSize :: CountOf (Frame 'Ram) -- Number of Ram Frame's

src/Manager.hs

@@ -5,10 +5,11 @@ module Manager
   , readMem
   , moveToRam
   , moveToSwap
-  , module Manager.Types
+  , ManagerSig
+  , module Types
   , module Manager.Page
   , module Manager.Frame
-  , module Manager.Env
+  , module Env
   )
 where
 
@@ -19,9 +20,9 @@ import Control.Effect.Catch
 import Control.Effect.Throw
 
 import Manager.Frame
-import Manager.Env
+import Env
 import Manager.Page
-import Manager.Types
+import Types
 
 data ManagerError = CantCreatePage 
                   | NoFreeSwapFrames
@@ -42,14 +43,12 @@ allocPage pid = do
   offM <- getFreeFrameOffset @'Ram
   case offM of
     -- in case free frame exists, then alloc a new page
-    Just off -> do
-      np <- createPage (offToId off) pid
-      return np
+    Just off -> createPage (offToId off) pid
 
     -- otherwise move specific page to swap and alloc a new page
     Nothing -> do
       -- unload a page to swap and create a new one instead
-      p@(Page { frId }) <- findPageToUnload
+      p@Page { frId } <- findPageToUnload
       moveToSwap p
 
       np <- createPage frId pid
@@ -60,29 +59,29 @@ allocPage pid = do
 
 -- Find corresponding frame and mark it free, then delete page from pool of pages
 freePage :: (Pages a, Frames a, ManagerSig sig m) => Page a -> m ()
-freePage p@(Page { frId }) = do
+freePage p@Page { frId } = do
   deletePage p
   setFrameFree frId
 
 
 -- Load page from SWAP to RAM
 moveToRam :: ManagerSig sig m => Page 'Swap -> m ()
-moveToRam p@(Page { pId }) = do
+moveToRam p@Page { pId } = do
   np <- allocPage pId
   copyMem p np
   freePage p
 
 
 -- Copy memory from one page to another
 copyMem :: (Pages a, Frames a, Pages b, Frames b, ManagerSig sig m) => Page a -> Page b -> m ()
-copyMem (Page { frId }) t = do
+copyMem Page { frId } t = do
   (Frame _ mem) <- getFrame frId
   writeMem t (Offset 0) mem
 
 
 -- Unload page from RAM to SWAP
 moveToSwap :: ManagerSig sig m => Page 'Ram -> m ()
-moveToSwap p@(Page { pId }) = do
+moveToSwap p@Page { pId } = do
   offM <- getFreeFrameOffset @'Swap
   case offM of
     Just off -> do
@@ -97,14 +96,14 @@ moveToSwap p@(Page { pId }) = do
 
 -- Write memory to the page
 writeMem :: (Pages a, Frames a, ManagerSig sig m) => Page a -> Offset Word8 -> [Word8] -> m ()
-writeMem (Page { frId }) off mem = do
+writeMem Page { frId } off mem = do
   f <- getFrame frId
   writeFrame f off mem
 
 
 -- Read memory from the page
-readMem :: (Pages a, Frames a, ManagerSig sig m) => Page a -> Offset Word8 -> CountOf Word8 -> m ([Word8])
-readMem (Page { frId }) off count = do
+readMem :: (Pages a, Frames a, ManagerSig sig m) => Page a -> Offset Word8 -> CountOf Word8 -> m [Word8]
+readMem Page { frId } off count = do
   f <- getFrame frId
   readFrame f off count
 

src/Manager/Frame.hs

@@ -9,7 +9,7 @@ module Manager.Frame
 import Foundation
 import Foundation.Collection
 import Control.Effect.State
-import Manager.Types
+import Types
 
 data Frame (a :: MemType) = Frame
              { frameId :: FrameId a -- Actually, FrameId is also Frame offset
@@ -34,13 +34,13 @@ class Frames a where
   setFrameNotFree :: Has (State FrameTable) sig m => FrameId a -> m ()
   getFrame :: Has (State FrameTable) sig m => FrameId a -> m (Frame a)
   writeFrame :: Has (State FrameTable) sig m => Frame a -> Offset Word8 -> [Word8] -> m ()
-  readFrame :: Has (State FrameTable) sig m => Frame a -> Offset Word8 -> CountOf Word8 -> m ([Word8])
+  readFrame :: Has (State FrameTable) sig m => Frame a -> Offset Word8 -> CountOf Word8 -> m [Word8]
 
-readFrame' :: Has (State FrameTable) sib m => Frame a -> Offset Word8 -> CountOf Word8 -> m ([Word8])
+readFrame' :: Has (State FrameTable) sib m => Frame a -> Offset Word8 -> CountOf Word8 -> m [Word8]
 readFrame' (Frame _ mem') (Offset off) co = do 
   let (_, m) = splitAt (toCount off) mem'
   let (r, _) = splitAt co m
-  return (r)
+  return r
 
 
 instance Frames 'Ram where

src/Manager/Page.hs

@@ -8,7 +8,7 @@ module Manager.Page
 import Foundation
 import Foundation.Collection
 import Control.Effect.State
-import Manager.Types
+import Types
 
 data Page (a :: MemType) = Page
             { frId :: FrameId a
@@ -46,10 +46,10 @@ instance Pages 'Ram where
 
   getPage fid = do
     (ram, _) <- get @PageTable
-    let frM = find (\(Page { frId }) -> if frId == fid then True else False) ram
+    let frM = find (\Page { frId } -> frId == fid) ram
     return frM
 
-  movePage p@(Page { pId }) fid = do
+  movePage p@Page { pId } fid = do
     np <- createPage (Fid $ unFid fid) pId
     modify @PageTable $ bimap (filter (/= p)) (np:)
 
@@ -64,9 +64,9 @@ instance Pages 'Swap where
 
   getPage fid = do
     (_, sw) <- get @PageTable
-    let frM = find (\(Page { frId }) -> if frId == fid then True else False) sw
+    let frM = find (\Page { frId } -> frId == fid) sw
     return frM
 
-  movePage p@(Page { pId }) fid = do
+  movePage p@Page { pId } fid = do
     np <- createPage (Fid $ unFid fid) pId
     modify @PageTable $ bimap (np:) (filter (/= p))

src/Manager/Types.hs → src/Types.hs

@@ -1,13 +1,15 @@
-module Manager.Types 
+module Types
   ( MemType (..)
   , ProcessId (..)
   , Age (..)
   , FrameId (..)
   ) where
 
 import Foundation
+import Data.Hashable
 
 newtype ProcessId = Pid { unPid :: Int } deriving (Show, Eq, Ord)
+deriving via Int instance Hashable ProcessId
 newtype Age = Age { unAge :: Word } deriving (Show, Eq, Ord)
 -- FrameId is also a Frame offset
 newtype FrameId (a :: MemType) = Fid { unFid :: Int } deriving (Show, Eq, Ord)

test/Manager/FrameSpec.hs

@@ -9,14 +9,14 @@ import Control.Algebra
 import Test.Hspec
 import qualified Test.QuickCheck as Q
 import qualified Test.QuickCheck.Monadic as QM
-import Manager.Types
+import Types
 import Manager.Frame
 
 idToOffToId :: Q.NonNegative Int -> Bool
-idToOffToId (Q.NonNegative x) = (idToOff . offToId $ Offset x) == (Offset x)
+idToOffToId (Q.NonNegative x) = (idToOff . offToId $ Offset x) == Offset x
 
 offToIdToOff :: Q.NonNegative Int -> Bool
-offToIdToOff (Q.NonNegative x) = (offToId . idToOff $ Fid x) == (Fid x)
+offToIdToOff (Q.NonNegative x) = (offToId . idToOff $ Fid x) == Fid x
 
 frameNumber = 32
 
@@ -33,12 +33,12 @@ getFrameTest :: Q.Property
 getFrameTest = Q.forAll (Q.choose (0, frameNumber)) $ \x ->
     let res = run' $ getFrame (Fid x :: FrameId 'Ram)
         (FT _ ram _ _) = startingState
-        res' = nonEmpty_ . filter (\f -> x == (unFid $ frameId f)) $ getNonEmpty ram
+        res' = nonEmpty_ . filter (\f -> x == unFid (frameId f)) $ getNonEmpty ram
         in res == head res'
 
 spec :: Spec
 spec = do 
     describe "idToOff and offToId roundabout" $ do 
-        it "idToOff . offToId == id" $ Q.property $ idToOffToId
-        it "offToId . idToOff == id" $ Q.property $ offToIdToOff
-        it "getFrame tests" $ Q.property $ getFrameTest
+        it "idToOff . offToId == id" $ Q.property idToOffToId
+        it "offToId . idToOff == id" $ Q.property offToIdToOff
+        it "getFrame tests" $ Q.property getFrameTest

test/Manager/TypesSpec.hs

@@ -3,7 +3,7 @@ module Manager.TypesSpec (spec) where
 import Foundation
 import Test.Hspec
 import Test.QuickCheck
-import Manager.Types
+import Types
 
 spec :: Spec
 spec = do