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

remove meets

cvs get-rid-of-meets
Slava Pestov 2005-09-17 08:15:05 +00:00
parent 59854a2546
commit b0426d93e4
14 changed files with 101 additions and 142 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

17
examples/raytracer.factor
View File

@ -7,11 +7,7 @@ IN: ray
! parameters
: light
#! Normalized { -1 -3 2 }.
@{
-0.2672612419124244
-0.8017837257372732
0.5345224838248488
}@ ; inline
@{ -0.2672612419124244 -0.8017837257372732 0.5345224838248488 }@ ; inline
: oversampling 4 ; inline
@ -125,7 +121,7 @@ DEFER: create ( level c r -- scene )
pick 1 = [ <sphere> nip ] [ create-group ] ifte ;
: ss-point ( dx dy -- point )
>r oversampling /f r> oversampling /f 0.0 3array ;
[ oversampling /f ] 2apply 0.0 3array ;
: ss-grid ( -- ss-grid )
oversampling [ oversampling [ ss-point ] map-with ] map ;
@ -142,14 +138,7 @@ DEFER: create ( level c r -- scene )
: pixel-grid ( -- grid )
size reverse [
size [
size 0.5 * - swap size 0.5 * - size >float 3array
] map-with
] map ;
: pixel-grid ( -- grid )
size reverse [
size [
size 0.5 * - swap size 0.5 * - size >float 3array
[ size 0.5 * - ] 2apply swap size >float 3array
] map-with
] map ;

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

