Merge branch 'master' of git://factorcode.org/git/factor
Joe Groff
commit
865e37f590
|
|
@ -12,28 +12,17 @@ SYMBOL: library-is-c++
|
|||
SYMBOL: compiler-args
|
||||
SYMBOL: c-strings
|
||||
|
||||
: (C-LIBRARY:) ( -- )
|
||||
scan c-library set
|
||||
V{ } clone c-strings set
|
||||
V{ } clone compiler-args set ;
|
||||
|
||||
: (C-LINK:) ( -- )
|
||||
"-l" scan append compiler-args get push ;
|
||||
|
||||
: (C-FRAMEWORK:) ( -- )
|
||||
"-framework" scan compiler-args get '[ _ push ] bi@ ;
|
||||
|
||||
: return-library-function-params ( -- return library function params )
|
||||
scan c-library get scan ")" parse-tokens
|
||||
[ "(" subseq? not ] filter [
|
||||
[ dup CHAR: - = [ drop CHAR: space ] when ] map
|
||||
] 3dip ;
|
||||
|
||||
: factor-function ( return library functions params -- )
|
||||
: factor-function ( return library function params -- )
|
||||
[ dup "const " head? [ 6 tail ] when ] 3dip
|
||||
make-function define-declared ;
|
||||
|
||||
: (C-FUNCTION:) ( return library function params -- str )
|
||||
: c-function-string ( return library function params -- str )
|
||||
[ nip ] dip
|
||||
" " join "(" prepend ")" append 3array " " join
|
||||
library-is-c++ get [ "extern \"C\" " prepend ] when ;
|
||||
|
|
@ -53,31 +42,47 @@ SYMBOL: c-strings
|
|||
compiler-args get
|
||||
c-strings get "\n" join
|
||||
c-library get compile-to-library ;
|
||||
|
||||
: (;C-LIBRARY) ( -- )
|
||||
compile-library? [ compile-library ] when
|
||||
c-library get library-path "cdecl" add-library ;
|
||||
PRIVATE>
|
||||
|
||||
SYNTAX: C-LIBRARY: (C-LIBRARY:) ;
|
||||
: define-c-library ( name -- )
|
||||
c-library set
|
||||
V{ } clone c-strings set
|
||||
V{ } clone compiler-args set ;
|
||||
|
||||
SYNTAX: COMPILE-AS-C++ t library-is-c++ set ;
|
||||
: compile-c-library ( -- )
|
||||
compile-library? [ compile-library ] when
|
||||
c-library get library-path "cdecl" add-library ;
|
||||
|
||||
SYNTAX: C-LINK: (C-LINK:) ;
|
||||
|
||||
SYNTAX: C-FRAMEWORK: (C-FRAMEWORK:) ;
|
||||
|
||||
SYNTAX: C-LINK/FRAMEWORK:
|
||||
os macosx? [ (C-FRAMEWORK:) ] [ (C-LINK:) ] if ;
|
||||
|
||||
SYNTAX: C-INCLUDE:
|
||||
"#include " scan append c-strings get push ;
|
||||
|
||||
SYNTAX: C-FUNCTION:
|
||||
return-library-function-params
|
||||
[ factor-function ]
|
||||
4 nkeep (C-FUNCTION:)
|
||||
: define-c-function ( return library function params -- )
|
||||
[ factor-function ] 4 nkeep c-function-string
|
||||
" {\n" append parse-here append "\n}\n" append
|
||||
c-strings get push ;
|
||||
|
||||
SYNTAX: ;C-LIBRARY (;C-LIBRARY) ;
|
||||
: define-c-link ( str -- )
|
||||
"-l" prepend compiler-args get push ;
|
||||
|
||||
: define-c-framework ( str -- )
|
||||
"-framework" swap compiler-args get '[ _ push ] bi@ ;
|
||||
|
||||
: define-c-link/framework ( str -- )
|
||||
os macosx? [ define-c-framework ] [ define-c-link ] if ;
|
||||
|
||||
: define-c-include ( str -- )
|
||||
"#include " prepend c-strings get push ;
|
||||
|
||||
SYNTAX: C-LIBRARY: scan define-c-library ;
|
||||
|
||||
SYNTAX: COMPILE-AS-C++ t library-is-c++ set ;
|
||||
|
||||
SYNTAX: C-LINK: scan define-c-link ;
|
||||
|
||||
SYNTAX: C-FRAMEWORK: scan define-c-framework ;
|
||||
|
||||
SYNTAX: C-LINK/FRAMEWORK: scan define-c-link/framework ;
|
||||
|
||||
SYNTAX: C-INCLUDE: scan define-c-include ;
|
||||
|
||||
SYNTAX: C-FUNCTION:
|
||||
return-library-function-params define-c-function ;
|
||||
|
||||
SYNTAX: ;C-LIBRARY compile-c-library ;
|
||||
|
|
|
|||
|
|
@ -1,6 +1,7 @@
|
|||
! Copyright (C) 2009 Jeremy Hughes.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: tools.test alien.inline alien.inline.private io.files io.directories kernel ;
|
||||
USING: tools.test alien.inline alien.inline.private io.files
|
||||
io.directories kernel ;
|
||||
IN: alien.inline.tests
|
||||
|
||||
C-LIBRARY: const
|
||||
|
|
@ -42,6 +43,6 @@ C-FUNCTION: char* breakme ( )
|
|||
return not a string;
|
||||
;
|
||||
|
||||
<< [ (;C-LIBRARY) ] must-fail >>
|
||||
<< [ compile-c-library ] must-fail >>
|
||||
|
||||
<< library-path dup exists? [ delete-file ] [ drop ] if >>
|
||||
|
|
|
|||
|
|
@ -1,8 +1,8 @@
|
|||
IN: compiler.cfg.branch-folding.tests
|
||||
USING: compiler.cfg.branch-folding compiler.cfg.instructions
|
||||
compiler.cfg compiler.cfg.registers compiler.cfg.debugger
|
||||
arrays compiler.cfg.phi-elimination
|
||||
compiler.cfg.predecessors kernel accessors
|
||||
arrays compiler.cfg.phi-elimination compiler.cfg.dce
|
||||
compiler.cfg.predecessors kernel accessors assocs
|
||||
sequences classes namespaces tools.test cpu.architecture ;
|
||||
|
||||
V{ T{ ##branch } } 0 test-bb
|
||||
|
|
@ -42,3 +42,44 @@ test-diamond
|
|||
|
||||
[ T{ ##copy f V int-regs 3 V int-regs 2 } ] [ 3 get instructions>> second ] unit-test
|
||||
[ 2 ] [ 4 get instructions>> length ] unit-test
|
||||
|
||||
V{
|
||||
T{ ##peek f V int-regs 0 D 0 }
|
||||
T{ ##branch }
|
||||
} 0 test-bb
|
||||
|
||||
V{
|
||||
T{ ##peek f V int-regs 1 D 1 }
|
||||
T{ ##compare-branch f V int-regs 1 V int-regs 1 cc< }
|
||||
} 1 test-bb
|
||||
|
||||
V{
|
||||
T{ ##copy f V int-regs 2 V int-regs 0 }
|
||||
T{ ##branch }
|
||||
} 2 test-bb
|
||||
|
||||
V{
|
||||
T{ ##phi f V int-regs 3 V{ } }
|
||||
T{ ##branch }
|
||||
} 3 test-bb
|
||||
|
||||
V{
|
||||
T{ ##replace f V int-regs 3 D 0 }
|
||||
T{ ##return }
|
||||
} 4 test-bb
|
||||
|
||||
1 get V int-regs 1 2array
|
||||
2 get V int-regs 0 2array 2array 3 get instructions>> first (>>inputs)
|
||||
|
||||
test-diamond
|
||||
|
||||
[ ] [
|
||||
cfg new 0 get >>entry
|
||||
compute-predecessors
|
||||
fold-branches
|
||||
compute-predecessors
|
||||
eliminate-dead-code
|
||||
drop
|
||||
] unit-test
|
||||
|
||||
[ 1 ] [ 3 get instructions>> first inputs>> assoc-size ] unit-test
|
||||
|
|
@ -1,20 +1,16 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors kernel sequences assocs
|
||||
cpu.architecture compiler.cfg.rpo
|
||||
compiler.cfg.liveness compiler.cfg.instructions
|
||||
compiler.cfg.rpo compiler.cfg.instructions
|
||||
compiler.cfg.hats ;
|
||||
IN: compiler.cfg.gc-checks
|
||||
|
||||
: gc? ( bb -- ? )
|
||||
instructions>> [ ##allocation? ] any? ;
|
||||
|
||||
: object-pointer-regs ( basic-block -- vregs )
|
||||
live-in keys [ reg-class>> int-regs eq? ] filter ;
|
||||
|
||||
: insert-gc-check ( basic-block -- )
|
||||
dup gc? [
|
||||
[ i i f f \ ##gc new-insn prefix ] change-instructions drop
|
||||
[ i i f \ ##gc new-insn prefix ] change-instructions drop
|
||||
] [ drop ] if ;
|
||||
|
||||
: insert-gc-checks ( cfg -- cfg' )
|
||||
|
|
|
|||
|
|
@ -199,6 +199,16 @@ SYMBOL: cc/=
|
|||
{ cc/= cc= }
|
||||
} at ;
|
||||
|
||||
: swap-cc ( cc -- cc' )
|
||||
H{
|
||||
{ cc< cc> }
|
||||
{ cc<= cc>= }
|
||||
{ cc> cc< }
|
||||
{ cc>= cc<= }
|
||||
{ cc= cc= }
|
||||
{ cc/= cc/= }
|
||||
} at ;
|
||||
|
||||
: evaluate-cc ( result cc -- ? )
|
||||
H{
|
||||
{ cc< { +lt+ } }
|
||||
|
|
@ -220,7 +230,7 @@ INSN: ##compare-imm < ##binary-imm cc temp ;
|
|||
INSN: ##compare-float-branch < ##conditional-branch ;
|
||||
INSN: ##compare-float < ##binary cc temp ;
|
||||
|
||||
INSN: ##gc { temp1 vreg } { temp2 vreg } live-registers live-spill-slots ;
|
||||
INSN: ##gc { temp1 vreg } { temp2 vreg } live-values ;
|
||||
|
||||
! Instructions used by machine IR only.
|
||||
INSN: _prologue stack-frame ;
|
||||
|
|
@ -240,7 +250,7 @@ INSN: _compare-imm-branch label { src1 vreg } { src2 integer } cc ;
|
|||
|
||||
INSN: _compare-float-branch < _conditional-branch ;
|
||||
|
||||
TUPLE: spill-slot { n integer } ; C: <spill-slot> spill-slot
|
||||
TUPLE: spill-slot n ; C: <spill-slot> spill-slot
|
||||
|
||||
INSN: _gc { temp1 vreg } { temp2 vreg } gc-roots gc-root-count gc-root-size ;
|
||||
|
||||
|
|
|
|||
|
|
@ -48,9 +48,7 @@ ERROR: bad-live-ranges interval ;
|
|||
} 2cleave ;
|
||||
|
||||
: assign-spill ( live-interval -- live-interval )
|
||||
dup reload-from>>
|
||||
[ dup vreg>> reg-class>> next-spill-location ] unless*
|
||||
>>spill-to ;
|
||||
dup vreg>> assign-spill-slot >>spill-to ;
|
||||
|
||||
: assign-reload ( before after -- before after )
|
||||
over spill-to>> >>reload-from ;
|
||||
|
|
|
|||
|
|
@ -109,18 +109,26 @@ CONSTANT: reg-classes { int-regs double-float-regs }
|
|||
: reg-class-assoc ( quot -- assoc )
|
||||
[ reg-classes ] dip { } map>assoc ; inline
|
||||
|
||||
! Mapping from register classes to spill counts
|
||||
SYMBOL: spill-counts
|
||||
|
||||
: next-spill-location ( reg-class -- n )
|
||||
: next-spill-slot ( reg-class -- n )
|
||||
spill-counts get [ dup 1 + ] change-at ;
|
||||
|
||||
! Mapping from vregs to spill slots
|
||||
SYMBOL: spill-slots
|
||||
|
||||
: assign-spill-slot ( vreg -- n )
|
||||
spill-slots get [ reg-class>> next-spill-slot ] cache ;
|
||||
|
||||
: init-allocator ( registers -- )
|
||||
registers set
|
||||
[ 0 ] reg-class-assoc spill-counts set
|
||||
<min-heap> unhandled-intervals set
|
||||
[ V{ } clone ] reg-class-assoc active-intervals set
|
||||
[ V{ } clone ] reg-class-assoc inactive-intervals set
|
||||
V{ } clone handled-intervals set
|
||||
[ 0 ] reg-class-assoc spill-counts set
|
||||
H{ } clone spill-slots set
|
||||
-1 progress set ;
|
||||
|
||||
: init-unhandled ( live-intervals -- )
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors kernel math assocs namespaces sequences heaps
|
||||
fry make combinators sets
|
||||
fry make combinators sets locals
|
||||
cpu.architecture
|
||||
compiler.cfg.def-use
|
||||
compiler.cfg.registers
|
||||
|
|
@ -33,6 +33,20 @@ SYMBOL: spill-slots
|
|||
: spill-slots-for ( vreg -- assoc )
|
||||
reg-class>> spill-slots get at ;
|
||||
|
||||
! Mapping from basic blocks to values which are live at the start
|
||||
SYMBOL: register-live-ins
|
||||
|
||||
! Mapping from basic blocks to values which are live at the end
|
||||
SYMBOL: register-live-outs
|
||||
|
||||
: init-assignment ( live-intervals -- )
|
||||
V{ } clone pending-intervals set
|
||||
<min-heap> unhandled-intervals set
|
||||
[ H{ } clone ] reg-class-assoc spill-slots set
|
||||
H{ } clone register-live-ins set
|
||||
H{ } clone register-live-outs set
|
||||
init-unhandled ;
|
||||
|
||||
ERROR: already-spilled ;
|
||||
|
||||
: record-spill ( live-interval -- )
|
||||
|
|
@ -102,10 +116,13 @@ ERROR: already-reloaded ;
|
|||
] [ 2drop ] if
|
||||
] if ;
|
||||
|
||||
: prepare-insn ( n -- )
|
||||
[ expire-old-intervals ] [ activate-new-intervals ] bi ;
|
||||
|
||||
GENERIC: assign-registers-in-insn ( insn -- )
|
||||
|
||||
: register-mapping ( live-intervals -- alist )
|
||||
[ [ vreg>> ] [ reg>> ] bi ] { } map>assoc ;
|
||||
[ [ vreg>> ] [ reg>> ] bi ] H{ } map>assoc ;
|
||||
|
||||
: all-vregs ( insn -- vregs )
|
||||
[ defs-vregs ] [ temp-vregs ] [ uses-vregs ] tri 3append ;
|
||||
|
|
@ -118,55 +135,67 @@ ERROR: overlapping-registers 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
|
||||
: active-intervals ( n -- intervals )
|
||||
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
|
||||
dup [ insn#>> active-intervals ] [ all-vregs ] bi
|
||||
'[ vreg>> _ member? ] filter
|
||||
register-mapping
|
||||
>>regs drop ;
|
||||
|
||||
: compute-live-registers ( insn -- regs )
|
||||
[ active-intervals ] [ temp-vregs ] bi
|
||||
'[ vreg>> _ memq? not ] filter
|
||||
register-mapping ;
|
||||
: compute-live-registers ( n -- assoc )
|
||||
active-intervals register-mapping ;
|
||||
|
||||
: compute-live-spill-slots ( -- spill-slots )
|
||||
spill-slots get values
|
||||
[ [ vreg>> swap ] { } assoc-map-as ] map concat ;
|
||||
: compute-live-spill-slots ( -- assocs )
|
||||
spill-slots get values first2
|
||||
[ [ vreg>> swap <spill-slot> ] H{ } assoc-map-as ] bi@
|
||||
assoc-union ;
|
||||
|
||||
: compute-live-values ( n -- assoc )
|
||||
[ compute-live-spill-slots ] dip compute-live-registers
|
||||
assoc-union ;
|
||||
|
||||
: compute-live-gc-values ( insn -- assoc )
|
||||
[ insn#>> compute-live-values ] [ temp-vregs ] bi
|
||||
'[ drop _ memq? not ] assoc-filter ;
|
||||
|
||||
M: ##gc assign-registers-in-insn
|
||||
dup call-next-method
|
||||
dup compute-live-registers >>live-registers
|
||||
compute-live-spill-slots >>live-spill-slots
|
||||
dup compute-live-gc-values >>live-values
|
||||
drop ;
|
||||
|
||||
M: insn assign-registers-in-insn drop ;
|
||||
|
||||
: init-assignment ( live-intervals -- )
|
||||
V{ } clone pending-intervals set
|
||||
<min-heap> unhandled-intervals set
|
||||
[ H{ } clone ] reg-class-assoc spill-slots set
|
||||
init-unhandled ;
|
||||
: begin-block ( bb -- )
|
||||
dup block-from 1 - prepare-insn
|
||||
[ block-from compute-live-values ] keep register-live-ins get set-at ;
|
||||
|
||||
: assign-registers-in-block ( bb -- )
|
||||
[
|
||||
: end-block ( bb -- )
|
||||
[ block-to compute-live-values ] keep register-live-outs get set-at ;
|
||||
|
||||
ERROR: bad-vreg vreg ;
|
||||
|
||||
: vreg-at-start ( vreg bb -- state )
|
||||
register-live-ins get at ?at [ bad-vreg ] unless ;
|
||||
|
||||
: vreg-at-end ( vreg bb -- state )
|
||||
register-live-outs get at ?at [ bad-vreg ] unless ;
|
||||
|
||||
:: assign-registers-in-block ( bb -- )
|
||||
bb [
|
||||
[
|
||||
bb begin-block
|
||||
[
|
||||
[
|
||||
insn#>>
|
||||
[ expire-old-intervals ]
|
||||
[ activate-new-intervals ]
|
||||
bi
|
||||
]
|
||||
[ insn#>> prepare-insn ]
|
||||
[ assign-registers-in-insn ]
|
||||
[ , ]
|
||||
tri
|
||||
] each
|
||||
bb end-block
|
||||
] V{ } make
|
||||
] change-instructions drop ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1353,7 +1353,7 @@ USING: math.private ;
|
|||
|
||||
! Spill slot liveness was computed incorrectly, leading to a FEP
|
||||
! early in bootstrap on x86-32
|
||||
[ t t ] [
|
||||
[ t ] [
|
||||
[
|
||||
H{ } clone live-ins set
|
||||
H{ } clone live-outs set
|
||||
|
|
@ -1379,8 +1379,7 @@ USING: math.private ;
|
|||
}
|
||||
} dup 1array { { int-regs V{ 0 1 2 3 } } } (linear-scan)
|
||||
instructions>> first
|
||||
[ live-spill-slots>> empty? ]
|
||||
[ live-registers>> empty? ] bi
|
||||
live-values>> assoc-empty?
|
||||
] with-scope
|
||||
] unit-test
|
||||
|
||||
|
|
@ -1860,3 +1859,120 @@ test-diamond
|
|||
[ _spill ] [ 3 get instructions>> second class ] unit-test
|
||||
|
||||
[ _reload ] [ 4 get instructions>> first class ] unit-test
|
||||
|
||||
! Resolve pass
|
||||
V{
|
||||
T{ ##branch }
|
||||
} 0 test-bb
|
||||
|
||||
V{
|
||||
T{ ##peek f V int-regs 0 D 0 }
|
||||
T{ ##compare-imm-branch f V int-regs 0 5 cc= }
|
||||
} 1 test-bb
|
||||
|
||||
V{
|
||||
T{ ##replace f V int-regs 0 D 0 }
|
||||
T{ ##peek f V int-regs 1 D 0 }
|
||||
T{ ##peek f V int-regs 2 D 0 }
|
||||
T{ ##replace f V int-regs 1 D 0 }
|
||||
T{ ##replace f V int-regs 2 D 0 }
|
||||
T{ ##branch }
|
||||
} 2 test-bb
|
||||
|
||||
V{
|
||||
T{ ##branch }
|
||||
} 3 test-bb
|
||||
|
||||
V{
|
||||
T{ ##peek f V int-regs 1 D 0 }
|
||||
T{ ##compare-imm-branch f V int-regs 1 5 cc= }
|
||||
} 4 test-bb
|
||||
|
||||
V{
|
||||
T{ ##replace f V int-regs 0 D 0 }
|
||||
T{ ##return }
|
||||
} 5 test-bb
|
||||
|
||||
V{
|
||||
T{ ##replace f V int-regs 0 D 0 }
|
||||
T{ ##return }
|
||||
} 6 test-bb
|
||||
|
||||
0 get 1 get V{ } 1sequence >>successors drop
|
||||
1 get 2 get 3 get V{ } 2sequence >>successors drop
|
||||
2 get 4 get V{ } 1sequence >>successors drop
|
||||
3 get 4 get V{ } 1sequence >>successors drop
|
||||
4 get 5 get 6 get V{ } 2sequence >>successors drop
|
||||
|
||||
[ ] [ { 1 2 } test-linear-scan-on-cfg ] unit-test
|
||||
|
||||
[ t ] [ 2 get instructions>> [ _spill? ] any? ] unit-test
|
||||
|
||||
[ t ] [ 3 get instructions>> [ _spill? ] any? ] unit-test
|
||||
|
||||
[ t ] [ 5 get instructions>> [ _reload? ] any? ] unit-test
|
||||
|
||||
! A more complicated failure case with resolve that came up after the above
|
||||
! got fixed
|
||||
V{ T{ ##branch } } 0 test-bb
|
||||
V{
|
||||
T{ ##peek f V int-regs 0 D 0 }
|
||||
T{ ##peek f V int-regs 1 D 1 }
|
||||
T{ ##peek f V int-regs 2 D 2 }
|
||||
T{ ##peek f V int-regs 3 D 3 }
|
||||
T{ ##peek f V int-regs 4 D 0 }
|
||||
T{ ##branch }
|
||||
} 1 test-bb
|
||||
V{ T{ ##branch } } 2 test-bb
|
||||
V{ T{ ##branch } } 3 test-bb
|
||||
V{
|
||||
|
||||
T{ ##replace f V int-regs 1 D 1 }
|
||||
T{ ##replace f V int-regs 2 D 2 }
|
||||
T{ ##replace f V int-regs 3 D 3 }
|
||||
T{ ##replace f V int-regs 4 D 4 }
|
||||
T{ ##replace f V int-regs 0 D 0 }
|
||||
T{ ##branch }
|
||||
} 4 test-bb
|
||||
V{ T{ ##replace f V int-regs 0 D 0 } T{ ##branch } } 5 test-bb
|
||||
V{ T{ ##return } } 6 test-bb
|
||||
V{ T{ ##branch } } 7 test-bb
|
||||
V{
|
||||
T{ ##replace f V int-regs 1 D 1 }
|
||||
T{ ##replace f V int-regs 2 D 2 }
|
||||
T{ ##replace f V int-regs 3 D 3 }
|
||||
T{ ##peek f V int-regs 5 D 1 }
|
||||
T{ ##peek f V int-regs 6 D 2 }
|
||||
T{ ##peek f V int-regs 7 D 3 }
|
||||
T{ ##peek f V int-regs 8 D 4 }
|
||||
T{ ##replace f V int-regs 5 D 1 }
|
||||
T{ ##replace f V int-regs 6 D 2 }
|
||||
T{ ##replace f V int-regs 7 D 3 }
|
||||
T{ ##replace f V int-regs 8 D 4 }
|
||||
T{ ##branch }
|
||||
} 8 test-bb
|
||||
V{
|
||||
T{ ##replace f V int-regs 1 D 1 }
|
||||
T{ ##replace f V int-regs 2 D 2 }
|
||||
T{ ##replace f V int-regs 3 D 3 }
|
||||
T{ ##return }
|
||||
} 9 test-bb
|
||||
|
||||
0 get 1 get 1vector >>successors drop
|
||||
1 get 2 get 7 get V{ } 2sequence >>successors drop
|
||||
7 get 8 get 1vector >>successors drop
|
||||
8 get 9 get 1vector >>successors drop
|
||||
2 get 3 get 5 get V{ } 2sequence >>successors drop
|
||||
3 get 4 get 1vector >>successors drop
|
||||
4 get 9 get 1vector >>successors drop
|
||||
5 get 6 get 1vector >>successors drop
|
||||
|
||||
[ ] [ { 1 2 3 4 } test-linear-scan-on-cfg ] unit-test
|
||||
|
||||
[ _spill ] [ 1 get instructions>> second class ] unit-test
|
||||
[ _reload ] [ 4 get instructions>> 4 swap nth class ] unit-test
|
||||
[ V{ 3 2 1 } ] [ 8 get instructions>> [ _spill? ] filter [ n>> ] map ] unit-test
|
||||
[ V{ 3 2 1 } ] [ 9 get instructions>> [ _reload? ] filter [ n>> ] map ] unit-test
|
||||
|
||||
! Resolve pass should insert this
|
||||
[ _reload ] [ 5 get instructions>> first class ] unit-test
|
||||
|
|
@ -12,59 +12,6 @@ IN: compiler.cfg.linear-scan.resolve.tests
|
|||
{ 3 4 } V{ 1 2 } clone [ { 5 6 } 3append-here ] keep >array
|
||||
] unit-test
|
||||
|
||||
V{
|
||||
T{ ##peek f V int-regs 0 D 0 }
|
||||
T{ ##branch }
|
||||
} 0 test-bb
|
||||
|
||||
V{
|
||||
T{ ##replace f V int-regs 0 D 1 }
|
||||
T{ ##return }
|
||||
} 1 test-bb
|
||||
|
||||
1 get 1vector 0 get (>>successors)
|
||||
|
||||
cfg new 0 get >>entry
|
||||
compute-predecessors
|
||||
dup reverse-post-order number-instructions
|
||||
drop
|
||||
|
||||
CONSTANT: test-live-interval-1
|
||||
T{ live-interval
|
||||
{ start 0 }
|
||||
{ end 6 }
|
||||
{ uses V{ 0 6 } }
|
||||
{ ranges V{ T{ live-range f 0 2 } T{ live-range f 4 6 } } }
|
||||
{ spill-to 0 }
|
||||
{ vreg V int-regs 0 }
|
||||
}
|
||||
|
||||
[ f ] [
|
||||
test-live-interval-1 0 get spill-to
|
||||
] unit-test
|
||||
|
||||
[ 0 ] [
|
||||
test-live-interval-1 1 get spill-to
|
||||
] unit-test
|
||||
|
||||
CONSTANT: test-live-interval-2
|
||||
T{ live-interval
|
||||
{ start 0 }
|
||||
{ end 6 }
|
||||
{ uses V{ 0 6 } }
|
||||
{ ranges V{ T{ live-range f 0 2 } T{ live-range f 4 6 } } }
|
||||
{ reload-from 0 }
|
||||
{ vreg V int-regs 0 }
|
||||
}
|
||||
|
||||
[ 0 ] [
|
||||
test-live-interval-2 0 get reload-from
|
||||
] unit-test
|
||||
|
||||
[ f ] [
|
||||
test-live-interval-2 1 get reload-from
|
||||
] unit-test
|
||||
|
||||
[
|
||||
{
|
||||
T{ _copy { dst 5 } { src 4 } { class int-regs } }
|
||||
|
|
@ -142,8 +89,8 @@ T{ live-interval
|
|||
}
|
||||
] [
|
||||
{
|
||||
T{ register->memory { from 3 } { to 4 } { reg-class int-regs } }
|
||||
T{ memory->register { from 1 } { to 2 } { reg-class int-regs } }
|
||||
T{ register->memory { from 3 } { to T{ spill-slot f 4 } } { reg-class int-regs } }
|
||||
T{ memory->register { from T{ spill-slot f 1 } } { to 2 } { reg-class int-regs } }
|
||||
} mapping-instructions
|
||||
] unit-test
|
||||
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@
|
|||
USING: accessors arrays assocs classes.parser classes.tuple
|
||||
combinators combinators.short-circuit fry hashtables kernel locals
|
||||
make math math.order namespaces sequences sets words parser
|
||||
compiler.cfg.instructions compiler.cfg.linear-scan.live-intervals
|
||||
compiler.cfg.instructions compiler.cfg.linear-scan.assignment
|
||||
compiler.cfg.liveness ;
|
||||
IN: compiler.cfg.linear-scan.resolve
|
||||
|
||||
|
|
@ -14,50 +14,33 @@ TUPLE: operation from to reg-class ;
|
|||
SYNTAX: OPERATION:
|
||||
CREATE-CLASS dup save-location
|
||||
[ operation { } define-tuple-class ]
|
||||
[
|
||||
[ scan-word scan-word ] keep
|
||||
'[
|
||||
[ [ _ execute ] [ _ execute ] bi* ]
|
||||
[ vreg>> reg-class>> ]
|
||||
bi _ boa ,
|
||||
] (( from to -- )) define-declared
|
||||
] bi ;
|
||||
[ dup '[ _ boa , ] (( from to reg-class -- )) define-declared ] bi ;
|
||||
|
||||
>>
|
||||
|
||||
: insn-in-block? ( insn# bb -- ? )
|
||||
[ block-from ] [ block-to ] bi between? ;
|
||||
OPERATION: register->memory
|
||||
OPERATION: memory->register
|
||||
OPERATION: register->register
|
||||
|
||||
: reload-from ( live-interval bb -- n/f )
|
||||
2dup [ start>> ] dip insn-in-block?
|
||||
[ drop reload-from>> ] [ 2drop f ] if ;
|
||||
! This should never come up because of how spill slots are assigned,
|
||||
! so make it an error.
|
||||
: memory->memory ( from to reg-class -- ) drop [ n>> ] bi@ assert= ;
|
||||
|
||||
: spill-to ( live-interval bb -- n/f )
|
||||
2dup [ end>> ] dip insn-in-block?
|
||||
[ drop spill-to>> ] [ 2drop f ] if ;
|
||||
|
||||
OPERATION: memory->memory spill-to>> reload-from>>
|
||||
OPERATION: register->memory reg>> reload-from>>
|
||||
OPERATION: memory->register spill-to>> reg>>
|
||||
OPERATION: register->register reg>> reg>>
|
||||
|
||||
:: add-mapping ( bb1 bb2 li1 li2 -- )
|
||||
li2 bb2 reload-from [
|
||||
li1 bb1 spill-to
|
||||
[ li1 li2 memory->memory ]
|
||||
[ li1 li2 register->memory ] if
|
||||
: add-mapping ( from to reg-class -- )
|
||||
over spill-slot? [
|
||||
pick spill-slot?
|
||||
[ memory->memory ]
|
||||
[ register->memory ] if
|
||||
] [
|
||||
li1 bb1 spill-to
|
||||
[ li1 li2 memory->register ]
|
||||
[ li1 li2 register->register ] if
|
||||
pick spill-slot?
|
||||
[ memory->register ]
|
||||
[ register->register ] if
|
||||
] if ;
|
||||
|
||||
: resolve-value-data-flow ( bb to vreg -- )
|
||||
[ 2dup ] dip
|
||||
live-intervals get at
|
||||
[ [ block-to ] dip child-interval-at ]
|
||||
[ [ block-from ] dip child-interval-at ]
|
||||
bi-curry bi* 2dup eq? [ 2drop 2drop ] [ add-mapping ] if ;
|
||||
:: resolve-value-data-flow ( bb to vreg -- )
|
||||
vreg bb vreg-at-end
|
||||
vreg to vreg-at-start
|
||||
2dup eq? [ 2drop ] [ vreg reg-class>> add-mapping ] if ;
|
||||
|
||||
: compute-mappings ( bb to -- mappings )
|
||||
[
|
||||
|
|
@ -67,48 +50,23 @@ OPERATION: register->register reg>> reg>>
|
|||
|
||||
GENERIC: >insn ( operation -- )
|
||||
|
||||
M: memory->memory >insn
|
||||
[ from>> ] [ to>> ] bi = [ "Not allowed" throw ] unless ;
|
||||
|
||||
M: register->memory >insn
|
||||
[ from>> ] [ reg-class>> ] [ to>> ] tri _spill ;
|
||||
[ from>> ] [ reg-class>> ] [ to>> n>> ] tri _spill ;
|
||||
|
||||
M: memory->register >insn
|
||||
[ to>> ] [ reg-class>> ] [ from>> ] tri _reload ;
|
||||
[ to>> ] [ reg-class>> ] [ from>> n>> ] tri _reload ;
|
||||
|
||||
M: register->register >insn
|
||||
[ to>> ] [ from>> ] [ reg-class>> ] tri _copy ;
|
||||
|
||||
GENERIC: >collision-table ( operation -- )
|
||||
|
||||
M: memory->memory >collision-table
|
||||
[ from>> ] [ to>> ] bi = [ "Not allowed" throw ] unless ;
|
||||
|
||||
M: register->memory >collision-table
|
||||
[ from>> ] [ reg-class>> ] [ to>> ] tri _spill ;
|
||||
|
||||
M: memory->register >collision-table
|
||||
[ to>> ] [ reg-class>> ] [ from>> ] tri _reload ;
|
||||
|
||||
M: register->register >collision-table
|
||||
[ to>> ] [ from>> ] [ reg-class>> ] tri _copy ;
|
||||
|
||||
SYMBOL: froms
|
||||
SYMBOL: tos
|
||||
|
||||
SINGLETONS: memory register ;
|
||||
|
||||
GENERIC: from-loc ( operation -- obj )
|
||||
M: memory->memory from-loc drop memory ;
|
||||
M: register->memory from-loc drop register ;
|
||||
M: memory->register from-loc drop memory ;
|
||||
M: register->register from-loc drop register ;
|
||||
: from-loc ( operation -- obj ) from>> spill-slot? memory register ? ;
|
||||
|
||||
GENERIC: to-loc ( operation -- obj )
|
||||
M: memory->memory to-loc drop memory ;
|
||||
M: register->memory to-loc drop memory ;
|
||||
M: memory->register to-loc drop register ;
|
||||
M: register->register to-loc drop register ;
|
||||
: to-loc ( operation -- obj ) to>> spill-slot? memory register ? ;
|
||||
|
||||
: from-reg ( operation -- seq )
|
||||
[ from-loc ] [ from>> ] [ reg-class>> ] tri 3array ;
|
||||
|
|
@ -142,7 +100,6 @@ M: register->register to-loc drop register ;
|
|||
dup dup associate (trace-chain)
|
||||
] { } make prune reverse ;
|
||||
|
||||
|
||||
: trace-chains ( seq -- seq' )
|
||||
[ trace-chain ] map concat ;
|
||||
|
||||
|
|
@ -159,10 +116,10 @@ ERROR: resolve-error ;
|
|||
|
||||
: break-cycle-n ( operations -- operations' )
|
||||
split-cycle [
|
||||
[ from>> spill-temp ]
|
||||
[ from>> spill-temp <spill-slot> ]
|
||||
[ reg-class>> ] bi \ register->memory boa
|
||||
] [
|
||||
[ to>> spill-temp swap ]
|
||||
[ to>> spill-temp <spill-slot> swap ]
|
||||
[ reg-class>> ] bi \ memory->register boa
|
||||
] bi [ 1array ] bi@ surround ;
|
||||
|
||||
|
|
|
|||
|
|
@ -57,41 +57,31 @@ M: ##dispatch linearize-insn
|
|||
[ successors>> [ number>> _dispatch-label ] each ]
|
||||
bi* ;
|
||||
|
||||
: gc-root-registers ( n live-registers -- n )
|
||||
: (compute-gc-roots) ( n live-values -- n )
|
||||
[
|
||||
[ second 2array , ]
|
||||
[ first reg-class>> reg-size + ]
|
||||
2bi
|
||||
] each ;
|
||||
[ nip 2array , ]
|
||||
[ drop reg-class>> reg-size + ]
|
||||
3bi
|
||||
] assoc-each ;
|
||||
|
||||
: gc-root-spill-slots ( n live-spill-slots -- n )
|
||||
: oop-values ( regs -- regs' )
|
||||
[ drop reg-class>> int-regs eq? ] assoc-filter ;
|
||||
|
||||
: data-values ( regs -- regs' )
|
||||
[ drop reg-class>> double-float-regs eq? ] assoc-filter ;
|
||||
|
||||
: compute-gc-roots ( live-values -- alist )
|
||||
[
|
||||
dup first reg-class>> int-regs eq? [
|
||||
[ second <spill-slot> 2array , ]
|
||||
[ first reg-class>> reg-size + ]
|
||||
2bi
|
||||
] [ drop ] if
|
||||
] each ;
|
||||
|
||||
: oop-registers ( regs -- regs' )
|
||||
[ first reg-class>> int-regs eq? ] filter ;
|
||||
|
||||
: data-registers ( regs -- regs' )
|
||||
[ first reg-class>> double-float-regs eq? ] filter ;
|
||||
|
||||
:: compute-gc-roots ( live-registers live-spill-slots -- alist )
|
||||
[
|
||||
0
|
||||
[ 0 ] dip
|
||||
! we put float registers last; the GC doesn't actually scan them
|
||||
live-registers oop-registers gc-root-registers
|
||||
live-spill-slots gc-root-spill-slots
|
||||
live-registers data-registers gc-root-registers
|
||||
[ oop-values (compute-gc-roots) ]
|
||||
[ data-values (compute-gc-roots) ] bi
|
||||
drop
|
||||
] { } make ;
|
||||
|
||||
: count-gc-roots ( live-registers live-spill-slots -- n )
|
||||
: count-gc-roots ( live-values -- n )
|
||||
! Size of GC root area, minus the float registers
|
||||
[ oop-registers length ] bi@ + ;
|
||||
oop-values assoc-size ;
|
||||
|
||||
M: ##gc linearize-insn
|
||||
nip
|
||||
|
|
@ -99,11 +89,11 @@ M: ##gc linearize-insn
|
|||
[ temp1>> ]
|
||||
[ temp2>> ]
|
||||
[
|
||||
[ live-registers>> ] [ live-spill-slots>> ] bi
|
||||
live-values>>
|
||||
[ compute-gc-roots ]
|
||||
[ count-gc-roots ]
|
||||
[ gc-roots-size ]
|
||||
2tri
|
||||
tri
|
||||
] tri
|
||||
_gc
|
||||
] with-regs ;
|
||||
|
|
|
|||
|
|
@ -1,13 +1,27 @@
|
|||
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel accessors sequences compiler.cfg.rpo ;
|
||||
USING: kernel accessors combinators fry sequences assocs compiler.cfg.rpo
|
||||
compiler.cfg.instructions ;
|
||||
IN: compiler.cfg.predecessors
|
||||
|
||||
: predecessors-step ( bb -- )
|
||||
: update-predecessors ( bb -- )
|
||||
dup successors>> [ predecessors>> push ] with each ;
|
||||
|
||||
: update-phi ( bb ##phi -- )
|
||||
[
|
||||
swap predecessors>>
|
||||
'[ drop _ memq? ] assoc-filter
|
||||
] change-inputs drop ;
|
||||
|
||||
: update-phis ( bb -- )
|
||||
dup instructions>> [
|
||||
dup ##phi? [ update-phi ] [ 2drop ] if
|
||||
] with each ;
|
||||
|
||||
: compute-predecessors ( cfg -- cfg' )
|
||||
[ [ V{ } clone >>predecessors drop ] each-basic-block ]
|
||||
[ [ predecessors-step ] each-basic-block ]
|
||||
[ ]
|
||||
tri ;
|
||||
{
|
||||
[ [ V{ } clone >>predecessors drop ] each-basic-block ]
|
||||
[ [ update-predecessors ] each-basic-block ]
|
||||
[ [ update-phis ] each-basic-block ]
|
||||
[ ]
|
||||
} cleave ;
|
||||
|
|
|
|||
|
|
@ -34,8 +34,8 @@ spill-counts ;
|
|||
|
||||
: gc-root-offset ( n -- n' ) gc-root-base + ;
|
||||
|
||||
: gc-roots-size ( live-registers live-spill-slots -- n )
|
||||
[ keys [ reg-class>> reg-size ] sigma ] bi@ + ;
|
||||
: gc-roots-size ( live-values -- n )
|
||||
keys [ reg-class>> reg-size ] sigma ;
|
||||
|
||||
: (stack-frame-size) ( stack-frame -- n )
|
||||
[
|
||||
|
|
|
|||
|
|
@ -1,11 +1,11 @@
|
|||
! Copyright (C) 2008 Slava Pestov, Doug Coleman.
|
||||
! Copyright (C) 2008, 2009 Slava Pestov, Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors combinators combinators.short-circuit
|
||||
arrays compiler.cfg.hats compiler.cfg.instructions
|
||||
USING: accessors locals combinators combinators.short-circuit arrays
|
||||
fry kernel layouts math namespaces sequences cpu.architecture
|
||||
math.bitwise compiler.cfg.hats compiler.cfg.instructions
|
||||
compiler.cfg.value-numbering.expressions
|
||||
compiler.cfg.value-numbering.graph
|
||||
compiler.cfg.value-numbering.simplify fry kernel layouts math
|
||||
namespaces sequences cpu.architecture math.bitwise locals ;
|
||||
compiler.cfg.value-numbering.simplify ;
|
||||
IN: compiler.cfg.value-numbering.rewrite
|
||||
|
||||
GENERIC: rewrite ( insn -- insn' )
|
||||
|
|
@ -70,21 +70,34 @@ M: ##compare-imm-branch rewrite
|
|||
dup rewrite-tagged-comparison? [ rewrite-tagged-comparison ] when
|
||||
] when ;
|
||||
|
||||
: flip-comparison? ( insn -- ? )
|
||||
dup cc>> cc= eq? [ src1>> vreg>expr constant-expr? ] [ drop f ] if ;
|
||||
:: >compare-imm ( insn swap? -- insn' )
|
||||
insn dst>>
|
||||
insn src1>>
|
||||
insn src2>> swap? [ swap ] when vreg>constant
|
||||
insn cc>> swap? [ swap-cc ] when
|
||||
i \ ##compare-imm new-insn ; inline
|
||||
|
||||
: flip-comparison ( insn -- insn' )
|
||||
[ dst>> ]
|
||||
[ src2>> ]
|
||||
[ src1>> vreg>constant ] tri
|
||||
cc= i \ ##compare-imm new-insn ;
|
||||
! M: ##compare rewrite
|
||||
! dup [ src1>> ] [ src2>> ] bi
|
||||
! [ vreg>expr constant-expr? ] bi@ 2array {
|
||||
! { { f t } [ f >compare-imm ] }
|
||||
! { { t f } [ t >compare-imm ] }
|
||||
! [ drop ]
|
||||
! } case ;
|
||||
|
||||
M: ##compare rewrite
|
||||
dup flip-comparison? [
|
||||
flip-comparison
|
||||
dup number-values
|
||||
rewrite
|
||||
] when ;
|
||||
:: >compare-imm-branch ( insn swap? -- insn' )
|
||||
insn src1>>
|
||||
insn src2>> swap? [ swap ] when vreg>constant
|
||||
insn cc>> swap? [ swap-cc ] when
|
||||
\ ##compare-imm-branch new-insn ; inline
|
||||
|
||||
! M: ##compare-branch rewrite
|
||||
! dup [ src1>> ] [ src2>> ] bi
|
||||
! [ vreg>expr constant-expr? ] bi@ 2array {
|
||||
! { { f t } [ f >compare-imm-branch ] }
|
||||
! { { t f } [ t >compare-imm-branch ] }
|
||||
! [ drop ]
|
||||
! } case ;
|
||||
|
||||
: rewrite-redundant-comparison? ( insn -- ? )
|
||||
{
|
||||
|
|
|
|||
|
|
@ -311,3 +311,7 @@ M: cucumber equal? "The cucumber has no equal" throw ;
|
|||
] [
|
||||
[ { 1 2 3 } "x" "y" linear-scan-regression ] { } make
|
||||
] unit-test
|
||||
|
||||
! Regression from Doug's value numbering changes
|
||||
[ t ] [ 2 [ 1 swap fixnum< ] compile-call ] unit-test
|
||||
[ 3 ] [ 2 [ 1 swap fixnum< [ 3 ] [ 4 ] if ] compile-call ] unit-test
|
||||
|
|
@ -6,6 +6,7 @@ definitions system layouts vectors math.partial-dispatch
|
|||
math.order math.functions accessors hashtables classes assocs
|
||||
io.encodings.utf8 io.encodings.ascii io.encodings fry slots
|
||||
sorting.private combinators.short-circuit grouping prettyprint
|
||||
generalizations
|
||||
compiler.tree
|
||||
compiler.tree.combinators
|
||||
compiler.tree.cleanup
|
||||
|
|
@ -518,3 +519,23 @@ cell-bits 32 = [
|
|||
[ { integer integer } declare + drop ]
|
||||
{ + +-integer-integer } inlined?
|
||||
] unit-test
|
||||
|
||||
[ [ ] ] [
|
||||
[
|
||||
20 f <array>
|
||||
[ 0 swap nth ] keep
|
||||
[ 1 swap nth ] keep
|
||||
[ 2 swap nth ] keep
|
||||
[ 3 swap nth ] keep
|
||||
[ 4 swap nth ] keep
|
||||
[ 5 swap nth ] keep
|
||||
[ 6 swap nth ] keep
|
||||
[ 7 swap nth ] keep
|
||||
[ 8 swap nth ] keep
|
||||
[ 9 swap nth ] keep
|
||||
[ 10 swap nth ] keep
|
||||
[ 11 swap nth ] keep
|
||||
[ 12 swap nth ] keep
|
||||
14 ndrop
|
||||
] cleaned-up-tree nodes>quot
|
||||
] unit-test
|
||||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel accessors words assocs sequences arrays namespaces
|
||||
fry locals definitions classes.algebra
|
||||
fry locals definitions classes classes.algebra generic
|
||||
stack-checker.state
|
||||
stack-checker.backend
|
||||
compiler.tree
|
||||
|
|
@ -9,8 +9,13 @@ compiler.tree.propagation.info
|
|||
compiler.tree.dead-code.liveness ;
|
||||
IN: compiler.tree.dead-code.simple
|
||||
|
||||
: flushable? ( word -- ? )
|
||||
[ "flushable" word-prop ] [ "predicating" word-prop ] bi or ;
|
||||
GENERIC: flushable? ( word -- ? )
|
||||
|
||||
M: predicate flushable? drop t ;
|
||||
|
||||
M: word flushable? "flushable" word-prop ;
|
||||
|
||||
M: method-body flushable? "method-generic" word-prop flushable? ;
|
||||
|
||||
: flushable-call? ( #call -- ? )
|
||||
dup word>> dup flushable? [
|
||||
|
|
|
|||
|
|
@ -49,3 +49,14 @@ M: string blah-generic ;
|
|||
[ ] [ M\ string blah-generic watch ] unit-test
|
||||
|
||||
[ "hi" ] [ "hi" blah-generic ] unit-test
|
||||
|
||||
! See how well watch interacts with optimizations.
|
||||
GENERIC: my-generic ( a -- b )
|
||||
M: object my-generic ;
|
||||
|
||||
\ my-generic watch
|
||||
|
||||
: some-code ( -- )
|
||||
f my-generic drop ;
|
||||
|
||||
[ ] [ some-code ] unit-test
|
||||
|
|
@ -3,7 +3,8 @@
|
|||
USING: accessors kernel math sorting words parser io summary
|
||||
quotations sequences prettyprint continuations effects
|
||||
definitions compiler.units namespaces assocs tools.walker
|
||||
tools.time generic inspector fry tools.continuations ;
|
||||
tools.time generic inspector fry tools.continuations
|
||||
locals generalizations macros ;
|
||||
IN: tools.annotations
|
||||
|
||||
GENERIC: reset ( word -- )
|
||||
|
|
@ -46,17 +47,20 @@ M: word annotate
|
|||
|
||||
<PRIVATE
|
||||
|
||||
: stack-values ( names -- alist )
|
||||
[ datastack ] dip [ nip ] [ length tail* ] 2bi zip ;
|
||||
:: trace-quot ( word effect quot str -- quot' )
|
||||
effect quot call :> values
|
||||
values length :> n
|
||||
[
|
||||
"--- " write str write bl word .
|
||||
n ndup n narray values swap zip simple-table.
|
||||
flush
|
||||
] ; inline
|
||||
|
||||
: trace-message ( word quot str -- )
|
||||
"--- " write write bl over .
|
||||
[ stack-effect ] dip '[ @ stack-values ] [ f ] if*
|
||||
[ simple-table. ] unless-empty flush ; inline
|
||||
MACRO: entering ( word -- quot )
|
||||
dup stack-effect [ in>> ] "Entering" trace-quot ;
|
||||
|
||||
: entering ( str -- ) [ in>> ] "Entering" trace-message ;
|
||||
|
||||
: leaving ( str -- ) [ out>> ] "Leaving" trace-message ;
|
||||
MACRO: leaving ( word -- quot )
|
||||
dup stack-effect [ out>> ] "Leaving" trace-quot ;
|
||||
|
||||
: (watch) ( word def -- def )
|
||||
over '[ _ entering @ _ leaving ] ;
|
||||
|
|
|
|||
|
|
@ -397,8 +397,8 @@ M: f sloppy-pick-up*
|
|||
] [ drop ] if ;
|
||||
|
||||
: end-selection ( pane -- )
|
||||
f >>selecting?
|
||||
hand-moved?
|
||||
dup selecting?>> hand-moved? or
|
||||
[ f >>selecting? ] dip
|
||||
[ [ com-copy-selection ] [ request-focus ] bi ]
|
||||
[ [ relayout-1 ] [ focus-input ] bi ]
|
||||
if ;
|
||||
|
|
|
|||
|
|
@ -63,6 +63,7 @@ M: definition-completion row-columns
|
|||
|
||||
M: word-completion row-color
|
||||
[ vocabulary>> ] [ manifest>> ] bi* {
|
||||
{ [ dup not ] [ COLOR: black ] }
|
||||
{ [ 2dup search-vocabs>> memq? ] [ COLOR: black ] }
|
||||
{ [ over ".private" tail? ] [ COLOR: dark-red ] }
|
||||
[ COLOR: dark-gray ]
|
||||
|
|
|
|||
|
|
@ -52,3 +52,16 @@ IN: ui.tools.listener.history.tests
|
|||
[ ] [ "h" get history-recall-previous ] unit-test
|
||||
|
||||
[ "22" ] [ "d" get doc-string ] unit-test
|
||||
|
||||
[ ] [ <document> "d" set ] unit-test
|
||||
[ ] [ "d" get <history> "h" set ] unit-test
|
||||
|
||||
[ ] [ "aaa" "d" get set-doc-string ] unit-test
|
||||
[ T{ input f "aaa" } ] [ "h" get history-add ] unit-test
|
||||
|
||||
[ ] [ "" "d" get set-doc-string ] unit-test
|
||||
[ T{ input f "" } ] [ "h" get history-add ] unit-test
|
||||
[ T{ input f "" } ] [ "h" get history-add ] unit-test
|
||||
[ ] [ " " "d" get set-doc-string ] unit-test
|
||||
[ ] [ "h" get history-recall-previous ] unit-test
|
||||
|
||||
|
|
|
|||
|
|
@ -16,9 +16,15 @@ TUPLE: history document elements index ;
|
|||
|
||||
<PRIVATE
|
||||
|
||||
: (save-history) ( input index elements -- )
|
||||
2dup length > [
|
||||
[ [ T{ input f "" } ] dip push ] keep
|
||||
(save-history)
|
||||
] [ set-nth ] if ;
|
||||
|
||||
: save-history ( history -- )
|
||||
[ document>> doc-string ] keep
|
||||
'[ <input> _ [ index>> ] [ elements>> ] bi set-nth ]
|
||||
'[ <input> _ [ index>> ] [ elements>> ] bi (save-history) ]
|
||||
unless-empty ;
|
||||
|
||||
: update-document ( history -- )
|
||||
|
|
|
|||
|
|
@ -7,11 +7,16 @@ ARTICLE: "unicode.breaks" "Word and grapheme breaks"
|
|||
"The " { $vocab-link "unicode.breaks" "unicode.breaks" } " vocabulary partially implements Unicode Standard Annex #29. This provides for segmentation of a string along grapheme and word boundaries. In Unicode, a grapheme, or a basic unit of display in text, may be more than one code point. For example, in the string \"e\\u000301\" (where U+0301 is a combining acute accent), there is only one grapheme, as the acute accent goes above the e, forming a single grapheme. Word breaks, in general, are more complicated than simply splitting by whitespace, and the Unicode algorithm provides for that."
|
||||
$nl "Operations for graphemes:"
|
||||
{ $subsection first-grapheme }
|
||||
{ $subsection first-grapheme-from }
|
||||
{ $subsection last-grapheme }
|
||||
{ $subsection last-grapheme-from }
|
||||
{ $subsection >graphemes }
|
||||
{ $subsection string-reverse }
|
||||
"Operations on words:"
|
||||
{ $subsection first-word }
|
||||
{ $subsection first-word-from }
|
||||
{ $subsection last-word }
|
||||
{ $subsection last-word-from }
|
||||
{ $subsection >words } ;
|
||||
|
||||
HELP: first-grapheme
|
||||
|
|
@ -22,6 +27,14 @@ HELP: last-grapheme
|
|||
{ $values { "str" string } { "i" "an index" } }
|
||||
{ $description "Finds the index of the start of the last grapheme of the string. This can be used to traverse the graphemes of a string backwards." } ;
|
||||
|
||||
HELP: first-grapheme-from
|
||||
{ $values { "start" "an index" } { "str" string } { "i" "an index" } }
|
||||
{ $description "Finds the length of the first grapheme of the string, starting from the given index. This can be used repeatedly to efficiently traverse the graphemes of the string, using slices." } ;
|
||||
|
||||
HELP: last-grapheme-from
|
||||
{ $values { "end" "an index" } { "str" string } { "i" "an index" } }
|
||||
{ $description "Finds the index of the start of the last grapheme of the string, starting from the given index. This can be used to traverse the graphemes of a string backwards." } ;
|
||||
|
||||
HELP: >graphemes
|
||||
{ $values { "str" string } { "graphemes" "an array of strings" } }
|
||||
{ $description "Divides a string into a sequence of individual graphemes." } ;
|
||||
|
|
@ -32,7 +45,19 @@ HELP: string-reverse
|
|||
|
||||
HELP: first-word
|
||||
{ $values { "str" string } { "i" "index" } }
|
||||
{ $description "Finds the length of the first word in the string." } ;
|
||||
{ $description "Finds the index of the end of the first word in the string." } ;
|
||||
|
||||
HELP: last-word
|
||||
{ $values { "str" string } { "i" "index" } }
|
||||
{ $description "Finds the index of the beginning of the last word in the string." } ;
|
||||
|
||||
HELP: first-word-from
|
||||
{ $values { "start" "index" } { "str" string } { "i" "index" } }
|
||||
{ $description "Finds the index of the end of the first word in the string, starting from the given index." } ;
|
||||
|
||||
HELP: last-word-from
|
||||
{ $values { "end" "index" } { "str" string } { "i" "index" } }
|
||||
{ $description "Finds the index of the start of the word that the index is contained in." } ;
|
||||
|
||||
HELP: >words
|
||||
{ $values { "str" string } { "words" "an array of strings" } }
|
||||
|
|
|
|||
|
|
@ -12,6 +12,11 @@ IN: unicode.breaks.tests
|
|||
[ 3 ] [ 2 "hello" first-grapheme-from ] unit-test
|
||||
[ 1 ] [ 2 "hello" last-grapheme-from ] unit-test
|
||||
|
||||
[ 4 ] [ 2 "what am I saying" first-word-from ] unit-test
|
||||
[ 0 ] [ 2 "what am I saying" last-word-from ] unit-test
|
||||
[ 16 ] [ 11 "what am I saying" first-word-from ] unit-test
|
||||
[ 10 ] [ 11 "what am I saying" last-word-from ] unit-test
|
||||
|
||||
: grapheme-break-test ( -- filename )
|
||||
"vocab:unicode/breaks/GraphemeBreakTest.txt" ;
|
||||
|
||||
|
|
|
|||
|
|
@ -247,3 +247,12 @@ PRIVATE>
|
|||
word-break-next nip
|
||||
]
|
||||
} 2|| ;
|
||||
|
||||
: first-word-from ( start str -- i )
|
||||
over tail-slice first-word + ;
|
||||
|
||||
: last-word ( str -- i )
|
||||
[ length ] keep '[ _ word-break-at? ] find-last drop 0 or ;
|
||||
|
||||
: last-word-from ( end str -- i )
|
||||
swap head-slice last-word ;
|
||||
|
|
|
|||
Loading…
Reference in New Issue