From 7ecbfb5c98b48818f314ebf9955ca55d4316aa2c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 16 Sep 2005 06:39:33 +0000 Subject: [PATCH] big generic word cleanup; kill-literals optimization; continuations overhaul --- CHANGES.html | 1 + TODO.FACTOR.txt | 3 +- library/bootstrap/boot-stage1.factor | 2 - library/bootstrap/image.factor | 4 +- library/bootstrap/primitives.factor | 31 ++-- library/collections/cons.factor | 2 - library/collections/hashtables.factor | 26 ++- library/collections/namespaces.factor | 5 + library/collections/sequence-eq.factor | 8 +- library/collections/sequences-epilogue.factor | 21 +-- library/collections/slicing.factor | 6 +- library/collections/vectors.factor | 3 - library/compiler/compiler.factor | 1 + library/continuations.factor | 4 +- library/generic/generic.factor | 157 ++++++++++++------ library/generic/math-combination.factor | 7 +- library/generic/predicate.factor | 25 --- library/generic/slots.factor | 2 +- library/generic/standard-combination.factor | 20 +-- library/generic/tuple.factor | 17 +- library/generic/union.factor | 24 --- library/inference/kill-literals.factor | 142 ++++++---------- library/inference/shuffle.factor | 4 +- library/io/files.factor | 2 +- library/kernel.factor | 3 + library/syntax/generic.factor | 2 +- library/syntax/parse-stream.factor | 4 +- library/syntax/prettyprint.factor | 2 +- library/syntax/see.factor | 6 +- library/test/collections/hashtables.factor | 31 ++++ library/test/collections/sequences.factor | 5 +- library/test/continuations.factor | 8 + library/test/generic.factor | 32 ++-- library/tools/debugger.factor | 2 +- library/tools/inspector.factor | 13 +- library/vocabularies.factor | 11 +- native/run.c | 2 +- 37 files changed, 312 insertions(+), 326 deletions(-) delete mode 100644 library/generic/predicate.factor delete mode 100644 library/generic/union.factor diff --git a/CHANGES.html b/CHANGES.html index ab94b3e1b4..f74d2c24c6 100644 --- a/CHANGES.html +++ b/CHANGES.html @@ -30,6 +30,7 @@ diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt index 3a2255b42f..f34cd87865 100644 --- a/TODO.FACTOR.txt +++ b/TODO.FACTOR.txt @@ -1,3 +1,5 @@ +- quot>interp needs to go + + ui: - fix up the min thumb size hack @@ -61,7 +63,6 @@ + sequences: -- typemap keys need to be arrays - split: return vectors - specialized arrays - instances: do not use make-list diff --git a/library/bootstrap/boot-stage1.factor b/library/bootstrap/boot-stage1.factor index b21dc2134a..df033dd9db 100644 --- a/library/bootstrap/boot-stage1.factor +++ b/library/bootstrap/boot-stage1.factor @@ -81,8 +81,6 @@ sequences io vectors words ; "/library/generic/standard-combination.factor" "/library/generic/slots.factor" "/library/generic/math-combination.factor" - "/library/generic/predicate.factor" - "/library/generic/union.factor" "/library/generic/tuple.factor" "/library/syntax/generic.factor" diff --git a/library/bootstrap/image.factor b/library/bootstrap/image.factor index 11b03ea8f7..fa2a81121d 100644 --- a/library/bootstrap/image.factor +++ b/library/bootstrap/image.factor @@ -14,9 +14,6 @@ USING: arrays errors generic hashtables kernel lists math namespaces parser prettyprint sequences sequences-internals io strings vectors words ; -! If true in current namespace, we are bootstrapping. -SYMBOL: bootstrapping? - ! The image being constructed; a vector of word-size integers SYMBOL: image @@ -292,6 +289,7 @@ M: hashtable ' ( hashtable -- pointer ) "Object cache size: " write objects get hash-size . image get \ word global remove-hash + namespace global [ "foobar" set ] bind ] with-scope ; : make-image ( name -- ) diff --git a/library/bootstrap/primitives.factor b/library/bootstrap/primitives.factor index 117f45a566..e18623561b 100644 --- a/library/bootstrap/primitives.factor +++ b/library/bootstrap/primitives.factor @@ -12,7 +12,7 @@ words ; ! These symbols need the same hashcode in the target as in the ! host. -{ vocabularies object null typemap builtins } +{ vocabularies typemap builtins } ! Bring up a bare cross-compiling vocabulary. "syntax" vocab @@ -251,18 +251,18 @@ FORGET: set-stack-effect ! word system. : builtin-predicate ( class predicate -- ) [ - over types first dup + over "type" word-prop dup tag-mask < \ tag \ type ? , , \ eq? , ] [ ] make define-predicate ; : register-builtin ( class -- ) - dup types first builtins get set-nth ; + dup "type" word-prop builtins get set-nth ; : define-builtin ( symbol type# predicate slotspec -- ) >r >r >r dup intern-symbol - dup r> 1 [ push ] keep "types" set-word-prop - dup builtin define-class + dup r> "type" set-word-prop + dup define-class dup r> builtin-predicate dup r> intern-slots 2dup "slots" set-word-prop define-slots @@ -271,15 +271,9 @@ FORGET: set-stack-effect {{ }} clone typemap set num-types builtins set -! Catch-all metaclass for providing a default method. -object num-types >vector "types" set-word-prop -object [ drop t ] "predicate" set-word-prop -object object define-class - -! Null metaclass with no instances. -null { } "types" set-word-prop -null [ drop f ] "predicate" set-word-prop -null null define-class +! These symbols are needed by the code that executes below +"object" "generic" create drop +"null" "generic" create drop "fixnum?" "math" create t "inline" set-word-prop "fixnum" "math" create 0 "fixnum?" "math" create { } define-builtin @@ -383,6 +377,15 @@ null null define-class f "f" "!syntax" lookup builtins get remove [ ] subset define-union +! Catch-all class for providing a default method. +"object" "generic" create [ drop t ] "predicate" set-word-prop +"object" "generic" create dup define-symbol +f builtins get [ ] subset define-union + +! Null class with no instances. +"null" "generic" create [ drop f ] "predicate" set-word-prop +"null" "generic" create dup define-symbol f @{ }@ define-union + FORGET: builtin-predicate FORGET: register-builtin FORGET: define-builtin diff --git a/library/collections/cons.factor b/library/collections/cons.factor index 65b9806e95..e604daf0d7 100644 --- a/library/collections/cons.factor +++ b/library/collections/cons.factor @@ -47,5 +47,3 @@ M: cons = ( obj cons -- ? ) ] ifte ; M: f = ( obj f -- ? ) eq? ; - -M: cons hashcode ( cons -- hash ) car hashcode ; diff --git a/library/collections/hashtables.factor b/library/collections/hashtables.factor index 2a2715ea8a..acaaba0767 100644 --- a/library/collections/hashtables.factor +++ b/library/collections/hashtables.factor @@ -154,16 +154,13 @@ M: hashtable = ( obj hash -- ? ) ] ifte ; M: hashtable hashcode ( hash -- n ) - dup bucket-count 0 number= [ - drop 0 - ] [ - 0 swap hash-bucket hashcode - ] ifte ; + #! Poor. + hash-size ; : cache ( key hash quot -- value | quot: key -- value ) pick pick hash [ >r 3drop r> - ] [ + ] [ pick rot >r >r call dup r> r> set-hash ] ifte* ; inline @@ -176,3 +173,20 @@ M: hashtable hashcode ( hash -- n ) : ?set-hash ( value key hash/f -- hash ) [ 1 ] unless* [ set-hash ] keep ; + +: hash-intersect ( hash1 hash2 -- hash1/\hash2 ) + #! Remove all keys from hash2 not in hash1. + [ car swap hash ] hash-subset-with ; + +: hash-diff ( hash1 hash2 -- hash2-hash1 ) + #! Remove all keys from hash2 in hash1. + [ car swap hash not ] hash-subset-with ; + +: hash-update ( hash1 hash2 -- ) + #! Add all key/value pairs from hash2 to hash1. + [ unswons rot set-hash ] hash-each-with ; + +: hash-union ( hash1 hash2 -- hash1\/hash2 ) + #! Make a new hashtable with all key/value pairs from + #! hash1 and hash2. Values in hash2 take precedence. + >r clone dup r> hash-update ; diff --git a/library/collections/namespaces.factor b/library/collections/namespaces.factor index 2ddf0bf6be..b84836f037 100644 --- a/library/collections/namespaces.factor +++ b/library/collections/namespaces.factor @@ -133,3 +133,8 @@ SYMBOL: hash-buffer (closure) hash-buffer get hash-keys ] with-scope ; + +IN: lists + +: alist>quot ( default alist -- quot ) + [ unswons [ % , , \ ifte , ] [ ] make ] each ; diff --git a/library/collections/sequence-eq.factor b/library/collections/sequence-eq.factor index 1c70409014..56f3b03da1 100644 --- a/library/collections/sequence-eq.factor +++ b/library/collections/sequence-eq.factor @@ -8,12 +8,10 @@ vectors ; ! defined tuples that respond to the sequence protocol. UNION: sequence array string sbuf vector ; -: length= ( seq seq -- ? ) length swap length number= ; flushable - : sequence= ( seq seq -- ? ) #! Check if two sequences have the same length and elements, #! but not necessarily the same class. - 2dup length= [ + 2dup [ length ] 2apply = [ dup length [ >r 2dup r> 2nth-unsafe = ] all? 2nip ] [ 2drop f @@ -26,6 +24,10 @@ M: sequence = ( obj seq -- ? ) over type over type eq? [ sequence= ] [ 2drop f ] ifte ] ifte ; +M: sequence hashcode ( seq -- n ) + #! Poor + length ; + M: string = ( obj str -- ? ) over string? [ over hashcode over hashcode number= diff --git a/library/collections/sequences-epilogue.factor b/library/collections/sequences-epilogue.factor index c6503b057a..25ec952c1a 100644 --- a/library/collections/sequences-epilogue.factor +++ b/library/collections/sequences-epilogue.factor @@ -36,6 +36,9 @@ M: object >list ( seq -- list ) dup length 0 rot (>list) ; : memq? ( obj seq -- ? ) [ eq? ] contains-with? ; flushable : remove ( obj list -- list ) [ = not ] subset-with ; flushable +: remove-all ( seq1 seq2 -- seq2-seq1 ) + [ swap member? not ] subset-with ; flushable + : move ( to from seq -- ) pick pick number= [ 3drop ] [ [ nth swap ] keep set-nth ] ifte ; inline @@ -48,6 +51,7 @@ M: object >list ( seq -- list ) dup length 0 rot (>list) ; ] when ; : delete ( elt seq -- ) + #! Delete all occurrences of elt from seq. 0 0 rot (delete) nip set-length drop ; : copy-into-check ( start to from -- ) @@ -56,10 +60,13 @@ M: object >list ( seq -- list ) dup length 0 rot (>list) ; ] when ; : copy-into ( start to from -- ) + #! Copy all elements in 'from' to 'to', storing at + #! consecutive indices numbered from 'start'. 3dup copy-into-check dup length [ >r pick r> + pick set-nth-unsafe ] 2each 2drop ; : nappend ( to from -- ) + #! Add all elements of 'from' at the end of 'to'. >r dup length swap r> over length over length + pick set-length copy-into ; @@ -118,20 +125,6 @@ M: object reverse-slice ( seq -- seq ) ; M: object reverse ( seq -- seq ) [ ] keep like ; -! Set theoretic operations -: seq-intersect ( seq1 seq2 -- seq1/\seq2 ) - [ swap member? ] subset-with ; flushable - -: seq-diff ( seq1 seq2 -- seq2-seq1 ) - [ swap member? not ] subset-with ; flushable - -: seq-union ( seq1 seq2 -- seq1\/seq2 ) - append prune ; flushable - -: contained? ( seq1 seq2 -- ? ) - #! Is every element of seq1 in seq2 - swap [ swap member? ] all-with? ; flushable - ! Lexicographic comparison : lexi ( s1 s2 -- n ) #! Lexicographically compare two sequences of numbers diff --git a/library/collections/slicing.factor b/library/collections/slicing.factor index 4607eb3303..3e5a4e6b2d 100644 --- a/library/collections/slicing.factor +++ b/library/collections/slicing.factor @@ -24,10 +24,8 @@ M: object tail ( index seq -- seq ) [ tail-slice ] keep like ; : tail* ( n seq -- seq ) [ tail-slice* ] keep like ; flushable -: length< ( seq seq -- ? ) swap length swap length < ; flushable - : head? ( seq begin -- ? ) - 2dup length< [ + 2dup [ length ] 2apply < [ 2drop f ] [ dup length rot head-slice sequence= @@ -37,7 +35,7 @@ M: object tail ( index seq -- seq ) [ tail-slice ] keep like ; 2dup head? [ length swap tail t ] [ drop f ] ifte ; flushable : tail? ( seq end -- ? ) - 2dup length< [ + 2dup [ length ] 2apply < [ 2drop f ] [ dup length rot tail-slice* sequence= diff --git a/library/collections/vectors.factor b/library/collections/vectors.factor index a9c68af73c..9a54c1065b 100644 --- a/library/collections/vectors.factor +++ b/library/collections/vectors.factor @@ -16,9 +16,6 @@ M: vector set-nth-unsafe ( obj n vec -- ) M: vector set-nth ( obj n vec -- ) growable-check 2dup ensure set-nth-unsafe ; -M: vector hashcode ( vec -- n ) - dup length 0 number= [ drop 0 ] [ first hashcode ] ifte ; - : >vector ( list -- vector ) dup length [ swap nappend ] keep ; inline diff --git a/library/compiler/compiler.factor b/library/compiler/compiler.factor index 3e1d214676..3ffe6f7992 100644 --- a/library/compiler/compiler.factor +++ b/library/compiler/compiler.factor @@ -46,6 +46,7 @@ words ; \ split-blocks profile \ simplify profile \ keep-optimizing profile +\ literals profile \ kill-set profile \ kill-node profile \ infer-classes profile diff --git a/library/continuations.factor b/library/continuations.factor index b3dcb0fca0..6018ff6425 100644 --- a/library/continuations.factor +++ b/library/continuations.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2003, 2005 Slava Pestov. ! See http://factor.sf.net/license.txt for BSD license. IN: kernel -USING: errors lists namespaces sequences words vectors ; +USING: arrays errors lists namespaces sequences words vectors ; TUPLE: interp data call name catch ; @@ -21,7 +21,7 @@ TUPLE: interp data call name catch ; #! Make a continuation that executes the quotation. #! The quotation should not return, or a call stack #! underflow will be signalled. - { } swap 1 [ push ] keep f f ; + { } f rot 2array >vector f f ; : continue ( continuation -- ) #! Restore a continuation. diff --git a/library/generic/generic.factor b/library/generic/generic.factor index 95687fac4d..f89dae777d 100644 --- a/library/generic/generic.factor +++ b/library/generic/generic.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2004, 2005 Slava Pestov. ! See http://factor.sf.net/license.txt for BSD license. IN: generic -USING: errors hashtables kernel kernel-internals lists +USING: arrays errors hashtables kernel kernel-internals lists namespaces parser sequences strings words vectors math math-internals ; @@ -10,16 +10,9 @@ math-internals ; ! Maps lists of builtin type numbers to class objects. SYMBOL: typemap -! Forward definitions. -SYMBOL: object -SYMBOL: null - ! Global vector mapping type numbers to builtin class objects. SYMBOL: builtins -! Builtin metaclass -SYMBOL: builtin - : type>class ( n -- symbol ) builtins get nth ; : predicate-word ( word -- word ) @@ -35,26 +28,44 @@ SYMBOL: builtin 3drop ] ifte ; -: metaclass ( class -- metaclass ) - "metaclass" word-prop ; +: superclass "superclass" word-prop ; + +: members "members" word-prop ; + +: (flatten) ( class -- ) + dup members [ [ (flatten) ] each ] [ dup set ] ?ifte ; + +: flatten ( class -- classes ) + #! Outputs a sequence of classes whose union is this class. + [ (flatten) ] make-hash ; + +DEFER: types + +: (types) ( class -- ) + #! Only valid for a flattened class. + dup superclass [ types % ] [ "type" word-prop , ] ?ifte ; : types ( class -- types ) - dup "types" word-prop [ ] [ - "superclass" word-prop [ types ] [ [ ] ] ifte* - ] ?ifte ; + [ flatten hash-keys [ (types) ] each ] { } make prune ; -: 2types ( class class -- seq seq ) swap types swap types ; +DEFER: class< -: custom-class< metaclass "class<" word-prop ; +: superclass< ( cls1 cls2 -- ? ) + >r superclass r> over [ class< ] [ 2drop f ] ifte ; + +: (class<) ( cls1 cls2 -- ? ) + [ flatten hash-keys ] 2apply + swap [ swap [ class< ] contains-with? ] all-with? ; : class< ( cls1 cls2 -- ? ) #! Test if class1 is a subclass of class2. @{ @{ [ 2dup eq? ] [ 2drop t ] }@ - @{ [ over types empty? ] [ 2drop t ] }@ - @{ [ dup types empty? ] [ 2drop f ] }@ - @{ [ dup custom-class< ] [ dup custom-class< call ] }@ - @{ [ t ] [ 2types contained? ] }@ + @{ [ over flatten hash-size 0 = ] [ 2drop t ] }@ + @{ [ over superclass ] [ >r superclass r> class< ] }@ + @{ [ dup superclass ] [ superclass< ] }@ + @{ [ 2dup [ members ] 2apply or not ] [ 2drop f ] }@ + @{ [ t ] [ (class<) ] }@ }@ cond ; : class-compare ( cls1 cls2 -- -1/0/1 ) @@ -64,16 +75,28 @@ SYMBOL: builtin "methods" word-prop hash>alist [ 2car class-compare ] sort ; : order ( generic -- list ) - "methods" word-prop hash-keys [ class-compare ] sort ; + methods [ car ] map ; + +PREDICATE: compound generic ( word -- ? ) + "combination" word-prop ; + +M: generic definer drop \ G: ; : make-generic ( word -- ) dup dup "combination" word-prop call define-compound ; -: define-method ( class generic definition -- ) - -rot - over metaclass word? [ - over word-name " is not a class" append throw +: class? ( word -- ? ) "class" word-prop ; + +: check-method ( class generic -- ) + dup generic? [ + dup word-name " is not a generic word" append throw ] unless + over "class" word-prop [ + over word-name " is not a class" append throw + ] unless 2drop ; + +: define-method ( definition class generic -- ) + >r reintern r> 2dup check-method [ "methods" word-prop set-hash ] keep make-generic ; : forget-method ( class generic -- ) @@ -100,41 +123,41 @@ SYMBOL: builtin dupd "combination" set-word-prop dup init-methods make-generic ; -PREDICATE: compound generic ( word -- ? ) - "combination" word-prop ; +: lookup-union ( class-set -- class ) + #! The class set is a hashtable with equal keys/values. + typemap get hash [ object ] unless* ; -M: generic definer drop \ G: ; - -: lookup-union ( typelist -- class ) - number-sort typemap get hash [ object ] unless* ; - -: class-or ( class class -- class ) - #! Return a class that both classes are subclasses of. - 2dup class< [ - nip +: (builtin-supertypes) ( class -- ) + dup members [ + [ (builtin-supertypes) ] each ] [ - 2dup swap class< [ - drop + dup superclass [ + (builtin-supertypes) ] [ - 2types seq-union lookup-union - ] ifte - ] ifte ; + dup set + ] ?ifte + ] ?ifte ; + +: builtin-supertypes ( class -- classes ) + #! Outputs a sequence of builtin classes whose union is the + #! smallest union of builtin classes that contains this + #! class. + [ (builtin-supertypes) ] make-hash ; + +: (class-and) ( class class -- class ) + [ builtin-supertypes ] 2apply hash-intersect lookup-union ; : class-and ( class class -- class ) #! Return a class that is a subclass of both, or null in #! the degenerate case. - 2dup class< [ - drop - ] [ - 2dup swap class< [ - nip - ] [ - 2types seq-intersect lookup-union - ] ifte - ] ifte ; + @{ + @{ [ 2dup class< ] [ drop ] }@ + @{ [ 2dup swap class< ] [ nip ] }@ + @{ [ t ] [ (class-and) ] }@ + }@ cond ; : classes-intersect? ( class class -- ? ) - class-and null = not ; + class-and flatten hash-size 0 > ; : min-class ( class seq -- class/f ) #! Is this class the smallest class in the sequence? @@ -142,9 +165,9 @@ M: generic definer drop \ G: ; [ class-compare neg ] sort tuck [ class< ] all-with? [ first ] [ drop f ] ifte ; -: define-class ( class metaclass -- ) - dupd "metaclass" set-word-prop - dup types number-sort typemap get set-hash ; +: define-class ( class -- ) + dup t "class" set-word-prop + dup flatten typemap get set-hash ; : implementors ( class -- list ) #! Find a list of generics that implement a method @@ -153,4 +176,30 @@ M: generic definer drop \ G: ; : classes ( -- list ) #! Output a list of all defined classes. - [ metaclass ] word-subset ; + [ class? ] word-subset ; + +! Predicate classes for generalized predicate dispatch. +: define-predicate-class ( class predicate definition -- ) + pick define-class + 3dup nip "definition" set-word-prop + pick superclass "predicate" word-prop + [ \ dup , % , [ drop f ] , \ ifte , ] [ ] make + define-predicate ; + +PREDICATE: word predicate "definition" word-prop ; + +! Union classes for dispatch on multiple classes. +: union-predicate ( members -- list ) + [ + "predicate" word-prop \ dup swons [ drop t ] cons + ] map [ drop f ] swap alist>quot ; + +: set-members ( class members -- ) + [ reintern ] map "members" set-word-prop ; + +: define-union ( class predicate members -- ) + #! We have to turn the f object into the f word, same for t. + 3dup nip set-members pick define-class + union-predicate define-predicate ; + +PREDICATE: word union members ; diff --git a/library/generic/math-combination.factor b/library/generic/math-combination.factor index 8243f640d7..b7012e4cc0 100644 --- a/library/generic/math-combination.factor +++ b/library/generic/math-combination.factor @@ -38,13 +38,16 @@ TUPLE: no-math-method left right generic ; literalize [ no-math-method ] cons ] ?ifte ; +: object-method ( generic -- quot ) + object reintern applicable-method ; + : math-method ( word left right -- quot ) swap type>class swap type>class 2dup and [ 2dup math-upgrade >r math-class-max over order min-class applicable-method r> swap append ] [ - 2drop object applicable-method + 2drop object-method ] ifte ; : math-vtable ( picker quot -- ) @@ -62,7 +65,7 @@ TUPLE: no-math-method left right generic ; dup type>class math-class? [ \ dup [ >r 2dup r> math-method ] math-vtable ] [ - over object applicable-method + over object-method ] ifte nip ] math-vtable nip ; diff --git a/library/generic/predicate.factor b/library/generic/predicate.factor deleted file mode 100644 index 46e9d5cb1a..0000000000 --- a/library/generic/predicate.factor +++ /dev/null @@ -1,25 +0,0 @@ -! Copyright (C) 2004, 2005 Slava Pestov. -! See http://factor.sf.net/license.txt for BSD license. -IN: generic -USING: errors hashtables kernel lists namespaces parser -sequences strings words vectors ; - -! Predicate metaclass for generalized predicate dispatch. -SYMBOL: predicate - -predicate [ - over metaclass over metaclass eq? [ - >r "superclass" word-prop r> class< - ] [ - 2drop f - ] ifte -] "class<" set-word-prop - -: define-predicate-class ( class predicate definition -- ) - 3dup nip "definition" set-word-prop - pick predicate "metaclass" set-word-prop - pick "superclass" word-prop "predicate" word-prop - [ \ dup , % , [ drop f ] , \ ifte , ] [ ] make - define-predicate ; - -PREDICATE: word predicate metaclass predicate = ; diff --git a/library/generic/slots.factor b/library/generic/slots.factor index 00b38bc1de..a30ef3093d 100644 --- a/library/generic/slots.factor +++ b/library/generic/slots.factor @@ -11,7 +11,7 @@ parser sequences strings words ; #! Just like: #! GENERIC: generic #! M: class generic def ; - over define-generic define-method ; + over define-generic -rot define-method ; : define-slot-word ( class slot word quot -- ) over [ diff --git a/library/generic/standard-combination.factor b/library/generic/standard-combination.factor index c06a6157b2..0836882bab 100644 --- a/library/generic/standard-combination.factor +++ b/library/generic/standard-combination.factor @@ -17,13 +17,10 @@ namespaces sequences vectors words ; : class-predicates ( picker assoc -- assoc ) [ uncons >r "predicate" word-prop append r> cons ] map-with ; -: alist>quot ( default alist -- quot ) - [ unswons [ % , , \ ifte , ] [ ] make ] each ; - -: sort-methods ( assoc -- vtable ) +: sort-methods ( assoc n -- vtable ) #! Input is a predicate -> method association. - num-types [ - type>class [ object ] unless* + [ + type>class [ object reintern ] unless* swap [ car classes-intersect? ] subset-with ] map-with ; @@ -38,17 +35,16 @@ namespaces sequences vectors words ; nip car cdr [ ] ] ifte ; -: vtable-methods ( picker alist-seq n -- alist-seq ) - [ - type>class [ object ] unless* - swap simplify-alist +: vtable-methods ( picker alist-seq -- alist-seq ) + dup length [ + type>class [ swap simplify-alist ] [ car cdr [ ] ] ifte* >r over r> class-predicates alist>quot ] 2map nip ; : ( picker word n -- vtable ) #! n is vtable size; either num-types or num-tags. - >r 2dup empty-method \ object swons >r methods r> swons - sort-methods r> vtable-methods ; + >r 2dup empty-method \ object reintern + swons >r methods r> swons r> sort-methods vtable-methods ; : small-generic ( picker word -- def ) 2dup methods class-predicates >r empty-method r> alist>quot ; diff --git a/library/generic/tuple.factor b/library/generic/tuple.factor index fc68b57edc..8fe4505def 100644 --- a/library/generic/tuple.factor +++ b/library/generic/tuple.factor @@ -67,8 +67,8 @@ words ; >r create-in dup intern-symbol dup tuple-predicate - dup tuple "superclass" set-word-prop - dup tuple "metaclass" set-word-prop + dup \ tuple reintern "superclass" set-word-prop + dup define-class dup r> tuple-slots default-constructor ; @@ -77,13 +77,8 @@ M: tuple clone ( tuple -- tuple ) (clone) dup delegate clone over set-delegate ; M: tuple hashcode ( vec -- n ) - #! If the capacity is two, then all we have is the class - #! slot and delegate. - dup array-capacity 2 number= [ - drop 0 - ] [ - 2 swap array-nth hashcode - ] ifte ; + #! Poor. + array-capacity ; M: tuple = ( obj tuple -- ? ) 2dup eq? [ @@ -92,9 +87,7 @@ M: tuple = ( obj tuple -- ? ) over tuple? [ array= ] [ 2drop f ] ifte ] ifte ; -tuple [ 2drop f ] "class<" set-word-prop - -PREDICATE: word tuple-class metaclass tuple = ; +PREDICATE: word tuple-class "tuple-size" word-prop ; : is? ( obj pred -- ? | pred: obj -- ? ) #! Tests if the object satisfies the predicate, or if diff --git a/library/generic/union.factor b/library/generic/union.factor deleted file mode 100644 index 7342ade6ca..0000000000 --- a/library/generic/union.factor +++ /dev/null @@ -1,24 +0,0 @@ -! Copyright (C) 2004, 2005 Slava Pestov. -! See http://factor.sf.net/license.txt for BSD license. -IN: generic -USING: errors hashtables kernel lists namespaces parser -sequences strings words vectors ; - -! Union metaclass for dispatch on multiple classes. -SYMBOL: union - -: union-predicate ( members -- list ) - [ - "predicate" word-prop \ dup swons [ drop t ] cons - ] map [ drop f ] swap alist>quot ; - -: set-members ( class members -- ) - 2dup [ types ] map concat "types" set-word-prop - "members" set-word-prop ; - -: define-union ( class predicate members -- ) - #! We have to turn the f object into the f word, same for t. - 3dup nip set-members pick union define-class - union-predicate define-predicate ; - -PREDICATE: word union metaclass union = ; diff --git a/library/inference/kill-literals.factor b/library/inference/kill-literals.factor index eaafb9938d..8348b531d8 100644 --- a/library/inference/kill-literals.factor +++ b/library/inference/kill-literals.factor @@ -1,121 +1,75 @@ ! Copyright (C) 2004, 2005 Slava Pestov. ! See http://factor.sf.net/license.txt for BSD license. IN: optimizer -USING: generic hashtables inference kernel lists -matrices namespaces sequences vectors ; +USING: arrays generic hashtables inference kernel +namespaces sequences ; + +: node-union ( node quot -- hash | quot: node -- seq ) + #! Build a hash with equal keys/values, effectively taking + #! the set union over all return values of the quotation. + [ + swap [ swap call [ dup set ] each ] each-node-with + ] make-hash ; inline GENERIC: literals* ( node -- seq ) -: literals ( node -- seq ) - [ [ literals* % ] each-node ] { } make prune ; +: literals ( node -- hash ) + [ literals* ] node-union ; -GENERIC: can-kill* ( literal node -- ? ) +GENERIC: live-values* ( node -- seq ) -: can-kill? ( literal node -- ? ) - dup [ - 2dup can-kill* [ - node-successor can-kill? - ] [ - 2drop f - ] ifte - ] [ - 2drop t - ] ifte ; +: live-values ( node -- hash ) + #! All values that are returned or passed to calls. + [ live-values* ] node-union ; -: kill-set ( node -- list ) +GENERIC: returns* + +: returns ( node -- hash ) + #! Trace all control flow paths, build a hash of + #! final #return nodes. + [ returns* ] node-union ; + +: kill-set ( node -- seq ) #! Push a list of literals that may be killed in the IR. - dup literals [ swap can-kill? ] subset-with ; + dup live-values swap literals hash-diff hash-keys ; : 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 ; + 2dup [ node-in-d remove-all ] keep set-node-in-d + 2dup [ node-out-d remove-all ] keep set-node-out-d + 2dup [ node-in-r remove-all ] keep set-node-in-r + [ node-out-r remove-all ] keep set-node-out-r ; : kill-node ( literals node -- ) [ remove-values ] each-node-with ; ! Generic nodes -M: node literals* ( node -- ) drop { } ; +M: node literals* ( node -- seq ) drop @{ }@ ; -M: node can-kill* ( literal node -- ? ) - uses-value? not ; +M: node live-values* ( node -- seq ) node-values ; + +M: node returns* ( node -- seq ) drop @{ }@ ; ! #shuffle -M: #shuffle literals* ( node -- ) +M: #shuffle literals* ( node -- seq ) node-out-d [ literal? ] subset ; -M: #shuffle can-kill* ( literal node -- ? ) 2drop t ; - -! #call-label -M: #call-label can-kill* ( literal node -- ? ) 2drop t ; - -! #merge -M: #merge can-kill* ( literal node -- ? ) 2drop t ; - -! #entry -M: #entry can-kill* ( literal node -- ? ) 2drop t ; - -! #values -M: #values can-kill* ( literal node -- ? ) 2drop t ; - ! #return -SYMBOL: branch-returns +M: #return returns* 1array ; -GENERIC: returns* +M: #return live-values* ( node -- seq ) + #! Values returned by local labels can be killed. + dup node-param [ drop @{ }@ ] [ delegate live-values* ] ifte ; +! nodes that don't use their input values directly +UNION: #killable #shuffle #call-label #merge #entry #values ; + +M: #killable live-values* ( node -- seq ) drop @{ }@ ; + +! branching UNION: #branch #ifte #dispatch ; -M: #branch returns* - node-children [ last-node returns* ] each ; - -M: #return returns* , ; - -M: node returns* node-successor returns* ; - -: returns ( node -- seq ) - #! Trace all control flow paths, build a sequence of - #! final #return nodes. - [ returns* ] { } make ; - -: branch-values ( branches -- ) - returns [ node-in-d ] map unify-lengths flip \ returns set ; - -M: #return can-kill* ( literal node -- ? ) - #! Values returned by local labels can be killed. - dup node-param [ - dupd uses-value? [ - \ returns get - [ memq? ] subset-with - [ [ eq? ] monotonic? ] all? - ] [ - drop t - ] ifte - ] [ - delegate can-kill* - ] ifte ; - -: can-kill-branches? ( literal node -- ? ) - #! Check if the literal appears in either branch. This - #! assumes that the last element of each branch is a #return - #! node. - 2dup uses-value? [ - 2drop f - ] [ - [ - dup branch-values - node-children [ can-kill? ] all-with? - ] with-scope - ] ifte ; - -! #ifte -M: #ifte can-kill* ( literal node -- ? ) - can-kill-branches? ; - -! #dispatch -M: #dispatch can-kill* ( literal node -- ? ) - can-kill-branches? ; - -! #label -M: #label can-kill* ( literal node -- ? ) - node-child can-kill? ; +M: #branch live-values* ( node -- seq ) + #! This assumes that the last element of each branch is a + #! #return node. + returns hash-keys [ node-in-d ] map unify-lengths flip + [ [ eq? ] monotonic? not ] subset concat ; diff --git a/library/inference/shuffle.factor b/library/inference/shuffle.factor index 0f66f5452a..65cb549b00 100644 --- a/library/inference/shuffle.factor +++ b/library/inference/shuffle.factor @@ -34,14 +34,14 @@ TUPLE: shuffle in-d in-r out-d out-r ; [ split-shuffle ] keep shuffle* join-shuffle ; : fix-compose-d ( s1 s2 -- ) - over shuffle-out-d over shuffle-in-d length< [ + over shuffle-out-d over shuffle-in-d [ length ] 2apply < [ over shuffle-out-d length over shuffle-in-d head* [ pick shuffle-in-d append pick set-shuffle-in-d ] keep pick shuffle-out-d append pick set-shuffle-out-d ] when 2drop ; : fix-compose-r ( s1 s2 -- ) - over shuffle-out-r over shuffle-in-r length< [ + over shuffle-out-r over shuffle-in-r [ length ] 2apply < [ over shuffle-out-r length over shuffle-in-r head* [ pick shuffle-in-r append pick set-shuffle-in-r ] keep pick shuffle-out-r append pick set-shuffle-out-r diff --git a/library/io/files.factor b/library/io/files.factor index cbecb1a4a8..1b63c18deb 100644 --- a/library/io/files.factor +++ b/library/io/files.factor @@ -12,7 +12,7 @@ USING: kernel lists namespaces sequences strings ; : directory? ( file -- ? ) stat car ; : directory ( dir -- list ) - (directory) { "." ".." } swap seq-diff string-sort ; + (directory) { "." ".." } swap remove-all string-sort ; : file-length ( file -- length ) stat third ; diff --git a/library/kernel.factor b/library/kernel.factor index 5351c40a1b..867cf0ff83 100644 --- a/library/kernel.factor +++ b/library/kernel.factor @@ -72,6 +72,9 @@ M: wrapper = ( obj wrapper -- ? ) : 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 +: 2apply ( x y quot -- | quot: x/y -- ) + tuck 2slip call ; inline + : ifte* ( cond true false -- | true: cond -- | false: -- ) #! [ X ] [ Y ] ifte* ==> dup [ X ] [ drop Y ] ifte pick [ drop call ] [ 2nip call ] ifte ; inline diff --git a/library/syntax/generic.factor b/library/syntax/generic.factor index 6b5e7eeb86..13d171a9c9 100644 --- a/library/syntax/generic.factor +++ b/library/syntax/generic.factor @@ -40,7 +40,7 @@ syntax words ; : M: ( -- class generic [ ] ) #! M: foo bar begins a definition of the bar generic word #! specialized to the foo type. - scan-word scan-word [ define-method ] [ ] ; parsing + scan-word scan-word [ -rot define-method ] [ ] ; parsing : C: #! Followed by a tuple name, then constructor code, then ; diff --git a/library/syntax/parse-stream.factor b/library/syntax/parse-stream.factor index aac3b2459c..41579638db 100644 --- a/library/syntax/parse-stream.factor +++ b/library/syntax/parse-stream.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2004, 2005 Slava Pestov. ! See http://factor.sf.net/license.txt for BSD license. IN: parser -USING: kernel lists namespaces sequences io words ; +USING: io kernel lists math namespaces sequences words ; : file-vocabs ( -- ) "scratchpad" "in" set @@ -10,7 +10,7 @@ USING: kernel lists namespaces sequences io words ; : parse-lines ( lines -- quot ) [ dup length [ ] - [ line-number set (parse) ] 2reduce + [ 1 + line-number set (parse) ] 2reduce reverse ] with-parser ; diff --git a/library/syntax/prettyprint.factor b/library/syntax/prettyprint.factor index f53dbe8ad9..7711bab667 100644 --- a/library/syntax/prettyprint.factor +++ b/library/syntax/prettyprint.factor @@ -226,7 +226,6 @@ M: string pprint* ( str -- str ) "\"" pprint-string ; M: sbuf pprint* ( str -- str ) "SBUF\" " pprint-string ; M: word pprint* ( word -- ) - dup interned? [ "( uninterned )" f text ] unless dup "pprint-before-hook" word-prop call dup pprint-word "pprint-after-hook" word-prop call ; @@ -360,6 +359,7 @@ M: wrapper pprint* ( wrapper -- ) { { POSTPONE: [ POSTPONE: ] } { POSTPONE: { POSTPONE: } } + { POSTPONE: @{ POSTPONE: }@ } { POSTPONE: {{ POSTPONE: }} } { POSTPONE: [[ POSTPONE: ]] } { POSTPONE: [[ POSTPONE: ]] } diff --git a/library/syntax/see.factor b/library/syntax/see.factor index b207da79d8..196306967a 100644 --- a/library/syntax/see.factor +++ b/library/syntax/see.factor @@ -81,7 +81,7 @@ GENERIC: class. ( word -- ) : methods. ( class -- ) #! List all methods implemented for this class. - dup metaclass [ + dup class? [ dup implementors [ dup in. tuck "methods" word-prop hash* method. ] each-with @@ -92,11 +92,11 @@ GENERIC: class. ( word -- ) M: union class. \ UNION: pprint-word dup pprint-word - "members" word-prop pprint-elements pprint-; newline ; + members pprint-elements pprint-; newline ; M: predicate class. \ PREDICATE: pprint-word - dup "superclass" word-prop pprint-word + dup superclass pprint-word dup pprint-word interp + continue + ] with-continuation global [ "x" off ] bind +] unit-test diff --git a/library/test/generic.factor b/library/test/generic.factor index b6e51d9c55..6f9d6e98af 100644 --- a/library/test/generic.factor +++ b/library/test/generic.factor @@ -1,19 +1,6 @@ +USING: hashtables namespaces generic test kernel math words +lists vectors alien sequences prettyprint io parser strings ; IN: temporary -USE: hashtables -USE: namespaces -USE: generic -USE: test -USE: kernel -USE: math -USE: words -USE: lists -USE: vectors -USE: alien -USE: sequences -USE: prettyprint -USE: io -USE: parser -USE: strings GENERIC: class-of @@ -80,6 +67,8 @@ M: very-funny gooey sq ; [ 1/4 ] [ 1/2 gooey ] unit-test +[ cons ] [ [ 1 2 ] class ] unit-test + [ object ] [ object object class-and ] unit-test [ fixnum ] [ fixnum object class-and ] unit-test [ fixnum ] [ object fixnum class-and ] unit-test @@ -87,14 +76,9 @@ M: very-funny gooey sq ; [ fixnum ] [ fixnum integer class-and ] unit-test [ fixnum ] [ integer fixnum class-and ] unit-test [ null ] [ vector fixnum class-and ] unit-test -[ integer ] [ fixnum bignum class-or ] unit-test -[ integer ] [ fixnum integer class-or ] unit-test -[ rational ] [ ratio integer class-or ] unit-test [ number ] [ number object class-and ] unit-test [ number ] [ object number class-and ] unit-test -[ cons ] [ [ 1 2 ] class ] unit-test - [ t ] [ \ fixnum \ integer class< ] unit-test [ t ] [ \ fixnum \ fixnum class< ] unit-test [ f ] [ \ integer \ fixnum class< ] unit-test @@ -114,10 +98,16 @@ M: very-funny gooey sq ; [ f ] [ \ reversed \ slice class< ] unit-test [ f ] [ \ slice \ reversed class< ] unit-test +TUPLE: a ; +TUPLE: b ; +UNION: c a b ; + +[ t ] [ \ c \ tuple class< ] unit-test +[ f ] [ \ tuple \ c class< ] unit-test + DEFER: bah FORGET: bah UNION: bah fixnum alien ; -[ bah ] [ fixnum alien class-or ] unit-test [ bah ] [ \ bah? "predicating" word-prop ] unit-test DEFER: complement-test diff --git a/library/tools/debugger.factor b/library/tools/debugger.factor index a3d70eb475..48edc596fb 100644 --- a/library/tools/debugger.factor +++ b/library/tools/debugger.factor @@ -132,7 +132,7 @@ M: object error. ( error -- ) . ; : init-error-handler ( -- ) [ die ] quot>interp >c ( last resort ) - [ print-error die ] quot>interp >c + [ global [ print-error ] bind die ] quot>interp >c ( kernel calls on error ) [ datastack dupd callstack namestack catchstack diff --git a/library/tools/inspector.factor b/library/tools/inspector.factor index f522c8aaaf..d5e1925421 100644 --- a/library/tools/inspector.factor +++ b/library/tools/inspector.factor @@ -38,7 +38,9 @@ SYMBOL: inspector-slots flip [ " | " join ] map ; -: vocab-banner ( word -- ) +GENERIC: extra-banner ( obj -- ) + +M: word extra-banner ( word -- ) dup word-vocabulary [ dup interned? [ "This word is located in the " write @@ -52,15 +54,6 @@ SYMBOL: inspector-slots "The word is a uniquely generated symbol." print ] ifte ; -GENERIC: extra-banner ( obj -- ) - -M: word extra-banner ( obj -- ) - dup vocab-banner - metaclass [ - "This is a class whose behavior is specifed by the " write - pprint " metaclass." print - ] when* ; - M: object extra-banner ( obj -- ) drop ; : inspect-banner ( obj -- ) diff --git a/library/vocabularies.factor b/library/vocabularies.factor index 9d7f396b09..3fc21d2a0f 100644 --- a/library/vocabularies.factor +++ b/library/vocabularies.factor @@ -4,6 +4,9 @@ IN: words USING: hashtables errors kernel lists namespaces strings sequences ; +! If true in current namespace, we are bootstrapping. +SYMBOL: bootstrapping? + SYMBOL: vocabularies : word ( -- word ) \ word global hash ; @@ -75,13 +78,19 @@ SYMBOL: vocabularies #! Test if the word is a member of its vocabulary. dup word-name over word-vocabulary lookup eq? ; +: reintern ( word -- word ) + dup word-name swap word-vocabulary + bootstrapping? get [ + dup "syntax" = [ drop "!syntax" ] when + ] when lookup ; + "scratchpad" "in" set [ + "scratchpad" "syntax" "arrays" "compiler" "errors" "generic" "hashtables" "help" "inference" "inspector" "interpreter" "io" "jedit" "kernel" "listener" "lists" "math" "memory" "namespaces" "parser" "prettyprint" "queues" "sequences" "shells" "strings" "styles" "test" "threads" "vectors" "words" - "scratchpad" ] "use" set diff --git a/native/run.c b/native/run.c index ecc72a28ab..b007fc684b 100644 --- a/native/run.c +++ b/native/run.c @@ -2,7 +2,7 @@ INLINE void execute(F_WORD* word) { - call_into_factor((XT)word->xt,word); + ((XT)(word->xt))(word); } void run(void)