diff --git a/library/compiler/generator/generator.factor b/library/compiler/generator/generator.factor index 35f8fcf475..0fa40bf02a 100644 --- a/library/compiler/generator/generator.factor +++ b/library/compiler/generator/generator.factor @@ -240,8 +240,3 @@ M: #return generate-node drop end-basic-block %return f ; : float-offset 8 float-tag - ; : string-offset 3 cells object-tag - ; - -: fp-scratch ( -- vreg ) - "fp-scratch" get [ - T{ int-regs } alloc-reg dup "fp-scratch" set - ] unless* ; diff --git a/library/compiler/generator/templates.factor b/library/compiler/generator/templates.factor index 728586439d..5f95e17e0f 100644 --- a/library/compiler/generator/templates.factor +++ b/library/compiler/generator/templates.factor @@ -242,8 +242,31 @@ SYMBOL: +clobber : requested-vregs ( template -- int# float# ) dup length swap [ float eq? ] subset length [ - ] keep ; +: (holds-class?) ( class phantom -- ? ) + [ delegate class eq? ] contains-with? ; + +: holds-class? ( class -- ? ) + dup phantom-d get (holds-class?) swap + phantom-r get (holds-class?) or ; + +: (requests-class?) ( class template -- ) + [ second reg-spec>class eq? ] contains-with? ; + +: requests-class? ( class -- ? ) + dup +input get (requests-class?) swap + +scratch get (requests-class?) or ; + +: ?fp-scratch ( -- n ) + T{ float-regs f 8 } dup holds-class? >r requests-class? r> + or 1 0 ? ; + +: fp-scratch ( -- vreg ) + "fp-scratch" get [ + T{ int-regs } alloc-reg dup "fp-scratch" set + ] unless* ; + : guess-vregs ( -- int# float# ) - +input get { } additional-vregs + +input get { } additional-vregs ?fp-scratch + +scratch get [ first ] map requested-vregs >r + r> ; : alloc-scratch ( -- ) diff --git a/library/compiler/ppc/architecture.factor b/library/compiler/ppc/architecture.factor index 4b5af4bdfc..f0eee28761 100644 --- a/library/compiler/ppc/architecture.factor +++ b/library/compiler/ppc/architecture.factor @@ -123,7 +123,7 @@ M: int-regs (%replace) ( vreg loc -- ) ] bind save-allot-ptr ; inline M: float-regs (%replace) ( vreg loc reg-class -- ) - drop swap + drop swap fp-scratch drop [ v>operand 12 8 STFD ] [ fp-scratch v>operand swap loc>operand STW ] H{ { tag-header [ float-tag ] } diff --git a/library/test/compiler/float.factor b/library/test/compiler/float.factor index 49cb4b51b5..7589a1a2be 100644 --- a/library/test/compiler/float.factor +++ b/library/test/compiler/float.factor @@ -6,6 +6,9 @@ math-internals test ; [ 2.0 3.0 ] [ 3.0 [ 2.0 swap ] compile-1 ] unit-test [ 1 2 3 4.0 ] [ [ 1 2 3 4.0 ] compile-1 ] unit-test + +[ 3.0 1 2 3 ] [ 1.0 2.0 [ float+ 1 2 3 ] compile-1 ] unit-test + [ 5 ] [ 1.0 [ 2.0 float+ tag ] compile-1 ] unit-test [ 3.0 ] [ 1.0 [ 2.0 float+ ] compile-1 ] unit-test