steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge branch 'master' of git://factorcode.org/git/factor

db4
Joe Groff 2009-06-17 21:45:04 -05:00
parent 19d77c5193 82825caf80
commit 2b3d62821e
58 changed files with 1765 additions and 1042 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

35
basis/bitstreams/bitstreams.factor
View File

@ -1,10 +1,10 @@
! Copyright (C) 2009 Doug Coleman. ! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien.accessors assocs byte-arrays combinators USING: accessors alien.accessors assocs byte-arrays combinators
constructors destructors fry io io.binary io.encodings.binary destructors fry io io.binary io.encodings.binary io.streams.byte-array
io.streams.byte-array kernel locals macros math math.ranges kernel locals macros math math.ranges multiline sequences
multiline sequences sequences.private vectors byte-vectors sequences.private vectors byte-vectors combinators.short-circuit
combinators.short-circuit math.bitwise ; math.bitwise ;
IN: bitstreams IN: bitstreams
TUPLE: widthed { bits integer read-only } { #bits integer read-only } ; TUPLE: widthed { bits integer read-only } { #bits integer read-only } ;
@ -36,8 +36,12 @@ TUPLE: bit-writer
TUPLE: msb0-bit-reader < bit-reader ; TUPLE: msb0-bit-reader < bit-reader ;
TUPLE: lsb0-bit-reader < bit-reader ; TUPLE: lsb0-bit-reader < bit-reader ;
CONSTRUCTOR: msb0-bit-reader ( bytes -- bs ) ;
CONSTRUCTOR: lsb0-bit-reader ( bytes -- bs ) ; : <msb0-bit-reader> ( bytes -- bs )
msb0-bit-reader new swap >>bytes ; inline
: <lsb0-bit-reader> ( bytes -- bs )
lsb0-bit-reader new swap >>bytes ; inline
TUPLE: msb0-bit-writer < bit-writer ; TUPLE: msb0-bit-writer < bit-writer ;
TUPLE: lsb0-bit-writer < bit-writer ; TUPLE: lsb0-bit-writer < bit-writer ;
@ -56,13 +60,20 @@ TUPLE: lsb0-bit-writer < bit-writer ;
GENERIC: peek ( n bitstream -- value ) GENERIC: peek ( n bitstream -- value )
GENERIC: poke ( value n bitstream -- ) GENERIC: poke ( value n bitstream -- )
: get-abp ( bitstream -- abp )
[ byte-pos>> 8 * ] [ bit-pos>> + ] bi ; inline
: set-abp ( abp bitstream -- )
[ 8 /mod ] dip [ (>>bit-pos) ] [ (>>byte-pos) ] bi ; inline
: seek ( n bitstream -- ) : seek ( n bitstream -- )
{ [ get-abp + ] [ set-abp ] bi ; inline
[ byte-pos>> 8 * ]
[ bit-pos>> + + 8 /mod ] : (align) ( n m -- n' )
[ (>>bit-pos) ] [ /mod 0 > [ 1+ ] when ] [ * ] bi ; inline
[ (>>byte-pos) ]
} cleave ; inline : align ( n bitstream -- )
[ get-abp swap (align) ] [ set-abp ] bi ; inline
: read ( n bitstream -- value ) : read ( n bitstream -- value )
[ peek ] [ seek ] 2bi ; inline [ peek ] [ seek ] 2bi ; inline

1
basis/compiler/cfg/instructions/instructions.factor
View File

@ -245,4 +245,5 @@ INSN: _gc { temp1 vreg } { temp2 vreg } gc-roots gc-root-count gc-root-size ;
! virtual registers ! virtual registers
INSN: _spill src class n ; INSN: _spill src class n ;
INSN: _reload dst class n ; INSN: _reload dst class n ;
INSN: _copy dst src class ;
INSN: _spill-counts counts ; INSN: _spill-counts counts ;

295
basis/compiler/cfg/linear-scan/allocation/allocation.factor
View File

@ -1,280 +1,12 @@
! Copyright (C) 2008, 2009 Slava Pestov. ! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: namespaces sequences math math.order kernel assocs USING: accessors assocs heaps kernel namespaces sequences
accessors vectors fry heaps cpu.architecture sorting locals compiler.cfg.linear-scan.allocation.coalescing
combinators compiler.cfg.registers compiler.cfg.linear-scan.allocation.spilling
compiler.cfg.linear-scan.live-intervals hints ; compiler.cfg.linear-scan.allocation.splitting
compiler.cfg.linear-scan.allocation.state ;
IN: compiler.cfg.linear-scan.allocation IN: compiler.cfg.linear-scan.allocation
! Mapping from register classes to sequences of machine registers
SYMBOL: free-registers
: free-registers-for ( vreg -- seq )
reg-class>> free-registers get at ;
: deallocate-register ( live-interval -- )
[ reg>> ] [ vreg>> ] bi free-registers-for push ;
! Vector of active live intervals
SYMBOL: active-intervals
: active-intervals-for ( vreg -- seq )
reg-class>> active-intervals get at ;
: add-active ( live-interval -- )
dup vreg>> active-intervals-for push ;
: delete-active ( live-interval -- )
dup vreg>> active-intervals-for delq ;
! Vector of inactive live intervals
SYMBOL: inactive-intervals
: inactive-intervals-for ( vreg -- seq )
reg-class>> inactive-intervals get at ;
: add-inactive ( live-interval -- )
dup vreg>> inactive-intervals-for push ;
! Vector of handled live intervals
SYMBOL: handled-intervals
: add-handled ( live-interval -- )
handled-intervals get push ;
: finished? ( n live-interval -- ? ) end>> swap < ;
: finish ( n live-interval -- keep? )
nip [ deallocate-register ] [ add-handled ] bi f ;
: activate ( n live-interval -- keep? )
nip add-active f ;
: deactivate ( n live-interval -- keep? )
nip add-inactive f ;
: don't-change ( n live-interval -- keep? ) 2drop t ;
! Moving intervals between active and inactive sets
: process-intervals ( n symbol quots -- )
! symbol stores an alist mapping register classes to vectors
[ get values ] dip '[ [ _ cond ] with filter-here ] with each ; inline
: covers? ( insn# live-interval -- ? )
ranges>> [ [ from>> ] [ to>> ] bi between? ] with any? ;
: deactivate-intervals ( n -- )
! Any active intervals which have ended are moved to handled
! Any active intervals which cover the current position
! are moved to inactive
active-intervals {
{ [ 2dup finished? ] [ finish ] }
{ [ 2dup covers? not ] [ deactivate ] }
[ don't-change ]
} process-intervals ;
: activate-intervals ( n -- )
! Any inactive intervals which have ended are moved to handled
! Any inactive intervals which do not cover the current position
! are moved to active
inactive-intervals {
{ [ 2dup finished? ] [ finish ] }
{ [ 2dup covers? ] [ activate ] }
[ don't-change ]
} process-intervals ;
! Minheap of live intervals which still need a register allocation
SYMBOL: unhandled-intervals
! Start index of current live interval. We ensure that all
! live intervals added to the unhandled set have a start index
! strictly greater than ths one. This ensures that we can catch
! infinite loop situations.
SYMBOL: progress
: check-progress ( live-interval -- )
start>> progress get <= [ "No progress" throw ] when ; inline
: add-unhandled ( live-interval -- )
[ check-progress ]
[ dup start>> unhandled-intervals get heap-push ]
bi ;
: init-unhandled ( live-intervals -- )
[ [ start>> ] keep ] { } map>assoc
unhandled-intervals get heap-push-all ;
! Coalescing
: active-interval ( vreg -- live-interval )
dup [ dup active-intervals-for [ vreg>> = ] with find nip ] when ;
: coalesce? ( live-interval -- ? )
[ start>> ] [ copy-from>> active-interval ] bi
dup [ end>> = ] [ 2drop f ] if ;
: coalesce ( live-interval -- )
dup copy-from>> active-interval
[ [ add-active ] [ [ delete-active ] [ add-handled ] bi ] bi* ]
[ reg>> >>reg drop ]
2bi ;
! Splitting
: split-range ( live-range n -- before after )
[ [ from>> ] dip <live-range> ]
[ 1 + swap to>> <live-range> ]
2bi ;
: split-last-range? ( last n -- ? )
swap to>> <= ;
: split-last-range ( before after last n -- before' after' )
split-range [ [ but-last ] dip suffix ] [ prefix ] bi-curry* bi* ;
: split-ranges ( live-ranges n -- before after )
[ '[ from>> _ <= ] partition ]
[
pick empty? [ drop ] [
[ over last ] dip 2dup split-last-range?
[ split-last-range ] [ 2drop ] if
] if
] bi ;
: split-uses ( uses n -- before after )
'[ _ <= ] partition ;
: record-split ( live-interval before after -- )
[ >>split-before ] [ >>split-after ] bi* drop ; inline
: check-split ( live-interval -- )
[ end>> ] [ start>> ] bi - 0 =
[ "BUG: splitting atomic interval" throw ] when ; inline
: split-before ( before -- before' )
[ [ ranges>> last ] [ uses>> last ] bi >>to drop ]
[ compute-start/end ]
[ ]
tri ; inline
: split-after ( after -- after' )
[ [ ranges>> first ] [ uses>> first ] bi >>from drop ]
[ compute-start/end ]
[ ]
tri ; inline
:: split-interval ( live-interval n -- before after )
live-interval check-split
live-interval clone :> before
live-interval clone f >>copy-from f >>reg :> after
live-interval uses>> n split-uses before after [ (>>uses) ] bi-curry@ bi*
live-interval ranges>> n split-ranges before after [ (>>ranges) ] bi-curry@ bi*
live-interval before after record-split
before split-before
after split-after ;
HINTS: split-interval live-interval object ;
! Spilling
SYMBOL: spill-counts
: next-spill-location ( reg-class -- n )
spill-counts get [ dup 1+ ] change-at ;
: find-use ( live-interval n quot -- i elt )
[ uses>> ] 2dip curry find ; inline
: interval-to-spill ( active-intervals current -- live-interval )
#! We spill the interval with the most distant use location.
start>> '[ dup _ [ >= ] find-use nip ] { } map>assoc
[ ] [ [ [ second ] bi@ > ] most ] map-reduce first ;
: assign-spill ( before after -- before after )
#! If it has been spilled already, reuse spill location.
over reload-from>>
[ over vreg>> reg-class>> next-spill-location ] unless*
[ >>spill-to ] [ >>reload-from ] bi-curry bi* ;
: split-and-spill ( new existing -- before after )
swap start>> split-interval assign-spill ;
: reuse-register ( new existing -- )
reg>> >>reg add-active ;
: spill-existing ( new existing -- )
#! Our new interval will be used before the active interval
#! with the most distant use location. Spill the existing
#! interval, then process the new interval and the tail end
#! of the existing interval again.
[ reuse-register ]
[ nip delete-active ]
[ split-and-spill [ add-handled ] [ add-unhandled ] bi* ] 2tri ;
: spill-new ( new existing -- )
#! Our new interval will be used after the active interval
#! with the most distant use location. Split the new
#! interval, then process both parts of the new interval
#! again.
[ dup split-and-spill add-unhandled ] dip spill-existing ;
: spill-existing? ( new existing -- ? )
#! Test if 'new' will be used before 'existing'.
over start>> '[ _ [ > ] find-use nip -1 or ] bi@ < ;
: assign-blocked-register ( new -- )
[ dup vreg>> active-intervals-for ] keep interval-to-spill
2dup spill-existing? [ spill-existing ] [ spill-new ] if ;
: assign-free-register ( new registers -- )
pop >>reg add-active ;
: relevant-ranges ( new inactive -- new' inactive' )
! Slice off all ranges of 'inactive' that precede the start of 'new'
[ [ ranges>> ] bi@ ] [ nip start>> ] 2bi '[ to>> _ >= ] filter ;
: intersect-live-range ( range1 range2 -- n/f )
2dup [ from>> ] bi@ > [ swap ] when
2dup [ to>> ] [ from>> ] bi* >= [ nip from>> ] [ 2drop f ] if ;
: intersect-live-ranges ( ranges1 ranges2 -- n )
{
{ [ over empty? ] [ 2drop 1/0. ] }
{ [ dup empty? ] [ 2drop 1/0. ] }
[
2dup [ first ] bi@ intersect-live-range dup [ 2nip ] [
drop
2dup [ first from>> ] bi@ <
[ [ rest-slice ] dip ] [ rest-slice ] if
intersect-live-ranges
] if
]
} cond ;
: intersect-inactive ( new inactive -- n )
relevant-ranges intersect-live-ranges ;
: intersecting-inactive ( new -- live-intervals )
dup vreg>> inactive-intervals-for
[ tuck intersect-inactive ] with { } map>assoc ;
: fits-in-hole ( new pair -- )
first reuse-register ;
: split-before-use ( new pair -- before after )
! Find optimal split position
! Insert move instruction
second split-interval ;
: assign-inactive-register ( new live-intervals -- )
! If there is an interval which is inactive for the entire lifetime
! if the new interval, reuse its vreg. Otherwise, split new so that
! the first half fits.
sort-values last
2dup [ end>> ] [ second ] bi* < [
fits-in-hole
] [
[ split-before-use ] keep
'[ _ fits-in-hole ] [ add-unhandled ] bi*
] if ;
: assign-register ( new -- ) : assign-register ( new -- )
dup coalesce? [ coalesce ] [ dup coalesce? [ coalesce ] [
dup vreg>> free-registers-for [ dup vreg>> free-registers-for [
@ -286,21 +18,6 @@ SYMBOL: spill-counts
if-empty if-empty
] if ; ] if ;
! Main loop
CONSTANT: reg-classes { int-regs double-float-regs }
: reg-class-assoc ( quot -- assoc )
[ reg-classes ] dip { } map>assoc ; inline
: init-allocator ( registers -- )
[ reverse >vector ] assoc-map free-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
-1 progress set ;
: handle-interval ( live-interval -- ) : handle-interval ( live-interval -- )
[ [
start>> start>>
@ -313,12 +30,10 @@ CONSTANT: reg-classes { int-regs double-float-regs }
unhandled-intervals get [ handle-interval ] slurp-heap ; unhandled-intervals get [ handle-interval ] slurp-heap ;
: finish-allocation ( -- ) : finish-allocation ( -- )
! Sanity check: all live intervals should've been processed
active-intervals inactive-intervals active-intervals inactive-intervals
[ get values [ handled-intervals get push-all ] each ] bi@ ; [ get values [ handled-intervals get push-all ] each ] bi@ ;
: allocate-registers ( live-intervals machine-registers -- live-intervals ) : allocate-registers ( live-intervals machine-registers -- live-intervals )
#! This modifies the input live-intervals.
init-allocator init-allocator
init-unhandled init-unhandled
(allocate-registers) (allocate-registers)

18
basis/compiler/cfg/linear-scan/allocation/coalescing/coalescing.factor Normal file
View File

@ -0,0 +1,18 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel sequences
compiler.cfg.linear-scan.allocation.state ;
IN: compiler.cfg.linear-scan.allocation.coalescing
: active-interval ( vreg -- live-interval )
dup [ dup active-intervals-for [ vreg>> = ] with find nip ] when ;
: coalesce? ( live-interval -- ? )
[ start>> ] [ copy-from>> active-interval ] bi
dup [ end>> = ] [ 2drop f ] if ;
: coalesce ( live-interval -- )
dup copy-from>> active-interval
[ [ add-active ] [ [ delete-active ] [ add-handled ] bi ] bi* ]
[ reg>> >>reg drop ]
2bi ;

60
basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor Normal file
View File

@ -0,0 +1,60 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs combinators fry hints kernel locals
math sequences sets sorting splitting
compiler.cfg.linear-scan.allocation.state
compiler.cfg.linear-scan.allocation.splitting
compiler.cfg.linear-scan.live-intervals ;
IN: compiler.cfg.linear-scan.allocation.spilling
: split-for-spill ( live-interval n -- before after )
split-interval
[
[ [ ranges>> last ] [ uses>> last ] bi >>to drop ]
[ [ ranges>> first ] [ uses>> first ] bi >>from drop ] bi*
]
[ [ compute-start/end ] bi@ ]
[ ]
2tri ;
: find-use ( live-interval n quot -- i elt )
[ uses>> ] 2dip curry find ; inline
: interval-to-spill ( active-intervals current -- live-interval )
#! We spill the interval with the most distant use location.
start>> '[ dup _ [ >= ] find-use nip ] { } map>assoc
[ ] [ [ [ second ] bi@ > ] most ] map-reduce first ;
: assign-spill ( before after -- before after )
#! If it has been spilled already, reuse spill location.
over reload-from>>
[ over vreg>> reg-class>> next-spill-location ] unless*
[ >>spill-to ] [ >>reload-from ] bi-curry bi* ;
: split-and-spill ( new existing -- before after )
swap start>> split-for-spill assign-spill ;
: spill-existing ( new existing -- )
#! Our new interval will be used before the active interval
#! with the most distant use location. Spill the existing
#! interval, then process the new interval and the tail end
#! of the existing interval again.
[ reuse-register ]
[ nip delete-active ]
[ split-and-spill [ add-handled ] [ add-unhandled ] bi* ] 2tri ;
: spill-new ( new existing -- )
#! Our new interval will be used after the active interval
#! with the most distant use location. Split the new
#! interval, then process both parts of the new interval
#! again.
[ dup split-and-spill add-unhandled ] dip spill-existing ;
: spill-existing? ( new existing -- ? )
#! Test if 'new' will be used before 'existing'.
over start>> '[ _ [ > ] find-use nip -1 or ] bi@ < ;
: assign-blocked-register ( new -- )
[ dup vreg>> active-intervals-for ] keep interval-to-spill
2dup spill-existing? [ spill-existing ] [ spill-new ] if ;

120
basis/compiler/cfg/linear-scan/allocation/splitting/splitting.factor Normal file
View File

@ -0,0 +1,120 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs combinators fry hints kernel locals
math sequences sets sorting splitting
compiler.cfg.linear-scan.allocation.state
compiler.cfg.linear-scan.live-intervals ;
IN: compiler.cfg.linear-scan.allocation.splitting
: split-range ( live-range n -- before after )
[ [ from>> ] dip <live-range> ]
[ 1 + swap to>> <live-range> ]
2bi ;
: split-last-range? ( last n -- ? )
swap to>> <= ;
: split-last-range ( before after last n -- before' after' )
split-range [ [ but-last ] dip suffix ] [ prefix ] bi-curry* bi* ;
: split-ranges ( live-ranges n -- before after )
[ '[ from>> _ <= ] partition ]
[
[ over last ] dip 2dup split-last-range?
[ split-last-range ] [ 2drop ] if
] bi ;
: split-uses ( uses n -- before after )
'[ _ <= ] partition ;
: record-split ( live-interval before after -- )
[ >>split-next drop ]
[ [ >>split-before ] [ >>split-after ] bi* drop ]
2bi ; inline
ERROR: splitting-too-early ;
ERROR: splitting-atomic-interval ;
: check-split ( live-interval n -- )
[ [ start>> ] dip > [ splitting-too-early ] when ]
[ drop [ end>> ] [ start>> ] bi - 0 = [ splitting-atomic-interval ] when ]
2bi ; inline
: split-before ( before -- before' )
f >>spill-to ; inline
: split-after ( after -- after' )
f >>copy-from f >>reg f >>reload-from ; inline
:: split-interval ( live-interval n -- before after )
live-interval n check-split
live-interval clone :> before
live-interval clone :> after
live-interval uses>> n split-uses before after [ (>>uses) ] bi-curry@ bi*
live-interval ranges>> n split-ranges before after [ (>>ranges) ] bi-curry@ bi*
live-interval before after record-split
before split-before
after split-after ;
HINTS: split-interval live-interval object ;
: reuse-register ( new existing -- )
reg>> >>reg add-active ;
: relevant-ranges ( new inactive -- new' inactive' )
! Slice off all ranges of 'inactive' that precede the start of 'new'
[ [ ranges>> ] bi@ ] [ nip start>> ] 2bi '[ to>> _ >= ] filter ;
: intersect-live-range ( range1 range2 -- n/f )
2dup [ from>> ] bi@ > [ swap ] when
2dup [ to>> ] [ from>> ] bi* >= [ nip from>> ] [ 2drop f ] if ;
: intersect-live-ranges ( ranges1 ranges2 -- n )
{
{ [ over empty? ] [ 2drop 1/0. ] }
{ [ dup empty? ] [ 2drop 1/0. ] }
[
2dup [ first ] bi@ intersect-live-range dup [ 2nip ] [
drop
2dup [ first from>> ] bi@ <
[ [ rest-slice ] dip ] [ rest-slice ] if
intersect-live-ranges
] if
]
} cond ;
: intersect-inactive ( new inactive active-regs -- n/f )
! If the interval's register is currently in use, we cannot
! re-use it.
2dup [ reg>> ] dip key?
[ 3drop f ] [ drop relevant-ranges intersect-live-ranges ] if ;
: intersecting-inactive ( new -- live-intervals )
dup vreg>>
[ inactive-intervals-for ]
[ active-intervals-for [ reg>> ] map unique ] bi
'[ tuck _ intersect-inactive ] with { } map>assoc
[ nip ] assoc-filter ;
: insert-use-for-copy ( seq n -- seq' )
[ 1array split1 ] keep [ 1 - ] keep 2array glue ;
: split-before-use ( new n -- before after )
! Find optimal split position
! Insert move instruction
[ '[ _ insert-use-for-copy ] change-uses ] keep
1 - split-interval
2dup [ compute-start/end ] bi@ ;
: assign-inactive-register ( new live-intervals -- )
! If there is an interval which is inactive for the entire lifetime
! if the new interval, reuse its vreg. Otherwise, split new so that
! the first half fits.
sort-values last
2dup [ end>> ] [ second ] bi* < [
first reuse-register
] [
[ second split-before-use ] keep
'[ _ first reuse-register ] [ add-unhandled ] bi*
] if ;

134
basis/compiler/cfg/linear-scan/allocation/state/state.factor Normal file
View File

@ -0,0 +1,134 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs combinators cpu.architecture fry heaps
kernel math namespaces sequences vectors
compiler.cfg.linear-scan.live-intervals ;
IN: compiler.cfg.linear-scan.allocation.state
! Mapping from register classes to sequences of machine registers
SYMBOL: free-registers
: free-registers-for ( vreg -- seq )
reg-class>> free-registers get at ;
: deallocate-register ( live-interval -- )
[ reg>> ] [ vreg>> ] bi free-registers-for push ;
! Vector of active live intervals
SYMBOL: active-intervals
: active-intervals-for ( vreg -- seq )
reg-class>> active-intervals get at ;
: add-active ( live-interval -- )
dup vreg>> active-intervals-for push ;
: delete-active ( live-interval -- )
dup vreg>> active-intervals-for delq ;
: assign-free-register ( new registers -- )
pop >>reg add-active ;
! Vector of inactive live intervals
SYMBOL: inactive-intervals
: inactive-intervals-for ( vreg -- seq )
reg-class>> inactive-intervals get at ;
: add-inactive ( live-interval -- )
dup vreg>> inactive-intervals-for push ;
! Vector of handled live intervals
SYMBOL: handled-intervals
: add-handled ( live-interval -- )
handled-intervals get push ;
: finished? ( n live-interval -- ? ) end>> swap < ;
: finish ( n live-interval -- keep? )
nip [ deallocate-register ] [ add-handled ] bi f ;
SYMBOL: check-allocation?
ERROR: register-already-used live-interval ;
: check-activate ( live-interval -- )
check-allocation? get [
dup [ reg>> ] [ vreg>> active-intervals-for [ reg>> ] map ] bi member?
[ register-already-used ] [ drop ] if
] [ drop ] if ;
: activate ( n live-interval -- keep? )
dup check-activate
nip add-active f ;
: deactivate ( n live-interval -- keep? )
nip add-inactive f ;
: don't-change ( n live-interval -- keep? ) 2drop t ;
! Moving intervals between active and inactive sets
: process-intervals ( n symbol quots -- )
! symbol stores an alist mapping register classes to vectors
[ get values ] dip '[ [ _ cond ] with filter-here ] with each ; inline
: deactivate-intervals ( n -- )
! Any active intervals which have ended are moved to handled
! Any active intervals which cover the current position
! are moved to inactive
active-intervals {
{ [ 2dup finished? ] [ finish ] }
{ [ 2dup covers? not ] [ deactivate ] }
[ don't-change ]
} process-intervals ;
: activate-intervals ( n -- )
! Any inactive intervals which have ended are moved to handled
! Any inactive intervals which do not cover the current position
! are moved to active
inactive-intervals {
{ [ 2dup finished? ] [ finish ] }
{ [ 2dup covers? ] [ activate ] }
[ don't-change ]
} process-intervals ;
! Minheap of live intervals which still need a register allocation
SYMBOL: unhandled-intervals
! Start index of current live interval. We ensure that all
! live intervals added to the unhandled set have a start index
! strictly greater than ths one. This ensures that we can catch
! infinite loop situations.
SYMBOL: progress
: check-progress ( live-interval -- )
start>> progress get <= [ "No progress" throw ] when ; inline
: add-unhandled ( live-interval -- )
[ check-progress ]
[ dup start>> unhandled-intervals get heap-push ]
bi ;
CONSTANT: reg-classes { int-regs double-float-regs }
: reg-class-assoc ( quot -- assoc )
[ reg-classes ] dip { } map>assoc ; inline
SYMBOL: spill-counts
: next-spill-location ( reg-class -- n )
spill-counts get [ dup 1 + ] change-at ;
: init-allocator ( registers -- )
[ reverse >vector ] assoc-map free-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
-1 progress set ;
: init-unhandled ( live-intervals -- )
[ [ start>> ] keep ] { } map>assoc
unhandled-intervals get heap-push-all ;

4
basis/compiler/cfg/linear-scan/assignment/assignment-tests.factor
View File

@ -1,4 +0,0 @@
USING: compiler.cfg.linear-scan.assignment tools.test ;
IN: compiler.cfg.linear-scan.assignment.tests

88
basis/compiler/cfg/linear-scan/assignment/assignment.factor
View File

@ -7,20 +7,16 @@ compiler.cfg.def-use
compiler.cfg.registers compiler.cfg.registers
compiler.cfg.instructions compiler.cfg.instructions
compiler.cfg.linear-scan.allocation compiler.cfg.linear-scan.allocation
compiler.cfg.linear-scan.allocation.state
compiler.cfg.linear-scan.live-intervals ; compiler.cfg.linear-scan.live-intervals ;
IN: compiler.cfg.linear-scan.assignment IN: compiler.cfg.linear-scan.assignment
! A vector of live intervals. There is linear searching involved ! This contains both active and inactive intervals; any interval
! but since we never have too many machine registers (around 30 ! such that start <= insn# <= end is in this set.
! at most) and we probably won't have that many live at any one SYMBOL: pending-intervals
! time anyway, it is not a problem to check each element.
TUPLE: active-intervals seq ;
: add-active ( live-interval -- ) : add-active ( live-interval -- )
active-intervals get seq>> push ; pending-intervals get push ;
: lookup-register ( vreg -- reg )
active-intervals get seq>> [ vreg>> = ] with find nip reg>> ;
! Minheap of live intervals which still need a register allocation ! Minheap of live intervals which still need a register allocation
SYMBOL: unhandled-intervals SYMBOL: unhandled-intervals
@ -37,9 +33,11 @@ SYMBOL: spill-slots
: spill-slots-for ( vreg -- assoc ) : spill-slots-for ( vreg -- assoc )
reg-class>> spill-slots get at ; reg-class>> spill-slots get at ;
ERROR: already-spilled ;
: record-spill ( live-interval -- ) : record-spill ( live-interval -- )
[ dup spill-to>> ] [ vreg>> spill-slots-for ] bi [ dup spill-to>> ] [ vreg>> spill-slots-for ] bi
2dup key? [ "BUG: Already spilled" throw ] [ set-at ] if ; 2dup key? [ already-spilled ] [ set-at ] if ;
: insert-spill ( live-interval -- ) : insert-spill ( live-interval -- )
[ reg>> ] [ vreg>> reg-class>> ] [ spill-to>> ] tri _spill ; [ reg>> ] [ vreg>> reg-class>> ] [ spill-to>> ] tri _spill ;
@ -47,14 +45,27 @@ SYMBOL: spill-slots
: handle-spill ( live-interval -- ) : handle-spill ( live-interval -- )
dup spill-to>> [ [ record-spill ] [ insert-spill ] bi ] [ drop ] if ; dup spill-to>> [ [ record-spill ] [ insert-spill ] bi ] [ drop ] if ;
: insert-copy ( live-interval -- )
[ split-next>> reg>> ]
[ reg>> ]
[ vreg>> reg-class>> ]
tri _copy ;
: handle-copy ( live-interval -- )
dup [ spill-to>> not ] [ split-next>> ] bi and
[ insert-copy ] [ drop ] if ;
: expire-old-intervals ( n -- ) : expire-old-intervals ( n -- )
active-intervals get [ pending-intervals get ] dip '[
[ swap '[ end>> _ = ] partition ] change-seq drop dup end>> _ <
[ handle-spill ] each ; [ [ handle-spill ] [ handle-copy ] bi f ] [ drop t ] if
] filter-here ;
ERROR: already-reloaded ;
: record-reload ( live-interval -- ) : record-reload ( live-interval -- )
[ reload-from>> ] [ vreg>> spill-slots-for ] bi [ reload-from>> ] [ vreg>> spill-slots-for ] bi
2dup key? [ delete-at ] [ "BUG: Already reloaded" throw ] if ; 2dup key? [ delete-at ] [ already-reloaded ] if ;
: insert-reload ( live-interval -- ) : insert-reload ( live-interval -- )
[ reg>> ] [ vreg>> reg-class>> ] [ reload-from>> ] tri _reload ; [ reg>> ] [ vreg>> reg-class>> ] [ reload-from>> ] tri _reload ;
@ -73,39 +84,40 @@ SYMBOL: spill-slots
] [ 2drop ] if ] [ 2drop ] if
] if ; ] if ;
GENERIC: assign-before ( insn -- ) GENERIC: assign-registers-in-insn ( insn -- )
GENERIC: assign-after ( insn -- ) : register-mapping ( live-intervals -- alist )
[ [ vreg>> ] [ reg>> ] bi ] { } map>assoc ;
: all-vregs ( insn -- vregs ) : all-vregs ( insn -- vregs )
[ defs-vregs ] [ temp-vregs ] [ uses-vregs ] tri 3append ; [ defs-vregs ] [ temp-vregs ] [ uses-vregs ] tri 3append ;
M: vreg-insn assign-before : active-intervals ( insn -- intervals )
active-intervals get seq>> over all-vregs '[ vreg>> _ member? ] filter insn#>> pending-intervals get [ covers? ] with filter ;
[ [ vreg>> ] [ reg>> ] bi ] { } map>assoc
M: vreg-insn assign-registers-in-insn
dup [ active-intervals ] [ all-vregs ] bi
'[ vreg>> _ member? ] filter
register-mapping
>>regs drop ; >>regs drop ;
M: insn assign-before drop ; : compute-live-registers ( insn -- regs )
active-intervals register-mapping ;
: compute-live-registers ( -- regs )
active-intervals get seq>> [ [ vreg>> ] [ reg>> ] bi ] { } map>assoc ;
: compute-live-spill-slots ( -- spill-slots ) : compute-live-spill-slots ( -- spill-slots )
spill-slots get values [ values ] map concat spill-slots get values [ values ] map concat
[ [ vreg>> ] [ reload-from>> ] bi ] { } map>assoc ; [ [ vreg>> ] [ reload-from>> ] bi ] { } map>assoc ;
M: ##gc assign-after M: ##gc assign-registers-in-insn
compute-live-registers >>live-registers dup call-next-method
dup compute-live-registers >>live-registers
compute-live-spill-slots >>live-spill-slots compute-live-spill-slots >>live-spill-slots
drop ; drop ;
M: insn assign-after drop ; M: insn assign-registers-in-insn drop ;
: <active-intervals> ( -- obj )
V{ } clone active-intervals boa ;
: init-assignment ( live-intervals -- ) : init-assignment ( live-intervals -- )
<active-intervals> active-intervals set V{ } clone pending-intervals set
<min-heap> unhandled-intervals set <min-heap> unhandled-intervals set
[ H{ } clone ] reg-class-assoc spill-slots set [ H{ } clone ] reg-class-assoc spill-slots set
init-unhandled ; init-unhandled ;
@ -114,13 +126,15 @@ M: insn assign-after drop ;
[ [
[ [
[ [
{ [
[ insn#>> activate-new-intervals ] insn#>>
[ assign-before ] [ expire-old-intervals ]
[ , ] [ activate-new-intervals ]
[ insn#>> expire-old-intervals ] bi
[ assign-after ] ]
} cleave [ assign-registers-in-insn ]
[ , ]
tri
] each ] each
] V{ } make ] V{ } make
] change-instructions drop ; ] change-instructions drop ;

502
basis/compiler/cfg/linear-scan/linear-scan-tests.factor
View File

@ -1,17 +1,26 @@
IN: compiler.cfg.linear-scan.tests IN: compiler.cfg.linear-scan.tests
USING: tools.test random sorting sequences sets hashtables assocs USING: tools.test random sorting sequences sets hashtables assocs
kernel fry arrays splitting namespaces math accessors vectors kernel fry arrays splitting namespaces math accessors vectors locals
math.order grouping math.order grouping
cpu.architecture cpu.architecture
compiler.cfg compiler.cfg
compiler.cfg.optimizer compiler.cfg.optimizer
compiler.cfg.instructions compiler.cfg.instructions
compiler.cfg.registers compiler.cfg.registers
compiler.cfg.liveness
compiler.cfg.predecessors
compiler.cfg.rpo
compiler.cfg.linear-scan compiler.cfg.linear-scan
compiler.cfg.linear-scan.live-intervals compiler.cfg.linear-scan.live-intervals
compiler.cfg.linear-scan.allocation 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 ; compiler.cfg.linear-scan.debugger ;
check-allocation? on
[ [
{ T{ live-range f 1 10 } T{ live-range f 15 15 } } { T{ live-range f 1 10 } T{ live-range f 15 15 } }
{ T{ live-range f 16 20 } } { T{ live-range f 16 20 } }
@ -53,11 +62,8 @@ compiler.cfg.linear-scan.debugger ;
] unit-test ] unit-test
[ [
{ }
{ T{ live-range f 1 10 } }
] [
{ T{ live-range f 1 10 } } 0 split-ranges { T{ live-range f 1 10 } } 0 split-ranges
] unit-test ] must-fail
[ [
{ T{ live-range f 0 0 } } { T{ live-range f 0 0 } }
@ -118,32 +124,57 @@ compiler.cfg.linear-scan.debugger ;
{ end 5 } { end 5 }
{ uses V{ 0 1 5 } } { uses V{ 0 1 5 } }
{ ranges V{ T{ live-range f 0 5 } } } { ranges V{ T{ live-range f 0 5 } } }
} 2 split-interval } 2 split-for-spill [ f >>split-next ] bi@
] unit-test
[
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
{ start 0 }
{ end 0 }
{ uses V{ 0 } }
{ ranges V{ T{ live-range f 0 0 } } }
}
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
{ start 1 }
{ end 5 }
{ uses V{ 1 5 } }
{ ranges V{ T{ live-range f 1 5 } } }
}
] [
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
{ start 0 }
{ end 5 }
{ uses V{ 0 1 5 } }
{ ranges V{ T{ live-range f 0 5 } } }
} 0 split-for-spill [ f >>split-next ] bi@
] unit-test ] unit-test
[ [
T{ live-interval T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } } { vreg T{ vreg { reg-class int-regs } { n 1 } } }
{ start 0 } { start 0 }
{ end 0 } { end 4 }
{ uses V{ 0 } } { uses V{ 0 1 4 } }
{ ranges V{ T{ live-range f 0 0 } } } { ranges V{ T{ live-range f 0 4 } } }
} }
T{ live-interval T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } } { vreg T{ vreg { reg-class int-regs } { n 1 } } }
{ start 1 } { start 5 }
{ end 5 } { end 5 }
{ uses V{ 1 5 } } { uses V{ 5 } }
{ ranges V{ T{ live-range f 1 5 } } } { ranges V{ T{ live-range f 5 5 } } }
} }
] [ ] [
T{ live-interval T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } } { vreg T{ vreg { reg-class int-regs } { n 1 } } }
{ start 0 } { start 0 }
{ end 5 } { end 5 }
{ uses V{ 0 1 5 } } { uses V{ 0 1 5 } }
{ ranges V{ T{ live-range f 0 5 } } } { ranges V{ T{ live-range f 0 5 } } }
} 0 split-interval } 5 split-before-use [ f >>split-next ] bi@
] unit-test ] unit-test
[ [
@ -1294,26 +1325,32 @@ USING: math.private compiler.cfg.debugger ;
! Spill slot liveness was computed incorrectly, leading to a FEP ! Spill slot liveness was computed incorrectly, leading to a FEP
! early in bootstrap on x86-32 ! early in bootstrap on x86-32
[ t ] [ [ t ] [
T{ basic-block [
{ instructions H{ } clone live-ins set
V{ H{ } clone live-outs set
T{ ##gc f V int-regs 6 V int-regs 7 } H{ } clone phi-live-ins set
T{ ##peek f V int-regs 0 D 0 } T{ basic-block
T{ ##peek f V int-regs 1 D 1 } { id 12345 }
T{ ##peek f V int-regs 2 D 2 } { instructions
T{ ##peek f V int-regs 3 D 3 } V{
T{ ##peek f V int-regs 4 D 4 } T{ ##gc f V int-regs 6 V int-regs 7 }
T{ ##peek f V int-regs 5 D 5 } T{ ##peek f V int-regs 0 D 0 }
T{ ##replace f V int-regs 0 D 1 } T{ ##peek f V int-regs 1 D 1 }
T{ ##replace f V int-regs 1 D 2 } T{ ##peek f V int-regs 2 D 2 }
T{ ##replace f V int-regs 2 D 3 } T{ ##peek f V int-regs 3 D 3 }
T{ ##replace f V int-regs 3 D 4 } T{ ##peek f V int-regs 4 D 4 }
T{ ##replace f V int-regs 4 D 5 } T{ ##peek f V int-regs 5 D 5 }
T{ ##replace f V int-regs 5 D 0 } T{ ##replace f V int-regs 0 D 1 }
} T{ ##replace f V int-regs 1 D 2 }
} T{ ##replace f V int-regs 2 D 3 }
} dup 1array { { int-regs V{ 0 1 2 3 } } } (linear-scan) T{ ##replace f V int-regs 3 D 4 }
instructions>> first live-spill-slots>> empty? T{ ##replace f V int-regs 4 D 5 }
T{ ##replace f V int-regs 5 D 0 }
}
}
} dup 1array { { int-regs V{ 0 1 2 3 } } } (linear-scan)
instructions>> first live-spill-slots>> empty?
] with-scope
] unit-test ] unit-test
[ f ] [ [ f ] [
@ -1373,5 +1410,394 @@ USING: math.private compiler.cfg.debugger ;
{ uses { 5 10 } } { uses { 5 10 } }
{ ranges V{ T{ live-range f 5 10 } } } { ranges V{ T{ live-range f 5 10 } } }
} }
H{ }
intersect-inactive intersect-inactive
] unit-test ] unit-test
! Bug in live spill slots calculation
T{ basic-block
{ id 205651 }
{ number 0 }
{ instructions V{ T{ ##prologue } T{ ##branch } } }
} 0 set
T{ basic-block
{ id 205652 }
{ number 1 }
{ instructions
V{
T{ ##peek
{ dst V int-regs 703128 }
{ loc D 1 }
}
T{ ##peek
{ dst V int-regs 703129 }
{ loc D 0 }
}
T{ ##copy
{ dst V int-regs 703134 }
{ src V int-regs 703128 }
}
T{ ##copy
{ dst V int-regs 703135 }
{ src V int-regs 703129 }
}
T{ ##compare-imm-branch
{ src1 V int-regs 703128 }
{ src2 5 }
{ cc cc/= }
}
}
}
} 1 set
T{ basic-block
{ id 205653 }
{ number 2 }
{ instructions
V{
T{ ##copy
{ dst V int-regs 703134 }
{ src V int-regs 703129 }
}
T{ ##copy
{ dst V int-regs 703135 }
{ src V int-regs 703128 }
}
T{ ##branch }
}
}
} 2 set
T{ basic-block
{ id 205655 }
{ number 3 }
{ instructions
V{
T{ ##replace
{ src V int-regs 703134 }
{ loc D 0 }
}
T{ ##replace
{ src V int-regs 703135 }
{ loc D 1 }
}
T{ ##epilogue }
T{ ##return }
}
}
} 3 set
1 get 1vector 0 get (>>successors)
2 get 3 get V{ } 2sequence 1 get (>>successors)
3 get 1vector 2 get (>>successors)
:: test-linear-scan-on-cfg ( regs -- )
[ ] [
cfg new 0 get >>entry
compute-predecessors
compute-liveness
reverse-post-order
{ { int-regs regs } } (linear-scan)
] unit-test ;
{ 1 2 } test-linear-scan-on-cfg
! Bug in inactive interval handling
! [ rot dup [ -rot ] when ]
T{ basic-block
{ id 201486 }
{ number 0 }
{ instructions V{ T{ ##prologue } T{ ##branch } } }
} 0 set
T{ basic-block
{ id 201487 }
{ number 1 }
{ instructions
V{
T{ ##peek
{ dst V int-regs 689473 }
{ loc D 2 }
}
T{ ##peek
{ dst V int-regs 689474 }
{ loc D 1 }
}
T{ ##peek
{ dst V int-regs 689475 }
{ loc D 0 }
}
T{ ##compare-imm-branch
{ src1 V int-regs 689473 }
{ src2 5 }
{ cc cc/= }
}
}
}
} 1 set
T{ basic-block
{ id 201488 }
{ number 2 }
{ instructions
V{
T{ ##copy
{ dst V int-regs 689481 }
{ src V int-regs 689475 }
}
T{ ##copy
{ dst V int-regs 689482 }
{ src V int-regs 689474 }
}
T{ ##copy
{ dst V int-regs 689483 }
{ src V int-regs 689473 }
}
T{ ##branch }
}
}
} 2 set
T{ basic-block
{ id 201489 }
{ number 3 }
{ instructions
V{
T{ ##copy
{ dst V int-regs 689481 }
{ src V int-regs 689473 }
}
T{ ##copy
{ dst V int-regs 689482 }
{ src V int-regs 689475 }
}
T{ ##copy
{ dst V int-regs 689483 }
{ src V int-regs 689474 }
}
T{ ##branch }
}
}
} 3 set
T{ basic-block
{ id 201490 }
{ number 4 }
{ instructions
V{
T{ ##replace
{ src V int-regs 689481 }
{ loc D 0 }
}
T{ ##replace
{ src V int-regs 689482 }
{ loc D 1 }
}
T{ ##replace
{ src V int-regs 689483 }
{ loc D 2 }
}
T{ ##epilogue }
T{ ##return }
}
}
} 4 set
: test-diamond ( -- )
1 get 1vector 0 get (>>successors)
2 get 3 get V{ } 2sequence 1 get (>>successors)
4 get 1vector 2 get (>>successors)
4 get 1vector 3 get (>>successors) ;
test-diamond
{ 1 2 3 4 } test-linear-scan-on-cfg
! Similar to the above
! [ swap dup [ rot ] when ]
T{ basic-block
{ id 201537 }
{ number 0 }
{ instructions V{ T{ ##prologue } T{ ##branch } } }
} 0 set
T{ basic-block
{ id 201538 }
{ number 1 }
{ instructions
V{
T{ ##peek
{ dst V int-regs 689600 }
{ loc D 1 }
}
T{ ##peek
{ dst V int-regs 689601 }
{ loc D 0 }
}
T{ ##compare-imm-branch
{ src1 V int-regs 689600 }
{ src2 5 }
{ cc cc/= }
}
}
}
} 1 set
T{ basic-block
{ id 201539 }
{ number 2 }
{ instructions
V{
T{ ##peek
{ dst V int-regs 689604 }
{ loc D 2 }
}
T{ ##copy
{ dst V int-regs 689607 }
{ src V int-regs 689604 }
}
T{ ##copy
{ dst V int-regs 689608 }
{ src V int-regs 689600 }
}
T{ ##copy
{ dst V int-regs 689610 }
{ src V int-regs 689601 }
}
T{ ##branch }
}
}
} 2 set
T{ basic-block
{ id 201540 }
{ number 3 }
{ instructions
V{
T{ ##peek
{ dst V int-regs 689609 }
{ loc D 2 }
}
T{ ##copy
{ dst V int-regs 689607 }
{ src V int-regs 689600 }
}
T{ ##copy
{ dst V int-regs 689608 }
{ src V int-regs 689601 }
}
T{ ##copy
{ dst V int-regs 689610 }
{ src V int-regs 689609 }
}
T{ ##branch }
}
}
} 3 set
T{ basic-block
{ id 201541 }
{ number 4 }
{ instructions
V{
T{ ##replace
{ src V int-regs 689607 }
{ loc D 0 }
}
T{ ##replace
{ src V int-regs 689608 }
{ loc D 1 }
}
T{ ##replace
{ src V int-regs 689610 }
{ loc D 2 }
}
T{ ##epilogue }
T{ ##return }
}
}
} 4 set
test-diamond
{ 1 2 3 4 } test-linear-scan-on-cfg
! compute-live-registers was inaccurate since it didn't take
! lifetime holes into account
T{ basic-block
{ id 0 }
{ number 0 }
{ instructions V{ T{ ##prologue } T{ ##branch } } }
} 0 set
T{ basic-block
{ id 1 }
{ instructions
V{
T{ ##peek
{ dst V int-regs 0 }
{ loc D 0 }
}
T{ ##compare-imm-branch
{ src1 V int-regs 0 }
{ src2 5 }
{ cc cc/= }
}
}
}
} 1 set
T{ basic-block
{ id 2 }
{ instructions
V{
T{ ##peek
{ dst V int-regs 1 }
{ loc D 1 }
}
T{ ##copy
{ dst V int-regs 2 }
{ src V int-regs 1 }
}
T{ ##branch }
}
}
} 2 set
T{ basic-block
{ id 3 }
{ instructions
V{
T{ ##peek
{ dst V int-regs 3 }
{ loc D 2 }
}
T{ ##copy
{ dst V int-regs 2 }
{ src V int-regs 3 }
}
T{ ##branch }
}
}
} 3 set
T{ basic-block
{ id 4 }
{ instructions
V{
T{ ##replace
{ src V int-regs 2 }
{ loc D 0 }
}
T{ ##return }
}
}
} 4 set
test-diamond
{ 1 2 3 4 } test-linear-scan-on-cfg

1
basis/compiler/cfg/linear-scan/linear-scan.factor
View File

@ -8,6 +8,7 @@ compiler.cfg.instructions
compiler.cfg.linear-scan.numbering compiler.cfg.linear-scan.numbering
compiler.cfg.linear-scan.live-intervals compiler.cfg.linear-scan.live-intervals
compiler.cfg.linear-scan.allocation compiler.cfg.linear-scan.allocation
compiler.cfg.linear-scan.allocation.state
compiler.cfg.linear-scan.assignment ; compiler.cfg.linear-scan.assignment ;
IN: compiler.cfg.linear-scan IN: compiler.cfg.linear-scan

43
basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2008, 2009 Slava Pestov. ! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: namespaces kernel assocs accessors sequences math math.order fry USING: namespaces kernel assocs accessors sequences math math.order fry
binary-search compiler.cfg.instructions compiler.cfg.registers binary-search combinators compiler.cfg.instructions compiler.cfg.registers
compiler.cfg.def-use compiler.cfg.liveness compiler.cfg ; compiler.cfg.def-use compiler.cfg.liveness compiler.cfg ;
IN: compiler.cfg.linear-scan.live-intervals IN: compiler.cfg.linear-scan.live-intervals
@ -11,10 +11,21 @@ C: <live-range> live-range
TUPLE: live-interval TUPLE: live-interval
vreg vreg
reg spill-to reload-from split-before split-after reg spill-to reload-from
split-before split-after split-next
start end ranges uses start end ranges uses
copy-from ; copy-from ;
: covers? ( insn# live-interval -- ? )
ranges>> [ [ from>> ] [ to>> ] bi between? ] with any? ;
: child-interval-at ( insn# interval -- interval' )
dup split-after>> [
2dup split-after>> start>> <
[ split-before>> ] [ split-after>> ] if
child-interval-at
] [ nip ] if ;
ERROR: dead-value-error vreg ; ERROR: dead-value-error vreg ;
: shorten-range ( n live-interval -- ) : shorten-range ( n live-interval -- )
@ -46,11 +57,9 @@ ERROR: dead-value-error vreg ;
V{ } clone >>ranges V{ } clone >>ranges
swap >>vreg ; swap >>vreg ;
: block-from ( -- n ) : block-from ( bb -- n ) instructions>> first insn#>> ;
basic-block get instructions>> first insn#>> ;
: block-to ( -- n ) : block-to ( bb -- n ) instructions>> last insn#>> ;
basic-block get instructions>> last insn#>> ;
M: live-interval hashcode* M: live-interval hashcode*
nip [ start>> ] [ end>> 1000 * ] bi + ; nip [ start>> ] [ end>> 1000 * ] bi + ;
@ -74,7 +83,7 @@ M: insn compute-live-intervals* drop ;
: handle-input ( n vreg live-intervals -- ) : handle-input ( n vreg live-intervals -- )
live-interval live-interval
[ [ block-from ] 2dip add-range ] [ add-use ] 2bi ; [ [ basic-block get block-from ] 2dip add-range ] [ add-use ] 2bi ;
: handle-temp ( n vreg live-intervals -- ) : handle-temp ( n vreg live-intervals -- )
live-interval live-interval
@ -98,7 +107,9 @@ M: ##copy-float compute-live-intervals*
[ call-next-method ] [ record-copy ] bi ; [ call-next-method ] [ record-copy ] bi ;
: handle-live-out ( bb -- ) : handle-live-out ( bb -- )
live-out keys block-from block-to live-intervals get '[ live-out keys
basic-block get [ block-from ] [ block-to ] bi
live-intervals get '[
[ _ _ ] dip _ live-interval add-range [ _ _ ] dip _ live-interval add-range
] each ; ] each ;
@ -109,17 +120,23 @@ M: ##copy-float compute-live-intervals*
: compute-start/end ( live-interval -- ) : compute-start/end ( live-interval -- )
dup ranges>> [ first from>> ] [ last to>> ] bi dup ranges>> [ first from>> ] [ last to>> ] bi
2dup > [ "BUG: start > end" throw ] when
[ >>start ] [ >>end ] bi* drop ; [ >>start ] [ >>end ] bi* drop ;
: check-start/end ( live-interval -- )
[ [ start>> ] [ uses>> first ] bi assert= ]
[ [ end>> ] [ uses>> last ] bi assert= ]
bi ;
: finish-live-intervals ( live-intervals -- ) : finish-live-intervals ( live-intervals -- )
! Since live intervals are computed in a backward order, we have ! Since live intervals are computed in a backward order, we have
! to reverse some sequences, and compute the start and end. ! to reverse some sequences, and compute the start and end.
[ [
[ ranges>> reverse-here ] {
[ uses>> reverse-here ] [ ranges>> reverse-here ]
[ compute-start/end ] [ uses>> reverse-here ]
tri [ compute-start/end ]
[ check-start/end ]
} cleave
] each ; ] each ;
: compute-live-intervals ( rpo -- live-intervals ) : compute-live-intervals ( rpo -- live-intervals )

34
basis/compiler/cfg/linear-scan/resolve/resolve.factor Normal file
View File

@ -0,0 +1,34 @@
! Copyright (C) 2009 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs kernel math namespaces sequences
compiler.cfg.linear-scan.live-intervals compiler.cfg.liveness ;
IN: compiler.cfg.linear-scan.resolve
: add-mapping ( from to -- )
2drop
;
: resolve-value-data-flow ( bb to vreg -- )
live-intervals get at
[ [ block-to ] dip child-interval-at ]
[ [ block-from ] dip child-interval-at ]
bi-curry bi* 2dup = [ 2drop ] [
add-mapping
] if ;
: resolve-mappings ( bb to -- )
2drop
;
: resolve-edge-data-flow ( bb to -- )
[ dup live-in [ resolve-value-data-flow ] with with each ]
[ resolve-mappings ]
2bi ;
: resolve-block-data-flow ( bb -- )
dup successors>> [
resolve-edge-data-flow
] with each ;
: resolve-data-flow ( rpo -- )
[ resolve-block-data-flow ] each ;

5
basis/compiler/cfg/predecessors/predecessors.factor
View File

@ -7,4 +7,7 @@ IN: compiler.cfg.predecessors
dup successors>> [ predecessors>> push ] with each ; dup successors>> [ predecessors>> push ] with each ;
: compute-predecessors ( cfg -- cfg' ) : compute-predecessors ( cfg -- cfg' )
dup [ predecessors-step ] each-basic-block ; [ [ V{ } clone >>predecessors drop ] each-basic-block ]
[ [ predecessors-step ] each-basic-block ]
[ ]
tri ;

4
basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor
View File

@ -4,7 +4,7 @@ compiler.cfg.instructions sequences kernel tools.test accessors
sequences.private alien math combinators.private compiler.cfg sequences.private alien math combinators.private compiler.cfg
compiler.cfg.checker compiler.cfg.height compiler.cfg.rpo compiler.cfg.checker compiler.cfg.height compiler.cfg.rpo
compiler.cfg.dce compiler.cfg.registers compiler.cfg.useless-blocks compiler.cfg.dce compiler.cfg.registers compiler.cfg.useless-blocks
sets ; sets namespaces ;
IN: compiler.cfg.stack-analysis.tests IN: compiler.cfg.stack-analysis.tests
! Fundamental invariant: a basic block should not load or store a value more than once ! Fundamental invariant: a basic block should not load or store a value more than once
@ -33,6 +33,8 @@ IN: compiler.cfg.stack-analysis.tests
: linearize ( cfg -- mr ) : linearize ( cfg -- mr )
flatten-cfg instructions>> ; flatten-cfg instructions>> ;
local-only? off
[ ] [ [ ] test-stack-analysis drop ] unit-test [ ] [ [ ] test-stack-analysis drop ] unit-test
! Only peek once ! Only peek once

6
basis/compiler/codegen/codegen.factor
View File

@ -531,4 +531,10 @@ M: _reload generate-insn
{ double-float-regs [ %reload-float ] } { double-float-regs [ %reload-float ] }
} case ; } case ;
M: _copy generate-insn
[ dst>> ] [ src>> ] [ class>> ] tri {
{ int-regs [ %copy ] }
{ double-float-regs [ %copy-float ] }
} case ;
M: _spill-counts generate-insn drop ; M: _spill-counts generate-insn drop ;

22
basis/compiler/tests/codegen.factor
View File

@ -289,3 +289,25 @@ M: cucumber equal? "The cucumber has no equal" throw ;
[ [ 0 alien-unsigned-cell swap ] [ 0 alien-signed-2 ] bi ] [ [ 0 alien-unsigned-cell swap ] [ 0 alien-signed-2 ] bi ]
compile-call compile-call
] unit-test ] unit-test
! Regression found while working on global register allocation
: linear-scan-regression-1 ( a b c -- ) 3array , ;
: linear-scan-regression-2 ( a b -- ) 2array , ;
: linear-scan-regression ( a b c -- )
[ linear-scan-regression-2 ]
[ linear-scan-regression-1 ]
bi-curry bi-curry interleave ;
[
{
{ 1 "x" "y" }
{ "x" "y" }
{ 2 "x" "y" }
{ "x" "y" }
{ 3 "x" "y" }
}
] [
[ { 1 2 3 } "x" "y" linear-scan-regression ] { } make
] unit-test

7
basis/compression/huffman/huffman.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2009 Marc Fauconneau. ! Copyright (C) 2009 Marc Fauconneau.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs constructors fry USING: accessors arrays assocs fry
hashtables io kernel locals math math.order math.parser hashtables io kernel locals math math.order math.parser
math.ranges multiline sequences ; math.ranges multiline sequences ;
IN: compression.huffman IN: compression.huffman
@ -58,7 +58,10 @@ TUPLE: huffman-decoder
{ rtable } { rtable }
{ bits/level } ; { bits/level } ;
CONSTRUCTOR: huffman-decoder ( bs tdesc -- decoder ) : <huffman-decoder> ( bs tdesc -- decoder )
huffman-decoder new
swap >>tdesc
swap >>bs
16 >>bits/level 16 >>bits/level
[ ] [ tdesc>> ] [ bits/level>> 2^ ] tri reverse-table >>rtable ; [ ] [ tdesc>> ] [ bits/level>> 2^ ] tri reverse-table >>rtable ;

14
basis/compression/inflate/inflate.factor Executable file → Normal file
View File

@ -1,7 +1,7 @@
! Copyright (C) 2009 Marc Fauconneau. ! Copyright (C) 2009 Marc Fauconneau.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs byte-arrays USING: accessors arrays assocs byte-arrays
byte-vectors combinators constructors fry grouping hashtables byte-vectors combinators fry grouping hashtables
compression.huffman images io.binary kernel locals compression.huffman images io.binary kernel locals
math math.bitwise math.order math.ranges multiline sequences math math.bitwise math.order math.ranges multiline sequences
sorting ; sorting ;
@ -151,7 +151,16 @@ CONSTANT: dist-table
] when ] when
] map ; ] map ;
: inflate-raw ( bitstream -- bytes ) zlib-unimplemented ; :: inflate-raw ( bitstream -- bytes )
8 bitstream bs:align
16 bitstream bs:read :> len
16 bitstream bs:read :> nlen
len nlen + 16 >signed -1 assert= ! len + ~len = -1
bitstream byte-pos>>
bitstream byte-pos>> len +
bitstream bytes>> <slice>
len 8 * bitstream bs:seek ;
: inflate-static ( bitstream -- bytes ) zlib-unimplemented ; : inflate-static ( bitstream -- bytes ) zlib-unimplemented ;
:: inflate-loop ( bitstream -- bytes ) :: inflate-loop ( bitstream -- bytes )
@ -194,7 +203,6 @@ CONSTANT: dist-table
PRIVATE> PRIVATE>
! for debug -- shows residual values
: reverse-png-filter' ( lines -- byte-array ) : reverse-png-filter' ( lines -- byte-array )
[ first ] [ 1 tail ] [ map ] bi-curry@ bi nip [ first ] [ 1 tail ] [ map ] bi-curry@ bi nip
concat [ 128 + ] B{ } map-as ; concat [ 128 + ] B{ } map-as ;

2
basis/functors/functors.factor
View File

@ -58,8 +58,6 @@ M: object (fake-quotations>) , ;
[ parse-definition* ] dip [ parse-definition* ] dip
parsed ; parsed ;
: DEFINE* ( accum -- accum ) \ define-declared* parsed ;
SYNTAX: `TUPLE: SYNTAX: `TUPLE:
scan-param parsed scan-param parsed
scan { scan {

19
basis/game-input/dinput/dinput.factor
View File

@ -1,14 +1,13 @@
USING: windows.dinput windows.dinput.constants parser USING: accessors alien alien.c-types alien.strings arrays
alien.c-types windows.ole32 namespaces assocs kernel arrays assocs byte-arrays combinators continuations game-input
vectors windows.kernel32 windows.com windows.dinput shuffle game-input.dinput.keys-array io.encodings.utf16
windows.user32 windows.messages sequences combinators locals io.encodings.utf16n kernel locals math math.bitwise
math.rectangles accessors math alien alien.strings math.rectangles namespaces parser sequences shuffle
io.encodings.utf16 io.encodings.utf16n continuations struct-arrays ui.backend.windows vectors windows.com
byte-arrays game-input.dinput.keys-array game-input windows.dinput windows.dinput.constants windows.errors
ui.backend.windows windows.errors struct-arrays windows.kernel32 windows.messages windows.ole32
math.bitwise ; windows.user32 ;
IN: game-input.dinput IN: game-input.dinput
CONSTANT: MOUSE-BUFFER-SIZE 16 CONSTANT: MOUSE-BUFFER-SIZE 16
SINGLETON: dinput-game-input-backend SINGLETON: dinput-game-input-backend

9
basis/heaps/heaps.factor
View File

@ -51,9 +51,6 @@ M: heap heap-size ( heap -- n )
: data-nth ( n heap -- entry ) : data-nth ( n heap -- entry )
data>> nth-unsafe ; inline data>> nth-unsafe ; inline
: up-value ( n heap -- entry )
[ up ] dip data-nth ; inline
: left-value ( n heap -- entry ) : left-value ( n heap -- entry )
[ left ] dip data-nth ; inline [ left ] dip data-nth ; inline
@ -75,9 +72,6 @@ M: heap heap-size ( heap -- n )
: data-pop* ( heap -- ) : data-pop* ( heap -- )
data>> pop* ; inline data>> pop* ; inline
: data-peek ( heap -- entry )
data>> last ; inline
: data-first ( heap -- entry ) : data-first ( heap -- entry )
data>> first ; inline data>> first ; inline
@ -130,9 +124,6 @@ DEFER: up-heap
2dup right-bounds-check? 2dup right-bounds-check?
[ drop left ] [ (child) ] if ; [ drop left ] [ (child) ] if ;
: swap-down ( m heap -- )
[ child ] 2keep data-exchange ;
DEFER: down-heap DEFER: down-heap
: (down-heap) ( m heap -- ) : (down-heap) ( m heap -- )

2
basis/help/lint/lint.factor
View File

@ -55,8 +55,6 @@ PRIVATE>
] check-something ] check-something
] [ drop ] if ; ] [ drop ] if ;
: check-words ( words -- ) [ check-word ] each ;
: check-article ( article -- ) : check-article ( article -- )
[ with-interactive-vocabs ] vocabs-quot set [ with-interactive-vocabs ] vocabs-quot set
>link dup '[ >link dup '[

134
basis/images/jpeg/jpeg.factor Executable file → Normal file
View File

@ -1,19 +1,17 @@
! Copyright (C) 2009 Marc Fauconneau. ! Copyright (C) 2009 Marc Fauconneau.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays byte-arrays combinators USING: accessors arrays byte-arrays combinators
constructors grouping compression.huffman images grouping compression.huffman images
images.processing io io.binary io.encodings.binary io.files images.processing io io.binary io.encodings.binary io.files
io.streams.byte-array kernel locals math math.bitwise io.streams.byte-array kernel locals math math.bitwise
math.constants math.functions math.matrices math.order math.constants math.functions math.matrices math.order
math.ranges math.vectors memoize multiline namespaces math.ranges math.vectors memoize multiline namespaces
sequences sequences.deep images.loader ; sequences sequences.deep ;
QUALIFIED-WITH: bitstreams bs
IN: images.jpeg IN: images.jpeg
SINGLETON: jpeg-image QUALIFIED-WITH: bitstreams bs
{ "jpg" "jpeg" } [ jpeg-image register-image-class ] each
TUPLE: loading-jpeg < image TUPLE: jpeg-image < image
{ headers } { headers }
{ bitstream } { bitstream }
{ color-info initial: { f f f f } } { color-info initial: { f f f f } }
@ -23,7 +21,8 @@ TUPLE: loading-jpeg < image
<PRIVATE <PRIVATE
CONSTRUCTOR: loading-jpeg ( headers bitstream -- image ) ; : <jpeg-image> ( headers bitstream -- image )
jpeg-image new swap >>bitstream swap >>headers ;
SINGLETONS: SOF DHT DAC RST SOI EOI SOS DQT DNL DRI DHP EXP SINGLETONS: SOF DHT DAC RST SOI EOI SOS DQT DNL DRI DHP EXP
APP JPG COM TEM RES ; APP JPG COM TEM RES ;
@ -58,14 +57,22 @@ APP JPG COM TEM RES ;
TUPLE: jpeg-chunk length type data ; TUPLE: jpeg-chunk length type data ;
CONSTRUCTOR: jpeg-chunk ( type length data -- jpeg-chunk ) ; : <jpeg-chunk> ( type length data -- jpeg-chunk )
jpeg-chunk new
swap >>data
swap >>length
swap >>type ;
TUPLE: jpeg-color-info TUPLE: jpeg-color-info
h v quant-table dc-huff-table ac-huff-table { diff initial: 0 } id ; h v quant-table dc-huff-table ac-huff-table { diff initial: 0 } id ;
CONSTRUCTOR: jpeg-color-info ( h v quant-table -- jpeg-color-info ) ; : <jpeg-color-info> ( h v quant-table -- jpeg-color-info )
jpeg-color-info new
swap >>quant-table
swap >>v
swap >>h ;
: jpeg> ( -- jpeg-image ) loading-jpeg get ; : jpeg> ( -- jpeg-image ) jpeg-image get ;
: apply-diff ( dc color -- dc' ) : apply-diff ( dc color -- dc' )
[ diff>> + dup ] [ (>>diff) ] bi ; [ diff>> + dup ] [ (>>diff) ] bi ;
@ -77,7 +84,6 @@ CONSTRUCTOR: jpeg-color-info ( h v quant-table -- jpeg-color-info ) ;
: read4/4 ( -- a b ) read1 16 /mod ; : read4/4 ( -- a b ) read1 16 /mod ;
! headers ! headers
: decode-frame ( header -- ) : decode-frame ( header -- )
@ -188,6 +194,9 @@ MEMO: dct-matrix ( -- m ) 64 [0,b) [ 8 /mod dct-vect flatten ] map ;
: mb-dim ( component -- dim ) [ h>> ] [ v>> ] bi 2array ; : mb-dim ( component -- dim ) [ h>> ] [ v>> ] bi 2array ;
! : blocks ( component -- seq )
! mb-dim ! coord-matrix flip concat [ [ { 2 2 } v* ] [ v+ ] bi* ] with map ;
: all-macroblocks ( quot: ( mb -- ) -- ) : all-macroblocks ( quot: ( mb -- ) -- )
[ [
jpeg> jpeg>
@ -211,12 +220,12 @@ MEMO: dct-matrix-blas ( -- m ) dct-matrix >float-blas-matrix ;
: idct ( b -- b' ) idct-blas ; : idct ( b -- b' ) idct-blas ;
:: draw-block ( block x,y color jpeg-image -- ) :: draw-block ( block x,y color-id jpeg-image -- )
block dup length>> sqrt >fixnum group flip block dup length>> sqrt >fixnum group flip
dup matrix-dim coord-matrix flip dup matrix-dim coord-matrix flip
[ [
[ first2 spin nth nth ] [ first2 spin nth nth ]
[ x,y v+ color id>> 1- jpeg-image draw-color ] bi [ x,y v+ color-id jpeg-image draw-color ] bi
] with each^2 ; ] with each^2 ;
: sign-extend ( bits v -- v' ) : sign-extend ( bits v -- v' )
@ -229,7 +238,7 @@ MEMO: dct-matrix-blas ( -- m ) dct-matrix >float-blas-matrix ;
: read1-jpeg-ac ( decoder -- run/ac ) : read1-jpeg-ac ( decoder -- run/ac )
[ read1-huff 16 /mod dup ] [ bs>> bs:read ] bi sign-extend 2array ; [ read1-huff 16 /mod dup ] [ bs>> bs:read ] bi sign-extend 2array ;
:: decode-block ( pos color -- ) :: decode-block ( color -- pixels )
color dc-huff-table>> read1-jpeg-dc color apply-diff color dc-huff-table>> read1-jpeg-dc color apply-diff
64 0 <array> :> coefs 64 0 <array> :> coefs
0 coefs set-nth 0 coefs set-nth
@ -241,19 +250,38 @@ MEMO: dct-matrix-blas ( -- m ) dct-matrix >float-blas-matrix ;
k 63 < and k 63 < and
] loop ] loop
coefs color quant-table>> v* coefs color quant-table>> v*
reverse-zigzag idct reverse-zigzag idct ;
! %fixme: color hack
! this eat 50% cpu time
color h>> 2 =
[ 8 group 2 matrix-zoom concat ] unless
pos { 8 8 } v* color jpeg> draw-block ;
: decode-macroblock ( mb -- ) :: draw-macroblock-yuv420 ( mb blocks -- )
mb { 16 16 } v* :> pos
0 blocks nth pos { 0 0 } v+ 0 jpeg> draw-block
1 blocks nth pos { 8 0 } v+ 0 jpeg> draw-block
2 blocks nth pos { 0 8 } v+ 0 jpeg> draw-block
3 blocks nth pos { 8 8 } v+ 0 jpeg> draw-block
4 blocks nth 8 group 2 matrix-zoom concat pos 1 jpeg> draw-block
5 blocks nth 8 group 2 matrix-zoom concat pos 2 jpeg> draw-block ;
:: draw-macroblock-yuv444 ( mb blocks -- )
mb { 8 8 } v* :> pos
3 iota [ [ blocks nth pos ] [ jpeg> draw-block ] bi ] each ;
:: draw-macroblock-y ( mb blocks -- )
mb { 8 8 } v* :> pos
0 blocks nth pos 0 jpeg> draw-block
64 0 <array> pos 1 jpeg> draw-block
64 0 <array> pos 2 jpeg> draw-block ;
! %fixme: color hack
! color h>> 2 =
! [ 8 group 2 matrix-zoom concat ] unless
! pos { 8 8 } v* color jpeg> draw-block ;
: decode-macroblock ( -- blocks )
jpeg> components>> jpeg> components>>
[ [
[ mb-dim coord-matrix flip concat [ [ { 2 2 } v* ] [ v+ ] bi* ] with map ] [ mb-dim first2 * iota ]
[ [ decode-block ] curry each ] bi [ [ decode-block ] curry replicate ] bi
] with each ; ] map concat ;
: cleanup-bitstream ( bytes -- bytes' ) : cleanup-bitstream ( bytes -- bytes' )
binary [ binary [
@ -274,33 +302,67 @@ MEMO: dct-matrix-blas ( -- m ) dct-matrix >float-blas-matrix ;
dup dim>> first2 * 3 * 0 <array> >>bitmap dup dim>> first2 * 3 * 0 <array> >>bitmap
drop ; drop ;
: baseline-decompress ( -- ) ERROR: unsupported-colorspace ;
jpeg> bitstream>> cleanup-bitstream { 255 255 255 255 } append SINGLETONS: YUV420 YUV444 Y MAGIC! ;
>byte-array bs:<msb0-bit-reader> jpeg> (>>bitstream)
jpeg> [ bitstream>> ] [ [ [ <huffman-decoder> ] with map ] change-huff-tables drop ] bi :: detect-colorspace ( jpeg-image -- csp )
jpeg> components>> [ fetch-tables ] each jpeg-image color-info>> sift :> colors
jpeg> setup-bitmap MAGIC!
[ decode-macroblock ] all-macroblocks ; colors length 1 = [ drop Y ] when
colors length 3 =
[
colors [ mb-dim { 1 1 } = ] all?
[ drop YUV444 ] when
colors unclip
[ [ mb-dim { 1 1 } = ] all? ]
[ mb-dim { 2 2 } = ] bi* and
[ drop YUV420 ] when
] when ;
! this eats ~50% cpu time
: draw-macroblocks ( mbs -- )
jpeg> detect-colorspace
{
{ YUV420 [ [ first2 draw-macroblock-yuv420 ] each ] }
{ YUV444 [ [ first2 draw-macroblock-yuv444 ] each ] }
{ Y [ [ first2 draw-macroblock-y ] each ] }
[ unsupported-colorspace ]
} case ;
! this eats ~25% cpu time ! this eats ~25% cpu time
: color-transform ( yuv -- rgb ) : color-transform ( yuv -- rgb )
{ 128 0 0 } v+ yuv>bgr-matrix swap m.v { 128 0 0 } v+ yuv>bgr-matrix swap m.v
[ 0 max 255 min >fixnum ] map ; [ 0 max 255 min >fixnum ] map ;
: baseline-decompress ( -- )
jpeg> bitstream>> cleanup-bitstream { 255 255 255 255 } append
>byte-array bs:<msb0-bit-reader> jpeg> (>>bitstream)
jpeg>
[ bitstream>> ]
[ [ [ <huffman-decoder> ] with map ] change-huff-tables drop ] bi
jpeg> components>> [ fetch-tables ] each
[ decode-macroblock 2array ] accumulator
[ all-macroblocks ] dip
jpeg> setup-bitmap draw-macroblocks
jpeg> bitmap>> 3 <groups> [ color-transform ] change-each
jpeg> [ >byte-array ] change-bitmap drop ;
ERROR: not-a-jpeg-image ;
PRIVATE> PRIVATE>
: load-jpeg ( path -- image ) : load-jpeg ( path -- image )
binary [ binary [
parse-marker { SOI } assert= parse-marker { SOI } = [ not-a-jpeg-image ] unless
parse-headers parse-headers
contents <loading-jpeg> contents <jpeg-image>
] with-file-reader ] with-file-reader
dup loading-jpeg [ dup jpeg-image [
baseline-parse baseline-parse
baseline-decompress baseline-decompress
jpeg> bitmap>> 3 <groups> [ color-transform ] change-each
jpeg> [ >byte-array ] change-bitmap drop
] with-variable ; ] with-variable ;
M: jpeg-image load-image* ( path jpeg-image -- bitmap ) M: jpeg-image load-image* ( path jpeg-image -- bitmap )
drop load-jpeg ; drop load-jpeg ;

4
basis/images/loader/loader.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2009 Doug Coleman, Daniel Ehrenberg. ! Copyright (C) 2009 Doug Coleman, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: constructors kernel splitting unicode.case combinators USING: kernel splitting unicode.case combinators accessors images
accessors images io.pathnames namespaces assocs ; io.pathnames namespaces assocs ;
IN: images.loader IN: images.loader
ERROR: unknown-image-extension extension ; ERROR: unknown-image-extension extension ;

13
basis/images/png/png.factor
View File

@ -1,10 +1,9 @@
! Copyright (C) 2009 Doug Coleman. ! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors constructors images io io.binary io.encodings.ascii USING: accessors images io io.binary io.encodings.ascii
io.encodings.binary io.encodings.string io.files io.files.info kernel io.encodings.binary io.encodings.string io.files io.files.info kernel
sequences io.streams.limited fry combinators arrays math sequences io.streams.limited fry combinators arrays math checksums
checksums checksums.crc32 compression.inflate grouping byte-arrays checksums.crc32 compression.inflate grouping byte-arrays images.loader ;
images.loader ;
IN: images.png IN: images.png
SINGLETON: png-image SINGLETON: png-image
@ -15,12 +14,14 @@ TUPLE: loading-png
width height bit-depth color-type compression-method width height bit-depth color-type compression-method
filter-method interlace-method uncompressed ; filter-method interlace-method uncompressed ;
CONSTRUCTOR: loading-png ( -- image ) : <loading-png> ( -- image )
loading-png new
V{ } clone >>chunks ; V{ } clone >>chunks ;
TUPLE: png-chunk length type data ; TUPLE: png-chunk length type data ;
CONSTRUCTOR: png-chunk ( -- png-chunk ) ; : <png-chunk> ( -- png-chunk )
png-chunk new ; inline
CONSTANT: png-header CONSTANT: png-header
B{ HEX: 89 HEX: 50 HEX: 4e HEX: 47 HEX: 0d HEX: 0a HEX: 1a HEX: 0a } B{ HEX: 89 HEX: 50 HEX: 4e HEX: 47 HEX: 0d HEX: 0a HEX: 1a HEX: 0a }

21
basis/images/tiff/tiff.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2009 Doug Coleman. ! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs byte-arrays classes combinators USING: accessors arrays assocs byte-arrays classes combinators
compression.lzw constructors endian fry grouping images io compression.lzw endian fry grouping images io
io.binary io.encodings.ascii io.encodings.binary io.binary io.encodings.ascii io.encodings.binary
io.encodings.string io.encodings.utf8 io.files kernel math io.encodings.string io.encodings.utf8 io.files kernel math
math.bitwise math.order math.parser pack prettyprint sequences math.bitwise math.order math.parser pack prettyprint sequences
@ -12,14 +12,27 @@ IN: images.tiff
SINGLETON: tiff-image SINGLETON: tiff-image
TUPLE: loading-tiff endianness the-answer ifd-offset ifds ; TUPLE: loading-tiff endianness the-answer ifd-offset ifds ;
CONSTRUCTOR: loading-tiff ( -- tiff ) V{ } clone >>ifds ;
: <loading-tiff> ( -- tiff )
loading-tiff new V{ } clone >>ifds ;
TUPLE: ifd count ifd-entries next TUPLE: ifd count ifd-entries next
processed-tags strips bitmap ; processed-tags strips bitmap ;
CONSTRUCTOR: ifd ( count ifd-entries next -- ifd ) ;
: <ifd> ( count ifd-entries next -- ifd )
ifd new
swap >>next
swap >>ifd-entries
swap >>count ;
TUPLE: ifd-entry tag type count offset/value ; TUPLE: ifd-entry tag type count offset/value ;
CONSTRUCTOR: ifd-entry ( tag type count offset/value -- ifd-entry ) ;
: <ifd-entry> ( tag type count offset/value -- ifd-entry )
ifd-entry new
swap >>offset/value
swap >>count
swap >>type
swap >>tag ;
SINGLETONS: photometric-interpretation SINGLETONS: photometric-interpretation
photometric-interpretation-white-is-zero photometric-interpretation-white-is-zero

11
basis/io/servers/connection/connection.factor
View File

@ -13,7 +13,8 @@ IN: io.servers.connection
TUPLE: threaded-server TUPLE: threaded-server
name name
log-level log-level
secure insecure secure
insecure
secure-config secure-config
sockets sockets
max-connections max-connections
@ -29,14 +30,14 @@ ready ;
: new-threaded-server ( encoding class -- threaded-server ) : new-threaded-server ( encoding class -- threaded-server )
new new
swap >>encoding
"server" >>name "server" >>name
DEBUG >>log-level DEBUG >>log-level
1 minutes >>timeout
V{ } clone >>sockets
<secure-config> >>secure-config <secure-config> >>secure-config
V{ } clone >>sockets
1 minutes >>timeout
[ "No handler quotation" throw ] >>handler [ "No handler quotation" throw ] >>handler
<flag> >>ready ; inline <flag> >>ready
swap >>encoding ;
: <threaded-server> ( encoding -- threaded-server ) : <threaded-server> ( encoding -- threaded-server )
threaded-server new-threaded-server ; threaded-server new-threaded-server ;

8
basis/math/matrices/matrices.factor Executable file → Normal file
View File

@ -1,7 +1,7 @@
! Copyright (C) 2005, 2009 Slava Pestov. ! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: arrays fry kernel math math.order math.vectors USING: accessors arrays columns kernel math math.bits
sequences sequences.private accessors columns ; math.order math.vectors sequences sequences.private fry ;
IN: math.matrices IN: math.matrices
! Matrices ! Matrices
@ -61,3 +61,7 @@ PRIVATE>
: cross-zip ( seq1 seq2 -- seq1xseq2 ) : cross-zip ( seq1 seq2 -- seq1xseq2 )
[ [ 2array ] with map ] curry map ; [ [ 2array ] with map ] curry map ;
: m^n ( m n -- n )
make-bits over first length identity-matrix
[ [ dupd m. ] when [ dup m. ] dip ] reduce nip ;

3
basis/opengl/textures/textures.factor
View File

@ -135,9 +135,6 @@ TUPLE: multi-texture grid display-list loc disposed ;
[ dup image-locs ] dip [ dup image-locs ] dip
'[ [ _ v+ <single-texture> |dispose ] 2map ] 2map ; '[ [ _ v+ <single-texture> |dispose ] 2map ] 2map ;
: draw-textured-grid ( grid -- )
[ [ [ dim>> ] keep (draw-textured-rect) ] each ] each ;
: grid-has-alpha? ( grid -- ? ) : grid-has-alpha? ( grid -- ? )
first first image>> has-alpha? ; first first image>> has-alpha? ;

2
basis/persistent/vectors/vectors-docs.factor
View File

@ -2,7 +2,7 @@ USING: help.markup help.syntax kernel math sequences ;
IN: persistent.vectors IN: persistent.vectors
HELP: PV{ HELP: PV{
{ $syntax "elements... }" } { $syntax "PV{ elements... }" }
{ $description "Parses a literal " { $link persistent-vector } "." } ; { $description "Parses a literal " { $link persistent-vector } "." } ;
HELP: >persistent-vector HELP: >persistent-vector

51
basis/prettyprint/prettyprint-tests.factor
View File

@ -303,3 +303,54 @@ M: started-out-hustlin' ended-up-ballin' ; inline
[ "USING: prettyprint.tests ;\nM: started-out-hustlin' ended-up-ballin' ; inline\n" ] [ [ "USING: prettyprint.tests ;\nM: started-out-hustlin' ended-up-ballin' ; inline\n" ] [
[ M\ started-out-hustlin' ended-up-ballin' see ] with-string-writer [ M\ started-out-hustlin' ended-up-ballin' see ] with-string-writer
] unit-test ] unit-test
TUPLE: tuple-with-declared-slot { x integer } ;
[
{
"USING: math ;"
"IN: prettyprint.tests"
"TUPLE: tuple-with-declared-slot { x integer initial: 0 } ;"
""
}
] [
[ \ tuple-with-declared-slot see ] with-string-writer "\n" split
] unit-test
TUPLE: tuple-with-read-only-slot { x read-only } ;
[
{
"IN: prettyprint.tests"
"TUPLE: tuple-with-read-only-slot { x read-only } ;"
""
}
] [
[ \ tuple-with-read-only-slot see ] with-string-writer "\n" split
] unit-test
TUPLE: tuple-with-initial-slot { x initial: 123 } ;
[
{
"IN: prettyprint.tests"
"TUPLE: tuple-with-initial-slot { x initial: 123 } ;"
""
}
] [
[ \ tuple-with-initial-slot see ] with-string-writer "\n" split
] unit-test
TUPLE: tuple-with-initial-declared-slot { x integer initial: 123 } ;
[
{
"USING: math ;"
"IN: prettyprint.tests"
"TUPLE: tuple-with-initial-declared-slot"
" { x integer initial: 123 } ;"
""
}
] [
[ \ tuple-with-initial-declared-slot see ] with-string-writer "\n" split
] unit-test

6
basis/see/see.factor
View File

@ -165,12 +165,14 @@ M: array pprint-slot-name
dup name>> , dup name>> ,
dup class>> object eq? [ dup class>> object eq? [
dup class>> , dup class>> ,
initial: ,
dup initial>> ,
] unless ] unless
dup read-only>> [ dup read-only>> [
read-only , read-only ,
] when ] when
dup [ class>> object eq? not ] [ initial>> ] bi or [
initial: ,
dup initial>> ,
] when
drop drop
] { } make ; ] { } make ;

3
basis/ui/baseline-alignment/baseline-alignment.factor
View File

@ -36,9 +36,6 @@ TUPLE: gadget-metrics height ascent descent cap-height ;
: max-descent ( seq -- n ) : max-descent ( seq -- n )
[ descent>> ] map ?supremum ; [ descent>> ] map ?supremum ;
: max-text-height ( seq -- y )
[ ascent>> ] filter [ height>> ] map ?supremum ;
: max-graphics-height ( seq -- y ) : max-graphics-height ( seq -- y )
[ ascent>> not ] filter [ height>> ] map ?supremum 0 or ; [ ascent>> not ] filter [ height>> ] map ?supremum 0 or ;

3
basis/ui/gadgets/gadgets.factor
View File

@ -112,8 +112,7 @@ M: gadget gadget-text-separator
orientation>> vertical = "\n" "" ? ; orientation>> vertical = "\n" "" ? ;
: gadget-seq-text ( seq gadget -- ) : gadget-seq-text ( seq gadget -- )
gadget-text-separator swap gadget-text-separator '[ _ % ] [ gadget-text* ] interleave ;
[ dup % ] [ gadget-text* ] interleave drop ;
M: gadget gadget-text* M: gadget gadget-text*
[ children>> ] keep gadget-seq-text ; [ children>> ] keep gadget-seq-text ;

4
basis/ui/gadgets/panes/panes.factor
View File

@ -96,10 +96,6 @@ M: pane selected-children
add-incremental add-incremental
] [ next-line ] bi ; ] [ next-line ] bi ;
: ?pane-nl ( pane -- )
[ dup current>> children>> empty? [ pane-nl ] [ drop ] if ]
[ pane-nl ] bi ;
: smash-pane ( pane -- gadget ) [ pane-nl ] [ output>> smash-line ] bi ; : smash-pane ( pane -- gadget ) [ pane-nl ] [ output>> smash-line ] bi ;
: pane-write ( seq pane -- ) : pane-write ( seq pane -- )

4
basis/ui/gadgets/sliders/sliders-docs.factor
View File

@ -5,10 +5,6 @@ IN: ui.gadgets.sliders
HELP: elevator HELP: elevator
{ $class-description "An elevator is the part of a " { $link slider } " between the up/down arrow buttons, where a " { $link thumb } " may be moved up and down." } ; { $class-description "An elevator is the part of a " { $link slider } " between the up/down arrow buttons, where a " { $link thumb } " may be moved up and down." } ;
HELP: find-elevator
{ $values { "gadget" gadget } { "elevator/f" { $maybe elevator } } }
{ $description "Finds the first parent of " { $snippet "gadget" } " which is an " { $link elevator } ". Outputs " { $link f } " if the gadget is not contained in an " { $link elevator } "." } ;
HELP: slider HELP: slider
{ $class-description "A slider is a control for graphically manipulating a " { $link "models-range" } "." { $class-description "A slider is a control for graphically manipulating a " { $link "models-range" } "."
$nl $nl

2
basis/ui/gadgets/sliders/sliders.factor
View File

@ -23,8 +23,6 @@ TUPLE: slider < track elevator thumb saved line ;
TUPLE: elevator < gadget direction ; TUPLE: elevator < gadget direction ;
: find-elevator ( gadget -- elevator/f ) [ elevator? ] find-parent ;
: find-slider ( gadget -- slider/f ) [ slider? ] find-parent ; : find-slider ( gadget -- slider/f ) [ slider? ] find-parent ;
CONSTANT: elevator-padding 4 CONSTANT: elevator-padding 4

6
basis/unicode/breaks/breaks.factor
View File

@ -72,9 +72,6 @@ SYMBOL: table
: connect ( class1 class2 -- ) 1 set-table ; : connect ( class1 class2 -- ) 1 set-table ;
: disconnect ( class1 class2 -- ) 0 set-table ; : disconnect ( class1 class2 -- ) 0 set-table ;
: break-around ( classes1 classes2 -- )
[ disconnect ] [ swap disconnect ] 2bi ;
: make-grapheme-table ( -- ) : make-grapheme-table ( -- )
{ CR } { LF } connect { CR } { LF } connect
{ Control CR LF } graphemes disconnect { Control CR LF } graphemes disconnect
@ -91,9 +88,6 @@ VALUE: grapheme-table
: grapheme-break? ( class1 class2 -- ? ) : grapheme-break? ( class1 class2 -- ? )
grapheme-table nth nth not ; grapheme-table nth nth not ;
: chars ( i str n -- str[i] str[i+n] )
swap [ dupd + ] dip [ ?nth ] curry bi@ ;
PRIVATE> PRIVATE>
: first-grapheme ( str -- i ) : first-grapheme ( str -- i )

2
core/classes/tuple/parser/parser-tests.factor
View File

@ -1,7 +1,7 @@
IN: classes.tuple.parser.tests IN: classes.tuple.parser.tests
USING: accessors classes.tuple.parser lexer words classes USING: accessors classes.tuple.parser lexer words classes
sequences math kernel slots tools.test parser compiler.units sequences math kernel slots tools.test parser compiler.units
arrays classes.tuple eval ; arrays classes.tuple eval multiline ;
TUPLE: test-1 ; TUPLE: test-1 ;

20
core/classes/tuple/tuple-tests.factor
View File

@ -1,11 +1,12 @@
USING: definitions generic kernel kernel.private math math.constants USING: accessors arrays assocs calendar classes classes.algebra
parser sequences tools.test words assocs namespaces quotations classes.private classes.tuple classes.tuple.private columns
sequences.private classes continuations generic.single compiler.errors compiler.units continuations definitions
generic.standard effects classes.tuple classes.tuple.private arrays effects eval generic generic.single generic.standard grouping
vectors strings compiler.units accessors classes.algebra calendar io.streams.string kernel kernel.private math math.constants
prettyprint io.streams.string splitting summary columns math.order math.order namespaces parser parser.notes prettyprint
classes.private slots slots.private eval see words.symbol quotations random see sequences sequences.private slots
compiler.errors parser.notes ; slots.private splitting strings summary threads tools.test
vectors vocabs words words.symbol ;
IN: classes.tuple.tests IN: classes.tuple.tests
TUPLE: rect x y w h ; TUPLE: rect x y w h ;
@ -421,7 +422,6 @@ TUPLE: redefinition-problem-2 ;
[ t ] [ 3 redefinition-problem'? ] unit-test [ t ] [ 3 redefinition-problem'? ] unit-test
! Hardcore unit tests ! Hardcore unit tests
USE: threads
\ thread "slots" word-prop "slots" set \ thread "slots" word-prop "slots" set
@ -439,8 +439,6 @@ USE: threads
] with-compilation-unit ] with-compilation-unit
] unit-test ] unit-test
USE: vocabs
\ vocab "slots" word-prop "slots" set \ vocab "slots" word-prop "slots" set
[ ] [ [ ] [

9
core/classes/tuple/tuple.factor
View File

@ -66,7 +66,7 @@ PRIVATE>
GENERIC: slots>tuple ( seq class -- tuple ) GENERIC: slots>tuple ( seq class -- tuple )
M: tuple-class slots>tuple M: tuple-class slots>tuple ( seq class -- tuple )
check-slots pad-slots check-slots pad-slots
tuple-layout <tuple> [ tuple-layout <tuple> [
[ tuple-size ] [ tuple-size ]
@ -147,8 +147,8 @@ ERROR: bad-superclass class ;
dup boa-check-quot "boa-check" set-word-prop ; dup boa-check-quot "boa-check" set-word-prop ;
: tuple-prototype ( class -- prototype ) : tuple-prototype ( class -- prototype )
[ initial-values ] keep [ initial-values ] keep over [ ] any?
over [ ] any? [ slots>tuple ] [ 2drop f ] if ; [ slots>tuple ] [ 2drop f ] if ;
: define-tuple-prototype ( class -- ) : define-tuple-prototype ( class -- )
dup tuple-prototype "prototype" set-word-prop ; dup tuple-prototype "prototype" set-word-prop ;
@ -340,8 +340,7 @@ M: tuple tuple-hashcode
M: tuple hashcode* tuple-hashcode ; M: tuple hashcode* tuple-hashcode ;
M: tuple-class new M: tuple-class new
dup "prototype" word-prop dup "prototype" word-prop [ (clone) ] [ tuple-layout <tuple> ] ?if ;
[ (clone) ] [ tuple-layout <tuple> ] ?if ;
M: tuple-class boa M: tuple-class boa
[ "boa-check" word-prop [ call ] when* ] [ "boa-check" word-prop [ call ] when* ]

6
core/destructors/destructors-docs.factor
View File

@ -8,16 +8,16 @@ HELP: dispose
$nl $nl
"No further operations can be performed on a disposable object after this call." "No further operations can be performed on a disposable object after this call."
$nl $nl
"Disposing an object which has already been disposed should have no effect, and in particular it should not fail with an error. To help implement this pattern, add a " { $snippet "disposed" } " slot to your object and implement the " { $link dispose* } " method instead." } "Disposing an object which has already been disposed should have no effect, and in particular it should not fail with an error. To help implement this pattern, add a " { $slot "disposed" } " slot to your object and implement the " { $link dispose* } " method instead." }
{ $notes "You must close disposable objects after you are finished working with them, to avoid leaking operating system resources. A convenient way to automate this is by using the " { $link with-disposal } " word." { $notes "You must close disposable objects after you are finished working with them, to avoid leaking operating system resources. A convenient way to automate this is by using the " { $link with-disposal } " word."
$nl $nl
"The default implementation assumes the object has a " { $snippet "disposable" } " slot. If the slot is set to " { $link f } ", it calls " { $link dispose* } " and sets the slot to " { $link f } "." } ; "The default implementation assumes the object has a " { $snippet "disposed" } " slot. If the slot is set to " { $link f } ", it calls " { $link dispose* } " and sets the slot to " { $link t } "." } ;
HELP: dispose* HELP: dispose*
{ $values { "disposable" "a disposable object" } } { $values { "disposable" "a disposable object" } }
{ $contract "Releases operating system resources associated with a disposable object. Disposable objects include streams, memory mapped files, and so on." } { $contract "Releases operating system resources associated with a disposable object. Disposable objects include streams, memory mapped files, and so on." }
{ $notes { $notes
"This word should not be called directly. It can be implemented on objects with a " { $snippet "disposable" } " slot to ensure that the object is only disposed once." "This word should not be called directly. It can be implemented on objects with a " { $slot "disposed" } " slot to ensure that the object is only disposed once."
} ; } ;
HELP: with-disposal HELP: with-disposal

4
core/generic/math/math-docs.factor
View File

@ -40,6 +40,4 @@ $nl
HELP: math-generic HELP: math-generic
{ $class-description "The class of generic words using " { $link math-combination } "." } ; { $class-description "The class of generic words using " { $link math-combination } "." } ;
HELP: last/first
{ $values { "seq" sequence } { "pair" "a two-element array" } }
{ $description "Creates an array holding the first and last element of the sequence." } ;

2
core/generic/math/math.factor
View File

@ -15,8 +15,6 @@ PREDICATE: math-class < class
<PRIVATE <PRIVATE
: last/first ( seq -- pair ) [ last ] [ first ] bi 2array ;
: bootstrap-words ( classes -- classes' ) : bootstrap-words ( classes -- classes' )
[ bootstrap-word ] map ; [ bootstrap-word ] map ;

2
core/lexer/lexer-docs.factor
View File

@ -29,7 +29,7 @@ HELP: <lexer-error>
HELP: skip HELP: skip
{ $values { "i" "a starting index" } { "seq" sequence } { "?" "a boolean" } { "n" integer } } { $values { "i" "a starting index" } { "seq" sequence } { "?" "a boolean" } { "n" integer } }
{ $description "Skips to the first space character (if " { $snippet "boolean" } " is " { $link f } ") or the first non-space character (otherwise)." } ; { $description "Skips to the first space character (if " { $snippet "boolean" } " is " { $link f } ") or the first non-space character (otherwise). Tabulations used as separators instead of spaces will be flagged as an error." } ;
HELP: change-lexer-column HELP: change-lexer-column
{ $values { "lexer" lexer } { "quot" { $quotation "( col line -- newcol )" } } } { $values { "lexer" lexer } { "quot" { $quotation "( col line -- newcol )" } } }

12
core/lexer/lexer.factor
View File

@ -22,9 +22,17 @@ TUPLE: lexer text line line-text line-length column ;
: <lexer> ( text -- lexer ) : <lexer> ( text -- lexer )
lexer new-lexer ; lexer new-lexer ;
ERROR: unexpected want got ;
PREDICATE: unexpected-tab < unexpected
got>> CHAR: \t = ;
: forbid-tab ( c -- c )
[ CHAR: \t eq? [ "[space]" "[tab]" unexpected ] when ] keep ;
: skip ( i seq ? -- n ) : skip ( i seq ? -- n )
over length over length
[ [ swap CHAR: \s eq? xor ] curry find-from drop ] dip or ; [ [ swap forbid-tab CHAR: \s eq? xor ] curry find-from drop ] dip or ;
: change-lexer-column ( lexer quot -- ) : change-lexer-column ( lexer quot -- )
[ [ column>> ] [ line-text>> ] bi ] prepose keep [ [ column>> ] [ line-text>> ] bi ] prepose keep
@ -65,8 +73,6 @@ M: lexer skip-word ( lexer -- )
: scan ( -- str/f ) lexer get parse-token ; : scan ( -- str/f ) lexer get parse-token ;
ERROR: unexpected want got ;
PREDICATE: unexpected-eof < unexpected PREDICATE: unexpected-eof < unexpected
got>> not ; got>> not ;

5
core/sequences/sequences-tests.factor
View File

@ -286,3 +286,8 @@ M: bogus-hashcode hashcode* 2drop 0 >bignum ;
[ f f ] [ [ f f ] [
{ 1 2 3 4 5 6 7 8 } [ H{ { 11 "hi" } } at ] map-find { 1 2 3 4 5 6 7 8 } [ H{ { 11 "hi" } } at ] map-find
] unit-test ] unit-test
USE: make
[ { "a" 1 "b" 1 "c" } ]
[ 1 { "a" "b" "c" } [ [ dup , ] [ , ] interleave drop ] { } make ] unit-test

23
core/sequences/sequences.factor
View File

@ -358,8 +358,14 @@ PRIVATE>
<PRIVATE <PRIVATE
: ((each)) ( seq -- n quot )
[ length ] keep [ nth-unsafe ] curry ; inline
: (each) ( seq quot -- n quot' ) : (each) ( seq quot -- n quot' )
[ [ length ] keep [ nth-unsafe ] curry ] dip compose ; inline [ ((each)) ] dip compose ; inline
: (each-index) ( seq quot -- n quot' )
[ ((each)) [ keep ] curry ] dip compose ; inline
: (collect) ( quot into -- quot' ) : (collect) ( quot into -- quot' )
[ [ keep ] dip set-nth-unsafe ] 2curry ; inline [ [ keep ] dip set-nth-unsafe ] 2curry ; inline
@ -498,19 +504,18 @@ PRIVATE>
: follow ( obj quot -- seq ) : follow ( obj quot -- seq )
[ dup ] swap [ keep ] curry produce nip ; inline [ dup ] swap [ keep ] curry produce nip ; inline
: prepare-index ( seq quot -- seq n quot )
[ dup length ] dip ; inline
: each-index ( seq quot -- ) : each-index ( seq quot -- )
prepare-index 2each ; inline (each-index) each-integer ; inline
: interleave ( seq between quot -- ) : interleave ( seq between quot -- )
swap [ drop ] [ [ 2dip call ] 2curry ] 2bi pick empty? [ 3drop ] [
[ [ 0 = ] 2dip if ] 2curry [ [ drop first-unsafe ] dip call ]
each-index ; inline [ [ rest-slice ] 2dip [ bi* ] 2curry each ]
3bi
] if ; inline
: map-index ( seq quot -- newseq ) : map-index ( seq quot -- newseq )
prepare-index 2map ; inline [ dup length iota ] dip 2map ; inline
: reduce-index ( seq identity quot -- ) : reduce-index ( seq identity quot -- )
swapd each-index ; inline swapd each-index ; inline

0
basis/constructors/authors.txt → extra/constructors/authors.txt
View File

0
basis/constructors/constructors-tests.factor → extra/constructors/constructors-tests.factor
View File

0
basis/constructors/constructors.factor → extra/constructors/constructors.factor
View File

0
basis/constructors/summary.txt → extra/constructors/summary.txt
View File

0
basis/constructors/tags.txt → extra/constructors/tags.txt
View File

20
extra/nested-comments/nested-comments.factor Normal file
View File

@ -0,0 +1,20 @@
! by blei on #concatenative
USING: kernel sequences math locals make multiline ;
IN: nested-comments
:: (subsequences-at) ( sseq seq n -- )
sseq seq n start*
[ dup , sseq length + [ sseq seq ] dip (subsequences-at) ]
when* ;
: subsequences-at ( sseq seq -- indices )
[ 0 (subsequences-at) ] { } make ;
: count-subsequences ( sseq seq -- i )
subsequences-at length ;
: parse-all-(* ( parsed-vector left-to-parse -- parsed-vector )
1 - "*)" parse-multiline-string [ "(*" ] dip
count-subsequences + dup 0 > [ parse-all-(* ] [ drop ] if ;
SYNTAX: (* 1 parse-all-(* ;

36
misc/fuel/factor-mode.el
View File

@ -122,26 +122,32 @@ code in the buffer."
(beginning-of-line) (beginning-of-line)
(when (fuel-syntax--at-begin-of-def) 0))) (when (fuel-syntax--at-begin-of-def) 0)))
(defsubst factor-mode--previous-non-empty ()
(forward-line -1)
(while (and (not (bobp))
(fuel-syntax--looking-at-emptiness))
(forward-line -1)))
(defun factor-mode--indent-setter-line () (defun factor-mode--indent-setter-line ()
(when (fuel-syntax--at-setter-line) (when (fuel-syntax--at-setter-line)
(save-excursion (or (save-excursion
(let ((indent (and (fuel-syntax--at-constructor-line) (let ((indent (and (fuel-syntax--at-constructor-line)
(current-indentation)))) (current-indentation))))
(while (not (or indent (while (not (or indent
(bobp) (bobp)
(fuel-syntax--at-begin-of-def) (fuel-syntax--at-begin-of-def)
(fuel-syntax--at-end-of-def))) (fuel-syntax--at-end-of-def)))
(if (fuel-syntax--at-constructor-line) (if (fuel-syntax--at-constructor-line)
(setq indent (fuel-syntax--increased-indentation)) (setq indent (fuel-syntax--increased-indentation))
(forward-line -1))) (forward-line -1)))
indent)))) indent))
(save-excursion
(factor-mode--previous-non-empty)
(current-indentation)))))
(defun factor-mode--indent-continuation () (defun factor-mode--indent-continuation ()
(save-excursion (save-excursion
(forward-line -1) (factor-mode--previous-non-empty)
(while (and (not (bobp))
(fuel-syntax--looking-at-emptiness))
(forward-line -1))
(cond ((or (fuel-syntax--at-end-of-def) (cond ((or (fuel-syntax--at-end-of-def)
(fuel-syntax--at-setter-line)) (fuel-syntax--at-setter-line))
(fuel-syntax--decreased-indentation)) (fuel-syntax--decreased-indentation))