diff --git a/library/compiler/amd64/architecture.factor b/library/compiler/amd64/architecture.factor index 59be8dfbe9..9a48d9b571 100644 --- a/library/compiler/amd64/architecture.factor +++ b/library/compiler/amd64/architecture.factor @@ -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 diff --git a/library/compiler/generator/generator.factor b/library/compiler/generator/generator.factor index f8dba4d840..435dcecb4a 100644 --- a/library/compiler/generator/generator.factor +++ b/library/compiler/generator/generator.factor @@ -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 - ; diff --git a/library/compiler/generator/templates.factor b/library/compiler/generator/templates.factor index 1a9f8897c9..1e7982fd17 100644 --- a/library/compiler/generator/templates.factor +++ b/library/compiler/generator/templates.factor @@ -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> ; +: 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 [ ] [ 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 ] [ 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 ] 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) ; diff --git a/library/compiler/x86/architecture.factor b/library/compiler/x86/architecture.factor index 532816d909..70a0a20614 100644 --- a/library/compiler/x86/architecture.factor +++ b/library/compiler/x86/architecture.factor @@ -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 ; diff --git a/library/compiler/x86/intrinsics.factor b/library/compiler/x86/intrinsics.factor index c4aea1c22d..e98ab9ec33 100644 --- a/library/compiler/x86/intrinsics.factor +++ b/library/compiler/x86/intrinsics.factor @@ -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