diff --git a/Makefile b/Makefile index aa520063e3..973ba1f3d4 100644 --- a/Makefile +++ b/Makefile @@ -170,7 +170,7 @@ vm/resources.o: $(CC) -c $(CFLAGS) -o $@ $< .S.o: - $(CC) -c $(CFLAGS) -o $@ $< + $(CC) -x assembler-with-cpp -c $(CFLAGS) -o $@ $< .m.o: $(CC) -c $(CFLAGS) -o $@ $< diff --git a/basis/alien/c-types/c-types.factor b/basis/alien/c-types/c-types.factor index 6a88441be9..a93c87611d 100644 --- a/basis/alien/c-types/c-types.factor +++ b/basis/alien/c-types/c-types.factor @@ -435,7 +435,7 @@ M: long-long-type box-return ( type -- ) [ >float ] >>unboxer-quot "double" define-primitive-type - os winnt? cpu x86.64? and "longlong" "long" ? "ptrdiff_t" typedef + "long" "ptrdiff_t" typedef "ulong" "size_t" typedef ] with-compilation-unit diff --git a/basis/alien/strings/strings-tests.factor b/basis/alien/strings/strings-tests.factor index 484809469f..c1a509041e 100644 --- a/basis/alien/strings/strings-tests.factor +++ b/basis/alien/strings/strings-tests.factor @@ -1,6 +1,6 @@ USING: alien.strings tools.test kernel libc io.encodings.8-bit io.encodings.utf8 io.encodings.utf16 -io.encodings.ascii alien ; +io.encodings.ascii alien io.encodings.string ; IN: alien.strings.tests [ "\u0000ff" ] @@ -28,3 +28,7 @@ unit-test ] unit-test [ f ] [ f utf8 alien>string ] unit-test + +[ "hello" ] [ "hello" utf16 encode utf16 decode ] unit-test + +[ "hello" ] [ "hello" utf16 string>alien utf16 alien>string ] unit-test diff --git a/basis/bootstrap/compiler/compiler.factor b/basis/bootstrap/compiler/compiler.factor index 0b44761f5c..dabdeea741 100644 --- a/basis/bootstrap/compiler/compiler.factor +++ b/basis/bootstrap/compiler/compiler.factor @@ -7,7 +7,7 @@ hashtables.private sequences.private math classes.tuple.private growable namespaces.private assocs words command-line vocabs io io.encodings.string prettyprint libc splitting math.parser compiler.units math.order compiler.tree.builder -compiler.tree.optimizer ; +compiler.tree.optimizer compiler.cfg.optimizer ; IN: bootstrap.compiler ! Don't bring this in when deploying, since it will store a @@ -89,10 +89,24 @@ nl . malloc calloc free memcpy } compile-uncompiled +"." write flush + { build-tree } compile-uncompiled +"." write flush + { optimize-tree } compile-uncompiled +"." write flush + +{ optimize-cfg } compile-uncompiled + +"." write flush + +{ (compile) } compile-uncompiled + +"." write flush + vocabs [ words compile-uncompiled "." write flush ] each " done" print flush diff --git a/basis/bootstrap/image/image.factor b/basis/bootstrap/image/image.factor index db8e8c8ec0..8b0051148f 100644 --- a/basis/bootstrap/image/image.factor +++ b/basis/bootstrap/image/image.factor @@ -8,12 +8,19 @@ grouping growable classes classes.builtin classes.tuple classes.tuple.private words.private io.binary io.files vocabs vocabs.loader source-files definitions debugger quotations.private sequences.private combinators -io.encodings.binary math.order math.private accessors slots.private ; +io.encodings.binary math.order math.private accessors +slots.private compiler.units ; IN: bootstrap.image +: arch ( os cpu -- arch ) + { + { "ppc" [ "-ppc" append ] } + { "x86.64" [ "winnt" = "winnt" "unix" ? "-x86.64" append ] } + [ nip ] + } case ; + : my-arch ( -- arch ) - cpu name>> - dup "ppc" = [ >r os name>> "-" r> 3append ] when ; + os name>> cpu name>> arch ; : boot-image-name ( arch -- string ) "boot." swap ".image" 3append ; @@ -24,7 +31,7 @@ IN: bootstrap.image : images ( -- seq ) { "x86.32" - "x86.64" + "winnt-x86.64" "unix-x86.64" "linux-ppc" "macosx-ppc" } ; @@ -367,31 +374,35 @@ M: byte-array ' M: tuple ' emit-tuple ; -M: tuple-layout ' - [ - [ - { - [ hashcode>> , ] - [ class>> , ] - [ size>> , ] - [ superclasses>> , ] - [ echelon>> , ] - } cleave - ] { } make [ ' ] map - \ tuple-layout type-number - object tag-number [ emit-seq ] emit-object - ] cache-object ; - M: tombstone ' state>> "((tombstone))" "((empty))" ? "hashtables.private" lookup def>> first [ emit-tuple ] cache-object ; ! Arrays -M: array ' +: emit-array ( array -- offset ) [ ' ] map array type-number object tag-number [ [ length emit-fixnum ] [ emit-seq ] bi ] emit-object ; +M: array ' emit-array ; + +! This is a hack. We need to detect arrays which are tuple +! layout arrays so that they can be internalized, but making +! them a built-in type is not worth it. +PREDICATE: tuple-layout-array < array + dup length 5 >= [ + [ first tuple-class? ] + [ second fixnum? ] + [ third fixnum? ] + tri and and + ] [ drop f ] if ; + +M: tuple-layout-array ' + [ + [ dup integer? [ ] when ] map + emit-array + ] cache-object ; + ! Quotations M: quotation ' @@ -458,6 +469,8 @@ M: quotation ' 800000 image set 20000 objects set emit-header t, 0, 1, -1, + "Building generic words..." print flush + call-remake-generics-hook "Serializing words..." print flush emit-words "Serializing JIT data..." print flush diff --git a/basis/bootstrap/random/random.factor b/basis/bootstrap/random/random.factor deleted file mode 100644 index f6527cdda1..0000000000 --- a/basis/bootstrap/random/random.factor +++ /dev/null @@ -1,16 +0,0 @@ -USING: vocabs.loader sequences system -random random.mersenne-twister combinators init -namespaces random ; -IN: bootstrap.random - -"random.mersenne-twister" require - -{ - { [ os windows? ] [ "random.windows" require ] } - { [ os unix? ] [ "random.unix" require ] } -} cond - -[ - [ 32 random-bits ] with-system-random - random-generator set-global -] "bootstrap.random" add-init-hook diff --git a/basis/bootstrap/stage2.factor b/basis/bootstrap/stage2.factor index 58ea725d1e..d25394e978 100644 --- a/basis/bootstrap/stage2.factor +++ b/basis/bootstrap/stage2.factor @@ -8,6 +8,8 @@ definitions assocs compiler.errors compiler.units math.parser generic sets debugger command-line ; IN: bootstrap.stage2 +SYMBOL: core-bootstrap-time + SYMBOL: bootstrap-time : default-image-name ( -- string ) @@ -30,11 +32,15 @@ SYMBOL: bootstrap-time : count-words ( pred -- ) all-words swap count number>string write ; -: print-report ( time -- ) +: print-time ( time -- ) 1000 /i 60 /mod swap - "Bootstrap completed in " write number>string write - " minutes and " write number>string write " seconds." print + number>string write + " minutes and " write number>string write " seconds." print ; + +: print-report ( -- ) + "Core bootstrap completed in " write core-bootstrap-time get print-time + "Bootstrap completed in " write bootstrap-time get print-time [ compiled>> ] count-words " compiled words" print [ symbol? ] count-words " symbol words" print @@ -46,11 +52,11 @@ SYMBOL: bootstrap-time [ ! We time bootstrap - millis >r + millis default-image-name "output-image" set-global - "math compiler threads help io tools ui ui.tools random unicode handbook" "include" set-global + "math compiler threads help io tools ui ui.tools unicode handbook" "include" set-global "" "exclude" set-global parse-command-line @@ -71,6 +77,8 @@ SYMBOL: bootstrap-time [ load-components + millis over - core-bootstrap-time set-global + run-bootstrap-init ] with-compiler-errors :errors @@ -92,7 +100,7 @@ SYMBOL: bootstrap-time ] [ print-error 1 exit ] recover ] set-boot-quot - millis r> - dup bootstrap-time set-global + millis swap - bootstrap-time set-global print-report "output-image" get save-image-and-exit diff --git a/basis/cocoa/messages/messages.factor b/basis/cocoa/messages/messages.factor index 3d7e1bfd84..09b2255913 100644 --- a/basis/cocoa/messages/messages.factor +++ b/basis/cocoa/messages/messages.factor @@ -1,10 +1,11 @@ ! Copyright (C) 2006, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors alien alien.c-types alien.strings arrays assocs -combinators compiler kernel math namespaces make parser -prettyprint prettyprint.sections quotations sequences strings -words cocoa.runtime io macros memoize debugger fry -io.encodings.ascii effects compiler.generator libc libc.private ; +combinators compiler compiler.alien kernel math namespaces make +parser prettyprint prettyprint.sections quotations sequences +strings words cocoa.runtime io macros memoize debugger +io.encodings.ascii effects libc libc.private parser lexer init +core-foundation fry ; IN: cocoa.messages : make-sender ( method function -- quot ) diff --git a/unfinished/compiler/alien/alien.factor b/basis/compiler/alien/alien.factor similarity index 100% rename from unfinished/compiler/alien/alien.factor rename to basis/compiler/alien/alien.factor diff --git a/basis/compiler/cfg/alias-analysis/alias-analysis-tests.factor b/basis/compiler/cfg/alias-analysis/alias-analysis-tests.factor new file mode 100644 index 0000000000..c7094c8c36 --- /dev/null +++ b/basis/compiler/cfg/alias-analysis/alias-analysis-tests.factor @@ -0,0 +1,56 @@ +USING: compiler.cfg.instructions compiler.cfg.registers +compiler.cfg.alias-analysis cpu.architecture tools.test +kernel ; +IN: compiler.cfg.alias-analysis.tests + +[ ] [ + { + T{ ##peek f V int-regs 2 D 1 f } + T{ ##box-alien f V int-regs 1 V int-regs 2 } + T{ ##slot-imm f V int-regs 3 V int-regs 1 0 3 } + } alias-analysis drop +] unit-test + +[ ] [ + { + T{ ##load-indirect f V int-regs 1 "hello" } + T{ ##slot-imm f V int-regs 0 V int-regs 1 0 3 } + } alias-analysis drop +] unit-test + +[ + { + T{ ##peek f V int-regs 1 D 1 f } + T{ ##peek f V int-regs 2 D 2 f } + T{ ##replace f V int-regs 1 D 0 f } + } +] [ + { + T{ ##peek f V int-regs 1 D 1 f } + T{ ##peek f V int-regs 2 D 2 f } + T{ ##replace f V int-regs 2 D 0 f } + T{ ##replace f V int-regs 1 D 0 f } + } alias-analysis +] unit-test + +[ + { + T{ ##peek f V int-regs 1 D 1 f } + T{ ##peek f V int-regs 2 D 0 f } + T{ ##copy f V int-regs 3 V int-regs 2 f } + T{ ##copy f V int-regs 4 V int-regs 1 f } + T{ ##replace f V int-regs 3 D 0 f } + T{ ##replace f V int-regs 4 D 1 f } + } +] [ + { + T{ ##peek f V int-regs 1 D 1 f } + T{ ##peek f V int-regs 2 D 0 f } + T{ ##replace f V int-regs 1 D 0 f } + T{ ##replace f V int-regs 2 D 1 f } + T{ ##peek f V int-regs 3 D 1 f } + T{ ##peek f V int-regs 4 D 0 f } + T{ ##replace f V int-regs 3 D 0 f } + T{ ##replace f V int-regs 4 D 1 f } + } alias-analysis +] unit-test diff --git a/unfinished/compiler/cfg.bluesky/alias/alias.factor b/basis/compiler/cfg/alias-analysis/alias-analysis.factor similarity index 70% rename from unfinished/compiler/cfg.bluesky/alias/alias.factor rename to basis/compiler/cfg/alias-analysis/alias-analysis.factor index 0ed0b49cc0..98569d868c 100644 --- a/unfinished/compiler/cfg.bluesky/alias/alias.factor +++ b/basis/compiler/cfg/alias-analysis/alias-analysis.factor @@ -1,10 +1,12 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel math namespaces assocs hashtables sequences -accessors vectors combinators sets compiler.vops compiler.cfg ; -IN: compiler.cfg.alias +accessors vectors combinators sets classes compiler.cfg +compiler.cfg.registers compiler.cfg.instructions +compiler.cfg.copy-prop ; +IN: compiler.cfg.alias-analysis -! Alias analysis -- must be run after compiler.cfg.stack. +! Alias analysis -- assumes compiler.cfg.height has already run. ! ! We try to eliminate redundant slot and stack ! traffic using some simple heuristics. @@ -69,8 +71,8 @@ SYMBOL: vregs>acs : check [ "BUG: static type error detected" throw ] unless* ; inline : vreg>ac ( vreg -- ac ) - #! Only vregs produced by %%allot, %peek and %%slot can - #! ever be used as valid inputs to %%slot and %%set-slot, + #! Only vregs produced by ##allot, ##peek and ##slot can + #! ever be used as valid inputs to ##slot and ##set-slot, #! so we assert this fact by not giving alias classes to #! other vregs. vregs>acs get at check ; @@ -175,31 +177,30 @@ SYMBOL: heap-ac [ kill-constant-set-slot ] 2bi ] [ nip kill-computed-set-slot ] if ; -SYMBOL: copies - -: resolve ( vreg -- vreg ) - dup copies get at swap or ; - SYMBOL: constants : constant ( vreg -- n/f ) - #! Return an %iconst value, or f if the vreg was not - #! assigned by an %iconst. + #! Return a ##load-immediate value, or f if the vreg was not + #! assigned by an ##load-immediate. resolve constants get at ; ! We treat slot accessors and stack traffic alike GENERIC: insn-slot# ( insn -- slot#/f ) GENERIC: insn-object ( insn -- vreg ) -M: %peek insn-slot# n>> ; -M: %replace insn-slot# n>> ; -M: %%slot insn-slot# slot>> constant ; -M: %%set-slot insn-slot# slot>> constant ; +M: ##peek insn-slot# loc>> n>> ; +M: ##replace insn-slot# loc>> n>> ; +M: ##slot insn-slot# slot>> constant ; +M: ##slot-imm insn-slot# slot>> ; +M: ##set-slot insn-slot# slot>> constant ; +M: ##set-slot-imm insn-slot# slot>> ; -M: %peek insn-object stack>> ; -M: %replace insn-object stack>> ; -M: %%slot insn-object obj>> resolve ; -M: %%set-slot insn-object obj>> resolve ; +M: ##peek insn-object loc>> class ; +M: ##replace insn-object loc>> class ; +M: ##slot insn-object obj>> resolve ; +M: ##slot-imm insn-object obj>> resolve ; +M: ##set-slot insn-object obj>> resolve ; +M: ##set-slot-imm insn-object obj>> resolve ; : init-alias-analysis ( -- ) H{ } clone histories set @@ -212,24 +213,37 @@ M: %%set-slot insn-object obj>> resolve ; 0 ac-counter set next-ac heap-ac set - %data next-ac set-ac - %retain next-ac set-ac ; + ds-loc next-ac set-ac + rs-loc next-ac set-ac ; -GENERIC: analyze-aliases ( insn -- insn' ) +GENERIC: analyze-aliases* ( insn -- insn' ) -M: %iconst analyze-aliases - dup [ value>> ] [ out>> ] bi constants get set-at ; +M: ##load-immediate analyze-aliases* + dup [ val>> ] [ dst>> ] bi constants get set-at ; -M: %%allot analyze-aliases +M: ##load-indirect analyze-aliases* + dup dst>> set-heap-ac ; + +M: ##allot analyze-aliases* #! A freshly allocated object is distinct from any other #! object. - dup out>> set-new-ac ; + dup dst>> set-new-ac ; -M: read-op analyze-aliases - dup out>> set-heap-ac - dup [ out>> ] [ insn-slot# ] [ insn-object ] tri +M: ##box-float analyze-aliases* + #! A freshly allocated object is distinct from any other + #! object. + dup dst>> set-new-ac ; + +M: ##box-alien analyze-aliases* + #! A freshly allocated object is distinct from any other + #! object. + dup dst>> set-new-ac ; + +M: ##read analyze-aliases* + dup dst>> set-heap-ac + dup [ dst>> ] [ insn-slot# ] [ insn-object ] tri 2dup live-slot dup [ - 2nip %copy boa analyze-aliases nip + 2nip f \ ##copy boa analyze-aliases* nip ] [ drop remember-slot ] if ; @@ -239,21 +253,20 @@ M: read-op analyze-aliases #! from? live-slot = ; -M: write-op analyze-aliases +M: ##write analyze-aliases* dup - [ in>> resolve ] [ insn-slot# ] [ insn-object ] tri - 3dup idempotent? [ - 2drop 2drop nop - ] [ - [ remember-set-slot drop ] [ load-slot ] 3bi - ] if ; + [ src>> resolve ] [ insn-slot# ] [ insn-object ] tri + [ remember-set-slot drop ] [ load-slot ] 3bi ; -M: %copy analyze-aliases +M: ##copy analyze-aliases* #! The output vreg gets the same alias class as the input #! vreg, since they both contain the same value. - dup [ in>> resolve ] [ out>> ] bi copies get set-at ; + dup record-copy ; -M: vop analyze-aliases ; +M: insn analyze-aliases* ; + +: analyze-aliases ( insns -- insns' ) + [ insn# set analyze-aliases* ] map-index sift ; SYMBOL: live-stores @@ -264,30 +277,35 @@ SYMBOL: live-stores ] map concat unique live-stores set ; -GENERIC: eliminate-dead-store ( insn -- insn' ) +GENERIC: eliminate-dead-stores* ( insn -- insn' ) -: (eliminate-dead-store) ( insn -- insn' ) +: (eliminate-dead-stores) ( insn -- insn' ) dup insn-slot# [ insn# get live-stores get key? [ - drop nop + drop f ] unless ] when ; -M: %replace eliminate-dead-store +M: ##replace eliminate-dead-stores* #! Writes to above the top of the stack can be pruned also. #! This is sound since any such writes are not observable #! after the basic block, and any reads of those locations #! will have been converted to copies by analyze-slot, #! and the final stack height of the basic block is set at #! the beginning by compiler.cfg.stack. - dup n>> 0 < [ drop nop ] [ (eliminate-dead-store) ] if ; + dup loc>> n>> 0 < [ drop f ] [ (eliminate-dead-stores) ] if ; -M: %%set-slot eliminate-dead-store (eliminate-dead-store) ; +M: ##set-slot eliminate-dead-stores* (eliminate-dead-stores) ; -M: vop eliminate-dead-store ; +M: ##set-slot-imm eliminate-dead-stores* (eliminate-dead-stores) ; + +M: insn eliminate-dead-stores* ; + +: eliminate-dead-stores ( insns -- insns' ) + [ insn# set eliminate-dead-stores* ] map-index sift ; : alias-analysis ( insns -- insns' ) init-alias-analysis - [ insn# set analyze-aliases ] map-index + analyze-aliases compute-live-stores - [ insn# set eliminate-dead-store ] map-index ; + eliminate-dead-stores ; diff --git a/basis/compiler/generator/authors.txt b/basis/compiler/cfg/builder/authors.txt similarity index 100% rename from basis/compiler/generator/authors.txt rename to basis/compiler/cfg/builder/authors.txt diff --git a/basis/compiler/cfg/builder/builder-tests.factor b/basis/compiler/cfg/builder/builder-tests.factor new file mode 100644 index 0000000000..c3cce1425e --- /dev/null +++ b/basis/compiler/cfg/builder/builder-tests.factor @@ -0,0 +1,105 @@ +IN: compiler.cfg.builder.tests +USING: tools.test kernel sequences +words sequences.private fry prettyprint alien alien.accessors +math.private compiler.tree.builder compiler.tree.optimizer +compiler.cfg.builder compiler.cfg.debugger arrays locals byte-arrays +kernel.private math ; + +\ build-cfg must-infer + +! Just ensure that various CFGs build correctly. +: unit-test-cfg ( quot -- ) '[ _ test-cfg drop ] [ ] swap unit-test ; + +{ + [ ] + [ dup ] + [ swap ] + [ >r r> ] + [ fixnum+ ] + [ fixnum+fast ] + [ 3 fixnum+fast ] + [ fixnum*fast ] + [ 3 fixnum*fast ] + [ fixnum-shift-fast ] + [ 10 fixnum-shift-fast ] + [ -10 fixnum-shift-fast ] + [ 0 fixnum-shift-fast ] + [ fixnum-bitnot ] + [ eq? ] + [ "hi" eq? ] + [ fixnum< ] + [ 5 fixnum< ] + [ float+ ] + [ 3.0 float+ ] + [ float<= ] + [ fixnum>bignum ] + [ bignum>fixnum ] + [ fixnum>float ] + [ float>fixnum ] + [ 3 f ] + [ [ 1 ] [ 2 ] if ] + [ fixnum< [ 1 ] [ 2 ] if ] + [ float+ [ 2.0 float* ] [ 3.0 float* ] bi float/f ] + [ { [ 1 ] [ 2 ] [ 3 ] } dispatch ] + [ [ t ] loop ] + [ [ dup ] loop ] + [ [ 2 ] [ 3 throw ] if 4 ] + [ "int" f "malloc" { "int" } alien-invoke ] + [ "int" { "int" } "cdecl" alien-indirect ] + [ "int" { "int" } "cdecl" [ ] alien-callback ] +} [ + unit-test-cfg +] each + +: test-1 ( -- ) test-1 ; +: test-2 ( -- ) 3 . test-2 ; +: test-3 ( a -- b ) dup [ test-3 ] when ; + +{ + test-1 + test-2 + test-3 +} [ unit-test-cfg ] each + +{ + byte-array + simple-alien + alien + POSTPONE: f +} [| class | + { + alien-signed-1 + alien-signed-2 + alien-signed-4 + alien-unsigned-1 + alien-unsigned-2 + alien-unsigned-4 + alien-cell + alien-float + alien-double + } [| word | + { class } word '[ _ declare 10 _ execute ] unit-test-cfg + { class fixnum } word '[ _ declare _ execute ] unit-test-cfg + ] each + + { + set-alien-signed-1 + set-alien-signed-2 + set-alien-signed-4 + set-alien-unsigned-1 + set-alien-unsigned-2 + set-alien-unsigned-4 + } [| word | + { fixnum class } word '[ _ declare 10 _ execute ] unit-test-cfg + { fixnum class fixnum } word '[ _ declare _ execute ] unit-test-cfg + ] each + + { float class } \ set-alien-float '[ _ declare 10 _ execute ] unit-test-cfg + { float class fixnum } \ set-alien-float '[ _ declare _ execute ] unit-test-cfg + + { float class } \ set-alien-double '[ _ declare 10 _ execute ] unit-test-cfg + { float class fixnum } \ set-alien-double '[ _ declare _ execute ] unit-test-cfg + + { pinned-c-ptr class } \ set-alien-cell '[ _ declare 10 _ execute ] unit-test-cfg + { pinned-c-ptr class fixnum } \ set-alien-cell '[ _ declare _ execute ] unit-test-cfg +] each diff --git a/basis/compiler/cfg/builder/builder.factor b/basis/compiler/cfg/builder/builder.factor new file mode 100755 index 0000000000..17a5942af2 --- /dev/null +++ b/basis/compiler/cfg/builder/builder.factor @@ -0,0 +1,297 @@ +! Copyright (C) 2004, 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors arrays assocs combinators hashtables kernel +math fry namespaces make sequences words byte-arrays +layouts alien.c-types alien.structs +stack-checker.inlining cpu.architecture +compiler.tree +compiler.tree.builder +compiler.tree.combinators +compiler.tree.propagation.info +compiler.cfg +compiler.cfg.hats +compiler.cfg.stacks +compiler.cfg.iterator +compiler.cfg.utilities +compiler.cfg.registers +compiler.cfg.intrinsics +compiler.cfg.instructions +compiler.alien ; +IN: compiler.cfg.builder + +! Convert tree SSA IR to CFG SSA IR. + +: stop-iterating ( -- next ) end-basic-block f ; + +SYMBOL: procedures +SYMBOL: current-word +SYMBOL: current-label +SYMBOL: loops +SYMBOL: first-basic-block + +! Basic block after prologue, makes recursion faster +SYMBOL: current-label-start + +: add-procedure ( -- ) + basic-block get current-word get current-label get + procedures get push ; + +: begin-procedure ( word label -- ) + end-basic-block + begin-basic-block + H{ } clone loops set + current-label set + current-word set + add-procedure ; + +: with-cfg-builder ( nodes word label quot -- ) + '[ begin-procedure @ ] with-scope ; inline + +GENERIC: emit-node ( node -- next ) + +: check-basic-block ( node -- node' ) + basic-block get [ drop f ] unless ; inline + +: emit-nodes ( nodes -- ) + [ current-node emit-node check-basic-block ] iterate-nodes ; + +: begin-word ( -- ) + #! We store the basic block after the prologue as a loop + #! labelled by the current word, so that self-recursive + #! calls can skip an epilogue/prologue. + ##prologue + ##branch + begin-basic-block + basic-block get first-basic-block set ; + +: (build-cfg) ( nodes word label -- ) + [ + begin-word + V{ } clone node-stack set + emit-nodes + ] with-cfg-builder ; + +: build-cfg ( nodes word -- procedures ) + V{ } clone [ + procedures [ + dup (build-cfg) + ] with-variable + ] keep ; + +: local-recursive-call ( basic-block -- next ) + ##branch + basic-block get successors>> push + stop-iterating ; + +: emit-call ( word -- next ) + { + { [ dup loops get key? ] [ loops get at local-recursive-call ] } + { [ tail-call? not ] [ ##call ##branch begin-basic-block iterate-next ] } + { [ dup current-label get eq? ] [ drop first-basic-block get local-recursive-call ] } + [ ##epilogue ##jump stop-iterating ] + } cond ; + +! #recursive +: compile-recursive ( node -- next ) + [ label>> id>> emit-call ] + [ [ child>> ] [ label>> word>> ] [ label>> id>> ] tri (build-cfg) ] bi ; + +: remember-loop ( label -- ) + basic-block get swap loops get set-at ; + +: compile-loop ( node -- next ) + ##loop-entry + begin-basic-block + [ label>> id>> remember-loop ] [ child>> emit-nodes ] bi + iterate-next ; + +M: #recursive emit-node + dup label>> loop?>> [ compile-loop ] [ compile-recursive ] if ; + +! #if +: emit-branch ( obj -- final-bb ) + [ + begin-basic-block + emit-nodes + basic-block get dup [ ##branch ] when + ] with-scope ; + +: emit-if ( node -- ) + children>> [ emit-branch ] map + end-basic-block + begin-basic-block + basic-block get '[ [ _ swap successors>> push ] when* ] each ; + +: ##branch-t ( vreg -- ) + \ f tag-number cc/= ##compare-imm-branch ; + +: trivial-branch? ( nodes -- value ? ) + dup length 1 = [ + first dup #push? [ literal>> t ] [ drop f f ] if + ] [ drop f f ] if ; + +: trivial-if? ( #if -- ? ) + children>> first2 + [ trivial-branch? [ t eq? ] when ] + [ trivial-branch? [ f eq? ] when ] bi* + and ; + +: emit-trivial-if ( -- ) + ds-pop \ f tag-number cc/= ^^compare-imm ds-push ; + +: trivial-not-if? ( #if -- ? ) + children>> first2 + [ trivial-branch? [ f eq? ] when ] + [ trivial-branch? [ t eq? ] when ] bi* + and ; + +: emit-trivial-not-if ( -- ) + ds-pop \ f tag-number cc= ^^compare-imm ds-push ; + +M: #if emit-node + { + { [ dup trivial-if? ] [ drop emit-trivial-if ] } + { [ dup trivial-not-if? ] [ drop emit-trivial-not-if ] } + [ ds-pop ##branch-t emit-if ] + } cond iterate-next ; + +! #dispatch +: trivial-dispatch-branch? ( nodes -- ? ) + dup length 1 = [ + first dup #call? [ + word>> "intrinsic" word-prop not + ] [ drop f ] if + ] [ drop f ] if ; + +: dispatch-branch ( nodes word -- label ) + over trivial-dispatch-branch? [ + drop first word>> + ] [ + gensym [ + [ + V{ } clone node-stack set + ##prologue + begin-basic-block + emit-nodes + basic-block get [ + ##epilogue + ##return + end-basic-block + ] when + ] with-cfg-builder + ] keep + ] if ; + +: dispatch-branches ( node -- ) + children>> [ + current-word get dispatch-branch + ##dispatch-label + ] each ; + +: emit-dispatch ( node -- ) + ##epilogue + ds-pop ^^offset>slot i ##dispatch + dispatch-branches ; + +: ( -- word ) + gensym dup t "inlined-block" set-word-prop ; + +M: #dispatch emit-node + tail-call? [ + emit-dispatch stop-iterating + ] [ + current-word get [ + [ + begin-word + emit-dispatch + ] with-cfg-builder + ] keep emit-call + ] if ; + +! #call +M: #call emit-node + dup word>> dup "intrinsic" word-prop + [ emit-intrinsic iterate-next ] [ nip emit-call ] if ; + +! #call-recursive +M: #call-recursive emit-node label>> id>> emit-call ; + +! #push +M: #push emit-node + literal>> ^^load-literal ds-push iterate-next ; + +! #shuffle +: emit-shuffle ( effect -- ) + [ out>> ] [ in>> dup length ds-load zip ] bi + '[ _ at ] map ds-store ; + +M: #shuffle emit-node + shuffle-effect emit-shuffle iterate-next ; + +M: #>r emit-node + [ in-d>> length ] [ out-r>> empty? ] bi + [ neg ##inc-d ] [ ds-load rs-store ] if + iterate-next ; + +M: #r> emit-node + [ in-r>> length ] [ out-d>> empty? ] bi + [ neg ##inc-r ] [ rs-load ds-store ] if + iterate-next ; + +! #return +M: #return emit-node + drop ##epilogue ##return stop-iterating ; + +M: #return-recursive emit-node + label>> id>> loops get key? + [ iterate-next ] [ ##epilogue ##return stop-iterating ] if ; + +! #terminate +M: #terminate emit-node drop stop-iterating ; + +! FFI +: return-size ( ctype -- n ) + #! Amount of space we reserve for a return value. + { + { [ dup c-struct? not ] [ drop 0 ] } + { [ dup large-struct? not ] [ drop 2 cells ] } + [ heap-size ] + } cond ; + +: ( params -- stack-frame ) + stack-frame new + swap + [ return>> return-size >>return ] + [ alien-parameters parameter-sizes drop >>params ] bi ; + +: alien-stack-frame ( params -- ) + ##stack-frame ; + +: emit-alien-node ( node quot -- next ) + [ params>> ] dip [ drop alien-stack-frame ] [ call ] 2bi + begin-basic-block iterate-next ; inline + +M: #alien-invoke emit-node + [ ##alien-invoke ] emit-alien-node ; + +M: #alien-indirect emit-node + [ ##alien-indirect ] emit-alien-node ; + +M: #alien-callback emit-node + dup params>> xt>> dup + [ + ##prologue + dup [ ##alien-callback ] emit-alien-node drop + ##epilogue + params>> ##callback-return + ] with-cfg-builder + iterate-next ; + +! No-op nodes +M: #introduce emit-node drop iterate-next ; + +M: #copy emit-node drop iterate-next ; + +M: #enter-recursive emit-node drop iterate-next ; + +M: #phi emit-node drop iterate-next ; diff --git a/basis/compiler/generator/summary.txt b/basis/compiler/cfg/builder/summary.txt similarity index 100% rename from basis/compiler/generator/summary.txt rename to basis/compiler/cfg/builder/summary.txt diff --git a/basis/compiler/generator/tags.txt b/basis/compiler/cfg/builder/tags.txt similarity index 100% rename from basis/compiler/generator/tags.txt rename to basis/compiler/cfg/builder/tags.txt diff --git a/unfinished/compiler/cfg/cfg.factor b/basis/compiler/cfg/cfg.factor similarity index 53% rename from unfinished/compiler/cfg/cfg.factor rename to basis/compiler/cfg/cfg.factor index e32ad47890..054b4f7ed0 100644 --- a/unfinished/compiler/cfg/cfg.factor +++ b/basis/compiler/cfg/cfg.factor @@ -1,25 +1,27 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel accessors namespaces assocs sequences sets fry ; +USING: kernel arrays vectors accessors namespaces ; IN: compiler.cfg -TUPLE: cfg entry word label ; - -C: cfg - -! - "number" and "visited" is used by linearization. TUPLE: basic-block < identity-tuple -visited +id number -instructions -successors ; +{ instructions vector } +{ successors vector } +{ predecessors vector } ; : ( -- basic-block ) basic-block new V{ } clone >>instructions - V{ } clone >>successors ; + V{ } clone >>successors + V{ } clone >>predecessors + \ basic-block counter >>id ; -TUPLE: mr instructions word label ; +TUPLE: cfg { entry basic-block } word label ; + +C: cfg + +TUPLE: mr { instructions array } word label spill-counts ; : ( instructions word label -- mr ) mr new diff --git a/basis/compiler/cfg/copy-prop/copy-prop.factor b/basis/compiler/cfg/copy-prop/copy-prop.factor new file mode 100644 index 0000000000..52cc75f047 --- /dev/null +++ b/basis/compiler/cfg/copy-prop/copy-prop.factor @@ -0,0 +1,12 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel namespaces assocs accessors ; +IN: compiler.cfg.copy-prop + +SYMBOL: copies + +: resolve ( vreg -- vreg ) + dup copies get at swap or ; + +: record-copy ( insn -- ) + [ src>> resolve ] [ dst>> ] bi copies get set-at ; inline diff --git a/basis/compiler/cfg/dead-code/dead-code-tests.factor b/basis/compiler/cfg/dead-code/dead-code-tests.factor new file mode 100644 index 0000000000..b9c3af5215 --- /dev/null +++ b/basis/compiler/cfg/dead-code/dead-code-tests.factor @@ -0,0 +1,8 @@ +USING: compiler.cfg.dead-code compiler.cfg.instructions +compiler.cfg.registers cpu.architecture tools.test ; +IN: compiler.cfg.dead-code.tests + +[ { } ] [ + { T{ ##load-immediate f V int-regs 134 16 } } + eliminate-dead-code +] unit-test diff --git a/basis/compiler/cfg/dead-code/dead-code.factor b/basis/compiler/cfg/dead-code/dead-code.factor new file mode 100644 index 0000000000..73aa7b4a5a --- /dev/null +++ b/basis/compiler/cfg/dead-code/dead-code.factor @@ -0,0 +1,61 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors assocs sets kernel namespaces sequences +compiler.cfg.instructions compiler.cfg.def-use ; +IN: compiler.cfg.dead-code + +! Dead code elimination -- assumes compiler.cfg.alias-analysis +! has already run. + +! Maps vregs to sequences of vregs +SYMBOL: liveness-graph + +! vregs which participate in side effects and thus are always live +SYMBOL: live-vregs + +! mapping vregs to stack locations +SYMBOL: vregs>locs + +: init-dead-code ( -- ) + H{ } clone liveness-graph set + H{ } clone live-vregs set + H{ } clone vregs>locs set ; + +GENERIC: compute-liveness ( insn -- ) + +M: ##flushable compute-liveness + [ uses-vregs ] [ dst>> ] bi liveness-graph get set-at ; + +M: ##peek compute-liveness + [ [ loc>> ] [ dst>> ] bi vregs>locs get set-at ] + [ call-next-method ] + bi ; + +: live-replace? ( ##replace -- ? ) + [ src>> vregs>locs get at ] [ loc>> ] bi = not ; + +M: ##replace compute-liveness + dup live-replace? [ call-next-method ] [ drop ] if ; + +: record-live ( vregs -- ) + [ + dup live-vregs get key? [ drop ] [ + [ live-vregs get conjoin ] + [ liveness-graph get at record-live ] + bi + ] if + ] each ; + +M: insn compute-liveness uses-vregs record-live ; + +GENERIC: live-insn? ( insn -- ? ) + +M: ##flushable live-insn? dst>> live-vregs get key? ; + +M: ##replace live-insn? live-replace? ; + +M: insn live-insn? drop t ; + +: eliminate-dead-code ( insns -- insns' ) + init-dead-code + [ [ compute-liveness ] each ] [ [ live-insn? ] filter ] bi ; diff --git a/basis/compiler/cfg/debugger/debugger.factor b/basis/compiler/cfg/debugger/debugger.factor new file mode 100644 index 0000000000..7b1b9100c4 --- /dev/null +++ b/basis/compiler/cfg/debugger/debugger.factor @@ -0,0 +1,42 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel words sequences quotations namespaces io +classes.tuple accessors prettyprint prettyprint.config +compiler.tree.builder compiler.tree.optimizer +compiler.cfg.builder compiler.cfg.linearization +compiler.cfg.stack-frame compiler.cfg.linear-scan +compiler.cfg.two-operand compiler.cfg.optimizer ; +IN: compiler.cfg.debugger + +GENERIC: test-cfg ( quot -- cfgs ) + +M: callable test-cfg + build-tree optimize-tree gensym build-cfg ; + +M: word test-cfg + [ build-tree-from-word nip optimize-tree ] keep build-cfg ; + +SYMBOL: allocate-registers? + +: test-mr ( quot -- mrs ) + test-cfg [ + optimize-cfg + build-mr + convert-two-operand + allocate-registers? get + [ linear-scan build-stack-frame ] when + ] map ; + +: insn. ( insn -- ) + tuple>array allocate-registers? get [ but-last ] unless + [ pprint bl ] each nl ; + +: mr. ( mrs -- ) + [ + "=== word: " write + dup word>> pprint + ", label: " write + dup label>> pprint nl nl + instructions>> [ insn. ] each + nl + ] each ; diff --git a/basis/compiler/cfg/def-use/def-use.factor b/basis/compiler/cfg/def-use/def-use.factor new file mode 100644 index 0000000000..7553407e00 --- /dev/null +++ b/basis/compiler/cfg/def-use/def-use.factor @@ -0,0 +1,46 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors arrays kernel compiler.cfg.instructions ; +IN: compiler.cfg.def-use + +GENERIC: defs-vregs ( insn -- seq ) +GENERIC: uses-vregs ( insn -- seq ) + +: dst/tmp-vregs ( insn -- seq ) [ dst>> ] [ temp>> ] bi 2array ; +M: ##flushable defs-vregs dst>> 1array ; +M: ##write-barrier defs-vregs [ card#>> ] [ table>> ] bi 2array ; +M: ##unary/temp defs-vregs dst/tmp-vregs ; +M: ##allot defs-vregs dst/tmp-vregs ; +M: ##dispatch defs-vregs temp>> 1array ; +M: ##slot defs-vregs [ dst>> ] [ temp>> ] bi 2array ; +M: ##set-slot defs-vregs temp>> 1array ; +M: ##string-nth defs-vregs [ dst>> ] [ temp>> ] bi 2array ; +M: insn defs-vregs drop f ; + +M: ##unary uses-vregs src>> 1array ; +M: ##binary uses-vregs [ src1>> ] [ src2>> ] bi 2array ; +M: ##binary-imm uses-vregs src1>> 1array ; +M: ##effect uses-vregs src>> 1array ; +M: ##slot uses-vregs [ obj>> ] [ slot>> ] bi 2array ; +M: ##slot-imm uses-vregs obj>> 1array ; +M: ##set-slot uses-vregs [ src>> ] [ obj>> ] [ slot>> ] tri 3array ; +M: ##set-slot-imm uses-vregs [ src>> ] [ obj>> ] bi 2array ; +M: ##string-nth uses-vregs [ obj>> ] [ index>> ] bi 2array ; +M: ##conditional-branch uses-vregs [ src1>> ] [ src2>> ] bi 2array ; +M: ##compare-imm-branch uses-vregs src1>> 1array ; +M: ##dispatch uses-vregs src>> 1array ; +M: ##alien-getter uses-vregs src>> 1array ; +M: ##alien-setter uses-vregs [ src>> ] [ value>> ] bi 2array ; +M: _conditional-branch uses-vregs [ src1>> ] [ src2>> ] bi 2array ; +M: _compare-imm-branch uses-vregs src1>> 1array ; +M: insn uses-vregs drop f ; + +UNION: vreg-insn +##flushable +##write-barrier +##dispatch +##effect +##conditional-branch +##compare-imm-branch +_conditional-branch +_compare-imm-branch ; diff --git a/basis/compiler/cfg/hats/hats.factor b/basis/compiler/cfg/hats/hats.factor new file mode 100644 index 0000000000..e6e05abbd5 --- /dev/null +++ b/basis/compiler/cfg/hats/hats.factor @@ -0,0 +1,73 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: arrays byte-arrays kernel layouts math namespaces +sequences classes.tuple cpu.architecture compiler.cfg.registers +compiler.cfg.instructions ; +IN: compiler.cfg.hats + +: i int-regs next-vreg ; inline +: ^^i i dup ; inline +: ^^i1 [ ^^i ] dip ; inline +: ^^i2 [ ^^i ] 2dip ; inline +: ^^i3 [ ^^i ] 3dip ; inline + +: d double-float-regs next-vreg ; inline +: ^^d d dup ; inline +: ^^d1 [ ^^d ] dip ; inline +: ^^d2 [ ^^d ] 2dip ; inline +: ^^d3 [ ^^d ] 3dip ; inline + +: ^^load-literal ( obj -- dst ) ^^i1 ##load-literal ; inline +: ^^peek ( loc -- dst ) ^^i1 ##peek ; inline +: ^^slot ( obj slot tag -- dst ) ^^i3 i ##slot ; inline +: ^^slot-imm ( obj slot tag -- dst ) ^^i3 ##slot-imm ; inline +: ^^set-slot ( src obj slot tag -- ) i ##set-slot ; inline +: ^^string-nth ( obj index -- dst ) ^^i2 i ##string-nth ; inline +: ^^add ( src1 src2 -- dst ) ^^i2 ##add ; inline +: ^^add-imm ( src1 src2 -- dst ) ^^i2 ##add-imm ; inline +: ^^sub ( src1 src2 -- dst ) ^^i2 ##sub ; inline +: ^^sub-imm ( src1 src2 -- dst ) ^^i2 ##sub-imm ; inline +: ^^mul ( src1 src2 -- dst ) ^^i2 ##mul ; inline +: ^^mul-imm ( src1 src2 -- dst ) ^^i2 ##mul-imm ; inline +: ^^and ( input mask -- output ) ^^i2 ##and ; inline +: ^^and-imm ( input mask -- output ) ^^i2 ##and-imm ; inline +: ^^or ( src1 src2 -- dst ) ^^i2 ##or ; inline +: ^^or-imm ( src1 src2 -- dst ) ^^i2 ##or-imm ; inline +: ^^xor ( src1 src2 -- dst ) ^^i2 ##xor ; inline +: ^^xor-imm ( src1 src2 -- dst ) ^^i2 ##xor-imm ; inline +: ^^shl-imm ( src1 src2 -- dst ) ^^i2 ##shl-imm ; inline +: ^^shr-imm ( src1 src2 -- dst ) ^^i2 ##shr-imm ; inline +: ^^sar-imm ( src1 src2 -- dst ) ^^i2 ##sar-imm ; inline +: ^^not ( src -- dst ) ^^i1 ##not ; inline +: ^^bignum>integer ( src -- dst ) ^^i1 i ##bignum>integer ; inline +: ^^integer>bignum ( src -- dst ) ^^i1 i ##integer>bignum ; inline +: ^^add-float ( src1 src2 -- dst ) ^^d2 ##add-float ; inline +: ^^sub-float ( src1 src2 -- dst ) ^^d2 ##sub-float ; inline +: ^^mul-float ( src1 src2 -- dst ) ^^d2 ##mul-float ; inline +: ^^div-float ( src1 src2 -- dst ) ^^d2 ##div-float ; inline +: ^^float>integer ( src -- dst ) ^^i1 ##float>integer ; inline +: ^^integer>float ( src -- dst ) ^^d1 ##integer>float ; inline +: ^^allot ( size class -- dst ) ^^i2 i ##allot ; inline +: ^^allot-tuple ( n -- dst ) 2 + cells tuple ^^allot ; inline +: ^^allot-array ( n -- dst ) 2 + cells array ^^allot ; inline +: ^^allot-byte-array ( n -- dst ) 2 cells + byte-array ^^allot ; inline +: ^^box-float ( src -- dst ) ^^i1 i ##box-float ; inline +: ^^unbox-float ( src -- dst ) ^^d1 ##unbox-float ; inline +: ^^box-alien ( src -- dst ) ^^i1 i ##box-alien ; inline +: ^^unbox-alien ( src -- dst ) ^^i1 ##unbox-alien ; inline +: ^^unbox-c-ptr ( src class -- dst ) ^^i2 i ##unbox-c-ptr ; +: ^^alien-unsigned-1 ( src -- dst ) ^^i1 ##alien-unsigned-1 ; inline +: ^^alien-unsigned-2 ( src -- dst ) ^^i1 ##alien-unsigned-2 ; inline +: ^^alien-unsigned-4 ( src -- dst ) ^^i1 ##alien-unsigned-4 ; inline +: ^^alien-signed-1 ( src -- dst ) ^^i1 ##alien-signed-1 ; inline +: ^^alien-signed-2 ( src -- dst ) ^^i1 ##alien-signed-2 ; inline +: ^^alien-signed-4 ( src -- dst ) ^^i1 ##alien-signed-4 ; inline +: ^^alien-cell ( src -- dst ) ^^i1 ##alien-cell ; inline +: ^^alien-float ( src -- dst ) ^^d1 ##alien-float ; inline +: ^^alien-double ( src -- dst ) ^^d1 ##alien-double ; inline +: ^^compare ( src1 src2 cc -- dst ) ^^i3 ##compare ; inline +: ^^compare-imm ( src1 src2 cc -- dst ) ^^i3 ##compare-imm ; inline +: ^^compare-float ( src1 src2 cc -- dst ) ^^i3 ##compare-float ; inline +: ^^offset>slot ( vreg -- vreg' ) cell 4 = [ 1 ^^shr-imm ] when ; inline +: ^^tag-fixnum ( src -- dst ) ^^i1 ##tag-fixnum ; inline +: ^^untag-fixnum ( src -- dst ) ^^i1 ##untag-fixnum ; inline diff --git a/basis/compiler/cfg/height/height.factor b/basis/compiler/cfg/height/height.factor new file mode 100644 index 0000000000..9312f6f133 --- /dev/null +++ b/basis/compiler/cfg/height/height.factor @@ -0,0 +1,51 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors math namespaces sequences kernel fry +compiler.cfg compiler.cfg.registers compiler.cfg.instructions ; +IN: compiler.cfg.height + +! Combine multiple stack height changes into one at the +! start of the basic block. + +SYMBOL: ds-height +SYMBOL: rs-height + +GENERIC: compute-heights ( insn -- ) + +M: ##inc-d compute-heights n>> ds-height [ + ] change ; +M: ##inc-r compute-heights n>> rs-height [ + ] change ; +M: insn compute-heights drop ; + +GENERIC: normalize-height* ( insn -- insn' ) + +: normalize-inc-d/r ( insn stack -- insn' ) + swap n>> '[ _ - ] change f ; inline + +M: ##inc-d normalize-height* ds-height normalize-inc-d/r ; +M: ##inc-r normalize-height* rs-height normalize-inc-d/r ; + +GENERIC: loc-stack ( loc -- stack ) + +M: ds-loc loc-stack drop ds-height ; +M: rs-loc loc-stack drop rs-height ; + +GENERIC: ( n stack -- loc ) + +M: ds-loc drop ; +M: rs-loc drop ; + +: normalize-peek/replace ( insn -- insn' ) + [ [ [ n>> ] [ loc-stack get ] bi + ] keep ] change-loc ; inline + +M: ##peek normalize-height* normalize-peek/replace ; +M: ##replace normalize-height* normalize-peek/replace ; + +M: insn normalize-height* ; + +: normalize-height ( insns -- insns' ) + 0 ds-height set + 0 rs-height set + [ [ compute-heights ] each ] + [ [ [ normalize-height* ] map sift ] with-scope ] bi + ds-height get dup zero? [ drop ] [ f \ ##inc-d boa prefix ] if + rs-height get dup zero? [ drop ] [ f \ ##inc-r boa prefix ] if ; diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor new file mode 100644 index 0000000000..c39f517671 --- /dev/null +++ b/basis/compiler/cfg/instructions/instructions.factor @@ -0,0 +1,228 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: assocs accessors arrays kernel sequences namespaces words +math math.order layouts classes.algebra alien byte-arrays +compiler.constants combinators compiler.cfg.registers +compiler.cfg.instructions.syntax ; +IN: compiler.cfg.instructions + +! Virtual CPU instructions, used by CFG and machine IRs +TUPLE: insn ; + +! Instruction with no side effects; if 'out' is never read, we +! can eliminate it. +TUPLE: ##flushable < insn { dst vreg } ; + +! Instruction which is referentially transparent; we can replace +! repeated computation with a reference to a previous value +TUPLE: ##pure < ##flushable ; + +TUPLE: ##unary < ##pure { src vreg } ; +TUPLE: ##unary/temp < ##unary { temp vreg } ; +TUPLE: ##binary < ##pure { src1 vreg } { src2 vreg } ; +TUPLE: ##binary-imm < ##pure { src1 vreg } { src2 integer } ; +TUPLE: ##commutative < ##binary ; +TUPLE: ##commutative-imm < ##binary-imm ; + +! Instruction only used for its side effect, produces no values +TUPLE: ##effect < insn { src vreg } ; + +! Read/write ops: candidates for alias analysis +TUPLE: ##read < ##flushable ; +TUPLE: ##write < ##effect ; + +TUPLE: ##alien-getter < ##flushable { src vreg } ; +TUPLE: ##alien-setter < ##effect { value vreg } ; + +! Stack operations +INSN: ##load-immediate < ##pure { val integer } ; +INSN: ##load-indirect < ##pure obj ; + +GENERIC: ##load-literal ( dst value -- ) + +M: fixnum ##load-literal tag-fixnum ##load-immediate ; +M: f ##load-literal drop \ f tag-number ##load-immediate ; +M: object ##load-literal ##load-indirect ; + +INSN: ##peek < ##read { loc loc } ; +INSN: ##replace < ##write { loc loc } ; +INSN: ##inc-d { n integer } ; +INSN: ##inc-r { n integer } ; + +! Subroutine calls +TUPLE: stack-frame +{ params integer } +{ return integer } +{ total-size integer } +spill-counts ; + +INSN: ##stack-frame stack-frame ; +INSN: ##call word ; +INSN: ##jump word ; +INSN: ##return ; + +! Jump tables +INSN: ##dispatch src temp ; +INSN: ##dispatch-label label ; + +! Slot access +INSN: ##slot < ##read { obj vreg } { slot vreg } { tag integer } { temp vreg } ; +INSN: ##slot-imm < ##read { obj vreg } { slot integer } { tag integer } ; +INSN: ##set-slot < ##write { obj vreg } { slot vreg } { tag integer } { temp vreg } ; +INSN: ##set-slot-imm < ##write { obj vreg } { slot integer } { tag integer } ; + +! String element access +INSN: ##string-nth < ##flushable { obj vreg } { index vreg } { temp vreg } ; + +! Integer arithmetic +INSN: ##add < ##commutative ; +INSN: ##add-imm < ##commutative-imm ; +INSN: ##sub < ##binary ; +INSN: ##sub-imm < ##binary-imm ; +INSN: ##mul < ##commutative ; +INSN: ##mul-imm < ##commutative-imm ; +INSN: ##and < ##commutative ; +INSN: ##and-imm < ##commutative-imm ; +INSN: ##or < ##commutative ; +INSN: ##or-imm < ##commutative-imm ; +INSN: ##xor < ##commutative ; +INSN: ##xor-imm < ##commutative-imm ; +INSN: ##shl-imm < ##binary-imm ; +INSN: ##shr-imm < ##binary-imm ; +INSN: ##sar-imm < ##binary-imm ; +INSN: ##not < ##unary ; + +: ##tag-fixnum ( dst src -- ) tag-bits get ##shl-imm ; inline +: ##untag-fixnum ( dst src -- ) tag-bits get ##sar-imm ; inline + +! Bignum/integer conversion +INSN: ##integer>bignum < ##unary/temp ; +INSN: ##bignum>integer < ##unary/temp ; + +! Float arithmetic +INSN: ##add-float < ##commutative ; +INSN: ##sub-float < ##binary ; +INSN: ##mul-float < ##commutative ; +INSN: ##div-float < ##binary ; + +! Float/integer conversion +INSN: ##float>integer < ##unary ; +INSN: ##integer>float < ##unary ; + +! Boxing and unboxing +INSN: ##copy < ##unary ; +INSN: ##copy-float < ##unary ; +INSN: ##unbox-float < ##unary ; +INSN: ##unbox-any-c-ptr < ##unary/temp ; +INSN: ##box-float < ##unary/temp ; +INSN: ##box-alien < ##unary/temp ; + +: ##unbox-f ( dst src -- ) drop 0 ##load-immediate ; +: ##unbox-byte-array ( dst src -- ) byte-array-offset ##add-imm ; +: ##unbox-alien ( dst src -- ) 3 object tag-number ##slot-imm ; + +: ##unbox-c-ptr ( dst src class temp -- ) + { + { [ over \ f class<= ] [ 2drop ##unbox-f ] } + { [ over simple-alien class<= ] [ 2drop ##unbox-alien ] } + { [ over byte-array class<= ] [ 2drop ##unbox-byte-array ] } + [ nip ##unbox-any-c-ptr ] + } cond ; + +! Alien accessors +INSN: ##alien-unsigned-1 < ##alien-getter ; +INSN: ##alien-unsigned-2 < ##alien-getter ; +INSN: ##alien-unsigned-4 < ##alien-getter ; +INSN: ##alien-signed-1 < ##alien-getter ; +INSN: ##alien-signed-2 < ##alien-getter ; +INSN: ##alien-signed-4 < ##alien-getter ; +INSN: ##alien-cell < ##alien-getter ; +INSN: ##alien-float < ##alien-getter ; +INSN: ##alien-double < ##alien-getter ; + +INSN: ##set-alien-integer-1 < ##alien-setter ; +INSN: ##set-alien-integer-2 < ##alien-setter ; +INSN: ##set-alien-integer-4 < ##alien-setter ; +INSN: ##set-alien-cell < ##alien-setter ; +INSN: ##set-alien-float < ##alien-setter ; +INSN: ##set-alien-double < ##alien-setter ; + +! Memory allocation +INSN: ##allot < ##flushable size class { temp vreg } ; +INSN: ##write-barrier < ##effect card# table ; + +! FFI +INSN: ##alien-invoke params ; +INSN: ##alien-indirect params ; +INSN: ##alien-callback params ; +INSN: ##callback-return params ; + +! Instructions used by CFG IR only. +INSN: ##prologue ; +INSN: ##epilogue ; + +INSN: ##branch ; + +INSN: ##loop-entry ; + +! Condition codes +SYMBOL: cc< +SYMBOL: cc<= +SYMBOL: cc= +SYMBOL: cc> +SYMBOL: cc>= +SYMBOL: cc/= + +: negate-cc ( cc -- cc' ) + H{ + { cc< cc>= } + { cc<= cc> } + { cc> cc<= } + { cc>= cc< } + { cc= cc/= } + { cc/= cc= } + } at ; + +: evaluate-cc ( result cc -- ? ) + H{ + { cc< { +lt+ } } + { cc<= { +lt+ +eq+ } } + { cc= { +eq+ } } + { cc>= { +eq+ +gt+ } } + { cc> { +gt+ } } + { cc/= { +lt+ +gt+ } } + } at memq? ; + +TUPLE: ##conditional-branch < insn { src1 vreg } { src2 vreg } cc ; + +INSN: ##compare-branch < ##conditional-branch ; +INSN: ##compare-imm-branch { src1 vreg } { src2 integer } cc ; + +INSN: ##compare < ##binary cc ; +INSN: ##compare-imm < ##binary-imm cc ; + +INSN: ##compare-float-branch < ##conditional-branch ; +INSN: ##compare-float < ##binary cc ; + +! Instructions used by machine IR only. +INSN: _prologue stack-frame ; +INSN: _epilogue stack-frame ; + +INSN: _label id ; + +INSN: _gc ; + +INSN: _branch label ; + +TUPLE: _conditional-branch < insn label { src1 vreg } { src2 vreg } cc ; + +INSN: _compare-branch < _conditional-branch ; +INSN: _compare-imm-branch label { src1 vreg } { src2 integer } cc ; + +INSN: _compare-float-branch < _conditional-branch ; + +! These instructions operate on machine registers and not +! virtual registers +INSN: _spill src class n ; +INSN: _reload dst class n ; +INSN: _spill-counts counts ; diff --git a/unfinished/compiler/cfg/instructions/syntax/syntax.factor b/basis/compiler/cfg/instructions/syntax/syntax.factor similarity index 58% rename from unfinished/compiler/cfg/instructions/syntax/syntax.factor rename to basis/compiler/cfg/instructions/syntax/syntax.factor index 6d533d2059..5a5df88112 100644 --- a/unfinished/compiler/cfg/instructions/syntax/syntax.factor +++ b/basis/compiler/cfg/instructions/syntax/syntax.factor @@ -4,11 +4,15 @@ USING: classes.tuple classes.tuple.parser kernel words make fry sequences parser ; IN: compiler.cfg.instructions.syntax -TUPLE: insn ; +: insn-word ( -- word ) + #! We want to put the insn tuple in compiler.cfg.instructions, + #! but we cannot have circularity between that vocabulary and + #! this one. + "insn" "compiler.cfg.instructions" lookup ; : INSN: parse-tuple-definition "regs" suffix - [ dup tuple eq? [ drop insn ] when ] dip + [ dup tuple eq? [ drop insn-word ] when ] dip [ define-tuple-class ] [ 2drop save-location ] [ 2drop dup '[ f _ boa , ] define-inline ] diff --git a/basis/compiler/cfg/intrinsics/alien/alien.factor b/basis/compiler/cfg/intrinsics/alien/alien.factor new file mode 100644 index 0000000000..42e23c29c9 --- /dev/null +++ b/basis/compiler/cfg/intrinsics/alien/alien.factor @@ -0,0 +1,108 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors kernel sequences alien math classes.algebra +fry locals combinators cpu.architecture +compiler.tree.propagation.info +compiler.cfg.hats compiler.cfg.stacks compiler.cfg.instructions +compiler.cfg.utilities ; +IN: compiler.cfg.intrinsics.alien + +: (prepare-alien-accessor-imm) ( class offset -- offset-vreg ) + ds-drop [ ds-pop swap ^^unbox-c-ptr ] dip ^^add-imm ; + +: (prepare-alien-accessor) ( class -- offset-vreg ) + [ 2inputs ^^untag-fixnum swap ] dip ^^unbox-c-ptr ^^add ; + +: prepare-alien-accessor ( infos -- offset-vreg ) + [ second class>> ] [ first ] bi + dup value-info-small-fixnum? [ + literal>> (prepare-alien-accessor-imm) + ] [ drop (prepare-alien-accessor) ] if ; + +:: inline-alien ( node quot test -- ) + [let | infos [ node node-input-infos ] | + infos test call + [ infos prepare-alien-accessor quot call ] + [ node emit-primitive ] + if + ] ; inline + +: inline-alien-getter? ( infos -- ? ) + [ first class>> c-ptr class<= ] + [ second class>> fixnum class<= ] + bi and ; + +: inline-alien-getter ( node quot -- ) + '[ @ ds-push ] + [ inline-alien-getter? ] inline-alien ; inline + +: inline-alien-setter? ( infos class -- ? ) + '[ first class>> _ class<= ] + [ second class>> c-ptr class<= ] + [ third class>> fixnum class<= ] + tri and and ; + +: inline-alien-integer-setter ( node quot -- ) + '[ ds-pop ^^untag-fixnum @ ] + [ fixnum inline-alien-setter? ] + inline-alien ; inline + +: inline-alien-cell-setter ( node quot -- ) + [ dup node-input-infos first class>> ] dip + '[ ds-pop _ ^^unbox-c-ptr @ ] + [ pinned-c-ptr inline-alien-setter? ] + inline-alien ; inline + +: inline-alien-float-setter ( node quot -- ) + '[ ds-pop ^^unbox-float @ ] + [ float inline-alien-setter? ] + inline-alien ; inline + +: emit-alien-unsigned-getter ( node n -- ) + '[ + _ { + { 1 [ ^^alien-unsigned-1 ] } + { 2 [ ^^alien-unsigned-2 ] } + { 4 [ ^^alien-unsigned-4 ] } + } case ^^tag-fixnum + ] inline-alien-getter ; + +: emit-alien-signed-getter ( node n -- ) + '[ + _ { + { 1 [ ^^alien-signed-1 ] } + { 2 [ ^^alien-signed-2 ] } + { 4 [ ^^alien-signed-4 ] } + } case ^^tag-fixnum + ] inline-alien-getter ; + +: emit-alien-integer-setter ( node n -- ) + '[ + _ { + { 1 [ ##set-alien-integer-1 ] } + { 2 [ ##set-alien-integer-2 ] } + { 4 [ ##set-alien-integer-4 ] } + } case + ] inline-alien-integer-setter ; + +: emit-alien-cell-getter ( node -- ) + [ ^^alien-cell ^^box-alien ] inline-alien-getter ; + +: emit-alien-cell-setter ( node -- ) + [ ##set-alien-cell ] inline-alien-cell-setter ; + +: emit-alien-float-getter ( node reg-class -- ) + '[ + _ { + { single-float-regs [ ^^alien-float ] } + { double-float-regs [ ^^alien-double ] } + } case ^^box-float + ] inline-alien-getter ; + +: emit-alien-float-setter ( node reg-class -- ) + '[ + _ { + { single-float-regs [ ##set-alien-float ] } + { double-float-regs [ ##set-alien-double ] } + } case + ] inline-alien-float-setter ; diff --git a/basis/compiler/cfg/intrinsics/allot/allot.factor b/basis/compiler/cfg/intrinsics/allot/allot.factor new file mode 100644 index 0000000000..ceac5e960c --- /dev/null +++ b/basis/compiler/cfg/intrinsics/allot/allot.factor @@ -0,0 +1,68 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel math math.order sequences accessors arrays +byte-arrays layouts classes.tuple.private fry locals +compiler.tree.propagation.info compiler.cfg.hats +compiler.cfg.instructions compiler.cfg.stacks +compiler.cfg.utilities ; +IN: compiler.cfg.intrinsics.allot + +: ##set-slots ( regs obj class -- ) + '[ _ swap 1+ _ tag-number ##set-slot-imm ] each-index ; + +: emit-simple-allot ( node -- ) + [ in-d>> length ] [ node-output-infos first class>> ] bi + [ drop ds-load ] [ [ 1+ cells ] dip ^^allot ] [ nip ] 2tri + [ ##set-slots ] [ [ drop ] [ ds-push ] [ drop ] tri* ] 3bi ; + +: tuple-slot-regs ( layout -- vregs ) + [ second ds-load ] [ ^^load-literal ] bi prefix ; + +: emit- ( node -- ) + dup node-input-infos peek literal>> + dup array? [ + nip + ds-drop + [ tuple-slot-regs ] [ second ^^allot-tuple ] bi + [ tuple ##set-slots ] [ ds-push drop ] 2bi + ] [ drop emit-primitive ] if ; + +: store-length ( len reg -- ) + [ ^^load-literal ] dip 1 object tag-number ##set-slot-imm ; + +: store-initial-element ( elt reg len -- ) + [ 2 + object tag-number ##set-slot-imm ] with with each ; + +: expand-? ( obj -- ? ) + dup integer? [ 0 8 between? ] [ drop f ] if ; + +:: emit- ( node -- ) + [let | len [ node node-input-infos first literal>> ] | + len expand-? [ + [let | elt [ ds-pop ] + reg [ len ^^allot-array ] | + ds-drop + len reg store-length + elt reg len store-initial-element + reg ds-push + ] + ] [ node emit-primitive ] if + ] ; + +: expand-? ( obj -- ? ) + dup integer? [ 0 32 between? ] [ drop f ] if ; + +: bytes>cells ( m -- n ) cell align cell /i ; + +:: emit- ( node -- ) + [let | len [ node node-input-infos first literal>> ] | + len expand-? [ + [let | elt [ 0 ^^load-literal ] + reg [ len ^^allot-byte-array ] | + ds-drop + len reg store-length + elt reg len bytes>cells store-initial-element + reg ds-push + ] + ] [ node emit-primitive ] if + ] ; diff --git a/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor b/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor new file mode 100644 index 0000000000..04c9097725 --- /dev/null +++ b/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor @@ -0,0 +1,66 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: sequences accessors layouts kernel math namespaces +combinators fry locals +compiler.tree.propagation.info +compiler.cfg.stacks compiler.cfg.hats compiler.cfg.instructions +compiler.cfg.utilities ; +IN: compiler.cfg.intrinsics.fixnum + +: (emit-fixnum-imm-op) ( infos insn -- dst ) + ds-drop + [ ds-pop ] + [ second literal>> [ tag-fixnum ] [ \ f tag-number ] if* ] + [ ] + tri* + call ; inline + +: (emit-fixnum-op) ( insn -- dst ) + [ 2inputs ] dip call ; inline + +:: emit-fixnum-op ( node insn imm-insn -- ) + [let | infos [ node node-input-infos ] | + infos second value-info-small-tagged? + [ infos imm-insn (emit-fixnum-imm-op) ] + [ insn (emit-fixnum-op) ] + if + ds-push + ] ; inline + +: emit-fixnum-shift-fast ( node -- ) + dup node-input-infos dup second value-info-small-fixnum? [ + nip + [ ds-drop ds-pop ] dip + second literal>> dup sgn { + { -1 [ neg tag-bits get + ^^sar-imm ^^tag-fixnum ] } + { 0 [ drop ] } + { 1 [ ^^shl-imm ] } + } case + ds-push + ] [ drop emit-primitive ] if ; + +: emit-fixnum-bitnot ( -- ) + ds-pop ^^not tag-mask get ^^xor-imm ds-push ; + +: (emit-fixnum*fast) ( -- dst ) + 2inputs ^^untag-fixnum ^^mul ; + +: (emit-fixnum*fast-imm) ( infos -- dst ) + ds-drop + [ ds-pop ] [ second literal>> ] bi* ^^mul-imm ; + +: emit-fixnum*fast ( node -- ) + node-input-infos + dup second value-info-small-fixnum? + [ (emit-fixnum*fast-imm) ] [ drop (emit-fixnum*fast) ] if + ds-push ; + +: emit-fixnum-comparison ( node cc -- ) + [ '[ _ ^^compare ] ] [ '[ _ ^^compare-imm ] ] bi + emit-fixnum-op ; + +: emit-bignum>fixnum ( -- ) + ds-pop ^^bignum>integer ^^tag-fixnum ds-push ; + +: emit-fixnum>bignum ( -- ) + ds-pop ^^untag-fixnum ^^integer>bignum ds-push ; diff --git a/basis/compiler/cfg/intrinsics/float/float.factor b/basis/compiler/cfg/intrinsics/float/float.factor new file mode 100644 index 0000000000..84a0bc9ca0 --- /dev/null +++ b/basis/compiler/cfg/intrinsics/float/float.factor @@ -0,0 +1,19 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel compiler.cfg.stacks compiler.cfg.hats +compiler.cfg.instructions compiler.cfg.utilities ; +IN: compiler.cfg.intrinsics.float + +: emit-float-op ( insn -- ) + [ 2inputs [ ^^unbox-float ] bi@ ] dip call ^^box-float + ds-push ; inline + +: emit-float-comparison ( cc -- ) + [ 2inputs [ ^^unbox-float ] bi@ ] dip ^^compare-float + ds-push ; inline + +: emit-float>fixnum ( -- ) + ds-pop ^^unbox-float ^^float>integer ^^tag-fixnum ds-push ; + +: emit-fixnum>float ( -- ) + ds-pop ^^untag-fixnum ^^integer>float ^^box-float ds-push ; diff --git a/basis/compiler/cfg/intrinsics/intrinsics.factor b/basis/compiler/cfg/intrinsics/intrinsics.factor new file mode 100644 index 0000000000..ef1cde337a --- /dev/null +++ b/basis/compiler/cfg/intrinsics/intrinsics.factor @@ -0,0 +1,144 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: qualified words sequences kernel combinators +cpu.architecture +compiler.cfg.hats +compiler.cfg.instructions +compiler.cfg.intrinsics.alien +compiler.cfg.intrinsics.allot +compiler.cfg.intrinsics.fixnum +compiler.cfg.intrinsics.float +compiler.cfg.intrinsics.slots ; +QUALIFIED: kernel +QUALIFIED: arrays +QUALIFIED: byte-arrays +QUALIFIED: kernel.private +QUALIFIED: slots.private +QUALIFIED: strings.private +QUALIFIED: classes.tuple.private +QUALIFIED: math.private +QUALIFIED: alien.accessors +IN: compiler.cfg.intrinsics + +{ + kernel.private:tag + math.private:fixnum+fast + math.private:fixnum-fast + math.private:fixnum-bitand + math.private:fixnum-bitor + math.private:fixnum-bitxor + math.private:fixnum-shift-fast + math.private:fixnum-bitnot + math.private:fixnum*fast + math.private:fixnum< + math.private:fixnum<= + math.private:fixnum>= + math.private:fixnum> + math.private:bignum>fixnum + math.private:fixnum>bignum + kernel:eq? + slots.private:slot + slots.private:set-slot + strings.private:string-nth + classes.tuple.private: + arrays: + byte-arrays: + math.private: + math.private: + kernel: + alien.accessors:alien-unsigned-1 + alien.accessors:set-alien-unsigned-1 + alien.accessors:alien-signed-1 + alien.accessors:set-alien-signed-1 + alien.accessors:alien-unsigned-2 + alien.accessors:set-alien-unsigned-2 + alien.accessors:alien-signed-2 + alien.accessors:set-alien-signed-2 + alien.accessors:alien-cell + alien.accessors:set-alien-cell +} [ t "intrinsic" set-word-prop ] each + +: enable-alien-4-intrinsics ( -- ) + { + alien.accessors:alien-unsigned-4 + alien.accessors:set-alien-unsigned-4 + alien.accessors:alien-signed-4 + alien.accessors:set-alien-signed-4 + } [ t "intrinsic" set-word-prop ] each ; + +: enable-float-intrinsics ( -- ) + { + math.private:float+ + math.private:float- + math.private:float* + math.private:float/f + math.private:fixnum>float + math.private:float>fixnum + math.private:float< + math.private:float<= + math.private:float> + math.private:float>= + math.private:float= + alien.accessors:alien-float + alien.accessors:set-alien-float + alien.accessors:alien-double + alien.accessors:set-alien-double + } [ t "intrinsic" set-word-prop ] each ; + +: emit-intrinsic ( node word -- ) + { + { \ kernel.private:tag [ drop emit-tag ] } + { \ math.private:fixnum+fast [ [ ^^add ] [ ^^add-imm ] emit-fixnum-op ] } + { \ math.private:fixnum-fast [ [ ^^sub ] [ ^^sub-imm ] emit-fixnum-op ] } + { \ math.private:fixnum-bitand [ [ ^^and ] [ ^^and-imm ] emit-fixnum-op ] } + { \ math.private:fixnum-bitor [ [ ^^or ] [ ^^or-imm ] emit-fixnum-op ] } + { \ math.private:fixnum-bitxor [ [ ^^xor ] [ ^^xor-imm ] emit-fixnum-op ] } + { \ math.private:fixnum-shift-fast [ emit-fixnum-shift-fast ] } + { \ math.private:fixnum-bitnot [ drop emit-fixnum-bitnot ] } + { \ math.private:fixnum*fast [ emit-fixnum*fast ] } + { \ math.private:fixnum< [ cc< emit-fixnum-comparison ] } + { \ math.private:fixnum<= [ cc<= emit-fixnum-comparison ] } + { \ math.private:fixnum>= [ cc>= emit-fixnum-comparison ] } + { \ math.private:fixnum> [ cc> emit-fixnum-comparison ] } + { \ kernel:eq? [ cc= emit-fixnum-comparison ] } + { \ math.private:bignum>fixnum [ drop emit-bignum>fixnum ] } + { \ math.private:fixnum>bignum [ drop emit-fixnum>bignum ] } + { \ math.private:float+ [ drop [ ^^add-float ] emit-float-op ] } + { \ math.private:float- [ drop [ ^^sub-float ] emit-float-op ] } + { \ math.private:float* [ drop [ ^^mul-float ] emit-float-op ] } + { \ math.private:float/f [ drop [ ^^div-float ] emit-float-op ] } + { \ math.private:float< [ drop cc< emit-float-comparison ] } + { \ math.private:float<= [ drop cc<= emit-float-comparison ] } + { \ math.private:float>= [ drop cc>= emit-float-comparison ] } + { \ math.private:float> [ drop cc> emit-float-comparison ] } + { \ math.private:float= [ drop cc= emit-float-comparison ] } + { \ math.private:float>fixnum [ drop emit-float>fixnum ] } + { \ math.private:fixnum>float [ drop emit-fixnum>float ] } + { \ slots.private:slot [ emit-slot ] } + { \ slots.private:set-slot [ emit-set-slot ] } + { \ strings.private:string-nth [ drop emit-string-nth ] } + { \ classes.tuple.private: [ emit- ] } + { \ arrays: [ emit- ] } + { \ byte-arrays: [ emit- ] } + { \ math.private: [ emit-simple-allot ] } + { \ math.private: [ emit-simple-allot ] } + { \ kernel: [ emit-simple-allot ] } + { \ alien.accessors:alien-unsigned-1 [ 1 emit-alien-unsigned-getter ] } + { \ alien.accessors:set-alien-unsigned-1 [ 1 emit-alien-integer-setter ] } + { \ alien.accessors:alien-signed-1 [ 1 emit-alien-signed-getter ] } + { \ alien.accessors:set-alien-signed-1 [ 1 emit-alien-integer-setter ] } + { \ alien.accessors:alien-unsigned-2 [ 2 emit-alien-unsigned-getter ] } + { \ alien.accessors:set-alien-unsigned-2 [ 2 emit-alien-integer-setter ] } + { \ alien.accessors:alien-signed-2 [ 2 emit-alien-signed-getter ] } + { \ alien.accessors:set-alien-signed-2 [ 2 emit-alien-integer-setter ] } + { \ alien.accessors:alien-unsigned-4 [ 4 emit-alien-unsigned-getter ] } + { \ alien.accessors:set-alien-unsigned-4 [ 4 emit-alien-integer-setter ] } + { \ alien.accessors:alien-signed-4 [ 4 emit-alien-signed-getter ] } + { \ alien.accessors:set-alien-signed-4 [ 4 emit-alien-integer-setter ] } + { \ alien.accessors:alien-cell [ emit-alien-cell-getter ] } + { \ alien.accessors:set-alien-cell [ emit-alien-cell-setter ] } + { \ alien.accessors:alien-float [ single-float-regs emit-alien-float-getter ] } + { \ alien.accessors:set-alien-float [ single-float-regs emit-alien-float-setter ] } + { \ alien.accessors:alien-double [ double-float-regs emit-alien-float-getter ] } + { \ alien.accessors:set-alien-double [ double-float-regs emit-alien-float-setter ] } + } case ; diff --git a/basis/compiler/cfg/intrinsics/slots/slots.factor b/basis/compiler/cfg/intrinsics/slots/slots.factor new file mode 100644 index 0000000000..fec234a576 --- /dev/null +++ b/basis/compiler/cfg/intrinsics/slots/slots.factor @@ -0,0 +1,56 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: layouts namespaces kernel accessors sequences +classes.algebra compiler.tree.propagation.info +compiler.cfg.stacks compiler.cfg.hats compiler.cfg.instructions +compiler.cfg.utilities ; +IN: compiler.cfg.intrinsics.slots + +: emit-tag ( -- ) + ds-pop tag-mask get ^^and-imm ^^tag-fixnum ds-push ; + +: value-tag ( info -- n ) class>> class-tag ; inline + +: (emit-slot) ( infos -- dst ) + [ 2inputs ^^offset>slot ] [ first value-tag ] bi* + ^^slot ; + +: (emit-slot-imm) ( infos -- dst ) + ds-drop + [ ds-pop ] + [ [ second literal>> ] [ first value-tag ] bi ] bi* + ^^slot-imm ; + +: emit-slot ( node -- ) + dup node-input-infos + dup first value-tag [ + nip + dup second value-info-small-fixnum? + [ (emit-slot-imm) ] [ (emit-slot) ] if + ds-push + ] [ drop emit-primitive ] if ; + +: (emit-set-slot) ( infos -- obj-reg ) + [ 3inputs [ tuck ] dip ^^offset>slot ] + [ second value-tag ] + bi* ^^set-slot ; + +: (emit-set-slot-imm) ( infos -- obj-reg ) + ds-drop + [ 2inputs tuck ] + [ [ third literal>> ] [ second value-tag ] bi ] bi* + ##set-slot-imm ; + +: emit-set-slot ( node -- ) + dup node-input-infos + dup second value-tag [ + nip + [ + dup third value-info-small-fixnum? + [ (emit-set-slot-imm) ] [ (emit-set-slot) ] if + ] [ first class>> immediate class<= ] bi + [ drop ] [ i i ##write-barrier ] if + ] [ drop emit-primitive ] if ; + +: emit-string-nth ( -- ) + 2inputs swap ^^untag-fixnum ^^string-nth ^^tag-fixnum ds-push ; diff --git a/unfinished/compiler/cfg/iterator/iterator.factor b/basis/compiler/cfg/iterator/iterator.factor similarity index 92% rename from unfinished/compiler/cfg/iterator/iterator.factor rename to basis/compiler/cfg/iterator/iterator.factor index 904da3f0c3..3444b517ac 100644 --- a/unfinished/compiler/cfg/iterator/iterator.factor +++ b/basis/compiler/cfg/iterator/iterator.factor @@ -19,9 +19,6 @@ SYMBOL: node-stack [ swap >node call node> drop ] keep iterate-nodes ] if ; inline recursive -: with-node-iterator ( quot -- ) - >r V{ } clone node-stack r> with-variable ; inline - DEFER: (tail-call?) : tail-phi? ( cursor -- ? ) diff --git a/unfinished/compiler/cfg/linear-scan/allocation/allocation.factor b/basis/compiler/cfg/linear-scan/allocation/allocation.factor similarity index 51% rename from unfinished/compiler/cfg/linear-scan/allocation/allocation.factor rename to basis/compiler/cfg/linear-scan/allocation/allocation.factor index 4a9646c88a..d75d5649cb 100644 --- a/unfinished/compiler/cfg/linear-scan/allocation/allocation.factor +++ b/basis/compiler/cfg/linear-scan/allocation/allocation.factor @@ -1,10 +1,9 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: namespaces sequences math math.order kernel assocs -accessors vectors fry heaps +accessors vectors fry heaps cpu.architecture combinators compiler.cfg.registers -compiler.cfg.linear-scan.live-intervals -compiler.backend ; +compiler.cfg.linear-scan.live-intervals ; IN: compiler.cfg.linear-scan.allocation ! Mapping from register classes to sequences of machine registers @@ -19,24 +18,22 @@ SYMBOL: free-registers ! Vector of active live intervals SYMBOL: active-intervals +: active-intervals-for ( vreg -- seq ) + reg-class>> active-intervals get at ; + : add-active ( live-interval -- ) - active-intervals get push ; + dup vreg>> active-intervals-for push ; : delete-active ( live-interval -- ) - active-intervals get delete ; + dup vreg>> active-intervals-for delq ; : expire-old-intervals ( n -- ) - active-intervals get - swap '[ end>> _ < ] partition - active-intervals set - [ deallocate-register ] each ; - -: expire-old-uses ( n -- ) - active-intervals get - swap '[ uses>> dup peek _ < [ pop* ] [ drop ] if ] each ; - -: update-state ( live-interval -- ) - start>> [ expire-old-intervals ] [ expire-old-uses ] bi ; + active-intervals swap '[ + [ + [ end>> _ < ] partition + [ [ deallocate-register ] each ] dip + ] assoc-map + ] change ; ! Minheap of live intervals which still need a register allocation SYMBOL: unhandled-intervals @@ -59,14 +56,39 @@ SYMBOL: progress [ [ start>> ] keep ] { } map>assoc unhandled-intervals get heap-push-all ; -: assign-free-register ( live-interval registers -- ) - #! If the live interval does not have any uses, it means it - #! will be spilled immediately, so it still needs a register - #! to compute the new value, but we don't add the interval - #! to the active set and we don't remove the register from - #! the free list. - over uses>> empty? - [ peek >>reg drop ] [ pop >>reg add-active ] if ; +! Coalescing +: active-interval ( vreg -- live-interval ) + dup [ dup active-intervals-for [ vreg>> = ] with find nip ] when ; + +: coalesce? ( live-interval -- ? ) + [ start>> ] [ copy-from>> active-interval ] bi + dup [ end>> = ] [ 2drop f ] if ; + +: coalesce ( live-interval -- ) + dup copy-from>> active-interval + [ [ add-active ] [ delete-active ] bi* ] + [ reg>> >>reg drop ] + 2bi ; + +! Splitting +: find-use ( live-interval n quot -- i elt ) + [ uses>> ] 2dip curry find ; inline + +: split-before ( live-interval i -- before ) + [ clone dup uses>> ] dip + [ head >>uses ] [ 1- swap nth >>end ] 2bi ; + +: split-after ( live-interval i -- after ) + [ clone dup uses>> ] dip + [ tail >>uses ] [ swap nth >>start ] 2bi + f >>reg f >>copy-from ; + +: split-interval ( live-interval n -- before after ) + [ drop ] [ [ > ] find-use drop ] 2bi + [ split-before ] [ split-after ] 2bi ; + +: record-split ( live-interval before after -- ) + [ >>split-before ] [ >>split-after ] bi* drop ; ! Spilling SYMBOL: spill-counts @@ -74,37 +96,23 @@ SYMBOL: spill-counts : next-spill-location ( reg-class -- n ) spill-counts get [ dup 1+ ] change-at ; -: interval-to-spill ( -- live-interval ) +: interval-to-spill ( active-intervals current -- live-interval ) #! We spill the interval with the most distant use location. - active-intervals get unclip-slice [ - [ [ uses>> peek ] bi@ > ] most - ] reduce ; - -: check-split ( live-interval -- ) - [ start>> ] [ end>> ] bi = [ "Cannot split any further" throw ] when ; - -: split-interval ( live-interval -- before after ) - #! Split the live interval at the location of its first use. - #! 'Before' now starts and ends on the same instruction. - [ check-split ] - [ clone [ uses>> delete-all ] [ dup start>> >>end ] bi ] - [ clone f >>reg dup uses>> peek >>start ] - tri ; - -: record-split ( live-interval before after -- ) - [ >>split-before ] [ >>split-after ] bi* drop ; + start>> '[ dup _ [ >= ] find-use nip ] { } map>assoc + unclip-slice [ [ [ second ] bi@ > ] most ] reduce first ; : assign-spill ( before after -- before after ) #! If it has been spilled already, reuse spill location. - over reload-from>> [ next-spill-location ] unless* + over reload-from>> + [ over vreg>> reg-class>> next-spill-location ] unless* tuck [ >>spill-to ] [ >>reload-from ] 2bi* ; -: split-and-spill ( live-interval -- before after ) - dup split-interval [ record-split ] [ assign-spill ] 2bi ; +: split-and-spill ( new existing -- before after ) + dup rot start>> split-interval + [ record-split ] [ assign-spill ] 2bi ; : reuse-register ( new existing -- ) - reg>> >>reg - dup uses>> empty? [ deallocate-register ] [ add-active ] if ; + reg>> >>reg add-active ; : spill-existing ( new existing -- ) #! Our new interval will be used before the active interval @@ -112,41 +120,52 @@ SYMBOL: spill-counts #! interval, then process the new interval and the tail end #! of the existing interval again. [ reuse-register ] - [ delete-active ] - [ split-and-spill [ drop ] [ add-unhandled ] bi* ] tri ; + [ nip delete-active ] + [ split-and-spill [ drop ] [ add-unhandled ] bi* ] 2tri ; : spill-new ( new existing -- ) #! Our new interval will be used after the active interval #! with the most distant use location. Split the new #! interval, then process both parts of the new interval #! again. - [ split-and-spill add-unhandled ] dip spill-existing ; + [ dup split-and-spill add-unhandled ] dip spill-existing ; : spill-existing? ( new existing -- ? ) - over uses>> empty? [ 2drop t ] [ [ uses>> peek ] bi@ < ] if ; + #! Test if 'new' will be used before 'existing'. + over start>> '[ _ [ > ] find-use nip -1 or ] bi@ < ; -: assign-blocked-register ( live-interval -- ) - interval-to-spill - 2dup spill-existing? - [ spill-existing ] [ spill-new ] if ; +: assign-blocked-register ( new -- ) + [ dup vreg>> active-intervals-for ] keep interval-to-spill + 2dup spill-existing? [ spill-existing ] [ spill-new ] if ; -: assign-register ( live-interval -- ) - dup vreg>> free-registers-for [ - assign-blocked-register +: assign-free-register ( new registers -- ) + pop >>reg add-active ; + +: assign-register ( new -- ) + dup coalesce? [ + coalesce ] [ - assign-free-register - ] if-empty ; + dup vreg>> free-registers-for + [ assign-blocked-register ] + [ assign-free-register ] + if-empty + ] if ; ! Main loop +: reg-classes ( -- seq ) { int-regs double-float-regs } ; inline + : init-allocator ( registers -- ) - V{ } clone active-intervals set unhandled-intervals set [ reverse >vector ] assoc-map free-registers set - H{ { int-regs 0 } { double-float-regs 0 } } clone spill-counts set + reg-classes [ 0 ] { } map>assoc spill-counts set + reg-classes [ V{ } clone ] { } map>assoc active-intervals set -1 progress set ; : handle-interval ( live-interval -- ) - [ start>> progress set ] [ update-state ] [ assign-register ] tri ; + [ start>> progress set ] + [ start>> expire-old-intervals ] + [ assign-register ] + tri ; : (allocate-registers) ( -- ) unhandled-intervals get [ handle-interval ] slurp-heap ; diff --git a/unfinished/compiler/cfg/linear-scan/assignment/assignment-tests.factor b/basis/compiler/cfg/linear-scan/assignment/assignment-tests.factor similarity index 100% rename from unfinished/compiler/cfg/linear-scan/assignment/assignment-tests.factor rename to basis/compiler/cfg/linear-scan/assignment/assignment-tests.factor diff --git a/unfinished/compiler/cfg/linear-scan/assignment/assignment.factor b/basis/compiler/cfg/linear-scan/assignment/assignment.factor similarity index 83% rename from unfinished/compiler/cfg/linear-scan/assignment/assignment.factor rename to basis/compiler/cfg/linear-scan/assignment/assignment.factor index ffe8e6b687..da45b45aaa 100644 --- a/unfinished/compiler/cfg/linear-scan/assignment/assignment.factor +++ b/basis/compiler/cfg/linear-scan/assignment/assignment.factor @@ -2,6 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel math assocs namespaces sequences heaps fry make combinators +cpu.architecture +compiler.cfg.def-use compiler.cfg.registers compiler.cfg.instructions compiler.cfg.linear-scan.live-intervals ; @@ -34,13 +36,8 @@ SYMBOL: unhandled-intervals [ add-unhandled ] each ; : insert-spill ( live-interval -- ) - [ reg>> ] [ spill-to>> ] [ vreg>> reg-class>> ] tri - over [ - { - { int-regs [ _spill-integer ] } - { double-float-regs [ _spill-float ] } - } case - ] [ 3drop ] if ; + [ reg>> ] [ vreg>> reg-class>> ] [ spill-to>> ] tri + dup [ _spill ] [ 3drop ] if ; : expire-old-intervals ( n -- ) active-intervals get @@ -49,13 +46,8 @@ SYMBOL: unhandled-intervals [ insert-spill ] each ; : insert-reload ( live-interval -- ) - [ reg>> ] [ reload-from>> ] [ vreg>> reg-class>> ] tri - over [ - { - { int-regs [ _reload-integer ] } - { double-float-regs [ _reload-float ] } - } case - ] [ 3drop ] if ; + [ reg>> ] [ vreg>> reg-class>> ] [ reload-from>> ] tri + dup [ _reload ] [ 3drop ] if ; : activate-new-intervals ( n -- ) #! Any live intervals which start on the current instruction @@ -67,13 +59,17 @@ SYMBOL: unhandled-intervals ] [ 2drop ] if ] if ; -: (assign-registers) ( insn -- ) +GENERIC: (assign-registers) ( insn -- ) + +M: vreg-insn (assign-registers) dup [ defs-vregs ] [ uses-vregs ] bi append active-intervals get swap '[ vreg>> _ member? ] filter [ [ vreg>> ] [ reg>> ] bi ] { } map>assoc >>regs drop ; +M: insn (assign-registers) drop ; + : init-assignment ( live-intervals -- ) V{ } clone active-intervals set unhandled-intervals set diff --git a/unfinished/compiler/cfg/linear-scan/debugger/debugger.factor b/basis/compiler/cfg/linear-scan/debugger/debugger.factor similarity index 59% rename from unfinished/compiler/cfg/linear-scan/debugger/debugger.factor rename to basis/compiler/cfg/linear-scan/debugger/debugger.factor index 89bf81d2ba..c6481b305e 100644 --- a/unfinished/compiler/cfg/linear-scan/debugger/debugger.factor +++ b/basis/compiler/cfg/linear-scan/debugger/debugger.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors kernel sequences sets arrays -compiler.cfg.linear-scan.live-intervals +USING: accessors kernel sequences sets arrays math strings fry +prettyprint compiler.cfg.linear-scan.live-intervals compiler.cfg.linear-scan.allocation ; IN: compiler.cfg.linear-scan.debugger @@ -21,3 +21,16 @@ IN: compiler.cfg.linear-scan.debugger : check-linear-scan ( live-intervals machine-registers -- ) [ [ clone ] map ] dip allocate-registers [ split-children ] map concat check-assigned ; + +: picture ( uses -- str ) + dup peek 1 + CHAR: space + [ '[ CHAR: * swap _ set-nth ] each ] keep ; + +: interval-picture ( interval -- str ) + [ uses>> picture ] + [ copy-from>> unparse ] + [ vreg>> unparse ] + tri 3array ; + +: live-intervals. ( seq -- ) + [ interval-picture ] map simple-table. ; diff --git a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor new file mode 100644 index 0000000000..948302c74b --- /dev/null +++ b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor @@ -0,0 +1,1205 @@ +IN: compiler.cfg.linear-scan.tests +USING: tools.test random sorting sequences sets hashtables assocs +kernel fry arrays splitting namespaces math accessors vectors +math.order +cpu.architecture +compiler.cfg.instructions +compiler.cfg.registers +compiler.cfg.linear-scan +compiler.cfg.linear-scan.live-intervals +compiler.cfg.linear-scan.allocation +compiler.cfg.linear-scan.debugger ; + +[ 7 ] [ + T{ live-interval + { vreg T{ vreg { reg-class int-regs } { n 2 } } } + { start 0 } + { end 10 } + { uses V{ 0 1 3 7 10 } } + } + 4 [ >= ] find-use nip +] unit-test + +[ 4 ] [ + T{ live-interval + { vreg T{ vreg { reg-class int-regs } { n 2 } } } + { start 0 } + { end 10 } + { uses V{ 0 1 3 4 10 } } + } + 4 [ >= ] find-use nip +] unit-test + +[ f ] [ + T{ live-interval + { vreg T{ vreg { reg-class int-regs } { n 2 } } } + { start 0 } + { end 10 } + { uses V{ 0 1 3 4 10 } } + } + 100 [ >= ] find-use nip +] unit-test + +[ + T{ live-interval + { vreg T{ vreg { reg-class int-regs } { n 1 } } } + { start 0 } + { end 1 } + { uses V{ 0 1 } } + } + T{ live-interval + { vreg T{ vreg { reg-class int-regs } { n 1 } } } + { start 5 } + { end 5 } + { uses V{ 5 } } + } +] [ + T{ live-interval + { vreg T{ vreg { reg-class int-regs } { n 1 } } } + { start 0 } + { end 5 } + { uses V{ 0 1 5 } } + } 2 split-interval +] unit-test + +[ + T{ live-interval + { vreg T{ vreg { reg-class int-regs } { n 1 } } } + { start 0 } + { end 0 } + { uses V{ 0 } } + } + T{ live-interval + { vreg T{ vreg { reg-class int-regs } { n 1 } } } + { start 1 } + { end 5 } + { uses V{ 1 5 } } + } +] [ + T{ live-interval + { vreg T{ vreg { reg-class int-regs } { n 1 } } } + { start 0 } + { end 5 } + { uses V{ 0 1 5 } } + } 0 split-interval +] unit-test + +[ + T{ live-interval + { vreg T{ vreg { reg-class int-regs } { n 1 } } } + { start 3 } + { end 10 } + { uses V{ 3 10 } } + } +] [ + { + T{ live-interval + { vreg T{ vreg { reg-class int-regs } { n 1 } } } + { start 1 } + { end 15 } + { uses V{ 1 3 7 10 15 } } + } + T{ live-interval + { vreg T{ vreg { reg-class int-regs } { n 1 } } } + { start 3 } + { end 8 } + { uses V{ 3 4 8 } } + } + T{ live-interval + { vreg T{ vreg { reg-class int-regs } { n 1 } } } + { start 3 } + { end 10 } + { uses V{ 3 10 } } + } + } + T{ live-interval + { vreg T{ vreg { reg-class int-regs } { n 1 } } } + { start 5 } + { end 5 } + { uses V{ 5 } } + } + interval-to-spill +] unit-test + +[ t ] [ + T{ live-interval + { vreg T{ vreg { reg-class int-regs } { n 1 } } } + { start 5 } + { end 15 } + { uses V{ 5 10 15 } } + } + T{ live-interval + { vreg T{ vreg { reg-class int-regs } { n 1 } } } + { start 1 } + { end 20 } + { uses V{ 1 20 } } + } + spill-existing? +] unit-test + +[ f ] [ + T{ live-interval + { vreg T{ vreg { reg-class int-regs } { n 1 } } } + { start 5 } + { end 15 } + { uses V{ 5 10 15 } } + } + T{ live-interval + { vreg T{ vreg { reg-class int-regs } { n 1 } } } + { start 1 } + { end 20 } + { uses V{ 1 7 20 } } + } + spill-existing? +] unit-test + +[ t ] [ + T{ live-interval + { vreg T{ vreg { reg-class int-regs } { n 1 } } } + { start 5 } + { end 5 } + { uses V{ 5 } } + } + T{ live-interval + { vreg T{ vreg { reg-class int-regs } { n 1 } } } + { start 1 } + { end 20 } + { uses V{ 1 7 20 } } + } + spill-existing? +] unit-test + +[ ] [ + { + T{ live-interval { vreg T{ vreg { n 1 } { reg-class int-regs } } } { start 0 } { end 100 } { uses V{ 0 100 } } } + } + H{ { int-regs { "A" } } } + check-linear-scan +] unit-test + +[ ] [ + { + T{ live-interval { vreg T{ vreg { n 1 } { reg-class int-regs } } } { start 0 } { end 10 } { uses V{ 0 10 } } } + T{ live-interval { vreg T{ vreg { n 2 } { reg-class int-regs } } } { start 11 } { end 20 } { uses V{ 11 20 } } } + } + H{ { int-regs { "A" } } } + check-linear-scan +] unit-test + +[ ] [ + { + T{ live-interval { vreg T{ vreg { n 1 } { reg-class int-regs } } } { start 0 } { end 100 } { uses V{ 0 100 } } } + T{ live-interval { vreg T{ vreg { n 2 } { reg-class int-regs } } } { start 30 } { end 60 } { uses V{ 30 60 } } } + } + H{ { int-regs { "A" } } } + check-linear-scan +] unit-test + +[ ] [ + { + T{ live-interval { vreg T{ vreg { n 1 } { reg-class int-regs } } } { start 0 } { end 100 } { uses V{ 0 100 } } } + T{ live-interval { vreg T{ vreg { n 2 } { reg-class int-regs } } } { start 30 } { end 200 } { uses V{ 30 200 } } } + } + H{ { int-regs { "A" } } } + check-linear-scan +] unit-test + +[ + { + T{ live-interval { vreg T{ vreg { n 1 } { reg-class int-regs } } } { start 0 } { end 100 } { uses V{ 0 100 } } } + T{ live-interval { vreg T{ vreg { n 2 } { reg-class int-regs } } } { start 30 } { end 100 } { uses V{ 30 100 } } } + } + H{ { int-regs { "A" } } } + check-linear-scan +] must-fail + +SYMBOL: available + +SYMBOL: taken + +SYMBOL: max-registers + +SYMBOL: max-insns + +SYMBOL: max-uses + +: not-taken ( -- n ) + available get keys dup empty? [ "Oops" throw ] when + random + dup taken get nth 1 + max-registers get = [ + dup available get delete-at + ] [ + dup taken get [ 1 + ] change-nth + ] if ; + +: random-live-intervals ( num-intervals max-uses max-registers max-insns -- seq ) + [ + max-insns set + max-registers set + max-uses set + max-insns get [ 0 ] replicate taken set + max-insns get [ dup ] H{ } map>assoc available set + [ + live-interval new + swap int-regs swap vreg boa >>vreg + max-uses get random 2 max [ not-taken ] replicate natural-sort + [ >>uses ] [ first >>start ] bi + dup uses>> peek >>end + ] map + ] with-scope ; + +: random-test ( num-intervals max-uses max-registers max-insns -- ) + over >r random-live-intervals r> int-regs associate check-linear-scan ; + +[ ] [ 30 2 1 60 random-test ] unit-test +[ ] [ 60 2 2 60 random-test ] unit-test +[ ] [ 80 2 3 200 random-test ] unit-test +[ ] [ 70 2 5 30 random-test ] unit-test +[ ] [ 60 2 6 30 random-test ] unit-test +[ ] [ 1 2 10 10 random-test ] unit-test + +[ ] [ 10 4 2 60 random-test ] unit-test +[ ] [ 10 20 2 400 random-test ] unit-test +[ ] [ 10 20 4 300 random-test ] unit-test + +USING: math.private compiler.cfg.debugger ; + +[ ] [ [ float+ float>fixnum 3 fixnum*fast ] test-mr first linear-scan drop ] unit-test + +[ f ] [ + T{ ##allot + f + T{ vreg f int-regs 1 } + 40 + array + T{ vreg f int-regs 2 } + f + } clone + 1array (linear-scan) first regs>> values all-equal? +] unit-test + +[ 0 1 ] [ + { + T{ live-interval + { vreg T{ vreg { reg-class int-regs } { n 1 } } } + { start 0 } + { end 5 } + { uses V{ 0 1 5 } } + } + T{ live-interval + { vreg T{ vreg { reg-class int-regs } { n 2 } } } + { start 3 } + { end 4 } + { uses V{ 3 4 } } + } + T{ live-interval + { vreg T{ vreg { reg-class int-regs } { n 3 } } } + { start 2 } + { end 6 } + { uses V{ 2 4 6 } } + } + } [ clone ] map + H{ { int-regs { "A" "B" } } } + allocate-registers + first split-before>> [ start>> ] [ end>> ] bi +] unit-test + +! Coalescing interacted badly with splitting +[ ] [ + { + T{ live-interval + { vreg V int-regs 70 } + { start 14 } + { end 17 } + { uses V{ 14 15 16 17 } } + { copy-from V int-regs 67 } + } + T{ live-interval + { vreg V int-regs 67 } + { start 13 } + { end 14 } + { uses V{ 13 14 } } + } + T{ live-interval + { vreg V int-regs 30 } + { start 4 } + { end 18 } + { uses V{ 4 12 16 17 18 } } + } + T{ live-interval + { vreg V int-regs 27 } + { start 3 } + { end 13 } + { uses V{ 3 7 13 } } + } + T{ live-interval + { vreg V int-regs 59 } + { start 10 } + { end 18 } + { uses V{ 10 11 12 18 } } + { copy-from V int-regs 56 } + } + T{ live-interval + { vreg V int-regs 60 } + { start 12 } + { end 17 } + { uses V{ 12 17 } } + } + T{ live-interval + { vreg V int-regs 56 } + { start 9 } + { end 10 } + { uses V{ 9 10 } } + } + } + { { int-regs { 0 1 2 3 } } } + allocate-registers drop +] unit-test + +[ ] [ + { + T{ live-interval + { vreg V int-regs 3687168 } + { start 106 } + { end 112 } + { uses V{ 106 112 } } + } + T{ live-interval + { vreg V int-regs 3687169 } + { start 107 } + { end 113 } + { uses V{ 107 113 } } + } + T{ live-interval + { vreg V int-regs 3687727 } + { start 190 } + { end 198 } + { uses V{ 190 195 198 } } + } + T{ live-interval + { vreg V int-regs 3686445 } + { start 43 } + { end 44 } + { uses V{ 43 44 } } + } + T{ live-interval + { vreg V int-regs 3686195 } + { start 5 } + { end 11 } + { uses V{ 5 11 } } + } + T{ live-interval + { vreg V int-regs 3686449 } + { start 44 } + { end 56 } + { uses V{ 44 45 45 46 56 } } + { copy-from V int-regs 3686445 } + } + T{ live-interval + { vreg V int-regs 3686198 } + { start 8 } + { end 10 } + { uses V{ 8 9 10 } } + } + T{ live-interval + { vreg V int-regs 3686454 } + { start 46 } + { end 49 } + { uses V{ 46 47 47 49 } } + { copy-from V int-regs 3686449 } + } + T{ live-interval + { vreg V int-regs 3686196 } + { start 6 } + { end 12 } + { uses V{ 6 12 } } + } + T{ live-interval + { vreg V int-regs 3686197 } + { start 7 } + { end 14 } + { uses V{ 7 13 14 } } + } + T{ live-interval + { vreg V int-regs 3686455 } + { start 48 } + { end 51 } + { uses V{ 48 51 } } + } + T{ live-interval + { vreg V int-regs 3686463 } + { start 52 } + { end 53 } + { uses V{ 52 53 } } + } + T{ live-interval + { vreg V int-regs 3686460 } + { start 49 } + { end 52 } + { uses V{ 49 50 50 52 } } + { copy-from V int-regs 3686454 } + } + T{ live-interval + { vreg V int-regs 3686461 } + { start 51 } + { end 71 } + { uses V{ 51 52 64 68 71 } } + } + T{ live-interval + { vreg V int-regs 3686464 } + { start 53 } + { end 54 } + { uses V{ 53 54 } } + } + T{ live-interval + { vreg V int-regs 3686465 } + { start 54 } + { end 76 } + { uses V{ 54 55 55 76 } } + { copy-from V int-regs 3686464 } + } + T{ live-interval + { vreg V int-regs 3686470 } + { start 58 } + { end 60 } + { uses V{ 58 59 59 60 } } + { copy-from V int-regs 3686469 } + } + T{ live-interval + { vreg V int-regs 3686469 } + { start 56 } + { end 58 } + { uses V{ 56 57 57 58 } } + { copy-from V int-regs 3686449 } + } + T{ live-interval + { vreg V int-regs 3686473 } + { start 60 } + { end 62 } + { uses V{ 60 61 61 62 } } + { copy-from V int-regs 3686470 } + } + T{ live-interval + { vreg V int-regs 3686479 } + { start 62 } + { end 64 } + { uses V{ 62 63 63 64 } } + { copy-from V int-regs 3686473 } + } + T{ live-interval + { vreg V int-regs 3686735 } + { start 78 } + { end 96 } + { uses V{ 78 79 79 96 } } + { copy-from V int-regs 3686372 } + } + T{ live-interval + { vreg V int-regs 3686482 } + { start 64 } + { end 65 } + { uses V{ 64 65 } } + } + T{ live-interval + { vreg V int-regs 3686483 } + { start 65 } + { end 66 } + { uses V{ 65 66 } } + } + T{ live-interval + { vreg V int-regs 3687510 } + { start 168 } + { end 171 } + { uses V{ 168 171 } } + } + T{ live-interval + { vreg V int-regs 3687511 } + { start 169 } + { end 176 } + { uses V{ 169 176 } } + } + T{ live-interval + { vreg V int-regs 3686484 } + { start 66 } + { end 75 } + { uses V{ 66 67 67 75 } } + { copy-from V int-regs 3686483 } + } + T{ live-interval + { vreg V int-regs 3687509 } + { start 162 } + { end 163 } + { uses V{ 162 163 } } + } + T{ live-interval + { vreg V int-regs 3686491 } + { start 68 } + { end 69 } + { uses V{ 68 69 } } + } + T{ live-interval + { vreg V int-regs 3687512 } + { start 170 } + { end 178 } + { uses V{ 170 177 178 } } + } + T{ live-interval + { vreg V int-regs 3687515 } + { start 172 } + { end 173 } + { uses V{ 172 173 } } + } + T{ live-interval + { vreg V int-regs 3686492 } + { start 69 } + { end 74 } + { uses V{ 69 70 70 74 } } + { copy-from V int-regs 3686491 } + } + T{ live-interval + { vreg V int-regs 3687778 } + { start 202 } + { end 208 } + { uses V{ 202 208 } } + } + T{ live-interval + { vreg V int-regs 3686499 } + { start 71 } + { end 72 } + { uses V{ 71 72 } } + } + T{ live-interval + { vreg V int-regs 3687520 } + { start 174 } + { end 175 } + { uses V{ 174 175 } } + } + T{ live-interval + { vreg V int-regs 3687779 } + { start 203 } + { end 209 } + { uses V{ 203 209 } } + } + T{ live-interval + { vreg V int-regs 3687782 } + { start 206 } + { end 207 } + { uses V{ 206 207 } } + } + T{ live-interval + { vreg V int-regs 3686503 } + { start 74 } + { end 75 } + { uses V{ 74 75 } } + } + T{ live-interval + { vreg V int-regs 3686500 } + { start 72 } + { end 74 } + { uses V{ 72 73 73 74 } } + { copy-from V int-regs 3686499 } + } + T{ live-interval + { vreg V int-regs 3687780 } + { start 204 } + { end 210 } + { uses V{ 204 210 } } + } + T{ live-interval + { vreg V int-regs 3686506 } + { start 75 } + { end 76 } + { uses V{ 75 76 } } + } + T{ live-interval + { vreg V int-regs 3687530 } + { start 185 } + { end 192 } + { uses V{ 185 192 } } + } + T{ live-interval + { vreg V int-regs 3687528 } + { start 183 } + { end 198 } + { uses V{ 183 198 } } + } + T{ live-interval + { vreg V int-regs 3687529 } + { start 184 } + { end 197 } + { uses V{ 184 197 } } + } + T{ live-interval + { vreg V int-regs 3687781 } + { start 205 } + { end 211 } + { uses V{ 205 211 } } + } + T{ live-interval + { vreg V int-regs 3687535 } + { start 187 } + { end 194 } + { uses V{ 187 194 } } + } + T{ live-interval + { vreg V int-regs 3686252 } + { start 9 } + { end 17 } + { uses V{ 9 15 17 } } + } + T{ live-interval + { vreg V int-regs 3686509 } + { start 76 } + { end 90 } + { uses V{ 76 87 90 } } + } + T{ live-interval + { vreg V int-regs 3687532 } + { start 186 } + { end 196 } + { uses V{ 186 196 } } + } + T{ live-interval + { vreg V int-regs 3687538 } + { start 188 } + { end 193 } + { uses V{ 188 193 } } + } + T{ live-interval + { vreg V int-regs 3687827 } + { start 217 } + { end 219 } + { uses V{ 217 219 } } + } + T{ live-interval + { vreg V int-regs 3687825 } + { start 215 } + { end 218 } + { uses V{ 215 216 218 } } + } + T{ live-interval + { vreg V int-regs 3687831 } + { start 218 } + { end 219 } + { uses V{ 218 219 } } + } + T{ live-interval + { vreg V int-regs 3686296 } + { start 16 } + { end 18 } + { uses V{ 16 18 } } + } + T{ live-interval + { vreg V int-regs 3686302 } + { start 29 } + { end 31 } + { uses V{ 29 31 } } + } + T{ live-interval + { vreg V int-regs 3687838 } + { start 231 } + { end 232 } + { uses V{ 231 232 } } + } + T{ live-interval + { vreg V int-regs 3686300 } + { start 26 } + { end 27 } + { uses V{ 26 27 } } + } + T{ live-interval + { vreg V int-regs 3686301 } + { start 27 } + { end 30 } + { uses V{ 27 28 28 30 } } + { copy-from V int-regs 3686300 } + } + T{ live-interval + { vreg V int-regs 3686306 } + { start 37 } + { end 93 } + { uses V{ 37 82 93 } } + } + T{ live-interval + { vreg V int-regs 3686307 } + { start 38 } + { end 88 } + { uses V{ 38 85 88 } } + } + T{ live-interval + { vreg V int-regs 3687837 } + { start 222 } + { end 223 } + { uses V{ 222 223 } } + } + T{ live-interval + { vreg V int-regs 3686305 } + { start 36 } + { end 81 } + { uses V{ 36 42 77 81 } } + } + T{ live-interval + { vreg V int-regs 3686310 } + { start 39 } + { end 95 } + { uses V{ 39 84 95 } } + } + T{ live-interval + { vreg V int-regs 3687836 } + { start 227 } + { end 228 } + { uses V{ 227 228 } } + } + T{ live-interval + { vreg V int-regs 3687839 } + { start 239 } + { end 246 } + { uses V{ 239 245 246 } } + } + T{ live-interval + { vreg V int-regs 3687841 } + { start 240 } + { end 241 } + { uses V{ 240 241 } } + } + T{ live-interval + { vreg V int-regs 3687845 } + { start 241 } + { end 243 } + { uses V{ 241 243 } } + } + T{ live-interval + { vreg V int-regs 3686315 } + { start 40 } + { end 94 } + { uses V{ 40 83 94 } } + } + T{ live-interval + { vreg V int-regs 3687846 } + { start 242 } + { end 245 } + { uses V{ 242 245 } } + } + T{ live-interval + { vreg V int-regs 3687849 } + { start 243 } + { end 245 } + { uses V{ 243 244 244 245 } } + { copy-from V int-regs 3687845 } + } + T{ live-interval + { vreg V int-regs 3687850 } + { start 245 } + { end 245 } + { uses V{ 245 } } + } + T{ live-interval + { vreg V int-regs 3687851 } + { start 246 } + { end 246 } + { uses V{ 246 } } + } + T{ live-interval + { vreg V int-regs 3687852 } + { start 246 } + { end 246 } + { uses V{ 246 } } + } + T{ live-interval + { vreg V int-regs 3687853 } + { start 247 } + { end 248 } + { uses V{ 247 248 } } + } + T{ live-interval + { vreg V int-regs 3687854 } + { start 249 } + { end 250 } + { uses V{ 249 250 } } + } + T{ live-interval + { vreg V int-regs 3687855 } + { start 258 } + { end 259 } + { uses V{ 258 259 } } + } + T{ live-interval + { vreg V int-regs 3687080 } + { start 280 } + { end 285 } + { uses V{ 280 285 } } + } + T{ live-interval + { vreg V int-regs 3687081 } + { start 281 } + { end 286 } + { uses V{ 281 286 } } + } + T{ live-interval + { vreg V int-regs 3687082 } + { start 282 } + { end 287 } + { uses V{ 282 287 } } + } + T{ live-interval + { vreg V int-regs 3687083 } + { start 283 } + { end 288 } + { uses V{ 283 288 } } + } + T{ live-interval + { vreg V int-regs 3687085 } + { start 284 } + { end 299 } + { uses V{ 284 285 286 287 288 296 299 } } + } + T{ live-interval + { vreg V int-regs 3687086 } + { start 284 } + { end 284 } + { uses V{ 284 } } + } + T{ live-interval + { vreg V int-regs 3687087 } + { start 289 } + { end 293 } + { uses V{ 289 293 } } + } + T{ live-interval + { vreg V int-regs 3687088 } + { start 290 } + { end 294 } + { uses V{ 290 294 } } + } + T{ live-interval + { vreg V int-regs 3687089 } + { start 291 } + { end 297 } + { uses V{ 291 297 } } + } + T{ live-interval + { vreg V int-regs 3687090 } + { start 292 } + { end 298 } + { uses V{ 292 298 } } + } + T{ live-interval + { vreg V int-regs 3687363 } + { start 118 } + { end 119 } + { uses V{ 118 119 } } + } + T{ live-interval + { vreg V int-regs 3686599 } + { start 77 } + { end 89 } + { uses V{ 77 86 89 } } + } + T{ live-interval + { vreg V int-regs 3687370 } + { start 131 } + { end 132 } + { uses V{ 131 132 } } + } + T{ live-interval + { vreg V int-regs 3687371 } + { start 138 } + { end 143 } + { uses V{ 138 143 } } + } + T{ live-interval + { vreg V int-regs 3687368 } + { start 127 } + { end 128 } + { uses V{ 127 128 } } + } + T{ live-interval + { vreg V int-regs 3687369 } + { start 122 } + { end 123 } + { uses V{ 122 123 } } + } + T{ live-interval + { vreg V int-regs 3687373 } + { start 139 } + { end 140 } + { uses V{ 139 140 } } + } + T{ live-interval + { vreg V int-regs 3686352 } + { start 41 } + { end 91 } + { uses V{ 41 43 79 91 } } + } + T{ live-interval + { vreg V int-regs 3687377 } + { start 140 } + { end 141 } + { uses V{ 140 141 } } + } + T{ live-interval + { vreg V int-regs 3687382 } + { start 143 } + { end 143 } + { uses V{ 143 } } + } + T{ live-interval + { vreg V int-regs 3687383 } + { start 144 } + { end 161 } + { uses V{ 144 159 161 } } + } + T{ live-interval + { vreg V int-regs 3687380 } + { start 141 } + { end 143 } + { uses V{ 141 142 142 143 } } + { copy-from V int-regs 3687377 } + } + T{ live-interval + { vreg V int-regs 3687381 } + { start 143 } + { end 160 } + { uses V{ 143 160 } } + } + T{ live-interval + { vreg V int-regs 3687384 } + { start 145 } + { end 158 } + { uses V{ 145 158 } } + } + T{ live-interval + { vreg V int-regs 3687385 } + { start 146 } + { end 157 } + { uses V{ 146 157 } } + } + T{ live-interval + { vreg V int-regs 3687640 } + { start 189 } + { end 191 } + { uses V{ 189 191 } } + } + T{ live-interval + { vreg V int-regs 3687388 } + { start 147 } + { end 152 } + { uses V{ 147 152 } } + } + T{ live-interval + { vreg V int-regs 3687393 } + { start 148 } + { end 153 } + { uses V{ 148 153 } } + } + T{ live-interval + { vreg V int-regs 3687398 } + { start 149 } + { end 154 } + { uses V{ 149 154 } } + } + T{ live-interval + { vreg V int-regs 3686372 } + { start 42 } + { end 92 } + { uses V{ 42 45 78 80 92 } } + } + T{ live-interval + { vreg V int-regs 3687140 } + { start 293 } + { end 295 } + { uses V{ 293 294 294 295 } } + { copy-from V int-regs 3687087 } + } + T{ live-interval + { vreg V int-regs 3687403 } + { start 150 } + { end 155 } + { uses V{ 150 155 } } + } + T{ live-interval + { vreg V int-regs 3687150 } + { start 304 } + { end 306 } + { uses V{ 304 306 } } + } + T{ live-interval + { vreg V int-regs 3687151 } + { start 305 } + { end 307 } + { uses V{ 305 307 } } + } + T{ live-interval + { vreg V int-regs 3687408 } + { start 151 } + { end 156 } + { uses V{ 151 156 } } + } + T{ live-interval + { vreg V int-regs 3687153 } + { start 312 } + { end 313 } + { uses V{ 312 313 } } + } + T{ live-interval + { vreg V int-regs 3686902 } + { start 267 } + { end 272 } + { uses V{ 267 272 } } + } + T{ live-interval + { vreg V int-regs 3686903 } + { start 268 } + { end 273 } + { uses V{ 268 273 } } + } + T{ live-interval + { vreg V int-regs 3686900 } + { start 265 } + { end 270 } + { uses V{ 265 270 } } + } + T{ live-interval + { vreg V int-regs 3686901 } + { start 266 } + { end 271 } + { uses V{ 266 271 } } + } + T{ live-interval + { vreg V int-regs 3687162 } + { start 100 } + { end 119 } + { uses V{ 100 114 117 119 } } + } + T{ live-interval + { vreg V int-regs 3687163 } + { start 101 } + { end 118 } + { uses V{ 101 115 116 118 } } + } + T{ live-interval + { vreg V int-regs 3686904 } + { start 269 } + { end 274 } + { uses V{ 269 274 } } + } + T{ live-interval + { vreg V int-regs 3687166 } + { start 104 } + { end 110 } + { uses V{ 104 110 } } + } + T{ live-interval + { vreg V int-regs 3687167 } + { start 105 } + { end 111 } + { uses V{ 105 111 } } + } + T{ live-interval + { vreg V int-regs 3687164 } + { start 102 } + { end 108 } + { uses V{ 102 108 } } + } + T{ live-interval + { vreg V int-regs 3687165 } + { start 103 } + { end 109 } + { uses V{ 103 109 } } + } + } + { { int-regs { 0 1 2 3 4 } } } + allocate-registers drop +] unit-test + +! A reduction of the above +[ ] [ + { + T{ live-interval + { vreg V int-regs 6449 } + { start 44 } + { end 56 } + { uses V{ 44 45 46 56 } } + } + T{ live-interval + { vreg V int-regs 6454 } + { start 46 } + { end 49 } + { uses V{ 46 47 49 } } + } + T{ live-interval + { vreg V int-regs 6455 } + { start 48 } + { end 51 } + { uses V{ 48 51 } } + } + T{ live-interval + { vreg V int-regs 6460 } + { start 49 } + { end 52 } + { uses V{ 49 50 52 } } + } + T{ live-interval + { vreg V int-regs 6461 } + { start 51 } + { end 71 } + { uses V{ 51 52 64 68 71 } } + } + T{ live-interval + { vreg V int-regs 6464 } + { start 53 } + { end 54 } + { uses V{ 53 54 } } + } + T{ live-interval + { vreg V int-regs 6470 } + { start 58 } + { end 60 } + { uses V{ 58 59 60 } } + } + T{ live-interval + { vreg V int-regs 6469 } + { start 56 } + { end 58 } + { uses V{ 56 57 58 } } + } + T{ live-interval + { vreg V int-regs 6473 } + { start 60 } + { end 62 } + { uses V{ 60 61 62 } } + } + T{ live-interval + { vreg V int-regs 6479 } + { start 62 } + { end 64 } + { uses V{ 62 63 64 } } + } + T{ live-interval + { vreg V int-regs 6735 } + { start 78 } + { end 96 } + { uses V{ 78 79 96 } } + { copy-from V int-regs 6372 } + } + T{ live-interval + { vreg V int-regs 6483 } + { start 65 } + { end 66 } + { uses V{ 65 66 } } + } + T{ live-interval + { vreg V int-regs 7845 } + { start 91 } + { end 93 } + { uses V{ 91 93 } } + } + T{ live-interval + { vreg V int-regs 6372 } + { start 42 } + { end 92 } + { uses V{ 42 45 78 80 92 } } + } + } + { { int-regs { 0 1 2 3 } } } + allocate-registers drop +] unit-test diff --git a/unfinished/compiler/cfg/linear-scan/linear-scan.factor b/basis/compiler/cfg/linear-scan/linear-scan.factor similarity index 71% rename from unfinished/compiler/cfg/linear-scan/linear-scan.factor rename to basis/compiler/cfg/linear-scan/linear-scan.factor index f62e3a39d1..855f2a6648 100644 --- a/unfinished/compiler/cfg/linear-scan/linear-scan.factor +++ b/basis/compiler/cfg/linear-scan/linear-scan.factor @@ -1,8 +1,9 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel accessors namespaces -compiler.backend +USING: kernel accessors namespaces make +cpu.architecture compiler.cfg +compiler.cfg.instructions compiler.cfg.linear-scan.live-intervals compiler.cfg.linear-scan.allocation compiler.cfg.linear-scan.assignment ; @@ -22,12 +23,16 @@ IN: compiler.cfg.linear-scan ! by Omri Traub, Glenn Holloway, Michael D. Smith ! http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.34.8435 +: (linear-scan) ( insns -- insns' ) + dup compute-live-intervals + machine-registers allocate-registers assign-registers ; + : linear-scan ( mr -- mr' ) [ [ - dup compute-live-intervals - machine-registers allocate-registers - assign-registers + [ + (linear-scan) % + spill-counts get _spill-counts + ] { } make ] change-instructions - spill-counts get >>spill-counts ] with-scope ; diff --git a/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor b/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor new file mode 100644 index 0000000000..1055a3524a --- /dev/null +++ b/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor @@ -0,0 +1,64 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: namespaces kernel assocs accessors sequences math fry +compiler.cfg.instructions compiler.cfg.registers +compiler.cfg.def-use ; +IN: compiler.cfg.linear-scan.live-intervals + +TUPLE: live-interval +vreg +reg spill-to reload-from split-before split-after +start end uses +copy-from ; + +: add-use ( n live-interval -- ) + dup live-interval? [ "No def" throw ] unless + [ (>>end) ] [ uses>> push ] 2bi ; + +: ( start vreg -- live-interval ) + live-interval new + V{ } clone >>uses + swap >>vreg + over >>start + [ add-use ] keep ; + +M: live-interval hashcode* + nip [ start>> ] [ end>> 1000 * ] bi + ; + +M: live-interval clone + call-next-method [ clone ] change-uses ; + +! Mapping from vreg to live-interval +SYMBOL: live-intervals + +: new-live-interval ( n vreg live-intervals -- ) + 2dup key? [ + at add-use + ] [ + [ [ ] keep ] dip set-at + ] if ; + +GENERIC# compute-live-intervals* 1 ( insn n -- ) + +M: insn compute-live-intervals* 2drop ; + +M: vreg-insn compute-live-intervals* + live-intervals get + [ [ uses-vregs ] 2dip '[ _ swap _ at add-use ] each ] + [ [ defs-vregs ] 2dip '[ _ swap _ new-live-interval ] each ] + 3bi ; + +: record-copy ( insn -- ) + [ dst>> live-intervals get at ] [ src>> ] bi >>copy-from drop ; + +M: ##copy compute-live-intervals* + [ call-next-method ] [ drop record-copy ] 2bi ; + +M: ##copy-float compute-live-intervals* + [ call-next-method ] [ drop record-copy ] 2bi ; + +: compute-live-intervals ( instructions -- live-intervals ) + H{ } clone [ + live-intervals set + [ compute-live-intervals* ] each-index + ] keep values ; diff --git a/basis/compiler/cfg/linearization/linearization-tests.factor b/basis/compiler/cfg/linearization/linearization-tests.factor new file mode 100644 index 0000000000..5e866d15db --- /dev/null +++ b/basis/compiler/cfg/linearization/linearization-tests.factor @@ -0,0 +1,4 @@ +IN: compiler.cfg.linearization.tests +USING: compiler.cfg.linearization tools.test ; + +\ build-mr must-infer diff --git a/basis/compiler/cfg/linearization/linearization.factor b/basis/compiler/cfg/linearization/linearization.factor new file mode 100644 index 0000000000..d397c9d448 --- /dev/null +++ b/basis/compiler/cfg/linearization/linearization.factor @@ -0,0 +1,80 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel math accessors sequences namespaces make +combinators classes +compiler.cfg +compiler.cfg.rpo +compiler.cfg.instructions ; +IN: compiler.cfg.linearization + +! Convert CFG IR to machine IR. +GENERIC: linearize-insn ( basic-block insn -- ) + +: linearize-insns ( basic-block -- ) + dup instructions>> [ linearize-insn ] with each ; inline + +M: insn linearize-insn , drop ; + +: useless-branch? ( basic-block successor -- ? ) + #! If our successor immediately follows us in RPO, then we + #! don't need to branch. + [ number>> ] bi@ 1- = ; inline + +: branch-to-branch? ( successor -- ? ) + #! A branch to a block containing just a jump return is cloned. + instructions>> dup length 2 = [ + [ first ##epilogue? ] + [ second [ ##return? ] [ ##jump? ] bi or ] bi and + ] [ drop f ] if ; + +: emit-branch ( basic-block successor -- ) + { + { [ 2dup useless-branch? ] [ 2drop ] } + { [ dup branch-to-branch? ] [ nip linearize-insns ] } + [ nip number>> _branch ] + } cond ; + +M: ##branch linearize-insn + drop dup successors>> first emit-branch ; + +: (binary-conditional) + [ dup successors>> first2 ] + [ [ src1>> ] [ src2>> ] [ cc>> ] tri ] bi* ; inline + +: binary-conditional ( basic-block insn -- basic-block successor label2 src1 src2 cc ) + [ (binary-conditional) ] + [ drop dup successors>> first useless-branch? ] 2bi + [ [ number>> ] 3dip negate-cc ] [ [ swap number>> ] 3dip ] if ; + +M: ##compare-branch linearize-insn + binary-conditional _compare-branch emit-branch ; + +M: ##compare-imm-branch linearize-insn + binary-conditional _compare-imm-branch emit-branch ; + +M: ##compare-float-branch linearize-insn + binary-conditional _compare-float-branch emit-branch ; + +: gc? ( bb -- ? ) + instructions>> [ + class { + ##allot + ##integer>bignum + ##box-float + ##box-alien + } memq? + ] contains? ; + +: linearize-basic-block ( bb -- ) + [ number>> _label ] + [ gc? [ _gc ] when ] + [ linearize-insns ] + tri ; + +: linearize-basic-blocks ( rpo -- insns ) + [ [ linearize-basic-block ] each ] { } make ; + +: build-mr ( cfg -- mr ) + [ entry>> reverse-post-order linearize-basic-blocks ] + [ word>> ] [ label>> ] + tri ; diff --git a/basis/compiler/cfg/optimizer/optimizer.factor b/basis/compiler/cfg/optimizer/optimizer.factor new file mode 100644 index 0000000000..7887faeb61 --- /dev/null +++ b/basis/compiler/cfg/optimizer/optimizer.factor @@ -0,0 +1,29 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel sequences compiler.cfg.rpo +compiler.cfg.instructions +compiler.cfg.predecessors +compiler.cfg.useless-blocks +compiler.cfg.height +compiler.cfg.alias-analysis +compiler.cfg.value-numbering +compiler.cfg.dead-code +compiler.cfg.write-barrier ; +IN: compiler.cfg.optimizer + +: trivial? ( insns -- ? ) + dup length 2 = [ first ##call? ] [ drop f ] if ; + +: optimize-cfg ( cfg -- cfg' ) + compute-predecessors + delete-useless-blocks + delete-useless-conditionals + [ + dup trivial? [ + normalize-height + alias-analysis + value-numbering + eliminate-dead-code + eliminate-write-barriers + ] unless + ] change-basic-blocks ; diff --git a/basis/compiler/cfg/predecessors/predecessors.factor b/basis/compiler/cfg/predecessors/predecessors.factor new file mode 100644 index 0000000000..01a2a771bc --- /dev/null +++ b/basis/compiler/cfg/predecessors/predecessors.factor @@ -0,0 +1,10 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel accessors sequences compiler.cfg.rpo ; +IN: compiler.cfg.predecessors + +: (compute-predecessors) ( bb -- ) + dup successors>> [ predecessors>> push ] with each ; + +: compute-predecessors ( cfg -- cfg' ) + dup [ (compute-predecessors) ] each-basic-block ; diff --git a/basis/compiler/cfg/registers/registers.factor b/basis/compiler/cfg/registers/registers.factor new file mode 100644 index 0000000000..21572ec615 --- /dev/null +++ b/basis/compiler/cfg/registers/registers.factor @@ -0,0 +1,37 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors namespaces kernel arrays +parser prettyprint.backend prettyprint.sections ; +IN: compiler.cfg.registers + +! Virtual registers, used by CFG and machine IRs +TUPLE: vreg { reg-class read-only } { n read-only } ; +SYMBOL: vreg-counter +: next-vreg ( reg-class -- vreg ) \ vreg-counter counter vreg boa ; + +! Stack locations +TUPLE: loc { n read-only } ; + +TUPLE: ds-loc < loc ; +C: ds-loc + +TUPLE: rs-loc < loc ; +C: rs-loc + +! Prettyprinting +: V scan-word scan-word vreg boa parsed ; parsing + +M: vreg pprint* + > pprint* ] [ n>> pprint* ] bi + block> ; + +: pprint-loc ( loc word -- ) > pprint* block> ; + +: D scan-word parsed ; parsing + +M: ds-loc pprint* \ D pprint-loc ; + +: R scan-word parsed ; parsing + +M: rs-loc pprint* \ R pprint-loc ; diff --git a/basis/compiler/cfg/rpo/rpo.factor b/basis/compiler/cfg/rpo/rpo.factor new file mode 100644 index 0000000000..7f4b09e68f --- /dev/null +++ b/basis/compiler/cfg/rpo/rpo.factor @@ -0,0 +1,32 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel accessors namespaces make math sequences sets +assocs fry compiler.cfg.instructions ; +IN: compiler.cfg.rpo + +SYMBOL: visited + +: post-order-traversal ( bb -- ) + dup id>> visited get key? [ drop ] [ + dup id>> visited get conjoin + [ successors>> [ post-order-traversal ] each ] [ , ] bi + ] if ; + +: post-order ( bb -- blocks ) + [ post-order-traversal ] { } make ; + +: number-blocks ( blocks -- ) + [ >>number drop ] each-index ; + +: reverse-post-order ( bb -- blocks ) + H{ } clone visited [ + post-order dup number-blocks + ] with-variable ; inline + +: each-basic-block ( cfg quot -- ) + [ entry>> reverse-post-order ] dip each ; inline + +: change-basic-blocks ( cfg quot -- cfg' ) + [ '[ _ change-instructions drop ] each-basic-block ] + [ drop ] + 2bi ; inline diff --git a/unfinished/compiler/cfg/stack-frame/stack-frame.factor b/basis/compiler/cfg/stack-frame/stack-frame.factor similarity index 60% rename from unfinished/compiler/cfg/stack-frame/stack-frame.factor rename to basis/compiler/cfg/stack-frame/stack-frame.factor index 6ec34d37c2..ec9ffaba49 100644 --- a/unfinished/compiler/cfg/stack-frame/stack-frame.factor +++ b/basis/compiler/cfg/stack-frame/stack-frame.factor @@ -1,43 +1,45 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: namespaces accessors math.order assocs kernel sequences -make compiler.cfg.instructions compiler.cfg.instructions.syntax -compiler.cfg.registers ; +combinators make classes words cpu.architecture +compiler.cfg.instructions compiler.cfg.registers ; IN: compiler.cfg.stack-frame SYMBOL: frame-required? SYMBOL: spill-counts -: init-stack-frame-builder ( -- ) - frame-required? off - T{ stack-frame } clone stack-frame set ; - GENERIC: compute-stack-frame* ( insn -- ) : max-stack-frame ( frame1 frame2 -- frame3 ) - { - [ [ size>> ] bi@ max ] - [ [ params>> ] bi@ max ] - [ [ return>> ] bi@ max ] - [ [ total-size>> ] bi@ max ] - } cleave - stack-frame boa ; + [ stack-frame new ] 2dip + [ [ params>> ] bi@ max >>params ] + [ [ return>> ] bi@ max >>return ] + 2bi ; M: ##stack-frame compute-stack-frame* frame-required? on stack-frame>> stack-frame [ max-stack-frame ] change ; -M: _spill-integer compute-stack-frame* - drop frame-required? on ; +M: ##call compute-stack-frame* + word>> sub-primitive>> [ frame-required? on ] unless ; -M: _spill-float compute-stack-frame* - drop frame-required? on ; +M: _spill-counts compute-stack-frame* + counts>> stack-frame get (>>spill-counts) ; -M: insn compute-stack-frame* drop ; +M: insn compute-stack-frame* + class frame-required? word-prop [ + frame-required? on + ] when ; + +\ _gc t frame-required? set-word-prop +\ _spill t frame-required? set-word-prop : compute-stack-frame ( insns -- ) - [ compute-stack-frame* ] each ; + frame-required? off + T{ stack-frame } clone stack-frame set + [ compute-stack-frame* ] each + stack-frame get dup stack-frame-size >>total-size drop ; GENERIC: insert-pro/epilogues* ( insn -- ) @@ -56,7 +58,6 @@ M: insn insert-pro/epilogues* , ; : build-stack-frame ( mr -- mr ) [ - init-stack-frame-builder [ [ compute-stack-frame ] [ insert-pro/epilogues ] diff --git a/basis/compiler/generator/fixup/authors.txt b/basis/compiler/cfg/stacks/authors.txt similarity index 100% rename from basis/compiler/generator/fixup/authors.txt rename to basis/compiler/cfg/stacks/authors.txt diff --git a/basis/compiler/cfg/stacks/stacks.factor b/basis/compiler/cfg/stacks/stacks.factor new file mode 100755 index 0000000000..f138f673e0 --- /dev/null +++ b/basis/compiler/cfg/stacks/stacks.factor @@ -0,0 +1,33 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: math sequences kernel cpu.architecture +compiler.cfg.instructions compiler.cfg.registers +compiler.cfg.hats ; +IN: compiler.cfg.stacks + +: ds-drop ( -- ) + -1 ##inc-d ; + +: ds-pop ( -- vreg ) + D 0 ^^peek -1 ##inc-d ; + +: ds-push ( vreg -- ) + 1 ##inc-d D 0 ##replace ; + +: ds-load ( n -- vregs ) + [ [ ^^peek ] map ] [ neg ##inc-d ] bi ; + +: ds-store ( vregs -- ) + [ length ##inc-d ] [ [ ##replace ] each-index ] bi ; + +: rs-load ( n -- vregs ) + [ [ ^^peek ] map ] [ neg ##inc-r ] bi ; + +: rs-store ( vregs -- ) + [ length ##inc-r ] [ [ ##replace ] each-index ] bi ; + +: 2inputs ( -- vreg1 vreg2 ) + D 1 ^^peek D 0 ^^peek -2 ##inc-d ; + +: 3inputs ( -- vreg1 vreg2 vreg3 ) + D 2 ^^peek D 1 ^^peek D 0 ^^peek -3 ##inc-d ; diff --git a/basis/compiler/cfg/two-operand/two-operand.factor b/basis/compiler/cfg/two-operand/two-operand.factor new file mode 100644 index 0000000000..e943fb4828 --- /dev/null +++ b/basis/compiler/cfg/two-operand/two-operand.factor @@ -0,0 +1,60 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors arrays kernel sequences sequences.deep +compiler.cfg.instructions cpu.architecture ; +IN: compiler.cfg.two-operand + +! On x86, instructions take the form x = x op y +! Our SSA IR is x = y op z + +! We don't bother with ##add, ##add-imm or ##sub-imm since x86 +! has a LEA instruction which is effectively a three-operand +! addition + +: make-copy ( dst src -- insn ) f \ ##copy boa ; inline + +: make-copy/float ( dst src -- insn ) f \ ##copy-float boa ; inline + +: convert-two-operand/integer ( insn -- insns ) + [ [ dst>> ] [ src1>> ] bi make-copy ] + [ dup dst>> >>src1 ] + bi 2array ; inline + +: convert-two-operand/float ( insn -- insns ) + [ [ dst>> ] [ src1>> ] bi make-copy/float ] + [ dup dst>> >>src1 ] + bi 2array ; inline + +GENERIC: convert-two-operand* ( insn -- insns ) + +M: ##not convert-two-operand* + [ [ dst>> ] [ src>> ] bi make-copy ] + [ dup dst>> >>src ] + bi 2array ; + +M: ##sub convert-two-operand* convert-two-operand/integer ; +M: ##mul convert-two-operand* convert-two-operand/integer ; +M: ##mul-imm convert-two-operand* convert-two-operand/integer ; +M: ##and convert-two-operand* convert-two-operand/integer ; +M: ##and-imm convert-two-operand* convert-two-operand/integer ; +M: ##or convert-two-operand* convert-two-operand/integer ; +M: ##or-imm convert-two-operand* convert-two-operand/integer ; +M: ##xor convert-two-operand* convert-two-operand/integer ; +M: ##xor-imm convert-two-operand* convert-two-operand/integer ; +M: ##shl-imm convert-two-operand* convert-two-operand/integer ; +M: ##shr-imm convert-two-operand* convert-two-operand/integer ; +M: ##sar-imm convert-two-operand* convert-two-operand/integer ; + +M: ##add-float convert-two-operand* convert-two-operand/float ; +M: ##sub-float convert-two-operand* convert-two-operand/float ; +M: ##mul-float convert-two-operand* convert-two-operand/float ; +M: ##div-float convert-two-operand* convert-two-operand/float ; + +M: insn convert-two-operand* ; + +: convert-two-operand ( mr -- mr' ) + [ + two-operand? [ + [ convert-two-operand* ] map flatten + ] when + ] change-instructions ; diff --git a/basis/compiler/cfg/useless-blocks/useless-blocks.factor b/basis/compiler/cfg/useless-blocks/useless-blocks.factor new file mode 100644 index 0000000000..f543aa4036 --- /dev/null +++ b/basis/compiler/cfg/useless-blocks/useless-blocks.factor @@ -0,0 +1,55 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel accessors sequences combinators classes vectors +compiler.cfg compiler.cfg.rpo compiler.cfg.instructions ; +IN: compiler.cfg.useless-blocks + +: update-predecessor-for-delete ( bb -- ) + dup predecessors>> first [ + [ + 2dup eq? [ drop successors>> first ] [ nip ] if + ] with map + ] change-successors drop ; + +: update-successor-for-delete ( bb -- ) + [ predecessors>> first ] + [ successors>> first predecessors>> ] + bi set-first ; + +: delete-basic-block ( bb -- ) + [ update-predecessor-for-delete ] + [ update-successor-for-delete ] + bi ; + +: delete-basic-block? ( bb -- ? ) + { + { [ dup instructions>> length 1 = not ] [ f ] } + { [ dup predecessors>> length 1 = not ] [ f ] } + { [ dup successors>> length 1 = not ] [ f ] } + { [ dup instructions>> first ##branch? not ] [ f ] } + [ t ] + } cond nip ; + +: delete-useless-blocks ( cfg -- cfg' ) + dup [ + dup delete-basic-block? [ delete-basic-block ] [ drop ] if + ] each-basic-block ; + +: delete-conditional? ( bb -- ? ) + dup instructions>> [ drop f ] [ + peek class { + ##compare-branch + ##compare-imm-branch + ##compare-float-branch + } memq? [ successors>> first2 eq? ] [ drop f ] if + ] if-empty ; + +: delete-conditional ( bb -- ) + dup successors>> first 1vector >>successors + [ but-last f \ ##branch boa suffix ] change-instructions + drop ; + +: delete-useless-conditionals ( cfg -- cfg' ) + dup [ + dup delete-conditional? [ delete-conditional ] [ drop ] if + ] each-basic-block ; diff --git a/basis/compiler/cfg/utilities/utilities.factor b/basis/compiler/cfg/utilities/utilities.factor new file mode 100644 index 0000000000..cef14d06e4 --- /dev/null +++ b/basis/compiler/cfg/utilities/utilities.factor @@ -0,0 +1,37 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors kernel math layouts make sequences combinators +cpu.architecture namespaces compiler.cfg +compiler.cfg.instructions ; +IN: compiler.cfg.utilities + +: value-info-small-fixnum? ( value-info -- ? ) + literal>> { + { [ dup fixnum? ] [ tag-fixnum small-enough? ] } + [ drop f ] + } cond ; + +: value-info-small-tagged? ( value-info -- ? ) + dup literal?>> [ + literal>> { + { [ dup fixnum? ] [ tag-fixnum small-enough? ] } + { [ dup not ] [ drop t ] } + [ drop f ] + } cond + ] [ drop f ] if ; + +: set-basic-block ( basic-block -- ) + [ basic-block set ] [ instructions>> building set ] bi ; + +: begin-basic-block ( -- ) + basic-block get [ + dupd successors>> push + ] when* + set-basic-block ; + +: end-basic-block ( -- ) + building off + basic-block off ; + +: emit-primitive ( node -- ) + word>> ##call ##branch begin-basic-block ; diff --git a/basis/compiler/cfg/value-numbering/expressions/expressions.factor b/basis/compiler/cfg/value-numbering/expressions/expressions.factor new file mode 100644 index 0000000000..476ba7d0ab --- /dev/null +++ b/basis/compiler/cfg/value-numbering/expressions/expressions.factor @@ -0,0 +1,88 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors classes kernel math namespaces combinators +compiler.cfg.instructions compiler.cfg.value-numbering.graph ; +IN: compiler.cfg.value-numbering.expressions + +! Referentially-transparent expressions +TUPLE: expr op ; +TUPLE: unary-expr < expr in ; +TUPLE: binary-expr < expr in1 in2 ; +TUPLE: commutative-expr < binary-expr ; +TUPLE: compare-expr < binary-expr cc ; +TUPLE: constant-expr < expr value ; + +: ( constant -- expr ) + f swap constant-expr boa ; inline + +M: constant-expr equal? + over constant-expr? [ + [ [ value>> ] bi@ = ] + [ [ value>> class ] bi@ = ] 2bi + and + ] [ 2drop f ] if ; + +SYMBOL: input-expr-counter + +: next-input-expr ( -- n ) + input-expr-counter [ dup 1 + ] change ; + +! Expressions whose values are inputs to the basic block. We +! can eliminate a second computation having the same 'n' as +! the first one; we can also eliminate input-exprs whose +! result is not used. +TUPLE: input-expr < expr n ; + +: constant>vn ( constant -- vn ) expr>vn ; inline + +GENERIC: >expr ( insn -- expr ) + +M: ##load-immediate >expr val>> ; + +M: ##load-indirect >expr obj>> ; + +M: ##unary >expr + [ class ] [ src>> vreg>vn ] bi unary-expr boa ; + +M: ##binary >expr + [ class ] [ src1>> vreg>vn ] [ src2>> vreg>vn ] tri + binary-expr boa ; + +M: ##binary-imm >expr + [ class ] [ src1>> vreg>vn ] [ src2>> constant>vn ] tri + binary-expr boa ; + +M: ##commutative >expr + [ class ] [ src1>> vreg>vn ] [ src2>> vreg>vn ] tri + commutative-expr boa ; + +M: ##commutative-imm >expr + [ class ] [ src1>> vreg>vn ] [ src2>> constant>vn ] tri + commutative-expr boa ; + +: compare>expr ( insn -- expr ) + { + [ class ] + [ src1>> vreg>vn ] + [ src2>> vreg>vn ] + [ cc>> ] + } cleave compare-expr boa ; inline + +M: ##compare >expr compare>expr ; + +: compare-imm>expr ( insn -- expr ) + { + [ class ] + [ src1>> vreg>vn ] + [ src2>> constant>vn ] + [ cc>> ] + } cleave compare-expr boa ; inline + +M: ##compare-imm >expr compare-imm>expr ; + +M: ##compare-float >expr compare>expr ; + +M: ##flushable >expr class next-input-expr input-expr boa ; + +: init-expressions ( -- ) + 0 input-expr-counter set ; diff --git a/unfinished/compiler/cfg.bluesky/vn/graph/graph.factor b/basis/compiler/cfg/value-numbering/graph/graph.factor similarity index 64% rename from unfinished/compiler/cfg.bluesky/vn/graph/graph.factor rename to basis/compiler/cfg/value-numbering/graph/graph.factor index ef5d7c2d46..7ec9eaf7ce 100644 --- a/unfinished/compiler/cfg.bluesky/vn/graph/graph.factor +++ b/basis/compiler/cfg/value-numbering/graph/graph.factor @@ -1,20 +1,11 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel math namespaces assocs biassocs accessors -math.order prettyprint.backend parser ; -IN: compiler.cfg.vn.graph - -TUPLE: vn n ; +USING: accessors kernel math namespaces assocs biassocs ; +IN: compiler.cfg.value-numbering.graph SYMBOL: vn-counter -: next-vn ( -- vn ) vn-counter [ dup 1 + ] change vn boa ; - -: VN: scan-word vn boa parsed ; parsing - -M: vn <=> [ n>> ] compare ; - -M: vn pprint* \ VN: pprint-word n>> pprint* ; +: next-vn ( -- vn ) vn-counter [ dup 1 + ] change ; ! biassoc mapping expressions to value numbers SYMBOL: exprs>vns @@ -31,6 +22,10 @@ SYMBOL: vregs>vns : set-vn ( vn vreg -- ) vregs>vns get set-at ; +: vreg>expr ( vreg -- expr ) vreg>vn vn>expr ; inline + +: vn>constant ( vn -- constant ) vn>expr value>> ; inline + : init-value-graph ( -- ) 0 vn-counter set exprs>vns set diff --git a/basis/compiler/cfg/value-numbering/propagate/propagate.factor b/basis/compiler/cfg/value-numbering/propagate/propagate.factor new file mode 100644 index 0000000000..a3c9725838 --- /dev/null +++ b/basis/compiler/cfg/value-numbering/propagate/propagate.factor @@ -0,0 +1,65 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: namespaces assocs sequences kernel accessors +compiler.cfg.instructions compiler.cfg.value-numbering.graph ; +IN: compiler.cfg.value-numbering.propagate + +! If two vregs compute the same value, replace references to +! the latter with the former. + +: resolve ( vreg -- vreg' ) vreg>vn vn>vreg ; inline + +GENERIC: propagate ( insn -- insn ) + +M: ##effect propagate + [ resolve ] change-src ; + +M: ##unary propagate + [ resolve ] change-src ; + +M: ##binary propagate + [ resolve ] change-src1 + [ resolve ] change-src2 ; + +M: ##binary-imm propagate + [ resolve ] change-src1 ; + +M: ##slot propagate + [ resolve ] change-obj + [ resolve ] change-slot ; + +M: ##slot-imm propagate + [ resolve ] change-obj ; + +M: ##set-slot propagate + call-next-method + [ resolve ] change-obj + [ resolve ] change-slot ; + +M: ##string-nth propagate + [ resolve ] change-obj + [ resolve ] change-index ; + +M: ##set-slot-imm propagate + call-next-method + [ resolve ] change-obj ; + +M: ##alien-getter propagate + call-next-method + [ resolve ] change-src ; + +M: ##alien-setter propagate + call-next-method + [ resolve ] change-value ; + +M: ##conditional-branch propagate + [ resolve ] change-src1 + [ resolve ] change-src2 ; + +M: ##compare-imm-branch propagate + [ resolve ] change-src1 ; + +M: ##dispatch propagate + [ resolve ] change-src ; + +M: insn propagate ; diff --git a/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor b/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor new file mode 100644 index 0000000000..94c3f0d6f9 --- /dev/null +++ b/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor @@ -0,0 +1,116 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel sequences layouts accessors combinators namespaces +math +compiler.cfg.instructions +compiler.cfg.value-numbering.graph +compiler.cfg.value-numbering.simplify +compiler.cfg.value-numbering.expressions ; +IN: compiler.cfg.value-numbering.rewrite + +GENERIC: rewrite ( insn -- insn' ) + +M: ##mul-imm rewrite + dup src2>> dup power-of-2? [ + [ [ dst>> ] [ src1>> ] bi ] [ log2 ] bi* f \ ##shl-imm boa + dup number-values + ] [ drop ] if ; + +: ##branch-t? ( insn -- ? ) + dup ##compare-imm-branch? [ + [ cc>> cc/= eq? ] + [ src2>> \ f tag-number eq? ] bi and + ] [ drop f ] if ; inline + +: rewrite-boolean-comparison? ( insn -- ? ) + dup ##branch-t? [ + src1>> vreg>expr compare-expr? + ] [ drop f ] if ; inline + +: >compare-expr< ( expr -- in1 in2 cc ) + [ in1>> vn>vreg ] [ in2>> vn>vreg ] [ cc>> ] tri ; inline + +: >compare-imm-expr< ( expr -- in1 in2 cc ) + [ in1>> vn>vreg ] [ in2>> vn>constant ] [ cc>> ] tri ; inline + +: rewrite-boolean-comparison ( expr -- insn ) + src1>> vreg>expr dup op>> { + { \ ##compare [ >compare-expr< f \ ##compare-branch boa ] } + { \ ##compare-imm [ >compare-imm-expr< f \ ##compare-imm-branch boa ] } + { \ ##compare-float [ >compare-expr< f \ ##compare-float-branch boa ] } + } case ; + +: tag-fixnum-expr? ( expr -- ? ) + dup op>> \ ##shl-imm eq? + [ in2>> vn>constant tag-bits get = ] [ drop f ] if ; + +: rewrite-tagged-comparison? ( insn -- ? ) + #! Are we comparing two tagged fixnums? Then untag them. + [ src1>> vreg>expr tag-fixnum-expr? ] + [ src2>> tag-mask get bitand 0 = ] + bi and ; inline + +: (rewrite-tagged-comparison) ( insn -- src1 src2 cc ) + [ src1>> vreg>expr in1>> vn>vreg ] + [ src2>> tag-bits get neg shift ] + [ cc>> ] + tri ; inline + +GENERIC: rewrite-tagged-comparison ( insn -- insn' ) + +M: ##compare-imm-branch rewrite-tagged-comparison + (rewrite-tagged-comparison) f \ ##compare-imm-branch boa ; + +M: ##compare-imm rewrite-tagged-comparison + [ dst>> ] [ (rewrite-tagged-comparison) ] bi + f \ ##compare-imm boa ; + +M: ##compare-imm-branch rewrite + dup rewrite-boolean-comparison? [ rewrite-boolean-comparison ] when + dup ##compare-imm-branch? [ + dup rewrite-tagged-comparison? [ rewrite-tagged-comparison ] when + ] when ; + +: flip-comparison? ( insn -- ? ) + dup cc>> cc= eq? [ src1>> vreg>expr constant-expr? ] [ drop f ] if ; + +: flip-comparison ( insn -- insn' ) + [ dst>> ] + [ src2>> ] + [ src1>> vreg>vn vn>constant ] tri + cc= f \ ##compare-imm boa ; + +M: ##compare rewrite + dup flip-comparison? [ + flip-comparison + dup number-values + rewrite + ] when ; + +: rewrite-redundant-comparison? ( insn -- ? ) + [ src1>> vreg>expr compare-expr? ] + [ src2>> \ f tag-number = ] + [ cc>> { cc= cc/= } memq? ] + tri and and ; inline + +: rewrite-redundant-comparison ( insn -- insn' ) + [ cc>> ] [ dst>> ] [ src1>> vreg>expr dup op>> ] tri { + { \ ##compare [ >compare-expr< f \ ##compare boa ] } + { \ ##compare-imm [ >compare-imm-expr< f \ ##compare-imm boa ] } + { \ ##compare-float [ >compare-expr< f \ ##compare-float boa ] } + } case + swap cc= eq? [ [ negate-cc ] change-cc ] when ; + +M: ##compare-imm rewrite + dup rewrite-redundant-comparison? [ + rewrite-redundant-comparison + dup number-values rewrite + ] when + dup ##compare-imm? [ + dup rewrite-tagged-comparison? [ + rewrite-tagged-comparison + dup number-values rewrite + ] when + ] when ; + +M: insn rewrite ; diff --git a/basis/compiler/cfg/value-numbering/simplify/simplify.factor b/basis/compiler/cfg/value-numbering/simplify/simplify.factor new file mode 100644 index 0000000000..e70ba4b54b --- /dev/null +++ b/basis/compiler/cfg/value-numbering/simplify/simplify.factor @@ -0,0 +1,74 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel accessors combinators classes math layouts +compiler.cfg.instructions +compiler.cfg.value-numbering.graph +compiler.cfg.value-numbering.expressions ; +IN: compiler.cfg.value-numbering.simplify + +! Return value of f means we didn't simplify. +GENERIC: simplify* ( expr -- vn/expr/f ) + +: simplify-unbox ( in boxer -- vn/expr/f ) + over op>> eq? [ in>> ] [ drop f ] if ; inline + +: simplify-unbox-float ( in -- vn/expr/f ) + \ ##box-float simplify-unbox ; inline + +: simplify-unbox-alien ( in -- vn/expr/f ) + \ ##box-alien simplify-unbox ; inline + +M: unary-expr simplify* + #! Note the copy propagation: a copy always simplifies to + #! its source VN. + [ in>> vn>expr ] [ op>> ] bi { + { \ ##copy [ ] } + { \ ##copy-float [ ] } + { \ ##unbox-float [ simplify-unbox-float ] } + { \ ##unbox-alien [ simplify-unbox-alien ] } + { \ ##unbox-any-c-ptr [ simplify-unbox-alien ] } + [ 2drop f ] + } case ; + +: expr-zero? ( expr -- ? ) T{ constant-expr f f 0 } = ; inline + +: >binary-expr< ( expr -- in1 in2 ) + [ in1>> vn>expr ] [ in2>> vn>expr ] bi ; inline + +: simplify-add ( expr -- vn/expr/f ) + >binary-expr< { + { [ over expr-zero? ] [ nip ] } + { [ dup expr-zero? ] [ drop ] } + [ 2drop f ] + } cond ; inline + +: useless-shift? ( in1 in2 -- ? ) + over op>> \ ##shl-imm eq? + [ [ in2>> ] [ expr>vn ] bi* = ] [ 2drop f ] if ; inline + +: simplify-shift ( expr -- vn/expr/f ) + >binary-expr< + 2dup useless-shift? [ drop in1>> ] [ 2drop f ] if ; inline + +M: binary-expr simplify* + dup op>> { + { \ ##add [ simplify-add ] } + { \ ##add-imm [ simplify-add ] } + { \ ##shr-imm [ simplify-shift ] } + { \ ##sar-imm [ simplify-shift ] } + [ 2drop f ] + } case ; + +M: expr simplify* drop f ; + +: simplify ( expr -- vn ) + dup simplify* { + { [ dup not ] [ drop expr>vn ] } + { [ dup expr? ] [ expr>vn nip ] } + { [ dup integer? ] [ nip ] } + } cond ; + +GENERIC: number-values ( insn -- ) + +M: ##flushable number-values [ >expr simplify ] [ dst>> ] bi set-vn ; +M: insn number-values drop ; diff --git a/basis/compiler/cfg/value-numbering/value-numbering-tests.factor b/basis/compiler/cfg/value-numbering/value-numbering-tests.factor new file mode 100644 index 0000000000..d3be68c3c9 --- /dev/null +++ b/basis/compiler/cfg/value-numbering/value-numbering-tests.factor @@ -0,0 +1,142 @@ +IN: compiler.cfg.value-numbering.tests +USING: compiler.cfg.value-numbering compiler.cfg.instructions +compiler.cfg.registers cpu.architecture tools.test kernel math ; +[ + { + T{ ##peek f V int-regs 45 D 1 } + T{ ##copy f V int-regs 48 V int-regs 45 } + T{ ##compare-imm-branch f V int-regs 45 7 cc/= } + } +] [ + { + T{ ##peek f V int-regs 45 D 1 } + T{ ##copy f V int-regs 48 V int-regs 45 } + T{ ##compare-imm-branch f V int-regs 48 7 cc/= } + } value-numbering +] unit-test + +[ + { + T{ ##load-immediate f V int-regs 2 8 } + T{ ##peek f V int-regs 3 D 0 } + T{ ##slot-imm f V int-regs 4 V int-regs 3 1 3 } + T{ ##replace f V int-regs 4 D 0 } + } +] [ + { + T{ ##load-immediate f V int-regs 2 8 } + T{ ##peek f V int-regs 3 D 0 } + T{ ##slot-imm f V int-regs 4 V int-regs 3 1 3 } + T{ ##replace f V int-regs 4 D 0 } + } value-numbering +] unit-test + +[ t ] [ + { + T{ ##peek f V int-regs 1 D 0 } + T{ ##dispatch f V int-regs 1 V int-regs 2 } + } dup value-numbering = +] unit-test + +[ t ] [ + { + T{ ##peek f V int-regs 16 D 0 } + T{ ##peek f V int-regs 17 D -1 } + T{ ##sar-imm f V int-regs 18 V int-regs 17 3 } + T{ ##add-imm f V int-regs 19 V int-regs 16 13 } + T{ ##add f V int-regs 21 V int-regs 18 V int-regs 19 } + T{ ##alien-unsigned-1 f V int-regs 22 V int-regs 21 } + T{ ##shl-imm f V int-regs 23 V int-regs 22 3 } + T{ ##replace f V int-regs 23 D 0 } + } dup value-numbering = +] unit-test + +[ + { + T{ ##peek f V int-regs 1 D 0 } + T{ ##shl-imm f V int-regs 2 V int-regs 1 3 } + T{ ##shr-imm f V int-regs 3 V int-regs 2 3 } + T{ ##replace f V int-regs 1 D 0 } + } +] [ + { + T{ ##peek f V int-regs 1 D 0 } + T{ ##mul-imm f V int-regs 2 V int-regs 1 8 } + T{ ##shr-imm f V int-regs 3 V int-regs 2 3 } + T{ ##replace f V int-regs 3 D 0 } + } value-numbering +] unit-test + +[ + { + T{ ##load-indirect f V int-regs 1 + } + T{ ##peek f V int-regs 2 D 0 } + T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc> } + T{ ##compare f V int-regs 6 V int-regs 2 V int-regs 1 cc> } + T{ ##replace f V int-regs 4 D 0 } + } +] [ + { + T{ ##load-indirect f V int-regs 1 + } + T{ ##peek f V int-regs 2 D 0 } + T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc> } + T{ ##compare-imm f V int-regs 6 V int-regs 4 7 cc/= } + T{ ##replace f V int-regs 6 D 0 } + } value-numbering +] unit-test + +[ + { + T{ ##load-indirect f V int-regs 1 + } + T{ ##peek f V int-regs 2 D 0 } + T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc<= } + T{ ##compare f V int-regs 6 V int-regs 2 V int-regs 1 cc> } + T{ ##replace f V int-regs 6 D 0 } + } +] [ + { + T{ ##load-indirect f V int-regs 1 + } + T{ ##peek f V int-regs 2 D 0 } + T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc<= } + T{ ##compare-imm f V int-regs 6 V int-regs 4 7 cc= } + T{ ##replace f V int-regs 6 D 0 } + } value-numbering +] unit-test + +[ + { + T{ ##peek f V int-regs 8 D 0 } + T{ ##peek f V int-regs 9 D -1 } + T{ ##unbox-float f V double-float-regs 10 V int-regs 8 } + T{ ##unbox-float f V double-float-regs 11 V int-regs 9 } + T{ ##compare-float f V int-regs 12 V double-float-regs 10 V double-float-regs 11 cc< } + T{ ##compare-float f V int-regs 14 V double-float-regs 10 V double-float-regs 11 cc>= } + T{ ##replace f V int-regs 14 D 0 } + } +] [ + { + T{ ##peek f V int-regs 8 D 0 } + T{ ##peek f V int-regs 9 D -1 } + T{ ##unbox-float f V double-float-regs 10 V int-regs 8 } + T{ ##unbox-float f V double-float-regs 11 V int-regs 9 } + T{ ##compare-float f V int-regs 12 V double-float-regs 10 V double-float-regs 11 cc< } + T{ ##compare-imm f V int-regs 14 V int-regs 12 7 cc= } + T{ ##replace f V int-regs 14 D 0 } + } value-numbering +] unit-test + +[ + { + T{ ##peek f V int-regs 29 D -1 } + T{ ##peek f V int-regs 30 D -2 } + T{ ##compare f V int-regs 33 V int-regs 29 V int-regs 30 cc<= } + T{ ##compare-branch f V int-regs 29 V int-regs 30 cc<= } + } +] [ + { + T{ ##peek f V int-regs 29 D -1 } + T{ ##peek f V int-regs 30 D -2 } + T{ ##compare f V int-regs 33 V int-regs 29 V int-regs 30 cc<= } + T{ ##compare-imm-branch f V int-regs 33 7 cc/= } + } value-numbering +] unit-test diff --git a/basis/compiler/cfg/value-numbering/value-numbering.factor b/basis/compiler/cfg/value-numbering/value-numbering.factor new file mode 100644 index 0000000000..d17b2a7e1f --- /dev/null +++ b/basis/compiler/cfg/value-numbering/value-numbering.factor @@ -0,0 +1,15 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: namespaces assocs biassocs classes kernel math accessors +sorting sets sequences +compiler.cfg.value-numbering.graph +compiler.cfg.value-numbering.expressions +compiler.cfg.value-numbering.propagate +compiler.cfg.value-numbering.simplify +compiler.cfg.value-numbering.rewrite ; +IN: compiler.cfg.value-numbering + +: value-numbering ( insns -- insns' ) + init-value-graph + init-expressions + [ [ number-values ] [ rewrite propagate ] bi ] map ; diff --git a/basis/compiler/cfg/write-barrier/write-barrier-tests.factor b/basis/compiler/cfg/write-barrier/write-barrier-tests.factor new file mode 100644 index 0000000000..7a4b1c488f --- /dev/null +++ b/basis/compiler/cfg/write-barrier/write-barrier-tests.factor @@ -0,0 +1,72 @@ +USING: compiler.cfg.write-barrier compiler.cfg.instructions +compiler.cfg.registers cpu.architecture arrays tools.test ; +IN: compiler.cfg.write-barrier.tests + +[ + { + T{ ##peek f V int-regs 4 D 0 f } + T{ ##copy f V int-regs 6 V int-regs 4 f } + T{ ##allot f V int-regs 7 24 array V int-regs 8 f } + T{ ##load-immediate f V int-regs 9 8 f } + T{ ##set-slot-imm f V int-regs 9 V int-regs 7 1 3 f } + T{ ##set-slot-imm f V int-regs 6 V int-regs 7 2 3 f } + T{ ##replace f V int-regs 7 D 0 f } + } +] [ + { + T{ ##peek f V int-regs 4 D 0 } + T{ ##copy f V int-regs 6 V int-regs 4 } + T{ ##allot f V int-regs 7 24 array V int-regs 8 } + T{ ##load-immediate f V int-regs 9 8 } + T{ ##set-slot-imm f V int-regs 9 V int-regs 7 1 3 } + T{ ##write-barrier f V int-regs 7 V int-regs 10 V int-regs 11 } + T{ ##set-slot-imm f V int-regs 6 V int-regs 7 2 3 } + T{ ##write-barrier f V int-regs 7 V int-regs 12 V int-regs 13 } + T{ ##replace f V int-regs 7 D 0 } + } eliminate-write-barriers +] unit-test + +[ + { + T{ ##load-immediate f V int-regs 4 24 } + T{ ##peek f V int-regs 5 D -1 } + T{ ##peek f V int-regs 6 D -2 } + T{ ##set-slot-imm f V int-regs 5 V int-regs 6 3 2 } + T{ ##write-barrier f V int-regs 6 V int-regs 7 V int-regs 8 } + } +] [ + { + T{ ##load-immediate f V int-regs 4 24 } + T{ ##peek f V int-regs 5 D -1 } + T{ ##peek f V int-regs 6 D -2 } + T{ ##set-slot-imm f V int-regs 5 V int-regs 6 3 2 } + T{ ##write-barrier f V int-regs 6 V int-regs 7 V int-regs 8 } + } eliminate-write-barriers +] unit-test + +[ + { + T{ ##peek f V int-regs 19 D -3 } + T{ ##peek f V int-regs 22 D -2 } + T{ ##copy f V int-regs 23 V int-regs 19 } + T{ ##set-slot-imm f V int-regs 22 V int-regs 23 3 2 } + T{ ##write-barrier f V int-regs 23 V int-regs 24 V int-regs 25 } + T{ ##copy f V int-regs 26 V int-regs 19 } + T{ ##peek f V int-regs 28 D -1 } + T{ ##copy f V int-regs 29 V int-regs 19 } + T{ ##set-slot-imm f V int-regs 28 V int-regs 29 4 2 } + } +] [ + { + T{ ##peek f V int-regs 19 D -3 } + T{ ##peek f V int-regs 22 D -2 } + T{ ##copy f V int-regs 23 V int-regs 19 } + T{ ##set-slot-imm f V int-regs 22 V int-regs 23 3 2 } + T{ ##write-barrier f V int-regs 23 V int-regs 24 V int-regs 25 } + T{ ##copy f V int-regs 26 V int-regs 19 } + T{ ##peek f V int-regs 28 D -1 } + T{ ##copy f V int-regs 29 V int-regs 19 } + T{ ##set-slot-imm f V int-regs 28 V int-regs 29 4 2 } + T{ ##write-barrier f V int-regs 29 V int-regs 30 V int-regs 3 } + } eliminate-write-barriers +] unit-test diff --git a/basis/compiler/cfg/write-barrier/write-barrier.factor b/basis/compiler/cfg/write-barrier/write-barrier.factor new file mode 100644 index 0000000000..4a55cb3266 --- /dev/null +++ b/basis/compiler/cfg/write-barrier/write-barrier.factor @@ -0,0 +1,42 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel accessors namespaces assocs sets sequences locals +compiler.cfg compiler.cfg.instructions compiler.cfg.copy-prop ; +IN: compiler.cfg.write-barrier + +! Eliminate redundant write barrier hits. + +! Objects which have already been marked, as well as +! freshly-allocated objects +SYMBOL: safe + +! Objects which have been mutated +SYMBOL: mutated + +GENERIC: eliminate-write-barrier ( insn -- insn' ) + +M: ##allot eliminate-write-barrier + dup dst>> safe get conjoin ; + +M: ##write-barrier eliminate-write-barrier + dup src>> resolve dup + [ safe get key? not ] + [ mutated get key? ] bi and + [ safe get conjoin ] [ 2drop f ] if ; + +M: ##copy eliminate-write-barrier + dup record-copy ; + +M: ##set-slot eliminate-write-barrier + dup obj>> resolve mutated get conjoin ; + +M: ##set-slot-imm eliminate-write-barrier + dup obj>> resolve mutated get conjoin ; + +M: insn eliminate-write-barrier ; + +: eliminate-write-barriers ( insns -- insns' ) + H{ } clone safe set + H{ } clone mutated set + H{ } clone copies set + [ eliminate-write-barrier ] map sift ; diff --git a/unfinished/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor similarity index 54% rename from unfinished/compiler/codegen/codegen.factor rename to basis/compiler/codegen/codegen.factor index fe6b45e88a..35d4d59253 100644 --- a/unfinished/compiler/codegen/codegen.factor +++ b/basis/compiler/codegen/codegen.factor @@ -1,30 +1,28 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: namespaces make math math.parser sequences accessors +USING: namespaces make math math.order math.parser sequences accessors kernel kernel.private layouts assocs words summary arrays combinators classes.algebra alien alien.c-types alien.structs -alien.strings sets threads libc continuations.private +alien.strings alien.arrays sets threads libc continuations.private +fry cpu.architecture compiler.errors compiler.alien -compiler.backend -compiler.codegen.fixup compiler.cfg compiler.cfg.instructions compiler.cfg.registers -compiler.cfg.builder ; +compiler.cfg.builder +compiler.codegen.fixup ; IN: compiler.codegen GENERIC: generate-insn ( insn -- ) -GENERIC: v>operand ( obj -- operand ) - SYMBOL: registers -M: constant v>operand - value>> [ tag-fixnum ] [ \ f tag-number ] if* ; +: register ( vreg -- operand ) + registers get at [ "Bad value" throw ] unless* ; -M: value v>operand - >vreg [ registers get at ] [ "Bad value" throw ] if* ; +: ?register ( obj -- operand ) + dup vreg? [ register ] when ; : generate-insns ( insns -- code ) [ @@ -68,118 +66,156 @@ SYMBOL: labels : lookup-label ( id -- label ) labels get [ drop