diff --git a/basis/bitstreams/bitstreams.factor b/basis/bitstreams/bitstreams.factor
index cb6a753735..4718f137e4 100644
--- a/basis/bitstreams/bitstreams.factor
+++ b/basis/bitstreams/bitstreams.factor
@@ -158,3 +158,9 @@ M: msb0-bit-reader peek ( n bs -- bits ) \ be> \ subseq>bits-be (peek) ;
writer bytes>> swap push
] unless
writer bytes>> ;
+
+:: byte-array-n>seq ( byte-array n -- seq )
+ byte-array length 8 * n / iota
+ byte-array <msb0-bit-reader> '[
+ drop n _ read
+ ] { } map-as ;
diff --git a/basis/compiler/cfg/build-stack-frame/build-stack-frame.factor b/basis/compiler/cfg/build-stack-frame/build-stack-frame.factor
new file mode 100644
index 0000000000..e5be2d9eb9
--- /dev/null
+++ b/basis/compiler/cfg/build-stack-frame/build-stack-frame.factor
@@ -0,0 +1,74 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: namespaces accessors math.order assocs kernel sequences
+combinators make classes words cpu.architecture
+compiler.cfg.instructions compiler.cfg.registers
+compiler.cfg.stack-frame ;
+IN: compiler.cfg.build-stack-frame
+
+SYMBOL: frame-required?
+
+SYMBOL: spill-counts
+
+GENERIC: compute-stack-frame* ( insn -- )
+
+: request-stack-frame ( stack-frame -- )
+ stack-frame [ max-stack-frame ] change ;
+
+M: ##stack-frame compute-stack-frame*
+ frame-required? on
+ stack-frame>> request-stack-frame ;
+
+M: ##call compute-stack-frame*
+ word>> sub-primitive>> [ frame-required? on ] unless ;
+
+M: _gc compute-stack-frame*
+ frame-required? on
+ stack-frame new swap gc-root-size>> >>gc-root-size
+ request-stack-frame ;
+
+M: _spill-counts compute-stack-frame*
+ counts>> stack-frame get (>>spill-counts) ;
+
+M: insn compute-stack-frame*
+ class frame-required? word-prop [
+ frame-required? on
+ ] when ;
+
+\ _spill t frame-required? set-word-prop
+\ ##fixnum-add t frame-required? set-word-prop
+\ ##fixnum-sub t frame-required? set-word-prop
+\ ##fixnum-mul t frame-required? set-word-prop
+\ ##fixnum-add-tail f frame-required? set-word-prop
+\ ##fixnum-sub-tail f frame-required? set-word-prop
+\ ##fixnum-mul-tail f frame-required? set-word-prop
+
+: compute-stack-frame ( insns -- )
+ frame-required? off
+ T{ stack-frame } clone stack-frame set
+ [ compute-stack-frame* ] each
+ stack-frame get dup stack-frame-size >>total-size drop ;
+
+GENERIC: insert-pro/epilogues* ( insn -- )
+
+M: ##stack-frame insert-pro/epilogues* drop ;
+
+M: ##prologue insert-pro/epilogues*
+ drop frame-required? get [ stack-frame get _prologue ] when ;
+
+M: ##epilogue insert-pro/epilogues*
+ drop frame-required? get [ stack-frame get _epilogue ] when ;
+
+M: insn insert-pro/epilogues* , ;
+
+: insert-pro/epilogues ( insns -- insns )
+ [ [ insert-pro/epilogues* ] each ] { } make ;
+
+: build-stack-frame ( mr -- mr )
+ [
+ [
+ [ compute-stack-frame ]
+ [ insert-pro/epilogues ]
+ bi
+ ] change-instructions
+ ] with-scope ;
diff --git a/basis/compiler/cfg/stack-frame/summary.txt b/basis/compiler/cfg/build-stack-frame/summary.txt
similarity index 100%
rename from basis/compiler/cfg/stack-frame/summary.txt
rename to basis/compiler/cfg/build-stack-frame/summary.txt
diff --git a/basis/compiler/cfg/builder/builder.factor b/basis/compiler/cfg/builder/builder.factor
index 38075c24a3..d323263fc7 100755
--- a/basis/compiler/cfg/builder/builder.factor
+++ b/basis/compiler/cfg/builder/builder.factor
@@ -15,6 +15,7 @@ compiler.cfg.iterator
compiler.cfg.utilities
compiler.cfg.registers
compiler.cfg.intrinsics
+compiler.cfg.stack-frame
compiler.cfg.instructions
compiler.alien ;
IN: compiler.cfg.builder
diff --git a/basis/compiler/cfg/def-use/def-use.factor b/basis/compiler/cfg/def-use/def-use.factor
index 1484b3ec72..4ff9814e6d 100644
--- a/basis/compiler/cfg/def-use/def-use.factor
+++ b/basis/compiler/cfg/def-use/def-use.factor
@@ -8,14 +8,6 @@ GENERIC: temp-vregs ( insn -- seq )
GENERIC: uses-vregs ( insn -- seq )
M: ##flushable defs-vregs dst>> 1array ;
-M: ##unary/temp defs-vregs dst>> 1array ;
-M: ##allot defs-vregs dst>> 1array ;
-M: ##slot defs-vregs dst>> 1array ;
-M: ##set-slot defs-vregs temp>> 1array ;
-M: ##string-nth defs-vregs dst>> 1array ;
-M: ##compare defs-vregs dst>> 1array ;
-M: ##compare-imm defs-vregs dst>> 1array ;
-M: ##compare-float defs-vregs dst>> 1array ;
M: insn defs-vregs drop f ;
M: ##write-barrier temp-vregs [ card#>> ] [ table>> ] bi 2array ;
@@ -31,6 +23,7 @@ M: ##compare-imm temp-vregs temp>> 1array ;
M: ##compare-float temp-vregs temp>> 1array ;
M: ##fixnum-mul temp-vregs [ temp1>> ] [ temp2>> ] bi 2array ;
M: ##fixnum-mul-tail temp-vregs [ temp1>> ] [ temp2>> ] bi 2array ;
+M: ##gc temp-vregs [ temp1>> ] [ temp2>> ] bi 2array ;
M: _dispatch temp-vregs temp>> 1array ;
M: insn temp-vregs drop f ;
@@ -51,7 +44,6 @@ M: ##alien-getter uses-vregs src>> 1array ;
M: ##alien-setter uses-vregs [ src>> ] [ value>> ] bi 2array ;
M: ##fixnum-overflow uses-vregs [ src1>> ] [ src2>> ] bi 2array ;
M: ##phi uses-vregs inputs>> ;
-M: ##gc uses-vregs live-in>> ;
M: _conditional-branch uses-vregs [ src1>> ] [ src2>> ] bi 2array ;
M: _compare-imm-branch uses-vregs src1>> 1array ;
M: _dispatch uses-vregs src>> 1array ;
diff --git a/basis/compiler/cfg/gc-checks/gc-checks.factor b/basis/compiler/cfg/gc-checks/gc-checks.factor
index 91e79ea2dd..4176914126 100644
--- a/basis/compiler/cfg/gc-checks/gc-checks.factor
+++ b/basis/compiler/cfg/gc-checks/gc-checks.factor
@@ -2,7 +2,8 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel sequences assocs
cpu.architecture compiler.cfg.rpo
-compiler.cfg.liveness compiler.cfg.instructions ;
+compiler.cfg.liveness compiler.cfg.instructions
+compiler.cfg.hats ;
IN: compiler.cfg.gc-checks
: gc? ( bb -- ? )
@@ -13,9 +14,7 @@ IN: compiler.cfg.gc-checks
: insert-gc-check ( basic-block -- )
dup gc? [
- dup
- [ swap object-pointer-regs \ ##gc new-insn prefix ]
- change-instructions drop
+ [ i i f f \ ##gc new-insn prefix ] change-instructions drop
] [ drop ] if ;
: insert-gc-checks ( cfg -- cfg' )
diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor
index 314a66ba9c..fe853cf490 100644
--- a/basis/compiler/cfg/instructions/instructions.factor
+++ b/basis/compiler/cfg/instructions/instructions.factor
@@ -52,12 +52,6 @@ INSN: ##inc-d { n integer } ;
INSN: ##inc-r { n integer } ;
! Subroutine calls
-TUPLE: stack-frame
-{ params integer }
-{ return integer }
-{ total-size integer }
-spill-counts ;
-
INSN: ##stack-frame stack-frame ;
INSN: ##call word { height integer } ;
INSN: ##jump word ;
@@ -223,7 +217,7 @@ INSN: ##compare-imm < ##binary-imm cc temp ;
INSN: ##compare-float-branch < ##conditional-branch ;
INSN: ##compare-float < ##binary cc temp ;
-INSN: ##gc live-in ;
+INSN: ##gc { temp1 vreg } { temp2 vreg } live-registers live-spill-slots ;
! Instructions used by machine IR only.
INSN: _prologue stack-frame ;
@@ -243,6 +237,10 @@ INSN: _compare-imm-branch label { src1 vreg } { src2 integer } cc ;
INSN: _compare-float-branch < _conditional-branch ;
+TUPLE: spill-slot n ; C: <spill-slot> spill-slot
+
+INSN: _gc { temp1 vreg } { temp2 vreg } gc-roots gc-root-count gc-root-size ;
+
! These instructions operate on machine registers and not
! virtual registers
INSN: _spill src class n ;
diff --git a/basis/compiler/cfg/linear-scan/allocation/allocation.factor b/basis/compiler/cfg/linear-scan/allocation/allocation.factor
index 908bf2475b..fa10ecfca4 100644
--- a/basis/compiler/cfg/linear-scan/allocation/allocation.factor
+++ b/basis/compiler/cfg/linear-scan/allocation/allocation.factor
@@ -1,9 +1,9 @@
-! Copyright (C) 2008 Slava Pestov.
+! 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 combinators
-compiler.cfg.registers
-compiler.cfg.linear-scan.live-intervals ;
+accessors vectors fry heaps cpu.architecture sorting locals
+combinators compiler.cfg.registers
+compiler.cfg.linear-scan.live-intervals hints ;
IN: compiler.cfg.linear-scan.allocation
! Mapping from register classes to sequences of machine registers
@@ -27,13 +27,61 @@ SYMBOL: active-intervals
: delete-active ( live-interval -- )
dup vreg>> active-intervals-for delq ;
-: expire-old-intervals ( n -- )
- active-intervals swap '[
- [
- [ end>> _ < ] partition
- [ [ deallocate-register ] each ] dip
- ] assoc-map
- ] change ;
+! 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
@@ -66,29 +114,64 @@ SYMBOL: progress
: coalesce ( live-interval -- )
dup copy-from>> active-interval
- [ [ add-active ] [ delete-active ] bi* ]
+ [ [ add-active ] [ [ delete-active ] [ add-handled ] bi ] bi* ]
[ reg>> >>reg drop ]
2bi ;
! Splitting
-: find-use ( live-interval n quot -- i elt )
- [ uses>> ] 2dip curry find ; inline
+: split-range ( live-range n -- before after )
+ [ [ from>> ] dip <live-range> ]
+ [ 1 + swap to>> <live-range> ]
+ 2bi ;
-: split-before ( live-interval i -- before )
- [ clone dup uses>> ] dip
- [ head >>uses ] [ 1- swap nth >>end ] 2bi ;
+: split-last-range? ( last n -- ? )
+ swap to>> <= ;
-: split-after ( live-interval i -- after )
- [ clone dup uses>> ] dip
- [ tail >>uses ] [ swap nth >>start ] 2bi
- f >>reg f >>copy-from ;
+: split-last-range ( before after last n -- before' after' )
+ split-range [ [ but-last ] dip suffix ] [ prefix ] bi-curry* bi* ;
-: split-interval ( live-interval n -- before after )
- [ drop ] [ [ > ] find-use drop ] 2bi
- [ split-before ] [ split-after ] 2bi ;
+: 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 ;
+ [ >>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
@@ -96,6 +179,9 @@ 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
@@ -108,8 +194,7 @@ SYMBOL: spill-counts
[ >>spill-to ] [ >>reload-from ] bi-curry bi* ;
: split-and-spill ( new existing -- before after )
- dup rot start>> split-interval
- [ record-split ] [ assign-spill ] 2bi ;
+ swap start>> split-interval assign-spill ;
: reuse-register ( new existing -- )
reg>> >>reg add-active ;
@@ -121,7 +206,7 @@ SYMBOL: spill-counts
#! of the existing interval again.
[ reuse-register ]
[ nip delete-active ]
- [ split-and-spill [ drop ] [ add-unhandled ] bi* ] 2tri ;
+ [ split-and-spill [ add-handled ] [ add-unhandled ] bi* ] 2tri ;
: spill-new ( new existing -- )
#! Our new interval will be used after the active interval
@@ -141,37 +226,78 @@ SYMBOL: spill-counts
: assign-free-register ( new registers -- )
pop >>reg add-active ;
-: assign-register ( new -- )
- dup coalesce? [
- coalesce
+: next-intersection ( new inactive -- n )
+ 2drop 0 ;
+
+: intersecting-inactive ( new -- live-intervals )
+ dup vreg>> inactive-intervals-for
+ [ tuck next-intersection ] with { } map>assoc ;
+
+: fits-in-hole ( new pair -- )
+ first reuse-register ;
+
+: split-before-use ( new pair -- before after )
+ ! Find optimal split position
+ 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
] [
- dup vreg>> free-registers-for
- [ assign-blocked-register ]
- [ assign-free-register ]
+ [ split-before-use ] keep
+ '[ _ fits-in-hole ] [ add-unhandled ] bi*
+ ] if ;
+
+: assign-register ( new -- )
+ dup coalesce? [ coalesce ] [
+ dup vreg>> free-registers-for [
+ dup intersecting-inactive
+ [ assign-blocked-register ]
+ [ assign-inactive-register ]
+ if-empty
+ ] [ assign-free-register ]
if-empty
] if ;
! Main loop
: reg-classes ( -- seq ) { int-regs double-float-regs } ; inline
+: reg-class-assoc ( quot -- assoc )
+ [ reg-classes ] dip { } map>assoc ; inline
+
: init-allocator ( registers -- )
- <min-heap> unhandled-intervals set
[ reverse >vector ] assoc-map free-registers set
- reg-classes [ 0 ] { } map>assoc spill-counts set
- reg-classes [ V{ } clone ] { } map>assoc active-intervals 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>> progress set ]
- [ start>> expire-old-intervals ]
- [ assign-register ]
- tri ;
+ [
+ start>>
+ [ progress set ]
+ [ deactivate-intervals ]
+ [ activate-intervals ] tri
+ ] [ assign-register ] bi ;
: (allocate-registers) ( -- )
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
- dup init-unhandled
- (allocate-registers) ;
+ init-unhandled
+ (allocate-registers)
+ finish-allocation
+ handled-intervals get ;
diff --git a/basis/compiler/cfg/linear-scan/assignment/assignment.factor b/basis/compiler/cfg/linear-scan/assignment/assignment.factor
index c7e3380f83..4a9b0b231d 100644
--- a/basis/compiler/cfg/linear-scan/assignment/assignment.factor
+++ b/basis/compiler/cfg/linear-scan/assignment/assignment.factor
@@ -25,12 +25,7 @@ TUPLE: active-intervals seq ;
SYMBOL: unhandled-intervals
: add-unhandled ( live-interval -- )
- dup split-before>> [
- [ split-before>> ] [ split-after>> ] bi
- [ add-unhandled ] bi@
- ] [
- dup start>> unhandled-intervals get heap-push
- ] if ;
+ dup start>> unhandled-intervals get heap-push ;
: init-unhandled ( live-intervals -- )
[ add-unhandled ] each ;
@@ -58,17 +53,34 @@ SYMBOL: unhandled-intervals
] [ 2drop ] if
] if ;
-GENERIC: assign-registers-in-insn ( insn -- )
+GENERIC: assign-before ( insn -- )
+
+GENERIC: assign-after ( insn -- )
: all-vregs ( insn -- vregs )
[ defs-vregs ] [ temp-vregs ] [ uses-vregs ] tri 3append ;
-M: vreg-insn assign-registers-in-insn
+M: vreg-insn assign-before
active-intervals get seq>> over all-vregs '[ vreg>> _ member? ] filter
[ [ vreg>> ] [ reg>> ] bi ] { } map>assoc
>>regs drop ;
-M: insn assign-registers-in-insn drop ;
+M: insn assign-before drop ;
+
+: compute-live-registers ( -- regs )
+ active-intervals get seq>> [ [ vreg>> ] [ reg>> ] bi ] { } map>assoc ;
+
+: compute-live-spill-slots ( -- spill-slots )
+ unhandled-intervals get
+ heap-values [ reload-from>> ] filter
+ [ [ vreg>> ] [ reload-from>> ] bi ] { } map>assoc ;
+
+M: ##gc assign-after
+ 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 ;
@@ -82,10 +94,13 @@ M: insn assign-registers-in-insn drop ;
[
[
[
- [ insn#>> activate-new-intervals ]
- [ [ assign-registers-in-insn ] [ , ] bi ]
- [ insn#>> expire-old-intervals ]
- tri
+ {
+ [ insn#>> activate-new-intervals ]
+ [ assign-before ]
+ [ , ]
+ [ insn#>> expire-old-intervals ]
+ [ assign-after ]
+ } cleave
] each
] V{ } make
] change-instructions drop ;
diff --git a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor
index 030d8503e9..cf4daa3ab0 100644
--- a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor
+++ b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor
@@ -12,6 +12,60 @@ compiler.cfg.linear-scan.live-intervals
compiler.cfg.linear-scan.allocation
compiler.cfg.linear-scan.debugger ;
+[
+ { T{ live-range f 1 10 } T{ live-range f 15 15 } }
+ { T{ live-range f 16 20 } }
+] [
+ {
+ T{ live-range f 1 10 }
+ T{ live-range f 15 20 }
+ } 15 split-ranges
+] unit-test
+
+[
+ { T{ live-range f 1 10 } T{ live-range f 15 16 } }
+ { T{ live-range f 17 20 } }
+] [
+ {
+ T{ live-range f 1 10 }
+ T{ live-range f 15 20 }
+ } 16 split-ranges
+] unit-test
+
+[
+ { T{ live-range f 1 10 } }
+ { T{ live-range f 15 20 } }
+] [
+ {
+ T{ live-range f 1 10 }
+ T{ live-range f 15 20 }
+ } 12 split-ranges
+] unit-test
+
+[
+ { T{ live-range f 1 10 } T{ live-range f 15 17 } }
+ { T{ live-range f 18 20 } }
+] [
+ {
+ T{ live-range f 1 10 }
+ T{ live-range f 15 20 }
+ } 17 split-ranges
+] unit-test
+
+[
+ { }
+ { T{ live-range f 1 10 } }
+] [
+ { T{ live-range f 1 10 } } 0 split-ranges
+] unit-test
+
+[
+ { T{ live-range f 0 0 } }
+ { T{ live-range f 1 5 } }
+] [
+ { T{ live-range f 0 5 } } 0 split-ranges
+] unit-test
+
[ 7 ] [
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 2 } } }
@@ -44,23 +98,26 @@ compiler.cfg.linear-scan.debugger ;
[
T{ live-interval
- { vreg T{ vreg { reg-class int-regs } { n 1 } } }
- { start 0 }
- { end 1 }
- { uses V{ 0 1 } }
+ { vreg T{ vreg { reg-class int-regs } { n 1 } } }
+ { start 0 }
+ { end 1 }
+ { uses V{ 0 1 } }
+ { ranges V{ T{ live-range f 0 1 } } }
}
T{ live-interval
- { vreg T{ vreg { reg-class int-regs } { n 1 } } }
- { start 5 }
- { end 5 }
- { uses V{ 5 } }
+ { vreg T{ vreg { reg-class int-regs } { n 1 } } }
+ { start 5 }
+ { end 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 } }
+ { 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 } } }
} 2 split-interval
] unit-test
@@ -70,12 +127,14 @@ compiler.cfg.linear-scan.debugger ;
{ 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
@@ -83,6 +142,7 @@ compiler.cfg.linear-scan.debugger ;
{ start 0 }
{ end 5 }
{ uses V{ 0 1 5 } }
+ { ranges V{ T{ live-range f 0 5 } } }
} 0 split-interval
] unit-test
@@ -173,7 +233,13 @@ compiler.cfg.linear-scan.debugger ;
[ ] [
{
- T{ live-interval { vreg T{ vreg { n 1 } { reg-class int-regs } } } { start 0 } { end 100 } { uses V{ 0 100 } } }
+ T{ live-interval
+ { vreg T{ vreg { n 1 } { reg-class int-regs } } }
+ { start 0 }
+ { end 100 }
+ { uses V{ 0 100 } }
+ { ranges V{ T{ live-range f 0 100 } } }
+ }
}
H{ { int-regs { "A" } } }
check-linear-scan
@@ -181,8 +247,20 @@ compiler.cfg.linear-scan.debugger ;
[ ] [
{
- T{ live-interval { vreg T{ vreg { n 1 } { reg-class int-regs } } } { start 0 } { end 10 } { uses V{ 0 10 } } }
- T{ live-interval { vreg T{ vreg { n 2 } { reg-class int-regs } } } { start 11 } { end 20 } { uses V{ 11 20 } } }
+ T{ live-interval
+ { vreg T{ vreg { n 1 } { reg-class int-regs } } }
+ { start 0 }
+ { end 10 }
+ { uses V{ 0 10 } }
+ { ranges V{ T{ live-range f 0 10 } } }
+ }
+ T{ live-interval
+ { vreg T{ vreg { n 2 } { reg-class int-regs } } }
+ { start 11 }
+ { end 20 }
+ { uses V{ 11 20 } }
+ { ranges V{ T{ live-range f 11 20 } } }
+ }
}
H{ { int-regs { "A" } } }
check-linear-scan
@@ -190,8 +268,20 @@ compiler.cfg.linear-scan.debugger ;
[ ] [
{
- T{ live-interval { vreg T{ vreg { n 1 } { reg-class int-regs } } } { start 0 } { end 100 } { uses V{ 0 100 } } }
- T{ live-interval { vreg T{ vreg { n 2 } { reg-class int-regs } } } { start 30 } { end 60 } { uses V{ 30 60 } } }
+ T{ live-interval
+ { vreg T{ vreg { n 1 } { reg-class int-regs } } }
+ { start 0 }
+ { end 100 }
+ { uses V{ 0 100 } }
+ { ranges V{ T{ live-range f 0 100 } } }
+ }
+ T{ live-interval
+ { vreg T{ vreg { n 2 } { reg-class int-regs } } }
+ { start 30 }
+ { end 60 }
+ { uses V{ 30 60 } }
+ { ranges V{ T{ live-range f 30 60 } } }
+ }
}
H{ { int-regs { "A" } } }
check-linear-scan
@@ -199,8 +289,20 @@ compiler.cfg.linear-scan.debugger ;
[ ] [
{
- T{ live-interval { vreg T{ vreg { n 1 } { reg-class int-regs } } } { start 0 } { end 100 } { uses V{ 0 100 } } }
- T{ live-interval { vreg T{ vreg { n 2 } { reg-class int-regs } } } { start 30 } { end 200 } { uses V{ 30 200 } } }
+ T{ live-interval
+ { vreg T{ vreg { n 1 } { reg-class int-regs } } }
+ { start 0 }
+ { end 100 }
+ { uses V{ 0 100 } }
+ { ranges V{ T{ live-range f 0 100 } } }
+ }
+ T{ live-interval
+ { vreg T{ vreg { n 2 } { reg-class int-regs } } }
+ { start 30 }
+ { end 200 }
+ { uses V{ 30 200 } }
+ { ranges V{ T{ live-range f 30 200 } } }
+ }
}
H{ { int-regs { "A" } } }
check-linear-scan
@@ -208,8 +310,20 @@ compiler.cfg.linear-scan.debugger ;
[
{
- T{ live-interval { vreg T{ vreg { n 1 } { reg-class int-regs } } } { start 0 } { end 100 } { uses V{ 0 100 } } }
- T{ live-interval { vreg T{ vreg { n 2 } { reg-class int-regs } } } { start 30 } { end 100 } { uses V{ 30 100 } } }
+ T{ live-interval
+ { vreg T{ vreg { n 1 } { reg-class int-regs } } }
+ { start 0 }
+ { end 100 }
+ { uses V{ 0 100 } }
+ { ranges V{ T{ live-range f 0 100 } } }
+ }
+ T{ live-interval
+ { vreg T{ vreg { n 2 } { reg-class int-regs } } }
+ { start 30 }
+ { end 100 }
+ { uses V{ 30 100 } }
+ { ranges V{ T{ live-range f 30 100 } } }
+ }
}
H{ { int-regs { "A" } } }
check-linear-scan
@@ -242,11 +356,12 @@ SYMBOL: max-uses
max-insns get [ 0 ] replicate taken set
max-insns get [ dup ] H{ } map>assoc available set
[
- live-interval new
+ \ live-interval new
swap int-regs swap vreg boa >>vreg
max-uses get random 2 max [ not-taken ] replicate natural-sort
[ >>uses ] [ first >>start ] bi
dup uses>> last >>end
+ dup [ start>> ] [ end>> ] bi <live-range> 1vector >>ranges
] map
] with-scope ;
@@ -271,49 +386,10 @@ USING: math.private compiler.cfg.debugger ;
test-cfg first optimize-cfg linear-scan drop
] unit-test
-[ f ] [
- T{ basic-block
- { instructions
- V{
- T{ ##allot
- f
- T{ vreg f int-regs 1 }
- 40
- array
- T{ vreg f int-regs 2 }
- f
- }
- }
- }
- } clone [ [ clone ] map ] change-instructions
- dup 1array (linear-scan) instructions>> first regs>> values all-equal?
-] unit-test
-
-[ 0 1 ] [
- {
- T{ live-interval
- { vreg T{ vreg { reg-class int-regs } { n 1 } } }
- { start 0 }
- { end 5 }
- { uses V{ 0 1 5 } }
- }
- T{ live-interval
- { vreg T{ vreg { reg-class int-regs } { n 2 } } }
- { start 3 }
- { end 4 }
- { uses V{ 3 4 } }
- }
- T{ live-interval
- { vreg T{ vreg { reg-class int-regs } { n 3 } } }
- { start 2 }
- { end 6 }
- { uses V{ 2 4 6 } }
- }
- } [ clone ] map
- H{ { int-regs { "A" "B" } } }
- allocate-registers
- first split-before>> [ start>> ] [ end>> ] bi
-] unit-test
+: fake-live-ranges ( seq -- seq' )
+ [
+ clone dup [ start>> ] [ end>> ] bi <live-range> 1vector >>ranges
+ ] map ;
! Coalescing interacted badly with splitting
[ ] [
@@ -362,7 +438,7 @@ USING: math.private compiler.cfg.debugger ;
{ end 10 }
{ uses V{ 9 10 } }
}
- }
+ } fake-live-ranges
{ { int-regs { 0 1 2 3 } } }
allocate-registers drop
] unit-test
@@ -1117,7 +1193,7 @@ USING: math.private compiler.cfg.debugger ;
{ end 109 }
{ uses V{ 103 109 } }
}
- }
+ } fake-live-ranges
{ { int-regs { 0 1 2 3 4 } } }
allocate-registers drop
] unit-test
@@ -1210,7 +1286,7 @@ USING: math.private compiler.cfg.debugger ;
{ end 92 }
{ uses V{ 42 45 78 80 92 } }
}
- }
+ } fake-live-ranges
{ { int-regs { 0 1 2 3 } } }
allocate-registers drop
] unit-test
diff --git a/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor b/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor
index 55bcdc7470..546443b289 100644
--- a/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor
+++ b/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor
@@ -1,26 +1,56 @@
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces kernel assocs accessors sequences math fry
-compiler.cfg.instructions compiler.cfg.registers
-compiler.cfg.def-use ;
+USING: namespaces kernel assocs accessors sequences math math.order fry
+binary-search compiler.cfg.instructions compiler.cfg.registers
+compiler.cfg.def-use compiler.cfg.liveness compiler.cfg ;
IN: compiler.cfg.linear-scan.live-intervals
+TUPLE: live-range from to ;
+
+C: <live-range> live-range
+
TUPLE: live-interval
vreg
reg spill-to reload-from split-before split-after
-start end uses
+start end ranges uses
copy-from ;
-: add-use ( n live-interval -- )
- dup live-interval? [ "No def" throw ] unless
- [ (>>end) ] [ uses>> push ] 2bi ;
+ERROR: dead-value-error vreg ;
-: <live-interval> ( start vreg -- live-interval )
- live-interval new
+: shorten-range ( n live-interval -- )
+ dup ranges>> empty?
+ [ vreg>> dead-value-error ] [ ranges>> last (>>from) ] if ;
+
+: extend-range ( from to live-range -- )
+ ranges>> last
+ [ max ] change-to
+ [ min ] change-from
+ drop ;
+
+: add-new-range ( from to live-interval -- )
+ [ <live-range> ] dip ranges>> push ;
+
+: extend-range? ( to live-interval -- ? )
+ ranges>> [ drop f ] [ last from>> >= ] if-empty ;
+
+: add-range ( from to live-interval -- )
+ 2dup extend-range?
+ [ extend-range ] [ add-new-range ] if ;
+
+: add-use ( n live-interval -- )
+ uses>> push ;
+
+: <live-interval> ( vreg -- live-interval )
+ \ live-interval new
V{ } clone >>uses
- swap >>vreg
- over >>start
- [ add-use ] keep ;
+ V{ } clone >>ranges
+ swap >>vreg ;
+
+: block-from ( -- n )
+ basic-block get instructions>> first insn#>> ;
+
+: block-to ( -- n )
+ basic-block get instructions>> last insn#>> ;
M: live-interval hashcode*
nip [ start>> ] [ end>> 1000 * ] bi + ;
@@ -31,23 +61,31 @@ M: live-interval clone
! Mapping from vreg to live-interval
SYMBOL: live-intervals
-: new-live-interval ( n vreg live-intervals -- )
- 2dup key? [
- at add-use
- ] [
- [ [ <live-interval> ] keep ] dip set-at
- ] if ;
+: live-interval ( vreg live-intervals -- live-interval )
+ [ <live-interval> ] cache ;
GENERIC: compute-live-intervals* ( insn -- )
M: insn compute-live-intervals* drop ;
+: handle-output ( n vreg live-intervals -- )
+ live-interval
+ [ add-use ] [ shorten-range ] 2bi ;
+
+: handle-input ( n vreg live-intervals -- )
+ live-interval
+ [ [ block-from ] 2dip add-range ] [ add-use ] 2bi ;
+
+: handle-temp ( n vreg live-intervals -- )
+ live-interval
+ [ dupd add-range ] [ add-use ] 2bi ;
+
M: vreg-insn compute-live-intervals*
dup insn#>>
live-intervals get
- [ [ uses-vregs ] 2dip '[ _ swap _ at add-use ] each ]
- [ [ defs-vregs ] 2dip '[ _ swap _ new-live-interval ] each ]
- [ [ temp-vregs ] 2dip '[ _ swap _ new-live-interval ] each ]
+ [ [ defs-vregs ] 2dip '[ [ _ ] dip _ handle-output ] each ]
+ [ [ uses-vregs ] 2dip '[ [ _ ] dip _ handle-input ] each ]
+ [ [ temp-vregs ] 2dip '[ [ _ ] dip _ handle-temp ] each ]
3tri ;
: record-copy ( insn -- )
@@ -59,8 +97,33 @@ M: ##copy compute-live-intervals*
M: ##copy-float compute-live-intervals*
[ call-next-method ] [ record-copy ] bi ;
+: handle-live-out ( bb -- )
+ live-out keys block-from block-to live-intervals get '[
+ [ _ _ ] dip _ live-interval add-range
+ ] each ;
+
+: compute-live-intervals-step ( bb -- )
+ [ basic-block set ]
+ [ handle-live-out ]
+ [ instructions>> <reversed> [ compute-live-intervals* ] each ] tri ;
+
+: compute-start/end ( live-interval -- )
+ dup ranges>> [ first from>> ] [ last to>> ] bi
+ 2dup > [ "BUG: start > end" throw ] when
+ [ >>start ] [ >>end ] bi* drop ;
+
+: 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
+ ] each ;
+
: compute-live-intervals ( rpo -- live-intervals )
H{ } clone [
live-intervals set
- [ instructions>> [ compute-live-intervals* ] each ] each
- ] keep values ;
+ <reversed> [ compute-live-intervals-step ] each
+ ] keep values dup finish-live-intervals ;
diff --git a/basis/compiler/cfg/linearization/linearization.factor b/basis/compiler/cfg/linearization/linearization.factor
index 53ca56907d..9e222f1832 100755
--- a/basis/compiler/cfg/linearization/linearization.factor
+++ b/basis/compiler/cfg/linearization/linearization.factor
@@ -1,11 +1,11 @@
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math accessors sequences namespaces make
-combinators assocs
-cpu.architecture
+combinators assocs arrays locals cpu.architecture
compiler.cfg
compiler.cfg.rpo
compiler.cfg.liveness
+compiler.cfg.stack-frame
compiler.cfg.instructions ;
IN: compiler.cfg.linearization
@@ -68,6 +68,57 @@ M: ##dispatch linearize-insn
[ successors>> [ number>> _dispatch-label ] each ]
bi* ;
+: gc-root-registers ( n live-registers -- n )
+ [
+ [ second 2array , ]
+ [ first reg-class>> reg-size + ]
+ 2bi
+ ] each ;
+
+: gc-root-spill-slots ( n live-spill-slots -- n )
+ [
+ dup first reg-class>> int-regs eq? [
+ [ second <spill-slot> 2array , ]
+ [ first reg-class>> reg-size + ]
+ 2bi
+ ] [ drop ] if
+ ] each ;
+
+: oop-registers ( regs -- regs' )
+ [ first reg-class>> int-regs eq? ] filter ;
+
+: data-registers ( regs -- regs' )
+ [ first reg-class>> double-float-regs eq? ] filter ;
+
+:: compute-gc-roots ( live-registers live-spill-slots -- alist )
+ [
+ 0
+ ! we put float registers last; the GC doesn't actually scan them
+ live-registers oop-registers gc-root-registers
+ live-spill-slots gc-root-spill-slots
+ live-registers data-registers gc-root-registers
+ drop
+ ] { } make ;
+
+: count-gc-roots ( live-registers live-spill-slots -- n )
+ ! Size of GC root area, minus the float registers
+ [ oop-registers length ] bi@ + ;
+
+M: ##gc linearize-insn
+ nip
+ [
+ [ temp1>> ]
+ [ temp2>> ]
+ [
+ [ live-registers>> ] [ live-spill-slots>> ] bi
+ [ compute-gc-roots ]
+ [ count-gc-roots ]
+ [ gc-roots-size ]
+ 2tri
+ ] tri
+ _gc
+ ] with-regs ;
+
: linearize-basic-blocks ( cfg -- insns )
[
[ [ linearize-basic-block ] each-basic-block ]
diff --git a/basis/compiler/cfg/mr/mr.factor b/basis/compiler/cfg/mr/mr.factor
index 49f7c793e5..9f6a62090c 100644
--- a/basis/compiler/cfg/mr/mr.factor
+++ b/basis/compiler/cfg/mr/mr.factor
@@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: compiler.cfg.linearization compiler.cfg.two-operand
compiler.cfg.liveness compiler.cfg.gc-checks compiler.cfg.linear-scan
-compiler.cfg.stack-frame compiler.cfg.rpo ;
+compiler.cfg.build-stack-frame compiler.cfg.rpo ;
IN: compiler.cfg.mr
: build-mr ( cfg -- mr )
diff --git a/basis/compiler/cfg/stack-frame/authors.txt b/basis/compiler/cfg/stack-frame/authors.txt
new file mode 100644
index 0000000000..d4f5d6b3ae
--- /dev/null
+++ b/basis/compiler/cfg/stack-frame/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
\ No newline at end of file
diff --git a/basis/compiler/cfg/stack-frame/stack-frame.factor b/basis/compiler/cfg/stack-frame/stack-frame.factor
index fd11260f97..5cb5762b78 100644
--- a/basis/compiler/cfg/stack-frame/stack-frame.factor
+++ b/basis/compiler/cfg/stack-frame/stack-frame.factor
@@ -1,72 +1,55 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces accessors math.order assocs kernel sequences
-combinators make classes words cpu.architecture
-compiler.cfg.instructions compiler.cfg.registers ;
+USING: math math.order namespaces accessors kernel layouts combinators
+combinators.smart assocs sequences cpu.architecture ;
IN: compiler.cfg.stack-frame
-SYMBOL: frame-required?
+TUPLE: stack-frame
+{ params integer }
+{ return integer }
+{ total-size integer }
+{ gc-root-size integer }
+spill-counts ;
-SYMBOL: spill-counts
+! Stack frame utilities
+: param-base ( -- n )
+ stack-frame get [ params>> ] [ return>> ] bi + ;
-GENERIC: compute-stack-frame* ( insn -- )
+: spill-float-offset ( n -- offset )
+ double-float-regs reg-size * ;
+
+: spill-integer-base ( -- n )
+ stack-frame get spill-counts>> double-float-regs [ swap at ] keep reg-size *
+ param-base + ;
+
+: spill-integer-offset ( n -- offset )
+ cells spill-integer-base + ;
+
+: spill-area-size ( stack-frame -- n )
+ spill-counts>> [ swap reg-size * ] { } assoc>map sum ;
+
+: gc-root-base ( -- n )
+ stack-frame get spill-area-size
+ param-base + ;
+
+: gc-root-offset ( n -- n' ) gc-root-base + ;
+
+: gc-roots-size ( live-registers live-spill-slots -- n )
+ [ keys [ reg-class>> reg-size ] sigma ] bi@ + ;
+
+: (stack-frame-size) ( stack-frame -- n )
+ [
+ {
+ [ spill-area-size ]
+ [ gc-root-size>> ]
+ [ params>> ]
+ [ return>> ]
+ } cleave
+ ] sum-outputs ;
: max-stack-frame ( frame1 frame2 -- frame3 )
[ stack-frame new ] 2dip
[ [ params>> ] bi@ max >>params ]
[ [ return>> ] bi@ max >>return ]
- 2bi ;
-
-M: ##stack-frame compute-stack-frame*
- frame-required? on
- stack-frame>> stack-frame [ max-stack-frame ] change ;
-
-M: ##call compute-stack-frame*
- word>> sub-primitive>> [ frame-required? on ] unless ;
-
-M: _spill-counts compute-stack-frame*
- counts>> stack-frame get (>>spill-counts) ;
-
-M: insn compute-stack-frame*
- class frame-required? word-prop [
- frame-required? on
- ] when ;
-
-\ _spill t frame-required? set-word-prop
-\ ##gc t frame-required? set-word-prop
-\ ##fixnum-add t frame-required? set-word-prop
-\ ##fixnum-sub t frame-required? set-word-prop
-\ ##fixnum-mul t frame-required? set-word-prop
-\ ##fixnum-add-tail f frame-required? set-word-prop
-\ ##fixnum-sub-tail f frame-required? set-word-prop
-\ ##fixnum-mul-tail f frame-required? set-word-prop
-
-: compute-stack-frame ( insns -- )
- frame-required? off
- T{ stack-frame } clone stack-frame set
- [ compute-stack-frame* ] each
- stack-frame get dup stack-frame-size >>total-size drop ;
-
-GENERIC: insert-pro/epilogues* ( insn -- )
-
-M: ##stack-frame insert-pro/epilogues* drop ;
-
-M: ##prologue insert-pro/epilogues*
- drop frame-required? get [ stack-frame get _prologue ] when ;
-
-M: ##epilogue insert-pro/epilogues*
- drop frame-required? get [ stack-frame get _epilogue ] when ;
-
-M: insn insert-pro/epilogues* , ;
-
-: insert-pro/epilogues ( insns -- insns )
- [ [ insert-pro/epilogues* ] each ] { } make ;
-
-: build-stack-frame ( mr -- mr )
- [
- [
- [ compute-stack-frame ]
- [ insert-pro/epilogues ]
- bi
- ] change-instructions
- ] with-scope ;
+ [ [ gc-root-size>> ] bi@ max >>gc-root-size ]
+ 2tri ;
\ No newline at end of file
diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor
index 3962902c62..7bdaace1db 100755
--- a/basis/compiler/codegen/codegen.factor
+++ b/basis/compiler/codegen/codegen.factor
@@ -10,6 +10,7 @@ compiler.errors
compiler.alien
compiler.cfg
compiler.cfg.instructions
+compiler.cfg.stack-frame
compiler.cfg.registers
compiler.cfg.builder
compiler.codegen.fixup
@@ -234,7 +235,13 @@ M: ##write-barrier generate-insn
[ table>> register ]
tri %write-barrier ;
-M: ##gc generate-insn drop %gc ;
+M: _gc generate-insn
+ {
+ [ temp1>> register ]
+ [ temp2>> register ]
+ [ gc-roots>> ]
+ [ gc-root-count>> ]
+ } cleave %gc ;
M: ##loop-entry generate-insn drop %loop-entry ;
@@ -243,16 +250,6 @@ M: ##alien-global generate-insn
%alien-global ;
! ##alien-invoke
-GENERIC: reg-size ( register-class -- n )
-
-M: int-regs reg-size drop cell ;
-
-M: single-float-regs reg-size drop 4 ;
-
-M: double-float-regs reg-size drop 8 ;
-
-M: stack-params reg-size drop "void*" heap-size ;
-
GENERIC: reg-class-variable ( register-class -- symbol )
M: reg-class reg-class-variable ;
diff --git a/basis/compiler/tests/codegen.factor b/basis/compiler/tests/codegen.factor
index e0bc917f1c..47c6fa31e7 100644
--- a/basis/compiler/tests/codegen.factor
+++ b/basis/compiler/tests/codegen.factor
@@ -2,7 +2,7 @@ USING: generalizations accessors arrays compiler kernel kernel.private
math hashtables.private math.private namespaces sequences tools.test
namespaces.private slots.private sequences.private byte-arrays alien
alien.accessors layouts words definitions compiler.units io
-combinators vectors grouping make ;
+combinators vectors grouping make alien.c-types ;
QUALIFIED: namespaces.private
IN: compiler.tests.codegen
@@ -282,3 +282,10 @@ TUPLE: cucumber ;
M: cucumber equal? "The cucumber has no equal" throw ;
[ t ] [ [ cucumber ] compile-call cucumber eq? ] unit-test
+
+[ 4294967295 B{ 255 255 255 255 } -1 ]
+[
+ -1 <int> -1 <int>
+ [ [ 0 alien-unsigned-cell swap ] [ 0 alien-signed-2 ] bi ]
+ compile-call
+] unit-test
\ No newline at end of file
diff --git a/basis/compression/run-length/run-length.factor b/basis/compression/run-length/run-length.factor
new file mode 100644
index 0000000000..6553860546
--- /dev/null
+++ b/basis/compression/run-length/run-length.factor
@@ -0,0 +1,7 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays grouping sequences ;
+IN: compression.run-length
+
+: run-length-uncompress ( byte-array -- byte-array' )
+ 2 group [ first2 <array> ] map concat ;
diff --git a/basis/constructors/constructors-tests.factor b/basis/constructors/constructors-tests.factor
index 367f0ad143..271e173718 100644
--- a/basis/constructors/constructors-tests.factor
+++ b/basis/constructors/constructors-tests.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: tools.test constructors calendar kernel accessors
-combinators.short-circuit ;
+combinators.short-circuit initializers math ;
IN: constructors.tests
TUPLE: stock-spread stock spread timestamp ;
@@ -18,4 +18,42 @@ SYMBOL: AAPL
[ spread>> 1234 = ]
[ timestamp>> timestamp? ]
} 1&&
-] unit-test
\ No newline at end of file
+] 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
diff --git a/basis/constructors/constructors.factor b/basis/constructors/constructors.factor
index 7a98cd5e0a..e6982e3d98 100644
--- a/basis/constructors/constructors.factor
+++ b/basis/constructors/constructors.factor
@@ -1,23 +1,54 @@
-! Copyright (C) 2009 Slava Pestov.
+! Copyright (C) 2009 Slava Pestov, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: slots kernel sequences fry accessors parser lexer words
-effects.parser macros ;
+USING: accessors assocs classes.tuple effects.parser fry
+generalizations generic.standard kernel lexer locals macros
+parser sequences slots vocabs words ;
IN: constructors
! An experiment
-MACRO: set-slots ( slots -- quot )
- <reversed> [ setter-word '[ swap _ execute ] ] map [ ] join ;
+: initializer-name ( class -- word )
+ name>> "initialize-" prepend ;
-: construct ( ... class slots -- instance )
- [ new ] dip set-slots ; inline
+: lookup-initializer ( class -- word/f )
+ initializer-name "initializers" lookup ;
-: define-constructor ( name class effect body -- )
- [ [ in>> '[ _ _ construct ] ] dip compose ] [ drop ] 2bi
- define-declared ;
+: 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 ;
+
+MACRO:: slots>constructor ( class slots -- quot )
+ class all-slots [ [ name>> ] [ initial>> ] bi ] { } map>assoc :> params
+ slots length
+ params length
+ '[
+ _ narray slots swap zip
+ params swap assoc-union
+ values _ firstn class boa
+ ] ;
+
+:: define-constructor ( constructor-word class effect def -- )
+ constructor-word
+ class def define-initializer
+ class effect in>> '[ _ _ slots>constructor ]
+ class lookup-initializer
+ '[ @ _ execute( obj -- obj ) ] effect define-declared ;
+
+: scan-constructor ( -- class word )
+ scan-word [ name>> "<" ">" surround create-in ] keep ;
SYNTAX: CONSTRUCTOR:
- scan-word [ name>> "<" ">" surround create-in ] keep
+ scan-constructor
complete-effect
parse-definition
- define-constructor ;
\ No newline at end of file
+ define-constructor ;
+
+"initializers" create-vocab drop
diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor
index f7f91524c3..805ba4fd71 100644
--- a/basis/cpu/architecture/architecture.factor
+++ b/basis/cpu/architecture/architecture.factor
@@ -12,12 +12,22 @@ SINGLETON: double-float-regs
UNION: float-regs single-float-regs double-float-regs ;
UNION: reg-class int-regs float-regs ;
-! Mapping from register class to machine registers
-HOOK: machine-registers cpu ( -- assoc )
-
! A pseudo-register class for parameters spilled on the stack
SINGLETON: stack-params
+GENERIC: reg-size ( register-class -- n )
+
+M: int-regs reg-size drop cell ;
+
+M: single-float-regs reg-size drop 4 ;
+
+M: double-float-regs reg-size drop 8 ;
+
+M: stack-params reg-size drop cell ;
+
+! Mapping from register class to machine registers
+HOOK: machine-registers cpu ( -- assoc )
+
! Return values of this class go here
GENERIC: return-reg ( register-class -- reg )
@@ -119,7 +129,7 @@ HOOK: %alien-global cpu ( dst symbol library -- )
HOOK: %allot cpu ( dst size class temp -- )
HOOK: %write-barrier cpu ( src card# table -- )
-HOOK: %gc cpu ( -- )
+HOOK: %gc cpu ( temp1 temp2 live-registers live-spill-slots -- )
HOOK: %prologue cpu ( n -- )
HOOK: %epilogue cpu ( n -- )
diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor
index cf84b083fe..b591b254f8 100755
--- a/basis/cpu/x86/32/32.factor
+++ b/basis/cpu/x86/32/32.factor
@@ -3,10 +3,11 @@
USING: locals alien.c-types alien.syntax arrays kernel
math namespaces sequences system layouts io vocabs.loader
accessors init combinators command-line cpu.x86.assembler
-cpu.x86 cpu.architecture compiler compiler.units
+cpu.x86 cpu.architecture make compiler compiler.units
compiler.constants compiler.alien compiler.codegen
compiler.codegen.fixup compiler.cfg.instructions
-compiler.cfg.builder compiler.cfg.intrinsics make ;
+compiler.cfg.builder compiler.cfg.intrinsics
+compiler.cfg.stack-frame ;
IN: cpu.x86.32
! We implement the FFI for Linux, OS X and Windows all at once.
diff --git a/basis/cpu/x86/64/64.factor b/basis/cpu/x86/64/64.factor
index 0b9b4e8ddf..3a7221c239 100644
--- a/basis/cpu/x86/64/64.factor
+++ b/basis/cpu/x86/64/64.factor
@@ -1,4 +1,4 @@
-! Copyright (C) 2005, 2008 Slava Pestov.
+! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays kernel math namespaces make sequences
system layouts alien alien.c-types alien.accessors alien.structs
@@ -6,7 +6,7 @@ slots splitting assocs combinators locals cpu.x86.assembler
cpu.x86 cpu.architecture compiler.constants
compiler.codegen compiler.codegen.fixup
compiler.cfg.instructions compiler.cfg.builder
-compiler.cfg.intrinsics ;
+compiler.cfg.intrinsics compiler.cfg.stack-frame ;
IN: cpu.x86.64
M: x86.64 machine-registers
diff --git a/basis/cpu/x86/x86.factor b/basis/cpu/x86/x86.factor
index 1a2c2e3ee1..ef353281e5 100644
--- a/basis/cpu/x86/x86.factor
+++ b/basis/cpu/x86/x86.factor
@@ -6,7 +6,7 @@ kernel kernel.private math memory namespaces make sequences
words system layouts combinators math.order fry locals
compiler.constants compiler.cfg.registers
compiler.cfg.instructions compiler.cfg.intrinsics
-compiler.codegen compiler.codegen.fixup ;
+compiler.cfg.stack-frame compiler.codegen compiler.codegen.fixup ;
IN: cpu.x86
<< enable-fixnum-log2 >>
@@ -17,6 +17,32 @@ M: label JUMPcc [ 0 ] dip JUMPcc rc-relative label-fixup ;
M: x86 two-operand? t ;
+HOOK: stack-reg cpu ( -- reg )
+
+HOOK: reserved-area-size cpu ( -- n )
+
+: stack@ ( n -- op ) stack-reg swap [+] ;
+
+: param@ ( n -- op ) reserved-area-size + stack@ ;
+
+: spill-integer@ ( n -- op ) spill-integer-offset param@ ;
+
+: spill-float@ ( n -- op ) spill-float-offset param@ ;
+
+: gc-root@ ( n -- op ) gc-root-offset param@ ;
+
+: decr-stack-reg ( n -- )
+ dup 0 = [ drop ] [ stack-reg swap SUB ] if ;
+
+: incr-stack-reg ( n -- )
+ dup 0 = [ drop ] [ stack-reg swap ADD ] if ;
+
+: align-stack ( n -- n' )
+ os macosx? cpu x86.64? or [ 16 align ] when ;
+
+M: x86 stack-frame-size ( stack-frame -- i )
+ (stack-frame-size) 3 cells reserved-area-size + + align-stack ;
+
HOOK: temp-reg-1 cpu ( -- reg )
HOOK: temp-reg-2 cpu ( -- reg )
@@ -45,20 +71,6 @@ M: x86 %replace loc>operand swap MOV ;
M: x86 %inc-d ( n -- ) ds-reg (%inc) ;
M: x86 %inc-r ( n -- ) rs-reg (%inc) ;
-: align-stack ( n -- n' )
- os macosx? cpu x86.64? or [ 16 align ] when ;
-
-HOOK: reserved-area-size cpu ( -- n )
-
-M: x86 stack-frame-size ( stack-frame -- i )
- [ spill-counts>> [ swap reg-size * ] { } assoc>map sum ]
- [ params>> ]
- [ return>> ]
- tri + +
- 3 cells +
- reserved-area-size +
- align-stack ;
-
M: x86 %call ( word -- ) 0 CALL rc-relative rel-word-pic ;
: xt-tail-pic-offset ( -- n )
@@ -315,17 +327,29 @@ M:: x86 %box-alien ( dst src temp -- )
"end" resolve-label
] with-scope ;
-: small-reg-4 ( reg -- reg' )
+: small-reg-8 ( reg -- reg' )
H{
- { EAX EAX }
- { ECX ECX }
- { EDX EDX }
- { EBX EBX }
- { ESP ESP }
- { EBP EBP }
- { ESI ESP }
- { EDI EDI }
+ { EAX RAX }
+ { ECX RCX }
+ { EDX RDX }
+ { EBX RBX }
+ { ESP RSP }
+ { EBP RBP }
+ { ESI RSP }
+ { EDI RDI }
+ { RAX RAX }
+ { RCX RCX }
+ { RDX RDX }
+ { RBX RBX }
+ { RSP RSP }
+ { RBP RBP }
+ { RSI RSP }
+ { RDI RDI }
+ } at ; inline
+
+: small-reg-4 ( reg -- reg' )
+ small-reg-8 H{
{ RAX EAX }
{ RCX ECX }
{ RDX EDX }
@@ -361,12 +385,21 @@ M:: x86 %box-alien ( dst src temp -- )
{ 1 [ small-reg-1 ] }
{ 2 [ small-reg-2 ] }
{ 4 [ small-reg-4 ] }
+ { 8 [ small-reg-8 ] }
} case ;
-: small-regs ( -- regs ) { EAX ECX EDX EBX } ; inline
+HOOK: small-regs cpu ( -- regs )
+
+M: x86.32 small-regs { EAX ECX EDX EBX } ;
+M: x86.64 small-regs { RAX RCX RDX RBX } ;
+
+HOOK: small-reg-native cpu ( reg -- reg' )
+
+M: x86.32 small-reg-native small-reg-4 ;
+M: x86.64 small-reg-native small-reg-8 ;
: small-reg-that-isn't ( exclude -- reg' )
- small-regs swap [ small-reg-4 ] map '[ _ memq? not ] find nip ;
+ small-regs swap [ small-reg-native ] map '[ _ memq? not ] find nip ;
: with-save/restore ( reg quot -- )
[ drop PUSH ] [ call ] [ drop POP ] 2tri ; inline
@@ -376,7 +409,7 @@ M:: x86 %box-alien ( dst src temp -- )
#! call the quot with that. Otherwise, we find a small
#! register that is not in exclude, and call quot, saving
#! and restoring the small register.
- dst small-reg-4 small-regs memq? [ dst quot call ] [
+ dst small-reg-native small-regs memq? [ dst quot call ] [
exclude small-reg-that-isn't
[ quot call ] with-save/restore
] if ; inline
@@ -492,29 +525,58 @@ M:: x86 %write-barrier ( src card# table -- )
table table [] MOV
table card# [+] card-mark <byte> MOV ;
-M: x86 %gc ( -- )
- "end" define-label
- temp-reg-1 load-zone-ptr
- temp-reg-2 temp-reg-1 cell [+] MOV
- temp-reg-2 1024 ADD
- temp-reg-1 temp-reg-1 3 cells [+] MOV
- temp-reg-2 temp-reg-1 CMP
- "end" get JLE
+:: check-nursery ( temp1 temp2 -- )
+ temp1 load-zone-ptr
+ temp2 temp1 cell [+] MOV
+ temp2 1024 ADD
+ temp1 temp1 3 cells [+] MOV
+ temp2 temp1 CMP ;
+
+GENERIC# save-gc-root 1 ( gc-root operand temp -- )
+
+M:: spill-slot save-gc-root ( gc-root spill-slot temp -- )
+ temp spill-slot n>> spill-integer@ MOV
+ gc-root gc-root@ temp MOV ;
+
+M:: word save-gc-root ( gc-root register temp -- )
+ gc-root gc-root@ register MOV ;
+
+: save-gc-roots ( gc-roots temp -- )
+ '[ _ save-gc-root ] assoc-each ;
+
+GENERIC# load-gc-root 1 ( gc-root operand temp -- )
+
+M:: spill-slot load-gc-root ( gc-root spill-slot temp -- )
+ temp gc-root gc-root@ MOV
+ spill-slot n>> spill-integer@ temp MOV ;
+
+M:: word load-gc-root ( gc-root register temp -- )
+ register gc-root gc-root@ MOV ;
+
+: load-gc-roots ( gc-roots temp -- )
+ '[ _ load-gc-root ] assoc-each ;
+
+:: call-gc ( gc-root-count -- )
+ ! Pass pointer to start of GC roots as first parameter
+ param-reg-1 gc-root-base param@ LEA
+ ! Pass number of roots as second parameter
+ param-reg-2 gc-root-count MOV
+ ! Call GC
%prepare-alien-invoke
- "minor_gc" f %alien-invoke
+ "inline_gc" f %alien-invoke ;
+
+M:: x86 %gc ( temp1 temp2 gc-roots gc-root-count -- )
+ "end" define-label
+ temp1 temp2 check-nursery
+ "end" get JLE
+ gc-roots temp1 save-gc-roots
+ gc-root-count call-gc
+ gc-roots temp1 load-gc-roots
"end" resolve-label ;
M: x86 %alien-global
[ 0 MOV ] 2dip rc-absolute-cell rel-dlsym ;
-HOOK: stack-reg cpu ( -- reg )
-
-: decr-stack-reg ( n -- )
- dup 0 = [ drop ] [ stack-reg swap SUB ] if ;
-
-: incr-stack-reg ( n -- )
- dup 0 = [ drop ] [ stack-reg swap ADD ] if ;
-
M: x86 %epilogue ( n -- ) cell - incr-stack-reg ;
:: %boolean ( dst temp word -- )
@@ -568,28 +630,6 @@ M: x86 %compare-float-branch ( label cc src1 src2 -- )
{ cc/= [ JNE ] }
} case ;
-: stack@ ( n -- op ) stack-reg swap [+] ;
-
-: param@ ( n -- op ) reserved-area-size + stack@ ;
-
-: spill-integer-base ( stack-frame -- n )
- [ params>> ] [ return>> ] bi + reserved-area-size + ;
-
-: spill-integer@ ( n -- op )
- cells
- stack-frame get spill-integer-base
- + stack@ ;
-
-: spill-float-base ( stack-frame -- n )
- [ spill-integer-base ]
- [ spill-counts>> int-regs swap at int-regs reg-size * ]
- bi + ;
-
-: spill-float@ ( n -- op )
- double-float-regs reg-size *
- stack-frame get spill-float-base
- + stack@ ;
-
M: x86 %spill-integer ( src n -- ) spill-integer@ swap MOV ;
M: x86 %reload-integer ( dst n -- ) spill-integer@ MOV ;
diff --git a/basis/heaps/heaps.factor b/basis/heaps/heaps.factor
index f2ccaad1b4..becfb6826d 100644
--- a/basis/heaps/heaps.factor
+++ b/basis/heaps/heaps.factor
@@ -192,6 +192,9 @@ M: heap heap-pop ( heap -- value key )
[ dup heap-pop swap 2array ]
produce nip ;
+: heap-values ( heap -- alist )
+ data>> [ value>> ] { } map-as ;
+
: slurp-heap ( heap quot: ( elt -- ) -- )
over heap-empty? [ 2drop ] [
[ [ heap-pop drop ] dip call ] [ slurp-heap ] 2bi
diff --git a/basis/images/authors.txt b/basis/images/authors.txt
index b4bd0e7b35..a4a77d97e9 100644
--- a/basis/images/authors.txt
+++ b/basis/images/authors.txt
@@ -1 +1,2 @@
-Doug Coleman
\ No newline at end of file
+Doug Coleman
+Daniel Ehrenberg
diff --git a/basis/images/bitmap/bitmap.factor b/basis/images/bitmap/bitmap.factor
index 48095bb26b..4f2ad720b6 100755
--- a/basis/images/bitmap/bitmap.factor
+++ b/basis/images/bitmap/bitmap.factor
@@ -1,61 +1,147 @@
! Copyright (C) 2007, 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien alien.c-types arrays byte-arrays columns
-combinators fry grouping io io.binary io.encodings.binary io.files
-kernel macros math math.bitwise math.functions namespaces sequences
-strings images endian summary locals ;
+combinators compression.run-length endian fry grouping images
+images.loader io io.binary io.encodings.binary io.files
+io.streams.limited kernel locals macros math math.bitwise
+math.functions namespaces sequences specialized-arrays.uint
+specialized-arrays.ushort strings summary io.encodings.8-bit
+io.encodings.string ;
+QUALIFIED-WITH: bitstreams b
IN: images.bitmap
-: assert-sequence= ( a b -- )
- 2dup sequence= [ 2drop ] [ assert ] if ;
-
: read2 ( -- n ) 2 read le> ;
: read4 ( -- n ) 4 read le> ;
: write2 ( n -- ) 2 >le write ;
: write4 ( n -- ) 4 >le write ;
-TUPLE: bitmap-image < image ;
-
-! Used to construct the final bitmap-image
+SINGLETON: bitmap-image
+"bmp" bitmap-image register-image-class
TUPLE: loading-bitmap
-size reserved offset header-length width
+magic size reserved1 reserved2 offset header-length width
height planes bit-count compression size-image
-x-pels y-pels color-used color-important rgb-quads color-index ;
+x-pels y-pels color-used color-important
+red-mask green-mask blue-mask alpha-mask
+cs-type end-points
+gamma-red gamma-green gamma-blue
+intent profile-data profile-size reserved3
+color-palette color-index bitfields ;
-ERROR: bitmap-magic magic ;
-
-M: bitmap-magic summary
- drop "First two bytes of bitmap stream must be 'BM'" ;
+! endpoints-triple is ciexyzX/Y/Z, 3x fixed-point-2.30 aka 3x uint
<PRIVATE
-: 8bit>buffer ( bitmap -- array )
- [ rgb-quads>> 4 <sliced-groups> [ 3 head-slice ] map ]
- [ color-index>> >array ] bi [ swap nth ] with map concat ;
+: os2-color-lookup ( loading-bitmap -- seq )
+ [ color-index>> >array ]
+ [ color-palette>> 3 <sliced-groups> ] bi
+ '[ _ nth ] map concat ;
+
+: os2v2-color-lookup ( loading-bitmap -- seq )
+ [ color-index>> >array ]
+ [ color-palette>> 3 <sliced-groups> ] bi
+ '[ _ nth ] map concat ;
+
+: v3-color-lookup ( loading-bitmap -- seq )
+ [ color-index>> >array ]
+ [ color-palette>> 4 <sliced-groups> [ 3 head-slice ] map ] bi
+ '[ _ nth ] map concat ;
+
+: color-lookup ( loading-bitmap -- seq )
+ dup header-length>> {
+ { 12 [ os2-color-lookup ] }
+ { 64 [ os2v2-color-lookup ] }
+ { 40 [ v3-color-lookup ] }
+ ! { 108 [ v4-color-lookup ] }
+ ! { 124 [ v5-color-lookup ] }
+ } case ;
ERROR: bmp-not-supported n ;
-: reverse-lines ( byte-array width -- byte-array )
- <sliced-groups> <reversed> concat ; inline
+: uncompress-bitfield ( seq masks -- bytes' )
+ '[
+ _ [
+ [ bitand ] [ bit-count ] [ log2 ] tri - shift
+ ] with map
+ ] { } map-as B{ } concat-as ;
-: raw-bitmap>seq ( loading-bitmap -- array )
+: bitmap>bytes ( loading-bitmap -- byte-array )
dup bit-count>>
{
{ 32 [ color-index>> ] }
- { 24 [ [ color-index>> ] [ width>> 3 * ] bi reverse-lines ] }
- { 8 [ [ 8bit>buffer ] [ width>> 3 * ] bi reverse-lines ] }
+ { 24 [ color-index>> ] }
+ { 16 [
+ [
+ ! byte-array>ushort-array
+ 2 group [ le> ] map
+ ! 5 6 5
+ ! { HEX: f800 HEX: 7e0 HEX: 1f } uncompress-bitfield
+ ! 5 5 5
+ { HEX: 7c00 HEX: 3e0 HEX: 1f } uncompress-bitfield
+ ] change-color-index
+ color-index>>
+ ] }
+ { 8 [ color-lookup ] }
+ { 4 [ [ 4 b:byte-array-n>seq ] change-color-index color-lookup ] }
+ { 1 [ [ 1 b:byte-array-n>seq ] change-color-index color-lookup ] }
[ bmp-not-supported ]
} case >byte-array ;
+: set-bitfield-widths ( loading-bitmap -- loading-bitmap' )
+ dup bit-count>> {
+ { 16 [ dup color-palette>> 4 group [ le> ] map ] }
+ { 32 [ { HEX: ff0000 HEX: ff00 HEX: ff } ] }
+ } case reverse >>bitfields ;
+
+ERROR: unsupported-bitfield-widths n ;
+
+M: unsupported-bitfield-widths summary
+ drop "Bitmaps only support bitfield compression in 16/32bit images" ;
+
+: uncompress-bitfield-widths ( loading-bitmap -- loading-bitmap' )
+ set-bitfield-widths
+ dup bit-count>> {
+ { 16 [
+ dup bitfields>> '[
+ byte-array>ushort-array _ uncompress-bitfield
+ ] change-color-index
+ ] }
+ { 32 [
+ dup bitfields>> '[
+ byte-array>uint-array _ uncompress-bitfield
+ ] change-color-index
+ ] }
+ [ unsupported-bitfield-widths ]
+ } case ;
+
+ERROR: unsupported-bitmap-compression compression ;
+
+: uncompress-bitmap ( loading-bitmap -- loading-bitmap' )
+ dup compression>> {
+ { f [ ] }
+ { 0 [ ] }
+ { 1 [ [ run-length-uncompress ] change-color-index ] }
+ { 2 [ [ 4 b:byte-array-n>seq run-length-uncompress >byte-array ] change-color-index ] }
+ { 3 [ uncompress-bitfield-widths ] }
+ { 4 [ "jpeg" unsupported-bitmap-compression ] }
+ { 5 [ "png" unsupported-bitmap-compression ] }
+ } case ;
+
+: bitmap-padding ( width -- n )
+ 3 * 4 mod 4 swap - 4 mod ; inline
+
+: loading-bitmap>bytes ( loading-bitmap -- byte-array )
+ uncompress-bitmap
+ bitmap>bytes ;
+
: parse-file-header ( loading-bitmap -- loading-bitmap )
- 2 read "BM" assert-sequence=
+ 2 read latin1 decode >>magic
read4 >>size
- read4 >>reserved
+ read2 >>reserved1
+ read2 >>reserved2
read4 >>offset ;
-: parse-bitmap-header ( loading-bitmap -- loading-bitmap )
- read4 >>header-length
+: read-v3-header ( loading-bitmap -- loading-bitmap )
read4 >>width
read4 32 >signed >>height
read2 >>planes
@@ -67,7 +153,51 @@ ERROR: bmp-not-supported n ;
read4 >>color-used
read4 >>color-important ;
-: rgb-quads-length ( loading-bitmap -- n )
+: read-v4-header ( loading-bitmap -- loading-bitmap )
+ read-v3-header
+ read4 >>red-mask
+ read4 >>green-mask
+ read4 >>blue-mask
+ read4 >>alpha-mask
+ read4 >>cs-type
+ read4 read4 read4 3array >>end-points
+ read4 >>gamma-red
+ read4 >>gamma-green
+ read4 >>gamma-blue ;
+
+: read-v5-header ( loading-bitmap -- loading-bitmap )
+ read-v4-header
+ read4 >>intent
+ read4 >>profile-data
+ read4 >>profile-size
+ read4 >>reserved3 ;
+
+: read-os2-header ( loading-bitmap -- loading-bitmap )
+ read2 >>width
+ read2 16 >signed >>height
+ read2 >>planes
+ read2 >>bit-count ;
+
+: read-os2v2-header ( loading-bitmap -- loading-bitmap )
+ read4 >>width
+ read4 32 >signed >>height
+ read2 >>planes
+ read2 >>bit-count ;
+
+ERROR: unknown-bitmap-header n ;
+
+: parse-bitmap-header ( loading-bitmap -- loading-bitmap )
+ read4 [ >>header-length ] keep
+ {
+ { 12 [ read-os2-header ] }
+ { 64 [ read-os2v2-header ] }
+ { 40 [ read-v3-header ] }
+ { 108 [ read-v4-header ] }
+ { 124 [ read-v5-header ] }
+ [ unknown-bitmap-header ]
+ } case ;
+
+: color-palette-length ( loading-bitmap -- n )
[ offset>> 14 - ] [ header-length>> ] bi - ;
: color-index-length ( loading-bitmap -- n )
@@ -81,54 +211,54 @@ ERROR: bmp-not-supported n ;
: image-size ( loading-bitmap -- n )
[ [ width>> ] [ height>> ] bi * ] [ bit-count>> 8 /i ] bi * abs ;
-: bitmap-padding ( width -- n )
- 3 * 4 mod 4 swap - 4 mod ; inline
-
-:: fixup-color-index ( loading-bitmap -- loading-bitmap )
- loading-bitmap width>> :> width
- width 3 * :> width*3
- loading-bitmap width>> bitmap-padding :> padding
- loading-bitmap [ color-index>> length ] [ height>> abs ] bi /i :> stride
- loading-bitmap
- padding 0 > [
- [
- stride <sliced-groups>
- [ width*3 head-slice ] map concat
- ] change-color-index
- ] when ;
-
: parse-bitmap ( loading-bitmap -- loading-bitmap )
- dup rgb-quads-length read >>rgb-quads
- dup color-index-length read >>color-index
- fixup-color-index ;
+ dup color-palette-length read >>color-palette
+ dup size-image>> dup 0 > [
+ read >>color-index
+ ] [
+ drop dup color-index-length read >>color-index
+ ] if ;
-: load-bitmap-data ( path -- loading-bitmap )
- binary [
+ERROR: unsupported-bitmap-file magic ;
+
+: load-bitmap ( path -- loading-bitmap )
+ binary stream-throws <limited-file-reader> [
loading-bitmap new
- parse-file-header parse-bitmap-header parse-bitmap
- ] with-file-reader ;
+ parse-file-header dup magic>> {
+ { "BM" [ parse-bitmap-header parse-bitmap ] }
+ ! { "BA" [ parse-os2-bitmap-array ] }
+ ! { "CI" [ parse-os2-color-icon ] }
+ ! { "CP" [ parse-os2-color-pointer ] }
+ ! { "IC" [ parse-os2-icon ] }
+ ! { "PT" [ parse-os2-pointer ] }
+ [ unsupported-bitmap-file ]
+ } case
+ ] with-input-stream ;
ERROR: unknown-component-order bitmap ;
: bitmap>component-order ( loading-bitmap -- object )
bit-count>> {
- { 32 [ BGRA ] }
+ { 32 [ BGR ] }
{ 24 [ BGR ] }
+ { 16 [ BGR ] }
{ 8 [ BGR ] }
+ { 4 [ BGR ] }
+ { 1 [ BGR ] }
[ unknown-component-order ]
} case ;
-: loading-bitmap>bitmap-image ( bitmap-image loading-bitmap -- bitmap-image )
+M: bitmap-image load-image* ( path bitmap-image -- bitmap )
+ drop load-bitmap
+ [ image new ] dip
{
- [ raw-bitmap>seq >>bitmap ]
+ [ loading-bitmap>bytes >>bitmap ]
[ [ width>> ] [ height>> abs ] bi 2array >>dim ]
- [ height>> 0 < [ t >>upside-down? ] when ]
+ [ height>> 0 < not >>upside-down? ]
+ [ compression>> 3 = [ t >>upside-down? ] when ]
[ bitmap>component-order >>component-order ]
} cleave ;
-M: bitmap-image load-image* ( path loading-bitmap -- bitmap )
- swap load-bitmap-data loading-bitmap>bitmap-image ;
-
PRIVATE>
: bitmap>color-index ( bitmap -- byte-array )
@@ -146,6 +276,9 @@ PRIVATE>
] if
] bi ;
+: reverse-lines ( byte-array width -- byte-array )
+ <sliced-groups> <reversed> concat ; inline
+
: save-bitmap ( image path -- )
binary [
B{ CHAR: B CHAR: M } write
@@ -183,7 +316,7 @@ PRIVATE>
! color-important
[ drop 0 write4 ]
- ! rgb-quads
+ ! color-palette
[
[ bitmap>color-index ]
[ dim>> first 3 * ]
diff --git a/basis/images/images-tests.factor b/basis/images/images-tests.factor
new file mode 100644
index 0000000000..8918dcb38c
--- /dev/null
+++ b/basis/images/images-tests.factor
@@ -0,0 +1,29 @@
+! Copyright (C) 2009 Daniel Ehrenberg.
+! See http://factorcode.org/license.txt for BSD license.
+USING: images tools.test kernel accessors ;
+IN: images.tests
+
+[ B{ 57 57 57 255 } ] [ 1 1 T{ image f { 2 3 } RGBA f B{
+ 0 0 0 0
+ 0 0 0 0
+ 0 0 0 0
+ 57 57 57 255
+ 0 0 0 0
+ 0 0 0 0
+} } pixel-at ] unit-test
+
+[ B{
+ 0 0 0 0
+ 0 0 0 0
+ 0 0 0 0
+ 57 57 57 255
+ 0 0 0 0
+ 0 0 0 0
+} ] [ B{ 57 57 57 255 } 1 1 T{ image f { 2 3 } RGBA f B{
+ 0 0 0 0
+ 0 0 0 0
+ 0 0 0 0
+ 0 0 0 0
+ 0 0 0 0
+ 0 0 0 0
+} } [ set-pixel-at ] keep bitmap>> ] unit-test
diff --git a/basis/images/images.factor b/basis/images/images.factor
index 178b91ab52..4c76b85459 100755
--- a/basis/images/images.factor
+++ b/basis/images/images.factor
@@ -1,6 +1,6 @@
-! Copyright (C) 2009 Doug Coleman.
+! Copyright (C) 2009 Doug Coleman, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
-USING: combinators kernel accessors ;
+USING: combinators kernel accessors sequences math arrays ;
IN: images
SINGLETONS: L LA BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR
@@ -34,4 +34,22 @@ TUPLE: image dim component-order upside-down? bitmap ;
: has-alpha? ( image -- ? ) component-order>> alpha-channel? ;
-GENERIC: load-image* ( path tuple -- image )
+GENERIC: load-image* ( path class -- image )
+
+<PRIVATE
+
+: pixel@ ( x y image -- start end bitmap )
+ [ dim>> first * + ]
+ [ component-order>> bytes-per-pixel [ * dup ] keep + ]
+ [ bitmap>> ] tri ;
+
+: set-subseq ( new-value from to victim -- )
+ <slice> 0 swap copy ; inline
+
+PRIVATE>
+
+: pixel-at ( x y image -- pixel )
+ pixel@ subseq ;
+
+: set-pixel-at ( pixel x y image -- )
+ pixel@ set-subseq ;
diff --git a/basis/images/jpeg/jpeg.factor b/basis/images/jpeg/jpeg.factor
index 648923704a..2cdc32e9df 100755
--- a/basis/images/jpeg/jpeg.factor
+++ b/basis/images/jpeg/jpeg.factor
@@ -6,12 +6,14 @@ images.processing io io.binary io.encodings.binary io.files
io.streams.byte-array kernel locals math math.bitwise
math.constants math.functions math.matrices math.order
math.ranges math.vectors memoize multiline namespaces
-sequences sequences.deep ;
+sequences sequences.deep images.loader ;
+QUALIFIED-WITH: bitstreams bs
IN: images.jpeg
-QUALIFIED-WITH: bitstreams bs
+SINGLETON: jpeg-image
+{ "jpg" "jpeg" } [ jpeg-image register-image-class ] each
-TUPLE: jpeg-image < image
+TUPLE: loading-jpeg < image
{ headers }
{ bitstream }
{ color-info initial: { f f f f } }
@@ -21,7 +23,7 @@ TUPLE: jpeg-image < image
<PRIVATE
-CONSTRUCTOR: jpeg-image ( headers bitstream -- image ) ;
+CONSTRUCTOR: loading-jpeg ( headers bitstream -- image ) ;
SINGLETONS: SOF DHT DAC RST SOI EOI SOS DQT DNL DRI DHP EXP
APP JPG COM TEM RES ;
@@ -63,7 +65,7 @@ TUPLE: jpeg-color-info
CONSTRUCTOR: jpeg-color-info ( h v quant-table -- jpeg-color-info ) ;
-: jpeg> ( -- jpeg-image ) jpeg-image get ;
+: jpeg> ( -- jpeg-image ) loading-jpeg get ;
: apply-diff ( dc color -- dc' )
[ diff>> + dup ] [ (>>diff) ] bi ;
@@ -291,9 +293,9 @@ PRIVATE>
binary [
parse-marker { SOI } assert=
parse-headers
- contents <jpeg-image>
+ contents <loading-jpeg>
] with-file-reader
- dup jpeg-image [
+ dup loading-jpeg [
baseline-parse
baseline-decompress
jpeg> bitmap>> 3 <groups> [ color-transform ] change-each
diff --git a/basis/images/loader/loader.factor b/basis/images/loader/loader.factor
index d86b275635..51d4e0fadf 100644
--- a/basis/images/loader/loader.factor
+++ b/basis/images/loader/loader.factor
@@ -1,22 +1,24 @@
-! Copyright (C) 2009 Doug Coleman.
+! 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.bitmap images.tiff images io.pathnames
-images.png ;
+accessors images io.pathnames namespaces assocs ;
IN: images.loader
ERROR: unknown-image-extension extension ;
+<PRIVATE
+
+SYMBOL: types
+types [ H{ } clone ] initialize
+
: image-class ( path -- class )
- file-extension >lower {
- { "bmp" [ bitmap-image ] }
- { "tif" [ tiff-image ] }
- { "tiff" [ tiff-image ] }
- ! { "jpg" [ jpeg-image ] }
- ! { "jpeg" [ jpeg-image ] }
- { "png" [ png-image ] }
- [ unknown-image-extension ]
- } case ;
+ file-extension >lower types get ?at
+ [ unknown-image-extension ] unless ;
+
+PRIVATE>
+
+: register-image-class ( extension class -- )
+ swap types get set-at ;
: load-image ( path -- image )
- dup image-class new load-image* ;
+ dup image-class load-image* ;
diff --git a/basis/images/png/png.factor b/basis/images/png/png.factor
index c5b84de221..fd5e36e212 100755
--- a/basis/images/png/png.factor
+++ b/basis/images/png/png.factor
@@ -3,15 +3,19 @@
USING: accessors constructors 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 ;
+checksums checksums.crc32 compression.inflate grouping byte-arrays
+images.loader ;
IN: images.png
-TUPLE: png-image < image chunks
+SINGLETON: png-image
+"png" png-image register-image-class
+
+TUPLE: loading-png < image chunks
width height bit-depth color-type compression-method
filter-method interlace-method uncompressed ;
-CONSTRUCTOR: png-image ( -- image )
-V{ } clone >>chunks ;
+CONSTRUCTOR: loading-png ( -- image )
+ V{ } clone >>chunks ;
TUPLE: png-chunk length type data ;
@@ -103,9 +107,8 @@ ERROR: unimplemented-color-type image ;
} case ;
: load-png ( path -- image )
- [ binary <file-reader> ] [ file-info size>> ] bi
- stream-throws <limited-stream> [
- <png-image>
+ binary stream-throws <limited-file-reader> [
+ <loading-png>
read-png-header
read-png-chunks
parse-ihdr-chunk
diff --git a/basis/images/tiff/tiff.factor b/basis/images/tiff/tiff.factor
index 27dc25de73..876076e9fe 100755
--- a/basis/images/tiff/tiff.factor
+++ b/basis/images/tiff/tiff.factor
@@ -5,13 +5,14 @@ compression.lzw constructors 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
-strings math.vectors specialized-arrays.float locals ;
+strings math.vectors specialized-arrays.float locals
+images.loader ;
IN: images.tiff
-TUPLE: tiff-image < image ;
+SINGLETON: tiff-image
-TUPLE: parsed-tiff endianness the-answer ifd-offset ifds ;
-CONSTRUCTOR: parsed-tiff ( -- tiff ) V{ } clone >>ifds ;
+TUPLE: loading-tiff endianness the-answer ifd-offset ifds ;
+CONSTRUCTOR: loading-tiff ( -- tiff ) V{ } clone >>ifds ;
TUPLE: ifd count ifd-entries next
processed-tags strips bitmap ;
@@ -409,7 +410,7 @@ ERROR: bad-small-ifd-type n ;
[ nip unhandled-ifd-entry swap ]
} case ;
-: process-ifds ( parsed-tiff -- parsed-tiff )
+: process-ifds ( loading-tiff -- loading-tiff )
[
[
dup ifd-entries>>
@@ -482,18 +483,6 @@ ERROR: unknown-component-order ifd ;
[ unknown-component-order ]
} case ;
-: normalize-alpha-data ( seq -- byte-array )
- B{ } like dup
- byte-array>float-array
- 4 <sliced-groups>
- [
- dup fourth dup 0 = [
- 2drop
- ] [
- [ 3 head-slice ] dip '[ _ / ] change-each
- ] if
- ] each ;
-
: handle-alpha-data ( ifd -- ifd )
dup extra-samples find-tag {
{ extra-samples-associated-alpha-data [ ] }
@@ -507,17 +496,17 @@ ERROR: unknown-component-order ifd ;
[ [ image-width find-tag ] [ image-length find-tag ] bi 2array ]
[ ifd-component-order f ]
[ bitmap>> ]
- } cleave tiff-image boa ;
+ } cleave image boa ;
: tiff>image ( image -- image )
ifds>> [ ifd>image ] map first ;
-: with-tiff-endianness ( parsed-tiff quot -- )
+: with-tiff-endianness ( loading-tiff quot -- )
[ dup endianness>> ] dip with-endianness ; inline
-: load-tiff-ifds ( path -- parsed-tiff )
+: load-tiff-ifds ( path -- loading-tiff )
binary [
- <parsed-tiff>
+ <loading-tiff>
read-header [
dup ifd-offset>> read-ifds
process-ifds
@@ -549,10 +538,10 @@ ERROR: unknown-component-order ifd ;
drop "no planar configuration" throw
] if ;
-: process-tif-ifds ( parsed-tiff -- )
+: process-tif-ifds ( loading-tiff -- )
ifds>> [ process-ifd ] each ;
-: load-tiff ( path -- parsed-tiff )
+: load-tiff ( path -- loading-tiff )
[ load-tiff-ifds dup ] keep
binary [
[ process-tif-ifds ] with-tiff-endianness
@@ -561,3 +550,5 @@ ERROR: unknown-component-order ifd ;
! tiff files can store several images -- we just take the first for now
M: tiff-image load-image* ( path tiff-image -- image )
drop load-tiff tiff>image ;
+
+{ "tif" "tiff" } [ tiff-image register-image-class ] each
diff --git a/basis/io/streams/limited/limited.factor b/basis/io/streams/limited/limited.factor
index b1b07a08c0..fd441e4c4d 100755
--- a/basis/io/streams/limited/limited.factor
+++ b/basis/io/streams/limited/limited.factor
@@ -1,8 +1,9 @@
! Copyright (C) 2008 Slava Pestov.
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math io io.encodings destructors accessors
-sequences namespaces byte-vectors fry combinators ;
+USING: accessors byte-vectors combinators destructors fry io
+io.encodings io.files io.files.info kernel math namespaces
+sequences ;
IN: io.streams.limited
TUPLE: limited-stream stream count limit mode stack ;
@@ -16,6 +17,12 @@ SINGLETONS: stream-throws stream-eofs ;
swap >>stream
0 >>count ;
+: <limited-file-reader> ( path encoding mode -- stream' )
+ [
+ [ <file-reader> ]
+ [ drop file-info size>> ] 2bi
+ ] dip <limited-stream> ;
+
GENERIC# limit 2 ( stream limit mode -- stream' )
M: decoder limit ( stream limit mode -- stream' )
diff --git a/basis/math/bits/bits-docs.factor b/basis/math/bits/bits-docs.factor
index 6ae83f7af0..36043a5576 100644
--- a/basis/math/bits/bits-docs.factor
+++ b/basis/math/bits/bits-docs.factor
@@ -1,6 +1,6 @@
! Copyright (C) 2009 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
-USING: help.syntax help.markup math ;
+USING: help.syntax help.markup math sequences ;
IN: math.bits
ABOUT: "math.bits"
@@ -24,3 +24,7 @@ HELP: make-bits
{ $example "USING: math.bits prettyprint arrays ;" "BIN: 1101 make-bits >array ." "{ t f t t }" }
{ $example "USING: math.bits prettyprint arrays ;" "-3 make-bits >array ." "{ t f }" }
} ;
+
+HELP: unbits
+{ $values { "seq" sequence } { "number" integer } }
+{ $description "Turns a sequence of booleans, of the same format made by the " { $link bits } " class, and calculates the number that it represents as little-endian." } ;
diff --git a/basis/math/bits/bits-tests.factor b/basis/math/bits/bits-tests.factor
index b17d9d8b6e..c6f4c6e8fa 100644
--- a/basis/math/bits/bits-tests.factor
+++ b/basis/math/bits/bits-tests.factor
@@ -29,3 +29,6 @@ IN: math.bits.tests
[ t ] [
1067811677921310779 >bignum make-bits last
] unit-test
+
+[ 6 ] [ 6 make-bits unbits ] unit-test
+[ 6 ] [ 6 3 <bits> >array unbits ] unit-test
diff --git a/basis/math/bits/bits.factor b/basis/math/bits/bits.factor
index 72b83a991f..0fbfdf0bd9 100644
--- a/basis/math/bits/bits.factor
+++ b/basis/math/bits/bits.factor
@@ -14,3 +14,6 @@ M: bits length length>> ;
M: bits nth-unsafe number>> swap bit? ;
INSTANCE: bits immutable-sequence
+
+: unbits ( seq -- number )
+ <reversed> 0 [ [ 1 shift ] dip [ 1+ ] when ] reduce ;
diff --git a/basis/opengl/gl/gl.factor b/basis/opengl/gl/gl.factor
index 39a8a2c4fe..be457dcd00 100644
--- a/basis/opengl/gl/gl.factor
+++ b/basis/opengl/gl/gl.factor
@@ -1872,7 +1872,7 @@ GL-FUNCTION: void glUniform4uivEXT { } ( GLint location, GLsizei count, GLuint*
GL-FUNCTION: void glGetUniformuivEXT { } ( GLuint program, GLint location, GLuint* params ) ;
GL-FUNCTION: void glBindFragDataLocationEXT { } ( GLuint program, GLuint colorNumber, GLchar* name ) ;
-GL-FUNCTION: GLint GetFragDataLocationEXT { } ( GLuint program, GLchar* name ) ;
+GL-FUNCTION: GLint glGetFragDataLocationEXT { } ( GLuint program, GLchar* name ) ;
CONSTANT: GL_VERTEX_ATTRIB_ARRAY_INTEGER_EXT HEX: 88FD
CONSTANT: GL_SAMPLER_1D_ARRAY_EXT HEX: 8DC0
diff --git a/basis/ui/gadgets/worlds/worlds.factor b/basis/ui/gadgets/worlds/worlds.factor
index 38fb220c69..dfce3d3eee 100755
--- a/basis/ui/gadgets/worlds/worlds.factor
+++ b/basis/ui/gadgets/worlds/worlds.factor
@@ -217,4 +217,3 @@ M: world check-world-pixel-format
: with-world-pixel-format ( world quot -- )
[ dup dup world-pixel-format-attributes <pixel-format> ]
dip [ 2dup check-world-pixel-format ] prepose with-disposal ; inline
-
diff --git a/basis/ui/images/images.factor b/basis/ui/images/images.factor
index 2b1caa8ab9..519217a644 100755
--- a/basis/ui/images/images.factor
+++ b/basis/ui/images/images.factor
@@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces cache images images.loader accessors assocs
kernel opengl opengl.gl opengl.textures ui.gadgets.worlds
-memoize ;
+memoize images.tiff ;
IN: ui.images
TUPLE: image-name path ;
@@ -29,4 +29,4 @@ PRIVATE>
rendered-image draw-scaled-texture ;
: image-dim ( image-name -- dim )
- cached-image dim>> ;
\ No newline at end of file
+ cached-image dim>> ;
diff --git a/basis/ui/ui.factor b/basis/ui/ui.factor
index 144530399c..aee19279a4 100644
--- a/basis/ui/ui.factor
+++ b/basis/ui/ui.factor
@@ -206,8 +206,11 @@ PRIVATE>
: open-world-window ( world -- )
dup pref-dim >>dim dup relayout graft ;
+: open-window* ( gadget title/attributes -- window )
+ ?attributes <world> [ open-world-window ] keep ;
+
: open-window ( gadget title/attributes -- )
- ?attributes <world> open-world-window ;
+ open-window* drop ;
: set-fullscreen ( gadget ? -- )
[ find-world ] dip (set-fullscreen) ;
diff --git a/extra/game-loop/game-loop.factor b/extra/game-loop/game-loop.factor
index 8abbe6ba25..982319541b 100644
--- a/extra/game-loop/game-loop.factor
+++ b/extra/game-loop/game-loop.factor
@@ -1,5 +1,5 @@
-USING: accessors calendar destructors kernel math math.order namespaces
-system threads ;
+USING: accessors calendar continuations destructors kernel math
+math.order namespaces system threads ui ui.gadgets.worlds ;
IN: game-loop
TUPLE: game-loop
@@ -27,6 +27,16 @@ SYMBOL: game-loop
CONSTANT: MAX-FRAMES-TO-SKIP 5
+DEFER: stop-loop
+
+TUPLE: game-loop-error game-loop error ;
+
+: ?ui-error ( error -- )
+ ui-running? [ ui-error ] [ rethrow ] if ;
+
+: game-loop-error ( game-loop error -- )
+ [ drop stop-loop ] [ \ game-loop-error boa ?ui-error ] 2bi ;
+
<PRIVATE
: redraw ( loop -- )
@@ -54,7 +64,9 @@ CONSTANT: MAX-FRAMES-TO-SKIP 5
[ drop ] if ;
: run-loop ( loop -- )
- dup game-loop [ (run-loop) ] with-variable ;
+ dup game-loop
+ [ [ (run-loop) ] [ game-loop-error ] recover ]
+ with-variable ;
: benchmark-millis ( loop -- millis )
millis swap benchmark-time>> - ;
@@ -91,3 +103,6 @@ PRIVATE>
M: game-loop dispose
stop-loop ;
+USING: vocabs vocabs.loader ;
+
+"prettyprint" vocab [ "game-loop.prettyprint" require ] when
diff --git a/extra/game-loop/prettyprint/prettyprint.factor b/extra/game-loop/prettyprint/prettyprint.factor
new file mode 100644
index 0000000000..8b20dd4c9d
--- /dev/null
+++ b/extra/game-loop/prettyprint/prettyprint.factor
@@ -0,0 +1,9 @@
+! (c)2009 Joe Groff bsd license
+USING: accessors debugger game-loop io ;
+IN: game-loop.prettyprint
+
+M: game-loop-error error.
+ "An error occurred inside a game loop." print
+ "The game loop has been stopped to prevent runaway errors." print
+ "The error was:" print nl
+ error>> error. ;
diff --git a/extra/images/processing/rotation/rotation-tests.factor b/extra/images/processing/rotation/rotation-tests.factor
index 493f09b145..9d9e72a205 100755
--- a/extra/images/processing/rotation/rotation-tests.factor
+++ b/extra/images/processing/rotation/rotation-tests.factor
@@ -1,6 +1,6 @@
! Copyright (C) 2009 Kobi Lurie, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors fry images.loader images.normalization
+USING: accessors fry images.loader
images.processing.rotation kernel literals math sequences
tools.test images.processing.rotation.private ;
IN: images.processing.rotation.tests
@@ -24,13 +24,13 @@ IN: images.processing.rotation.tests
CONSTANT: pasted-image
$[
"vocab:images/processing/rotation/test-bitmaps/PastedImage.bmp"
- load-image normalize-image clone-image
+ load-image clone-image
]
CONSTANT: pasted-image90
$[
"vocab:images/processing/rotation/test-bitmaps/PastedImage90.bmp"
- load-image normalize-image clone-image
+ load-image clone-image
]
CONSTANT: lake-image
@@ -55,7 +55,7 @@ CONSTANT: lake-image
"vocab:images/processing/rotation/test-bitmaps/small.bmp"
load-image 90 rotate
"vocab:images/processing/rotation/test-bitmaps/small-rotated.bmp"
- load-image normalize-image =
+ load-image =
] unit-test
[ t ] [
diff --git a/extra/managed-server/chat/chat.factor b/extra/managed-server/chat/chat.factor
index 4e841ec95e..f60445c48f 100644
--- a/extra/managed-server/chat/chat.factor
+++ b/extra/managed-server/chat/chat.factor
@@ -126,7 +126,8 @@ M: chat-server handle-client-disconnect
] "" append-outputs-as send-everyone ;
M: chat-server handle-already-logged-in
- username username-taken-string send-line ;
+ username username-taken-string send-line
+ t client (>>quit?) ;
M: chat-server handle-managed-client*
readln dup f = [ t client (>>quit?) ] when
diff --git a/extra/managed-server/managed-server.factor b/extra/managed-server/managed-server.factor
index 4d4a440525..6f9bdf25f1 100644
--- a/extra/managed-server/managed-server.factor
+++ b/extra/managed-server/managed-server.factor
@@ -11,7 +11,7 @@ TUPLE: managed-server < threaded-server clients ;
TUPLE: managed-client
input-stream output-stream local-address remote-address
-username object quit? ;
+username object quit? logged-in? ;
HOOK: handle-login threaded-server ( -- username )
HOOK: handle-managed-client* managed-server ( -- )
@@ -62,26 +62,39 @@ PRIVATE>
local-address get >>local-address
remote-address get >>remote-address ;
-: check-logged-in ( username -- username )
- dup clients key? [ handle-already-logged-in ] when ;
+: maybe-login-client ( -- )
+ username clients key? [
+ handle-already-logged-in
+ ] [
+ t client (>>logged-in?)
+ client username clients set-at
+ ] if ;
-: add-managed-client ( -- )
- client username check-logged-in clients set-at ;
+: when-logged-in ( quot -- )
+ client logged-in?>> [ call ] [ drop ] if ; inline
: delete-managed-client ( -- )
- username server clients>> delete-at ;
+ [ username server clients>> delete-at ] when-logged-in ;
: handle-managed-client ( -- )
handle-login <managed-client> managed-client set
- add-managed-client handle-client-join
- [ handle-managed-client* client quit?>> not ] loop ;
+ maybe-login-client [
+ handle-client-join
+ [ handle-managed-client* client quit?>> not ] loop
+ ] when-logged-in ;
+
+: cleanup-client ( -- )
+ [
+ delete-managed-client
+ handle-client-disconnect
+ ] when-logged-in ;
PRIVATE>
M: managed-server handle-client*
managed-server set
[ handle-managed-client ]
- [ delete-managed-client handle-client-disconnect ]
+ [ cleanup-client ]
[ ] cleanup ;
: new-managed-server ( port name encoding class -- server )
diff --git a/extra/ui/gadgets/worlds/null/null.factor b/extra/ui/gadgets/worlds/null/null.factor
new file mode 100644
index 0000000000..26fc3e8a94
--- /dev/null
+++ b/extra/ui/gadgets/worlds/null/null.factor
@@ -0,0 +1,27 @@
+USING: accessors kernel ui ui.backend ui.gadgets
+ui.gadgets.worlds ui.pixel-formats ;
+IN: ui.gadgets.worlds.null
+
+TUPLE: null-world < world ;
+M: null-world begin-world drop ;
+M: null-world end-world drop ;
+M: null-world draw-world* drop ;
+M: null-world resize-world drop ;
+M: null-world pref-dim* drop { 512 512 } ;
+
+: null-window ( title -- world )
+ <world-attributes>
+ swap >>title
+ null-world >>world-class
+ {
+ windowed
+ double-buffered
+ backing-store
+ T{ depth-bits f 24 }
+ } >>pixel-format-attributes
+ f swap open-window* ;
+
+: into-window ( world quot -- world )
+ [ dup handle>> ] dip with-gl-context ; inline
+
+
diff --git a/vm/data_gc.cpp b/vm/data_gc.cpp
index bcf6387639..6631a046ac 100755
--- a/vm/data_gc.cpp
+++ b/vm/data_gc.cpp
@@ -680,9 +680,15 @@ PRIMITIVE(become)
compile_all_words();
}
-VM_C_API void minor_gc()
+VM_ASM_API void inline_gc(cell *gc_roots_base, cell gc_roots_size)
{
+ for(cell i = 0; i < gc_roots_size; i++)
+ gc_local_push((cell)&gc_roots_base[i]);
+
garbage_collection(data->nursery(),false,0);
+
+ for(cell i = 0; i < gc_roots_size; i++)
+ gc_local_pop();
}
}
diff --git a/vm/data_gc.hpp b/vm/data_gc.hpp
index 2d6a1ab897..334ad5a2bb 100755
--- a/vm/data_gc.hpp
+++ b/vm/data_gc.hpp
@@ -143,6 +143,6 @@ inline static void check_tagged_pointer(cell tagged)
#endif
}
-VM_C_API void minor_gc();
+VM_ASM_API void inline_gc(cell *gc_roots_base, cell gc_roots_size);
}