! 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 } ;
TUPLE: msb0-bit-reader < bit-reader ;
TUPLE: lsb0-bit-reader < bit-reader ;
-CONSTRUCTOR: msb0-bit-reader ( bytes -- bs ) ;
-CONSTRUCTOR: lsb0-bit-reader ( bytes -- bs ) ;
+
+: <msb0-bit-reader> ( bytes -- bs )
+ msb0-bit-reader new swap >>bytes ; inline
+
+: <lsb0-bit-reader> ( bytes -- bs )
+ lsb0-bit-reader new swap >>bytes ; inline
TUPLE: msb0-bit-writer < bit-writer ;
TUPLE: lsb0-bit-writer < bit-writer ;
"NSOpenGLPixelFormat"
"NSOpenGLView"
"NSOpenPanel"
+ "NSPanel"
"NSPasteboard"
"NSPropertyListSerialization"
"NSResponder"
sequences math.bitwise ;
IN: cocoa.windows
+! Window styles
CONSTANT: NSBorderlessWindowMask 0
CONSTANT: NSTitledWindowMask 1
CONSTANT: NSClosableWindowMask 2
CONSTANT: NSMiniaturizableWindowMask 4
CONSTANT: NSResizableWindowMask 8
+! Additional panel-only styles
+CONSTANT: NSUtilityWindowMask 16
+CONSTANT: NSDocModalWindowMask 64
+CONSTANT: NSNonactivatingPanelMask 128
+CONSTANT: NSHUDWindowMask HEX: 1000
+
CONSTANT: NSBackingStoreRetained 0
CONSTANT: NSBackingStoreNonretained 1
CONSTANT: NSBackingStoreBuffered 2
-: standard-window-type ( -- n )
- {
- NSTitledWindowMask
- NSClosableWindowMask
- NSMiniaturizableWindowMask
- NSResizableWindowMask
- } flags ; inline
-
-: <NSWindow> ( rect -- window )
- NSWindow -> alloc swap
- standard-window-type NSBackingStoreBuffered 1
+: <NSWindow> ( rect style class -- window )
+ [ -> alloc ] curry 2dip NSBackingStoreBuffered 1
-> initWithContentRect:styleMask:backing:defer: ;
-: <ViewWindow> ( view rect -- window )
- <NSWindow> [ swap -> setContentView: ] keep
+: class-for-style ( style -- NSWindow/NSPanel )
+ HEX: 1ff0 bitand zero? NSWindow NSPanel ? ;
+
+: <ViewWindow> ( view rect style -- window )
+ dup class-for-style <NSWindow> [ swap -> setContentView: ] keep
dup dup -> contentView -> setInitialFirstResponder:
dup 1 -> setAcceptsMouseMovedEvents:
dup 0 -> setReleasedWhenClosed: ;
: window-content-rect ( window -- rect )
- [ NSWindow ] dip
+ dup -> class swap
[ -> frame ] [ -> styleMask ] bi
-> contentRectForFrameRect:styleMask: ;
! virtual registers
INSN: _spill src class n ;
INSN: _reload dst class n ;
+INSN: _copy dst src class ;
INSN: _spill-counts counts ;
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces sequences math math.order kernel assocs
-accessors vectors fry heaps cpu.architecture sorting locals
-combinators compiler.cfg.registers
-compiler.cfg.linear-scan.live-intervals hints ;
+USING: accessors assocs heaps kernel namespaces sequences
+compiler.cfg.linear-scan.allocation.coalescing
+compiler.cfg.linear-scan.allocation.spilling
+compiler.cfg.linear-scan.allocation.splitting
+compiler.cfg.linear-scan.allocation.state ;
IN: compiler.cfg.linear-scan.allocation
-! Mapping from register classes to sequences of machine registers
-SYMBOL: free-registers
-
-: free-registers-for ( vreg -- seq )
- reg-class>> free-registers get at ;
-
-: deallocate-register ( live-interval -- )
- [ reg>> ] [ vreg>> ] bi free-registers-for push ;
-
-! Vector of active live intervals
-SYMBOL: active-intervals
-
-: active-intervals-for ( vreg -- seq )
- reg-class>> active-intervals get at ;
-
-: add-active ( live-interval -- )
- dup vreg>> active-intervals-for push ;
-
-: delete-active ( live-interval -- )
- dup vreg>> active-intervals-for delq ;
-
-! Vector of inactive live intervals
-SYMBOL: inactive-intervals
-
-: inactive-intervals-for ( vreg -- seq )
- reg-class>> inactive-intervals get at ;
-
-: add-inactive ( live-interval -- )
- dup vreg>> inactive-intervals-for push ;
-
-! Vector of handled live intervals
-SYMBOL: handled-intervals
-
-: add-handled ( live-interval -- )
- handled-intervals get push ;
-
-: finished? ( n live-interval -- ? ) end>> swap < ;
-
-: finish ( n live-interval -- keep? )
- nip [ deallocate-register ] [ add-handled ] bi f ;
-
-: activate ( n live-interval -- keep? )
- nip add-active f ;
-
-: deactivate ( n live-interval -- keep? )
- nip add-inactive f ;
-
-: don't-change ( n live-interval -- keep? ) 2drop t ;
-
-! Moving intervals between active and inactive sets
-: process-intervals ( n symbol quots -- )
- ! symbol stores an alist mapping register classes to vectors
- [ get values ] dip '[ [ _ cond ] with filter-here ] with each ; inline
-
-: covers? ( insn# live-interval -- ? )
- ranges>> [ [ from>> ] [ to>> ] bi between? ] with any? ;
-
-: deactivate-intervals ( n -- )
- ! Any active intervals which have ended are moved to handled
- ! Any active intervals which cover the current position
- ! are moved to inactive
- active-intervals {
- { [ 2dup finished? ] [ finish ] }
- { [ 2dup covers? not ] [ deactivate ] }
- [ don't-change ]
- } process-intervals ;
-
-: activate-intervals ( n -- )
- ! Any inactive intervals which have ended are moved to handled
- ! Any inactive intervals which do not cover the current position
- ! are moved to active
- inactive-intervals {
- { [ 2dup finished? ] [ finish ] }
- { [ 2dup covers? ] [ activate ] }
- [ don't-change ]
- } process-intervals ;
-
-! Minheap of live intervals which still need a register allocation
-SYMBOL: unhandled-intervals
-
-! Start index of current live interval. We ensure that all
-! live intervals added to the unhandled set have a start index
-! strictly greater than ths one. This ensures that we can catch
-! infinite loop situations.
-SYMBOL: progress
-
-: check-progress ( live-interval -- )
- start>> progress get <= [ "No progress" throw ] when ; inline
-
-: add-unhandled ( live-interval -- )
- [ check-progress ]
- [ dup start>> unhandled-intervals get heap-push ]
- bi ;
-
-: init-unhandled ( live-intervals -- )
- [ [ start>> ] keep ] { } map>assoc
- unhandled-intervals get heap-push-all ;
-
-! Coalescing
-: active-interval ( vreg -- live-interval )
- dup [ dup active-intervals-for [ vreg>> = ] with find nip ] when ;
-
-: coalesce? ( live-interval -- ? )
- [ start>> ] [ copy-from>> active-interval ] bi
- dup [ end>> = ] [ 2drop f ] if ;
-
-: coalesce ( live-interval -- )
- dup copy-from>> active-interval
- [ [ add-active ] [ [ delete-active ] [ add-handled ] bi ] bi* ]
- [ reg>> >>reg drop ]
- 2bi ;
-
-! Splitting
-: split-range ( live-range n -- before after )
- [ [ from>> ] dip <live-range> ]
- [ 1 + swap to>> <live-range> ]
- 2bi ;
-
-: split-last-range? ( last n -- ? )
- swap to>> <= ;
-
-: split-last-range ( before after last n -- before' after' )
- split-range [ [ but-last ] dip suffix ] [ prefix ] bi-curry* bi* ;
-
-: split-ranges ( live-ranges n -- before after )
- [ '[ from>> _ <= ] partition ]
- [
- pick empty? [ drop ] [
- [ over last ] dip 2dup split-last-range?
- [ split-last-range ] [ 2drop ] if
- ] if
- ] bi ;
-
-: split-uses ( uses n -- before after )
- '[ _ <= ] partition ;
-
-: record-split ( live-interval before after -- )
- [ >>split-before ] [ >>split-after ] bi* drop ; inline
-
-: check-split ( live-interval -- )
- [ end>> ] [ start>> ] bi - 0 =
- [ "BUG: splitting atomic interval" throw ] when ; inline
-
-: split-before ( before -- before' )
- [ [ ranges>> last ] [ uses>> last ] bi >>to drop ]
- [ compute-start/end ]
- [ ]
- tri ; inline
-
-: split-after ( after -- after' )
- [ [ ranges>> first ] [ uses>> first ] bi >>from drop ]
- [ compute-start/end ]
- [ ]
- tri ; inline
-
-:: split-interval ( live-interval n -- before after )
- live-interval check-split
- live-interval clone :> before
- live-interval clone f >>copy-from f >>reg :> after
- live-interval uses>> n split-uses before after [ (>>uses) ] bi-curry@ bi*
- live-interval ranges>> n split-ranges before after [ (>>ranges) ] bi-curry@ bi*
- live-interval before after record-split
- before split-before
- after split-after ;
-
-HINTS: split-interval live-interval object ;
-
-! Spilling
-SYMBOL: spill-counts
-
-: next-spill-location ( reg-class -- n )
- spill-counts get [ dup 1+ ] change-at ;
-
-: find-use ( live-interval n quot -- i elt )
- [ uses>> ] 2dip curry find ; inline
-
-: interval-to-spill ( active-intervals current -- live-interval )
- #! We spill the interval with the most distant use location.
- start>> '[ dup _ [ >= ] find-use nip ] { } map>assoc
- [ ] [ [ [ second ] bi@ > ] most ] map-reduce first ;
-
-: assign-spill ( before after -- before after )
- #! If it has been spilled already, reuse spill location.
- over reload-from>>
- [ over vreg>> reg-class>> next-spill-location ] unless*
- [ >>spill-to ] [ >>reload-from ] bi-curry bi* ;
-
-: split-and-spill ( new existing -- before after )
- swap start>> split-interval assign-spill ;
-
-: reuse-register ( new existing -- )
- reg>> >>reg add-active ;
-
-: spill-existing ( new existing -- )
- #! Our new interval will be used before the active interval
- #! with the most distant use location. Spill the existing
- #! interval, then process the new interval and the tail end
- #! of the existing interval again.
- [ reuse-register ]
- [ nip delete-active ]
- [ split-and-spill [ add-handled ] [ add-unhandled ] bi* ] 2tri ;
-
-: spill-new ( new existing -- )
- #! Our new interval will be used after the active interval
- #! with the most distant use location. Split the new
- #! interval, then process both parts of the new interval
- #! again.
- [ dup split-and-spill add-unhandled ] dip spill-existing ;
-
-: spill-existing? ( new existing -- ? )
- #! Test if 'new' will be used before 'existing'.
- over start>> '[ _ [ > ] find-use nip -1 or ] bi@ < ;
-
-: assign-blocked-register ( new -- )
- [ dup vreg>> active-intervals-for ] keep interval-to-spill
- 2dup spill-existing? [ spill-existing ] [ spill-new ] if ;
-
-: assign-free-register ( new registers -- )
- pop >>reg add-active ;
-
-: relevant-ranges ( new inactive -- new' inactive' )
- ! Slice off all ranges of 'inactive' that precede the start of 'new'
- [ [ ranges>> ] bi@ ] [ nip start>> ] 2bi '[ to>> _ >= ] filter ;
-
-: intersect-live-range ( range1 range2 -- n/f )
- 2dup [ from>> ] bi@ > [ swap ] when
- 2dup [ to>> ] [ from>> ] bi* >= [ nip from>> ] [ 2drop f ] if ;
-
-: intersect-live-ranges ( ranges1 ranges2 -- n )
- {
- { [ over empty? ] [ 2drop 1/0. ] }
- { [ dup empty? ] [ 2drop 1/0. ] }
- [
- 2dup [ first ] bi@ intersect-live-range dup [ 2nip ] [
- drop
- 2dup [ first from>> ] bi@ <
- [ [ rest-slice ] dip ] [ rest-slice ] if
- intersect-live-ranges
- ] if
- ]
- } cond ;
-
-: intersect-inactive ( new inactive -- n )
- relevant-ranges intersect-live-ranges ;
-
-: intersecting-inactive ( new -- live-intervals )
- dup vreg>> inactive-intervals-for
- [ tuck intersect-inactive ] with { } map>assoc ;
-
-: fits-in-hole ( new pair -- )
- first reuse-register ;
-
-: split-before-use ( new pair -- before after )
- ! Find optimal split position
- ! Insert move instruction
- second split-interval ;
-
-: assign-inactive-register ( new live-intervals -- )
- ! If there is an interval which is inactive for the entire lifetime
- ! if the new interval, reuse its vreg. Otherwise, split new so that
- ! the first half fits.
- sort-values last
- 2dup [ end>> ] [ second ] bi* < [
- fits-in-hole
- ] [
- [ split-before-use ] keep
- '[ _ fits-in-hole ] [ add-unhandled ] bi*
- ] if ;
-
: assign-register ( new -- )
dup coalesce? [ coalesce ] [
dup vreg>> free-registers-for [
if-empty
] if ;
-! Main loop
-CONSTANT: reg-classes { int-regs double-float-regs }
-
-: reg-class-assoc ( quot -- assoc )
- [ reg-classes ] dip { } map>assoc ; inline
-
-: init-allocator ( registers -- )
- [ reverse >vector ] assoc-map free-registers set
- [ 0 ] reg-class-assoc spill-counts set
- <min-heap> unhandled-intervals set
- [ V{ } clone ] reg-class-assoc active-intervals set
- [ V{ } clone ] reg-class-assoc inactive-intervals set
- V{ } clone handled-intervals set
- -1 progress set ;
-
: handle-interval ( live-interval -- )
[
start>>
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)
--- /dev/null
+! 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 ;
--- /dev/null
+! 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 ;
+
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays assocs combinators fry hints kernel locals
+math sequences sets sorting splitting
+compiler.cfg.linear-scan.allocation.state
+compiler.cfg.linear-scan.live-intervals ;
+IN: compiler.cfg.linear-scan.allocation.splitting
+
+: split-range ( live-range n -- before after )
+ [ [ from>> ] dip <live-range> ]
+ [ 1 + swap to>> <live-range> ]
+ 2bi ;
+
+: split-last-range? ( last n -- ? )
+ swap to>> <= ;
+
+: split-last-range ( before after last n -- before' after' )
+ split-range [ [ but-last ] dip suffix ] [ prefix ] bi-curry* bi* ;
+
+: split-ranges ( live-ranges n -- before after )
+ [ '[ from>> _ <= ] partition ]
+ [
+ [ over last ] dip 2dup split-last-range?
+ [ split-last-range ] [ 2drop ] if
+ ] bi ;
+
+: split-uses ( uses n -- before after )
+ '[ _ <= ] partition ;
+
+: record-split ( live-interval before after -- )
+ [ >>split-next drop ]
+ [ [ >>split-before ] [ >>split-after ] bi* drop ]
+ 2bi ; inline
+
+ERROR: splitting-too-early ;
+
+ERROR: splitting-atomic-interval ;
+
+: check-split ( live-interval n -- )
+ [ [ start>> ] dip > [ splitting-too-early ] when ]
+ [ drop [ end>> ] [ start>> ] bi - 0 = [ splitting-atomic-interval ] when ]
+ 2bi ; inline
+
+: split-before ( before -- before' )
+ f >>spill-to ; inline
+
+: split-after ( after -- after' )
+ f >>copy-from f >>reg f >>reload-from ; inline
+
+:: split-interval ( live-interval n -- before after )
+ live-interval n check-split
+ live-interval clone :> before
+ live-interval clone :> after
+ live-interval uses>> n split-uses before after [ (>>uses) ] bi-curry@ bi*
+ live-interval ranges>> n split-ranges before after [ (>>ranges) ] bi-curry@ bi*
+ live-interval before after record-split
+ before split-before
+ after split-after ;
+
+HINTS: split-interval live-interval object ;
+
+: reuse-register ( new existing -- )
+ reg>> >>reg add-active ;
+
+: relevant-ranges ( new inactive -- new' inactive' )
+ ! Slice off all ranges of 'inactive' that precede the start of 'new'
+ [ [ ranges>> ] bi@ ] [ nip start>> ] 2bi '[ to>> _ >= ] filter ;
+
+: intersect-live-range ( range1 range2 -- n/f )
+ 2dup [ from>> ] bi@ > [ swap ] when
+ 2dup [ to>> ] [ from>> ] bi* >= [ nip from>> ] [ 2drop f ] if ;
+
+: intersect-live-ranges ( ranges1 ranges2 -- n )
+ {
+ { [ over empty? ] [ 2drop 1/0. ] }
+ { [ dup empty? ] [ 2drop 1/0. ] }
+ [
+ 2dup [ first ] bi@ intersect-live-range dup [ 2nip ] [
+ drop
+ 2dup [ first from>> ] bi@ <
+ [ [ rest-slice ] dip ] [ rest-slice ] if
+ intersect-live-ranges
+ ] if
+ ]
+ } cond ;
+
+: intersect-inactive ( new inactive active-regs -- n/f )
+ ! If the interval's register is currently in use, we cannot
+ ! re-use it.
+ 2dup [ reg>> ] dip key?
+ [ 3drop f ] [ drop relevant-ranges intersect-live-ranges ] if ;
+
+: intersecting-inactive ( new -- live-intervals )
+ dup vreg>>
+ [ inactive-intervals-for ]
+ [ active-intervals-for [ reg>> ] map unique ] bi
+ '[ tuck _ intersect-inactive ] with { } map>assoc
+ [ nip ] assoc-filter ;
+
+: insert-use-for-copy ( seq n -- seq' )
+ [ 1array split1 ] keep [ 1 - ] keep 2array glue ;
+
+: split-before-use ( new n -- before after )
+ ! Find optimal split position
+ ! Insert move instruction
+ [ '[ _ insert-use-for-copy ] change-uses ] keep
+ 1 - split-interval
+ 2dup [ compute-start/end ] bi@ ;
+
+: assign-inactive-register ( new live-intervals -- )
+ ! If there is an interval which is inactive for the entire lifetime
+ ! if the new interval, reuse its vreg. Otherwise, split new so that
+ ! the first half fits.
+ sort-values last
+ 2dup [ end>> ] [ second ] bi* < [
+ first reuse-register
+ ] [
+ [ second split-before-use ] keep
+ '[ _ first reuse-register ] [ add-unhandled ] bi*
+ ] if ;
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs combinators cpu.architecture fry heaps
+kernel math namespaces sequences vectors
+compiler.cfg.linear-scan.live-intervals ;
+IN: compiler.cfg.linear-scan.allocation.state
+
+! Mapping from register classes to sequences of machine registers
+SYMBOL: free-registers
+
+: free-registers-for ( vreg -- seq )
+ reg-class>> free-registers get at ;
+
+: deallocate-register ( live-interval -- )
+ [ reg>> ] [ vreg>> ] bi free-registers-for push ;
+
+! Vector of active live intervals
+SYMBOL: active-intervals
+
+: active-intervals-for ( vreg -- seq )
+ reg-class>> active-intervals get at ;
+
+: add-active ( live-interval -- )
+ dup vreg>> active-intervals-for push ;
+
+: delete-active ( live-interval -- )
+ dup vreg>> active-intervals-for delq ;
+
+: assign-free-register ( new registers -- )
+ pop >>reg add-active ;
+
+! Vector of inactive live intervals
+SYMBOL: inactive-intervals
+
+: inactive-intervals-for ( vreg -- seq )
+ reg-class>> inactive-intervals get at ;
+
+: add-inactive ( live-interval -- )
+ dup vreg>> inactive-intervals-for push ;
+
+! Vector of handled live intervals
+SYMBOL: handled-intervals
+
+: add-handled ( live-interval -- )
+ handled-intervals get push ;
+
+: finished? ( n live-interval -- ? ) end>> swap < ;
+
+: finish ( n live-interval -- keep? )
+ nip [ deallocate-register ] [ add-handled ] bi f ;
+
+SYMBOL: check-allocation?
+
+ERROR: register-already-used live-interval ;
+
+: check-activate ( live-interval -- )
+ check-allocation? get [
+ dup [ reg>> ] [ vreg>> active-intervals-for [ reg>> ] map ] bi member?
+ [ register-already-used ] [ drop ] if
+ ] [ drop ] if ;
+
+: activate ( n live-interval -- keep? )
+ dup check-activate
+ nip add-active f ;
+
+: deactivate ( n live-interval -- keep? )
+ nip add-inactive f ;
+
+: don't-change ( n live-interval -- keep? ) 2drop t ;
+
+! Moving intervals between active and inactive sets
+: process-intervals ( n symbol quots -- )
+ ! symbol stores an alist mapping register classes to vectors
+ [ get values ] dip '[ [ _ cond ] with filter-here ] with each ; inline
+
+: deactivate-intervals ( n -- )
+ ! Any active intervals which have ended are moved to handled
+ ! Any active intervals which cover the current position
+ ! are moved to inactive
+ active-intervals {
+ { [ 2dup finished? ] [ finish ] }
+ { [ 2dup covers? not ] [ deactivate ] }
+ [ don't-change ]
+ } process-intervals ;
+
+: activate-intervals ( n -- )
+ ! Any inactive intervals which have ended are moved to handled
+ ! Any inactive intervals which do not cover the current position
+ ! are moved to active
+ inactive-intervals {
+ { [ 2dup finished? ] [ finish ] }
+ { [ 2dup covers? ] [ activate ] }
+ [ don't-change ]
+ } process-intervals ;
+
+! Minheap of live intervals which still need a register allocation
+SYMBOL: unhandled-intervals
+
+! Start index of current live interval. We ensure that all
+! live intervals added to the unhandled set have a start index
+! strictly greater than ths one. This ensures that we can catch
+! infinite loop situations.
+SYMBOL: progress
+
+: check-progress ( live-interval -- )
+ start>> progress get <= [ "No progress" throw ] when ; inline
+
+: add-unhandled ( live-interval -- )
+ [ check-progress ]
+ [ dup start>> unhandled-intervals get heap-push ]
+ bi ;
+
+CONSTANT: reg-classes { int-regs double-float-regs }
+
+: reg-class-assoc ( quot -- assoc )
+ [ reg-classes ] dip { } map>assoc ; inline
+
+SYMBOL: spill-counts
+
+: next-spill-location ( reg-class -- n )
+ spill-counts get [ dup 1 + ] change-at ;
+
+: init-allocator ( registers -- )
+ [ reverse >vector ] assoc-map free-registers set
+ [ 0 ] reg-class-assoc spill-counts set
+ <min-heap> unhandled-intervals set
+ [ V{ } clone ] reg-class-assoc active-intervals set
+ [ V{ } clone ] reg-class-assoc inactive-intervals set
+ V{ } clone handled-intervals set
+ -1 progress set ;
+
+: init-unhandled ( live-intervals -- )
+ [ [ start>> ] keep ] { } map>assoc
+ unhandled-intervals get heap-push-all ;
\ No newline at end of file
+++ /dev/null
-USING: compiler.cfg.linear-scan.assignment tools.test ;
-IN: compiler.cfg.linear-scan.assignment.tests
-
-
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
: 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 ;
: 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 ;
] [ 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
- >>regs drop ;
+: active-intervals ( insn -- intervals )
+ insn#>> pending-intervals get [ covers? ] with filter ;
-M: insn assign-before drop ;
+M: vreg-insn assign-registers-in-insn
+ dup [ active-intervals ] [ all-vregs ] bi
+ '[ vreg>> _ member? ] filter
+ register-mapping
+ >>regs drop ;
-: compute-live-registers ( -- regs )
- active-intervals get seq>> [ [ vreg>> ] [ reg>> ] bi ] { } map>assoc ;
+: compute-live-registers ( insn -- regs )
+ active-intervals register-mapping ;
: compute-live-spill-slots ( -- spill-slots )
spill-slots get values [ values ] map concat
[ [ vreg>> ] [ reload-from>> ] bi ] { } map>assoc ;
-M: ##gc assign-after
- compute-live-registers >>live-registers
+M: ##gc assign-registers-in-insn
+ dup call-next-method
+ dup compute-live-registers >>live-registers
compute-live-spill-slots >>live-spill-slots
drop ;
-M: insn assign-after drop ;
-
-: <active-intervals> ( -- obj )
- V{ } clone active-intervals boa ;
+M: insn assign-registers-in-insn drop ;
: init-assignment ( live-intervals -- )
- <active-intervals> active-intervals set
+ V{ } clone pending-intervals set
<min-heap> unhandled-intervals set
[ H{ } clone ] reg-class-assoc spill-slots set
init-unhandled ;
[
[
[
- {
- [ 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 ;
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 } }
] 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 } }
{ 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
[
! 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 ] [
{ 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
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
! 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
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 -- )
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 + ;
: 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
[ 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 ;
: 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 )
--- /dev/null
+! 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
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 ;
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
: linearize ( cfg -- mr )
flatten-cfg instructions>> ;
+local-only? off
+
[ ] [ [ ] test-stack-analysis drop ] unit-test
! Only peek once
{ 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 ;
-1 <int> -1 <int>
[ [ 0 alien-unsigned-cell swap ] [ 0 alien-signed-2 ] bi ]
compile-call
+] unit-test
+
+! Regression found while working on global register allocation
+
+: linear-scan-regression-1 ( a b c -- ) 3array , ;
+: linear-scan-regression-2 ( a b -- ) 2array , ;
+
+: linear-scan-regression ( a b c -- )
+ [ linear-scan-regression-2 ]
+ [ linear-scan-regression-1 ]
+ bi-curry bi-curry interleave ;
+
+[
+ {
+ { 1 "x" "y" }
+ { "x" "y" }
+ { 2 "x" "y" }
+ { "x" "y" }
+ { 3 "x" "y" }
+ }
+] [
+ [ { 1 2 3 } "x" "y" linear-scan-regression ] { } make
] unit-test
\ No newline at end of file
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
! Copyright (C) 2009 Marc Fauconneau.\r
! See http://factorcode.org/license.txt for BSD license.\r
-USING: accessors arrays assocs constructors fry\r
+USING: accessors arrays assocs fry\r
hashtables io kernel locals math math.order math.parser\r
math.ranges multiline sequences ;\r
IN: compression.huffman\r
{ rtable }\r
{ bits/level } ;\r
\r
-CONSTRUCTOR: huffman-decoder ( bs tdesc -- decoder )\r
+: <huffman-decoder> ( bs tdesc -- decoder )\r
+ huffman-decoder new\r
+ swap >>tdesc\r
+ swap >>bs\r
16 >>bits/level\r
[ ] [ tdesc>> ] [ bits/level>> 2^ ] tri reverse-table >>rtable ;\r
\r
! 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
+byte-vectors combinators fry grouping hashtables
compression.huffman images io.binary kernel locals
math math.bitwise math.order math.ranges multiline sequences
sorting ;
+++ /dev/null
-Slava Pestov
\ No newline at end of file
+++ /dev/null
-! Copyright (C) 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test constructors calendar kernel accessors
-combinators.short-circuit initializers math ;
-IN: constructors.tests
-
-TUPLE: stock-spread stock spread timestamp ;
-
-CONSTRUCTOR: stock-spread ( stock spread -- stock-spread )
- now >>timestamp ;
-
-SYMBOL: AAPL
-
-[ t ] [
- AAPL 1234 <stock-spread>
- {
- [ stock>> AAPL eq? ]
- [ spread>> 1234 = ]
- [ timestamp>> timestamp? ]
- } 1&&
-] unit-test
-
-TUPLE: ct1 a ;
-TUPLE: ct2 < ct1 b ;
-TUPLE: ct3 < ct2 c ;
-TUPLE: ct4 < ct3 d ;
-
-CONSTRUCTOR: ct1 ( a -- obj )
- [ 1 + ] change-a ;
-
-CONSTRUCTOR: ct2 ( a b -- obj )
- initialize-ct1
- [ 1 + ] change-a ;
-
-CONSTRUCTOR: ct3 ( a b c -- obj )
- initialize-ct1
- [ 1 + ] change-a ;
-
-CONSTRUCTOR: ct4 ( a b c d -- obj )
- initialize-ct3
- [ 1 + ] change-a ;
-
-[ 1001 ] [ 1000 <ct1> a>> ] unit-test
-[ 2 ] [ 0 0 <ct2> a>> ] unit-test
-[ 2 ] [ 0 0 0 <ct3> a>> ] unit-test
-[ 3 ] [ 0 0 0 0 <ct4> a>> ] unit-test
-
-
-TUPLE: rofl a b c ;
-CONSTRUCTOR: rofl ( b c a -- obj ) ;
-
-[ T{ rofl { a 3 } { b 1 } { c 2 } } ] [ 1 2 3 <rofl> ] unit-test
-
-
-TUPLE: default { a integer initial: 0 } ;
-
-CONSTRUCTOR: default ( -- obj ) ;
-
-[ 0 ] [ <default> a>> ] unit-test
-
-
-TUPLE: inherit1 a ;
-TUPLE: inherit2 < inherit1 a ;
-
-CONSTRUCTOR: inherit2 ( a -- obj ) ;
-
-[ T{ inherit2 f f 100 } ] [ 100 <inherit2> ] unit-test
-
-
-TUPLE: inherit3 hp max-hp ;
-TUPLE: inherit4 < inherit3 ;
-TUPLE: inherit5 < inherit3 ;
-
-CONSTRUCTOR: inherit3 ( -- obj )
- dup max-hp>> >>hp ;
-
-BACKWARD-CONSTRUCTOR: inherit4 ( -- obj )
- 10 >>max-hp ;
-
-[ 10 ] [ <inherit4> hp>> ] unit-test
-
-FORWARD-CONSTRUCTOR: inherit5 ( -- obj )
- 5 >>hp
- 10 >>max-hp ;
-
-[ 5 ] [ <inherit5> hp>> ] unit-test
+++ /dev/null
-! Copyright (C) 2009 Slava Pestov, Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs classes classes.tuple effects.parser
-fry generalizations generic.standard kernel lexer locals macros
-parser sequences slots vocabs words arrays ;
-IN: constructors
-
-! An experiment
-
-: initializer-name ( class -- word )
- name>> "initialize-" prepend ;
-
-: lookup-initializer ( class -- word/f )
- initializer-name "initializers" lookup ;
-
-: initializer-word ( class -- word )
- initializer-name
- "initializers" create-vocab create
- [ t "initializer" set-word-prop ] [ ] bi ;
-
-: define-initializer-generic ( name -- )
- initializer-word (( object -- object )) define-simple-generic ;
-
-: define-initializer ( class def -- )
- [ drop define-initializer-generic ]
- [ [ dup lookup-initializer ] dip H{ } clone define-typecheck ] 2bi ;
-
-: all-slots-assoc ( class -- slots )
- superclasses [ [ "slots" word-prop ] keep '[ _ ] { } map>assoc ] map concat ;
-
-MACRO:: slots>constructor ( class slots -- quot )
- class all-slots-assoc slots [ '[ first name>> _ = ] find-last nip ] with map :> slot-assoc
- class all-slots-assoc [ [ ] [ first initial>> ] bi ] { } map>assoc :> default-params
- slots length
- default-params length
- '[
- _ narray slot-assoc swap zip
- default-params swap assoc-union values _ firstn class boa
- ] ;
-
-:: (define-constructor) ( constructor-word class effect def -- word quot )
- constructor-word
- class def define-initializer
- class effect in>> '[ _ _ slots>constructor ] ;
-
-:: define-constructor ( constructor-word class effect def -- )
- constructor-word class effect def (define-constructor)
- class lookup-initializer
- '[ @ _ execute( obj -- obj ) ] effect define-declared ;
-
-:: define-auto-constructor ( constructor-word class effect def reverse? -- )
- constructor-word class effect def (define-constructor)
- class superclasses [ lookup-initializer ] map sift
- reverse? [ reverse ] when
- '[ @ _ [ execute( obj -- obj ) ] each ] effect define-declared ;
-
-: scan-constructor ( -- class word )
- scan-word [ name>> "<" ">" surround create-in ] keep ;
-
-: parse-constructor ( -- class word effect def )
- scan-constructor complete-effect parse-definition ;
-
-SYNTAX: CONSTRUCTOR: parse-constructor define-constructor ;
-SYNTAX: FORWARD-CONSTRUCTOR: parse-constructor f define-auto-constructor ;
-SYNTAX: BACKWARD-CONSTRUCTOR: parse-constructor t define-auto-constructor ;
-SYNTAX: AUTO-CONSTRUCTOR: parse-constructor f define-auto-constructor ;
-
-"initializers" create-vocab drop
+++ /dev/null
-Utility to simplify tuple constructors
+++ /dev/null
-extensions
[ parse-definition* ] dip
parsed ;
-: DEFINE* ( accum -- accum ) \ define-declared* parsed ;
-
SYNTAX: `TUPLE:
scan-param parsed
scan {
DBT_DEVTYP_DEVICEINTERFACE over set-DEV_BROADCAST_DEVICEW-dbcc_devicetype ;
: create-device-change-window ( -- )
- <zero-window-rect> create-window
+ <zero-window-rect> WS_OVERLAPPEDWINDOW 0 create-window
[
(device-notification-filter)
DEVICE_NOTIFY_WINDOW_HANDLE DEVICE_NOTIFY_ALL_INTERFACE_CLASSES bitor
: 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
: data-pop* ( heap -- )
data>> pop* ; inline
-: data-peek ( heap -- entry )
- data>> last ; inline
-
: data-first ( heap -- entry )
data>> first ; inline
2dup right-bounds-check?
[ drop left ] [ (child) ] if ;
-: swap-down ( m heap -- )
- [ child ] 2keep data-exchange ;
-
DEFER: down-heap
: (down-heap) ( m heap -- )
] check-something
] [ drop ] if ;
-: check-words ( words -- ) [ check-word ] each ;
-
: check-article ( article -- )
[ with-interactive-vocabs ] vocabs-quot set
>link dup '[
! 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
+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
<PRIVATE
-CONSTRUCTOR: jpeg-image ( headers bitstream -- image ) ;
+: <jpeg-image> ( headers bitstream -- image )
+ jpeg-image new swap >>bitstream swap >>headers ;
SINGLETONS: SOF DHT DAC RST SOI EOI SOS DQT DNL DRI DHP EXP
APP JPG COM TEM RES ;
TUPLE: jpeg-chunk length type data ;
-CONSTRUCTOR: jpeg-chunk ( type length data -- jpeg-chunk ) ;
+: <jpeg-chunk> ( type length data -- jpeg-chunk )
+ jpeg-chunk new
+ swap >>data
+ swap >>length
+ swap >>type ;
TUPLE: jpeg-color-info
h v quant-table dc-huff-table ac-huff-table { diff initial: 0 } id ;
-CONSTRUCTOR: jpeg-color-info ( h v quant-table -- jpeg-color-info ) ;
+: <jpeg-color-info> ( h v quant-table -- jpeg-color-info )
+ jpeg-color-info new
+ swap >>quant-table
+ swap >>v
+ swap >>h ;
: jpeg> ( -- jpeg-image ) jpeg-image get ;
! 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 ;
! 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
width height bit-depth color-type compression-method
filter-method interlace-method uncompressed ;
-CONSTRUCTOR: loading-png ( -- image )
+: <loading-png> ( -- image )
+ loading-png new
V{ } clone >>chunks ;
TUPLE: png-chunk length type data ;
-CONSTRUCTOR: png-chunk ( -- png-chunk ) ;
+: <png-chunk> ( -- png-chunk )
+ png-chunk new ; inline
CONSTANT: png-header
B{ HEX: 89 HEX: 50 HEX: 4e HEX: 47 HEX: 0d HEX: 0a HEX: 1a HEX: 0a }
! 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
SINGLETON: tiff-image
TUPLE: loading-tiff endianness the-answer ifd-offset ifds ;
-CONSTRUCTOR: loading-tiff ( -- tiff ) V{ } clone >>ifds ;
+
+: <loading-tiff> ( -- tiff )
+ loading-tiff new V{ } clone >>ifds ;
TUPLE: ifd count ifd-entries next
processed-tags strips bitmap ;
-CONSTRUCTOR: ifd ( count ifd-entries next -- ifd ) ;
+
+: <ifd> ( count ifd-entries next -- ifd )
+ ifd new
+ swap >>next
+ swap >>ifd-entries
+ swap >>count ;
TUPLE: ifd-entry tag type count offset/value ;
-CONSTRUCTOR: ifd-entry ( tag type count offset/value -- ifd-entry ) ;
+
+: <ifd-entry> ( tag type count offset/value -- ifd-entry )
+ ifd-entry new
+ swap >>offset/value
+ swap >>count
+ swap >>type
+ swap >>tag ;
SINGLETONS: photometric-interpretation
photometric-interpretation-white-is-zero
IN: io.servers.connection
TUPLE: threaded-server
-{ name initial: "server" }
-{ log-level initial: DEBUG }
-secure insecure
-{ secure-config initial-quot: [ <secure-config> ] }
-{ sockets initial-quot: [ V{ } clone ] }
+name
+log-level
+secure
+insecure
+secure-config
+sockets
max-connections
semaphore
-{ timeout initial-quot: [ 1 minutes ] }
+timeout
encoding
-{ handler initial: [ "No handler quotation" throw ] }
-{ ready initial-quot: [ <flag> ] } ;
+handler
+ready ;
: local-server ( port -- addrspec ) "localhost" swap <inet> ;
: new-threaded-server ( encoding class -- threaded-server )
new
+ "server" >>name
+ DEBUG >>log-level
+ <secure-config> >>secure-config
+ V{ } clone >>sockets
+ 1 minutes >>timeout
+ [ "No handler quotation" throw ] >>handler
+ <flag> >>ready
swap >>encoding ;
: <threaded-server> ( encoding -- threaded-server )
SYNTAX: $ scan-word expand-literal >vector ;
SYNTAX: $[ parse-quotation with-datastack >vector ;
SYNTAX: ${ \ } [ expand-literals ] parse-literal ;
+
+SYNTAX: $$
+ scan-word execute( accum -- accum ) dup pop [ >quotation ] keep
+ [ output>sequence ] 2curry call( -- object ) parsed ;
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: help.markup help.syntax math sequences ;
+USING: assocs help.markup help.syntax math sequences ;
IN: math.bitwise
HELP: bitfield
}
} ;
+HELP: symbols>flags
+{ $values { "symbols" sequence } { "assoc" assoc } { "flag-bits" integer } }
+{ $description "Constructs an integer value by mapping the values in the " { $snippet "symbols" } " sequence to integer values using " { $snippet "assoc" } " and " { $link bitor } "ing the values together." }
+{ $examples
+ { $example "USING: math.bitwise prettyprint ui.gadgets.worlds ;"
+ "IN: scratchpad"
+ "CONSTANT: window-controls>flags H{"
+ " { close-button 1 }"
+ " { minimize-button 2 }"
+ " { maximize-button 4 }"
+ " { resize-handles 8 }"
+ " { small-title-bar 16 }"
+ " { normal-title-bar 32 }"
+ "}"
+ "{ resize-handles close-button small-title-bar } window-controls>flags symbols>flags ."
+ "25"
+ }
+} ;
+
HELP: mask
{ $values
{ "x" integer } { "n" integer }
! Copyright (C) 2007, 2008 Slava Pestov, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays kernel math sequences accessors math.bits
-sequences.private words namespaces macros hints
-combinators fry io.binary combinators.smart ;
+USING: arrays assocs kernel math sequences accessors
+math.bits sequences.private words namespaces macros
+hints combinators fry io.binary combinators.smart ;
IN: math.bitwise
! utilities
MACRO: flags ( values -- )
[ 0 ] [ [ ?execute bitor ] curry compose ] reduce ;
+: symbols>flags ( symbols assoc -- flag-bits )
+ [ at ] curry map
+ 0 [ bitor ] reduce ;
+
! bitfield
<PRIVATE
{ HEX: 0503 "Stack overflow" }
{ HEX: 0504 "Stack underflow" }
{ HEX: 0505 "Out of memory" }
+ { HEX: 0506 "Invalid framebuffer operation" }
} at "Unknown error" or ;
TUPLE: gl-error code string ;
GL_PROJECTION glMatrixMode
glLoadIdentity
GL_MODELVIEW glMatrixMode
- glLoadIdentity ;
\ No newline at end of file
+ glLoadIdentity ;
! Programs
+: <mrt-gl-program> ( shaders frag-data-locations -- program )
+ glCreateProgram
+ [
+ [ swap [ glAttachShader ] with each ]
+ [ swap [ first2 swap glBindFragDataLocationEXT ] with each ] bi-curry bi*
+ ]
+ [ glLinkProgram ]
+ [ ] tri
+ gl-error ;
+
: <gl-program> ( shaders -- program )
- glCreateProgram swap
- [ dupd glAttachShader ] each
- [ glLinkProgram ] keep
+ glCreateProgram
+ [ swap [ glAttachShader ] with each ]
+ [ glLinkProgram ]
+ [ ] tri
gl-error ;
: (gl-program?) ( object -- ? )
[ dup image-locs ] dip
'[ [ _ v+ <single-texture> |dispose ] 2map ] 2map ;
-: draw-textured-grid ( grid -- )
- [ [ [ dim>> ] keep (draw-textured-rect) ] each ] each ;
-
: grid-has-alpha? ( grid -- ? )
first first image>> has-alpha? ;
IN: persistent.vectors
HELP: PV{
-{ $syntax "elements... }" }
+{ $syntax "PV{ elements... }" }
{ $description "Parses a literal " { $link persistent-vector } "." } ;
HELP: >persistent-vector
[ "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
! Copyright (C) 2007 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays assocs fry generalizations grouping
-kernel lexer macros make math math.order math.vectors
+USING: accessors arrays assocs effects fry generalizations
+grouping kernel lexer macros math math.order math.vectors
namespaces parser quotations sequences sequences.private
-splitting.monotonic stack-checker strings unicode.case
-words effects ;
+splitting.monotonic stack-checker strings unicode.case words ;
IN: roman
<PRIVATE
ERROR: roman-range-error n ;
-: roman-range-check ( n -- )
- dup 1 3999 between? [ drop ] [ roman-range-error ] if ;
+: roman-range-check ( n -- n )
+ dup 1 3999 between? [ roman-range-error ] unless ;
: roman-digit-index ( ch -- n )
1string roman-digits index ; inline
-: roman<= ( ch1 ch2 -- ? )
+: roman>= ( ch1 ch2 -- ? )
[ roman-digit-index ] bi@ >= ;
: roman>n ( ch -- n )
roman-digit-index roman-values nth ;
-: (>roman) ( n -- )
- roman-values roman-digits [
- [ /mod swap ] dip <repetition> concat %
- ] 2each drop ;
-
: (roman>) ( seq -- n )
[ [ roman>n ] map ] [ all-eq? ] bi
[ sum ] [ first2 swap - ] if ;
PRIVATE>
: >roman ( n -- str )
- dup roman-range-check [ (>roman) ] "" make ;
+ roman-range-check
+ roman-values roman-digits [
+ [ /mod swap ] dip <repetition> concat
+ ] 2map "" concat-as nip ;
: >ROMAN ( n -- str ) >roman >upper ;
: roman> ( str -- n )
- >lower [ roman<= ] monotonic-split [ (roman>) ] sigma ;
+ >lower [ roman>= ] monotonic-split [ (roman>) ] sigma ;
<PRIVATE
PRIVATE>
<<
+
SYNTAX: ROMAN-OP:
scan-word [ name>> "roman" prepend create-in ] keep
1quotation '[ _ binary-roman-op ]
dup infer [ in>> ] [ out>> ] bi
[ "string" <repetition> ] bi@ <effect> define-declared ;
+
>>
ROMAN-OP: +
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 ;
cocoa.views cocoa.windows combinators command-line
core-foundation core-foundation.run-loop core-graphics
core-graphics.types destructors fry generalizations io.thread
-kernel libc literals locals math math.rectangles memory
+kernel libc literals locals math math.bitwise math.rectangles memory
namespaces sequences specialized-arrays.int threads ui
ui.backend ui.backend.cocoa.views ui.clipboards ui.gadgets
ui.gadgets.worlds ui.pixel-formats ui.pixel-formats.private
M: cocoa-ui-backend (fullscreen?) ( world -- ? )
handle>> view>> -> isInFullScreenMode zero? not ;
+CONSTANT: window-control>styleMask
+ H{
+ { close-button $ NSClosableWindowMask }
+ { minimize-button $ NSMiniaturizableWindowMask }
+ { maximize-button 0 }
+ { resize-handles $ NSResizableWindowMask }
+ { small-title-bar $[ NSTitledWindowMask NSUtilityWindowMask bitor ] }
+ { normal-title-bar $ NSTitledWindowMask }
+ }
+
+: world>styleMask ( world -- n )
+ window-controls>> window-control>styleMask symbols>flags ;
+
M:: cocoa-ui-backend (open-window) ( world -- )
world [ [ dim>> ] dip <FactorView> ]
with-world-pixel-format :> view
- view world world>NSRect <ViewWindow> :> window
+ view world [ world>NSRect ] [ world>styleMask ] bi <ViewWindow> :> window
view -> release
world view register-window
window world window-loc>> auto-position
M: cocoa-ui-backend close-window ( gadget -- )
find-world [
handle>> [
- window>> f -> performClose:
+ window>> -> close
] when*
] when* ;
windows.messages windows.types windows.offscreen windows.nt
threads libc combinators fry combinators.short-circuit continuations
command-line shuffle opengl ui.render math.bitwise locals
-accessors math.rectangles math.order calendar ascii
+accessors math.rectangles math.order calendar ascii sets
io.encodings.utf16n windows.errors literals ui.pixel-formats
ui.pixel-formats.private memoize classes struct-arrays ;
IN: ui.backend.windows
SYMBOLS: msg-obj class-name-ptr mouse-captured ;
-: style ( -- n ) WS_OVERLAPPEDWINDOW ; inline
-: ex-style ( -- n ) WS_EX_APPWINDOW WS_EX_WINDOWEDGE bitor ; inline
+CONSTANT: window-control>style
+ H{
+ { close-button 0 }
+ { minimize-button $ WS_MINIMIZEBOX }
+ { maximize-button $ WS_MAXIMIZEBOX }
+ { resize-handles $ WS_THICKFRAME }
+ { small-title-bar $ WS_CAPTION }
+ { normal-title-bar $ WS_CAPTION }
+ }
+
+CONSTANT: window-control>ex-style
+ H{
+ { close-button 0 }
+ { minimize-button 0 }
+ { maximize-button 0 }
+ { resize-handles $ WS_EX_WINDOWEDGE }
+ { small-title-bar $ WS_EX_TOOLWINDOW }
+ { normal-title-bar $ WS_EX_APPWINDOW }
+ }
+
+: needs-sysmenu? ( controls -- ? )
+ { close-button minimize-button maximize-button } intersects? ;
+
+: has-titlebar? ( controls -- ? )
+ { small-title-bar normal-title-bar } intersects? ;
+
+: world>style ( world -- n )
+ window-controls>>
+ [ window-control>style symbols>flags ]
+ [ needs-sysmenu? [ WS_SYSMENU bitor ] when ]
+ [ has-titlebar? [ WS_POPUP bitor ] unless ] tri ;
+
+: world>ex-style ( world -- n )
+ window-controls>> window-control>ex-style symbols>flags ;
: get-RECT-top-left ( RECT -- x y )
[ RECT-left ] keep RECT-top ;
: handle-wm-size ( hWnd uMsg wParam lParam -- )
2nip
[ lo-word ] keep hi-word 2array
- dup { 0 0 } = [ 2drop ] [ swap window (>>dim) ] if ;
+ dup { 0 0 } = [ 2drop ] [ swap window [ (>>dim) ] [ drop ] if* ] if ;
: handle-wm-move ( hWnd uMsg wParam lParam -- )
2nip
[ lo-word ] keep hi-word 2array
- swap window (>>window-loc) ;
+ swap window [ (>>window-loc) ] [ drop ] if* ;
CONSTANT: wm-keydown-codes
H{
RegisterClassEx win32-error=0/f
] [ drop ] if ;
-: adjust-RECT ( RECT -- )
- style 0 ex-style AdjustWindowRectEx win32-error=0/f ;
+: adjust-RECT ( RECT style ex-style -- )
+ [ 0 ] dip AdjustWindowRectEx win32-error=0/f ;
: make-RECT ( world -- RECT )
[ window-loc>> ] [ dim>> ] bi <RECT> ;
CW_USEDEFAULT over set-RECT-left
CW_USEDEFAULT swap set-RECT-top ;
-: make-adjusted-RECT ( rect -- RECT )
- make-RECT
- dup get-RECT-top-left [ zero? ] both? swap
- dup adjust-RECT
+: make-adjusted-RECT ( rect style ex-style -- RECT )
+ [
+ make-RECT
+ dup get-RECT-top-left [ zero? ] both? swap
+ dup
+ ] 2dip adjust-RECT
swap [ dup default-position-RECT ] when ;
: get-window-class ( -- class-name )
dup
] change-global ;
-: create-window ( rect -- hwnd )
- make-adjusted-RECT
+:: create-window ( rect style ex-style -- hwnd )
+ rect style ex-style make-adjusted-RECT
[ get-window-class f ] dip
[
[ ex-style ] 2dip
- { WS_CLIPSIBLINGS WS_CLIPCHILDREN style } flags
+ WS_CLIPSIBLINGS WS_CLIPCHILDREN bitor style bitor
] dip get-RECT-dimensions
f f f GetModuleHandle f CreateWindowEx dup win32-error=0/f ;
[ swap [ handle>> hDC>> set-pixel-format ] [ get-rc ] bi ]
with-world-pixel-format ;
+: disable-close-button ( hwnd -- )
+ 0 GetSystemMenu
+ SC_CLOSE MF_BYCOMMAND MF_GRAYED bitor EnableMenuItem drop ;
+
+: ?disable-close-button ( world hwnd -- )
+ swap window-controls>> close-button swap member? not
+ [ disable-close-button ] [ drop ] if ;
+
M: windows-ui-backend (open-window) ( world -- )
- [ dup create-window [ f f ] dip f f <win> >>handle setup-gl ]
+ [
+ dup
+ [ ] [ world>style ] [ world>ex-style ] tri create-window
+ [ ?disable-close-button ]
+ [ [ f f ] dip f f <win> >>handle setup-gl ] 2bi
+ ]
[ dup handle>> hWnd>> register-window ]
[ handle>> hWnd>> show-window ] tri ;
} cleave ;
: exit-fullscreen ( world -- )
- handle>> hWnd>>
+ dup handle>> hWnd>>
{
- [
- GWL_STYLE GetWindowLong
- fullscreen-flags bitor
- ]
- [ GWL_STYLE rot SetWindowLong win32-error=0/f ]
+ [ GWL_STYLE rot world>style SetWindowLong win32-error=0/f ]
[
f
over hwnd>RECT get-RECT-dimensions
: 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 ;
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 ;
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 -- )
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
TUPLE: elevator < gadget direction ;
-: find-elevator ( gadget -- elevator/f ) [ elevator? ] find-parent ;
-
: find-slider ( gadget -- slider/f ) [ slider? ] find-parent ;
CONSTANT: elevator-padding 4
{ { $snippet "grab-input?" } " - if set to " { $link t } ", the world will hide the mouse cursor and disable normal mouse input while focused. Use " { $link grab-input } " and " { $link ungrab-input } " to change this setting." }
{ { $snippet "handle" } " - a backend-specific native handle representing the native window containing the world, or " { $link f } " if the world is not grafted." }
{ { $snippet "window-loc" } " - the on-screen location of the native window containing the world. The co-ordinate system here is backend-specific." }
+ { { $snippet "window-controls" } " - the set of " { $link "ui.gadgets.worlds-window-controls" } " with which the world window was created." }
}
} ;
{ $subsection "ui.gadgets.worlds-subclassing" }
{ $subsection "gl-utilities" }
{ $subsection "text-rendering" } ;
+
ui.pixel-formats destructors literals strings ;
IN: ui.gadgets.worlds
+SYMBOLS:
+ close-button
+ minimize-button
+ maximize-button
+ resize-handles
+ small-title-bar
+ normal-title-bar ;
+
CONSTANT: default-world-pixel-format-attributes
{ windowed double-buffered T{ depth-bits { value 16 } } }
+CONSTANT: default-world-window-controls
+ {
+ normal-title-bar
+ close-button
+ minimize-button
+ maximize-button
+ resize-handles
+ }
+
TUPLE: world < track
active? focused? grab-input?
layers
title status status-owner
text-handle handle images
window-loc
- pixel-format-attributes ;
+ pixel-format-attributes
+ window-controls ;
TUPLE: world-attributes
{ world-class initial: world }
{ title string initial: "Factor Window" }
status
gadgets
- { pixel-format-attributes initial: $ default-world-pixel-format-attributes } ;
+ { pixel-format-attributes initial: $ default-world-pixel-format-attributes }
+ { window-controls initial: $ default-world-window-controls } ;
: <world-attributes> ( -- world-attributes )
world-attributes new ; inline
[ title>> >>title ]
[ status>> >>status ]
[ pixel-format-attributes>> >>pixel-format-attributes ]
+ [ window-controls>> >>window-controls ]
[ grab-input?>> >>grab-input? ]
[ gadgets>> [ 1 track-add ] each ]
} cleave ;
{ $values { "gadget" gadget } { "title/attributes" { "a " { $link string } " or a " { $link world-attributes } " tuple" } } }
{ $description "Opens a native window containing " { $snippet "gadget" } " with the specified attributes. If a string is provided, it is used as the window title; otherwise, the window attributes are specified in a " { $link world-attributes } " tuple." } ;
+HELP: close-window
+{ $values { "gadget" gadget } }
+{ $description "Close the native window containing " { $snippet "gadget" } "." } ;
+
HELP: world-attributes
{ $values { "world-class" class } { "title" string } { "status" gadget } { "gadgets" sequence } { "pixel-format-attributes" sequence } }
{ $class-description "Tuples of this class can be passed to " { $link open-window } " to control attributes of the window opened. The following attributes can be set:" }
{ { $snippet "status" } ", if specified, is a gadget that will be used as the window's status bar." }
{ { $snippet "gadgets" } " is a sequence of gadgets that will be placed inside the window." }
{ { $snippet "pixel-format-attributes" } " is a sequence of " { $link "ui.pixel-formats-attributes" } " that the window will request for its OpenGL pixel format." }
+ { { $snippet "window-controls" } " is a sequence of " { $link "ui.gadgets.worlds-window-controls" } " that will be placed in the window." }
} ;
HELP: set-fullscreen
{ $subsection "ui-backend" } ;
ABOUT: "ui"
+
+HELP: close-button
+{ $description "Asks for a close button to be available for a window. Without a close button, a window cannot be closed by the user and must be closed by the program using " { $link close-window } "." } ;
+
+HELP: minimize-button
+{ $description "Asks for a minimize button to be available for a window." } ;
+
+HELP: maximize-button
+{ $description "Asks for a maximize button to be available for a window." } ;
+
+HELP: resize-handles
+{ $description "Asks for resize controls to be available for a window. Without resize controls, the window size will not be changeable by the user." } ;
+
+HELP: small-title-bar
+{ $description "Asks for a window to have a small title bar. Without a title bar, the " { $link close-button } ", " { $link minimize-button } ", and " { $link maximize-button } " controls will not be available. A small title bar may have other side effects in the window system, such as causing the window to not show up in the system task switcher and to float over other Factor windows." } ;
+
+HELP: normal-title-bar
+{ $description "Asks for a window to have a title bar. Without a title bar, the " { $link close-button } ", " { $link minimize-button } ", and " { $link maximize-button } " controls will not be available." } ;
+
+ARTICLE: "ui.gadgets.worlds-window-controls" "Window controls"
+"The following window controls can be placed in a " { $link world } " window:"
+{ $subsection close-button }
+{ $subsection minimize-button }
+{ $subsection maximize-button }
+{ $subsection resize-handles }
+{ $subsection small-title-bar }
+{ $subsection normal-title-bar }
+"Provide a sequence of these values in the " { $snippet "window-controls" } " slot of the " { $link world-attributes } " tuple you pass to " { $link open-window } "." ;
: 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
: 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 )
CONSTANT: SWP_DEFERERASE 8192
CONSTANT: SWP_ASYNCWINDOWPOS 16384
+CONSTANT: MF_ENABLED HEX: 0000
+CONSTANT: MF_GRAYED HEX: 0001
+CONSTANT: MF_DISABLED HEX: 0002
+CONSTANT: MF_STRING HEX: 0000
+CONSTANT: MF_BITMAP HEX: 0004
+CONSTANT: MF_UNCHECKED HEX: 0000
+CONSTANT: MF_CHECKED HEX: 0008
+CONSTANT: MF_POPUP HEX: 0010
+CONSTANT: MF_MENUBARBREAK HEX: 0020
+CONSTANT: MF_MENUBREAK HEX: 0040
+CONSTANT: MF_UNHILITE HEX: 0000
+CONSTANT: MF_HILITE HEX: 0080
+CONSTANT: MF_OWNERDRAW HEX: 0100
+CONSTANT: MF_USECHECKBITMAPS HEX: 0200
+CONSTANT: MF_BYCOMMAND HEX: 0000
+CONSTANT: MF_BYPOSITION HEX: 0400
+CONSTANT: MF_SEPARATOR HEX: 0800
+CONSTANT: MF_DEFAULT HEX: 1000
+CONSTANT: MF_SYSMENU HEX: 2000
+CONSTANT: MF_HELP HEX: 4000
+CONSTANT: MF_RIGHTJUSTIFY HEX: 4000
+CONSTANT: MF_MOUSESELECT HEX: 8000
LIBRARY: user32
! FUNCTION: DrawTextW
! FUNCTION: EditWndProc
FUNCTION: BOOL EmptyClipboard ( ) ;
-! FUNCTION: EnableMenuItem
+FUNCTION: BOOL EnableMenuItem ( HMENU hMenu, UINT uIDEnableItem, UINT uEnable ) ;
! FUNCTION: EnableScrollBar
! FUNCTION: EnableWindow
! FUNCTION: EndDeferWindowPos
! FUNCTION: GetSubMenu
! FUNCTION: GetSysColor
FUNCTION: HBRUSH GetSysColorBrush ( int nIndex ) ;
-! FUNCTION: GetSystemMenu
+FUNCTION: HMENU GetSystemMenu ( HWND hWnd, BOOL bRevert ) ;
! FUNCTION: GetSystemMetrics
! FUNCTION: GetTabbedTextExtentA
! FUNCTION: GetTabbedTextExtentW
">>"
"call-next-method"
"initial:"
- "initial-quot:"
"read-only"
"call("
"execute("
"USE: classes.tuple.parser.tests T{ parsing-corner-case {"
" x 3 }"
} "\n" join eval( -- tuple )
-] [ error>> unexpected-eof? ] must-fail-with
-
-
-[ ] [
- <" USE: sequences
- IN: classes.tuple.tests
- TUPLE: book { name initial-quot: [ "Lord of the " "Rings" append ] } ;">
- eval( -- )
-] unit-test
+] [ error>> unexpected-eof? ] must-fail-with
\ No newline at end of file
[ ] [ "IN: classes.tuple.tests TUPLE: redefine-tuple-twice ;" eval( -- ) ] unit-test
[ t ] [ \ redefine-tuple-twice symbol? ] unit-test
-
-TUPLE: lucky-number { n initial-quot: [ 64 random-bits ] } ;
-SLOT: winner?
-
-[ f ] [ 100 [ lucky-number new ] replicate all-equal? ] unit-test
-
-! Reshaping initial-quot:
-lucky-number new dup n>> 2array "luckiest-number" set
-
-[ t ] [ "luckiest-number" get first2 [ n>> ] dip = ] unit-test
-
-[ ] [ "USING: accessors random ; IN: classes.tuple.tests TUPLE: lucky-number { n initial-quot: [ 64 random-bits ] } { winner? initial-quot: [ t ] } ;" eval( -- ) ] unit-test
-
-[ t ] [ "luckiest-number" get first2 [ n>> ] dip = ] unit-test
-[ t ] [ "luckiest-number" get first winner?>> ] unit-test
PRIVATE>
-: initial-quots? ( class -- ? )
- all-slots [ initial-quot>> ] any? ;
-
: initial-values ( class -- slots )
all-slots [ initial>> ] map ;
: define-boa-check ( class -- )
dup boa-check-quot "boa-check" set-word-prop ;
-: tuple-initial-quots-quot ( class -- quot )
- all-slots [ initial-quot>> ] filter
- [
- [
- [ initial-quot>> , (( -- obj )) , \ call-effect , \ over , ]
- [ offset>> , ] bi \ set-slot ,
- ] each
- ] [ ] make f like ;
-
: tuple-prototype ( class -- prototype )
- [ initial-values ] [ over [ ] any? ] [ initial-quots? or ] tri
+ [ initial-values ] keep over [ ] any?
[ slots>tuple ] [ 2drop f ] if ;
: define-tuple-prototype ( class -- )
- dup [ tuple-prototype ] [ tuple-initial-quots-quot ] bi 2array
- dup [ ] any? [ drop f ] unless "prototype" set-word-prop ;
+ dup tuple-prototype "prototype" set-word-prop ;
: prepare-slots ( slots superclass -- slots' )
[ make-slots ] [ class-size 2 + ] bi* finalize-slots ;
: define-tuple-layout ( class -- )
dup make-tuple-layout "layout" set-word-prop ;
-: calculate-initial-value ( slot-spec -- value )
- dup initial>> [
- nip
- ] [
- dup initial-quot>> [
- nip call( -- obj )
- ] [
- drop f
- ] if*
- ] if* ;
-
: compute-slot-permutation ( new-slots old-slots -- triples )
[ [ [ name>> ] map ] bi@ [ index ] curry map ]
[ drop [ class>> ] map ]
- [ drop [ calculate-initial-value ] map ]
+ [ drop [ initial>> ] map ]
2tri 3array flip ;
: update-slot ( old-values n class initial -- value )
M: tuple hashcode* tuple-hashcode ;
M: tuple-class new
- dup "prototype" word-prop [
- first2 [ (clone) ] dip [ call( obj -- obj ) ] when*
- ] [
- tuple-layout <tuple>
- ] ?if ;
+ dup "prototype" word-prop [ (clone) ] [ tuple-layout <tuple> ] ?if ;
M: tuple-class boa
[ "boa-check" word-prop [ call ] when* ]
"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 " { $slot "disposed" } " 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" } }
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." } ;
+
<PRIVATE
-: last/first ( seq -- pair ) [ last ] [ first ] bi 2array ;
-
: bootstrap-words ( classes -- classes' )
[ bootstrap-word ] map ;
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 )" } } }
: <lexer> ( text -- lexer )
lexer new-lexer ;
+ERROR: unexpected want got ;
+
+PREDICATE: unexpected-tab < unexpected
+ got>> CHAR: \t = ;
+
+: forbid-tab ( c -- c )
+ [ CHAR: \t eq? [ "[space]" "[tab]" unexpected ] when ] keep ;
+
: skip ( i seq ? -- n )
over length
- [ [ swap CHAR: \s eq? xor ] curry find-from drop ] dip or ;
+ [ [ swap forbid-tab CHAR: \s eq? xor ] curry find-from drop ] dip or ;
: change-lexer-column ( lexer quot -- )
[ [ column>> ] [ line-text>> ] bi ] prepose keep
: scan ( -- str/f ) lexer get parse-token ;
-ERROR: unexpected want got ;
-
PREDICATE: unexpected-eof < unexpected
got>> not ;
[ 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
<PRIVATE
+: ((each)) ( seq -- n quot )
+ [ length ] keep [ nth-unsafe ] curry ; inline
+
: (each) ( seq quot -- n quot' )
- [ [ length ] keep [ nth-unsafe ] curry ] dip compose ; inline
+ [ ((each)) ] dip compose ; inline
+
+: (each-index) ( seq quot -- n quot' )
+ [ ((each)) [ keep ] curry ] dip compose ; inline
: (collect) ( quot into -- quot' )
[ [ keep ] dip set-nth-unsafe ] 2curry ; inline
: 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
-USING: kernel help.markup help.syntax sequences quotations assocs ;
+USING: assocs hashtables help.markup help.syntax kernel
+quotations sequences ;
IN: sets
ARTICLE: "sets" "Set-theoretic operations on sequences"
{ $subsection set= }
"A word used to implement the above:"
{ $subsection unique }
+"Counting elements in a sequence:"
+{ $subsection histogram }
+{ $subsection histogram* }
+"Combinators for implementing histogram:"
+{ $subsection sequence>assoc }
+{ $subsection sequence>assoc* }
+{ $subsection sequence>hashtable }
"Adding elements to sets:"
{ $subsection adjoin }
{ $subsection conjoin }
{ "seq" sequence } { "quot" quotation }
{ "newseq" sequence } }
{ $description "Maps a quotation onto a sequence, concatenates the results of the mapping, and removes duplicates." } ;
+
+HELP: histogram
+{ $values
+ { "seq" sequence }
+ { "hashtable" hashtable }
+}
+{ $examples
+ { $example "! Count the number of times an element appears in a sequence."
+ "USING: prettyprint sets ;"
+ "\"aaabc\" histogram ."
+ "H{ { 97 3 } { 98 1 } { 99 1 } }"
+ }
+}
+{ $description "Returns a hashtable where the keys are the elements of the sequence and the values are the number of times they appeared in that sequence." } ;
+
+HELP: histogram*
+{ $values
+ { "hashtable" hashtable } { "seq" sequence }
+ { "hashtable" hashtable }
+}
+{ $examples
+ { $example "! Count the number of times the elements of two sequences appear."
+ "USING: prettyprint sets ;"
+ "\"aaabc\" histogram \"aaaaaabc\" histogram* ."
+ "H{ { 97 9 } { 98 2 } { 99 2 } }"
+ }
+}
+{ $description "Takes an existing hashtable and uses " { $link histogram } " to continue counting the number of occurences of each element." } ;
+
+HELP: sequence>assoc
+{ $values
+ { "seq" sequence } { "quot" quotation } { "exemplar" "an exemplar assoc" }
+ { "assoc" assoc }
+}
+{ $examples
+ { $example "! Iterate over a sequence and increment the count at each element"
+ "USING: assocs prettyprint sets ;"
+ "\"aaabc\" [ inc-at ] H{ } sequence>assoc ."
+ "H{ { 97 3 } { 98 1 } { 99 1 } }"
+ }
+}
+{ $description "Iterates over a sequence, allowing elements of the sequence to be added to a newly created " { $snippet "assoc" } " according to the passed quotation." } ;
+
+HELP: sequence>assoc*
+{ $values
+ { "assoc" assoc } { "seq" sequence } { "quot" quotation }
+ { "assoc" assoc }
+}
+{ $examples
+ { $example "! Iterate over a sequence and add the counts to an existing assoc"
+ "USING: assocs prettyprint sets kernel ;"
+ "H{ { 97 2 } { 98 1 } } clone \"aaabc\" [ inc-at ] sequence>assoc* ."
+ "H{ { 97 5 } { 98 2 } { 99 1 } }"
+ }
+}
+{ $description "Iterates over a sequence, allowing elements of the sequence to be added to an existing " { $snippet "assoc" } " according to the passed quotation." } ;
+
+HELP: sequence>hashtable
+{ $values
+ { "seq" sequence } { "quot" quotation }
+ { "hashtable" hashtable }
+}
+{ $examples
+ { $example "! Count the number of times an element occurs in a sequence"
+ "USING: assocs prettyprint sets ;"
+ "\"aaabc\" [ inc-at ] sequence>hashtable ."
+ "H{ { 97 3 } { 98 1 } { 99 1 } }"
+ }
+}
+{ $description "Iterates over a sequence, allowing elements of the sequence to be added to a hashtable according to the passed quotation." } ;
[ f ] [ { } { 1 } intersects? ] unit-test
[ f ] [ { 1 } { } intersects? ] unit-test
+
+[
+ H{
+ { 97 2 }
+ { 98 2 }
+ { 99 2 }
+ }
+] [
+ "aabbcc" histogram
+] unit-test
: set= ( seq1 seq2 -- ? )
[ unique ] bi@ = ;
+
+<PRIVATE
+
+: (sequence>assoc) ( seq quot assoc -- assoc )
+ [ swap curry each ] keep ; inline
+
+PRIVATE>
+
+: sequence>assoc* ( assoc seq quot: ( obj assoc -- ) -- assoc )
+ rot (sequence>assoc) ; inline
+
+: sequence>assoc ( seq quot: ( obj assoc -- ) exemplar -- assoc )
+ clone (sequence>assoc) ; inline
+
+: sequence>hashtable ( seq quot: ( obj hashtable -- ) -- hashtable )
+ H{ } sequence>assoc ; inline
+
+: histogram* ( hashtable seq -- hashtable )
+ [ inc-at ] sequence>assoc* ;
+
+: histogram ( seq -- hashtable )
+ [ inc-at ] sequence>hashtable ;
words sequences.private assocs alien quotations hashtables ;
IN: slots
-TUPLE: slot-spec name offset class initial initial-quot read-only ;
+TUPLE: slot-spec name offset class initial read-only ;
PREDICATE: reader < word "reader" word-prop ;
dup empty? [
unclip {
{ initial: [ [ first >>initial ] [ rest ] bi ] }
- { initial-quot: [ [ first >>initial-quot ] [ rest ] bi ] }
{ read-only [ [ t >>read-only ] dip ] }
[ bad-slot-attribute ]
} case
ERROR: bad-initial-value name ;
-ERROR: duplicate-initial-values slot ;
-
-: check-duplicate-initial-values ( slot-spec -- slot-spec )
- dup [ initial>> ] [ initial-quot>> ] bi and
- [ duplicate-initial-values ] when ;
-
: check-initial-value ( slot-spec -- slot-spec )
- check-duplicate-initial-values
dup initial>> [
[ ] [
dup [ initial>> ] [ class>> ] bi instance?
"initial:" "syntax" lookup define-symbol
- "initial-quot:" "syntax" lookup define-symbol
-
"read-only" "syntax" lookup define-symbol
"call(" [ \ call-effect parse-call( ] define-core-syntax
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test constructors calendar kernel accessors
+combinators.short-circuit initializers math ;
+IN: constructors.tests
+
+TUPLE: stock-spread stock spread timestamp ;
+
+CONSTRUCTOR: stock-spread ( stock spread -- stock-spread )
+ now >>timestamp ;
+
+SYMBOL: AAPL
+
+[ t ] [
+ AAPL 1234 <stock-spread>
+ {
+ [ stock>> AAPL eq? ]
+ [ spread>> 1234 = ]
+ [ timestamp>> timestamp? ]
+ } 1&&
+] unit-test
+
+TUPLE: ct1 a ;
+TUPLE: ct2 < ct1 b ;
+TUPLE: ct3 < ct2 c ;
+TUPLE: ct4 < ct3 d ;
+
+CONSTRUCTOR: ct1 ( a -- obj )
+ [ 1 + ] change-a ;
+
+CONSTRUCTOR: ct2 ( a b -- obj )
+ initialize-ct1
+ [ 1 + ] change-a ;
+
+CONSTRUCTOR: ct3 ( a b c -- obj )
+ initialize-ct1
+ [ 1 + ] change-a ;
+
+CONSTRUCTOR: ct4 ( a b c d -- obj )
+ initialize-ct3
+ [ 1 + ] change-a ;
+
+[ 1001 ] [ 1000 <ct1> a>> ] unit-test
+[ 2 ] [ 0 0 <ct2> a>> ] unit-test
+[ 2 ] [ 0 0 0 <ct3> a>> ] unit-test
+[ 3 ] [ 0 0 0 0 <ct4> a>> ] unit-test
+
+
+TUPLE: rofl a b c ;
+CONSTRUCTOR: rofl ( b c a -- obj ) ;
+
+[ T{ rofl { a 3 } { b 1 } { c 2 } } ] [ 1 2 3 <rofl> ] unit-test
+
+
+TUPLE: default { a integer initial: 0 } ;
+
+CONSTRUCTOR: default ( -- obj ) ;
+
+[ 0 ] [ <default> a>> ] unit-test
+
+
+TUPLE: inherit1 a ;
+TUPLE: inherit2 < inherit1 a ;
+
+CONSTRUCTOR: inherit2 ( a -- obj ) ;
+
+[ T{ inherit2 f f 100 } ] [ 100 <inherit2> ] unit-test
+
+
+TUPLE: inherit3 hp max-hp ;
+TUPLE: inherit4 < inherit3 ;
+TUPLE: inherit5 < inherit3 ;
+
+CONSTRUCTOR: inherit3 ( -- obj )
+ dup max-hp>> >>hp ;
+
+BACKWARD-CONSTRUCTOR: inherit4 ( -- obj )
+ 10 >>max-hp ;
+
+[ 10 ] [ <inherit4> hp>> ] unit-test
+
+FORWARD-CONSTRUCTOR: inherit5 ( -- obj )
+ 5 >>hp
+ 10 >>max-hp ;
+
+[ 5 ] [ <inherit5> hp>> ] unit-test
--- /dev/null
+! Copyright (C) 2009 Slava Pestov, Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs classes classes.tuple effects.parser
+fry generalizations generic.standard kernel lexer locals macros
+parser sequences slots vocabs words arrays ;
+IN: constructors
+
+! An experiment
+
+: initializer-name ( class -- word )
+ name>> "initialize-" prepend ;
+
+: lookup-initializer ( class -- word/f )
+ initializer-name "initializers" lookup ;
+
+: initializer-word ( class -- word )
+ initializer-name
+ "initializers" create-vocab create
+ [ t "initializer" set-word-prop ] [ ] bi ;
+
+: define-initializer-generic ( name -- )
+ initializer-word (( object -- object )) define-simple-generic ;
+
+: define-initializer ( class def -- )
+ [ drop define-initializer-generic ]
+ [ [ dup lookup-initializer ] dip H{ } clone define-typecheck ] 2bi ;
+
+: all-slots-assoc ( class -- slots )
+ superclasses [ [ "slots" word-prop ] keep '[ _ ] { } map>assoc ] map concat ;
+
+MACRO:: slots>constructor ( class slots -- quot )
+ class all-slots-assoc slots [ '[ first name>> _ = ] find-last nip ] with map :> slot-assoc
+ class all-slots-assoc [ [ ] [ first initial>> ] bi ] { } map>assoc :> default-params
+ slots length
+ default-params length
+ '[
+ _ narray slot-assoc swap zip
+ default-params swap assoc-union values _ firstn class boa
+ ] ;
+
+:: (define-constructor) ( constructor-word class effect def -- word quot )
+ constructor-word
+ class def define-initializer
+ class effect in>> '[ _ _ slots>constructor ] ;
+
+:: define-constructor ( constructor-word class effect def -- )
+ constructor-word class effect def (define-constructor)
+ class lookup-initializer
+ '[ @ _ execute( obj -- obj ) ] effect define-declared ;
+
+:: define-auto-constructor ( constructor-word class effect def reverse? -- )
+ constructor-word class effect def (define-constructor)
+ class superclasses [ lookup-initializer ] map sift
+ reverse? [ reverse ] when
+ '[ @ _ [ execute( obj -- obj ) ] each ] effect define-declared ;
+
+: scan-constructor ( -- class word )
+ scan-word [ name>> "<" ">" surround create-in ] keep ;
+
+: parse-constructor ( -- class word effect def )
+ scan-constructor complete-effect parse-definition ;
+
+SYNTAX: CONSTRUCTOR: parse-constructor define-constructor ;
+SYNTAX: FORWARD-CONSTRUCTOR: parse-constructor f define-auto-constructor ;
+SYNTAX: BACKWARD-CONSTRUCTOR: parse-constructor t define-auto-constructor ;
+SYNTAX: AUTO-CONSTRUCTOR: parse-constructor f define-auto-constructor ;
+
+"initializers" create-vocab drop
--- /dev/null
+Utility to simplify tuple constructors
--- /dev/null
+extensions
[ -1.5 ] [ HEX: be00 bits>half ] unit-test
[ 1/0. ] [ HEX: 7c00 bits>half ] unit-test
[ -1/0. ] [ HEX: fc00 bits>half ] unit-test
-[ t ] [ HEX: 7e00 bits>half fp-nan? ] unit-test
+[ t ] [ HEX: 7e00 bits>half fp-nan? ] unit-test
C-STRUCT: halves
{ "half" "tom" }
--- /dev/null
+Open windows with different control sets
--- /dev/null
+! (c)2009 Joe Groff bsd license
+USING: accessors assocs kernel locals sequences ui
+ui.gadgets ui.gadgets.worlds ;
+IN: window-controls-demo
+
+CONSTANT: window-control-sets-to-test
+ H{
+ { "No controls" { } }
+ { "Normal title bar" { normal-title-bar } }
+ { "Small title bar" { small-title-bar close-button } }
+ { "Close button" { normal-title-bar close-button } }
+ { "Close and minimize buttons" { normal-title-bar close-button minimize-button } }
+ { "Minimize button" { normal-title-bar minimize-button } }
+ { "Close, minimize, and maximize buttons" { normal-title-bar close-button minimize-button maximize-button } }
+ { "Resizable" { normal-title-bar close-button minimize-button maximize-button resize-handles } }
+ }
+
+TUPLE: window-controls-demo-world < world
+ windows ;
+
+M: window-controls-demo-world end-world
+ windows>> [ close-window ] each ;
+
+M: window-controls-demo-world pref-dim*
+ drop { 400 400 } ;
+
+: attributes-template ( -- x )
+ T{ world-attributes
+ { world-class window-controls-demo-world }
+ } clone ;
+
+: window-controls-demo ( -- )
+ attributes-template V{ } clone window-control-sets-to-test
+ [| title attributes windows controls |
+ f attributes
+ title >>title
+ controls >>window-controls
+ open-window*
+ windows >>windows
+ windows push
+ ] with with assoc-each ;
+
+MAIN: window-controls-demo
(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))
projects / factor.git / commitdiff