Merge branch 'master' of factorcode.org:/git/factor

diff --git a/basis/boxes/boxes.factor b/basis/boxes/boxes.factor
index 811c5addb078ac56714808ecb4b8b5f8687bf140..a159e1402b04027301eac6f104814f41e81642cc 100644 (file)
--- a/basis/boxes/boxes.factor
+++ b/basis/boxes/boxes.factor
@@ -11,7 +11,7 @@ ERROR: box-full box ;
 \r
 : >box ( value box -- )\r
     dup occupied>>\r
-    [ box-full ] [ t >>occupied (>>value) ] if ;\r
+    [ box-full ] [ t >>occupied (>>value) ] if ; inline\r
 \r
 ERROR: box-empty box ;\r
 \r
@@ -19,10 +19,10 @@ ERROR: box-empty box ;
     dup occupied>> [ box-empty ] unless ; inline\r
 \r
 : box> ( box -- value )\r
-    check-box [ f ] change-value f >>occupied drop ;\r
+    check-box [ f ] change-value f >>occupied drop ; inline\r
 \r
 : ?box ( box -- value/f ? )\r
-    dup occupied>> [ box> t ] [ drop f f ] if ;\r
+    dup occupied>> [ box> t ] [ drop f f ] if ; inline\r
 \r
 : if-box? ( box quot -- )\r
     [ ?box ] dip [ drop ] if ; inline\r

diff --git a/basis/compiler/cfg/alias-analysis/alias-analysis.factor b/basis/compiler/cfg/alias-analysis/alias-analysis.factor
index 24433ad594f75ff9742e166082b3c54c1d226a9a..44326c179fb4b60834b78764a54ffb66788b093b 100644 (file)
--- a/basis/compiler/cfg/alias-analysis/alias-analysis.factor
+++ b/basis/compiler/cfg/alias-analysis/alias-analysis.factor
@@ -202,14 +202,16 @@ M: ##slot-imm insn-slot# slot>> ;
 M: ##set-slot insn-slot# slot>> constant ;
 M: ##set-slot-imm insn-slot# slot>> ;
 M: ##alien-global insn-slot# [ library>> ] [ symbol>> ] bi 2array ;
-M: ##vm-field-ptr insn-slot# field-name>> ;
+M: ##vm-field insn-slot# offset>> ;
+M: ##set-vm-field insn-slot# offset>> ;
 
 M: ##slot insn-object obj>> resolve ;
 M: ##slot-imm insn-object obj>> resolve ;
 M: ##set-slot insn-object obj>> resolve ;
 M: ##set-slot-imm insn-object obj>> resolve ;
 M: ##alien-global insn-object drop \ ##alien-global ;
