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

fixing various compiler and inferencer bugs

cvs
Slava Pestov 2005-11-23 02:41:41 +00:00
parent d0eff0b9f0
commit 81c39d3368
18 changed files with 187 additions and 124 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
TODO.FACTOR.txt
View File

@ -1,3 +1,11 @@
- flip-branches optimizer not working
- prettyprint:
{ V{ T{ literal T{ value f f G:110886 } f } T{ value
f f G:110887
} } }
- make-pane: if no input, just return pane-output
- intrinsic char-slot set-char-slot for x86
- closing ui does not stop timers
@ -69,8 +77,6 @@
- flushing optimization
- [ [ dup call ] dup call ] infer hangs
- the invalid recursion form case needs to be fixed, for inlines too
- recursion is iffy; if the stack at the recursive call doesn't match
up, throw an error
- compile continuations
+ sequences:
@ -85,6 +91,10 @@
+ kernel:
- first-class methods:
- methods outliner
- annotations for methods
- docstrings, and originating source file for methods
- better handling of random arrangements of html words when
prettyprinting
- reader syntax for byte arrays, displaced aliens

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

@ -123,7 +123,6 @@ vectors words ;
"/library/inference/inference.factor"
"/library/inference/branches.factor"
"/library/inference/words.factor"
"/library/inference/recursive-values.factor"
"/library/inference/class-infer.factor"
"/library/inference/kill-literals.factor"
"/library/inference/split-nodes.factor"

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

@ -44,7 +44,7 @@ compile? [
{
uncons 1+ 1- + <= > >= mod length
nth-unsafe set-nth-unsafe
= string>number number>string scan solve-recursion
= string>number number>string scan
kill-set kill-node (generate)
} [ compile ] each
] when

22
library/collections/lists.factor
View File

@ -15,15 +15,25 @@ M: cons peek ( list -- last )
#! Last element of a list.
last car ;
M: f each ( list quot -- ) 2drop ;
: (list-each) ( list quot -- )
over [
[ >r car r> call ] 2keep >r cdr r> (list-each)
] [
2drop
] if ; inline
M: cons each ( list quot -- | quot: elt -- )
[ >r car r> call ] 2keep >r cdr r> each ;
M: general-list each ( list quot -- | quot: elt -- )
(list-each) ;
M: f map ( f quot -- f ) drop ;
: (list-map) ( list quot -- list )
over [
over cdr over >r >r >r car r> call
r> r> rot >r (list-map) r> swons
] [
drop
] if ; inline
M: cons map ( cons quot -- cons )
over cdr over >r >r >r car r> call r> r> rot >r map r> swons ;
M: general-list map ( list quot -- list ) (list-map) ;
: (list-find) ( list quot i -- i elt )
pick [

2
library/collections/sequence-sort.factor
View File

@ -44,8 +44,6 @@ C: sorter ( seq start end -- sorter )
] when
] when ; inline
DEFER: (nsort)
: (nsort) ( quot seq start end -- )
2dup < [
<sorter> sort-step

7
library/collections/sequences-epilogue.factor
View File

@ -79,12 +79,13 @@ M: object >list ( seq -- list ) dup length 0 rot (>list) ;
#! consecutive indices numbered from 'start'.
3dup copy-into-check
dup length [ >r pick r> + pick set-nth-unsafe ] 2each 2drop ;
inline
: 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 ;
copy-into ; inline
: append ( s1 s2 -- s1+s2 )
#! Outputs a new sequence of the same type as s1.
@ -122,11 +123,11 @@ M: object peek ( sequence -- element )
#! Shorten the sequence by one element.
[ length 1- ] keep
[ 0 -rot set-nth ] 2keep
set-length ;
set-length ; inline
: pop ( sequence -- element )
#! Get value at end of sequence and remove it.
dup peek swap pop* ;
dup peek swap pop* ; inline
: join ( seq glue -- seq )
#! The new sequence is of the same type as glue.

4
library/collections/virtual-sequences.factor
View File

@ -47,9 +47,9 @@ C: slice ( from to seq -- seq )
>r 3dup check-slice r>
[ set-slice-seq ] keep
[ set-slice-to ] keep
[ set-slice-from ] keep ;
[ set-slice-from ] keep ; inline
: <range> ( from to -- seq ) dup <slice> ;
: <range> ( from to -- seq ) dup <slice> ; inline
M: slice length ( range -- n )
dup slice-to swap slice-from - ;

19
library/compiler/linearizer.factor
View File

@ -19,18 +19,21 @@ M: f linearize* ( f -- ) drop ;
M: node linearize* ( node -- ) linearize-next ;
M: #label linearize* ( node -- )
#! We remap the IR node's label to a new label object here,
#! to avoid problems with two IR #label nodes having the
#! same label in different lexical scopes.
<label> [
%return-to ,
dup node-param %label ,
<label> dup pick node-param set %label ,
dup node-child linearize*
] keep %label ,
linearize-next ;
: ?tail-call ( node caller jumper -- next )
>r >r dup node-successor #return? [
node-param r> drop r> execute ,
: ?tail-call ( node label caller jumper -- next )
>r >r over node-successor #return? [
r> drop r> execute , drop
] [
dup node-param r> execute , r> drop linearize-next
r> execute , r> drop linearize-next
] if ; inline
: intrinsic ( #call -- quot ) node-param "intrinsic" word-prop ;
@ -53,12 +56,12 @@ M: #call linearize* ( node -- )
dup intrinsic [
dupd call linearize-next
] [
\ %call \ %jump ?tail-call
dup node-param \ %call \ %jump ?tail-call
] if*
] if* ;
M: #call-label linearize* ( node -- )
\ %call-label \ %jump-label ?tail-call ;
dup node-param get \ %call-label \ %jump-label ?tail-call ;
M: #if linearize* ( node -- )
<label> dup in-1 -1 %inc-d , 0 %jump-t , linearize-if ;
@ -81,6 +84,4 @@ M: #dispatch linearize* ( vtable -- )
node-children dispatch-head dispatch-body ;
M: #return linearize* ( node -- )
#! Simple label returns do not count, since simple labels do
#! not push a stack frame on the C stack.
drop %return , ;

