From 1c89045f0ec02c15c51fa16d6bd6ac376e3f5cc3 Mon Sep 17 00:00:00 2001
From: prunedtree <prunedtree@gmail.com>
Date: Thu, 4 Jun 2009 20:42:29 -0700
Subject: [PATCH 01/35] m^n binary exponentiation of matrices
---
basis/math/matrices/matrices.factor | 11 ++++++++---
1 file changed, 8 insertions(+), 3 deletions(-)
mode change 100755 => 100644 basis/math/matrices/matrices.factor
diff --git a/basis/math/matrices/matrices.factor b/basis/math/matrices/matrices.factor
old mode 100755
new mode 100644
index cfdbe17c06..61e98ee444
--- a/basis/math/matrices/matrices.factor
+++ b/basis/math/matrices/matrices.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays kernel math math.order math.vectors
-sequences sequences.private accessors columns ;
+USING: accessors arrays columns kernel math math.bits
+math.order math.vectors sequences sequences.private ;
IN: math.matrices
! Matrices
@@ -60,4 +60,9 @@ PRIVATE>
gram-schmidt [ normalize ] map ;
: cross-zip ( seq1 seq2 -- seq1xseq2 )
- [ [ 2array ] with map ] curry map ;
\ No newline at end of file
+ [ [ 2array ] with map ] curry map ;
+
+: m^n ( m n -- n )
+ make-bits over first length identity-matrix
+ [ [ dupd m. ] when [ dup m. ] dip ] reduce nip ;
+
From 5e31d6266e86ab68c827adae9b8f2a1c82946659 Mon Sep 17 00:00:00 2001
From: Marc Fauconneau <prunedtree@gmail.com>
Date: Fri, 5 Jun 2009 15:29:36 +0900
Subject: [PATCH 02/35] ML-style (* nested (* comments *) *)
---
extra/nested-comments/nested-comments.factor | 20 ++++++++++++++++++++
1 file changed, 20 insertions(+)
create mode 100644 extra/nested-comments/nested-comments.factor
diff --git a/extra/nested-comments/nested-comments.factor b/extra/nested-comments/nested-comments.factor
new file mode 100644
index 0000000000..94daffec2d
--- /dev/null
+++ b/extra/nested-comments/nested-comments.factor
@@ -0,0 +1,20 @@
+! by blei on #concatenative
+USING: kernel sequences math locals make multiline ;
+IN: nested-comments
+
+:: (subsequences-at) ( sseq seq n -- )
+ sseq seq n start*
+ [ dup , sseq length + [ sseq seq ] dip (subsequences-at) ]
+ when* ;
+
+: subsequences-at ( sseq seq -- indices )
+ [ 0 (subsequences-at) ] { } make ;
+
+: count-subsequences ( sseq seq -- i )
+ subsequences-at length ;
+
+: parse-all-(* ( parsed-vector left-to-parse -- parsed-vector )
+ 1 - "*)" parse-multiline-string [ "(*" ] dip
+ count-subsequences + dup 0 > [ parse-all-(* ] [ drop ] if ;
+
+SYNTAX: (* 1 parse-all-(* ;
\ No newline at end of file
From 9612b430343a8a9fc503edfb420ffe003c9feece Mon Sep 17 00:00:00 2001
From: prunedtree <prunedtree@gmail.com>
Date: Fri, 5 Jun 2009 03:26:50 -0700
Subject: [PATCH 03/35] bit alignement and absolute positionning for bit-reader
---
basis/bitstreams/bitstreams.factor | 19 +++++++++++++------
1 file changed, 13 insertions(+), 6 deletions(-)
diff --git a/basis/bitstreams/bitstreams.factor b/basis/bitstreams/bitstreams.factor
index 4718f137e4..032e851a79 100644
--- a/basis/bitstreams/bitstreams.factor
+++ b/basis/bitstreams/bitstreams.factor
@@ -56,13 +56,20 @@ TUPLE: lsb0-bit-writer < bit-writer ;
GENERIC: peek ( n bitstream -- value )
GENERIC: poke ( value n bitstream -- )
+: get-abp ( bitstream -- abp )
+ [ byte-pos>> 8 * ] [ bit-pos>> + ] bi ; inline
+
+: set-abp ( abp bitstream -- )
+ [ 8 /mod ] dip [ (>>bit-pos) ] [ (>>byte-pos) ] bi ; inline
+
: seek ( n bitstream -- )
- {
- [ byte-pos>> 8 * ]
- [ bit-pos>> + + 8 /mod ]
- [ (>>bit-pos) ]
- [ (>>byte-pos) ]
- } cleave ; inline
+ [ get-abp + ] [ set-abp ] bi ; inline
+
+: (align) ( n m -- n' )
+ [ /mod 0 > [ 1+ ] when ] [ * ] bi ; inline
+
+: align ( n bitstream -- )
+ [ get-abp swap (align) ] [ set-abp ] bi ; inline
: read ( n bitstream -- value )
[ peek ] [ seek ] 2bi ; inline
From f09a2807fa0c9dc0407517e055b5300e6f7be95b Mon Sep 17 00:00:00 2001
From: prunedtree <prunedtree@gmail.com>
Date: Fri, 5 Jun 2009 03:29:12 -0700
Subject: [PATCH 04/35] implemented inflate-raw (uncompressed chunks)
---
basis/compression/inflate/inflate.factor | 433 ++++++++++++-----------
1 file changed, 221 insertions(+), 212 deletions(-)
mode change 100755 => 100644 basis/compression/inflate/inflate.factor
diff --git a/basis/compression/inflate/inflate.factor b/basis/compression/inflate/inflate.factor
old mode 100755
new mode 100644
index 7cb43ac68f..ce352827ea
--- a/basis/compression/inflate/inflate.factor
+++ b/basis/compression/inflate/inflate.factor
@@ -1,212 +1,221 @@
-! Copyright (C) 2009 Marc Fauconneau.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays assocs byte-arrays
-byte-vectors combinators constructors fry grouping hashtables
-compression.huffman images io.binary kernel locals
-math math.bitwise math.order math.ranges multiline sequences
-sorting ;
-IN: compression.inflate
-
-QUALIFIED-WITH: bitstreams bs
-
-<PRIVATE
-
-: enum>seq ( assoc -- seq )
- dup keys [ ] [ max ] map-reduce 1 + f <array>
- [ '[ swap _ set-nth ] assoc-each ] keep ;
-
-ERROR: zlib-unimplemented ;
-ERROR: bad-zlib-data ;
-ERROR: bad-zlib-header ;
-
-:: check-zlib-header ( data -- )
- 16 data bs:peek 2 >le be> 31 mod ! checksum
- 0 assert=
- 4 data bs:read 8 assert= ! compression method: deflate
- 4 data bs:read ! log2(max length)-8, 32K max
- 7 <= [ bad-zlib-header ] unless
- 5 data bs:seek ! drop check bits
- 1 data bs:read 0 assert= ! dictionnary - not allowed in png
- 2 data bs:seek ! compression level; ignore
- ;
-
-:: default-table ( -- table )
- 0 <hashtable> :> table
- 0 143 [a,b] 280 287 [a,b] append 8 table set-at
- 144 255 [a,b] >array 9 table set-at
- 256 279 [a,b] >array 7 table set-at
- table enum>seq 1 tail ;
-
-CONSTANT: clen-shuffle { 16 17 18 0 8 7 9 6 10 5 11 4 12 3 13 2 14 1 15 }
-
-: get-table ( values size -- table )
- 16 f <array> clone <enum>
- [ '[ _ push-at ] 2each ] keep seq>> 1 tail [ natural-sort ] map ;
-
-:: decode-huffman-tables ( bitstream -- tables )
- 5 bitstream bs:read 257 +
- 5 bitstream bs:read 1 +
- 4 bitstream bs:read 4 +
- clen-shuffle swap head
- dup [ drop 3 bitstream bs:read ] map
- get-table
- bitstream swap <huffman-decoder>
- [ 2dup + ] dip swap :> k!
- '[
- _ read1-huff2
- {
- { [ dup 16 = ] [ 2 bitstream bs:read 3 + 2array ] }
- { [ dup 17 = ] [ 3 bitstream bs:read 3 + 2array ] }
- { [ dup 18 = ] [ 7 bitstream bs:read 11 + 2array ] }
- [ ]
- } cond
- dup array? [ dup second ] [ 1 ] if
- k swap - dup k! 0 >
- ]
- [ ] produce swap suffix
- { } [ dup array? [ dup first 16 = ] [ f ] if [ [ unclip-last ] [ second 1+ swap <repetition> append ] bi* ] [ suffix ] if ] reduce
- [ dup array? [ second 0 <repetition> ] [ 1array ] if ] map concat
- nip swap cut 2array [ [ length>> [0,b) ] [ ] bi get-table ] map ;
-
-CONSTANT: length-table
- {
- 3 4 5 6 7 8 9 10
- 11 13 15 17
- 19 23 27 31
- 35 43 51 59
- 67 83 99 115
- 131 163 195 227 258
- }
-
-CONSTANT: dist-table
- {
- 1 2 3 4
- 5 7 9 13
- 17 25 33 49
- 65 97 129 193
- 257 385 513 769
- 1025 1537 2049 3073
- 4097 6145 8193 12289
- 16385 24577
- }
-
-: nth* ( n seq -- elt )
- [ length 1- swap - ] [ nth ] bi ;
-
-:: inflate-lz77 ( seq -- bytes )
- 1000 <byte-vector> :> bytes
- seq
- [
- dup array?
- [ first2 '[ _ 1- bytes nth* bytes push ] times ]
- [ bytes push ] if
- ] each
- bytes ;
-
-:: inflate-dynamic ( bitstream -- bytes )
- bitstream decode-huffman-tables
- bitstream '[ _ swap <huffman-decoder> ] map :> tables
- [
- tables first read1-huff2
- dup 256 >
- [
- dup 285 =
- [ ]
- [
- dup 264 >
- [
- dup 261 - 4 /i dup 5 >
- [ bad-zlib-data ] when
- bitstream bs:read 2array
- ]
- when
- ] if
- ! 5 bitstream read-bits ! distance
- tables second read1-huff2
- dup 3 >
- [
- dup 2 - 2 /i dup 13 >
- [ bad-zlib-data ] when
- bitstream bs:read 2array
- ]
- when
- 2array
- ]
- when
- dup 256 = not
- ]
- [ ] produce nip
- [
- dup array? [
- first2
- [
- dup array? [ first2 ] [ 0 ] if
- [ 257 - length-table nth ] [ + ] bi*
- ]
- [
- dup array? [ first2 ] [ 0 ] if
- [ dist-table nth ] [ + ] bi*
- ] bi*
- 2array
- ] when
- ] map ;
-
-: inflate-raw ( bitstream -- bytes ) zlib-unimplemented ;
-: inflate-static ( bitstream -- bytes ) zlib-unimplemented ;
-
-:: inflate-loop ( bitstream -- bytes )
- [ 1 bitstream bs:read 0 = ]
- [
- bitstream
- 2 bitstream bs:read
- {
- { 0 [ inflate-raw ] }
- { 1 [ inflate-static ] }
- { 2 [ inflate-dynamic ] }
- { 3 [ bad-zlib-data f ] }
- }
- case
- ]
- [ produce ] keep call suffix concat ;
-
- ! [ produce ] keep dip swap suffix
-
-:: paeth ( a b c -- p )
- a b + c - { a b c } [ [ - abs ] keep 2array ] with map
- sort-keys first second ;
-
-:: png-unfilter-line ( prev curr filter -- curr' )
- prev :> c
- prev 3 tail-slice :> b
- curr :> a
- curr 3 tail-slice :> x
- x length [0,b)
- filter
- {
- { 0 [ drop ] }
- { 1 [ [| n | n x nth n a nth + 256 wrap n x set-nth ] each ] }
- { 2 [ [| n | n x nth n b nth + 256 wrap n x set-nth ] each ] }
- { 3 [ [| n | n x nth n a nth n b nth + 2/ + 256 wrap n x set-nth ] each ] }
- { 4 [ [| n | n x nth n a nth n b nth n c nth paeth + 256 wrap n x set-nth ] each ] }
-
- } case
- curr 3 tail ;
-
-PRIVATE>
-
-! for debug -- shows residual values
-: reverse-png-filter' ( lines -- filtered )
- [ first ] [ 1 tail ] [ map ] bi-curry@ bi nip
- concat [ 128 + 256 wrap ] map ;
-
-: reverse-png-filter ( lines -- filtered )
- dup first [ 0 ] replicate prefix
- [ { 0 0 } prepend ] map
- 2 clump [
- first2 dup [ third ] [ 0 2 rot set-nth ] bi png-unfilter-line
- ] map concat ;
-
-: zlib-inflate ( bytes -- bytes )
- bs:<lsb0-bit-reader>
- [ check-zlib-header ] [ inflate-loop ] bi
- inflate-lz77 ;
+! Copyright (C) 2009 Marc Fauconneau.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays assocs byte-arrays
+byte-vectors combinators constructors fry grouping hashtables
+compression.huffman images io.binary kernel locals
+math math.bitwise math.order math.ranges multiline sequences
+sorting ;
+IN: compression.inflate
+
+QUALIFIED-WITH: bitstreams bs
+
+<PRIVATE
+
+: enum>seq ( assoc -- seq )
+ dup keys [ ] [ max ] map-reduce 1 + f <array>
+ [ '[ swap _ set-nth ] assoc-each ] keep ;
+
+ERROR: zlib-unimplemented ;
+ERROR: bad-zlib-data ;
+ERROR: bad-zlib-header ;
+
+:: check-zlib-header ( data -- )
+ 16 data bs:peek 2 >le be> 31 mod ! checksum
+ 0 assert=
+ 4 data bs:read 8 assert= ! compression method: deflate
+ 4 data bs:read ! log2(max length)-8, 32K max
+ 7 <= [ bad-zlib-header ] unless
+ 5 data bs:seek ! drop check bits
+ 1 data bs:read 0 assert= ! dictionnary - not allowed in png
+ 2 data bs:seek ! compression level; ignore
+ ;
+
+:: default-table ( -- table )
+ 0 <hashtable> :> table
+ 0 143 [a,b] 280 287 [a,b] append 8 table set-at
+ 144 255 [a,b] >array 9 table set-at
+ 256 279 [a,b] >array 7 table set-at
+ table enum>seq 1 tail ;
+
+CONSTANT: clen-shuffle { 16 17 18 0 8 7 9 6 10 5 11 4 12 3 13 2 14 1 15 }
+
+: get-table ( values size -- table )
+ 16 f <array> clone <enum>
+ [ '[ _ push-at ] 2each ] keep seq>> 1 tail [ natural-sort ] map ;
+
+:: decode-huffman-tables ( bitstream -- tables )
+ 5 bitstream bs:read 257 +
+ 5 bitstream bs:read 1 +
+ 4 bitstream bs:read 4 +
+ clen-shuffle swap head
+ dup [ drop 3 bitstream bs:read ] map
+ get-table
+ bitstream swap <huffman-decoder>
+ [ 2dup + ] dip swap :> k!
+ '[
+ _ read1-huff2
+ {
+ { [ dup 16 = ] [ 2 bitstream bs:read 3 + 2array ] }
+ { [ dup 17 = ] [ 3 bitstream bs:read 3 + 2array ] }
+ { [ dup 18 = ] [ 7 bitstream bs:read 11 + 2array ] }
+ [ ]
+ } cond
+ dup array? [ dup second ] [ 1 ] if
+ k swap - dup k! 0 >
+ ]
+ [ ] produce swap suffix
+ { } [ dup array? [ dup first 16 = ] [ f ] if [ [ unclip-last ] [ second 1+ swap <repetition> append ] bi* ] [ suffix ] if ] reduce
+ [ dup array? [ second 0 <repetition> ] [ 1array ] if ] map concat
+ nip swap cut 2array [ [ length>> [0,b) ] [ ] bi get-table ] map ;
+
+CONSTANT: length-table
+ {
+ 3 4 5 6 7 8 9 10
+ 11 13 15 17
+ 19 23 27 31
+ 35 43 51 59
+ 67 83 99 115
+ 131 163 195 227 258
+ }
+
+CONSTANT: dist-table
+ {
+ 1 2 3 4
+ 5 7 9 13
+ 17 25 33 49
+ 65 97 129 193
+ 257 385 513 769
+ 1025 1537 2049 3073
+ 4097 6145 8193 12289
+ 16385 24577
+ }
+
+: nth* ( n seq -- elt )
+ [ length 1- swap - ] [ nth ] bi ;
+
+:: inflate-lz77 ( seq -- bytes )
+ 1000 <byte-vector> :> bytes
+ seq
+ [
+ dup array?
+ [ first2 '[ _ 1- bytes nth* bytes push ] times ]
+ [ bytes push ] if
+ ] each
+ bytes ;
+
+:: inflate-dynamic ( bitstream -- bytes )
+ bitstream decode-huffman-tables
+ bitstream '[ _ swap <huffman-decoder> ] map :> tables
+ [
+ tables first read1-huff2
+ dup 256 >
+ [
+ dup 285 =
+ [ ]
+ [
+ dup 264 >
+ [
+ dup 261 - 4 /i dup 5 >
+ [ bad-zlib-data ] when
+ bitstream bs:read 2array
+ ]
+ when
+ ] if
+ ! 5 bitstream read-bits ! distance
+ tables second read1-huff2
+ dup 3 >
+ [
+ dup 2 - 2 /i dup 13 >
+ [ bad-zlib-data ] when
+ bitstream bs:read 2array
+ ]
+ when
+ 2array
+ ]
+ when
+ dup 256 = not
+ ]
+ [ ] produce nip
+ [
+ dup array? [
+ first2
+ [
+ dup array? [ first2 ] [ 0 ] if
+ [ 257 - length-table nth ] [ + ] bi*
+ ]
+ [
+ dup array? [ first2 ] [ 0 ] if
+ [ dist-table nth ] [ + ] bi*
+ ] bi*
+ 2array
+ ] when
+ ] map ;
+
+:: inflate-raw ( bitstream -- bytes )
+ 8 bitstream bs:align
+ 16 bitstream bs:read :> len
+ 16 bitstream bs:read :> nlen
+ len nlen + 16 >signed -1 assert= ! len + ~len = -1
+ bitstream byte-pos>>
+ bitstream byte-pos>> len +
+ bitstream bytes>> <slice>
+ len 8 * bitstream bs:seek ;
+
+: inflate-static ( bitstream -- bytes ) zlib-unimplemented ;
+
+:: inflate-loop ( bitstream -- bytes )
+ [ 1 bitstream bs:read 0 = ]
+ [
+ bitstream
+ 2 bitstream bs:read
+ {
+ { 0 [ inflate-raw ] }
+ { 1 [ inflate-static ] }
+ { 2 [ inflate-dynamic ] }
+ { 3 [ bad-zlib-data f ] }
+ }
+ case
+ ]
+ [ produce ] keep call suffix concat ;
+
+ ! [ produce ] keep dip swap suffix
+
+:: paeth ( a b c -- p )
+ a b + c - { a b c } [ [ - abs ] keep 2array ] with map
+ sort-keys first second ;
+
+:: png-unfilter-line ( prev curr filter -- curr' )
+ prev :> c
+ prev 3 tail-slice :> b
+ curr :> a
+ curr 3 tail-slice :> x
+ x length [0,b)
+ filter
+ {
+ { 0 [ drop ] }
+ { 1 [ [| n | n x nth n a nth + 256 wrap n x set-nth ] each ] }
+ { 2 [ [| n | n x nth n b nth + 256 wrap n x set-nth ] each ] }
+ { 3 [ [| n | n x nth n a nth n b nth + 2/ + 256 wrap n x set-nth ] each ] }
+ { 4 [ [| n | n x nth n a nth n b nth n c nth paeth + 256 wrap n x set-nth ] each ] }
+
+ } case
+ curr 3 tail ;
+
+PRIVATE>
+
+! for debug -- shows residual values
+: reverse-png-filter' ( lines -- filtered )
+ [ first ] [ 1 tail ] [ map ] bi-curry@ bi nip
+ concat [ 128 + 256 wrap ] map ;
+
+: reverse-png-filter ( lines -- filtered )
+ dup first [ 0 ] replicate prefix
+ [ { 0 0 } prepend ] map
+ 2 clump [
+ first2 dup [ third ] [ 0 2 rot set-nth ] bi png-unfilter-line
+ ] map concat ;
+
+: zlib-inflate ( bytes -- bytes )
+ bs:<lsb0-bit-reader>
+ [ check-zlib-header ] [ inflate-loop ] bi
+ inflate-lz77 ;
From 011abaa079169c370ed874917669436066144f64 Mon Sep 17 00:00:00 2001
From: prunedtree <prunedtree@gmail.com>
Date: Fri, 5 Jun 2009 05:28:18 -0700
Subject: [PATCH 05/35] images.jpeg: added support for yuv444 and black and
white images
---
basis/images/jpeg/jpeg.factor | 665 ++++++++++++++++++----------------
1 file changed, 359 insertions(+), 306 deletions(-)
mode change 100755 => 100644 basis/images/jpeg/jpeg.factor
diff --git a/basis/images/jpeg/jpeg.factor b/basis/images/jpeg/jpeg.factor
old mode 100755
new mode 100644
index 2cdc32e9df..b66aed043d
--- a/basis/images/jpeg/jpeg.factor
+++ b/basis/images/jpeg/jpeg.factor
@@ -1,306 +1,359 @@
-! Copyright (C) 2009 Marc Fauconneau.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays byte-arrays combinators
-constructors grouping compression.huffman images
-images.processing io io.binary io.encodings.binary io.files
-io.streams.byte-array kernel locals math math.bitwise
-math.constants math.functions math.matrices math.order
-math.ranges math.vectors memoize multiline namespaces
-sequences sequences.deep images.loader ;
-QUALIFIED-WITH: bitstreams bs
-IN: images.jpeg
-
-SINGLETON: jpeg-image
-{ "jpg" "jpeg" } [ jpeg-image register-image-class ] each
-
-TUPLE: loading-jpeg < image
- { headers }
- { bitstream }
- { color-info initial: { f f f f } }
- { quant-tables initial: { f f } }
- { huff-tables initial: { f f f f } }
- { components } ;
-
-<PRIVATE
-
-CONSTRUCTOR: loading-jpeg ( headers bitstream -- image ) ;
-
-SINGLETONS: SOF DHT DAC RST SOI EOI SOS DQT DNL DRI DHP EXP
-APP JPG COM TEM RES ;
-
-! ISO/IEC 10918-1 Table B.1
-:: >marker ( byte -- marker )
- byte
- {
- { [ dup HEX: CC = ] [ { DAC } ] }
- { [ dup HEX: C4 = ] [ { DHT } ] }
- { [ dup HEX: C9 = ] [ { JPG } ] }
- { [ dup -4 shift HEX: C = ] [ SOF byte 4 bits 2array ] }
-
- { [ dup HEX: D8 = ] [ { SOI } ] }
- { [ dup HEX: D9 = ] [ { EOI } ] }
- { [ dup HEX: DA = ] [ { SOS } ] }
- { [ dup HEX: DB = ] [ { DQT } ] }
- { [ dup HEX: DC = ] [ { DNL } ] }
- { [ dup HEX: DD = ] [ { DRI } ] }
- { [ dup HEX: DE = ] [ { DHP } ] }
- { [ dup HEX: DF = ] [ { EXP } ] }
- { [ dup -4 shift HEX: D = ] [ RST byte 4 bits 2array ] }
-
- { [ dup -4 shift HEX: E = ] [ APP byte 4 bits 2array ] }
- { [ dup HEX: FE = ] [ { COM } ] }
- { [ dup -4 shift HEX: F = ] [ JPG byte 4 bits 2array ] }
-
- { [ dup HEX: 01 = ] [ { TEM } ] }
- [ { RES } ]
- }
- cond nip ;
-
-TUPLE: jpeg-chunk length type data ;
-
-CONSTRUCTOR: jpeg-chunk ( type length data -- jpeg-chunk ) ;
-
-TUPLE: jpeg-color-info
- h v quant-table dc-huff-table ac-huff-table { diff initial: 0 } id ;
-
-CONSTRUCTOR: jpeg-color-info ( h v quant-table -- jpeg-color-info ) ;
-
-: jpeg> ( -- jpeg-image ) loading-jpeg get ;
-
-: apply-diff ( dc color -- dc' )
- [ diff>> + dup ] [ (>>diff) ] bi ;
-
-: fetch-tables ( component -- )
- [ [ jpeg> quant-tables>> nth ] change-quant-table drop ]
- [ [ jpeg> huff-tables>> nth ] change-dc-huff-table drop ]
- [ [ 2 + jpeg> huff-tables>> nth ] change-ac-huff-table drop ] tri ;
-
-: read4/4 ( -- a b ) read1 16 /mod ;
-
-
-! headers
-
-: decode-frame ( header -- )
- data>>
- binary
- [
- read1 8 assert=
- 2 read be>
- 2 read be>
- swap 2array jpeg> (>>dim)
- read1
- [
- read1 read4/4 read1 <jpeg-color-info>
- swap [ >>id ] keep jpeg> color-info>> set-nth
- ] times
- ] with-byte-reader ;
-
-: decode-quant-table ( chunk -- )
- dup data>>
- binary
- [
- length>>
- 2 - 65 /
- [
- read4/4 [ 0 assert= ] dip
- 64 read
- swap jpeg> quant-tables>> set-nth
- ] times
- ] with-byte-reader ;
-
-: decode-huff-table ( chunk -- )
- data>>
- binary
- [
- 1 ! %fixme: Should handle multiple tables at once
- [
- read4/4 swap 2 * +
- 16 read
- dup [ ] [ + ] map-reduce read
- binary [ [ read [ B{ } ] unless* ] { } map-as ] with-byte-reader
- swap jpeg> huff-tables>> set-nth
- ] times
- ] with-byte-reader ;
-
-: decode-scan ( chunk -- )
- data>>
- binary
- [
- read1 [0,b)
- [ drop
- read1 jpeg> color-info>> nth clone
- read1 16 /mod [ >>dc-huff-table ] [ >>ac-huff-table ] bi*
- ] map jpeg> (>>components)
- read1 0 assert=
- read1 63 assert=
- read1 16 /mod [ 0 assert= ] bi@
- ] with-byte-reader ;
-
-: singleton-first ( seq -- elt )
- [ length 1 assert= ] [ first ] bi ;
-
-: baseline-parse ( -- )
- jpeg> headers>>
- {
- [ [ type>> { SOF 0 } = ] filter singleton-first decode-frame ]
- [ [ type>> { DQT } = ] filter [ decode-quant-table ] each ]
- [ [ type>> { DHT } = ] filter [ decode-huff-table ] each ]
- [ [ type>> { SOS } = ] filter singleton-first decode-scan ]
- } cleave ;
-
-: parse-marker ( -- marker )
- read1 HEX: FF assert=
- read1 >marker ;
-
-: parse-headers ( -- chunks )
- [ parse-marker dup { SOS } = not ]
- [
- 2 read be>
- dup 2 - read <jpeg-chunk>
- ] [ produce ] keep dip swap suffix ;
-
-MEMO: zig-zag ( -- zz )
- {
- { 0 1 5 6 14 15 27 28 }
- { 2 4 7 13 16 26 29 42 }
- { 3 8 12 17 25 30 41 43 }
- { 9 11 18 24 31 40 44 53 }
- { 10 19 23 32 39 45 52 54 }
- { 20 22 33 38 46 51 55 60 }
- { 21 34 37 47 50 56 59 61 }
- { 35 36 48 49 57 58 62 63 }
- } flatten ;
-
-MEMO: yuv>bgr-matrix ( -- m )
- {
- { 1 2.03211 0 }
- { 1 -0.39465 -0.58060 }
- { 1 0 1.13983 }
- } ;
-
-: wave ( x u -- n ) swap 2 * 1 + * pi * 16 / cos ;
-
-:: dct-vect ( u v -- basis )
- { 8 8 } coord-matrix [ { u v } [ wave ] 2map product ] map^2
- 1 u v [ 0 = [ 2 sqrt / ] when ] bi@ 4 / m*n ;
-
-MEMO: dct-matrix ( -- m ) 64 [0,b) [ 8 /mod dct-vect flatten ] map ;
-
-: mb-dim ( component -- dim ) [ h>> ] [ v>> ] bi 2array ;
-
-: all-macroblocks ( quot: ( mb -- ) -- )
- [
- jpeg>
- [ dim>> 8 v/n ]
- [ color-info>> sift { 0 0 } [ mb-dim vmax ] reduce v/ ] bi
- [ ceiling ] map
- coord-matrix flip concat
- ]
- [ each ] bi* ; inline
-
-: reverse-zigzag ( b -- b' ) zig-zag swap [ nth ] curry map ;
-
-: idct-factor ( b -- b' ) dct-matrix v.m ;
-
-USE: math.blas.vectors
-USE: math.blas.matrices
-
-MEMO: dct-matrix-blas ( -- m ) dct-matrix >float-blas-matrix ;
-: V.M ( x A -- x.A ) Mtranspose swap M.V ;
-: idct-blas ( b -- b' ) >float-blas-vector dct-matrix-blas V.M ;
-
-: idct ( b -- b' ) idct-blas ;
-
-:: draw-block ( block x,y color jpeg-image -- )
- block dup length>> sqrt >fixnum group flip
- dup matrix-dim coord-matrix flip
- [
- [ first2 spin nth nth ]
- [ x,y v+ color id>> 1- jpeg-image draw-color ] bi
- ] with each^2 ;
-
-: sign-extend ( bits v -- v' )
- swap [ ] [ 1- 2^ < ] 2bi
- [ -1 swap shift 1+ + ] [ drop ] if ;
-
-: read1-jpeg-dc ( decoder -- dc )
- [ read1-huff dup ] [ bs>> bs:read ] bi sign-extend ;
-
-: read1-jpeg-ac ( decoder -- run/ac )
- [ read1-huff 16 /mod dup ] [ bs>> bs:read ] bi sign-extend 2array ;
-
-:: decode-block ( pos color -- )
- color dc-huff-table>> read1-jpeg-dc color apply-diff
- 64 0 <array> :> coefs
- 0 coefs set-nth
- 0 :> k!
- [
- color ac-huff-table>> read1-jpeg-ac
- [ first 1+ k + k! ] [ second k coefs set-nth ] [ ] tri
- { 0 0 } = not
- k 63 < and
- ] loop
- coefs color quant-table>> v*
- reverse-zigzag idct
- ! %fixme: color hack
- ! this eat 50% cpu time
- color h>> 2 =
- [ 8 group 2 matrix-zoom concat ] unless
- pos { 8 8 } v* color jpeg> draw-block ;
-
-: decode-macroblock ( mb -- )
- jpeg> components>>
- [
- [ mb-dim coord-matrix flip concat [ [ { 2 2 } v* ] [ v+ ] bi* ] with map ]
- [ [ decode-block ] curry each ] bi
- ] with each ;
-
-: cleanup-bitstream ( bytes -- bytes' )
- binary [
- [
- { HEX: FF } read-until
- read1 tuck HEX: 00 = and
- ]
- [ drop ] produce
- swap >marker { EOI } assert=
- swap suffix
- { HEX: FF } join
- ] with-byte-reader ;
-
-: setup-bitmap ( image -- )
- dup dim>> 16 v/n [ ceiling ] map 16 v*n >>dim
- BGR >>component-order
- f >>upside-down?
- dup dim>> first2 * 3 * 0 <array> >>bitmap
- drop ;
-
-: baseline-decompress ( -- )
- jpeg> bitstream>> cleanup-bitstream { 255 255 255 255 } append
- >byte-array bs:<msb0-bit-reader> jpeg> (>>bitstream)
- jpeg> [ bitstream>> ] [ [ [ <huffman-decoder> ] with map ] change-huff-tables drop ] bi
- jpeg> components>> [ fetch-tables ] each
- jpeg> setup-bitmap
- [ decode-macroblock ] all-macroblocks ;
-
-! this eats ~25% cpu time
-: color-transform ( yuv -- rgb )
- { 128 0 0 } v+ yuv>bgr-matrix swap m.v
- [ 0 max 255 min >fixnum ] map ;
-
-PRIVATE>
-
-: load-jpeg ( path -- image )
- binary [
- parse-marker { SOI } assert=
- parse-headers
- contents <loading-jpeg>
- ] with-file-reader
- dup loading-jpeg [
- baseline-parse
- baseline-decompress
- jpeg> bitmap>> 3 <groups> [ color-transform ] change-each
- jpeg> [ >byte-array ] change-bitmap drop
- ] with-variable ;
-
-M: jpeg-image load-image* ( path jpeg-image -- bitmap )
- drop load-jpeg ;
+! Copyright (C) 2009 Marc Fauconneau.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays byte-arrays combinators
+constructors grouping compression.huffman images
+images.processing io io.binary io.encodings.binary io.files
+io.streams.byte-array kernel locals math math.bitwise
+math.constants math.functions math.matrices math.order
+math.ranges math.vectors memoize multiline namespaces
+sequences sequences.deep ;
+IN: images.jpeg
+
+QUALIFIED-WITH: bitstreams bs
+
+TUPLE: jpeg-image < image
+ { headers }
+ { bitstream }
+ { color-info initial: { f f f f } }
+ { quant-tables initial: { f f } }
+ { huff-tables initial: { f f f f } }
+ { components } ;
+
+<PRIVATE
+
+CONSTRUCTOR: jpeg-image ( headers bitstream -- image ) ;
+
+SINGLETONS: SOF DHT DAC RST SOI EOI SOS DQT DNL DRI DHP EXP
+APP JPG COM TEM RES ;
+
+! ISO/IEC 10918-1 Table B.1
+:: >marker ( byte -- marker )
+ byte
+ {
+ { [ dup HEX: CC = ] [ { DAC } ] }
+ { [ dup HEX: C4 = ] [ { DHT } ] }
+ { [ dup HEX: C9 = ] [ { JPG } ] }
+ { [ dup -4 shift HEX: C = ] [ SOF byte 4 bits 2array ] }
+
+ { [ dup HEX: D8 = ] [ { SOI } ] }
+ { [ dup HEX: D9 = ] [ { EOI } ] }
+ { [ dup HEX: DA = ] [ { SOS } ] }
+ { [ dup HEX: DB = ] [ { DQT } ] }
+ { [ dup HEX: DC = ] [ { DNL } ] }
+ { [ dup HEX: DD = ] [ { DRI } ] }
+ { [ dup HEX: DE = ] [ { DHP } ] }
+ { [ dup HEX: DF = ] [ { EXP } ] }
+ { [ dup -4 shift HEX: D = ] [ RST byte 4 bits 2array ] }
+
+ { [ dup -4 shift HEX: E = ] [ APP byte 4 bits 2array ] }
+ { [ dup HEX: FE = ] [ { COM } ] }
+ { [ dup -4 shift HEX: F = ] [ JPG byte 4 bits 2array ] }
+
+ { [ dup HEX: 01 = ] [ { TEM } ] }
+ [ { RES } ]
+ }
+ cond nip ;
+
+TUPLE: jpeg-chunk length type data ;
+
+CONSTRUCTOR: jpeg-chunk ( type length data -- jpeg-chunk ) ;
+
+TUPLE: jpeg-color-info
+ h v quant-table dc-huff-table ac-huff-table { diff initial: 0 } id ;
+
+CONSTRUCTOR: jpeg-color-info ( h v quant-table -- jpeg-color-info ) ;
+
+: jpeg> ( -- jpeg-image ) jpeg-image get ;
+
+: apply-diff ( dc color -- dc' )
+ [ diff>> + dup ] [ (>>diff) ] bi ;
+
+: fetch-tables ( component -- )
+ [ [ jpeg> quant-tables>> nth ] change-quant-table drop ]
+ [ [ jpeg> huff-tables>> nth ] change-dc-huff-table drop ]
+ [ [ 2 + jpeg> huff-tables>> nth ] change-ac-huff-table drop ] tri ;
+
+: read4/4 ( -- a b ) read1 16 /mod ;
+
+! headers
+
+: decode-frame ( header -- )
+ data>>
+ binary
+ [
+ read1 8 assert=
+ 2 read be>
+ 2 read be>
+ swap 2array jpeg> (>>dim)
+ read1
+ [
+ read1 read4/4 read1 <jpeg-color-info>
+ swap [ >>id ] keep jpeg> color-info>> set-nth
+ ] times
+ ] with-byte-reader ;
+
+: decode-quant-table ( chunk -- )
+ dup data>>
+ binary
+ [
+ length>>
+ 2 - 65 /
+ [
+ read4/4 [ 0 assert= ] dip
+ 64 read
+ swap jpeg> quant-tables>> set-nth
+ ] times
+ ] with-byte-reader ;
+
+: decode-huff-table ( chunk -- )
+ data>>
+ binary
+ [
+ 1 ! %fixme: Should handle multiple tables at once
+ [
+ read4/4 swap 2 * +
+ 16 read
+ dup [ ] [ + ] map-reduce read
+ binary [ [ read [ B{ } ] unless* ] { } map-as ] with-byte-reader
+ swap jpeg> huff-tables>> set-nth
+ ] times
+ ] with-byte-reader ;
+
+: decode-scan ( chunk -- )
+ data>>
+ binary
+ [
+ read1 [0,b)
+ [ drop
+ read1 jpeg> color-info>> nth clone
+ read1 16 /mod [ >>dc-huff-table ] [ >>ac-huff-table ] bi*
+ ] map jpeg> (>>components)
+ read1 0 assert=
+ read1 63 assert=
+ read1 16 /mod [ 0 assert= ] bi@
+ ] with-byte-reader ;
+
+: singleton-first ( seq -- elt )
+ [ length 1 assert= ] [ first ] bi ;
+
+: baseline-parse ( -- )
+ jpeg> headers>>
+ {
+ [ [ type>> { SOF 0 } = ] filter singleton-first decode-frame ]
+ [ [ type>> { DQT } = ] filter [ decode-quant-table ] each ]
+ [ [ type>> { DHT } = ] filter [ decode-huff-table ] each ]
+ [ [ type>> { SOS } = ] filter singleton-first decode-scan ]
+ } cleave ;
+
+: parse-marker ( -- marker )
+ read1 HEX: FF assert=
+ read1 >marker ;
+
+: parse-headers ( -- chunks )
+ [ parse-marker dup { SOS } = not ]
+ [
+ 2 read be>
+ dup 2 - read <jpeg-chunk>
+ ] [ produce ] keep dip swap suffix ;
+
+MEMO: zig-zag ( -- zz )
+ {
+ { 0 1 5 6 14 15 27 28 }
+ { 2 4 7 13 16 26 29 42 }
+ { 3 8 12 17 25 30 41 43 }
+ { 9 11 18 24 31 40 44 53 }
+ { 10 19 23 32 39 45 52 54 }
+ { 20 22 33 38 46 51 55 60 }
+ { 21 34 37 47 50 56 59 61 }
+ { 35 36 48 49 57 58 62 63 }
+ } flatten ;
+
+MEMO: yuv>bgr-matrix ( -- m )
+ {
+ { 1 2.03211 0 }
+ { 1 -0.39465 -0.58060 }
+ { 1 0 1.13983 }
+ } ;
+
+: wave ( x u -- n ) swap 2 * 1 + * pi * 16 / cos ;
+
+:: dct-vect ( u v -- basis )
+ { 8 8 } coord-matrix [ { u v } [ wave ] 2map product ] map^2
+ 1 u v [ 0 = [ 2 sqrt / ] when ] bi@ 4 / m*n ;
+
+MEMO: dct-matrix ( -- m ) 64 [0,b) [ 8 /mod dct-vect flatten ] map ;
+
+: mb-dim ( component -- dim ) [ h>> ] [ v>> ] bi 2array ;
+
+! : blocks ( component -- seq )
+! mb-dim ! coord-matrix flip concat [ [ { 2 2 } v* ] [ v+ ] bi* ] with map ;
+
+: all-macroblocks ( quot: ( mb -- ) -- )
+ [
+ jpeg>
+ [ dim>> 8 v/n ]
+ [ color-info>> sift { 0 0 } [ mb-dim vmax ] reduce v/ ] bi
+ [ ceiling ] map
+ coord-matrix flip concat
+ ]
+ [ each ] bi* ; inline
+
+: reverse-zigzag ( b -- b' ) zig-zag swap [ nth ] curry map ;
+
+: idct-factor ( b -- b' ) dct-matrix v.m ;
+
+USE: math.blas.vectors
+USE: math.blas.matrices
+
+MEMO: dct-matrix-blas ( -- m ) dct-matrix >float-blas-matrix ;
+: V.M ( x A -- x.A ) Mtranspose swap M.V ;
+: idct-blas ( b -- b' ) >float-blas-vector dct-matrix-blas V.M ;
+
+: idct ( b -- b' ) idct-blas ;
+
+:: draw-block ( block x,y color-id jpeg-image -- )
+ block dup length>> sqrt >fixnum group flip
+ dup matrix-dim coord-matrix flip
+ [
+ [ first2 spin nth nth ]
+ [ x,y v+ color-id jpeg-image draw-color ] bi
+ ] with each^2 ;
+
+: sign-extend ( bits v -- v' )
+ swap [ ] [ 1- 2^ < ] 2bi
+ [ -1 swap shift 1+ + ] [ drop ] if ;
+
+: read1-jpeg-dc ( decoder -- dc )
+ [ read1-huff dup ] [ bs>> bs:read ] bi sign-extend ;
+
+: read1-jpeg-ac ( decoder -- run/ac )
+ [ read1-huff 16 /mod dup ] [ bs>> bs:read ] bi sign-extend 2array ;
+
+:: decode-block ( color -- pixels )
+ color dc-huff-table>> read1-jpeg-dc color apply-diff
+ 64 0 <array> :> coefs
+ 0 coefs set-nth
+ 0 :> k!
+ [
+ color ac-huff-table>> read1-jpeg-ac
+ [ first 1+ k + k! ] [ second k coefs set-nth ] [ ] tri
+ { 0 0 } = not
+ k 63 < and
+ ] loop
+ coefs color quant-table>> v*
+ reverse-zigzag idct ;
+
+:: draw-macroblock-yuv420 ( mb blocks -- )
+ mb { 16 16 } v* :> pos
+ 0 blocks nth pos { 0 0 } v+ 0 jpeg> draw-block
+ 1 blocks nth pos { 8 0 } v+ 0 jpeg> draw-block
+ 2 blocks nth pos { 0 8 } v+ 0 jpeg> draw-block
+ 3 blocks nth pos { 8 8 } v+ 0 jpeg> draw-block
+ 4 blocks nth 8 group 2 matrix-zoom concat pos 1 jpeg> draw-block
+ 5 blocks nth 8 group 2 matrix-zoom concat pos 2 jpeg> draw-block ;
+
+:: draw-macroblock-yuv444 ( mb blocks -- )
+ mb { 8 8 } v* :> pos
+ 3 iota [ [ blocks nth pos ] [ jpeg> draw-block ] bi ] each ;
+
+:: draw-macroblock-y ( mb blocks -- )
+ mb { 8 8 } v* :> pos
+ 0 blocks nth pos 0 jpeg> draw-block
+ 64 0 <array> pos 1 jpeg> draw-block
+ 64 0 <array> pos 2 jpeg> draw-block ;
+
+ ! %fixme: color hack
+ ! color h>> 2 =
+ ! [ 8 group 2 matrix-zoom concat ] unless
+ ! pos { 8 8 } v* color jpeg> draw-block ;
+
+: decode-macroblock ( -- blocks )
+ jpeg> components>>
+ [
+ [ mb-dim first2 * iota ]
+ [ [ decode-block ] curry replicate ] bi
+ ] map concat ;
+
+: cleanup-bitstream ( bytes -- bytes' )
+ binary [
+ [
+ { HEX: FF } read-until
+ read1 tuck HEX: 00 = and
+ ]
+ [ drop ] produce
+ swap >marker { EOI } assert=
+ swap suffix
+ { HEX: FF } join
+ ] with-byte-reader ;
+
+: setup-bitmap ( image -- )
+ dup dim>> 16 v/n [ ceiling ] map 16 v*n >>dim
+ BGR >>component-order
+ f >>upside-down?
+ dup dim>> first2 * 3 * 0 <array> >>bitmap
+ drop ;
+
+ERROR: unsupported-colorspace ;
+SINGLETONS: YUV420 YUV444 Y MAGIC! ;
+
+:: detect-colorspace ( jpeg-image -- csp )
+ jpeg-image color-info>> sift :> colors
+ MAGIC!
+ colors length 1 = [ drop Y ] when
+ colors length 3 =
+ [
+ colors [ mb-dim { 1 1 } = ] all?
+ [ drop YUV444 ] when
+
+ colors unclip
+ [ [ mb-dim { 1 1 } = ] all? ]
+ [ mb-dim { 2 2 } = ] bi* and
+ [ drop YUV420 ] when
+ ] when ;
+
+! this eats ~50% cpu time
+: draw-macroblocks ( mbs -- )
+ jpeg> detect-colorspace
+ {
+ { YUV420 [ [ first2 draw-macroblock-yuv420 ] each ] }
+ { YUV444 [ [ first2 draw-macroblock-yuv444 ] each ] }
+ { Y [ [ first2 draw-macroblock-y ] each ] }
+ [ unsupported-colorspace ]
+ } case ;
+
+! this eats ~25% cpu time
+: color-transform ( yuv -- rgb )
+ { 128 0 0 } v+ yuv>bgr-matrix swap m.v
+ [ 0 max 255 min >fixnum ] map ;
+
+: baseline-decompress ( -- )
+ jpeg> bitstream>> cleanup-bitstream { 255 255 255 255 } append
+ >byte-array bs:<msb0-bit-reader> jpeg> (>>bitstream)
+ jpeg>
+ [ bitstream>> ]
+ [ [ [ <huffman-decoder> ] with map ] change-huff-tables drop ] bi
+ jpeg> components>> [ fetch-tables ] each
+ [ decode-macroblock 2array ] accumulator
+ [ all-macroblocks ] dip
+ jpeg> setup-bitmap draw-macroblocks
+ jpeg> bitmap>> 3 <groups> [ color-transform ] change-each
+ jpeg> [ >byte-array ] change-bitmap drop ;
+
+ERROR: not-a-jpeg-image ;
+
+PRIVATE>
+
+: load-jpeg ( path -- image )
+ binary [
+ parse-marker { SOI } = [ not-a-jpeg-image ] unless
+ parse-headers
+ contents <jpeg-image>
+ ] with-file-reader
+ dup jpeg-image [
+ baseline-parse
+ baseline-decompress
+ ] with-variable ;
+
+M: jpeg-image load-image* ( path jpeg-image -- bitmap )
+ drop load-jpeg ;
+
From 88f8af4b697f8ff271854685be894869412fd2f4 Mon Sep 17 00:00:00 2001
From: Marc Fauconneau <prunedtree@gmail.com>
Date: Fri, 5 Jun 2009 21:33:04 +0900
Subject: [PATCH 06/35] images.jpeg: added support for yuv444 and black and
white images
---
basis/images/jpeg/jpeg.factor | 665 ++++++++++++++++++----------------
1 file changed, 359 insertions(+), 306 deletions(-)
diff --git a/basis/images/jpeg/jpeg.factor b/basis/images/jpeg/jpeg.factor
index 2cdc32e9df..b66aed043d 100755
--- a/basis/images/jpeg/jpeg.factor
+++ b/basis/images/jpeg/jpeg.factor
@@ -1,306 +1,359 @@
-! Copyright (C) 2009 Marc Fauconneau.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays byte-arrays combinators
-constructors grouping compression.huffman images
-images.processing io io.binary io.encodings.binary io.files
-io.streams.byte-array kernel locals math math.bitwise
-math.constants math.functions math.matrices math.order
-math.ranges math.vectors memoize multiline namespaces
-sequences sequences.deep images.loader ;
-QUALIFIED-WITH: bitstreams bs
-IN: images.jpeg
-
-SINGLETON: jpeg-image
-{ "jpg" "jpeg" } [ jpeg-image register-image-class ] each
-
-TUPLE: loading-jpeg < image
- { headers }
- { bitstream }
- { color-info initial: { f f f f } }
- { quant-tables initial: { f f } }
- { huff-tables initial: { f f f f } }
- { components } ;
-
-<PRIVATE
-
-CONSTRUCTOR: loading-jpeg ( headers bitstream -- image ) ;
-
-SINGLETONS: SOF DHT DAC RST SOI EOI SOS DQT DNL DRI DHP EXP
-APP JPG COM TEM RES ;
-
-! ISO/IEC 10918-1 Table B.1
-:: >marker ( byte -- marker )
- byte
- {
- { [ dup HEX: CC = ] [ { DAC } ] }
- { [ dup HEX: C4 = ] [ { DHT } ] }
- { [ dup HEX: C9 = ] [ { JPG } ] }
- { [ dup -4 shift HEX: C = ] [ SOF byte 4 bits 2array ] }
-
- { [ dup HEX: D8 = ] [ { SOI } ] }
- { [ dup HEX: D9 = ] [ { EOI } ] }
- { [ dup HEX: DA = ] [ { SOS } ] }
- { [ dup HEX: DB = ] [ { DQT } ] }
- { [ dup HEX: DC = ] [ { DNL } ] }
- { [ dup HEX: DD = ] [ { DRI } ] }
- { [ dup HEX: DE = ] [ { DHP } ] }
- { [ dup HEX: DF = ] [ { EXP } ] }
- { [ dup -4 shift HEX: D = ] [ RST byte 4 bits 2array ] }
-
- { [ dup -4 shift HEX: E = ] [ APP byte 4 bits 2array ] }
- { [ dup HEX: FE = ] [ { COM } ] }
- { [ dup -4 shift HEX: F = ] [ JPG byte 4 bits 2array ] }
-
- { [ dup HEX: 01 = ] [ { TEM } ] }
- [ { RES } ]
- }
- cond nip ;
-
-TUPLE: jpeg-chunk length type data ;
-
-CONSTRUCTOR: jpeg-chunk ( type length data -- jpeg-chunk ) ;
-
-TUPLE: jpeg-color-info
- h v quant-table dc-huff-table ac-huff-table { diff initial: 0 } id ;
-
-CONSTRUCTOR: jpeg-color-info ( h v quant-table -- jpeg-color-info ) ;
-
-: jpeg> ( -- jpeg-image ) loading-jpeg get ;
-
-: apply-diff ( dc color -- dc' )
- [ diff>> + dup ] [ (>>diff) ] bi ;
-
-: fetch-tables ( component -- )
- [ [ jpeg> quant-tables>> nth ] change-quant-table drop ]
- [ [ jpeg> huff-tables>> nth ] change-dc-huff-table drop ]
- [ [ 2 + jpeg> huff-tables>> nth ] change-ac-huff-table drop ] tri ;
-
-: read4/4 ( -- a b ) read1 16 /mod ;
-
-
-! headers
-
-: decode-frame ( header -- )
- data>>
- binary
- [
- read1 8 assert=
- 2 read be>
- 2 read be>
- swap 2array jpeg> (>>dim)
- read1
- [
- read1 read4/4 read1 <jpeg-color-info>
- swap [ >>id ] keep jpeg> color-info>> set-nth
- ] times
- ] with-byte-reader ;
-
-: decode-quant-table ( chunk -- )
- dup data>>
- binary
- [
- length>>
- 2 - 65 /
- [
- read4/4 [ 0 assert= ] dip
- 64 read
- swap jpeg> quant-tables>> set-nth
- ] times
- ] with-byte-reader ;
-
-: decode-huff-table ( chunk -- )
- data>>
- binary
- [
- 1 ! %fixme: Should handle multiple tables at once
- [
- read4/4 swap 2 * +
- 16 read
- dup [ ] [ + ] map-reduce read
- binary [ [ read [ B{ } ] unless* ] { } map-as ] with-byte-reader
- swap jpeg> huff-tables>> set-nth
- ] times
- ] with-byte-reader ;
-
-: decode-scan ( chunk -- )
- data>>
- binary
- [
- read1 [0,b)
- [ drop
- read1 jpeg> color-info>> nth clone
- read1 16 /mod [ >>dc-huff-table ] [ >>ac-huff-table ] bi*
- ] map jpeg> (>>components)
- read1 0 assert=
- read1 63 assert=
- read1 16 /mod [ 0 assert= ] bi@
- ] with-byte-reader ;
-
-: singleton-first ( seq -- elt )
- [ length 1 assert= ] [ first ] bi ;
-
-: baseline-parse ( -- )
- jpeg> headers>>
- {
- [ [ type>> { SOF 0 } = ] filter singleton-first decode-frame ]
- [ [ type>> { DQT } = ] filter [ decode-quant-table ] each ]
- [ [ type>> { DHT } = ] filter [ decode-huff-table ] each ]
- [ [ type>> { SOS } = ] filter singleton-first decode-scan ]
- } cleave ;
-
-: parse-marker ( -- marker )
- read1 HEX: FF assert=
- read1 >marker ;
-
-: parse-headers ( -- chunks )
- [ parse-marker dup { SOS } = not ]
- [
- 2 read be>
- dup 2 - read <jpeg-chunk>
- ] [ produce ] keep dip swap suffix ;
-
-MEMO: zig-zag ( -- zz )
- {
- { 0 1 5 6 14 15 27 28 }
- { 2 4 7 13 16 26 29 42 }
- { 3 8 12 17 25 30 41 43 }
- { 9 11 18 24 31 40 44 53 }
- { 10 19 23 32 39 45 52 54 }
- { 20 22 33 38 46 51 55 60 }
- { 21 34 37 47 50 56 59 61 }
- { 35 36 48 49 57 58 62 63 }
- } flatten ;
-
-MEMO: yuv>bgr-matrix ( -- m )
- {
- { 1 2.03211 0 }
- { 1 -0.39465 -0.58060 }
- { 1 0 1.13983 }
- } ;
-
-: wave ( x u -- n ) swap 2 * 1 + * pi * 16 / cos ;
-
-:: dct-vect ( u v -- basis )
- { 8 8 } coord-matrix [ { u v } [ wave ] 2map product ] map^2
- 1 u v [ 0 = [ 2 sqrt / ] when ] bi@ 4 / m*n ;
-
-MEMO: dct-matrix ( -- m ) 64 [0,b) [ 8 /mod dct-vect flatten ] map ;
-
-: mb-dim ( component -- dim ) [ h>> ] [ v>> ] bi 2array ;
-
-: all-macroblocks ( quot: ( mb -- ) -- )
- [
- jpeg>
- [ dim>> 8 v/n ]
- [ color-info>> sift { 0 0 } [ mb-dim vmax ] reduce v/ ] bi
- [ ceiling ] map
- coord-matrix flip concat
- ]
- [ each ] bi* ; inline
-
-: reverse-zigzag ( b -- b' ) zig-zag swap [ nth ] curry map ;
-
-: idct-factor ( b -- b' ) dct-matrix v.m ;
-
-USE: math.blas.vectors
-USE: math.blas.matrices
-
-MEMO: dct-matrix-blas ( -- m ) dct-matrix >float-blas-matrix ;
-: V.M ( x A -- x.A ) Mtranspose swap M.V ;
-: idct-blas ( b -- b' ) >float-blas-vector dct-matrix-blas V.M ;
-
-: idct ( b -- b' ) idct-blas ;
-
-:: draw-block ( block x,y color jpeg-image -- )
- block dup length>> sqrt >fixnum group flip
- dup matrix-dim coord-matrix flip
- [
- [ first2 spin nth nth ]
- [ x,y v+ color id>> 1- jpeg-image draw-color ] bi
- ] with each^2 ;
-
-: sign-extend ( bits v -- v' )
- swap [ ] [ 1- 2^ < ] 2bi
- [ -1 swap shift 1+ + ] [ drop ] if ;
-
-: read1-jpeg-dc ( decoder -- dc )
- [ read1-huff dup ] [ bs>> bs:read ] bi sign-extend ;
-
-: read1-jpeg-ac ( decoder -- run/ac )
- [ read1-huff 16 /mod dup ] [ bs>> bs:read ] bi sign-extend 2array ;
-
-:: decode-block ( pos color -- )
- color dc-huff-table>> read1-jpeg-dc color apply-diff
- 64 0 <array> :> coefs
- 0 coefs set-nth
- 0 :> k!
- [
- color ac-huff-table>> read1-jpeg-ac
- [ first 1+ k + k! ] [ second k coefs set-nth ] [ ] tri
- { 0 0 } = not
- k 63 < and
- ] loop
- coefs color quant-table>> v*
- reverse-zigzag idct
- ! %fixme: color hack
- ! this eat 50% cpu time
- color h>> 2 =
- [ 8 group 2 matrix-zoom concat ] unless
- pos { 8 8 } v* color jpeg> draw-block ;
-
-: decode-macroblock ( mb -- )
- jpeg> components>>
- [
- [ mb-dim coord-matrix flip concat [ [ { 2 2 } v* ] [ v+ ] bi* ] with map ]
- [ [ decode-block ] curry each ] bi
- ] with each ;
-
-: cleanup-bitstream ( bytes -- bytes' )
- binary [
- [
- { HEX: FF } read-until
- read1 tuck HEX: 00 = and
- ]
- [ drop ] produce
- swap >marker { EOI } assert=
- swap suffix
- { HEX: FF } join
- ] with-byte-reader ;
-
-: setup-bitmap ( image -- )
- dup dim>> 16 v/n [ ceiling ] map 16 v*n >>dim
- BGR >>component-order
- f >>upside-down?
- dup dim>> first2 * 3 * 0 <array> >>bitmap
- drop ;
-
-: baseline-decompress ( -- )
- jpeg> bitstream>> cleanup-bitstream { 255 255 255 255 } append
- >byte-array bs:<msb0-bit-reader> jpeg> (>>bitstream)
- jpeg> [ bitstream>> ] [ [ [ <huffman-decoder> ] with map ] change-huff-tables drop ] bi
- jpeg> components>> [ fetch-tables ] each
- jpeg> setup-bitmap
- [ decode-macroblock ] all-macroblocks ;
-
-! this eats ~25% cpu time
-: color-transform ( yuv -- rgb )
- { 128 0 0 } v+ yuv>bgr-matrix swap m.v
- [ 0 max 255 min >fixnum ] map ;
-
-PRIVATE>
-
-: load-jpeg ( path -- image )
- binary [
- parse-marker { SOI } assert=
- parse-headers
- contents <loading-jpeg>
- ] with-file-reader
- dup loading-jpeg [
- baseline-parse
- baseline-decompress
- jpeg> bitmap>> 3 <groups> [ color-transform ] change-each
- jpeg> [ >byte-array ] change-bitmap drop
- ] with-variable ;
-
-M: jpeg-image load-image* ( path jpeg-image -- bitmap )
- drop load-jpeg ;
+! Copyright (C) 2009 Marc Fauconneau.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays byte-arrays combinators
+constructors grouping compression.huffman images
+images.processing io io.binary io.encodings.binary io.files
+io.streams.byte-array kernel locals math math.bitwise
+math.constants math.functions math.matrices math.order
+math.ranges math.vectors memoize multiline namespaces
+sequences sequences.deep ;
+IN: images.jpeg
+
+QUALIFIED-WITH: bitstreams bs
+
+TUPLE: jpeg-image < image
+ { headers }
+ { bitstream }
+ { color-info initial: { f f f f } }
+ { quant-tables initial: { f f } }
+ { huff-tables initial: { f f f f } }
+ { components } ;
+
+<PRIVATE
+
+CONSTRUCTOR: jpeg-image ( headers bitstream -- image ) ;
+
+SINGLETONS: SOF DHT DAC RST SOI EOI SOS DQT DNL DRI DHP EXP
+APP JPG COM TEM RES ;
+
+! ISO/IEC 10918-1 Table B.1
+:: >marker ( byte -- marker )
+ byte
+ {
+ { [ dup HEX: CC = ] [ { DAC } ] }
+ { [ dup HEX: C4 = ] [ { DHT } ] }
+ { [ dup HEX: C9 = ] [ { JPG } ] }
+ { [ dup -4 shift HEX: C = ] [ SOF byte 4 bits 2array ] }
+
+ { [ dup HEX: D8 = ] [ { SOI } ] }
+ { [ dup HEX: D9 = ] [ { EOI } ] }
+ { [ dup HEX: DA = ] [ { SOS } ] }
+ { [ dup HEX: DB = ] [ { DQT } ] }
+ { [ dup HEX: DC = ] [ { DNL } ] }
+ { [ dup HEX: DD = ] [ { DRI } ] }
+ { [ dup HEX: DE = ] [ { DHP } ] }
+ { [ dup HEX: DF = ] [ { EXP } ] }
+ { [ dup -4 shift HEX: D = ] [ RST byte 4 bits 2array ] }
+
+ { [ dup -4 shift HEX: E = ] [ APP byte 4 bits 2array ] }
+ { [ dup HEX: FE = ] [ { COM } ] }
+ { [ dup -4 shift HEX: F = ] [ JPG byte 4 bits 2array ] }
+
+ { [ dup HEX: 01 = ] [ { TEM } ] }
+ [ { RES } ]
+ }
+ cond nip ;
+
+TUPLE: jpeg-chunk length type data ;
+
+CONSTRUCTOR: jpeg-chunk ( type length data -- jpeg-chunk ) ;
+
+TUPLE: jpeg-color-info
+ h v quant-table dc-huff-table ac-huff-table { diff initial: 0 } id ;
+
+CONSTRUCTOR: jpeg-color-info ( h v quant-table -- jpeg-color-info ) ;
+
+: jpeg> ( -- jpeg-image ) jpeg-image get ;
+
+: apply-diff ( dc color -- dc' )
+ [ diff>> + dup ] [ (>>diff) ] bi ;
+
+: fetch-tables ( component -- )
+ [ [ jpeg> quant-tables>> nth ] change-quant-table drop ]
+ [ [ jpeg> huff-tables>> nth ] change-dc-huff-table drop ]
+ [ [ 2 + jpeg> huff-tables>> nth ] change-ac-huff-table drop ] tri ;
+
+: read4/4 ( -- a b ) read1 16 /mod ;
+
+! headers
+
+: decode-frame ( header -- )
+ data>>
+ binary
+ [
+ read1 8 assert=
+ 2 read be>
+ 2 read be>
+ swap 2array jpeg> (>>dim)
+ read1
+ [
+ read1 read4/4 read1 <jpeg-color-info>
+ swap [ >>id ] keep jpeg> color-info>> set-nth
+ ] times
+ ] with-byte-reader ;
+
+: decode-quant-table ( chunk -- )
+ dup data>>
+ binary
+ [
+ length>>
+ 2 - 65 /
+ [
+ read4/4 [ 0 assert= ] dip
+ 64 read
+ swap jpeg> quant-tables>> set-nth
+ ] times
+ ] with-byte-reader ;
+
+: decode-huff-table ( chunk -- )
+ data>>
+ binary
+ [
+ 1 ! %fixme: Should handle multiple tables at once
+ [
+ read4/4 swap 2 * +
+ 16 read
+ dup [ ] [ + ] map-reduce read
+ binary [ [ read [ B{ } ] unless* ] { } map-as ] with-byte-reader
+ swap jpeg> huff-tables>> set-nth
+ ] times
+ ] with-byte-reader ;
+
+: decode-scan ( chunk -- )
+ data>>
+ binary
+ [
+ read1 [0,b)
+ [ drop
+ read1 jpeg> color-info>> nth clone
+ read1 16 /mod [ >>dc-huff-table ] [ >>ac-huff-table ] bi*
+ ] map jpeg> (>>components)
+ read1 0 assert=
+ read1 63 assert=
+ read1 16 /mod [ 0 assert= ] bi@
+ ] with-byte-reader ;
+
+: singleton-first ( seq -- elt )
+ [ length 1 assert= ] [ first ] bi ;
+
+: baseline-parse ( -- )
+ jpeg> headers>>
+ {
+ [ [ type>> { SOF 0 } = ] filter singleton-first decode-frame ]
+ [ [ type>> { DQT } = ] filter [ decode-quant-table ] each ]
+ [ [ type>> { DHT } = ] filter [ decode-huff-table ] each ]
+ [ [ type>> { SOS } = ] filter singleton-first decode-scan ]
+ } cleave ;
+
+: parse-marker ( -- marker )
+ read1 HEX: FF assert=
+ read1 >marker ;
+
+: parse-headers ( -- chunks )
+ [ parse-marker dup { SOS } = not ]
+ [
+ 2 read be>
+ dup 2 - read <jpeg-chunk>
+ ] [ produce ] keep dip swap suffix ;
+
+MEMO: zig-zag ( -- zz )
+ {
+ { 0 1 5 6 14 15 27 28 }
+ { 2 4 7 13 16 26 29 42 }
+ { 3 8 12 17 25 30 41 43 }
+ { 9 11 18 24 31 40 44 53 }
+ { 10 19 23 32 39 45 52 54 }
+ { 20 22 33 38 46 51 55 60 }
+ { 21 34 37 47 50 56 59 61 }
+ { 35 36 48 49 57 58 62 63 }
+ } flatten ;
+
+MEMO: yuv>bgr-matrix ( -- m )
+ {
+ { 1 2.03211 0 }
+ { 1 -0.39465 -0.58060 }
+ { 1 0 1.13983 }
+ } ;
+
+: wave ( x u -- n ) swap 2 * 1 + * pi * 16 / cos ;
+
+:: dct-vect ( u v -- basis )
+ { 8 8 } coord-matrix [ { u v } [ wave ] 2map product ] map^2
+ 1 u v [ 0 = [ 2 sqrt / ] when ] bi@ 4 / m*n ;
+
+MEMO: dct-matrix ( -- m ) 64 [0,b) [ 8 /mod dct-vect flatten ] map ;
+
+: mb-dim ( component -- dim ) [ h>> ] [ v>> ] bi 2array ;
+
+! : blocks ( component -- seq )
+! mb-dim ! coord-matrix flip concat [ [ { 2 2 } v* ] [ v+ ] bi* ] with map ;
+
+: all-macroblocks ( quot: ( mb -- ) -- )
+ [
+ jpeg>
+ [ dim>> 8 v/n ]
+ [ color-info>> sift { 0 0 } [ mb-dim vmax ] reduce v/ ] bi
+ [ ceiling ] map
+ coord-matrix flip concat
+ ]
+ [ each ] bi* ; inline
+
+: reverse-zigzag ( b -- b' ) zig-zag swap [ nth ] curry map ;
+
+: idct-factor ( b -- b' ) dct-matrix v.m ;
+
+USE: math.blas.vectors
+USE: math.blas.matrices
+
+MEMO: dct-matrix-blas ( -- m ) dct-matrix >float-blas-matrix ;
+: V.M ( x A -- x.A ) Mtranspose swap M.V ;
+: idct-blas ( b -- b' ) >float-blas-vector dct-matrix-blas V.M ;
+
+: idct ( b -- b' ) idct-blas ;
+
+:: draw-block ( block x,y color-id jpeg-image -- )
+ block dup length>> sqrt >fixnum group flip
+ dup matrix-dim coord-matrix flip
+ [
+ [ first2 spin nth nth ]
+ [ x,y v+ color-id jpeg-image draw-color ] bi
+ ] with each^2 ;
+
+: sign-extend ( bits v -- v' )
+ swap [ ] [ 1- 2^ < ] 2bi
+ [ -1 swap shift 1+ + ] [ drop ] if ;
+
+: read1-jpeg-dc ( decoder -- dc )
+ [ read1-huff dup ] [ bs>> bs:read ] bi sign-extend ;
+
+: read1-jpeg-ac ( decoder -- run/ac )
+ [ read1-huff 16 /mod dup ] [ bs>> bs:read ] bi sign-extend 2array ;
+
+:: decode-block ( color -- pixels )
+ color dc-huff-table>> read1-jpeg-dc color apply-diff
+ 64 0 <array> :> coefs
+ 0 coefs set-nth
+ 0 :> k!
+ [
+ color ac-huff-table>> read1-jpeg-ac
+ [ first 1+ k + k! ] [ second k coefs set-nth ] [ ] tri
+ { 0 0 } = not
+ k 63 < and
+ ] loop
+ coefs color quant-table>> v*
+ reverse-zigzag idct ;
+
+:: draw-macroblock-yuv420 ( mb blocks -- )
+ mb { 16 16 } v* :> pos
+ 0 blocks nth pos { 0 0 } v+ 0 jpeg> draw-block
+ 1 blocks nth pos { 8 0 } v+ 0 jpeg> draw-block
+ 2 blocks nth pos { 0 8 } v+ 0 jpeg> draw-block
+ 3 blocks nth pos { 8 8 } v+ 0 jpeg> draw-block
+ 4 blocks nth 8 group 2 matrix-zoom concat pos 1 jpeg> draw-block
+ 5 blocks nth 8 group 2 matrix-zoom concat pos 2 jpeg> draw-block ;
+
+:: draw-macroblock-yuv444 ( mb blocks -- )
+ mb { 8 8 } v* :> pos
+ 3 iota [ [ blocks nth pos ] [ jpeg> draw-block ] bi ] each ;
+
+:: draw-macroblock-y ( mb blocks -- )
+ mb { 8 8 } v* :> pos
+ 0 blocks nth pos 0 jpeg> draw-block
+ 64 0 <array> pos 1 jpeg> draw-block
+ 64 0 <array> pos 2 jpeg> draw-block ;
+
+ ! %fixme: color hack
+ ! color h>> 2 =
+ ! [ 8 group 2 matrix-zoom concat ] unless
+ ! pos { 8 8 } v* color jpeg> draw-block ;
+
+: decode-macroblock ( -- blocks )
+ jpeg> components>>
+ [
+ [ mb-dim first2 * iota ]
+ [ [ decode-block ] curry replicate ] bi
+ ] map concat ;
+
+: cleanup-bitstream ( bytes -- bytes' )
+ binary [
+ [
+ { HEX: FF } read-until
+ read1 tuck HEX: 00 = and
+ ]
+ [ drop ] produce
+ swap >marker { EOI } assert=
+ swap suffix
+ { HEX: FF } join
+ ] with-byte-reader ;
+
+: setup-bitmap ( image -- )
+ dup dim>> 16 v/n [ ceiling ] map 16 v*n >>dim
+ BGR >>component-order
+ f >>upside-down?
+ dup dim>> first2 * 3 * 0 <array> >>bitmap
+ drop ;
+
+ERROR: unsupported-colorspace ;
+SINGLETONS: YUV420 YUV444 Y MAGIC! ;
+
+:: detect-colorspace ( jpeg-image -- csp )
+ jpeg-image color-info>> sift :> colors
+ MAGIC!
+ colors length 1 = [ drop Y ] when
+ colors length 3 =
+ [
+ colors [ mb-dim { 1 1 } = ] all?
+ [ drop YUV444 ] when
+
+ colors unclip
+ [ [ mb-dim { 1 1 } = ] all? ]
+ [ mb-dim { 2 2 } = ] bi* and
+ [ drop YUV420 ] when
+ ] when ;
+
+! this eats ~50% cpu time
+: draw-macroblocks ( mbs -- )
+ jpeg> detect-colorspace
+ {
+ { YUV420 [ [ first2 draw-macroblock-yuv420 ] each ] }
+ { YUV444 [ [ first2 draw-macroblock-yuv444 ] each ] }
+ { Y [ [ first2 draw-macroblock-y ] each ] }
+ [ unsupported-colorspace ]
+ } case ;
+
+! this eats ~25% cpu time
+: color-transform ( yuv -- rgb )
+ { 128 0 0 } v+ yuv>bgr-matrix swap m.v
+ [ 0 max 255 min >fixnum ] map ;
+
+: baseline-decompress ( -- )
+ jpeg> bitstream>> cleanup-bitstream { 255 255 255 255 } append
+ >byte-array bs:<msb0-bit-reader> jpeg> (>>bitstream)
+ jpeg>
+ [ bitstream>> ]
+ [ [ [ <huffman-decoder> ] with map ] change-huff-tables drop ] bi
+ jpeg> components>> [ fetch-tables ] each
+ [ decode-macroblock 2array ] accumulator
+ [ all-macroblocks ] dip
+ jpeg> setup-bitmap draw-macroblocks
+ jpeg> bitmap>> 3 <groups> [ color-transform ] change-each
+ jpeg> [ >byte-array ] change-bitmap drop ;
+
+ERROR: not-a-jpeg-image ;
+
+PRIVATE>
+
+: load-jpeg ( path -- image )
+ binary [
+ parse-marker { SOI } = [ not-a-jpeg-image ] unless
+ parse-headers
+ contents <jpeg-image>
+ ] with-file-reader
+ dup jpeg-image [
+ baseline-parse
+ baseline-decompress
+ ] with-variable ;
+
+M: jpeg-image load-image* ( path jpeg-image -- bitmap )
+ drop load-jpeg ;
+
From 46a50fe0b9f25e2ff614e47689dbd6fe5138ec32 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Thu, 11 Jun 2009 16:53:52 -0500
Subject: [PATCH 07/35] fix duplicate using
---
basis/game-input/dinput/dinput.factor | 19 +++++++++----------
1 file changed, 9 insertions(+), 10 deletions(-)
diff --git a/basis/game-input/dinput/dinput.factor b/basis/game-input/dinput/dinput.factor
index 8540907db9..0ecf543baa 100755
--- a/basis/game-input/dinput/dinput.factor
+++ b/basis/game-input/dinput/dinput.factor
@@ -1,14 +1,13 @@
-USING: windows.dinput windows.dinput.constants parser
-alien.c-types windows.ole32 namespaces assocs kernel arrays
-vectors windows.kernel32 windows.com windows.dinput shuffle
-windows.user32 windows.messages sequences combinators locals
-math.rectangles accessors math alien alien.strings
-io.encodings.utf16 io.encodings.utf16n continuations
-byte-arrays game-input.dinput.keys-array game-input
-ui.backend.windows windows.errors struct-arrays
-math.bitwise ;
+USING: accessors alien alien.c-types alien.strings arrays
+assocs byte-arrays combinators continuations game-input
+game-input.dinput.keys-array io.encodings.utf16
+io.encodings.utf16n kernel locals math math.bitwise
+math.rectangles namespaces parser sequences shuffle
+struct-arrays ui.backend.windows vectors windows.com
+windows.dinput windows.dinput.constants windows.errors
+windows.kernel32 windows.messages windows.ole32
+windows.user32 ;
IN: game-input.dinput
-
CONSTANT: MOUSE-BUFFER-SIZE 16
SINGLETON: dinput-game-input-backend
From d0f6a7d04814dbf49176369cbcb1c6fe541342e3 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 11 Jun 2009 17:55:14 -0500
Subject: [PATCH 08/35] Split up compiler.cfg.linear-scan.allocation into a
number of sub-vocabularies; start work on compiler.cfg.linear-scan.resolve;
start work on inactive interval splitting
---
.../cfg/instructions/instructions.factor | 1 +
.../linear-scan/allocation/allocation.factor | 295 +----------
.../allocation/coalescing/coalescing.factor | 18 +
.../allocation/spilling/spilling.factor | 60 +++
.../allocation/splitting/splitting.factor | 119 +++++
.../linear-scan/allocation/state/state.factor | 134 +++++
.../assignment/assignment-tests.factor | 4 -
.../linear-scan/assignment/assignment.factor | 88 ++--
.../cfg/linear-scan/linear-scan-tests.factor | 493 ++++++++++++++++--
.../cfg/linear-scan/linear-scan.factor | 1 +
.../live-intervals/live-intervals.factor | 25 +-
.../cfg/linear-scan/resolve/resolve.factor | 34 ++
.../cfg/predecessors/predecessors.factor | 5 +-
basis/compiler/codegen/codegen.factor | 6 +
14 files changed, 909 insertions(+), 374 deletions(-)
create mode 100644 basis/compiler/cfg/linear-scan/allocation/coalescing/coalescing.factor
create mode 100644 basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor
create mode 100644 basis/compiler/cfg/linear-scan/allocation/splitting/splitting.factor
create mode 100644 basis/compiler/cfg/linear-scan/allocation/state/state.factor
delete mode 100644 basis/compiler/cfg/linear-scan/assignment/assignment-tests.factor
create mode 100644 basis/compiler/cfg/linear-scan/resolve/resolve.factor
diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor
index fe853cf490..1bf94985a6 100644
--- a/basis/compiler/cfg/instructions/instructions.factor
+++ b/basis/compiler/cfg/instructions/instructions.factor
@@ -245,4 +245,5 @@ INSN: _gc { temp1 vreg } { temp2 vreg } gc-roots gc-root-count gc-root-size ;
! virtual registers
INSN: _spill src class n ;
INSN: _reload dst class n ;
+INSN: _copy dst src class ;
INSN: _spill-counts counts ;
diff --git a/basis/compiler/cfg/linear-scan/allocation/allocation.factor b/basis/compiler/cfg/linear-scan/allocation/allocation.factor
index 7b56bd6150..a99fea1d24 100644
--- a/basis/compiler/cfg/linear-scan/allocation/allocation.factor
+++ b/basis/compiler/cfg/linear-scan/allocation/allocation.factor
@@ -1,280 +1,12 @@
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces sequences math math.order kernel assocs
-accessors vectors fry heaps cpu.architecture sorting locals
-combinators compiler.cfg.registers
-compiler.cfg.linear-scan.live-intervals hints ;
+USING: accessors assocs heaps kernel namespaces sequences
+compiler.cfg.linear-scan.allocation.coalescing
+compiler.cfg.linear-scan.allocation.spilling
+compiler.cfg.linear-scan.allocation.splitting
+compiler.cfg.linear-scan.allocation.state ;
IN: compiler.cfg.linear-scan.allocation
-! Mapping from register classes to sequences of machine registers
-SYMBOL: free-registers
-
-: free-registers-for ( vreg -- seq )
- reg-class>> free-registers get at ;
-
-: deallocate-register ( live-interval -- )
- [ reg>> ] [ vreg>> ] bi free-registers-for push ;
-
-! Vector of active live intervals
-SYMBOL: active-intervals
-
-: active-intervals-for ( vreg -- seq )
- reg-class>> active-intervals get at ;
-
-: add-active ( live-interval -- )
- dup vreg>> active-intervals-for push ;
-
-: delete-active ( live-interval -- )
- dup vreg>> active-intervals-for delq ;
-
-! Vector of inactive live intervals
-SYMBOL: inactive-intervals
-
-: inactive-intervals-for ( vreg -- seq )
- reg-class>> inactive-intervals get at ;
-
-: add-inactive ( live-interval -- )
- dup vreg>> inactive-intervals-for push ;
-
-! Vector of handled live intervals
-SYMBOL: handled-intervals
-
-: add-handled ( live-interval -- )
- handled-intervals get push ;
-
-: finished? ( n live-interval -- ? ) end>> swap < ;
-
-: finish ( n live-interval -- keep? )
- nip [ deallocate-register ] [ add-handled ] bi f ;
-
-: activate ( n live-interval -- keep? )
- nip add-active f ;
-
-: deactivate ( n live-interval -- keep? )
- nip add-inactive f ;
-
-: don't-change ( n live-interval -- keep? ) 2drop t ;
-
-! Moving intervals between active and inactive sets
-: process-intervals ( n symbol quots -- )
- ! symbol stores an alist mapping register classes to vectors
- [ get values ] dip '[ [ _ cond ] with filter-here ] with each ; inline
-
-: covers? ( insn# live-interval -- ? )
- ranges>> [ [ from>> ] [ to>> ] bi between? ] with any? ;
-
-: deactivate-intervals ( n -- )
- ! Any active intervals which have ended are moved to handled
- ! Any active intervals which cover the current position
- ! are moved to inactive
- active-intervals {
- { [ 2dup finished? ] [ finish ] }
- { [ 2dup covers? not ] [ deactivate ] }
- [ don't-change ]
- } process-intervals ;
-
-: activate-intervals ( n -- )
- ! Any inactive intervals which have ended are moved to handled
- ! Any inactive intervals which do not cover the current position
- ! are moved to active
- inactive-intervals {
- { [ 2dup finished? ] [ finish ] }
- { [ 2dup covers? ] [ activate ] }
- [ don't-change ]
- } process-intervals ;
-
-! Minheap of live intervals which still need a register allocation
-SYMBOL: unhandled-intervals
-
-! Start index of current live interval. We ensure that all
-! live intervals added to the unhandled set have a start index
-! strictly greater than ths one. This ensures that we can catch
-! infinite loop situations.
-SYMBOL: progress
-
-: check-progress ( live-interval -- )
- start>> progress get <= [ "No progress" throw ] when ; inline
-
-: add-unhandled ( live-interval -- )
- [ check-progress ]
- [ dup start>> unhandled-intervals get heap-push ]
- bi ;
-
-: init-unhandled ( live-intervals -- )
- [ [ start>> ] keep ] { } map>assoc
- unhandled-intervals get heap-push-all ;
-
-! Coalescing
-: active-interval ( vreg -- live-interval )
- dup [ dup active-intervals-for [ vreg>> = ] with find nip ] when ;
-
-: coalesce? ( live-interval -- ? )
- [ start>> ] [ copy-from>> active-interval ] bi
- dup [ end>> = ] [ 2drop f ] if ;
-
-: coalesce ( live-interval -- )
- dup copy-from>> active-interval
- [ [ add-active ] [ [ delete-active ] [ add-handled ] bi ] bi* ]
- [ reg>> >>reg drop ]
- 2bi ;
-
-! Splitting
-: split-range ( live-range n -- before after )
- [ [ from>> ] dip <live-range> ]
- [ 1 + swap to>> <live-range> ]
- 2bi ;
-
-: split-last-range? ( last n -- ? )
- swap to>> <= ;
-
-: split-last-range ( before after last n -- before' after' )
- split-range [ [ but-last ] dip suffix ] [ prefix ] bi-curry* bi* ;
-
-: split-ranges ( live-ranges n -- before after )
- [ '[ from>> _ <= ] partition ]
- [
- pick empty? [ drop ] [
- [ over last ] dip 2dup split-last-range?
- [ split-last-range ] [ 2drop ] if
- ] if
- ] bi ;
-
-: split-uses ( uses n -- before after )
- '[ _ <= ] partition ;
-
-: record-split ( live-interval before after -- )
- [ >>split-before ] [ >>split-after ] bi* drop ; inline
-
-: check-split ( live-interval -- )
- [ end>> ] [ start>> ] bi - 0 =
- [ "BUG: splitting atomic interval" throw ] when ; inline
-
-: split-before ( before -- before' )
- [ [ ranges>> last ] [ uses>> last ] bi >>to drop ]
- [ compute-start/end ]
- [ ]
- tri ; inline
-
-: split-after ( after -- after' )
- [ [ ranges>> first ] [ uses>> first ] bi >>from drop ]
- [ compute-start/end ]
- [ ]
- tri ; inline
-
-:: split-interval ( live-interval n -- before after )
- live-interval check-split
- live-interval clone :> before
- live-interval clone f >>copy-from f >>reg :> after
- live-interval uses>> n split-uses before after [ (>>uses) ] bi-curry@ bi*
- live-interval ranges>> n split-ranges before after [ (>>ranges) ] bi-curry@ bi*
- live-interval before after record-split
- before split-before
- after split-after ;
-
-HINTS: split-interval live-interval object ;
-
-! Spilling
-SYMBOL: spill-counts
-
-: next-spill-location ( reg-class -- n )
- spill-counts get [ dup 1+ ] change-at ;
-
-: find-use ( live-interval n quot -- i elt )
- [ uses>> ] 2dip curry find ; inline
-
-: interval-to-spill ( active-intervals current -- live-interval )
- #! We spill the interval with the most distant use location.
- start>> '[ dup _ [ >= ] find-use nip ] { } map>assoc
- [ ] [ [ [ second ] bi@ > ] most ] map-reduce first ;
-
-: assign-spill ( before after -- before after )
- #! If it has been spilled already, reuse spill location.
- over reload-from>>
- [ over vreg>> reg-class>> next-spill-location ] unless*
- [ >>spill-to ] [ >>reload-from ] bi-curry bi* ;
-
-: split-and-spill ( new existing -- before after )
- swap start>> split-interval assign-spill ;
-
-: reuse-register ( new existing -- )
- reg>> >>reg add-active ;
-
-: spill-existing ( new existing -- )
- #! Our new interval will be used before the active interval
- #! with the most distant use location. Spill the existing
- #! interval, then process the new interval and the tail end
- #! of the existing interval again.
- [ reuse-register ]
- [ nip delete-active ]
- [ split-and-spill [ add-handled ] [ add-unhandled ] bi* ] 2tri ;
-
-: spill-new ( new existing -- )
- #! Our new interval will be used after the active interval
- #! with the most distant use location. Split the new
- #! interval, then process both parts of the new interval
- #! again.
- [ dup split-and-spill add-unhandled ] dip spill-existing ;
-
-: spill-existing? ( new existing -- ? )
- #! Test if 'new' will be used before 'existing'.
- over start>> '[ _ [ > ] find-use nip -1 or ] bi@ < ;
-
-: assign-blocked-register ( new -- )
- [ dup vreg>> active-intervals-for ] keep interval-to-spill
- 2dup spill-existing? [ spill-existing ] [ spill-new ] if ;
-
-: assign-free-register ( new registers -- )
- pop >>reg add-active ;
-
-: relevant-ranges ( new inactive -- new' inactive' )
- ! Slice off all ranges of 'inactive' that precede the start of 'new'
- [ [ ranges>> ] bi@ ] [ nip start>> ] 2bi '[ to>> _ >= ] filter ;
-
-: intersect-live-range ( range1 range2 -- n/f )
- 2dup [ from>> ] bi@ > [ swap ] when
- 2dup [ to>> ] [ from>> ] bi* >= [ nip from>> ] [ 2drop f ] if ;
-
-: intersect-live-ranges ( ranges1 ranges2 -- n )
- {
- { [ over empty? ] [ 2drop 1/0. ] }
- { [ dup empty? ] [ 2drop 1/0. ] }
- [
- 2dup [ first ] bi@ intersect-live-range dup [ 2nip ] [
- drop
- 2dup [ first from>> ] bi@ <
- [ [ rest-slice ] dip ] [ rest-slice ] if
- intersect-live-ranges
- ] if
- ]
- } cond ;
-
-: intersect-inactive ( new inactive -- n )
- relevant-ranges intersect-live-ranges ;
-
-: intersecting-inactive ( new -- live-intervals )
- dup vreg>> inactive-intervals-for
- [ tuck intersect-inactive ] with { } map>assoc ;
-
-: fits-in-hole ( new pair -- )
- first reuse-register ;
-
-: split-before-use ( new pair -- before after )
- ! Find optimal split position
- ! Insert move instruction
- second split-interval ;
-
-: assign-inactive-register ( new live-intervals -- )
- ! If there is an interval which is inactive for the entire lifetime
- ! if the new interval, reuse its vreg. Otherwise, split new so that
- ! the first half fits.
- sort-values last
- 2dup [ end>> ] [ second ] bi* < [
- fits-in-hole
- ] [
- [ split-before-use ] keep
- '[ _ fits-in-hole ] [ add-unhandled ] bi*
- ] if ;
-
: assign-register ( new -- )
dup coalesce? [ coalesce ] [
dup vreg>> free-registers-for [
@@ -286,21 +18,6 @@ SYMBOL: spill-counts
if-empty
] if ;
-! Main loop
-CONSTANT: reg-classes { int-regs double-float-regs }
-
-: reg-class-assoc ( quot -- assoc )
- [ reg-classes ] dip { } map>assoc ; inline
-
-: init-allocator ( registers -- )
- [ reverse >vector ] assoc-map free-registers set
- [ 0 ] reg-class-assoc spill-counts set
- <min-heap> unhandled-intervals set
- [ V{ } clone ] reg-class-assoc active-intervals set
- [ V{ } clone ] reg-class-assoc inactive-intervals set
- V{ } clone handled-intervals set
- -1 progress set ;
-
: handle-interval ( live-interval -- )
[
start>>
@@ -313,12 +30,10 @@ CONSTANT: reg-classes { int-regs double-float-regs }
unhandled-intervals get [ handle-interval ] slurp-heap ;
: finish-allocation ( -- )
- ! Sanity check: all live intervals should've been processed
active-intervals inactive-intervals
[ get values [ handled-intervals get push-all ] each ] bi@ ;
: allocate-registers ( live-intervals machine-registers -- live-intervals )
- #! This modifies the input live-intervals.
init-allocator
init-unhandled
(allocate-registers)
diff --git a/basis/compiler/cfg/linear-scan/allocation/coalescing/coalescing.factor b/basis/compiler/cfg/linear-scan/allocation/coalescing/coalescing.factor
new file mode 100644
index 0000000000..99ed75dcbc
--- /dev/null
+++ b/basis/compiler/cfg/linear-scan/allocation/coalescing/coalescing.factor
@@ -0,0 +1,18 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel sequences
+compiler.cfg.linear-scan.allocation.state ;
+IN: compiler.cfg.linear-scan.allocation.coalescing
+
+: active-interval ( vreg -- live-interval )
+ dup [ dup active-intervals-for [ vreg>> = ] with find nip ] when ;
+
+: coalesce? ( live-interval -- ? )
+ [ start>> ] [ copy-from>> active-interval ] bi
+ dup [ end>> = ] [ 2drop f ] if ;
+
+: coalesce ( live-interval -- )
+ dup copy-from>> active-interval
+ [ [ add-active ] [ [ delete-active ] [ add-handled ] bi ] bi* ]
+ [ reg>> >>reg drop ]
+ 2bi ;
diff --git a/basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor b/basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor
new file mode 100644
index 0000000000..4981a223a4
--- /dev/null
+++ b/basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor
@@ -0,0 +1,60 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays assocs combinators fry hints kernel locals
+math sequences sets sorting splitting
+compiler.cfg.linear-scan.allocation.state
+compiler.cfg.linear-scan.allocation.splitting
+compiler.cfg.linear-scan.live-intervals ;
+IN: compiler.cfg.linear-scan.allocation.spilling
+
+: split-for-spill ( live-interval n -- before after )
+ split-interval
+ [
+ [ [ ranges>> last ] [ uses>> last ] bi >>to drop ]
+ [ [ ranges>> first ] [ uses>> first ] bi >>from drop ] bi*
+ ]
+ [ [ compute-start/end ] bi@ ]
+ [ ]
+ 2tri ;
+
+: find-use ( live-interval n quot -- i elt )
+ [ uses>> ] 2dip curry find ; inline
+
+: interval-to-spill ( active-intervals current -- live-interval )
+ #! We spill the interval with the most distant use location.
+ start>> '[ dup _ [ >= ] find-use nip ] { } map>assoc
+ [ ] [ [ [ second ] bi@ > ] most ] map-reduce first ;
+
+: assign-spill ( before after -- before after )
+ #! If it has been spilled already, reuse spill location.
+ over reload-from>>
+ [ over vreg>> reg-class>> next-spill-location ] unless*
+ [ >>spill-to ] [ >>reload-from ] bi-curry bi* ;
+
+: split-and-spill ( new existing -- before after )
+ swap start>> split-for-spill assign-spill ;
+
+: spill-existing ( new existing -- )
+ #! Our new interval will be used before the active interval
+ #! with the most distant use location. Spill the existing
+ #! interval, then process the new interval and the tail end
+ #! of the existing interval again.
+ [ reuse-register ]
+ [ nip delete-active ]
+ [ split-and-spill [ add-handled ] [ add-unhandled ] bi* ] 2tri ;
+
+: spill-new ( new existing -- )
+ #! Our new interval will be used after the active interval
+ #! with the most distant use location. Split the new
+ #! interval, then process both parts of the new interval
+ #! again.
+ [ dup split-and-spill add-unhandled ] dip spill-existing ;
+
+: spill-existing? ( new existing -- ? )
+ #! Test if 'new' will be used before 'existing'.
+ over start>> '[ _ [ > ] find-use nip -1 or ] bi@ < ;
+
+: assign-blocked-register ( new -- )
+ [ dup vreg>> active-intervals-for ] keep interval-to-spill
+ 2dup spill-existing? [ spill-existing ] [ spill-new ] if ;
+
diff --git a/basis/compiler/cfg/linear-scan/allocation/splitting/splitting.factor b/basis/compiler/cfg/linear-scan/allocation/splitting/splitting.factor
new file mode 100644
index 0000000000..31c9332ab5
--- /dev/null
+++ b/basis/compiler/cfg/linear-scan/allocation/splitting/splitting.factor
@@ -0,0 +1,119 @@
+! 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 ]
+ [
+ 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-next drop ]
+ [ [ >>split-before ] [ >>split-after ] bi* drop ]
+ 2bi ; inline
+
+ERROR: splitting-atomic-interval ;
+
+: check-split ( live-interval -- )
+ [ end>> ] [ start>> ] bi - 0 =
+ [ splitting-atomic-interval ] when ; 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 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 )
+ 2dup [ reg>> ] dip key? [
+ 2drop start>>
+ ] [
+ 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 ;
+
+: insert-use-for-copy ( seq n -- seq' )
+ [ 1array split1 ] keep [ 1 - ] keep 2array glue ;
+
+: split-before-use ( new n -- before after )
+ ! Find optimal split position
+ ! Insert move instruction
+ [ '[ _ insert-use-for-copy ] change-uses ] keep
+ 1 - split-interval
+ 2dup [ compute-start/end ] bi@ ;
+
+: assign-inactive-register ( new live-intervals -- )
+ ! If there is an interval which is inactive for the entire lifetime
+ ! if the new interval, reuse its vreg. Otherwise, split new so that
+ ! the first half fits.
+ sort-values last
+ 2dup [ end>> ] [ second ] bi* < [
+ first reuse-register
+ ] [
+ [ second split-before-use ] keep
+ '[ _ first reuse-register ] [ add-unhandled ] bi*
+ ] if ;
\ No newline at end of file
diff --git a/basis/compiler/cfg/linear-scan/allocation/state/state.factor b/basis/compiler/cfg/linear-scan/allocation/state/state.factor
new file mode 100644
index 0000000000..2a1e87dcdd
--- /dev/null
+++ b/basis/compiler/cfg/linear-scan/allocation/state/state.factor
@@ -0,0 +1,134 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs combinators cpu.architecture fry heaps
+kernel math namespaces sequences vectors
+compiler.cfg.linear-scan.live-intervals ;
+IN: compiler.cfg.linear-scan.allocation.state
+
+! Mapping from register classes to sequences of machine registers
+SYMBOL: free-registers
+
+: free-registers-for ( vreg -- seq )
+ reg-class>> free-registers get at ;
+
+: deallocate-register ( live-interval -- )
+ [ reg>> ] [ vreg>> ] bi free-registers-for push ;
+
+! Vector of active live intervals
+SYMBOL: active-intervals
+
+: active-intervals-for ( vreg -- seq )
+ reg-class>> active-intervals get at ;
+
+: add-active ( live-interval -- )
+ dup vreg>> active-intervals-for push ;
+
+: delete-active ( live-interval -- )
+ dup vreg>> active-intervals-for delq ;
+
+: assign-free-register ( new registers -- )
+ pop >>reg add-active ;
+
+! Vector of inactive live intervals
+SYMBOL: inactive-intervals
+
+: inactive-intervals-for ( vreg -- seq )
+ reg-class>> inactive-intervals get at ;
+
+: add-inactive ( live-interval -- )
+ dup vreg>> inactive-intervals-for push ;
+
+! Vector of handled live intervals
+SYMBOL: handled-intervals
+
+: add-handled ( live-interval -- )
+ handled-intervals get push ;
+
+: finished? ( n live-interval -- ? ) end>> swap < ;
+
+: finish ( n live-interval -- keep? )
+ nip [ deallocate-register ] [ add-handled ] bi f ;
+
+SYMBOL: check-allocation?
+
+ERROR: register-already-used live-interval ;
+
+: check-activate ( live-interval -- )
+ check-allocation? get [
+ dup [ reg>> ] [ vreg>> active-intervals-for [ reg>> ] map ] bi member?
+ [ register-already-used ] [ drop ] if
+ ] [ drop ] if ;
+
+: activate ( n live-interval -- keep? )
+ dup check-activate
+ nip add-active f ;
+
+: deactivate ( n live-interval -- keep? )
+ nip add-inactive f ;
+
+: don't-change ( n live-interval -- keep? ) 2drop t ;
+
+! Moving intervals between active and inactive sets
+: process-intervals ( n symbol quots -- )
+ ! symbol stores an alist mapping register classes to vectors
+ [ get values ] dip '[ [ _ cond ] with filter-here ] with each ; inline
+
+: deactivate-intervals ( n -- )
+ ! Any active intervals which have ended are moved to handled
+ ! Any active intervals which cover the current position
+ ! are moved to inactive
+ active-intervals {
+ { [ 2dup finished? ] [ finish ] }
+ { [ 2dup covers? not ] [ deactivate ] }
+ [ don't-change ]
+ } process-intervals ;
+
+: activate-intervals ( n -- )
+ ! Any inactive intervals which have ended are moved to handled
+ ! Any inactive intervals which do not cover the current position
+ ! are moved to active
+ inactive-intervals {
+ { [ 2dup finished? ] [ finish ] }
+ { [ 2dup covers? ] [ activate ] }
+ [ don't-change ]
+ } process-intervals ;
+
+! Minheap of live intervals which still need a register allocation
+SYMBOL: unhandled-intervals
+
+! Start index of current live interval. We ensure that all
+! live intervals added to the unhandled set have a start index
+! strictly greater than ths one. This ensures that we can catch
+! infinite loop situations.
+SYMBOL: progress
+
+: check-progress ( live-interval -- )
+ start>> progress get <= [ "No progress" throw ] when ; inline
+
+: add-unhandled ( live-interval -- )
+ [ check-progress ]
+ [ dup start>> unhandled-intervals get heap-push ]
+ bi ;
+
+CONSTANT: reg-classes { int-regs double-float-regs }
+
+: reg-class-assoc ( quot -- assoc )
+ [ reg-classes ] dip { } map>assoc ; inline
+
+SYMBOL: spill-counts
+
+: next-spill-location ( reg-class -- n )
+ spill-counts get [ dup 1 + ] change-at ;
+
+: init-allocator ( registers -- )
+ [ reverse >vector ] assoc-map free-registers set
+ [ 0 ] reg-class-assoc spill-counts set
+ <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
diff --git a/basis/compiler/cfg/linear-scan/assignment/assignment-tests.factor b/basis/compiler/cfg/linear-scan/assignment/assignment-tests.factor
deleted file mode 100644
index 13c1783711..0000000000
--- a/basis/compiler/cfg/linear-scan/assignment/assignment-tests.factor
+++ /dev/null
@@ -1,4 +0,0 @@
-USING: compiler.cfg.linear-scan.assignment tools.test ;
-IN: compiler.cfg.linear-scan.assignment.tests
-
-
diff --git a/basis/compiler/cfg/linear-scan/assignment/assignment.factor b/basis/compiler/cfg/linear-scan/assignment/assignment.factor
index 6fcd6e7570..ff06fbfa9b 100644
--- a/basis/compiler/cfg/linear-scan/assignment/assignment.factor
+++ b/basis/compiler/cfg/linear-scan/assignment/assignment.factor
@@ -7,20 +7,16 @@ compiler.cfg.def-use
compiler.cfg.registers
compiler.cfg.instructions
compiler.cfg.linear-scan.allocation
+compiler.cfg.linear-scan.allocation.state
compiler.cfg.linear-scan.live-intervals ;
IN: compiler.cfg.linear-scan.assignment
-! A vector of live intervals. There is linear searching involved
-! but since we never have too many machine registers (around 30
-! at most) and we probably won't have that many live at any one
-! time anyway, it is not a problem to check each element.
-TUPLE: active-intervals seq ;
+! This contains both active and inactive intervals; any interval
+! such that start <= insn# <= end is in this set.
+SYMBOL: pending-intervals
: add-active ( live-interval -- )
- active-intervals get seq>> push ;
-
-: lookup-register ( vreg -- reg )
- active-intervals get seq>> [ vreg>> = ] with find nip reg>> ;
+ pending-intervals get push ;
! Minheap of live intervals which still need a register allocation
SYMBOL: unhandled-intervals
@@ -37,9 +33,11 @@ SYMBOL: spill-slots
: spill-slots-for ( vreg -- assoc )
reg-class>> spill-slots get at ;
+ERROR: already-spilled ;
+
: record-spill ( live-interval -- )
[ dup spill-to>> ] [ vreg>> spill-slots-for ] bi
- 2dup key? [ "BUG: Already spilled" throw ] [ set-at ] if ;
+ 2dup key? [ already-spilled ] [ set-at ] if ;
: insert-spill ( live-interval -- )
[ reg>> ] [ vreg>> reg-class>> ] [ spill-to>> ] tri _spill ;
@@ -47,14 +45,27 @@ SYMBOL: spill-slots
: handle-spill ( live-interval -- )
dup spill-to>> [ [ record-spill ] [ insert-spill ] bi ] [ drop ] if ;
+: insert-copy ( live-interval -- )
+ [ split-next>> reg>> ]
+ [ reg>> ]
+ [ vreg>> reg-class>> ]
+ tri _copy ;
+
+: handle-copy ( live-interval -- )
+ dup [ spill-to>> not ] [ split-next>> ] bi and
+ [ insert-copy ] [ drop ] if ;
+
: expire-old-intervals ( n -- )
- active-intervals get
- [ swap '[ end>> _ = ] partition ] change-seq drop
- [ handle-spill ] each ;
+ [ pending-intervals get ] dip '[
+ dup end>> _ <
+ [ [ handle-spill ] [ handle-copy ] bi f ] [ drop t ] if
+ ] filter-here ;
+
+ERROR: already-reloaded ;
: record-reload ( live-interval -- )
[ reload-from>> ] [ vreg>> spill-slots-for ] bi
- 2dup key? [ delete-at ] [ "BUG: Already reloaded" throw ] if ;
+ 2dup key? [ delete-at ] [ already-reloaded ] if ;
: insert-reload ( live-interval -- )
[ reg>> ] [ vreg>> reg-class>> ] [ reload-from>> ] tri _reload ;
@@ -73,39 +84,40 @@ SYMBOL: spill-slots
] [ 2drop ] if
] if ;
-GENERIC: assign-before ( insn -- )
+GENERIC: assign-registers-in-insn ( insn -- )
-GENERIC: assign-after ( insn -- )
+: register-mapping ( live-intervals -- alist )
+ [ [ vreg>> ] [ reg>> ] bi ] { } map>assoc ;
: all-vregs ( insn -- vregs )
[ defs-vregs ] [ temp-vregs ] [ uses-vregs ] tri 3append ;
-M: vreg-insn assign-before
- active-intervals get seq>> over all-vregs '[ vreg>> _ member? ] filter
- [ [ vreg>> ] [ reg>> ] bi ] { } map>assoc
+: active-intervals ( insn -- intervals )
+ insn#>> pending-intervals get [ covers? ] with filter ;
+
+M: vreg-insn assign-registers-in-insn
+ dup [ active-intervals ] [ all-vregs ] bi
+ '[ vreg>> _ member? ] filter
+ register-mapping
>>regs drop ;
-M: insn assign-before drop ;
-
-: compute-live-registers ( -- regs )
- active-intervals get seq>> [ [ vreg>> ] [ reg>> ] bi ] { } map>assoc ;
+: compute-live-registers ( insn -- regs )
+ active-intervals register-mapping ;
: compute-live-spill-slots ( -- spill-slots )
spill-slots get values [ values ] map concat
[ [ vreg>> ] [ reload-from>> ] bi ] { } map>assoc ;
-M: ##gc assign-after
- compute-live-registers >>live-registers
+M: ##gc assign-registers-in-insn
+ dup call-next-method
+ dup compute-live-registers >>live-registers
compute-live-spill-slots >>live-spill-slots
drop ;
-M: insn assign-after drop ;
-
-: <active-intervals> ( -- obj )
- V{ } clone active-intervals boa ;
+M: insn assign-registers-in-insn drop ;
: init-assignment ( live-intervals -- )
- <active-intervals> active-intervals set
+ V{ } clone pending-intervals set
<min-heap> unhandled-intervals set
[ H{ } clone ] reg-class-assoc spill-slots set
init-unhandled ;
@@ -114,13 +126,15 @@ M: insn assign-after drop ;
[
[
[
- {
- [ insn#>> activate-new-intervals ]
- [ assign-before ]
- [ , ]
- [ insn#>> expire-old-intervals ]
- [ assign-after ]
- } cleave
+ [
+ insn#>>
+ [ activate-new-intervals ]
+ [ expire-old-intervals ]
+ bi
+ ]
+ [ assign-registers-in-insn ]
+ [ , ]
+ tri
] each
] V{ } make
] change-instructions drop ;
diff --git a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor
index ccfc4a1ff7..d851b67fc0 100644
--- a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor
+++ b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor
@@ -1,17 +1,26 @@
IN: compiler.cfg.linear-scan.tests
USING: tools.test random sorting sequences sets hashtables assocs
-kernel fry arrays splitting namespaces math accessors vectors
+kernel fry arrays splitting namespaces math accessors vectors locals
math.order grouping
cpu.architecture
compiler.cfg
compiler.cfg.optimizer
compiler.cfg.instructions
compiler.cfg.registers
+compiler.cfg.liveness
+compiler.cfg.predecessors
+compiler.cfg.rpo
compiler.cfg.linear-scan
compiler.cfg.linear-scan.live-intervals
compiler.cfg.linear-scan.allocation
+compiler.cfg.linear-scan.allocation.state
+compiler.cfg.linear-scan.allocation.splitting
+compiler.cfg.linear-scan.allocation.spilling
+compiler.cfg.linear-scan.assignment
compiler.cfg.linear-scan.debugger ;
+check-allocation? on
+
[
{ T{ live-range f 1 10 } T{ live-range f 15 15 } }
{ T{ live-range f 16 20 } }
@@ -118,32 +127,57 @@ compiler.cfg.linear-scan.debugger ;
{ end 5 }
{ uses V{ 0 1 5 } }
{ ranges V{ T{ live-range f 0 5 } } }
- } 2 split-interval
+ } 2 split-for-spill [ f >>split-next ] bi@
+] unit-test
+
+[
+ T{ live-interval
+ { vreg T{ vreg { reg-class int-regs } { n 1 } } }
+ { start 0 }
+ { end 0 }
+ { uses V{ 0 } }
+ { ranges V{ T{ live-range f 0 0 } } }
+ }
+ T{ live-interval
+ { vreg T{ vreg { reg-class int-regs } { n 1 } } }
+ { start 1 }
+ { end 5 }
+ { uses V{ 1 5 } }
+ { ranges V{ T{ live-range f 1 5 } } }
+ }
+] [
+ T{ live-interval
+ { vreg T{ vreg { reg-class int-regs } { n 1 } } }
+ { start 0 }
+ { end 5 }
+ { uses V{ 0 1 5 } }
+ { ranges V{ T{ live-range f 0 5 } } }
+ } 0 split-for-spill [ f >>split-next ] bi@
] unit-test
[
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
{ start 0 }
- { end 0 }
- { uses V{ 0 } }
- { ranges V{ T{ live-range f 0 0 } } }
+ { end 4 }
+ { uses V{ 0 1 4 } }
+ { ranges V{ T{ live-range f 0 4 } } }
}
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
- { start 1 }
+ { start 5 }
{ end 5 }
- { uses V{ 1 5 } }
- { ranges V{ T{ live-range f 1 5 } } }
+ { uses V{ 5 } }
+ { ranges V{ T{ live-range f 5 5 } } }
}
] [
T{ live-interval
- { vreg T{ vreg { reg-class int-regs } { n 1 } } }
- { start 0 }
- { end 5 }
- { uses V{ 0 1 5 } }
- { ranges V{ T{ live-range f 0 5 } } }
- } 0 split-interval
+ { vreg T{ vreg { reg-class int-regs } { n 1 } } }
+ { start 0 }
+ { end 5 }
+ { uses V{ 0 1 5 } }
+ { ranges V{ T{ live-range f 0 5 } } }
+ } 5 split-before-use [ f >>split-next ] bi@
] unit-test
[
@@ -1294,26 +1328,32 @@ USING: math.private compiler.cfg.debugger ;
! Spill slot liveness was computed incorrectly, leading to a FEP
! early in bootstrap on x86-32
[ t ] [
- T{ basic-block
- { instructions
- V{
- T{ ##gc f V int-regs 6 V int-regs 7 }
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##peek f V int-regs 1 D 1 }
- T{ ##peek f V int-regs 2 D 2 }
- T{ ##peek f V int-regs 3 D 3 }
- T{ ##peek f V int-regs 4 D 4 }
- T{ ##peek f V int-regs 5 D 5 }
- T{ ##replace f V int-regs 0 D 1 }
- T{ ##replace f V int-regs 1 D 2 }
- T{ ##replace f V int-regs 2 D 3 }
- T{ ##replace f V int-regs 3 D 4 }
- T{ ##replace f V int-regs 4 D 5 }
- T{ ##replace f V int-regs 5 D 0 }
- }
- }
- } dup 1array { { int-regs V{ 0 1 2 3 } } } (linear-scan)
- instructions>> first live-spill-slots>> empty?
+ [
+ H{ } clone live-ins set
+ H{ } clone live-outs set
+ H{ } clone phi-live-ins set
+ T{ basic-block
+ { id 12345 }
+ { instructions
+ V{
+ T{ ##gc f V int-regs 6 V int-regs 7 }
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##peek f V int-regs 1 D 1 }
+ T{ ##peek f V int-regs 2 D 2 }
+ T{ ##peek f V int-regs 3 D 3 }
+ T{ ##peek f V int-regs 4 D 4 }
+ T{ ##peek f V int-regs 5 D 5 }
+ T{ ##replace f V int-regs 0 D 1 }
+ T{ ##replace f V int-regs 1 D 2 }
+ T{ ##replace f V int-regs 2 D 3 }
+ T{ ##replace f V int-regs 3 D 4 }
+ T{ ##replace f V int-regs 4 D 5 }
+ T{ ##replace f V int-regs 5 D 0 }
+ }
+ }
+ } dup 1array { { int-regs V{ 0 1 2 3 } } } (linear-scan)
+ instructions>> first live-spill-slots>> empty?
+ ] with-scope
] unit-test
[ f ] [
@@ -1373,5 +1413,388 @@ USING: math.private compiler.cfg.debugger ;
{ uses { 5 10 } }
{ ranges V{ T{ live-range f 5 10 } } }
}
+ H{ }
intersect-inactive
-] unit-test
\ No newline at end of file
+] unit-test
+
+! Bug in live spill slots calculation
+
+T{ basic-block
+ { id 205651 }
+ { number 0 }
+ { instructions V{ T{ ##prologue } T{ ##branch } } }
+} 0 set
+
+T{ basic-block
+ { id 205652 }
+ { number 1 }
+ { instructions
+ V{
+ T{ ##peek
+ { dst V int-regs 703128 }
+ { loc D 1 }
+ }
+ T{ ##peek
+ { dst V int-regs 703129 }
+ { loc D 0 }
+ }
+ T{ ##copy
+ { dst V int-regs 703134 }
+ { src V int-regs 703128 }
+ }
+ T{ ##copy
+ { dst V int-regs 703135 }
+ { src V int-regs 703129 }
+ }
+ T{ ##compare-imm-branch
+ { src1 V int-regs 703128 }
+ { src2 5 }
+ { cc cc/= }
+ }
+ }
+ }
+} 1 set
+
+T{ basic-block
+ { id 205653 }
+ { number 2 }
+ { instructions
+ V{
+ T{ ##copy
+ { dst V int-regs 703134 }
+ { src V int-regs 703129 }
+ }
+ T{ ##copy
+ { dst V int-regs 703135 }
+ { src V int-regs 703128 }
+ }
+ T{ ##branch }
+ }
+ }
+} 2 set
+
+T{ basic-block
+ { id 205655 }
+ { number 3 }
+ { instructions
+ V{
+ T{ ##replace
+ { src V int-regs 703134 }
+ { loc D 0 }
+ }
+ T{ ##replace
+ { src V int-regs 703135 }
+ { loc D 1 }
+ }
+ T{ ##epilogue }
+ T{ ##return }
+ }
+ }
+} 3 set
+
+1 get 1vector 0 get (>>successors)
+2 get 3 get V{ } 2sequence 1 get (>>successors)
+3 get 1vector 2 get (>>successors)
+
+:: test-linear-scan-on-cfg ( regs -- )
+ [ ] [
+ cfg new 0 get >>entry
+ compute-predecessors
+ compute-liveness
+ reverse-post-order
+ { { int-regs regs } } (linear-scan)
+ ] unit-test ;
+
+{ 1 2 } test-linear-scan-on-cfg
+
+! Bug in inactive interval handling
+! [ rot dup [ -rot ] when ]
+T{ basic-block
+ { id 201486 }
+ { number 0 }
+ { instructions V{ T{ ##prologue } T{ ##branch } } }
+} 0 set
+
+T{ basic-block
+ { id 201487 }
+ { number 1 }
+ { instructions
+ V{
+ T{ ##peek
+ { dst V int-regs 689473 }
+ { loc D 2 }
+ }
+ T{ ##peek
+ { dst V int-regs 689474 }
+ { loc D 1 }
+ }
+ T{ ##peek
+ { dst V int-regs 689475 }
+ { loc D 0 }
+ }
+ T{ ##compare-imm-branch
+ { src1 V int-regs 689473 }
+ { src2 5 }
+ { cc cc/= }
+ }
+ }
+ }
+} 1 set
+
+T{ basic-block
+ { id 201488 }
+ { number 2 }
+ { instructions
+ V{
+ T{ ##copy
+ { dst V int-regs 689481 }
+ { src V int-regs 689475 }
+ }
+ T{ ##copy
+ { dst V int-regs 689482 }
+ { src V int-regs 689474 }
+ }
+ T{ ##copy
+ { dst V int-regs 689483 }
+ { src V int-regs 689473 }
+ }
+ T{ ##branch }
+ }
+ }
+} 2 set
+
+T{ basic-block
+ { id 201489 }
+ { number 3 }
+ { instructions
+ V{
+ T{ ##copy
+ { dst V int-regs 689481 }
+ { src V int-regs 689473 }
+ }
+ T{ ##copy
+ { dst V int-regs 689482 }
+ { src V int-regs 689475 }
+ }
+ T{ ##copy
+ { dst V int-regs 689483 }
+ { src V int-regs 689474 }
+ }
+ T{ ##branch }
+ }
+ }
+} 3 set
+
+T{ basic-block
+ { id 201490 }
+ { number 4 }
+ { instructions
+ V{
+ T{ ##replace
+ { src V int-regs 689481 }
+ { loc D 0 }
+ }
+ T{ ##replace
+ { src V int-regs 689482 }
+ { loc D 1 }
+ }
+ T{ ##replace
+ { src V int-regs 689483 }
+ { loc D 2 }
+ }
+ T{ ##epilogue }
+ T{ ##return }
+ }
+ }
+} 4 set
+
+: test-diamond ( -- )
+ 1 get 1vector 0 get (>>successors)
+ 2 get 3 get V{ } 2sequence 1 get (>>successors)
+ 4 get 1vector 2 get (>>successors)
+ 4 get 1vector 3 get (>>successors) ;
+
+test-diamond
+
+{ 1 2 3 4 } test-linear-scan-on-cfg
+
+! Similar to the above
+! [ swap dup [ rot ] when ]
+
+T{ basic-block
+ { id 201537 }
+ { number 0 }
+ { instructions V{ T{ ##prologue } T{ ##branch } } }
+} 0 set
+
+T{ basic-block
+ { id 201538 }
+ { number 1 }
+ { instructions
+ V{
+ T{ ##peek
+ { dst V int-regs 689600 }
+ { loc D 1 }
+ }
+ T{ ##peek
+ { dst V int-regs 689601 }
+ { loc D 0 }
+ }
+ T{ ##compare-imm-branch
+ { src1 V int-regs 689600 }
+ { src2 5 }
+ { cc cc/= }
+ }
+ }
+ }
+} 1 set
+
+T{ basic-block
+ { id 201539 }
+ { number 2 }
+ { instructions
+ V{
+ T{ ##peek
+ { dst V int-regs 689604 }
+ { loc D 2 }
+ }
+ T{ ##copy
+ { dst V int-regs 689607 }
+ { src V int-regs 689604 }
+ }
+ T{ ##copy
+ { dst V int-regs 689608 }
+ { src V int-regs 689600 }
+ }
+ T{ ##copy
+ { dst V int-regs 689610 }
+ { src V int-regs 689601 }
+ }
+ T{ ##branch }
+ }
+ }
+} 2 set
+
+T{ basic-block
+ { id 201540 }
+ { number 3 }
+ { instructions
+ V{
+ T{ ##peek
+ { dst V int-regs 689609 }
+ { loc D 2 }
+ }
+ T{ ##copy
+ { dst V int-regs 689607 }
+ { src V int-regs 689600 }
+ }
+ T{ ##copy
+ { dst V int-regs 689608 }
+ { src V int-regs 689601 }
+ }
+ T{ ##copy
+ { dst V int-regs 689610 }
+ { src V int-regs 689609 }
+ }
+ T{ ##branch }
+ }
+ }
+} 3 set
+
+T{ basic-block
+ { id 201541 }
+ { number 4 }
+ { instructions
+ V{
+ T{ ##replace
+ { src V int-regs 689607 }
+ { loc D 0 }
+ }
+ T{ ##replace
+ { src V int-regs 689608 }
+ { loc D 1 }
+ }
+ T{ ##replace
+ { src V int-regs 689610 }
+ { loc D 2 }
+ }
+ T{ ##epilogue }
+ T{ ##return }
+ }
+ }
+} 4 set
+
+test-diamond
+
+{ 1 2 3 4 } test-linear-scan-on-cfg
+
+! compute-live-registers was inaccurate since it didn't take
+! lifetime holes into account
+
+T{ basic-block
+ { id 0 }
+ { 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/= }
+ }
+ }
+ }
+} 0 set
+
+T{ basic-block
+ { id 1 }
+ { 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 }
+ }
+ }
+} 1 set
+
+T{ basic-block
+ { id 2 }
+ { 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 }
+ }
+ }
+} 2 set
+
+T{ basic-block
+ { id 3 }
+ { instructions
+ V{
+ T{ ##replace
+ { src V int-regs 2 }
+ { loc D 0 }
+ }
+ T{ ##return }
+ }
+ }
+} 3 set
+
+test-diamond
+
+{ 1 2 3 4 } test-linear-scan-on-cfg
\ No newline at end of file
diff --git a/basis/compiler/cfg/linear-scan/linear-scan.factor b/basis/compiler/cfg/linear-scan/linear-scan.factor
index ffa356bfc2..3a0a7f8770 100644
--- a/basis/compiler/cfg/linear-scan/linear-scan.factor
+++ b/basis/compiler/cfg/linear-scan/linear-scan.factor
@@ -8,6 +8,7 @@ compiler.cfg.instructions
compiler.cfg.linear-scan.numbering
compiler.cfg.linear-scan.live-intervals
compiler.cfg.linear-scan.allocation
+compiler.cfg.linear-scan.allocation.state
compiler.cfg.linear-scan.assignment ;
IN: compiler.cfg.linear-scan
diff --git a/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor b/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor
index 546443b289..b631834d79 100644
--- a/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor
+++ b/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor
@@ -11,10 +11,21 @@ C: <live-range> live-range
TUPLE: live-interval
vreg
-reg spill-to reload-from split-before split-after
+reg spill-to reload-from
+split-before split-after split-next
start end ranges uses
copy-from ;
+: covers? ( insn# live-interval -- ? )
+ ranges>> [ [ from>> ] [ to>> ] bi between? ] with any? ;
+
+: child-interval-at ( insn# interval -- interval' )
+ dup split-after>> [
+ 2dup split-after>> start>> <
+ [ split-before>> ] [ split-after>> ] if
+ child-interval-at
+ ] [ nip ] if ;
+
ERROR: dead-value-error vreg ;
: shorten-range ( n live-interval -- )
@@ -46,11 +57,9 @@ ERROR: dead-value-error vreg ;
V{ } clone >>ranges
swap >>vreg ;
-: block-from ( -- n )
- basic-block get instructions>> first insn#>> ;
+: block-from ( bb -- n ) instructions>> first insn#>> ;
-: block-to ( -- n )
- basic-block get instructions>> last insn#>> ;
+: block-to ( bb -- n ) instructions>> last insn#>> ;
M: live-interval hashcode*
nip [ start>> ] [ end>> 1000 * ] bi + ;
@@ -74,7 +83,7 @@ M: insn compute-live-intervals* drop ;
: handle-input ( n vreg live-intervals -- )
live-interval
- [ [ block-from ] 2dip add-range ] [ add-use ] 2bi ;
+ [ [ basic-block get block-from ] 2dip add-range ] [ add-use ] 2bi ;
: handle-temp ( n vreg live-intervals -- )
live-interval
@@ -98,7 +107,9 @@ M: ##copy-float compute-live-intervals*
[ call-next-method ] [ record-copy ] bi ;
: handle-live-out ( bb -- )
- live-out keys block-from block-to live-intervals get '[
+ live-out keys
+ basic-block get [ block-from ] [ block-to ] bi
+ live-intervals get '[
[ _ _ ] dip _ live-interval add-range
] each ;
diff --git a/basis/compiler/cfg/linear-scan/resolve/resolve.factor b/basis/compiler/cfg/linear-scan/resolve/resolve.factor
new file mode 100644
index 0000000000..8996327beb
--- /dev/null
+++ b/basis/compiler/cfg/linear-scan/resolve/resolve.factor
@@ -0,0 +1,34 @@
+! Copyright (C) 2009 Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs kernel math namespaces sequences
+compiler.cfg.linear-scan.live-intervals compiler.cfg.liveness ;
+IN: compiler.cfg.linear-scan.resolve
+
+: add-mapping ( from to -- )
+ 2drop
+ ;
+
+: resolve-value-data-flow ( bb to vreg -- )
+ live-intervals get at
+ [ [ block-to ] dip child-interval-at ]
+ [ [ block-from ] dip child-interval-at ]
+ bi-curry bi* 2dup = [ 2drop ] [
+ add-mapping
+ ] if ;
+
+: resolve-mappings ( bb to -- )
+ 2drop
+ ;
+
+: resolve-edge-data-flow ( bb to -- )
+ [ 2dup live-in [ resolve-value-data-flow ] with with each ]
+ [ resolve-mappings ]
+ 2bi ;
+
+: resolve-block-data-flow ( bb -- )
+ dup successors>> [
+ resolve-edge-data-flow
+ ] with each ;
+
+: resolve-data-flow ( rpo -- )
+ [ resolve-block-data-flow ] each ;
\ No newline at end of file
diff --git a/basis/compiler/cfg/predecessors/predecessors.factor b/basis/compiler/cfg/predecessors/predecessors.factor
index 5be085ba5a..54efc53bc4 100644
--- a/basis/compiler/cfg/predecessors/predecessors.factor
+++ b/basis/compiler/cfg/predecessors/predecessors.factor
@@ -7,4 +7,7 @@ IN: compiler.cfg.predecessors
dup successors>> [ predecessors>> push ] with each ;
: compute-predecessors ( cfg -- cfg' )
- dup [ predecessors-step ] each-basic-block ;
+ [ [ V{ } clone >>predecessors drop ] each-basic-block ]
+ [ [ predecessors-step ] each-basic-block ]
+ [ ]
+ tri ;
diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor
index 7602295284..a1583d2a5d 100755
--- a/basis/compiler/codegen/codegen.factor
+++ b/basis/compiler/codegen/codegen.factor
@@ -531,4 +531,10 @@ M: _reload generate-insn
{ double-float-regs [ %reload-float ] }
} case ;
+M: _copy generate-insn
+ [ dst>> ] [ src>> ] [ class>> ] tri {
+ { int-regs [ %copy ] }
+ { double-float-regs [ %copy-float ] }
+ } case ;
+
M: _spill-counts generate-insn drop ;
From 059eb399f02643264949dd9b3630b4657a0467a9 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Thu, 11 Jun 2009 19:48:14 -0500
Subject: [PATCH 09/35] add initial-quot: syntax for tuples
---
core/bootstrap/syntax.factor | 1 +
core/classes/tuple/parser/parser-tests.factor | 16 +++++++++++++++-
core/classes/tuple/tuple.factor | 15 +++++++++++++--
core/slots/slots.factor | 15 +++++++++++++--
core/syntax/syntax.factor | 4 +++-
5 files changed, 45 insertions(+), 6 deletions(-)
diff --git a/core/bootstrap/syntax.factor b/core/bootstrap/syntax.factor
index f5182a0210..24538229c6 100644
--- a/core/bootstrap/syntax.factor
+++ b/core/bootstrap/syntax.factor
@@ -80,6 +80,7 @@ IN: bootstrap.syntax
">>"
"call-next-method"
"initial:"
+ "initial-quot:"
"read-only"
"call("
"execute("
diff --git a/core/classes/tuple/parser/parser-tests.factor b/core/classes/tuple/parser/parser-tests.factor
index b95507c78b..88fca567f4 100644
--- a/core/classes/tuple/parser/parser-tests.factor
+++ b/core/classes/tuple/parser/parser-tests.factor
@@ -1,7 +1,7 @@
IN: classes.tuple.parser.tests
USING: accessors classes.tuple.parser lexer words classes
sequences math kernel slots tools.test parser compiler.units
-arrays classes.tuple eval ;
+arrays classes.tuple eval multiline ;
TUPLE: test-1 ;
@@ -142,3 +142,17 @@ TUPLE: parsing-corner-case x ;
" 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
+
+[ ] [
+ <" IN: classes.tuple.tests
+ TUPLE: monster { hp virtual } ;">
+ eval( -- )
+] unit-test
diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor
index 225176f4e5..9e0c0b7316 100755
--- a/core/classes/tuple/tuple.factor
+++ b/core/classes/tuple/tuple.factor
@@ -50,8 +50,19 @@ M: tuple class layout-of 2 slot { word } declare ;
PRIVATE>
+: initial-value ( slot -- obj )
+ dup initial>> [
+ nip
+ ] [
+ dup initial-quot>> [
+ nip call( -- obj )
+ ] [
+ drop f
+ ] if*
+ ] if* ;
+
: initial-values ( class -- slots )
- all-slots [ initial>> ] map ;
+ all-slots [ initial-value ] map ;
: pad-slots ( slots class -- slots' class )
[ initial-values over length tail append ] keep ; inline
@@ -176,7 +187,7 @@ ERROR: bad-superclass class ;
: compute-slot-permutation ( new-slots old-slots -- triples )
[ [ [ name>> ] map ] bi@ [ index ] curry map ]
[ drop [ class>> ] map ]
- [ drop [ initial>> ] map ]
+ [ drop [ initial-value ] map ]
2tri 3array flip ;
: update-slot ( old-values n class initial -- value )
diff --git a/core/slots/slots.factor b/core/slots/slots.factor
index 304ded0adb..9db26846d0 100755
--- a/core/slots/slots.factor
+++ b/core/slots/slots.factor
@@ -3,10 +3,10 @@
USING: arrays byte-arrays kernel kernel.private math namespaces
make sequences strings effects generic generic.standard
classes classes.algebra slots.private combinators accessors
-words sequences.private assocs alien quotations hashtables ;
+words sequences.private assocs alien quotations hashtables summary ;
IN: slots
-TUPLE: slot-spec name offset class initial read-only ;
+TUPLE: slot-spec name offset class initial initial-quot read-only ;
PREDICATE: reader < word "reader" word-prop ;
@@ -190,6 +190,7 @@ ERROR: bad-slot-attribute key ;
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
@@ -197,7 +198,17 @@ ERROR: bad-slot-attribute key ;
ERROR: bad-initial-value name ;
+ERROR: duplicate-initial-values slot ;
+
+M: duplicate-initial-values summary
+ drop "Slots can either define initial: or initial-quot:, but not both" ;
+
+: 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?
diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor
index 56ac9fa36e..8093b6345b 100644
--- a/core/syntax/syntax.factor
+++ b/core/syntax/syntax.factor
@@ -245,7 +245,9 @@ IN: bootstrap.syntax
] define-core-syntax
"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
From 4bd06486fb662d55db3773b4eb3f2c5fa4e7c02c Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Thu, 11 Jun 2009 20:20:21 -0500
Subject: [PATCH 10/35] make a word not generic, remove unit test for
unimplemented feature
---
core/classes/tuple/parser/parser-tests.factor | 6 ------
core/classes/tuple/tuple.factor | 4 +---
2 files changed, 1 insertion(+), 9 deletions(-)
diff --git a/core/classes/tuple/parser/parser-tests.factor b/core/classes/tuple/parser/parser-tests.factor
index 88fca567f4..350b594274 100644
--- a/core/classes/tuple/parser/parser-tests.factor
+++ b/core/classes/tuple/parser/parser-tests.factor
@@ -150,9 +150,3 @@ TUPLE: parsing-corner-case x ;
TUPLE: book { name initial-quot: [ "Lord of the " "Rings" append ] } ;">
eval( -- )
] unit-test
-
-[ ] [
- <" IN: classes.tuple.tests
- TUPLE: monster { hp virtual } ;">
- eval( -- )
-] unit-test
diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor
index 9e0c0b7316..55fbdf725f 100755
--- a/core/classes/tuple/tuple.factor
+++ b/core/classes/tuple/tuple.factor
@@ -75,9 +75,7 @@ PRIVATE>
: tuple-slots ( tuple -- seq )
prepare-tuple>array drop copy-tuple-slots ;
-GENERIC: slots>tuple ( seq class -- tuple )
-
-M: tuple-class slots>tuple
+: slots>tuple ( seq class -- tuple )
check-slots pad-slots
tuple-layout <tuple> [
[ tuple-size ]
From 6c2e4839136d363f34bca7c7233c211ef0441e20 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Thu, 11 Jun 2009 20:20:38 -0500
Subject: [PATCH 11/35] use initital-quot: in threaded-server tuple declaration
---
basis/io/servers/connection/connection.factor | 23 +++++++------------
1 file changed, 8 insertions(+), 15 deletions(-)
diff --git a/basis/io/servers/connection/connection.factor b/basis/io/servers/connection/connection.factor
index df6c21e7cc..de75165c7a 100644
--- a/basis/io/servers/connection/connection.factor
+++ b/basis/io/servers/connection/connection.factor
@@ -11,17 +11,17 @@ combinators.short-circuit ;
IN: io.servers.connection
TUPLE: threaded-server
-name
-log-level
+{ name initial: "server" }
+{ log-level initial: DEBUG }
secure insecure
-secure-config
-sockets
+{ secure-config initial-quot: [ <secure-config> ] }
+{ sockets initial-quot: [ V{ } clone ] }
max-connections
semaphore
-timeout
+{ timeout initial-quot: [ 1 minutes ] }
encoding
-handler
-ready ;
+{ handler initial: [ "No handler quotation" throw ] }
+{ ready initial-quot: [ <flag> ] } ;
: local-server ( port -- addrspec ) "localhost" swap <inet> ;
@@ -29,14 +29,7 @@ ready ;
: new-threaded-server ( encoding class -- threaded-server )
new
- swap >>encoding
- "server" >>name
- DEBUG >>log-level
- 1 minutes >>timeout
- V{ } clone >>sockets
- <secure-config> >>secure-config
- [ "No handler quotation" throw ] >>handler
- <flag> >>ready ; inline
+ swap >>encoding ;
: <threaded-server> ( encoding -- threaded-server )
threaded-server new-threaded-server ;
From f9fb81a96226dd96bdc9507af36ae39be4a8ff34 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Thu, 11 Jun 2009 21:22:24 -0400
Subject: [PATCH 12/35] merge
---
basis/game-input/dinput/dinput.factor | 19 +++++++--------
basis/io/servers/connection/connection.factor | 23 ++++++++++++-------
core/bootstrap/syntax.factor | 1 -
core/classes/tuple/parser/parser-tests.factor | 10 +-------
core/classes/tuple/tuple.factor | 19 ++++-----------
core/slots/slots.factor | 15 ++----------
core/syntax/syntax.factor | 4 +---
7 files changed, 34 insertions(+), 57 deletions(-)
diff --git a/basis/game-input/dinput/dinput.factor b/basis/game-input/dinput/dinput.factor
index 0ecf543baa..8540907db9 100755
--- a/basis/game-input/dinput/dinput.factor
+++ b/basis/game-input/dinput/dinput.factor
@@ -1,13 +1,14 @@
-USING: accessors alien alien.c-types alien.strings arrays
-assocs byte-arrays combinators continuations game-input
-game-input.dinput.keys-array io.encodings.utf16
-io.encodings.utf16n kernel locals math math.bitwise
-math.rectangles namespaces parser sequences shuffle
-struct-arrays ui.backend.windows vectors windows.com
-windows.dinput windows.dinput.constants windows.errors
-windows.kernel32 windows.messages windows.ole32
-windows.user32 ;
+USING: windows.dinput windows.dinput.constants parser
+alien.c-types windows.ole32 namespaces assocs kernel arrays
+vectors windows.kernel32 windows.com windows.dinput shuffle
+windows.user32 windows.messages sequences combinators locals
+math.rectangles accessors math alien alien.strings
+io.encodings.utf16 io.encodings.utf16n continuations
+byte-arrays game-input.dinput.keys-array game-input
+ui.backend.windows windows.errors struct-arrays
+math.bitwise ;
IN: game-input.dinput
+
CONSTANT: MOUSE-BUFFER-SIZE 16
SINGLETON: dinput-game-input-backend
diff --git a/basis/io/servers/connection/connection.factor b/basis/io/servers/connection/connection.factor
index de75165c7a..df6c21e7cc 100644
--- a/basis/io/servers/connection/connection.factor
+++ b/basis/io/servers/connection/connection.factor
@@ -11,17 +11,17 @@ combinators.short-circuit ;
IN: io.servers.connection
TUPLE: threaded-server
-{ name initial: "server" }
-{ log-level initial: DEBUG }
+name
+log-level
secure insecure
-{ secure-config initial-quot: [ <secure-config> ] }
-{ sockets initial-quot: [ V{ } clone ] }
+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> ;
@@ -29,7 +29,14 @@ encoding
: new-threaded-server ( encoding class -- threaded-server )
new
- swap >>encoding ;
+ swap >>encoding
+ "server" >>name
+ DEBUG >>log-level
+ 1 minutes >>timeout
+ V{ } clone >>sockets
+ <secure-config> >>secure-config
+ [ "No handler quotation" throw ] >>handler
+ <flag> >>ready ; inline
: <threaded-server> ( encoding -- threaded-server )
threaded-server new-threaded-server ;
diff --git a/core/bootstrap/syntax.factor b/core/bootstrap/syntax.factor
index 24538229c6..f5182a0210 100644
--- a/core/bootstrap/syntax.factor
+++ b/core/bootstrap/syntax.factor
@@ -80,7 +80,6 @@ IN: bootstrap.syntax
">>"
"call-next-method"
"initial:"
- "initial-quot:"
"read-only"
"call("
"execute("
diff --git a/core/classes/tuple/parser/parser-tests.factor b/core/classes/tuple/parser/parser-tests.factor
index 350b594274..b95507c78b 100644
--- a/core/classes/tuple/parser/parser-tests.factor
+++ b/core/classes/tuple/parser/parser-tests.factor
@@ -1,7 +1,7 @@
IN: classes.tuple.parser.tests
USING: accessors classes.tuple.parser lexer words classes
sequences math kernel slots tools.test parser compiler.units
-arrays classes.tuple eval multiline ;
+arrays classes.tuple eval ;
TUPLE: test-1 ;
@@ -142,11 +142,3 @@ TUPLE: parsing-corner-case x ;
" 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
diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor
index 55fbdf725f..225176f4e5 100755
--- a/core/classes/tuple/tuple.factor
+++ b/core/classes/tuple/tuple.factor
@@ -50,19 +50,8 @@ M: tuple class layout-of 2 slot { word } declare ;
PRIVATE>
-: initial-value ( slot -- obj )
- dup initial>> [
- nip
- ] [
- dup initial-quot>> [
- nip call( -- obj )
- ] [
- drop f
- ] if*
- ] if* ;
-
: initial-values ( class -- slots )
- all-slots [ initial-value ] map ;
+ all-slots [ initial>> ] map ;
: pad-slots ( slots class -- slots' class )
[ initial-values over length tail append ] keep ; inline
@@ -75,7 +64,9 @@ PRIVATE>
: tuple-slots ( tuple -- seq )
prepare-tuple>array drop copy-tuple-slots ;
-: slots>tuple ( seq class -- tuple )
+GENERIC: slots>tuple ( seq class -- tuple )
+
+M: tuple-class slots>tuple
check-slots pad-slots
tuple-layout <tuple> [
[ tuple-size ]
@@ -185,7 +176,7 @@ ERROR: bad-superclass class ;
: compute-slot-permutation ( new-slots old-slots -- triples )
[ [ [ name>> ] map ] bi@ [ index ] curry map ]
[ drop [ class>> ] map ]
- [ drop [ initial-value ] map ]
+ [ drop [ initial>> ] map ]
2tri 3array flip ;
: update-slot ( old-values n class initial -- value )
diff --git a/core/slots/slots.factor b/core/slots/slots.factor
index 9db26846d0..304ded0adb 100755
--- a/core/slots/slots.factor
+++ b/core/slots/slots.factor
@@ -3,10 +3,10 @@
USING: arrays byte-arrays kernel kernel.private math namespaces
make sequences strings effects generic generic.standard
classes classes.algebra slots.private combinators accessors
-words sequences.private assocs alien quotations hashtables summary ;
+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 ;
@@ -190,7 +190,6 @@ ERROR: bad-slot-attribute key ;
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
@@ -198,17 +197,7 @@ ERROR: bad-slot-attribute key ;
ERROR: bad-initial-value name ;
-ERROR: duplicate-initial-values slot ;
-
-M: duplicate-initial-values summary
- drop "Slots can either define initial: or initial-quot:, but not both" ;
-
-: 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?
diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor
index 8093b6345b..56ac9fa36e 100644
--- a/core/syntax/syntax.factor
+++ b/core/syntax/syntax.factor
@@ -245,9 +245,7 @@ IN: bootstrap.syntax
] define-core-syntax
"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
From a390fe9644f2555c5b47445136113569fb68a8cc Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Thu, 11 Jun 2009 21:23:47 -0400
Subject: [PATCH 13/35] Revert "merge"
This reverts commit c2a03d259a7b853b586afd68a0b842140188e0db.
---
basis/game-input/dinput/dinput.factor | 19 ++++++++-------
basis/io/servers/connection/connection.factor | 23 +++++++------------
core/bootstrap/syntax.factor | 1 +
core/classes/tuple/parser/parser-tests.factor | 10 +++++++-
core/classes/tuple/tuple.factor | 19 +++++++++++----
core/slots/slots.factor | 15 ++++++++++--
core/syntax/syntax.factor | 4 +++-
7 files changed, 57 insertions(+), 34 deletions(-)
diff --git a/basis/game-input/dinput/dinput.factor b/basis/game-input/dinput/dinput.factor
index 8540907db9..0ecf543baa 100755
--- a/basis/game-input/dinput/dinput.factor
+++ b/basis/game-input/dinput/dinput.factor
@@ -1,14 +1,13 @@
-USING: windows.dinput windows.dinput.constants parser
-alien.c-types windows.ole32 namespaces assocs kernel arrays
-vectors windows.kernel32 windows.com windows.dinput shuffle
-windows.user32 windows.messages sequences combinators locals
-math.rectangles accessors math alien alien.strings
-io.encodings.utf16 io.encodings.utf16n continuations
-byte-arrays game-input.dinput.keys-array game-input
-ui.backend.windows windows.errors struct-arrays
-math.bitwise ;
+USING: accessors alien alien.c-types alien.strings arrays
+assocs byte-arrays combinators continuations game-input
+game-input.dinput.keys-array io.encodings.utf16
+io.encodings.utf16n kernel locals math math.bitwise
+math.rectangles namespaces parser sequences shuffle
+struct-arrays ui.backend.windows vectors windows.com
+windows.dinput windows.dinput.constants windows.errors
+windows.kernel32 windows.messages windows.ole32
+windows.user32 ;
IN: game-input.dinput
-
CONSTANT: MOUSE-BUFFER-SIZE 16
SINGLETON: dinput-game-input-backend
diff --git a/basis/io/servers/connection/connection.factor b/basis/io/servers/connection/connection.factor
index df6c21e7cc..de75165c7a 100644
--- a/basis/io/servers/connection/connection.factor
+++ b/basis/io/servers/connection/connection.factor
@@ -11,17 +11,17 @@ combinators.short-circuit ;
IN: io.servers.connection
TUPLE: threaded-server
-name
-log-level
+{ name initial: "server" }
+{ log-level initial: DEBUG }
secure insecure
-secure-config
-sockets
+{ secure-config initial-quot: [ <secure-config> ] }
+{ sockets initial-quot: [ V{ } clone ] }
max-connections
semaphore
-timeout
+{ timeout initial-quot: [ 1 minutes ] }
encoding
-handler
-ready ;
+{ handler initial: [ "No handler quotation" throw ] }
+{ ready initial-quot: [ <flag> ] } ;
: local-server ( port -- addrspec ) "localhost" swap <inet> ;
@@ -29,14 +29,7 @@ ready ;
: new-threaded-server ( encoding class -- threaded-server )
new
- swap >>encoding
- "server" >>name
- DEBUG >>log-level
- 1 minutes >>timeout
- V{ } clone >>sockets
- <secure-config> >>secure-config
- [ "No handler quotation" throw ] >>handler
- <flag> >>ready ; inline
+ swap >>encoding ;
: <threaded-server> ( encoding -- threaded-server )
threaded-server new-threaded-server ;
diff --git a/core/bootstrap/syntax.factor b/core/bootstrap/syntax.factor
index f5182a0210..24538229c6 100644
--- a/core/bootstrap/syntax.factor
+++ b/core/bootstrap/syntax.factor
@@ -80,6 +80,7 @@ IN: bootstrap.syntax
">>"
"call-next-method"
"initial:"
+ "initial-quot:"
"read-only"
"call("
"execute("
diff --git a/core/classes/tuple/parser/parser-tests.factor b/core/classes/tuple/parser/parser-tests.factor
index b95507c78b..350b594274 100644
--- a/core/classes/tuple/parser/parser-tests.factor
+++ b/core/classes/tuple/parser/parser-tests.factor
@@ -1,7 +1,7 @@
IN: classes.tuple.parser.tests
USING: accessors classes.tuple.parser lexer words classes
sequences math kernel slots tools.test parser compiler.units
-arrays classes.tuple eval ;
+arrays classes.tuple eval multiline ;
TUPLE: test-1 ;
@@ -142,3 +142,11 @@ TUPLE: parsing-corner-case x ;
" 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
diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor
index 225176f4e5..55fbdf725f 100755
--- a/core/classes/tuple/tuple.factor
+++ b/core/classes/tuple/tuple.factor
@@ -50,8 +50,19 @@ M: tuple class layout-of 2 slot { word } declare ;
PRIVATE>
+: initial-value ( slot -- obj )
+ dup initial>> [
+ nip
+ ] [
+ dup initial-quot>> [
+ nip call( -- obj )
+ ] [
+ drop f
+ ] if*
+ ] if* ;
+
: initial-values ( class -- slots )
- all-slots [ initial>> ] map ;
+ all-slots [ initial-value ] map ;
: pad-slots ( slots class -- slots' class )
[ initial-values over length tail append ] keep ; inline
@@ -64,9 +75,7 @@ PRIVATE>
: tuple-slots ( tuple -- seq )
prepare-tuple>array drop copy-tuple-slots ;
-GENERIC: slots>tuple ( seq class -- tuple )
-
-M: tuple-class slots>tuple
+: slots>tuple ( seq class -- tuple )
check-slots pad-slots
tuple-layout <tuple> [
[ tuple-size ]
@@ -176,7 +185,7 @@ ERROR: bad-superclass class ;
: compute-slot-permutation ( new-slots old-slots -- triples )
[ [ [ name>> ] map ] bi@ [ index ] curry map ]
[ drop [ class>> ] map ]
- [ drop [ initial>> ] map ]
+ [ drop [ initial-value ] map ]
2tri 3array flip ;
: update-slot ( old-values n class initial -- value )
diff --git a/core/slots/slots.factor b/core/slots/slots.factor
index 304ded0adb..9db26846d0 100755
--- a/core/slots/slots.factor
+++ b/core/slots/slots.factor
@@ -3,10 +3,10 @@
USING: arrays byte-arrays kernel kernel.private math namespaces
make sequences strings effects generic generic.standard
classes classes.algebra slots.private combinators accessors
-words sequences.private assocs alien quotations hashtables ;
+words sequences.private assocs alien quotations hashtables summary ;
IN: slots
-TUPLE: slot-spec name offset class initial read-only ;
+TUPLE: slot-spec name offset class initial initial-quot read-only ;
PREDICATE: reader < word "reader" word-prop ;
@@ -190,6 +190,7 @@ ERROR: bad-slot-attribute key ;
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
@@ -197,7 +198,17 @@ ERROR: bad-slot-attribute key ;
ERROR: bad-initial-value name ;
+ERROR: duplicate-initial-values slot ;
+
+M: duplicate-initial-values summary
+ drop "Slots can either define initial: or initial-quot:, but not both" ;
+
+: 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?
diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor
index 56ac9fa36e..8093b6345b 100644
--- a/core/syntax/syntax.factor
+++ b/core/syntax/syntax.factor
@@ -245,7 +245,9 @@ IN: bootstrap.syntax
] define-core-syntax
"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
From 50be248db0d229bd11f247d2a0a27b40c4ce8b28 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Thu, 11 Jun 2009 20:26:49 -0500
Subject: [PATCH 14/35] don't use summary in slots
---
core/slots/slots.factor | 5 +----
1 file changed, 1 insertion(+), 4 deletions(-)
diff --git a/core/slots/slots.factor b/core/slots/slots.factor
index 9db26846d0..c8be08e79b 100755
--- a/core/slots/slots.factor
+++ b/core/slots/slots.factor
@@ -3,7 +3,7 @@
USING: arrays byte-arrays kernel kernel.private math namespaces
make sequences strings effects generic generic.standard
classes classes.algebra slots.private combinators accessors
-words sequences.private assocs alien quotations hashtables summary ;
+words sequences.private assocs alien quotations hashtables ;
IN: slots
TUPLE: slot-spec name offset class initial initial-quot read-only ;
@@ -200,9 +200,6 @@ ERROR: bad-initial-value name ;
ERROR: duplicate-initial-values slot ;
-M: duplicate-initial-values summary
- drop "Slots can either define initial: or initial-quot:, but not both" ;
-
: check-duplicate-initial-values ( slot-spec -- slot-spec )
dup [ initial>> ] [ initial-quot>> ] bi and
[ duplicate-initial-values ] when ;
From 6a67f02f69a3bb6446715bb7b23deea735672142 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Fri, 12 Jun 2009 02:43:05 -0500
Subject: [PATCH 15/35] fix load error
---
basis/math/matrices/matrices.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/basis/math/matrices/matrices.factor b/basis/math/matrices/matrices.factor
index 3a3b470ac8..d6bee78c14 100644
--- a/basis/math/matrices/matrices.factor
+++ b/basis/math/matrices/matrices.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays columns kernel math math.bits
-math.order math.vectors sequences sequences.private ;
+math.order math.vectors sequences sequences.private fry ;
IN: math.matrices
! Matrices
From c5a5e943812f1e35dd85f7a6f5714dac1bc85556 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Fri, 12 Jun 2009 02:43:13 -0500
Subject: [PATCH 16/35] fix destructors docs
---
core/destructors/destructors-docs.factor | 6 +++---
1 file changed, 3 insertions(+), 3 deletions(-)
diff --git a/core/destructors/destructors-docs.factor b/core/destructors/destructors-docs.factor
index 536ee19c8b..40482fce05 100644
--- a/core/destructors/destructors-docs.factor
+++ b/core/destructors/destructors-docs.factor
@@ -8,16 +8,16 @@ HELP: dispose
$nl
"No further operations can be performed on a disposable object after this call."
$nl
-"Disposing an object which has already been disposed should have no effect, and in particular it should not fail with an error. To help implement this pattern, add a " { $snippet "disposed" } " slot to your object and implement the " { $link dispose* } " method instead." }
+"Disposing an object which has already been disposed should have no effect, and in particular it should not fail with an error. To help implement this pattern, add a " { $slot "disposed" } " slot to your object and implement the " { $link dispose* } " method instead." }
{ $notes "You must close disposable objects after you are finished working with them, to avoid leaking operating system resources. A convenient way to automate this is by using the " { $link with-disposal } " word."
$nl
-"The default implementation assumes the object has a " { $snippet "disposable" } " slot. If the slot is set to " { $link f } ", it calls " { $link dispose* } " and sets the slot to " { $link f } "." } ;
+"The default implementation assumes the object has a " { $slot "disposed" } " slot. If the slot is set to " { $link f } ", it calls " { $link dispose* } " and sets the slot to " { $link f } "." } ;
HELP: dispose*
{ $values { "disposable" "a disposable object" } }
{ $contract "Releases operating system resources associated with a disposable object. Disposable objects include streams, memory mapped files, and so on." }
{ $notes
- "This word should not be called directly. It can be implemented on objects with a " { $snippet "disposable" } " slot to ensure that the object is only disposed once."
+ "This word should not be called directly. It can be implemented on objects with a " { $slot "disposed" } " slot to ensure that the object is only disposed once."
} ;
HELP: with-disposal
From 21a33419a737795190e13f37ed87d8e33607c822 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Fri, 12 Jun 2009 09:21:51 -0500
Subject: [PATCH 17/35] initial-quot: works fully, need to make a couple
simplifications
---
core/classes/tuple/tuple.factor | 63 ++++++++++++++++++++++++---------
1 file changed, 46 insertions(+), 17 deletions(-)
diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor
index 55fbdf725f..8aaed4aaae 100755
--- a/core/classes/tuple/tuple.factor
+++ b/core/classes/tuple/tuple.factor
@@ -50,19 +50,11 @@ M: tuple class layout-of 2 slot { word } declare ;
PRIVATE>
-: initial-value ( slot -- obj )
- dup initial>> [
- nip
- ] [
- dup initial-quot>> [
- nip call( -- obj )
- ] [
- drop f
- ] if*
- ] if* ;
+: initial-quots? ( class -- ? )
+ all-slots [ initial-quot>> ] any? ;
: initial-values ( class -- slots )
- all-slots [ initial-value ] map ;
+ all-slots [ initial>> ] map ;
: pad-slots ( slots class -- slots' class )
[ initial-values over length tail append ] keep ; inline
@@ -75,7 +67,9 @@ PRIVATE>
: tuple-slots ( tuple -- seq )
prepare-tuple>array drop copy-tuple-slots ;
-: slots>tuple ( seq class -- tuple )
+GENERIC: slots>tuple ( seq class -- tuple )
+
+M: tuple-class slots>tuple ( seq class -- tuple )
check-slots pad-slots
tuple-layout <tuple> [
[ tuple-size ]
@@ -156,8 +150,8 @@ ERROR: bad-superclass class ;
dup boa-check-quot "boa-check" set-word-prop ;
: tuple-prototype ( class -- prototype )
- [ initial-values ] keep
- over [ ] any? [ slots>tuple ] [ 2drop f ] if ;
+ [ initial-values ] [ over [ ] any? ] [ initial-quots? or ] tri
+ [ slots>tuple ] [ 2drop f ] if ;
: define-tuple-prototype ( class -- )
dup tuple-prototype "prototype" set-word-prop ;
@@ -182,10 +176,40 @@ ERROR: bad-superclass class ;
: define-tuple-layout ( class -- )
dup make-tuple-layout "layout" set-word-prop ;
+: define-tuple-constructor ( class -- )
+ {
+ { [ dup initial-quots? ] [ "initial-quots" ] }
+ { [ dup "prototype" word-prop ] [ "prototype" ] }
+ [ f ]
+ } cond "constructor" set-word-prop ;
+
+: define-tuple-initial-quots ( class -- )
+ dup all-slots [ initial-quot>> ] filter
+ [
+ [
+ [ initial-quot>> , (( -- obj )) , \ call-effect , \ over , ]
+ [ offset>> , ] bi \ set-slot ,
+ ] each
+ ] [ ] make "initial-quots-setter" set-word-prop ;
+
+: set-initial-quots ( tuple -- tuple' )
+ dup class "initial-quots-setter" word-prop call( obj -- obj ) ;
+
+: 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 [ initial-value ] map ]
+ [ drop [ calculate-initial-value ] map ]
2tri 3array flip ;
: update-slot ( old-values n class initial -- value )
@@ -233,6 +257,8 @@ M: tuple-class update-class
[ define-tuple-slots ]
[ define-tuple-predicate ]
[ define-tuple-prototype ]
+ [ define-tuple-constructor ]
+ [ define-tuple-initial-quots ]
} cleave ;
: define-new-tuple-class ( class superclass slots -- )
@@ -349,8 +375,11 @@ M: tuple tuple-hashcode
M: tuple hashcode* tuple-hashcode ;
M: tuple-class new
- dup "prototype" word-prop
- [ (clone) ] [ tuple-layout <tuple> ] ?if ;
+ dup "constructor" word-prop {
+ { "initial-quots" [ "prototype" word-prop (clone) set-initial-quots ] }
+ { "prototype" [ "prototype" word-prop (clone) ] }
+ [ drop tuple-layout <tuple> ]
+ } case ;
M: tuple-class boa
[ "boa-check" word-prop [ call ] when* ]
From 99bfeb62c4c630a33ac0d3a7edfec90b8805c03c Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Fri, 12 Jun 2009 11:45:53 -0500
Subject: [PATCH 18/35] simplify implementation of initial-quot:
---
core/classes/tuple/tuple.factor | 43 ++++++++++++---------------------
1 file changed, 16 insertions(+), 27 deletions(-)
diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor
index 8aaed4aaae..e5ea80bc39 100755
--- a/core/classes/tuple/tuple.factor
+++ b/core/classes/tuple/tuple.factor
@@ -149,12 +149,22 @@ ERROR: bad-superclass class ;
: 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
[ slots>tuple ] [ 2drop f ] if ;
: define-tuple-prototype ( class -- )
- dup tuple-prototype "prototype" set-word-prop ;
+ dup [ tuple-prototype ] [ tuple-initial-quots-quot ] bi 2array
+ dup [ ] any? [ drop f ] unless "prototype" set-word-prop ;
: prepare-slots ( slots superclass -- slots' )
[ make-slots ] [ class-size 2 + ] bi* finalize-slots ;
@@ -176,25 +186,6 @@ ERROR: bad-superclass class ;
: define-tuple-layout ( class -- )
dup make-tuple-layout "layout" set-word-prop ;
-: define-tuple-constructor ( class -- )
- {
- { [ dup initial-quots? ] [ "initial-quots" ] }
- { [ dup "prototype" word-prop ] [ "prototype" ] }
- [ f ]
- } cond "constructor" set-word-prop ;
-
-: define-tuple-initial-quots ( class -- )
- dup all-slots [ initial-quot>> ] filter
- [
- [
- [ initial-quot>> , (( -- obj )) , \ call-effect , \ over , ]
- [ offset>> , ] bi \ set-slot ,
- ] each
- ] [ ] make "initial-quots-setter" set-word-prop ;
-
-: set-initial-quots ( tuple -- tuple' )
- dup class "initial-quots-setter" word-prop call( obj -- obj ) ;
-
: calculate-initial-value ( slot-spec -- value )
dup initial>> [
nip
@@ -257,8 +248,6 @@ M: tuple-class update-class
[ define-tuple-slots ]
[ define-tuple-predicate ]
[ define-tuple-prototype ]
- [ define-tuple-constructor ]
- [ define-tuple-initial-quots ]
} cleave ;
: define-new-tuple-class ( class superclass slots -- )
@@ -375,11 +364,11 @@ M: tuple tuple-hashcode
M: tuple hashcode* tuple-hashcode ;
M: tuple-class new
- dup "constructor" word-prop {
- { "initial-quots" [ "prototype" word-prop (clone) set-initial-quots ] }
- { "prototype" [ "prototype" word-prop (clone) ] }
- [ drop tuple-layout <tuple> ]
- } case ;
+ dup "prototype" word-prop [
+ first2 [ (clone) ] dip [ call( obj -- obj ) ] when*
+ ] [
+ tuple-layout <tuple>
+ ] ?if ;
M: tuple-class boa
[ "boa-check" word-prop [ call ] when* ]
From 258abe31abdd200c12ba21c0a1c73082bd57cc2a Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Fri, 12 Jun 2009 11:58:07 -0500
Subject: [PATCH 19/35] add some unit tests for reshaping tuples with
initial-quot: slots
---
core/classes/tuple/tuple-tests.factor | 35 ++++++++++++++++++---------
1 file changed, 24 insertions(+), 11 deletions(-)
diff --git a/core/classes/tuple/tuple-tests.factor b/core/classes/tuple/tuple-tests.factor
index e3452194c6..352d66f19e 100644
--- a/core/classes/tuple/tuple-tests.factor
+++ b/core/classes/tuple/tuple-tests.factor
@@ -1,11 +1,12 @@
-USING: definitions generic kernel kernel.private math math.constants
-parser sequences tools.test words assocs namespaces quotations
-sequences.private classes continuations generic.single
-generic.standard effects classes.tuple classes.tuple.private arrays
-vectors strings compiler.units accessors classes.algebra calendar
-prettyprint io.streams.string splitting summary columns math.order
-classes.private slots slots.private eval see words.symbol
-compiler.errors parser.notes ;
+USING: accessors arrays assocs calendar classes classes.algebra
+classes.private classes.tuple classes.tuple.private columns
+compiler.errors compiler.units continuations definitions
+effects eval generic generic.single generic.standard grouping
+io.streams.string kernel kernel.private math math.constants
+math.order namespaces parser parser.notes prettyprint
+quotations random see sequences sequences.private slots
+slots.private splitting strings summary threads tools.test
+vectors vocabs words words.symbol ;
IN: classes.tuple.tests
TUPLE: rect x y w h ;
@@ -421,7 +422,6 @@ TUPLE: redefinition-problem-2 ;
[ t ] [ 3 redefinition-problem'? ] unit-test
! Hardcore unit tests
-USE: threads
\ thread "slots" word-prop "slots" set
@@ -439,8 +439,6 @@ USE: threads
] with-compilation-unit
] unit-test
-USE: vocabs
-
\ vocab "slots" word-prop "slots" set
[ ] [
@@ -731,3 +729,18 @@ DEFER: redefine-tuple-twice
[ ] [ "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
From 64f93e41a92612e534774fe450facdf4a3a5456b Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 13 Jun 2009 17:35:40 -0500
Subject: [PATCH 20/35] Various linear scan fixes insert spill before reload to
fix x86-32 regression inactive splitting: if all inactive intervals'
registers are in use, don't fail fix stack analysis tests
---
.../allocation/splitting/splitting.factor | 33 ++++++++++---------
.../linear-scan/assignment/assignment.factor | 2 +-
.../cfg/linear-scan/linear-scan-tests.factor | 25 +++++++-------
.../live-intervals/live-intervals.factor | 18 ++++++----
.../stack-analysis-tests.factor | 4 ++-
basis/compiler/tests/codegen.factor | 22 +++++++++++++
6 files changed, 69 insertions(+), 35 deletions(-)
diff --git a/basis/compiler/cfg/linear-scan/allocation/splitting/splitting.factor b/basis/compiler/cfg/linear-scan/allocation/splitting/splitting.factor
index 31c9332ab5..40ee4083e4 100644
--- a/basis/compiler/cfg/linear-scan/allocation/splitting/splitting.factor
+++ b/basis/compiler/cfg/linear-scan/allocation/splitting/splitting.factor
@@ -20,10 +20,8 @@ IN: compiler.cfg.linear-scan.allocation.splitting
: 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
+ [ over last ] dip 2dup split-last-range?
+ [ split-last-range ] [ 2drop ] if
] bi ;
: split-uses ( uses n -- before after )
@@ -34,11 +32,14 @@ IN: compiler.cfg.linear-scan.allocation.splitting
[ [ >>split-before ] [ >>split-after ] bi* drop ]
2bi ; inline
+ERROR: splitting-too-early ;
+
ERROR: splitting-atomic-interval ;
-: check-split ( live-interval -- )
- [ end>> ] [ start>> ] bi - 0 =
- [ splitting-atomic-interval ] when ; inline
+: 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
@@ -47,7 +48,7 @@ ERROR: splitting-atomic-interval ;
f >>copy-from f >>reg f >>reload-from ; inline
:: split-interval ( live-interval n -- before after )
- live-interval check-split
+ 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*
@@ -83,18 +84,18 @@ HINTS: split-interval live-interval object ;
]
} cond ;
-: intersect-inactive ( new inactive active-regs -- n )
- 2dup [ reg>> ] dip key? [
- 2drop start>>
- ] [
- drop relevant-ranges intersect-live-ranges
- ] if ;
+: 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 ;
+ '[ tuck _ intersect-inactive ] with { } map>assoc
+ [ nip ] assoc-filter ;
: insert-use-for-copy ( seq n -- seq' )
[ 1array split1 ] keep [ 1 - ] keep 2array glue ;
@@ -115,5 +116,5 @@ HINTS: split-interval live-interval object ;
first reuse-register
] [
[ second split-before-use ] keep
- '[ _ first reuse-register ] [ add-unhandled ] bi*
+ '[ _ first reuse-register ] [ add-unhandled ] bi*
] if ;
\ No newline at end of file
diff --git a/basis/compiler/cfg/linear-scan/assignment/assignment.factor b/basis/compiler/cfg/linear-scan/assignment/assignment.factor
index ff06fbfa9b..ea918a7424 100644
--- a/basis/compiler/cfg/linear-scan/assignment/assignment.factor
+++ b/basis/compiler/cfg/linear-scan/assignment/assignment.factor
@@ -128,8 +128,8 @@ M: insn assign-registers-in-insn drop ;
[
[
insn#>>
- [ activate-new-intervals ]
[ expire-old-intervals ]
+ [ activate-new-intervals ]
bi
]
[ assign-registers-in-insn ]
diff --git a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor
index d851b67fc0..243e83445d 100644
--- a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor
+++ b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor
@@ -62,11 +62,8 @@ check-allocation? on
] 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 } }
@@ -1733,6 +1730,12 @@ test-diamond
T{ basic-block
{ id 0 }
+ { number 0 }
+ { instructions V{ T{ ##prologue } T{ ##branch } } }
+} 0 set
+
+T{ basic-block
+ { id 1 }
{ instructions
V{
T{ ##peek
@@ -1746,10 +1749,10 @@ T{ basic-block
}
}
}
-} 0 set
+} 1 set
T{ basic-block
- { id 1 }
+ { id 2 }
{ instructions
V{
T{ ##peek
@@ -1763,10 +1766,10 @@ T{ basic-block
T{ ##branch }
}
}
-} 1 set
+} 2 set
T{ basic-block
- { id 2 }
+ { id 3 }
{ instructions
V{
T{ ##peek
@@ -1780,10 +1783,10 @@ T{ basic-block
T{ ##branch }
}
}
-} 2 set
+} 3 set
T{ basic-block
- { id 3 }
+ { id 4 }
{ instructions
V{
T{ ##replace
@@ -1793,7 +1796,7 @@ T{ basic-block
T{ ##return }
}
}
-} 3 set
+} 4 set
test-diamond
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 b631834d79..c88f7fd21b 100644
--- a/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor
+++ b/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces kernel assocs accessors sequences math math.order fry
-binary-search compiler.cfg.instructions compiler.cfg.registers
+binary-search combinators compiler.cfg.instructions compiler.cfg.registers
compiler.cfg.def-use compiler.cfg.liveness compiler.cfg ;
IN: compiler.cfg.linear-scan.live-intervals
@@ -120,17 +120,23 @@ M: ##copy-float compute-live-intervals*
: compute-start/end ( live-interval -- )
dup ranges>> [ first from>> ] [ last to>> ] bi
- 2dup > [ "BUG: start > end" throw ] when
[ >>start ] [ >>end ] bi* drop ;
+: check-start/end ( live-interval -- )
+ [ [ start>> ] [ uses>> first ] bi assert= ]
+ [ [ end>> ] [ uses>> last ] bi assert= ]
+ bi ;
+
: finish-live-intervals ( live-intervals -- )
! Since live intervals are computed in a backward order, we have
! to reverse some sequences, and compute the start and end.
[
- [ ranges>> reverse-here ]
- [ uses>> reverse-here ]
- [ compute-start/end ]
- tri
+ {
+ [ ranges>> reverse-here ]
+ [ uses>> reverse-here ]
+ [ compute-start/end ]
+ [ check-start/end ]
+ } cleave
] each ;
: compute-live-intervals ( rpo -- live-intervals )
diff --git a/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor b/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor
index 4455d5e208..3501825704 100644
--- a/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor
+++ b/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor
@@ -4,7 +4,7 @@ compiler.cfg.instructions sequences kernel tools.test accessors
sequences.private alien math combinators.private compiler.cfg
compiler.cfg.checker compiler.cfg.height compiler.cfg.rpo
compiler.cfg.dce compiler.cfg.registers compiler.cfg.useless-blocks
-sets ;
+sets namespaces ;
IN: compiler.cfg.stack-analysis.tests
! Fundamental invariant: a basic block should not load or store a value more than once
@@ -33,6 +33,8 @@ IN: compiler.cfg.stack-analysis.tests
: linearize ( cfg -- mr )
flatten-cfg instructions>> ;
+local-only? off
+
[ ] [ [ ] test-stack-analysis drop ] unit-test
! Only peek once
diff --git a/basis/compiler/tests/codegen.factor b/basis/compiler/tests/codegen.factor
index 47c6fa31e7..36ee5eb94d 100644
--- a/basis/compiler/tests/codegen.factor
+++ b/basis/compiler/tests/codegen.factor
@@ -288,4 +288,26 @@ M: cucumber equal? "The cucumber has no equal" throw ;
-1 <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
From 7076d89fc30cd248a5e7046bef310df3d0f12669 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 13 Jun 2009 17:36:47 -0500
Subject: [PATCH 21/35] destructors: fix docs typo reported by Blei in
#concatenative
---
core/destructors/destructors-docs.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/core/destructors/destructors-docs.factor b/core/destructors/destructors-docs.factor
index 536ee19c8b..1966f0b69f 100644
--- a/core/destructors/destructors-docs.factor
+++ b/core/destructors/destructors-docs.factor
@@ -11,7 +11,7 @@ $nl
"Disposing an object which has already been disposed should have no effect, and in particular it should not fail with an error. To help implement this pattern, add a " { $snippet "disposed" } " slot to your object and implement the " { $link dispose* } " method instead." }
{ $notes "You must close disposable objects after you are finished working with them, to avoid leaking operating system resources. A convenient way to automate this is by using the " { $link with-disposal } " word."
$nl
-"The default implementation assumes the object has a " { $snippet "disposable" } " slot. If the slot is set to " { $link f } ", it calls " { $link dispose* } " and sets the slot to " { $link f } "." } ;
+"The default implementation assumes the object has a " { $snippet "disposable" } " 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" } }
From 285c8cecc6e960fc7ea460b22ae857b46e61aefa Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 13 Jun 2009 18:34:27 -0500
Subject: [PATCH 22/35] Add some failing unit tests exposing bugs in
initial-quot: implementation
---
.../escape-analysis-tests.factor | 9 ++++-
core/classes/tuple/tuple-tests.factor | 34 ++++++++++++++++++-
core/classes/tuple/tuple.factor | 16 +++------
3 files changed, 46 insertions(+), 13 deletions(-)
diff --git a/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor b/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor
index 708992f918..2688f7f8f1 100644
--- a/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor
+++ b/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor
@@ -327,4 +327,11 @@ C: <ro-box> ro-box
TUPLE: empty-tuple ;
-[ ] [ [ empty-tuple boa layout-of ] count-unboxed-allocations drop ] unit-test
\ No newline at end of file
+[ ] [ [ empty-tuple boa layout-of ] count-unboxed-allocations drop ] unit-test
+
+! Make sure that initial-quot: doesn't inhibit unboxing
+TUPLE: initial-quot-tuple { x read-only initial-quot: [ 0 ] } ;
+
+[ 1 ] [
+ [ initial-quot-tuple new x>> ] count-unboxed-allocations
+] unit-test
\ No newline at end of file
diff --git a/core/classes/tuple/tuple-tests.factor b/core/classes/tuple/tuple-tests.factor
index 352d66f19e..4b23578a29 100644
--- a/core/classes/tuple/tuple-tests.factor
+++ b/core/classes/tuple/tuple-tests.factor
@@ -733,7 +733,11 @@ DEFER: redefine-tuple-twice
TUPLE: lucky-number { n initial-quot: [ 64 random-bits ] } ;
SLOT: winner?
-[ f ] [ 100 [ lucky-number new ] replicate all-equal? ] unit-test
+[ t ] [ lucky-number new n>> integer? ] unit-test
+
+: compiled-lucky-number ( -- tuple ) lucky-number new ;
+
+[ t ] [ compiled-lucky-number n>> integer? ] unit-test
! Reshaping initial-quot:
lucky-number new dup n>> 2array "luckiest-number" set
@@ -744,3 +748,31 @@ lucky-number new dup n>> 2array "luckiest-number" set
[ t ] [ "luckiest-number" get first2 [ n>> ] dip = ] unit-test
[ t ] [ "luckiest-number" get first winner?>> ] unit-test
+
+! invalid-quot: together with type declaration
+TUPLE: decl-initial-quot { x integer initial-quot: [ 1 ] } ;
+
+[ t ] [ decl-initial-quot new x>> integer? ] unit-test
+
+: compiled-decl-initial-quot ( -- tuple ) decl-initial-quot new ;
+
+[ t ] [ compiled-decl-initial-quot x>> integer? ] unit-test
+
+! invalid-quot: with read-only
+TUPLE: read-only-initial-quot { x integer read-only initial-quot: [ 1 ] } ;
+
+[ t ] [ read-only-initial-quot new x>> integer? ] unit-test
+
+: compiled-read-only-initial-quot ( -- tuple ) read-only-initial-quot new ;
+
+[ t ] [ compiled-read-only-initial-quot x>> integer? ] unit-test
+
+! Specifying both initial: and initial-quot: should fail
+2 [
+ [
+ "IN: classes.tuple.test TUPLE: redundant-decl { x initial: 0 initial-quot: [ 0 ] } ;"
+ eval( -- )
+ ]
+ [ error>> duplicate-initial-values? ]
+ must-fail-with
+] times
diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor
index e5ea80bc39..4ca57a59ed 100755
--- a/core/classes/tuple/tuple.factor
+++ b/core/classes/tuple/tuple.factor
@@ -153,8 +153,7 @@ ERROR: bad-superclass class ;
all-slots [ initial-quot>> ] filter
[
[
- [ initial-quot>> , (( -- obj )) , \ call-effect , \ over , ]
- [ offset>> , ] bi \ set-slot ,
+ [ initial-quot>> % \ over , ] [ offset>> , ] bi \ set-slot ,
] each
] [ ] make f like ;
@@ -187,15 +186,10 @@ ERROR: bad-superclass 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* ;
+ dup initial>> [ ] [
+ dup initial-quot>>
+ [ call( -- obj ) ] [ drop f ] ?if
+ ] ?if ;
: compute-slot-permutation ( new-slots old-slots -- triples )
[ [ [ name>> ] map ] bi@ [ index ] curry map ]
From b18c84454b5185b22aa5387164e5953e23870710 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 13 Jun 2009 18:47:19 -0500
Subject: [PATCH 23/35] Move constructors vocabulary to extra and refactor
basis code not to use it
---
basis/bitstreams/bitstreams.factor | 16 ++++++++------
basis/compression/huffman/huffman.factor | 7 +++++--
basis/compression/inflate/inflate.factor | 2 +-
basis/images/jpeg/jpeg.factor | 17 +++++++++++----
basis/images/loader/loader.factor | 4 ++--
basis/images/png/png.factor | 13 ++++++------
basis/images/tiff/tiff.factor | 21 +++++++++++++++----
{basis => extra}/constructors/authors.txt | 0
.../constructors/constructors-tests.factor | 0
.../constructors/constructors.factor | 0
{basis => extra}/constructors/summary.txt | 0
{basis => extra}/constructors/tags.txt | 0
12 files changed, 55 insertions(+), 25 deletions(-)
rename {basis => extra}/constructors/authors.txt (100%)
rename {basis => extra}/constructors/constructors-tests.factor (100%)
rename {basis => extra}/constructors/constructors.factor (100%)
rename {basis => extra}/constructors/summary.txt (100%)
rename {basis => extra}/constructors/tags.txt (100%)
diff --git a/basis/bitstreams/bitstreams.factor b/basis/bitstreams/bitstreams.factor
index 032e851a79..2aa0059542 100644
--- a/basis/bitstreams/bitstreams.factor
+++ b/basis/bitstreams/bitstreams.factor
@@ -1,10 +1,10 @@
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien.accessors assocs byte-arrays combinators
-constructors destructors fry io io.binary io.encodings.binary
-io.streams.byte-array kernel locals macros math math.ranges
-multiline sequences sequences.private vectors byte-vectors
-combinators.short-circuit math.bitwise ;
+destructors fry io io.binary io.encodings.binary io.streams.byte-array
+kernel locals macros math math.ranges multiline sequences
+sequences.private vectors byte-vectors combinators.short-circuit
+math.bitwise ;
IN: bitstreams
TUPLE: widthed { bits integer read-only } { #bits integer read-only } ;
@@ -36,8 +36,12 @@ TUPLE: bit-writer
TUPLE: msb0-bit-reader < bit-reader ;
TUPLE: lsb0-bit-reader < bit-reader ;
-CONSTRUCTOR: msb0-bit-reader ( bytes -- bs ) ;
-CONSTRUCTOR: lsb0-bit-reader ( bytes -- bs ) ;
+
+: <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 ;
diff --git a/basis/compression/huffman/huffman.factor b/basis/compression/huffman/huffman.factor
index 6ef9c2fabc..9ece36e6cd 100755
--- a/basis/compression/huffman/huffman.factor
+++ b/basis/compression/huffman/huffman.factor
@@ -1,6 +1,6 @@
! Copyright (C) 2009 Marc Fauconneau.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays assocs constructors fry
+USING: accessors arrays assocs fry
hashtables io kernel locals math math.order math.parser
math.ranges multiline sequences ;
IN: compression.huffman
@@ -58,7 +58,10 @@ TUPLE: huffman-decoder
{ rtable }
{ bits/level } ;
-CONSTRUCTOR: huffman-decoder ( bs tdesc -- decoder )
+: <huffman-decoder> ( bs tdesc -- decoder )
+ huffman-decoder new
+ swap >>tdesc
+ swap >>bs
16 >>bits/level
[ ] [ tdesc>> ] [ bits/level>> 2^ ] tri reverse-table >>rtable ;
diff --git a/basis/compression/inflate/inflate.factor b/basis/compression/inflate/inflate.factor
index ab1caf3f6a..05ec94a794 100644
--- a/basis/compression/inflate/inflate.factor
+++ b/basis/compression/inflate/inflate.factor
@@ -1,7 +1,7 @@
! 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 ;
diff --git a/basis/images/jpeg/jpeg.factor b/basis/images/jpeg/jpeg.factor
index b66aed043d..f61254c3cf 100644
--- a/basis/images/jpeg/jpeg.factor
+++ b/basis/images/jpeg/jpeg.factor
@@ -1,7 +1,7 @@
! 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
@@ -21,7 +21,8 @@ TUPLE: jpeg-image < image
<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 ;
@@ -56,12 +57,20 @@ 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 ;
diff --git a/basis/images/loader/loader.factor b/basis/images/loader/loader.factor
index 51d4e0fadf..dc0eec75c2 100644
--- a/basis/images/loader/loader.factor
+++ b/basis/images/loader/loader.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2009 Doug Coleman, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
-USING: constructors kernel splitting unicode.case combinators
-accessors images io.pathnames namespaces assocs ;
+USING: kernel splitting unicode.case combinators accessors images
+io.pathnames namespaces assocs ;
IN: images.loader
ERROR: unknown-image-extension extension ;
diff --git a/basis/images/png/png.factor b/basis/images/png/png.factor
index eb6b29713c..bb470d8dd8 100755
--- a/basis/images/png/png.factor
+++ b/basis/images/png/png.factor
@@ -1,10 +1,9 @@
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors constructors images io io.binary io.encodings.ascii
+USING: accessors images io io.binary io.encodings.ascii
io.encodings.binary io.encodings.string io.files io.files.info kernel
-sequences io.streams.limited fry combinators arrays math
-checksums checksums.crc32 compression.inflate grouping byte-arrays
-images.loader ;
+sequences io.streams.limited fry combinators arrays math checksums
+checksums.crc32 compression.inflate grouping byte-arrays images.loader ;
IN: images.png
SINGLETON: png-image
@@ -15,12 +14,14 @@ TUPLE: loading-png
width height bit-depth color-type compression-method
filter-method interlace-method uncompressed ;
-CONSTRUCTOR: loading-png ( -- image )
+: <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 }
diff --git a/basis/images/tiff/tiff.factor b/basis/images/tiff/tiff.factor
index e0de68b368..e00b05f2e7 100755
--- a/basis/images/tiff/tiff.factor
+++ b/basis/images/tiff/tiff.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs byte-arrays classes combinators
-compression.lzw constructors endian fry grouping images io
+compression.lzw endian fry grouping images io
io.binary io.encodings.ascii io.encodings.binary
io.encodings.string io.encodings.utf8 io.files kernel math
math.bitwise math.order math.parser pack prettyprint sequences
@@ -12,14 +12,27 @@ IN: images.tiff
SINGLETON: tiff-image
TUPLE: loading-tiff endianness the-answer ifd-offset ifds ;
-CONSTRUCTOR: loading-tiff ( -- tiff ) V{ } clone >>ifds ;
+
+: <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
diff --git a/basis/constructors/authors.txt b/extra/constructors/authors.txt
similarity index 100%
rename from basis/constructors/authors.txt
rename to extra/constructors/authors.txt
diff --git a/basis/constructors/constructors-tests.factor b/extra/constructors/constructors-tests.factor
similarity index 100%
rename from basis/constructors/constructors-tests.factor
rename to extra/constructors/constructors-tests.factor
diff --git a/basis/constructors/constructors.factor b/extra/constructors/constructors.factor
similarity index 100%
rename from basis/constructors/constructors.factor
rename to extra/constructors/constructors.factor
diff --git a/basis/constructors/summary.txt b/extra/constructors/summary.txt
similarity index 100%
rename from basis/constructors/summary.txt
rename to extra/constructors/summary.txt
diff --git a/basis/constructors/tags.txt b/extra/constructors/tags.txt
similarity index 100%
rename from basis/constructors/tags.txt
rename to extra/constructors/tags.txt
From 4a6ee34ec492751553ef8a9c510d3c7d0ade80e2 Mon Sep 17 00:00:00 2001
From: "Jose A. Ortega Ruiz" <jao@gnu.org>
Date: Sun, 14 Jun 2009 20:29:27 +0200
Subject: [PATCH 24/35] FUEL: Bug fix: indentation of consecutive setter lines.
---
misc/fuel/factor-mode.el | 36 +++++++++++++++++++++---------------
1 file changed, 21 insertions(+), 15 deletions(-)
diff --git a/misc/fuel/factor-mode.el b/misc/fuel/factor-mode.el
index cc8ebe35fb..bef6e4c774 100644
--- a/misc/fuel/factor-mode.el
+++ b/misc/fuel/factor-mode.el
@@ -122,26 +122,32 @@ code in the buffer."
(beginning-of-line)
(when (fuel-syntax--at-begin-of-def) 0)))
+(defsubst factor-mode--previous-non-empty ()
+ (forward-line -1)
+ (while (and (not (bobp))
+ (fuel-syntax--looking-at-emptiness))
+ (forward-line -1)))
+
(defun factor-mode--indent-setter-line ()
(when (fuel-syntax--at-setter-line)
- (save-excursion
- (let ((indent (and (fuel-syntax--at-constructor-line)
- (current-indentation))))
- (while (not (or indent
- (bobp)
- (fuel-syntax--at-begin-of-def)
- (fuel-syntax--at-end-of-def)))
- (if (fuel-syntax--at-constructor-line)
- (setq indent (fuel-syntax--increased-indentation))
- (forward-line -1)))
- indent))))
+ (or (save-excursion
+ (let ((indent (and (fuel-syntax--at-constructor-line)
+ (current-indentation))))
+ (while (not (or indent
+ (bobp)
+ (fuel-syntax--at-begin-of-def)
+ (fuel-syntax--at-end-of-def)))
+ (if (fuel-syntax--at-constructor-line)
+ (setq indent (fuel-syntax--increased-indentation))
+ (forward-line -1)))
+ indent))
+ (save-excursion
+ (factor-mode--previous-non-empty)
+ (current-indentation)))))
(defun factor-mode--indent-continuation ()
(save-excursion
- (forward-line -1)
- (while (and (not (bobp))
- (fuel-syntax--looking-at-emptiness))
- (forward-line -1))
+ (factor-mode--previous-non-empty)
(cond ((or (fuel-syntax--at-end-of-def)
(fuel-syntax--at-setter-line))
(fuel-syntax--decreased-indentation))
From 6fb7dca404a85c99a6f7392253559def823ecaab Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 14 Jun 2009 17:00:52 -0500
Subject: [PATCH 25/35] compiler.cfg.linear-scan.resolve: fix compile error
---
basis/compiler/cfg/linear-scan/resolve/resolve.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/basis/compiler/cfg/linear-scan/resolve/resolve.factor b/basis/compiler/cfg/linear-scan/resolve/resolve.factor
index 8996327beb..df2dbb1198 100644
--- a/basis/compiler/cfg/linear-scan/resolve/resolve.factor
+++ b/basis/compiler/cfg/linear-scan/resolve/resolve.factor
@@ -21,7 +21,7 @@ IN: compiler.cfg.linear-scan.resolve
;
: resolve-edge-data-flow ( bb to -- )
- [ 2dup live-in [ resolve-value-data-flow ] with with each ]
+ [ dup live-in [ resolve-value-data-flow ] with with each ]
[ resolve-mappings ]
2bi ;
From 425f1f96c57cc94dd9107d6b5487bec3ee5d0007 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 14 Jun 2009 17:46:29 -0500
Subject: [PATCH 26/35] 'see' on tuple classes didn't show initial values if
slot type was not declared
---
basis/prettyprint/prettyprint-tests.factor | 51 ++++++++++++++++++++++
basis/see/see.factor | 6 ++-
2 files changed, 55 insertions(+), 2 deletions(-)
diff --git a/basis/prettyprint/prettyprint-tests.factor b/basis/prettyprint/prettyprint-tests.factor
index a2696b1263..b3897960f0 100644
--- a/basis/prettyprint/prettyprint-tests.factor
+++ b/basis/prettyprint/prettyprint-tests.factor
@@ -303,3 +303,54 @@ M: started-out-hustlin' ended-up-ballin' ; inline
[ "USING: prettyprint.tests ;\nM: started-out-hustlin' ended-up-ballin' ; inline\n" ] [
[ M\ started-out-hustlin' ended-up-ballin' see ] with-string-writer
] unit-test
+
+TUPLE: tuple-with-declared-slot { x integer } ;
+
+[
+ {
+ "USING: math ;"
+ "IN: prettyprint.tests"
+ "TUPLE: tuple-with-declared-slot { x integer initial: 0 } ;"
+ ""
+ }
+] [
+ [ \ tuple-with-declared-slot see ] with-string-writer "\n" split
+] unit-test
+
+TUPLE: tuple-with-read-only-slot { x read-only } ;
+
+[
+ {
+ "IN: prettyprint.tests"
+ "TUPLE: tuple-with-read-only-slot { x read-only } ;"
+ ""
+ }
+] [
+ [ \ tuple-with-read-only-slot see ] with-string-writer "\n" split
+] unit-test
+
+TUPLE: tuple-with-initial-slot { x initial: 123 } ;
+
+[
+ {
+ "IN: prettyprint.tests"
+ "TUPLE: tuple-with-initial-slot { x initial: 123 } ;"
+ ""
+ }
+] [
+ [ \ tuple-with-initial-slot see ] with-string-writer "\n" split
+] unit-test
+
+TUPLE: tuple-with-initial-declared-slot { x integer initial: 123 } ;
+
+[
+ {
+ "USING: math ;"
+ "IN: prettyprint.tests"
+ "TUPLE: tuple-with-initial-declared-slot"
+ " { x integer initial: 123 } ;"
+ ""
+ }
+] [
+ [ \ tuple-with-initial-declared-slot see ] with-string-writer "\n" split
+] unit-test
diff --git a/basis/see/see.factor b/basis/see/see.factor
index a8d78a68e4..206bdbb906 100644
--- a/basis/see/see.factor
+++ b/basis/see/see.factor
@@ -165,12 +165,14 @@ M: array pprint-slot-name
dup name>> ,
dup class>> object eq? [
dup class>> ,
- initial: ,
- dup initial>> ,
] unless
dup read-only>> [
read-only ,
] when
+ dup [ class>> object eq? not ] [ initial>> ] bi or [
+ initial: ,
+ dup initial>> ,
+ ] when
drop
] { } make ;
From dd61b59937682d1f910706aa5c1fe35119b2eff5 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 14 Jun 2009 18:10:24 -0500
Subject: [PATCH 27/35] sequences: update each-index and map-index to not
depend on integers-as-sequences
---
core/sequences/sequences.factor | 15 +++++++++------
1 file changed, 9 insertions(+), 6 deletions(-)
diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor
index 36e4c95470..745fe2a033 100755
--- a/core/sequences/sequences.factor
+++ b/core/sequences/sequences.factor
@@ -358,8 +358,14 @@ PRIVATE>
<PRIVATE
+: ((each)) ( seq -- n quot )
+ [ length ] keep [ nth-unsafe ] curry ; inline
+
: (each) ( seq quot -- n quot' )
- [ [ length ] keep [ nth-unsafe ] curry ] dip compose ; inline
+ [ ((each)) ] dip compose ; inline
+
+: (each-index) ( seq quot -- n quot' )
+ [ ((each)) [ keep ] curry ] dip compose ; inline
: (collect) ( quot into -- quot' )
[ [ keep ] dip set-nth-unsafe ] 2curry ; inline
@@ -498,11 +504,8 @@ PRIVATE>
: follow ( obj quot -- seq )
[ dup ] swap [ keep ] curry produce nip ; inline
-: prepare-index ( seq quot -- seq n quot )
- [ dup length ] dip ; inline
-
: each-index ( seq quot -- )
- prepare-index 2each ; inline
+ (each-index) each-integer ; inline
: interleave ( seq between quot -- )
swap [ drop ] [ [ 2dip call ] 2curry ] 2bi
@@ -510,7 +513,7 @@ PRIVATE>
each-index ; 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
From 75276855aeb99b5c580d8d69dcef6f04542ba17b Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 14 Jun 2009 18:22:31 -0500
Subject: [PATCH 28/35] sequences: change implementation of interleave
---
core/sequences/sequences.factor | 8 +++++---
1 file changed, 5 insertions(+), 3 deletions(-)
diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor
index 745fe2a033..c58304de44 100755
--- a/core/sequences/sequences.factor
+++ b/core/sequences/sequences.factor
@@ -508,9 +508,11 @@ PRIVATE>
(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 [ [ call ] bi@ ] 2curry each ]
+ 3bi
+ ] if ; inline
: map-index ( seq quot -- newseq )
[ dup length iota ] dip 2map ; inline
From 29327a787c6a236ffa10c65c8838759ec7a70c58 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 15 Jun 2009 13:07:15 -0500
Subject: [PATCH 29/35] Remove initial-quot feature
---
.../escape-analysis-tests.factor | 7 ---
basis/io/servers/connection/connection.factor | 24 ++++++----
core/bootstrap/syntax.factor | 1 -
core/classes/tuple/parser/parser-tests.factor | 10 +---
core/classes/tuple/tuple-tests.factor | 47 -------------------
core/classes/tuple/tuple.factor | 30 ++----------
core/slots/slots.factor | 10 +---
core/syntax/syntax.factor | 2 -
8 files changed, 22 insertions(+), 109 deletions(-)
diff --git a/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor b/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor
index 2688f7f8f1..4fb01608f0 100644
--- a/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor
+++ b/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor
@@ -328,10 +328,3 @@ C: <ro-box> ro-box
TUPLE: empty-tuple ;
[ ] [ [ empty-tuple boa layout-of ] count-unboxed-allocations drop ] unit-test
-
-! Make sure that initial-quot: doesn't inhibit unboxing
-TUPLE: initial-quot-tuple { x read-only initial-quot: [ 0 ] } ;
-
-[ 1 ] [
- [ initial-quot-tuple new x>> ] count-unboxed-allocations
-] unit-test
\ No newline at end of file
diff --git a/basis/io/servers/connection/connection.factor b/basis/io/servers/connection/connection.factor
index de75165c7a..345b739b61 100644
--- a/basis/io/servers/connection/connection.factor
+++ b/basis/io/servers/connection/connection.factor
@@ -11,17 +11,18 @@ combinators.short-circuit ;
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> ;
@@ -29,6 +30,13 @@ encoding
: 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 )
diff --git a/core/bootstrap/syntax.factor b/core/bootstrap/syntax.factor
index 24538229c6..f5182a0210 100644
--- a/core/bootstrap/syntax.factor
+++ b/core/bootstrap/syntax.factor
@@ -80,7 +80,6 @@ IN: bootstrap.syntax
">>"
"call-next-method"
"initial:"
- "initial-quot:"
"read-only"
"call("
"execute("
diff --git a/core/classes/tuple/parser/parser-tests.factor b/core/classes/tuple/parser/parser-tests.factor
index 350b594274..72457ff974 100644
--- a/core/classes/tuple/parser/parser-tests.factor
+++ b/core/classes/tuple/parser/parser-tests.factor
@@ -141,12 +141,4 @@ TUPLE: parsing-corner-case x ;
"USE: classes.tuple.parser.tests T{ parsing-corner-case {"
" x 3 }"
} "\n" join eval( -- tuple )
-] [ error>> unexpected-eof? ] must-fail-with
-
-
-[ ] [
- <" 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
diff --git a/core/classes/tuple/tuple-tests.factor b/core/classes/tuple/tuple-tests.factor
index 4b23578a29..191ec75544 100644
--- a/core/classes/tuple/tuple-tests.factor
+++ b/core/classes/tuple/tuple-tests.factor
@@ -729,50 +729,3 @@ DEFER: redefine-tuple-twice
[ ] [ "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?
-
-[ t ] [ lucky-number new n>> integer? ] unit-test
-
-: compiled-lucky-number ( -- tuple ) lucky-number new ;
-
-[ t ] [ compiled-lucky-number n>> integer? ] 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
-
-! invalid-quot: together with type declaration
-TUPLE: decl-initial-quot { x integer initial-quot: [ 1 ] } ;
-
-[ t ] [ decl-initial-quot new x>> integer? ] unit-test
-
-: compiled-decl-initial-quot ( -- tuple ) decl-initial-quot new ;
-
-[ t ] [ compiled-decl-initial-quot x>> integer? ] unit-test
-
-! invalid-quot: with read-only
-TUPLE: read-only-initial-quot { x integer read-only initial-quot: [ 1 ] } ;
-
-[ t ] [ read-only-initial-quot new x>> integer? ] unit-test
-
-: compiled-read-only-initial-quot ( -- tuple ) read-only-initial-quot new ;
-
-[ t ] [ compiled-read-only-initial-quot x>> integer? ] unit-test
-
-! Specifying both initial: and initial-quot: should fail
-2 [
- [
- "IN: classes.tuple.test TUPLE: redundant-decl { x initial: 0 initial-quot: [ 0 ] } ;"
- eval( -- )
- ]
- [ error>> duplicate-initial-values? ]
- must-fail-with
-] times
diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor
index 4ca57a59ed..7633f9b4c8 100755
--- a/core/classes/tuple/tuple.factor
+++ b/core/classes/tuple/tuple.factor
@@ -50,9 +50,6 @@ M: tuple class layout-of 2 slot { word } declare ;
PRIVATE>
-: initial-quots? ( class -- ? )
- all-slots [ initial-quot>> ] any? ;
-
: initial-values ( class -- slots )
all-slots [ initial>> ] map ;
@@ -149,21 +146,12 @@ ERROR: bad-superclass class ;
: 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>> % \ 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 ;
@@ -185,16 +173,10 @@ ERROR: bad-superclass class ;
: define-tuple-layout ( class -- )
dup make-tuple-layout "layout" set-word-prop ;
-: calculate-initial-value ( slot-spec -- value )
- dup initial>> [ ] [
- dup initial-quot>>
- [ 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 )
@@ -358,11 +340,7 @@ M: tuple tuple-hashcode
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* ]
diff --git a/core/slots/slots.factor b/core/slots/slots.factor
index c8be08e79b..304ded0adb 100755
--- a/core/slots/slots.factor
+++ b/core/slots/slots.factor
@@ -6,7 +6,7 @@ classes classes.algebra slots.private combinators accessors
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 ;
@@ -190,7 +190,6 @@ ERROR: bad-slot-attribute key ;
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
@@ -198,14 +197,7 @@ ERROR: bad-slot-attribute key ;
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?
diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor
index 8093b6345b..7b9a0d36ef 100644
--- a/core/syntax/syntax.factor
+++ b/core/syntax/syntax.factor
@@ -246,8 +246,6 @@ IN: bootstrap.syntax
"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
From a7b474b54b7d3af78b73a396fbcc73c3ffe8e77e Mon Sep 17 00:00:00 2001
From: Samuel Tardieu <sam@rfc1149.net>
Date: Fri, 12 Jun 2009 11:59:48 +0200
Subject: [PATCH 30/35] Documentation fix for PV{
---
basis/persistent/vectors/vectors-docs.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/basis/persistent/vectors/vectors-docs.factor b/basis/persistent/vectors/vectors-docs.factor
index 4816877a35..aa817edf52 100644
--- a/basis/persistent/vectors/vectors-docs.factor
+++ b/basis/persistent/vectors/vectors-docs.factor
@@ -2,7 +2,7 @@ USING: help.markup help.syntax kernel math sequences ;
IN: persistent.vectors
HELP: PV{
-{ $syntax "elements... }" }
+{ $syntax "PV{ elements... }" }
{ $description "Parses a literal " { $link persistent-vector } "." } ;
HELP: >persistent-vector
From 92b436d7fb6025901c569fb26519f1924985113b Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 15 Jun 2009 16:07:39 -0500
Subject: [PATCH 31/35] interleave: allow the 'between' quot to access the
stack
---
basis/ui/gadgets/gadgets.factor | 3 +--
core/sequences/sequences-tests.factor | 5 +++++
core/sequences/sequences.factor | 5 ++++-
3 files changed, 10 insertions(+), 3 deletions(-)
diff --git a/basis/ui/gadgets/gadgets.factor b/basis/ui/gadgets/gadgets.factor
index 6a289ec1d6..0295012584 100644
--- a/basis/ui/gadgets/gadgets.factor
+++ b/basis/ui/gadgets/gadgets.factor
@@ -112,8 +112,7 @@ M: gadget gadget-text-separator
orientation>> vertical = "\n" "" ? ;
: gadget-seq-text ( seq gadget -- )
- gadget-text-separator swap
- [ dup % ] [ gadget-text* ] interleave drop ;
+ gadget-text-separator '[ _ % ] [ gadget-text* ] interleave ;
M: gadget gadget-text*
[ children>> ] keep gadget-seq-text ;
diff --git a/core/sequences/sequences-tests.factor b/core/sequences/sequences-tests.factor
index 85f9d56596..5e0d5597ca 100644
--- a/core/sequences/sequences-tests.factor
+++ b/core/sequences/sequences-tests.factor
@@ -286,3 +286,8 @@ M: bogus-hashcode hashcode* 2drop 0 >bignum ;
[ f f ] [
{ 1 2 3 4 5 6 7 8 } [ H{ { 11 "hi" } } at ] map-find
] unit-test
+
+USE: make
+
+[ { "a" 1 "b" 1 "c" } ]
+[ 1 { "a" "b" "c" } [ [ dup , ] [ , ] interleave drop ] { } make ] unit-test
\ No newline at end of file
diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor
index c58304de44..39e6d21c67 100755
--- a/core/sequences/sequences.factor
+++ b/core/sequences/sequences.factor
@@ -406,6 +406,9 @@ PRIVATE>
[ 2drop f f ]
if ; inline
+: interleave-step ( elt between quot -- )
+ [ dip ] dip call ; inline
+
PRIVATE>
: each ( seq quot -- )
@@ -510,7 +513,7 @@ PRIVATE>
: interleave ( seq between quot -- )
pick empty? [ 3drop ] [
[ [ drop first-unsafe ] dip call ]
- [ [ rest-slice ] 2dip [ [ call ] bi@ ] 2curry each ]
+ [ [ rest-slice ] 2dip [ interleave-step ] 2curry each ]
3bi
] if ; inline
From cb03fe43db4e7b489e7ed86ec9468128e7b1caac Mon Sep 17 00:00:00 2001
From: Samuel Tardieu <sam@rfc1149.net>
Date: Tue, 16 Jun 2009 20:47:56 +0200
Subject: [PATCH 32/35] Forbid tabs in source code
---
core/lexer/lexer-docs.factor | 2 +-
core/lexer/lexer.factor | 12 +++++++++---
2 files changed, 10 insertions(+), 4 deletions(-)
diff --git a/core/lexer/lexer-docs.factor b/core/lexer/lexer-docs.factor
index 31f5a3f72e..fcfd0806d4 100644
--- a/core/lexer/lexer-docs.factor
+++ b/core/lexer/lexer-docs.factor
@@ -29,7 +29,7 @@ HELP: <lexer-error>
HELP: skip
{ $values { "i" "a starting index" } { "seq" sequence } { "?" "a boolean" } { "n" integer } }
-{ $description "Skips to the first space character (if " { $snippet "boolean" } " is " { $link f } ") or the first non-space character (otherwise)." } ;
+{ $description "Skips to the first space character (if " { $snippet "boolean" } " is " { $link f } ") or the first non-space character (otherwise). Tabulations used as separators instead of spaces will be flagged as an error." } ;
HELP: change-lexer-column
{ $values { "lexer" lexer } { "quot" { $quotation "( col line -- newcol )" } } }
diff --git a/core/lexer/lexer.factor b/core/lexer/lexer.factor
index 60157033d7..99e6f05c6c 100644
--- a/core/lexer/lexer.factor
+++ b/core/lexer/lexer.factor
@@ -22,9 +22,17 @@ TUPLE: lexer text line line-text line-length column ;
: <lexer> ( text -- lexer )
lexer new-lexer ;
+ERROR: unexpected want got ;
+
+PREDICATE: unexpected-tab < unexpected
+ got>> CHAR: \t = ;
+
+: forbid-tab ( c -- c )
+ [ CHAR: \t eq? [ "[space]" "[tab]" unexpected ] when ] keep ;
+
: skip ( i seq ? -- n )
over length
- [ [ swap CHAR: \s eq? xor ] curry find-from drop ] dip or ;
+ [ [ swap forbid-tab CHAR: \s eq? xor ] curry find-from drop ] dip or ;
: change-lexer-column ( lexer quot -- )
[ [ column>> ] [ line-text>> ] bi ] prepose keep
@@ -65,8 +73,6 @@ M: lexer skip-word ( lexer -- )
: scan ( -- str/f ) lexer get parse-token ;
-ERROR: unexpected want got ;
-
PREDICATE: unexpected-eof < unexpected
got>> not ;
From ef6634337db1d0d45b157e49537b75bc6a799ba9 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 16 Jun 2009 14:05:39 -0500
Subject: [PATCH 33/35] Oops: interleave-step is bi*
---
core/sequences/sequences.factor | 5 +----
1 file changed, 1 insertion(+), 4 deletions(-)
diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor
index 39e6d21c67..6eea872343 100755
--- a/core/sequences/sequences.factor
+++ b/core/sequences/sequences.factor
@@ -406,9 +406,6 @@ PRIVATE>
[ 2drop f f ]
if ; inline
-: interleave-step ( elt between quot -- )
- [ dip ] dip call ; inline
-
PRIVATE>
: each ( seq quot -- )
@@ -513,7 +510,7 @@ PRIVATE>
: interleave ( seq between quot -- )
pick empty? [ 3drop ] [
[ [ drop first-unsafe ] dip call ]
- [ [ rest-slice ] 2dip [ interleave-step ] 2curry each ]
+ [ [ rest-slice ] 2dip [ bi* ] 2curry each ]
3bi
] if ; inline
From 37b01357ecdb7a981ba6c886574a15ce47887dfa Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 16 Jun 2009 16:38:39 -0500
Subject: [PATCH 34/35] Remove unused words discovered by Samuel Tardieu
---
basis/functors/functors.factor | 2 --
basis/heaps/heaps.factor | 9 ---------
basis/help/lint/lint.factor | 2 --
basis/opengl/textures/textures.factor | 3 ---
basis/ui/baseline-alignment/baseline-alignment.factor | 3 ---
basis/ui/gadgets/panes/panes.factor | 4 ----
basis/ui/gadgets/sliders/sliders.factor | 2 --
basis/unicode/breaks/breaks.factor | 6 ------
core/generic/math/math-docs.factor | 4 +---
core/generic/math/math.factor | 2 --
10 files changed, 1 insertion(+), 36 deletions(-)
diff --git a/basis/functors/functors.factor b/basis/functors/functors.factor
index e5eb50e82f..b7dab0d6af 100644
--- a/basis/functors/functors.factor
+++ b/basis/functors/functors.factor
@@ -58,8 +58,6 @@ M: object (fake-quotations>) , ;
[ parse-definition* ] dip
parsed ;
-: DEFINE* ( accum -- accum ) \ define-declared* parsed ;
-
SYNTAX: `TUPLE:
scan-param parsed
scan {
diff --git a/basis/heaps/heaps.factor b/basis/heaps/heaps.factor
index becfb6826d..ae546080a1 100644
--- a/basis/heaps/heaps.factor
+++ b/basis/heaps/heaps.factor
@@ -51,9 +51,6 @@ M: heap heap-size ( heap -- n )
: data-nth ( n heap -- entry )
data>> nth-unsafe ; inline
-: up-value ( n heap -- entry )
- [ up ] dip data-nth ; inline
-
: left-value ( n heap -- entry )
[ left ] dip data-nth ; inline
@@ -75,9 +72,6 @@ M: heap heap-size ( heap -- n )
: data-pop* ( heap -- )
data>> pop* ; inline
-: data-peek ( heap -- entry )
- data>> last ; inline
-
: data-first ( heap -- entry )
data>> first ; inline
@@ -130,9 +124,6 @@ DEFER: up-heap
2dup right-bounds-check?
[ drop left ] [ (child) ] if ;
-: swap-down ( m heap -- )
- [ child ] 2keep data-exchange ;
-
DEFER: down-heap
: (down-heap) ( m heap -- )
diff --git a/basis/help/lint/lint.factor b/basis/help/lint/lint.factor
index 4ead01159a..c1dd591013 100755
--- a/basis/help/lint/lint.factor
+++ b/basis/help/lint/lint.factor
@@ -55,8 +55,6 @@ PRIVATE>
] check-something
] [ drop ] if ;
-: check-words ( words -- ) [ check-word ] each ;
-
: check-article ( article -- )
[ with-interactive-vocabs ] vocabs-quot set
>link dup '[
diff --git a/basis/opengl/textures/textures.factor b/basis/opengl/textures/textures.factor
index d43e1736d1..2eabbd478b 100755
--- a/basis/opengl/textures/textures.factor
+++ b/basis/opengl/textures/textures.factor
@@ -135,9 +135,6 @@ TUPLE: multi-texture grid display-list loc disposed ;
[ dup image-locs ] dip
'[ [ _ v+ <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? ;
diff --git a/basis/ui/baseline-alignment/baseline-alignment.factor b/basis/ui/baseline-alignment/baseline-alignment.factor
index f7f7a757f5..6e2b58479b 100644
--- a/basis/ui/baseline-alignment/baseline-alignment.factor
+++ b/basis/ui/baseline-alignment/baseline-alignment.factor
@@ -36,9 +36,6 @@ TUPLE: gadget-metrics height ascent descent cap-height ;
: max-descent ( seq -- n )
[ descent>> ] map ?supremum ;
-: max-text-height ( seq -- y )
- [ ascent>> ] filter [ height>> ] map ?supremum ;
-
: max-graphics-height ( seq -- y )
[ ascent>> not ] filter [ height>> ] map ?supremum 0 or ;
diff --git a/basis/ui/gadgets/panes/panes.factor b/basis/ui/gadgets/panes/panes.factor
index eb741f13b6..2c5ed596ac 100644
--- a/basis/ui/gadgets/panes/panes.factor
+++ b/basis/ui/gadgets/panes/panes.factor
@@ -96,10 +96,6 @@ M: pane selected-children
add-incremental
] [ next-line ] bi ;
-: ?pane-nl ( pane -- )
- [ dup current>> children>> empty? [ pane-nl ] [ drop ] if ]
- [ pane-nl ] bi ;
-
: smash-pane ( pane -- gadget ) [ pane-nl ] [ output>> smash-line ] bi ;
: pane-write ( seq pane -- )
diff --git a/basis/ui/gadgets/sliders/sliders.factor b/basis/ui/gadgets/sliders/sliders.factor
index 80829d7b66..d293fd7f8b 100644
--- a/basis/ui/gadgets/sliders/sliders.factor
+++ b/basis/ui/gadgets/sliders/sliders.factor
@@ -23,8 +23,6 @@ TUPLE: slider < track elevator thumb saved line ;
TUPLE: elevator < gadget direction ;
-: find-elevator ( gadget -- elevator/f ) [ elevator? ] find-parent ;
-
: find-slider ( gadget -- slider/f ) [ slider? ] find-parent ;
CONSTANT: elevator-padding 4
diff --git a/basis/unicode/breaks/breaks.factor b/basis/unicode/breaks/breaks.factor
index 1b1d9434f8..6d6b5cc0cf 100644
--- a/basis/unicode/breaks/breaks.factor
+++ b/basis/unicode/breaks/breaks.factor
@@ -72,9 +72,6 @@ SYMBOL: table
: connect ( class1 class2 -- ) 1 set-table ;
: disconnect ( class1 class2 -- ) 0 set-table ;
-: break-around ( classes1 classes2 -- )
- [ disconnect ] [ swap disconnect ] 2bi ;
-
: make-grapheme-table ( -- )
{ CR } { LF } connect
{ Control CR LF } graphemes disconnect
@@ -91,9 +88,6 @@ VALUE: grapheme-table
: grapheme-break? ( class1 class2 -- ? )
grapheme-table nth nth not ;
-: chars ( i str n -- str[i] str[i+n] )
- swap [ dupd + ] dip [ ?nth ] curry bi@ ;
-
PRIVATE>
: first-grapheme ( str -- i )
diff --git a/core/generic/math/math-docs.factor b/core/generic/math/math-docs.factor
index 7d7d6e725b..5953c5ad9b 100644
--- a/core/generic/math/math-docs.factor
+++ b/core/generic/math/math-docs.factor
@@ -40,6 +40,4 @@ $nl
HELP: math-generic
{ $class-description "The class of generic words using " { $link math-combination } "." } ;
-HELP: last/first
-{ $values { "seq" sequence } { "pair" "a two-element array" } }
-{ $description "Creates an array holding the first and last element of the sequence." } ;
+
diff --git a/core/generic/math/math.factor b/core/generic/math/math.factor
index e88c0c02e4..e0e8b91a2c 100644
--- a/core/generic/math/math.factor
+++ b/core/generic/math/math.factor
@@ -15,8 +15,6 @@ PREDICATE: math-class < class
<PRIVATE
-: last/first ( seq -- pair ) [ last ] [ first ] bi 2array ;
-
: bootstrap-words ( classes -- classes' )
[ bootstrap-word ] map ;
From 82825caf80928c12efb522cc71795d0f62f9f2e9 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 16 Jun 2009 17:11:36 -0500
Subject: [PATCH 35/35] ui.gadgets.sliders: forgot to update docs
---
basis/ui/gadgets/sliders/sliders-docs.factor | 4 ----
1 file changed, 4 deletions(-)
diff --git a/basis/ui/gadgets/sliders/sliders-docs.factor b/basis/ui/gadgets/sliders/sliders-docs.factor
index 38f4b5ac15..570291a18f 100644
--- a/basis/ui/gadgets/sliders/sliders-docs.factor
+++ b/basis/ui/gadgets/sliders/sliders-docs.factor
@@ -5,10 +5,6 @@ IN: ui.gadgets.sliders
HELP: elevator
{ $class-description "An elevator is the part of a " { $link slider } " between the up/down arrow buttons, where a " { $link thumb } " may be moved up and down." } ;
-HELP: find-elevator
-{ $values { "gadget" gadget } { "elevator/f" { $maybe elevator } } }
-{ $description "Finds the first parent of " { $snippet "gadget" } " which is an " { $link elevator } ". Outputs " { $link f } " if the gadget is not contained in an " { $link elevator } "." } ;
-
HELP: slider
{ $class-description "A slider is a control for graphically manipulating a " { $link "models-range" } "."
$nl