PowerPC backend almost functional; some new compiler unit tests added,

better compilation of 'f eq?'; f becomes an immediate operand
move aux-offset to compiler.constants
db4
sheeple 2008-11-06 06:27:27 -06:00
parent c2117d4046
commit d2ec46e38f
8 changed files with 161 additions and 126 deletions
basis

View File

@ -15,7 +15,7 @@ IN: compiler.cfg.intrinsics.alien
: prepare-alien-accessor ( infos -- offset-vreg )
<reversed> [ second class>> ] [ first ] bi
dup value-info-small-tagged? [
dup value-info-small-fixnum? [
literal>> (prepare-alien-accessor-imm)
] [ drop (prepare-alien-accessor) ] if ;

View File

@ -9,7 +9,10 @@ IN: compiler.cfg.intrinsics.fixnum
: (emit-fixnum-imm-op) ( infos insn -- dst )
ds-drop
[ ds-pop ] [ second literal>> tag-fixnum ] [ ] tri*
[ ds-pop ]
[ second literal>> [ tag-fixnum ] [ \ f tag-number ] if* ]
[ ]
tri*
call ; inline
: (emit-fixnum-op) ( insn -- dst )
@ -25,7 +28,7 @@ IN: compiler.cfg.intrinsics.fixnum
] ; inline
: emit-fixnum-shift-fast ( node -- )
dup node-input-infos dup second value-info-small-tagged? [
dup node-input-infos dup second value-info-small-fixnum? [
nip
[ ds-drop ds-pop ] dip
second literal>> dup sgn {
@ -48,7 +51,7 @@ IN: compiler.cfg.intrinsics.fixnum
: emit-fixnum*fast ( node -- )
node-input-infos
dup second value-info-small-tagged?
dup second value-info-small-fixnum?
[ (emit-fixnum*fast-imm) ] [ drop (emit-fixnum*fast) ] if
ds-push ;

View File

@ -25,7 +25,7 @@ IN: compiler.cfg.intrinsics.slots
dup node-input-infos
dup first value-tag [
nip
dup second value-info-small-tagged?
dup second value-info-small-fixnum?
[ (emit-slot-imm) ] [ (emit-slot) ] if
ds-push
] [ drop emit-primitive ] if ;
@ -46,7 +46,7 @@ IN: compiler.cfg.intrinsics.slots
dup second value-tag [
nip
[
dup third value-info-small-tagged?
dup third value-info-small-fixnum?
[ (emit-set-slot-imm) ] [ (emit-set-slot) ] if
] [ first class>> immediate class<= ] bi
[ drop ] [ i i ##write-barrier ] if

View File

@ -1,12 +1,24 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel math layouts make sequences
USING: accessors kernel math layouts make sequences combinators
cpu.architecture namespaces compiler.cfg
compiler.cfg.instructions ;
IN: compiler.cfg.utilities
: value-info-small-fixnum? ( value-info -- ? )
literal>> {
{ [ dup fixnum? ] [ tag-fixnum small-enough? ] }
[ drop f ]
} cond ;
: value-info-small-tagged? ( value-info -- ? )
literal>> dup fixnum? [ tag-fixnum small-enough? ] [ drop f ] if ;
dup literal?>> [
literal>> {
{ [ dup fixnum? ] [ tag-fixnum small-enough? ] }
{ [ dup not ] [ drop t ] }
[ drop f ]
} cond
] [ drop f ] if ;
: set-basic-block ( basic-block -- )
[ basic-block set ] [ instructions>> building set ] bi ;

View File

@ -1,49 +1,50 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: math kernel layouts system ;
USING: math kernel layouts system strings ;
IN: compiler.constants
! These constants must match vm/memory.h
: card-bits 8 ;
: deck-bits 18 ;
: card-mark ( -- n ) HEX: 40 HEX: 80 bitor ;
: card-bits 8 ; inline
: deck-bits 18 ; inline
: card-mark ( -- n ) HEX: 40 HEX: 80 bitor ; inline
! These constants must match vm/layouts.h
: header-offset ( -- n ) object tag-number neg ;
: float-offset ( -- n ) 8 float tag-number - ;
: string-offset ( -- n ) 4 bootstrap-cells object tag-number - ;
: profile-count-offset ( -- n ) 7 bootstrap-cells object tag-number - ;
: byte-array-offset ( -- n ) 2 bootstrap-cells object tag-number - ;
: alien-offset ( -- n ) 3 bootstrap-cells object tag-number - ;
: underlying-alien-offset ( -- n ) bootstrap-cell object tag-number - ;
: tuple-class-offset ( -- n ) bootstrap-cell tuple tag-number - ;
: class-hash-offset ( -- n ) bootstrap-cell object tag-number - ;
: word-xt-offset ( -- n ) 9 bootstrap-cells object tag-number - ;
: quot-xt-offset ( -- n ) 3 bootstrap-cells object tag-number - ;
: word-code-offset ( -- n ) 10 bootstrap-cells object tag-number - ;
: array-start-offset ( -- n ) 2 bootstrap-cells object tag-number - ;
: compiled-header-size ( -- n ) 4 bootstrap-cells ;
: header-offset ( -- n ) object tag-number neg ; inline
: float-offset ( -- n ) 8 float tag-number - ; inline
: string-offset ( -- n ) 4 bootstrap-cells object tag-number - ; inline
: string-aux-offset ( -- n ) 2 bootstrap-cells string tag-number - ; inline
: profile-count-offset ( -- n ) 7 bootstrap-cells object tag-number - ; inline
: byte-array-offset ( -- n ) 2 bootstrap-cells object tag-number - ; inline
: alien-offset ( -- n ) 3 bootstrap-cells object tag-number - ; inline
: underlying-alien-offset ( -- n ) bootstrap-cell object tag-number - ; inline
: tuple-class-offset ( -- n ) bootstrap-cell tuple tag-number - ; inline
: class-hash-offset ( -- n ) bootstrap-cell object tag-number - ; inline
: word-xt-offset ( -- n ) 9 bootstrap-cells object tag-number - ; inline
: quot-xt-offset ( -- n ) 3 bootstrap-cells object tag-number - ; inline
: word-code-offset ( -- n ) 10 bootstrap-cells object tag-number - ; inline
: array-start-offset ( -- n ) 2 bootstrap-cells object tag-number - ; inline
: compiled-header-size ( -- n ) 4 bootstrap-cells ; inline
! Relocation classes
: rc-absolute-cell 0 ;
: rc-absolute 1 ;
: rc-relative 2 ;
: rc-absolute-ppc-2/2 3 ;
: rc-relative-ppc-2 4 ;
: rc-relative-ppc-3 5 ;
: rc-relative-arm-3 6 ;
: rc-indirect-arm 7 ;
: rc-indirect-arm-pc 8 ;
: rc-absolute-cell 0 ; inline
: rc-absolute 1 ; inline
: rc-relative 2 ; inline
: rc-absolute-ppc-2/2 3 ; inline
: rc-relative-ppc-2 4 ; inline
: rc-relative-ppc-3 5 ; inline
: rc-relative-arm-3 6 ; inline
: rc-indirect-arm 7 ; inline
: rc-indirect-arm-pc 8 ; inline
! Relocation types
: rt-primitive 0 ;
: rt-dlsym 1 ;
: rt-literal 2 ;
: rt-dispatch 3 ;
: rt-xt 4 ;
: rt-here 5 ;
: rt-label 6 ;
: rt-immediate 7 ;
: rt-primitive 0 ; inline
: rt-dlsym 1 ; inline
: rt-literal 2 ; inline
: rt-dispatch 3 ; inline
: rt-xt 4 ; inline
: rt-here 5 ; inline
: rt-label 6 ; inline
: rt-immediate 7 ; inline
: rc-absolute? ( n -- ? )
[ rc-absolute-ppc-2/2 = ]

View File

@ -4,7 +4,8 @@ continuations sequences.private hashtables.private byte-arrays
strings.private system random layouts vectors
sbufs strings.private slots.private alien math.order
alien.accessors alien.c-types alien.syntax alien.strings
namespaces libc sequences.private io.encodings.ascii ;
namespaces libc sequences.private io.encodings.ascii
classes ;
IN: compiler.tests
! Make sure that intrinsic ops compile to correct code.
@ -27,6 +28,9 @@ IN: compiler.tests
[ 1 ] [ { 1 2 } [ 2 slot ] compile-call ] unit-test
[ 1 ] [ [ { 1 2 } 2 slot ] compile-call ] unit-test
[ { f f } ] [ 2 f <array> ] unit-test
[ 3 ] [ 3 1 2 2array [ { array } declare [ 2 set-slot ] keep ] compile-call first ] unit-test
[ 3 ] [ 3 1 2 [ 2array [ 2 set-slot ] keep ] compile-call first ] unit-test
[ 3 ] [ [ 3 1 2 2array [ 2 set-slot ] keep ] compile-call first ] unit-test
@ -37,13 +41,19 @@ IN: compiler.tests
! Write barrier hits on the wrong value were causing segfaults
[ -3 ] [ -3 1 2 [ 2array [ 3 set-slot ] keep ] compile-call second ] unit-test
! [ CHAR: b ] [ 1 "abc" [ char-slot ] compile-call ] unit-test
! [ CHAR: b ] [ 1 [ "abc" char-slot ] compile-call ] unit-test
! [ CHAR: b ] [ [ 1 "abc" char-slot ] compile-call ] unit-test
!
! [ "axc" ] [ CHAR: x 1 "abc" [ [ set-char-slot ] keep { string } declare dup rehash-string ] compile-call ] unit-test
! [ "axc" ] [ CHAR: x 1 [ "abc" [ set-char-slot ] keep { string } declare dup rehash-string ] compile-call ] unit-test
! [ "axc" ] [ CHAR: x [ 1 "abc" [ set-char-slot ] keep { string } declare dup rehash-string ] compile-call ] unit-test
[ CHAR: a ] [ 0 "abc" [ string-nth ] compile-call ] unit-test
[ CHAR: a ] [ 0 [ "abc" string-nth ] compile-call ] unit-test
[ CHAR: a ] [ [ 0 "abc" string-nth ] compile-call ] unit-test
[ CHAR: b ] [ 1 "abc" [ string-nth ] compile-call ] unit-test
[ CHAR: b ] [ 1 [ "abc" string-nth ] compile-call ] unit-test
[ CHAR: b ] [ [ 1 "abc" string-nth ] compile-call ] unit-test
[ HEX: 123456 ] [ 0 "\u123456bc" [ string-nth ] compile-call ] unit-test
[ HEX: 123456 ] [ 0 [ "\u123456bc" string-nth ] compile-call ] unit-test
[ HEX: 123456 ] [ [ 0 "\u123456bc" string-nth ] compile-call ] unit-test
[ HEX: 123456 ] [ 1 "a\u123456c" [ string-nth ] compile-call ] unit-test
[ HEX: 123456 ] [ 1 [ "a\u123456c" string-nth ] compile-call ] unit-test
[ HEX: 123456 ] [ [ 1 "a\u123456c" string-nth ] compile-call ] unit-test
[ ] [ [ 0 getenv ] compile-call drop ] unit-test
[ ] [ 1 getenv [ 1 setenv ] compile-call ] unit-test
@ -158,6 +168,10 @@ IN: compiler.tests
[ 4 ] [ 1 [ 3 fixnum+fast ] compile-call ] unit-test
[ 4 ] [ [ 1 3 fixnum+fast ] compile-call ] unit-test
[ -2 ] [ 1 3 [ fixnum-fast ] compile-call ] unit-test
[ -2 ] [ 1 [ 3 fixnum-fast ] compile-call ] unit-test
[ -2 ] [ [ 1 3 fixnum-fast ] compile-call ] unit-test
[ 30001 ] [ 1 [ 30000 fixnum+fast ] compile-call ] unit-test
[ 6 ] [ 2 3 [ fixnum*fast ] compile-call ] unit-test
@ -263,6 +277,8 @@ cell 8 = [
: compiled-fixnum>bignum fixnum>bignum ;
[ bignum ] [ 0 compiled-fixnum>bignum class ] unit-test
[ ] [
10000 [
32 random-bits >fixnum

View File

@ -1,21 +1,10 @@
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types
accessors
cpu.architecture
compiler.cfg.registers
cpu.ppc.assembler
kernel
locals
layouts
combinators
make
compiler.cfg.instructions
math.order
system
math
compiler.constants
namespaces compiler.codegen.fixup ;
USING: accessors assocs sequences kernel combinators make math
math.order math.ranges system namespaces locals layouts words
alien alien.c-types cpu.architecture cpu.ppc.assembler
compiler.cfg.registers compiler.cfg.instructions
compiler.constants compiler.codegen compiler.codegen.fixup ;
IN: cpu.ppc
! PowerPC register assignments:
@ -57,13 +46,13 @@ M:: ppc %load-indirect ( reg obj -- )
obj rc-absolute-ppc-2/2 rel-literal
reg reg 0 LWZ ;
: ds-reg 30 ; inline
: rs-reg 31 ; inline
: ds-reg 29 ; inline
: rs-reg 30 ; inline
GENERIC: loc-reg ( loc -- reg )
M: ds-loc log-reg drop ds-reg ;
M: rs-loc log-reg drop rs-reg ;
M: ds-loc loc-reg drop ds-reg ;
M: rs-loc loc-reg drop rs-reg ;
: loc>operand ( loc -- reg n )
[ loc-reg ] [ n>> cells neg ] bi ; inline
@ -137,9 +126,25 @@ M: ppc %slot-imm ( dst obj slot tag -- ) (%slot-imm) LWZ ;
M: ppc %set-slot ( src obj slot tag temp -- ) (%slot) STW ;
M: ppc %set-slot-imm ( src obj slot tag -- ) (%slot-imm) STW ;
M:: ppc %string-nth ( dst src index temp -- )
[
"end" define-label
temp src index ADD
dst temp string-offset LBZ
temp src string-aux-offset LWZ
0 temp \ f tag-number CMPI
"end" get BEQ
temp temp index ADD
temp temp index ADD
temp temp byte-array-offset LHZ
temp temp 8 SLWI
dst dst temp OR
"end" resolve-label
] with-scope ;
M: ppc %add ADD ;
M: ppc %add-imm ADDI ;
M: ppc %sub swapd SUBF ;
M: ppc %sub swap SUBF ;
M: ppc %sub-imm SUBI ;
M: ppc %mul MULLW ;
M: ppc %mul-imm MULLI ;
@ -156,44 +161,42 @@ M: ppc %not NOT ;
: bignum@ ( n -- offset ) cells bignum tag-number - ; inline
M: ppc %integer>bignum ( dst src temp -- )
M:: ppc %integer>bignum ( dst src temp -- )
[
{ "end" "non-zero" "pos" "store" } [ define-label ] each
dst 0 >bignum %load-immediate
"end" define-label
dst 0 >bignum %load-indirect
! Is it zero? Then just go to the end and return this zero
0 src 0 CMPI
"end" get BEQ
! Allocate a bignum
dst 4 cells bignum temp %allot
! Write length
2 temp LI
dst 1 bignum@ temp STW
! Store value
dst 3 bignum@ src STW
2 tag-fixnum temp LI
temp dst 1 bignum@ STW
! Compute sign
temp src MR
temp cell-bits 1- SRAWI
temp temp cell-bits 1- SRAWI
temp temp 1 ANDI
! Store sign
dst 2 bignum@ temp STW
temp dst 2 bignum@ STW
! Make negative value positive
temp temp temp ADD
temp temp NEG
temp temp 1 ADDI
temp src temp MULLW
! Store the bignum
dst 3 bignum@ temp STW
temp dst 3 bignum@ STW
"end" resolve-label
] with-scope ;
M:: %bignum>integer ( dst src temp -- )
M:: ppc %bignum>integer ( dst src temp -- )
[
"end" define-label
temp src 1 bignum@ LWZ
! if the length is 1, its just the sign and nothing else,
! so output 0
0 dst LI
0 temp 1 v>operand CMPI
0 temp 1 tag-fixnum CMPI
"end" get BEQ
! load the value
dst src 3 bignum@ LWZ
@ -203,6 +206,7 @@ M:: %bignum>integer ( dst src temp -- )
! and 1 into -1
temp temp temp ADD
temp temp 1 SUBI
temp temp NEG
! multiply value by sign
dst dst temp MULLW
"end" resolve-label
@ -213,14 +217,14 @@ M: ppc %sub-float FSUB ;
M: ppc %mul-float FMUL ;
M: ppc %div-float FDIV ;
M: ppc %integer>float ( dst src -- )
M:: ppc %integer>float ( dst src -- )
HEX: 4330 scratch-reg LIS
scratch-reg 1 0 param@ STW
scratch-reg src MR
scratch-reg dup HEX: 8000 XORIS
scratch-reg 1 cell param@ STW
fp-scratch-reg-2 1 0 param@ LFD
4503601774854144.0 scratch-reg load-indirect
scratch-reg 4503601774854144.0 %load-indirect
fp-scratch-reg-2 scratch-reg float-offset LFD
fp-scratch-reg-2 fp-scratch-reg-2 fp-scratch-reg-2 FSUB ;
@ -231,7 +235,7 @@ M:: ppc %float>integer ( dst src -- )
M: ppc %copy ( dst src -- ) MR ;
M: ppc %copy-float ( dst src -- ) MFR ;
M: ppc %copy-float ( dst src -- ) FMR ;
M: ppc %unbox-float ( dst src -- ) float-offset LFD ;
@ -277,9 +281,9 @@ M:: ppc %box-alien ( dst src temp -- )
"f" get BEQ
dst 4 cells alien temp %allot
! Store offset
dst src 3 alien@ STW
temp \ f tag-number %load-immediate
src dst 3 alien@ STW
! Store expired slot
temp \ f tag-number %load-immediate
temp dst 1 alien@ STW
! Store underlying-alien slot
temp dst 2 alien@ STW
@ -289,7 +293,7 @@ M:: ppc %box-alien ( dst src temp -- )
M: ppc %alien-unsigned-1 0 LBZ ;
M: ppc %alien-unsigned-2 0 LHZ ;
M: ppc %alien-signed-1 dupd 0 LBZ EXTSB ;
M: ppc %alien-signed-1 dupd 0 LBZ dup EXTSB ;
M: ppc %alien-signed-2 0 LHA ;
M: ppc %alien-cell 0 LWZ ;
@ -297,45 +301,47 @@ M: ppc %alien-cell 0 LWZ ;
M: ppc %alien-float 0 LFS ;
M: ppc %alien-double 0 LFD ;
M: ppc %set-alien-integer-1 0 STB ;
M: ppc %set-alien-integer-2 0 STH ;
M: ppc %set-alien-integer-1 swap 0 STB ;
M: ppc %set-alien-integer-2 swap 0 STH ;
M: ppc %set-alien-cell 0 STW ;
M: ppc %set-alien-cell swap 0 STW ;
M: ppc %set-alien-float 0 STFS ;
M: ppc %set-alien-double 0 STFD ;
M: ppc %set-alien-float swap 0 STFS ;
M: ppc %set-alien-double swap 0 STFD ;
: %load-dlsym ( symbol dll register -- )
0 swap LOAD32 rc-absolute-ppc-2/2 rel-dlsym ;
: load-zone-ptr ( reg -- )
[ "nursery" f ] dip %load-dlsym ;
: load-allot-ptr ( nursery-ptr allot-ptr -- )
[ drop load-zone-ptr ] [ swap cell LWZ ] 2bi ;
[ drop load-zone-ptr ] [ swap 4 LWZ ] 2bi ;
:: inc-allot-ptr ( nursery-ptr n -- )
scratch-reg inc-allot-ptr 4 LWZ
scratch-reg scratch-reg n 8 align ADD
scratch-reg inc-allot-ptr 4 STW ;
:: inc-allot-ptr ( nursery-ptr allot-ptr n -- )
scratch-reg allot-ptr n 8 align ADDI
scratch-reg nursery-ptr 4 STW ;
:: store-header ( temp class -- )
:: store-header ( dst class -- )
class type-number tag-fixnum scratch-reg LI
temp scratch-reg 0 STW ;
scratch-reg dst 0 STW ;
: store-tagged ( dst tag -- )
dupd tag-number ORI ;
M:: ppc %allot ( dst size class nursery-ptr -- )
nursery-ptr dst load-allot-ptr
nursery-ptr dst size inc-allot-ptr
dst class store-header
dst class store-tagged
nursery-ptr size inc-allot-ptr ;
dst class store-tagged ;
: %alien-global ( dest name -- )
[ f swap %load-dlsym ] [ drop dup 0 LWZ ] 2bi ;
: %alien-global ( dst name -- )
[ f rot %load-dlsym ] [ drop dup 0 LWZ ] 2bi ;
: load-cards-offset ( dest -- )
: load-cards-offset ( dst -- )
"cards_offset" %alien-global ;
: load-decks-offset ( dest -- )
: load-decks-offset ( dst -- )
"decks_offset" %alien-global ;
M:: ppc %write-barrier ( src card# table -- )
@ -359,18 +365,17 @@ M: ppc %gc
11 11 1024 ADDI ! add ALLOT_BUFFER_ZONE to here
11 0 12 CMP ! is here >= end?
"end" get BLE
0 frame-required
%prepare-alien-invoke
"minor_gc" f %alien-invoke
"end" resolve-label ;
M: ppc %prologue ( n -- )
0 scrach-reg LOAD32 rc-absolute-ppc-2/2 rel-this
0 scratch-reg LOAD32 rc-absolute-ppc-2/2 rel-this
0 MFLR
1 1 pick neg ADDI
scrach-reg 1 pick xt-save STW
dup scrach-reg LI
scrach-reg 1 pick next-save STW
scratch-reg 1 pick xt-save STW
dup scratch-reg LI
scratch-reg 1 pick next-save STW
0 1 rot lr-save + STW ;
M: ppc %epilogue ( n -- )
@ -384,19 +389,19 @@ M: ppc %epilogue ( n -- )
:: (%boolean) ( dst word -- )
"end" define-label
\ f tag-number %load-immediate
dst \ f tag-number %load-immediate
"end" get word execute
dst \ t %load-indirect
"end" get resolve-label ; inline
: %boolean ( dst cc -- )
negate-cc {
{ cc< [ \ BLT %boolean ] }
{ cc<= [ \ BLE %boolean ] }
{ cc> [ \ BGT %boolean ] }
{ cc>= [ \ BGE %boolean ] }
{ cc= [ \ BEQ %boolean ] }
{ cc/= [ \ BNE %boolean ] }
{ cc< [ \ BLT (%boolean) ] }
{ cc<= [ \ BLE (%boolean) ] }
{ cc> [ \ BGT (%boolean) ] }
{ cc>= [ \ BGE (%boolean) ] }
{ cc= [ \ BEQ (%boolean) ] }
{ cc/= [ \ BNE (%boolean) ] }
} case ;
: (%compare) ( src1 src2 -- ) [ 0 ] dip CMP ; inline
@ -426,7 +431,7 @@ M: ppc %compare-float-branch (%compare-float) %branch ;
: stack@ 1 swap ; inline
: spill-integer@ ( n -- op )
: spill-integer@ ( n -- reg offset )
cells
stack-frame get spill-integer-base
+ stack@ ;
@ -437,7 +442,7 @@ M: ppc %compare-float-branch (%compare-float) %branch ;
[ return>> ]
tri + + ;
: spill-float@ ( n -- op )
: spill-float@ ( n -- reg offset )
double-float-regs reg-size *
stack-frame get spill-float-base
+ stack@ ;
@ -560,7 +565,7 @@ M: ppc %alien-invoke ( symbol dll -- )
11 %load-dlsym 11 MTLR BLRL ;
M: ppc %alien-callback ( quot -- )
3 load-indirect "c_to_factor" f %alien-invoke ;
3 swap %load-indirect "c_to_factor" f %alien-invoke ;
M: ppc %prepare-alien-indirect ( -- )
"unbox_alien" f %alien-invoke

View File

@ -293,15 +293,13 @@ M:: x86 %box-alien ( dst src temp -- )
[ quot call ] with-save/restore
] if ; inline
: aux-offset 2 cells string tag-number - ; inline
M:: x86 %string-nth ( dst src index temp -- )
"end" define-label
dst { src index temp } [| new-dst |
temp src index [+] LEA
new-dst 1 small-reg temp string-offset [+] MOV
new-dst new-dst 1 small-reg MOVZX
temp src aux-offset [+] MOV
temp src string-aux-offset [+] MOV
temp \ f tag-number CMP
"end" get JE
new-dst temp XCHG