New alarm system

core/heaps/heaps-docs.factor

@@ -18,7 +18,7 @@ $nl
 $nl
 "Queries:"
 { $subsection heap-empty? }
-{ $subsection heap-length }
+{ $subsection heap-size }
 { $subsection heap-peek }
 "Insertion:"
 { $subsection heap-push }
@@ -40,43 +40,43 @@ HELP: <max-heap>
 { $description "Create a new " { $link max-heap } "." } ;
 
 HELP: heap-push
-{ $values { "key" "a comparable object" } { "value" object } { "heap" heap } }
+{ $values { "key" "a comparable object" } { "value" object } { "heap" "a heap" } }
 { $description "Push a pair onto a heap. The key must be comparable with all other keys by the " { $link <=> } " generic word." }
 { $side-effects "heap" } ;
 
 HELP: heap-push*
-{ $values { "key" "a comparable object" } { "value" object } { "heap" heap } { "entry" entry } }
+{ $values { "key" "a comparable object" } { "value" object } { "heap" "a heap" } { "entry" entry } }
 { $description "Push a pair onto a heap, and output an entry which may later be passed to " { $link heap-delete } "." }
 { $side-effects "heap" } ;
 
 HELP: heap-push-all
-{ $values { "assoc" assoc } { "heap" heap } }
+{ $values { "assoc" assoc } { "heap" "a heap" } }
 { $description "Push every key/value pair of an assoc onto a heap." }
 { $side-effects "heap" } ;
 
 HELP: heap-peek
-{ $values { "heap" heap } { "key" object } { "value" object } }
+{ $values { "heap" "a heap" } { "key" object } { "value" object } }
 { $description "Output the first element in the heap, leaving it in the heap." } ;
 
 HELP: heap-pop*
-{ $values { "heap" heap } }
+{ $values { "heap" "a heap" } }
 { $description "Remove the first element from the heap." }
 { $side-effects "heap" } ;
 
 HELP: heap-pop
-{ $values { "heap" heap } { "key" object } { "value" object } }
+{ $values { "heap" "a heap" } { "key" object } { "value" object } }
 { $description "Output and remove the first element in the heap." }
 { $side-effects "heap" } ;
 
 HELP: heap-empty?
-{ $values { "heap" heap } { "?" "a boolean" } }
+{ $values { "heap" "a heap" } { "?" "a boolean" } }
-{ $description "Tests if a " { $link heap } " has no nodes." } ;
+{ $description "Tests if a heap has no nodes." } ;
 
 HELP: heap-size
-{ $values { "heap" heap } { "n" integer } }
+{ $values { "heap" "a heap" } { "n" integer } }
 { $description "Returns the number of key/value pairs in the heap." } ;
 
 HELP: heap-delete
-{ $values { "heap" heap } { "key" object } { "value" object } }
+{ $values { "heap" "a heap" } { "key" object } { "value" object } }
 { $description "Output and remove the first element in the heap." }
 { $side-effects "heap" } ;

core/heaps/heaps.factor

@@ -11,7 +11,7 @@ GENERIC: heap-push* ( value key heap -- entry )
 GENERIC: heap-peek ( heap -- value key )
 GENERIC: heap-pop* ( heap -- )
 GENERIC: heap-pop ( heap -- value key )
-GENERIC: heap-delete ( entry -- )
+GENERIC: heap-delete ( entry heap -- )
 GENERIC: heap-empty? ( heap -- ? )
 GENERIC: heap-size ( heap -- n )
 

core/threads/threads-docs.factor

@@ -17,7 +17,11 @@ ARTICLE: "threads-start/stop" "Starting and stopping threads"
 ARTICLE: "threads-yield" "Yielding and suspending threads"
 "Yielding to other threads:"
 { $subsection yield }
+"Sleeping for a period of time:"
 { $subsection sleep }
+"Interruptible sleep:"
+{ $subsection nap }
+{ $subsection interrupt }
 "Threads can be suspended and woken up at some point in the future when a condition is satisfied:"
 { $subsection suspend }
 { $subsection resume }
@@ -104,7 +108,16 @@ HELP: yield
 
 HELP: sleep
 { $values { "ms" "a non-negative integer" } }
