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

Working on improved alien intrinsics

release
Slava Pestov 2007-09-28 04:02:33 -04:00
parent 15057fd349
commit f7c2c9e441
7 changed files with 163 additions and 83 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

32
core/compiler/test/templates.factor
View File

@ -1,9 +1,9 @@
! Black box testing of templater optimization
! Black box testing of templating optimization
USING: arrays compiler kernel kernel.private math
hashtables.private math.private math.ratios.private namespaces
sequences sequences.private tools.test namespaces.private
slots.private combinators.private ;
slots.private combinators.private byte-arrays alien layouts ;
IN: temporary
! Oops!
@ -185,3 +185,31 @@ TUPLE: my-tuple ;
[ 4 ] [ T{ my-tuple } foox ] unit-test
[ 5 ] [ "hi" foox ] unit-test
! Making sure we don't needlessly unbox/rebox
[ t 3.0 ] [ 1.0 dup [ dup 2.0 float+ >r eq? r> ] compile-1 ] unit-test
[ t 3.0 ] [ 1.0 dup [ dup 2.0 float+ ] compile-1 >r eq? r> ] unit-test
[ t ] [ 1.0 dup [ [ 2.0 float+ ] keep ] compile-1 nip eq? ] unit-test
[ 1 B{ 1 2 3 4 } ] [
B{ 1 2 3 4 } [
{ byte-array } declare
[ 0 alien-unsigned-1 ] keep
] compile-1
] unit-test
[ 1 t ] [
B{ 1 2 3 4 } [
{ simple-c-ptr } declare
[ 0 alien-unsigned-1 ] keep type
] compile-1 byte-array type-number =
] unit-test
[ t ] [
B{ 1 2 3 4 } [
{ simple-c-ptr } declare
0 alien-cell type
] compile-1 alien type-number =
] unit-test

19
core/cpu/architecture/architecture.factor
View File

@ -183,24 +183,15 @@ PREDICATE: integer inline-array 32 < ;
] if-small-struct ;
! Alien accessors
HOOK: %unbox-byte-array compiler-backend ( quot src -- ) inline
HOOK: %unbox-byte-array compiler-backend ( dst src -- )
HOOK: %unbox-alien compiler-backend ( quot src -- ) inline
HOOK: %unbox-alien compiler-backend ( dst src -- )
HOOK: %unbox-f compiler-backend ( quot src -- ) inline
HOOK: %unbox-f compiler-backend ( dst src -- )
HOOK: %complex-alien-accessor compiler-backend ( quot src -- )
inline
HOOK: %unbox-c-ptr compiler-backend ( dst src -- )
: %alien-accessor ( quot src class -- )
{
{ [ dup \ f class< ] [ drop %unbox-f ] }
{ [ dup simple-alien class< ] [ drop %unbox-alien ] }
{ [ dup byte-array class< ] [ drop %unbox-byte-array ] }
{ [ dup bit-array class< ] [ drop %unbox-byte-array ] }
{ [ dup float-array class< ] [ drop %unbox-byte-array ] }
{ [ t ] [ drop %complex-alien-accessor ] }
} cond ; inline
HOOK: %box-alien compiler-backend ( dst src -- )
: operand ( var -- op ) get v>operand ; inline

18
core/cpu/ppc/allot/allot.factor
View File

@ -78,22 +78,22 @@ M: ppc-backend %box-float ( dst src -- )
"end" resolve-label
] with-scope ;
: %allot-alien ( ptr -- )
"temp" set
M: ppc-backend %box-alien ( dst src -- )
"f" define-label
"end" define-label
0 "temp" operand 0 CMPI
0 over v>operand 0 CMPI
"f" get BEQ
alien 4 cells %allot
"temp" operand 11 3 cells STW
f v>operand "temp" operand LI
! Store offset
v>operand 11 3 cells STW
f v>operand 12 LI
! Store expired slot
"temp" operand 11 1 cells STW
12 11 1 cells STW
! Store underlying-alien slot
"temp" operand 11 2 cells STW
12 11 2 cells STW
! Store tagged ptr in reg
"temp" get object %store-tagged
dup object %store-tagged
"end" get B
"f" resolve-label
f v>operand "temp" operand LI
f v>operand swap v>operand LI
"end" resolve-label ;

30
core/cpu/ppc/architecture/architecture.factor
View File

