From 652c4c28c6780e8aeb06305322805c9f09521f38 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 3 May 2010 20:16:13 -0400 Subject: [PATCH 01/24] cpu.x86.assembler: fix test on 64-bit --- basis/cpu/x86/assembler/assembler-tests.factor | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/basis/cpu/x86/assembler/assembler-tests.factor b/basis/cpu/x86/assembler/assembler-tests.factor index 7312a16f83..2959910f0e 100644 --- a/basis/cpu/x86/assembler/assembler-tests.factor +++ b/basis/cpu/x86/assembler/assembler-tests.factor @@ -3,7 +3,12 @@ kernel tools.test namespaces make layouts ; IN: cpu.x86.assembler.tests ! immediate operands -[ { HEX: b9 HEX: 01 HEX: 00 HEX: 00 HEX: 00 } ] [ [ ECX 1 MOV ] { } make ] unit-test +cell 4 = [ + [ { HEX: b9 HEX: 01 HEX: 00 HEX: 00 HEX: 00 } ] [ [ ECX 1 MOV ] { } make ] unit-test +] [ + [ { HEX: b9 HEX: 01 HEX: 00 HEX: 00 HEX: 00 HEX: 00 HEX: 00 HEX: 00 HEX: 00 } ] [ [ ECX 1 MOV ] { } make ] unit-test +] if + [ { HEX: 83 HEX: c1 HEX: 01 } ] [ [ ECX 1 ADD ] { } make ] unit-test [ { HEX: 81 HEX: c1 HEX: 96 HEX: 00 HEX: 00 HEX: 00 } ] [ [ ECX 150 ADD ] { } make ] unit-test [ { HEX: f7 HEX: c1 HEX: d2 HEX: 04 HEX: 00 HEX: 00 } ] [ [ ECX 1234 TEST ] { } make ] unit-test From cf4abda115451e638c3bd92165ac74b4a2b898ba Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 3 May 2010 22:09:00 -0400 Subject: [PATCH 02/24] ui.gadgets.tables: remove multiple selection support, and make the error list handle preservation of the current selection better when the underlying model changes --- basis/ui/gadgets/tables/tables.factor | 190 +++++++------------- basis/ui/tools/error-list/error-list.factor | 2 + 2 files changed, 67 insertions(+), 125 deletions(-) diff --git a/basis/ui/gadgets/tables/tables.factor b/basis/ui/gadgets/tables/tables.factor index c907e90673..77b9ec99ed 100644 --- a/basis/ui/gadgets/tables/tables.factor +++ b/basis/ui/gadgets/tables/tables.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2008, 2009 Slava Pestov. +! Copyright (C) 2008, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors assocs hashtables arrays colors colors.constants fry kernel math math.functions math.ranges math.rectangles math.order @@ -18,6 +18,7 @@ GENERIC: column-titles ( renderer -- strings ) GENERIC: row-columns ( row renderer -- columns ) GENERIC: row-value ( row renderer -- object ) GENERIC: row-color ( row renderer -- color ) +GENERIC: row-value? ( value row renderer -- ? ) SINGLETON: trivial-renderer @@ -29,6 +30,7 @@ M: object column-titles drop f ; M: trivial-renderer row-columns drop ; M: object row-value drop ; M: object row-color 2drop f ; +M: object row-value? drop eq? ; TUPLE: table < line-gadget { renderer initial: trivial-renderer } @@ -41,33 +43,11 @@ focus-border-color { mouse-color initial: COLOR: black } column-line-color selection-required? -selection selection-index -selected-indices +selection mouse-index { takes-focus? initial: t } -focused? -multiple-selection? ; - -> conjoin ; - -: multiple>single ( values -- value/f ? ) - dup assoc-empty? [ drop f f ] [ values first t ] if ; - -: selected-index ( table -- n ) - selected-indices>> multiple>single drop ; - -: set-selected-index ( table n -- table ) - dup associate >>selected-indices ; - -PRIVATE> - -: selected ( table -- index/indices ) - [ selected-indices>> ] [ multiple-selection?>> ] bi - [ multiple>single drop ] unless ; +focused? ; : new-table ( rows renderer class -- table ) new-line-gadget @@ -77,8 +57,7 @@ PRIVATE> focus-border-color >>focus-border-color transparent >>column-line-color f >>selection-index - f >>selection - H{ } clone >>selected-indices ; + f >>selection ; : ( rows renderer -- table ) table new-table ; @@ -156,30 +135,23 @@ M: table layout* : row-bounds ( table row -- loc dim ) row-rect rect-bounds ; inline -: draw-selected-rows ( table -- ) - { - { [ dup selected-indices>> assoc-empty? ] [ drop ] } - [ - [ selected-indices>> keys ] [ selection-color>> gl-color ] [ ] tri - [ swap row-bounds gl-fill-rect ] curry each - ] - } cond ; +: draw-selected-row ( table -- ) + dup selection-index>> value>> [ + dup selection-color>> gl-color + dup selection-index>> value>> row-bounds gl-fill-rect + ] [ drop ] if ; : draw-focused-row ( table -- ) - { - { [ dup focused?>> not ] [ drop ] } - { [ dup selected-index not ] [ drop ] } - [ - [ ] [ selected-index ] [ focus-border-color>> gl-color ] tri - row-bounds gl-rect - ] - } cond ; + dup { [ focused?>> ] [ selection-index>> value>> ] } 1&& [ + dup focus-border-color>> gl-color + dup selection-index>> value>> row-bounds gl-rect + ] [ drop ] if ; : draw-moused-row ( table -- ) - dup mouse-index>> dup [ - over mouse-color>> gl-color - row-bounds gl-rect - ] [ 2drop ] if ; + dup mouse-index>> [ + dup mouse-color>> gl-color + dup mouse-index>> row-bounds gl-rect + ] [ drop ] if ; : column-line-offsets ( table -- xs ) [ column-widths>> ] [ gap>> ] bi @@ -217,7 +189,7 @@ M: table layout* :: row-font ( row ind table -- font ) table font>> clone row table renderer>> row-color [ >>foreground ] when* - ind table selected-indices>> key? + ind table selection-index>> value>> = [ table selection-color>> >>background ] when ; : draw-columns ( columns widths alignment font gap -- ) @@ -239,7 +211,7 @@ M: table draw-gadget* dup control-value empty? [ drop ] [ dup line-height \ line-height [ { - [ draw-selected-rows ] + [ draw-selected-row ] [ draw-lines ] [ draw-column-lines ] [ draw-focused-row ] @@ -262,37 +234,15 @@ M: table pref-dim* PRIVATE> -: (selected-rows) ( table -- assoc ) - [ selected-indices>> ] keep - '[ _ nth-row drop ] assoc-map ; +: (selected-row) ( table -- value/f ? ) + [ selection-index>> value>> ] keep nth-row ; -: selected-rows ( table -- assoc ) - [ selected-indices>> ] [ ] [ renderer>> ] tri - '[ _ nth-row drop _ row-value ] assoc-map ; - -: (selected-row) ( table -- value/f ? ) (selected-rows) multiple>single ; - -: selected-row ( table -- value/f ? ) selected-rows multiple>single ; +: selected-row ( table -- value/f ? ) + [ (selected-row) ] [ renderer>> ] bi + swap [ row-value t ] [ 2drop f f ] if ; single drop ] if swap set-model ; - -: update-selected ( table -- ) - [ - [ selection>> ] - [ selected-rows ] - [ multiple-selection?>> ] tri - set-table-model - ] - [ - [ selection-index>> ] - [ selected-indices>> ] - [ multiple-selection?>> ] tri - set-table-model - ] bi ; - : show-row-summary ( table n -- ) over nth-row [ swap [ renderer>> row-value ] keep show-summary ] @@ -302,34 +252,45 @@ PRIVATE> : hide-mouse-help ( table -- ) f >>mouse-index [ hide-status ] [ relayout-1 ] bi ; -: find-row-index ( value table -- n/f ) - [ model>> value>> ] [ renderer>> ] bi - '[ _ row-value eq? ] with find drop ; +: ((select-row)) ( n table -- ) + [ selection-index>> set-model ] + [ [ selected-row drop ] keep selection>> set-model ] + bi ; -: (update-selected-indices) ( table -- set ) - [ selection>> value>> dup { [ array? not ] [ ] } 1&& [ 1array ] when ] keep - '[ _ find-row-index ] map sift unique f assoc-like ; +: update-mouse-index ( table -- ) + dup [ model>> value>> ] [ mouse-index>> ] bi + dup [ swap length [ drop f ] [ 1 - min ] if-zero ] [ 2drop f ] if + >>mouse-index drop ; -: initial-selected-indices ( table -- set ) +: initial-selection-index ( table -- n/f ) { [ model>> value>> empty? not ] [ selection-required?>> ] - [ drop { 0 } unique ] + [ drop 0 ] } 1&& ; -: update-selected-indices ( table -- set ) - { - [ (update-selected-indices) ] - [ initial-selected-indices ] - } 1|| ; +: find-row-index ( value table -- n/f ) + [ model>> value>> ] [ renderer>> ] bi + '[ _ row-value? ] with find drop ; + +: update-selection ( table -- ) + [ + { + [ [ selection>> value>> ] keep find-row-index ] + [ initial-selection-index ] + } 1|| + ] keep + over [ ((select-row)) ] [ + [ selection-index>> set-model ] + [ selection>> set-model ] + 2bi + ] if ; M: table model-changed - nip dup update-selected-indices { - [ >>selected-indices f >>mouse-index drop ] - [ multiple>single drop show-row-summary ] - [ drop update-selected ] - [ drop relayout ] - } 2cleave ; + nip + dup update-selection + dup update-mouse-index + [ dup mouse-index>> show-row-summary ] [ relayout ] bi ; : thin-row-rect ( table row -- rect ) row-rect [ { 0 1 } v* ] change-dim ; @@ -337,14 +298,11 @@ M: table model-changed : scroll-to-row ( table n -- ) dup [ [ thin-row-rect ] [ drop ] 2bi scroll>rect ] [ 2drop ] if ; -: add-selected-row ( table n -- ) - [ scroll-to-row ] - [ add-selected-index relayout-1 ] 2bi ; - : (select-row) ( table n -- ) [ scroll-to-row ] - [ set-selected-index relayout-1 ] - 2bi ; + [ swap ((select-row)) ] + [ drop relayout-1 ] + 2tri ; : mouse-row ( table -- n ) [ hand-rel second ] keep y>line ; @@ -353,23 +311,9 @@ M: table model-changed [ [ mouse-row ] keep 2dup valid-line? ] [ ] [ '[ nip @ ] ] tri* if ; inline -: (table-button-down) ( quot table -- ) - dup takes-focus?>> [ dup request-focus ] when swap - '[ swap [ >>mouse-index ] _ bi ] [ drop ] if-mouse-row ; inline - : table-button-down ( table -- ) - [ (select-row) ] swap (table-button-down) ; - -: continued-button-down ( table -- ) - dup multiple-selection?>> - [ [ add-selected-row ] swap (table-button-down) ] [ table-button-down ] if ; - -: thru-button-down ( table -- ) - dup multiple-selection?>> [ - [ 2dup over selected-index (a,b) swap - [ swap add-selected-index drop ] curry each add-selected-row ] - swap (table-button-down) - ] [ table-button-down ] if ; + dup takes-focus?>> [ dup request-focus ] when + [ swap [ >>mouse-index ] [ (select-row) ] bi ] [ drop ] if-mouse-row ; inline PRIVATE> @@ -386,22 +330,20 @@ PRIVATE> : table-button-up ( table -- ) dup [ mouse-row ] keep valid-line? [ - dup row-action? [ row-action ] [ update-selected ] if + dup row-action? [ row-action ] [ drop ] if ] [ drop ] if ; PRIVATE> : select-row ( table n -- ) over validate-line - [ (select-row) ] - [ drop update-selected ] - [ show-row-summary ] - 2tri ; + [ (select-row) ] [ show-row-summary ] 2bi ; > value>> ] dip + '[ _ + ] [ 0 ] if* select-row ; : previous-row ( table -- ) -1 prev/next-row ; @@ -453,8 +395,6 @@ table "sundry" f { { mouse-enter show-mouse-help } { mouse-leave hide-mouse-help } { motion show-mouse-help } - { T{ button-down f { S+ } 1 } thru-button-down } - { T{ button-down f { A+ } 1 } continued-button-down } { T{ button-up } table-button-up } { T{ button-up f { S+ } } table-button-up } { T{ button-down } table-button-down } diff --git a/basis/ui/tools/error-list/error-list.factor b/basis/ui/tools/error-list/error-list.factor index eaa947b2d6..76df264131 100644 --- a/basis/ui/tools/error-list/error-list.factor +++ b/basis/ui/tools/error-list/error-list.factor @@ -49,6 +49,8 @@ M: source-file-renderer prototype-row M: source-file-renderer row-value drop dup [ first [ ] [ f ] if* ] when ; +M: source-file-renderer row-value? row-value = ; + M: source-file-renderer column-titles drop { "" "File" "Errors" } ; From ad69052a1a1442e7c3fd8ebe8983279466f839f5 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 3 May 2010 22:11:29 -0400 Subject: [PATCH 03/24] compiler.cfg.value-numbering: fix typo in unit test --- basis/compiler/cfg/registers/registers.factor | 4 ++-- .../compiler/cfg/value-numbering/value-numbering-tests.factor | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/basis/compiler/cfg/registers/registers.factor b/basis/compiler/cfg/registers/registers.factor index 2f4f2a99e6..9c7896be7e 100644 --- a/basis/compiler/cfg/registers/registers.factor +++ b/basis/compiler/cfg/registers/registers.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors namespaces kernel parser assocs sequences ; +USING: accessors namespaces kernel math parser assocs sequences ; IN: compiler.cfg.registers ! Virtual registers, used by CFG and machine IRs, are just integers @@ -34,7 +34,7 @@ ERROR: bad-vreg vreg ; ! ##inc-d and ##inc-r affect locations as follows. Location D 0 before ! an ##inc-d 1 becomes D 1 after ##inc-d 1. -TUPLE: loc { n read-only } ; +TUPLE: loc { n integer read-only } ; TUPLE: ds-loc < loc ; C: ds-loc diff --git a/basis/compiler/cfg/value-numbering/value-numbering-tests.factor b/basis/compiler/cfg/value-numbering/value-numbering-tests.factor index 7c281d0fe7..3be4e584fb 100644 --- a/basis/compiler/cfg/value-numbering/value-numbering-tests.factor +++ b/basis/compiler/cfg/value-numbering/value-numbering-tests.factor @@ -91,7 +91,7 @@ cpu x86.32? [ [ { T{ ##load-reference f 0 + } - T{ ##replace-imm f 10 D + } + T{ ##replace-imm f + D 0 } } ] [ { From 1c6bbf7fd1b356bca81cfdbc2f5454c06c2344ee Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 3 May 2010 22:38:50 -0400 Subject: [PATCH 04/24] bit-arrays: re-use utility words from math.bitwise and io.binary to make implementation a bit more elegant --- basis/bit-arrays/bit-arrays-tests.factor | 6 +++- basis/bit-arrays/bit-arrays.factor | 43 ++++++++++-------------- 2 files changed, 23 insertions(+), 26 deletions(-) diff --git a/basis/bit-arrays/bit-arrays-tests.factor b/basis/bit-arrays/bit-arrays-tests.factor index f08db68441..46089e3f7b 100644 --- a/basis/bit-arrays/bit-arrays-tests.factor +++ b/basis/bit-arrays/bit-arrays-tests.factor @@ -1,4 +1,4 @@ -USING: sequences sequences.private arrays bit-arrays kernel +USING: alien sequences sequences.private arrays bit-arrays kernel tools.test math random ; IN: bit-arrays.tests @@ -79,4 +79,8 @@ IN: bit-arrays.tests [ 49 ] [ 49 dup set-bits [ ] count ] unit-test +[ 1 ] [ ?{ f t f t } byte-length ] unit-test + +[ HEX: a ] [ ?{ f t f t } bit-array>integer ] unit-test + [ HEX: 100 ] [ ?{ f f f f f f f f t } bit-array>integer ] unit-test diff --git a/basis/bit-arrays/bit-arrays.factor b/basis/bit-arrays/bit-arrays.factor index 798bfb8ae9..ade7d8ddac 100644 --- a/basis/bit-arrays/bit-arrays.factor +++ b/basis/bit-arrays/bit-arrays.factor @@ -1,8 +1,9 @@ ! Copyright (C) 2007, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien alien.data accessors math alien.accessors kernel -kernel.private sequences sequences.private byte-arrays -parser prettyprint.custom fry ; +USING: alien alien.data accessors io.binary math math.bitwise +alien.accessors kernel kernel.private sequences +sequences.private byte-arrays parser prettyprint.custom fry +locals ; IN: bit-arrays TUPLE: bit-array @@ -13,11 +14,10 @@ TUPLE: bit-array : n>byte ( m -- n ) -3 shift ; inline -: byte/bit ( n alien -- byte bit ) - over n>byte alien-unsigned-1 swap 7 bitand ; inline +: bit/byte ( n -- bit byte ) [ 7 bitand ] [ n>byte ] bi ; inline -: set-bit ( ? byte bit -- byte ) - 2^ rot [ bitor ] [ bitnot bitand ] if ; inline +: bit-index ( n bit-array -- bit# byte# byte-array ) + [ >fixnum bit/byte ] [ underlying>> ] bi* ; inline : bits>cells ( m -- n ) 31 + -5 shift ; inline @@ -25,7 +25,7 @@ TUPLE: bit-array : (set-bits) ( bit-array n -- ) [ [ length bits>cells ] keep ] dip swap underlying>> - '[ 2 shift [ _ _ ] dip set-alien-unsigned-4 ] each-integer ; inline + '[ [ _ _ ] dip 4 * set-alien-unsigned-4 ] each-integer ; inline : clean-up ( bit-array -- ) ! Zero bits after the end. @@ -47,12 +47,13 @@ PRIVATE> M: bit-array length length>> ; inline M: bit-array nth-unsafe - [ >fixnum ] [ underlying>> ] bi* byte/bit bit? ; inline + bit-index nth-unsafe swap bit? ; inline + +:: toggle-bit ( ? n x -- y ) + x n ? [ set-bit ] [ clear-bit ] if ; inline M: bit-array set-nth-unsafe - [ >fixnum ] [ underlying>> ] bi* - [ byte/bit set-bit ] 2keep - swap n>byte set-alien-unsigned-1 ; inline + bit-index [ toggle-bit ] change-nth-unsafe ; inline GENERIC: clear-bits ( bit-array -- ) @@ -83,25 +84,17 @@ M: bit-array resize bit-array boa dup clean-up ; inline -M: bit-array byte-length length 7 + -3 shift ; inline +M: bit-array byte-length length bits>bytes ; inline SYNTAX: ?{ \ } [ >bit-array ] parse-literal ; : integer>bit-array ( n -- bit-array ) - dup 0 = [ - - ] [ - [ log2 1 + 0 ] keep - [ dup 0 = ] [ - [ pick underlying>> pick set-alien-unsigned-1 ] keep - [ 1 + ] [ -8 shift ] bi* - ] until 2drop - ] if ; + dup 0 = + [ ] + [ dup log2 1 + [ nip ] [ bits>bytes >le ] 2bi bit-array boa ] if ; : bit-array>integer ( bit-array -- n ) - 0 swap underlying>> dup length iota [ - alien-unsigned-1 swap 8 shift bitor - ] with each ; + underlying>> le> ; INSTANCE: bit-array sequence From a8fdfc5860725b00c79aace69a4afab15b2aebc8 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 3 May 2010 22:42:19 -0400 Subject: [PATCH 05/24] ui.gadgets.tables: fix load error in docs --- basis/ui/gadgets/tables/tables-docs.factor | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/basis/ui/gadgets/tables/tables-docs.factor b/basis/ui/gadgets/tables/tables-docs.factor index 057c8320ac..45f948e14a 100644 --- a/basis/ui/gadgets/tables/tables-docs.factor +++ b/basis/ui/gadgets/tables/tables-docs.factor @@ -25,13 +25,11 @@ ARTICLE: "ui.gadgets.tables.selection" "Table row selection" { { $slot "selection" } { " - if set to a model, the values of the currently selected row or rows, as determined by a " { $link row-value } " call to the renderer, is stored in this model. See " { $link "models" } "." } } { { $slot "selection-index" } { " - if set to a model, the indices of the currently selected rows." } } { { $slot "selection-required?" } { " - if set to a true value, the table ensures that some row is always selected, if the model is non-empty. If set to " { $link f } ", a state where nothing is selected is permitted to occur. The default is " { $link f } "." } } - { { $slot "multiple-selection?" } { " - if set to a true value, users are allowed to select more than one value." } } } "Some words for row selection:" { $subsections - selected-rows - (selected-rows) - selected + selected-row + (selected-row) } ; ARTICLE: "ui.gadgets.tables.actions" "Table row actions" From 86d89f3ff7e14f8f9326a7f0bda0f5f45f943933 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 3 May 2010 22:43:51 -0400 Subject: [PATCH 06/24] cpu.ppc: fixing typos in non-optimizing backend --- basis/cpu/ppc/bootstrap.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/cpu/ppc/bootstrap.factor b/basis/cpu/ppc/bootstrap.factor index 5fb303409e..68ebbf9f4f 100644 --- a/basis/cpu/ppc/bootstrap.factor +++ b/basis/cpu/ppc/bootstrap.factor @@ -4,7 +4,7 @@ USING: bootstrap.image.private kernel kernel.private namespaces system cpu.ppc.assembler compiler.units compiler.constants math math.private math.ranges layouts words vocabs slots.private locals locals.backend generic.single.private fry sequences -threads.private ; +threads.private strings.private ; FROM: cpu.ppc.assembler => B ; IN: bootstrap.ppc @@ -502,7 +502,7 @@ CONSTANT: nv-reg 17 3 3 4 LBZX 3 3 tag-bits get SLWI ! store character to stack - ds-reg ds-reg 4 SUB + ds-reg ds-reg 4 SUBI 3 ds-reg 0 STW ] \ string-nth-fast define-sub-primitive From 41ec3f20a8504a6832c422fcdb2df611242a6142 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 3 May 2010 23:07:46 -0400 Subject: [PATCH 07/24] tools.deploy.shaker: tweak error reporting slightly --- basis/tools/deploy/shaker/shaker.factor | 28 +++++++++++++------ .../tools/deploy/shaker/strip-debugger.factor | 10 ++----- 2 files changed, 22 insertions(+), 16 deletions(-) diff --git a/basis/tools/deploy/shaker/shaker.factor b/basis/tools/deploy/shaker/shaker.factor index 485f0f5fa7..44291a96cc 100755 --- a/basis/tools/deploy/shaker/shaker.factor +++ b/basis/tools/deploy/shaker/shaker.factor @@ -1,13 +1,15 @@ ! Copyright (C) 2007, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays alien.libraries accessors io.backend io.encodings.utf8 io.files -io.streams.c init fry namespaces math make assocs kernel parser -parser.notes lexer strings.parser vocabs sequences sequences.deep -sequences.private words memory kernel.private continuations io -vocabs.loader system strings sets vectors quotations byte-arrays -sorting compiler.units definitions generic generic.standard -generic.single tools.deploy.config combinators classes vocabs.loader.private -classes.builtin slots.private grouping command-line io.pathnames ; +USING: arrays alien.libraries accessors io.backend +io.encodings.utf8 io.files io.streams.c init fry namespaces math +make assocs kernel parser parser.notes lexer strings.parser +vocabs sequences sequences.deep sequences.private words memory +kernel.private continuations io vocabs.loader system strings +sets vectors quotations byte-arrays sorting compiler.units +definitions generic generic.standard generic.single +tools.deploy.config combinators combinators.private classes +vocabs.loader.private classes.builtin slots.private grouping +command-line io.pathnames ; QUALIFIED: bootstrap.stage2 QUALIFIED: classes.private QUALIFIED: compiler.crossref @@ -548,10 +550,18 @@ SYMBOL: deploy-vocab strip-words clear-megamorphic-caches ; +: die-with ( error original-error -- * ) + #! We don't want DCE to drop the error before the die call! + [ die 1 exit ] (( a -- * )) call-effect-unsafe ; + +: die-with2 ( error original-error -- * ) + #! We don't want DCE to drop the error before the die call! + [ die 1 exit ] (( a b -- * )) call-effect-unsafe ; + : deploy-error-handler ( quot -- ) [ strip-debugger? - [ error-continuation get call>> callstack>array die 1 exit ] + [ original-error get die-with2 ] ! Don't reference these words literally, if we're stripping the ! debugger out we don't want to load the prettyprinter at all [ [:c] execute( -- ) nl [print-error] execute( error -- ) flush ] if diff --git a/basis/tools/deploy/shaker/strip-debugger.factor b/basis/tools/deploy/shaker/strip-debugger.factor index b7565e7d9e..5faeab0e2d 100644 --- a/basis/tools/deploy/shaker/strip-debugger.factor +++ b/basis/tools/deploy/shaker/strip-debugger.factor @@ -1,17 +1,13 @@ USING: compiler.units words vocabs kernel threads.private ; IN: debugger -: consume ( error -- ) - #! We don't want DCE to drop the error before the die call! - drop ; +: error. ( error -- ) original-error get die-with2 ; -: print-error ( error -- ) die consume ; - -: error. ( error -- ) die consume ; +: print-error ( error -- ) error. ; "threads" vocab [ [ "error-in-thread" "threads" lookup - [ [ die 2drop ] define ] [ f "combination" set-word-prop ] bi + [ [ drop error. ] define ] [ f "combination" set-word-prop ] bi ] with-compilation-unit ] when From 6c35652666fe275de9dc5fdb18fa1a664c9ef41d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 3 May 2010 23:08:24 -0400 Subject: [PATCH 08/24] cpu: cleanups --- basis/cpu/architecture/architecture.factor | 2 -- basis/cpu/x86/x86.factor | 4 ++-- 2 files changed, 2 insertions(+), 4 deletions(-) diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor index d156b2f39d..8f69b24729 100644 --- a/basis/cpu/architecture/architecture.factor +++ b/basis/cpu/architecture/architecture.factor @@ -508,8 +508,6 @@ M: stack-params param-reg 2drop ; ! objects in %compare-imm? HOOK: fused-unboxing? cpu ( -- ? ) -M: object fused-unboxing? f ; - ! Can this value be an immediate operand for %add-imm, %sub-imm, ! or %mul-imm? HOOK: immediate-arithmetic? cpu ( n -- ? ) diff --git a/basis/cpu/x86/x86.factor b/basis/cpu/x86/x86.factor index b0d4f05a0e..6019a5af8b 100644 --- a/basis/cpu/x86/x86.factor +++ b/basis/cpu/x86/x86.factor @@ -70,9 +70,9 @@ HOOK: pic-tail-reg cpu ( -- reg ) M: x86 complex-addressing? t ; -M: x86 fused-unboxing? ( -- ? ) t ; +M: x86 fused-unboxing? t ; -M: x86 immediate-store? ( obj -- ? ) immediate-comparand? ; +M: x86 immediate-store? immediate-comparand? ; M: x86 %load-immediate dup 0 = [ drop dup XOR ] [ MOV ] if ; From ea4ee4ff6003096c0cebcc6b8bf4d1a83a90771b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 4 May 2010 00:07:53 -0400 Subject: [PATCH 09/24] compiler.tests: remove useless test from float tests; min and max are generic now, with methods on floats, so any potential inconsistency is gone --- basis/compiler/tests/float.factor | 15 +-------------- 1 file changed, 1 insertion(+), 14 deletions(-) diff --git a/basis/compiler/tests/float.factor b/basis/compiler/tests/float.factor index b1ce0e454d..d55fe2b769 100644 --- a/basis/compiler/tests/float.factor +++ b/basis/compiler/tests/float.factor @@ -99,9 +99,6 @@ IN: compiler.tests.float [ 2 ] [ 3.0 1.0 [ float-unordered? [ 1 ] [ 2 ] if ] compile-call ] unit-test [ 2 ] [ 1.0 3.0 [ float-unordered? [ 1 ] [ 2 ] if ] compile-call ] unit-test -! Ensure that float-min and min, and float-max and max, have -! consistent behavior with respect to NaNs - : two-floats ( a b -- a b ) { float float } declare ; inline [ -11.3 ] [ -11.3 17.5 [ two-floats min ] compile-call ] unit-test @@ -109,17 +106,7 @@ IN: compiler.tests.float [ 17.5 ] [ -11.3 17.5 [ two-floats max ] compile-call ] unit-test [ 17.5 ] [ 17.5 -11.3 [ two-floats max ] compile-call ] unit-test -: check-compiled-binary-op ( a b word -- ) - [ '[ [ [ two-floats _ execute ] compile-call ] call( a b -- c ) ] ] - [ '[ _ execute ] ] - bi 2bi fp-bitwise= ; inline - -[ t ] [ 0/0. 3.0 \ min check-compiled-binary-op ] unit-test -[ t ] [ 3.0 0/0. \ min check-compiled-binary-op ] unit-test -[ t ] [ 0/0. 3.0 \ max check-compiled-binary-op ] unit-test -[ t ] [ 3.0 0/0. \ max check-compiled-binary-op ] unit-test - -! Test vector ops +! Test loops [ 30.0 ] [ float-array{ 1 2 3 4 } float-array{ 1 2 3 4 } [ { float-array float-array } declare [ * ] [ + ] 2map-reduce ] compile-call From c7351595e56d100921f88a3a42c65ea3235ce82e Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 3 May 2010 23:35:17 -0500 Subject: [PATCH 10/24] Allow a-zA-Z0-9_ in identifiers for peg.ebnf --- basis/peg/ebnf/ebnf-tests.factor | 21 +++++++++++++++++++++ basis/peg/ebnf/ebnf.factor | 2 +- 2 files changed, 22 insertions(+), 1 deletion(-) diff --git a/basis/peg/ebnf/ebnf-tests.factor b/basis/peg/ebnf/ebnf-tests.factor index aba92899da..825e07dbf8 100644 --- a/basis/peg/ebnf/ebnf-tests.factor +++ b/basis/peg/ebnf/ebnf-tests.factor @@ -528,3 +528,24 @@ Tok = Spaces (Number | Special ) ] [ error>> [ redefined-rule? ] [ name>> "lol" = ] bi and ] must-fail-with + +[ + { "a" "a" } +] [ + EBNF: foo Bar = "a":a1 "a":a2 => [[ a1 a2 2array ]] ;EBNF + "aa" foo +] unit-test + +[ + { "a" "a" } +] [ + EBNF: foo2 Bar = "a":1a "a":2a => [[ 1a 2a 2array ]] ;EBNF + "aa" foo2 +] unit-test + +[ + { "a" "a" } +] [ + EBNF: foo3 Bar = "a":11 "a":22 => [[ 11 22 2array ]] ;EBNF + "aa" foo3 +] unit-test diff --git a/basis/peg/ebnf/ebnf.factor b/basis/peg/ebnf/ebnf.factor index ffc4cb91ad..4462330a44 100644 --- a/basis/peg/ebnf/ebnf.factor +++ b/basis/peg/ebnf/ebnf.factor @@ -230,7 +230,7 @@ DEFER: 'action' : 'element' ( -- parser ) [ - [ ('element') , ":" syntax , "a-zA-Z" range-pattern repeat1 [ >string ] action , ] seq* [ first2 ] action , + [ ('element') , ":" syntax , "(a-zA-Z0-9_)+" range-pattern repeat1 [ >string ] action , ] seq* [ first2 ] action , ('element') , ] choice* ; From fa07f5d85fd5f1eafdd2acc4e4e49ca56250af0d Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 3 May 2010 23:40:50 -0500 Subject: [PATCH 11/24] Allow - in peg.ebnf identifiers. Eating still not allowed... --- basis/peg/ebnf/ebnf-tests.factor | 7 +++++++ basis/peg/ebnf/ebnf.factor | 2 +- 2 files changed, 8 insertions(+), 1 deletion(-) diff --git a/basis/peg/ebnf/ebnf-tests.factor b/basis/peg/ebnf/ebnf-tests.factor index 825e07dbf8..accbec6fd7 100644 --- a/basis/peg/ebnf/ebnf-tests.factor +++ b/basis/peg/ebnf/ebnf-tests.factor @@ -549,3 +549,10 @@ Tok = Spaces (Number | Special ) EBNF: foo3 Bar = "a":11 "a":22 => [[ 11 22 2array ]] ;EBNF "aa" foo3 ] unit-test + +[ + { "a" "a" } +] [ + EBNF: foo4 Bar = "a":a-1 "a":a-2 => [[ a-1 a-2 2array ]] ;EBNF + "aa" foo4 +] unit-test diff --git a/basis/peg/ebnf/ebnf.factor b/basis/peg/ebnf/ebnf.factor index 4462330a44..29123b7126 100644 --- a/basis/peg/ebnf/ebnf.factor +++ b/basis/peg/ebnf/ebnf.factor @@ -230,7 +230,7 @@ DEFER: 'action' : 'element' ( -- parser ) [ - [ ('element') , ":" syntax , "(a-zA-Z0-9_)+" range-pattern repeat1 [ >string ] action , ] seq* [ first2 ] action , + [ ('element') , ":" syntax , "(a-zA-Z0-9_-)+" range-pattern repeat1 [ >string ] action , ] seq* [ first2 ] action , ('element') , ] choice* ; From 8ccb56c924297a7a96e7d29663a92ba5c1e4bcef Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 3 May 2010 23:52:37 -0500 Subject: [PATCH 12/24] C-style identifiers in peg.ebnf --- basis/peg/ebnf/ebnf-tests.factor | 16 +--------------- basis/peg/ebnf/ebnf.factor | 6 +++++- 2 files changed, 6 insertions(+), 16 deletions(-) diff --git a/basis/peg/ebnf/ebnf-tests.factor b/basis/peg/ebnf/ebnf-tests.factor index accbec6fd7..897746a9c9 100644 --- a/basis/peg/ebnf/ebnf-tests.factor +++ b/basis/peg/ebnf/ebnf-tests.factor @@ -539,20 +539,6 @@ Tok = Spaces (Number | Special ) [ { "a" "a" } ] [ - EBNF: foo2 Bar = "a":1a "a":2a => [[ 1a 2a 2array ]] ;EBNF + EBNF: foo2 Bar = "a":a-1 "a":a-2 => [[ a-1 a-2 2array ]] ;EBNF "aa" foo2 ] unit-test - -[ - { "a" "a" } -] [ - EBNF: foo3 Bar = "a":11 "a":22 => [[ 11 22 2array ]] ;EBNF - "aa" foo3 -] unit-test - -[ - { "a" "a" } -] [ - EBNF: foo4 Bar = "a":a-1 "a":a-2 => [[ a-1 a-2 2array ]] ;EBNF - "aa" foo4 -] unit-test diff --git a/basis/peg/ebnf/ebnf.factor b/basis/peg/ebnf/ebnf.factor index 29123b7126..b682f582ad 100644 --- a/basis/peg/ebnf/ebnf.factor +++ b/basis/peg/ebnf/ebnf.factor @@ -230,7 +230,11 @@ DEFER: 'action' : 'element' ( -- parser ) [ - [ ('element') , ":" syntax , "(a-zA-Z0-9_-)+" range-pattern repeat1 [ >string ] action , ] seq* [ first2 ] action , + [ + ('element') , ":" syntax , + "a-zA-Z_" range-pattern + "a-zA-Z0-9_-" range-pattern repeat1 2seq [ first2 swap prefix >string ] action , + ] seq* [ first2 ] action , ('element') , ] choice* ; From dd2a4c2c7783cb08605c117436f5ec5b6236eb18 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 4 May 2010 02:50:25 -0400 Subject: [PATCH 13/24] cpu.x86: GC root offsets were computed wrong in words containing alien calls --- basis/compiler/tests/codegen.factor | 10 ++++++++++ basis/cpu/x86/x86.factor | 2 +- 2 files changed, 11 insertions(+), 1 deletion(-) diff --git a/basis/compiler/tests/codegen.factor b/basis/compiler/tests/codegen.factor index 288940e660..2edb016734 100644 --- a/basis/compiler/tests/codegen.factor +++ b/basis/compiler/tests/codegen.factor @@ -462,3 +462,13 @@ TUPLE: myseq { underlying1 byte-array read-only } { underlying2 byte-array read- 1 1 [ [ HEX: f bitand ] bi@ [ shift ] [ drop -3 shift ] 2bi ] compile-call ] unit-test + +! GC root offsets were computed wrong on x86 +: gc-root-messup ( a -- b ) + dup [ + 1024 (byte-array) 2array + 10 void* "libc" "malloc" { ulong } alien-invoke + void "libc" "free" { void* } alien-invoke + ] when ; + +[ ] [ 2000 [ "hello" clone dup gc-root-messup first eq? t assert= ] times ] unit-test diff --git a/basis/cpu/x86/x86.factor b/basis/cpu/x86/x86.factor index 6019a5af8b..d4a3be49b6 100644 --- a/basis/cpu/x86/x86.factor +++ b/basis/cpu/x86/x86.factor @@ -45,7 +45,7 @@ HOOK: extra-stack-space cpu ( stack-frame -- n ) : param@ ( n -- op ) reserved-stack-space + stack@ ; : gc-root-offsets ( seq -- seq' ) - [ n>> special-offset ] map f like ; + [ n>> spill-offset special-offset ] map f like ; : decr-stack-reg ( n -- ) dup 0 = [ drop ] [ stack-reg swap SUB ] if ; From f46a56024cdcd21290befcadc6cd1cffd71f76af Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 4 May 2010 02:53:46 -0400 Subject: [PATCH 14/24] ui.tools.error-list: re-use the same actual gadget, so that the current selection and set of displayed error types is preserved if the user closes and re-opens the error list --- basis/ui/tools/error-list/error-list.factor | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/basis/ui/tools/error-list/error-list.factor b/basis/ui/tools/error-list/error-list.factor index 76df264131..8cc8781b19 100644 --- a/basis/ui/tools/error-list/error-list.factor +++ b/basis/ui/tools/error-list/error-list.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2009 Slava Pestov. +! Copyright (C) 2009, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays sequences sorting assocs colors.constants fry combinators combinators.smart combinators.short-circuit editors make @@ -154,7 +154,7 @@ error-display "toolbar" f { [ swap '[ error-type _ at ] filter ] ; :: ( model -- gadget ) - vertical error-list-gadget new-track + vertical \ error-list-gadget new-track [ >>error-toggle ] [ >>visible-errors ] bi* dup visible-errors>> model >>model f >>source-file @@ -178,16 +178,16 @@ M: error-list-gadget focusable-child* \ error-list-help H{ { +nullary+ t } } define-command -error-list-gadget "toolbar" f { +\ error-list-gadget "toolbar" f { { T{ key-down f f "F1" } error-list-help } } define-command-map -: error-list-window ( -- ) - error-list-model get [ drop all-errors ] - "Errors" open-status-window ; +MEMO: error-list-gadget ( -- gadget ) + error-list-model get-global [ drop all-errors ] + ; : show-error-list ( -- ) - [ error-list-gadget? ] find-window - [ raise-window ] [ error-list-window ] if* ; + [ error-list-gadget eq? ] find-window + [ raise-window ] [ error-list-gadget "Errors" open-status-window ] if* ; \ show-error-list H{ { +nullary+ t } } define-command From 1bd7b85b039747238773c4538bcf0509bf4f4a6e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 4 May 2010 02:31:36 -0500 Subject: [PATCH 15/24] windows.directx.dinput.constants: fix breakage if image is saved and restarted --- .../directx/dinput/constants/constants.factor | 23 +++++++++---------- 1 file changed, 11 insertions(+), 12 deletions(-) mode change 100644 => 100755 basis/windows/directx/dinput/constants/constants.factor diff --git a/basis/windows/directx/dinput/constants/constants.factor b/basis/windows/directx/dinput/constants/constants.factor old mode 100644 new mode 100755 index 6a2d9b148d..98ea261d38 --- a/basis/windows/directx/dinput/constants/constants.factor +++ b/basis/windows/directx/dinput/constants/constants.factor @@ -1,8 +1,8 @@ -USING: windows.directx.dinput windows.kernel32 windows.ole32 windows.com -windows.com.syntax alien alien.c-types alien.data alien.syntax -kernel system namespaces combinators sequences fry math accessors -macros words quotations libc continuations generalizations -splitting locals assocs init specialized-arrays memoize +USING: windows.directx.dinput windows.kernel32 windows.ole32 +windows.com windows.com.syntax alien alien.c-types alien.data +alien.syntax kernel system namespaces combinators sequences fry +math accessors macros words quotations libc continuations +generalizations splitting locals assocs init specialized-arrays classes.struct strings arrays literals ; SPECIALIZED-ARRAY: DIOBJECTDATAFORMAT IN: windows.directx.dinput.constants @@ -20,21 +20,21 @@ SYMBOLS: > [ name>> = ] with find nip ; + c-type fields>> [ name>> = ] with find nip ; : (offsetof) ( field struct -- offset ) [ (field-spec-of) offset>> ] [ drop 0 ] if* ; : (sizeof) ( field struct -- size ) - [ (field-spec-of) type>> array-base-type heap-size* ] [ drop 1 ] if* ; + [ (field-spec-of) type>> array-base-type heap-size ] [ drop 1 ] if* ; : (flag) ( thing -- integer ) { @@ -832,8 +832,7 @@ MACRO: ( dwFlags dwDataSize struct rgodf-array -- alien ) [ define-constants ] "windows.directx.dinput.constants" add-startup-hook : uninitialize ( variable quot -- ) - [ '[ _ when* f ] change-global ] - [ drop global delete-at ] 2bi ; inline + [ [ get-global ] dip when* ] [ drop global delete-at ] 2bi ; inline : free-dinput-constants ( -- ) { From 74a4c334235198ec11ae22fcd7cd602c3ce95981 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 4 May 2010 02:34:37 -0500 Subject: [PATCH 16/24] Remove 'prettyprint' from a few USING: forms --- basis/compression/lzw/lzw.factor | 2 +- basis/images/ppm/ppm.factor | 2 +- basis/images/tiff/tiff.factor | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) mode change 100644 => 100755 basis/compression/lzw/lzw.factor mode change 100644 => 100755 basis/images/ppm/ppm.factor mode change 100644 => 100755 basis/images/tiff/tiff.factor diff --git a/basis/compression/lzw/lzw.factor b/basis/compression/lzw/lzw.factor old mode 100644 new mode 100755 index 340e455291..f61a02c01b --- a/basis/compression/lzw/lzw.factor +++ b/basis/compression/lzw/lzw.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: accessors combinators io kernel math namespaces -prettyprint sequences vectors ; +sequences vectors ; QUALIFIED-WITH: bitstreams bs IN: compression.lzw diff --git a/basis/images/ppm/ppm.factor b/basis/images/ppm/ppm.factor old mode 100644 new mode 100755 index d50d51797d..9610189094 --- a/basis/images/ppm/ppm.factor +++ b/basis/images/ppm/ppm.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors ascii combinators images images.loader io io.encodings.ascii io.encodings.string kernel locals make math -math.parser prettyprint sequences ; +math.parser sequences ; IN: images.ppm SINGLETON: ppm-image diff --git a/basis/images/tiff/tiff.factor b/basis/images/tiff/tiff.factor old mode 100644 new mode 100755 index 4a82545d79..a1880a3d3c --- a/basis/images/tiff/tiff.factor +++ b/basis/images/tiff/tiff.factor @@ -4,7 +4,7 @@ USING: accessors arrays assocs byte-arrays classes combinators 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 +math.bitwise math.order math.parser pack sequences strings math.vectors specialized-arrays locals images.loader ; FROM: alien.c-types => float ; From 421dc67be498174dba031a5708177db9efc08773 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 4 May 2010 03:41:47 -0400 Subject: [PATCH 17/24] tools.deploy.shaker: fix debugger stripping --- basis/tools/deploy/shaker/strip-debugger.factor | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/basis/tools/deploy/shaker/strip-debugger.factor b/basis/tools/deploy/shaker/strip-debugger.factor index 5faeab0e2d..121891b563 100644 --- a/basis/tools/deploy/shaker/strip-debugger.factor +++ b/basis/tools/deploy/shaker/strip-debugger.factor @@ -1,4 +1,5 @@ -USING: compiler.units words vocabs kernel threads.private ; +USING: compiler.units continuations kernel namespaces +threads.private words vocabs tools.deploy.shaker ; IN: debugger : error. ( error -- ) original-error get die-with2 ; From 43f7c4f2da12d655be4de6bfb67ec91f8e9b298b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 4 May 2010 04:28:58 -0400 Subject: [PATCH 18/24] Update cleanup list so that Windows binary packages won't include various crap emitted by Windows SDK --- build-support/cleanup | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/build-support/cleanup b/build-support/cleanup index 06cb09a4dd..b52a942eb1 100644 --- a/build-support/cleanup +++ b/build-support/cleanup @@ -8,3 +8,9 @@ Nmakefile unmaintained build-support images +factor.dll.exp +factor.dll.lib +factor.exp +factor.lib +libfactor-ffi-test.exp +libfactor-ffi-test.lib From aaa4c70b0167b8d9010662bd4a61e92f992bbf4a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 4 May 2010 04:54:48 -0500 Subject: [PATCH 19/24] windows.directx.dinput: factor out a code snippet into a word instead of repeating it many times in macro expansion, reducing compiled code size --- basis/windows/directx/dinput/constants/constants.factor | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/basis/windows/directx/dinput/constants/constants.factor b/basis/windows/directx/dinput/constants/constants.factor index 98ea261d38..c77364ccde 100755 --- a/basis/windows/directx/dinput/constants/constants.factor +++ b/basis/windows/directx/dinput/constants/constants.factor @@ -56,14 +56,17 @@ M: array array-base-type first ; [ first dup word? [ '[ _ get ] ] [ drop [ f ] ] if ] } cleave [ DIOBJECTDATAFORMAT ] dip - '[ _ clone @ >>pguid ] ; + curry ; + +: set-DIOBJECTDATAFORMAT ( array struct pguid n -- array ) + [ [ clone ] dip >>pguid ] dip pick set-nth ; :: make-DIOBJECTDATAFORMAT-array-quot ( struct array -- quot ) array length '[ _ malloc-DIOBJECTDATAFORMAT-array ] array [| args i | struct args -quot - i '[ _ pick set-nth ] compose compose - ] each-index ; + i '[ @ _ set-DIOBJECTDATAFORMAT ] + ] map-index [ ] join compose ; >> From fec408260ee02e246f0c4438bbd6b94cb9fdd055 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 4 May 2010 06:52:12 -0400 Subject: [PATCH 20/24] vm: tweak inline_gc() for PowerPC --- basis/cpu/x86/x86.factor | 2 +- vm/gc.cpp | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/cpu/x86/x86.factor b/basis/cpu/x86/x86.factor index d4a3be49b6..aa802c76fc 100644 --- a/basis/cpu/x86/x86.factor +++ b/basis/cpu/x86/x86.factor @@ -45,7 +45,7 @@ HOOK: extra-stack-space cpu ( stack-frame -- n ) : param@ ( n -- op ) reserved-stack-space + stack@ ; : gc-root-offsets ( seq -- seq' ) - [ n>> spill-offset special-offset ] map f like ; + [ n>> spill-offset special-offset cell + ] map f like ; : decr-stack-reg ( n -- ) dup 0 = [ drop ] [ stack-reg swap SUB ] if ; diff --git a/vm/gc.cpp b/vm/gc.cpp index 257a2a556c..ed36aff563 100755 --- a/vm/gc.cpp +++ b/vm/gc.cpp @@ -217,7 +217,7 @@ void factor_vm::primitive_compact_gc() void factor_vm::inline_gc(cell gc_roots_) { - cell stack_pointer = (cell)ctx->callstack_top + sizeof(cell); + cell stack_pointer = (cell)ctx->callstack_top; if(to_boolean(gc_roots_)) { From 572d7f77f86cc0c57509e0f2611cd8b450df62ca Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 4 May 2010 05:46:21 -0500 Subject: [PATCH 21/24] compiler.cfg.value-numbering: don't use complex addressing modes unless architecture supports it --- .../cfg/value-numbering/alien/alien.factor | 19 ++-- .../value-numbering-tests.factor | 92 +++++++++++++------ 2 files changed, 77 insertions(+), 34 deletions(-) diff --git a/basis/compiler/cfg/value-numbering/alien/alien.factor b/basis/compiler/cfg/value-numbering/alien/alien.factor index 190d911ad5..58674602d9 100644 --- a/basis/compiler/cfg/value-numbering/alien/alien.factor +++ b/basis/compiler/cfg/value-numbering/alien/alien.factor @@ -70,7 +70,10 @@ M: ##unbox-alien rewrite rewrite-unbox-any-c-ptr ; ! construct a new ##load-memory or ##store-memory with the ! ##add's operand as the displacement : fuse-displacement? ( insn -- ? ) - base>> vreg>insn ##add? ; + { + [ offset>> 0 = complex-addressing? or ] + [ base>> vreg>insn ##add? ] + } 1&& ; GENERIC: alien-insn-value ( insn -- value ) @@ -106,12 +109,14 @@ M: ##store-memory-imm new-alien-insn drop \ ##store-memory new-insn ; [ >>displacement ] [ >>scale ] bi* ; : rewrite-memory-op ( insn -- insn/f ) - { - { [ dup fuse-base-offset? ] [ fuse-base-offset ] } - { [ dup fuse-displacement-offset? ] [ fuse-displacement-offset ] } - { [ dup fuse-scale? ] [ fuse-scale ] } - [ drop f ] - } cond ; + complex-addressing? [ + { + { [ dup fuse-base-offset? ] [ fuse-base-offset ] } + { [ dup fuse-displacement-offset? ] [ fuse-displacement-offset ] } + { [ dup fuse-scale? ] [ fuse-scale ] } + [ drop f ] + } cond + ] [ drop f ] if ; : rewrite-memory-imm-op ( insn -- insn/f ) { diff --git a/basis/compiler/cfg/value-numbering/value-numbering-tests.factor b/basis/compiler/cfg/value-numbering/value-numbering-tests.factor index 3be4e584fb..00d8652279 100644 --- a/basis/compiler/cfg/value-numbering/value-numbering-tests.factor +++ b/basis/compiler/cfg/value-numbering/value-numbering-tests.factor @@ -2576,7 +2576,8 @@ cpu x86? [ } value-numbering-step ] unit-test -! Base offset fusion on ##load/store-memory +! Base offset fusion on ##load/store-memory -- only on x86 +cpu x86? [ V{ T{ ##peek f 0 D 0 } @@ -2586,7 +2587,18 @@ cpu x86? [ T{ ##add-imm f 4 2 31337 } T{ ##load-memory f 5 2 3 0 31337 int-rep c:uchar } } -] [ +] +[ + V{ + T{ ##peek f 0 D 0 } + T{ ##peek f 1 D 1 } + T{ ##tagged>integer f 2 0 } + T{ ##tagged>integer f 3 1 } + T{ ##add-imm f 4 2 31337 } + T{ ##load-memory f 5 4 3 0 0 int-rep c:uchar } + } +] ? +[ V{ T{ ##peek f 0 D 0 } T{ ##peek f 1 D 1 } @@ -2597,7 +2609,8 @@ cpu x86? [ } value-numbering-step ] unit-test -! Displacement offset fusion on ##load/store-memory +! Displacement offset fusion on ##load/store-memory -- only on x86 +cpu x86? [ V{ T{ ##peek f 0 D 0 } @@ -2607,7 +2620,18 @@ cpu x86? [ T{ ##add-imm f 4 3 31337 } T{ ##load-memory f 5 2 3 0 31338 int-rep c:uchar } } -] [ +] +[ + V{ + T{ ##peek f 0 D 0 } + T{ ##peek f 1 D 1 } + T{ ##tagged>integer f 2 0 } + T{ ##tagged>integer f 3 1 } + T{ ##add-imm f 4 3 31337 } + T{ ##load-memory f 5 2 4 0 1 int-rep c:uchar } + } +] ? +[ V{ T{ ##peek f 0 D 0 } T{ ##peek f 1 D 1 } @@ -2632,6 +2656,7 @@ cpu x86? [ ] unit-test ! Scale fusion on ##load/store-memory +cpu x86? [ V{ T{ ##peek f 0 D 0 } @@ -2641,7 +2666,18 @@ cpu x86? [ T{ ##shl-imm f 4 3 2 } T{ ##load-memory f 5 2 3 2 0 int-rep c:uchar } } -] [ +] +[ + V{ + T{ ##peek f 0 D 0 } + T{ ##peek f 1 D 1 } + T{ ##tagged>integer f 2 0 } + T{ ##tagged>integer f 3 1 } + T{ ##shl-imm f 4 3 2 } + T{ ##load-memory f 5 2 4 0 0 int-rep c:uchar } + } +] ? +[ V{ T{ ##peek f 0 D 0 } T{ ##peek f 1 D 1 } @@ -2652,26 +2688,28 @@ cpu x86? [ } value-numbering-step ] unit-test -! Don't do scale fusion if there's already a scale -[ ] [ - V{ - T{ ##peek f 0 D 0 } - T{ ##peek f 1 D 1 } - T{ ##tagged>integer f 2 0 } - T{ ##tagged>integer f 3 1 } - T{ ##shl-imm f 4 3 2 } - T{ ##load-memory f 5 2 4 1 0 int-rep c:uchar } - } dup value-numbering-step assert= -] unit-test +cpu x86? [ + ! Don't do scale fusion if there's already a scale + [ ] [ + V{ + T{ ##peek f 0 D 0 } + T{ ##peek f 1 D 1 } + T{ ##tagged>integer f 2 0 } + T{ ##tagged>integer f 3 1 } + T{ ##shl-imm f 4 3 2 } + T{ ##load-memory f 5 2 4 1 0 int-rep c:uchar } + } dup value-numbering-step assert= + ] unit-test -! Don't do scale fusion if the scale factor is out of range -[ ] [ - V{ - T{ ##peek f 0 D 0 } - T{ ##peek f 1 D 1 } - T{ ##tagged>integer f 2 0 } - T{ ##tagged>integer f 3 1 } - T{ ##shl-imm f 4 3 4 } - T{ ##load-memory f 5 2 4 0 0 int-rep c:uchar } - } dup value-numbering-step assert= -] unit-test + ! Don't do scale fusion if the scale factor is out of range + [ ] [ + V{ + T{ ##peek f 0 D 0 } + T{ ##peek f 1 D 1 } + T{ ##tagged>integer f 2 0 } + T{ ##tagged>integer f 3 1 } + T{ ##shl-imm f 4 3 4 } + T{ ##load-memory f 5 2 4 0 0 int-rep c:uchar } + } dup value-numbering-step assert= + ] unit-test +] when From 035a2e9b63eaba084e1da4f3a43e67eaf591e3c0 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 4 May 2010 05:46:45 -0500 Subject: [PATCH 22/24] compiler: more tests --- basis/compiler/tests/float.factor | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/basis/compiler/tests/float.factor b/basis/compiler/tests/float.factor index d55fe2b769..9685870936 100644 --- a/basis/compiler/tests/float.factor +++ b/basis/compiler/tests/float.factor @@ -121,3 +121,13 @@ IN: compiler.tests.float float-array{ 1 2 3 4 } [ { float-array } declare [ dup * ] [ + ] map-reduce ] compile-call ] unit-test + +[ 4.5 ] [ + float-array{ 1.0 3.5 } + [ { float-array } declare 0.0 [ + ] reduce ] compile-call +] unit-test + +[ float-array{ 2.0 4.5 } ] [ + float-array{ 1.0 3.5 } + [ { float-array } declare [ 1 + ] map ] compile-call +] unit-test From 92a4b5ec7ba91877c9f690b19d1108f1b71cff78 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 4 May 2010 05:47:21 -0500 Subject: [PATCH 23/24] cpu.ppc.assembler: new opcodes: LFDUX LFDX LFSUX LFSX STFDUX STFDX STFSUX STFSX --- basis/cpu/ppc/assembler/assembler-tests.factor | 8 ++++++++ basis/cpu/ppc/assembler/assembler.factor | 8 ++++++++ 2 files changed, 16 insertions(+) diff --git a/basis/cpu/ppc/assembler/assembler-tests.factor b/basis/cpu/ppc/assembler/assembler-tests.factor index 8e412c4c83..a30556444e 100644 --- a/basis/cpu/ppc/assembler/assembler-tests.factor +++ b/basis/cpu/ppc/assembler/assembler-tests.factor @@ -72,6 +72,14 @@ HEX{ 7c 41 1a 2e } [ 1 2 3 LHZX ] test-assembler HEX{ 7c 41 1a 6e } [ 1 2 3 LHZUX ] test-assembler HEX{ 7c 41 18 2e } [ 1 2 3 LWZX ] test-assembler HEX{ 7c 41 18 6e } [ 1 2 3 LWZUX ] test-assembler +HEX{ 7c 41 1c 2e } [ 1 2 3 LFSX ] test-assembler +HEX{ 7c 41 1c 6e } [ 1 2 3 LFSUX ] test-assembler +HEX{ 7c 41 1c ae } [ 1 2 3 LFDX ] test-assembler +HEX{ 7c 41 1c ee } [ 1 2 3 LFDUX ] test-assembler +HEX{ 7c 41 1d 2e } [ 1 2 3 STFSX ] test-assembler +HEX{ 7c 41 1d 6e } [ 1 2 3 STFSUX ] test-assembler +HEX{ 7c 41 1d ae } [ 1 2 3 STFDX ] test-assembler +HEX{ 7c 41 1d ee } [ 1 2 3 STFDUX ] test-assembler HEX{ 48 00 00 01 } [ 1 B ] test-assembler HEX{ 48 00 00 01 } [ 1 BL ] test-assembler HEX{ 41 80 00 04 } [ 1 BLT ] test-assembler diff --git a/basis/cpu/ppc/assembler/assembler.factor b/basis/cpu/ppc/assembler/assembler.factor index ca626a638e..30beabc09c 100644 --- a/basis/cpu/ppc/assembler/assembler.factor +++ b/basis/cpu/ppc/assembler/assembler.factor @@ -66,6 +66,10 @@ X: FCMPO 0 32 63 X: FCMPU 0 0 63 X: LBZUX 0 119 31 X: LBZX 0 87 31 +X: LFDUX 0 631 31 +X: LFDX 0 599 31 +X: LFSUX 0 567 31 +X: LFSX 0 535 31 X: LHAUX 0 375 31 X: LHAX 0 343 31 X: LHZUX 0 311 31 @@ -89,6 +93,10 @@ X: SRW 0 536 31 X: SRW. 1 536 31 X: STBUX 0 247 31 X: STBX 0 215 31 +X: STFDUX 0 759 31 +X: STFDX 0 727 31 +X: STFSUX 0 695 31 +X: STFSX 0 663 31 X: STHUX 0 439 31 X: STHX 0 407 31 X: STWUX 0 183 31 From f3ea9288df7b8082d33ef8b866029563253e87e5 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 4 May 2010 05:51:54 -0500 Subject: [PATCH 24/24] cpu.ppc: updating optimizing compiler backend for recent changes --- basis/cpu/ppc/ppc.factor | 71 +++++++++++++++++++++++++++++++++------- 1 file changed, 59 insertions(+), 12 deletions(-) diff --git a/basis/cpu/ppc/ppc.factor b/basis/cpu/ppc/ppc.factor index e07ee9d490..d0571337c2 100644 --- a/basis/cpu/ppc/ppc.factor +++ b/basis/cpu/ppc/ppc.factor @@ -46,6 +46,10 @@ M: ppc machine-registers CONSTANT: scratch-reg 30 CONSTANT: fp-scratch-reg 30 +M: ppc complex-addressing? f ; + +M: ppc fused-unboxing? f ; + M: ppc %load-immediate ( reg n -- ) swap LOAD ; M: ppc %load-reference ( reg obj -- ) @@ -139,9 +143,12 @@ M:: ppc %dispatch ( src temp -- ) temp MTCTR BCTR ; -M: ppc %slot ( dst obj slot -- ) swapd LWZX ; +: (%slot) ( dst obj slot scale tag -- obj dst slot ) + [ 0 assert= ] bi@ swapd ; + +M: ppc %slot ( dst obj slot scale tag -- ) (%slot) LWZX ; M: ppc %slot-imm ( dst obj slot tag -- ) slot-offset LWZ ; -M: ppc %set-slot ( src obj slot -- ) swapd STWX ; +M: ppc %set-slot ( src obj slot scale tag -- ) (%slot) STWX ; M: ppc %set-slot-imm ( src obj slot tag -- ) slot-offset STW ; M: ppc %add ADD ; @@ -357,7 +364,7 @@ M:: ppc %box-displaced-alien ( dst displacement base temp base-class -- ) dst displacement base temp { - { [ base-class \ f class<= ] [ 2drop %box-displaced-alien/f ] } + { [ base-class \ f class<= ] [ drop %box-displaced-alien/f ] } { [ base-class \ alien class<= ] [ %box-displaced-alien/alien ] } { [ base-class \ byte-array class<= ] [ %box-displaced-alien/byte-array ] } [ %box-displaced-alien/dynamic ] @@ -366,7 +373,7 @@ M:: ppc %box-displaced-alien ( dst displacement base temp base-class -- ) "end" resolve-label ] with-scope ; -M:: ppc %load-memory-imm ( dst base offset rep c-type -- ) +M: ppc %load-memory-imm ( dst base offset rep c-type -- ) [ { { c:char [ [ dup ] 2dip LBZ dup EXTSB ] } @@ -382,7 +389,26 @@ M:: ppc %load-memory-imm ( dst base offset rep c-type -- ) } case ] ?if ; -M:: ppc %store-memory-imm ( src base offset rep c-type -- ) +: (%memory) ( val base displacement scale offset rep c-type -- base val displacement rep c-type ) + [ [ 0 assert= ] bi@ swapd ] 2dip ; inline + +M: ppc %load-memory ( dst base displacement scale offset rep c-type -- ) + (%memory) [ + { + { c:char [ [ LBZX ] [ drop dup EXTSB ] 2bi ] } + { c:uchar [ LBZX ] } + { c:short [ LHAX ] } + { c:ushort [ LHZX ] } + } case + ] [ + { + { int-rep [ LWZX ] } + { float-rep [ LFSX ] } + { double-rep [ LFDX ] } + } case + ] ?if ; + +M: ppc %store-memory-imm ( src base offset rep c-type -- ) [ { { c:char [ STB ] } @@ -398,6 +424,22 @@ M:: ppc %store-memory-imm ( src base offset rep c-type -- ) } case ] ?if ; +M: ppc %store-memory ( src base displacement scale offset rep c-type -- ) + (%memory) [ + { + { c:char [ STBX ] } + { c:uchar [ STBX ] } + { c:short [ STHX ] } + { c:ushort [ STHX ] } + } case + ] [ + { + { int-rep [ STWX ] } + { float-rep [ STFSX ] } + { double-rep [ STFDX ] } + } case + ] ?if ; + : load-zone-ptr ( reg -- ) vm-reg "nursery" vm-field-offset ADDI ; @@ -440,18 +482,18 @@ M:: ppc %allot ( dst size class nursery-ptr -- ) temp2 load-decks-offset temp1 scratch-reg temp2 STBX ; -M:: ppc %write-barrier ( src slot temp1 temp2 -- ) +M:: ppc %write-barrier ( src slot scale tag temp1 temp2 -- ) + scale 0 assert= tag 0 assert= temp1 src slot ADD temp1 temp2 (%write-barrier) ; -M:: ppc %write-barrier-imm ( src slot temp1 temp2 -- ) - temp1 src slot ADDI +M:: ppc %write-barrier-imm ( src slot tag temp1 temp2 -- ) + temp1 src slot tag slot-offset ADDI temp1 temp2 (%write-barrier) ; M:: ppc %check-nursery-branch ( label size cc temp1 temp2 -- ) - temp2 load-zone-ptr - temp1 temp2 0 LWZ - temp2 temp2 2 cells LWZ + temp1 vm-reg "nursery" vm-field-offset LWZ + temp2 vm-reg "nursery" vm-field-offset 2 cells + LWZ temp1 temp1 size ADDI ! is here >= end? temp1 0 temp2 CMP @@ -460,8 +502,11 @@ M:: ppc %check-nursery-branch ( label size cc temp1 temp2 -- ) { cc/<= [ label BGT ] } } case ; +: gc-root-offsets ( seq -- seq' ) + [ n>> spill@ ] map f like ; + M: ppc %call-gc ( gc-roots -- ) - 3 swap %load-reference + 3 swap gc-root-offsets %load-reference 4 %load-vm-addr "inline_gc" f %alien-invoke ; @@ -586,6 +631,7 @@ M:: ppc %compare-float-unordered-branch ( label src1 src2 cc -- ) : load-from-frame ( dst n rep -- ) { { int-rep [ [ 1 ] dip LWZ ] } + { tagged-rep [ [ 1 ] dip LWZ ] } { float-rep [ [ 1 ] dip LFS ] } { double-rep [ [ 1 ] dip LFD ] } { stack-params [ [ 0 1 ] dip LWZ [ 0 1 ] dip param@ STW ] } @@ -597,6 +643,7 @@ M:: ppc %compare-float-unordered-branch ( label src1 src2 cc -- ) : store-to-frame ( src n rep -- ) { { int-rep [ [ 1 ] dip STW ] } + { tagged-rep [ [ 1 ] dip STW ] } { float-rep [ [ 1 ] dip STFS ] } { double-rep [ [ 1 ] dip STFD ] } { stack-params [ [ [ 0 ] dip next-param@ LWZ 0 1 ] dip STW ] }