Some minor pointless optimizations

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

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

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 )
     mailbox new
         <dlist> >>threads
-        <dlist> >>data ;
+        <dlist> >>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 )
+GENERIC# mailbox-get-timeout 1 ( mailbox timeout -- obj )
-    block-if-empty data>> pop-back ;
+
+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

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
+USING: kernel kernel.private threads concurrency.mailboxes
-namespaces assocs accessors summary fry ;
+continuations namespaces assocs accessors summary fry ;
 IN: concurrency.messaging
 
 GENERIC: send ( message thread -- )
 
-: mailbox-of ( thread -- mailbox )
+GENERIC: mailbox-of ( thread -- mailbox )
-    dup mailbox>> [ ] [
+
-        <mailbox> [ >>mailbox drop ] keep
+M: thread mailbox-of
-    ] ?if ;
+    dup mailbox>>
+    [ { mailbox } declare ]
+    [ <mailbox> [ >>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 ;

basis/dlists/dlists.factor

@@ -29,7 +29,7 @@ TUPLE: dlist
 : <hashed-dlist> ( -- search-deque )
     20 <hashtable> <dlist> <search-deque> ;
 
-M: dlist deque-empty? front>> not ;
+M: dlist deque-empty? front>> not ; inline
 
 M: dlist-node node-value obj>> ;
 

basis/heaps/heaps.factor

@@ -35,7 +35,7 @@ TUPLE: max-heap < heap ;
 : <max-heap> ( -- max-heap ) max-heap <heap> ;
 
 M: heap heap-empty? ( heap -- ? )
-    data>> empty? ;
+    data>> empty? ; inline
 
 M: heap heap-size ( heap -- n )
     data>> length ;

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 ;
-
 <PRIVATE
 
 : register-thread ( thread -- )
-    check-unregistered dup id>> 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
+    f >>state run-queue push-front ;
-    check-registered run-queue push-front ;
 
 : resume-now ( thread -- )
-    f >>state
+    f >>state run-queue push-back ;
-    check-registered run-queue push-back ;
 
 : resume-with ( obj thread -- )
-    f >>state
+    f >>state 2array run-queue push-front ;
-    check-registered 2array run-queue push-front ;
 
 : sleep-time ( -- nanos/f )
     {
@@ -150,22 +137,19 @@ DEFER: stop
 <PRIVATE
 
 : schedule-sleep ( thread dt -- )
-    [ check-registered dup ] dip sleep-queue heap-push*
+    dupd sleep-queue heap-push* >>sleep-entry drop ;
-    >>sleep-entry drop ;
 
-: expire-sleep? ( heap -- ? )
+: expire-sleep? ( -- ? )
-    dup heap-empty?
+    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
+    [ expire-sleep? ]
-    [ dup expire-sleep? ]
+    [ sleep-queue heap-pop drop expire-sleep ]
-    [ dup heap-pop drop expire-sleep ]
+    while ;
-    while
-    drop ;
 
 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 ;