Merge branch 'master' into llvm

db4
Matthew Willis 2009-07-01 11:15:54 +09:00
commit e8d298588f
18 changed files with 248 additions and 100 deletions

View File

@ -0,0 +1 @@
Doug Coleman

View File

@ -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 ;

View File

@ -248,4 +248,4 @@ INSN: _reload dst class n ;
INSN: _copy dst src class ;
INSN: _spill-counts counts ;
SYMBOL: temp-spill
SYMBOL: spill-temp

View File

@ -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 ;

View File

@ -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 ] }

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -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 } }
}
] [
{

View File

@ -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 ;

View File

@ -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

View File

@ -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

View File

@ -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 , ;

View File

@ -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 ;

View File

@ -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 ;

View File

@ -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

View File

@ -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

View File

@ -2,6 +2,6 @@
<html>
<head><title>Uploaded</title></head>
<body>
hi from uploaded-image
You uploaded something!
</body>
</html>