
  0 | module IO.Async.Loop.Sync
  1 | 
  2 | import Data.Linear.Traverse1
  3 | import Data.So
  4 | import Data.SortedMap
  5 | import public IO.Async.Loop
  6 | import IO.Async.Loop.TimerH
  7 | import IO.Async.Loop.TimerST
  8 | import IO.Async.Internal.Ref
  9 | import System.Clock
 10 | import System
 11 | 
 12 | %default total
 13 | 
 14 | --------------------------------------------------------------------------------
 15 | -- Loop State
 16 | --------------------------------------------------------------------------------
 17 | 
 18 | ||| State of a synchronous event loop with timers
 19 | export
 20 | record SyncST where
 21 |   constructor SST
 22 |   timer   : Timer
 23 |   queue   : IORef (SnocList $ FbrState SyncST)
 24 |   running : IORef Bool
 25 | 
 26 | export %inline
 27 | TimerH SyncST where
 28 |   primWait s dur f = schedule s.timer dur f
 29 | 
 30 | --------------------------------------------------------------------------------
 31 | -- Loop Implementation
 32 | --------------------------------------------------------------------------------
 33 | 
 34 | covering
 35 | spawnImpl : SyncST -> FbrState SyncST -> IO1 ()
 36 | 
 37 | export %inline covering
 38 | EventLoop SyncST where
 39 |   spawn = spawnImpl
 40 |   limit = 1024
 41 | 
 42 | covering
 43 | checkTimers, checkQueue : SyncST -> IO1 ()
 44 | 
 45 | -- runs the given queue of IO actions. when this is done, we run the
 46 | -- timers
 47 | covering
 48 | run : SyncST -> List (FbrState SyncST) -> IO1 ()
 49 | run s []        t = checkTimers s t
 50 | run s (x :: xs) t =
 51 |   case runFbr s x t of
 52 |     Cont fst # t => let _ # t := mod1 s.queue (:< fst) t in run s xs t
 53 |     Done     # t => run s xs t
 54 | 
 55 | -- Check if there is more work in the queue. if yes, run it, otherwise abort.
 56 | -- Note: Only call this when there are no timers left!
 57 | checkQueue s t =
 58 |   let sa # t := read1 s.queue t
 59 |       _  # t := write1 s.queue [<] t
 60 |    in case sa <>> [] of
 61 |         [] => () # t
 62 |         as => run s as t
 63 | 
 64 | doSleep : Integer -> IO1 ()
 65 | doSleep n t =
 66 |   let v := cast {to = Int} (n `div` 1000)
 67 |    in case choose (v >= 0) of
 68 |         Left x  => ioToF1 (usleep v) t
 69 |         Right x => () # t
 70 | 
 71 | -- Check if we have any timers that are due and run them
 72 | checkTimers s t =
 73 |  case runDueTimers s.timer t of
 74 |    0 # t => checkQueue s t
 75 |    n # t => case read1 s.queue t of
 76 |      [<] # t => let _ # t := doSleep n t in checkTimers s t
 77 |      _   # t => checkQueue s t
 78 | 
 79 | spawnImpl s pkg t =
 80 |   let _     # t := mod1 s.queue (:< pkg) t
 81 |       False # t := read1 s.running t | _ # t => () # t
 82 |       _     # t := write1 s.running True t
 83 |    in run s [] t
 84 | 
 85 | ||| A synchronous event loop running all asynchronous computations
 86 | ||| on the calling thread.
 87 | |||
 88 | ||| This will block the calling thread after submitting a work package until
 89 | ||| the package has been completed.
 90 | export covering
 91 | sync : IO SyncST
 92 | sync = [| SST (runIO timer) (newref [<]) (newref False) |]
 93 |