diff --git a/doc/handbook.tex b/doc/handbook.tex index a1cfe92da5..acffad2dd3 100644 --- a/doc/handbook.tex +++ b/doc/handbook.tex @@ -6271,6 +6271,144 @@ The compiler has two limitations you must be aware of. First, if an exception is The compiler consists of multiple stages -- first, a dataflow graph is inferred, then various optimizations are done on this graph, then it is transformed into a linear representation, further optimizations are done, and finally, machine code is generated from the linear representation. +\section{Dataflow intermediate representation} + +The dataflow IR represents nested control structure, and annotates all calls with stack input and output annotations. Such annotations consists of lists of values, where a value abstracts over a possibly unknown computation result. It has a tree shape, where each node is a tuple delegating to an instance of the \verb|node| tuple class. + +The \verb|node| tuple has the following slots: + +\begin{description} +\item[\texttt{param}] The meaning is determined by the tuple wrapping the node instance. For example with \verb|#call| nodes, this is the word being called. +\item[\texttt{in-d}] A list of input values popped the data stack. +\item[\texttt{in-r}] A list of input values popped the return stack. Only used by \verb|#call >r| nodes. +\item[\texttt{out-d}] A list of output values pushed on the data stack. +\item[\texttt{out-r}] A list of output values pushed on the return stack. Only used by \verb|#call r>| nodes. +\item[\texttt{node-successor}] The direct successor of the node. +\item[\texttt{node-children}] A list of the node's children, for example if this is a branch or label node. The number of children depends on the type of node. +\end{description} + +Note that nodes are linked by the \verb|node-successor| slot. Nested structure is realized by a list value in the \verb|node-children| slot. + +The stack effect inferencer transforms quotations into dataflow IR. + +\wordtable{ +\vocabulary{inference} +\ordinaryword{dataflow}{dataflow ( quot -- node )} +} + +Produces the dataflow IR of a quotation. + +\wordtable{ +\vocabulary{inference} +\ordinaryword{dataflow.}{dataflow.~( node -- )} +} + +Prints dataflow IR in human-readable form. + +\subsection{Values} + +Values are an abstraction over possibly known computation inputs and outputs. There are three types of values: + +\begin{description} +\item[Literal values] represent a known constant +\item[Computed values] represent inputs and outputs whose specific value is not known +\item[Joined values] represent a unification of possible values of a stack slot where branched control flow meets +\end{description} + +The \verb|value| tuple has the following slots: + +\begin{description} +\item[\texttt{recursion}] A list of nested lexical scopes, used to resolve recursive stack effects +\item[\texttt{safe?}] This is a hack. If this is false, the value's type at that point might not potentially be known, since a entry to this block from another entry point can potentially occur +\end{description} + +\subsection{Straight-line code} + +\begin{description} + +\item[\texttt{\#push}] Pushes literal values on the data stack. + +\begin{tabular}{l|l} +Slot&Role\\ +\hline +\verb|node-out-d|&A list of literals. +\end{tabular} + +\item[\texttt{\#drop}] Pops literal values from the data stack. + +\begin{tabular}{l|l} +Slot&Role\\ +\hline +\verb|node-in-d|&A list of literals. +\end{tabular} + +\item[\texttt{\#call}] Invokes the word identified by \verb|node-param|. + +\begin{tabular}{l|l} +Slot&Role\\ +\hline +\verb|node-param|&A word.\\ +\verb|node-in-d|&Input values.\\ +\verb|node-out-d|&Output values. +\end{tabular} + +\item[\texttt{\#call-label}] Like \verb|#call| but \verb|node-param| refers to a parent \verb|#label| node. + +\end{description} + +\subsection{Branching and recursion} + +\begin{description} + +\item[\texttt{\#ifte}] A conditional expression. + +\begin{tabular}{l|l} +Slot&Role\\ +\hline +\verb|node-in-d|&A singleton list holding the condition being tested.\\ +\verb|node-children|&A list of two nodes, the true and false branches. +\end{tabular} + +\item[\texttt{\#dispatch}] A jump table. + +\begin{tabular}{l|l} +Slot&Role\\ +\hline +\verb|node-in-d|&A singleton list holding the jump table index.\\ +\verb|node-children|&A list of nodes, in consecutive jump table order. +\end{tabular} + +\item[\texttt{\#values}] Found at the end of each branch in an \verb|#ifte| or \verb|#dispatch| node. + +\begin{tabular}{l|l} +Slot&Role\\ +\hline +\verb|node-out-d|&A list of values present on the data stack at the end of the branch.\\ +\end{tabular} + +\item[\texttt{\#label}] A named block of code. Child \verb|#call-label| nodes can recurse on this label. + +\begin{tabular}{l|l} +Slot&Role\\ +\hline +\verb|node-param|&A gensym identifying the label.\\ +\verb|node-children|&A singleton list whose sole element is the labelled node. +\end{tabular} + +\item[\texttt{\#return}] Found at the end of a word's dataflow IR. + +\begin{tabular}{l|l} +Slot&Role\\ +\hline +\verb|node-out-d|&Values present on the stack when the word returns. +\end{tabular} + +\end{description} + +\section{Dataflow optimizer} + +\subsection{Killing unused literals} + \section{Linear intermediate representation} The linear IR is the second of the two intermediate diff --git a/library/bootstrap/boot-stage1.factor b/library/bootstrap/boot-stage1.factor index 8d16275738..80ad224844 100644 --- a/library/bootstrap/boot-stage1.factor +++ b/library/bootstrap/boot-stage1.factor @@ -90,11 +90,12 @@ parser prettyprint sequences io vectors words ; "/library/inference/words.factor" "/library/inference/stack.factor" "/library/inference/partial-eval.factor" + "/library/inference/optimizer.factor" + "/library/inference/print-dataflow.factor" "/library/compiler/assembler.factor" "/library/compiler/relocate.factor" "/library/compiler/xt.factor" - "/library/compiler/optimizer.factor" "/library/compiler/vops.factor" "/library/compiler/linearizer.factor" "/library/compiler/intrinsics.factor" diff --git a/library/bootstrap/boot-stage3.factor b/library/bootstrap/boot-stage3.factor index 2a9e7dcb0c..56eb3eff4a 100644 --- a/library/bootstrap/boot-stage3.factor +++ b/library/bootstrap/boot-stage3.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2004, 2005 Slava Pestov. ! See http://factor.sf.net/license.txt for BSD license. USING: alien assembler command-line compiler compiler-backend -compiler-frontend io-internals kernel lists math namespaces -parser sequences io unparser words ; +compiler-frontend inference io-internals kernel lists math +namespaces parser sequences io unparser words ; "Compiling base..." print diff --git a/library/collections/assoc.factor b/library/collections/assoc.factor index fa44e5f7e8..2959adb23a 100644 --- a/library/collections/assoc.factor +++ b/library/collections/assoc.factor @@ -14,12 +14,6 @@ IN: lists USING: kernel sequences ; : assoc ( key alist -- value ) assoc* cdr ; -: assq* ( key alist -- [[ key value ]] ) - #! Looks up a key/value pair using identity comparison. - [ car eq? ] find-with nip ; - -: assq ( key alist -- value ) assq* cdr ; - : remove-assoc ( key alist -- alist ) #! Remove all key/value pairs with this key. [ car = not ] subset-with ; diff --git a/library/collections/sequences-epilogue.factor b/library/collections/sequences-epilogue.factor index 7d5a25ab0b..4febc4ca6f 100644 --- a/library/collections/sequences-epilogue.factor +++ b/library/collections/sequences-epilogue.factor @@ -186,9 +186,13 @@ M: object peek ( sequence -- element ) : join ( seq glue -- seq ) #! The new sequence is of the same type as glue. - swap dup length swap - [ over push 2dup push ] each nip >pop> - concat ; + swap dup empty? [ + swap like + ] [ + dup length swap + [ over push 2dup push ] each nip >pop> + concat + ] ifte ; M: object reverse-slice ( seq -- seq ) ; @@ -243,6 +247,14 @@ M: object reverse ( seq -- seq ) [ ] keep like ; #! Longest sequence length in a sequence of sequences. 0 [ length max ] reduce ; +: subst ( new old seq -- seq ) + #! Substitute elements of old in seq with corresponding + #! elements from new. + [ + dup pick index dup -1 = + [ drop ] [ nip pick nth ] ifte + ] map 2nip ; + IN: kernel : depth ( -- n ) diff --git a/library/compiler/intrinsics.factor b/library/compiler/intrinsics.factor index f864fd5715..96701798c5 100644 --- a/library/compiler/intrinsics.factor +++ b/library/compiler/intrinsics.factor @@ -59,6 +59,8 @@ sequences words ; : peek-2 dup length 2 - swap nth ; : node-peek-2 ( node -- obj ) node-in-d peek-2 ; +: value-types drop f ; + : typed? ( value -- ? ) value-types length 1 = ; : slot@ ( node -- n ) diff --git a/library/inference/branches.factor b/library/inference/branches.factor index aff4ba6770..4a80177e79 100644 --- a/library/inference/branches.factor +++ b/library/inference/branches.factor @@ -4,9 +4,6 @@ IN: inference USING: errors generic hashtables interpreter kernel lists math matrices namespaces prettyprint sequences strings vectors words ; -: computed-value-vector ( n -- vector ) - empty-vector [ drop object ] map ; - : add-inputs ( count stack -- stack ) #! Add this many inputs to the given stack. [ length - computed-value-vector ] keep append ; @@ -18,10 +15,8 @@ matrices namespaces prettyprint sequences strings vectors words ; : unify-results ( seq -- value ) #! If all values in list are equal, return the value. - #! Otherwise, unify types. - dup [ eq? ] fiber? - [ first ] - [ [ value-class ] map class-or-list ] ifte ; + #! Otherwise, unify. + dup [ eq? ] fiber? [ first ] [ ] ifte ; : unify-stacks ( seq -- stack ) #! Replace differing literals in stacks with unknown @@ -53,24 +48,19 @@ matrices namespaces prettyprint sequences strings vectors words ; [ [ active? ] bind ] subset ; : unify-effects ( seq -- ) - filter-terminators [ - dup datastack-effect callstack-effect - ] [ - terminate - ] ifte* ; + filter-terminators + [ dup datastack-effect callstack-effect ] + [ terminate ] ifte* ; : unify-dataflow ( effects -- nodes ) [ [ dataflow-graph get ] bind ] map ; -: clone-values ( seq -- seq ) [ clone-value ] map ; - : copy-inference ( -- ) #! We avoid cloning the same object more than once in order #! to preserve identity structure. - cloned off - meta-r [ clone-values ] change - meta-d [ clone-values ] change - d-in [ clone-values ] change + meta-r [ clone ] change + meta-d [ clone ] change + d-in [ clone ] change dataflow-graph off current-node off ; @@ -82,34 +72,31 @@ matrices namespaces prettyprint sequences strings vectors words ; copy-inference dup value-recursion recursive-state set literal-value dup infer-quot - active? [ - #values node, - handle-terminator - ] [ - drop - ] ifte + active? [ #values node, handle-terminator ] [ drop ] ifte ] extend ; : (infer-branches) ( branchlist -- list ) - [ infer-branch ] map dup unify-effects unify-dataflow ; + [ infer-branch ] map dup unify-effects + unify-dataflow ; : 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. - [ >r (infer-branches) r> set-node-children ] keep node, ; + [ >r (infer-branches) r> set-node-children ] keep + node, meta-d get >list #merge node, ; \ ifte [ - 2 #drop node, pop-d pop-d swap 2list + 2 #drop node, pop-d pop-d swap 2vector #ifte pop-d drop infer-branches ] "infer" set-word-prop -: vtable>list ( rstate vtable -- list ) - [ swap ] map-with >list ; +: vtable-value ( rstate vtable -- seq ) + [ swap ] map-with ; USE: kernel-internals \ dispatch [ - pop-literal vtable>list + pop-literal vtable-value #dispatch pop-d drop infer-branches ] "infer" set-word-prop diff --git a/library/inference/dataflow.factor b/library/inference/dataflow.factor index 72b295c1eb..d1438827e1 100644 --- a/library/inference/dataflow.factor +++ b/library/inference/dataflow.factor @@ -8,16 +8,16 @@ sequences vectors words ; ! 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 +TUPLE: node 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 r> set-delegate ] keep ; -: 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 ; +: empty-node f f f f f f f f ; +: param-node ( label) f f f f f ; +: in-d-node ( inputs) >r f r> f f f f ; +: out-d-node ( outputs) >r f f r> f f f ; : d-tail ( n -- list ) meta-d get tail* >list ; : r-tail ( n -- list ) meta-r get tail* >list ; @@ -58,6 +58,10 @@ TUPLE: #dispatch ; C: #dispatch make-node ; : #dispatch ( in -- node ) 1 d-tail in-d-node <#dispatch> ; +TUPLE: #merge ; +C: #merge make-node ; +: #merge ( values -- node ) in-d-node <#merge> ; + : node-inputs ( d-count r-count node -- ) tuck >r r-tail r> set-node-in-r diff --git a/library/inference/inference.factor b/library/inference/inference.factor index 66e2c8df47..c413f41783 100644 --- a/library/inference/inference.factor +++ b/library/inference/inference.factor @@ -20,31 +20,14 @@ SYMBOL: d-in : pop-literal ( -- rstate obj ) 1 #drop node, pop-d >literal< ; -: (ensure-types) ( typelist n stack -- ) - pick [ - 3dup >r >r car r> r> nth value-class-and - >r >r cdr r> 1 + r> (ensure-types) - ] [ - 3drop - ] ifte ; - -: ensure-types ( typelist stack -- ) - dup length pick length - dup 0 < [ - swap >r neg swap tail 0 r> - ] [ - swap - ] ifte (ensure-types) ; +: computed-value-vector ( n -- vector ) + empty-vector dup [ drop ] nmap ; : required-inputs ( typelist stack -- values ) - >r dup length r> length - dup 0 > [ - swap head [ ] map - ] [ - 2drop f - ] ifte ; + >r length r> length - abs computed-value-vector ; : ensure-d ( typelist -- ) - dup meta-d get ensure-types - meta-d get required-inputs >vector dup + meta-d get required-inputs dup meta-d [ append ] change d-in [ append ] change ; @@ -54,16 +37,9 @@ SYMBOL: d-in 2slip second length 0 rot node-outputs ; inline -: (present-effect) ( vector -- list ) - >list [ value-class ] map ; - -: present-effect ( [[ d-in meta-d ]] -- [ in-types out-types ] ) +: present-effect ( [[ d-in meta-d ]] -- [[ in# out# ]] ) #! After inference is finished, collect information. - uncons >r (present-effect) r> (present-effect) 2list ; - -: simple-effect ( [[ d-in meta-d ]] -- [[ in# out# ]] ) - #! After inference is finished, collect information. - uncons length >r length r> cons ; + uncons length >r length r> 2list ; : init-inference ( recursive-state -- ) init-interpreter diff --git a/library/compiler/optimizer.factor b/library/inference/optimizer.factor similarity index 64% rename from library/compiler/optimizer.factor rename to library/inference/optimizer.factor index 8dc963bfe1..c788462a8f 100644 --- a/library/compiler/optimizer.factor +++ b/library/inference/optimizer.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2004, 2005 Slava Pestov. ! See http://factor.sf.net/license.txt for BSD license. -IN: compiler-frontend +IN: inference USING: generic hashtables inference kernel lists matrices -namespaces sequences ; +namespaces sequences vectors ; ! The optimizer transforms dataflow IR to dataflow IR. Currently ! it removes literals that are eventually dropped, and never @@ -52,35 +52,31 @@ DEFER: kill-node 2drop ] ifte ; -GENERIC: useless-node? ( node -- ? ) +GENERIC: optimize-node* ( node -- node ) -DEFER: prune-nodes +DEFER: optimize-node ( node -- node/t ) -: prune-children ( node -- ) - [ node-children [ prune-nodes ] map ] keep - set-node-children ; +: optimize-children ( node -- ) + dup node-children [ optimize-node ] map + swap set-node-children ; -: (prune-nodes) ( node -- ) - [ - dup prune-children - dup node-successor dup useless-node? [ - node-successor over set-node-successor - ] [ - nip - ] ifte (prune-nodes) - ] when* ; +: keep-optimizing ( node -- node ) + dup optimize-node* dup t = + [ drop ] [ nip keep-optimizing ] ifte ; -: prune-nodes ( node -- node ) - dup useless-node? [ - node-successor prune-nodes - ] [ - [ (prune-nodes) ] keep - ] ifte ; +: optimize-node ( node -- node ) + keep-optimizing dup [ + dup optimize-children + dup node-successor optimize-node over set-node-successor + ] when ; : optimize ( dataflow -- dataflow ) #! Remove redundant literals from the IR. The original IR #! is destructively modified. - dup kill-set over kill-node prune-nodes ; + dup kill-set over kill-node optimize-node ; + +: prune-if ( node quot -- successor/t ) + over >r call [ r> node-successor ] [ r> drop t ] ifte ; ! Generic nodes M: node literals* ( node -- ) @@ -95,11 +91,10 @@ M: node can-kill* ( literal node -- ? ) M: node kill-node* ( literals node -- ) 2drop ; -M: f useless-node? ( node -- ? ) - drop f ; +M: f optimize-node* drop t ; -M: node useless-node? ( node -- ? ) - drop f ; +M: node optimize-node* ( node -- t ) + drop t ; ! #push M: #push literals* ( node -- ) @@ -111,8 +106,8 @@ M: #push can-kill* ( literal node -- ? ) M: #push kill-node* ( literals node -- ) [ node-out-d seq-diffq ] keep set-node-out-d ; -M: #push useless-node? ( node -- ? ) - node-out-d empty? ; +M: #push optimize-node* ( node -- node/t ) + [ node-out-d empty? ] prune-if ; ! #drop M: #drop can-kill* ( literal node -- ? ) @@ -121,8 +116,8 @@ M: #drop can-kill* ( literal node -- ? ) M: #drop kill-node* ( literals node -- ) [ node-in-d seq-diffq ] keep set-node-in-d ; -M: #drop useless-node? ( node -- ? ) - node-in-d empty? ; +M: #drop optimize-node* ( node -- node/t ) + [ node-in-d empty? ] prune-if ; ! #call M: #call can-kill* ( literal node -- ? ) @@ -174,8 +169,19 @@ M: #call kill-node* ( literals node -- ) dup node-param (kill-shuffle) [ kill-shuffle ] [ 2drop ] ifte ; -M: #call useless-node? ( node -- ? ) - node-param not ; +: optimize-not? ( #call -- ? ) + dup node-param \ not = + [ node-successor #ifte? ] [ drop f ] ifte ; + +: flip-branches ( #ifte -- ) + dup node-children 2unseq swap 2vector swap set-node-children ; + +M: #call optimize-node* ( node -- node ) + dup optimize-not? [ + node-successor dup flip-branches + ] [ + [ node-param not ] prune-if + ] ifte ; ! #call-label M: #call-label can-kill* ( literal node -- ? ) @@ -215,9 +221,45 @@ M: #values can-kill* ( literal node -- ? ) ] ifte ; ! #ifte +: static-branch? ( node -- lit ? ) + node-in-d first dup safe-literal? ; + +: static-branch ( conditional n -- node ) + >r [ node-in-d in-d-node <#drop> ] keep r> + over node-children nth + over node-successor over last-node set-node-successor + pick set-node-successor drop ; + M: #ifte can-kill* ( literal node -- ? ) can-kill-branches? ; +M: #ifte optimize-node* ( node -- node ) + dup static-branch? + [ f swap value= 1 0 ? static-branch ] [ 2drop t ] ifte ; + ! #dispatch M: #dispatch can-kill* ( literal node -- ? ) can-kill-branches? ; + +! #values +: subst-values ( new old node -- ) + dup [ + 3dup [ node-in-d subst ] keep set-node-in-d + 3dup [ node-in-r subst ] keep set-node-in-r + 3dup [ node-out-d subst ] keep set-node-out-d + 3dup [ node-out-r subst ] keep set-node-out-r + node-successor subst-values + ] [ + 3drop + ] ifte ; + +: post-split ( #values -- node ) + #! If a #values is followed by a #merge, we need to replace + #! meet values after the merge with their branch value in + #! #values. + dup node-successor dup node-successor + >r >r node-in-d reverse-slice r> node-in-d reverse-slice r> + [ subst-values ] keep ; + +M: #values optimize-node* ( node -- node ) + dup node-successor #merge? [ post-split ] [ drop t ] ifte ; diff --git a/library/inference/print-dataflow.factor b/library/inference/print-dataflow.factor new file mode 100644 index 0000000000..2c6aab9aaf --- /dev/null +++ b/library/inference/print-dataflow.factor @@ -0,0 +1,70 @@ +IN: inference +USING: generic inference io kernel kernel-internals math +namespaces prettyprint sequences vectors words ; + +! A simple tool for turning dataflow IR into quotations, for +! debugging purposes. + +GENERIC: node>quot ( node -- ) + +TUPLE: annotation node text ; + +M: annotation prettyprint* ( ann -- ) + "( " over annotation-text " )" append3 + swap annotation-node object. ; + +: value-str ( values -- str ) + length "x" " " join ; + +: effect-str ( node -- str ) + [ + dup node-in-d value-str % + "-" % + node-out-d value-str % + ] make-string ; + +M: #push node>quot ( node -- ) + node-out-d [ literal-value ] map % ; + +M: #drop node>quot ( node -- ) + node-in-d length dup 3 > [ + \ drop % + ] [ + { f drop 2drop 3drop } nth , + ] ifte ; + +DEFER: dataflow>quot + +M: #call node>quot ( node -- ) + dup node-param , dup effect-str , ; + +M: #call-label node>quot ( node -- ) + "#call-label: " over node-param word-name append , ; + +M: #label node>quot ( node -- ) + dup "#label: " over node-param word-name append , + node-children first dataflow>quot , \ call , ; + +M: #ifte node>quot ( node -- ) + dup "#ifte" , + node-children [ dataflow>quot ] map % \ ifte , ; + +M: #dispatch node>quot ( node -- ) + dup "#dispatch" , + node-children [ dataflow>quot ] map >vector % \ dispatch , ; + +M: #return node>quot ( node -- ) "#return" , ; + +M: #values node>quot ( node -- ) "#values" , ; + +M: #merge node>quot ( node -- ) "#merge" , ; + +: (dataflow>quot) ( node -- ) + [ dup node>quot node-successor (dataflow>quot) ] when* ; + +: dataflow>quot ( node -- quot ) + [ (dataflow>quot) ] make-list ; + +: dataflow. ( quot -- ) + #! Print dataflow IR for a word. + dataflow>quot prettyprint ; diff --git a/library/inference/values.factor b/library/inference/values.factor index c5e40e9a0d..58e86b21fc 100644 --- a/library/inference/values.factor +++ b/library/inference/values.factor @@ -4,12 +4,8 @@ IN: inference USING: generic kernel lists namespaces sequences unparser words ; GENERIC: value= ( literal value -- ? ) -GENERIC: value-class-and ( class value -- ) -SYMBOL: cloned -GENERIC: clone-value ( value -- value ) - -TUPLE: value class recursion safe? ; +TUPLE: value recursion safe? ; C: value ( recursion -- value ) [ t swap set-value-safe? ] keep @@ -17,62 +13,32 @@ C: value ( recursion -- value ) TUPLE: computed ; -C: computed ( class -- value ) - swap recursive-state get [ set-value-class ] keep - over set-delegate ; +C: computed ( -- value ) + recursive-state get over set-delegate ; M: computed value= ( literal value -- ? ) 2drop f ; -: failing-class-and ( class class -- class ) - 2dup class-and dup null = [ - -rot [ - word-name % " and " % word-name % - " do not intersect" % - ] make-string inference-warning - ] [ - 2nip - ] ifte ; - -M: computed value-class-and ( class value -- ) - [ - value-class failing-class-and - ] keep set-value-class ; - TUPLE: literal value ; C: literal ( obj rstate -- value ) - [ - >r [ >r dup class r> set-value-class ] keep - r> set-delegate - ] keep + [ >r r> set-delegate ] keep [ set-literal-value ] keep ; -M: literal clone-value ( value -- value ) ; - M: literal value= ( literal value -- ? ) literal-value = ; -M: literal value-class-and ( class value -- ) - value-class class-and drop ; - -M: literal set-value-class ( class value -- ) - 2drop ; - -M: computed clone-value ( value -- value ) - dup cloned get assq [ ] [ - dup clone [ swap cloned [ acons ] change ] keep - ] ?ifte ; - -M: computed literal-value ( value -- ) - "A literal value was expected where a computed value was" - " found: " rot unparse append3 inference-error ; - -: value-types ( value -- list ) - value-class builtin-supertypes ; - : >literal< ( literal -- rstate obj ) dup value-recursion swap literal-value ; +M: value literal-value ( value -- ) + "A literal value was expected where a computed value was found" + inference-error ; + +TUPLE: meet values ; + +C: meet ( values -- value ) + [ set-meet-values ] keep f over set-delegate ; + PREDICATE: tuple safe-literal ( obj -- ? ) dup literal? [ value-safe? ] [ drop f ] ifte ; diff --git a/library/inference/words.factor b/library/inference/words.factor index 7197fb82a1..7389034963 100644 --- a/library/inference/words.factor +++ b/library/inference/words.factor @@ -9,7 +9,7 @@ hashtables parser prettyprint ; [ pop-d 2drop ] each ; : produce-d ( typelist -- ) - [ push-d ] each ; + [ drop push-d ] each ; : consume/produce ( word effect -- ) #! Add a node to the dataflow graph that consumes and diff --git a/library/syntax/prettyprint.factor b/library/syntax/prettyprint.factor index 3ecabe8475..02d311c22d 100644 --- a/library/syntax/prettyprint.factor +++ b/library/syntax/prettyprint.factor @@ -12,8 +12,11 @@ SYMBOL: recursion-check GENERIC: prettyprint* ( indent obj -- indent ) +: object. ( str obj -- ) + presented swons unit format ; + : unparse. ( obj -- ) - dup unparse swap presented swons unit format ; + [ unparse ] keep object. ; M: object prettyprint* ( indent obj -- indent ) unparse. ; diff --git a/library/test/sequences.factor b/library/test/sequences.factor index 5211229b1f..e3b5a11774 100644 --- a/library/test/sequences.factor +++ b/library/test/sequences.factor @@ -58,3 +58,9 @@ USING: kernel lists math sequences strings test vectors ; [ "hello world how are you" ] [ { "hello" "world" "how" "are" "you" } " " join ] unit-test + +[ "" ] [ { } "" join ] unit-test + +[ { "three" "three" "two" "two" "one" "one" } ] +[ { "one" "two" "three" } { 1 2 3 } { 3 3 2 2 1 1 } subst ] +unit-test diff --git a/library/ui/editors.factor b/library/ui/editors.factor index d30c9cf356..5c0f5ac07d 100644 --- a/library/ui/editors.factor +++ b/library/ui/editors.factor @@ -54,6 +54,8 @@ TUPLE: editor line caret ; [[ [ "LEFT" ] [ [ left ] with-editor ] ]] [[ [ "RIGHT" ] [ [ right ] with-editor ] ]] [[ [ "CTRL" "k" ] [ [ line-clear ] with-editor ] ]] + [[ [ "HOME" ] [ [ home ] with-editor ] ]] + [[ [ "END" ] [ [ end ] with-editor ] ]] ] swap add-actions ; : ( -- caret ) diff --git a/library/ui/line-editor.factor b/library/ui/line-editor.factor index a05c9bb8e8..115b1c673f 100644 --- a/library/ui/line-editor.factor +++ b/library/ui/line-editor.factor @@ -117,3 +117,11 @@ SYMBOL: history-index : right ( -- ) #! Call this in the line editor scope. caret [ 1 + line-text get length min ] change ; + +: home ( -- ) + #! Call this in the line editor scope. + 0 caret set ; + +: end ( -- ) + #! Call this in the line editor scope. + line-text get length caret set ;