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

More efficient locals

db4
Slava Pestov 2008-04-17 03:05:36 -05:00
parent b2a3bfa466
commit b4ce5c93e8
6 changed files with 142 additions and 79 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

40
core/inference/backend/backend.factor
View File

@ -15,7 +15,7 @@ GENERIC: inline? ( word -- ? )
M: method-body inline? M: method-body inline?
"method-generic" word-prop inline? ; "method-generic" word-prop inline? ;
M: tuple-dispatch-engine-word inline? M: engine-word inline?
"tuple-dispatch-generic" word-prop inline? ; "tuple-dispatch-generic" word-prop inline? ;
M: word inline? M: word inline?
@ -130,25 +130,27 @@ TUPLE: too-many->r ;
TUPLE: too-many-r> ; TUPLE: too-many-r> ;
: check-r> ( -- ) : check-r> ( n -- )
meta-r get empty? meta-r get length >
[ \ too-many-r> inference-error ] when ; [ \ too-many-r> inference-error ] when ;
: infer->r ( -- ) : infer->r ( n -- )
1 ensure-values dup ensure-values
#>r #>r
1 0 pick node-inputs over 0 pick node-inputs
pop-d push-r over [ drop pop-d ] map reverse [ push-r ] each
0 1 pick node-outputs 0 pick pick node-outputs
node, ; node,
drop ;
: infer-r> ( -- ) : infer-r> ( n -- )
check-r> dup check-r>
#r> #r>
0 1 pick node-inputs 0 pick pick node-inputs
pop-r push-d over [ drop pop-r ] map reverse [ push-d ] each
1 0 pick node-outputs over 0 pick node-outputs
node, ; node,
drop ;
: undo-infer ( -- ) : undo-infer ( -- )
recorded get [ f "inferred-effect" set-word-prop ] each ; recorded get [ f "inferred-effect" set-word-prop ] each ;
@ -199,18 +201,18 @@ M: object constructor drop f ;
dup infer-uncurry dup infer-uncurry
constructor [ constructor [
peek-d reify-curry peek-d reify-curry
infer->r 1 infer->r
peek-d reify-curry peek-d reify-curry
infer-r> 1 infer-r>
2 1 <effect> swap #call consume/produce 2 1 <effect> swap #call consume/produce
] when* ; ] when* ;
: reify-curries ( n -- ) : reify-curries ( n -- )
meta-d get reverse [ meta-d get reverse [
dup special? [ dup special? [
over [ infer->r ] times over infer->r
dup reify-curry dup reify-curry
over [ infer-r> ] times over infer-r>
] when 2drop ] when 2drop
] 2each ; ] 2each ;

8
core/inference/known-words/known-words.factor
View File

