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

basis/bootstrap/image/image.factor

@@ -109,12 +109,11 @@ SYMBOL: jit-relocations
 
 SYMBOL: jit-offset
 
-: compute-offset ( rc -- offset )
+: compute-offset ( -- offset )
-    [ building get length jit-offset get + ] dip
+    building get length jit-offset get + ;
-    rc-absolute-cell = bootstrap-cell 4 ? - ;
 
 : jit-rel ( rc rt -- )
-    over compute-offset 3array jit-relocations get push-all ;
+    compute-offset 3array jit-relocations get push-all ;
 
 SYMBOL: jit-parameters
 

basis/compiler/cfg/builder/builder.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2004, 2009 Slava Pestov.
+! Copyright (C) 2004, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays assocs combinators hashtables kernel
 math fry namespaces make sequences words byte-arrays
@@ -240,9 +240,9 @@ M: #alien-callback emit-node
     dup params>> xt>> dup
     [
         ##prologue
-        dup [ ##alien-callback ] emit-alien-node
+        [ ##alien-callback ] emit-alien-node
         ##epilogue
-        params>> ##callback-return
+        ##return
     ] with-cfg-builder ;
 
 ! No-op nodes

basis/compiler/cfg/checker/checker.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2009 Slava Pestov.
+! Copyright (C) 2009, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel combinators.short-circuit accessors math sequences
 sets assocs compiler.cfg.instructions compiler.cfg.rpo
@@ -14,7 +14,7 @@ ERROR: bad-kill-block bb ;
     dup instructions>> dup penultimate ##epilogue? [
         {
             [ length 2 = ]
-            [ last { [ ##return? ] [ ##callback-return? ] [ ##jump? ] } 1|| ]
+            [ last { [ ##return? ] [ ##jump? ] } 1|| ]
         } 1&&
     ] [ last ##branch? ] if
     [ drop ] [ bad-kill-block ] if ;

basis/compiler/cfg/instructions/instructions.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: assocs accessors arrays kernel sequences namespaces words
 math math.order layouts classes.algebra classes.union
@@ -674,9 +674,6 @@ literal: params stack-frame ;
 INSN: ##alien-callback
 literal: params stack-frame ;
 
-INSN: ##callback-return
-literal: params ;
-
 ! Instructions used by CFG IR only.
 INSN: ##prologue ;
 INSN: ##epilogue ;

basis/compiler/codegen/codegen.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: namespaces make math math.order math.parser sequences accessors
 kernel kernel.private layouts assocs words summary arrays
@@ -496,11 +496,6 @@ TUPLE: callback-context ;
         [ callback-context new do-callback ] %
     ] [ ] make ;
 
-M: ##callback-return generate-insn
-    #! All the extra book-keeping for %unwind is only for x86.
-    #! On other platforms its an alias for %return.
-    params>> %callback-return ;
-
 M: ##alien-callback generate-insn
     params>>
     [ registers>objects ]

basis/compiler/codegen/fixup/fixup.factor

@@ -34,13 +34,10 @@ TUPLE: label offset ;
     dup label? [ get ] unless
     compiled-offset >>offset drop ;
 
-: offset-for-class ( class -- n )
-    rc-absolute-cell = cell 4 ? compiled-offset swap - ;
-
 TUPLE: label-fixup { label label } { class integer } { offset integer } ;
 
 : label-fixup ( label class -- )
-    dup offset-for-class \ label-fixup boa label-table get push ;
+    compiled-offset \ label-fixup boa label-table get push ;
 
 ! Relocation table
 SYMBOL: relocation-table
@@ -53,7 +50,7 @@ SYMBOL: relocation-table
     { 0 24 28 } bitfield relocation-table get push-4 ;
 
 : rel-fixup ( class type -- )
-    swap dup offset-for-class add-relocation-entry ;
+    swap compiled-offset add-relocation-entry ;
 
 : add-dlsym-parameters ( symbol dll -- )
     [ string>symbol add-parameter ] [ add-parameter ] bi* ;

basis/compiler/constants/constants.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: math kernel layouts system strings words quotations byte-arrays
 alien arrays literals sequences ;
@@ -37,6 +37,7 @@ CONSTANT: rc-relative-ppc-3 6
 CONSTANT: rc-relative-arm-3 7
 CONSTANT: rc-indirect-arm 8
 CONSTANT: rc-indirect-arm-pc 9
+CONSTANT: rc-absolute-2 10
 
 ! Relocation types
 CONSTANT: rt-primitive 0

basis/cpu/architecture/architecture.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2006, 2009 Slava Pestov.
+! Copyright (C) 2006, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays assocs generic kernel kernel.private
 math memory namespaces make sequences layouts system hashtables
@@ -550,6 +550,8 @@ HOOK: %save-param-reg cpu ( stack reg rep -- )
 
 HOOK: %load-param-reg cpu ( stack reg rep -- )
 
+HOOK: %load-context cpu ( temp1 temp2 -- )
+
 HOOK: %save-context cpu ( temp1 temp2 -- )
 
 HOOK: %prepare-var-args cpu ( -- )
@@ -574,7 +576,6 @@ HOOK: %nest-stacks cpu ( -- )
 
 HOOK: %unnest-stacks cpu ( -- )
 
-! Return to caller with stdcall unwinding (only for x86)
+HOOK: callback-return-rewind cpu ( params -- n )
-HOOK: %callback-return cpu ( params -- )
 
-M: object %callback-return drop %return ;
+M: object callback-return-rewind drop 0 ;

basis/cpu/x86/32/32.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2005, 2009 Slava Pestov.
+! Copyright (C) 2005, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: locals alien.c-types alien.libraries alien.syntax arrays
 kernel fry math namespaces sequences system layouts io
@@ -20,6 +20,7 @@ M: x86.32 machine-registers
 M: x86.32 ds-reg ESI ;
 M: x86.32 rs-reg EDI ;
 M: x86.32 stack-reg ESP ;
+M: x86.32 frame-reg EBP ;
 M: x86.32 temp-reg ECX ;
 
 : local@ ( n -- op )
@@ -42,7 +43,7 @@ M: x86.32 %mark-deck
 M:: x86.32 %dispatch ( src temp -- )
     ! Load jump table base.
     temp src HEX: ffffffff [+] LEA
-    building get length cell - :> start
+    building get length :> start
     0 rc-absolute-cell rel-here
     ! Go
     temp HEX: 7f [+] JMP
@@ -215,11 +216,7 @@ M:: x86.32 %unbox-large-struct ( n c-type -- )
     "to_value_struct" f %alien-invoke ;
 
 M: x86.32 %nest-stacks ( -- )
-    ! Save current frame to ctx->magic_frame.
+    0 save-vm-ptr
-    ! See comment in vm/contexts.hpp.
-    EAX stack-reg stack-frame get total-size>> 3 cells - [+] LEA
-    4 save-vm-ptr
-    0 stack@ EAX MOV
     "nest_stacks" f %alien-invoke ;
 
 M: x86.32 %unnest-stacks ( -- )
@@ -238,10 +235,11 @@ M: x86.32 %alien-indirect ( -- )
     EBP CALL ;
 
 M: x86.32 %alien-callback ( quot -- )
+    EAX EDX %load-context
     EAX swap %load-reference
-    0 stack@ EAX MOV
+    EDX %mov-vm-ptr
-    4 save-vm-ptr
+    EAX quot-xt-offset [+] CALL
-    "c_to_factor" f %alien-invoke ;
+    EAX EDX %save-context ;
 
 M: x86.32 %callback-value ( ctype -- )
     %pop-context-stack
@@ -300,20 +298,6 @@ M: x86.32 %cleanup ( params -- )
         [ drop ]
     } cond ;
 
-M: x86.32 %callback-return ( n -- )
-    #! a) If the callback is stdcall, we have to clean up the
-    #! caller's stack frame.
-    #! b) If the callback is returning a large struct, we have
-    #! to fix ESP.
-    {
-        { [ dup abi>> "stdcall" = ] [
-            <alien-stack-frame>
-            [ params>> ] [ return>> ] bi +
-        ] }
-        { [ dup return>> large-struct? ] [ drop 4 ] }
-        [ drop 0 ]
-    } cond RET ;
-
 M:: x86.32 %call-gc ( gc-root-count temp -- )
     temp gc-root-base special@ LEA
     8 save-vm-ptr
@@ -327,6 +311,20 @@ M: x86.32 dummy-int-params? f ;
 
 M: x86.32 dummy-fp-params? f ;
 
+M: x86.32 callback-return-rewind ( params -- n )
+    #! a) If the callback is stdcall, we have to clean up the
+    #! caller's stack frame.
+    #! b) If the callback is returning a large struct, we have
+    #! to fix ESP.
+    {
+        { [ dup abi>> "stdcall" = ] [
+            <alien-stack-frame>
+            [ params>> ] [ return>> ] bi +
+        ] }
+        { [ dup return>> large-struct? ] [ drop 4 ] }
+        [ drop 0 ]
+    } cond ;
+
 ! Dreadful
 M: object flatten-value-type (flatten-int-type) ;
 

basis/cpu/x86/32/bootstrap.factor

@@ -18,6 +18,8 @@ IN: bootstrap.x86
 : temp3 ( -- reg ) EBX ;
 : safe-reg ( -- reg ) EAX ;
 : stack-reg ( -- reg ) ESP ;
+: frame-reg ( -- reg ) EBP ;
+: nv-regs ( -- seq ) { ESI EDI EBX } ;
 : ds-reg ( -- reg ) ESI ;
 : rs-reg ( -- reg ) EDI ;
 : fixnum>slot@ ( -- ) temp0 2 SAR ;

basis/cpu/x86/64/64.factor

@@ -1,17 +1,19 @@
-! Copyright (C) 2005, 2009 Slava Pestov.
+! Copyright (C) 2005, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays kernel math namespaces make sequences system
+USING: accessors arrays kernel math namespaces make sequences
-layouts alien alien.c-types alien.accessors slots
+system layouts alien alien.c-types alien.accessors slots
 splitting assocs combinators locals compiler.constants
-compiler.codegen compiler.codegen.fixup compiler.cfg.instructions
+compiler.codegen compiler.codegen.fixup
-compiler.cfg.builder compiler.cfg.intrinsics compiler.cfg.stack-frame
+compiler.cfg.instructions compiler.cfg.builder
-cpu.x86.assembler cpu.x86.assembler.operands cpu.x86 cpu.architecture ;
+compiler.cfg.intrinsics compiler.cfg.stack-frame
+cpu.x86.assembler cpu.x86.assembler.operands cpu.x86
+cpu.architecture ;
 IN: cpu.x86.64
 
-: param-reg-1 ( -- reg ) int-regs param-regs first ; inline
+: param-reg-0 ( -- reg ) 0 int-regs param-reg ; inline
-: param-reg-2 ( -- reg ) int-regs param-regs second ; inline
+: param-reg-1 ( -- reg ) 1 int-regs param-reg ; inline
-: param-reg-3 ( -- reg ) int-regs param-regs third ; inline
+: param-reg-2 ( -- reg ) 2 int-regs param-reg ; inline
-: param-reg-4 ( -- reg ) int-regs param-regs fourth ; inline
+: param-reg-3 ( -- reg ) 3 int-regs param-reg ; inline
 
 M: x86.64 pic-tail-reg RBX ;
 
@@ -21,6 +23,7 @@ M: float-regs return-reg drop XMM0 ;
 M: x86.64 ds-reg R14 ;
 M: x86.64 rs-reg R15 ;
 M: x86.64 stack-reg RSP ;
+M: x86.64 frame-reg RBP ;
 
 M: x86.64 extra-stack-space drop 0 ;
 
@@ -56,9 +59,9 @@ M: x86.64 %mark-deck
     [+] card-mark <byte> MOV ;
 
 M:: x86.64 %dispatch ( src temp -- )
-    building get length :> start
     ! Load jump table base.
     temp HEX: ffffffff MOV
+    building get length :> start
     0 rc-absolute-cell rel-here
     ! Add jump table base
     temp src ADD
@@ -66,7 +69,7 @@ M:: x86.64 %dispatch ( src temp -- )
     building get length :> end
     ! Fix up the displacement above
     cell code-alignment
-    [ end start - 2 - + building get dup pop* push ]
+    [ end start - + building get dup pop* push ]
     [ align-code ]
     bi ;
 
@@ -89,16 +92,16 @@ M: x86.64 %load-param-reg [ swap param@ ] dip %copy ;
     ] with-scope ; inline
 
 M: x86.64 %pop-stack ( n -- )
-    param-reg-1 swap ds-reg reg-stack MOV ;
+    param-reg-0 swap ds-reg reg-stack MOV ;
 
 M: x86.64 %pop-context-stack ( -- )
     temp-reg %load-context-datastack
-    param-reg-1 temp-reg [] MOV
+    param-reg-0 temp-reg [] MOV
-    param-reg-1 param-reg-1 [] MOV
+    param-reg-0 param-reg-0 [] MOV
     temp-reg [] bootstrap-cell SUB ;
 
 M:: x86.64 %unbox ( n rep func -- )
-    param-reg-2 %mov-vm-ptr
+    param-reg-1 %mov-vm-ptr
     ! Call the unboxer
     func f %alien-invoke
     ! Store the return value on the C stack if this is an
@@ -110,15 +113,15 @@ M: x86.64 %unbox-long-long ( n func -- )
     [ int-rep ] dip %unbox ;
 
 : %unbox-struct-field ( c-type i -- )
-    ! Alien must be in param-reg-1.
+    ! Alien must be in param-reg-0.
     R11 swap cells [+] swap rep>> reg-class-of {
         { int-regs [ int-regs get pop swap MOV ] }
         { float-regs [ float-regs get pop swap MOVSD ] }
     } case ;
 
 M: x86.64 %unbox-small-struct ( c-type -- )
-    ! Alien must be in param-reg-1.
+    ! Alien must be in param-reg-0.
-    param-reg-2 %mov-vm-ptr
+    param-reg-1 %mov-vm-ptr
     "alien_offset" f %alien-invoke
     ! Move alien_offset() return value to R11 so that we don't
     ! clobber it.
@@ -128,12 +131,12 @@ M: x86.64 %unbox-small-struct ( c-type -- )
     ] with-return-regs ;
 
 M:: x86.64 %unbox-large-struct ( n c-type -- )
-    ! Source is in param-reg-1
+    ! Source is in param-reg-0
-    ! Load destination address into param-reg-2
+    ! Load destination address into param-reg-1
-    param-reg-2 n param@ LEA
+    param-reg-1 n param@ LEA
-    ! Load structure size into param-reg-3
+    ! Load structure size into param-reg-2
-    param-reg-3 c-type heap-size MOV
+    param-reg-2 c-type heap-size MOV
-    param-reg-4 %mov-vm-ptr
+    param-reg-3 %mov-vm-ptr
     ! Copy the struct to the C stack
     "to_value_struct" f %alien-invoke ;
 
@@ -151,7 +154,7 @@ M:: x86.64 %box ( n rep func -- )
     ] [
         rep load-return-value
     ] if
-    rep int-rep? [ param-reg-2 ] [ param-reg-1 ] if %mov-vm-ptr
+    rep int-rep? [ param-reg-1 ] [ param-reg-0 ] if %mov-vm-ptr
     func f %alien-invoke ;
 
 M: x86.64 %box-long-long ( n func -- )
@@ -169,10 +172,10 @@ M: x86.64 %box-small-struct ( c-type -- )
     #! Box a <= 16-byte struct.
     [
         [ flatten-value-type [ %box-struct-field ] each-index ]
-        [ param-reg-3 swap heap-size MOV ] bi
+        [ param-reg-2 swap heap-size MOV ] bi
-        param-reg-1 0 box-struct-field@ MOV
+        param-reg-0 0 box-struct-field@ MOV
-        param-reg-2 1 box-struct-field@ MOV
+        param-reg-1 1 box-struct-field@ MOV
-        param-reg-4 %mov-vm-ptr
+        param-reg-3 %mov-vm-ptr
         "from_small_struct" f %alien-invoke
     ] with-return-regs ;
 
@@ -181,10 +184,10 @@ M: x86.64 %box-small-struct ( c-type -- )
 
 M: x86.64 %box-large-struct ( n c-type -- )
     ! Struct size is parameter 2
-    param-reg-2 swap heap-size MOV
+    param-reg-1 swap heap-size MOV
     ! Compute destination address
-    param-reg-1 swap struct-return@ LEA
+    param-reg-0 swap struct-return@ LEA
-    param-reg-3 %mov-vm-ptr
+    param-reg-2 %mov-vm-ptr
     ! Copy the struct from the C stack
     "from_value_struct" f %alien-invoke ;
 
@@ -202,19 +205,17 @@ M: x86.64 %alien-invoke
     R11 CALL ;
 
 M: x86.64 %nest-stacks ( -- )
-    ! Save current frame. See comment in vm/contexts.hpp
+    param-reg-0 %mov-vm-ptr
-    param-reg-1 stack-reg stack-frame get total-size>> 3 cells - [+] LEA
-    param-reg-2 %mov-vm-ptr
     "nest_stacks" f %alien-invoke ;
 
 M: x86.64 %unnest-stacks ( -- )
-    param-reg-1 %mov-vm-ptr
+    param-reg-0 %mov-vm-ptr
     "unnest_stacks" f %alien-invoke ;
 
 M: x86.64 %prepare-alien-indirect ( -- )
-    param-reg-1 ds-reg [] MOV
+    param-reg-0 ds-reg [] MOV
     ds-reg 8 SUB
-    param-reg-2 %mov-vm-ptr
+    param-reg-1 %mov-vm-ptr
     "pinned_alien_offset" f %alien-invoke
     RBP RAX MOV ;
 
@@ -222,19 +223,21 @@ M: x86.64 %alien-indirect ( -- )
     RBP CALL ;
 
 M: x86.64 %alien-callback ( quot -- )
-    param-reg-1 swap %load-reference
+    param-reg-0 param-reg-1 %load-context
-    param-reg-2 %mov-vm-ptr
+    param-reg-0 swap %load-reference
-    "c_to_factor" f %alien-invoke ;
+    param-reg-1 %mov-vm-ptr
+    param-reg-0 quot-xt-offset [+] CALL
+    param-reg-0 param-reg-1 %save-context ;
 
 M: x86.64 %callback-value ( ctype -- )
     %pop-context-stack
     RSP 8 SUB
-    param-reg-1 PUSH
+    param-reg-0 PUSH
-    param-reg-1 %mov-vm-ptr
+    param-reg-0 %mov-vm-ptr
     ! Restore data/call/retain stacks
     "unnest_stacks" f %alien-invoke
-    ! Put former top of data stack in param-reg-1
+    ! Put former top of data stack in param-reg-0
-    param-reg-1 POP
+    param-reg-0 POP
     RSP 8 ADD
     ! Unbox former top of data stack to return registers
     unbox-return ;
@@ -260,11 +263,11 @@ M:: x86.64 %binary-float-function ( dst src1 src2 func -- )
 
 M:: x86.64 %call-gc ( gc-root-count temp -- )
     ! Pass pointer to start of GC roots as first parameter
-    param-reg-1 gc-root-base param@ LEA
+    param-reg-0 gc-root-base param@ LEA
     ! Pass number of roots as second parameter
-    param-reg-2 gc-root-count MOV
+    param-reg-1 gc-root-count MOV
     ! Pass VM ptr as third parameter
-    param-reg-3 %mov-vm-ptr
+    param-reg-2 %mov-vm-ptr
     ! Call GC
     "inline_gc" f %alien-invoke ;
 

basis/cpu/x86/64/bootstrap.factor

@@ -17,6 +17,7 @@ IN: bootstrap.x86
 : temp3 ( -- reg ) RBX ;
 : safe-reg ( -- reg ) RAX ;
 : stack-reg ( -- reg ) RSP ;
+: frame-reg ( -- reg ) RBP ;
 : ds-reg ( -- reg ) R14 ;
 : rs-reg ( -- reg ) R15 ;
 : fixnum>slot@ ( -- ) temp0 1 SAR ;

basis/cpu/x86/64/unix/bootstrap.factor

@@ -6,9 +6,11 @@ sequences system vocabs ;
 IN: bootstrap.x86
 
 : stack-frame-size ( -- n ) 4 bootstrap-cells ;
+: nv-regs ( -- seq ) { RBX R12 R13 R14 R15 } ;
 : arg1 ( -- reg ) RDI ;
 : arg2 ( -- reg ) RSI ;
 : arg3 ( -- reg ) RDX ;
+: arg4 ( -- reg ) RCX ;
 
 << "vocab:cpu/x86/64/bootstrap.factor" parse-file suffix! >>
 call

basis/cpu/x86/64/winnt/bootstrap.factor

@@ -6,9 +6,11 @@ cpu.x86.assembler.operands ;
 IN: bootstrap.x86
 
 : stack-frame-size ( -- n ) 8 bootstrap-cells ;
+: nv-regs ( -- seq ) { RBX RSI RDI R12 R13 R14 R15 } ;
 : arg1 ( -- reg ) RCX ;
 : arg2 ( -- reg ) RDX ;
 : arg3 ( -- reg ) R8 ;
+: arg4 ( -- reg ) R9 ;
 
 << "vocab:cpu/x86/64/bootstrap.factor" parse-file suffix! >>
 call

basis/cpu/x86/bootstrap.factor

@@ -8,6 +8,49 @@ IN: bootstrap.x86
 
 big-endian off
 
+! C to Factor entry point
+[
+    ! Optimizing compiler's side of callback accesses
+    ! arguments that are on the stack via the frame pointer.
+    ! On x86-64, some arguments are passed in registers, and
+    ! so the only register that is safe for use here is safe-reg.
+    frame-reg PUSH
+    frame-reg stack-reg MOV
+
+    ! Save all non-volatile registers
+    nv-regs [ PUSH ] each
+
+    ! Save old stack pointer and align
+    safe-reg stack-reg MOV
+    stack-reg bootstrap-cell SUB
+    stack-reg -16 AND
+    stack-reg [] safe-reg MOV
+
+    ! Register shadow area - only required on Win64, but doesn't
+    ! hurt on other platforms
+    stack-reg 32 SUB
+
+    ! Call into Factor code
+    safe-reg 0 MOV rc-absolute-cell rt-xt jit-rel
+    safe-reg CALL
+
+    ! Tear down register shadow area
+    stack-reg 32 ADD
+
+    ! Undo stack alignment
+    stack-reg stack-reg [] MOV
+
+    ! Restore non-volatile registers
+    nv-regs <reversed> [ POP ] each
+
+    frame-reg POP
+
+    ! Callbacks which return structs, or use stdcall, need a
+    ! parameter here. See the comment in callback-return-rewind
+    ! in cpu.x86.32
+    HEX: ffff RET rc-absolute-2 rt-untagged jit-rel
+] callback-stub jit-define
+
 [
     ! Load word
     temp0 0 MOV rc-absolute-cell rt-literal jit-rel
@@ -206,11 +249,6 @@ big-endian off
     ! fall-through on miss
 ] mega-lookup jit-define
 
-[
-    safe-reg 0 MOV rc-absolute-cell rt-xt jit-rel
-    safe-reg JMP
-] callback-stub jit-define
-
 ! ! ! Sub-primitives
 
 ! Objects

basis/cpu/x86/x86.factor

@@ -24,6 +24,8 @@ M: x86 vector-regs float-regs ;
 
 HOOK: stack-reg cpu ( -- reg )
 
+HOOK: frame-reg cpu ( -- reg )
+
 HOOK: reserved-stack-space cpu ( -- n )
 
 HOOK: extra-stack-space cpu ( stack-frame -- n )
@@ -84,7 +86,7 @@ M: x86 %call ( word -- ) 0 CALL rc-relative rel-word-pic ;
 
 : xt-tail-pic-offset ( -- n )
     #! See the comment in vm/cpu-x86.hpp
-    cell 4 + 1 + ; inline
+    4 1 + ; inline
 
 M: x86 %jump ( word -- )
     pic-tail-reg 0 MOV xt-tail-pic-offset rc-absolute-cell rel-here
@@ -1408,15 +1410,31 @@ M:: x86 %reload ( dst rep src -- ) dst src rep %copy ;
 
 M: x86 %loop-entry 16 code-alignment [ NOP ] times ;
 
+M:: x86 %load-context ( temp1 temp2 -- )
+    #! Load Factor stack pointers on entry from C to Factor.
+    #! Also save callstack bottom!
+    temp1 "ctx" %vm-field-ptr
+    temp1 temp1 [] MOV
+    ! callstack_bottom
+    temp2 stack-reg stack-frame get total-size>> cell - [+] LEA
+    temp1 1 cells [+] temp2 MOV
+    ! datastack
+    ds-reg temp1 2 cells [+] MOV
+    ! retainstack
+    rs-reg temp1 3 cells [+] MOV ;
+
 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-ptr
     temp1 temp1 [] MOV
+    ! callstack_top
     temp2 stack-reg cell neg [+] LEA
     temp1 [] temp2 MOV
+    ! datastack
     temp1 2 cells [+] ds-reg MOV
+    ! retainstack
     temp1 3 cells [+] rs-reg MOV ;
 
 M: x86 value-struct? drop t ;
@@ -1432,7 +1450,7 @@ M: x86 immediate-bitwise? ( n -- ? )
     #! input values to callbacks; the callback has its own
     #! stack frame set up, and we want to read the frame
     #! set up by the caller.
-    stack-frame get total-size>> + stack@ ;
+    frame-reg swap 2 cells + [+] ;
 
 enable-min/max
 enable-fixnum-log2

basis/stack-checker/alien/alien.factor

@@ -1,8 +1,9 @@
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel sequences accessors combinators math namespaces
 init sets words assocs alien.libraries alien alien.c-types
-stack-checker.backend stack-checker.errors stack-checker.visitor ;
+cpu.architecture fry stack-checker.backend stack-checker.errors
+stack-checker.visitor ;
 IN: stack-checker.alien
 
 TUPLE: alien-node-params return parameters abi in-d out-d ;
@@ -49,7 +50,7 @@ TUPLE: alien-callback-params < alien-node-params quot xt ;
     pop-literal nip >>parameters
     pop-literal nip >>return
     ! Quotation which coerces parameters to required types
-    dup param-prep-quot [ dip ] curry infer-quot-here
+    dup param-prep-quot '[ _ dip ] infer-quot-here
     ! Magic #: consume the function pointer, too
     dup 1 alien-stack
     ! Add node to IR
@@ -57,11 +58,12 @@ TUPLE: alien-callback-params < alien-node-params quot xt ;
     ! Quotation which coerces return value to required type
     return-prep-quot infer-quot-here ;
 
-: callback-xt ( word -- alien )
+: callback-xt ( word return-rewind -- alien )
-    callbacks get [ <callback> ] cache ;
+    [ callbacks get ] dip '[ _ <callback> ] cache ;
 
 : callback-bottom ( params -- )
-    xt>> [ callback-xt ] curry infer-quot-here ;
+    [ xt>> ] [ callback-return-rewind ] bi
+    '[ _ _ callback-xt ] infer-quot-here ;
 
 : infer-alien-callback ( -- )
     alien-callback-params new

basis/stack-checker/known-words/known-words.factor

@@ -709,7 +709,7 @@ M: bad-executable summary
 
 \ strip-stack-traces { } { } define-primitive
 
-\ <callback> { word } { alien } define-primitive
+\ <callback> { integer word } { alien } define-primitive
 
 \ enable-gc-events { } { } define-primitive
 \ disable-gc-events { } { object } define-primitive

core/bootstrap/primitives.factor

@@ -518,7 +518,7 @@ tuple
     { "quot-compiled?" "quotations" (( quot -- ? )) }
     { "vm-ptr" "vm" (( -- ptr )) }
     { "strip-stack-traces" "kernel.private" (( -- )) }
-    { "<callback>" "alien" (( word -- alien )) }
+    { "<callback>" "alien" (( return-rewind word -- alien )) }
     { "enable-gc-events" "memory" (( -- )) }
     { "disable-gc-events" "memory" (( -- events )) }
     { "(identity-hashcode)" "kernel.private" (( obj -- code )) }

vm/callbacks.cpp

@@ -38,7 +38,7 @@ void callback_heap::update(code_block *stub)
 	stub->flush_icache();
 }
 
-code_block *callback_heap::add(cell owner)
+code_block *callback_heap::add(cell owner, cell return_rewind)
 {
 	tagged<array> code_template(parent->special_objects[CALLBACK_STUB]);
 	tagged<byte_array> insns(array_nth(code_template.untagged(),0));
@@ -57,6 +57,24 @@ code_block *callback_heap::add(cell owner)
 	stub->relocation = false_object;
 
 	memcpy(stub->xt(),insns->data<void>(),size);
+
+	/* On x86, the RET instruction takes an argument which depends on
+	the callback's calling convention */
+	if(array_capacity(code_template.untagged()) == 7)
+	{
+		cell rel_class = untag_fixnum(array_nth(code_template.untagged(),4));
+		cell rel_type = untag_fixnum(array_nth(code_template.untagged(),5));
+		cell offset = untag_fixnum(array_nth(code_template.untagged(),6));
+
+		relocation_entry rel(
+			(relocation_type)rel_type,
+			(relocation_class)rel_class,
+			offset);
+
+		instruction_operand op(rel,stub,0);
+		op.store_value(return_rewind);
+	}
+
 	update(stub);
 
 	return stub;
@@ -81,9 +99,11 @@ void callback_heap::update()
 
 void factor_vm::primitive_callback()
 {
+	cell return_rewind = to_cell(ctx->pop());
 	tagged<word> w(ctx->pop());
+
 	w.untag_check(this);
-	ctx->push(allot_alien(callbacks->add(w.value())->xt()));
+	ctx->push(allot_alien(callbacks->add(w.value(),return_rewind)->xt()));
 }
 
 }

vm/callbacks.hpp

@@ -39,7 +39,7 @@ struct callback_heap {
 	}
 
 	void update(code_block *stub);
-	code_block *add(cell owner);
+	code_block *add(cell owner, cell return_rewind);
 
 	void update();
 

vm/contexts.cpp

@@ -8,7 +8,6 @@ context::context(cell ds_size, cell rs_size) :
 	callstack_bottom(NULL),
 	datastack(0),
 	retainstack(0),
-	magic_frame(NULL),
 	datastack_region(new segment(ds_size,false)),
 	retainstack_region(new segment(rs_size,false)),
 	catchstack_save(0),
@@ -41,15 +40,13 @@ void factor_vm::dealloc_context(context *old_context)
 }
 
 /* called on entry into a compiled callback */
-void factor_vm::nest_stacks(stack_frame *magic_frame)
+void factor_vm::nest_stacks()
 {
 	context *new_ctx = alloc_context();
 
 	new_ctx->callstack_bottom = (stack_frame *)-1;
 	new_ctx->callstack_top = (stack_frame *)-1;
 
-	new_ctx->magic_frame = magic_frame;
-
 	/* save per-callback special_objects */
 	new_ctx->current_callback_save = special_objects[OBJ_CURRENT_CALLBACK];
 	new_ctx->catchstack_save = special_objects[OBJ_CATCHSTACK];
@@ -61,9 +58,9 @@ void factor_vm::nest_stacks(stack_frame *magic_frame)
 	ctx = new_ctx;
 }
 
-void nest_stacks(stack_frame *magic_frame, factor_vm *parent)
+void nest_stacks(factor_vm *parent)
 {
-	return parent->nest_stacks(magic_frame);
+	return parent->nest_stacks();
 }
 
 /* called when leaving a compiled callback */

vm/contexts.hpp

@@ -13,18 +13,6 @@ struct context {
 	/* current retain stack top pointer */
 	cell retainstack;
 
-	/* callback-bottom stack frame, or NULL for top-level context.
-	When nest_stacks() is called, callstack layout with callbacks
-	is as follows:
-	
-	[ C function ]
-	[ callback stub in code heap ] <-- this is the magic frame
-	[ native frame: c_to_factor() ]
-	[ callback quotation frame ] <-- first call frame in call stack
-	
-	magic frame is retained so that it's XT can be traced and forwarded. */
-	stack_frame *magic_frame;
-
 	/* memory region holding current datastack */
 	segment *datastack_region;
 
@@ -86,7 +74,7 @@ struct context {
 	}
 };
 
-VM_C_API void nest_stacks(stack_frame *magic_frame, factor_vm *vm);
+VM_C_API void nest_stacks(factor_vm *vm);
 VM_C_API void unnest_stacks(factor_vm *vm);
 
 }