-M: ##vm-field-ptr insn-object drop \ ##vm-field-ptr ;
+M: ##vm-field insn-object drop \ ##vm-field ;
+M: ##set-vm-field insn-object drop \ ##vm-field ;
 
 : init-alias-analysis ( insns -- insns' )
     H{ } clone histories set
@@ -222,7 +224,7 @@ M: ##vm-field-ptr insn-object drop \ ##vm-field-ptr ;
     0 ac-counter set
     next-ac heap-ac set
 
-    \ ##vm-field-ptr set-new-ac
+    \ ##vm-field set-new-ac
     \ ##alien-global set-new-ac
 
     dup local-live-in [ set-heap-ac ] each ;

diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor
index 678ce768600a5829282534af9b88c5049c0ff9d0..c015cb640b5222a3dcaaff6c04e784507cab9a62 100644 (file)
--- a/basis/compiler/cfg/instructions/instructions.factor
+++ b/basis/compiler/cfg/instructions/instructions.factor
@@ -660,13 +660,13 @@ INSN: ##alien-global
 def: dst/int-rep
 literal: symbol library ;
 
-INSN: ##vm-field-ptr
-def: dst/int-rep
-literal: field-name ;
-
 INSN: ##vm-field
 def: dst/int-rep
-literal: field-name ;
+literal: offset ;
+
+INSN: ##set-vm-field
+use: src/int-rep
+literal: offset ;
 
 ! FFI
 INSN: ##alien-invoke
@@ -835,8 +835,8 @@ UNION: ##allocation
 ##box-displaced-alien ;
 
 ! For alias analysis
-UNION: ##read ##slot ##slot-imm ##vm-field-ptr ##alien-global ;
-UNION: ##write ##set-slot ##set-slot-imm ;
+UNION: ##read ##slot ##slot-imm ##vm-field ##alien-global ;
+UNION: ##write ##set-slot ##set-slot-imm ##set-vm-field ;
 
 ! Instructions that kill all live vregs but cannot trigger GC
 UNION: partial-sync-insn

diff --git a/basis/compiler/cfg/intrinsics/intrinsics.factor b/basis/compiler/cfg/intrinsics/intrinsics.factor
index 4ebc818b83c1c7e97dfbbbfbfbe141f26c0198a5..2b2ae7d160d15a94cf8c76fb3243aac040bd91a7 100644 (file)
--- a/basis/compiler/cfg/intrinsics/intrinsics.factor
+++ b/basis/compiler/cfg/intrinsics/intrinsics.factor
@@ -32,6 +32,7 @@ IN: compiler.cfg.intrinsics
     { kernel.private:tag [ drop emit-tag ] }
     { kernel.private:context-object [ emit-context-object ] }
     { kernel.private:special-object [ emit-special-object ] }
+    { kernel.private:set-special-object [ emit-set-special-object ] }
     { kernel.private:(identity-hashcode) [ drop emit-identity-hashcode ] }
     { math.private:both-fixnums? [ drop emit-both-fixnums? ] }
     { math.private:fixnum+ [ drop emit-fixnum+ ] }

diff --git a/basis/compiler/cfg/intrinsics/misc/misc.factor b/basis/compiler/cfg/intrinsics/misc/misc.factor
index 9731d2f6f519668c0e7d7f2fb60433b9b9b2f048..da77bcaa09d69deb332739ddbe24bf00c207e0fa 100644 (file)
--- a/basis/compiler/cfg/intrinsics/misc/misc.factor
+++ b/basis/compiler/cfg/intrinsics/misc/misc.factor
@@ -1,30 +1,39 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: namespaces layouts sequences kernel math accessors
 compiler.tree.propagation.info compiler.cfg.stacks
 compiler.cfg.hats compiler.cfg.instructions
 compiler.cfg.builder.blocks
 compiler.cfg.utilities ;
-FROM: vm => context-field-offset ;
+FROM: vm => context-field-offset vm-field-offset ;
 IN: compiler.cfg.intrinsics.misc
 
 : emit-tag ( -- )
     ds-pop tag-mask get ^^and-imm ^^tag-fixnum ds-push ;
 
+: special-object-offset ( n -- offset )
+    cells "special-objects" vm-field-offset + ;
+
 : emit-special-object ( node -- )
     dup node-input-infos first literal>> [
-        "special-objects" ^^vm-field-ptr
-        ds-drop swap 0 ^^slot-imm
+        ds-drop
+        special-object-offset ^^vm-field
         ds-push
     ] [ emit-primitive ] ?if ;
 
-: context-object-offset ( -- n )
-    "context-objects" context-field-offset cell /i ;
+: emit-set-special-object ( node -- )
+    dup node-input-infos second literal>> [
+        ds-drop
+        [ ds-pop ] dip special-object-offset ##set-vm-field
+    ] [ emit-primitive ] ?if ;
+
+: context-object-offset ( n -- n )
+    cells "context-objects" context-field-offset + ;
 
 : emit-context-object ( node -- )
     dup node-input-infos first literal>> [
-        "ctx" ^^vm-field
-        ds-drop swap context-object-offset + 0 ^^slot-imm ds-push
+        "ctx" vm-field-offset ^^vm-field
+        ds-drop swap context-object-offset cell /i 0 ^^slot-imm ds-push
     ] [ emit-primitive ] ?if ;
 
 : emit-identity-hashcode ( -- )

diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor
index d82ced8a1d8a8b2c4dad3457a80121a0b40be3cd..4208fec0a73fb544f6c88d0456cc7174a536232a 100755 (executable)
--- a/basis/compiler/codegen/codegen.factor
+++ b/basis/compiler/codegen/codegen.factor
@@ -210,8 +210,8 @@ CODEGEN: ##compare-imm %compare-imm
 CODEGEN: ##compare-float-ordered %compare-float-ordered
 CODEGEN: ##compare-float-unordered %compare-float-unordered
 CODEGEN: ##save-context %save-context
-CODEGEN: ##vm-field-ptr %vm-field-ptr
 CODEGEN: ##vm-field %vm-field
+CODEGEN: ##set-vm-field %set-vm-field
 
 CODEGEN: _fixnum-add %fixnum-add
 CODEGEN: _fixnum-sub %fixnum-sub

diff --git a/basis/compiler/tests/alien.factor b/basis/compiler/tests/alien.factor
index 692dbee4c54aeb03ab7fe38301c2dc64f2a7d9c5..ceac1b094c58efdb39b06a6a6f51b08bd1c7bd23 100755 (executable)
--- a/basis/compiler/tests/alien.factor
+++ b/basis/compiler/tests/alien.factor
@@ -432,14 +432,17 @@ STRUCT: double-rect
     void { void* void* double-rect } "cdecl"
     [ "example" set-global 2drop ] alien-callback ;
 
-: double-rect-test ( arg -- arg' )
-    f f rot
-    double-rect-callback
+: double-rect-test ( arg callback -- arg' )
+    [ f f ] 2dip
     void { void* void* double-rect } "cdecl" alien-indirect
     "example" get-global ;
 
 [ 1.0 2.0 3.0 4.0 ]
-[ 1.0 2.0 3.0 4.0 <double-rect> double-rect-test >double-rect< ] unit-test
+[
+    1.0 2.0 3.0 4.0 <double-rect>
+    double-rect-callback double-rect-test
+    >double-rect<
+] unit-test
 
 STRUCT: test_struct_14
     { x1 double }

diff --git a/basis/concurrency/conditions/conditions.factor b/basis/concurrency/conditions/conditions.factor
index 4a1c7d3370f40963f5a5fb798f22b818a0a56c2d..2fb75226eb2e44272ffdbf82fc6e164204c57302 100644 (file)
--- 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\r
 \r
 : notify-1 ( deque -- )\r
-    dup deque-empty? [ drop ] [ pop-back resume-now ] if ;\r
+    dup deque-empty? [ drop ] [ pop-back resume-now ] if ; inline\r
 \r
 : notify-all ( deque -- )\r
-    [ resume-now ] slurp-deque ;\r
+    [ resume-now ] slurp-deque ; inline\r
 \r
 : queue-timeout ( queue timeout -- alarm )\r
     #! Add an alarm which removes the current thread from the\r
@@ -23,7 +23,7 @@ IN: concurrency.conditions
 ERROR: wait-timeout ;\r
 \r
 : queue ( queue -- )\r
-    [ self ] dip push-front ;\r
+    [ self ] dip push-front ; inline\r
 \r
 : wait ( queue timeout status -- )\r
     over [\r
@@ -31,4 +31,4 @@ ERROR: wait-timeout ;
         [ wait-timeout ] [ cancel-alarm ] if\r
     ] [\r
         [ drop queue ] dip suspend drop\r
-    ] if ;\r
+    ] if ; inline\r

diff --git a/basis/concurrency/mailboxes/mailboxes.factor b/basis/concurrency/mailboxes/mailboxes.factor
index e245f93bd5f86f7169668e9a5fb7b5abd5e12852..163873575c9f4b11f7069bf99a290aef6b46aee9 100644 (file)
--- 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 )
     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 )
