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

Preliminary floating point intrinsics work

release
slava 2006-05-05 06:00:17 +00:00
parent ade9b3333c
commit a6e9ed5c21
5 changed files with 115 additions and 43 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
library/compiler/amd64/architecture.factor
View File

@ -16,8 +16,8 @@ kernel-internals math namespaces sequences ;
: remainder-reg RDX ; inline
M: int-regs return-reg drop RAX ;
M: int-regs vregs { RAX RCX RDX RSI RDI R8 R9 R10 R11 } ;
M: int-regs fastcall-regs { RDI RSI RDX RCX R8 R9 } ;
M: int-regs vregs drop { RAX RCX RDX RSI RDI R8 R9 R10 R11 } ;
M: int-regs fastcall-regs drop { RDI RSI RDX RCX R8 R9 } ;
: compile-c-call ( symbol dll -- )
2dup dlsym R10 swap MOV

13
library/compiler/generator/generator.factor
View File

@ -192,8 +192,16 @@ M: #dispatch generate-node ( node -- next )
! #push
UNION: immediate fixnum POSTPONE: f ;
: alloc-literal-reg ( literal -- vreg )
float? T{ float-regs f 8 } T{ int-regs } ? alloc-reg ;
! : generate-push ( node -- )
! >#push< dup [ class ] map requested-vregs ensure-vregs
! [ dup alloc-literal-reg [ load-literal ] keep ] map
! phantom-d get phantom-append ;
: generate-push ( node -- )
>#push< dup length ensure-vregs
>#push< dup length 0 ensure-vregs
[ T{ int-regs } alloc-reg [ load-literal ] keep ] map
phantom-d get phantom-append ;
@ -221,7 +229,7 @@ M: #push generate-node ( #push -- )
dup shuffle-in-d swap shuffle-in-r additional-vregs# ;
: phantom-shuffle ( shuffle -- )
dup shuffle-vregs# ensure-vregs
dup shuffle-vregs# 0 ensure-vregs
[ phantom-shuffle-inputs ] keep
[ shuffle* ] keep adjust-shuffle
(template-outputs) ;
@ -236,4 +244,5 @@ M: #return generate-node drop end-basic-block %return f ;
: card-bits 7 ;
: card-mark HEX: 80 ;
: float-offset 8 float-tag - ;
: string-offset 3 cells object-tag - ;

74
library/compiler/generator/templates.factor
View File

