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 ; 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/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 ] } 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..ea717f9218 100644 --- a/basis/compiler/cfg/linear-scan/assignment/assignment.factor +++ b/basis/compiler/cfg/linear-scan/assignment/assignment.factor @@ -104,8 +104,19 @@ 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 ; + +: 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 ; + insn#>> pending-intervals get [ covers? ] with filter + check-assignment? get [ + dup check-assignment + ] 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 diff --git a/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor b/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor index 7579b46175..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 6 } } - 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{ _copy { dst 0 } { src 1 } { class float-regs } } - T{ _reload { dst 1 } { class float-regs } { n 7 } } + 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 3 } } - 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 3 } } + T{ _copy { dst 1 } { src 0 } { class int-regs } } + T{ _reload { dst 0 } { 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 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 5 } } + 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 10 } } + 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 10 } } + 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 182686a0fa..bd7528291d 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 ] @@ -130,26 +126,40 @@ 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 [ - [ from>> temp-spill get ] + [ 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 ] [ - [ to>> temp-spill [ get ] [ inc ] bi swap ] + [ to>> spill-temp swap ] [ reg-class>> ] bi \ memory->register boa ] bi [ 1array ] bi@ surround ; @@ -182,9 +192,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 ; 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 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 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 , ; diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor index b591b254f8..86cd53712d 100755 --- a/basis/cpu/x86/32/32.factor +++ b/basis/cpu/x86/32/32.factor @@ -29,13 +29,15 @@ 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 + building get length cell - :> start 0 rc-absolute-cell rel-here ! Go - src HEX: 7f [+] JMP + 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 3a7221c239..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 - src temp ADD - src HEX: 7f [+] JMP + 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 ; 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 diff --git a/extra/webapps/imagebin/imagebin.factor b/extra/webapps/imagebin/imagebin.factor index f347377d95..bb8720466c 100755 --- a/extra/webapps/imagebin/imagebin.factor +++ b/extra/webapps/imagebin/imagebin.factor @@ -1,39 +1,45 @@ ! 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 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 -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 ) { 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 [ - - ! request get post-data>> my-post-data set-global - ! image new - ! "file" value - ! insert-tuple + "file1" param [ move-image ] when* + "file2" param [ move-image ] when* + "file3" param [ move-image ] when* "uploaded-image" ] >>submit ; -: ( -- responder ) +: ( image-directory -- responder ) imagebin new-dispatcher + swap [ make-directories ] [ >>path ] bi + 0 >>n "" add-responder "upload-image" add-responder "uploaded-image" add-responder ; +"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!