-    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 37965309e8b4f1a41fbf966bea242eb81ae4a2db..3f55b0969b2705d97ed8edbb1caead9c942423f4 100644 (file)
--- a/basis/concurrency/messaging/messaging.factor
+++ b/basis/concurrency/messaging/messaging.factor
@@ -1,20 +1,22 @@
-! Copyright (C) 2005, 2008 Chris Double, Slava Pestov.\r
+! Copyright (C) 2005, 2010 Chris Double, Slava Pestov.\r
 ! See http://factorcode.org/license.txt for BSD license.\r
-USING: kernel threads concurrency.mailboxes continuations\r
-namespaces assocs accessors summary fry ;\r
+USING: kernel kernel.private threads concurrency.mailboxes\r
+continuations namespaces assocs accessors summary fry ;\r
 IN: concurrency.messaging\r
 \r
 GENERIC: send ( message thread -- )\r
 \r
-: mailbox-of ( thread -- mailbox )\r
-    dup mailbox>> [ ] [\r
-        <mailbox> [ >>mailbox drop ] keep\r
-    ] ?if ;\r
+GENERIC: mailbox-of ( thread -- mailbox )\r
+\r
+M: thread mailbox-of\r
+    dup mailbox>>\r
+    [ { mailbox } declare ]\r
+    [ <mailbox> [ >>mailbox drop ] keep ] ?if ; inline\r
 \r
 M: thread send ( message thread -- )\r
-    check-registered mailbox-of mailbox-put ;\r
+    mailbox-of mailbox-put ;\r
 \r
-: my-mailbox ( -- mailbox ) self mailbox-of ;\r
+: my-mailbox ( -- mailbox ) self mailbox-of ; inline\r
 \r
 : receive ( -- message )\r
     my-mailbox mailbox-get ?linked ;\r

diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor
index b617746a06f81db50e7ddf101845c6efcb4fa36f..ad1a4be2eb072f67966b5b641813c1a343965d75 100644 (file)
--- a/basis/cpu/architecture/architecture.factor
+++ b/basis/cpu/architecture/architecture.factor
@@ -447,8 +447,10 @@ HOOK: %set-alien-double    cpu ( ptr offset value -- )
 HOOK: %set-alien-vector    cpu ( ptr offset value rep -- )
 
 HOOK: %alien-global cpu ( dst symbol library -- )
-HOOK: %vm-field cpu ( dst fieldname -- )
-HOOK: %vm-field-ptr cpu ( dst fieldname -- )
+HOOK: %vm-field cpu ( dst offset -- )
+HOOK: %set-vm-field cpu ( src offset -- )
+
+: %context ( dst -- ) 0 %vm-field ;
 
 HOOK: %allot cpu ( dst size class temp -- )
 HOOK: %write-barrier cpu ( src slot temp1 temp2 -- )

diff --git a/basis/cpu/ppc/bootstrap.factor b/basis/cpu/ppc/bootstrap.factor
index 83be0150d87d1dea5c02f0b790b1df5c8995d5eb..f7a1917d0e9fb7eafa0e5fb81f94a79a49bf2449 100644 (file)
--- a/basis/cpu/ppc/bootstrap.factor
+++ b/basis/cpu/ppc/bootstrap.factor
@@ -76,9 +76,12 @@ CONSTANT: nv-reg 17
     432 save-at ;\r
 \r
 [\r
+    ! Save old stack pointer\r
+    11 1 MR\r
+\r
     ! Create stack frame\r
     0 MFLR\r
-    1 1 callback-frame-size neg STWU\r
+    1 1 callback-frame-size SUBI\r
     0 1 callback-frame-size lr-save + STW\r
 \r
     ! Save all non-volatile registers\r
@@ -86,6 +89,10 @@ CONSTANT: nv-reg 17
     nv-fp-regs [ 8 * 80 + save-fp ] each-index\r
     nv-vec-regs [ 16 * 224 + save-vec ] each-index\r
 \r
+    ! Stick old stack pointer in a non-volatile register so that\r
+    ! callbacks can access their arguments\r
+    nv-reg 11 MR\r
+\r
     ! Load VM into vm-reg\r
     0 vm-reg LOAD32 rc-absolute-ppc-2/2 rt-vm jit-rel\r
 \r
@@ -126,7 +133,7 @@ CONSTANT: nv-reg 17
 \r
     ! Tear down stack frame and return\r
     0 1 callback-frame-size lr-save + LWZ\r
-    1 1 0 LWZ\r
+    1 1 callback-frame-size ADDI\r
     0 MTLR\r
     BLR\r
 ] callback-stub jit-define\r

