Dataflow UI improvements

TODO.FACTOR.txt

@@ -7,11 +7,6 @@
 - links:
   - same deal
 
-- UI dataflow visualizer:
-  - spacing is weird
-  - #label, #if mess up height
-  - [ >r + dup r> ] foo  broken
-  - why does + look funny?
 - pane output in UI should use less memory
 - signal 4 on datastack underflow on mac intel??
 - faster I/O
@@ -45,6 +40,7 @@
 - merge keyboard help with help in some way
 - keyboard help: hide commands whose gestures are shadowed
 - division by zero may not raise an error -- document this
+- the editor should fill up the interior of the scroller completely
 
 + ui:
 

doc/handbook/tools.facts

@@ -93,15 +93,11 @@ ARTICLE: "debugger" "The debugger"
 ARTICLE: "inspector" "The inspector"
 "The prettyprinter (see " { $link "prettyprint" } ") can turn any object into a source representation. Sometimes this source representation is hard to read for a human, so the inspector provides an alternative tabular view of an object:"
 { $subsection inspect }
-"Once running, the inspector spawns a new nested listener with an " { $snippet "inspector" } " prompt. The inspector supports a number of commands:"
+"The inspector supports a number of commands which operate on the most recently inspected object:"
 { $subsection inspecting }
 { $subsection go }
 { $subsection up }
-{ $subsection bye }
-"A one-time inspector-like display can be shown without starting the inspector:"
-{ $subsection describe }
 "Word for getting very brief descriptions of words and general objects:"
-{ $subsection synopsis }
 { $subsection summary } ;
 
 ARTICLE: "memory" "Object memory"

library/compiler/generator/generator.factor

@@ -178,26 +178,36 @@ M: #push generate-node
         [ append ] keep delete-all
     ] if ;
 
-: phantom-shuffle-inputs ( shuffle -- locs locs )
-    dup shuffle-in-d length phantom-d get phantom-shuffle-input
-    swap shuffle-in-r length phantom-r get phantom-shuffle-input ;
-
 : adjust-shuffle ( shuffle -- )
-    dup shuffle-in-d length neg phantom-d get adjust-phantom
+    shuffle-in length neg phantom-d get adjust-phantom ;
-    shuffle-in-r length neg phantom-r get adjust-phantom ;
-
-: shuffle-vregs# ( shuffle -- n )
-    dup shuffle-in-d swap shuffle-in-r additional-vregs ;
 
 : phantom-shuffle ( shuffle -- )
-    dup shuffle-vregs# 0 ensure-vregs
+    dup shuffle-in 0 additional-vregs 0 ensure-vregs
-    [ phantom-shuffle-inputs ] keep
+    [
+        shuffle-in length phantom-d get phantom-shuffle-input
+    ] keep
     [ shuffle* ] keep adjust-shuffle
-    (template-outputs) ;
+    phantom-d get phantom-append ;
 
 M: #shuffle generate-node
     node-shuffle phantom-shuffle iterate-next ;
 
+M: #>r generate-node
+    drop
+    1 0 additional-vregs 0 ensure-vregs
+    1 phantom-d get phantom-shuffle-input
+    -1 phantom-d get adjust-phantom
+    phantom-r get phantom-append
+    iterate-next ;
+
+M: #r> generate-node
+    drop
+    0 1 additional-vregs 0 ensure-vregs
+    1 phantom-r get phantom-shuffle-input
+    -1 phantom-r get adjust-phantom
+    phantom-d get phantom-append
+    iterate-next ;
+
 ! #return
 M: #return generate-node drop end-basic-block %return f ;
 

library/compiler/generator/templates.factor

@@ -206,9 +206,6 @@ SYMBOL: phantom-r
 : phantom-append ( seq stack -- )
     over length over adjust-phantom swap nappend ;
 
-: (template-outputs) ( seq stack -- )
-    phantoms swapd phantom-append phantom-append ;
-
 SYMBOL: +input
 SYMBOL: +output
 SYMBOL: +scratch
@@ -273,7 +270,7 @@ SYMBOL: +clobber
     alloc-scratch ;
 
 : template-outputs ( -- )
