diff --git a/basis/bitstreams/bitstreams.factor b/basis/bitstreams/bitstreams.factor index 4718f137e4..2aa0059542 100644 --- a/basis/bitstreams/bitstreams.factor +++ b/basis/bitstreams/bitstreams.factor @@ -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 ) ; + +: ( bytes -- bs ) + msb0-bit-reader new swap >>bytes ; inline + +: ( 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 diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor index fe853cf490..1bf94985a6 100644 --- a/basis/compiler/cfg/instructions/instructions.factor +++ b/basis/compiler/cfg/instructions/instructions.factor @@ -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 ; diff --git a/basis/compiler/cfg/linear-scan/allocation/allocation.factor b/basis/compiler/cfg/linear-scan/allocation/allocation.factor index 7b56bd6150..a99fea1d24 100644 --- a/basis/compiler/cfg/linear-scan/allocation/allocation.factor +++ b/basis/compiler/cfg/linear-scan/allocation/allocation.factor @@ -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 ] - [ 1 + swap to>> ] - 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 - 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) diff --git a/basis/compiler/cfg/linear-scan/allocation/coalescing/coalescing.factor b/basis/compiler/cfg/linear-scan/allocation/coalescing/coalescing.factor new file mode 100644 index 0000000000..99ed75dcbc --- /dev/null +++ b/basis/compiler/cfg/linear-scan/allocation/coalescing/coalescing.factor @@ -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 ; diff --git a/basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor b/basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor new file mode 100644 index 0000000000..4981a223a4 --- /dev/null +++ b/basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor @@ -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 ; + diff --git a/basis/compiler/cfg/linear-scan/allocation/splitting/splitting.factor b/basis/compiler/cfg/linear-scan/allocation/splitting/splitting.factor new file mode 100644 index 0000000000..40ee4083e4 --- /dev/null +++ b/basis/compiler/cfg/linear-scan/allocation/splitting/splitting.factor @@ -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 ] + [ 1 + swap to>> ] + 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 ; \ No newline at end of file diff --git a/basis/compiler/cfg/linear-scan/allocation/state/state.factor b/basis/compiler/cfg/linear-scan/allocation/state/state.factor new file mode 100644 index 0000000000..2a1e87dcdd --- /dev/null +++ b/basis/compiler/cfg/linear-scan/allocation/state/state.factor @@ -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 + 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 ; \ No newline at end of file diff --git a/basis/compiler/cfg/linear-scan/assignment/assignment-tests.factor b/basis/compiler/cfg/linear-scan/assignment/assignment-tests.factor deleted file mode 100644 index 13c1783711..0000000000 --- a/basis/compiler/cfg/linear-scan/assignment/assignment-tests.factor +++ /dev/null @@ -1,4 +0,0 @@ -USING: compiler.cfg.linear-scan.assignment tools.test ; -IN: compiler.cfg.linear-scan.assignment.tests - - diff --git a/basis/compiler/cfg/linear-scan/assignment/assignment.factor b/basis/compiler/cfg/linear-scan/assignment/assignment.factor index 6fcd6e7570..ea918a7424 100644 --- a/basis/compiler/cfg/linear-scan/assignment/assignment.factor +++ b/basis/compiler/cfg/linear-scan/assignment/assignment.factor @@ -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 ; - -: ( -- obj ) - V{ } clone active-intervals boa ; +M: insn assign-registers-in-insn drop ; : init-assignment ( live-intervals -- ) - active-intervals set + V{ } clone pending-intervals set 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 ; diff --git a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor index ccfc4a1ff7..243e83445d 100644 --- a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor +++ b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor @@ -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 \ No newline at end of file +] 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 \ No newline at end of file diff --git a/basis/compiler/cfg/linear-scan/linear-scan.factor b/basis/compiler/cfg/linear-scan/linear-scan.factor index ffa356bfc2..3a0a7f8770 100644 --- a/basis/compiler/cfg/linear-scan/linear-scan.factor +++ b/basis/compiler/cfg/linear-scan/linear-scan.factor @@ -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 diff --git a/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor b/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor index 546443b289..c88f7fd21b 100644 --- a/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor +++ b/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor @@ -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 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 ) diff --git a/basis/compiler/cfg/linear-scan/resolve/resolve.factor b/basis/compiler/cfg/linear-scan/resolve/resolve.factor new file mode 100644 index 0000000000..df2dbb1198 --- /dev/null +++ b/basis/compiler/cfg/linear-scan/resolve/resolve.factor @@ -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 ; \ No newline at end of file diff --git a/basis/compiler/cfg/predecessors/predecessors.factor b/basis/compiler/cfg/predecessors/predecessors.factor index 5be085ba5a..54efc53bc4 100644 --- a/basis/compiler/cfg/predecessors/predecessors.factor +++ b/basis/compiler/cfg/predecessors/predecessors.factor @@ -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 ; diff --git a/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor b/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor index 4455d5e208..3501825704 100644 --- a/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor +++ b/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor @@ -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 diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor index 7602295284..a1583d2a5d 100755 --- a/basis/compiler/codegen/codegen.factor +++ b/basis/compiler/codegen/codegen.factor @@ -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 ; diff --git a/basis/compiler/tests/codegen.factor b/basis/compiler/tests/codegen.factor index 47c6fa31e7..36ee5eb94d 100644 --- a/basis/compiler/tests/codegen.factor +++ b/basis/compiler/tests/codegen.factor @@ -288,4 +288,26 @@ M: cucumber equal? "The cucumber has no equal" throw ; -1 -1 [ [ 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 \ No newline at end of file diff --git a/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor b/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor index 708992f918..4fb01608f0 100644 --- a/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor +++ b/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor @@ -327,4 +327,4 @@ C: ro-box TUPLE: empty-tuple ; -[ ] [ [ empty-tuple boa layout-of ] count-unboxed-allocations drop ] unit-test \ No newline at end of file +[ ] [ [ empty-tuple boa layout-of ] count-unboxed-allocations drop ] unit-test diff --git a/basis/compression/huffman/huffman.factor b/basis/compression/huffman/huffman.factor index 6ef9c2fabc..9ece36e6cd 100755 --- a/basis/compression/huffman/huffman.factor +++ b/basis/compression/huffman/huffman.factor @@ -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 ) +: ( bs tdesc -- decoder ) + huffman-decoder new + swap >>tdesc + swap >>bs 16 >>bits/level [ ] [ tdesc>> ] [ bits/level>> 2^ ] tri reverse-table >>rtable ; diff --git a/basis/compression/inflate/inflate.factor b/basis/compression/inflate/inflate.factor old mode 100755 new mode 100644 index 48b831be9e..05ec94a794 --- a/basis/compression/inflate/inflate.factor +++ b/basis/compression/inflate/inflate.factor @@ -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 - -seq ( assoc -- seq ) - dup keys [ ] [ max ] map-reduce 1 + f - [ '[ 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 :> 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 clone - [ '[ _ 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 - [ 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 append ] bi* ] [ suffix ] if ] reduce - [ dup array? [ second 0 ] [ 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 :> 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 ] 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: - [ 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 + +seq ( assoc -- seq ) + dup keys [ ] [ max ] map-reduce 1 + f + [ '[ 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 :> 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 clone + [ '[ _ 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 + [ 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 append ] bi* ] [ suffix ] if ] reduce + [ dup array? [ second 0 ] [ 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 :> 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 ] 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>> + 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: + [ check-zlib-header ] [ inflate-loop ] bi + inflate-lz77 ; diff --git a/basis/functors/functors.factor b/basis/functors/functors.factor index e5eb50e82f..b7dab0d6af 100644 --- a/basis/functors/functors.factor +++ b/basis/functors/functors.factor @@ -58,8 +58,6 @@ M: object (fake-quotations>) , ; [ parse-definition* ] dip parsed ; -: DEFINE* ( accum -- accum ) \ define-declared* parsed ; - SYNTAX: `TUPLE: scan-param parsed scan { diff --git a/basis/game-input/dinput/dinput.factor b/basis/game-input/dinput/dinput.factor index 8540907db9..0ecf543baa 100755 --- a/basis/game-input/dinput/dinput.factor +++ b/basis/game-input/dinput/dinput.factor @@ -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 diff --git a/basis/heaps/heaps.factor b/basis/heaps/heaps.factor index becfb6826d..ae546080a1 100644 --- a/basis/heaps/heaps.factor +++ b/basis/heaps/heaps.factor @@ -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 -- ) diff --git a/basis/help/lint/lint.factor b/basis/help/lint/lint.factor index 4ead01159a..c1dd591013 100755 --- a/basis/help/lint/lint.factor +++ b/basis/help/lint/lint.factor @@ -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 '[ diff --git a/basis/images/jpeg/jpeg.factor b/basis/images/jpeg/jpeg.factor old mode 100755 new mode 100644 index 2cdc32e9df..f61254c3cf --- a/basis/images/jpeg/jpeg.factor +++ b/basis/images/jpeg/jpeg.factor @@ -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 } ; - -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 - 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 - ] [ 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 :> 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 >>bitmap - drop ; - -: baseline-decompress ( -- ) - jpeg> bitstream>> cleanup-bitstream { 255 255 255 255 } append - >byte-array bs: jpeg> (>>bitstream) - jpeg> [ bitstream>> ] [ [ [ ] 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 - ] with-file-reader - dup loading-jpeg [ - baseline-parse - baseline-decompress - jpeg> bitmap>> 3 [ 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 } ; + + ( 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 ; + +: ( 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 ; + +: ( 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 + 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 + ] [ 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 :> 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 pos 1 jpeg> draw-block + 64 0 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 >>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: jpeg> (>>bitstream) + jpeg> + [ bitstream>> ] + [ [ [ ] 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 [ 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 + ] with-file-reader + dup jpeg-image [ + baseline-parse + baseline-decompress + ] with-variable ; + +M: jpeg-image load-image* ( path jpeg-image -- bitmap ) + drop load-jpeg ; + diff --git a/basis/images/loader/loader.factor b/basis/images/loader/loader.factor index 51d4e0fadf..dc0eec75c2 100644 --- a/basis/images/loader/loader.factor +++ b/basis/images/loader/loader.factor @@ -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 ; diff --git a/basis/images/png/png.factor b/basis/images/png/png.factor index eb6b29713c..bb470d8dd8 100755 --- a/basis/images/png/png.factor +++ b/basis/images/png/png.factor @@ -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 ) +: ( -- image ) + loading-png new V{ } clone >>chunks ; TUPLE: png-chunk length type data ; -CONSTRUCTOR: 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 } diff --git a/basis/images/tiff/tiff.factor b/basis/images/tiff/tiff.factor index e0de68b368..e00b05f2e7 100755 --- a/basis/images/tiff/tiff.factor +++ b/basis/images/tiff/tiff.factor @@ -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 ; + +: ( -- tiff ) + loading-tiff new V{ } clone >>ifds ; TUPLE: ifd count ifd-entries next processed-tags strips bitmap ; -CONSTRUCTOR: ifd ( count ifd-entries next -- 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 ) ; + +: ( 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 diff --git a/basis/io/servers/connection/connection.factor b/basis/io/servers/connection/connection.factor index df6c21e7cc..345b739b61 100644 --- a/basis/io/servers/connection/connection.factor +++ b/basis/io/servers/connection/connection.factor @@ -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 + V{ } clone >>sockets + 1 minutes >>timeout [ "No handler quotation" throw ] >>handler - >>ready ; inline + >>ready + swap >>encoding ; : ( encoding -- threaded-server ) threaded-server new-threaded-server ; diff --git a/basis/math/matrices/matrices.factor b/basis/math/matrices/matrices.factor old mode 100755 new mode 100644 index 346da45ad8..d6bee78c14 --- a/basis/math/matrices/matrices.factor +++ b/basis/math/matrices/matrices.factor @@ -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 ; diff --git a/basis/opengl/textures/textures.factor b/basis/opengl/textures/textures.factor index d43e1736d1..2eabbd478b 100755 --- a/basis/opengl/textures/textures.factor +++ b/basis/opengl/textures/textures.factor @@ -135,9 +135,6 @@ TUPLE: multi-texture grid display-list loc disposed ; [ dup image-locs ] dip '[ [ _ v+ |dispose ] 2map ] 2map ; -: draw-textured-grid ( grid -- ) - [ [ [ dim>> ] keep (draw-textured-rect) ] each ] each ; - : grid-has-alpha? ( grid -- ? ) first first image>> has-alpha? ; diff --git a/basis/persistent/vectors/vectors-docs.factor b/basis/persistent/vectors/vectors-docs.factor index 4816877a35..aa817edf52 100644 --- a/basis/persistent/vectors/vectors-docs.factor +++ b/basis/persistent/vectors/vectors-docs.factor @@ -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 diff --git a/basis/prettyprint/prettyprint-tests.factor b/basis/prettyprint/prettyprint-tests.factor index a2696b1263..b3897960f0 100644 --- a/basis/prettyprint/prettyprint-tests.factor +++ b/basis/prettyprint/prettyprint-tests.factor @@ -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 diff --git a/basis/see/see.factor b/basis/see/see.factor index a8d78a68e4..206bdbb906 100644 --- a/basis/see/see.factor +++ b/basis/see/see.factor @@ -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 ; diff --git a/basis/ui/baseline-alignment/baseline-alignment.factor b/basis/ui/baseline-alignment/baseline-alignment.factor index f7f7a757f5..6e2b58479b 100644 --- a/basis/ui/baseline-alignment/baseline-alignment.factor +++ b/basis/ui/baseline-alignment/baseline-alignment.factor @@ -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 ; diff --git a/basis/ui/gadgets/gadgets.factor b/basis/ui/gadgets/gadgets.factor index 6a289ec1d6..0295012584 100644 --- a/basis/ui/gadgets/gadgets.factor +++ b/basis/ui/gadgets/gadgets.factor @@ -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 ; diff --git a/basis/ui/gadgets/panes/panes.factor b/basis/ui/gadgets/panes/panes.factor index eb741f13b6..2c5ed596ac 100644 --- a/basis/ui/gadgets/panes/panes.factor +++ b/basis/ui/gadgets/panes/panes.factor @@ -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 -- ) diff --git a/basis/ui/gadgets/sliders/sliders-docs.factor b/basis/ui/gadgets/sliders/sliders-docs.factor index 38f4b5ac15..570291a18f 100644 --- a/basis/ui/gadgets/sliders/sliders-docs.factor +++ b/basis/ui/gadgets/sliders/sliders-docs.factor @@ -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 diff --git a/basis/ui/gadgets/sliders/sliders.factor b/basis/ui/gadgets/sliders/sliders.factor index 80829d7b66..d293fd7f8b 100644 --- a/basis/ui/gadgets/sliders/sliders.factor +++ b/basis/ui/gadgets/sliders/sliders.factor @@ -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 diff --git a/basis/unicode/breaks/breaks.factor b/basis/unicode/breaks/breaks.factor index 1b1d9434f8..6d6b5cc0cf 100644 --- a/basis/unicode/breaks/breaks.factor +++ b/basis/unicode/breaks/breaks.factor @@ -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 ) diff --git a/core/classes/tuple/parser/parser-tests.factor b/core/classes/tuple/parser/parser-tests.factor index b95507c78b..72457ff974 100644 --- a/core/classes/tuple/parser/parser-tests.factor +++ b/core/classes/tuple/parser/parser-tests.factor @@ -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 \ No newline at end of file diff --git a/core/classes/tuple/tuple-tests.factor b/core/classes/tuple/tuple-tests.factor index e3452194c6..191ec75544 100644 --- a/core/classes/tuple/tuple-tests.factor +++ b/core/classes/tuple/tuple-tests.factor @@ -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 [ ] [ diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor index 225176f4e5..7633f9b4c8 100755 --- a/core/classes/tuple/tuple.factor +++ b/core/classes/tuple/tuple.factor @@ -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-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 ] ?if ; + dup "prototype" word-prop [ (clone) ] [ tuple-layout ] ?if ; M: tuple-class boa [ "boa-check" word-prop [ call ] when* ] diff --git a/core/destructors/destructors-docs.factor b/core/destructors/destructors-docs.factor index 536ee19c8b..1abcba0720 100644 --- a/core/destructors/destructors-docs.factor +++ b/core/destructors/destructors-docs.factor @@ -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 diff --git a/core/generic/math/math-docs.factor b/core/generic/math/math-docs.factor index 7d7d6e725b..5953c5ad9b 100644 --- a/core/generic/math/math-docs.factor +++ b/core/generic/math/math-docs.factor @@ -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." } ; + diff --git a/core/generic/math/math.factor b/core/generic/math/math.factor index e88c0c02e4..e0e8b91a2c 100644 --- a/core/generic/math/math.factor +++ b/core/generic/math/math.factor @@ -15,8 +15,6 @@ PREDICATE: math-class < class 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 )" } } } diff --git a/core/lexer/lexer.factor b/core/lexer/lexer.factor index 60157033d7..99e6f05c6c 100644 --- a/core/lexer/lexer.factor +++ b/core/lexer/lexer.factor @@ -22,9 +22,17 @@ TUPLE: lexer text line line-text line-length column ; : ( 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 ; diff --git a/core/sequences/sequences-tests.factor b/core/sequences/sequences-tests.factor index 85f9d56596..5e0d5597ca 100644 --- a/core/sequences/sequences-tests.factor +++ b/core/sequences/sequences-tests.factor @@ -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 \ No newline at end of file diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index 36e4c95470..6eea872343 100755 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -358,8 +358,14 @@ 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 diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor index 56ac9fa36e..7b9a0d36ef 100644 --- a/core/syntax/syntax.factor +++ b/core/syntax/syntax.factor @@ -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 diff --git a/basis/constructors/authors.txt b/extra/constructors/authors.txt similarity index 100% rename from basis/constructors/authors.txt rename to extra/constructors/authors.txt diff --git a/basis/constructors/constructors-tests.factor b/extra/constructors/constructors-tests.factor similarity index 100% rename from basis/constructors/constructors-tests.factor rename to extra/constructors/constructors-tests.factor diff --git a/basis/constructors/constructors.factor b/extra/constructors/constructors.factor similarity index 100% rename from basis/constructors/constructors.factor rename to extra/constructors/constructors.factor diff --git a/basis/constructors/summary.txt b/extra/constructors/summary.txt similarity index 100% rename from basis/constructors/summary.txt rename to extra/constructors/summary.txt diff --git a/basis/constructors/tags.txt b/extra/constructors/tags.txt similarity index 100% rename from basis/constructors/tags.txt rename to extra/constructors/tags.txt diff --git a/extra/nested-comments/nested-comments.factor b/extra/nested-comments/nested-comments.factor new file mode 100644 index 0000000000..94daffec2d --- /dev/null +++ b/extra/nested-comments/nested-comments.factor @@ -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-(* ; \ No newline at end of file diff --git a/misc/fuel/factor-mode.el b/misc/fuel/factor-mode.el index cc8ebe35fb..bef6e4c774 100644 --- a/misc/fuel/factor-mode.el +++ b/misc/fuel/factor-mode.el @@ -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))