@ -315,34 +315,28 @@ M: ppc-backend %unbox-small-struct
drop "No small structs" throw ;
! Alien intrinsics
M: ppc-backend %unbox-byte-array ( quot src -- )
"address" operand "alien" operand "offset" operand ADD
"address" operand byte-array-offset
roll call ;
M: ppc-backend %unbox-byte-array ( dst src -- )
[ v>operand ] 2apply byte-array-offset ADDI ;
M: ppc-backend %unbox-alien ( quot src -- )
"address" operand "alien" operand alien-offset LWZ
"address" operand dup "offset" operand ADD
"address" operand 0
roll call ;
M: ppc-backend %unbox-alien ( dst src -- )
[ v>operand ] 2apply alien-offset LWZ ;
M: ppc-backend %unbox-f ( quot src -- )
"offset" operand 0
roll call ;
M: ppc-backend %unbox-f ( dst src -- )
drop 0 swap v>operand LI ;
M: ppc-backend %complex-alien-accessor ( quot src -- )
M: ppc-backend %unbox-c-ptr ( dst src -- )
"is-f" define-label
"is-alien" define-label
"end" define-label
0 "alien" operand f v>operand CMPI
0 over v>operand f v>operand CMPI
"is-f" get BEQ
"address" operand "alien" operand header-offset LWZ
0 "address" operand alien type-number tag-header CMPI
12 over v>operand header-offset LWZ
0 12 alien type-number tag-header CMPI
"is-alien" get BEQ
[ %unbox-byte-array ] 2keep
2dup %unbox-byte-array
"end" get B
"is-alien" resolve-label
[ %unbox-alien ] 2keep
2dup %unbox-alien
"end" get B
"is-f" resolve-label
%unbox-f

77
core/cpu/ppc/intrinsics/intrinsics.factor
View File

@ -601,41 +601,48 @@ IN: cpu.ppc.intrinsics
} define-intrinsic
! Alien intrinsics
: %alien-get ( quot -- )
"offset" operand dup %untag-fixnum
"offset" operand dup "alien" operand ADD
"output" operand "offset" operand 0 roll call ; inline
: %alien-set ( quot -- )
"offset" operand dup %untag-fixnum
"offset" operand dup "alien" operand ADD
"value" operand "offset" operand 0 roll call ; inline
: alien-integer-get-template
H{
{ +input+ {
{ f "alien" simple-c-ptr }
{ unboxed-c-ptr "alien" simple-c-ptr }
{ f "offset" fixnum }
} }
{ +scratch+ { { f "output" } } }
{ +scratch+ { { f "output" } { f "address" } } }
{ +output+ { "output" } }
{ +clobber+ { "offset" } }
} ;
: %alien-get ( quot -- )
"output" get "address" set
"offset" operand dup %untag-fixnum
"output" operand "alien" operand-class %alien-accessor ;
: %alien-integer-get ( quot -- )
%alien-get
"output" operand dup %tag-fixnum ; inline
: %alien-integer-set ( quot -- )
{ "offset" "value" } %untag-fixnums
"value" operand "alien" operand-class %alien-accessor ; inline
: alien-integer-set-template
H{
{ +input+ {
{ f "value" fixnum }
{ f "alien" simple-c-ptr }
{ unboxed-c-ptr "alien" simple-c-ptr }
{ f "offset" fixnum }
} }
{ +scratch+ { { f "address" } } }
{ +clobber+ { "value" "offset" } }
} ;
: %alien-integer-set ( quot -- )
"offset" get "value" get = [
"value" operand dup %untag-fixnum
] unless
%alien-set ; inline
: define-alien-integer-intrinsics ( word get-quot word set-quot -- )
[ %alien-integer-set ] curry
alien-integer-set-template
@ -660,41 +667,56 @@ define-alien-integer-intrinsics
\ set-alien-signed-2 [ STH ]
define-alien-integer-intrinsics
: %alien-float-get ( quot -- )
"offset" operand dup %untag-fixnum
"output" operand "alien" operand-class %alien-accessor ; inline
\ alien-cell [
[ LWZ ] %alien-get
] H{
{ +input+ {
{ unboxed-c-ptr "alien" simple-c-ptr }
{ f "offset" fixnum }
} }
! should be unboxed-alien
{ +scratch+ { { unboxed-c-ptr "output" } } }
{ +output+ { "output" } }
{ +clobber+ { "offset" } }
} define-intrinsic
\ set-alien-cell [
[ STW ] %alien-set
] H{
{ +input+ {
{ unboxed-c-ptr "value" simple-c-ptr }
{ unboxed-c-ptr "alien" simple-c-ptr }
{ f "offset" fixnum }
} }
{ +clobber+ { "offset" } }
} define-intrinsic
: alien-float-get-template
H{
{ +input+ {
{ f "alien" simple-c-ptr }
{ unboxed-c-ptr "alien" simple-c-ptr }
{ f "offset" fixnum }
} }
{ +scratch+ { { float "output" } { f "address" } } }
{ +scratch+ { { float "output" } } }
{ +output+ { "output" } }
{ +clobber+ { "offset" } }
} ;
: %alien-float-set ( quot -- )
"offset" operand dup %untag-fixnum
"value" operand "alien" operand-class %alien-accessor ; inline
: alien-float-set-template
H{
{ +input+ {
{ float "value" float }
{ f "alien" simple-c-ptr }
{ unboxed-c-ptr "alien" simple-c-ptr }
{ f "offset" fixnum }
} }
{ +scratch+ { { f "address" } } }
{ +clobber+ { "offset" } }
} ;
: define-alien-float-intrinsics ( word get-quot word set-quot -- )
[ %alien-float-set ] curry
[ %alien-set ] curry
alien-float-set-template
define-intrinsic
[ %alien-float-get ] curry
[ %alien-get ] curry
alien-float-get-template
define-intrinsic ;
@ -705,8 +727,3 @@ define-alien-float-intrinsics
\ alien-float [ LFS ]
\ set-alien-float [ STFS ]
define-alien-float-intrinsics
\ alien-cell [
[ LWZ ] %alien-get
"output" get %allot-alien
] alien-integer-get-template define-intrinsic

