Remove HID counter and HIDs; extract common searchHandlers function
This commit is contained in:
parent
a4113f7608
commit
1dcf34bd56
82
os.hs
82
os.hs
|
@ -1,41 +1,34 @@
|
||||||
{-# LANGUAGE ExistentialQuantification #-}
|
{-# LANGUAGE ExistentialQuantification #-}
|
||||||
|
-- MultiParamTypeClasses FunctionalDependencies
|
||||||
module OS where
|
module OS where
|
||||||
|
|
||||||
-- TODO try avoiding double-matching for metamessages by closing over the callback
|
-- TODO try avoiding double-matching for metamessages and the need for
|
||||||
-- TODO try using PIDs instead of HIDs to avoid the search in runMetaHandler
|
-- broadcast by introducing a facility for supporting event-pattern
|
||||||
|
-- subtyping
|
||||||
|
|
||||||
import Data.IntMap (IntMap)
|
|
||||||
import qualified Data.IntMap as IntMap
|
|
||||||
import Control.Arrow ((>>>))
|
import Control.Arrow ((>>>))
|
||||||
import Data.Maybe
|
import Data.Maybe
|
||||||
|
import Data.List
|
||||||
import Control.Concurrent.Chan
|
import Control.Concurrent.Chan
|
||||||
|
|
||||||
data VM m mm = VM { hidCounter :: Int,
|
data VM m mm = VM { suspensions :: [Suspension m mm],
|
||||||
suspensions :: [Suspension m mm],
|
|
||||||
messages :: [m],
|
messages :: [m],
|
||||||
metaMessages :: [mm],
|
metaMessages :: [mm],
|
||||||
runnables :: [Callback m mm ()] }
|
runnables :: [Callback m mm ()] }
|
||||||
type Callback m mm state = (state -> KernelModeTransition m mm)
|
type Callback m mm state = (state -> KernelModeTransition m mm)
|
||||||
data Subscription m mm = forall state. Subscription
|
|
||||||
state
|
|
||||||
(Maybe (Callback m mm state))
|
|
||||||
[Handler m mm state]
|
|
||||||
[MetaHandler m mm state]
|
|
||||||
data Suspension m mm = forall state. Suspension
|
data Suspension m mm = forall state. Suspension
|
||||||
state
|
state
|
||||||
(Maybe (Callback m mm state))
|
(Maybe (Callback m mm state))
|
||||||
[Handler m mm state]
|
[Handler m mm state]
|
||||||
(IntMap (MetaHandler m mm state))
|
[MetaHandler m mm state]
|
||||||
data KernelModeTransition m mm = KernelModeTransition (Subscription m mm)
|
data KernelModeTransition m mm = KernelModeTransition (Suspension m mm)
|
||||||
[m]
|
[m]
|
||||||
[mm]
|
[mm]
|
||||||
[Callback m mm ()]
|
[Callback m mm ()]
|
||||||
type HID = Int
|
|
||||||
type Handler m mm state = (m -> Maybe (Callback m mm state))
|
type Handler m mm state = (m -> Maybe (Callback m mm state))
|
||||||
type MetaHandler m mm state = (mm -> Maybe (Callback m mm state))
|
type MetaHandler m mm state = (mm -> Maybe (Callback m mm state))
|
||||||
|
|
||||||
newVM boot = VM { hidCounter = 0,
|
newVM boot = VM { suspensions = [],
|
||||||
suspensions = [],
|
|
||||||
messages = [],
|
messages = [],
|
||||||
metaMessages = [],
|
metaMessages = [],
|
||||||
runnables = [boot] }
|
runnables = [boot] }
|
||||||
|
@ -46,7 +39,7 @@ runVM = rebuildSuspensions enqueuePoller >>> runRunnables >>> dispatchMessages >
|
||||||
mmhs = concatMap extractDown $ suspensions vm
|
mmhs = concatMap extractDown $ suspensions vm
|
||||||
pollerK = if shouldPoll vm then Just runVM else Nothing
|
pollerK = if shouldPoll vm then Just runVM else Nothing
|
||||||
in
|
in
|
||||||
KernelModeTransition (Subscription (vm { metaMessages = [] }) pollerK mmhs []) mms [] []
|
KernelModeTransition (Suspension (vm { metaMessages = [] }) pollerK mmhs []) mms [] []
|
||||||
|
|
||||||
rebuildSuspensions :: (VM m mm -> Suspension m mm -> VM m mm) -> (VM m mm) -> (VM m mm)
|
rebuildSuspensions :: (VM m mm -> Suspension m mm -> VM m mm) -> (VM m mm) -> (VM m mm)
|
||||||
rebuildSuspensions f vm = foldl f (vm { suspensions = [] }) (suspensions vm)
|
rebuildSuspensions f vm = foldl f (vm { suspensions = [] }) (suspensions vm)
|
||||||
|
@ -66,21 +59,19 @@ dispatchMessages vm = foldr dispatchMessage (vm { messages = [] }) (messages vm)
|
||||||
|
|
||||||
dispatchMessage m = rebuildSuspensions matchSuspension
|
dispatchMessage m = rebuildSuspensions matchSuspension
|
||||||
where matchSuspension vm susp@(Suspension state _ mhs _) =
|
where matchSuspension vm susp@(Suspension state _ mhs _) =
|
||||||
let searchHandlers [] = vm { suspensions = susp : suspensions vm }
|
searchHandlers vm susp state m mhs
|
||||||
searchHandlers (mh:mhs) =
|
|
||||||
case mh m of
|
|
||||||
Just h -> performTransition (h state) vm
|
|
||||||
Nothing -> searchHandlers mhs
|
|
||||||
in searchHandlers mhs
|
|
||||||
|
|
||||||
extractDown (Suspension _ _ _ mmhs) =
|
searchHandlers vm susp state m [] = vm { suspensions = susp : suspensions vm }
|
||||||
IntMap.foldWithKey (\ hid mmh xs -> dispatchMetaMessage hid mmh : xs) [] mmhs
|
searchHandlers vm susp state m (mh:mhs) =
|
||||||
|
case mh m of
|
||||||
|
Just h -> performTransition (h state) vm
|
||||||
|
Nothing -> searchHandlers vm susp state m mhs
|
||||||
|
|
||||||
dispatchMetaMessage :: HID -> MetaHandler m mm state -> Handler mm mm1 (VM m mm)
|
extractDown (Suspension _ _ _ mmhs) = map matchMetaMessage mmhs
|
||||||
dispatchMetaMessage hid mmh mm =
|
where matchMetaMessage mmh mm =
|
||||||
case mmh mm of
|
case mmh mm of
|
||||||
Nothing -> Nothing
|
Nothing -> Nothing
|
||||||
Just _ -> Just (runMetaHandler hid mm)
|
Just _ -> Just (runMetaHandler mm)
|
||||||
|
|
||||||
isPolling (Suspension _ pollerK _ _) = isNothing pollerK
|
isPolling (Suspension _ pollerK _ _) = isNothing pollerK
|
||||||
isBlocked = not . isPolling
|
isBlocked = not . isPolling
|
||||||
|
@ -88,29 +79,20 @@ isBlocked = not . isPolling
|
||||||
shouldPoll vm@(VM { messages = [], runnables = []}) = not $ all isBlocked (suspensions vm)
|
shouldPoll vm@(VM { messages = [], runnables = []}) = not $ all isBlocked (suspensions vm)
|
||||||
shouldPoll _ = True
|
shouldPoll _ = True
|
||||||
|
|
||||||
runMetaHandler :: HID -> mm -> (VM m mm) -> (KernelModeTransition mm mm1)
|
runMetaHandler :: mm -> (VM m mm) -> (KernelModeTransition mm mm1)
|
||||||
runMetaHandler hid mm = runVM . rebuildSuspensions runHid
|
runMetaHandler mm = runVM . rebuildSuspensions dispatchMetaMessage
|
||||||
where runHid vm susp@(Suspension state _ _ mmhs) =
|
where dispatchMetaMessage vm susp@(Suspension state _ _ mmhs) =
|
||||||
case IntMap.lookup hid mmhs of
|
searchHandlers vm susp state mm mmhs
|
||||||
Just h -> performTransition ((fromJust $ h mm) state) vm
|
|
||||||
Nothing -> vm { suspensions = susp : suspensions vm }
|
|
||||||
|
|
||||||
addHids vm mmhs =
|
|
||||||
foldr (\ mmh (vm, acc) -> let h = hidCounter vm in
|
|
||||||
(vm { hidCounter = h + 1 }, IntMap.insert h mmh acc))
|
|
||||||
(vm, IntMap.empty)
|
|
||||||
mmhs
|
|
||||||
|
|
||||||
performTransition :: KernelModeTransition m mm -> VM m mm -> VM m mm
|
performTransition :: KernelModeTransition m mm -> VM m mm -> VM m mm
|
||||||
performTransition (KernelModeTransition (Subscription state pollerK mhs mmhs) ms mms cbs) vm =
|
performTransition (KernelModeTransition susp ms mms cbs) vm =
|
||||||
let (vm, hidMap) = addHids vm mmhs in
|
vm { suspensions = susp : suspensions vm,
|
||||||
vm { suspensions = (Suspension state pollerK mhs hidMap) : suspensions vm,
|
|
||||||
messages = reverse ms ++ (messages vm),
|
messages = reverse ms ++ (messages vm),
|
||||||
metaMessages = reverse mms ++ (metaMessages vm),
|
metaMessages = reverse mms ++ (metaMessages vm),
|
||||||
runnables = reverse cbs ++ (runnables vm) }
|
runnables = reverse cbs ++ (runnables vm) }
|
||||||
|
|
||||||
---------------------------------------------------------------------------
|
---------------------------------------------------------------------------
|
||||||
|
{-
|
||||||
type LabelledMessage a b = (a, b)
|
type LabelledMessage a b = (a, b)
|
||||||
|
|
||||||
groundVM :: Callback m (IO ()) () -> IO ()
|
groundVM :: Callback m (IO ()) () -> IO ()
|
||||||
|
@ -146,4 +128,10 @@ groundVM boot = do inboundChannel <- newChan
|
||||||
(loop ((inbound-continuation inbound-value) new-state))]
|
(loop ((inbound-continuation inbound-value) new-state))]
|
||||||
[_
|
[_
|
||||||
(error 'ground-vm
|
(error 'ground-vm
|
||||||
"Outermost VM may not spawn new siblings or send or receive metamessages")]))))
|
"Outermost VM may not spawn new siblings or send or receive metamessages")]))))
|
||||||
|
-}
|
||||||
|
|
||||||
|
-- -- Values of type v are matchable by values of type p, yielding
|
||||||
|
-- -- residuals of type a.
|
||||||
|
-- class Matchable v p a | v -> p where
|
||||||
|
-- match :: p -> v -> Maybe a
|
||||||
|
|
Loading…
Reference in New Issue