2
library/inference/dataflow.factor
View File

@ -64,7 +64,7 @@ C: #label make-node ;
TUPLE: #entry ;
C: #entry make-node ;
: #entry ( -- node ) meta-d get clone in-node <#entry> ;
: #entry ( -- node ) f param-node <#entry> ;
TUPLE: #call ;
C: #call make-node ;

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

@ -50,8 +50,7 @@ M: 2generic dispatching-values drop node-in-d 2 swap tail* ;
dup inlining-class swap node-param "methods" word-prop hash ;
: method-dataflow ( node -- dataflow )
dup will-inline swap node-in-d dataflow-with
dup solve-recursion ;
dup will-inline swap node-in-d dataflow-with ;
: inline-method ( node -- node )
#! We set the #call node's param to f so that it gets killed

21
library/inference/kill-literals.factor
View File

@ -63,16 +63,19 @@ M: #return live-values* ( node -- seq )
dup node-param [ drop { } ] [ delegate live-values* ] if ;
! nodes that don't use their input values directly
UNION: #killable #shuffle #call-label #merge #values ;
UNION: #killable #shuffle #call-label #merge #values #entry ;
M: #killable live-values* ( node -- seq ) drop { } ;
! #entry
M: #entry live-values* ( node -- seq )
#! The live values are those which appear in the in-d but
#! not in the out-d. These are literals which are replaced
#! by computed values in the solve-recursion step.
node-out-d ;
: purge-invariants ( stacks -- seq )
#! Output a sequence of values which are not present in the
#! same position in each sequence of the stacks sequence.
unify-lengths flip [ all-eq? not ] subset concat ;
! #label
M: #label live-values* ( node -- seq )
dup node-child node-in-d
>r collect-recursion r> add purge-invariants ;
! branching
UNION: #branch #if #dispatch ;
@ -82,5 +85,5 @@ M: #branch returns* ( node -- ) node-children [ returns* ] each ;
M: #branch live-values* ( node -- )
#! This assumes that the last element of each branch is a
#! #return node.
dup delegate live-values* >r returns [ node-in-d ] map
unify-lengths purge-invariants r> append ;
dup delegate live-values*
>r returns [ node-in-d ] map purge-invariants r> append ;

4
library/inference/optimizer.factor
View File

@ -39,9 +39,7 @@ DEFER: optimize-node
optimize-1 [ optimize-loop ] when ;
: optimize ( dataflow -- dataflow )
[
dup solve-recursion dup split-node optimize-loop
] with-scope ;
[ dup split-node optimize-loop ] with-scope ;
: prune-if ( node quot -- successor/t )
over >r call [ r> node-successor ] [ r> drop t ] if ;

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