diff --git a/basis/cpu/ppc/ppc.factor b/basis/cpu/ppc/ppc.factor
index dbc313052f6e9c1d8127a79f9785fa0a7671c191..cf8a8323861b48d6bfce055c6af12dc672b904f5 100644 (file)
--- a/basis/cpu/ppc/ppc.factor
+++ b/basis/cpu/ppc/ppc.factor
@@ -58,11 +58,9 @@ CONSTANT: vm-reg 15
 
 : %load-vm-addr ( reg -- ) vm-reg MR ;
 
-M: ppc %vm-field ( dst field -- )
-    [ vm-reg ] dip vm-field-offset LWZ ;
+M: ppc %vm-field ( dst field -- ) [ vm-reg ] dip LWZ ;
 
-M: ppc %vm-field-ptr ( dst field -- )
-    [ vm-reg ] dip vm-field-offset ADDI ;
+M: ppc %set-vm-field ( src field -- ) [ vm-reg ] dip STW ;
 
 GENERIC: loc-reg ( loc -- reg )
 
@@ -385,7 +383,7 @@ M: ppc %set-alien-float -rot STFS ;
 M: ppc %set-alien-double -rot STFD ;
 
 : load-zone-ptr ( reg -- )
-    "nursery" %vm-field-ptr ;
+    vm-reg "nursery" vm-field-offset ADDI ;
 
 : load-allot-ptr ( nursery-ptr allot-ptr -- )
     [ drop load-zone-ptr ] [ swap 0 LWZ ] 2bi ;
@@ -567,8 +565,7 @@ M:: ppc %compare-float-unordered-branch ( label src1 src2 cc -- )
     } case ;
 
 : next-param@ ( n -- reg x )
