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: arrays calendar combinators generic init kernel math
   4 namespaces sequences heaps boxes threads debugger quotations
   5 assocs math.order ;
   6 IN: alarms
   7
   8 TUPLE: alarm quot time interval entry ;
   9
  10 <PRIVATE
  11
  12 SYMBOL: alarms
  13 SYMBOL: alarm-thread
  14
  15 : notify-alarm-thread ( -- )
  16     alarm-thread get-global interrupt ;
  17
  18 : check-alarm
  19     dup duration? over not or [ "Not a duration" throw ] unless
  20     over timestamp? [ "Not a timestamp" throw ] unless
  21     pick callable? [ "Not a quotation" throw ] unless ; inline
  22
  23 : <alarm> ( quot time frequency -- alarm )
  24     check-alarm <box> alarm boa ;
  25
  26 : register-alarm ( alarm -- )
  27     dup dup alarm-time alarms get-global heap-push*
  28     swap alarm-entry >box
  29     notify-alarm-thread ;
  30
  31 : alarm-expired? ( alarm now -- ? )
  32     >r alarm-time r> before=? ;
  33
  34 : reschedule-alarm ( alarm -- )
  35     dup alarm-time over alarm-interval time+
  36     over set-alarm-time
  37     register-alarm ;
  38
  39 : call-alarm ( alarm -- )
  40     dup alarm-entry box> drop
  41     dup alarm-quot "Alarm execution" spawn drop
  42     dup alarm-interval [ reschedule-alarm ] [ drop ] if ;
  43
  44 : (trigger-alarms) ( alarms now -- )
  45     over heap-empty? [
  46         2drop
  47     ] [
  48         over heap-peek drop over alarm-expired? [
  49             over heap-pop drop call-alarm (trigger-alarms)
  50         ] [
  51             2drop
  52         ] if
  53     ] if ;
  54
  55 : trigger-alarms ( alarms -- )
  56     now (trigger-alarms) ;
  57
  58 : next-alarm ( alarms -- timestamp/f )
  59     dup heap-empty?
  60     [ drop f ] [ heap-peek drop alarm-time ] if ;
  61
  62 : alarm-thread-loop ( -- )
  63     alarms get-global
  64     dup next-alarm sleep-until
  65     trigger-alarms ;
  66
  67 : cancel-alarms ( alarms -- )
  68     [
  69         heap-pop-all [ nip alarm-entry box> drop ] assoc-each
  70     ] when* ;
  71
  72 : init-alarms ( -- )
  73     alarms global [ cancel-alarms <min-heap> ] change-at
  74     [ alarm-thread-loop t ] "Alarms" spawn-server
  75     alarm-thread set-global ;
  76
  77 [ init-alarms ] "alarms" add-init-hook
  78
  79 PRIVATE>
  80
  81 : add-alarm ( quot time frequency -- alarm )
  82     <alarm> [ register-alarm ] keep ;
  83
  84 : later ( quot dt -- alarm )
  85     hence f add-alarm ;
  86
  87 : every ( quot dt -- alarm )
  88     [ hence ] keep add-alarm ;
  89
  90 : cancel-alarm ( alarm -- )
  91     alarm-entry [ alarms get-global heap-delete ] if-box? ;