steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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

db4
Doug Coleman 2010-01-04 10:59:39 -05:00
parent cbef261fde 18929373b9
commit 96c4b1a672
29 changed files with 234 additions and 168 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
basis/bootstrap/image/image.factor
View File

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

6
basis/compiler/cfg/builder/builder.factor
View File

@ -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

4
basis/compiler/cfg/checker/checker.factor
View File

@ -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 ;

5
basis/compiler/cfg/instructions/instructions.factor
View File

@ -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 ;

7
basis/compiler/codegen/codegen.factor
View File

@ -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 ]

7
basis/compiler/codegen/fixup/fixup.factor
View File

@ -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* ;

3
basis/compiler/constants/constants.factor
View File

@ -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

9
basis/cpu/architecture/architecture.factor
View File

@ -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 cpu ( params -- )
HOOK: callback-return-rewind cpu ( params -- n )
M: object %callback-return drop %return ;
M: object callback-return-rewind drop 0 ;

46
basis/cpu/x86/32/32.factor
View File

@ -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.
! 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
0 save-vm-ptr
"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
4 save-vm-ptr
"c_to_factor" f %alien-invoke ;
EDX %mov-vm-ptr
EAX quot-xt-offset [+] CALL
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) ;

2
basis/cpu/x86/32/bootstrap.factor
View File

@ -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 ;

101
basis/cpu/x86/64/64.factor
View File

@ -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
layouts alien alien.c-types alien.accessors slots
USING: accessors arrays kernel math namespaces make sequences
system layouts alien alien.c-types alien.accessors slots
splitting assocs combinators locals compiler.constants
compiler.codegen compiler.codegen.fixup compiler.cfg.instructions
compiler.cfg.builder compiler.cfg.intrinsics compiler.cfg.stack-frame
cpu.x86.assembler cpu.x86.assembler.operands cpu.x86 cpu.architecture ;
compiler.codegen compiler.codegen.fixup
compiler.cfg.instructions compiler.cfg.builder
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-2 ( -- reg ) int-regs param-regs second ; inline
: param-reg-3 ( -- reg ) int-regs param-regs third ; inline
: param-reg-4 ( -- reg ) int-regs param-regs fourth ; inline
: param-reg-0 ( -- reg ) 0 int-regs param-reg ; inline
: param-reg-1 ( -- reg ) 1 int-regs param-reg ; inline
: param-reg-2 ( -- reg ) 2 int-regs param-reg ; 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-1 param-reg-1 [] MOV
param-reg-0 temp-reg [] 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.
param-reg-2 %mov-vm-ptr
! Alien must be in param-reg-0.
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
! Load destination address into param-reg-2
param-reg-2 n param@ LEA
! Load structure size into param-reg-3
param-reg-3 c-type heap-size MOV
param-reg-4 %mov-vm-ptr
! Source is in param-reg-0
! Load destination address into param-reg-1
param-reg-1 n param@ LEA
! Load structure size into param-reg-2
param-reg-2 c-type heap-size MOV
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-1 0 box-struct-field@ MOV
param-reg-2 1 box-struct-field@ MOV
param-reg-4 %mov-vm-ptr
[ param-reg-2 swap heap-size MOV ] bi
param-reg-0 0 box-struct-field@ MOV
param-reg-1 1 box-struct-field@ MOV
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-3 %mov-vm-ptr
param-reg-0 swap struct-return@ LEA
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-1 stack-reg stack-frame get total-size>> 3 cells - [+] LEA
param-reg-2 %mov-vm-ptr
param-reg-0 %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-2 %mov-vm-ptr
"c_to_factor" f %alien-invoke ;
param-reg-0 param-reg-1 %load-context
param-reg-0 swap %load-reference
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-1 %mov-vm-ptr
param-reg-0 PUSH
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
param-reg-1 POP
! Put former top of data stack in param-reg-0
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 ;

1
basis/cpu/x86/64/bootstrap.factor
View File

@ -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 ;

2
basis/cpu/x86/64/unix/bootstrap.factor
View File

@ -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

2
basis/cpu/x86/64/winnt/bootstrap.factor
View File

@ -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

48
basis/cpu/x86/bootstrap.factor
View File

@ -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

22
basis/cpu/x86/x86.factor
View File

@ -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

14
basis/stack-checker/alien/alien.factor
View File

@ -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 )
callbacks get [ <callback> ] cache ;
: callback-xt ( word return-rewind -- alien )
[ 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

2
basis/stack-checker/known-words/known-words.factor
View File

@ -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

2
core/bootstrap/primitives.factor
View File

@ -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 )) }

24
vm/callbacks.cpp
View File

@ -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()));
}
}

2
vm/callbacks.hpp
View File

@ -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();

9
vm/contexts.cpp
View File

@ -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 */

14
vm/contexts.hpp
View File

@ -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);
}

7
vm/cpu-x86.32.S
View File

@ -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 %ebp,%esp
mov (%esp),%esp
/* Load context */
mov (%edx),%ecx

2
vm/cpu-x86.hpp
View File

@ -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;

4
vm/factor.cpp
View File

@ -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();
}

43
vm/instruction_operands.cpp
View File

@ -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 lo = (ptr[ 0] & 0xffff);
cell hi = (ptr[-2] & 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[ 0] = ((ptr[ 0] & ~0xffff) | (value & 0xffff));
ptr[-2] = ((ptr[-2] & ~0xffff) | ((value >> 16) & 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());

4
vm/instruction_operands.hpp
View File

@ -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;

3
vm/vm.hpp
View File

@ -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;
}
}