@ -54,9 +54,9 @@ IN: inference.known-words
{ swap T{ effect f 2 { 1 0 } } } { swap T{ effect f 2 { 1 0 } } }
} [ define-shuffle ] assoc-each } [ define-shuffle ] assoc-each
\ >r [ infer->r ] "infer" set-word-prop \ >r [ 1 infer->r ] "infer" set-word-prop
\ r> [ infer-r> ] "infer" set-word-prop \ r> [ 1 infer-r> ] "infer" set-word-prop
\ declare [ \ declare [
1 ensure-values 1 ensure-values
@ -81,8 +81,8 @@ M: curried infer-call
M: composed infer-call M: composed infer-call
infer-uncurry infer-uncurry
infer->r peek-d infer-call 1 infer->r peek-d infer-call
terminated? get [ infer-r> peek-d infer-call ] unless ; terminated? get [ 1 infer-r> peek-d infer-call ] unless ;
M: object infer-call M: object infer-call
\ literal-expected inference-warning ; \ literal-expected inference-warning ;

38
extra/locals/backend/backend-tests.factor Normal file
View File

@ -0,0 +1,38 @@
IN: locals.backend.tests
USING: tools.test locals.backend kernel arrays ;
[ 3 ] [ 3 >r 1 get-local r> drop ] unit-test
[ 4 ] [ 3 4 >r >r 2 get-local 2 drop-locals ] unit-test
: get-local-test-1 3 >r 1 get-local r> drop ;
{ 0 1 } [ get-local-test-1 ] must-infer-as
[ 3 ] [ get-local-test-1 ] unit-test
: get-local-test-2 3 4 >r >r 2 get-local 2 drop-locals ;
{ 0 1 } [ get-local-test-2 ] must-infer-as
[ 4 ] [ get-local-test-2 ] unit-test
: get-local-test-3 3 4 >r >r 2 get-local r> r> 2array ;
{ 0 2 } [ get-local-test-3 ] must-infer-as
[ 4 { 3 4 } ] [ get-local-test-3 ] unit-test
: get-local-test-4 3 4 >r >r r> r> dup swap >r swap >r r> r> 2array ;
{ 0 2 } [ get-local-test-4 ] must-infer-as
[ 4 { 3 4 } ] [ get-local-test-4 ] unit-test
[ 1 2 ] [ 1 2 2 load-locals r> r> ] unit-test
: load-locals-test-1 1 2 2 load-locals r> r> ;
{ 0 2 } [ load-locals-test-1 ] must-infer-as
[ 1 2 ] [ load-locals-test-1 ] unit-test

37
extra/locals/backend/backend.factor Normal file
View File

@ -0,0 +1,37 @@
USING: math kernel slots.private inference.known-words
inference.backend sequences effects words ;
IN: locals.backend
: load-locals ( n -- )
dup zero? [ drop ] [ swap >r 1- load-locals ] if ;
: get-local ( n -- value )
dup zero? [ drop dup ] [ r> swap 1- get-local swap >r ] if ;
: local-value 2 slot ; inline
: set-local-value 2 set-slot ; inline
: drop-locals ( n -- )
dup zero? [ drop ] [ r> drop 1- drop-locals ] if ;
\ load-locals [
pop-literal nip
[ dup reverse <effect> infer-shuffle ]
[ infer->r ]
bi
] "infer" set-word-prop
\ get-local [
pop-literal nip
[ infer-r> ]
[ dup 0 prefix <effect> infer-shuffle ]
[ infer->r ]
tri
] "infer" set-word-prop
\ drop-locals [
pop-literal nip
[ infer-r> ]
[ { } <effect> infer-shuffle ] bi
] "infer" set-word-prop

2
extra/locals/locals-tests.factor
View File

@ -82,6 +82,8 @@ IN: locals.tests
0 write-test-1 "q" set 0 write-test-1 "q" set
{ 1 1 } "q" get must-infer-as
[ 1 ] [ 1 "q" get call ] unit-test [ 1 ] [ 1 "q" get call ] unit-test
[ 2 ] [ 1 "q" get call ] unit-test [ 2 ] [ 1 "q" get call ] unit-test

96
extra/locals/locals.factor
View File

@ -4,7 +4,8 @@ USING: kernel namespaces sequences sequences.private assocs math
inference.transforms parser words quotations debugger macros inference.transforms parser words quotations debugger macros
arrays macros splitting combinators prettyprint.backend arrays macros splitting combinators prettyprint.backend
definitions prettyprint hashtables prettyprint.sections sets definitions prettyprint hashtables prettyprint.sections sets
sequences.private effects generic compiler.units accessors ; sequences.private effects generic compiler.units accessors
locals.backend ;
IN: locals IN: locals
! Inspired by ! Inspired by
@ -56,95 +57,80 @@ TUPLE: quote local ;
C: <quote> quote C: <quote> quote
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! read-local
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: local-index ( obj args -- n ) : local-index ( obj args -- n )
[ dup quote? [ quote-local ] when eq? ] with find drop ; [ dup quote? [ quote-local ] when eq? ] with find drop ;
: read-local ( obj args -- quot ) : read-local-quot ( obj args -- quot )
local-index 1+ local-index 1+ [ get-local ] curry ;
dup [ r> ] <repetition> concat [ dup ] append
swap [ swap >r ] <repetition> concat append ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! localize
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: localize-writer ( obj args -- quot ) : localize-writer ( obj args -- quot )
>r "local-reader" word-prop r> read-local [ 0 swap set-array-nth ] append ; >r "local-reader" word-prop r>
read-local-quot [ set-local-value ] append ;
: localize ( obj args -- quot ) : localize ( obj args -- quot )
{ {
{ [ over local? ] [ read-local ] } { [ over local? ] [ read-local-quot ] }
{ [ over quote? ] [ >r quote-local r> read-local ] } { [ over quote? ] [ >r quote-local r> read-local-quot ] }
{ [ over local-word? ] [ read-local [ call ] append ] } { [ over local-word? ] [ read-local-quot [ call ] append ] }
{ [ over local-reader? ] [ read-local [ 0 swap array-nth ] append ] } { [ over local-reader? ] [ read-local-quot [ local-value ] append ] }
{ [ over local-writer? ] [ localize-writer ] } { [ over local-writer? ] [ localize-writer ] }
{ [ over \ lambda eq? ] [ 2drop [ ] ] } { [ over \ lambda eq? ] [ 2drop [ ] ] }
{ [ t ] [ drop 1quotation ] } { [ t ] [ drop 1quotation ] }
} cond ; } cond ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! point-free
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
UNION: special local quote local-word local-reader local-writer ; UNION: special local quote local-word local-reader local-writer ;
: load-local ( arg -- quot ) : load-locals-quot ( args -- quot )
local-reader? [ 1array >r ] [ >r ] ? ; dup [ local-reader? ] contains? [
<reversed> [
local-reader? [ 1array >r ] [ >r ] ?
] map concat
] [
length [ load-locals ] curry >quotation
] if ;
: load-locals ( quot args -- quot ) : drop-locals-quot ( args -- quot )
nip <reversed> [ load-local ] map concat ; length [ drop-locals ] curry ;
: drop-locals ( args -- args quot )
dup length [ r> drop ] <repetition> concat ;
: point-free-body ( quot args -- newquot ) : point-free-body ( quot args -- newquot )
>r 1 head-slice* r> [ localize ] curry map concat ; >r 1 head-slice* r> [ localize ] curry map concat ;
: point-free-end ( quot args -- newquot ) : point-free-end ( quot args -- newquot )
over peek special? over peek special?
[ drop-locals >r >r peek r> localize r> append ] [ dup drop-locals-quot >r >r peek r> localize r> append ]
[ drop-locals nip swap peek suffix ] [ dup drop-locals-quot nip swap peek suffix ]
if ; if ;
: (point-free) ( quot args -- newquot ) : (point-free) ( quot args -- newquot )
[ load-locals ] [ point-free-body ] [ point-free-end ] [ nip load-locals-quot ]
[ point-free-body ]
[ point-free-end ]
2tri 3append >quotation ; 2tri 3append >quotation ;
: point-free ( quot args -- newquot ) : point-free ( quot args -- newquot )
over empty? [ drop ] [ (point-free) ] if ; over empty? [ drop ] [ (point-free) ] if ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! free-vars
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
UNION: lexical local local-reader local-writer local-word ; UNION: lexical local local-reader local-writer local-word ;
GENERIC: free-vars ( form -- vars ) GENERIC: free-vars* ( form -- )
: add-if-free ( vars object -- vars ) : free-vars ( form -- vars )
[ free-vars* ] { } make prune ;
: add-if-free ( object -- )
{ {
{ [ dup local-writer? ] [ "local-reader" word-prop suffix ] } { [ dup local-writer? ] [ "local-reader" word-prop , ] }
{ [ dup lexical? ] [ suffix ] } { [ dup lexical? ] [ , ] }
{ [ dup quote? ] [ quote-local suffix ] } { [ dup quote? ] [ local>> , ] }
{ [ t ] [ free-vars append ] } { [ t ] [ free-vars* ] }
} cond ; } cond ;
M: object free-vars drop { } ; M: object free-vars* drop ;
M: quotation free-vars { } [ add-if-free ] reduce ; M: quotation free-vars* [ add-if-free ] each ;
M: lambda free-vars M: lambda free-vars*
dup vars>> swap body>> free-vars diff ; [ vars>> ] [ body>> ] bi free-vars diff % ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! lambda-rewrite
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
GENERIC: lambda-rewrite* ( obj -- ) GENERIC: lambda-rewrite* ( obj -- )
@ -172,8 +158,8 @@ M: lambda block-vars vars>> ;
M: lambda block-body body>> ; M: lambda block-body body>> ;
M: lambda local-rewrite* M: lambda local-rewrite*
dup vars>> swap body>> [ vars>> ] [ body>> ] bi
[ local-rewrite* \ call , ] [ ] make <lambda> , ; [ [ local-rewrite* ] each ] [ ] make <lambda> , ;
M: block lambda-rewrite* M: block lambda-rewrite*
#! Turn free variables into bound variables, curry them #! Turn free variables into bound variables, curry them
@ -188,8 +174,6 @@ M: object lambda-rewrite* , ;
M: object local-rewrite* , ; M: object local-rewrite* , ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: make-local ( name -- word ) : make-local ( name -- word )
"!" ?tail [ "!" ?tail [
<local-reader> <local-reader>