basis/alarms/alarms.factor

   1 ! Copyright (C) 2005, 2008 Slava Pestov, Doug Coleman.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors assocs boxes calendar
   4 combinators.short-circuit fry heaps init kernel math.order
   5 namespaces quotations threads math system ;
   6 IN: alarms
   7
   8 TUPLE: alarm
   9     { quot callable initial: [ ] }
  10     { start integer }
  11     interval
  12     { entry box } ;
  13
  14 <PRIVATE
  15
  16 SYMBOL: alarms
  17 SYMBOL: alarm-thread
  18
  19 : notify-alarm-thread ( -- )
  20     alarm-thread get-global interrupt ;
  21
  22 GENERIC: >nanoseconds ( obj -- duration/f )
  23 M: f >nanoseconds ;
  24 M: real >nanoseconds >integer ;
  25 M: duration >nanoseconds duration>nanoseconds >integer ;
  26
  27 : <alarm> ( quot start interval -- alarm )
  28     alarm new
  29         swap >nanoseconds >>interval
  30         swap >nanoseconds nano-count + >>start
  31         swap >>quot
  32         <box> >>entry ;
  33
  34 : register-alarm ( alarm -- )
  35     [ dup start>> alarms get-global heap-push* ]
  36     [ entry>> >box ] bi
  37     notify-alarm-thread ;
  38
  39 : alarm-expired? ( alarm n -- ? )
  40     [ start>> ] dip <= ;
  41
  42 : reschedule-alarm ( alarm -- )
  43     dup interval>> nano-count + >>start register-alarm ;
  44
  45 : call-alarm ( alarm -- )
  46     [ entry>> box> drop ]
  47     [ dup interval>> [ reschedule-alarm ] [ drop ] if ]
  48     [ quot>> "Alarm execution" spawn drop ] tri ;
  49
  50 : (trigger-alarms) ( alarms n -- )
  51     over heap-empty? [
  52         2drop
  53     ] [
  54         over heap-peek drop over alarm-expired? [
  55             over heap-pop drop call-alarm (trigger-alarms)
  56         ] [
  57             2drop
  58         ] if
  59     ] if ;
  60
  61 : trigger-alarms ( alarms -- )
  62     nano-count (trigger-alarms) ;
  63
  64 : next-alarm ( alarms -- nanos/f )
  65     dup heap-empty? [ drop f ] [ heap-peek drop start>> ] if ;
  66
  67 : alarm-thread-loop ( -- )
  68     alarms get-global
  69     dup next-alarm sleep-until
  70     trigger-alarms ;
  71
  72 : cancel-alarms ( alarms -- )
  73     [
  74         heap-pop-all [ nip entry>> box> drop ] assoc-each
  75     ] when* ;
  76
  77 : init-alarms ( -- )
  78     alarms [ cancel-alarms <min-heap> ] change-global
  79     [ alarm-thread-loop t ] "Alarms" spawn-server
  80     alarm-thread set-global ;
  81
  82 [ init-alarms ] "alarms" add-startup-hook
  83
  84 PRIVATE>
  85
  86 : add-alarm ( quot start interval -- alarm )
  87     <alarm> [ register-alarm ] keep ;
  88
  89 : later ( quot duration -- alarm ) f add-alarm ;
  90
  91 : every ( quot duration -- alarm ) dup add-alarm ;
  92
  93 : cancel-alarm ( alarm -- )
  94     entry>> [ alarms get-global heap-delete ] if-box? ;