--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! 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 ;
INSN: _copy dst src class ;
INSN: _spill-counts counts ;
-SYMBOL: temp-spill
+SYMBOL: spill-temp
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
:: 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
[ (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 ;
{ \ 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 ] }
{ \ 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 ] }
! 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
: 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
: 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
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 } }
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
[
{
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 } }
}
] [
{
[
{
- 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 } }
}
] [
{
[
{
- 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 } }
}
] [
{
] 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 } }
{
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 } }
}
] [
{
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 } }
}
] [
{
[ 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 ;
[ 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 ;
: 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 ]
:: (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 ;
: mapping-instructions ( mappings -- insns )
[
- [ init-temp-spill ]
- [ set-tos/froms ]
- [ parallel-mappings ] tri
+ [ set-tos/froms ] [ parallel-mappings ] bi
[ [ >insn ] each ] { } make
] with-scope ;
-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
: linearize ( cfg -- mr )
flatten-cfg instructions>> ;
-local-only? off
-
[ ] [ [ ] test-stack-analysis drop ] unit-test
! Only peek once
##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 , ;
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 ;
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 ;
--- /dev/null
+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
! 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
<html>
<head><title>Uploaded</title></head>
<body>
-hi from uploaded-image
+You uploaded something!
</body>
</html>