-{ $description "Suspends the current thread for " { $snippet "ms" } " milliseconds. It will not get woken up before this time period elapses, but since the multitasker is co-operative, the precise wakeup time is dependent on when other threads yield." } ;
+{ $description "Suspends the current thread for " { $snippet "ms" } " milliseconds." }
+{ $errors "Throws an error if another thread interrupted the sleep with " { $link interrupt } "." } ;
+
+HELP: nap
+{ $values { "ms/f" "a non-negative integer or " { $link f } } { "?" "a boolean indicating whether the thread was interrupted" } }
+{ $description "Suspends the current thread until another thread interrupts it with " { $link interrupt } ". If the input parameter is not " { $link f } ", then the thread will also wake up if the timeout expires before an interrupt is received." } ;
+
+HELP: interrupt
+{ $values { "thread" thread } }
+{ $description "Interrupts a sleeping thread." } ;
 
 HELP: suspend
 { $values { "quot" "a quotation with stack effect " { $snippet "( thread -- )" } } { "obj" object } }

core/threads/threads.factor

@@ -13,7 +13,7 @@ TUPLE: thread
 name quot error-handler exit-handler
 id
 continuation state
-mailbox variables ;
+mailbox variables sleep-entry ;
 
 : self ( -- thread ) 40 getenv ; inline
 
@@ -86,19 +86,25 @@ PRIVATE>
 <PRIVATE
 
 : schedule-sleep ( thread ms -- )
-    >r check-registered r> sleep-queue heap-push ;
+    >r check-registered dup r> sleep-queue heap-push*
+    swap set-thread-sleep-entry ;
 
-: wake-up? ( heap -- ? )
+: expire-sleep? ( heap -- ? )
     dup heap-empty?
     [ drop f ] [ heap-peek nip millis <= ] if ;
 
-: wake-up ( -- )
+: expire-sleep ( thread -- )
+    f over set-thread-sleep-entry resume ;
+
+: expire-sleep-loop ( -- )
     sleep-queue
-    [ dup wake-up? ] [ dup heap-pop drop resume ] [ ] while
+    [ dup expire-sleep? ]
+    [ dup heap-pop drop expire-sleep ]
+    [ ] while
     drop ;
 
 : next ( -- )
-    wake-up
+    expire-sleep-loop
     run-queue pop-back
     dup array? [ first2 ] [ f swap ] if dup set-self
     f over set-thread-state
@@ -127,14 +133,23 @@ PRIVATE>
 
 : yield ( -- ) [ resume ] "yield" suspend drop ;
 
+: nap ( ms/f -- ? )
+    [
+        >fixnum millis + [ schedule-sleep ] curry "sleep"
+    ] [
+        [ drop ] "interrupt"
+    ] if* suspend ;
+
 : sleep ( ms -- )
