Compiler Explorer

Source code

import Control.Monad.State

---

type Quantum = Int

data Syscall = CreateProc Program | ReadWrite deriving Show

data Task = CPU Quantum | Syscall Syscall deriving Show

data Program = Program {
  pSize :: KBytes,
  pCode :: [Task]
} deriving Show

type Millis = Int

type KBytes = Int

type Pid = Int

data ProcessState = Ready | Blocked | Dead deriving Show

data Process = Process {
  kpPid :: Pid,
  kpState :: ProcessState,
  kpSwap :: Bool,
  kpSize :: KBytes,
  kpProc :: [Task]
} deriving Show

type PCB = [Process]

data Event = EvUnblock Pid | EvCreate Program deriving Show

data KernelState = KernelState {
  kMem :: KBytes,
  kTime :: Quantum,
  kPcb :: PCB,
  kEvs :: [(Quantum, Event)],
  kRR :: [Pid],
  kPid :: Pid
} deriving Show

type Kernel = StateT KernelState IO

data KernelConfig = KernelConfig KBytes Quantum Quantum Quantum Program

---

runTime :: Millis -> [Task]

runTime t = [CPU t]

runMixed :: Millis -> Millis -> [Task]

runMixed t v =
  if t <= v then
    [CPU t]
  else
    [CPU v, Syscall ReadWrite] ++ runMixed (t - v) v

mergeCPU :: [Task] -> [Task]

mergeCPU [] = []

mergeCPU (CPU t : CPU u : xs) = mergeCPU (CPU (t + u) : xs)

mergeCPU (x : xs) = x : mergeCPU xs

quantize :: Quantum -> [Task] -> [Task]

quantize q [] = []

quantize q (x:xs) =
  case x of
    CPU t     ->
      if t > q then
        CPU q : quantize q (CPU (t - q) : xs)
      else
        x : quantize q xs
    
    otherwise -> x : quantize q xs

isResident :: Process -> Bool

isResident = not . kpSwap

extract :: (a -> Bool) -> [a] -> (Maybe a, [a])

extract f xs =
  go [] xs
  where
    go ys [] = (Nothing, reverse ys)
    go ys (x:xs) =
      if f x then
        (Just x, reverse ys ++ xs)
      else
        go (x:ys) xs

find :: (a -> Bool) -> [a] -> Maybe a

find _ [] = Nothing

find f (x:xs) = if f x then Just x else find f xs

setSwap :: Bool -> Process -> Process

setSwap sw p = p { kpSwap = sw }

setState :: ProcessState -> Process -> Process

setState st p = p { kpState = st }

headAndBack :: [a] -> (Maybe a, [a])

headAndBack [] = (Nothing, [])

headAndBack (x:xs) = (Just x, xs ++ [x])

---

logs :: String -> Kernel ()

logs m = do
  t <- gets kTime
  lift $ putStrLn (show t ++ ": " ++ m)

findProcess :: Pid -> Kernel (Maybe Process)

findProcess pid = do
  ks <- get
  let ps = kPcb ks
  let p = find ((pid==) . kpPid) ps
  return p

extractProcess :: Pid -> Kernel (Maybe Process)

extractProcess pid = do
  ks <- get
  let ps = kPcb ks
  let (p, ps') = extract ((pid==) . kpPid) ps
  let ks' = ks { kPcb = ps' }
  put ks
  return p

putProcess :: Process -> Kernel ()

putProcess p = do
  ks <- get
  let ps = kPcb ks
  let ps' = p : ps
  let ks' = ks { kPcb = ps' }
  put ks'

enqueuePid :: Pid -> Kernel ()

enqueuePid pid = do
  ks <- get
  let pids = kRR ks
  let pids' = pids ++ [pid]
  let ks' = ks { kRR = pids' }
  put ks'

updateProcess :: (Process -> Process) -> Pid -> Kernel Process

updateProcess f pid = do
  Just p <- extractProcess pid
  let p' = f p
  putProcess p'
  return p'