vm/cpu-x86.32.S

@@ -18,9 +18,9 @@ DEF(void,c_to_factor,(cell quot, void *vm)):
 	push %edi
 
 	/* Save old stack pointer and align */
-	mov %esp,%ebp
+	mov %esp,%ebx
 	and $-16,%esp
-	push %ebp
+	push %ebx
 
 	/* Set up stack frame for the call to the boot quotation */
 	sub $4,%esp
@@ -49,8 +49,7 @@ DEF(void,c_to_factor,(cell quot, void *vm)):
 	add $4,%esp
 
 	/* Undo stack alignment */
-	pop %ebp
+	mov (%esp),%esp
-	mov %ebp,%esp
 
 	/* Load context */
 	mov (%edx),%ecx

vm/cpu-x86.hpp

@@ -15,7 +15,7 @@ inline static void flush_icache(cell start, cell len) {}
    the offset from the immediate operand to MOV to the instruction after
    the jump is a cell for the immediate operand, 4 bytes for the JMP
    destination, and one byte for the JMP opcode. */
-static const fixnum xt_tail_pic_offset = sizeof(cell) + 4 + 1;
+static const fixnum xt_tail_pic_offset = 4 + 1;
 
 static const unsigned char call_opcode = 0xe8;
 static const unsigned char jmp_opcode = 0xe9;

