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.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien.accessors assocs byte-arrays combinators
constructors destructors fry io io.binary io.encodings.binary
io.streams.byte-array kernel locals macros math math.ranges
multiline sequences sequences.private vectors byte-vectors
combinators.short-circuit math.bitwise ;
destructors fry io io.binary io.encodings.binary io.streams.byte-array
kernel locals macros math math.ranges multiline sequences
sequences.private vectors byte-vectors combinators.short-circuit
math.bitwise ;
IN: bitstreams
TUPLE: widthed { bits integer read-only } { #bits integer read-only } ;
@ -36,8 +36,12 @@ TUPLE: bit-writer
TUPLE: msb0-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: lsb0-bit-writer < bit-writer ;
@ -56,13 +60,20 @@ TUPLE: lsb0-bit-writer < bit-writer ;
GENERIC: peek ( n bitstream -- value )
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 -- )
{
[ byte-pos>> 8 * ]
[ bit-pos>> + + 8 /mod ]
[ (>>bit-pos) ]
[ (>>byte-pos) ]
} cleave ; inline
[ get-abp + ] [ set-abp ] bi ; inline
: (align) ( n m -- n' )
[ /mod 0 > [ 1+ ] when ] [ * ] bi ; inline
: align ( n bitstream -- )
[ get-abp swap (align) ] [ set-abp ] bi ; inline
: read ( n bitstream -- value )
[ 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
INSN: _spill src class n ;
INSN: _reload dst class n ;
INSN: _copy dst src class ;
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.
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces sequences math math.order kernel assocs
accessors vectors fry heaps cpu.architecture sorting locals
combinators compiler.cfg.registers
compiler.cfg.linear-scan.live-intervals hints ;
USING: accessors assocs heaps kernel namespaces sequences
compiler.cfg.linear-scan.allocation.coalescing
compiler.cfg.linear-scan.allocation.spilling
compiler.cfg.linear-scan.allocation.splitting
compiler.cfg.linear-scan.allocation.state ;
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 -- )
dup coalesce? [ coalesce ] [
dup vreg>> free-registers-for [
@ -286,21 +18,6 @@ SYMBOL: spill-counts
if-empty
] 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 -- )
[
start>>
@ -313,12 +30,10 @@ CONSTANT: reg-classes { int-regs double-float-regs }
unhandled-intervals get [ handle-interval ] slurp-heap ;
: finish-allocation ( -- )
! Sanity check: all live intervals should've been processed
active-intervals inactive-intervals
[ get values [ handled-intervals get push-all ] each ] bi@ ;
: allocate-registers ( live-intervals machine-registers -- live-intervals )
#! This modifies the input live-intervals.
init-allocator
init-unhandled
(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.instructions
compiler.cfg.linear-scan.allocation
compiler.cfg.linear-scan.allocation.state
compiler.cfg.linear-scan.live-intervals ;
IN: compiler.cfg.linear-scan.assignment
! A vector of live intervals. There is linear searching involved
! but since we never have too many machine registers (around 30
! at most) and we probably won't have that many live at any one
! time anyway, it is not a problem to check each element.
TUPLE: active-intervals seq ;
! This contains both active and inactive intervals; any interval
! such that start <= insn# <= end is in this set.
SYMBOL: pending-intervals
: add-active ( live-interval -- )
active-intervals get seq>> push ;
: lookup-register ( vreg -- reg )
active-intervals get seq>> [ vreg>> = ] with find nip reg>> ;
pending-intervals get push ;
! Minheap of live intervals which still need a register allocation
SYMBOL: unhandled-intervals
@ -37,9 +33,11 @@ SYMBOL: spill-slots
: spill-slots-for ( vreg -- assoc )
reg-class>> spill-slots get at ;
ERROR: already-spilled ;
: record-spill ( live-interval -- )
[ 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 -- )
[ reg>> ] [ vreg>> reg-class>> ] [ spill-to>> ] tri _spill ;
@ -47,14 +45,27 @@ SYMBOL: spill-slots
: handle-spill ( live-interval -- )
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 -- )
active-intervals get
[ swap '[ end>> _ = ] partition ] change-seq drop
[ handle-spill ] each ;
[ pending-intervals get ] dip '[
dup end>> _ <
[ [ handle-spill ] [ handle-copy ] bi f ] [ drop t ] if
] filter-here ;
ERROR: already-reloaded ;
: record-reload ( live-interval -- )
[ 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 -- )
[ reg>> ] [ vreg>> reg-class>> ] [ reload-from>> ] tri _reload ;
@ -73,39 +84,40 @@ SYMBOL: spill-slots
] [ 2drop ] 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 )
[ defs-vregs ] [ temp-vregs ] [ uses-vregs ] tri 3append ;
M: vreg-insn assign-before
active-intervals get seq>> over all-vregs '[ vreg>> _ member? ] filter
[ [ vreg>> ] [ reg>> ] bi ] { } map>assoc
: active-intervals ( insn -- intervals )
insn#>> pending-intervals get [ covers? ] with filter ;
M: vreg-insn assign-registers-in-insn
dup [ active-intervals ] [ all-vregs ] bi
'[ vreg>> _ member? ] filter
register-mapping
>>regs drop ;
M: insn assign-before drop ;
: compute-live-registers ( -- regs )
active-intervals get seq>> [ [ vreg>> ] [ reg>> ] bi ] { } map>assoc ;
: compute-live-registers ( insn -- regs )
active-intervals register-mapping ;
: compute-live-spill-slots ( -- spill-slots )
spill-slots get values [ values ] map concat
[ [ vreg>> ] [ reload-from>> ] bi ] { } map>assoc ;
M: ##gc assign-after
compute-live-registers >>live-registers
M: ##gc assign-registers-in-insn
dup call-next-method
dup compute-live-registers >>live-registers
compute-live-spill-slots >>live-spill-slots
drop ;
M: insn assign-after drop ;
: <active-intervals> ( -- obj )
V{ } clone active-intervals boa ;
M: insn assign-registers-in-insn drop ;
: init-assignment ( live-intervals -- )
<active-intervals> active-intervals set
V{ } clone pending-intervals set
<min-heap> unhandled-intervals set
[ H{ } clone ] reg-class-assoc spill-slots set
init-unhandled ;
@ -114,13 +126,15 @@ M: insn assign-after drop ;
[
[
[
{
[ insn#>> activate-new-intervals ]
[ assign-before ]
[ , ]
[ insn#>> expire-old-intervals ]
[ assign-after ]
} cleave
[
insn#>>
[ expire-old-intervals ]
[ activate-new-intervals ]
bi
]
[ assign-registers-in-insn ]
[ , ]
tri
] each
] V{ } make
] change-instructions drop ;

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

@ -1,17 +1,26 @@
IN: compiler.cfg.linear-scan.tests
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
cpu.architecture
compiler.cfg
compiler.cfg.optimizer
compiler.cfg.instructions
compiler.cfg.registers
compiler.cfg.liveness
compiler.cfg.predecessors
compiler.cfg.rpo
compiler.cfg.linear-scan
compiler.cfg.linear-scan.live-intervals
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 ;
check-allocation? on
[
{ T{ live-range f 1 10 } T{ live-range f 15 15 } }
{ T{ live-range f 16 20 } }
@ -53,11 +62,8 @@ compiler.cfg.linear-scan.debugger ;
] unit-test
[
{ }
{ T{ live-range f 1 10 } }
] [
{ T{ live-range f 1 10 } } 0 split-ranges
] unit-test
] must-fail
[
{ T{ live-range f 0 0 } }
@ -118,32 +124,57 @@ compiler.cfg.linear-scan.debugger ;
{ end 5 }
{ uses V{ 0 1 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
[
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 } } }
{ end 4 }
{ uses V{ 0 1 4 } }
{ ranges V{ T{ live-range f 0 4 } } }
}
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
{ start 1 }
{ start 5 }
{ end 5 }
{ uses V{ 1 5 } }
{ ranges V{ T{ live-range f 1 5 } } }
{ uses V{ 5 } }
{ ranges V{ T{ live-range f 5 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-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 } } }
} 5 split-before-use [ f >>split-next ] bi@
] unit-test
[
@ -1294,26 +1325,32 @@ USING: math.private compiler.cfg.debugger ;
! Spill slot liveness was computed incorrectly, leading to a FEP
! early in bootstrap on x86-32
[ t ] [
T{ basic-block
{ instructions
V{
T{ ##gc f V int-regs 6 V int-regs 7 }
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 4 }
T{ ##peek f V int-regs 5 D 5 }
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 }
T{ ##replace f V int-regs 3 D 4 }
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?
[
H{ } clone live-ins set
H{ } clone live-outs set
H{ } clone phi-live-ins set
T{ basic-block
{ id 12345 }
{ instructions
V{
T{ ##gc f V int-regs 6 V int-regs 7 }
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 4 }
T{ ##peek f V int-regs 5 D 5 }
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 }
T{ ##replace f V int-regs 3 D 4 }
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
[ f ] [
@ -1373,5 +1410,394 @@ USING: math.private compiler.cfg.debugger ;
{ uses { 5 10 } }
{ ranges V{ T{ live-range f 5 10 } } }
}
H{ }
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.live-intervals
compiler.cfg.linear-scan.allocation
compiler.cfg.linear-scan.allocation.state
compiler.cfg.linear-scan.assignment ;
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.
! See http://factorcode.org/license.txt for BSD license.
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 ;
IN: compiler.cfg.linear-scan.live-intervals
@ -11,10 +11,21 @@ C: <live-range> live-range
TUPLE: live-interval
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
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 ;
: shorten-range ( n live-interval -- )
@ -46,11 +57,9 @@ ERROR: dead-value-error vreg ;
V{ } clone >>ranges
swap >>vreg ;
: block-from ( -- n )
basic-block get instructions>> first insn#>> ;
: block-from ( bb -- n ) instructions>> first insn#>> ;
: block-to ( -- n )
basic-block get instructions>> last insn#>> ;
: block-to ( bb -- n ) instructions>> last insn#>> ;
M: live-interval hashcode*
nip [ start>> ] [ end>> 1000 * ] bi + ;
@ -74,7 +83,7 @@ M: insn compute-live-intervals* drop ;
: handle-input ( n vreg live-intervals -- )
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 -- )
live-interval
@ -98,7 +107,9 @@ M: ##copy-float compute-live-intervals*
[ call-next-method ] [ record-copy ] bi ;
: 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
] each ;
@ -109,17 +120,23 @@ M: ##copy-float compute-live-intervals*
: compute-start/end ( live-interval -- )
dup ranges>> [ first from>> ] [ last to>> ] bi
2dup > [ "BUG: start > end" throw ] when
[ >>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 -- )
! Since live intervals are computed in a backward order, we have
! to reverse some sequences, and compute the start and end.
[
[ ranges>> reverse-here ]
[ uses>> reverse-here ]
[ compute-start/end ]
tri
{
[ ranges>> reverse-here ]
[ uses>> reverse-here ]
[ compute-start/end ]
[ check-start/end ]
} cleave
] each ;
: 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 ;
: 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
compiler.cfg.checker compiler.cfg.height compiler.cfg.rpo
compiler.cfg.dce compiler.cfg.registers compiler.cfg.useless-blocks
sets ;
sets namespaces ;
IN: compiler.cfg.stack-analysis.tests
! 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 )
flatten-cfg instructions>> ;
local-only? off
[ ] [ [ ] test-stack-analysis drop ] unit-test
! Only peek once

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

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

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

@ -288,4 +288,26 @@ M: cucumber equal? "The cucumber has no equal" throw ;
-1 <int> -1 <int>
[ [ 0 alien-unsigned-cell swap ] [ 0 alien-signed-2 ] bi ]
compile-call
] 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

2
basis/compiler/tree/escape-analysis/escape-analysis-tests.factor
View File

@ -327,4 +327,4 @@ C: <ro-box> ro-box
TUPLE: empty-tuple ;
[ ] [ [ empty-tuple boa layout-of ] count-unboxed-allocations drop ] unit-test
[ ] [ [ empty-tuple boa layout-of ] count-unboxed-allocations drop ] unit-test

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

@ -1,6 +1,6 @@
! Copyright (C) 2009 Marc Fauconneau.
! 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
math.ranges multiline sequences ;
IN: compression.huffman
@ -58,7 +58,10 @@ TUPLE: huffman-decoder
{ rtable }
{ bits/level } ;
CONSTRUCTOR: huffman-decoder ( bs tdesc -- decoder )
: <huffman-decoder> ( bs tdesc -- decoder )
huffman-decoder new
swap >>tdesc
swap >>bs
16 >>bits/level
[ ] [ tdesc>> ] [ bits/level>> 2^ ] tri reverse-table >>rtable ;

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

@ -1,212 +1,220 @@
! Copyright (C) 2009 Marc Fauconneau.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs byte-arrays
byte-vectors combinators constructors fry grouping hashtables
compression.huffman images io.binary kernel locals
math math.bitwise math.order math.ranges multiline sequences
sorting ;
IN: compression.inflate
QUALIFIED-WITH: bitstreams bs
<PRIVATE
: enum>seq ( assoc -- seq )
dup keys [ ] [ max ] map-reduce 1 + f <array>
[ '[ swap _ set-nth ] assoc-each ] keep ;
ERROR: zlib-unimplemented ;
ERROR: bad-zlib-data ;
ERROR: bad-zlib-header ;
:: check-zlib-header ( data -- )
16 data bs:peek 2 >le be> 31 mod ! checksum
0 assert=
4 data bs:read 8 assert= ! compression method: deflate
4 data bs:read ! log2(max length)-8, 32K max
7 <= [ bad-zlib-header ] unless
5 data bs:seek ! drop check bits
1 data bs:read 0 assert= ! dictionnary - not allowed in png
2 data bs:seek ! compression level; ignore
;
:: default-table ( -- table )
0 <hashtable> :> table
0 143 [a,b] 280 287 [a,b] append 8 table set-at
144 255 [a,b] >array 9 table set-at
256 279 [a,b] >array 7 table set-at
table enum>seq 1 tail ;
CONSTANT: clen-shuffle { 16 17 18 0 8 7 9 6 10 5 11 4 12 3 13 2 14 1 15 }
: get-table ( values size -- table )
16 f <array> clone <enum>
[ '[ _ push-at ] 2each ] keep seq>> 1 tail [ natural-sort ] map ;
:: decode-huffman-tables ( bitstream -- tables )
5 bitstream bs:read 257 +
5 bitstream bs:read 1 +
4 bitstream bs:read 4 +
clen-shuffle swap head
dup [ drop 3 bitstream bs:read ] map
get-table
bitstream swap <huffman-decoder>
[ 2dup + ] dip swap :> k!
'[
_ read1-huff2
{
{ [ dup 16 = ] [ 2 bitstream bs:read 3 + 2array ] }
{ [ dup 17 = ] [ 3 bitstream bs:read 3 + 2array ] }
{ [ dup 18 = ] [ 7 bitstream bs:read 11 + 2array ] }
[ ]
} cond
dup array? [ dup second ] [ 1 ] if
k swap - dup k! 0 >
]
[ ] produce swap suffix
{ } [ dup array? [ dup first 16 = ] [ f ] if [ [ unclip-last ] [ second 1+ swap <repetition> append ] bi* ] [ suffix ] if ] reduce
[ dup array? [ second 0 <repetition> ] [ 1array ] if ] map concat
nip swap cut 2array [ [ length>> [0,b) ] [ ] bi get-table ] map ;
CONSTANT: length-table
{
3 4 5 6 7 8 9 10
11 13 15 17
19 23 27 31
35 43 51 59
67 83 99 115
131 163 195 227 258
}
CONSTANT: dist-table
{
1 2 3 4
5 7 9 13
17 25 33 49
65 97 129 193
257 385 513 769
1025 1537 2049 3073
4097 6145 8193 12289
16385 24577
}
: nth* ( n seq -- elt )
[ length 1- swap - ] [ nth ] bi ;
:: inflate-lz77 ( seq -- bytes )
1000 <byte-vector> :> bytes
seq
[
dup array?
[ first2 '[ _ 1- bytes nth* bytes push ] times ]
[ bytes push ] if
] each
bytes ;
:: inflate-dynamic ( bitstream -- bytes )
bitstream decode-huffman-tables
bitstream '[ _ swap <huffman-decoder> ] map :> tables
[
tables first read1-huff2
dup 256 >
[
dup 285 =
[ ]
[
dup 264 >
[
dup 261 - 4 /i dup 5 >
[ bad-zlib-data ] when
bitstream bs:read 2array
]
when
] if
! 5 bitstream read-bits ! distance
tables second read1-huff2
dup 3 >
[
dup 2 - 2 /i dup 13 >
[ bad-zlib-data ] when
bitstream bs:read 2array
]
when
2array
]
when
dup 256 = not
]
[ ] produce nip
[
dup array? [
first2
[
dup array? [ first2 ] [ 0 ] if
[ 257 - length-table nth ] [ + ] bi*
]
[
dup array? [ first2 ] [ 0 ] if
[ dist-table nth ] [ + ] bi*
] bi*
2array
] when
] map ;
: inflate-raw ( bitstream -- bytes ) zlib-unimplemented ;
: inflate-static ( bitstream -- bytes ) zlib-unimplemented ;
:: inflate-loop ( bitstream -- bytes )
[ 1 bitstream bs:read 0 = ]
[
bitstream
2 bitstream bs:read
{
{ 0 [ inflate-raw ] }
{ 1 [ inflate-static ] }
{ 2 [ inflate-dynamic ] }
{ 3 [ bad-zlib-data f ] }
}
case
]
[ produce ] keep call suffix concat ;
! [ produce ] keep dip swap suffix
:: paeth ( a b c -- p )
a b + c - { a b c } [ [ - abs ] keep 2array ] with map
sort-keys first second ;
:: png-unfilter-line ( prev curr filter -- curr' )
prev :> c
prev 3 tail-slice :> b
curr :> a
curr 3 tail-slice :> x
x length [0,b)
filter
{
{ 0 [ drop ] }
{ 1 [ [| n | n x nth n a nth + 256 wrap n x set-nth ] each ] }
{ 2 [ [| n | n x nth n b nth + 256 wrap n x set-nth ] each ] }
{ 3 [ [| n | n x nth n a nth n b nth + 2/ + 256 wrap n x set-nth ] each ] }
{ 4 [ [| n | n x nth n a nth n b nth n c nth paeth + 256 wrap n x set-nth ] each ] }
} case
curr 3 tail ;
PRIVATE>
! for debug -- shows residual values
: reverse-png-filter' ( lines -- byte-array )
[ first ] [ 1 tail ] [ map ] bi-curry@ bi nip
concat [ 128 + ] B{ } map-as ;
: reverse-png-filter ( lines -- byte-array )
dup first [ 0 ] replicate prefix
[ { 0 0 } prepend ] map
2 clump [
first2 dup [ third ] [ 0 2 rot set-nth ] bi png-unfilter-line
] map B{ } concat-as ;
: zlib-inflate ( bytes -- bytes )
bs:<lsb0-bit-reader>
[ check-zlib-header ] [ inflate-loop ] bi
inflate-lz77 ;
! Copyright (C) 2009 Marc Fauconneau.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs byte-arrays
byte-vectors combinators fry grouping hashtables
compression.huffman images io.binary kernel locals
math math.bitwise math.order math.ranges multiline sequences
sorting ;
IN: compression.inflate
QUALIFIED-WITH: bitstreams bs
<PRIVATE
: enum>seq ( assoc -- seq )
dup keys [ ] [ max ] map-reduce 1 + f <array>
[ '[ swap _ set-nth ] assoc-each ] keep ;
ERROR: zlib-unimplemented ;
ERROR: bad-zlib-data ;
ERROR: bad-zlib-header ;
:: check-zlib-header ( data -- )
16 data bs:peek 2 >le be> 31 mod ! checksum
0 assert=
4 data bs:read 8 assert= ! compression method: deflate
4 data bs:read ! log2(max length)-8, 32K max
7 <= [ bad-zlib-header ] unless
5 data bs:seek ! drop check bits
1 data bs:read 0 assert= ! dictionnary - not allowed in png
2 data bs:seek ! compression level; ignore
;
:: default-table ( -- table )
0 <hashtable> :> table
0 143 [a,b] 280 287 [a,b] append 8 table set-at
144 255 [a,b] >array 9 table set-at
256 279 [a,b] >array 7 table set-at
table enum>seq 1 tail ;
CONSTANT: clen-shuffle { 16 17 18 0 8 7 9 6 10 5 11 4 12 3 13 2 14 1 15 }
: get-table ( values size -- table )
16 f <array> clone <enum>
[ '[ _ push-at ] 2each ] keep seq>> 1 tail [ natural-sort ] map ;
:: decode-huffman-tables ( bitstream -- tables )
5 bitstream bs:read 257 +
5 bitstream bs:read 1 +
4 bitstream bs:read 4 +
clen-shuffle swap head
dup [ drop 3 bitstream bs:read ] map
get-table
bitstream swap <huffman-decoder>
[ 2dup + ] dip swap :> k!
'[
_ read1-huff2
{
{ [ dup 16 = ] [ 2 bitstream bs:read 3 + 2array ] }
{ [ dup 17 = ] [ 3 bitstream bs:read 3 + 2array ] }
{ [ dup 18 = ] [ 7 bitstream bs:read 11 + 2array ] }
[ ]
} cond
dup array? [ dup second ] [ 1 ] if
k swap - dup k! 0 >
]
[ ] produce swap suffix
{ } [ dup array? [ dup first 16 = ] [ f ] if [ [ unclip-last ] [ second 1+ swap <repetition> append ] bi* ] [ suffix ] if ] reduce
[ dup array? [ second 0 <repetition> ] [ 1array ] if ] map concat
nip swap cut 2array [ [ length>> [0,b) ] [ ] bi get-table ] map ;
CONSTANT: length-table
{
3 4 5 6 7 8 9 10
11 13 15 17
19 23 27 31
35 43 51 59
67 83 99 115
131 163 195 227 258
}
CONSTANT: dist-table
{
1 2 3 4
5 7 9 13
17 25 33 49
65 97 129 193
257 385 513 769
1025 1537 2049 3073
4097 6145 8193 12289
16385 24577
}
: nth* ( n seq -- elt )
[ length 1- swap - ] [ nth ] bi ;
:: inflate-lz77 ( seq -- bytes )
1000 <byte-vector> :> bytes
seq
[
dup array?
[ first2 '[ _ 1- bytes nth* bytes push ] times ]
[ bytes push ] if
] each
bytes ;
:: inflate-dynamic ( bitstream -- bytes )
bitstream decode-huffman-tables
bitstream '[ _ swap <huffman-decoder> ] map :> tables
[
tables first read1-huff2
dup 256 >
[
dup 285 =
[ ]
[
dup 264 >
[
dup 261 - 4 /i dup 5 >
[ bad-zlib-data ] when
bitstream bs:read 2array
]
when
] if
! 5 bitstream read-bits ! distance
tables second read1-huff2
dup 3 >
[
dup 2 - 2 /i dup 13 >
[ bad-zlib-data ] when
bitstream bs:read 2array
]
when
2array
]
when
dup 256 = not
]
[ ] produce nip
[
dup array? [
first2
[
dup array? [ first2 ] [ 0 ] if
[ 257 - length-table nth ] [ + ] bi*
]
[
dup array? [ first2 ] [ 0 ] if
[ dist-table nth ] [ + ] bi*
] bi*
2array
] when
] map ;
:: 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-loop ( bitstream -- bytes )
[ 1 bitstream bs:read 0 = ]
[
bitstream
2 bitstream bs:read
{
{ 0 [ inflate-raw ] }
{ 1 [ inflate-static ] }
{ 2 [ inflate-dynamic ] }
{ 3 [ bad-zlib-data f ] }
}
case
]
[ produce ] keep call suffix concat ;
! [ produce ] keep dip swap suffix
:: paeth ( a b c -- p )
a b + c - { a b c } [ [ - abs ] keep 2array ] with map
sort-keys first second ;
:: png-unfilter-line ( prev curr filter -- curr' )
prev :> c
prev 3 tail-slice :> b
curr :> a
curr 3 tail-slice :> x
x length [0,b)
filter
{
{ 0 [ drop ] }
{ 1 [ [| n | n x nth n a nth + 256 wrap n x set-nth ] each ] }
{ 2 [ [| n | n x nth n b nth + 256 wrap n x set-nth ] each ] }
{ 3 [ [| n | n x nth n a nth n b nth + 2/ + 256 wrap n x set-nth ] each ] }
{ 4 [ [| n | n x nth n a nth n b nth n c nth paeth + 256 wrap n x set-nth ] each ] }
} case
curr 3 tail ;
PRIVATE>
: reverse-png-filter' ( lines -- byte-array )
[ first ] [ 1 tail ] [ map ] bi-curry@ bi nip
concat [ 128 + ] B{ } map-as ;
: reverse-png-filter ( lines -- byte-array )
dup first [ 0 ] replicate prefix
[ { 0 0 } prepend ] map
2 clump [
first2 dup [ third ] [ 0 2 rot set-nth ] bi png-unfilter-line
] map B{ } concat-as ;
: zlib-inflate ( bytes -- bytes )
bs:<lsb0-bit-reader>
[ check-zlib-header ] [ inflate-loop ] bi
inflate-lz77 ;

2
basis/functors/functors.factor
View File

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

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

@ -1,14 +1,13 @@
USING: windows.dinput windows.dinput.constants parser
alien.c-types windows.ole32 namespaces assocs kernel arrays
vectors windows.kernel32 windows.com windows.dinput shuffle
windows.user32 windows.messages sequences combinators locals
math.rectangles accessors math alien alien.strings
io.encodings.utf16 io.encodings.utf16n continuations
byte-arrays game-input.dinput.keys-array game-input
ui.backend.windows windows.errors struct-arrays
math.bitwise ;
USING: accessors alien alien.c-types alien.strings arrays
assocs byte-arrays combinators continuations game-input
game-input.dinput.keys-array io.encodings.utf16
io.encodings.utf16n kernel locals math math.bitwise
math.rectangles namespaces parser sequences shuffle
struct-arrays ui.backend.windows vectors windows.com
windows.dinput windows.dinput.constants windows.errors
windows.kernel32 windows.messages windows.ole32
windows.user32 ;
IN: game-input.dinput
CONSTANT: MOUSE-BUFFER-SIZE 16
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-unsafe ; inline
: up-value ( n heap -- entry )
[ up ] dip data-nth ; inline
: left-value ( n heap -- entry )
[ left ] dip data-nth ; inline
@ -75,9 +72,6 @@ M: heap heap-size ( heap -- n )
: data-pop* ( heap -- )
data>> pop* ; inline
: data-peek ( heap -- entry )
data>> last ; inline
: data-first ( heap -- entry )
data>> first ; inline
@ -130,9 +124,6 @@ DEFER: up-heap
2dup right-bounds-check?
[ drop left ] [ (child) ] if ;
: swap-down ( m heap -- )
[ child ] 2keep data-exchange ;
DEFER: down-heap
: (down-heap) ( m heap -- )

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

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

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

@ -1,306 +1,368 @@
! Copyright (C) 2009 Marc Fauconneau.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays byte-arrays combinators
constructors grouping compression.huffman images
images.processing io io.binary io.encodings.binary io.files
io.streams.byte-array kernel locals math math.bitwise
math.constants math.functions math.matrices math.order
math.ranges math.vectors memoize multiline namespaces
sequences sequences.deep images.loader ;
QUALIFIED-WITH: bitstreams bs
IN: images.jpeg
SINGLETON: jpeg-image
{ "jpg" "jpeg" } [ jpeg-image register-image-class ] each
TUPLE: loading-jpeg < image
{ headers }
{ bitstream }
{ color-info initial: { f f f f } }
{ quant-tables initial: { f f } }
{ huff-tables initial: { f f f f } }
{ components } ;
<PRIVATE
CONSTRUCTOR: loading-jpeg ( headers bitstream -- image ) ;
SINGLETONS: SOF DHT DAC RST SOI EOI SOS DQT DNL DRI DHP EXP
APP JPG COM TEM RES ;
! ISO/IEC 10918-1 Table B.1
:: >marker ( byte -- marker )
byte
{
{ [ dup HEX: CC = ] [ { DAC } ] }
{ [ dup HEX: C4 = ] [ { DHT } ] }
{ [ dup HEX: C9 = ] [ { JPG } ] }
{ [ dup -4 shift HEX: C = ] [ SOF byte 4 bits 2array ] }
{ [ dup HEX: D8 = ] [ { SOI } ] }
{ [ dup HEX: D9 = ] [ { EOI } ] }
{ [ dup HEX: DA = ] [ { SOS } ] }
{ [ dup HEX: DB = ] [ { DQT } ] }
{ [ dup HEX: DC = ] [ { DNL } ] }
{ [ dup HEX: DD = ] [ { DRI } ] }
{ [ dup HEX: DE = ] [ { DHP } ] }
{ [ dup HEX: DF = ] [ { EXP } ] }
{ [ dup -4 shift HEX: D = ] [ RST byte 4 bits 2array ] }
{ [ dup -4 shift HEX: E = ] [ APP byte 4 bits 2array ] }
{ [ dup HEX: FE = ] [ { COM } ] }
{ [ dup -4 shift HEX: F = ] [ JPG byte 4 bits 2array ] }
{ [ dup HEX: 01 = ] [ { TEM } ] }
[ { RES } ]
}
cond nip ;
TUPLE: jpeg-chunk length type data ;
CONSTRUCTOR: jpeg-chunk ( type length data -- jpeg-chunk ) ;
TUPLE: jpeg-color-info
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> ( -- jpeg-image ) loading-jpeg get ;
: apply-diff ( dc color -- dc' )
[ diff>> + dup ] [ (>>diff) ] bi ;
: fetch-tables ( component -- )
[ [ jpeg> quant-tables>> nth ] change-quant-table drop ]
[ [ jpeg> huff-tables>> nth ] change-dc-huff-table drop ]
[ [ 2 + jpeg> huff-tables>> nth ] change-ac-huff-table drop ] tri ;
: read4/4 ( -- a b ) read1 16 /mod ;
! headers
: decode-frame ( header -- )
data>>
binary
[
read1 8 assert=
2 read be>
2 read be>
swap 2array jpeg> (>>dim)
read1
[
read1 read4/4 read1 <jpeg-color-info>
swap [ >>id ] keep jpeg> color-info>> set-nth
] times
] with-byte-reader ;
: decode-quant-table ( chunk -- )
dup data>>
binary
[
length>>
2 - 65 /
[
read4/4 [ 0 assert= ] dip
64 read
swap jpeg> quant-tables>> set-nth
] times
] with-byte-reader ;
: decode-huff-table ( chunk -- )
data>>
binary
[
1 ! %fixme: Should handle multiple tables at once
[
read4/4 swap 2 * +
16 read
dup [ ] [ + ] map-reduce read
binary [ [ read [ B{ } ] unless* ] { } map-as ] with-byte-reader
swap jpeg> huff-tables>> set-nth
] times
] with-byte-reader ;
: decode-scan ( chunk -- )
data>>
binary
[
read1 [0,b)
[ drop
read1 jpeg> color-info>> nth clone
read1 16 /mod [ >>dc-huff-table ] [ >>ac-huff-table ] bi*
] map jpeg> (>>components)
read1 0 assert=
read1 63 assert=
read1 16 /mod [ 0 assert= ] bi@
] with-byte-reader ;
: singleton-first ( seq -- elt )
[ length 1 assert= ] [ first ] bi ;
: baseline-parse ( -- )
jpeg> headers>>
{
[ [ type>> { SOF 0 } = ] filter singleton-first decode-frame ]
[ [ type>> { DQT } = ] filter [ decode-quant-table ] each ]
[ [ type>> { DHT } = ] filter [ decode-huff-table ] each ]
[ [ type>> { SOS } = ] filter singleton-first decode-scan ]
} cleave ;
: parse-marker ( -- marker )
read1 HEX: FF assert=
read1 >marker ;
: parse-headers ( -- chunks )
[ parse-marker dup { SOS } = not ]
[
2 read be>
dup 2 - read <jpeg-chunk>
] [ produce ] keep dip swap suffix ;
MEMO: zig-zag ( -- zz )
{
{ 0 1 5 6 14 15 27 28 }
{ 2 4 7 13 16 26 29 42 }
{ 3 8 12 17 25 30 41 43 }
{ 9 11 18 24 31 40 44 53 }
{ 10 19 23 32 39 45 52 54 }
{ 20 22 33 38 46 51 55 60 }
{ 21 34 37 47 50 56 59 61 }
{ 35 36 48 49 57 58 62 63 }
} flatten ;
MEMO: yuv>bgr-matrix ( -- m )
{
{ 1 2.03211 0 }
{ 1 -0.39465 -0.58060 }
{ 1 0 1.13983 }
} ;
: wave ( x u -- n ) swap 2 * 1 + * pi * 16 / cos ;
:: dct-vect ( u v -- basis )
{ 8 8 } coord-matrix [ { u v } [ wave ] 2map product ] map^2
1 u v [ 0 = [ 2 sqrt / ] when ] bi@ 4 / m*n ;
MEMO: dct-matrix ( -- m ) 64 [0,b) [ 8 /mod dct-vect flatten ] map ;
: mb-dim ( component -- dim ) [ h>> ] [ v>> ] bi 2array ;
: all-macroblocks ( quot: ( mb -- ) -- )
[
jpeg>
[ dim>> 8 v/n ]
[ color-info>> sift { 0 0 } [ mb-dim vmax ] reduce v/ ] bi
[ ceiling ] map
coord-matrix flip concat
]
[ each ] bi* ; inline
: reverse-zigzag ( b -- b' ) zig-zag swap [ nth ] curry map ;
: idct-factor ( b -- b' ) dct-matrix v.m ;
USE: math.blas.vectors
USE: math.blas.matrices
MEMO: dct-matrix-blas ( -- m ) dct-matrix >float-blas-matrix ;
: V.M ( x A -- x.A ) Mtranspose swap M.V ;
: idct-blas ( b -- b' ) >float-blas-vector dct-matrix-blas V.M ;
: idct ( b -- b' ) idct-blas ;
:: draw-block ( block x,y color jpeg-image -- )
block dup length>> sqrt >fixnum group flip
dup matrix-dim coord-matrix flip
[
[ first2 spin nth nth ]
[ x,y v+ color id>> 1- jpeg-image draw-color ] bi
] with each^2 ;
: sign-extend ( bits v -- v' )
swap [ ] [ 1- 2^ < ] 2bi
[ -1 swap shift 1+ + ] [ drop ] if ;
: read1-jpeg-dc ( decoder -- dc )
[ read1-huff dup ] [ bs>> bs:read ] bi sign-extend ;
: read1-jpeg-ac ( decoder -- run/ac )
[ read1-huff 16 /mod dup ] [ bs>> bs:read ] bi sign-extend 2array ;
:: decode-block ( pos color -- )
color dc-huff-table>> read1-jpeg-dc color apply-diff
64 0 <array> :> coefs
0 coefs set-nth
0 :> k!
[
color ac-huff-table>> read1-jpeg-ac
[ first 1+ k + k! ] [ second k coefs set-nth ] [ ] tri
{ 0 0 } = not
k 63 < and
] loop
coefs color quant-table>> v*
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 -- )
jpeg> components>>
[
[ mb-dim coord-matrix flip concat [ [ { 2 2 } v* ] [ v+ ] bi* ] with map ]
[ [ decode-block ] curry each ] bi
] with each ;
: cleanup-bitstream ( bytes -- bytes' )
binary [
[
{ HEX: FF } read-until
read1 tuck HEX: 00 = and
]
[ drop ] produce
swap >marker { EOI } assert=
swap suffix
{ HEX: FF } join
] with-byte-reader ;
: setup-bitmap ( image -- )
dup dim>> 16 v/n [ ceiling ] map 16 v*n >>dim
BGR >>component-order
f >>upside-down?
dup dim>> first2 * 3 * 0 <array> >>bitmap
drop ;
: 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
jpeg> setup-bitmap
[ decode-macroblock ] all-macroblocks ;
! this eats ~25% cpu time
: color-transform ( yuv -- rgb )
{ 128 0 0 } v+ yuv>bgr-matrix swap m.v
[ 0 max 255 min >fixnum ] map ;
PRIVATE>
: load-jpeg ( path -- image )
binary [
parse-marker { SOI } assert=
parse-headers
contents <loading-jpeg>
] with-file-reader
dup loading-jpeg [
baseline-parse
baseline-decompress
jpeg> bitmap>> 3 <groups> [ color-transform ] change-each
jpeg> [ >byte-array ] change-bitmap drop
] with-variable ;
M: jpeg-image load-image* ( path jpeg-image -- bitmap )
drop load-jpeg ;
! Copyright (C) 2009 Marc Fauconneau.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays byte-arrays combinators
grouping compression.huffman images
images.processing io io.binary io.encodings.binary io.files
io.streams.byte-array kernel locals math math.bitwise
math.constants math.functions math.matrices math.order
math.ranges math.vectors memoize multiline namespaces
sequences sequences.deep ;
IN: images.jpeg
QUALIFIED-WITH: bitstreams bs
TUPLE: jpeg-image < image
{ headers }
{ bitstream }
{ color-info initial: { f f f f } }
{ quant-tables initial: { f f } }
{ huff-tables initial: { f f f f } }
{ components } ;
<PRIVATE
: <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
APP JPG COM TEM RES ;
! ISO/IEC 10918-1 Table B.1
:: >marker ( byte -- marker )
byte
{
{ [ dup HEX: CC = ] [ { DAC } ] }
{ [ dup HEX: C4 = ] [ { DHT } ] }
{ [ dup HEX: C9 = ] [ { JPG } ] }
{ [ dup -4 shift HEX: C = ] [ SOF byte 4 bits 2array ] }
{ [ dup HEX: D8 = ] [ { SOI } ] }
{ [ dup HEX: D9 = ] [ { EOI } ] }
{ [ dup HEX: DA = ] [ { SOS } ] }
{ [ dup HEX: DB = ] [ { DQT } ] }
{ [ dup HEX: DC = ] [ { DNL } ] }
{ [ dup HEX: DD = ] [ { DRI } ] }
{ [ dup HEX: DE = ] [ { DHP } ] }
{ [ dup HEX: DF = ] [ { EXP } ] }
{ [ dup -4 shift HEX: D = ] [ RST byte 4 bits 2array ] }
{ [ dup -4 shift HEX: E = ] [ APP byte 4 bits 2array ] }
{ [ dup HEX: FE = ] [ { COM } ] }
{ [ dup -4 shift HEX: F = ] [ JPG byte 4 bits 2array ] }
{ [ dup HEX: 01 = ] [ { TEM } ] }
[ { RES } ]
}
cond nip ;
TUPLE: jpeg-chunk length type data ;
: <jpeg-chunk> ( type length data -- jpeg-chunk )
jpeg-chunk new
swap >>data
swap >>length
swap >>type ;
TUPLE: jpeg-color-info
h v quant-table dc-huff-table ac-huff-table { diff initial: 0 } id ;
: <jpeg-color-info> ( h v quant-table -- jpeg-color-info )
jpeg-color-info new
swap >>quant-table
swap >>v
swap >>h ;
: jpeg> ( -- jpeg-image ) jpeg-image get ;
: apply-diff ( dc color -- dc' )
[ diff>> + dup ] [ (>>diff) ] bi ;
: fetch-tables ( component -- )
[ [ jpeg> quant-tables>> nth ] change-quant-table drop ]
[ [ jpeg> huff-tables>> nth ] change-dc-huff-table drop ]
[ [ 2 + jpeg> huff-tables>> nth ] change-ac-huff-table drop ] tri ;
: read4/4 ( -- a b ) read1 16 /mod ;
! headers
: decode-frame ( header -- )
data>>
binary
[
read1 8 assert=
2 read be>
2 read be>
swap 2array jpeg> (>>dim)
read1
[
read1 read4/4 read1 <jpeg-color-info>
swap [ >>id ] keep jpeg> color-info>> set-nth
] times
] with-byte-reader ;
: decode-quant-table ( chunk -- )
dup data>>
binary
[
length>>
2 - 65 /
[
read4/4 [ 0 assert= ] dip
64 read
swap jpeg> quant-tables>> set-nth
] times
] with-byte-reader ;
: decode-huff-table ( chunk -- )
data>>
binary
[
1 ! %fixme: Should handle multiple tables at once
[
read4/4 swap 2 * +
16 read
dup [ ] [ + ] map-reduce read
binary [ [ read [ B{ } ] unless* ] { } map-as ] with-byte-reader
swap jpeg> huff-tables>> set-nth
] times
] with-byte-reader ;
: decode-scan ( chunk -- )
data>>
binary
[
read1 [0,b)
[ drop
read1 jpeg> color-info>> nth clone
read1 16 /mod [ >>dc-huff-table ] [ >>ac-huff-table ] bi*
] map jpeg> (>>components)
read1 0 assert=
read1 63 assert=
read1 16 /mod [ 0 assert= ] bi@
] with-byte-reader ;
: singleton-first ( seq -- elt )
[ length 1 assert= ] [ first ] bi ;
: baseline-parse ( -- )
jpeg> headers>>
{
[ [ type>> { SOF 0 } = ] filter singleton-first decode-frame ]
[ [ type>> { DQT } = ] filter [ decode-quant-table ] each ]
[ [ type>> { DHT } = ] filter [ decode-huff-table ] each ]
[ [ type>> { SOS } = ] filter singleton-first decode-scan ]
} cleave ;
: parse-marker ( -- marker )
read1 HEX: FF assert=
read1 >marker ;
: parse-headers ( -- chunks )
[ parse-marker dup { SOS } = not ]
[
2 read be>
dup 2 - read <jpeg-chunk>
] [ produce ] keep dip swap suffix ;
MEMO: zig-zag ( -- zz )
{
{ 0 1 5 6 14 15 27 28 }
{ 2 4 7 13 16 26 29 42 }
{ 3 8 12 17 25 30 41 43 }
{ 9 11 18 24 31 40 44 53 }
{ 10 19 23 32 39 45 52 54 }
{ 20 22 33 38 46 51 55 60 }
{ 21 34 37 47 50 56 59 61 }
{ 35 36 48 49 57 58 62 63 }
} flatten ;
MEMO: yuv>bgr-matrix ( -- m )
{
{ 1 2.03211 0 }
{ 1 -0.39465 -0.58060 }
{ 1 0 1.13983 }
} ;
: wave ( x u -- n ) swap 2 * 1 + * pi * 16 / cos ;
:: dct-vect ( u v -- basis )
{ 8 8 } coord-matrix [ { u v } [ wave ] 2map product ] map^2
1 u v [ 0 = [ 2 sqrt / ] when ] bi@ 4 / m*n ;
MEMO: dct-matrix ( -- m ) 64 [0,b) [ 8 /mod dct-vect flatten ] map ;
: 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 -- ) -- )
[
jpeg>
[ dim>> 8 v/n ]
[ color-info>> sift { 0 0 } [ mb-dim vmax ] reduce v/ ] bi
[ ceiling ] map
coord-matrix flip concat
]
[ each ] bi* ; inline
: reverse-zigzag ( b -- b' ) zig-zag swap [ nth ] curry map ;
: idct-factor ( b -- b' ) dct-matrix v.m ;
USE: math.blas.vectors
USE: math.blas.matrices
MEMO: dct-matrix-blas ( -- m ) dct-matrix >float-blas-matrix ;
: V.M ( x A -- x.A ) Mtranspose swap M.V ;
: idct-blas ( b -- b' ) >float-blas-vector dct-matrix-blas V.M ;
: idct ( b -- b' ) idct-blas ;
:: draw-block ( block x,y color-id jpeg-image -- )
block dup length>> sqrt >fixnum group flip
dup matrix-dim coord-matrix flip
[
[ first2 spin nth nth ]
[ x,y v+ color-id jpeg-image draw-color ] bi
] with each^2 ;
: sign-extend ( bits v -- v' )
swap [ ] [ 1- 2^ < ] 2bi
[ -1 swap shift 1+ + ] [ drop ] if ;
: read1-jpeg-dc ( decoder -- dc )
[ read1-huff dup ] [ bs>> bs:read ] bi sign-extend ;
: read1-jpeg-ac ( decoder -- run/ac )
[ read1-huff 16 /mod dup ] [ bs>> bs:read ] bi sign-extend 2array ;
:: decode-block ( color -- pixels )
color dc-huff-table>> read1-jpeg-dc color apply-diff
64 0 <array> :> coefs
0 coefs set-nth
0 :> k!
[
color ac-huff-table>> read1-jpeg-ac
[ first 1+ k + k! ] [ second k coefs set-nth ] [ ] tri
{ 0 0 } = not
k 63 < and
] loop
coefs color quant-table>> v*
reverse-zigzag idct ;
:: 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>>
[
[ mb-dim first2 * iota ]
[ [ decode-block ] curry replicate ] bi
] map concat ;
: cleanup-bitstream ( bytes -- bytes' )
binary [
[
{ HEX: FF } read-until
read1 tuck HEX: 00 = and
]
[ drop ] produce
swap >marker { EOI } assert=
swap suffix
{ HEX: FF } join
] with-byte-reader ;
: setup-bitmap ( image -- )
dup dim>> 16 v/n [ ceiling ] map 16 v*n >>dim
BGR >>component-order
f >>upside-down?
dup dim>> first2 * 3 * 0 <array> >>bitmap
drop ;
ERROR: unsupported-colorspace ;
SINGLETONS: YUV420 YUV444 Y MAGIC! ;
:: detect-colorspace ( jpeg-image -- csp )
jpeg-image color-info>> sift :> colors
MAGIC!
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
: color-transform ( yuv -- rgb )
{ 128 0 0 } v+ yuv>bgr-matrix swap m.v
[ 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>
: load-jpeg ( path -- image )
binary [
parse-marker { SOI } = [ not-a-jpeg-image ] unless
parse-headers
contents <jpeg-image>
] with-file-reader
dup jpeg-image [
baseline-parse
baseline-decompress
] with-variable ;
M: jpeg-image load-image* ( path jpeg-image -- bitmap )
drop load-jpeg ;

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

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

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

@ -1,10 +1,9 @@
! Copyright (C) 2009 Doug Coleman.
! 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
sequences io.streams.limited fry combinators arrays math
checksums checksums.crc32 compression.inflate grouping byte-arrays
images.loader ;
sequences io.streams.limited fry combinators arrays math checksums
checksums.crc32 compression.inflate grouping byte-arrays images.loader ;
IN: images.png
SINGLETON: png-image
@ -15,12 +14,14 @@ TUPLE: loading-png
width height bit-depth color-type compression-method
filter-method interlace-method uncompressed ;
CONSTRUCTOR: loading-png ( -- image )
: <loading-png> ( -- image )
loading-png new
V{ } clone >>chunks ;
TUPLE: png-chunk length type data ;
CONSTRUCTOR: png-chunk ( -- png-chunk ) ;
: <png-chunk> ( -- png-chunk )
png-chunk new ; inline
CONSTANT: png-header
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.
! See http://factorcode.org/license.txt for BSD license.
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.encodings.string io.encodings.utf8 io.files kernel math
math.bitwise math.order math.parser pack prettyprint sequences
@ -12,14 +12,27 @@ IN: images.tiff
SINGLETON: tiff-image
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
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 ;
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
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
name
log-level
secure insecure
secure
insecure
secure-config
sockets
max-connections
@ -29,14 +30,14 @@ ready ;
: new-threaded-server ( encoding class -- threaded-server )
new
swap >>encoding
"server" >>name
DEBUG >>log-level
1 minutes >>timeout
V{ } clone >>sockets
<secure-config> >>secure-config
V{ } clone >>sockets
1 minutes >>timeout
[ "No handler quotation" throw ] >>handler
<flag> >>ready ; inline
<flag> >>ready
swap >>encoding ;
: <threaded-server> ( encoding -- 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.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays fry kernel math math.order math.vectors
sequences sequences.private accessors columns ;
USING: accessors arrays columns kernel math math.bits
math.order math.vectors sequences sequences.private fry ;
IN: math.matrices
! Matrices
@ -61,3 +61,7 @@ PRIVATE>
: cross-zip ( seq1 seq2 -- seq1xseq2 )
[ [ 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
'[ [ _ v+ <single-texture> |dispose ] 2map ] 2map ;
: draw-textured-grid ( grid -- )
[ [ [ dim>> ] keep (draw-textured-rect) ] each ] each ;
: grid-has-alpha? ( grid -- ? )
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
HELP: PV{
{ $syntax "elements... }" }
{ $syntax "PV{ elements... }" }
{ $description "Parses a literal " { $link 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" ] [
[ M\ started-out-hustlin' ended-up-ballin' see ] with-string-writer
] 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 class>> object eq? [
dup class>> ,
initial: ,
dup initial>> ,
] unless
dup read-only>> [
read-only ,
] when
dup [ class>> object eq? not ] [ initial>> ] bi or [
initial: ,
dup initial>> ,
] when
drop
] { } 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 )
[ descent>> ] map ?supremum ;
: max-text-height ( seq -- y )
[ ascent>> ] filter [ height>> ] map ?supremum ;
: max-graphics-height ( seq -- y )
[ 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" "" ? ;
: gadget-seq-text ( seq gadget -- )
gadget-text-separator swap
[ dup % ] [ gadget-text* ] interleave drop ;
gadget-text-separator '[ _ % ] [ gadget-text* ] interleave ;
M: gadget gadget-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
] [ 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 ;
: pane-write ( seq pane -- )

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

@ -5,10 +5,6 @@ IN: ui.gadgets.sliders
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." } ;
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
{ $class-description "A slider is a control for graphically manipulating a " { $link "models-range" } "."
$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 ;
: find-elevator ( gadget -- elevator/f ) [ elevator? ] find-parent ;
: find-slider ( gadget -- slider/f ) [ slider? ] find-parent ;
CONSTANT: elevator-padding 4

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

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

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

@ -1,7 +1,7 @@
IN: classes.tuple.parser.tests
USING: accessors classes.tuple.parser lexer words classes
sequences math kernel slots tools.test parser compiler.units
arrays classes.tuple eval ;
arrays classes.tuple eval multiline ;
TUPLE: test-1 ;
@ -141,4 +141,4 @@ TUPLE: parsing-corner-case x ;
"USE: classes.tuple.parser.tests T{ parsing-corner-case {"
" x 3 }"
} "\n" join eval( -- tuple )
] [ error>> unexpected-eof? ] must-fail-with
] [ error>> unexpected-eof? ] must-fail-with

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

@ -1,11 +1,12 @@
USING: definitions generic kernel kernel.private math math.constants
parser sequences tools.test words assocs namespaces quotations
sequences.private classes continuations generic.single
generic.standard effects classes.tuple classes.tuple.private arrays
vectors strings compiler.units accessors classes.algebra calendar
prettyprint io.streams.string splitting summary columns math.order
classes.private slots slots.private eval see words.symbol
compiler.errors parser.notes ;
USING: accessors arrays assocs calendar classes classes.algebra
classes.private classes.tuple classes.tuple.private columns
compiler.errors compiler.units continuations definitions
effects eval generic generic.single generic.standard grouping
io.streams.string kernel kernel.private math math.constants
math.order namespaces parser parser.notes prettyprint
quotations random see sequences sequences.private slots
slots.private splitting strings summary threads tools.test
vectors vocabs words words.symbol ;
IN: classes.tuple.tests
TUPLE: rect x y w h ;
@ -421,7 +422,6 @@ TUPLE: redefinition-problem-2 ;
[ t ] [ 3 redefinition-problem'? ] unit-test
! Hardcore unit tests
USE: threads
\ thread "slots" word-prop "slots" set
@ -439,8 +439,6 @@ USE: threads
] with-compilation-unit
] unit-test
USE: vocabs
\ 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 )
M: tuple-class slots>tuple
M: tuple-class slots>tuple ( seq class -- tuple )
check-slots pad-slots
tuple-layout <tuple> [
[ tuple-size ]
@ -147,8 +147,8 @@ ERROR: bad-superclass class ;
dup boa-check-quot "boa-check" set-word-prop ;
: tuple-prototype ( class -- prototype )
[ initial-values ] keep
over [ ] any? [ slots>tuple ] [ 2drop f ] if ;
[ initial-values ] keep over [ ] any?
[ slots>tuple ] [ 2drop f ] if ;
: define-tuple-prototype ( class -- )
dup tuple-prototype "prototype" set-word-prop ;
@ -340,8 +340,7 @@ M: tuple tuple-hashcode
M: tuple hashcode* tuple-hashcode ;
M: tuple-class new
dup "prototype" word-prop
[ (clone) ] [ tuple-layout <tuple> ] ?if ;
dup "prototype" word-prop [ (clone) ] [ tuple-layout <tuple> ] ?if ;
M: tuple-class boa
[ "boa-check" word-prop [ call ] when* ]

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

@ -8,16 +8,16 @@ HELP: dispose
$nl
"No further operations can be performed on a disposable object after this call."
$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."
$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*
{ $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." }
{ $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

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

@ -40,6 +40,4 @@ $nl
HELP: math-generic
{ $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
: last/first ( seq -- pair ) [ last ] [ first ] bi 2array ;
: bootstrap-words ( classes -- classes' )
[ bootstrap-word ] map ;

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

@ -29,7 +29,7 @@ HELP: <lexer-error>
HELP: skip
{ $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
{ $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 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 )
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 -- )
[ [ column>> ] [ line-text>> ] bi ] prepose keep
@ -65,8 +73,6 @@ M: lexer skip-word ( lexer -- )
: scan ( -- str/f ) lexer get parse-token ;
ERROR: unexpected want got ;
PREDICATE: unexpected-eof < unexpected
got>> not ;

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

@ -286,3 +286,8 @@ M: bogus-hashcode hashcode* 2drop 0 >bignum ;
[ f f ] [
{ 1 2 3 4 5 6 7 8 } [ H{ { 11 "hi" } } at ] map-find
] 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
: ((each)) ( seq -- n quot )
[ length ] keep [ nth-unsafe ] curry ; inline
: (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' )
[ [ keep ] dip set-nth-unsafe ] 2curry ; inline
@ -498,19 +504,18 @@ PRIVATE>
: follow ( obj quot -- seq )
[ dup ] swap [ keep ] curry produce nip ; inline
: prepare-index ( seq quot -- seq n quot )
[ dup length ] dip ; inline
: each-index ( seq quot -- )
prepare-index 2each ; inline
(each-index) each-integer ; inline
: interleave ( seq between quot -- )
swap [ drop ] [ [ 2dip call ] 2curry ] 2bi
[ [ 0 = ] 2dip if ] 2curry
each-index ; inline
pick empty? [ 3drop ] [
[ [ drop first-unsafe ] dip call ]
[ [ rest-slice ] 2dip [ bi* ] 2curry each ]
3bi
] if ; inline
: map-index ( seq quot -- newseq )
prepare-index 2map ; inline
[ dup length iota ] dip 2map ; inline
: reduce-index ( seq identity quot -- )
swapd each-index ; inline

2
core/syntax/syntax.factor
View File

@ -245,7 +245,7 @@ IN: bootstrap.syntax
] define-core-syntax
"initial:" "syntax" lookup define-symbol
"read-only" "syntax" lookup define-symbol
"call(" [ \ call-effect parse-call( ] define-core-syntax

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)
(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 ()
(when (fuel-syntax--at-setter-line)
(save-excursion
(let ((indent (and (fuel-syntax--at-constructor-line)
(current-indentation))))
(while (not (or indent
(bobp)
(fuel-syntax--at-begin-of-def)
(fuel-syntax--at-end-of-def)))
(if (fuel-syntax--at-constructor-line)
(setq indent (fuel-syntax--increased-indentation))
(forward-line -1)))
indent))))
(or (save-excursion
(let ((indent (and (fuel-syntax--at-constructor-line)
(current-indentation))))
(while (not (or indent
(bobp)
(fuel-syntax--at-begin-of-def)
(fuel-syntax--at-end-of-def)))
(if (fuel-syntax--at-constructor-line)
(setq indent (fuel-syntax--increased-indentation))
(forward-line -1)))
indent))
(save-excursion
(factor-mode--previous-non-empty)
(current-indentation)))))
(defun factor-mode--indent-continuation ()
(save-excursion
(forward-line -1)
(while (and (not (bobp))
(fuel-syntax--looking-at-emptiness))
(forward-line -1))
(factor-mode--previous-non-empty)
(cond ((or (fuel-syntax--at-end-of-def)
(fuel-syntax--at-setter-line))
(fuel-syntax--decreased-indentation))