2006-05-10 20:32:04 -04:00
|
|
|
! Copyright (C) 2004, 2006 Slava Pestov.
|
2005-02-07 18:27:55 -05:00
|
|
|
! Copyright (C) 2005 Mackenzie Straight.
|
2006-05-10 20:32:04 -04:00
|
|
|
! See http://factorcode.org/license.txt for BSD license.
|
2004-08-20 21:26:25 -04:00
|
|
|
IN: threads
|
2006-05-10 20:32:04 -04:00
|
|
|
USING: arrays errors hashtables io-internals kernel math
|
2005-08-23 15:50:32 -04:00
|
|
|
namespaces queues sequences vectors ;
|
2004-08-20 21:26:25 -04:00
|
|
|
|
2005-08-23 15:50:32 -04:00
|
|
|
! Co-operative multitasker.
|
|
|
|
|
2006-03-19 00:30:57 -05:00
|
|
|
: run-queue ( -- queue ) \ run-queue get-global ;
|
2005-08-23 15:50:32 -04:00
|
|
|
|
2006-01-07 17:05:59 -05:00
|
|
|
: schedule-thread ( continuation -- ) run-queue enque ;
|
2005-08-23 15:50:32 -04:00
|
|
|
|
2006-03-19 00:30:57 -05:00
|
|
|
: sleep-queue ( -- vec ) \ sleep-queue get-global ;
|
2005-08-23 15:50:32 -04:00
|
|
|
|
|
|
|
: sleep-queue* ( -- vec )
|
2006-05-10 20:32:04 -04:00
|
|
|
sleep-queue dup [ [ first ] 2apply swap - ] nsort ;
|
2005-08-23 15:50:32 -04:00
|
|
|
|
|
|
|
: sleep-time ( sorted-queue -- ms )
|
2006-06-09 19:58:11 -04:00
|
|
|
dup empty? [ drop 1000 ] [ peek first millis [-] ] if ;
|
2005-08-23 15:50:32 -04:00
|
|
|
|
|
|
|
DEFER: next-thread
|
|
|
|
|
2006-01-07 17:05:59 -05:00
|
|
|
: do-sleep ( -- continuation )
|
2006-01-28 15:49:31 -05:00
|
|
|
sleep-queue* dup sleep-time dup zero?
|
2006-05-10 20:32:04 -04:00
|
|
|
[ drop pop second ] [ nip io-multiplex next-thread ] if ;
|
2005-02-07 18:04:49 -05:00
|
|
|
|
2006-01-07 17:05:59 -05:00
|
|
|
: next-thread ( -- continuation )
|
2005-09-24 15:21:17 -04:00
|
|
|
run-queue dup queue-empty? [ drop do-sleep ] [ deque ] if ;
|
2005-08-23 15:50:32 -04:00
|
|
|
|
2005-09-14 00:37:50 -04:00
|
|
|
: stop ( -- ) next-thread continue ;
|
2005-08-23 15:50:32 -04:00
|
|
|
|
2005-09-18 01:37:28 -04:00
|
|
|
: yield ( -- ) [ schedule-thread stop ] callcc0 ;
|
2005-08-23 15:50:32 -04:00
|
|
|
|
|
|
|
: sleep ( ms -- )
|
2006-05-10 20:32:04 -04:00
|
|
|
millis + [ 2array sleep-queue push stop ] callcc0 drop ;
|
2005-08-23 15:50:32 -04:00
|
|
|
|
|
|
|
: in-thread ( quot -- )
|
|
|
|
[
|
|
|
|
schedule-thread
|
2006-05-14 23:09:47 -04:00
|
|
|
V{ } set-catchstack
|
|
|
|
V{ } set-callstack
|
|
|
|
V{ } set-retainstack
|
2005-08-23 15:50:32 -04:00
|
|
|
try stop
|
2005-09-18 01:37:28 -04:00
|
|
|
] callcc0 drop ;
|
2005-08-23 15:50:32 -04:00
|
|
|
|
2005-08-24 00:30:07 -04:00
|
|
|
: init-threads ( -- )
|
|
|
|
global [
|
|
|
|
<queue> \ run-queue set
|
2005-10-29 23:25:38 -04:00
|
|
|
V{ } clone \ sleep-queue set
|
2005-08-24 00:30:07 -04:00
|
|
|
] bind ;
|