updateMem :: KBytes -> Kernel ()

updateMem dm = do
  ks <- get
  let mem = kMem ks
  let mem' = mem + dm
  let ks' = ks { kMem = mem' }
  put ks'

hasMem :: KBytes -> Kernel Bool

hasMem n = gets ((>= n) . kMem)

freeSpace :: KBytes -> Kernel Bool

freeSpace n = do
  mem <- gets kMem
  
  if mem >= n then
    return True
  else do
    ps <- gets (filter isResident . kPcb)
    
    if null ps then
      return False
    else do
      let p = head ps
      let k = kpSize p
      
      updateProcess (setSwap True) (kpPid p)
      
      updateMem (-k)
      
      freeSpace (n - k)

newPid :: Kernel Pid

newPid = do
  ks <- get
  let pid = kPid ks
  let ks' = ks { kPid = pid + 1 }
  put ks'
  logs ("Created PID = " ++ show pid)
  return pid

runEvent :: Event -> Kernel ()

runEvent (EvUnblock pid) = do
  updateProcess (setState Ready) pid
  return ()

runEvent (EvCreate pg) = do
  pid <- newPid
  let psize = pSize pg
  has <- hasMem psize
  let p = Process pid Ready (not has) psize (pCode pg)
  putProcess p
  enqueuePid pid

updateEvents :: Quantum -> Kernel ()

updateEvents dt = do
  ks <- get
  let evs = kEvs ks
  let evs' = map (\(t, e) -> (t - dt, e)) evs
  let ks' = ks { kEvs = evs' }
  put ks'

extractNowEvents :: Kernel [Event]

extractNowEvents = do
  ks <- get
  let evs = kEvs ks
  let (now, evs') = break ((> 0) . fst) evs
  let ks' = ks { kEvs = evs' }
  put ks'
  return $ map snd now

runEvents :: Quantum -> Kernel ()

runEvents dt = do
  updateEvents dt
  now <- extractNowEvents
  logs ("EVS = " ++ show now)
  mapM_ runEvent now

advance :: Quantum -> Kernel ()

advance dt = do
  ks <- get
  let t = kTime ks
  let t' = t + dt
  let ks' = ks { kTime = t' }
  put ks'

advanceRR :: Kernel (Maybe Pid)

advanceRR = do
  ks <- get
  let pids = kRR ks
  let (mpid, pids') = headAndBack pids
  let ks' = ks { kRR = pids' }
  put ks'
  return mpid

dequeueProc :: Kernel (Maybe Pid)

dequeueProc = do
  mpid <- advanceRR
  case mpid of
    Nothing  -> return Nothing
    Just pid -> do
      Just p <- findProcess pid
      ok <- freeSpace $ kpSize p
      if not ok then
        error "System ran out of memory"
      else do
        updateProcess (setSwap False) pid
        return $ Just pid

runProcess :: Pid -> Kernel Quantum

runProcess p = do
  return 50

kernel :: Quantum -> Quantum -> Quantum -> Kernel ()

kernel q c i =
  loop 0
  where
    loop dt = do
      logs "KERNELSPACE"
      kt <- gets kTime
      runEvents dt
      mpid <- dequeueProc
      logs ("dequeue = " ++ show mpid)
      case mpid of
        Nothing -> return ()
        Just pid -> do
          advance c
          logs "USERSPACE"
          t <- runProcess pid
          loop t

runKernel :: KernelConfig -> IO ()

runKernel (KernelConfig m q c i p) =
  evalStateT (kernel q c i) $ KernelState m 0 [] [(0, EvCreate p)] [] 1

---

createProc = Syscall . CreateProc

p1 = Program 500 $
  CPU 20 : createProc p2 : CPU 10 : createProc p3 : CPU 180 : []

p2 = Program 1000 $ runMixed 350 150

p3 = Program 1000 $ runTime 150

---

main = runKernel $ KernelConfig 2000 200 10 50 p1

---