From 606b9b878fd27abe1bedec5dc8d06fea27fa3473 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 7 Aug 2005 04:00:57 +0000 Subject: [PATCH] dataflow optimizer work --- library/bootstrap/boot-stage1.factor | 10 +- library/bootstrap/boot-stage3.factor | 2 - library/bootstrap/image.factor | 98 +++++------ library/collections/hashtables.factor | 4 +- library/collections/sequences.factor | 2 +- library/collections/strings-epilogue.factor | 9 +- library/collections/vectors-epilogue.factor | 5 +- library/combinators.factor | 68 -------- library/compiler/intrinsics.factor | 4 +- library/compiler/linearizer.factor | 2 +- library/generic/tuple.factor | 2 +- library/inference/branches.factor | 15 +- library/inference/class-infer.factor | 4 +- library/inference/dataflow.factor | 94 ++++++++++- library/inference/inference.factor | 52 ------ library/inference/inline-methods.factor | 17 +- library/inference/kill-literals.factor | 155 +++++++++++++++++ library/inference/known-words.factor | 91 ++++++++++ library/inference/optimizer.factor | 174 ++------------------ library/inference/recursive-values.factor | 4 +- library/inference/stack.factor | 39 ----- library/inference/words.factor | 59 ++----- library/kernel.factor | 85 +++++++++- library/stack.factor | 22 --- library/syntax/prettyprint.factor | 17 +- library/test/compiler/optimizer.factor | 14 +- library/test/hashtables.factor | 2 +- library/test/sequences.factor | 4 - library/test/tuple.factor | 5 +- 29 files changed, 551 insertions(+), 508 deletions(-) delete mode 100644 library/combinators.factor create mode 100644 library/inference/kill-literals.factor create mode 100644 library/inference/known-words.factor delete mode 100644 library/inference/stack.factor delete mode 100644 library/stack.factor diff --git a/library/bootstrap/boot-stage1.factor b/library/bootstrap/boot-stage1.factor index 9fb4e7ed36..2608aab543 100644 --- a/library/bootstrap/boot-stage1.factor +++ b/library/bootstrap/boot-stage1.factor @@ -15,14 +15,11 @@ parser prettyprint sequences io vectors words ; { "/version.factor" - "/library/stack.factor" - "/library/combinators.factor" + "/library/kernel.factor" "/library/collections/sequences.factor" "/library/collections/arrays.factor" - "/library/kernel.factor" - "/library/math/math.factor" "/library/math/integer.factor" "/library/math/ratio.factor" @@ -38,9 +35,9 @@ parser prettyprint sequences io vectors words ; "/library/collections/sbuf.factor" "/library/collections/assoc.factor" "/library/collections/lists.factor" + "/library/collections/vectors-epilogue.factor" "/library/collections/hashtables.factor" "/library/collections/namespaces.factor" - "/library/collections/vectors-epilogue.factor" "/library/collections/sequence-eq.factor" "/library/collections/slicing.factor" "/library/collections/strings-epilogue.factor" @@ -87,12 +84,13 @@ parser prettyprint sequences io vectors words ; "/library/inference/inference.factor" "/library/inference/branches.factor" "/library/inference/words.factor" - "/library/inference/stack.factor" "/library/inference/recursive-values.factor" "/library/inference/class-infer.factor" + "/library/inference/kill-literals.factor" "/library/inference/optimizer.factor" "/library/inference/inline-methods.factor" "/library/inference/print-dataflow.factor" + "/library/inference/known-words.factor" "/library/compiler/assembler.factor" "/library/compiler/relocate.factor" diff --git a/library/bootstrap/boot-stage3.factor b/library/bootstrap/boot-stage3.factor index 8e2294d53f..7b3d2703b8 100644 --- a/library/bootstrap/boot-stage3.factor +++ b/library/bootstrap/boot-stage3.factor @@ -32,8 +32,6 @@ init-assembler : compile? "compile" get supported-cpu? and ; -"library/inference/branches.factor" run-file - compile? [ \ car compile \ * compile diff --git a/library/bootstrap/image.factor b/library/bootstrap/image.factor index 4691d947b0..c20df27572 100644 --- a/library/bootstrap/image.factor +++ b/library/bootstrap/image.factor @@ -22,9 +22,18 @@ strings vectors words ; ! The image being constructed; a vector of word-size integers SYMBOL: image +! Object cache +SYMBOL: objects + ! Boot quotation, set by boot.factor SYMBOL: boot-quot +! Image output format +SYMBOL: big-endian +SYMBOL: 64-bits + +SYMBOL: t-object + : emit ( cell -- ) image get push ; : emit-seq ( seq -- ) image get swap nappend ; @@ -36,8 +45,8 @@ SYMBOL: boot-quot : image-magic HEX: 0f0e0d0c ; : image-version 0 ; -: cell "64-bits" get 8 4 ? ; -: char "64-bits" get 4 2 ? ; +: cell 64-bits get 8 4 ? ; +: char 64-bits get 4 2 ? ; : untag ( cell tag -- ) tag-mask bitnot bitand ; : tag ( cell -- tag ) tag-mask bitand ; @@ -56,12 +65,7 @@ SYMBOL: boot-quot ( Image header ) -: base - #! We relocate the image to after the header, and leaving - #! some empty cells. This lets us differentiate an F pointer - #! (0/tag 3) from a pointer to the first object in the - #! image. - 64 cell * ; +: base 1024 ; : header ( -- ) image-magic emit @@ -110,11 +114,11 @@ M: bignum ' ( bignum -- tagged ) #! This can only emit 0, -1 and 1. bignum-tag here-as >r bignum-tag >header emit - [ + {{ [[ 0 [ 1 0 ] ]] [[ -1 [ 2 1 1 ] ]] [[ 1 [ 2 0 1 ] ]] - ] assoc unswons emit-fixnum [ emit ] each align-here r> ; + }} hash unswons emit-fixnum emit-seq align-here r> ; ( Special objects ) @@ -122,11 +126,11 @@ M: bignum ' ( bignum -- tagged ) : t, object-tag here-as - dup t-offset fixup "t" set + dup t-offset fixup t-object set t-type >header emit 0 ' emit ; -M: t ' ( obj -- ptr ) drop "t" get ; +M: t ' ( obj -- ptr ) drop t-object get ; M: f ' ( obj -- ptr ) #! f is #define F RETAG(0,OBJECT_TYPE) drop object-tag ; @@ -144,16 +148,15 @@ M: f ' ( obj -- ptr ) ( Words ) : emit-word ( word -- ) - [ - word-type >header , - dup hashcode fixnum-tag immediate , - 0 , - dup word-primitive , - dup word-def ' , - dup word-props ' , - ] make-vector - swap object-tag here-as swap "objects" get set-hash - [ emit ] each ; + dup word-props ' >r + dup word-def ' >r + object-tag here-as over objects get set-hash + word-type >header emit + dup hashcode emit-fixnum + 0 emit + word-primitive emit + r> emit + r> emit ; : word-error ( word msg -- ) [ % dup word-vocabulary % " " % word-name % ] make-string @@ -164,17 +167,16 @@ M: f ' ( obj -- ptr ) dup dup word-name swap word-vocabulary unit search [ ] [ dup "Missing DEFER: " word-error ] ?ifte ; -: pooled-object ( object -- ptr ) "objects" get hash ; +: pooled-object ( object -- ptr ) objects get hash ; : fixup-word ( word -- offset ) - dup pooled-object - [ ] [ "Not in image: " word-error ] ?ifte ; + transfer-word dup pooled-object dup + [ nip ] [ "Not in image: " word-error ] ifte ; : fixup-words ( -- ) image get [ dup word? [ fixup-word ] when ] nmap ; -M: word ' ( word -- pointer ) - transfer-word dup pooled-object [ ] [ ] ?ifte ; +M: word ' ( word -- pointer ) ; ( Wrappers ) @@ -194,7 +196,7 @@ M: cons ' ( c -- tagged ) ( Strings ) : emit-chars ( seq -- ) - "big-endian" get [ [ reverse ] map ] unless + big-endian get [ [ reverse ] map ] unless [ 0 [ swap 16 shift + ] reduce emit ] each ; : pack-string ( string -- seq ) @@ -211,7 +213,7 @@ M: cons ' ( c -- tagged ) M: string ' ( string -- pointer ) #! We pool strings so that each string is only written once #! to the image - "objects" get [ emit-string ] cache ; + objects get [ emit-string ] cache ; ( Arrays and vectors ) @@ -226,7 +228,7 @@ M: string ' ( string -- pointer ) M: tuple ' ( tuple -- pointer ) tuple-type emit-array ; -: emit-vector ( vector -- pointer ) +M: vector ' ( vector -- pointer ) dup array-type emit-array swap length object-tag here-as >r vector-type >header emit @@ -234,21 +236,17 @@ M: tuple ' ( tuple -- pointer ) emit ( array ptr ) align-here r> ; -M: vector ' ( vector -- pointer ) - emit-vector ; +( Hashes ) -: emit-hashtable ( hash -- pointer ) - dup buckets>list array-type emit-array - swap hash>alist length +M: hashtable ' ( hashtable -- pointer ) + dup buckets>vector array-type emit-array + swap hash-size object-tag here-as >r hashtable-type >header emit emit-fixnum ( length ) emit ( array ptr ) align-here r> ; -M: hashtable ' ( hashtable -- pointer ) - "objects" get [ emit-hashtable ] cache ; - ( End of the image ) : words, ( -- ) @@ -264,6 +262,8 @@ M: hashtable ' ( hashtable -- pointer ) : boot, ( quot -- ) boot-quot get swap append ' boot-quot-offset fixup ; +: heap-size image get length header-size - cell * ; + : end ( quot -- ) "Generating words..." print words, @@ -273,12 +273,12 @@ M: hashtable ' ( hashtable -- pointer ) boot, "Performing some word fixups..." print fixup-words - here base - heap-size-offset fixup ; + heap-size heap-size-offset fixup ; ( Image output ) : (write-image) ( image -- ) - "64-bits" get 8 4 ? swap "big-endian" get [ + 64-bits get 8 4 ? swap big-endian get [ [ swap >be write ] each-with ] [ [ swap >le write ] each-with @@ -291,8 +291,10 @@ M: hashtable ' ( hashtable -- pointer ) : with-minimal-image ( quot -- image ) [ 800000 image set - "objects" set + 20000 objects set call + "Image length: " write image get length . + "Object cache size: " write objects get hash-size . image get ] with-scope ; @@ -310,10 +312,10 @@ M: hashtable ' ( hashtable -- pointer ) swap write-image ; : make-images ( -- ) - "64-bits" off - "big-endian" off "boot.image.le32" make-image - "big-endian" on "boot.image.be32" make-image - "64-bits" on - "big-endian" off "boot.image.le64" make-image - "big-endian" on "boot.image.be64" make-image - "64-bits" off ; + 64-bits off + big-endian off "boot.image.le32" make-image + big-endian on "boot.image.be32" make-image + 64-bits on + big-endian off "boot.image.le64" make-image + big-endian on "boot.image.be64" make-image + 64-bits off ; diff --git a/library/collections/hashtables.factor b/library/collections/hashtables.factor index ec9978a12f..b88f970d56 100644 --- a/library/collections/hashtables.factor +++ b/library/collections/hashtables.factor @@ -113,8 +113,8 @@ IN: hashtables : hash-clear ( hash -- ) 0 over set-hash-size [ f -rot set-hash-bucket ] each-bucket ; -: buckets>list ( hash -- list ) - hash-array >list ; +: buckets>vector ( hash -- vector ) + hash-array >vector ; : alist>hash ( alist -- hash ) dup length 1 max swap diff --git a/library/collections/sequences.factor b/library/collections/sequences.factor index 0b8a03db54..adcc10bcf5 100644 --- a/library/collections/sequences.factor +++ b/library/collections/sequences.factor @@ -57,7 +57,7 @@ G: find* ( i seq quot -- i elt | quot: elt -- ? ) : push ( element sequence -- ) #! Push a value on the end of a sequence. - dup length swap set-nth ; + dup length swap set-nth ; inline : 2nth ( s s n -- x x ) tuck swap nth >r swap nth r> ; inline diff --git a/library/collections/strings-epilogue.factor b/library/collections/strings-epilogue.factor index 35d0ee0f5a..6c15b67457 100644 --- a/library/collections/strings-epilogue.factor +++ b/library/collections/strings-epilogue.factor @@ -4,9 +4,11 @@ IN: strings USING: generic kernel kernel-internals lists math namespaces sequences strings ; -: empty-sbuf ( len -- sbuf ) dup [ set-length ] keep ; +: empty-sbuf ( len -- sbuf ) + dup [ set-length ] keep ; inline -: fill ( count char -- string ) >string ; +: fill ( count char -- string ) + >string ; inline : padding ( string count char -- string ) >r swap length - dup 0 <= [ r> 2drop "" ] [ r> fill ] ifte ; @@ -19,7 +21,8 @@ sequences strings ; : ch>string ( ch -- str ) 1 [ push ] keep (sbuf>string) ; -: >sbuf ( seq -- sbuf ) dup length [ swap nappend ] keep ; +: >sbuf ( seq -- sbuf ) + dup length [ swap nappend ] keep ; inline M: object >string >sbuf (sbuf>string) ; diff --git a/library/collections/vectors-epilogue.factor b/library/collections/vectors-epilogue.factor index 09ff8d50a1..c6b216f46f 100644 --- a/library/collections/vectors-epilogue.factor +++ b/library/collections/vectors-epilogue.factor @@ -5,10 +5,11 @@ math-internals sequences ; IN: vectors -: empty-vector ( len -- vec ) dup [ set-length ] keep ; +: empty-vector ( len -- vec ) + dup [ set-length ] keep ; inline : >vector ( list -- vector ) - dup length [ swap nappend ] keep ; + dup length [ swap nappend ] keep ; inline M: object thaw >vector ; diff --git a/library/combinators.factor b/library/combinators.factor deleted file mode 100644 index ba462e4f19..0000000000 --- a/library/combinators.factor +++ /dev/null @@ -1,68 +0,0 @@ -! Copyright (C) 2003, 2005 Slava Pestov. -! See http://factor.sf.net/license.txt for BSD license. -IN: kernel -USING: words ; - -: slip ( quot x -- x | quot: -- ) - >r call r> ; inline - -: 2slip ( quot x y -- x y | quot: -- ) - >r >r call r> r> ; inline - -: keep ( x quot -- x | quot: x -- ) - over >r call r> ; inline - -: 2keep ( x y quot -- x y | quot: x y -- ) - over >r pick >r call r> r> ; inline - -: 3keep ( x y z quot -- x y z | quot: x y z -- ) - >r 3dup r> swap >r swap >r swap >r call r> r> r> ; inline - -: while ( quot generator -- ) - #! Keep applying the quotation to the value produced by - #! calling the generator until the generator returns f. - 2dup >r >r swap >r call dup [ - r> call r> r> while - ] [ - r> 2drop r> r> 2drop - ] ifte ; inline - -: ifte* ( cond true false -- | true: cond -- | false: -- ) - #! [ X ] [ Y ] ifte* ==> dup [ X ] [ drop Y ] ifte - pick [ drop call ] [ 2nip call ] ifte ; inline - -: ?ifte ( default cond true false -- ) - #! [ X ] [ Y ] ?ifte ==> dup [ nip X ] [ drop Y ] ifte - >r >r dup [ - nip r> r> drop call - ] [ - drop r> drop r> call - ] ifte ; inline - -: unless ( cond quot -- | quot: -- ) - #! Execute a quotation only when the condition is f. The - #! condition is popped off the stack. - [ ] swap ifte ; inline - -: unless* ( cond quot -- | quot: -- ) - #! If cond is f, pop it off the stack and evaluate the - #! quotation. Otherwise, leave cond on the stack. - over [ drop ] [ nip call ] ifte ; inline - -: when ( cond quot -- | quot: -- ) - #! Execute a quotation only when the condition is not f. The - #! condition is popped off the stack. - [ ] ifte ; inline - -: when* ( cond quot -- | quot: cond -- ) - #! If the condition is true, it is left on the stack, and - #! the quotation is evaluated. Otherwise, the condition is - #! popped off the stack. - dupd [ drop ] ifte ; inline - -: with ( obj quot elt -- obj quot ) - #! Utility word for each-with, map-with. - pick pick >r >r swap call r> r> ; inline - -: keep-datastack ( quot -- ) - datastack slip set-datastack drop ; diff --git a/library/compiler/intrinsics.factor b/library/compiler/intrinsics.factor index b524fc795a..59d5f381a5 100644 --- a/library/compiler/intrinsics.factor +++ b/library/compiler/intrinsics.factor @@ -72,7 +72,7 @@ sequences vectors words ; : typed-literal? ( node -- ? ) #! Output if the node's first input is well-typed, and the #! second is a literal. - dup node-peek safe-literal? swap node-peek-2 typed? and ; + dup node-peek literal? swap node-peek-2 typed? and ; \ slot [ dup typed-literal? [ @@ -154,7 +154,7 @@ sequences vectors words ; 0 0 %replace-d , ; inline : literal-fixnum? ( value -- ? ) - dup safe-literal? [ literal-value fixnum? ] [ drop f ] ifte ; + dup literal? [ literal-value fixnum? ] [ drop f ] ifte ; : binary-op-imm ( imm op -- ) 1 %dec-d , in-1 diff --git a/library/compiler/linearizer.factor b/library/compiler/linearizer.factor index 09160ad20a..f0b7b48997 100644 --- a/library/compiler/linearizer.factor +++ b/library/compiler/linearizer.factor @@ -58,7 +58,7 @@ M: object load-value ( vreg n value -- ) literal-value dup immediate? [ %immediate ] [ %indirect ] ifte , ; -M: safe-literal load-value ( vreg n value -- ) +M: literal load-value ( vreg n value -- ) nip push-literal ; : push-1 ( value -- ) 0 swap push-literal ; diff --git a/library/generic/tuple.factor b/library/generic/tuple.factor index 4e9622471f..c56271c9d0 100644 --- a/library/generic/tuple.factor +++ b/library/generic/tuple.factor @@ -87,7 +87,7 @@ BUILTIN: tuple 18 tuple? ; : (hash>quot) ( default hash -- quot ) [ \ dup , \ hashcode , dup bucket-count , \ rem , - buckets>list [ alist>quot ] map-with >vector , + buckets>vector [ alist>quot ] map-with , \ dispatch , ] make-list ; diff --git a/library/inference/branches.factor b/library/inference/branches.factor index 7ea1168160..170b0f5443 100644 --- a/library/inference/branches.factor +++ b/library/inference/branches.factor @@ -10,6 +10,9 @@ namespaces prettyprint sequences strings unparser vectors words ; dup max-length swap [ [ required-inputs ] keep append ] map-with ; +: unify-length ( seq seq -- seq ) + 2vector unify-lengths 2unseq ; + : unify-values ( seq -- value ) #! If all values in list are equal, return the value. #! Otherwise, unify. @@ -86,15 +89,3 @@ namespaces prettyprint sequences strings unparser vectors words ; #! base case to this stack effect and try again. [ >r (infer-branches) r> set-node-children ] keep node, #merge node, ; - -\ ifte [ - 2 #drop node, pop-d pop-d swap 2vector - #ifte pop-d drop infer-branches -] "infer" set-word-prop - -USE: kernel-internals - -\ dispatch [ - pop-literal nip [ ] map - #dispatch pop-d drop infer-branches -] "infer" set-word-prop diff --git a/library/inference/class-infer.factor b/library/inference/class-infer.factor index e9277055e6..d1e6eb27fb 100644 --- a/library/inference/class-infer.factor +++ b/library/inference/class-infer.factor @@ -115,9 +115,7 @@ M: #call infer-classes* ( node -- ) ] ifte ; M: #push infer-classes* ( node -- ) - node-out-d [ safe-literal? ] subset - dup [ literal-value ] map - swap assume-literals ; + node-out-d dup [ literal-value ] map swap assume-literals ; M: #ifte child-ties ( node -- seq ) node-in-d first dup general-t diff --git a/library/inference/dataflow.factor b/library/inference/dataflow.factor index efc4e9847e..965a1e03ad 100644 --- a/library/inference/dataflow.factor +++ b/library/inference/dataflow.factor @@ -4,6 +4,43 @@ IN: inference USING: generic interpreter kernel lists namespaces parser sequences vectors words ; +! Recursive state. An alist, mapping words to labels. +SYMBOL: recursive-state + +TUPLE: value recursion uid ; + +C: value ( -- value ) + gensym over set-value-uid + recursive-state get over set-value-recursion ; + +M: value = eq? ; + +TUPLE: computed ; + +C: computed ( -- value ) over set-delegate ; + +TUPLE: literal value ; + +C: literal ( obj -- value ) + over set-delegate + [ set-literal-value ] keep ; + +TUPLE: meet values ; + +C: meet ( values -- value ) + over set-delegate [ set-meet-values ] keep ; + +: value-refers? ( referee referrer -- ? ) + 2dup eq? [ + 2drop t + ] [ + dup meet? [ + meet-values [ value-refers? ] contains-with? + ] [ + 2drop f + ] ifte + ] ifte ; + ! The dataflow IR is the first of the two intermediate ! representations used by Factor. It annotates concatenative ! code with stack flow information and types. @@ -121,7 +158,8 @@ SYMBOL: current-node dup node-in-r % node-out-r % ] make-vector ; -: uses-value? ( value node -- ? ) node-values memq? ; +: uses-value? ( value node -- ? ) + node-values [ value-refers? ] contains-with? ; : last-node ( node -- last ) dup node-successor [ last-node ] [ ] ?ifte ; @@ -137,9 +175,6 @@ SYMBOL: current-node : drop-inputs ( node -- #drop ) node-in-d clone in-d-node <#drop> ; -! Recursive state. An alist, mapping words to labels. -SYMBOL: recursive-state - : each-node ( node quot -- ) over [ [ call ] 2keep swap @@ -151,3 +186,54 @@ SYMBOL: recursive-state : each-node-with ( obj node quot -- | quot: obj node -- ) swap [ with ] each-node 2drop ; inline + +SYMBOL: substituted + +DEFER: subst-value + +: subst-meet ( new old meet -- ) + #! We avoid mutating the same meet more than once, since + #! doing so can introduce cycles. + dup substituted get memq? [ + 3drop + ] [ + dup substituted get push meet-values subst-value + ] ifte ; + +: (subst-value) ( new old value -- value ) + 2dup eq? [ + 2drop + ] [ + dup meet? [ + pick over eq? [ + 2nip ! don't substitute a meet into itself + ] [ + [ subst-meet ] keep + ] ifte + ] [ + 2nip + ] ifte + ] ifte ; + +: subst-value ( new old seq -- ) + pick pick eq? over empty? or [ + 3drop + ] [ + [ >r 2dup r> (subst-value) ] nmap 2drop + ] ifte ; + +: (subst-values) ( newseq oldseq seq -- ) + #! Mutates seq. + -rot [ pick subst-value ] 2each drop ; + +: subst-values ( new old node -- ) + #! Mutates the node. + [ + 10 substituted set [ + 3dup node-in-d (subst-values) + 3dup node-in-r (subst-values) + 3dup node-out-d (subst-values) + 3dup node-out-r (subst-values) + drop + ] each-node 2drop + ] with-scope ; diff --git a/library/inference/inference.factor b/library/inference/inference.factor index 1dd969887d..a1a9c16360 100644 --- a/library/inference/inference.factor +++ b/library/inference/inference.factor @@ -19,24 +19,6 @@ M: inference-error error. ( error -- ) "! Recursive state:" print inference-error-rstate [.] ; -TUPLE: value recursion safe? ; - -C: value ( -- value ) - t over set-value-safe? - recursive-state get over set-value-recursion ; - -M: value = eq? ; - -TUPLE: computed ; - -C: computed ( -- value ) over set-delegate ; - -TUPLE: literal value ; - -C: literal ( obj -- value ) - over set-delegate - [ set-literal-value ] keep ; - M: value literal-value ( value -- ) { "A literal value was expected where a computed value was found.\n" @@ -46,40 +28,6 @@ M: value literal-value ( value -- ) "is marked 'inline'. See the handbook for details." } concat inference-error ; -TUPLE: meet values ; - -C: meet ( values -- value ) - over set-delegate [ set-meet-values ] keep ; - -PREDICATE: tuple safe-literal ( obj -- ? ) - dup literal? [ value-safe? ] [ drop f ] ifte ; - -DEFER: subst-value - -: (subst-value) ( new old value -- value ) - dup meet? [ - [ meet-values subst-value ] keep - ] [ - tuck eq? [ drop ] [ nip ] ifte - ] ifte ; - -: subst-value ( new old seq -- ) - [ >r 2dup r> (subst-value) ] nmap 2drop ; - -: (subst-values) ( newseq oldseq seq -- ) - #! Mutates seq. - -rot [ pick subst-value ] 2each drop ; - -: subst-values ( new old node -- ) - #! Mutates the node. - [ - 3dup node-in-d (subst-values) - 3dup node-in-r (subst-values) - 3dup node-out-d (subst-values) - 3dup node-out-r (subst-values) - drop - ] each-node 2drop ; - ! Word properties that affect inference: ! - infer-effect -- must be set. controls number of inputs ! expected, and number of outputs produced. diff --git a/library/inference/inline-methods.factor b/library/inference/inline-methods.factor index 7f7b6c23c2..c07da751c1 100644 --- a/library/inference/inline-methods.factor +++ b/library/inference/inline-methods.factor @@ -19,17 +19,12 @@ M: simple-generic dispatching-values drop node-in-d peek 1vector ; M: 2generic dispatching-values drop node-in-d 2 swap tail* ; -: safe-node-classes ( node seq -- seq ) - >r node-classes r> [ - dup value-safe? [ - swap ?hash [ object ] unless* - ] [ - 2drop object - ] ifte - ] map-with ; +: node-classes* ( node seq -- seq ) + >r node-classes r> + [ swap ?hash [ object ] unless* ] map-with ; : dispatching-classes ( node -- seq ) - dup dup node-param dispatching-values safe-node-classes ; + dup dup node-param dispatching-values node-classes* ; : inlining-class ( #call -- class ) #! If the generic dispatch can be eliminated, return the @@ -76,7 +71,7 @@ M: 2generic dispatching-values drop node-in-d 2 swap tail* ; : optimize-predicate? ( #call -- ? ) dup node-param "predicating" word-prop dup [ - >r dup node-in-d safe-node-classes first r> related? + >r dup node-in-d node-classes* first r> related? ] [ 2drop f ] ifte ; @@ -92,7 +87,7 @@ M: 2generic dispatching-values drop node-in-d 2 swap tail* ; : optimize-predicate ( #call -- node ) dup node-param "predicating" word-prop >r - dup dup node-in-d safe-node-classes first r> class< + dup dup node-in-d node-classes* first r> class< inline-literal ; M: #call optimize-node* ( node -- node/t ) diff --git a/library/inference/kill-literals.factor b/library/inference/kill-literals.factor new file mode 100644 index 0000000000..cbf5997a56 --- /dev/null +++ b/library/inference/kill-literals.factor @@ -0,0 +1,155 @@ +! Copyright (C) 2004, 2005 Slava Pestov. +! See http://factor.sf.net/license.txt for BSD license. +IN: inference +USING: generic hashtables inference kernel lists +matrices namespaces sequences vectors ; + +GENERIC: literals* ( node -- ) + +: literals ( node -- seq ) + [ [ literals* ] each-node ] make-vector ; + +GENERIC: can-kill* ( literal node -- ? ) + +: can-kill? ( literal node -- ? ) + #! Return false if the literal appears in any node in the + #! list. + dup [ + 2dup can-kill* + [ node-successor can-kill? ] [ 2drop f ] ifte + ] [ + 2drop t + ] ifte ; + +: kill-set ( node -- list ) + #! Push a list of literals that may be killed in the IR. + dup literals [ swap can-kill? ] subset-with ; + +: remove-values ( values node -- ) + 2dup [ node-in-d seq-diff ] keep set-node-in-d + 2dup [ node-out-d seq-diff ] keep set-node-out-d + 2dup [ node-in-r seq-diff ] keep set-node-in-r + [ node-out-r seq-diff ] keep set-node-out-r ; + +GENERIC: kill-node* ( literals node -- ) + +M: node kill-node* ( literals node -- ) 2drop ; + +: kill-node ( literals node -- ) + [ 2dup kill-node* remove-values ] each-node-with ; + +! Generic nodes +M: node literals* ( node -- ) drop ; + +M: node can-kill* ( literal node -- ? ) uses-value? not ; + +! #push +M: #push literals* ( node -- ) + node-out-d % ; + +M: #push can-kill* ( literal node -- ? ) + 2drop t ; + +M: #push kill-node* ( literals node -- ) + [ node-out-d seq-diff ] keep set-node-out-d ; + +! #drop +M: #drop can-kill* ( literal node -- ? ) + 2drop t ; + +! #call +: (kill-shuffle) ( word -- map ) + {{ + [[ dup {{ }} ]] + [[ drop {{ }} ]] + [[ swap {{ }} ]] + [[ over + {{ + [[ { f t } dup ]] + }} + ]] + [[ pick + {{ + [[ { f f t } over ]] + [[ { f t f } over ]] + [[ { f t t } dup ]] + }} + ]] + [[ >r {{ }} ]] + [[ r> {{ }} ]] + }} hash ; + +M: #call can-kill* ( literal node -- ? ) + dup node-param (kill-shuffle) >r delegate can-kill* r> or ; + +: kill-mask ( killing node -- mask ) + dup node-param \ r> = [ node-in-r ] [ node-in-d ] ifte + [ swap memq? ] map-with ; + +: lookup-mask ( mask word -- word ) + over disj [ (kill-shuffle) hash ] [ nip ] ifte ; + +: kill-shuffle ( literals node -- ) + #! If certain values passing through a stack op are being + #! killed, the stack op can be reduced, in extreme cases + #! to a no-op. + [ [ kill-mask ] keep node-param lookup-mask ] keep + set-node-param ; + +M: #call kill-node* ( literals node -- ) + dup node-param (kill-shuffle) + [ kill-shuffle ] [ 2drop ] ifte ; + +! #call-label +M: #call-label can-kill* ( literal node -- ? ) + 2drop t ; + +! #label +M: #label can-kill* ( literal node -- ? ) + node-children first can-kill? ; + +M: #simple-label can-kill* ( literal node -- ? ) + node-children first can-kill? ; + +! #ifte +SYMBOL: branch-returns + +: branch-values ( branches -- ) + [ last-node node-in-d ] map + unify-lengths flip branch-returns set ; + +: can-kill-branches? ( literal node -- ? ) + #! Check if the literal appears in either branch. This + #! assumes that the last element of each branch is a #values + #! node. + 2dup uses-value? [ + 2drop f + ] [ + [ + node-children dup branch-values + [ can-kill? ] all-with? + ] with-scope + ] ifte ; + +M: #ifte can-kill* ( literal node -- ? ) + can-kill-branches? ; + +! #dispatch +M: #dispatch can-kill* ( literal node -- ? ) + can-kill-branches? ; + +! #values +M: #values can-kill* ( literal node -- ? ) + dupd uses-value? [ + branch-returns get + [ memq? ] subset-with + [ [ eq? ] every? ] all? + ] [ + drop t + ] ifte ; + +! #merge +M: #merge can-kill* ( literal node -- ? ) 2drop t ; + +! #entry +M: #entry can-kill* ( literal node -- ? ) 2drop t ; diff --git a/library/inference/known-words.factor b/library/inference/known-words.factor new file mode 100644 index 0000000000..412ef23b3e --- /dev/null +++ b/library/inference/known-words.factor @@ -0,0 +1,91 @@ +IN: inference + +! Primitive combinators +\ call [ + pop-literal infer-quot-value +] "infer" set-word-prop + +\ execute [ + pop-literal unit infer-quot-value +] "infer" set-word-prop + +\ ifte [ + 2 #drop node, pop-d pop-d swap 2vector + #ifte pop-d drop infer-branches +] "infer" set-word-prop + +\ dispatch [ + pop-literal nip [ ] map + #dispatch pop-d drop infer-branches +] "infer" set-word-prop + +! Stack manipulation +\ >r [ + \ >r #call + 1 0 pick node-inputs + pop-d push-r + 0 1 pick node-outputs + node, +] "infer" set-word-prop + +\ r> [ + \ r> #call + 0 1 pick node-inputs + pop-r push-d + 1 0 pick node-outputs + node, +] "infer" set-word-prop + +\ drop [ 1 #drop node, pop-d drop ] "infer" set-word-prop +\ dup [ \ dup infer-shuffle ] "infer" set-word-prop +\ swap [ \ swap infer-shuffle ] "infer" set-word-prop +\ over [ \ over infer-shuffle ] "infer" set-word-prop +\ pick [ \ pick infer-shuffle ] "infer" set-word-prop + +! Type conversion +{ + { >boolean boolean } + { >list general-list } + { >bignum bignum } + { >fixnum fixnum } + { >float float } + { >sbuf sbuf } + { >string string } + { >vector vector } +} [ 2unseq "converter" set-word-prop ] each + +! These hacks will go away soon +\ delegate [ [ object ] [ object ] ] "infer-effect" set-word-prop +\ no-method t "terminator" set-word-prop +\ no-method [ [ object word ] [ ] ] "infer-effect" set-word-prop +\ [ [ object object ] [ tuple ] ] "infer-effect" set-word-prop +\ set-no-method-generic [ [ object tuple ] [ ] ] "infer-effect" set-word-prop +\ set-no-method-object [ [ object tuple ] [ ] ] "infer-effect" set-word-prop +\ not-a-number t "terminator" set-word-prop +\ inference-error t "terminator" set-word-prop +\ throw t "terminator" set-word-prop +\ = [ [ object object ] [ boolean ] ] "infer-effect" set-word-prop +\ integer/ [ [ integer integer ] [ rational ] ] "infer-effect" set-word-prop +\ gcd [ [ integer integer ] [ integer integer ] ] "infer-effect" set-word-prop +\ car [ [ general-list ] [ object ] ] "infer-effect" set-word-prop +\ cdr [ [ general-list ] [ object ] ] "infer-effect" set-word-prop +\ < [ [ real real ] [ boolean ] ] "infer-effect" set-word-prop +\ <= [ [ real real ] [ boolean ] ] "infer-effect" set-word-prop +\ > [ [ real real ] [ boolean ] ] "infer-effect" set-word-prop +\ >= [ [ real real ] [ boolean ] ] "infer-effect" set-word-prop +\ number= [ [ object object ] [ boolean ] ] "infer-effect" set-word-prop +\ + [ [ number number ] [ number ] ] "infer-effect" set-word-prop +\ - [ [ number number ] [ number ] ] "infer-effect" set-word-prop +\ * [ [ number number ] [ number ] ] "infer-effect" set-word-prop +\ / [ [ number number ] [ number ] ] "infer-effect" set-word-prop +\ /i [ [ number number ] [ number ] ] "infer-effect" set-word-prop +\ /f [ [ number number ] [ number ] ] "infer-effect" set-word-prop +\ mod [ [ integer integer ] [ integer ] ] "infer-effect" set-word-prop +\ /mod [ [ integer integer ] [ integer integer ] ] "infer-effect" set-word-prop +\ bitand [ [ integer integer ] [ integer ] ] "infer-effect" set-word-prop +\ bitor [ [ integer integer ] [ integer ] ] "infer-effect" set-word-prop +\ bitxor [ [ integer integer ] [ integer ] ] "infer-effect" set-word-prop +\ shift [ [ integer integer ] [ integer ] ] "infer-effect" set-word-prop +\ bitnot [ [ integer ] [ integer ] ] "infer-effect" set-word-prop +\ real [ [ number ] [ real ] ] "infer-effect" set-word-prop +\ imaginary [ [ number ] [ real ] ] "infer-effect" set-word-prop diff --git a/library/inference/optimizer.factor b/library/inference/optimizer.factor index ea3d3761c9..1aaaa86064 100644 --- a/library/inference/optimizer.factor +++ b/library/inference/optimizer.factor @@ -8,51 +8,10 @@ matrices namespaces sequences vectors ; ! label scopes, to prevent infinite loops when inlining ! recursive methods. -GENERIC: literals* ( node -- ) - -: literals ( node -- seq ) - [ [ literals* ] each-node ] make-vector ; - -GENERIC: can-kill* ( literal node -- ? ) - -: can-kill? ( literal node -- ? ) - #! Return false if the literal appears in any node in the - #! list. - dup [ - 2dup can-kill* - [ node-successor can-kill? ] [ 2drop f ] ifte - ] [ - 2drop t - ] ifte ; - -: kill-set ( node -- list ) - #! Push a list of literals that may be killed in the IR. - dup literals [ swap can-kill? ] subset-with ; - -: remove-values ( values node -- ) - 2dup [ node-in-d seq-diff ] keep set-node-in-d - 2dup [ node-out-d seq-diff ] keep set-node-out-d - 2dup [ node-in-r seq-diff ] keep set-node-in-r - [ node-out-r seq-diff ] keep set-node-out-r ; - -GENERIC: kill-node* ( literals node -- ) - -M: node kill-node* ( literals node -- ) 2drop ; - -: kill-node ( literals node -- ) - [ 2dup kill-node* remove-values ] each-node-with ; - GENERIC: optimize-node* ( node -- node ) -DEFER: optimize-node ( node -- node/t ) - GENERIC: optimize-children -M: node optimize-children ( node -- ) - f swap [ - node-children [ optimize-node swap >r or r> ] map - ] keep set-node-children ; - : keep-optimizing ( node -- node ? ) dup optimize-node* dup t = [ drop f ] [ nip keep-optimizing t or ] ifte ; @@ -65,94 +24,42 @@ M: node optimize-children ( node -- ) over set-node-successor r> r> r> or or ] [ r> ] ifte ; +M: node optimize-children ( node -- ) + f swap [ + node-children [ optimize-node swap >r or r> ] map + ] keep set-node-children ; + +: optimize-loop ( dataflow -- dataflow ) + recursive-state off + dup kill-set over kill-node + dup infer-classes + optimize-node [ optimize-loop ] when ; + : optimize ( dataflow -- dataflow ) - #! Remove redundant literals from the IR. The original IR - #! is destructively modified. [ - recursive-state off dup solve-recursion - dup kill-set over kill-node - dup infer-classes - optimize-node - ] with-scope [ optimize ] when ; + optimize-loop + ] with-scope ; : prune-if ( node quot -- successor/t ) over >r call [ r> node-successor ] [ r> drop t ] ifte ; inline ! Generic nodes -M: node literals* ( node -- ) drop ; - -M: node can-kill* ( literal node -- ? ) uses-value? not ; - M: f optimize-node* drop t ; M: node optimize-node* ( node -- t ) drop t ; ! #push -M: #push literals* ( node -- ) - node-out-d % ; - -M: #push can-kill* ( literal node -- ? ) - 2drop t ; - -M: #push kill-node* ( literals node -- ) - [ node-out-d seq-diff ] keep set-node-out-d ; - M: #push optimize-node* ( node -- node/t ) [ node-out-d empty? ] prune-if ; ! #drop -M: #drop can-kill* ( literal node -- ? ) - 2drop t ; - M: #drop optimize-node* ( node -- node/t ) [ node-in-d empty? ] prune-if ; ! #call -: (kill-shuffle) ( word -- map ) - {{ - [[ dup {{ }} ]] - [[ drop {{ }} ]] - [[ swap {{ }} ]] - [[ over - {{ - [[ { f t } dup ]] - }} - ]] - [[ pick - {{ - [[ { f f t } over ]] - [[ { f t f } over ]] - [[ { f t t } dup ]] - }} - ]] - [[ >r {{ }} ]] - [[ r> {{ }} ]] - }} hash ; - -M: #call can-kill* ( literal node -- ? ) - dup node-param (kill-shuffle) >r delegate can-kill* r> or ; - -: kill-mask ( killing node -- mask ) - dup node-param \ r> = [ node-in-r ] [ node-in-d ] ifte - [ swap memq? ] map-with ; - -: lookup-mask ( mask word -- word ) - over disj [ (kill-shuffle) hash ] [ nip ] ifte ; - -: kill-shuffle ( literals node -- ) - #! If certain values passing through a stack op are being - #! killed, the stack op can be reduced, in extreme cases - #! to a no-op. - [ [ kill-mask ] keep node-param lookup-mask ] keep - set-node-param ; - -M: #call kill-node* ( literals node -- ) - dup node-param (kill-shuffle) - [ kill-shuffle ] [ 2drop ] ifte ; - : optimize-not? ( #call -- ? ) dup node-param \ not = [ node-successor #ifte? ] [ drop f ] ifte ; @@ -160,17 +67,7 @@ M: #call kill-node* ( literals node -- ) : flip-branches ( #ifte -- ) dup node-children 2unseq swap 2vector swap set-node-children ; -! #call-label -M: #call-label can-kill* ( literal node -- ? ) - 2drop t ; - ! #label -M: #label can-kill* ( literal node -- ? ) - node-children first can-kill? ; - -M: #simple-label can-kill* ( literal node -- ? ) - node-children first can-kill? ; - : optimize-label ( node -- node ) dup node-param recursive-state [ cons ] change delegate optimize-children @@ -181,27 +78,8 @@ M: #label optimize-children optimize-label ; M: #simple-label optimize-children optimize-label ; ! #ifte -SYMBOL: branch-returns - -: branch-values ( branches -- ) - [ last-node node-in-d ] map - unify-lengths flip branch-returns set ; - -: can-kill-branches? ( literal node -- ? ) - #! Check if the literal appears in either branch. This - #! assumes that the last element of each branch is a #values - #! node. - 2dup uses-value? [ - 2drop f - ] [ - [ - node-children dup branch-values - [ can-kill? ] all-with? - ] with-scope - ] ifte ; - : static-branch? ( node -- lit ? ) - node-in-d first dup safe-literal? ; + node-in-d first dup literal? ; : static-branch ( conditional n -- node ) >r [ drop-inputs ] keep r> @@ -209,29 +87,13 @@ SYMBOL: branch-returns over node-successor over last-node set-node-successor pick set-node-successor drop ; -M: #ifte can-kill* ( literal node -- ? ) - can-kill-branches? ; - M: #ifte optimize-node* ( node -- node ) dup static-branch? [ literal-value 0 1 ? static-branch ] [ 2drop t ] ifte ; -! #dispatch -M: #dispatch can-kill* ( literal node -- ? ) - can-kill-branches? ; - ! #values -M: #values can-kill* ( literal node -- ? ) - dupd uses-value? [ - branch-returns get - [ memq? ] subset-with - [ [ eq? ] every? ] all? - ] [ - drop t - ] ifte ; - : values/merge ( #values #merge -- new old ) - >r >r node-in-d r> node-in-d 2vector unify-lengths 2unseq r> ; + >r >r node-in-d r> node-in-d unify-length r> ; : post-split ( #values -- node ) #! If a #values is followed by a #merge, we need to replace @@ -242,9 +104,3 @@ M: #values can-kill* ( literal node -- ? ) M: #values optimize-node* ( node -- node ? ) dup node-successor #merge? [ post-split ] [ drop t ] ifte ; - -! #merge -M: #merge can-kill* ( literal node -- ? ) 2drop t ; - -! #entry -M: #entry can-kill* ( literal node -- ? ) 2drop t ; diff --git a/library/inference/recursive-values.factor b/library/inference/recursive-values.factor index df3ba60b76..5afe8226e8 100644 --- a/library/inference/recursive-values.factor +++ b/library/inference/recursive-values.factor @@ -22,8 +22,8 @@ M: node solve-recursion* ( node -- ) drop ; M: #label solve-recursion* ( node -- ) dup node-param over collect-recursion >r node-children first dup node-in-d r> swap add - unify-stacks swap [ node-in-d ] keep - node-successor dup . subst-values ; + unify-stacks swap [ node-in-d unify-length ] keep + subst-values ; : solve-recursion ( node -- ) #! Figure out which values survive inner recursions in diff --git a/library/inference/stack.factor b/library/inference/stack.factor deleted file mode 100644 index aaefb6ec25..0000000000 --- a/library/inference/stack.factor +++ /dev/null @@ -1,39 +0,0 @@ -! Copyright (C) 2004, 2005 Slava Pestov. -! See http://factor.sf.net/license.txt for BSD license. -IN: inference -USING: interpreter kernel namespaces sequences words ; - -\ >r [ - \ >r #call - 1 0 pick node-inputs - pop-d push-r - 0 1 pick node-outputs - node, -] "infer" set-word-prop - -\ r> [ - \ r> #call - 0 1 pick node-inputs - pop-r push-d - 1 0 pick node-outputs - node, -] "infer" set-word-prop - -: with-datastack ( stack word -- stack ) - datastack >r >r set-datastack r> execute - datastack r> [ push ] keep set-datastack 2nip ; - -: apply-datastack ( word -- ) - meta-d [ swap with-datastack ] change ; - -: infer-shuffle ( word -- ) - dup #call [ - over "infer-effect" word-prop - [ apply-datastack ] hairy-node - ] keep node, ; - -\ drop [ 1 #drop node, pop-d drop ] "infer" set-word-prop -\ dup [ \ dup infer-shuffle ] "infer" set-word-prop -\ swap [ \ swap infer-shuffle ] "infer" set-word-prop -\ over [ \ over infer-shuffle ] "infer" set-word-prop -\ pick [ \ pick infer-shuffle ] "infer" set-word-prop diff --git a/library/inference/words.factor b/library/inference/words.factor index bc084e2670..4c570ac3b0 100644 --- a/library/inference/words.factor +++ b/library/inference/words.factor @@ -25,9 +25,6 @@ hashtables parser prettyprint ; " was already attempted, and failed" append3 inference-error ; -: inhibit-parital ( -- ) - meta-d get [ f swap set-value-safe? ] each ; - : recursive? ( word -- ? ) f swap dup word-def [ = or ] tree-each-with ; @@ -39,9 +36,8 @@ hashtables parser prettyprint ; recursive-state [ cdr ] change ; inline : inline-block ( word -- node-block ) - gensym over word-def cons [ - #entry node, inhibit-parital word-def infer-quot - ] with-block ; + gensym over word-def cons + [ #entry node, word-def infer-quot ] with-block ; : inline-compound ( word -- ) #! Infer the stack effect of a compound word in the current @@ -147,46 +143,15 @@ M: compound apply-object ( word -- ) ] ifte ] ifte* ; -\ call [ - pop-literal infer-quot-value -] "infer" set-word-prop +: with-datastack ( stack word -- stack ) + datastack >r >r set-datastack r> execute + datastack r> [ push ] keep set-datastack 2nip ; -\ execute [ - pop-literal unit infer-quot-value -] "infer" set-word-prop +: apply-datastack ( word -- ) + meta-d [ swap with-datastack ] change ; -! These hacks will go away soon -\ delegate [ [ object ] [ object ] ] "infer-effect" set-word-prop -\ no-method t "terminator" set-word-prop -\ no-method [ [ object word ] [ ] ] "infer-effect" set-word-prop -\ [ [ object object ] [ tuple ] ] "infer-effect" set-word-prop -\ set-no-method-generic [ [ object tuple ] [ ] ] "infer-effect" set-word-prop -\ set-no-method-object [ [ object tuple ] [ ] ] "infer-effect" set-word-prop -\ not-a-number t "terminator" set-word-prop -\ inference-error t "terminator" set-word-prop -\ throw t "terminator" set-word-prop -\ = [ [ object object ] [ boolean ] ] "infer-effect" set-word-prop -\ integer/ [ [ integer integer ] [ rational ] ] "infer-effect" set-word-prop -\ gcd [ [ integer integer ] [ integer integer ] ] "infer-effect" set-word-prop -\ car [ [ general-list ] [ object ] ] "infer-effect" set-word-prop -\ cdr [ [ general-list ] [ object ] ] "infer-effect" set-word-prop -\ < [ [ real real ] [ boolean ] ] "infer-effect" set-word-prop -\ <= [ [ real real ] [ boolean ] ] "infer-effect" set-word-prop -\ > [ [ real real ] [ boolean ] ] "infer-effect" set-word-prop -\ >= [ [ real real ] [ boolean ] ] "infer-effect" set-word-prop -\ number= [ [ object object ] [ boolean ] ] "infer-effect" set-word-prop -\ + [ [ number number ] [ number ] ] "infer-effect" set-word-prop -\ - [ [ number number ] [ number ] ] "infer-effect" set-word-prop -\ * [ [ number number ] [ number ] ] "infer-effect" set-word-prop -\ / [ [ number number ] [ number ] ] "infer-effect" set-word-prop -\ /i [ [ number number ] [ number ] ] "infer-effect" set-word-prop -\ /f [ [ number number ] [ number ] ] "infer-effect" set-word-prop -\ mod [ [ integer integer ] [ integer ] ] "infer-effect" set-word-prop -\ /mod [ [ integer integer ] [ integer integer ] ] "infer-effect" set-word-prop -\ bitand [ [ integer integer ] [ integer ] ] "infer-effect" set-word-prop -\ bitor [ [ integer integer ] [ integer ] ] "infer-effect" set-word-prop -\ bitxor [ [ integer integer ] [ integer ] ] "infer-effect" set-word-prop -\ shift [ [ integer integer ] [ integer ] ] "infer-effect" set-word-prop -\ bitnot [ [ integer ] [ integer ] ] "infer-effect" set-word-prop -\ real [ [ number ] [ real ] ] "infer-effect" set-word-prop -\ imaginary [ [ number ] [ real ] ] "infer-effect" set-word-prop +: infer-shuffle ( word -- ) + dup #call [ + over "infer-effect" word-prop + [ apply-datastack ] hairy-node + ] keep node, ; diff --git a/library/kernel.factor b/library/kernel.factor index 88d6a14d58..dcaeaa3579 100644 --- a/library/kernel.factor +++ b/library/kernel.factor @@ -3,6 +3,25 @@ IN: kernel USING: generic kernel-internals vectors ; +: 2drop ( x x -- ) drop drop ; inline +: 3drop ( x x x -- ) drop drop drop ; inline +: 2dup ( x y -- x y x y ) over over ; inline +: 3dup ( x y z -- x y z x y z ) pick pick pick ; inline +: rot ( x y z -- y z x ) >r swap r> swap ; inline +: -rot ( x y z -- z x y ) swap >r swap r> ; inline +: dupd ( x y -- x x y ) >r dup r> ; inline +: swapd ( x y z -- y x z ) >r swap r> ; inline +: 2swap ( x y z t -- z t x y ) rot >r rot r> ; inline +: nip ( x y -- y ) swap drop ; inline +: 2nip ( x y z -- z ) >r drop drop r> ; inline +: tuck ( x y -- y x y ) dup >r swap r> ; inline + +: clear ( -- ) + #! Clear the datastack. For interactive use only; invoking + #! this from a word definition will clobber any values left + #! on the data stack by the caller. + { } set-datastack ; + UNION: boolean POSTPONE: f POSTPONE: t ; COMPLEMENT: general-t f @@ -28,7 +47,7 @@ M: object clone ; rot [ drop ] [ nip ] ifte ; inline DEFER: wrapper? -BUILTIN: wrapper 14 wrapper? { 1 "wrapped" "set-wrapped" } ; +BUILTIN: wrapper 14 wrapper? { 1 "wrapped" f } ; M: wrapper = ( obj wrapper -- ? ) over wrapper? [ swap wrapped = ] [ 2drop f ] ifte ; @@ -56,3 +75,67 @@ DEFER: t? : bignum-tag BIN: 001 ; inline : cons-tag BIN: 010 ; inline : object-tag BIN: 011 ; inline + +: slip ( quot x -- x | quot: -- ) + >r call r> ; inline + +: 2slip ( quot x y -- x y | quot: -- ) + >r >r call r> r> ; inline + +: keep ( x quot -- x | quot: x -- ) + over >r call r> ; inline + +: 2keep ( x y quot -- x y | quot: x y -- ) + over >r pick >r call r> r> ; inline + +: 3keep ( x y z quot -- x y z | quot: x y z -- ) + >r 3dup r> swap >r swap >r swap >r call r> r> r> ; inline + +: while ( quot generator -- ) + #! Keep applying the quotation to the value produced by + #! calling the generator until the generator returns f. + 2dup >r >r swap >r call dup [ + r> call r> r> while + ] [ + r> 2drop r> r> 2drop + ] ifte ; inline + +: ifte* ( cond true false -- | true: cond -- | false: -- ) + #! [ X ] [ Y ] ifte* ==> dup [ X ] [ drop Y ] ifte + pick [ drop call ] [ 2nip call ] ifte ; inline + +: ?ifte ( default cond true false -- ) + #! [ X ] [ Y ] ?ifte ==> dup [ nip X ] [ drop Y ] ifte + >r >r dup [ + nip r> r> drop call + ] [ + drop r> drop r> call + ] ifte ; inline + +: unless ( cond quot -- | quot: -- ) + #! Execute a quotation only when the condition is f. The + #! condition is popped off the stack. + [ ] swap ifte ; inline + +: unless* ( cond quot -- | quot: -- ) + #! If cond is f, pop it off the stack and evaluate the + #! quotation. Otherwise, leave cond on the stack. + over [ drop ] [ nip call ] ifte ; inline + +: when ( cond quot -- | quot: -- ) + #! Execute a quotation only when the condition is not f. The + #! condition is popped off the stack. + [ ] ifte ; inline + +: when* ( cond quot -- | quot: cond -- ) + #! If the condition is true, it is left on the stack, and + #! the quotation is evaluated. Otherwise, the condition is + #! popped off the stack. + dupd [ drop ] ifte ; inline + +: with ( obj quot elt -- obj quot ) + #! Utility word for each-with, map-with. + pick pick >r >r swap call r> r> ; inline + +: keep-datastack ( quot -- ) + datastack slip set-datastack drop ; diff --git a/library/stack.factor b/library/stack.factor deleted file mode 100644 index 2894406aaa..0000000000 --- a/library/stack.factor +++ /dev/null @@ -1,22 +0,0 @@ -! Copyright (C) 2004, 2005 Slava Pestov. -! See http://factor.sf.net/license.txt for BSD license. -IN: kernel - -: 2drop ( x x -- ) drop drop ; inline -: 3drop ( x x x -- ) drop drop drop ; inline -: 2dup ( x y -- x y x y ) over over ; inline -: 3dup ( x y z -- x y z x y z ) pick pick pick ; inline -: rot ( x y z -- y z x ) >r swap r> swap ; inline -: -rot ( x y z -- z x y ) swap >r swap r> ; inline -: dupd ( x y -- x x y ) >r dup r> ; inline -: swapd ( x y z -- y x z ) >r swap r> ; inline -: 2swap ( x y z t -- z t x y ) rot >r rot r> ; inline -: nip ( x y -- y ) swap drop ; inline -: 2nip ( x y z -- z ) >r drop drop r> ; inline -: tuck ( x y -- y x y ) dup >r swap r> ; inline - -: clear ( -- ) - #! Clear the datastack. For interactive use only; invoking - #! this from a word definition will clobber any values left - #! on the data stack by the caller. - { } set-datastack ; diff --git a/library/syntax/prettyprint.factor b/library/syntax/prettyprint.factor index 5c6a055b4d..fbcd9bb0fd 100644 --- a/library/syntax/prettyprint.factor +++ b/library/syntax/prettyprint.factor @@ -44,15 +44,18 @@ M: word prettyprint* ( indent word -- indent ) : prettyprint-limit? ( indent -- ? ) prettyprint-limit get dup [ >= ] [ nip ] ifte ; -: check-recursion ( indent obj quot -- ? indent ) +: check-recursion ( indent obj quot -- indent ) #! We detect circular structure. - pick prettyprint-limit? >r - over recursion-check get memq? r> or [ - 2drop "..." write + pick prettyprint-limit? [ + 2drop "#" write ] [ - over recursion-check [ cons ] change - call - recursion-check [ cdr ] change + over recursion-check get memq? [ + 2drop "&" write + ] [ + over recursion-check [ cons ] change + call + recursion-check [ cdr ] change + ] ifte ] ifte ; inline : prettyprint-elements ( indent list -- indent ) diff --git a/library/test/compiler/optimizer.factor b/library/test/compiler/optimizer.factor index 95afd91ffb..3d4092a8bf 100644 --- a/library/test/compiler/optimizer.factor +++ b/library/test/compiler/optimizer.factor @@ -30,11 +30,11 @@ USE: sequences : foo 1 2 3 ; -[ [ ] ] [ \ foo word-def dataflow kill-set ] unit-test +[ { } ] [ \ foo word-def dataflow kill-set ] unit-test -[ [ [ 1 ] [ 2 ] ] ] [ [ [ 1 ] [ 2 ] ifte ] kill-set* ] unit-test +[ { [ 1 ] [ 2 ] } ] [ [ [ 1 ] [ 2 ] ifte ] kill-set* ] unit-test -[ [ [ 1 ] [ 2 ] ] ] [ [ [ 1 ] [ 2 ] ifte ] kill-set* ] unit-test +[ { [ 1 ] [ 2 ] } ] [ [ [ 1 ] [ 2 ] ifte ] kill-set* ] unit-test [ [ t t f ] ] [ [ 1 2 3 ] [ ] map @@ -53,7 +53,7 @@ USE: sequences [ 3 ] [ literal-kill-test-3 ] unit-test -[ [ [ 3 ] [ dup ] ] ] [ [ [ 3 ] [ dup ] ifte drop ] kill-set* ] unit-test +[ { [ 3 ] [ dup ] } ] [ [ [ 3 ] [ dup ] ifte drop ] kill-set* ] unit-test : literal-kill-test-4 5 swap [ 3 ] [ dup ] ifte 2drop ; compiled @@ -61,7 +61,7 @@ USE: sequences [ ] [ t literal-kill-test-4 ] unit-test [ ] [ f literal-kill-test-4 ] unit-test -[ [ [ 3 ] [ dup ] ] ] [ \ literal-kill-test-4 word-def kill-set* ] unit-test +[ { [ 3 ] [ dup ] } ] [ \ literal-kill-test-4 word-def kill-set* ] unit-test : literal-kill-test-5 5 swap [ 5 ] [ dup ] ifte 2drop ; compiled @@ -69,7 +69,7 @@ USE: sequences [ ] [ t literal-kill-test-5 ] unit-test [ ] [ f literal-kill-test-5 ] unit-test -[ [ [ 5 ] [ dup ] ] ] [ \ literal-kill-test-5 word-def kill-set* ] unit-test +[ { [ 5 ] [ dup ] } ] [ \ literal-kill-test-5 word-def kill-set* ] unit-test : literal-kill-test-6 5 swap [ dup ] [ dup ] ifte 2drop ; compiled @@ -77,7 +77,7 @@ USE: sequences [ ] [ t literal-kill-test-6 ] unit-test [ ] [ f literal-kill-test-6 ] unit-test -[ [ 5 [ dup ] [ dup ] ] ] [ \ literal-kill-test-6 word-def kill-set* ] unit-test +[ { 5 [ dup ] [ dup ] } ] [ \ literal-kill-test-6 word-def kill-set* ] unit-test : literal-kill-test-7 [ 1 2 3 ] >r + r> drop ; compiled diff --git a/library/test/hashtables.factor b/library/test/hashtables.factor index 802c5b5d97..f7efb4e020 100644 --- a/library/test/hashtables.factor +++ b/library/test/hashtables.factor @@ -63,7 +63,7 @@ f 100000000000000000000000000 "testhash" get set-hash [ 4 ] [ "hey" {{ [[ "hey" 4 ]] [[ "whey" 5 ]] }} 2dup (hashcode) - >r buckets>list r> [ cdr ] times car assoc + swap buckets>vector nth assoc ] unit-test ! Testing the hash element counting diff --git a/library/test/sequences.factor b/library/test/sequences.factor index 299404d1fd..d16052ab28 100644 --- a/library/test/sequences.factor +++ b/library/test/sequences.factor @@ -61,10 +61,6 @@ unit-test [ "" ] [ { } "" join ] unit-test -[ { "three" "three" "two" "two" "one" "one" } ] -[ { "one" "two" "three" } { 1 2 3 } { 3 3 2 2 1 1 } subst ] -unit-test - [ { 1 2 } ] [ 1 2 2vector ] unit-test [ { 1 2 3 } ] [ 1 2 3 3vector ] unit-test diff --git a/library/test/tuple.factor b/library/test/tuple.factor index 038b4ca4dd..264245aca5 100644 --- a/library/test/tuple.factor +++ b/library/test/tuple.factor @@ -1,5 +1,5 @@ IN: temporary -USING: generic kernel test math parser ; +USING: errors generic kernel math parser sequences test ; TUPLE: rect x y w h ; C: rect @@ -87,3 +87,6 @@ TUPLE: delegate-clone ; [ f ] [ \ object \ delegate-clone class< ] unit-test [ t ] [ \ delegate-clone \ tuple class< ] unit-test [ f ] [ \ tuple \ delegate-clone class< ] unit-test + +! Compiler regression +[ t ] [ [ t length ] [ no-method-object ] catch ] unit-test