new dataflow IR
Slava Pestov
parent
7418990bdc
commit
ac34c06c0c
|
|
@ -6,8 +6,9 @@
|
|||
<magnus--> http://www.caddr.com/macho/archives/sbcl-devel/2005-3/4764.html
|
||||
<magnus--> http://clozure.com/cgi-bin/viewcvs.cgi/ccl/lisp-kernel/lisp-exceptions.c?rev=1.9&content-type=text/vnd.viewcvs-markup
|
||||
|
||||
- single-stepper and variable access: wrong namespace?
|
||||
- [ over ] generics no-method
|
||||
- investigate if COPYING_GEN needs a fix
|
||||
- alien-global type wrong
|
||||
- simplifier:
|
||||
- dead loads not optimized out
|
||||
- kill tag-fixnum/untag-fixnum
|
||||
|
|
|
|||
|
|
@ -1,9 +1,9 @@
|
|||
! Copyright (C) 2004, 2005 Slava Pestov.
|
||||
! See http://factor.sf.net/license.txt for BSD license.
|
||||
IN: alien
|
||||
USING: assembler compiler compiler-backend errors generic
|
||||
inference kernel lists math namespaces sequences stdio strings
|
||||
unparser words ;
|
||||
USING: assembler compiler compiler-frontend compiler-backend
|
||||
errors generic inference kernel lists math namespaces sequences
|
||||
stdio strings unparser words ;
|
||||
|
||||
! ! ! WARNING ! ! !
|
||||
! Reloading this file into a running Factor instance on Win32
|
||||
|
|
@ -42,48 +42,42 @@ M: alien-error error. ( error -- )
|
|||
" symbol." %
|
||||
] make-string print ;
|
||||
|
||||
: alien-invoke ( ... returns library function parameters -- ... )
|
||||
: alien-invoke ( ... return library function parameters -- ... )
|
||||
#! Call a C library function.
|
||||
#! 'returns' is a type spec, and 'parameters' is a list of
|
||||
#! 'return' is a type spec, and 'parameters' is a list of
|
||||
#! type specs. 'library' is an entry in the "libraries"
|
||||
#! namespace.
|
||||
drop <alien-error> throw ;
|
||||
|
||||
! These are set in the alien-invoke dataflow IR node.
|
||||
SYMBOL: alien-returns
|
||||
SYMBOL: alien-parameters
|
||||
TUPLE: alien-node return parameters ;
|
||||
C: alien-node make-node ;
|
||||
|
||||
: set-alien-returns ( returns node -- )
|
||||
[ dup alien-returns set ] bind
|
||||
"void" = [
|
||||
[ object ] produce-d 1 0 node-outputs
|
||||
] unless ;
|
||||
: set-alien-return ( return node -- )
|
||||
2dup set-alien-node-return
|
||||
swap "void" = [
|
||||
drop
|
||||
] [
|
||||
[ object ] produce-d 1 0 rot node-outputs
|
||||
] ifte ;
|
||||
|
||||
: set-alien-parameters ( parameters node -- )
|
||||
[ dup alien-parameters set ] bind
|
||||
[ drop object ] map dup dup ensure-d
|
||||
length 0 node-inputs consume-d ;
|
||||
2dup set-alien-node-parameters
|
||||
>r [ drop object ] map dup dup ensure-d
|
||||
length 0 r> node-inputs consume-d ;
|
||||
|
||||
: ensure-dlsym ( symbol library -- ) load-library dlsym drop ;
|
||||
|
||||
: alien-invoke-node ( returns params function library -- )
|
||||
: alien-node ( return params function library -- )
|
||||
#! We should fail if the library does not exist, so that
|
||||
#! compilation does not keep trying to compile FFI words
|
||||
#! over and over again if the library is not loaded.
|
||||
2dup ensure-dlsym
|
||||
cons \ alien-invoke dataflow,
|
||||
cons param-node <alien-node>
|
||||
[ set-alien-parameters ] keep
|
||||
set-alien-returns ;
|
||||
[ set-alien-return ] keep
|
||||
node, ;
|
||||
|
||||
: infer-alien-invoke ( -- )
|
||||
\ alien-invoke "infer-effect" word-prop car ensure-d
|
||||
pop-literal nip
|
||||
pop-literal nip >r
|
||||
pop-literal nip
|
||||
pop-literal nip -rot
|
||||
r> swap alien-invoke-node ;
|
||||
|
||||
: parameters [ alien-parameters get reverse ] bind ;
|
||||
: parameters alien-node-parameters reverse ;
|
||||
|
||||
: stack-space ( parameters -- n )
|
||||
0 swap [ c-size cell align + ] each ;
|
||||
|
|
@ -101,57 +95,35 @@ SYMBOL: alien-parameters
|
|||
parameters
|
||||
dup stack-space
|
||||
dup %parameters , >r
|
||||
dup dup length swap [ >r 1 - dup r> unbox-parameter ] each drop
|
||||
dup dup length swap [
|
||||
>r 1 - dup r> unbox-parameter
|
||||
] each drop
|
||||
length [ %parameter ] project % r> ;
|
||||
|
||||
: linearize-returns ( returns -- )
|
||||
[ alien-returns get ] bind dup "void" = [
|
||||
: linearize-return ( return -- )
|
||||
alien-node-return dup "void" = [
|
||||
drop
|
||||
] [
|
||||
c-type [ "boxer" get "box-op" get ] bind execute ,
|
||||
] ifte ;
|
||||
|
||||
: linearize-alien-invoke ( node -- )
|
||||
M: alien-node linearize-node* ( node -- )
|
||||
dup linearize-parameters >r
|
||||
dup [ node-param get ] bind %alien-invoke ,
|
||||
dup [ node-param get cdr library-abi "stdcall" = ] bind
|
||||
dup node-param %alien-invoke ,
|
||||
dup node-param cdr library-abi "stdcall" =
|
||||
r> swap [ drop ] [ %cleanup , ] ifte
|
||||
linearize-returns ;
|
||||
linearize-return ;
|
||||
|
||||
\ alien-invoke [ linearize-alien-invoke ] "linearizer" set-word-prop
|
||||
|
||||
\ alien-invoke [ [ string string string general-list ] [ ] ]
|
||||
\ alien-invoke [ [ string object string general-list ] [ ] ]
|
||||
"infer-effect" set-word-prop
|
||||
|
||||
\ alien-invoke [ infer-alien-invoke ] "infer" set-word-prop
|
||||
|
||||
: alien-global ( type library name -- value )
|
||||
#! Fetch the value of C global variable.
|
||||
#! 'type' is a type spec. 'library' is an entry in the
|
||||
#! "libraries" namespace.
|
||||
<alien-error> throw ;
|
||||
|
||||
: alien-global-node ( type name library -- )
|
||||
2dup ensure-dlsym
|
||||
cons \ alien-global dataflow,
|
||||
set-alien-returns ;
|
||||
|
||||
: infer-alien-global ( -- )
|
||||
\ alien-global "infer-effect" word-prop car ensure-d
|
||||
\ alien-invoke [
|
||||
pop-literal nip
|
||||
pop-literal nip >r
|
||||
pop-literal nip
|
||||
pop-literal nip -rot
|
||||
alien-global-node ;
|
||||
|
||||
: linearize-alien-global ( node -- )
|
||||
dup [ node-param get ] bind %alien-global ,
|
||||
linearize-returns ;
|
||||
|
||||
\ alien-global [ linearize-alien-global ] "linearizer" set-word-prop
|
||||
|
||||
\ alien-global [ [ string string string ] [ object ] ] "infer-effect" set-word-prop
|
||||
|
||||
\ alien-global [ infer-alien-global ] "infer" set-word-prop
|
||||
r> swap alien-node
|
||||
] "infer" set-word-prop
|
||||
|
||||
global [
|
||||
"libraries" get [ <namespace> "libraries" set ] unless
|
||||
|
|
|
|||
|
|
@ -5,6 +5,9 @@ IN: kernel
|
|||
: slip ( quot x -- x | quot: -- )
|
||||
>r call r> ; inline
|
||||
|
||||
: 2slip ( quot x y -- x y | quot: -- )
|
||||
>r >r call r> r> ; inline
|
||||
|
||||
: keep ( x quot -- x | quot: x -- )
|
||||
over >r call r> ; inline
|
||||
|
||||
|
|
|
|||
|
|
@ -5,55 +5,33 @@ USING: assembler compiler-backend generic hashtables inference
|
|||
kernel kernel-internals lists math math-internals namespaces
|
||||
sequences words ;
|
||||
|
||||
: immediate? ( obj -- ? )
|
||||
#! fixnums and f have a pointerless representation, and
|
||||
#! are compiled immediately. Everything else can be moved
|
||||
#! by GC, and is indexed through a table.
|
||||
dup fixnum? swap f eq? or ;
|
||||
|
||||
: push-1 ( obj -- )
|
||||
0 swap literal-value dup
|
||||
immediate? [ %immediate ] [ %indirect ] ifte , ;
|
||||
|
||||
#push [
|
||||
[ node-produce-d get ] bind
|
||||
dup length dup %inc-d ,
|
||||
1 - swap [
|
||||
push-1 0 over %replace-d ,
|
||||
] each drop
|
||||
] "linearizer" set-word-prop
|
||||
|
||||
#drop [
|
||||
[ node-consume-d get length ] bind %dec-d ,
|
||||
] "linearizer" set-word-prop
|
||||
|
||||
\ dup [
|
||||
drop
|
||||
in-1
|
||||
1 %inc-d ,
|
||||
out-1
|
||||
] "linearizer" set-word-prop
|
||||
] "intrinsic" set-word-prop
|
||||
|
||||
\ swap [
|
||||
drop
|
||||
in-2
|
||||
0 0 %replace-d ,
|
||||
1 1 %replace-d ,
|
||||
] "linearizer" set-word-prop
|
||||
] "intrinsic" set-word-prop
|
||||
|
||||
\ over [
|
||||
drop
|
||||
0 1 %peek-d ,
|
||||
1 %inc-d ,
|
||||
out-1
|
||||
] "linearizer" set-word-prop
|
||||
] "intrinsic" set-word-prop
|
||||
|
||||
\ pick [
|
||||
drop
|
||||
0 2 %peek-d ,
|
||||
1 %inc-d ,
|
||||
out-1
|
||||
] "linearizer" set-word-prop
|
||||
] "intrinsic" set-word-prop
|
||||
|
||||
\ >r [
|
||||
drop
|
||||
|
|
@ -61,7 +39,7 @@ sequences words ;
|
|||
1 %inc-r ,
|
||||
1 %dec-d ,
|
||||
0 0 %replace-r ,
|
||||
] "linearizer" set-word-prop
|
||||
] "intrinsic" set-word-prop
|
||||
|
||||
\ r> [
|
||||
drop
|
||||
|
|
@ -69,20 +47,18 @@ sequences words ;
|
|||
1 %inc-d ,
|
||||
1 %dec-r ,
|
||||
out-1
|
||||
] "linearizer" set-word-prop
|
||||
] "intrinsic" set-word-prop
|
||||
|
||||
: node-peek ( node -- obj ) node-consume-d swap hash peek ;
|
||||
: node-peek ( node -- obj ) node-in-d peek ;
|
||||
|
||||
: peek-2 dup length 2 - swap nth ;
|
||||
: node-peek-2 ( node -- obj ) node-consume-d swap hash peek-2 ;
|
||||
: node-peek-2 ( node -- obj ) node-in-d peek-2 ;
|
||||
|
||||
: typed? ( value -- ? ) value-types length 1 = ;
|
||||
|
||||
\ slot t "intrinsic" set-word-prop
|
||||
|
||||
: slot@ ( node -- n )
|
||||
#! Compute slot offset.
|
||||
node-consume-d swap hash
|
||||
node-in-d
|
||||
dup peek literal-value cell *
|
||||
swap peek-2 value-types car type-tag - ;
|
||||
|
||||
|
|
@ -103,9 +79,7 @@ sequences words ;
|
|||
0 %untag ,
|
||||
1 0 %slot ,
|
||||
] ifte out-1
|
||||
] "linearizer" set-word-prop
|
||||
|
||||
\ set-slot t "intrinsic" set-word-prop
|
||||
] "intrinsic" set-word-prop
|
||||
|
||||
\ set-slot [
|
||||
dup typed-literal? [
|
||||
|
|
@ -120,9 +94,7 @@ sequences words ;
|
|||
1 %untag ,
|
||||
0 1 2 %set-slot ,
|
||||
] ifte
|
||||
] "linearizer" set-word-prop
|
||||
|
||||
\ type t "intrinsic" set-word-prop
|
||||
] "intrinsic" set-word-prop
|
||||
|
||||
\ type [
|
||||
drop
|
||||
|
|
@ -130,9 +102,7 @@ sequences words ;
|
|||
0 %type ,
|
||||
0 %tag-fixnum ,
|
||||
out-1
|
||||
] "linearizer" set-word-prop
|
||||
|
||||
\ arithmetic-type t "intrinsic" set-word-prop
|
||||
] "intrinsic" set-word-prop
|
||||
|
||||
\ arithmetic-type [
|
||||
drop
|
||||
|
|
@ -141,25 +111,21 @@ sequences words ;
|
|||
0 %tag-fixnum ,
|
||||
1 %inc-d ,
|
||||
out-1
|
||||
] "linearizer" set-word-prop
|
||||
|
||||
\ getenv t "intrinsic" set-word-prop
|
||||
] "intrinsic" set-word-prop
|
||||
|
||||
\ getenv [
|
||||
1 %dec-d ,
|
||||
node-peek literal-value 0 <vreg> swap %getenv ,
|
||||
1 %inc-d ,
|
||||
out-1
|
||||
] "linearizer" set-word-prop
|
||||
|
||||
\ setenv t "intrinsic" set-word-prop
|
||||
] "intrinsic" set-word-prop
|
||||
|
||||
\ setenv [
|
||||
1 %dec-d ,
|
||||
in-1
|
||||
node-peek literal-value 0 <vreg> swap %setenv ,
|
||||
1 %dec-d ,
|
||||
] "linearizer" set-word-prop
|
||||
] "intrinsic" set-word-prop
|
||||
|
||||
: binary-op-reg ( op out -- )
|
||||
>r in-2
|
||||
|
|
@ -194,13 +160,10 @@ sequences words ;
|
|||
[[ fixnum> %fixnum> ]]
|
||||
[[ eq? %eq? ]]
|
||||
] [
|
||||
uncons over t "intrinsic" set-word-prop
|
||||
[ literal, 0 , \ binary-op , ] make-list
|
||||
"linearizer" set-word-prop
|
||||
uncons [ literal, 0 , \ binary-op , ] make-list
|
||||
"intrinsic" set-word-prop
|
||||
] each
|
||||
|
||||
\ fixnum* t "intrinsic" set-word-prop
|
||||
|
||||
: slow-fixnum* \ %fixnum* 0 binary-op-reg ;
|
||||
|
||||
\ fixnum* [
|
||||
|
|
@ -217,24 +180,20 @@ sequences words ;
|
|||
] [
|
||||
drop slow-fixnum*
|
||||
] ifte
|
||||
] "linearizer" set-word-prop
|
||||
|
||||
\ fixnum-mod t "intrinsic" set-word-prop
|
||||
] "intrinsic" set-word-prop
|
||||
|
||||
\ fixnum-mod [
|
||||
! This is not clever. Because of x86, %fixnum-mod is
|
||||
! hard-coded to put its output in vreg 2, which happends to
|
||||
! be EDX there.
|
||||
drop \ %fixnum-mod 2 binary-op-reg
|
||||
] "linearizer" set-word-prop
|
||||
] "intrinsic" set-word-prop
|
||||
|
||||
\ fixnum/i t "intrinsic" set-word-prop
|
||||
|
||||
\ fixnum/i [
|
||||
drop \ %fixnum/i 0 binary-op-reg
|
||||
] "linearizer" set-word-prop
|
||||
|
||||
\ fixnum/mod t "intrinsic" set-word-prop
|
||||
] "intrinsic" set-word-prop
|
||||
|
||||
\ fixnum/mod [
|
||||
! See the remark on fixnum-mod for vreg usage
|
||||
|
|
@ -243,16 +202,14 @@ sequences words ;
|
|||
0 <vreg> 1 <vreg> %fixnum/mod ,
|
||||
2 0 %replace-d ,
|
||||
0 1 %replace-d ,
|
||||
] "linearizer" set-word-prop
|
||||
|
||||
\ fixnum-bitnot t "intrinsic" set-word-prop
|
||||
] "intrinsic" set-word-prop
|
||||
|
||||
\ fixnum-bitnot [
|
||||
drop
|
||||
in-1
|
||||
0 %fixnum-bitnot ,
|
||||
out-1
|
||||
] "linearizer" set-word-prop
|
||||
] "intrinsic" set-word-prop
|
||||
|
||||
: slow-shift ( -- ) \ fixnum-shift %call , ;
|
||||
|
||||
|
|
@ -289,12 +246,10 @@ sequences words ;
|
|||
] ifte
|
||||
] ifte ;
|
||||
|
||||
\ fixnum-shift t "intrinsic" set-word-prop
|
||||
|
||||
\ fixnum-shift [
|
||||
node-peek dup literal? [
|
||||
literal-value fast-shift
|
||||
] [
|
||||
drop slow-shift
|
||||
] ifte
|
||||
] "linearizer" set-word-prop
|
||||
] "intrinsic" set-word-prop
|
||||
|
|
|
|||
|
|
@ -4,66 +4,69 @@ IN: compiler-frontend
|
|||
USING: compiler-backend inference kernel kernel-internals lists
|
||||
math namespaces words strings errors prettyprint sequences ;
|
||||
|
||||
: >linear ( node -- )
|
||||
#! Dataflow OPs have a linearizer word property. This
|
||||
#! quotation is executed to convert the node into linear
|
||||
#! form.
|
||||
"linearizer" [ "No linearizer" throw ] apply-dataflow ;
|
||||
GENERIC: linearize-node* ( node -- )
|
||||
M: f linearize-node* ( f -- ) drop ;
|
||||
|
||||
: (linearize) ( dataflow -- )
|
||||
[ >linear ] each ;
|
||||
: linearize-node ( node -- )
|
||||
[
|
||||
dup linearize-node* node-successor linearize-node
|
||||
] when* ;
|
||||
|
||||
: linearize ( dataflow -- linear )
|
||||
#! Transform dataflow IR into linear IR. This strips out
|
||||
#! stack flow information, flattens conditionals into
|
||||
#! jumps and labels, and turns dataflow IR nodes into
|
||||
#! lists where the first element is an operation, and the
|
||||
#! rest is arguments.
|
||||
[ %prologue , (linearize) ] make-list ;
|
||||
#! stack flow information, and flattens conditionals into
|
||||
#! jumps and labels.
|
||||
[ %prologue , linearize-node ] make-list ;
|
||||
|
||||
: linearize-label ( node -- )
|
||||
#! Labels are tricky, because they might contain non-tail
|
||||
#! calls. So we push the address of the location right after
|
||||
#! the #label , then linearize the #label , then add a #return
|
||||
#! node to the linear IR. The simplifier will take care of
|
||||
#! this in the common case where the labelled block does
|
||||
#! not contain non-tail recursive calls to itself.
|
||||
M: #label linearize-node* ( node -- )
|
||||
<label> dup %return-to , >r
|
||||
dup [ node-label get ] bind %label ,
|
||||
[ node-param get ] bind (linearize)
|
||||
dup node-param %label ,
|
||||
node-children car linearize-node
|
||||
f %return ,
|
||||
r> %label , ;
|
||||
|
||||
#label [
|
||||
linearize-label
|
||||
] "linearizer" set-word-prop
|
||||
M: #call linearize-node* ( node -- )
|
||||
dup node-param
|
||||
dup "intrinsic" word-prop [
|
||||
call
|
||||
] [
|
||||
%call , drop
|
||||
] ?ifte ;
|
||||
|
||||
#call [
|
||||
[ node-param get ] bind %call ,
|
||||
] "linearizer" set-word-prop
|
||||
M: #call-label linearize-node* ( node -- )
|
||||
node-param %call-label , ;
|
||||
|
||||
#call-label [
|
||||
[ node-param get ] bind %call-label ,
|
||||
] "linearizer" set-word-prop
|
||||
: immediate? ( obj -- ? )
|
||||
#! fixnums and f have a pointerless representation, and
|
||||
#! are compiled immediately. Everything else can be moved
|
||||
#! by GC, and is indexed through a table.
|
||||
dup fixnum? swap f eq? or ;
|
||||
|
||||
: push-1 ( obj -- )
|
||||
0 swap literal-value dup
|
||||
immediate? [ %immediate ] [ %indirect ] ifte , ;
|
||||
|
||||
M: #push linearize-node* ( node -- )
|
||||
node-out-d dup length dup %inc-d ,
|
||||
1 - swap [ push-1 0 over %replace-d , ] each drop ;
|
||||
|
||||
M: #drop linearize-node* ( node -- )
|
||||
node-in-d length %dec-d , ;
|
||||
|
||||
: ifte-head ( label -- )
|
||||
in-1 1 %dec-d , 0 %jump-t , ;
|
||||
|
||||
: linearize-ifte ( param -- )
|
||||
M: #ifte linearize-node* ( node -- )
|
||||
#! The parameter is a list of two lists, each one a dataflow
|
||||
#! IR.
|
||||
2unlist <label> [
|
||||
node-children 2unlist <label> [
|
||||
ifte-head
|
||||
(linearize) ( false branch )
|
||||
linearize-node ( false branch )
|
||||
<label> dup %jump-label ,
|
||||
] keep %label , ( branch target of BRANCH-T )
|
||||
swap (linearize) ( true branch )
|
||||
swap linearize-node ( true branch )
|
||||
%label , ( branch target of false branch end ) ;
|
||||
|
||||
\ ifte [
|
||||
[ node-param get ] bind linearize-ifte
|
||||
] "linearizer" set-word-prop
|
||||
|
||||
: dispatch-head ( vtable -- end label/code )
|
||||
#! Output the jump table insn and return a list of
|
||||
#! label/branch pairs.
|
||||
|
|
@ -77,17 +80,15 @@ math namespaces words strings errors prettyprint sequences ;
|
|||
|
||||
: dispatch-body ( end label/param -- )
|
||||
#! Output each branch, with a jump to the end label.
|
||||
[ uncons %label , (linearize) %jump-label , ] each-with ;
|
||||
[ uncons %label , linearize-node %jump-label , ] each-with ;
|
||||
|
||||
: linearize-dispatch ( vtable -- )
|
||||
M: #dispatch linearize-node* ( vtable -- )
|
||||
#! The parameter is a list of lists, each one is a branch to
|
||||
#! take in case the top of stack has that type.
|
||||
dispatch-head dupd dispatch-body %label , ;
|
||||
node-children dispatch-head dupd dispatch-body %label , ;
|
||||
|
||||
\ dispatch [
|
||||
[ node-param get ] bind linearize-dispatch
|
||||
] "linearizer" set-word-prop
|
||||
M: #values linearize-node* ( node -- )
|
||||
drop ;
|
||||
|
||||
#values [ drop ] "linearizer" set-word-prop
|
||||
|
||||
#return [ drop f %return , ] "linearizer" set-word-prop
|
||||
M: #return linearize-node* ( node -- )
|
||||
drop f %return , ;
|
||||
|
|
|
|||
|
|
@ -11,207 +11,209 @@ sequences vectors words words ;
|
|||
! lifted to their call sites. Also, #label nodes are inlined if
|
||||
! their children do not make a recursive call to the label.
|
||||
|
||||
: scan-literal ( node -- )
|
||||
#! If the node represents a literal push, add the literal to
|
||||
#! the list being constructed.
|
||||
"scan-literal" [ drop ] apply-dataflow ;
|
||||
! : scan-literal ( node -- )
|
||||
! #! If the node represents a literal push, add the literal to
|
||||
! #! the list being constructed.
|
||||
! "scan-literal" [ drop ] apply-dataflow ;
|
||||
!
|
||||
! : (scan-literals) ( dataflow -- )
|
||||
! [ scan-literal ] each ;
|
||||
!
|
||||
! : scan-literals ( dataflow -- list )
|
||||
! [ (scan-literals) ] make-list ;
|
||||
!
|
||||
! : scan-branches ( branches -- )
|
||||
! #! Collect all literals from all branches.
|
||||
! [ node-param get ] bind [ [ scan-literal ] each ] each ;
|
||||
!
|
||||
! : mentions-literal? ( literal list -- ? )
|
||||
! #! Does the given list of result objects refer to this
|
||||
! #! literal?
|
||||
! [ value= ] some-with? ;
|
||||
!
|
||||
! : consumes-literal? ( literal node -- ? )
|
||||
! #! Does the dataflow node consume the literal?
|
||||
! [
|
||||
! dup node-consume-d get mentions-literal? swap
|
||||
! dup node-consume-r get mentions-literal? nip or
|
||||
! ] bind ;
|
||||
!
|
||||
! : produces-literal? ( literal node -- ? )
|
||||
! #! Does the dataflow node produce the literal?
|
||||
! [
|
||||
! dup node-produce-d get mentions-literal? swap
|
||||
! dup node-produce-r get mentions-literal? nip or
|
||||
! ] bind ;
|
||||
!
|
||||
! : (can-kill?) ( literal node -- ? )
|
||||
! #! Return false if the literal appears as input to this
|
||||
! #! node, and this node is not a stack operation.
|
||||
! 2dup consumes-literal? >r produces-literal? r> or not ;
|
||||
!
|
||||
! : can-kill? ( literal dataflow -- ? )
|
||||
! #! Return false if the literal appears in any node in the
|
||||
! #! list.
|
||||
! [ dupd "can-kill" [ (can-kill?) ] apply-dataflow ] all? nip ;
|
||||
!
|
||||
! : kill-set ( dataflow -- list )
|
||||
! #! Push a list of literals that may be killed in the IR.
|
||||
! dup scan-literals [ over can-kill? ] subset nip ;
|
||||
!
|
||||
! SYMBOL: branch-returns
|
||||
!
|
||||
! : can-kill-branches? ( literal node -- ? )
|
||||
! #! Check if the literal appears in either branch. This
|
||||
! #! assumes that the last element of each branch is a #values
|
||||
! #! node.
|
||||
! 2dup consumes-literal? [
|
||||
! 2drop f
|
||||
! ] [
|
||||
! [ node-param get ] bind
|
||||
! [
|
||||
! dup [
|
||||
! peek [ node-consume-d get >vector ] bind
|
||||
! ] map
|
||||
! unify-stacks >list
|
||||
! branch-returns set
|
||||
! [ dupd can-kill? ] all? nip
|
||||
! ] with-scope
|
||||
! ] ifte ;
|
||||
!
|
||||
! : kill-node ( literals node -- )
|
||||
! swap [ over (can-kill?) ] all? [ , ] [ drop ] ifte ;
|
||||
!
|
||||
! : (kill-nodes) ( literals dataflow -- )
|
||||
! #! Append live nodes to currently constructing list.
|
||||
! [ "kill-node" [ nip , ] apply-dataflow ] each-with ;
|
||||
!
|
||||
! : kill-nodes ( literals dataflow -- dataflow )
|
||||
! #! Remove literals and construct a list.
|
||||
! [ (kill-nodes) ] make-list ;
|
||||
!
|
||||
! : optimize ( dataflow -- dataflow )
|
||||
! #! Remove redundant literals from the IR. The original IR
|
||||
! #! is destructively modified.
|
||||
! dup kill-set swap kill-nodes ;
|
||||
!
|
||||
! : kill-branches ( literals node -- )
|
||||
! [
|
||||
! node-param [ [ dupd kill-nodes ] map nip ] change
|
||||
! ] extend , ;
|
||||
!
|
||||
! : kill-literal ( literals values -- values )
|
||||
! [
|
||||
! swap [ swap value= ] some-with? not
|
||||
! ] subset-with ;
|
||||
!
|
||||
! #push [
|
||||
! [ node-produce-d get ] bind [ literal-value ] map %
|
||||
! ] "scan-literal" set-word-prop
|
||||
!
|
||||
! #push [ 2drop t ] "can-kill" set-word-prop
|
||||
!
|
||||
! #push [
|
||||
! [ node-produce-d [ kill-literal ] change ] extend ,
|
||||
! ] "kill-node" set-word-prop
|
||||
!
|
||||
! #drop [ 2drop t ] "can-kill" set-word-prop
|
||||
!
|
||||
! #drop [
|
||||
! [ node-consume-d [ kill-literal ] change ] extend ,
|
||||
! ] "kill-node" set-word-prop
|
||||
!
|
||||
! #label [
|
||||
! [ node-param get ] bind (scan-literals)
|
||||
! ] "scan-literal" set-word-prop
|
||||
!
|
||||
! #label [
|
||||
! [ node-param get ] bind can-kill?
|
||||
! ] "can-kill" set-word-prop
|
||||
!
|
||||
! #call-label [
|
||||
! [ node-param get ] bind =
|
||||
! ] "calls-label" set-word-prop
|
||||
!
|
||||
! : calls-label? ( label list -- ? )
|
||||
! [ "calls-label" [ 2drop f ] apply-dataflow ] some-with? ;
|
||||
!
|
||||
! #label [
|
||||
! [ node-param get ] bind calls-label?
|
||||
! ] "calls-label" set-word-prop
|
||||
!
|
||||
! : branches-call-label? ( label list -- ? )
|
||||
! [ calls-label? ] some-with? ;
|
||||
!
|
||||
! \ ifte [
|
||||
! [ node-param get ] bind branches-call-label?
|
||||
! ] "calls-label" set-word-prop
|
||||
!
|
||||
! \ dispatch [
|
||||
! [ node-param get ] bind branches-call-label?
|
||||
! ] "calls-label" set-word-prop
|
||||
!
|
||||
! #label [ ( literals node -- )
|
||||
! [ node-param [ kill-nodes ] change ] extend ,
|
||||
! ] "kill-node" set-word-prop
|
||||
!
|
||||
! #values [
|
||||
! dupd consumes-literal? [
|
||||
! branch-returns get mentions-literal?
|
||||
! ] [
|
||||
! drop t
|
||||
! ] ifte
|
||||
! ] "can-kill" set-word-prop
|
||||
!
|
||||
! \ ifte [ scan-branches ] "scan-literal" set-word-prop
|
||||
! \ ifte [ can-kill-branches? ] "can-kill" set-word-prop
|
||||
! \ ifte [ kill-branches ] "kill-node" set-word-prop
|
||||
!
|
||||
! \ dispatch [ scan-branches ] "scan-literal" set-word-prop
|
||||
! \ dispatch [ can-kill-branches? ] "can-kill" set-word-prop
|
||||
! \ dispatch [ kill-branches ] "kill-node" set-word-prop
|
||||
!
|
||||
! ! Don't care about inputs to recursive combinator calls
|
||||
! #call-label [ 2drop t ] "can-kill" set-word-prop
|
||||
!
|
||||
! \ drop [ 2drop t ] "can-kill" set-word-prop
|
||||
! \ drop [ kill-node ] "kill-node" set-word-prop
|
||||
! \ dup [ 2drop t ] "can-kill" set-word-prop
|
||||
! \ dup [ kill-node ] "kill-node" set-word-prop
|
||||
! \ swap [ 2drop t ] "can-kill" set-word-prop
|
||||
! \ swap [ kill-node ] "kill-node" set-word-prop
|
||||
!
|
||||
! : kill-mask ( killing inputs -- mask )
|
||||
! [ over [ over value= ] some? >boolean nip ] map nip ;
|
||||
!
|
||||
! : reduce-stack-op ( literals node map -- )
|
||||
! #! If certain values passing through a stack op are being
|
||||
! #! killed, the stack op can be reduced, in extreme cases
|
||||
! #! to a no-op.
|
||||
! -rot [
|
||||
! [ node-consume-d get ] bind kill-mask swap assoc
|
||||
! ] keep
|
||||
! over [ [ node-op set ] extend , ] [ 2drop ] ifte ;
|
||||
!
|
||||
! \ over [ 2drop t ] "can-kill" set-word-prop
|
||||
! \ over [
|
||||
! [
|
||||
! [[ [ f f ] over ]]
|
||||
! [[ [ f t ] dup ]]
|
||||
! ] reduce-stack-op
|
||||
! ] "kill-node" set-word-prop
|
||||
!
|
||||
! \ pick [ 2drop t ] "can-kill" set-word-prop
|
||||
! \ pick [
|
||||
! [
|
||||
! [[ [ f f f ] pick ]]
|
||||
! [[ [ f f t ] over ]]
|
||||
! [[ [ f t f ] over ]]
|
||||
! [[ [ f t t ] dup ]]
|
||||
! ] reduce-stack-op
|
||||
! ] "kill-node" set-word-prop
|
||||
!
|
||||
! \ >r [ 2drop t ] "can-kill" set-word-prop
|
||||
! \ >r [ kill-node ] "kill-node" set-word-prop
|
||||
! \ r> [ 2drop t ] "can-kill" set-word-prop
|
||||
! \ r> [ kill-node ] "kill-node" set-word-prop
|
||||
|
||||
: (scan-literals) ( dataflow -- )
|
||||
[ scan-literal ] each ;
|
||||
|
||||
: scan-literals ( dataflow -- list )
|
||||
[ (scan-literals) ] make-list ;
|
||||
|
||||
: scan-branches ( branches -- )
|
||||
#! Collect all literals from all branches.
|
||||
[ node-param get ] bind [ [ scan-literal ] each ] each ;
|
||||
|
||||
: mentions-literal? ( literal list -- ? )
|
||||
#! Does the given list of result objects refer to this
|
||||
#! literal?
|
||||
[ value= ] some-with? ;
|
||||
|
||||
: consumes-literal? ( literal node -- ? )
|
||||
#! Does the dataflow node consume the literal?
|
||||
[
|
||||
dup node-consume-d get mentions-literal? swap
|
||||
dup node-consume-r get mentions-literal? nip or
|
||||
] bind ;
|
||||
|
||||
: produces-literal? ( literal node -- ? )
|
||||
#! Does the dataflow node produce the literal?
|
||||
[
|
||||
dup node-produce-d get mentions-literal? swap
|
||||
dup node-produce-r get mentions-literal? nip or
|
||||
] bind ;
|
||||
|
||||
: (can-kill?) ( literal node -- ? )
|
||||
#! Return false if the literal appears as input to this
|
||||
#! node, and this node is not a stack operation.
|
||||
2dup consumes-literal? >r produces-literal? r> or not ;
|
||||
|
||||
: can-kill? ( literal dataflow -- ? )
|
||||
#! Return false if the literal appears in any node in the
|
||||
#! list.
|
||||
[ dupd "can-kill" [ (can-kill?) ] apply-dataflow ] all? nip ;
|
||||
|
||||
: kill-set ( dataflow -- list )
|
||||
#! Push a list of literals that may be killed in the IR.
|
||||
dup scan-literals [ over can-kill? ] subset nip ;
|
||||
|
||||
SYMBOL: branch-returns
|
||||
|
||||
: can-kill-branches? ( literal node -- ? )
|
||||
#! Check if the literal appears in either branch. This
|
||||
#! assumes that the last element of each branch is a #values
|
||||
#! node.
|
||||
2dup consumes-literal? [
|
||||
2drop f
|
||||
] [
|
||||
[ node-param get ] bind
|
||||
[
|
||||
dup [
|
||||
peek [ node-consume-d get >vector ] bind
|
||||
] map
|
||||
unify-stacks >list
|
||||
branch-returns set
|
||||
[ dupd can-kill? ] all? nip
|
||||
] with-scope
|
||||
] ifte ;
|
||||
|
||||
: kill-node ( literals node -- )
|
||||
swap [ over (can-kill?) ] all? [ , ] [ drop ] ifte ;
|
||||
|
||||
: (kill-nodes) ( literals dataflow -- )
|
||||
#! Append live nodes to currently constructing list.
|
||||
[ "kill-node" [ nip , ] apply-dataflow ] each-with ;
|
||||
|
||||
: kill-nodes ( literals dataflow -- dataflow )
|
||||
#! Remove literals and construct a list.
|
||||
[ (kill-nodes) ] make-list ;
|
||||
|
||||
: optimize ( dataflow -- dataflow )
|
||||
#! Remove redundant literals from the IR. The original IR
|
||||
#! is destructively modified.
|
||||
dup kill-set swap kill-nodes ;
|
||||
|
||||
: kill-branches ( literals node -- )
|
||||
[
|
||||
node-param [ [ dupd kill-nodes ] map nip ] change
|
||||
] extend , ;
|
||||
|
||||
: kill-literal ( literals values -- values )
|
||||
[
|
||||
swap [ swap value= ] some-with? not
|
||||
] subset-with ;
|
||||
|
||||
#push [
|
||||
[ node-produce-d get ] bind [ literal-value ] map %
|
||||
] "scan-literal" set-word-prop
|
||||
|
||||
#push [ 2drop t ] "can-kill" set-word-prop
|
||||
|
||||
#push [
|
||||
[ node-produce-d [ kill-literal ] change ] extend ,
|
||||
] "kill-node" set-word-prop
|
||||
|
||||
#drop [ 2drop t ] "can-kill" set-word-prop
|
||||
|
||||
#drop [
|
||||
[ node-consume-d [ kill-literal ] change ] extend ,
|
||||
] "kill-node" set-word-prop
|
||||
|
||||
#label [
|
||||
[ node-param get ] bind (scan-literals)
|
||||
] "scan-literal" set-word-prop
|
||||
|
||||
#label [
|
||||
[ node-param get ] bind can-kill?
|
||||
] "can-kill" set-word-prop
|
||||
|
||||
#call-label [
|
||||
[ node-param get ] bind =
|
||||
] "calls-label" set-word-prop
|
||||
|
||||
: calls-label? ( label list -- ? )
|
||||
[ "calls-label" [ 2drop f ] apply-dataflow ] some-with? ;
|
||||
|
||||
#label [
|
||||
[ node-param get ] bind calls-label?
|
||||
] "calls-label" set-word-prop
|
||||
|
||||
: branches-call-label? ( label list -- ? )
|
||||
[ calls-label? ] some-with? ;
|
||||
|
||||
\ ifte [
|
||||
[ node-param get ] bind branches-call-label?
|
||||
] "calls-label" set-word-prop
|
||||
|
||||
\ dispatch [
|
||||
[ node-param get ] bind branches-call-label?
|
||||
] "calls-label" set-word-prop
|
||||
|
||||
#label [ ( literals node -- )
|
||||
[ node-param [ kill-nodes ] change ] extend ,
|
||||
] "kill-node" set-word-prop
|
||||
|
||||
#values [
|
||||
dupd consumes-literal? [
|
||||
branch-returns get mentions-literal?
|
||||
] [
|
||||
drop t
|
||||
] ifte
|
||||
] "can-kill" set-word-prop
|
||||
|
||||
\ ifte [ scan-branches ] "scan-literal" set-word-prop
|
||||
\ ifte [ can-kill-branches? ] "can-kill" set-word-prop
|
||||
\ ifte [ kill-branches ] "kill-node" set-word-prop
|
||||
|
||||
\ dispatch [ scan-branches ] "scan-literal" set-word-prop
|
||||
\ dispatch [ can-kill-branches? ] "can-kill" set-word-prop
|
||||
\ dispatch [ kill-branches ] "kill-node" set-word-prop
|
||||
|
||||
! Don't care about inputs to recursive combinator calls
|
||||
#call-label [ 2drop t ] "can-kill" set-word-prop
|
||||
|
||||
\ drop [ 2drop t ] "can-kill" set-word-prop
|
||||
\ drop [ kill-node ] "kill-node" set-word-prop
|
||||
\ dup [ 2drop t ] "can-kill" set-word-prop
|
||||
\ dup [ kill-node ] "kill-node" set-word-prop
|
||||
\ swap [ 2drop t ] "can-kill" set-word-prop
|
||||
\ swap [ kill-node ] "kill-node" set-word-prop
|
||||
|
||||
: kill-mask ( killing inputs -- mask )
|
||||
[ over [ over value= ] some? >boolean nip ] map nip ;
|
||||
|
||||
: reduce-stack-op ( literals node map -- )
|
||||
#! If certain values passing through a stack op are being
|
||||
#! killed, the stack op can be reduced, in extreme cases
|
||||
#! to a no-op.
|
||||
-rot [
|
||||
[ node-consume-d get ] bind kill-mask swap assoc
|
||||
] keep
|
||||
over [ [ node-op set ] extend , ] [ 2drop ] ifte ;
|
||||
|
||||
\ over [ 2drop t ] "can-kill" set-word-prop
|
||||
\ over [
|
||||
[
|
||||
[[ [ f f ] over ]]
|
||||
[[ [ f t ] dup ]]
|
||||
] reduce-stack-op
|
||||
] "kill-node" set-word-prop
|
||||
|
||||
\ pick [ 2drop t ] "can-kill" set-word-prop
|
||||
\ pick [
|
||||
[
|
||||
[[ [ f f f ] pick ]]
|
||||
[[ [ f f t ] over ]]
|
||||
[[ [ f t f ] over ]]
|
||||
[[ [ f t t ] dup ]]
|
||||
] reduce-stack-op
|
||||
] "kill-node" set-word-prop
|
||||
|
||||
\ >r [ 2drop t ] "can-kill" set-word-prop
|
||||
\ >r [ kill-node ] "kill-node" set-word-prop
|
||||
\ r> [ 2drop t ] "can-kill" set-word-prop
|
||||
\ r> [ kill-node ] "kill-node" set-word-prop
|
||||
: optimize ;
|
||||
|
|
|
|||
|
|
@ -73,6 +73,9 @@ sequences strings vectors words hashtables prettyprint ;
|
|||
terminate
|
||||
] ifte* ;
|
||||
|
||||
: unify-dataflow ( effects -- nodes )
|
||||
[ [ dataflow-graph get ] bind ] map ;
|
||||
|
||||
: deep-clone ( seq -- seq ) [ clone ] map ;
|
||||
|
||||
: copy-inference ( -- )
|
||||
|
|
@ -81,7 +84,8 @@ sequences strings vectors words hashtables prettyprint ;
|
|||
meta-r [ deep-clone ] change
|
||||
meta-d [ deep-clone ] change
|
||||
d-in [ deep-clone ] change
|
||||
dataflow-graph off ;
|
||||
dataflow-graph off
|
||||
current-node off ;
|
||||
|
||||
: infer-branch ( value -- namespace )
|
||||
#! Return a namespace with inferencer variables:
|
||||
|
|
@ -92,7 +96,7 @@ sequences strings vectors words hashtables prettyprint ;
|
|||
dup value-recursion recursive-state set
|
||||
literal-value dup infer-quot
|
||||
active? [
|
||||
#values values-node
|
||||
#values node,
|
||||
handle-terminator
|
||||
] [
|
||||
drop
|
||||
|
|
@ -110,23 +114,18 @@ sequences strings vectors words hashtables prettyprint ;
|
|||
] each
|
||||
] make-list ;
|
||||
|
||||
: unify-dataflow ( input instruction effectlist -- )
|
||||
[ [ get-dataflow ] bind ] map
|
||||
swap dataflow, [ unit node-consume-d set ] bind ;
|
||||
|
||||
: infer-branches ( input instruction branchlist -- )
|
||||
: infer-branches ( branches node -- )
|
||||
#! Recursive stack effect inference is done here. If one of
|
||||
#! the branches has an undecidable stack effect, we set the
|
||||
#! base case to this stack effect and try again.
|
||||
(infer-branches) dup unify-effects unify-dataflow ;
|
||||
|
||||
: infer-ifte ( true false -- )
|
||||
#! If branch taken is computed, infer along both paths and
|
||||
#! unify.
|
||||
2list >r pop-d \ ifte r> infer-branches ;
|
||||
[
|
||||
>r (infer-branches) dup unify-effects unify-dataflow
|
||||
r> set-node-children
|
||||
] keep node, ;
|
||||
|
||||
\ ifte [
|
||||
2 dataflow-drop, pop-d pop-d swap infer-ifte
|
||||
2 #drop node, pop-d pop-d swap 2list
|
||||
#ifte pop-d drop infer-branches
|
||||
] "infer" set-word-prop
|
||||
|
||||
: vtable>list ( rstate vtable -- list )
|
||||
|
|
@ -134,9 +133,9 @@ sequences strings vectors words hashtables prettyprint ;
|
|||
|
||||
USE: kernel-internals
|
||||
|
||||
: infer-dispatch ( rstate vtable -- )
|
||||
>r >r pop-d \ dispatch r> r> vtable>list infer-branches ;
|
||||
|
||||
\ dispatch [ pop-literal infer-dispatch ] "infer" set-word-prop
|
||||
\ dispatch [
|
||||
pop-literal vtable>list
|
||||
#dispatch pop-d drop infer-branches
|
||||
] "infer" set-word-prop
|
||||
|
||||
\ dispatch [ [ fixnum vector ] [ ] ] "infer-effect" set-word-prop
|
||||
|
|
|
|||
|
|
@ -1,87 +1,99 @@
|
|||
! Copyright (C) 2004, 2005 Slava Pestov.
|
||||
! See http://factor.sf.net/license.txt for BSD license.
|
||||
IN: inference
|
||||
USING: interpreter kernel lists namespaces sequences vectors
|
||||
words ;
|
||||
USING: generic interpreter kernel lists namespaces parser
|
||||
sequences vectors words ;
|
||||
|
||||
! The dataflow IR is the first of the two intermediate
|
||||
! representations used by Factor. It annotates concatenative
|
||||
! code with stack flow information and types.
|
||||
|
||||
TUPLE: node effect param in-d out-d in-r out-r
|
||||
successor children ;
|
||||
|
||||
: make-node ( effect param in-d out-d in-r out-r node -- node )
|
||||
[ >r f <node> r> set-delegate ] keep ;
|
||||
|
||||
: NODE:
|
||||
#! Followed by a node name.
|
||||
scan dup [ ] define-tuple
|
||||
create-in [ make-node ] define-constructor ; parsing
|
||||
|
||||
: empty-node f f f f f f f f f ;
|
||||
: param-node ( label) f swap f f f f f ;
|
||||
: in-d-node ( inputs) >r f f r> f f f f ;
|
||||
: out-d-node ( outputs) >r f f f r> f f f ;
|
||||
|
||||
: d-tail ( n -- list ) meta-d get vector-tail* ;
|
||||
: r-tail ( n -- list ) meta-r get vector-tail* ;
|
||||
|
||||
NODE: #label
|
||||
: #label ( label -- node ) param-node <#label> ;
|
||||
|
||||
NODE: #call
|
||||
: #call ( word -- node ) param-node <#call> ;
|
||||
|
||||
NODE: #call-label
|
||||
: #call-label ( label -- node ) param-node <#call> ;
|
||||
|
||||
NODE: #push
|
||||
: #push ( outputs -- node ) d-tail out-d-node <#push> ;
|
||||
|
||||
NODE: #drop
|
||||
: #drop ( inputs -- node ) d-tail in-d-node <#drop> ;
|
||||
|
||||
NODE: #values
|
||||
: #values ( -- node ) meta-d get >list in-d-node <#values> ;
|
||||
|
||||
NODE: #return
|
||||
: #return ( -- node ) meta-d get >list in-d-node <#return> ;
|
||||
|
||||
NODE: #ifte
|
||||
: #ifte ( in -- node ) 1 d-tail in-d-node <#ifte> ;
|
||||
|
||||
NODE: #dispatch
|
||||
: #dispatch ( in -- node ) 1 d-tail in-d-node <#dispatch> ;
|
||||
|
||||
: node-inputs ( d-count r-count node -- )
|
||||
tuck
|
||||
>r r-tail r> set-node-in-r
|
||||
>r d-tail r> set-node-in-d ;
|
||||
|
||||
: node-outputs ( d-count r-count node -- )
|
||||
tuck
|
||||
>r r-tail r> set-node-out-r
|
||||
>r d-tail r> set-node-out-d ;
|
||||
|
||||
! Variable holding dataflow graph being built.
|
||||
SYMBOL: dataflow-graph
|
||||
! The most recently added node.
|
||||
SYMBOL: current-node
|
||||
|
||||
: node, ( node -- )
|
||||
dataflow-graph get [
|
||||
dup current-node [ set-node-successor ] change
|
||||
] [
|
||||
! first node
|
||||
dup dataflow-graph set current-node set
|
||||
] ifte ;
|
||||
|
||||
: nest-node ( -- dataflow current )
|
||||
dataflow-graph get dataflow-graph off
|
||||
current-node get current-node off ;
|
||||
|
||||
: unnest-node ( new-node dataflow current -- new-node )
|
||||
>r >r dataflow-graph get unit over set-node-children
|
||||
r> dataflow-graph set
|
||||
r> current-node set ;
|
||||
|
||||
: with-nesting ( quot -- new-node | quot: -- new-node )
|
||||
nest-node 2slip unnest-node ; inline
|
||||
|
||||
: copy-effect ( from to -- )
|
||||
over node-in-d over set-node-in-d
|
||||
over node-in-r over set-node-in-r
|
||||
over node-out-d over set-node-out-d
|
||||
swap node-out-r swap set-node-out-r ;
|
||||
|
||||
! Recursive state. An alist, mapping words to labels.
|
||||
SYMBOL: recursive-state
|
||||
|
||||
! We build a dataflow graph for the compiler.
|
||||
SYMBOL: dataflow-graph
|
||||
|
||||
! Label nodes have the node-label variable set.
|
||||
SYMBOL: #label
|
||||
|
||||
SYMBOL: #call ( non-tail call )
|
||||
SYMBOL: #call-label
|
||||
SYMBOL: #push ( literal )
|
||||
SYMBOL: #drop
|
||||
|
||||
! This is purely a marker for values we retain after a
|
||||
! conditional. It does not generate code, but merely alerts the
|
||||
! dataflow optimizer to the fact these values must be retained.
|
||||
SYMBOL: #values
|
||||
|
||||
SYMBOL: #return
|
||||
|
||||
SYMBOL: node-consume-d
|
||||
SYMBOL: node-produce-d
|
||||
SYMBOL: node-consume-r
|
||||
SYMBOL: node-produce-r
|
||||
SYMBOL: node-op
|
||||
SYMBOL: node-label
|
||||
|
||||
! #push nodes have this field set to the value being pushed.
|
||||
! #call nodes have this as the word being called
|
||||
SYMBOL: node-param
|
||||
|
||||
: <dataflow-node> ( param op -- node )
|
||||
<namespace> [
|
||||
node-op set
|
||||
node-param set
|
||||
[ ] node-consume-d set
|
||||
[ ] node-produce-d set
|
||||
[ ] node-consume-r set
|
||||
[ ] node-produce-r set
|
||||
] extend ;
|
||||
|
||||
: node-inputs ( d-count r-count -- )
|
||||
#! Execute in the node's namespace.
|
||||
meta-r get vector-tail* node-consume-r set
|
||||
meta-d get vector-tail* node-consume-d set ;
|
||||
|
||||
: dataflow-inputs ( in node -- )
|
||||
[ length 0 node-inputs ] bind ;
|
||||
|
||||
: node-outputs ( d-count r-count -- )
|
||||
#! Execute in the node's namespace.
|
||||
meta-r get vector-tail* node-produce-r set
|
||||
meta-d get vector-tail* node-produce-d set ;
|
||||
|
||||
: dataflow-outputs ( out node -- )
|
||||
[ length 0 node-outputs ] bind ;
|
||||
|
||||
: get-dataflow ( -- IR )
|
||||
dataflow-graph get reverse ;
|
||||
|
||||
: dataflow, ( param op -- node )
|
||||
#! Add a node to the dataflow IR.
|
||||
<dataflow-node> dup dataflow-graph [ cons ] change ;
|
||||
|
||||
: dataflow-drop, ( n -- )
|
||||
f #drop dataflow, [ 0 node-inputs ] bind ;
|
||||
|
||||
: dataflow-push, ( n -- )
|
||||
f #push dataflow, [ 0 node-outputs ] bind ;
|
||||
|
||||
: apply-dataflow ( dataflow name default -- )
|
||||
#! For the dataflow node, look up named word property,
|
||||
#! if its not defined, apply default quotation to
|
||||
#! ( node ) otherwise apply property quotation to
|
||||
#! ( node ).
|
||||
>r >r dup [ node-op get ] bind r> word-prop dup [
|
||||
call r> drop
|
||||
] [
|
||||
drop r> call
|
||||
] ifte ;
|
||||
|
|
|
|||
|
|
@ -18,7 +18,7 @@ SYMBOL: inferring-base-case
|
|||
SYMBOL: d-in
|
||||
|
||||
: pop-literal ( -- rstate obj )
|
||||
1 dataflow-drop, pop-d >literal< ;
|
||||
1 #drop node, pop-d >literal< ;
|
||||
|
||||
: (ensure-types) ( typelist n stack -- )
|
||||
pick [
|
||||
|
|
@ -48,6 +48,12 @@ SYMBOL: d-in
|
|||
meta-d [ append ] change
|
||||
d-in [ append ] change ;
|
||||
|
||||
: hairy-node ( node effect quot -- )
|
||||
over car ensure-d
|
||||
-rot 2dup car length 0 rot node-inputs
|
||||
2slip
|
||||
cdr car length 0 rot node-outputs ; inline
|
||||
|
||||
: (present-effect) ( vector -- list )
|
||||
>list [ value-class ] map ;
|
||||
|
||||
|
|
@ -64,6 +70,7 @@ SYMBOL: d-in
|
|||
0 <vector> d-in set
|
||||
recursive-state set
|
||||
dataflow-graph off
|
||||
current-node off
|
||||
inferring-base-case off ;
|
||||
|
||||
GENERIC: apply-object
|
||||
|
|
@ -71,7 +78,7 @@ GENERIC: apply-object
|
|||
: apply-literal ( obj -- )
|
||||
#! Literals are annotated with the current recursive
|
||||
#! state.
|
||||
recursive-state get <literal> push-d 1 dataflow-push, ;
|
||||
recursive-state get <literal> push-d 1 #push node, ;
|
||||
|
||||
M: object apply-object apply-literal ;
|
||||
|
||||
|
|
@ -119,12 +126,6 @@ M: object apply-object apply-literal ;
|
|||
"Word leaves elements on return stack" inference-error
|
||||
] unless ;
|
||||
|
||||
: values-node ( op -- )
|
||||
#! Add a #values or #return node to the graph.
|
||||
f swap dataflow, [
|
||||
meta-d get >list node-consume-d set
|
||||
] bind ;
|
||||
|
||||
: with-infer ( quot -- )
|
||||
[
|
||||
f init-inference
|
||||
|
|
@ -133,10 +134,10 @@ M: object apply-object apply-literal ;
|
|||
check-return
|
||||
] with-scope ;
|
||||
|
||||
: infer ( quot -- [[ in out ]] )
|
||||
: infer ( quot -- effect )
|
||||
#! Stack effect of a quotation.
|
||||
[ infer-quot effect present-effect ] with-infer ;
|
||||
|
||||
: dataflow ( quot -- dataflow )
|
||||
#! Data flow of a quotation.
|
||||
[ infer-quot #return values-node get-dataflow ] with-infer ;
|
||||
[ infer-quot #return node, dataflow-graph get ] with-infer ;
|
||||
|
|
|
|||
|
|
@ -6,7 +6,7 @@ sequences words ;
|
|||
|
||||
: literal-inputs? ( in stack -- )
|
||||
tail-slice dup >list [ safe-literal? ] all? [
|
||||
length dataflow-drop, t
|
||||
length #drop node, t
|
||||
] [
|
||||
drop f
|
||||
] ifte ;
|
||||
|
|
@ -16,7 +16,7 @@ sequences words ;
|
|||
|
||||
: literal-outputs ( out stack -- )
|
||||
tail-slice dup [ recursive-state get <literal> ] nmap
|
||||
length dataflow-push, ;
|
||||
length #push node, ;
|
||||
|
||||
: partial-eval? ( word -- ? )
|
||||
"infer-effect" word-prop car length
|
||||
|
|
|
|||
|
|
@ -4,24 +4,27 @@ IN: inference
|
|||
USING: interpreter kernel namespaces words ;
|
||||
|
||||
\ >r [
|
||||
f \ >r dataflow, [ 1 0 node-inputs ] extend
|
||||
\ >r #call
|
||||
1 0 pick node-inputs
|
||||
pop-d push-r
|
||||
[ 0 1 node-outputs ] bind
|
||||
0 1 pick node-outputs
|
||||
node,
|
||||
] "infer" set-word-prop
|
||||
|
||||
\ r> [
|
||||
f \ r> dataflow, [ 0 1 node-inputs ] extend
|
||||
\ r> #call
|
||||
0 1 pick node-inputs
|
||||
pop-r push-d
|
||||
[ 1 0 node-outputs ] bind
|
||||
1 0 pick node-outputs
|
||||
node,
|
||||
] "infer" set-word-prop
|
||||
|
||||
: partial-eval ( word quot -- | quot: word -- )
|
||||
>r f over dup "infer-effect" word-prop r> with-dataflow ;
|
||||
|
||||
: infer-shuffle ( word -- )
|
||||
[ host-word ] partial-eval ;
|
||||
dup #call [
|
||||
over "infer-effect" word-prop [ host-word ] hairy-node
|
||||
] keep node, ;
|
||||
|
||||
\ drop [ 1 dataflow-drop, pop-d drop ] "infer" set-word-prop
|
||||
\ drop [ 1 #drop node, pop-d drop ] "infer" set-word-prop
|
||||
\ dup [ \ dup infer-shuffle ] "infer" set-word-prop
|
||||
\ swap [ \ swap infer-shuffle ] "infer" set-word-prop
|
||||
\ over [ \ over infer-shuffle ] "infer" set-word-prop
|
||||
|
|
|
|||
|
|
@ -5,37 +5,24 @@ USING: errors generic interpreter kernel lists math
|
|||
math-internals namespaces sequences strings vectors words
|
||||
hashtables parser prettyprint ;
|
||||
|
||||
: with-dataflow ( param op [[ in# out# ]] quot -- )
|
||||
#! Take input parameters, execute quotation, take output
|
||||
#! parameters, add node. The quotation is called with the
|
||||
#! stack effect.
|
||||
>r dup car ensure-d
|
||||
>r dataflow, r> r> rot
|
||||
[ pick car swap [ length 0 node-inputs ] bind ] keep
|
||||
pick >r >r nip call r> r> cdr car swap
|
||||
[ length 0 node-outputs ] bind ; inline
|
||||
|
||||
: consume-d ( typelist -- )
|
||||
[ pop-d 2drop ] each ;
|
||||
|
||||
: produce-d ( typelist -- )
|
||||
[ <computed> push-d ] each ;
|
||||
|
||||
: (consume/produce) ( param op effect )
|
||||
dup >r -rot r>
|
||||
[ unswons consume-d car produce-d ] with-dataflow ;
|
||||
|
||||
: consume/produce ( word [ in-types out-types ] -- )
|
||||
: consume/produce ( word effect -- )
|
||||
#! Add a node to the dataflow graph that consumes and
|
||||
#! produces a number of values.
|
||||
over "intrinsic" word-prop [
|
||||
f -rot
|
||||
] [
|
||||
#call swap
|
||||
] ifte (consume/produce) ;
|
||||
swap #call [
|
||||
over [
|
||||
2unlist swap consume-d produce-d
|
||||
] hairy-node
|
||||
] keep node, ;
|
||||
|
||||
: no-effect ( word -- )
|
||||
"Unknown stack effect: " swap word-name cat2 inference-error ;
|
||||
"Unknown stack effect: " swap word-name append
|
||||
inference-error ;
|
||||
|
||||
: inhibit-parital ( -- )
|
||||
meta-d get [ f swap set-value-safe? ] each ;
|
||||
|
|
@ -43,31 +30,16 @@ hashtables parser prettyprint ;
|
|||
: recursive? ( word -- ? )
|
||||
f swap dup word-def [ = or ] tree-each-with ;
|
||||
|
||||
: (with-block) ( [[ label quot ]] quot -- node )
|
||||
#! Call a quotation in a new namespace, and transfer
|
||||
#! inference state from the outer scope.
|
||||
swap car >r [
|
||||
dataflow-graph off
|
||||
call
|
||||
d-in get meta-d get meta-r get get-dataflow
|
||||
] with-scope
|
||||
r> swap #label dataflow, [ node-label set ] extend >r
|
||||
meta-r set meta-d set d-in set r> ;
|
||||
|
||||
: with-block ( word [[ label quot ]] quot -- node )
|
||||
: with-block ( word [[ label quot ]] quot -- block-node )
|
||||
#! Execute a quotation with the word on the stack, and add
|
||||
#! its dataflow contribution to a new block node in the IR.
|
||||
over [
|
||||
>r
|
||||
dupd cons
|
||||
recursive-state [ cons ] change
|
||||
r> call
|
||||
] (with-block) ;
|
||||
#! its dataflow contribution to a new #label node in the IR.
|
||||
>r 2dup cons recursive-state [ cons ] change r>
|
||||
[ swap car #label slip ] with-nesting
|
||||
recursive-state [ cdr ] change ; inline
|
||||
|
||||
: inline-block ( word -- effect node )
|
||||
: inline-block ( word -- node-block )
|
||||
gensym over word-def cons [
|
||||
inhibit-parital
|
||||
word-def infer-quot effect
|
||||
inhibit-parital word-def infer-quot
|
||||
] with-block ;
|
||||
|
||||
: inline-compound ( word -- )
|
||||
|
|
@ -75,7 +47,7 @@ hashtables parser prettyprint ;
|
|||
#! inferencer instance. If the word in question is recursive
|
||||
#! we infer its stack effect inside a new block.
|
||||
dup recursive? [
|
||||
inline-block 2drop
|
||||
inline-block node,
|
||||
] [
|
||||
word-def infer-quot
|
||||
] ifte ;
|
||||
|
|
@ -86,7 +58,7 @@ hashtables parser prettyprint ;
|
|||
[
|
||||
[
|
||||
recursive-state get init-inference
|
||||
dup dup inline-block drop present-effect
|
||||
dup dup inline-block drop effect present-effect
|
||||
[ "infer-effect" set-word-prop ] keep
|
||||
] with-scope consume/produce
|
||||
] [
|
||||
|
|
@ -153,16 +125,16 @@ M: compound apply-word ( word -- )
|
|||
|
||||
: base-case ( word [ label quot ] -- )
|
||||
[
|
||||
car over inline-block [
|
||||
drop
|
||||
[ #call-label ] [ #call ] ?ifte
|
||||
node-op set
|
||||
node-param set
|
||||
] bind
|
||||
>r [ inline-block ] keep r> car [
|
||||
#call-label
|
||||
] [
|
||||
#call
|
||||
] ?ifte [ copy-effect ] keep node,
|
||||
] with-recursion ;
|
||||
|
||||
: no-base-case ( word -- )
|
||||
word-name " does not have a base case." cat2 inference-error ;
|
||||
word-name " does not have a base case." append
|
||||
inference-error ;
|
||||
|
||||
: recursive-word ( word [ label quot ] -- )
|
||||
#! Handle a recursive call, by either applying a previously
|
||||
|
|
|
|||
|
|
@ -70,3 +70,5 @@ TUPLE: circle radius ;
|
|||
M: circle area circle-radius sq pi * ;
|
||||
|
||||
[ 200 ] [ << rect f 0 0 10 20 >> area ] unit-test
|
||||
|
||||
[ ] [ "IN: temporary SYMBOL: #x TUPLE: #x ;" eval ] unit-test
|
||||
|
|
|
|||
Loading…
Reference in New Issue