@ -1,47 +0,0 @@
! Copyright (C) 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: optimizer
USING: inference kernel namespaces prettyprint sequences vectors ;
GENERIC: collect-recursion* ( label node -- )
M: node collect-recursion* ( label node -- ) 2drop ;
M: #call-label collect-recursion* ( label node -- )
tuck node-param = [ node-in-d , ] [ drop ] if ;
: collect-recursion ( #label -- seq )
#! Collect the input stacks of all #call-label nodes that
#! call given label.
dup node-param swap
[ [ collect-recursion* ] each-node-with ] { } make ;
GENERIC: solve-recursion*
M: node solve-recursion* ( node -- ) drop ;
: purge-invariants ( stacks -- seq )
#! Output a sequence of values which are not present in the
#! same position in each sequence of the stacks sequence.
flip [ all-eq? not ] subset concat ;
: join-values ( calls entry -- new old live )
add unify-lengths
[ flip [ unify-values ] map ] keep
[ peek ] keep
purge-invariants ;
: entry-values ( node -- new old live )
dup collect-recursion swap node-child node-in-d join-values ;
M: #label solve-recursion* ( node -- )
#! #entry node-out-d is abused; its not a stack slice, but
#! a set of values.
[ entry-values ] keep node-child
[ set-node-out-d ] keep
node-successor subst-values ;
: solve-recursion ( node -- )
#! Figure out which values survive inner recursions in
#! #labels, and those that don't should be fudged.
[ solve-recursion* ] each-node ;

102
library/inference/words.factor
View File

@ -30,18 +30,71 @@ TUPLE: rstate label quot base-case? ;
: with-recursive-state ( word label base-case quot -- )
>r >r over word-def r> <rstate> cons
recursive-state [ cons ] change r>
call
recursive-state [ cdr ] change ; inline
call ; inline
: inline-block ( word base-case -- node-block )
>r gensym 2dup r> [
[
dup #label >r
#entry node,
swap word-def infer-quot
#return node, r>
] with-nesting
] with-recursive-state ;
: inline-block ( word base-case -- node-block variables )
[
copy-inference
>r gensym 2dup r> [
[
dup #label >r
#entry node,
swap word-def infer-quot
#return node, r>
] with-nesting
] with-recursive-state
] make-hash ;
: apply-infer ( hash -- )
{ meta-d meta-r d-in }
[ [ swap hash ] keep set ] each-with ;
GENERIC: collect-recursion* ( label node -- )
M: node collect-recursion* ( label node -- ) 2drop ;
M: #call-label collect-recursion* ( label node -- )
tuck node-param = [ node-in-d , ] [ drop ] if ;
: collect-recursion ( #label -- seq )
#! Collect the input stacks of all #call-label nodes that
#! call given label.
dup node-param swap
[ [ collect-recursion* ] each-node-with ] { } make ;
: amend-d-in ( new old -- )
[ length ] 2apply - d-in [ + ] change ;
: join-values ( node -- )
#! We have to infer recursive labels twice to determine
#! which literals survive the recursion (eg, quotations)
#! and which don't (loop indices, etc). The latter cannot
#! be folded.
meta-d get [
>r collect-recursion r> add unify-lengths
flip [ unify-values ] map dup meta-d set
] keep amend-d-in ;
: splice-node ( node -- )
#! Labels which do not call themselves are just spliced into
#! the IR, and no #label node is added.
dup node-successor [
dup node, penultimate-node f over set-node-successor
dup current-node set
] when drop ;
: inline-closure ( word -- )
#! This is not a closure in the lexical scope sense, but a
#! closure under recursive value substitution.
#! If the block does not call itself, there is no point in
#! having the block node in the IR. Just add its contents.
dup f inline-block over recursive-label? [
meta-d get >r
drop join-values f inline-block apply-infer
r> over node-child set-node-in-d node,
] [
apply-infer node-child node-successor splice-node drop
] if ;
: infer-compound ( word base-case -- terminates? effect )
#! Infer a word's stack effect in a separate inferencer
@ -49,8 +102,8 @@ TUPLE: rstate label quot base-case? ;
#! control flow by throwing an exception or restoring a
#! continuation.
[
recursive-state get init-inference
over >r inline-block drop terminated? get effect r>
recursive-state get init-inference over >r inline-block
nip [ terminated? get effect ] bind r>
] with-scope over consume/produce over [ terminate ] when ;
GENERIC: apply-word
@ -92,10 +145,8 @@ M: symbol apply-object ( word -- )
apply-literal ;
: inline-base-case ( word label -- )
meta-d get clone >r
over t inline-block drop
[ #call-label ] [ #call ] ?if
r> over set-node-in-d node, ;
meta-d get clone >r over t inline-block apply-infer drop
[ #call-label ] [ #call ] ?if r> over set-node-in-d node, ;
: base-case ( word label -- )
over "inline" word-prop [
@ -134,26 +185,11 @@ M: symbol apply-object ( word -- )
] if*
] if* ;
: splice-node ( node -- )
dup node-successor [
dup node, penultimate-node f over set-node-successor
dup current-node set
] when drop ;
: block, ( block -- )
#! If the block does not call itself, there is no point in
#! having the block node in the IR. Just add its contents.
dup recursive-label? [
node,
] [
node-child node-successor splice-node
] if ;
M: compound apply-object ( word -- )
#! Apply the word's stack effect to the inferencer state.
dup recursive-state get assoc [
recursive-word
] [
dup "inline" word-prop
[ f inline-block block, ] [ apply-default ] if
[ inline-closure ] [ apply-default ] if
] if* ;

18
library/test/benchmark/iteration.factor Normal file
View File

@ -0,0 +1,18 @@
IN: temporary
USING: arrays compiler kernel kernel-internals lists math
sequences strings test vectors sequences-internals ;
: list-iter 100 [ 0 100000 <range> >list [ ] map drop ] times ; compiled
: vector-iter 100 [ 0 100000 <range> >vector [ ] map drop ] times ; compiled
: array-iter 100 [ 0 100000 <range> >array [ ] map drop ] times ; compiled
: string-iter 100 [ 0 100000 <range> >string [ ] map drop ] times ; compiled
: sbuf-iter 100 [ 0 100000 <range> >sbuf [ ] map drop ] times ; compiled
: reverse-iter 100 [ 0 100000 <range> >vector <reversed> [ ] map drop ] times ; compiled
: dot-iter 100 [ 0 100000 <range> dup v. drop ] times ; compiled
[ ] [ list-iter ] unit-test
[ ] [ vector-iter ] unit-test
[ ] [ array-iter ] unit-test
[ ] [ string-iter ] unit-test
[ ] [ sbuf-iter ] unit-test
[ ] [ reverse-iter ] unit-test

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

@ -1,6 +1,7 @@
USING: arrays assembler compiler compiler-backend generic
hashtables inference kernel kernel-internals lists math
optimizer prettyprint sequences strings test vectors words ;
optimizer prettyprint sequences strings test vectors words
sequences-internals ;
IN: temporary
: kill-1
@ -38,7 +39,7 @@ IN: temporary
: set= 2dup subset? >r swap subset? r> and ;
: kill-set=
dataflow dup solve-recursion dup split-node
dataflow dup split-node
kill-set hash-keys [ literal-value ] map set= ;
: foo 1 2 3 ;
@ -100,6 +101,14 @@ IN: temporary
[ 4 ] [ 2 2 literal-kill-test-7 ] unit-test
: literal-kill-test-8
dup [ >r dup slip r> literal-kill-test-8 ] [ 2drop ] if ; inline
[ t ] [
[ [ ] swap literal-kill-test-8 ] dataflow
dup split-node live-values hash-values [ literal? ] subset empty?
] unit-test
! Test method inlining
[ string ] [
\ string
@ -211,3 +220,21 @@ TUPLE: pred-test ;
: the-test 2 dup (the-test) ; compiled
[ 2 0 ] [ the-test ] unit-test
! regression
: (double-recursion) ( start end -- )
< [
6 1 (double-recursion)
3 2 (double-recursion)
] when ; inline
: double-recursion 0 2 (double-recursion) ; compiled
[ ] [ double-recursion ] unit-test
: double-label-1
[ f double-label-1 ] [ swap nth-unsafe ] if ; inline
: double-label-2
dup general-list? [ ] [ ] if 0 t double-label-1 ; compiled
[ 0 ] [ 10 double-label-2 ] unit-test

10
library/test/inference.factor
View File

@ -204,6 +204,16 @@ DEFER: blah4
: blah4 dup [ blah4 ] [ dup [ 3drop ] [ blah3 ] if ] if ;
[ { 3 0 } ] [ [ blah4 ] infer ] unit-test
! Regression
: bad-combinator ( obj quot -- )
over [
2drop
] [
[ swap slip ] keep swap bad-combinator
] if ; inline
[ [ [ 1 ] [ ] bad-combinator ] infer ] unit-test-fails
[ { 2 1 } ] [ [ swons ] infer ] unit-test
[ { 1 2 } ] [ [ uncons ] infer ] unit-test
[ { 1 1 } ] [ [ unit ] infer ] unit-test

2
library/test/test.factor
View File

@ -103,7 +103,7 @@ SYMBOL: failures
"benchmark/continuations" "benchmark/ack"
"benchmark/hashtables" "benchmark/strings"
"benchmark/vectors" "benchmark/prettyprint"
"benchmark/image"
"benchmark/image" "benchmark/iteration"
} run-tests ;
: compiler-tests