@ -7,22 +7,18 @@ namespaces prettyprint sequences vectors words ;
! Register allocation
! Hash mapping reg-classes to mutable vectors
SYMBOL: free-vregs
: free-vregs ( reg-class -- seq ) \ free-vregs get hash ;
: alloc-reg ( reg-class -- vreg )
>r free-vregs get pop r> <vreg> ;
: alloc-reg ( reg-class -- vreg ) free-vregs pop ;
: requested-vregs ( template -- n )
0 [ [ 1+ ] unless ] reduce ;
: template-vreg# ( template template -- n )
[ requested-vregs ] 2apply + ;
: take-reg ( vreg -- ) dup delegate free-vregs delete ;
: alloc-vregs ( template -- template )
[ first [ <int-vreg> ] [ T{ int-regs } alloc-reg ] if* ] map ;
: adjust-free-vregs ( seq -- )
free-vregs [ diff ] change ;
[
first dup
H{ { f T{ int-regs } } { float T{ float-regs f 8 } } }
hash [ alloc-reg ] [ <int-vreg> dup take-reg ] ?if
] map ;
! A data stack location.
TUPLE: ds-loc n ;
@ -84,7 +80,6 @@ M: phantom-callstack finalize-height
dup length swap phantom-locs ;
: adjust-phantom ( n phantom -- )
#! Change stack heiht.
[ phantom-stack-height + ] keep set-phantom-stack-height ;
GENERIC: cut-phantom ( n phantom -- seq )
@ -150,22 +145,29 @@ SYMBOL: phantom-r
finalize-contents finalize-heights ;
: used-vregs ( -- seq )
phantoms append [ vreg? ] subset [ vreg-n ] map ;
phantoms append [ vreg? ] subset ;
: (compute-free-vregs) ( used class -- vector )
dup vregs length reverse [ swap <vreg> ] map-with diff
>vector ;
: compute-free-vregs ( -- )
used-vregs T{ int-regs } vregs length reverse diff
>vector free-vregs set ;
used-vregs
{ T{ int-regs } T{ float-regs f 8 } }
[ 2dup (compute-free-vregs) ] map>hash \ free-vregs set
drop ;
: additional-vregs# ( seq seq -- n )
2array phantoms 2array [ [ length ] map ] 2apply v-
0 [ 0 max + ] reduce ;
: free-vregs* ( -- n )
free-vregs get length
phantoms [ [ loc? ] subset length ] 2apply + - ;
: free-vregs* ( -- int# float# )
T{ int-regs } free-vregs length
phantoms [ [ loc? ] subset length ] 2apply + -
T{ float-regs f 8 } free-vregs length ;
: ensure-vregs ( n -- )
compute-free-vregs free-vregs* <=
: ensure-vregs ( int# float# -- )
compute-free-vregs free-vregs* swapd <= >r <= r> and
[ finalize-contents compute-free-vregs ] unless ;
: lazy-load ( value loc -- value )
@ -181,12 +183,18 @@ SYMBOL: phantom-r
[ dupd %peek ] 2map
] 2keep length neg swap adjust-phantom ;
: compatible-vreg? ( n vreg -- ? )
{
{ [ dup [ int-regs? ] is? ] [ vreg-n = ] }
{ [ dup [ float-regs? ] is? ] [ 2drop t ] }
{ [ t ] [ 2drop f ] }
} cond ;
: compatible-values? ( value template -- ? )
{
{ [ over loc? ] [ 2drop t ] }
{ [ dup not ] [ 2drop t ] }
{ [ over not ] [ 2drop f ] }
{ [ dup integer? ] [ swap vreg-n = ] }
{ [ dup { f float } memq? ] [ 2drop t ] }
{ [ dup integer? ] [ swap compatible-vreg? ] }
} cond ;
: template-match? ( template phantom -- ? )
@ -245,12 +253,12 @@ SYMBOL: +clobber
outputs-clash? [ finalize-contents ] when
phantom-d get swap [ stack>vregs ] keep phantom-vregs ;
: input-vregs ( -- seq )
+input +scratch [ get [ second get vreg-n ] map ] 2apply
append ;
: requested-vregs ( template -- int# float# )
dup length swap [ float eq? ] subset length [ - ] keep ;
: guess-vregs ( -- n )
+input get { } additional-vregs# +scratch get length + ;
: guess-vregs ( -- int# float# )
+input get { } additional-vregs#
+scratch get requested-vregs >r + r> ;
: alloc-scratch ( -- )
+scratch get [ alloc-vregs ] keep phantom-vregs ;
@ -261,11 +269,9 @@ SYMBOL: +clobber
guess-vregs ensure-vregs
! Split the template into available (fast) parts and those
! that require allocating registers and reading the stack
+input get match-template fast-input
used-vregs adjust-free-vregs
slow-input
alloc-scratch
input-vregs adjust-free-vregs ;
+input get match-template fast-input slow-input
! Finally allocate scratch registers
alloc-scratch ;
: template-outputs ( -- )
+output get [ get ] map { } (template-outputs) ;

34
library/compiler/x86/architecture.factor
View File

@ -46,12 +46,23 @@ M: float-regs vregs drop { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } ;
: prepare-division CDQ ; inline
: unboxify-float ( obj vreg quot -- | quot: obj int-vreg )
over [ float-regs? ] is? [
swap >r T{ int-regs } alloc-reg [ swap call ] keep
r> swap [ v>operand ] 2apply float-offset [+] MOVSD
] [
call
] if ; inline
M: immediate load-literal ( literal vreg -- )
v>operand swap address MOV ;
v>operand swap v>operand MOV ;
: load-indirect ( literal vreg -- )
v>operand swap add-literal [] MOV
rel-absolute-cell rel-address ;
M: object load-literal ( literal vreg -- )
v>operand swap
add-literal [] MOV rel-absolute-cell rel-address ;
[ load-indirect ] unboxify-float ;
: (%call) ( label -- label )
dup postpone-word dup primitive? [ address-operand ] when ;
@ -85,9 +96,22 @@ M: object load-literal ( literal vreg -- )
: %return ( -- ) %epilogue RET ;
: %peek ( vreg loc -- ) [ v>operand ] 2apply MOV ;
: vreg-mov [ v>operand ] 2apply MOV ;
: %replace ( vreg loc -- ) swap %peek ;
: %peek ( vreg loc -- )
swap [ swap vreg-mov ] unboxify-float ;
: %replace ( vreg loc -- )
over [ float-regs? ] is? [
! >r
! "fp-scratch" operand "allot.here" f dlsym [] MOV
! "fp-scratch" operand [] float-tag >header MOV
! "fp-scratch" operand 8 [+] r> MOVSD
! "allot.here" f dlsym [] 16 ADD
vreg-mov
] [
vreg-mov
] if ;
: (%inc) swap cells dup 0 > [ ADD ] [ neg SUB ] if ;

33
library/compiler/x86/intrinsics.factor
View File

@ -261,6 +261,39 @@ IN: compiler
first2 define-fixnum-jump
] each
! Floats
! : define-float-op ( word op -- )
! [ [ "x" operand "y" operand ] % , ] [ ] make H{
! { +input { { float "x" } { float "y" } } }
! { +output { "x" } }
! } define-intrinsic ;
!
! {
! { float+ ADDSD }
! { float- SUBSD }
! { float* MULSD }
! { float/f DIVSD }
! } [
! first2 define-float-op
! ] each
!
! : define-float-jump ( word op -- )
! [
! [ end-basic-block "x" operand "y" operand COMISD ] % ,
! ] [ ] make H{
! { +input { { float "x" } { float "y" } } }
! } define-if-intrinsic ;
!
! {
! { float< JL }
! { float<= JLE }
! { float> JG }
! { float>= JGE }
! { float= JE }
! } [
! first2 define-float-jump
! ] each
! User environment
: %userenv ( -- )
"x" operand "userenv" f dlsym MOV