-    >fixnum millis +
+    nap [ "Sleep interrupted" throw ] when ;
-    [ schedule-sleep ] curry
+
-    "sleep" suspend drop ;
+: interrupt ( thread -- )
+    dup thread-sleep-entry [ sleep-queue heap-delete ] when*
+    t swap resume-with ;
 
 : (spawn) ( thread -- )
     [
-        resume [
+        resume-now [
             dup set-self
             dup register-thread
             init-namespaces

extra/alarms/alarms.factor

@@ -1,87 +1,80 @@
-! Copyright (C) 2007 Doug Coleman.
+! Copyright (C) 2005, 2008 Slava Pestov, Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: arrays calendar combinators concurrency.messaging
+USING: arrays calendar combinators generic init kernel math
-threads generic init kernel math namespaces sequences ;
+namespaces sequences heaps boxes threads debugger quotations ;
 IN: alarms
 
-TUPLE: alarm time quot ;
+TUPLE: alarm time interval quot entry ;
 
-C: <alarm> alarm
+: check-alarm
+    pick timestamp? [ "Not a timestamp" throw ] unless
+    over dup dt? swap not or [ "Not a dt" throw ] unless
+    dup callable? [ "Not a quotation" throw ] unless ; inline
 
-<PRIVATE
+: <alarm> ( time delay quot -- alarm )
+    check-alarm <box> alarm construct-boa ;
 
-! for now a V{ }, eventually a min-heap to store alarms
+! Global min-heap
 SYMBOL: alarms
-SYMBOL: alarm-receiver
+SYMBOL: alarm-thread
-SYMBOL: alarm-looper
 
-: add-alarm ( alarm -- )
+: notify-alarm-thread ( -- )
-    alarms get-global push ;
+    alarm-thread get-global interrupt ;
 
-: remove-alarm ( alarm -- )
+: add-alarm ( time delay quot -- alarm )
-    alarms get-global delete ;
+    <alarm> [
+        dup dup alarm-time alarms get-global heap-push*
+        swap alarm-entry >box
+        notify-alarm-thread
+    ] keep ;
 
-: handle-alarm ( alarm -- )
+: cancel-alarm ( alarm -- )
-    dup delegate {
+    alarm-entry box> alarms get-global heap-delete ;
-        { "register" [ add-alarm ] }
-        { "unregister" [ remove-alarm  ] }
-    } case ;
 
-: expired-alarms ( -- seq )
+: alarm-expired? ( alarm now -- ? )
-    now alarms get-global
+    >r alarm-time r> <=> 0 <= ;
-    [ alarm-time <=> 0 > ] with subset ;
 
-: unexpired-alarms ( -- seq )
+: reschedule-alarm ( alarm -- )
-    now alarms get-global
+    dup alarm-time over alarm-interval +dt
-    [ alarm-time <=> 0 <= ] with subset ;
+    over set-alarm-time
+    add-alarm drop ;
 
 : call-alarm ( alarm -- )
-    alarm-quot "Alarm invocation" spawn drop ;
+    dup alarm-quot try
+    dup alarm-entry box> drop
+    dup alarm-interval [ reschedule-alarm ] [ drop ] if ;
 
-: do-alarms ( -- )
+: (trigger-alarms) ( alarms now -- )
-    expired-alarms [ call-alarm ] each
+    over heap-empty? [
-    unexpired-alarms alarms set-global ;
+        2drop
+    ] [
+        over heap-peek drop over alarm-expired? [
+            over heap-pop drop call-alarm
+            (trigger-alarms)
+        ] [
+            2drop
+        ] if
+    ] if ;
 
-: alarm-receive-loop ( -- )
+: trigger-alarms ( alarms -- )
-    receive dup alarm? [ handle-alarm ] [ drop ] if
+    now (trigger-alarms) ;
-    alarm-receive-loop ;
 
-: start-alarm-receiver ( -- )
+: next-alarm ( alarms -- ms )
-    [
+    dup heap-empty?
-        alarm-receive-loop
+    [ drop f ] [
-    ] "Alarm receiver" spawn alarm-receiver set-global ;
+        heap-peek drop alarm-time now
+        [ timestamp>unix-time ] 2apply [-] 1000 *
+    ] if ;
 
-: alarm-loop ( -- )
+: alarm-thread-loop ( -- )
-    alarms get-global empty? [
+    alarms get-global
-        do-alarms
+    dup next-alarm nap drop
-    ] unless 100 sleep alarm-loop ;
+    dup trigger-alarms
+    alarm-thread-loop ;
 
-: start-alarm-looper ( -- )
+: init-alarms ( -- )
-    [
+    <min-heap> alarms set-global
-        alarm-loop
+    [ alarm-thread-loop ] "Alarms" spawn
-    ] "Alarm looper" spawn alarm-looper set-global ;
+    alarm-thread set-global ;
 
-: send-alarm ( str alarm -- )
+[ init-alarms ] "alarms" add-init-hook
-    over set-delegate
-    alarm-receiver get-global send ;
-
-: start-alarm-daemon ( -- )
-    alarms get-global [ V{ } clone alarms set-global ] unless
-    start-alarm-looper
-    start-alarm-receiver ;
-
-[ start-alarm-daemon ] "alarms" add-init-hook
-PRIVATE>
-
-: register-alarm ( alarm -- )
-    "register" send-alarm ;
-
-: unregister-alarm ( alarm -- )
-    "unregister" send-alarm ;
-
-: change-alarm ( alarm-old alarm-new -- )
-    "register" send-alarm
-    "unregister" send-alarm ;
-
-! Example:
-! 5 seconds from-now [ "hi" print flush ] <alarm> register-alarm

extra/calendar/calendar.factor

@@ -223,7 +223,7 @@ M: timestamp <=> ( ts1 ts2 -- n )
     [ >time< >r >r 3600 * r> 60 * r> + + ] 2apply - + ;
 
 : unix-1970 ( -- timestamp )
-    1970 1 1 0 0 0 0 <timestamp> ;
+    1970 1 1 0 0 0 0 <timestamp> ; foldable
 
 : unix-time>timestamp ( n -- timestamp )
     >r unix-1970 r> seconds +dt ;