@ -3,7 +3,7 @@
USING: alien assembler command-line compiler compiler-backend
errors generic hashtables io io-internals kernel
kernel-internals lists math memory namespaces parser sequences
words ;
sequences-internals words ;
: pull-in ( ? list -- )
swap [
@ -75,9 +75,11 @@ t [
compile? [
"Compiling base..." print
{ car * length nth = string>number number>string scan (generate) }
[ compile ]
each
{
uncons 1+ 1- + <= > >= mod length
nth-unsafe set-nth-unsafe
= string>number number>string scan (generate)
} [ compile ] each
] when
compile? [

2
library/bootstrap/image.factor
View File

@ -32,7 +32,7 @@ SYMBOL: 64-bits
] [
dup 1 32 shift 1- bitand
swap -32 shift 1 32 shift 1- bitand
big-endian get [ swap ] unless
big-endian get [ swap ] when
emit emit
] ifte ;

3
library/collections/hashtables.factor
View File

@ -70,8 +70,7 @@ IN: hashtables
: hash>alist ( hash -- alist )
#! Push a list of key/value pairs in a hashtable.
[ ] swap [ hash-bucket [ swons ] each ] each-bucket ;
flushable
underlying concat ; flushable
: (set-hash) ( value key hash -- )
dup hash-size+ [ set-assoc ] set-hash* ;

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

@ -36,6 +36,15 @@ 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
: (subst) ( newseq oldseq elt -- new/elt )
[ swap index ] keep
over -1 > [ drop swap nth ] [ 2nip ] ifte ;
: subst ( newseq oldseq seq -- )
#! Mutates seq. If an element of seq occurs in oldseq,
#! replace it with the corresponding element in newseq.
[ >r 2dup r> (subst) ] inject 2drop ;
: move ( to from seq -- )
pick pick number=
[ 3drop ] [ [ nth swap ] keep set-nth ] ifte ; inline

2
library/inference/branches.factor
View File

@ -16,7 +16,7 @@ namespaces parser prettyprint sequences strings vectors words ;
: unify-values ( seq -- value )
#! If all values in list are equal, return the value.
#! Otherwise, unify.
dup [ eq? ] monotonic? [ first ] [ <meet> ] ifte ;
dup [ eq? ] monotonic? [ first ] [ drop <computed> ] ifte ;
: unify-stacks ( seq -- stack )
#! Replace differing literals in stacks with unknown

70
library/inference/dataflow.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2004, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: inference
USING: arrays generic hashtables interpreter kernel lists
USING: arrays generic hashtables interpreter kernel lists math
namespaces parser sequences words ;
! Recursive state. An alist, mapping words to labels.
@ -29,23 +29,6 @@ C: literal ( obj -- value )
M: literal hashcode value-uid hashcode ;
TUPLE: meet values ;
C: meet ( values -- value )
<value> over set-delegate [ set-meet-values ] keep ;
M: meet hashcode value-uid hashcode ;
: (flatten-value)
dup meet?
[ meet-values [ (flatten-value) ] each ] [ dup set ] ifte ;
: flatten-value ( value -- seq )
[ (flatten-value) ] make-hash hash-keys ;
: value-refers? ( referee referrer -- ? )
2dup eq? [ 2drop t ] [ flatten-value memq? ] 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.
@ -173,8 +156,7 @@ SYMBOL: current-node
dup node-in-r % node-out-r %
] { } make ;
: uses-value? ( value node -- ? )
node-values [ value-refers? ] contains-with? ;
: uses-value? ( value node -- ? ) node-values memq? ;
: outputs-value? ( value node -- ? )
2dup node-out-d member? >r node-out-r member? r> or ;
@ -228,53 +210,13 @@ SYMBOL: current-node
: all-nodes-with? ( obj node quot -- ? | quot: obj node -- ? )
swap [ with rot ] all-nodes? 2nip ; 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 swap value-refers? [
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) ] inject 2drop ] ifte ;
: (subst-values) ( newseq oldseq seq -- )
#! Mutates seq.
-rot [ pick subst-value ] 2each drop ;
: (subst-values) ( new old node -- )
[ node-in-d subst ] 3keep [ node-in-r subst ] 3keep
[ node-out-d subst ] 3keep node-out-r subst ;
: subst-values ( new old node -- )
#! Mutates the node.
[
{ } clone 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 ;
[ >r 2dup r> (subst-values) ] each-node 2drop ;
: remember-node ( word node -- )
#! Annotate each node with the fact it was inlined from

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

@ -5,14 +5,16 @@ USING: arrays generic hashtables inference kernel math
namespaces sequences ;
: node-union ( node quot -- hash | quot: node -- )
[ swap [ swap call ] each-node-with ] make-hash ; inline
[
swap [ swap call [ dup set ] each ] each-node-with
] make-hash ; inline
GENERIC: literals* ( node -- )
GENERIC: literals* ( node -- seq )
: literals ( node -- hash )
[ literals* ] node-union ;
GENERIC: live-values* ( node -- )
GENERIC: live-values* ( node -- seq )
: live-values ( node -- hash )
#! All values that are returned or passed to calls.
@ -38,51 +40,47 @@ M: f returns* drop ;
[ node-out-r remove-all ] keep set-node-out-r ;
: kill-node ( values node -- )
over hash-size 0 > [
[ remove-values ] each-node-with
] [
2drop
] ifte ;
over hash-size 0 >
[ [ remove-values ] each-node-with ] [ 2drop ] ifte ;
! Generic nodes
M: node literals* ( node -- ) drop ;
M: node literals* ( node -- ) drop @{ }@ ;
M: node live-values* ( node -- )
node-values [ (flatten-value) ] each ;
M: node live-values* ( node -- ) node-values ;
M: node returns* ( node -- seq ) node-successor returns* ;
! #shuffle
: shuffle-literals
[ dup literal? [ dup set ] [ drop ] ifte ] each ;
M: #shuffle literals* ( node -- )
dup node-out-d shuffle-literals
node-out-r shuffle-literals ;
M: #shuffle literals* ( node -- seq )
dup node-out-d swap node-out-r
[ [ literal? ] subset ] 2apply append ;
! #return
M: #return returns* , ;
M: #return live-values* ( node -- )
M: #return live-values* ( node -- seq )
#! Values returned by local labels can be killed.
dup node-param [ drop ] [ delegate live-values* ] ifte ;
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 ;
UNION: #killable #shuffle #call-label #merge #values ;
M: #killable live-values* ( node -- ) drop ;
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 ;
! branching
UNION: #branch #ifte #dispatch ;
M: #branch returns* ( node -- )
node-children [ returns* ] each ;
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*
returns [ node-in-d ] map unify-lengths flip [
dup [ eq? ] monotonic?
[ drop ] [ [ dup set ] each ] ifte
] each ;
dup delegate live-values* >r returns [ node-in-d ] map
unify-lengths purge-invariants r> append ;

4
library/inference/optimizer.factor
View File

@ -17,7 +17,9 @@ GENERIC: optimize-node* ( node -- node/t )
DEFER: optimize-node
: optimize-children ( node -- ? )
f swap node-children [ optimize-node swap >r or r> ] inject ;
f swap [
node-children [ optimize-node swap >r or r> ] map
] keep set-node-children ;
: optimize-node ( node -- node ? )
#! Outputs t if any changes were made.

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

@ -10,22 +10,36 @@ M: node collect-recursion* ( label node -- ) 2drop ;
M: #call-label collect-recursion* ( label node -- )
tuck node-param = [ node-in-d , ] [ drop ] ifte ;
: collect-recursion ( label node -- seq )
: collect-recursion ( #label -- seq )
#! Collect the input stacks of all #call-label nodes that
#! call given label.
[ [ collect-recursion* ] each-node-with ] { } make ;
dup node-param swap
[ [ collect-recursion* ] each-node-with ] @{ }@ make ;
GENERIC: solve-recursion*
M: node solve-recursion* ( node -- ) drop ;
: join-values ( calls entry -- new old )
add unify-lengths [ unify-stacks ] keep peek ;
: 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 [ [ eq? ] monotonic? 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 -- )
dup node-param over collect-recursion >r
node-child dup node-in-d r> swap
join-values rot subst-values ;
#! #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

2
library/io/files.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2004, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: io
USING: kernel lists namespaces sequences strings ;
USING: hashtables kernel lists namespaces sequences strings ;
! Words for accessing filesystem meta-data.

2
library/test/collections/hashtables.factor
View File

@ -185,3 +185,5 @@ f 100000000000000000000000000 "testhash" get set-hash
{{ [[ 2 4 ]] [[ 6 5 ]] }} {{ [[ 1 2 ]] [[ 2 3 ]] }}
hash-union
] unit-test
[ [ 1 3 ] ] [ {{ [[ 2 2 ]] }} [ 1 2 3 ] remove-all ] unit-test

8
library/test/collections/sequences.factor
View File

@ -98,8 +98,6 @@ unit-test
[ f ] [ 3 [ 1 2 3 ] tail ] unit-test
[ [ 3 ] ] [ 2 [ 1 2 3 ] tail ] unit-test
[ [ 1 3 ] ] [ [ 2 ] [ 1 2 3 ] remove-all ] unit-test
[ t ] [ [ 1 2 3 ] [ 1 2 3 ] sequence= ] unit-test
[ t ] [ [ 1 2 3 ] { 1 2 3 } sequence= ] unit-test
[ t ] [ { 1 2 3 } [ 1 2 3 ] sequence= ] unit-test
@ -160,3 +158,9 @@ unit-test
[ { 1 4 9 } ] [ { 1 2 3 } clone dup [ sq ] inject ] unit-test
[ { 3 4 5 } ] [ 2 { 1 2 3 } clone [ [ + ] inject-with ] keep ] unit-test
[ { "one" "two" "three" 4 5 6 } ]
[
{ "one" "two" "three" }
{ 1 2 3 } { 1 2 3 4 5 6 } clone [ subst ] keep
] unit-test

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

@ -1,7 +1,7 @@
IN: temporary
USING: arrays assembler compiler compiler-backend generic
inference kernel kernel-internals lists math optimizer
prettyprint sequences strings test vectors words ;
hashtables inference kernel kernel-internals lists math
optimizer prettyprint sequences strings test vectors words ;
: kill-1
[ 1 2 3 ] [ + ] over drop drop ; compiled
@ -33,17 +33,21 @@ prettyprint sequences strings test vectors words ;
[ [ 1 2 3 ] [ 4 5 6 ] [ 1 2 3 ] ] [ kill-6 ] unit-test
: kill-set*
: subset? swap [ swap member? ] all-with? ;
: set= 2dup subset? >r swap subset? r> and ;
: kill-set=
dataflow dup solve-recursion dup split-node
kill-set [ literal-value ] map ;
kill-set hash-keys [ literal-value ] map set= ;
: foo 1 2 3 ;
[ f ] [ \ 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
[ t ] [ [ [ 1 ] [ 2 ] ] [ [ 1 ] [ 2 ] ifte ] kill-set= ] unit-test
[ [ [ 1 ] [ 2 ] ] ] [ [ [ 1 ] [ 2 ] ifte ] kill-set* ] unit-test
[ t ] [ [ [ 1 ] [ 2 ] ] [ [ 1 ] [ 2 ] ifte ] kill-set= ] unit-test
: literal-kill-test-1 4 compiled-offset cell 2 * - ; compiled
@ -57,7 +61,7 @@ prettyprint sequences strings test vectors words ;
[ 3 ] [ literal-kill-test-3 ] unit-test
[ [ [ 3 ] [ dup ] 3 ] ] [ [ [ 3 ] [ dup ] ifte drop ] kill-set* ] unit-test
[ t ] [ [ [ 3 ] [ dup ] 3 ] [ [ 3 ] [ dup ] ifte drop ] kill-set= ] unit-test
: literal-kill-test-4
5 swap [ 3 ] [ dup ] ifte 2drop ; compiled
@ -65,14 +69,9 @@ prettyprint sequences strings test vectors words ;
[ ] [ t literal-kill-test-4 ] unit-test
[ ] [ f literal-kill-test-4 ] unit-test
: subset? swap [ swap member? ] all-with? ;
: set= 2dup subset? >r swap subset? r> and ;
[ t ] [
[ 5 [ 3 ] [ dup ] 3 ]
\ literal-kill-test-4 word-def kill-set*
set=
\ literal-kill-test-4 word-def kill-set=
] unit-test
: literal-kill-test-5
@ -83,8 +82,7 @@ prettyprint sequences strings test vectors words ;
[ t ] [
[ 5 [ 5 ] [ dup ] 5 ]
\ literal-kill-test-5 word-def kill-set*
set=
\ literal-kill-test-5 word-def kill-set=
] unit-test
: literal-kill-test-6
@ -94,7 +92,7 @@ prettyprint sequences strings test vectors words ;
[ ] [ f literal-kill-test-6 ] unit-test
[ t ] [ [
5 [ dup ] [ dup ] ] \ literal-kill-test-6 word-def kill-set* set=
5 [ dup ] [ dup ] ] \ literal-kill-test-6 word-def kill-set=
] unit-test
: literal-kill-test-7