Merge branch 'master' into llvm
commit
e8d298588f
|
@ -0,0 +1 @@
|
|||
Doug Coleman
|
|
@ -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 ;
|
|
@ -248,4 +248,4 @@ INSN: _reload dst class n ;
|
|||
INSN: _copy dst src class ;
|
||||
INSN: _spill-counts counts ;
|
||||
|
||||
SYMBOL: temp-spill
|
||||
SYMBOL: spill-temp
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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 ] }
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 } }
|
||||
}
|
||||
] [
|
||||
{
|
||||
|
|
|
@ -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 ;
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 , ;
|
||||
|
|
|
@ -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 ;
|
||||
|
||||
|
|
|
@ -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 ;
|
||||
|
||||
|
|
|
@ -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
|
||||
|
||||
[ ] [
|
||||
<disjoint-set> 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
|
|
@ -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 ;
|
||||
|
||||
: <uploaded-image-action> ( -- action )
|
||||
<page-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 ;
|
||||
|
||||
: <upload-image-action> ( -- action )
|
||||
<page-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" <redirect>
|
||||
] >>submit ;
|
||||
|
||||
: <imagebin> ( -- responder )
|
||||
: <imagebin> ( image-directory -- responder )
|
||||
imagebin new-dispatcher
|
||||
swap [ make-directories ] [ >>path ] bi
|
||||
0 >>n
|
||||
<upload-image-action> "" add-responder
|
||||
<upload-image-action> "upload-image" add-responder
|
||||
<uploaded-image-action> "uploaded-image" add-responder ;
|
||||
|
||||
"resource:images" <imagebin> main-responder set-global
|
||||
|
|
|
@ -2,6 +2,6 @@
|
|||
<html>
|
||||
<head><title>Uploaded</title></head>
|
||||
<body>
|
||||
hi from uploaded-image
|
||||
You uploaded something!
|
||||
</body>
|
||||
</html>
|
||||
|
|
Loading…
Reference in New Issue