From 1b4b1a180c67e4ca4d4cd5007b1796082e7282a6 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 1 Apr 2010 20:05:32 -0400 Subject: [PATCH] Some minor pointless optimizations --- basis/boxes/boxes.factor | 6 +-- .../concurrency/conditions/conditions.factor | 8 ++-- basis/concurrency/mailboxes/mailboxes.factor | 21 +++++---- basis/concurrency/messaging/messaging.factor | 20 +++++---- basis/dlists/dlists.factor | 2 +- basis/heaps/heaps.factor | 2 +- basis/threads/threads.factor | 44 +++++++------------ 7 files changed, 47 insertions(+), 56 deletions(-) diff --git a/basis/boxes/boxes.factor b/basis/boxes/boxes.factor index 811c5addb0..a159e1402b 100644 --- a/basis/boxes/boxes.factor +++ b/basis/boxes/boxes.factor @@ -11,7 +11,7 @@ ERROR: box-full box ; : >box ( value box -- ) dup occupied>> - [ box-full ] [ t >>occupied (>>value) ] if ; + [ box-full ] [ t >>occupied (>>value) ] if ; inline ERROR: box-empty box ; @@ -19,10 +19,10 @@ ERROR: box-empty box ; dup occupied>> [ box-empty ] unless ; inline : box> ( box -- value ) - check-box [ f ] change-value f >>occupied drop ; + check-box [ f ] change-value f >>occupied drop ; inline : ?box ( box -- value/f ? ) - dup occupied>> [ box> t ] [ drop f f ] if ; + dup occupied>> [ box> t ] [ drop f f ] if ; inline : if-box? ( box quot -- ) [ ?box ] dip [ drop ] if ; inline diff --git a/basis/concurrency/conditions/conditions.factor b/basis/concurrency/conditions/conditions.factor index 4a1c7d3370..2fb75226eb 100644 --- a/basis/concurrency/conditions/conditions.factor +++ b/basis/concurrency/conditions/conditions.factor @@ -4,10 +4,10 @@ USING: deques threads kernel arrays sequences alarms fry ; IN: concurrency.conditions : notify-1 ( deque -- ) - dup deque-empty? [ drop ] [ pop-back resume-now ] if ; + dup deque-empty? [ drop ] [ pop-back resume-now ] if ; inline : notify-all ( deque -- ) - [ resume-now ] slurp-deque ; + [ resume-now ] slurp-deque ; inline : queue-timeout ( queue timeout -- alarm ) #! Add an alarm which removes the current thread from the @@ -23,7 +23,7 @@ IN: concurrency.conditions ERROR: wait-timeout ; : queue ( queue -- ) - [ self ] dip push-front ; + [ self ] dip push-front ; inline : wait ( queue timeout status -- ) over [ @@ -31,4 +31,4 @@ ERROR: wait-timeout ; [ wait-timeout ] [ cancel-alarm ] if ] [ [ drop queue ] dip suspend drop - ] if ; + ] if ; inline diff --git a/basis/concurrency/mailboxes/mailboxes.factor b/basis/concurrency/mailboxes/mailboxes.factor index e245f93bd5..163873575c 100644 --- a/basis/concurrency/mailboxes/mailboxes.factor +++ b/basis/concurrency/mailboxes/mailboxes.factor @@ -6,22 +6,24 @@ concurrency.conditions accessors debugger debugger.threads locals fry ; IN: concurrency.mailboxes -TUPLE: mailbox threads data ; +TUPLE: mailbox { threads dlist } { data dlist } ; : ( -- mailbox ) mailbox new >>threads - >>data ; + >>data ; inline : mailbox-empty? ( mailbox -- bool ) - data>> deque-empty? ; + data>> deque-empty? ; inline -: mailbox-put ( obj mailbox -- ) +GENERIC: mailbox-put ( obj mailbox -- ) + +M: mailbox mailbox-put [ data>> push-front ] [ threads>> notify-all ] bi yield ; : wait-for-mailbox ( mailbox timeout -- ) - [ threads>> ] dip "mailbox" wait ; + [ threads>> ] dip "mailbox" wait ; inline :: block-unless-pred ( ... mailbox timeout pred: ( ... message -- ... ? ) -- ... ) mailbox data>> pred dlist-any? [ @@ -34,16 +36,17 @@ TUPLE: mailbox threads data ; 2dup wait-for-mailbox block-if-empty ] [ drop - ] if ; + ] if ; inline recursive : mailbox-peek ( mailbox -- obj ) data>> peek-back ; -: mailbox-get-timeout ( mailbox timeout -- obj ) - block-if-empty data>> pop-back ; +GENERIC# mailbox-get-timeout 1 ( mailbox timeout -- obj ) + +M: mailbox mailbox-get-timeout block-if-empty data>> pop-back ; : mailbox-get ( mailbox -- obj ) - f mailbox-get-timeout ; + f mailbox-get-timeout ; inline : mailbox-get-all-timeout ( mailbox timeout -- array ) block-if-empty diff --git a/basis/concurrency/messaging/messaging.factor b/basis/concurrency/messaging/messaging.factor index 37965309e8..3f55b0969b 100644 --- a/basis/concurrency/messaging/messaging.factor +++ b/basis/concurrency/messaging/messaging.factor @@ -1,20 +1,22 @@ -! Copyright (C) 2005, 2008 Chris Double, Slava Pestov. +! Copyright (C) 2005, 2010 Chris Double, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel threads concurrency.mailboxes continuations -namespaces assocs accessors summary fry ; +USING: kernel kernel.private threads concurrency.mailboxes +continuations namespaces assocs accessors summary fry ; IN: concurrency.messaging GENERIC: send ( message thread -- ) -: mailbox-of ( thread -- mailbox ) - dup mailbox>> [ ] [ - [ >>mailbox drop ] keep - ] ?if ; +GENERIC: mailbox-of ( thread -- mailbox ) + +M: thread mailbox-of + dup mailbox>> + [ { mailbox } declare ] + [ [ >>mailbox drop ] keep ] ?if ; inline M: thread send ( message thread -- ) - check-registered mailbox-of mailbox-put ; + mailbox-of mailbox-put ; -: my-mailbox ( -- mailbox ) self mailbox-of ; +: my-mailbox ( -- mailbox ) self mailbox-of ; inline : receive ( -- message ) my-mailbox mailbox-get ?linked ; diff --git a/basis/dlists/dlists.factor b/basis/dlists/dlists.factor index 44140d3109..53e134fad9 100644 --- a/basis/dlists/dlists.factor +++ b/basis/dlists/dlists.factor @@ -29,7 +29,7 @@ TUPLE: dlist : ( -- search-deque ) 20 ; -M: dlist deque-empty? front>> not ; +M: dlist deque-empty? front>> not ; inline M: dlist-node node-value obj>> ; diff --git a/basis/heaps/heaps.factor b/basis/heaps/heaps.factor index 677daca69d..28d18cb53a 100644 --- a/basis/heaps/heaps.factor +++ b/basis/heaps/heaps.factor @@ -35,7 +35,7 @@ TUPLE: max-heap < heap ; : ( -- max-heap ) max-heap ; M: heap heap-empty? ( heap -- ? ) - data>> empty? ; + data>> empty? ; inline M: heap heap-size ( heap -- n ) data>> length ; diff --git a/basis/threads/threads.factor b/basis/threads/threads.factor index 117e941aa7..404c8112fb 100644 --- a/basis/threads/threads.factor +++ b/basis/threads/threads.factor @@ -80,23 +80,13 @@ sleep-entry ; : thread-registered? ( thread -- ? ) id>> threads key? ; -ERROR: already-stopped thread ; - -: check-unregistered ( thread -- thread ) - dup thread-registered? [ already-stopped ] when ; - -ERROR: not-running thread ; - -: check-registered ( thread -- thread ) - dup thread-registered? [ not-running ] unless ; - > threads set-at ; + dup id>> threads set-at ; : unregister-thread ( thread -- ) - check-registered id>> threads delete-at ; + id>> threads delete-at ; : set-self ( thread -- ) 63 set-special-object ; inline @@ -106,7 +96,7 @@ PRIVATE> 65 special-object { dlist } declare ; inline : sleep-queue ( -- heap ) - 66 special-object { dlist } declare ; inline + 66 special-object { min-heap } declare ; inline : new-thread ( quot name class -- thread ) new @@ -120,16 +110,13 @@ PRIVATE> \ thread new-thread ; : resume ( thread -- ) - f >>state - check-registered run-queue push-front ; + f >>state run-queue push-front ; : resume-now ( thread -- ) - f >>state - check-registered run-queue push-back ; + f >>state run-queue push-back ; : resume-with ( obj thread -- ) - f >>state - check-registered 2array run-queue push-front ; + f >>state 2array run-queue push-front ; : sleep-time ( -- nanos/f ) { @@ -150,22 +137,19 @@ DEFER: stop >sleep-entry drop ; + dupd sleep-queue heap-push* >>sleep-entry drop ; -: expire-sleep? ( heap -- ? ) - dup heap-empty? +: expire-sleep? ( -- ? ) + sleep-queue dup heap-empty? [ drop f ] [ heap-peek nip nano-count <= ] if ; : expire-sleep ( thread -- ) f >>sleep-entry resume ; : expire-sleep-loop ( -- ) - sleep-queue - [ dup expire-sleep? ] - [ dup heap-pop drop expire-sleep ] - while - drop ; + [ expire-sleep? ] + [ sleep-queue heap-pop drop expire-sleep ] + while ; CONSTANT: [start] [ @@ -177,7 +161,9 @@ CONSTANT: [start] : no-runnable-threads ( -- ) die ; -: (next) ( obj thread -- obj' ) +GENERIC: (next) ( obj thread -- obj' ) + +M: thread (next) dup runnable>> [ context>> box> set-context ] [ t >>runnable drop [start] start-context ] if ;