-    +output get [ get ] map { } (template-outputs) ;
+    +output get [ get ] map phantom-d get phantom-append ;
 
 : with-template ( quot spec -- )
     fix-spec [ template-inputs call template-outputs ] bind

library/compiler/inference/dataflow.factor

@@ -16,36 +16,18 @@ SYMBOL: meta-r
 : pop-r meta-r get pop ;
 : peek-r meta-r get peek ;
 
-TUPLE: node param shuffle
+TUPLE: node param
-d-height r-height
+in-d out-d in-r out-r
 classes literals history
 successor children ;
 
 M: node equal? eq? ;
 
-: d-height ( -- n ) meta-d get length d-in get - ; inline
+: node-shuffle ( node -- shuffle )
-
+    dup node-in-d swap node-out-d <shuffle> ;
-: r-height ( -- n ) meta-r get length ;
-
-: record-height ( node -- )
-    d-height over set-node-d-height
-    r-height swap set-node-r-height ;
 
 : make-node ( param in-d out-d in-r out-r node -- node )
-    [
+    [ >r f f f f f <node> r> set-delegate ] keep ;
-        >r swapd <shuffle> f f f f f f f <node> r>
-        set-delegate
-    ] keep ;
-
-: node-in-d  node-shuffle shuffle-in-d  ;
-: node-in-r  node-shuffle shuffle-in-r  ;
-: node-out-d node-shuffle shuffle-out-d ;
-: node-out-r node-shuffle shuffle-out-r ;
-
-: set-node-in-d  node-shuffle set-shuffle-in-d  ;
-: set-node-in-r  node-shuffle set-shuffle-in-r  ;
-: set-node-out-d node-shuffle set-shuffle-out-d ;
-: set-node-out-r node-shuffle set-shuffle-out-r ;
 
 : empty-node f { } { } { } { } ;
 : param-node { } { } { } { } ;
@@ -87,6 +69,14 @@ TUPLE: #shuffle ;
 C: #shuffle make-node ;
 : #shuffle ( -- node ) empty-node <#shuffle> ;
 
+TUPLE: #>r ;
+C: #>r make-node ;
+: #>r ( -- node ) empty-node <#>r> ;
+
+TUPLE: #r> ;
+C: #r> make-node ;
+: #r> ( -- node ) empty-node <#r>> ;
+
 TUPLE: #values ;
 C: #values make-node ;
 : #values ( -- node ) meta-d-node <#values> ;
@@ -130,7 +120,6 @@ SYMBOL: dataflow-graph
 SYMBOL: current-node
 
 : node, ( node -- )
