<magnus--> http://www.caddr.com/macho/archives/sbcl-devel/2005-3/4764.html\r
<magnus--> http://clozure.com/cgi-bin/viewcvs.cgi/ccl/lisp-kernel/lisp-exceptions.c?rev=1.9&content-type=text/vnd.viewcvs-markup\r
\r
+- single-stepper and variable access: wrong namespace?\r
+- [ over ] generics no-method\r
- investigate if COPYING_GEN needs a fix\r
-- alien-global type wrong\r
- simplifier:\r
- dead loads not optimized out\r
- kill tag-fixnum/untag-fixnum\r
! 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
" 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 ;
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 ;
-
-\ alien-invoke [ linearize-alien-invoke ] "linearizer" set-word-prop
+ linearize-return ;
-\ 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
: 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
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
1 %inc-r ,
1 %dec-d ,
0 0 %replace-r ,
-] "linearizer" set-word-prop
+] "intrinsic" set-word-prop
\ r> [
drop
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 - ;
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? [
1 %untag ,
0 1 2 %set-slot ,
] ifte
-] "linearizer" set-word-prop
-
-\ type t "intrinsic" set-word-prop
+] "intrinsic" set-word-prop
\ type [
drop
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
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
[[ 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* [
] [
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
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 , ;
] 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
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 ;
-
-: 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.
+ #! stack flow information, and flattens conditionals into
+ #! jumps and labels.
+ [ %prologue , linearize-node ] make-list ;
+
+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 ;
+
+M: #call-label linearize-node* ( node -- )
+ node-param %call-label , ;
+
+: 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 ;
-#call [
- [ node-param get ] bind %call ,
-] "linearizer" set-word-prop
+: push-1 ( obj -- )
+ 0 swap literal-value dup
+ immediate? [ %immediate ] [ %indirect ] ifte , ;
-#call-label [
- [ node-param get ] bind %call-label ,
-] "linearizer" set-word-prop
+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.
: 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 , ;
-
-\ dispatch [
- [ node-param get ] bind linearize-dispatch
-] "linearizer" set-word-prop
+ node-children dispatch-head dupd dispatch-body %label , ;
-#values [ drop ] "linearizer" set-word-prop
+M: #values linearize-node* ( node -- )
+ drop ;
-#return [ drop f %return , ] "linearizer" set-word-prop
+M: #return linearize-node* ( node -- )
+ drop f %return , ;
! 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-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-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
+
+: optimize ;
terminate
] ifte* ;
+: unify-dataflow ( effects -- nodes )
+ [ [ dataflow-graph get ] bind ] map ;
+
: deep-clone ( seq -- seq ) [ clone ] map ;
: copy-inference ( -- )
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:
dup value-recursion recursive-state set
literal-value dup infer-quot
active? [
- #values values-node
+ #values node,
handle-terminator
] [
drop
] 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 )
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
! 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 ;
-! Recursive state. An alist, mapping words to labels.
-SYMBOL: recursive-state
+! 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> ;
-! We build a dataflow graph for the compiler.
+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
-! 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
+: node, ( node -- )
+ dataflow-graph get [
+ dup current-node [ set-node-successor ] change
] [
- drop r> call
+ ! 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
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 [
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 ;
0 <vector> d-in set
recursive-state set
dataflow-graph off
+ current-node off
inferring-base-case off ;
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 ;
"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
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 ;
: literal-inputs? ( in stack -- )
tail-slice dup >list [ safe-literal? ] all? [
- length dataflow-drop, t
+ length #drop node, t
] [
drop f
] ifte ;
: 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
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
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 ;
: 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) ;
-
-: inline-block ( word -- effect node )
+ #! 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 -- 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 -- )
#! 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 ;
[
[
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
] [
: 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
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
projects / factor.git / commitdiff