66
core/generator/registers/registers.factor
View File

@ -47,6 +47,23 @@ TUPLE: rs-loc n ;
C: <rs-loc> rs-loc
! Unboxed alien pointers
TUPLE: unboxed-alien vreg ;
C: <unboxed-alien> unboxed-alien
M: unboxed-alien v>operand unboxed-alien-vreg v>operand ;
TUPLE: unboxed-byte-array vreg ;
C: <unboxed-byte-array> unboxed-byte-array
M: unboxed-byte-array v>operand unboxed-byte-array-vreg v>operand ;
TUPLE: unboxed-f vreg ;
C: <unboxed-f> unboxed-f
M: unboxed-f v>operand unboxed-f-vreg v>operand ;
TUPLE: unboxed-c-ptr vreg ;
C: <unboxed-c-ptr> unboxed-c-ptr
M: unboxed-c-ptr v>operand unboxed-c-ptr-vreg v>operand ;
<PRIVATE
UNION: loc ds-loc rs-loc ;
@ -54,22 +71,34 @@ UNION: loc ds-loc rs-loc ;
! Moving values between locations and registers
GENERIC: move-spec ( obj -- spec )
M: unboxed-alien move-spec class ;
M: unboxed-byte-array move-spec class ;
M: unboxed-f move-spec class ;
M: unboxed-c-ptr move-spec class ;
M: int-regs move-spec drop f ;
M: float-regs move-spec drop float ;
M: value move-spec class ;
M: cached move-spec drop cached ;
M: loc move-spec drop loc ;
M: f move-spec drop loc ;
USE: prettyprint
: %move ( dst src -- )
dup [ "FUCK" throw ] unless
2dup [ move-spec ] 2apply 2array {
{ { f f } [ "Bug in generator.registers %move" throw ] }
{ { float f } [ %unbox-float ] }
{ { loc f } [ swap %replace ] }
{ { f float } [ %box-float ] }
{ { f value } [ value-literal swap load-literal ] }
{ { f float } [ %box-float ] }
! { { f unboxed-alien } [ %box-alien ] }
{ { f unboxed-c-ptr } [ %box-alien ] }
{ { f loc } [ %peek ] }
{ { float f } [ %unbox-float ] }
{ { unboxed-alien f } [ %unbox-alien ] }
{ { unboxed-byte-array f } [ %unbox-byte-array ] }
{ { unboxed-f f } [ %unbox-f ] }
{ { unboxed-c-ptr f } [ %unbox-c-ptr ] }
{ { loc f } [ swap %replace ] }
[ drop temp-reg swap %move temp-reg %move ]
} case ;
@ -188,7 +217,11 @@ PRIVATE>
! Phantom stacks hold values, locs, and vregs
GENERIC: live-vregs* ( obj -- )
M: cached live-vregs* cached-vreg , ;
M: cached live-vregs* cached-vreg live-vregs* ;
M: unboxed-alien live-vregs* unboxed-alien-vreg , ;
M: unboxed-byte-array live-vregs* unboxed-byte-array-vreg , ;
M: unboxed-f live-vregs* unboxed-f-vreg , ;
M: unboxed-c-ptr live-vregs* unboxed-c-ptr-vreg , ;
M: vreg live-vregs* , ;
M: object live-vregs* drop ;
@ -239,7 +272,13 @@ SYMBOL: fresh-objects
! Copying vregs to stacks
: alloc-vreg ( spec -- reg )
reg-spec>class free-vregs pop ;
dup reg-spec>class free-vregs pop swap {
{ unboxed-alien [ <unboxed-alien> ] }
{ unboxed-byte-array [ <unboxed-byte-array> ] }
{ unboxed-f [ <unboxed-f> ] }
{ unboxed-c-ptr [ <unboxed-c-ptr> ] }
[ drop ]
} case ;
: allocation ( value spec -- reg-class )
dup quotation? [
@ -368,8 +407,19 @@ M: object minimal-ds-loc* drop ;
: vreg-substitution ( value vreg -- pair )
dupd <cached> 2array ;
: substitute-vreg? ( old new -- ? )
#! We don't substitute locs for float or alien vregs,
#! since in those cases the boxing overhead might kill us.
cached-vreg {
{ [ dup vreg? not ] [ f ] }
{ [ dup delegate int-regs? not ] [ f ] }
{ [ over loc? not ] [ f ] }
{ [ t ] [ t ] }
} cond 2nip ;
: substitute-vregs ( values vregs -- )
[ vreg-substitution ] 2map [ first loc? ] subset >hashtable
[ vreg-substitution ] 2map
[ substitute-vreg? ] assoc-subset >hashtable
[ swap substitute ] curry each-phantom ;
: lazy-load ( values template -- )