diff --git a/core/inference/backend/backend.factor b/core/inference/backend/backend.factor index cf40944d1d..e0cc1a5839 100755 --- a/core/inference/backend/backend.factor +++ b/core/inference/backend/backend.factor @@ -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 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 ; diff --git a/core/inference/known-words/known-words.factor b/core/inference/known-words/known-words.factor index 453e2460b0..2e471420da 100755 --- a/core/inference/known-words/known-words.factor +++ b/core/inference/known-words/known-words.factor @@ -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 ; diff --git a/extra/locals/backend/backend-tests.factor b/extra/locals/backend/backend-tests.factor new file mode 100644 index 0000000000..41caa87fae --- /dev/null +++ b/extra/locals/backend/backend-tests.factor @@ -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 diff --git a/extra/locals/backend/backend.factor b/extra/locals/backend/backend.factor new file mode 100644 index 0000000000..a51216b079 --- /dev/null +++ b/extra/locals/backend/backend.factor @@ -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 infer-shuffle ] + [ infer->r ] + bi +] "infer" set-word-prop + +\ get-local [ + pop-literal nip + [ infer-r> ] + [ dup 0 prefix infer-shuffle ] + [ infer->r ] + tri +] "infer" set-word-prop + +\ drop-locals [ + pop-literal nip + [ infer-r> ] + [ { } infer-shuffle ] bi +] "infer" set-word-prop diff --git a/extra/locals/locals-tests.factor b/extra/locals/locals-tests.factor index 4ee9b48bb7..c13be40c8f 100755 --- a/extra/locals/locals-tests.factor +++ b/extra/locals/locals-tests.factor @@ -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 diff --git a/extra/locals/locals.factor b/extra/locals/locals.factor index 2b0c61cc89..be73f1db88 100755 --- a/extra/locals/locals.factor +++ b/extra/locals/locals.factor @@ -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 -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! 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> ] concat [ dup ] append - swap [ swap >r ] 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? [ + [ + local-reader? [ 1array >r ] [ >r ] ? + ] map concat + ] [ + length [ load-locals ] curry >quotation + ] if ; -: load-locals ( quot args -- quot ) - nip [ load-local ] map concat ; - -: drop-locals ( args -- args quot ) - dup length [ r> drop ] 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 , ; + [ vars>> ] [ body>> ] bi + [ [ local-rewrite* ] each ] [ ] make , ; 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 [