Cleaner implementation of alarms. Separate creating alarm from starting/stopping them.
Doug Coleman
parent
4116d8a159
commit
09d2a7dbc7
|
|
@ -2,43 +2,21 @@ USING: help.markup help.syntax calendar quotations system ;
|
|||
IN: alarms
|
||||
|
||||
HELP: alarm
|
||||
{ $class-description "An alarm. Can be passed to " { $link cancel-alarm } "." } ;
|
||||
{ $class-description "An alarm. Can be passed to " { $link stop-alarm } "." } ;
|
||||
|
||||
HELP: add-alarm
|
||||
{ $values { "quot" quotation } { "start" duration } { "interval" { $maybe "duration/f" } } { "alarm" alarm } }
|
||||
{ $description "Creates and registers an alarm to start at " { $snippet "start" } " offset from the current time. If " { $snippet "interval" } " is " { $link f } ", this will be a one-time alarm, otherwise it will fire with the given frequency, with scheduling happening before the quotation is called in order to ensure that the next event will happen on time. The quotation will be called from a new thread spawned by the alarm thread. If a repeated alarm's quotation throws an exception, the alarm will not be rescheduled." } ;
|
||||
|
||||
HELP: later
|
||||
{ $values { "quot" quotation } { "duration" duration } { "alarm" alarm } }
|
||||
{ $description "Creates and registers an alarm which calls the quotation once at " { $snippet "duration" } " offset from now." }
|
||||
{ $examples
|
||||
{ $unchecked-example
|
||||
"USING: alarms io calendar ;"
|
||||
"""[ "Break's over!" print flush ] 15 minutes later drop"""
|
||||
""
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: later*
|
||||
{ $values { "quot" quotation } { "duration" duration } { "alarm" alarm } }
|
||||
{ $description "Creates and registers an alarm which calls the quotation once at " { $snippet "duration" } " offset from now. The alarm is passed to the quotation as an input." }
|
||||
{ $examples
|
||||
{ $unchecked-example
|
||||
"USING: alarms io calendar ;"
|
||||
"""[ cancel-alarm "Break's over!" print flush ] 15 minutes later* drop"""
|
||||
""
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: cancel-alarm
|
||||
HELP: start-alarm
|
||||
{ $values { "alarm" alarm } }
|
||||
{ $description "Cancels an alarm. Does nothing if the alarm is not active." } ;
|
||||
{ $description "Starts an alarm." } ;
|
||||
|
||||
HELP: stop-alarm
|
||||
{ $values { "alarm" alarm } }
|
||||
{ $description "Prevents an alarm from calling its quotation again. Has no effect on alarms that are not currently running." } ;
|
||||
|
||||
HELP: every
|
||||
{ $values
|
||||
{ "quot" quotation } { "duration" duration }
|
||||
{ "quot" quotation } { "interval-duration" duration }
|
||||
{ "alarm" alarm } }
|
||||
{ $description "Creates and registers an alarm which calls the quotation repeatedly, using " { $snippet "dt" } " as the frequency. If the quotation throws an exception that is not caught inside it, the alarm scheduler will cancel the alarm and will not reschedule it again." }
|
||||
{ $description "Creates an alarm that calls the quotation repeatedly, using " { $snippet "duration" } " as the frequency. The first call of " { $snippet "quot" } " will happen immediately. If the quotation throws an exception, the alarm will stop." }
|
||||
{ $examples
|
||||
{ $unchecked-example
|
||||
"USING: alarms io calendar ;"
|
||||
|
|
@ -47,32 +25,46 @@ HELP: every
|
|||
}
|
||||
} ;
|
||||
|
||||
HELP: every*
|
||||
HELP: later
|
||||
{ $values { "quot" quotation } { "delay-duration" duration } { "alarm" alarm } }
|
||||
{ $description "Sleeps for " { $snippet "duration" } " and then calls a " { $snippet "quot" } ". The user may cancel the alarm before " { $snippet "quot" } " runs. This alarm is not repeated." }
|
||||
{ $examples
|
||||
{ $unchecked-example
|
||||
"USING: alarms io calendar ;"
|
||||
"""[ "Break's over!" print flush ] 15 minutes later drop"""
|
||||
""
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: delayed-every
|
||||
{ $values
|
||||
{ "quot" quotation } { "duration" duration }
|
||||
{ "alarm" alarm } }
|
||||
{ $description "Creates and registers an alarm which calls the quotation repeatedly, using " { $snippet "dt" } " as the frequency. The alarm is passed as an input to the quotation. If the quotation throws an exception that is not caught inside it, the alarm scheduler will cancel the alarm and will not reschedule it again." }
|
||||
{ $description "Creates an alarm that calls " { $snippet "quot" } " repeatedly, waiting " { $snippet "duration" } " before calling " { $snippet "quot" } " the first time and then waiting " { $snippet "duration" } " between further calls. If the quotation throws an exception, the alarm will stop." }
|
||||
{ $examples
|
||||
"Cancelling an alarm from within the alarm:"
|
||||
{ $unchecked-example
|
||||
"USING: alarms io calendar inspector ;"
|
||||
"""[ cancel-alarm "Hi Buddy." print flush ] 10 seconds every* drop"""
|
||||
"USING: alarms io calendar ;"
|
||||
"""[ "Hi Buddy." print flush ] 10 seconds every drop"""
|
||||
""
|
||||
}
|
||||
} ;
|
||||
|
||||
ARTICLE: "alarms" "Alarms"
|
||||
"The " { $vocab-link "alarms" } " vocabulary provides a lightweight way to schedule one-time and recurring tasks. Alarms use " { $link nano-count } " as the timing primitive, so they will continue to work across system clock changes. Alarms run in a single green thread per alarm. If a recurring alarm's quotation would be scheduled to run again before the previous quotation has finished processing, the alarm will be run again immediately afterwards. This may result in the alarm falling behind indefinitely, in which case the it will run as often as possible while still allowing other green threads to run. Finally, recurring alarms that execute 'on time' or 'catch up' will always be scheduled for an exact multiple of the interval from the original starting time, which prevents the alarm from drifting over time." $nl
|
||||
"The " { $vocab-link "alarms" } " vocabulary provides a lightweight way to schedule one-time and recurring tasks. Alarms use " { $link nano-count } " as the timing primitive, so they will continue to work across system clock changes. Alarms run in a single green thread per alarm. If a recurring alarm's quotation would be scheduled to run again before the previous quotation has finished processing, the alarm will be run again immediately afterwards. This may result in the alarm falling behind indefinitely, in which case the it will run as often as possible while still allowing other green threads to run. Recurring alarms that execute 'on time' or 'catch up' will always be scheduled for an exact multiple of the interval from the original starting time, which prevents the alarm from drifting over time. Generally, alarms have a delay duration and an interval duration. Starting an alarm first waits out the delay duration, and then waits out the interval duration for every call thereafter. Alarms do not persist across saving and loading an image." $nl
|
||||
"The alarm class:"
|
||||
{ $subsections alarm }
|
||||
"Register a recurring alarm:"
|
||||
{ $subsections every every* }
|
||||
"Register a one-time alarm:"
|
||||
{ $subsections later later* }
|
||||
"Low-level interface to add alarms:"
|
||||
{ $subsections add-alarm }
|
||||
"Cancelling an alarm:"
|
||||
{ $subsections cancel-alarm }
|
||||
"Alarms do not persist across image saves. Saving and restoring an image has the effect of calling " { $link cancel-alarm } " on all " { $link alarm } " instances." ;
|
||||
"Create an alarm before starting it:"
|
||||
{ $subsections <alarm> }
|
||||
"Starting an alarm:"
|
||||
{ $subsections start-alarm }
|
||||
"Stopping an alarm:"
|
||||
{ $subsections stop-alarm }
|
||||
|
||||
"A recurring alarm without an initial delay:"
|
||||
{ $subsections every }
|
||||
"A one-time alarm with an initial delay:"
|
||||
{ $subsections later }
|
||||
"A recurring alarm with an initial delay:"
|
||||
{ $subsections delayed-every } ;
|
||||
|
||||
ABOUT: "alarms"
|
||||
|
|
|
|||
|
|
@ -7,122 +7,83 @@ IN: alarms
|
|||
|
||||
TUPLE: alarm
|
||||
{ quot callable initial: [ ] }
|
||||
{ start integer }
|
||||
interval
|
||||
{ iteration-scheduled integer }
|
||||
start-nanos
|
||||
delay-nanos
|
||||
interval-nanos integer
|
||||
{ next-iteration-nanos integer }
|
||||
{ stop? boolean } ;
|
||||
|
||||
SYMBOL: alarms
|
||||
SYMBOL: alarm-thread
|
||||
|
||||
: cancel-alarm ( alarm -- ) t >>stop? drop ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: notify-alarm-thread ( -- )
|
||||
alarm-thread get-global interrupt ;
|
||||
|
||||
GENERIC: >nanoseconds ( obj -- duration/f )
|
||||
M: f >nanoseconds ;
|
||||
M: real >nanoseconds >integer ;
|
||||
M: duration >nanoseconds duration>nanoseconds >integer ;
|
||||
|
||||
: <alarm> ( quot start interval -- alarm )
|
||||
alarm new
|
||||
swap >nanoseconds >>interval
|
||||
nano-count >>start
|
||||
swap >nanoseconds over start>> + >>iteration-scheduled
|
||||
swap >>quot ; inline
|
||||
|
||||
: register-alarm ( alarm -- )
|
||||
dup iteration-scheduled>> alarms get-global heap-push* drop
|
||||
notify-alarm-thread ;
|
||||
|
||||
: alarm-expired? ( alarm n -- ? )
|
||||
[ start>> ] dip <= ;
|
||||
|
||||
: set-next-alarm-time ( alarm -- alarm )
|
||||
! start + ceiling((now - start) / interval) * interval
|
||||
! start + delay + ceiling((now - start) / interval) * interval
|
||||
nano-count
|
||||
over start>> -
|
||||
over interval>> / ceiling
|
||||
over interval>> *
|
||||
over start>> + >>iteration-scheduled ; inline
|
||||
over start-nanos>> -
|
||||
over delay-nanos>> [ + ] when*
|
||||
over interval-nanos>> / ceiling
|
||||
over interval-nanos>> *
|
||||
over start-nanos>> + >>next-iteration-nanos ; inline
|
||||
|
||||
DEFER: call-alarm-loop
|
||||
|
||||
: loop-alarm ( alarm -- )
|
||||
nano-count over
|
||||
[ iteration-scheduled>> - ] [ interval>> ] bi <
|
||||
[ set-next-alarm-time ] dip [
|
||||
[ iteration-scheduled>> sleep-until ]
|
||||
[ call-alarm-loop ] bi
|
||||
] [
|
||||
0 sleep-until call-alarm-loop
|
||||
] if ;
|
||||
[ next-iteration-nanos>> - ] [ interval-nanos>> ] bi <
|
||||
[ set-next-alarm-time ] dip
|
||||
[ dup next-iteration-nanos>> ] [ 0 ] if
|
||||
sleep-until call-alarm-loop ;
|
||||
|
||||
: maybe-loop-alarm ( alarm -- )
|
||||
dup { [ stop?>> ] [ interval>> not ] } 1||
|
||||
dup { [ stop?>> ] [ interval-nanos>> not ] } 1||
|
||||
[ drop ] [ loop-alarm ] if ;
|
||||
|
||||
: call-alarm-loop ( alarm -- )
|
||||
dup stop?>> [
|
||||
drop
|
||||
] [
|
||||
[
|
||||
[ ] [ quot>> ] bi call( obj -- )
|
||||
] keep maybe-loop-alarm
|
||||
[ quot>> call( -- ) ] keep
|
||||
maybe-loop-alarm
|
||||
] if ;
|
||||
|
||||
: call-alarm ( alarm -- )
|
||||
'[ _ call-alarm-loop ] "Alarm execution" spawn drop ;
|
||||
|
||||
: (trigger-alarms) ( alarms n -- )
|
||||
over heap-empty? [
|
||||
2drop
|
||||
] [
|
||||
over heap-peek drop over alarm-expired? [
|
||||
over heap-pop drop call-alarm (trigger-alarms)
|
||||
] [
|
||||
2drop
|
||||
] if
|
||||
] if ;
|
||||
|
||||
: trigger-alarms ( alarms -- )
|
||||
nano-count (trigger-alarms) ;
|
||||
|
||||
: next-alarm ( alarms -- nanos/f )
|
||||
dup heap-empty? [ drop f ] [ heap-peek drop start>> ] if ;
|
||||
|
||||
: alarm-thread-loop ( -- )
|
||||
alarms get-global
|
||||
dup next-alarm sleep-until
|
||||
trigger-alarms ;
|
||||
|
||||
: cancel-alarms ( alarms -- )
|
||||
[
|
||||
heap-pop-all [ nip t >>stop? drop ] assoc-each
|
||||
] when* ;
|
||||
|
||||
: init-alarms ( -- )
|
||||
alarms [ cancel-alarms <min-heap> ] change-global
|
||||
[ alarm-thread-loop t ] "Alarms" spawn-server
|
||||
alarm-thread set-global ;
|
||||
|
||||
[ init-alarms ] "alarms" add-startup-hook
|
||||
|
||||
: drop-alarm ( quot duration -- quot' duration )
|
||||
[ [ drop ] prepose ] dip ; inline
|
||||
[ delay-nanos>> ] [ ] bi
|
||||
'[ _ [ sleep ] when* _ call-alarm-loop ] "Alarm execution" spawn drop ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: add-alarm ( quot start interval -- alarm )
|
||||
<alarm> [ register-alarm ] keep ;
|
||||
: <alarm> ( quot delay-duration/f interval-duration/f -- alarm )
|
||||
alarm new
|
||||
swap >nanoseconds >>interval-nanos
|
||||
swap >nanoseconds >>delay-nanos
|
||||
swap >>quot ; inline
|
||||
|
||||
: later* ( quot: ( alarm -- ) duration -- alarm ) f add-alarm ;
|
||||
: start-alarm ( alarm -- )
|
||||
f >>stop?
|
||||
nano-count >>start-nanos
|
||||
call-alarm ;
|
||||
|
||||
: later ( quot: ( -- ) duration -- alarm ) drop-alarm later* ;
|
||||
: stop-alarm ( alarm -- )
|
||||
t >>stop?
|
||||
f >>start-nanos
|
||||
drop ;
|
||||
|
||||
: every* ( quot: ( alarm -- ) duration -- alarm ) dup add-alarm ;
|
||||
<PRIVATE
|
||||
|
||||
: every ( quot: ( -- ) duration -- alarm ) drop-alarm every* ;
|
||||
: (start-alarm) ( quot start-duration interval-duration -- alarm )
|
||||
<alarm> [ start-alarm ] keep ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: every ( quot interval-duration -- alarm )
|
||||
[ f ] dip (start-alarm) ;
|
||||
|
||||
: later ( quot delay-duration -- alarm )
|
||||
f (start-alarm) ;
|
||||
|
||||
: delayed-every ( quot duration -- alarm )
|
||||
dup (start-alarm) ;
|
||||
|
|
|
|||
Loading…
Reference in New Issue