vm/factor.cpp

@@ -164,14 +164,14 @@ void factor_vm::start_factor(vm_parameters *p)
 {
 	if(p->fep) factorbug();
 
-	nest_stacks(NULL);
+	nest_stacks();
 	c_to_factor_toplevel(special_objects[OBJ_STARTUP_QUOT]);
 	unnest_stacks();
 }
 
 void factor_vm::stop_factor()
 {
-	nest_stacks(NULL);
+	nest_stacks();
 	c_to_factor_toplevel(special_objects[OBJ_SHUTDOWN_QUOT]);
 	unnest_stacks();
 }

vm/instruction_operands.cpp

@@ -10,17 +10,17 @@ instruction_operand::instruction_operand(relocation_entry rel_, code_block *comp
 fixnum instruction_operand::load_value_2_2()
 {
 	cell *ptr = (cell *)pointer;
-	cell hi = (ptr[-1] & 0xffff);
+	cell hi = (ptr[-2] & 0xffff);
-	cell lo = (ptr[ 0] & 0xffff);
+	cell lo = (ptr[-1] & 0xffff);
 	return hi << 16 | lo;
 }
 
 /* Load a value from a bitfield of a PowerPC instruction */
 fixnum instruction_operand::load_value_masked(cell mask, cell bits, cell shift)
 {
-	fixnum *ptr = (fixnum *)pointer;
+	s32 *ptr = (s32 *)(pointer - sizeof(u32));
 
-	return (((*ptr & (fixnum)mask) << bits) >> bits) << shift;
+	return (((*ptr & (s32)mask) << bits) >> bits) << shift;
 }
 
 fixnum instruction_operand::load_value(cell relative_to)
@@ -28,11 +28,11 @@ fixnum instruction_operand::load_value(cell relative_to)
 	switch(rel.rel_class())
 	{
 	case RC_ABSOLUTE_CELL:
-		return *(cell *)pointer;
+		return *(cell *)(pointer - sizeof(cell));
 	case RC_ABSOLUTE:
-		return *(u32*)pointer;
+		return *(u32 *)(pointer - sizeof(u32));
 	case RC_RELATIVE:
-		return *(s32*)pointer + relative_to + sizeof(u32);
+		return *(s32 *)(pointer - sizeof(u32)) + relative_to;
 	case RC_ABSOLUTE_PPC_2_2:
 		return load_value_2_2();
 	case RC_ABSOLUTE_PPC_2:
@@ -42,11 +42,13 @@ fixnum instruction_operand::load_value(cell relative_to)
 	case RC_RELATIVE_PPC_3:
 		return load_value_masked(rel_relative_ppc_3_mask,6,0) + relative_to;
 	case RC_RELATIVE_ARM_3:
-		return load_value_masked(rel_relative_arm_3_mask,6,2) + relative_to + sizeof(cell) * 2;
+		return load_value_masked(rel_relative_arm_3_mask,6,2) + relative_to + sizeof(cell);
 	case RC_INDIRECT_ARM:
-		return load_value_masked(rel_indirect_arm_mask,20,0) + relative_to + sizeof(cell);
+		return load_value_masked(rel_indirect_arm_mask,20,0) + relative_to;
 	case RC_INDIRECT_ARM_PC:
-		return load_value_masked(rel_indirect_arm_mask,20,0) + relative_to + sizeof(cell) * 2;
+		return load_value_masked(rel_indirect_arm_mask,20,0) + relative_to + sizeof(cell);
+	case RC_ABSOLUTE_2:
+		return *(u16 *)(pointer - sizeof(u16));
 	default:
 		critical_error("Bad rel class",rel.rel_class());
 		return 0;
@@ -72,14 +74,14 @@ code_block *instruction_operand::load_code_block()
 void instruction_operand::store_value_2_2(fixnum value)
 {
 	cell *ptr = (cell *)pointer;
-	ptr[-1] = ((ptr[-1] & ~0xffff) | ((value >> 16) & 0xffff));
+	ptr[-2] = ((ptr[-2] & ~0xffff) | ((value >> 16) & 0xffff));
-	ptr[ 0] = ((ptr[ 0] & ~0xffff) | (value & 0xffff));
+	ptr[-1] = ((ptr[-1] & ~0xffff) | (value & 0xffff));
 }
 
 /* Store a value into a bitfield of a PowerPC instruction */
 void instruction_operand::store_value_masked(fixnum value, cell mask, cell shift)
 {
-	cell *ptr = (cell *)pointer;
+	u32 *ptr = (u32 *)(pointer - sizeof(u32));
 	*ptr = ((*ptr & ~mask) | ((value >> shift) & mask));
 }
 
@@ -90,13 +92,13 @@ void instruction_operand::store_value(fixnum absolute_value)
 	switch(rel.rel_class())
 	{
 	case RC_ABSOLUTE_CELL:
-		*(cell *)pointer = absolute_value;
+		*(cell *)(pointer - sizeof(cell)) = absolute_value;
 		break;
 	case RC_ABSOLUTE:
-		*(u32*)pointer = absolute_value;
+		*(u32 *)(pointer - sizeof(u32)) = absolute_value;
 		break;
 	case RC_RELATIVE:
-		*(s32*)pointer = relative_value - sizeof(u32);
+		*(s32 *)(pointer - sizeof(s32)) = relative_value;
 		break;
 	case RC_ABSOLUTE_PPC_2_2:
 		store_value_2_2(absolute_value);
@@ -111,13 +113,16 @@ void instruction_operand::store_value(fixnum absolute_value)
 		store_value_masked(relative_value,rel_relative_ppc_3_mask,0);
 		break;
 	case RC_RELATIVE_ARM_3:
-		store_value_masked(relative_value - sizeof(cell) * 2,rel_relative_arm_3_mask,2);
+		store_value_masked(relative_value - sizeof(cell),rel_relative_arm_3_mask,2);
 		break;
 	case RC_INDIRECT_ARM:
-		store_value_masked(relative_value - sizeof(cell),rel_indirect_arm_mask,0);
+		store_value_masked(relative_value,rel_indirect_arm_mask,0);
 		break;
 	case RC_INDIRECT_ARM_PC:
-		store_value_masked(relative_value - sizeof(cell) * 2,rel_indirect_arm_mask,0);
+		store_value_masked(relative_value - sizeof(cell),rel_indirect_arm_mask,0);
+		break;
+	case RC_ABSOLUTE_2:
+		*(u16 *)(pointer - sizeof(u16)) = absolute_value;
 		break;
 	default:
 		critical_error("Bad rel class",rel.rel_class());

vm/instruction_operands.hpp

@@ -54,7 +54,9 @@ enum relocation_class {
 	/* pointer to address in an ARM LDR/STR instruction */
 	RC_INDIRECT_ARM,
 	/* pointer to address in an ARM LDR/STR instruction offset by 8 bytes */
-	RC_INDIRECT_ARM_PC
+	RC_INDIRECT_ARM_PC,
+	/* absolute address in a 16-bit location */
+	RC_ABSOLUTE_2
 };
 
 static const cell rel_absolute_ppc_2_mask = 0xffff;

vm/vm.hpp

@@ -94,7 +94,7 @@ struct factor_vm
 	// contexts
 	context *alloc_context();
 	void dealloc_context(context *old_context);
-	void nest_stacks(stack_frame *magic_frame);
+	void nest_stacks();
 	void unnest_stacks();
 	void init_stacks(cell ds_size_, cell rs_size_);
 	bool stack_to_array(cell bottom, cell top);
@@ -113,7 +113,6 @@ struct factor_vm
 		while(ctx)
 		{
 			iterate_callstack(ctx,iter);
-			if(ctx->magic_frame) iter(ctx->magic_frame);
 			ctx = ctx->next;
 		}
 	}