! 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 = ]
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.
[ 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
! 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
[ 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
: compiled-fixnum>bignum fixnum>bignum ;
+[ bignum ] [ 0 compiled-fixnum>bignum class ] unit-test
+
[ ] [
10000 [
32 random-bits >fixnum
! 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:
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
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 ;
: 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
! 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
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 ;
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 ;
"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
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 ;
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 swap 0 STW ;
-M: ppc %set-alien-cell 0 STW ;
+M: ppc %set-alien-float swap 0 STFS ;
+M: ppc %set-alien-double swap 0 STFD ;
-M: ppc %set-alien-float 0 STFS ;
-M: ppc %set-alien-double 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 -- )
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 -- )
:: (%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
: stack@ 1 swap ; inline
-: spill-integer@ ( n -- op )
+: spill-integer@ ( n -- reg offset )
cells
stack-frame get spill-integer-base
+ stack@ ;
[ return>> ]
tri + + ;
-: spill-float@ ( n -- op )
+: spill-float@ ( n -- reg offset )
double-float-regs reg-size *
stack-frame get spill-float-base
+ stack@ ;
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
projects / factor.git / commitdiff