diff --git a/basis/alarms/alarms-docs.factor b/basis/alarms/alarms-docs.factor index 396011a351..34a26d12da 100644 --- a/basis/alarms/alarms-docs.factor +++ b/basis/alarms/alarms-docs.factor @@ -4,20 +4,6 @@ IN: alarms HELP: alarm { $class-description "An alarm. Can be passed to " { $link cancel-alarm } "." } ; -HELP: current-alarm -{ $description "A symbol that contains the currently executing alarm, availble only to the alarm quotation. One use for this symbol is if a repeated alarm wishes to cancel itself from executing in the future." -} -{ $examples - { $unchecked-example - """USING: alarms calendar io threads ;""" - """[""" - """ "Hi, this should only get printed once..." print flush""" - """ current-alarm get cancel-alarm""" - """] 1 seconds every""" - "" - } -} ; - 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." } ; @@ -28,7 +14,18 @@ HELP: later { $examples { $unchecked-example "USING: alarms io calendar ;" - """[ "Break's over!" print flush ] 15 minutes drop""" + """[ "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""" "" } } ; @@ -50,16 +47,28 @@ HELP: every } } ; +HELP: 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." } +{ $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""" + "" + } +} ; + ARTICLE: "alarms" "Alarms" -"The " { $vocab-link "alarms" } " vocabulary provides a lightweight way to schedule one-time and recurring tasks without spawning a new thread. Alarms use " { $link nano-count } ", so they continue to work across system clock changes." $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. 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 alarm class:" { $subsections alarm } "Register a recurring alarm:" -{ $subsections every } +{ $subsections every every* } "Register a one-time alarm:" -{ $subsections later } -"The currently executing alarm:" -{ $subsections current-alarm } +{ $subsections later later* } "Low-level interface to add alarms:" { $subsections add-alarm } "Cancelling an alarm:" diff --git a/basis/alarms/alarms.factor b/basis/alarms/alarms.factor index 9ab30a1fa4..cd8d1e3159 100644 --- a/basis/alarms/alarms.factor +++ b/basis/alarms/alarms.factor @@ -1,22 +1,22 @@ ! Copyright (C) 2005, 2008 Slava Pestov, Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors assocs boxes calendar combinators.short-circuit -continuations fry heaps init kernel math.order -namespaces quotations threads math system ; +USING: accessors assocs calendar combinators.short-circuit fry +heaps init kernel math math.functions math.parser namespaces +quotations sequences system threads ; IN: alarms TUPLE: alarm { quot callable initial: [ ] } { start integer } interval - { entry box } ; + { previous-iteration-begin integer } + { iteration-begin integer } + { stop? boolean } ; SYMBOL: alarms SYMBOL: alarm-thread -SYMBOL: current-alarm -: cancel-alarm ( alarm -- ) - entry>> [ alarms get-global heap-delete ] if-box? ; +: cancel-alarm ( alarm -- ) t >>stop? drop ; nanoseconds duration>nanoseconds >integer ; alarm new swap >nanoseconds >>interval swap >nanoseconds nano-count + >>start - swap >>quot - >>entry ; + swap >>quot ; : register-alarm ( alarm -- ) - [ dup start>> alarms get-global heap-push* ] - [ entry>> >box ] bi + dup start>> alarms get-global heap-push* drop notify-alarm-thread ; : alarm-expired? ( alarm n -- ? ) [ start>> ] dip <= ; -: reschedule-alarm ( alarm -- ) - dup interval>> nano-count + >>start register-alarm ; +: next-alarm-time ( alarm -- n ) + ! start + ceiling((now - start) / interval) * interval + nano-count + over start>> - + over interval>> / ceiling + over interval>> * + swap start>> + ; inline + +DEFER: call-alarm-loop + +: loop-alarm ( alarm -- ) + nano-count over + [ iteration-begin>> - ] [ interval>> ] bi < [ + [ next-alarm-time sleep-until ] keep + call-alarm-loop + ] [ + 0 sleep-until call-alarm-loop + ] if ; + +: maybe-loop-alarm ( alarm -- ) + dup { [ stop?>> ] [ interval>> not ] } 1|| + [ drop ] [ loop-alarm ] if ; + +: call-alarm-loop ( alarm -- ) + dup stop?>> [ + drop + ] [ + [ + dup iteration-begin>> >>previous-iteration-begin + nano-count >>iteration-begin + [ ] [ quot>> ] bi call( obj -- ) + ] keep maybe-loop-alarm + ] if ; : call-alarm ( alarm -- ) - [ entry>> box> drop ] - [ dup interval>> [ reschedule-alarm ] [ drop ] if ] - [ - [ ] [ quot>> ] [ ] tri - '[ - _ current-alarm - [ - _ [ _ dup interval>> [ cancel-alarm ] [ drop ] if rethrow ] - recover - ] with-variable - ] "Alarm execution" spawn drop - ] tri ; + '[ _ call-alarm-loop ] "Alarm execution" spawn drop ; : (trigger-alarms) ( alarms n -- ) over heap-empty? [ @@ -84,7 +102,7 @@ M: duration >nanoseconds duration>nanoseconds >integer ; : cancel-alarms ( alarms -- ) [ - heap-pop-all [ nip entry>> box> drop ] assoc-each + heap-pop-all [ nip t >>stop? drop ] assoc-each ] when* ; : init-alarms ( -- ) @@ -94,11 +112,31 @@ M: duration >nanoseconds duration>nanoseconds >integer ; [ init-alarms ] "alarms" add-startup-hook +: drop-alarm ( quot duration -- quot' duration ) + [ [ drop ] prepose ] dip ; inline + PRIVATE> +: alarm-overdue ( alarm -- n/f ) + dup { [ interval>> not ] [ previous-iteration-begin>> 0 = ] } 1|| [ + drop f + ] [ + [ iteration-begin>> ] + [ previous-iteration-begin>> - ] + [ interval>> ] tri 2dup >= [ + nip + ] [ + 2drop f + ] if + ] if ; + : add-alarm ( quot start interval -- alarm ) [ register-alarm ] keep ; -: later ( quot duration -- alarm ) f add-alarm ; +: later* ( quot: ( alarm -- ) duration -- alarm ) f add-alarm ; -: every ( quot duration -- alarm ) dup add-alarm ; +: later ( quot: ( -- ) duration -- alarm ) drop-alarm later* ; + +: every* ( quot: ( alarm -- ) duration -- alarm ) dup add-alarm ; + +: every ( quot: ( -- ) duration -- alarm ) drop-alarm every* ;