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?
"method-generic" word-prop inline? ;
M: tuple-dispatch-engine-word inline?
M: engine-word inline?
"tuple-dispatch-generic" word-prop inline? ;
M: word inline?
@ -130,25 +130,27 @@ TUPLE: too-many->r ;
TUPLE: too-many-r> ;
: check-r> ( -- )
meta-r get empty?
: check-r> ( n -- )
meta-r get length >
[ \ too-many-r> inference-error ] when ;
: infer->r ( -- )
1 ensure-values
: infer->r ( n -- )
dup ensure-values
#>r
1 0 pick node-inputs
pop-d push-r
0 1 pick node-outputs
node, ;
over 0 pick node-inputs
over [ drop pop-d ] map reverse [ push-r ] each
0 pick pick node-outputs
node,
drop ;
: infer-r> ( -- )
check-r>
: infer-r> ( n -- )
dup check-r>
#r>
0 1 pick node-inputs
pop-r push-d
1 0 pick node-outputs
node, ;
0 pick pick node-inputs
over [ drop pop-r ] map reverse [ push-d ] each
over 0 pick node-outputs
node,
drop ;
: undo-infer ( -- )
recorded get [ f "inferred-effect" set-word-prop ] each ;
@ -199,18 +201,18 @@ M: object constructor drop f ;
dup infer-uncurry
constructor [
peek-d reify-curry
infer->r
1 infer->r
peek-d reify-curry
infer-r>
1 infer-r>
2 1 <effect> swap #call consume/produce
] when* ;
: reify-curries ( n -- )
meta-d get reverse [
dup special? [
over [ infer->r ] times
over infer->r
dup reify-curry
over [ infer-r> ] times
over infer-r>
] when 2drop
] 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 } } }
} [ 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 [
1 ensure-values
@ -81,8 +81,8 @@ M: curried infer-call
M: composed infer-call
infer-uncurry
infer->r peek-d infer-call
terminated? get [ infer-r> peek-d infer-call ] unless ;
1 infer->r peek-d infer-call
terminated? get [ 1 infer-r> peek-d infer-call ] unless ;
M: object infer-call
\ 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
{ 1 1 } "q" get must-infer-as
[ 1 ] [ 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
arrays macros splitting combinators prettyprint.backend
definitions prettyprint hashtables prettyprint.sections sets
sequences.private effects generic compiler.units accessors ;
sequences.private effects generic compiler.units accessors
locals.backend ;
IN: locals
! Inspired by
@ -56,95 +57,80 @@ TUPLE: quote local ;
C: <quote> quote
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! read-local
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: local-index ( obj args -- n )
[ dup quote? [ quote-local ] when eq? ] with find drop ;
: read-local ( obj args -- quot )
local-index 1+
dup [ r> ] <repetition> concat [ dup ] append
swap [ swap >r ] <repetition> concat append ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! localize
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: read-local-quot ( obj args -- quot )
local-index 1+ [ get-local ] curry ;
: 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 )
{
{ [ over local? ] [ read-local ] }
{ [ over quote? ] [ >r quote-local r> read-local ] }
{ [ over local-word? ] [ read-local [ call ] append ] }
{ [ over local-reader? ] [ read-local [ 0 swap array-nth ] append ] }
{ [ over local? ] [ read-local-quot ] }
{ [ over quote? ] [ >r quote-local r> read-local-quot ] }
{ [ over local-word? ] [ read-local-quot [ call ] append ] }
{ [ over local-reader? ] [ read-local-quot [ local-value ] append ] }
{ [ over local-writer? ] [ localize-writer ] }
{ [ over \ lambda eq? ] [ 2drop [ ] ] }
{ [ t ] [ drop 1quotation ] }
} cond ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! point-free
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
UNION: special local quote local-word local-reader local-writer ;
: load-local ( arg -- quot )
local-reader? [ 1array >r ] [ >r ] ? ;
: load-locals-quot ( args -- quot )
dup [ local-reader? ] contains? [
<reversed> [
local-reader? [ 1array >r ] [ >r ] ?
] map concat
] [
length [ load-locals ] curry >quotation
] if ;
: load-locals ( quot args -- quot )
nip <reversed> [ load-local ] map concat ;
: drop-locals ( args -- args quot )
dup length [ r> drop ] <repetition> concat ;
: drop-locals-quot ( args -- quot )
length [ drop-locals ] curry ;
: point-free-body ( quot args -- newquot )
>r 1 head-slice* r> [ localize ] curry map concat ;
: point-free-end ( quot args -- newquot )
over peek special?
[ drop-locals >r >r peek r> localize r> append ]
[ drop-locals nip swap peek suffix ]
[ dup drop-locals-quot >r >r peek r> localize r> append ]
[ dup drop-locals-quot nip swap peek suffix ]
if ;
: (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 ;
: point-free ( quot args -- newquot )
over empty? [ drop ] [ (point-free) ] if ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! free-vars
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
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 lexical? ] [ suffix ] }
{ [ dup quote? ] [ quote-local suffix ] }
{ [ t ] [ free-vars append ] }
{ [ dup local-writer? ] [ "local-reader" word-prop , ] }
{ [ dup lexical? ] [ , ] }
{ [ dup quote? ] [ local>> , ] }
{ [ t ] [ free-vars* ] }
} 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
dup vars>> swap body>> free-vars diff ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! lambda-rewrite
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
M: lambda free-vars*
[ vars>> ] [ body>> ] bi free-vars diff % ;
GENERIC: lambda-rewrite* ( obj -- )
@ -172,8 +158,8 @@ M: lambda block-vars vars>> ;
M: lambda block-body body>> ;
M: lambda local-rewrite*
dup vars>> swap body>>
[ local-rewrite* \ call , ] [ ] make <lambda> , ;
[ vars>> ] [ body>> ] bi
[ [ local-rewrite* ] each ] [ ] make <lambda> , ;
M: block lambda-rewrite*
#! Turn free variables into bound variables, curry them
@ -188,8 +174,6 @@ M: object lambda-rewrite* , ;
M: object local-rewrite* , ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: make-local ( name -- word )
"!" ?tail [
<local-reader>