fixed up getenv compiler intrinsic to use vm struct userenv
parent
3b3ed501c7
commit
ff8f2b10ec
|
@ -190,12 +190,14 @@ M: ##slot-imm insn-slot# slot>> ;
|
||||||
M: ##set-slot insn-slot# slot>> constant ;
|
M: ##set-slot insn-slot# slot>> constant ;
|
||||||
M: ##set-slot-imm insn-slot# slot>> ;
|
M: ##set-slot-imm insn-slot# slot>> ;
|
||||||
M: ##alien-global insn-slot# [ library>> ] [ symbol>> ] bi 2array ;
|
M: ##alien-global insn-slot# [ library>> ] [ symbol>> ] bi 2array ;
|
||||||
|
M: ##vm-field-ptr insn-slot# fieldname>> 1array ; ! is this right?
|
||||||
|
|
||||||
M: ##slot insn-object obj>> resolve ;
|
M: ##slot insn-object obj>> resolve ;
|
||||||
M: ##slot-imm insn-object obj>> resolve ;
|
M: ##slot-imm insn-object obj>> resolve ;
|
||||||
M: ##set-slot insn-object obj>> resolve ;
|
M: ##set-slot insn-object obj>> resolve ;
|
||||||
M: ##set-slot-imm insn-object obj>> resolve ;
|
M: ##set-slot-imm insn-object obj>> resolve ;
|
||||||
M: ##alien-global insn-object drop \ ##alien-global ;
|
M: ##alien-global insn-object drop \ ##alien-global ;
|
||||||
|
M: ##vm-field-ptr insn-object drop \ ##vm-field-ptr ;
|
||||||
|
|
||||||
: init-alias-analysis ( insns -- insns' )
|
: init-alias-analysis ( insns -- insns' )
|
||||||
H{ } clone histories set
|
H{ } clone histories set
|
||||||
|
|
|
@ -57,4 +57,4 @@ insn-classes get [
|
||||||
: ^^allot-byte-array ( n -- dst ) 2 cells + byte-array ^^allot ; inline
|
: ^^allot-byte-array ( n -- dst ) 2 cells + byte-array ^^allot ; inline
|
||||||
: ^^offset>slot ( vreg -- vreg' ) cell 4 = [ 1 ^^shr-imm ] [ any-rep ^^copy ] if ; inline
|
: ^^offset>slot ( vreg -- vreg' ) cell 4 = [ 1 ^^shr-imm ] [ any-rep ^^copy ] if ; inline
|
||||||
: ^^tag-fixnum ( src -- dst ) tag-bits get ^^shl-imm ; inline
|
: ^^tag-fixnum ( src -- dst ) tag-bits get ^^shl-imm ; inline
|
||||||
: ^^untag-fixnum ( src -- dst ) tag-bits get ^^sar-imm ; inline
|
: ^^untag-fixnum ( src -- dst ) tag-bits get ^^sar-imm ; inline
|
||||||
|
|
|
@ -450,6 +450,10 @@ INSN: ##alien-global
|
||||||
def: dst/int-rep
|
def: dst/int-rep
|
||||||
literal: symbol library ;
|
literal: symbol library ;
|
||||||
|
|
||||||
|
INSN: ##vm-field-ptr
|
||||||
|
def: dst/int-rep
|
||||||
|
literal: fieldname ;
|
||||||
|
|
||||||
! FFI
|
! FFI
|
||||||
INSN: ##alien-invoke
|
INSN: ##alien-invoke
|
||||||
literal: params stack-frame ;
|
literal: params stack-frame ;
|
||||||
|
|
|
@ -10,7 +10,7 @@ IN: compiler.cfg.intrinsics.misc
|
||||||
ds-pop tag-mask get ^^and-imm ^^tag-fixnum ds-push ;
|
ds-pop tag-mask get ^^and-imm ^^tag-fixnum ds-push ;
|
||||||
|
|
||||||
: emit-getenv ( node -- )
|
: emit-getenv ( node -- )
|
||||||
"userenv" f ^^alien-global
|
"userenv" ^^vm-field-ptr
|
||||||
swap node-input-infos first literal>>
|
swap node-input-infos first literal>>
|
||||||
[ ds-drop 0 ^^slot-imm ] [ ds-pop ^^offset>slot 0 ^^slot ] if*
|
[ ds-drop 0 ^^slot-imm ] [ ds-pop ^^offset>slot 0 ^^slot ] if*
|
||||||
ds-push ;
|
ds-push ;
|
||||||
|
|
|
@ -270,6 +270,9 @@ M: ##alien-global generate-insn
|
||||||
[ dst>> ] [ symbol>> ] [ library>> ] tri
|
[ dst>> ] [ symbol>> ] [ library>> ] tri
|
||||||
%alien-global ;
|
%alien-global ;
|
||||||
|
|
||||||
|
M: ##vm-field-ptr generate-insn
|
||||||
|
[ dst>> ] [ fieldname>> ] bi %vm-field-ptr ;
|
||||||
|
|
||||||
! ##alien-invoke
|
! ##alien-invoke
|
||||||
GENERIC: next-fastcall-param ( rep -- )
|
GENERIC: next-fastcall-param ( rep -- )
|
||||||
|
|
||||||
|
|
|
@ -202,6 +202,7 @@ HOOK: %set-alien-double cpu ( ptr value -- )
|
||||||
HOOK: %set-alien-vector cpu ( ptr value rep -- )
|
HOOK: %set-alien-vector cpu ( ptr value rep -- )
|
||||||
|
|
||||||
HOOK: %alien-global cpu ( dst symbol library -- )
|
HOOK: %alien-global cpu ( dst symbol library -- )
|
||||||
|
HOOK: %vm-field-ptr cpu ( dst fieldname -- )
|
||||||
|
|
||||||
HOOK: %allot cpu ( dst size class temp -- )
|
HOOK: %allot cpu ( dst size class temp -- )
|
||||||
HOOK: %write-barrier cpu ( src card# table -- )
|
HOOK: %write-barrier cpu ( src card# table -- )
|
||||||
|
|
|
@ -36,6 +36,7 @@ enable-float-intrinsics
|
||||||
[ drop %load-vm-addr ]
|
[ drop %load-vm-addr ]
|
||||||
[ [ dup ] dip vm-field-offset ADDI ] 2bi ;
|
[ [ dup ] dip vm-field-offset ADDI ] 2bi ;
|
||||||
|
|
||||||
|
M: ppc %vm-field-ptr ( dst field -- ) %load-vm-field-addr ;
|
||||||
|
|
||||||
M: ppc machine-registers
|
M: ppc machine-registers
|
||||||
{
|
{
|
||||||
|
|
|
@ -1,6 +1,5 @@
|
||||||
! Copyright (C) 2005, 2009 Slava Pestov.
|
! Copyright (C) 2005, 2009 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
<<<<<<< HEAD
|
|
||||||
USING: accessors assocs alien alien.c-types arrays strings
|
USING: accessors assocs alien alien.c-types arrays strings
|
||||||
cpu.x86.assembler cpu.x86.assembler.private cpu.x86.assembler.operands
|
cpu.x86.assembler cpu.x86.assembler.private cpu.x86.assembler.operands
|
||||||
cpu.architecture kernel kernel.private math memory namespaces make
|
cpu.architecture kernel kernel.private math memory namespaces make
|
||||||
|
@ -12,15 +11,7 @@ compiler.cfg.intrinsics
|
||||||
compiler.cfg.comparisons
|
compiler.cfg.comparisons
|
||||||
compiler.cfg.stack-frame
|
compiler.cfg.stack-frame
|
||||||
compiler.codegen
|
compiler.codegen
|
||||||
compiler.codegen.fixup ;
|
compiler.codegen.fixup vm ;
|
||||||
=======
|
|
||||||
USING: accessors alien combinators compiler.cfg.comparisons
|
|
||||||
compiler.cfg.intrinsics compiler.cfg.registers
|
|
||||||
compiler.cfg.stack-frame compiler.codegen.fixup compiler.constants
|
|
||||||
cpu.architecture cpu.x86.assembler cpu.x86.assembler.operands fry
|
|
||||||
kernel layouts locals make math math.order namespaces sequences system
|
|
||||||
vm ;
|
|
||||||
>>>>>>> Added a vm C-STRUCT, using it for struct offsets in x86 asm
|
|
||||||
IN: cpu.x86
|
IN: cpu.x86
|
||||||
|
|
||||||
<< enable-fixnum-log2 >>
|
<< enable-fixnum-log2 >>
|
||||||
|
@ -564,10 +555,13 @@ M: x86 %shl [ SHL ] emit-shift ;
|
||||||
M: x86 %shr [ SHR ] emit-shift ;
|
M: x86 %shr [ SHR ] emit-shift ;
|
||||||
M: x86 %sar [ SAR ] emit-shift ;
|
M: x86 %sar [ SAR ] emit-shift ;
|
||||||
|
|
||||||
|
M: x86 %vm-field-ptr ( dst field -- )
|
||||||
|
[ drop 0 MOV rc-absolute-cell rt-vm rel-fixup ]
|
||||||
|
[ vm-field-offset ADD ] 2bi ;
|
||||||
|
|
||||||
: load-zone-ptr ( reg -- )
|
: load-zone-ptr ( reg -- )
|
||||||
#! Load pointer to start of zone array
|
#! Load pointer to start of zone array
|
||||||
[ 0 MOV rc-absolute-cell rt-vm rel-fixup ]
|
"nursery" %vm-field-ptr ;
|
||||||
[ "nursery" vm-field-offset ADD ] bi ;
|
|
||||||
|
|
||||||
: load-allot-ptr ( nursery-ptr allot-ptr -- )
|
: load-allot-ptr ( nursery-ptr allot-ptr -- )
|
||||||
[ drop load-zone-ptr ] [ swap cell [+] MOV ] 2bi ;
|
[ drop load-zone-ptr ] [ swap cell [+] MOV ] 2bi ;
|
||||||
|
@ -587,9 +581,6 @@ M:: x86 %allot ( dst size class nursery-ptr -- )
|
||||||
dst class store-tagged
|
dst class store-tagged
|
||||||
nursery-ptr size inc-allot-ptr ;
|
nursery-ptr size inc-allot-ptr ;
|
||||||
|
|
||||||
: %vm-field-ptr ( reg field -- )
|
|
||||||
[ drop 0 MOV rc-absolute-cell rt-vm rel-fixup ]
|
|
||||||
[ vm-field-offset ADD ] 2bi ;
|
|
||||||
|
|
||||||
M:: x86 %write-barrier ( src card# table -- )
|
M:: x86 %write-barrier ( src card# table -- )
|
||||||
#! Mark the card pointed to by vreg.
|
#! Mark the card pointed to by vreg.
|
||||||
|
@ -627,7 +618,7 @@ M:: x86 %call-gc ( gc-root-count -- )
|
||||||
"inline_gc" f %vm-invoke ;
|
"inline_gc" f %vm-invoke ;
|
||||||
|
|
||||||
M: x86 %alien-global ( dst symbol library -- )
|
M: x86 %alien-global ( dst symbol library -- )
|
||||||
[ 0 MOV ] 2dip rc-absolute-cell rel-dlsym ;
|
[ 0 MOV ] 2dip rc-absolute-cell rel-dlsym ;
|
||||||
|
|
||||||
M: x86 %epilogue ( n -- ) cell - incr-stack-reg ;
|
M: x86 %epilogue ( n -- ) cell - incr-stack-reg ;
|
||||||
|
|
||||||
|
|
|
@ -17,6 +17,8 @@ C-STRUCT: vm
|
||||||
{ "zone" "nursery" }
|
{ "zone" "nursery" }
|
||||||
{ "cell" "cards_offset" }
|
{ "cell" "cards_offset" }
|
||||||
{ "cell" "decks_offset" }
|
{ "cell" "decks_offset" }
|
||||||
|
{ "cell" "__padding__" }
|
||||||
|
{ "cell[70]" "userenv" }
|
||||||
;
|
;
|
||||||
|
|
||||||
: vm-field-offset ( field -- offset ) "vm" offset-of ;
|
: vm-field-offset ( field -- offset ) "vm" offset-of ;
|
|
@ -14,7 +14,7 @@ NS_DURING
|
||||||
NS_VOIDRETURN;
|
NS_VOIDRETURN;
|
||||||
NS_HANDLER
|
NS_HANDLER
|
||||||
dpush(vm->allot_alien(F,(cell)localException));
|
dpush(vm->allot_alien(F,(cell)localException));
|
||||||
quot = userenv[COCOA_EXCEPTION_ENV];
|
quot = vm->userenv[COCOA_EXCEPTION_ENV];
|
||||||
if(!tagged<object>(quot).type_p(QUOTATION_TYPE))
|
if(!tagged<object>(quot).type_p(QUOTATION_TYPE))
|
||||||
{
|
{
|
||||||
/* No Cocoa exception handler was registered, so
|
/* No Cocoa exception handler was registered, so
|
||||||
|
|
|
@ -8,9 +8,13 @@ struct factorvm {
|
||||||
zone nursery; /* new objects are allocated here */
|
zone nursery; /* new objects are allocated here */
|
||||||
cell cards_offset;
|
cell cards_offset;
|
||||||
cell decks_offset;
|
cell decks_offset;
|
||||||
cell __padding__ ; // align to 8byte boundary (for 32bit platforms)
|
#ifndef FACTOR_64
|
||||||
|
cell __padding__ ; // align to 8 byte boundary
|
||||||
|
#endif
|
||||||
cell userenv[USER_ENV]; /* TAGGED user environment data; see getenv/setenv prims */
|
cell userenv[USER_ENV]; /* TAGGED user environment data; see getenv/setenv prims */
|
||||||
|
#ifndef FACTOR_64
|
||||||
|
cell __padding2__; // not sure why we need this, bootstrap doesn't work without it
|
||||||
|
#endif
|
||||||
|
|
||||||
// segments
|
// segments
|
||||||
inline cell align_page(cell a);
|
inline cell align_page(cell a);
|
||||||
|
|
Loading…
Reference in New Issue