-    dup record-height
     dataflow-graph get [
         dup current-node [ set-node-successor ] change
     ] [

library/compiler/inference/shuffle.factor

@@ -22,35 +22,22 @@ M: integer value-uid ;
 
 M: integer value-recursion drop f ;
 
-TUPLE: shuffle in-d in-r out-d out-r ;
+TUPLE: shuffle in out ;
 
-: load-shuffle ( d r shuffle -- )
+: split-shuffle ( stack shuffle -- stack1 stack2 )
-    tuck shuffle-in-r [ set ] 2each shuffle-in-d [ set ] 2each ;
+    shuffle-in length swap cut* ;
 
-: shuffled-values ( values -- values )
+: load-shuffle ( stack shuffle -- )
-    [ [ namespace hash dup ] keep ? ] map ;
+    shuffle-in [ set ] 2each ;
 
-: store-shuffle ( shuffle -- d r )
+: shuffled-values ( shuffle -- values )
-    dup shuffle-out-d shuffled-values
+    shuffle-out [ get ] map ;
-    swap shuffle-out-r shuffled-values ;
 
-: shuffle* ( d r shuffle -- d r )
+: shuffle* ( stack shuffle -- stack )
-    [ [ load-shuffle ] keep store-shuffle ] with-scope ;
+    [ [ load-shuffle ] keep shuffled-values ] with-scope ;
 
-: split-shuffle ( d r shuffle -- d' r' d r )
+: shuffle ( stack shuffle -- stack )
-    tuck shuffle-in-r length swap cut*
+    [ split-shuffle ] keep shuffle* append ;
-    >r >r shuffle-in-d length swap cut*
-    r> swap r> ;
-
-: join-shuffle ( d' r' d r -- d r )
-    swapd append >r append r> ;
-
-: shuffle ( d r shuffle -- newd newr )
-    [ split-shuffle ] keep shuffle* join-shuffle ;
 
 M: shuffle clone
-    [ shuffle-in-d clone ] keep
+    [ shuffle-in clone ] keep shuffle-out clone <shuffle> ;
-    [ shuffle-in-r clone ] keep
-    [ shuffle-out-d clone ] keep
-    shuffle-out-r clone
-    <shuffle> ;

library/compiler/inference/stack.factor

@@ -3,16 +3,13 @@ USING: arrays generic kernel math namespaces
 sequences words parser ;
 
 : infer-shuffle-inputs ( shuffle node -- )
-    >r dup shuffle-in-d length swap shuffle-in-r length r>
+    >r shuffle-in length 0 r> node-inputs ;
-    node-inputs ;
 
 : shuffle-stacks ( shuffle -- )
-    #! Shuffle simulated stacks.
+    meta-d [ swap shuffle ] change ;
-    meta-d get meta-r get rot shuffle meta-r set meta-d set ;
 
 : infer-shuffle-outputs ( shuffle node -- )
-    >r dup shuffle-out-d length swap shuffle-out-r length r>
+    >r shuffle-out length 0 r> node-outputs ;
-    node-outputs ;
 
 : infer-shuffle ( shuffle -- )
     #shuffle dup node,
@@ -21,7 +18,7 @@ sequences words parser ;
     infer-shuffle-outputs ;
 
 : shuffle>effect ( shuffle -- effect )
-    dup shuffle-in-d swap shuffle-out-d <effect> ;
+    dup shuffle-in swap shuffle-out <effect> ;
 
 : define-shuffle ( word shuffle -- )
     [ "shuffle" set-word-prop ] 2keep
@@ -29,22 +26,38 @@ sequences words parser ;
     [ , \ infer-shuffle , ] [ ] make "infer" set-word-prop ;
 
 {
-    { drop  T{ shuffle f 1 0 {             } {   } } }
+    { drop  T{ shuffle f 1 {             } } }
-    { 2drop T{ shuffle f 2 0 {             } {   } } }
+    { 2drop T{ shuffle f 2 {             } } }
-    { 3drop T{ shuffle f 3 0 {             } {   } } }
+    { 3drop T{ shuffle f 3 {             } } }
-    { dup   T{ shuffle f 1 0 { 0 0         } {   } } }
+    { dup   T{ shuffle f 1 { 0 0         } } }
-    { 2dup  T{ shuffle f 2 0 { 0 1 0 1     } {   } } }
+    { 2dup  T{ shuffle f 2 { 0 1 0 1     } } }
-    { 3dup  T{ shuffle f 3 0 { 0 1 2 0 1 2 } {   } } }
+    { 3dup  T{ shuffle f 3 { 0 1 2 0 1 2 } } }
-    { rot   T{ shuffle f 3 0 { 1 2 0       } {   } } }
+    { rot   T{ shuffle f 3 { 1 2 0       } } }
-    { -rot  T{ shuffle f 3 0 { 2 0 1       } {   } } }
+    { -rot  T{ shuffle f 3 { 2 0 1       } } }
-    { dupd  T{ shuffle f 2 0 { 0 0 1       } {   } } }
+    { dupd  T{ shuffle f 2 { 0 0 1       } } }
-    { swapd T{ shuffle f 3 0 { 1 0 2       } {   } } }
+    { swapd T{ shuffle f 3 { 1 0 2       } } }
-    { nip   T{ shuffle f 2 0 { 1           } {   } } }
+    { nip   T{ shuffle f 2 { 1           } } }
-    { 2nip  T{ shuffle f 3 0 { 2           } {   } } }
+    { 2nip  T{ shuffle f 3 { 2           } } }
-    { tuck  T{ shuffle f 2 0 { 1 0 1       } {   } } }
+    { tuck  T{ shuffle f 2 { 1 0 1       } } }
-    { over  T{ shuffle f 2 0 { 0 1 0       } {   } } }
+    { over  T{ shuffle f 2 { 0 1 0       } } }
-    { pick  T{ shuffle f 3 0 { 0 1 2 0     } {   } } }
+    { pick  T{ shuffle f 3 { 0 1 2 0     } } }
-    { swap  T{ shuffle f 2 0 { 1 0         } {   } } }
+    { swap  T{ shuffle f 2 { 1 0         } } }
-    { >r    T{ shuffle f 1 0 {             } { 0 } } }
-    { r>    T{ shuffle f 0 1 { 0           } {   } } }
 } [ first2 define-shuffle ] each
+
+\ >r [
+    #>r dup node,
+    1 0 pick node-inputs
+    pop-d push-r
+    0 1 rot node-outputs
+] "infer" set-word-prop
+
+\ >r { object } { } <effect> "infer-effect" set-word-prop
+
+\ r> [
+    #r> dup node,
+    0 1 pick node-inputs
+    pop-r push-d
+    1 0 rot node-outputs
+] "infer" set-word-prop
+
+\ r> { } { object } <effect> "infer-effect" set-word-prop

library/compiler/optimizer/kill-literals.factor

@@ -1,5 +1,5 @@
-! Copyright (C) 2004, 2005 Slava Pestov.
+! Copyright (C) 2004, 2006 Slava Pestov.
-! See http://factor.sf.net/license.txt for BSD license.
+! See http://factorcode.org/license.txt for BSD license.
 IN: optimizer
 USING: arrays generic hashtables inference kernel math
 namespaces sequences words ;
@@ -49,7 +49,7 @@ M: #return live-values*
 
 ! nodes that don't use their values directly
 UNION: #killable
-    #push #shuffle #call-label #merge #values #entry ;
+    #push #shuffle #>r #r> #call-label #merge #values #entry ;
 
 M: #killable live-values* drop { } ;
 

library/compiler/optimizer/optimizer.factor

@@ -40,6 +40,14 @@ M: node optimize-node* drop t ;
 M: #shuffle optimize-node* 
     [ node-values empty? ] prune-if ;
 
+! #>r
+M: #>r optimize-node* 
+    [ node-in-d empty? ] prune-if ;
+
+! #r>
+M: #r> optimize-node* 
+    [ node-in-r empty? ] prune-if ;
+
 ! #push
 M: #push optimize-node* 
     [ node-out-d empty? ] prune-if ;

library/ui/tools/dataflow.factor

@@ -7,10 +7,9 @@ gadgets-labels gadgets-theme gadgets-presentations
 gadgets-buttons gadgets-borders gadgets-scrolling
 gadgets-frames gadgets-workspace optimizer models ;
 
-: shuffle-in dup shuffle-in-d swap shuffle-in-r append ;
+GENERIC: node>gadget ( height node -- gadget )
-
-: shuffle-out dup shuffle-out-d swap shuffle-out-r append ;
 
+! Representation of shuffle nodes
 TUPLE: shuffle-gadget value ;
 
 : literal-theme ( shuffle -- )
@@ -24,14 +23,17 @@ C: shuffle-gadget ( node -- gadget )
     dup delegate>gadget ;
 
 : shuffled-offsets ( shuffle -- seq )
-    dup shuffle-in swap shuffle-out [ swap index ] map-with ;
+    dup shuffle-in swap shuffle-out
+    [ swap index ] map-with ;
 
-: shuffled-endpoints ( w seq seq -- seq )
+: shuffled-endpoints ( w h seq seq -- seq )
-    [ [ 30 * 15 + ] 2apply >r dupd 2array 0 r> 2array 2array ]
+    [ [ 30 * 15 + ] map ] 2apply
-    2map nip ;
+    >r over r> [ - ] map-with >r [ - ] map-with r>
+    [ 0 swap 2array ] map >r [ 2array ] map-with r>
+    [ 2array ] 2map ;
 
 : draw-shuffle ( gadget seq seq -- )
-    >r >r rect-dim first r> r> shuffled-endpoints
+    >r >r rect-dim first2 r> r> shuffled-endpoints
     [ first2 gl-line ] each ;
 
 M: shuffle-gadget draw-gadget*
@@ -40,62 +42,60 @@ M: shuffle-gadget draw-gadget*
     shuffled-offsets [ length ] keep
     draw-shuffle ;
 
-: shuffle-dim ( shuffle -- node )
+: node-dim ( n -- dim ) 30 * 10 swap 2array ;
+
+: shuffle-dim ( shuffle -- dim )
     dup shuffle-in length swap shuffle-out length max
-    30 * 10 swap 2array ;
+    node-dim ;
 
 M: shuffle-gadget pref-dim*
-    dup delegate pref-dim
+    shuffle-gadget-value shuffle-dim ;
-    swap shuffle-gadget-value shuffle-dim
-    vmax ;
 
-TUPLE: height-gadget value skew ;
+M: #shuffle node>gadget nip node-shuffle <shuffle-gadget> ;
 
-C: height-gadget ( value skew -- gadget )
+! Stack height underneath a node
-    [ set-height-gadget-skew ] keep
+TUPLE: height-gadget value ;
+
+C: height-gadget ( value -- gadget )
     [ set-height-gadget-value ] keep
     dup delegate>gadget ;
 
 M: height-gadget pref-dim*
-    dup height-gadget-value swap height-gadget-skew abs +
+    height-gadget-value node-dim ;
-    30 * 10 swap 2array ;
-
-: height-offsets ( value skew -- seq seq )
-    [ abs swap [ [ + ] map-with ] keep ] keep
-    0 < [ swap ] when ;
 
 M: height-gadget draw-gadget*
     { 0 0 0 1 } gl-color
-    dup height-gadget-value over height-gadget-skew
+    dup height-gadget-value dup draw-shuffle ;
-    height-offsets draw-shuffle ;
 
-TUPLE: node-gadget value ;
+! Calls and pushes
+TUPLE: node-gadget value height ;
 
-C: node-gadget ( gadget node -- gadget )
+C: node-gadget ( gadget node height -- gadget )
+    [ set-node-gadget-height ] keep
     [ set-node-gadget-value ] keep
-    swap <default-border> over set-gadget-delegate ;
+    swap <default-border> over set-gadget-delegate
+    dup faint-boundary ;
 
 M: node-gadget pref-dim*
     dup delegate pref-dim
-    swap node-gadget-value node-shuffle shuffle-dim
+    swap dup node-gadget-height [
-    vmax ;
+        node-dim
-
+    ] [
-GENERIC: node>gadget ( node -- gadget )
+        node-gadget-value node-shuffle shuffle-dim
+    ] ?if vmax ;
 
 M: #call node>gadget
+    nip
     [ node-param word-name <label> ] keep
-    [ <node-gadget> ] keep node-param <object-presentation>
+    [ f <node-gadget> ] keep node-param <object-presentation>
     dup word-theme ;
 
 M: #push node>gadget
-    [
+    nip [
         >#push< [ literalize unparse ] map " " join <label>
-    ] keep <node-gadget> dup literal-theme ;
+    ] keep f <node-gadget> dup literal-theme ;
-
-M: #shuffle node>gadget node-shuffle <shuffle-gadget> ;
-
-DEFER: dataflow.
 
+! #if #dispatch #label
 : <child-nodes> ( seq -- seq )
     [ length ] keep
     [
@@ -103,70 +103,69 @@ DEFER: dataflow.
         <object-presentation>
     ] 2map ;
 
+: default-node-content ( node -- gadget )
+    dup node-children <child-nodes>
+    swap class word-name <mono-label> add* make-pile
+    { 5 5 } over set-pack-gap ;
+
 M: object node>gadget
-    [
+    nip dup default-node-content swap f <node-gadget> ;
-        dup class word-name <label> ,
+
-        dup node-children <child-nodes> %
+UNION: full-height-node #if #dispatch #label ;
-    ] { } make make-pile
+
-    { 5 5 } over set-pack-gap
+M: full-height-node node>gadget
-    swap <node-gadget> dup faint-boundary ;
+    dup default-node-content swap rot <node-gadget> ;
+
+! Constructing the graphical representation; first we compute
+! stack heights
+SYMBOL: d-height
+
+: compute-child-heights ( node -- )
+    node-children dup empty? [
+        drop
+    ] [
+        [
+            [ (compute-heights) d-height get ] { } make drop
+        ] map supremum d-height set
+    ] if ;
 
 : (compute-heights) ( node -- )
     [
-        [ node-d-height ] keep
+        d-height get over 2array ,
-        [ node-r-height ] keep
+        dup compute-child-heights
-        [ 3array , ] keep
+        dup node-out-d length over node-in-d length -
+        d-height [ + ] change
         node-successor (compute-heights)
     ] when* ;
 
-: node-in-d# node-in-d length ;
+: normalize-height ( seq -- seq )
-: node-out-d# node-out-d length ;
+    [
-
+        [ dup first swap second node-in-d length - ] map infimum
-: node-in-r# node-in-r length ;
+    ] keep
-: node-out-r# node-out-r length ;
+    [ first2 >r swap - r> 2array ] map-with ;
-
-: normalize-d-height ( seq -- seq )
-    [ [ dup first swap third node-in-d# - ] map infimum ] keep
-    [ first3 >r >r swap - r> r> 3array ] map-with ;
-
-: normalize-r-height ( seq -- seq )
-    [ [ dup second swap third node-in-r# - ] map infimum ] keep
-    [ first3 >r rot - r> 3array ] map-with ;
 
 : compute-heights ( nodes -- pairs )
-    [ (compute-heights) ] { } make
+    [ 0 d-height set (compute-heights) ] { } make
-    normalize-d-height normalize-r-height ;
+    normalize-height ;
 
-: node-r-skew-1 ( node -- n )
+! Then we create gadgets for every node
-    dup node-out-d# over node-in-r# [-] swap node-in-d# [-] ;
+: print-node ( d-height node -- )
-
+    dup full-height-node? [
-: node-r-skew-2 ( node -- n )
+        node>gadget
-    dup node-in-d# over node-out-r# [-] swap node-out-d# [-] ;
+    ] [
-
+        [ node-in-d length - <height-gadget> ] 2keep
-SYMBOL: prev-node 
+        node>gadget swap 2array
-
+        make-pile 1 over set-pack-fill
-: node-r-skew ( node -- n )
+    ] if , ;
-    node-r-skew-1 prev-node get [ node-r-skew-2 - ] when* ;
-
-: print-node ( d-height r-height node -- )
-    [
-        [
-            pick 0 <height-gadget> ,
-            2dup node-in-r# + over node-r-skew <height-gadget> ,
-        ] { } make make-pile ,
-        [
-            rot over node-in-d# - 0 <height-gadget> ,
-            node>gadget ,
-            0 <height-gadget> ,
-        ] { } make make-pile 1 over set-pack-fill ,
-    ] keep prev-node set ;
 
 : <dataflow-graph> ( node -- gadget )
-    prev-node off
+    compute-heights [
-    compute-heights
+        dup empty? [ dup first first <height-gadget> , ] unless
-    [ [ first3 print-node ] each ] { } make
+        [ first2 print-node ] each
-    make-shelf ;
+    ] { } make
+    make-shelf 1 over set-pack-align ;
 
+! The UI tool
 TUPLE: dataflow-gadget history search ;
 
 dataflow-gadget {

library/ui/tools/workspace.factor

@@ -63,7 +63,7 @@ workspace {
         { "Definitions" T{ key-down f f "F3" } [ browser select-tool ] }
         { "Documentation" T{ key-down f f "F4" } [ help-gadget select-tool ] }
         { "Walker" T{ key-down f f "F5" } [ walker-gadget select-tool ] }
-        { "Dataflow" T{ key-down f f "F6" } [ walker-gadget select-tool ] }
+        { "Dataflow" T{ key-down f f "F6" } [ dataflow-gadget select-tool ] }
     }
 
     {