-    2 1 stack-frame get total-size>> LWZ
-    [ 2 ] dip param@ ;
+    [ 17 ] dip param@ ;
 
 : store-to-frame ( src n rep -- )
     {
@@ -604,14 +601,14 @@ M: ppc %push-stack ( -- )
     int-regs return-reg ds-reg 0 STW ;
 
 M: ppc %push-context-stack ( -- )
-    11 "ctx" %vm-field
+    11 %context
     12 11 "datastack" context-field-offset LWZ
     12 12 4 ADDI
     12 11 "datastack" context-field-offset STW
     int-regs return-reg 12 0 STW ;
 
 M: ppc %pop-context-stack ( -- )
-    11 "ctx" %vm-field
+    11 %context
     12 11 "datastack" context-field-offset LWZ
     int-regs return-reg 12 0 LWZ
     12 12 4 SUBI
@@ -677,12 +674,12 @@ M: ppc %box-large-struct ( n c-type -- )
     "from_value_struct" f %alien-invoke ;
 
 M:: ppc %restore-context ( temp1 temp2 -- )
-    temp1 "ctx" %vm-field
+    temp1 %context
     ds-reg temp1 "datastack" context-field-offset LWZ
     rs-reg temp1 "retainstack" context-field-offset LWZ ;
 
 M:: ppc %save-context ( temp1 temp2 -- )
-    temp1 "ctx" %vm-field
+    temp1 %context
     1 temp1 "callstack-top" context-field-offset STW
     ds-reg temp1 "datastack" context-field-offset STW
     rs-reg temp1 "retainstack" context-field-offset STW ;
@@ -749,14 +746,14 @@ M: ppc %alien-callback ( quot -- )
 
 M: ppc %end-callback ( -- )
     3 %load-vm-addr
-    "unnest_context" f %alien-invoke ;
+    "end_callback" f %alien-invoke ;
 
 M: ppc %end-callback-value ( ctype -- )
     ! Save top of data stack
-    12 ds-reg 0 LWZ
+    16 ds-reg 0 LWZ
     %end-callback
     ! Restore top of data stack
-    3 12 MR
+    3 16 MR
     ! Unbox former top of data stack to return registers
     unbox-return ;
 

diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor
index 09f1ecb32b6763c1b965212ad22d1538f10598f5..97f0cfb66845e4b7e08a3bd75c4cba789956ac27 100755 (executable)
--- a/basis/cpu/x86/32/32.factor
+++ b/basis/cpu/x86/32/32.factor
@@ -28,10 +28,13 @@ M: x86.32 %mov-vm-ptr ( reg -- )
     0 MOV 0 rc-absolute-cell rel-vm ;
 
 M: x86.32 %vm-field ( dst field -- )
-    [ 0 [] MOV ] dip vm-field-offset rc-absolute-cell rel-vm ;
+    [ 0 [] MOV ] dip rc-absolute-cell rel-vm ;
+
+M: x86.32 %set-vm-field ( dst field -- )
+    [ 0 [] swap MOV ] dip rc-absolute-cell rel-vm ;
 
 M: x86.32 %vm-field-ptr ( dst field -- )
-    [ 0 MOV ] dip vm-field-offset rc-absolute-cell rel-vm ;
+    [ 0 MOV ] dip rc-absolute-cell rel-vm ;
 
 : local@ ( n -- op )
     stack-frame get extra-stack-space dup 16 assert= + stack@ ;
@@ -166,7 +169,7 @@ M: x86.32 %pop-stack ( n -- )
     EAX swap ds-reg reg-stack MOV ;
 
 M: x86.32 %pop-context-stack ( -- )
-    temp-reg "ctx" %vm-field
+    temp-reg %context
     EAX temp-reg "datastack" context-field-offset [+] MOV
     EAX EAX [] MOV
     temp-reg "datastack" context-field-offset [+] bootstrap-cell SUB ;
@@ -241,6 +244,7 @@ M: x86.32 %alien-indirect ( -- )
 
 M: x86.32 %begin-callback ( -- )
     0 save-vm-ptr
+    ESP 4 [+] 0 MOV
     "begin_callback" f %alien-invoke ;
 
 M: x86.32 %alien-callback ( quot -- )

diff --git a/basis/cpu/x86/32/bootstrap.factor b/basis/cpu/x86/32/bootstrap.factor
index a428a66ace0775c072a5a3666bcdedba0de003be..293d99fe93d48b22fb3a7150529404f4861f2b7a 100644 (file)
--- a/basis/cpu/x86/32/bootstrap.factor
+++ b/basis/cpu/x86/32/bootstrap.factor
@@ -82,11 +82,9 @@ IN: bootstrap.x86
 [
     jit-load-vm
     ESP [] vm-reg MOV
-    "begin_callback" jit-call
-
-    ! load quotation - EBP is ctx-reg so it will get clobbered
-    ! later on
     EAX EBP 8 [+] MOV
+    ESP 4 [+] EAX MOV
+    "begin_callback" jit-call
 
     jit-load-vm
     jit-load-context

diff --git a/basis/cpu/x86/64/64.factor b/basis/cpu/x86/64/64.factor
index 04f64f96b6d3808b13e764ab3acc7aac1dab7aba..7e1c5c1f48fe6cd8ceb00624c640a7ce7702ce92 100644 (file)
--- a/basis/cpu/x86/64/64.factor
+++ b/basis/cpu/x86/64/64.factor
@@ -43,11 +43,14 @@ M: x86.64 machine-registers
 M: x86.64 %mov-vm-ptr ( reg -- )
     vm-reg MOV ;
 
-M: x86.64 %vm-field ( dst field -- )
-    [ vm-reg ] dip vm-field-offset [+] MOV ;
+M: x86.64 %vm-field ( dst offset -- )
+    [ vm-reg ] dip [+] MOV ;
 
-M: x86.64 %vm-field-ptr ( dst field -- )
-    [ vm-reg ] dip vm-field-offset [+] LEA ;
+M: x86.64 %set-vm-field ( src offset -- )
+    [ vm-reg ] dip [+] swap MOV ;
+
+M: x86.64 %vm-field-ptr ( dst offset -- )
+    [ vm-reg ] dip [+] LEA ;
 
 : param@ ( n -- op ) reserved-stack-space + stack@ ;
 
@@ -111,7 +114,7 @@ M: x86.64 %pop-stack ( n -- )
     param-reg-0 swap ds-reg reg-stack MOV ;
 
 M: x86.64 %pop-context-stack ( -- )
-    temp-reg "ctx" %vm-field
+    temp-reg %context
     param-reg-0 temp-reg "datastack" context-field-offset [+] MOV
     param-reg-0 param-reg-0 [] MOV
     temp-reg "datastack" context-field-offset [+] bootstrap-cell SUB ;
@@ -228,6 +231,7 @@ M: x86.64 %alien-indirect ( -- )
 
 M: x86.64 %begin-callback ( -- )
     param-reg-0 %mov-vm-ptr
+    param-reg-1 0 MOV
     "begin_callback" f %alien-invoke ;
 
 M: x86.64 %alien-callback ( quot -- )

diff --git a/basis/cpu/x86/64/bootstrap.factor b/basis/cpu/x86/64/bootstrap.factor
index 4cd2d8104b904b55a5eb648c5daa3371e300f47d..6c0d50f1b7e58733590ab9e898ad83a412b5f458 100644 (file)
--- a/basis/cpu/x86/64/bootstrap.factor
+++ b/basis/cpu/x86/64/bootstrap.factor
@@ -76,8 +76,7 @@ IN: bootstrap.x86
 : jit-call-quot ( -- ) arg1 quot-entry-point-offset [+] CALL ;
 
 [
-    nv-reg arg1 MOV
-
+    arg2 arg1 MOV
     arg1 vm-reg MOV
     "begin_callback" jit-call
 
@@ -85,7 +84,7 @@ IN: bootstrap.x86
     jit-restore-context
 
     ! call the quotation
-    arg1 nv-reg MOV
+    arg1 return-reg MOV
     jit-call-quot
 
     jit-save-context

diff --git a/basis/cpu/x86/x86.factor b/basis/cpu/x86/x86.factor
index dbb112bf4bf9a245e062a210d7bc6adfe4b736ba..acd2e1358dbdb9b7f1e95dd041728f5f6b37ee74 100644 (file)
--- a/basis/cpu/x86/x86.factor
+++ b/basis/cpu/x86/x86.factor
@@ -423,8 +423,13 @@ M: x86 %sar int-rep two-operand [ SAR ] emit-shift ;
 
 HOOK: %mov-vm-ptr cpu ( reg -- )
 
+HOOK: %vm-field-ptr cpu ( reg offset -- )
+
+: load-zone-offset ( nursery-ptr -- )
+    "nursery" vm-field-offset %vm-field-ptr ;
+
 : load-allot-ptr ( nursery-ptr allot-ptr -- )
-    [ drop "nursery" %vm-field-ptr ] [ swap [] MOV ] 2bi ;
+    [ drop load-zone-offset ] [ swap [] MOV ] 2bi ;
 
 : inc-allot-ptr ( nursery-ptr n -- )
     [ [] ] dip data-alignment get align ADD ;
@@ -456,7 +461,7 @@ M: x86 %write-barrier ( src slot temp1 temp2 -- ) (%write-barrier) ;
 M: x86 %write-barrier-imm ( src slot temp1 temp2 -- ) (%write-barrier) ;
 
 M:: x86 %check-nursery ( label size temp1 temp2 -- )
-    temp1 "nursery" %vm-field-ptr
+    temp1 load-zone-offset
     ! Load 'here' into temp2
     temp2 temp1 [] MOV
     temp2 size ADD
@@ -477,7 +482,7 @@ M: x86 %push-stack ( -- )
     ds-reg [] int-regs return-reg MOV ;
 
 M: x86 %push-context-stack ( -- )
-    temp-reg "ctx" %vm-field
+    temp-reg %context
     temp-reg "datastack" context-field-offset [+] bootstrap-cell ADD
     temp-reg temp-reg "datastack" context-field-offset [+] MOV
     temp-reg [] int-regs return-reg MOV ;
@@ -1403,7 +1408,7 @@ M: x86 %loop-entry 16 code-alignment [ NOP ] times ;
 
 M:: x86 %restore-context ( temp1 temp2 -- )
     #! Load Factor stack pointers on entry from C to Factor.
-    temp1 "ctx" %vm-field
+    temp1 %context
     ds-reg temp1 "datastack" context-field-offset [+] MOV
     rs-reg temp1 "retainstack" context-field-offset [+] MOV ;
 
@@ -1411,7 +1416,7 @@ M:: x86 %save-context ( temp1 temp2 -- )
     #! Save Factor stack pointers in case the C code calls a
     #! callback which does a GC, which must reliably trace
     #! all roots.
-    temp1 "ctx" %vm-field
+    temp1 %context
     temp2 stack-reg cell neg [+] LEA
     temp1 "callstack-top" context-field-offset [+] temp2 MOV
     temp1 "datastack" context-field-offset [+] ds-reg MOV

diff --git a/basis/dlists/dlists.factor b/basis/dlists/dlists.factor
index 44140d31093a76a07505a6ce01ac5a3edb637264..53e134fad9fb2f88c410279b11a4168b495fc638 100644 (file)
--- a/basis/dlists/dlists.factor
+++ b/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>> ;
 

diff --git a/basis/heaps/heaps.factor b/basis/heaps/heaps.factor
index 677daca69de52e85006fbfe78c9b4388248614f2..28d18cb53acce3ab053fa321b8ff34c3cdcce77d 100644 (file)
--- a/basis/heaps/heaps.factor
+++ b/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 ;

diff --git a/basis/io/pipes/windows/nt/nt.factor b/basis/io/pipes/windows/nt/nt.factor
index f87a98ab91fd49a0b7b6286c07c7a0aa2acd11ab..d58e5e3d5f883b18334fb8df40c94cf286829443 100644 (file)
--- a/basis/io/pipes/windows/nt/nt.factor
+++ b/basis/io/pipes/windows/nt/nt.factor
@@ -3,7 +3,7 @@
 USING: alien alien.c-types arrays destructors io io.backend.windows libc
 windows.types math.bitwise windows.kernel32 windows namespaces
 make kernel sequences windows.errors assocs math.parser system
-random combinators accessors io.pipes io.ports ;
+random combinators accessors io.pipes io.ports literals ;
 IN: io.pipes.windows.nt
 
 ! This code is based on

diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor
index 01f3ff77c07423e22df961341e80e328e118e6cc..15895184df8c25d7698831cf452f16c386b01df1 100644 (file)
--- a/basis/stack-checker/known-words/known-words.factor
+++ b/basis/stack-checker/known-words/known-words.factor
@@ -355,7 +355,6 @@ M: bad-executable summary
 \ code-room { } { byte-array } define-primitive \ code-room  make-flushable
 \ compact-gc { } { } define-primitive
 \ compute-identity-hashcode { object } { } define-primitive
-\ context { } { c-ptr } define-primitive \ context make-flushable
 \ context-object { fixnum } { object } define-primitive \ context-object make-flushable
 \ context-object-for { fixnum c-ptr } { object } define-primitive \ context-object-for make-flushable
 \ current-callback { } { fixnum } define-primitive \ current-callback make-flushable

diff --git a/basis/threads/threads.factor b/basis/threads/threads.factor
index 117e941aa7a0df2b35f16626f064205c93ba0c00..330b4abd6cae99b88a9b61d9302f061f3d8e8739 100644 (file)
--- a/basis/threads/threads.factor
+++ b/basis/threads/threads.factor
@@ -11,17 +11,20 @@ IN: threads
 
 ! Wrap sub-primitives; we don't want them inlined into callers
 ! since their behavior depends on what frames are on the callstack
+: context ( -- context )
+    2 context-object ; inline
+
 : set-context ( obj context -- obj' )
-    (set-context) ;
+    (set-context) ; inline
 
 : start-context ( obj quot: ( obj -- * ) -- obj' )
-    (start-context) ;
+    (start-context) ; inline
 
 : set-context-and-delete ( obj context -- * )
-    (set-context-and-delete) ;
+    (set-context-and-delete) ; inline
 
 : start-context-and-delete ( obj quot: ( obj -- * ) -- * )
-    (start-context-and-delete) ;
+    (start-context-and-delete) ; inline
 
 ! Context introspection
 : namestack-for ( context -- namestack )
@@ -80,23 +83,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 +99,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 +113,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 +140,19 @@ DEFER: stop
 <PRIVATE
 
 : schedule-sleep ( thread dt -- )
-    [ check-registered dup ] dip sleep-queue heap-push*
-    >>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 +164,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 ;

diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor
index 52ee1e14b4b98811e9a8c34170291e8073067cda..8a412b8a1482c8115b58165b208717faef934885 100644 (file)
--- a/core/bootstrap/primitives.factor
+++ b/core/bootstrap/primitives.factor
@@ -538,7 +538,6 @@ tuple
     { "system-micros" "system" "primitive_system_micros" (( -- us )) }
     { "(sleep)" "threads.private" "primitive_sleep" (( nanos -- )) }
     { "callstack-for" "threads.private" "primitive_callstack_for" (( context -- array )) }
-    { "context" "threads.private" "primitive_context" (( -- context )) }
     { "context-object-for" "threads.private" "primitive_context_object_for" (( n context -- obj )) }
     { "datastack-for" "threads.private" "primitive_datastack_for" (( context -- array )) }
     { "retainstack-for" "threads.private" "primitive_retainstack_for" (( context -- array )) }

diff --git a/extra/webkit-demo/webkit-demo.factor b/extra/webkit-demo/webkit-demo.factor
index eb24d035dc92b8276953784f49d6a5ba4f6916d4..8f89b1b4aead2a17742fb565a48a2a674d11e1e9 100644 (file)
--- a/extra/webkit-demo/webkit-demo.factor
+++ b/extra/webkit-demo/webkit-demo.factor
@@ -13,7 +13,7 @@ IMPORT: WebView
     WebView -> alloc
     rect f f -> initWithFrame:frameName:groupName: ;
 
-CONSTANT: window-style ( -- n )
+CONSTANT: window-style
     flags{
         NSClosableWindowMask
         NSMiniaturizableWindowMask

diff --git a/vm/contexts.cpp b/vm/contexts.cpp
index 9364f2e3623afbacb22a1f81b6198b93b7b97f1d..25fe0e5280cc43a82617111119e981303ec6424b 100644 (file)
--- a/vm/contexts.cpp
+++ b/vm/contexts.cpp
@@ -108,9 +108,16 @@ context *factor_vm::new_context()
        return new_context;
 }
 
+void factor_vm::init_context(context *ctx)
+{
+       ctx->context_objects[OBJ_CONTEXT] = allot_alien(ctx);
+}
+
 context *new_context(factor_vm *parent)
 {
-       return parent->new_context();
+       context *new_context = parent->new_context();
+       parent->init_context(new_context);
+       return new_context;
 }
 
 void factor_vm::delete_context(context *old_context)
@@ -124,16 +131,22 @@ VM_C_API void delete_context(factor_vm *parent, context *old_context)
        parent->delete_context(old_context);
 }
 
-void factor_vm::begin_callback()
+cell factor_vm::begin_callback(cell quot_)
 {
+       data_root<object> quot(quot_,this);
+
        ctx->reset();
        spare_ctx = new_context();
        callback_ids.push_back(callback_id++);
+
+       init_context(ctx);
+
+       return quot.value();
 }
 
-void begin_callback(factor_vm *parent)
+cell begin_callback(factor_vm *parent, cell quot)
 {
-       parent->begin_callback();
+       return parent->begin_callback(quot);
 }
 
 void factor_vm::end_callback()
@@ -296,9 +309,4 @@ void factor_vm::primitive_load_locals()
        ctx->retainstack += sizeof(cell) * count;
 }
 
-void factor_vm::primitive_context()
-{
-       ctx->push(allot_alien(ctx));
-}
-
 }

diff --git a/vm/contexts.hpp b/vm/contexts.hpp
index f3aba0e5a606b9784fc322bdee94d7b878ce4bfd..85338ca91d657624711078aa9e5d6d90d28a4807 100644 (file)
--- a/vm/contexts.hpp
+++ b/vm/contexts.hpp
@@ -6,6 +6,7 @@ static const cell context_object_count = 10;
 enum context_object {
        OBJ_NAMESTACK,
        OBJ_CATCHSTACK,
+       OBJ_CONTEXT,
 };
 
 static const cell stack_reserved = 1024;
@@ -71,7 +72,7 @@ struct context {
 
 VM_C_API context *new_context(factor_vm *parent);
 VM_C_API void delete_context(factor_vm *parent, context *old_context);
-VM_C_API void begin_callback(factor_vm *parent);
+VM_C_API cell begin_callback(factor_vm *parent, cell quot);
 VM_C_API void end_callback(factor_vm *parent);
 
 }

diff --git a/vm/factor.cpp b/vm/factor.cpp
index e726ebf6dad6cbbbba8b54cc2a5bd0901eaf8652..983e12bdcd400a7c763c87465666a6324dabb725 100755 (executable)
--- a/vm/factor.cpp
+++ b/vm/factor.cpp
@@ -14,7 +14,12 @@ void factor_vm::default_parameters(vm_parameters *p)
 
        p->datastack_size = 32 * sizeof(cell);
        p->retainstack_size = 32 * sizeof(cell);
+
+#ifdef __OpenBSD__
+       p->callstack_size = 32 * sizeof(cell);
+#else
        p->callstack_size = 128 * sizeof(cell);
+#endif
 
        p->code_size = 8 * sizeof(cell);
        p->young_size = sizeof(cell) / 4;

diff --git a/vm/os-genunix.hpp b/vm/os-genunix.hpp
index c6123eca56396caa0dbb41284fdfc8766873a510..a40e891a6e7ae9318ec0c77acdac1416921d3322 100644 (file)
--- a/vm/os-genunix.hpp
+++ b/vm/os-genunix.hpp
@@ -2,7 +2,6 @@ namespace factor
 {
 
 #define VM_C_API extern "C"
-#define NULL_DLL NULL
 
 void early_init();
 const char *vm_executable_path();

diff --git a/vm/os-macosx.hpp b/vm/os-macosx.hpp
index 4d4499461d861819414f82019176d61dd6499a1e..27eba772159ccc6521c4bbea608263d298c1fe1e 100644 (file)
--- a/vm/os-macosx.hpp
+++ b/vm/os-macosx.hpp
@@ -3,7 +3,6 @@ namespace factor
 
 #define VM_C_API extern "C" __attribute__((visibility("default")))
 #define FACTOR_OS_STRING "macosx"
-#define NULL_DLL NULL
 
 void early_init();
 

diff --git a/vm/os-unix.cpp b/vm/os-unix.cpp
index 60ac00fb395858a7675eae920b8c9a83a9c4ee39..034dfcbf5f2f7643e93615c0177bc8eb9adad727 100644 (file)
--- a/vm/os-unix.cpp
+++ b/vm/os-unix.cpp
@@ -46,7 +46,7 @@ void sleep_nanos(u64 nsec)
 
 void factor_vm::init_ffi()
 {
-       null_dll = dlopen(NULL_DLL,RTLD_LAZY);
+       null_dll = dlopen(NULL,RTLD_LAZY);
 }
 
 void factor_vm::ffi_dlopen(dll *dll)

diff --git a/vm/os-windows-nt.hpp b/vm/os-windows-nt.hpp
index c5e721c56dd3b915e1dbb2b9626b9e31c6298a35..f274d7813fc5be06a9248fd61e8198d068a95e43 100755 (executable)
--- a/vm/os-windows-nt.hpp
+++ b/vm/os-windows-nt.hpp
@@ -20,7 +20,7 @@ typedef char symbol_char;
 
 #define FACTOR_OS_STRING "winnt"
 
-#define FACTOR_DLL L"factor.dll"
+#define FACTOR_DLL NULL
 
 #ifdef _MSC_VER
        #define FACTOR_STDCALL(return_type) return_type __stdcall

diff --git a/vm/primitives.hpp b/vm/primitives.hpp
index 7e95a3bad587cc4c0e9204ab681cdc37b7b68942..ff0947912cad70cd3c35a3f1cb35e224bc753afb 100644 (file)
--- a/vm/primitives.hpp
+++ b/vm/primitives.hpp
@@ -43,7 +43,6 @@ namespace factor
        _(code_room) \
        _(compact_gc) \
        _(compute_identity_hashcode) \
-       _(context) \
        _(context_object) \
        _(context_object_for) \
        _(current_callback) \

diff --git a/vm/vm.hpp b/vm/vm.hpp
index ad74a8e09073d642aca8dd2747cbaa7babce89fd..cf2f0ca433bb5787b6580cc49d3d9e59a14a2128 100755 (executable)
--- a/vm/vm.hpp
+++ b/vm/vm.hpp
@@ -112,10 +112,11 @@ struct factor_vm
 
        // contexts
        context *new_context();
+       void init_context(context *ctx);
        void delete_context(context *old_context);
        void init_contexts(cell datastack_size_, cell retainstack_size_, cell callstack_size_);
        void delete_contexts();
-       void begin_callback();
+       cell begin_callback(cell quot);
        void end_callback();
        void primitive_current_callback();
        void primitive_context_object();
@@ -135,7 +136,6 @@ struct factor_vm
        void primitive_set_retainstack();
        void primitive_check_datastack();
        void primitive_load_locals();
-       void primitive_context();
 
        template<typename Iterator> void iterate_active_callstacks(Iterator &iter)
        {