steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

dataflow optimizer work

cvs
Slava Pestov 2005-08-07 04:00:57 +00:00
parent 7aaacb19dd
commit 606b9b878f
29 changed files with 551 additions and 508 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
library/bootstrap/boot-stage1.factor
View File

@ -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"

2
library/bootstrap/boot-stage3.factor
View File

@ -32,8 +32,6 @@ init-assembler
: compile? "compile" get supported-cpu? and ;
"library/inference/branches.factor" run-file
compile? [
\ car compile
\ * compile

98
library/bootstrap/image.factor
View File

@ -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 )
<mirror> 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 <vector> image set
<namespace> "objects" set
20000 <hashtable> 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 ;

4
library/collections/hashtables.factor
View File

@ -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 <hashtable> swap

2
library/collections/sequences.factor
View File

@ -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

9
library/collections/strings-epilogue.factor
View File

@ -4,9 +4,11 @@ IN: strings
USING: generic kernel kernel-internals lists math namespaces
sequences strings ;
: empty-sbuf ( len -- sbuf ) dup <sbuf> [ set-length ] keep ;
: empty-sbuf ( len -- sbuf )
dup <sbuf> [ set-length ] keep ; inline
: fill ( count char -- string ) <repeated> >string ;
: fill ( count char -- string )
<repeated> >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 <sbuf> [ push ] keep (sbuf>string) ;
: >sbuf ( seq -- sbuf ) dup length <sbuf> [ swap nappend ] keep ;
: >sbuf ( seq -- sbuf )
dup length <sbuf> [ swap nappend ] keep ; inline
M: object >string >sbuf (sbuf>string) ;

5
library/collections/vectors-epilogue.factor
View File

@ -5,10 +5,11 @@ math-internals sequences ;
IN: vectors
: empty-vector ( len -- vec ) dup <vector> [ set-length ] keep ;
: empty-vector ( len -- vec )
dup <vector> [ set-length ] keep ; inline
: >vector ( list -- vector )
dup length <vector> [ swap nappend ] keep ;
dup length <vector> [ swap nappend ] keep ; inline
M: object thaw >vector ;

68
library/combinators.factor
View File

@ -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 ;

4
library/compiler/intrinsics.factor
View File

@ -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

2
library/compiler/linearizer.factor
View File

@ -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 ;

2
library/generic/tuple.factor
View File

@ -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 ;

15
library/inference/branches.factor
View File

@ -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 [ <literal> ] map
#dispatch pop-d drop infer-branches
] "infer" set-word-prop

4
library/inference/class-infer.factor
View File

@ -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 <class-tie>

94
library/inference/dataflow.factor
View File

@ -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 ) <value> over set-delegate ;
TUPLE: literal value ;
C: literal ( obj -- value )
<value> over set-delegate
[ set-literal-value ] keep ;
TUPLE: meet values ;
C: meet ( values -- value )
<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 <vector> 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 ;

52
library/inference/inference.factor
View File

@ -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 ) <value> over set-delegate ;
TUPLE: literal value ;
C: literal ( obj -- value )
<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 )
<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.

17
library/inference/inline-methods.factor
View File

@ -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 )

155
library/inference/kill-literals.factor Normal file
View File

@ -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 ;

91
library/inference/known-words.factor Normal file
View File

@ -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 [ <literal> ] 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
\ <no-method> [ [ 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

174
library/inference/optimizer.factor
View File

@ -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 ;

4
library/inference/recursive-values.factor
View File

@ -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

39
library/inference/stack.factor
View File

@ -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

59
library/inference/words.factor
View File

@ -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
\ <no-method> [ [ 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, ;

85
library/kernel.factor
View File

@ -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 ;

22
library/stack.factor
View File

@ -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 ;

17
library/syntax/prettyprint.factor
View File

@ -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 )

14
library/test/compiler/optimizer.factor
View File

@ -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 ] [ <literal> ] 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

2
library/test/hashtables.factor
View File

@ -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

4
library/test/sequences.factor
View File

@ -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

5
library/test/tuple.factor
View File

@ -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