curry compose uncurry
- array-nth set-array-nth length>>
+ array-nth set-array-nth
wrap probe
def: dst/int-rep
constant: obj ;
+INSN: ##load-double
+def: dst/double-rep
+constant: val ;
+
INSN: ##peek
def: dst/int-rep
literal: loc ;
tri
] with-compilation-unit
-: each-def-rep ( ... insn vreg-quot: ( ... vreg rep -- ... ) -- ... )
+: each-def-rep ( insn vreg-quot: ( vreg rep -- ) -- )
[ [ defs-vreg ] [ defs-vreg-rep ] bi ] dip with when* ; inline
-: each-use-rep ( ... insn vreg-quot: ( ... vreg rep -- ... ) -- ... )
+: each-use-rep ( insn vreg-quot: ( vreg rep -- ) -- )
[ [ uses-vregs ] [ uses-vreg-reps ] bi ] dip 2each ; inline
-: each-temp-rep ( ... insn vreg-quot: ( ... vreg rep -- ... ) -- ... )
+: each-temp-rep ( insn vreg-quot: ( vreg rep -- ) -- )
[ [ temp-vregs ] [ temp-vreg-reps ] bi ] dip 2each ; inline
+: each-rep ( insn vreg-quot: ( vreg rep -- ) -- )
+ [ each-def-rep ] [ each-use-rep ] [ each-temp-rep ] 2tri ; inline
+
: with-vreg-reps ( ..a cfg vreg-quot: ( ..a vreg rep -- ..b ) -- ..b )
'[
[ basic-block set ] [
[
- _
- [ each-def-rep ]
- [ each-use-rep ]
- [ each-temp-rep ] 2tri
+ _ each-rep
] each-non-phi
] bi
] each-basic-block ; inline
-USING: tools.test cpu.architecture
-compiler.cfg.registers compiler.cfg.instructions
-compiler.cfg.representations.preferred ;
+USING: accessors compiler.cfg compiler.cfg.debugger
+compiler.cfg.instructions compiler.cfg.registers
+compiler.cfg.representations.preferred cpu.architecture kernel
+namespaces tools.test sequences arrays system ;
IN: compiler.cfg.representations
[ { double-rep double-rep } ] [
{ dst 5 }
{ src 3 }
} defs-vreg-rep
-] unit-test
\ No newline at end of file
+] unit-test
+
+: test-representations ( -- )
+ cfg new 0 get >>entry dup cfg set select-representations drop ;
+
+! Make sure cost calculation isn't completely wrong
+V{
+ T{ ##prologue }
+ T{ ##branch }
+} 0 test-bb
+
+V{
+ T{ ##peek f 1 D 0 }
+ T{ ##peek f 2 D 1 }
+ T{ ##add-float f 3 1 2 }
+ T{ ##replace f 3 D 0 }
+ T{ ##replace f 3 D 1 }
+ T{ ##replace f 3 D 2 }
+ T{ ##branch }
+} 1 test-bb
+
+V{
+ T{ ##epilogue }
+ T{ ##return }
+} 2 test-bb
+
+0 1 edge
+1 2 edge
+
+[ ] [ test-representations ] unit-test
+
+[ 1 ] [ 1 get instructions>> [ ##allot? ] count ] unit-test
+
+cpu x86.32? [
+
+ ! Make sure load-constant is converted into load-double
+ V{
+ T{ ##prologue }
+ T{ ##branch }
+ } 0 test-bb
+
+ V{
+ T{ ##peek f 1 D 0 }
+ T{ ##load-constant f 2 0.5 }
+ T{ ##add-float f 3 1 2 }
+ T{ ##replace f 3 D 0 }
+ T{ ##branch }
+ } 1 test-bb
+
+ V{
+ T{ ##epilogue }
+ T{ ##return }
+ } 2 test-bb
+
+ 0 1 edge
+ 1 2 edge
+
+ [ ] [ test-representations ] unit-test
+
+ [ t ] [ 1 get instructions>> second ##load-double? ] unit-test
+
+ ! Make sure phi nodes are handled in a sane way
+ V{
+ T{ ##prologue }
+ T{ ##branch }
+ } 0 test-bb
+
+ V{
+ T{ ##peek f 1 D 0 }
+ T{ ##compare-imm-branch f 1 2 }
+ } 1 test-bb
+
+ V{
+ T{ ##load-constant f 2 1.5 }
+ T{ ##branch }
+ } 2 test-bb
+
+ V{
+ T{ ##load-constant f 3 2.5 }
+ T{ ##branch }
+ } 3 test-bb
+
+ V{
+ T{ ##phi f 4 }
+ T{ ##peek f 5 D 0 }
+ T{ ##add-float f 6 4 5 }
+ T{ ##replace f 6 D 0 }
+ } 4 test-bb
+
+ V{
+ T{ ##epilogue }
+ T{ ##return }
+ } 5 test-bb
+
+ test-diamond
+ 4 5 edge
+
+ 2 get 2 2array
+ 3 get 3 2array 2array 4 get instructions>> first (>>inputs)
+
+ [ ] [ test-representations ] unit-test
+
+ [ t ] [ 2 get instructions>> first ##load-double? ] unit-test
+
+ [ t ] [ 3 get instructions>> first ##load-double? ] unit-test
+
+ [ t ] [ 4 get instructions>> first ##phi? ] unit-test
+] when
\ No newline at end of file
-! Copyright (C) 2009 Slava Pestov
+! Copyright (C) 2009, 2010 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: kernel fry accessors sequences assocs sets namespaces
arrays combinators combinators.short-circuit math make locals
: possible ( vreg -- reps ) possibilities get at ;
: compute-possibilities ( cfg -- )
- H{ } clone [ '[ swap _ conjoin-at ] with-vreg-reps ] keep
- [ keys ] assoc-map possibilities set ;
+ H{ } clone [ '[ swap _ adjoin-at ] with-vreg-reps ] keep
+ [ members ] assoc-map possibilities set ;
! Compute vregs which must remain tagged for their lifetime.
SYMBOL: always-boxed
SYMBOL: costs
: init-costs ( -- )
- possibilities get [ [ 0 ] H{ } map>assoc ] assoc-map costs set ;
+ possibilities get [ drop H{ } clone ] assoc-map costs set ;
+
+: record-possibility ( rep vreg -- )
+ costs get at [ 0 or ] change-at ;
: increase-cost ( rep vreg -- )
! Increase cost of keeping vreg in rep, making a choice of rep less
! likely.
- [ basic-block get loop-nesting-at ] 2dip costs get at at+ ;
+ costs get at [ 0 or basic-block get loop-nesting-at 1 + + ] change-at ;
: maybe-increase-cost ( possible vreg preferred -- )
- pick eq? [ 2drop ] [ increase-cost ] if ;
+ pick eq? [ record-possibility ] [ increase-cost ] if ;
: representation-cost ( vreg preferred -- )
! 'preferred' is a representation that the instruction can accept with no cost.
[ '[ _ _ maybe-increase-cost ] ]
2bi each ;
+GENERIC: compute-insn-costs ( insn -- )
+
+M: ##load-constant compute-insn-costs
+ ! There's no cost to unboxing the result of a ##load-constant
+ drop ;
+
+M: insn compute-insn-costs [ representation-cost ] each-rep ;
+
: compute-costs ( cfg -- costs )
- init-costs [ representation-cost ] with-vreg-reps costs get ;
+ init-costs
+ [
+ [ basic-block set ]
+ [
+ [
+ compute-insn-costs
+ ] each-non-phi
+ ] bi
+ ] each-basic-block
+ costs get ;
! For every vreg, compute preferred representation, that minimizes costs.
: minimize-costs ( costs -- representations )
+ [ nip assoc-empty? not ] assoc-filter
[ >alist alist-min first ] assoc-map ;
: compute-representations ( cfg -- )
bi assoc-union
representations set ;
+! PHI nodes require special treatment
+! If the output of a phi instruction is only used as the input to another
+! phi instruction, then we want to use the same representation for both
+! if possible.
+SYMBOL: phis
+
+: collect-phis ( cfg -- )
+ H{ } clone phis set
+ [
+ phis get
+ '[ [ inputs>> values ] [ dst>> ] bi _ set-at ] each-phi
+ ] each-basic-block ;
+
+SYMBOL: work-list
+
+: add-to-work-list ( vregs -- )
+ work-list get push-all-front ;
+
+: rep-assigned ( vregs -- vregs' )
+ representations get '[ _ key? ] filter ;
+
+: rep-not-assigned ( vregs -- vregs' )
+ representations get '[ _ key? not ] filter ;
+
+: add-ready-phis ( -- )
+ phis get keys rep-assigned add-to-work-list ;
+
+: process-phi ( dst -- )
+ ! If dst = phi(src1,src2,...) and dst's representation has been
+ ! determined, assign that representation to each one of src1,...
+ ! that does not have a representation yet, and process those, too.
+ dup phis get at* [
+ [ rep-of ] [ rep-not-assigned ] bi*
+ [ [ set-rep-of ] with each ] [ add-to-work-list ] bi
+ ] [ 2drop ] if ;
+
+: remaining-phis ( -- )
+ phis get keys rep-not-assigned { } assert-sequence= ;
+
+: process-phis ( -- )
+ <hashed-dlist> work-list set
+ add-ready-phis
+ work-list get [ process-phi ] slurp-deque
+ remaining-phis ;
+
+: compute-phi-representations ( cfg -- )
+ collect-phis process-phis ;
+
! Insert conversions. This introduces new temporaries, so we need
! to rename opearands too.
: record-renaming ( from to -- )
2array renaming-set get push needs-renaming? on ;
-:: (compute-renaming-set) ( ..a vreg required quot: ( ..a vreg preferred required -- ..b ) -- ..b )
+:: (compute-renaming-set) ( vreg required quot: ( vreg preferred required -- new-vreg ) -- )
vreg rep-of :> preferred
preferred required eq?
[ vreg no-renaming ]
GENERIC: conversions-for-insn ( insn -- )
-SYMBOL: phi-mappings
+M: ##phi conversions-for-insn , ;
-! compiler.cfg.cssa inserts conversions which convert phi inputs into
-! the representation of the output. However, we still have to do some
-! processing here, because if the only node that uses the output of
-! the phi instruction is another phi instruction then this phi node's
-! output won't have a representation assigned.
-M: ##phi conversions-for-insn
- [ , ] [ [ inputs>> values ] [ dst>> ] bi phi-mappings get set-at ] bi ;
+! When a float is unboxed, we replace the ##load-constant with a ##load-double
+! if the architecture supports it
+: convert-to-load-double? ( insn -- ? )
+ {
+ [ drop load-double? ]
+ [ dst>> rep-of double-rep? ]
+ [ obj>> float? ]
+ } 1&& ;
! When a literal zeroes/ones vector is unboxed, we replace the ##load-reference
! with a ##zero-vector or ##fill-vector instruction since this is more efficient.
[ dst>> rep-of vector-rep? ]
[ obj>> B{ 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 } = ]
} 1&& ;
+
: convert-to-fill-vector? ( insn -- ? )
{
[ dst>> rep-of vector-rep? ]
[ obj>> B{ 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 } = ]
} 1&& ;
+: (convert-to-load-double) ( insn -- dst val )
+ [ dst>> ] [ obj>> ] bi ; inline
+
: (convert-to-zero/fill-vector) ( insn -- dst rep )
dst>> dup rep-of ; inline
: conversions-for-load-insn ( insn -- ?insn )
{
+ {
+ [ dup convert-to-load-double? ]
+ [ (convert-to-load-double) ##load-double f ]
+ }
{
[ dup convert-to-zero-vector? ]
[ (convert-to-zero/fill-vector) ##zero-vector f ]
] change-instructions drop
] if ;
-! If the output of a phi instruction is only used as the input to another
-! phi instruction, then we want to use the same representation for both
-! if possible.
-SYMBOL: work-list
-
-: add-to-work-list ( vregs -- )
- work-list get push-all-front ;
-
-: rep-assigned ( vregs -- vregs' )
- representations get '[ _ key? ] filter ;
-
-: rep-not-assigned ( vregs -- vregs' )
- representations get '[ _ key? not ] filter ;
-
-: add-ready-phis ( -- )
- phi-mappings get keys rep-assigned add-to-work-list ;
-
-: process-phi-mapping ( dst -- )
- ! If dst = phi(src1,src2,...) and dst's representation has been
- ! determined, assign that representation to each one of src1,...
- ! that does not have a representation yet, and process those, too.
- dup phi-mappings get at* [
- [ rep-of ] [ rep-not-assigned ] bi*
- [ [ set-rep-of ] with each ] [ add-to-work-list ] bi
- ] [ 2drop ] if ;
-
-: remaining-phi-mappings ( -- )
- phi-mappings get keys rep-not-assigned
- [ [ int-rep ] dip set-rep-of ] each ;
-
-: process-phi-mappings ( -- )
- <hashed-dlist> work-list set
- add-ready-phis
- work-list get [ process-phi-mapping ] slurp-deque
- remaining-phi-mappings ;
-
: insert-conversions ( cfg -- )
- H{ } clone phi-mappings set
- [ conversions-for-block ] each-basic-block
- process-phi-mappings ;
+ [ conversions-for-block ] each-basic-block ;
PRIVATE>
{
[ compute-possibilities ]
[ compute-representations ]
+ [ compute-phi-representations ]
[ insert-conversions ]
[ ]
} cleave
CODEGEN: ##load-immediate %load-immediate
CODEGEN: ##load-reference %load-reference
CODEGEN: ##load-constant %load-reference
+CODEGEN: ##load-double %load-double
CODEGEN: ##peek %peek
CODEGEN: ##replace %replace
CODEGEN: ##inc-d %inc-d
: rel-word-pic-tail ( word class -- )
[ add-literal ] dip rt-entry-point-pic-tail rel-fixup ;
-: rel-immediate ( literal class -- )
+: rel-literal ( literal class -- )
[ add-literal ] dip rt-literal rel-fixup ;
+: rel-float ( literal class -- )
+ [ add-literal ] dip rt-float rel-fixup ;
+
: rel-this ( class -- )
rt-this rel-fixup ;
rt-vm
rt-cards-offset
rt-decks-offset
- rt-exception-handler ;
+ rt-exception-handler
+ rt-float ;
: rc-absolute? ( n -- ? )
${
integer generalize-counter-interval
] unit-test
-[ T{ interval f { 0 t } { $[ most-positive-fixnum ] t } } ] [
+[ T{ interval f { 0 t } { $[ max-array-capacity ] t } } ] [
T{ interval f { 1 t } { 1 t } }
T{ interval f { 0 t } { 0 t } }
fixnum generalize-counter-interval
! Mapping from register class to machine registers
HOOK: machine-registers cpu ( -- assoc )
-HOOK: %load-immediate cpu ( reg obj -- )
+HOOK: %load-immediate cpu ( reg val -- )
HOOK: %load-reference cpu ( reg obj -- )
+HOOK: %load-double cpu ( reg val -- )
HOOK: %peek cpu ( vreg loc -- )
HOOK: %replace cpu ( vreg loc -- )
M: stack-params param-reg 2drop ;
+! Does this architecture support %load-double?
+HOOK: load-double? cpu ( -- ? )
+
+M: object load-double? f ;
+
! Can this value be an immediate operand for %add-imm, %sub-imm,
! or %mul-imm?
HOOK: immediate-arithmetic? cpu ( n -- ? )
M: ppc %load-immediate ( reg n -- ) swap LOAD ;
M: ppc %load-reference ( reg obj -- )
- [ 0 swap LOAD32 ] [ rc-absolute-ppc-2/2 rel-immediate ] bi* ;
+ [ 0 swap LOAD32 ] [ rc-absolute-ppc-2/2 rel-literal ] bi* ;
M: ppc %alien-global ( register symbol dll -- )
[ 0 swap LOAD32 ] 2dip rc-absolute-ppc-2/2 rel-dlsym ;
FROM: layouts => cell ;
IN: cpu.x86.32
-M: x86.32 immediate-comparand? ( n -- ? )
- [ call-next-method ] [ word? ] bi or ;
-
M: x86.32 machine-registers
{
{ int-regs { EAX ECX EDX EBP EBX } }
M: x86.32 frame-reg EBP ;
M: x86.32 temp-reg ECX ;
+M: x86.32 immediate-comparand? ( n -- ? )
+ [ call-next-method ] [ word? ] bi or ;
+
+M: x86.32 load-double? ( -- ? ) t ;
+
+M: x86.32 %load-double ( dst val -- )
+ [ 0 [] MOVSD ] dip rc-absolute rel-float ;
+
M: x86.32 %mov-vm-ptr ( reg -- )
0 MOV 0 rc-absolute-cell rel-vm ;
M: x86 %load-immediate dup 0 = [ drop dup XOR ] [ MOV ] if ;
-M: x86 %load-reference swap 0 MOV rc-absolute-cell rel-immediate ;
+M: x86 %load-reference swap 0 MOV rc-absolute-cell rel-literal ;
HOOK: ds-reg cpu ( -- reg )
HOOK: rs-reg cpu ( -- reg )
:: (%boolean) ( dst temp insn -- )
dst \ f type-number MOV
- temp 0 MOV \ t rc-absolute-cell rel-immediate
+ temp 0 MOV \ t rc-absolute-cell rel-literal
dst temp insn execute ; inline
: %boolean ( dst cc temp -- )
[ register? ] [ 0 = ] [ { cc= cc/= } member? ] tri* and and ;
: (%compare-tagged) ( src1 src2 -- )
- [ HEX: ffffffff CMP ] dip rc-absolute rel-immediate ;
+ [ HEX: ffffffff CMP ] dip rc-absolute rel-literal ;
: (%compare-imm) ( src1 src2 cc -- )
{
case RT_LITERAL:
op.store_value(next_literal());
break;
+ case RT_FLOAT:
+ op.store_float(next_literal());
+ break;
case RT_ENTRY_POINT:
op.store_value(parent->compute_entry_point_address(next_literal()));
break;
case RT_LITERAL:
op.store_value(slot_forwarder.visit_pointer(op.load_value(old_offset)));
break;
+ case RT_FLOAT:
+ op.store_float(slot_forwarder.visit_pointer(op.load_float(old_offset)));
+ break;
case RT_ENTRY_POINT:
case RT_ENTRY_POINT_PIC:
case RT_ENTRY_POINT_PIC_TAIL:
case RT_LITERAL:
op.store_value(data_visitor.visit_pointer(op.load_value(old_offset)));
break;
+ case RT_FLOAT:
+ op.store_float(data_visitor.visit_pointer(op.load_float(old_offset)));
+ break;
case RT_ENTRY_POINT:
case RT_ENTRY_POINT_PIC:
case RT_ENTRY_POINT_PIC_TAIL:
return load_value(pointer);
}
+cell instruction_operand::load_float()
+{
+ return (cell)load_value() - boxed_float_offset;
+}
+
+cell instruction_operand::load_float(cell pointer)
+{
+ return (cell)load_value(pointer) - boxed_float_offset;
+}
+
code_block *instruction_operand::load_code_block(cell relative_to)
{
return ((code_block *)load_value(relative_to) - 1);
}
}
+void instruction_operand::store_float(cell value)
+{
+ store_value((fixnum)value + boxed_float_offset);
+}
+
void instruction_operand::store_code_block(code_block *compiled)
{
store_value((cell)compiled->entry_point());
type since its used in a situation where relocation arguments cannot
be passed in, and so RT_DLSYM is inappropriate (Windows only) */
RT_EXCEPTION_HANDLER,
+ /* pointer to a float's payload */
+ RT_FLOAT,
+
};
enum relocation_class {
case RT_CARDS_OFFSET:
case RT_DECKS_OFFSET:
case RT_EXCEPTION_HANDLER:
+ case RT_FLOAT:
return 0;
default:
critical_error("Bad rel type",rel_type());
fixnum load_value_masked(cell mask, cell bits, cell shift);
fixnum load_value(cell relative_to);
fixnum load_value();
+ cell load_float(cell relative_to);
+ cell load_float();
code_block *load_code_block(cell relative_to);
code_block *load_code_block();
void store_value_2_2(fixnum value);
void store_value_masked(fixnum value, cell mask, cell shift);
void store_value(fixnum value);
+ void store_float(cell value);
void store_code_block(code_block *compiled);
};
cell object;
};
+const fixnum boxed_float_offset = 8 - FLOAT_TYPE;
+
/* Assembly code makes assumptions about the layout of this struct */
struct boxed_float : object {
static const cell type_number = FLOAT_TYPE;
void operator()(instruction_operand op)
{
- if(op.rel_type() == RT_LITERAL)
+ switch(op.rel_type())
+ {
+ case RT_LITERAL:
op.store_value(visitor->visit_pointer(op.load_value()));
+ break;
+ case RT_FLOAT:
+ op.store_float(visitor->visit_pointer(op.load_float()));
+ break;
+ default:
+ break;
+ }
}
};
projects / factor.git / commitdiff