diff --git a/core/cpu/architecture/architecture.factor b/core/cpu/architecture/architecture.factor index 8d1e1f281f..4670cf86d2 100755 --- a/core/cpu/architecture/architecture.factor +++ b/core/cpu/architecture/architecture.factor @@ -5,8 +5,6 @@ namespaces sequences layouts system hashtables classes alien byte-arrays bit-arrays float-arrays combinators words ; IN: cpu.architecture -SYMBOL: compiler-backend - ! A pseudo-register class for parameters spilled on the stack TUPLE: stack-params ; @@ -26,122 +24,122 @@ GENERIC: vregs ( register-class -- regs ) ! Load a literal (immediate or indirect) GENERIC# load-literal 1 ( obj vreg -- ) -HOOK: load-indirect compiler-backend ( obj reg -- ) +HOOK: load-indirect cpu ( obj reg -- ) -HOOK: stack-frame compiler-backend ( frame-size -- n ) +HOOK: stack-frame cpu ( frame-size -- n ) : stack-frame* ( -- n ) \ stack-frame get stack-frame ; ! Set up caller stack frame -HOOK: %prologue compiler-backend ( n -- ) +HOOK: %prologue cpu ( n -- ) : %prologue-later \ %prologue-later , ; ! Tear down stack frame -HOOK: %epilogue compiler-backend ( n -- ) +HOOK: %epilogue cpu ( n -- ) : %epilogue-later \ %epilogue-later , ; ! Store word XT in stack frame -HOOK: %save-word-xt compiler-backend ( -- ) +HOOK: %save-word-xt cpu ( -- ) ! Store dispatch branch XT in stack frame -HOOK: %save-dispatch-xt compiler-backend ( -- ) +HOOK: %save-dispatch-xt cpu ( -- ) M: object %save-dispatch-xt %save-word-xt ; ! Call another word -HOOK: %call compiler-backend ( word -- ) +HOOK: %call cpu ( word -- ) ! Local jump for branches -HOOK: %jump-label compiler-backend ( label -- ) +HOOK: %jump-label cpu ( label -- ) ! Test if vreg is 'f' or not -HOOK: %jump-t compiler-backend ( label -- ) +HOOK: %jump-t cpu ( label -- ) -HOOK: %dispatch compiler-backend ( -- ) +HOOK: %dispatch cpu ( -- ) -HOOK: %dispatch-label compiler-backend ( word -- ) +HOOK: %dispatch-label cpu ( word -- ) ! Return to caller -HOOK: %return compiler-backend ( -- ) +HOOK: %return cpu ( -- ) ! Change datastack height -HOOK: %inc-d compiler-backend ( n -- ) +HOOK: %inc-d cpu ( n -- ) ! Change callstack height -HOOK: %inc-r compiler-backend ( n -- ) +HOOK: %inc-r cpu ( n -- ) ! Load stack into vreg -HOOK: %peek compiler-backend ( vreg loc -- ) +HOOK: %peek cpu ( vreg loc -- ) ! Store vreg to stack -HOOK: %replace compiler-backend ( vreg loc -- ) +HOOK: %replace cpu ( vreg loc -- ) ! Box and unbox floats -HOOK: %unbox-float compiler-backend ( dst src -- ) -HOOK: %box-float compiler-backend ( dst src -- ) +HOOK: %unbox-float cpu ( dst src -- ) +HOOK: %box-float cpu ( dst src -- ) ! FFI stuff ! Is this integer small enough to appear in value template ! slots? -HOOK: small-enough? compiler-backend ( n -- ? ) +HOOK: small-enough? cpu ( n -- ? ) ! Is this structure small enough to be returned in registers? -HOOK: struct-small-enough? compiler-backend ( size -- ? ) +HOOK: struct-small-enough? cpu ( size -- ? ) ! Do we pass explode value structs? -HOOK: value-structs? compiler-backend ( -- ? ) +HOOK: value-structs? cpu ( -- ? ) ! If t, fp parameters are shadowed by dummy int parameters -HOOK: fp-shadows-int? compiler-backend ( -- ? ) +HOOK: fp-shadows-int? cpu ( -- ? ) -HOOK: %prepare-unbox compiler-backend ( -- ) +HOOK: %prepare-unbox cpu ( -- ) -HOOK: %unbox compiler-backend ( n reg-class func -- ) +HOOK: %unbox cpu ( n reg-class func -- ) -HOOK: %unbox-long-long compiler-backend ( n func -- ) +HOOK: %unbox-long-long cpu ( n func -- ) -HOOK: %unbox-small-struct compiler-backend ( size -- ) +HOOK: %unbox-small-struct cpu ( size -- ) -HOOK: %unbox-large-struct compiler-backend ( n size -- ) +HOOK: %unbox-large-struct cpu ( n size -- ) -HOOK: %box compiler-backend ( n reg-class func -- ) +HOOK: %box cpu ( n reg-class func -- ) -HOOK: %box-long-long compiler-backend ( n func -- ) +HOOK: %box-long-long cpu ( n func -- ) -HOOK: %prepare-box-struct compiler-backend ( size -- ) +HOOK: %prepare-box-struct cpu ( size -- ) -HOOK: %box-small-struct compiler-backend ( size -- ) +HOOK: %box-small-struct cpu ( size -- ) -HOOK: %box-large-struct compiler-backend ( n size -- ) +HOOK: %box-large-struct cpu ( n size -- ) GENERIC: %save-param-reg ( stack reg reg-class -- ) GENERIC: %load-param-reg ( stack reg reg-class -- ) -HOOK: %prepare-alien-invoke compiler-backend ( -- ) +HOOK: %prepare-alien-invoke cpu ( -- ) -HOOK: %prepare-var-args compiler-backend ( -- ) +HOOK: %prepare-var-args cpu ( -- ) M: object %prepare-var-args ; -HOOK: %alien-invoke compiler-backend ( function library -- ) +HOOK: %alien-invoke cpu ( function library -- ) -HOOK: %cleanup compiler-backend ( alien-node -- ) +HOOK: %cleanup cpu ( alien-node -- ) -HOOK: %alien-callback compiler-backend ( quot -- ) +HOOK: %alien-callback cpu ( quot -- ) -HOOK: %callback-value compiler-backend ( ctype -- ) +HOOK: %callback-value cpu ( ctype -- ) ! Return to caller with stdcall unwinding (only for x86) -HOOK: %unwind compiler-backend ( n -- ) +HOOK: %unwind cpu ( n -- ) -HOOK: %prepare-alien-indirect compiler-backend ( -- ) +HOOK: %prepare-alien-indirect cpu ( -- ) -HOOK: %alien-indirect compiler-backend ( -- ) +HOOK: %alien-indirect cpu ( -- ) M: stack-params param-reg drop ; @@ -179,15 +177,15 @@ PREDICATE: inline-array < integer 32 < ; ] if-small-struct ; ! Alien accessors -HOOK: %unbox-byte-array compiler-backend ( dst src -- ) +HOOK: %unbox-byte-array cpu ( dst src -- ) -HOOK: %unbox-alien compiler-backend ( dst src -- ) +HOOK: %unbox-alien cpu ( dst src -- ) -HOOK: %unbox-f compiler-backend ( dst src -- ) +HOOK: %unbox-f cpu ( dst src -- ) -HOOK: %unbox-any-c-ptr compiler-backend ( dst src -- ) +HOOK: %unbox-any-c-ptr cpu ( dst src -- ) -HOOK: %box-alien compiler-backend ( dst src -- ) +HOOK: %box-alien cpu ( dst src -- ) : operand ( var -- op ) get v>operand ; inline diff --git a/core/cpu/ppc/allot/allot.factor b/core/cpu/ppc/allot/allot.factor index 6c37fce4f1..34ea82dc4e 100755 --- a/core/cpu/ppc/allot/allot.factor +++ b/core/cpu/ppc/allot/allot.factor @@ -32,7 +32,7 @@ IN: cpu.ppc.allot 12 11 float tag-number ORI f fresh-object ; -M: ppc-backend %box-float ( dst src -- ) +M: ppc %box-float ( dst src -- ) [ v>operand ] bi@ %allot-float 12 MR ; : %allot-bignum ( #digits -- ) @@ -78,7 +78,7 @@ M: ppc-backend %box-float ( dst src -- ) "end" resolve-label ] with-scope ; -M: ppc-backend %box-alien ( dst src -- ) +M: ppc %box-alien ( dst src -- ) { "end" "f" } [ define-label ] each 0 over v>operand 0 CMPI "f" get BEQ diff --git a/core/cpu/ppc/architecture/architecture.factor b/core/cpu/ppc/architecture/architecture.factor index 903ac32df9..8055e4ff6e 100755 --- a/core/cpu/ppc/architecture/architecture.factor +++ b/core/cpu/ppc/architecture/architecture.factor @@ -7,8 +7,6 @@ layouts classes words.private alien combinators compiler.constants ; IN: cpu.ppc.architecture -TUPLE: ppc-backend ; - ! PowerPC register assignments ! r3-r10, r16-r31: integer vregs ! f0-f13: float vregs @@ -44,7 +42,7 @@ TUPLE: ppc-backend ; : xt-save ( n -- i ) 2 cells - ; -M: ppc-backend stack-frame ( n -- i ) +M: ppc stack-frame ( n -- i ) local@ factor-area-size + 4 cells align ; M: temp-reg v>operand drop 11 ; @@ -73,14 +71,14 @@ M: rs-loc loc>operand rs-loc-n cells neg rs-reg swap ; M: immediate load-literal [ v>operand ] bi@ LOAD ; -M: ppc-backend load-indirect ( obj reg -- ) +M: ppc load-indirect ( obj reg -- ) [ 0 swap LOAD32 rc-absolute-ppc-2/2 rel-literal ] keep dup 0 LWZ ; -M: ppc-backend %save-word-xt ( -- ) +M: ppc %save-word-xt ( -- ) 0 11 LOAD32 rc-absolute-ppc-2/2 rel-this ; -M: ppc-backend %prologue ( n -- ) +M: ppc %prologue ( n -- ) 0 MFLR 1 1 pick neg ADDI 11 1 pick xt-save STW @@ -88,7 +86,7 @@ M: ppc-backend %prologue ( n -- ) 11 1 pick next-save STW 0 1 rot lr-save + STW ; -M: ppc-backend %epilogue ( n -- ) +M: ppc %epilogue ( n -- ) #! At the end of each word that calls a subroutine, we store #! the previous link register value in r0 by popping it off #! the stack, set the link register to the contents of r0, @@ -104,14 +102,14 @@ M: ppc-backend %epilogue ( n -- ) : %load-dlsym ( symbol dll register -- ) 0 swap LOAD32 rc-absolute-ppc-2/2 rel-dlsym ; -M: ppc-backend %call ( label -- ) BL ; +M: ppc %call ( label -- ) BL ; -M: ppc-backend %jump-label ( label -- ) B ; +M: ppc %jump-label ( label -- ) B ; -M: ppc-backend %jump-t ( label -- ) +M: ppc %jump-t ( label -- ) 0 "flag" operand f v>operand CMPI BNE ; -M: ppc-backend %dispatch ( -- ) +M: ppc %dispatch ( -- ) [ %epilogue-later 0 11 LOAD32 rc-absolute-ppc-2/2 rel-here @@ -124,25 +122,25 @@ M: ppc-backend %dispatch ( -- ) { +scratch+ { { f "offset" } } } } with-template ; -M: ppc-backend %dispatch-label ( word -- ) +M: ppc %dispatch-label ( word -- ) 0 , rc-absolute-cell rel-word ; -M: ppc-backend %return ( -- ) %epilogue-later BLR ; +M: ppc %return ( -- ) %epilogue-later BLR ; -M: ppc-backend %unwind drop %return ; +M: ppc %unwind drop %return ; -M: ppc-backend %peek ( vreg loc -- ) +M: ppc %peek ( vreg loc -- ) >r v>operand r> loc>operand LWZ ; -M: ppc-backend %replace +M: ppc %replace >r v>operand r> loc>operand STW ; -M: ppc-backend %unbox-float ( dst src -- ) +M: ppc %unbox-float ( dst src -- ) [ v>operand ] bi@ float-offset LFD ; -M: ppc-backend %inc-d ( n -- ) ds-reg dup rot cells ADDI ; +M: ppc %inc-d ( n -- ) ds-reg dup rot cells ADDI ; -M: ppc-backend %inc-r ( n -- ) rs-reg dup rot cells ADDI ; +M: ppc %inc-r ( n -- ) rs-reg dup rot cells ADDI ; M: int-regs %save-param-reg drop 1 rot local@ STW ; @@ -166,19 +164,19 @@ M: stack-params %save-param-reg ( stack reg reg-class -- ) 0 1 rot param@ stack-frame* + LWZ 0 1 rot local@ STW ; -M: ppc-backend %prepare-unbox ( -- ) +M: ppc %prepare-unbox ( -- ) ! First parameter is top of stack 3 ds-reg 0 LWZ ds-reg dup cell SUBI ; -M: ppc-backend %unbox ( n reg-class func -- ) +M: ppc %unbox ( n reg-class func -- ) ! Value must be in r3 ! Call the unboxer f %alien-invoke ! Store the return value on the C stack over [ [ return-reg ] keep %save-param-reg ] [ 2drop ] if ; -M: ppc-backend %unbox-long-long ( n func -- ) +M: ppc %unbox-long-long ( n func -- ) ! Value must be in r3:r4 ! Call the unboxer f %alien-invoke @@ -188,7 +186,7 @@ M: ppc-backend %unbox-long-long ( n func -- ) 4 1 rot cell + local@ STW ] when* ; -M: ppc-backend %unbox-large-struct ( n size -- ) +M: ppc %unbox-large-struct ( n size -- ) ! Value must be in r3 ! Compute destination address 4 1 roll local@ ADDI @@ -197,7 +195,7 @@ M: ppc-backend %unbox-large-struct ( n size -- ) ! Call the function "to_value_struct" f %alien-invoke ; -M: ppc-backend %box ( n reg-class func -- ) +M: ppc %box ( n reg-class func -- ) ! If the source is a stack location, load it into freg #0. ! If the source is f, then we assume the value is already in ! freg #0. @@ -205,7 +203,7 @@ M: ppc-backend %box ( n reg-class func -- ) over [ 0 over param-reg swap %load-param-reg ] [ 2drop ] if r> f %alien-invoke ; -M: ppc-backend %box-long-long ( n func -- ) +M: ppc %box-long-long ( n func -- ) >r [ 3 1 pick local@ LWZ 4 1 rot cell + local@ LWZ @@ -215,12 +213,12 @@ M: ppc-backend %box-long-long ( n func -- ) : struct-return@ ( size n -- n ) [ local@ ] [ temp@ ] ?if ; -M: ppc-backend %prepare-box-struct ( size -- ) +M: ppc %prepare-box-struct ( size -- ) #! Compute target address for value struct return 3 1 rot f struct-return@ ADDI 3 1 0 local@ STW ; -M: ppc-backend %box-large-struct ( n size -- ) +M: ppc %box-large-struct ( n size -- ) #! If n = f, then we're boxing a returned struct [ swap struct-return@ ] keep ! Compute destination address @@ -230,7 +228,7 @@ M: ppc-backend %box-large-struct ( n size -- ) ! Call the function "box_value_struct" f %alien-invoke ; -M: ppc-backend %prepare-alien-invoke +M: ppc %prepare-alien-invoke #! Save Factor stack pointers in case the C code calls a #! callback which does a GC, which must reliably trace #! all roots. @@ -240,20 +238,20 @@ M: ppc-backend %prepare-alien-invoke ds-reg 11 8 STW rs-reg 11 12 STW ; -M: ppc-backend %alien-invoke ( symbol dll -- ) +M: ppc %alien-invoke ( symbol dll -- ) 11 %load-dlsym (%call) ; -M: ppc-backend %alien-callback ( quot -- ) +M: ppc %alien-callback ( quot -- ) 3 load-indirect "c_to_factor" f %alien-invoke ; -M: ppc-backend %prepare-alien-indirect ( -- ) +M: ppc %prepare-alien-indirect ( -- ) "unbox_alien" f %alien-invoke 3 1 cell temp@ STW ; -M: ppc-backend %alien-indirect ( -- ) +M: ppc %alien-indirect ( -- ) 11 1 cell temp@ LWZ (%call) ; -M: ppc-backend %callback-value ( ctype -- ) +M: ppc %callback-value ( ctype -- ) ! Save top of data stack 3 ds-reg 0 LWZ 3 1 0 local@ STW @@ -264,7 +262,7 @@ M: ppc-backend %callback-value ( ctype -- ) ! Unbox former top of data stack to return registers unbox-return ; -M: ppc-backend %cleanup ( alien-node -- ) drop ; +M: ppc %cleanup ( alien-node -- ) drop ; : %untag ( src dest -- ) 0 0 31 tag-bits get - RLWINM ; @@ -272,34 +270,34 @@ M: ppc-backend %cleanup ( alien-node -- ) drop ; : %untag-fixnum ( dest src -- ) tag-bits get SRAWI ; -M: ppc-backend value-structs? +M: ppc value-structs? #! On Linux/PPC, value structs are passed in the same way #! as reference structs, we just have to make a copy first. linux? not ; -M: ppc-backend fp-shadows-int? ( -- ? ) macosx? ; +M: ppc fp-shadows-int? ( -- ? ) macosx? ; -M: ppc-backend small-enough? ( n -- ? ) -32768 32767 between? ; +M: ppc small-enough? ( n -- ? ) -32768 32767 between? ; -M: ppc-backend struct-small-enough? ( size -- ? ) drop f ; +M: ppc struct-small-enough? ( size -- ? ) drop f ; -M: ppc-backend %box-small-struct +M: ppc %box-small-struct drop "No small structs" throw ; -M: ppc-backend %unbox-small-struct +M: ppc %unbox-small-struct drop "No small structs" throw ; ! Alien intrinsics -M: ppc-backend %unbox-byte-array ( dst src -- ) +M: ppc %unbox-byte-array ( dst src -- ) [ v>operand ] bi@ byte-array-offset ADDI ; -M: ppc-backend %unbox-alien ( dst src -- ) +M: ppc %unbox-alien ( dst src -- ) [ v>operand ] bi@ alien-offset LWZ ; -M: ppc-backend %unbox-f ( dst src -- ) +M: ppc %unbox-f ( dst src -- ) drop 0 swap v>operand LI ; -M: ppc-backend %unbox-any-c-ptr ( dst src -- ) +M: ppc %unbox-any-c-ptr ( dst src -- ) { "is-byte-array" "end" "start" } [ define-label ] each ! Address is computed in R12 0 12 LI diff --git a/core/cpu/ppc/ppc.factor b/core/cpu/ppc/ppc.factor index 75de49acda..da17da9185 100755 --- a/core/cpu/ppc/ppc.factor +++ b/core/cpu/ppc/ppc.factor @@ -12,8 +12,6 @@ namespaces alien.c-types kernel system combinators ; ] } } cond -T{ ppc-backend } compiler-backend set-global - macosx? [ 4 "double" c-type set-c-type-align ] when diff --git a/core/cpu/x86/32/32.factor b/core/cpu/x86/32/32.factor index f4af421cdd..3ebee73cbf 100755 --- a/core/cpu/x86/32/32.factor +++ b/core/cpu/x86/32/32.factor @@ -8,23 +8,20 @@ alien.compiler combinators command-line compiler compiler.units io vocabs.loader accessors ; IN: cpu.x86.32 -PREDICATE: x86-32-backend < x86-backend - x86-backend-cell 4 = ; - ! We implement the FFI for Linux, OS X and Windows all at once. ! OS X requires that the stack be 16-byte aligned, and we do ! this on all platforms, sacrificing some stack space for ! code simplicity. -M: x86-32-backend ds-reg ESI ; -M: x86-32-backend rs-reg EDI ; -M: x86-32-backend stack-reg ESP ; -M: x86-32-backend xt-reg ECX ; -M: x86-32-backend stack-save-reg EDX ; +M: x86.32 ds-reg ESI ; +M: x86.32 rs-reg EDI ; +M: x86.32 stack-reg ESP ; +M: x86.32 xt-reg ECX ; +M: x86.32 stack-save-reg EDX ; M: temp-reg v>operand drop EBX ; -M: x86-32-backend %alien-invoke ( symbol dll -- ) +M: x86.32 %alien-invoke ( symbol dll -- ) (CALL) rel-dlsym ; ! On x86, parameters are never passed in registers. @@ -61,20 +58,20 @@ M: float-regs store-return-reg load/store-float-return FSTP ; ! On x86, we can always use an address as an operand ! directly. -M: x86-32-backend address-operand ; +M: x86.32 address-operand ; -M: x86-32-backend fixnum>slot@ 1 SHR ; +M: x86.32 fixnum>slot@ 1 SHR ; -M: x86-32-backend prepare-division CDQ ; +M: x86.32 prepare-division CDQ ; -M: x86-32-backend load-indirect +M: x86.32 load-indirect 0 [] MOV rc-absolute-cell rel-literal ; M: object %load-param-reg 3drop ; M: object %save-param-reg 3drop ; -M: x86-32-backend %prepare-unbox ( -- ) +M: x86.32 %prepare-unbox ( -- ) #! Move top of data stack to EAX. EAX ESI [] MOV ESI 4 SUB ; @@ -87,7 +84,7 @@ M: x86-32-backend %prepare-unbox ( -- ) f %alien-invoke ] with-aligned-stack ; -M: x86-32-backend %unbox ( n reg-class func -- ) +M: x86.32 %unbox ( n reg-class func -- ) #! The value being unboxed must already be in EAX. #! If n is f, we're unboxing a return value about to be #! returned by the callback. Otherwise, we're unboxing @@ -96,7 +93,7 @@ M: x86-32-backend %unbox ( n reg-class func -- ) ! Store the return value on the C stack over [ store-return-reg ] [ 2drop ] if ; -M: x86-32-backend %unbox-long-long ( n func -- ) +M: x86.32 %unbox-long-long ( n func -- ) (%unbox) ! Store the return value on the C stack [ @@ -104,7 +101,7 @@ M: x86-32-backend %unbox-long-long ( n func -- ) cell + stack@ EDX MOV ] when* ; -M: x86-32-backend %unbox-struct-2 +M: x86.32 %unbox-struct-2 #! Alien must be in EAX. 4 [ EAX PUSH @@ -115,7 +112,7 @@ M: x86-32-backend %unbox-struct-2 EAX EAX [] MOV ] with-aligned-stack ; -M: x86-32-backend %unbox-large-struct ( n size -- ) +M: x86.32 %unbox-large-struct ( n size -- ) #! Alien must be in EAX. ! Compute destination address ECX ESP roll [+] LEA @@ -147,7 +144,7 @@ M: x86-32-backend %unbox-large-struct ( n size -- ) over [ [ box@ ] keep [ load-return-reg ] keep ] [ nip ] if push-return-reg ; -M: x86-32-backend %box ( n reg-class func -- ) +M: x86.32 %box ( n reg-class func -- ) over reg-size [ >r (%box) r> f %alien-invoke ] with-aligned-stack ; @@ -165,12 +162,12 @@ M: x86-32-backend %box ( n reg-class func -- ) EDX PUSH EAX PUSH ; -M: x86-32-backend %box-long-long ( n func -- ) +M: x86.32 %box-long-long ( n func -- ) 8 [ >r (%box-long-long) r> f %alien-invoke ] with-aligned-stack ; -M: x86-32-backend %box-large-struct ( n size -- ) +M: x86.32 %box-large-struct ( n size -- ) ! Compute destination address [ swap struct-return@ ] keep ECX ESP roll [+] LEA @@ -183,13 +180,13 @@ M: x86-32-backend %box-large-struct ( n size -- ) "box_value_struct" f %alien-invoke ] with-aligned-stack ; -M: x86-32-backend %prepare-box-struct ( size -- ) +M: x86.32 %prepare-box-struct ( size -- ) ! Compute target address for value struct return EAX ESP rot f struct-return@ [+] LEA ! Store it as the first parameter ESP [] EAX MOV ; -M: x86-32-backend %unbox-struct-1 +M: x86.32 %unbox-struct-1 #! Alien must be in EAX. 4 [ EAX PUSH @@ -198,7 +195,7 @@ M: x86-32-backend %unbox-struct-1 EAX EAX [] MOV ] with-aligned-stack ; -M: x86-32-backend %box-small-struct ( size -- ) +M: x86.32 %box-small-struct ( size -- ) #! Box a <= 8-byte struct returned in EAX:DX. OS X only. 12 [ PUSH @@ -207,21 +204,21 @@ M: x86-32-backend %box-small-struct ( size -- ) "box_small_struct" f %alien-invoke ] with-aligned-stack ; -M: x86-32-backend %prepare-alien-indirect ( -- ) +M: x86.32 %prepare-alien-indirect ( -- ) "unbox_alien" f %alien-invoke cell temp@ EAX MOV ; -M: x86-32-backend %alien-indirect ( -- ) +M: x86.32 %alien-indirect ( -- ) cell temp@ CALL ; -M: x86-32-backend %alien-callback ( quot -- ) +M: x86.32 %alien-callback ( quot -- ) 4 [ EAX load-indirect EAX PUSH "c_to_factor" f %alien-invoke ] with-aligned-stack ; -M: x86-32-backend %callback-value ( ctype -- ) +M: x86.32 %callback-value ( ctype -- ) ! Align C stack ESP 12 SUB ! Save top of data stack @@ -236,7 +233,7 @@ M: x86-32-backend %callback-value ( ctype -- ) ! Unbox EAX unbox-return ; -M: x86-32-backend %cleanup ( alien-node -- ) +M: x86.32 %cleanup ( alien-node -- ) #! a) If we just called an stdcall function in Windows, it #! cleaned up the stack frame for us. But we don't want that #! so we 'undo' the cleanup since we do that in %epilogue. @@ -254,7 +251,7 @@ M: x86-32-backend %cleanup ( alien-node -- ) } } cond ; -M: x86-32-backend %unwind ( n -- ) %epilogue-later RET ; +M: x86.32 %unwind ( n -- ) %epilogue-later RET ; windows? [ cell "longlong" c-type set-c-type-align @@ -265,8 +262,6 @@ windows? [ 4 "double" c-type set-c-type-align ] unless -T{ x86-backend f 4 } compiler-backend set-global - : sse2? "Intrinsic" throw ; \ sse2? [ diff --git a/core/cpu/x86/64/64.factor b/core/cpu/x86/64/64.factor index c2af60e983..d3ccffe00e 100755 --- a/core/cpu/x86/64/64.factor +++ b/core/cpu/x86/64/64.factor @@ -8,14 +8,11 @@ layouts alien alien.accessors alien.compiler alien.structs slots splitting assocs ; IN: cpu.x86.64 -PREDICATE: amd64-backend < x86-backend - x86-backend-cell 8 = ; - -M: amd64-backend ds-reg R14 ; -M: amd64-backend rs-reg R15 ; -M: amd64-backend stack-reg RSP ; -M: amd64-backend xt-reg RCX ; -M: amd64-backend stack-save-reg RSI ; +M: x86.64 ds-reg R14 ; +M: x86.64 rs-reg R15 ; +M: x86.64 stack-reg RSP ; +M: x86.64 xt-reg RCX ; +M: x86.64 stack-save-reg RSI ; M: temp-reg v>operand drop RBX ; @@ -34,18 +31,18 @@ M: float-regs vregs M: float-regs param-regs drop { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } ; -M: amd64-backend address-operand ( address -- operand ) +M: x86.64 address-operand ( address -- operand ) #! On AMD64, we have to load 64-bit addresses into a #! scratch register first. The usage of R11 here is a hack. #! This word can only be called right before a subroutine #! call, where all vregs have been flushed anyway. temp-reg v>operand [ swap MOV ] keep ; -M: amd64-backend fixnum>slot@ drop ; +M: x86.64 fixnum>slot@ drop ; -M: amd64-backend prepare-division CQO ; +M: x86.64 prepare-division CQO ; -M: amd64-backend load-indirect ( literal reg -- ) +M: x86.64 load-indirect ( literal reg -- ) 0 [] MOV rc-relative rel-literal ; M: stack-params %load-param-reg @@ -56,27 +53,27 @@ M: stack-params %load-param-reg M: stack-params %save-param-reg >r stack-frame* + cell + swap r> %load-param-reg ; -M: amd64-backend %prepare-unbox ( -- ) +M: x86.64 %prepare-unbox ( -- ) ! First parameter is top of stack RDI R14 [] MOV R14 cell SUB ; -M: amd64-backend %unbox ( n reg-class func -- ) +M: x86.64 %unbox ( n reg-class func -- ) ! Call the unboxer f %alien-invoke ! Store the return value on the C stack over [ [ return-reg ] keep %save-param-reg ] [ 2drop ] if ; -M: amd64-backend %unbox-long-long ( n func -- ) +M: x86.64 %unbox-long-long ( n func -- ) T{ int-regs } swap %unbox ; -M: amd64-backend %unbox-struct-1 ( -- ) +M: x86.64 %unbox-struct-1 ( -- ) #! Alien must be in RDI. "alien_offset" f %alien-invoke ! Load first cell RAX RAX [] MOV ; -M: amd64-backend %unbox-struct-2 ( -- ) +M: x86.64 %unbox-struct-2 ( -- ) #! Alien must be in RDI. "alien_offset" f %alien-invoke ! Load second cell @@ -84,7 +81,7 @@ M: amd64-backend %unbox-struct-2 ( -- ) ! Load first cell RAX RAX [] MOV ; -M: amd64-backend %unbox-large-struct ( n size -- ) +M: x86.64 %unbox-large-struct ( n size -- ) ! Source is in RDI ! Load destination address RSI RSP roll [+] LEA @@ -97,7 +94,7 @@ M: amd64-backend %unbox-large-struct ( n size -- ) 0 over param-reg swap return-reg 2dup eq? [ 2drop ] [ MOV ] if ; -M: amd64-backend %box ( n reg-class func -- ) +M: x86.64 %box ( n reg-class func -- ) rot [ rot [ 0 swap param-reg ] keep %load-param-reg ] [ @@ -105,19 +102,19 @@ M: amd64-backend %box ( n reg-class func -- ) ] if* f %alien-invoke ; -M: amd64-backend %box-long-long ( n func -- ) +M: x86.64 %box-long-long ( n func -- ) T{ int-regs } swap %box ; -M: amd64-backend struct-small-enough? ( size -- ? ) 2 cells <= ; +M: x86.64 struct-small-enough? ( size -- ? ) 2 cells <= ; -M: amd64-backend %box-small-struct ( size -- ) +M: x86.64 %box-small-struct ( size -- ) #! Box a <= 16-byte struct returned in RAX:RDX. RDI RAX MOV RSI RDX MOV RDX swap MOV "box_small_struct" f %alien-invoke ; -M: amd64-backend %box-large-struct ( n size -- ) +M: x86.64 %box-large-struct ( n size -- ) ! Struct size is parameter 2 RSI over MOV ! Compute destination address @@ -125,27 +122,27 @@ M: amd64-backend %box-large-struct ( n size -- ) ! Copy the struct from the C stack "box_value_struct" f %alien-invoke ; -M: amd64-backend %prepare-box-struct ( size -- ) +M: x86.64 %prepare-box-struct ( size -- ) ! Compute target address for value struct return RAX RSP rot f struct-return@ [+] LEA RSP 0 [+] RAX MOV ; -M: amd64-backend %prepare-var-args RAX RAX XOR ; +M: x86.64 %prepare-var-args RAX RAX XOR ; -M: amd64-backend %alien-invoke ( symbol dll -- ) +M: x86.64 %alien-invoke ( symbol dll -- ) 0 address-operand >r rc-absolute-cell rel-dlsym r> CALL ; -M: amd64-backend %prepare-alien-indirect ( -- ) +M: x86.64 %prepare-alien-indirect ( -- ) "unbox_alien" f %alien-invoke cell temp@ RAX MOV ; -M: amd64-backend %alien-indirect ( -- ) +M: x86.64 %alien-indirect ( -- ) cell temp@ CALL ; -M: amd64-backend %alien-callback ( quot -- ) +M: x86.64 %alien-callback ( quot -- ) RDI load-indirect "c_to_factor" f %alien-invoke ; -M: amd64-backend %callback-value ( ctype -- ) +M: x86.64 %callback-value ( ctype -- ) ! Save top of data stack %prepare-unbox ! Put former top of data stack in RDI @@ -157,9 +154,9 @@ M: amd64-backend %callback-value ( ctype -- ) ! Unbox former top of data stack to return registers unbox-return ; -M: amd64-backend %cleanup ( alien-node -- ) drop ; +M: x86.64 %cleanup ( alien-node -- ) drop ; -M: amd64-backend %unwind ( n -- ) drop %epilogue-later 0 RET ; +M: x86.64 %unwind ( n -- ) drop %epilogue-later 0 RET ; USE: cpu.x86.intrinsics @@ -171,8 +168,6 @@ USE: cpu.x86.intrinsics \ alien-signed-4 small-reg-32 define-signed-getter \ set-alien-signed-4 small-reg-32 define-setter -T{ x86-backend f 8 } compiler-backend set-global - ! The ABI for passing structs by value is pretty messed up << "void*" c-type clone "__stack_value" define-primitive-type T{ stack-params } "__stack_value" c-type set-c-type-reg-class >> diff --git a/core/cpu/x86/allot/allot.factor b/core/cpu/x86/allot/allot.factor index 5519a9a8d5..f236cdcfa6 100755 --- a/core/cpu/x86/allot/allot.factor +++ b/core/cpu/x86/allot/allot.factor @@ -46,7 +46,7 @@ IN: cpu.x86.allot allot-reg swap tag-number OR allot-reg MOV ; -M: x86-backend %box-float ( dst src -- ) +M: x86 %box-float ( dst src -- ) #! Only called by pentium4 backend, uses SSE2 instruction #! dest is a loc or a vreg float 16 [ @@ -86,7 +86,7 @@ M: x86-backend %box-float ( dst src -- ) "end" resolve-label ] with-scope ; -M: x86-backend %box-alien ( dst src -- ) +M: x86 %box-alien ( dst src -- ) [ { "end" "f" } [ define-label ] each dup v>operand 0 CMP diff --git a/core/cpu/x86/architecture/architecture.factor b/core/cpu/x86/architecture/architecture.factor index 31fa4c8e4b..76c4f1691a 100755 --- a/core/cpu/x86/architecture/architecture.factor +++ b/core/cpu/x86/architecture/architecture.factor @@ -6,13 +6,11 @@ memory namespaces sequences words generator generator.registers generator.fixup system layouts combinators compiler.constants ; IN: cpu.x86.architecture -TUPLE: x86-backend cell ; - -HOOK: ds-reg compiler-backend -HOOK: rs-reg compiler-backend -HOOK: stack-reg compiler-backend -HOOK: xt-reg compiler-backend -HOOK: stack-save-reg compiler-backend +HOOK: ds-reg cpu +HOOK: rs-reg cpu +HOOK: stack-reg cpu +HOOK: xt-reg cpu +HOOK: stack-save-reg cpu : stack@ stack-reg swap [+] ; @@ -33,34 +31,34 @@ GENERIC: push-return-reg ( reg-class -- ) GENERIC: load-return-reg ( stack@ reg-class -- ) GENERIC: store-return-reg ( stack@ reg-class -- ) -HOOK: address-operand compiler-backend ( address -- operand ) +HOOK: address-operand cpu ( address -- operand ) -HOOK: fixnum>slot@ compiler-backend +HOOK: fixnum>slot@ cpu -HOOK: prepare-division compiler-backend +HOOK: prepare-division cpu M: immediate load-literal v>operand swap v>operand MOV ; -M: x86-backend stack-frame ( n -- i ) +M: x86 stack-frame ( n -- i ) 3 cells + 16 align cell - ; -M: x86-backend %save-word-xt ( -- ) +M: x86 %save-word-xt ( -- ) xt-reg 0 MOV rc-absolute-cell rel-this ; : factor-area-size 4 cells ; -M: x86-backend %prologue ( n -- ) +M: x86 %prologue ( n -- ) dup cell + PUSH xt-reg PUSH stack-reg swap 2 cells - SUB ; -M: x86-backend %epilogue ( n -- ) +M: x86 %epilogue ( n -- ) stack-reg swap ADD ; : %alien-global ( symbol dll register -- ) [ 0 MOV rc-absolute-cell rel-dlsym ] keep dup [] MOV ; -M: x86-backend %prepare-alien-invoke +M: x86 %prepare-alien-invoke #! Save Factor stack pointers in case the C code calls a #! callback which does a GC, which must reliably trace #! all roots. @@ -70,11 +68,11 @@ M: x86-backend %prepare-alien-invoke temp-reg v>operand 2 cells [+] ds-reg MOV temp-reg v>operand 3 cells [+] rs-reg MOV ; -M: x86-backend %call ( label -- ) CALL ; +M: x86 %call ( label -- ) CALL ; -M: x86-backend %jump-label ( label -- ) JMP ; +M: x86 %jump-label ( label -- ) JMP ; -M: x86-backend %jump-t ( label -- ) +M: x86 %jump-t ( label -- ) "flag" operand f v>operand CMP JNE ; : code-alignment ( -- n ) @@ -83,7 +81,7 @@ M: x86-backend %jump-t ( label -- ) : align-code ( n -- ) 0 % ; -M: x86-backend %dispatch ( -- ) +M: x86 %dispatch ( -- ) [ %epilogue-later ! Load jump table base. We use a temporary register @@ -105,27 +103,27 @@ M: x86-backend %dispatch ( -- ) { +clobber+ { "n" } } } with-template ; -M: x86-backend %dispatch-label ( word -- ) +M: x86 %dispatch-label ( word -- ) 0 cell, rc-absolute-cell rel-word ; -M: x86-backend %unbox-float ( dst src -- ) +M: x86 %unbox-float ( dst src -- ) [ v>operand ] bi@ float-offset [+] MOVSD ; -M: x86-backend %peek [ v>operand ] bi@ MOV ; +M: x86 %peek [ v>operand ] bi@ MOV ; -M: x86-backend %replace swap %peek ; +M: x86 %replace swap %peek ; : (%inc) swap cells dup 0 > [ ADD ] [ neg SUB ] if ; -M: x86-backend %inc-d ( n -- ) ds-reg (%inc) ; +M: x86 %inc-d ( n -- ) ds-reg (%inc) ; -M: x86-backend %inc-r ( n -- ) rs-reg (%inc) ; +M: x86 %inc-r ( n -- ) rs-reg (%inc) ; -M: x86-backend fp-shadows-int? ( -- ? ) f ; +M: x86 fp-shadows-int? ( -- ? ) f ; -M: x86-backend value-structs? t ; +M: x86 value-structs? t ; -M: x86-backend small-enough? ( n -- ? ) +M: x86 small-enough? ( n -- ? ) HEX: -80000000 HEX: 7fffffff between? ; : %untag ( reg -- ) tag-mask get bitnot AND ; @@ -143,34 +141,34 @@ M: x86-backend small-enough? ( n -- ? ) \ stack-frame get swap - ] ?if ; -HOOK: %unbox-struct-1 compiler-backend ( -- ) +HOOK: %unbox-struct-1 cpu ( -- ) -HOOK: %unbox-struct-2 compiler-backend ( -- ) +HOOK: %unbox-struct-2 cpu ( -- ) -M: x86-backend %unbox-small-struct ( size -- ) +M: x86 %unbox-small-struct ( size -- ) #! Alien must be in EAX. cell align cell /i { { 1 [ %unbox-struct-1 ] } { 2 [ %unbox-struct-2 ] } } case ; -M: x86-backend struct-small-enough? ( size -- ? ) +M: x86 struct-small-enough? ( size -- ? ) { 1 2 4 8 } member? os { "linux" "netbsd" "solaris" } member? not and ; -M: x86-backend %return ( -- ) 0 %unwind ; +M: x86 %return ( -- ) 0 %unwind ; ! Alien intrinsics -M: x86-backend %unbox-byte-array ( dst src -- ) +M: x86 %unbox-byte-array ( dst src -- ) [ v>operand ] bi@ byte-array-offset [+] LEA ; -M: x86-backend %unbox-alien ( dst src -- ) +M: x86 %unbox-alien ( dst src -- ) [ v>operand ] bi@ alien-offset [+] MOV ; -M: x86-backend %unbox-f ( dst src -- ) +M: x86 %unbox-f ( dst src -- ) drop v>operand 0 MOV ; -M: x86-backend %unbox-any-c-ptr ( dst src -- ) +M: x86 %unbox-any-c-ptr ( dst src -- ) { "is-byte-array" "end" "start" } [ define-label ] each ! Address is computed in ds-reg ds-reg PUSH diff --git a/core/system/system.factor b/core/system/system.factor index 5a0faeece9..459af28537 100755 --- a/core/system/system.factor +++ b/core/system/system.factor @@ -13,14 +13,14 @@ SINGLETON: x86.64 SINGLETON: arm SINGLETON: ppc +UNION: x86 x86.32 x86.64 ; + : cpu ( -- class ) \ cpu get ; ! SINGLETON: winnt ! SINGLETON: wince -! MIXIN: windows -! INSTANCE: winnt windows -! INSTANCE: wince windows +! UNION: windows winnt wince ; ! SINGLETON: freebsd ! SINGLETON: netbsd @@ -29,11 +29,23 @@ SINGLETON: ppc ! SINGLETON: macosx ! SINGLETON: linux +cpu ( str -- class ) + H{ + { "x86.32" x86.32 } + { "x86.64" x86.64 } + { "arm" arm } + { "ppc" ppc } + } at ; + +PRIVATE> + ! : os ( -- class ) \ os get ; [ - 8 getenv "system" lookup \ cpu set-global - ! 9 getenv "system" lookup \ os set-global + 8 getenv string>cpu \ cpu set-global + ! 9 getenv string>os \ os set-global ] "system" add-init-hook : image ( -- path ) 13 getenv ;