Clean up inference and fix hygiene issue with macros
Slava Pestov
parent
73d664a7d5
commit
5e2c7e769d
|
|
@ -206,7 +206,7 @@ M: alien-invoke-error summary
|
|||
pop-literal nip over set-alien-invoke-library
|
||||
pop-literal nip over set-alien-invoke-return
|
||||
! Quotation which coerces parameters to required types
|
||||
dup make-prep-quot infer-quot
|
||||
dup make-prep-quot recursive-state get infer-quot
|
||||
! If symbol doesn't resolve, no stack effect, no compile
|
||||
dup alien-invoke-dlsym 2drop
|
||||
! Add node to IR
|
||||
|
|
@ -243,7 +243,7 @@ M: alien-indirect-error summary
|
|||
pop-parameters over set-alien-indirect-parameters
|
||||
pop-literal nip over set-alien-indirect-return
|
||||
! Quotation which coerces parameters to required types
|
||||
dup make-prep-quot 1 make-dip infer-quot
|
||||
dup make-prep-quot [ dip ] curry recursive-state get infer-quot
|
||||
! Add node to IR
|
||||
dup node,
|
||||
! Magic #: consume the function pointer, too
|
||||
|
|
@ -282,7 +282,8 @@ M: alien-callback-error summary
|
|||
drop "Words calling ``alien-callback'' cannot run in the interpreter. Compile the caller word and try again." ;
|
||||
|
||||
: callback-bottom ( node -- )
|
||||
alien-callback-xt [ word-xt <alien> ] curry infer-quot ;
|
||||
alien-callback-xt [ word-xt <alien> ] curry
|
||||
recursive-state get infer-quot ;
|
||||
|
||||
\ alien-callback [
|
||||
4 ensure-values
|
||||
|
|
|
|||
|
|
@ -5,7 +5,6 @@ IN: combinators
|
|||
|
||||
ARTICLE: "combinators-quot" "Quotation construction utilities"
|
||||
"Some words for creating quotations which can be useful for implementing method combinations and compiler transforms:"
|
||||
{ $subsection make-dip }
|
||||
{ $subsection cond>quot }
|
||||
{ $subsection case>quot }
|
||||
{ $subsection alist>quot }
|
||||
|
|
@ -27,13 +26,6 @@ ARTICLE: "combinators" "Additional combinators"
|
|||
|
||||
ABOUT: "combinators"
|
||||
|
||||
HELP: make-dip
|
||||
{ $values { "quot" "a quotation" } { "n" "a non-negative integer" } { "newquot" "a new quotation" } }
|
||||
{ $description "Constructs a quotation which retains the top " { $snippet "n" } " stack items, and applies " { $snippet "quot" } " to what is underneath." }
|
||||
{ $examples
|
||||
{ $example "USE: quotations" "[ 3 + ] 2 make-dip ." "[ >r >r 3 + r> r> ]" }
|
||||
} ;
|
||||
|
||||
HELP: alist>quot
|
||||
{ $values { "default" "a quotation" } { "assoc" "a sequence of quotation pairs" } { "quot" "a new quotation" } }
|
||||
{ $description "Constructs a quotation which calls the first quotation in each pair of " { $snippet "assoc" } " until one of them outputs a true value, and then calls the second quotation in the corresponding pair. Quotations are called in reverse order, and if no quotation outputs a true value then " { $snippet "default" } " is called." }
|
||||
|
|
|
|||
|
|
@ -73,10 +73,9 @@ SYMBOL: profiler-prologues
|
|||
: word-dataflow ( word -- dataflow )
|
||||
[
|
||||
dup "no-effect" word-prop [ no-effect ] when
|
||||
dup dup add-recursive-state
|
||||
[ specialized-def (dataflow) ] keep
|
||||
finish-word drop
|
||||
] with-infer ;
|
||||
dup specialized-def over dup 2array 1array infer-quot
|
||||
finish-word
|
||||
] with-infer nip ;
|
||||
|
||||
SYMBOL: compiler-hook
|
||||
|
||||
|
|
|
|||
|
|
@ -34,7 +34,7 @@ PREDICATE: class math-class ( object -- ? )
|
|||
: math-upgrade ( class1 class2 -- quot )
|
||||
[ math-class-max ] 2keep
|
||||
>r over r> (math-upgrade)
|
||||
>r (math-upgrade) dup empty? [ 1 make-dip ] unless
|
||||
>r (math-upgrade) dup empty? [ [ dip ] curry ] unless
|
||||
r> append ;
|
||||
|
||||
TUPLE: no-math-method left right generic ;
|
||||
|
|
|
|||
|
|
@ -20,9 +20,6 @@ debugger assocs combinators ;
|
|||
: recursive-quotation? ( quot -- ? )
|
||||
local-recursive-state [ first eq? ] curry* contains? ;
|
||||
|
||||
: add-recursive-state ( word label -- )
|
||||
2array recursive-state [ swap add* ] change ;
|
||||
|
||||
TUPLE: inference-error rstate major? ;
|
||||
|
||||
: (inference-error) ( ... class important? -- * )
|
||||
|
|
@ -65,12 +62,11 @@ SYMBOL: terminated?
|
|||
|
||||
SYMBOL: recorded
|
||||
|
||||
: init-inference ( recursive-state -- )
|
||||
: init-inference ( -- )
|
||||
terminated? off
|
||||
V{ } clone meta-d set
|
||||
V{ } clone meta-r set
|
||||
0 d-in set
|
||||
recursive-state set
|
||||
dataflow-graph off
|
||||
current-node off ;
|
||||
|
||||
|
|
@ -86,25 +82,31 @@ M: wrapper apply-object wrapped apply-literal ;
|
|||
: terminate ( -- )
|
||||
terminated? on #terminate node, ;
|
||||
|
||||
: infer-quot ( quot -- )
|
||||
[ apply-object terminated? get not ] all? drop ;
|
||||
: infer-quot ( quot rstate -- )
|
||||
recursive-state get >r
|
||||
recursive-state set
|
||||
[ apply-object terminated? get not ] all? drop
|
||||
r> recursive-state set ;
|
||||
|
||||
TUPLE: recursive-quotation-error quot ;
|
||||
: infer-quot-recursive ( quot word label -- )
|
||||
2array add* infer-quot ;
|
||||
|
||||
: time-bomb ( error -- )
|
||||
[ throw ] curry recursive-state get infer-quot ;
|
||||
|
||||
: bad-call ( -- )
|
||||
[ "call must be given a callable" throw ] infer-quot ;
|
||||
"call must be given a callable" time-bomb ;
|
||||
|
||||
TUPLE: recursive-quotation-error quot ;
|
||||
|
||||
: infer-quot-value ( value -- )
|
||||
dup recursive-quotation? [
|
||||
value-literal recursive-quotation-error inference-error
|
||||
] [
|
||||
dup value-literal callable? [
|
||||
recursive-state get >r
|
||||
[
|
||||
[ value-recursion ] keep f 2array add*
|
||||
recursive-state set
|
||||
] keep value-literal infer-quot
|
||||
r> recursive-state set
|
||||
dup value-literal
|
||||
over value-recursion
|
||||
rot f infer-quot-recursive
|
||||
] [
|
||||
drop bad-call
|
||||
] if
|
||||
|
|
@ -141,17 +143,6 @@ TUPLE: too-many-r> ;
|
|||
: undo-infer ( -- )
|
||||
recorded get [ f "inferred-effect" set-word-prop ] each ;
|
||||
|
||||
: with-infer ( quot -- )
|
||||
[
|
||||
[
|
||||
{ } recursive-state set
|
||||
V{ } clone recorded set
|
||||
f init-inference
|
||||
call
|
||||
check->r
|
||||
] [ ] [ undo-infer ] cleanup
|
||||
] with-scope ;
|
||||
|
||||
: (consume-values) ( n -- )
|
||||
meta-d get [ length swap - ] keep set-length ;
|
||||
|
||||
|
|
@ -216,6 +207,11 @@ M: object constructor drop f ;
|
|||
: reify-all ( -- )
|
||||
meta-d get length reify-curries ;
|
||||
|
||||
: end-infer ( -- )
|
||||
check->r
|
||||
reify-all
|
||||
f #return node, ;
|
||||
|
||||
: unify-lengths ( seq -- newseq )
|
||||
dup empty? [
|
||||
dup [ length ] map supremum
|
||||
|
|
@ -349,65 +345,6 @@ TUPLE: no-effect word ;
|
|||
|
||||
: no-effect ( word -- * ) \ no-effect inference-warning ;
|
||||
|
||||
: nest-node ( -- ) #entry node, ;
|
||||
|
||||
: unnest-node ( new-node -- new-node )
|
||||
dup node-param #return node,
|
||||
dataflow-graph get 1array over set-node-children ;
|
||||
|
||||
: inline-block ( word -- node-block data )
|
||||
[
|
||||
copy-inference nest-node
|
||||
gensym 2dup add-recursive-state
|
||||
over >r #label r> word-def infer-quot
|
||||
unnest-node
|
||||
] H{ } make-assoc ;
|
||||
|
||||
: apply-infer ( hash -- )
|
||||
{ meta-d meta-r d-in terminated? }
|
||||
[ swap [ at ] curry map ] keep
|
||||
[ set ] 2each ;
|
||||
|
||||
GENERIC: collect-recursion* ( label node -- )
|
||||
|
||||
M: node collect-recursion* 2drop ;
|
||||
|
||||
M: #call-label collect-recursion*
|
||||
tuck node-param eq? [ , ] [ drop ] if ;
|
||||
|
||||
: collect-recursion ( #label -- seq )
|
||||
dup node-param
|
||||
[ [ swap collect-recursion* ] curry each-node ] { } make ;
|
||||
|
||||
: join-values ( node -- )
|
||||
collect-recursion [ node-in-d ] map meta-d get add
|
||||
unify-lengths unify-stacks
|
||||
meta-d [ length tail* ] change ;
|
||||
|
||||
: splice-node ( node -- )
|
||||
dup node-successor [
|
||||
dup node, penultimate-node f over set-node-successor
|
||||
dup current-node set
|
||||
] when drop ;
|
||||
|
||||
: inline-closure ( word -- )
|
||||
dup inline-block over recursive-label? [
|
||||
flatten-meta-d >r
|
||||
drop join-values inline-block apply-infer
|
||||
r> over set-node-in-d
|
||||
dup node,
|
||||
collect-recursion [
|
||||
[ flatten-curries ] modify-values
|
||||
] each
|
||||
] [
|
||||
apply-infer node-child node-successor splice-node drop
|
||||
] if ;
|
||||
|
||||
: infer-compound ( word -- hash )
|
||||
[
|
||||
recursive-state get init-inference inline-block nip
|
||||
] with-scope ;
|
||||
|
||||
GENERIC: infer-word ( word -- effect )
|
||||
|
||||
M: word infer-word no-effect ;
|
||||
|
|
@ -421,15 +358,22 @@ TUPLE: effect-error word effect ;
|
|||
dup pick "declared-effect" word-prop effect<=
|
||||
[ 2drop ] [ effect-error ] if ;
|
||||
|
||||
: finish-word ( word -- effect )
|
||||
: finish-word ( word -- )
|
||||
current-effect
|
||||
2dup check-effect
|
||||
over recorded get push
|
||||
tuck "inferred-effect" set-word-prop ;
|
||||
"inferred-effect" set-word-prop ;
|
||||
|
||||
: infer-compound ( word -- )
|
||||
[
|
||||
init-inference
|
||||
dup word-def over dup infer-quot-recursive
|
||||
finish-word
|
||||
] with-scope ;
|
||||
|
||||
M: compound infer-word
|
||||
[ dup infer-compound [ finish-word ] bind ]
|
||||
[ ] [ t "no-effect" set-word-prop ] cleanup ;
|
||||
[ infer-compound ] [ ] [ t "no-effect" set-word-prop ]
|
||||
cleanup ;
|
||||
|
||||
: custom-infer ( word -- )
|
||||
#! Customized inference behavior
|
||||
|
|
@ -459,6 +403,60 @@ TUPLE: recursive-declare-error word ;
|
|||
\ recursive-declare-error inference-error
|
||||
] if* ;
|
||||
|
||||
: nest-node ( -- ) #entry node, ;
|
||||
|
||||
: unnest-node ( new-node -- new-node )
|
||||
dup node-param #return node,
|
||||
dataflow-graph get 1array over set-node-children ;
|
||||
|
||||
: inline-block ( word -- node-block data )
|
||||
[
|
||||
copy-inference nest-node
|
||||
dup word-def swap gensym
|
||||
recursive-state get pick pick infer-quot-recursive
|
||||
#label unnest-node
|
||||
] H{ } make-assoc ;
|
||||
|
||||
GENERIC: collect-recursion* ( label node -- )
|
||||
|
||||
M: node collect-recursion* 2drop ;
|
||||
|
||||
M: #call-label collect-recursion*
|
||||
tuck node-param eq? [ , ] [ drop ] if ;
|
||||
|
||||
: collect-recursion ( #label -- seq )
|
||||
dup node-param
|
||||
[ [ swap collect-recursion* ] curry each-node ] { } make ;
|
||||
|
||||
: join-values ( node -- )
|
||||
collect-recursion [ node-in-d ] map meta-d get add
|
||||
unify-lengths unify-stacks
|
||||
meta-d [ length tail* ] change ;
|
||||
|
||||
: splice-node ( node -- )
|
||||
dup node-successor [
|
||||
dup node, penultimate-node f over set-node-successor
|
||||
dup current-node set
|
||||
] when drop ;
|
||||
|
||||
: apply-infer ( hash -- )
|
||||
{ meta-d meta-r d-in terminated? }
|
||||
[ swap [ at ] curry map ] keep
|
||||
[ set ] 2each ;
|
||||
|
||||
: inline-closure ( word -- )
|
||||
dup inline-block over recursive-label? [
|
||||
flatten-meta-d >r
|
||||
drop join-values inline-block apply-infer
|
||||
r> over set-node-in-d
|
||||
dup node,
|
||||
collect-recursion [
|
||||
[ flatten-curries ] modify-values
|
||||
] each
|
||||
] [
|
||||
apply-infer node-child node-successor splice-node drop
|
||||
] if ;
|
||||
|
||||
M: compound apply-object
|
||||
[
|
||||
dup inline-recursive-label
|
||||
|
|
@ -469,4 +467,16 @@ M: compound apply-object
|
|||
] if-inline ;
|
||||
|
||||
M: undefined apply-object
|
||||
drop [ "Undefined" throw ] infer-quot ;
|
||||
drop "Undefined word" time-bomb ;
|
||||
|
||||
: with-infer ( quot -- effect dataflow )
|
||||
[
|
||||
[
|
||||
V{ } clone recorded set
|
||||
init-inference
|
||||
call
|
||||
end-infer
|
||||
current-effect
|
||||
dataflow-graph get
|
||||
] [ ] [ undo-infer ] cleanup
|
||||
] with-scope ;
|
||||
|
|
|
|||
|
|
@ -9,19 +9,20 @@ namespaces quotations ;
|
|||
GENERIC: infer ( quot -- effect )
|
||||
|
||||
M: callable infer ( quot -- effect )
|
||||
[ infer-quot current-effect ] with-infer ;
|
||||
[ f infer-quot ] with-infer drop ;
|
||||
|
||||
: infer. ( quot -- )
|
||||
infer effect>string print ;
|
||||
|
||||
: (dataflow) ( quot -- dataflow )
|
||||
infer-quot
|
||||
reify-all
|
||||
f #return node,
|
||||
dataflow-graph get ;
|
||||
GENERIC: dataflow ( quot -- dataflow )
|
||||
|
||||
: dataflow ( quot -- dataflow )
|
||||
[ (dataflow) ] with-infer ;
|
||||
M: callable dataflow
|
||||
[ f infer-quot ] with-infer nip ;
|
||||
|
||||
: dataflow-with ( quot stack -- dataflow )
|
||||
[ V{ } like meta-d set (dataflow) ] with-infer ;
|
||||
GENERIC# dataflow-with 1 ( quot stack -- dataflow )
|
||||
|
||||
M: callable dataflow-with
|
||||
[
|
||||
V{ } like meta-d set
|
||||
f infer-quot
|
||||
] with-infer nip ;
|
||||
|
|
|
|||
|
|
@ -69,6 +69,7 @@ M: object infer-call
|
|||
] [
|
||||
drop
|
||||
[ "execute must be given a word" throw ]
|
||||
recursive-state get
|
||||
infer-quot
|
||||
] if
|
||||
] "infer" set-word-prop
|
||||
|
|
@ -76,7 +77,8 @@ M: object infer-call
|
|||
\ if [
|
||||
3 ensure-values
|
||||
2 d-tail [ special? ] contains? [
|
||||
[ rot [ drop call ] [ nip call ] if ] infer-quot
|
||||
[ rot [ drop call ] [ nip call ] if ]
|
||||
recursive-state get infer-quot
|
||||
] [
|
||||
[ #values ]
|
||||
2 #drop node, pop-d pop-d swap 2array
|
||||
|
|
|
|||
|
|
@ -5,16 +5,16 @@ quotations assocs combinators math.bitfields inference.backend
|
|||
inference.dataflow tuples.private ;
|
||||
IN: inference.transforms
|
||||
|
||||
: pop-literals ( n -- seq )
|
||||
[ ensure-values ] keep
|
||||
[ d-tail ] keep
|
||||
(consume-values)
|
||||
[ value-literal ] map ;
|
||||
: pop-literals ( n -- rstate seq )
|
||||
dup zero? [ drop f ] [
|
||||
[ ensure-values ] keep [ d-tail ] keep (consume-values)
|
||||
dup value-recursion swap [ value-literal ] map
|
||||
] if ;
|
||||
|
||||
: transform-quot ( quot n -- newquot )
|
||||
[
|
||||
, \ pop-literals , [ [ ] each ] % % \ infer-quot ,
|
||||
] [ ] make ;
|
||||
[ pop-literals [ ] each ] curry
|
||||
swap
|
||||
[ swap infer-quot ] 3compose ;
|
||||
|
||||
: define-transform ( word quot n -- )
|
||||
transform-quot "infer" set-word-prop ;
|
||||
|
|
|
|||
|
|
@ -26,10 +26,6 @@ M: quotation like drop dup quotation? [ >quotation ] unless ;
|
|||
|
||||
INSTANCE: quotation immutable-sequence
|
||||
|
||||
: make-dip ( quot n -- newquot )
|
||||
dup \ >r <repetition> -rot \ r> <repetition> 3append
|
||||
>quotation ;
|
||||
|
||||
: 1quotation ( obj -- quot ) 1array >quotation ;
|
||||
|
||||
GENERIC: literalize ( obj -- wrapped )
|
||||
|
|
|
|||
|
|
@ -3,7 +3,8 @@
|
|||
USING: alien alien.c-types alien.compiler
|
||||
arrays assocs combinators compiler inference.transforms kernel
|
||||
math namespaces parser prettyprint prettyprint.sections
|
||||
quotations sequences strings words cocoa.runtime io macros ;
|
||||
quotations sequences strings words cocoa.runtime io macros
|
||||
combinators.lib ;
|
||||
IN: cocoa.messages
|
||||
|
||||
: make-sender ( method function -- quot )
|
||||
|
|
@ -74,7 +75,7 @@ H{ } clone objc-methods set-global
|
|||
[ \ <super> , ] when
|
||||
swap cache-selector , \ selector ,
|
||||
] [ ] make
|
||||
swap second length 2 - make-dip ;
|
||||
swap second length 2 - [ ndip ] curry ;
|
||||
|
||||
MACRO: (send) ( selector super? -- quot )
|
||||
[
|
||||
|
|
|
|||
Loading…
Reference in New Issue