From fefea85514bd5b3caba1514eb16b16e6ff64d51d Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 30 Jun 2009 14:56:58 -0500 Subject: [PATCH 01/14] working on imagebin --- extra/webapps/imagebin/imagebin.factor | 23 ++++++++++++++++++----- 1 file changed, 18 insertions(+), 5 deletions(-) diff --git a/extra/webapps/imagebin/imagebin.factor b/extra/webapps/imagebin/imagebin.factor index f347377d95..7c63c51eee 100755 --- a/extra/webapps/imagebin/imagebin.factor +++ b/extra/webapps/imagebin/imagebin.factor @@ -1,10 +1,15 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors kernel furnace.actions html.forms -http.server.dispatchers db db.tuples db.types urls -furnace.redirection multiline http namespaces ; +USING: accessors db db.tuples db.types furnace.actions +furnace.redirection html.forms http http.server +http.server.dispatchers io.directories io.pathnames kernel +multiline namespaces urls ; IN: webapps.imagebin +SYMBOL: image-directory + +image-directory [ "resource:images" ] initialize + TUPLE: imagebin < dispatcher ; TUPLE: image id path ; @@ -16,24 +21,32 @@ image "IMAGE" { : ( -- action ) + image-directory get >>temporary-directory { imagebin "uploaded-image" } >>template ; SYMBOL: my-post-data : ( -- action ) { imagebin "upload-image" } >>template + image-directory get >>temporary-directory [ - - ! request get post-data>> my-post-data set-global + "file1" param [ + temporary-path>> image-directory get move-file + ] when* ! image new ! "file" value ! insert-tuple "uploaded-image" ] >>submit ; +: initialize-image-directory ( -- ) + image-directory get make-directories ; + : ( -- responder ) imagebin new-dispatcher "" add-responder "upload-image" add-responder "uploaded-image" add-responder ; +initialize-image-directory + main-responder set-global From ea072731d4d6f2e586de418be213803a65099470 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 30 Jun 2009 15:31:48 -0500 Subject: [PATCH 02/14] add branch splitting pass to compiler.cfg --- .../compiler/cfg/branch-splitting/authors.txt | 1 + .../branch-splitting/branch-splitting.factor | 29 +++++++++++++++++++ 2 files changed, 30 insertions(+) create mode 100644 basis/compiler/cfg/branch-splitting/authors.txt create mode 100644 basis/compiler/cfg/branch-splitting/branch-splitting.factor diff --git a/basis/compiler/cfg/branch-splitting/authors.txt b/basis/compiler/cfg/branch-splitting/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/basis/compiler/cfg/branch-splitting/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/basis/compiler/cfg/branch-splitting/branch-splitting.factor b/basis/compiler/cfg/branch-splitting/branch-splitting.factor new file mode 100644 index 0000000000..2b3d88191c --- /dev/null +++ b/basis/compiler/cfg/branch-splitting/branch-splitting.factor @@ -0,0 +1,29 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors combinators.short-circuit compiler.cfg.def-use +compiler.cfg.rpo kernel math sequences ; +IN: compiler.cfg.branch-splitting + +: split-branch ( branch -- ) + [ + [ instructions>> ] [ predecessors>> ] bi [ + instructions>> [ pop* ] [ push-all ] bi + ] with each + ] [ + [ successors>> ] [ predecessors>> ] bi [ + [ drop clone ] change-successors drop + ] with each + ] bi ; + +: split-branches? ( bb -- ? ) + { + [ predecessors>> length 1 >= ] + [ successors>> length 1 <= ] + [ instructions>> [ defs-vregs ] any? not ] + [ instructions>> [ temp-vregs ] any? not ] + } 1&& ; + +: split-branches ( cfg -- cfg' ) + dup [ + dup split-branches? [ split-branch ] [ drop ] if + ] each-basic-block f >>post-order ; From f41f84436cd6079bf5a788cbd123031477f05885 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 30 Jun 2009 15:40:13 -0500 Subject: [PATCH 03/14] spill to spill-temp, not to virtual spill addresses --- .../linear-scan/resolve/resolve-tests.factor | 26 +++++++++---------- .../cfg/linear-scan/resolve/resolve.factor | 20 +++++--------- 2 files changed, 20 insertions(+), 26 deletions(-) diff --git a/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor b/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor index 7579b46175..df9f29e999 100644 --- a/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor +++ b/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor @@ -68,12 +68,12 @@ T{ live-interval [ { T{ _copy { dst 5 } { src 4 } { class int-regs } } - T{ _spill { src 0 } { class int-regs } { n 6 } } + T{ _spill { src 0 } { class int-regs } { n spill-temp } } T{ _copy { dst 0 } { src 1 } { class int-regs } } - T{ _reload { dst 1 } { class int-regs } { n 6 } } - T{ _spill { src 0 } { class float-regs } { n 7 } } + T{ _reload { dst 1 } { class int-regs } { n spill-temp } } + T{ _spill { src 0 } { class float-regs } { n spill-temp } } T{ _copy { dst 0 } { src 1 } { class float-regs } } - T{ _reload { dst 1 } { class float-regs } { n 7 } } + T{ _reload { dst 1 } { class float-regs } { n spill-temp } } } ] [ { @@ -87,10 +87,10 @@ T{ live-interval [ { - T{ _spill { src 0 } { class int-regs } { n 3 } } + T{ _spill { src 0 } { class int-regs } { n spill-temp } } T{ _copy { dst 0 } { src 2 } { class int-regs } } T{ _copy { dst 2 } { src 1 } { class int-regs } } - T{ _reload { dst 1 } { class int-regs } { n 3 } } + T{ _reload { dst 1 } { class int-regs } { n spill-temp } } } ] [ { @@ -102,10 +102,10 @@ T{ live-interval [ { - T{ _spill { src 0 } { class int-regs } { n 3 } } + T{ _spill { src 0 } { class int-regs } { n spill-temp } } T{ _copy { dst 0 } { src 2 } { class int-regs } } T{ _copy { dst 2 } { src 1 } { class int-regs } } - T{ _reload { dst 1 } { class int-regs } { n 3 } } + T{ _reload { dst 1 } { class int-regs } { n spill-temp } } } ] [ { @@ -136,7 +136,7 @@ T{ live-interval ] unit-test [ - { T{ _spill { src 4 } { class int-regs } { n 4 } } } + { T{ _spill { src 4 } { class int-regs } { n spill-temp } } } ] [ { T{ register->memory { from 4 } { to 4 } { reg-class int-regs } } @@ -162,10 +162,10 @@ T{ live-interval { T{ _copy { dst 1 } { src 0 } { class int-regs } } T{ _copy { dst 2 } { src 0 } { class int-regs } } - T{ _spill { src 3 } { class int-regs } { n 5 } } + T{ _spill { src 3 } { class int-regs } { n spill-temp } } T{ _copy { dst 4 } { src 0 } { class int-regs } } T{ _copy { dst 3 } { src 4 } { class int-regs } } - T{ _reload { dst 0 } { class int-regs } { n 5 } } + T{ _reload { dst 0 } { class int-regs } { n spill-temp } } } ] [ { @@ -182,10 +182,10 @@ T{ live-interval T{ _copy { dst 2 } { src 0 } { class int-regs } } T{ _copy { dst 9 } { src 1 } { class int-regs } } T{ _copy { dst 1 } { src 0 } { class int-regs } } - T{ _spill { src 3 } { class int-regs } { n 10 } } + T{ _spill { src 3 } { class int-regs } { n spill-temp } } T{ _copy { dst 4 } { src 0 } { class int-regs } } T{ _copy { dst 3 } { src 4 } { class int-regs } } - T{ _reload { dst 0 } { class int-regs } { n 10 } } + T{ _reload { dst 0 } { class int-regs } { n spill-temp } } } ] [ { diff --git a/basis/compiler/cfg/linear-scan/resolve/resolve.factor b/basis/compiler/cfg/linear-scan/resolve/resolve.factor index 182686a0fa..b996520546 100644 --- a/basis/compiler/cfg/linear-scan/resolve/resolve.factor +++ b/basis/compiler/cfg/linear-scan/resolve/resolve.factor @@ -68,10 +68,10 @@ M: memory->memory >insn [ from>> ] [ to>> ] bi = [ "Not allowed" throw ] unless ; M: register->memory >insn - [ from>> ] [ reg-class>> ] [ to>> ] tri _spill ; + [ from>> ] [ reg-class>> ] bi spill-temp _spill ; M: memory->register >insn - [ to>> ] [ reg-class>> ] [ from>> ] tri _reload ; + [ to>> ] [ reg-class>> ] bi spill-temp _reload ; M: register->register >insn [ to>> ] [ from>> ] [ reg-class>> ] tri _copy ; @@ -82,10 +82,10 @@ M: memory->memory >collision-table [ from>> ] [ to>> ] bi = [ "Not allowed" throw ] unless ; M: register->memory >collision-table - [ from>> ] [ reg-class>> ] [ to>> ] tri _spill ; + [ from>> ] [ reg-class>> ] bi spill-temp _spill ; M: memory->register >collision-table - [ to>> ] [ reg-class>> ] [ from>> ] tri _reload ; + [ to>> ] [ reg-class>> ] bi spill-temp _reload ; M: register->register >collision-table [ to>> ] [ from>> ] [ reg-class>> ] tri _copy ; @@ -119,10 +119,6 @@ M: register->register to-loc drop register ; : independent-assignment? ( operations -- pair ) to-reg froms get key? not ; -: init-temp-spill ( operations -- ) - [ [ to>> ] [ from>> ] bi max ] [ max ] map-reduce - 1 + temp-spill set ; - : set-tos/froms ( operations -- ) [ [ [ from-reg ] keep ] H{ } map>assoc froms set ] [ [ [ to-reg ] keep ] H{ } map>assoc tos set ] @@ -146,10 +142,10 @@ M: register->register to-loc drop register ; : break-cycle-n ( operations -- operations' ) unclip [ - [ from>> temp-spill get ] + [ from>> spill-temp ] [ reg-class>> ] bi \ register->memory boa ] [ - [ to>> temp-spill [ get ] [ inc ] bi swap ] + [ to>> spill-temp swap ] [ reg-class>> ] bi \ memory->register boa ] bi [ 1array ] bi@ surround ; @@ -182,9 +178,7 @@ M: register->register to-loc drop register ; : mapping-instructions ( mappings -- insns ) [ - [ init-temp-spill ] - [ set-tos/froms ] - [ parallel-mappings ] tri + [ set-tos/froms ] [ parallel-mappings ] bi [ [ >insn ] each ] { } make ] with-scope ; From 578b0126fc09f25d5bfa6793174b9a832e43df52 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 30 Jun 2009 16:07:58 -0500 Subject: [PATCH 04/14] compiler.cfg.linear-scan: compute-free-pos was broken in the case where more than one inactive interval had the same physical register assigned --- .../linear-scan/allocation/allocation.factor | 24 +++++--- .../linear-scan/assignment/assignment.factor | 10 +++- .../cfg/linear-scan/linear-scan-tests.factor | 56 ++++++++++++++++++- 3 files changed, 79 insertions(+), 11 deletions(-) diff --git a/basis/compiler/cfg/linear-scan/allocation/allocation.factor b/basis/compiler/cfg/linear-scan/allocation/allocation.factor index 4425050d4b..d948fe37ff 100644 --- a/basis/compiler/cfg/linear-scan/allocation/allocation.factor +++ b/basis/compiler/cfg/linear-scan/allocation/allocation.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors assocs heaps kernel namespaces sequences fry math -combinators arrays sorting compiler.utilities +math.order combinators arrays sorting compiler.utilities compiler.cfg.linear-scan.live-intervals compiler.cfg.linear-scan.allocation.coalescing compiler.cfg.linear-scan.allocation.spilling @@ -12,17 +12,23 @@ IN: compiler.cfg.linear-scan.allocation : free-positions ( new -- assoc ) vreg>> reg-class>> registers get at [ 1/0. ] H{ } map>assoc ; -: active-positions ( new -- assoc ) - vreg>> active-intervals-for [ reg>> 0 ] H{ } map>assoc ; +: add-use-position ( n reg assoc -- ) [ [ min ] when* ] change-at ; -: inactive-positions ( new -- assoc ) - dup vreg>> inactive-intervals-for - [ [ reg>> swap ] keep relevant-ranges intersect-live-ranges ] - with H{ } map>assoc ; +: active-positions ( new assoc -- ) + [ vreg>> active-intervals-for ] dip + '[ [ 0 ] dip reg>> _ add-use-position ] each ; + +: inactive-positions ( new assoc -- ) + [ [ vreg>> inactive-intervals-for ] keep ] dip + '[ + [ _ relevant-ranges intersect-live-ranges ] [ reg>> ] bi + _ add-use-position + ] each ; : compute-free-pos ( new -- free-pos ) - [ free-positions ] [ inactive-positions ] [ active-positions ] tri - 3array assoc-combine >alist alist-max ; + dup free-positions + [ inactive-positions ] [ active-positions ] [ nip ] 2tri + >alist alist-max ; : no-free-registers? ( result -- ? ) second 0 = ; inline diff --git a/basis/compiler/cfg/linear-scan/assignment/assignment.factor b/basis/compiler/cfg/linear-scan/assignment/assignment.factor index e55f42e774..1a7f32a0ea 100644 --- a/basis/compiler/cfg/linear-scan/assignment/assignment.factor +++ b/basis/compiler/cfg/linear-scan/assignment/assignment.factor @@ -104,8 +104,16 @@ GENERIC: assign-registers-in-insn ( insn -- ) : all-vregs ( insn -- vregs ) [ defs-vregs ] [ temp-vregs ] [ uses-vregs ] tri 3append ; +SYMBOL: check-assignment? + +ERROR: overlapping-registers intervals ; + : active-intervals ( insn -- intervals ) - insn#>> pending-intervals get [ covers? ] with filter ; + insn#>> pending-intervals get [ covers? ] with filter + check-assignment? get [ + dup [ reg>> ] map all-unique? + [ overlapping-registers ] unless + ] when ; M: vreg-insn assign-registers-in-insn dup [ active-intervals ] [ all-vregs ] bi diff --git a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor index 49352da0f7..5d11e2a5a0 100644 --- a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor +++ b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor @@ -18,10 +18,12 @@ compiler.cfg.linear-scan.allocation compiler.cfg.linear-scan.allocation.state compiler.cfg.linear-scan.allocation.splitting compiler.cfg.linear-scan.allocation.spilling -compiler.cfg.linear-scan.assignment compiler.cfg.linear-scan.debugger ; +FROM: compiler.cfg.linear-scan.assignment => check-assignment? ; + check-allocation? on +check-assignment? on [ { T{ live-range f 1 10 } T{ live-range f 15 15 } } @@ -1417,6 +1419,58 @@ USING: math.private ; relevant-ranges intersect-live-ranges ] unit-test +! compute-free-pos had problems because it used map>assoc where the sequence +! had multiple keys +[ { 0 10 } ] [ + H{ { int-regs { 0 1 } } } registers set + H{ + { int-regs + { + T{ live-interval + { vreg V int-regs 1 } + { start 0 } + { end 20 } + { reg 0 } + { ranges V{ T{ live-range f 0 2 } T{ live-range f 10 20 } } } + { uses V{ 0 2 10 20 } } + } + + T{ live-interval + { vreg V int-regs 2 } + { start 4 } + { end 40 } + { reg 0 } + { ranges V{ T{ live-range f 4 6 } T{ live-range f 30 40 } } } + { uses V{ 4 6 30 40 } } + } + } + } + } inactive-intervals set + H{ + { int-regs + { + T{ live-interval + { vreg V int-regs 3 } + { start 0 } + { end 40 } + { reg 1 } + { ranges V{ T{ live-range f 0 40 } } } + { uses V{ 0 40 } } + } + } + } + } active-intervals set + + T{ live-interval + { vreg V int-regs 4 } + { start 8 } + { end 10 } + { ranges V{ T{ live-range f 8 10 } } } + { uses V{ 8 10 } } + } + compute-free-pos +] unit-test + ! Bug in live spill slots calculation V{ T{ ##prologue } T{ ##branch } } 0 test-bb From b61b47922fb13569fa6d747db2cd172e2b3aab6c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 30 Jun 2009 16:08:16 -0500 Subject: [PATCH 05/14] disjoint-sets: add some tests for compiler bug; eventually more tests should be written for this vocab --- basis/disjoint-sets/disjoint-sets-tests.factor | 16 ++++++++++++++++ 1 file changed, 16 insertions(+) create mode 100644 basis/disjoint-sets/disjoint-sets-tests.factor diff --git a/basis/disjoint-sets/disjoint-sets-tests.factor b/basis/disjoint-sets/disjoint-sets-tests.factor new file mode 100644 index 0000000000..74746f1a3a --- /dev/null +++ b/basis/disjoint-sets/disjoint-sets-tests.factor @@ -0,0 +1,16 @@ +IN: disjoint-sets.testes +USING: tools.test disjoint-sets namespaces slots.private ; + +SYMBOL: +blah+ +-405534154 +blah+ 1 set-slot + +SYMBOL: uf + +[ ] [ + uf set + +blah+ uf get add-atom + 19026 uf get add-atom + 19026 +blah+ uf get equate +] unit-test + +[ 2 ] [ 19026 uf get equiv-set-size ] unit-test From d1f6871081efeb085bc6cb5e61fa2ed2d9539bf7 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 30 Jun 2009 16:44:14 -0500 Subject: [PATCH 06/14] fix bug where traversal order was lost --- .../cfg/instructions/instructions.factor | 2 +- .../linear-scan/resolve/resolve-tests.factor | 30 +++++++++---------- .../cfg/linear-scan/resolve/resolve.factor | 22 +++++++++++--- 3 files changed, 34 insertions(+), 20 deletions(-) diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor index 5b3e1af930..4ce9c59e7e 100644 --- a/basis/compiler/cfg/instructions/instructions.factor +++ b/basis/compiler/cfg/instructions/instructions.factor @@ -248,4 +248,4 @@ INSN: _reload dst class n ; INSN: _copy dst src class ; INSN: _spill-counts counts ; -SYMBOL: temp-spill +SYMBOL: spill-temp diff --git a/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor b/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor index df9f29e999..feb9ac2504 100644 --- a/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor +++ b/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor @@ -68,12 +68,12 @@ T{ live-interval [ { T{ _copy { dst 5 } { src 4 } { class int-regs } } - T{ _spill { src 0 } { class int-regs } { n spill-temp } } - T{ _copy { dst 0 } { src 1 } { class int-regs } } - T{ _reload { dst 1 } { class int-regs } { n spill-temp } } - T{ _spill { src 0 } { class float-regs } { n spill-temp } } - T{ _copy { dst 0 } { src 1 } { class float-regs } } - T{ _reload { dst 1 } { class float-regs } { n spill-temp } } + T{ _spill { src 1 } { class int-regs } { n spill-temp } } + T{ _copy { dst 1 } { src 0 } { class int-regs } } + T{ _reload { dst 0 } { class int-regs } { n spill-temp } } + T{ _spill { src 1 } { class float-regs } { n spill-temp } } + T{ _copy { dst 1 } { src 0 } { class float-regs } } + T{ _reload { dst 0 } { class float-regs } { n spill-temp } } } ] [ { @@ -87,10 +87,10 @@ T{ live-interval [ { - T{ _spill { src 0 } { class int-regs } { n spill-temp } } - T{ _copy { dst 0 } { src 2 } { class int-regs } } + T{ _spill { src 2 } { class int-regs } { n spill-temp } } T{ _copy { dst 2 } { src 1 } { class int-regs } } - T{ _reload { dst 1 } { class int-regs } { n spill-temp } } + T{ _copy { dst 1 } { src 0 } { class int-regs } } + T{ _reload { dst 0 } { class int-regs } { n spill-temp } } } ] [ { @@ -162,10 +162,10 @@ T{ live-interval { T{ _copy { dst 1 } { src 0 } { class int-regs } } T{ _copy { dst 2 } { src 0 } { class int-regs } } - T{ _spill { src 3 } { class int-regs } { n spill-temp } } + T{ _spill { src 4 } { class int-regs } { n spill-temp } } T{ _copy { dst 4 } { src 0 } { class int-regs } } - T{ _copy { dst 3 } { src 4 } { class int-regs } } - T{ _reload { dst 0 } { class int-regs } { n spill-temp } } + T{ _copy { dst 0 } { src 3 } { class int-regs } } + T{ _reload { dst 3 } { class int-regs } { n spill-temp } } } ] [ { @@ -182,10 +182,10 @@ T{ live-interval T{ _copy { dst 2 } { src 0 } { class int-regs } } T{ _copy { dst 9 } { src 1 } { class int-regs } } T{ _copy { dst 1 } { src 0 } { class int-regs } } - T{ _spill { src 3 } { class int-regs } { n spill-temp } } + T{ _spill { src 4 } { class int-regs } { n spill-temp } } T{ _copy { dst 4 } { src 0 } { class int-regs } } - T{ _copy { dst 3 } { src 4 } { class int-regs } } - T{ _reload { dst 0 } { class int-regs } { n spill-temp } } + T{ _copy { dst 0 } { src 3 } { class int-regs } } + T{ _reload { dst 3 } { class int-regs } { n spill-temp } } } ] [ { diff --git a/basis/compiler/cfg/linear-scan/resolve/resolve.factor b/basis/compiler/cfg/linear-scan/resolve/resolve.factor index b996520546..bd7528291d 100644 --- a/basis/compiler/cfg/linear-scan/resolve/resolve.factor +++ b/basis/compiler/cfg/linear-scan/resolve/resolve.factor @@ -126,22 +126,36 @@ M: register->register to-loc drop register ; :: (trace-chain) ( obj hashtable -- ) obj to-reg froms get at* [ + dup , obj over hashtable clone [ maybe-set-at ] keep swap - [ (trace-chain) ] [ , drop ] if + [ (trace-chain) ] [ 2drop ] if ] [ - drop hashtable , + drop ] if ; : trace-chain ( obj -- seq ) [ + dup , dup dup associate (trace-chain) - ] { } make [ keys ] map concat reverse ; + ] { } make prune reverse ; + : trace-chains ( seq -- seq' ) [ trace-chain ] map concat ; -: break-cycle-n ( operations -- operations' ) +ERROR: resolve-error ; + +: split-cycle ( operations -- chain spilled-operation ) unclip [ + [ set-tos/froms ] + [ + [ start? ] find nip + [ resolve-error ] unless* trace-chain + ] bi + ] dip ; + +: break-cycle-n ( operations -- operations' ) + split-cycle [ [ from>> spill-temp ] [ reg-class>> ] bi \ register->memory boa ] [ From fc6c9e2dfde7ebfb63de5fa89dfcc00514b4b772 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 30 Jun 2009 16:47:22 -0500 Subject: [PATCH 07/14] cpu.x86: don't clobber src in %dispatch --- basis/cpu/x86/32/32.factor | 4 ++-- basis/cpu/x86/64/64.factor | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor index b591b254f8..e908f52952 100755 --- a/basis/cpu/x86/32/32.factor +++ b/basis/cpu/x86/32/32.factor @@ -29,10 +29,10 @@ M: x86.32 temp-reg-2 EDX ; M:: x86.32 %dispatch ( src temp -- ) ! Load jump table base. - src HEX: ffffffff ADD + temp src HEX: ffffffff [+] LEA 0 rc-absolute-cell rel-here ! Go - src HEX: 7f [+] JMP + temp HEX: 7f [+] JMP ! Fix up the displacement above cell code-alignment [ 7 + building get dup pop* push ] diff --git a/basis/cpu/x86/64/64.factor b/basis/cpu/x86/64/64.factor index 3a7221c239..2c8fb3f18f 100644 --- a/basis/cpu/x86/64/64.factor +++ b/basis/cpu/x86/64/64.factor @@ -27,8 +27,8 @@ M:: x86.64 %dispatch ( src temp -- ) temp HEX: ffffffff MOV 0 rc-absolute-cell rel-here ! Add jump table base - src temp ADD - src HEX: 7f [+] JMP + temp src ADD + temp HEX: 7f [+] JMP ! Fix up the displacement above cell code-alignment [ 15 + building get dup pop* push ] From e8390ebace0233bd87035e041c482b8f310bed34 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 30 Jun 2009 17:39:36 -0500 Subject: [PATCH 08/14] imagebin does the right thing now --- extra/webapps/imagebin/imagebin.factor | 55 ++++++++++------------- extra/webapps/imagebin/uploaded-image.xml | 2 +- 2 files changed, 25 insertions(+), 32 deletions(-) diff --git a/extra/webapps/imagebin/imagebin.factor b/extra/webapps/imagebin/imagebin.factor index 7c63c51eee..bb8720466c 100755 --- a/extra/webapps/imagebin/imagebin.factor +++ b/extra/webapps/imagebin/imagebin.factor @@ -1,52 +1,45 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors db db.tuples db.types furnace.actions -furnace.redirection html.forms http http.server -http.server.dispatchers io.directories io.pathnames kernel -multiline namespaces urls ; +USING: accessors furnace.actions furnace.redirection +html.forms http http.server http.server.dispatchers +io.directories io.encodings.utf8 io.files io.pathnames +kernel math.parser multiline namespaces sequences urls ; IN: webapps.imagebin -SYMBOL: image-directory - -image-directory [ "resource:images" ] initialize - -TUPLE: imagebin < dispatcher ; - -TUPLE: image id path ; - -image "IMAGE" { - { "id" "ID" INTEGER +db-assigned-id+ } - { "path" "PATH" { VARCHAR 256 } +not-null+ } -} define-persistent +TUPLE: imagebin < dispatcher path n ; : ( -- action ) - image-directory get >>temporary-directory { imagebin "uploaded-image" } >>template ; -SYMBOL: my-post-data +: next-image-path ( -- path ) + imagebin get + [ path>> ] [ n>> number>string ] bi append-path ; + +M: imagebin call-responder* + [ imagebin set ] [ call-next-method ] bi ; + +: move-image ( mime-file -- ) + next-image-path + [ [ temporary-path>> ] dip move-file ] + [ [ filename>> ] dip ".txt" append utf8 set-file-contents ] 2bi ; + : ( -- action ) { imagebin "upload-image" } >>template - image-directory get >>temporary-directory [ - "file1" param [ - temporary-path>> image-directory get move-file - ] when* - ! image new - ! "file" value - ! insert-tuple + "file1" param [ move-image ] when* + "file2" param [ move-image ] when* + "file3" param [ move-image ] when* "uploaded-image" ] >>submit ; -: initialize-image-directory ( -- ) - image-directory get make-directories ; - -: ( -- responder ) +: ( image-directory -- responder ) imagebin new-dispatcher + swap [ make-directories ] [ >>path ] bi + 0 >>n "" add-responder "upload-image" add-responder "uploaded-image" add-responder ; -initialize-image-directory - main-responder set-global +"resource:images" main-responder set-global diff --git a/extra/webapps/imagebin/uploaded-image.xml b/extra/webapps/imagebin/uploaded-image.xml index 903be5cca4..79dfabc924 100644 --- a/extra/webapps/imagebin/uploaded-image.xml +++ b/extra/webapps/imagebin/uploaded-image.xml @@ -2,6 +2,6 @@ Uploaded -hi from uploaded-image +You uploaded something! From 54876d0cba8e892e5298166d456c191fd43e53d1 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 30 Jun 2009 18:10:53 -0500 Subject: [PATCH 09/14] compiler.cfg.linear-scan.assignment: get check-assignment? to work with coalescing --- .../compiler/cfg/linear-scan/assignment/assignment.factor | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/basis/compiler/cfg/linear-scan/assignment/assignment.factor b/basis/compiler/cfg/linear-scan/assignment/assignment.factor index 1a7f32a0ea..ea717f9218 100644 --- a/basis/compiler/cfg/linear-scan/assignment/assignment.factor +++ b/basis/compiler/cfg/linear-scan/assignment/assignment.factor @@ -108,11 +108,14 @@ SYMBOL: check-assignment? ERROR: overlapping-registers intervals ; +: check-assignment ( intervals -- ) + dup [ copy-from>> ] map sift '[ vreg>> _ member? not ] filter + dup [ reg>> ] map all-unique? [ drop ] [ overlapping-registers ] if ; + : active-intervals ( insn -- intervals ) insn#>> pending-intervals get [ covers? ] with filter check-assignment? get [ - dup [ reg>> ] map all-unique? - [ overlapping-registers ] unless + dup check-assignment ] when ; M: vreg-insn assign-registers-in-insn From 4db44cd23f57c41284debe0e196a9fb77f6c1b49 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 30 Jun 2009 18:11:15 -0500 Subject: [PATCH 10/14] %dispatch: sometimes the generated sequence is one byte longer, so instead of hard-coding it, compute the right length --- basis/cpu/x86/32/32.factor | 4 +++- basis/cpu/x86/64/64.factor | 4 +++- 2 files changed, 6 insertions(+), 2 deletions(-) diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor index e908f52952..86cd53712d 100755 --- a/basis/cpu/x86/32/32.factor +++ b/basis/cpu/x86/32/32.factor @@ -30,12 +30,14 @@ M: x86.32 temp-reg-2 EDX ; M:: x86.32 %dispatch ( src temp -- ) ! Load jump table base. temp src HEX: ffffffff [+] LEA + building get length cell - :> start 0 rc-absolute-cell rel-here ! Go temp HEX: 7f [+] JMP + building get length :> end ! Fix up the displacement above cell code-alignment - [ 7 + building get dup pop* push ] + [ end start - + building get dup pop* push ] [ align-code ] bi ; diff --git a/basis/cpu/x86/64/64.factor b/basis/cpu/x86/64/64.factor index 2c8fb3f18f..5390d7e0c8 100644 --- a/basis/cpu/x86/64/64.factor +++ b/basis/cpu/x86/64/64.factor @@ -23,15 +23,17 @@ M: x86.64 rs-reg R15 ; M: x86.64 stack-reg RSP ; M:: x86.64 %dispatch ( src temp -- ) + building get length :> start ! Load jump table base. temp HEX: ffffffff MOV 0 rc-absolute-cell rel-here ! Add jump table base temp src ADD temp HEX: 7f [+] JMP + building get length :> end ! Fix up the displacement above cell code-alignment - [ 15 + building get dup pop* push ] + [ end start - 2 - + building get dup pop* push ] [ align-code ] bi ; From 3355fa480993e19a68686f622f5767cedd20b72f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 30 Jun 2009 18:11:45 -0500 Subject: [PATCH 11/14] compiler.cfg.stack-analysis: enable global optimization --- basis/compiler/cfg/stack-analysis/stack-analysis.factor | 7 +------ 1 file changed, 1 insertion(+), 6 deletions(-) diff --git a/basis/compiler/cfg/stack-analysis/stack-analysis.factor b/basis/compiler/cfg/stack-analysis/stack-analysis.factor index 5679d8bd11..1e7f33c7e0 100644 --- a/basis/compiler/cfg/stack-analysis/stack-analysis.factor +++ b/basis/compiler/cfg/stack-analysis/stack-analysis.factor @@ -59,17 +59,12 @@ UNION: sync-if-back-edge ##dispatch ##loop-entry ; -SYMBOL: local-only? - -t local-only? set-global - : back-edge? ( from to -- ? ) [ number>> ] bi@ > ; : sync-state? ( -- ? ) basic-block get successors>> - [ [ predecessors>> ] keep '[ _ back-edge? ] any? ] any? - local-only? get or ; + [ [ predecessors>> ] keep '[ _ back-edge? ] any? ] any? ; M: sync-if-back-edge visit sync-state? [ sync-state ] when , ; From bc2a6c0ecc3909567bbf5c3b0e1f6ad115b59add Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 30 Jun 2009 18:22:54 -0500 Subject: [PATCH 12/14] compiler.cfg.stack-analysis: fix tests --- basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor | 2 -- 1 file changed, 2 deletions(-) diff --git a/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor b/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor index 1bef0c3967..6f4b88e28e 100644 --- a/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor +++ b/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor @@ -17,8 +17,6 @@ IN: compiler.cfg.stack-analysis.tests : linearize ( cfg -- mr ) flatten-cfg instructions>> ; -local-only? off - [ ] [ [ ] test-stack-analysis drop ] unit-test ! Only peek once From 97cd0d584e9c270795fe7ce932e5016e7b044e2f Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 30 Jun 2009 18:47:24 -0500 Subject: [PATCH 13/14] make commutative operations with immediates output the same IR --- .../cfg/intrinsics/fixnum/fixnum.factor | 43 +++++++++++++------ .../compiler/cfg/intrinsics/intrinsics.factor | 10 ++--- 2 files changed, 36 insertions(+), 17 deletions(-) diff --git a/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor b/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor index cb5f2e926d..a93fa5d902 100644 --- a/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor +++ b/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor @@ -18,13 +18,14 @@ IN: compiler.cfg.intrinsics.fixnum 0 cc= ^^compare-imm ds-push ; -: (emit-fixnum-imm-op) ( infos insn -- dst ) - ds-drop - [ ds-pop ] - [ second literal>> [ tag-fixnum ] [ \ f tag-number ] if* ] - [ ] - tri* - call ; inline +: tag-literal ( n -- tagged ) + literal>> [ tag-fixnum ] [ \ f tag-number ] if* ; + +: emit-fixnum-imm-op1 ( infos insn -- dst ) + [ ds-pop ds-drop ] [ first tag-literal ] [ ] tri* call ; inline + +: emit-fixnum-imm-op2 ( infos insn -- dst ) + [ ds-drop ds-pop ] [ second tag-literal ] [ ] tri* call ; inline : (emit-fixnum-op) ( insn -- dst ) [ 2inputs ] dip call ; inline @@ -32,9 +33,22 @@ IN: compiler.cfg.intrinsics.fixnum :: 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 + [ infos imm-insn emit-fixnum-imm-op2 ] + [ insn (emit-fixnum-op) ] if + ds-push + ] ; inline + +:: emit-commutative-fixnum-op ( node insn imm-insn -- ) + [let | infos [ node node-input-infos ] | + infos first value-info-small-tagged? + [ infos imm-insn emit-fixnum-imm-op1 ] + [ + infos second value-info-small-tagged? [ + infos imm-insn emit-fixnum-imm-op2 + ] [ + insn (emit-fixnum-op) + ] if + ] if ds-push ] ; inline @@ -69,9 +83,14 @@ IN: compiler.cfg.intrinsics.fixnum [ (emit-fixnum*fast-imm) ] [ drop (emit-fixnum*fast) ] if ds-push ; +: (emit-fixnum-comparison) ( cc -- quot1 quot2 ) + [ ^^compare ] [ ^^compare-imm ] bi-curry ; inline + +: emit-eq ( node cc -- ) + (emit-fixnum-comparison) emit-commutative-fixnum-op ; + : emit-fixnum-comparison ( node cc -- ) - [ ^^compare ] [ ^^compare-imm ] bi-curry - emit-fixnum-op ; + (emit-fixnum-comparison) emit-fixnum-op ; : emit-bignum>fixnum ( -- ) ds-pop ^^bignum>integer ^^tag-fixnum ds-push ; diff --git a/basis/compiler/cfg/intrinsics/intrinsics.factor b/basis/compiler/cfg/intrinsics/intrinsics.factor index ec819f9440..15c9c0cef3 100644 --- a/basis/compiler/cfg/intrinsics/intrinsics.factor +++ b/basis/compiler/cfg/intrinsics/intrinsics.factor @@ -103,11 +103,11 @@ IN: compiler.cfg.intrinsics { \ math.private:fixnum+ [ drop [ ##fixnum-add ] [ ##fixnum-add-tail ] emit-fixnum-overflow-op ] } { \ math.private:fixnum- [ drop [ ##fixnum-sub ] [ ##fixnum-sub-tail ] emit-fixnum-overflow-op ] } { \ math.private:fixnum* [ drop [ i i ##fixnum-mul ] [ i i ##fixnum-mul-tail ] emit-fixnum-overflow-op ] } - { \ math.private:fixnum+fast [ [ ^^add ] [ ^^add-imm ] emit-fixnum-op iterate-next ] } + { \ math.private:fixnum+fast [ [ ^^add ] [ ^^add-imm ] emit-commutative-fixnum-op iterate-next ] } { \ math.private:fixnum-fast [ [ ^^sub ] [ ^^sub-imm ] emit-fixnum-op iterate-next ] } - { \ math.private:fixnum-bitand [ [ ^^and ] [ ^^and-imm ] emit-fixnum-op iterate-next ] } - { \ math.private:fixnum-bitor [ [ ^^or ] [ ^^or-imm ] emit-fixnum-op iterate-next ] } - { \ math.private:fixnum-bitxor [ [ ^^xor ] [ ^^xor-imm ] emit-fixnum-op iterate-next ] } + { \ math.private:fixnum-bitand [ [ ^^and ] [ ^^and-imm ] emit-commutative-fixnum-op iterate-next ] } + { \ math.private:fixnum-bitor [ [ ^^or ] [ ^^or-imm ] emit-commutative-fixnum-op iterate-next ] } + { \ math.private:fixnum-bitxor [ [ ^^xor ] [ ^^xor-imm ] emit-commutative-fixnum-op iterate-next ] } { \ math.private:fixnum-shift-fast [ emit-fixnum-shift-fast iterate-next ] } { \ math.private:fixnum-bitnot [ drop emit-fixnum-bitnot iterate-next ] } { \ math.integers.private:fixnum-log2 [ drop emit-fixnum-log2 iterate-next ] } @@ -116,7 +116,7 @@ IN: compiler.cfg.intrinsics { \ math.private:fixnum<= [ cc<= emit-fixnum-comparison iterate-next ] } { \ math.private:fixnum>= [ cc>= emit-fixnum-comparison iterate-next ] } { \ math.private:fixnum> [ cc> emit-fixnum-comparison iterate-next ] } - { \ kernel:eq? [ cc= emit-fixnum-comparison iterate-next ] } + { \ kernel:eq? [ cc= emit-eq iterate-next ] } { \ math.private:bignum>fixnum [ drop emit-bignum>fixnum iterate-next ] } { \ math.private:fixnum>bignum [ drop emit-fixnum>bignum iterate-next ] } { \ math.private:float+ [ drop [ ^^add-float ] emit-float-op iterate-next ] } From 2cd202d1752c87f17799c6e02075e4878fa1245e Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 30 Jun 2009 18:48:52 -0500 Subject: [PATCH 14/14] remove duplicate using --- basis/compiler/cfg/optimizer/optimizer-tests.factor | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/basis/compiler/cfg/optimizer/optimizer-tests.factor b/basis/compiler/cfg/optimizer/optimizer-tests.factor index b95a8c79ea..ee601f2337 100644 --- a/basis/compiler/cfg/optimizer/optimizer-tests.factor +++ b/basis/compiler/cfg/optimizer/optimizer-tests.factor @@ -1,6 +1,7 @@ -USING: arrays sequences tools.test compiler.cfg.checker compiler.cfg.debugger -compiler.cfg.def-use sets kernel kernel.private fry slots.private vectors -sequences.private math sbufs math.private slots.private strings ; +USING: arrays sequences tools.test compiler.cfg.checker +compiler.cfg.debugger compiler.cfg.def-use sets kernel +kernel.private fry slots.private vectors sequences.private +math sbufs math.private strings ; IN: compiler.cfg.optimizer.tests ! Miscellaneous tests