Cleanup compiler and some minor library code

doc/handbook/collections.facts

@@ -52,7 +52,6 @@ ARTICLE: "hashtables-lookup" "Looking up keys in hashtables"
 
 ARTICLE: "hashtables-mutation" "Storing keys in hashtables"
 { $subsection set-hash }
-{ $subsection ?set-hash }
 { $subsection remove-hash }
 { $subsection clear-hash } ;
 

library/alien/alien-invoke.factor

@@ -74,7 +74,8 @@ M: alien-invoke stack-reserve*
     alien-invoke-parameters stack-space ;
 
 : parse-arglist ( return seq -- types stack-effect )
-    unpair rot dup "void" = [ drop { } ] [ 1array ] if 2array
+    2 swap group unpair
+    rot dup "void" = [ drop { } ] [ 1array ] if 2array
     effect>string ;
 
 : (define-c-word) ( type lib func types stack-effect -- )

library/bootstrap/boot-stage1.factor

@@ -127,9 +127,9 @@ vectors words ;
 
         "/library/compiler/assembler.factor"
         "/library/compiler/vops.factor"
+        "/library/compiler/templates.factor"
         "/library/compiler/linearizer.factor"
         "/library/compiler/xt.factor"
-        "/library/compiler/stack.factor"
         "/library/compiler/intrinsics.factor"
         "/library/compiler/generator.factor"
         "/library/compiler/basic-blocks.factor"

library/bootstrap/boot-stage2.factor

@@ -5,8 +5,8 @@ kernel-internals lists math memory namespaces optimizer parser
 sequences sequences-internals words ;
 
 "Cross-referencing..." print
-xref-words
+H{ } clone crossref set-global xref-words
-xref-articles
+H{ } clone help-graph set-global xref-articles
 
 "compile" get [
     "native-io" get [

library/collections/hashtables.factor

@@ -235,9 +235,6 @@ M: hashtable hashcode ( hash -- n )
 : ?hash* ( key hash/f -- value/f )
     dup [ hash* ] [ 2drop f f ] if ; flushable
 
-: ?set-hash ( value key hash/f -- hash )
-    [ [ set-hash ] keep ] [ associate ] if ;
-
 : hash-stack ( key seq -- value )
     [ dupd hash-member? ] find-last nip ?hash ; flushable
 

library/collections/hashtables.facts

@@ -146,11 +146,6 @@ HELP: set-hash "( value key hash -- )"
 { $description "Stores an entry into the hashtable." }
 { $see-also hash remove-hash } ;
 
-HELP: ?set-hash "( value key hash/f -- hash )"
-{ $values { "value" "a value" } { "key" "a key" } { "hash/f" "a hashtable or " { $link f } } }
-{ $description "If the mapping is " { $link f } ", constructs a new hashtable storing the given key/value pair. Otherwise, stores the key/value pair into the hashtable." }
-{ $see-also hash remove-hash } ;
-
 HELP: hash-keys "( hash -- keys )"
 { $values { "hash" "a hashtable" } { "keys" "an array of keys" } }
 { $description "Outputs an array of all keys in the hashtable." }

library/collections/slicing.factor

@@ -104,8 +104,7 @@ strings vectors ;
     tuck swap tail-slice >r swap tail-slice r> ;
 
 : unpair ( seq -- firsts seconds )
-    2 swap group flip
+    flip dup empty? [ drop { } { } ] [ first2 ] if ;
-    dup empty? [ drop { } { } ] [ first2 ] if ;
 
 : concat ( seq -- seq )
     dup empty? [ [ [ % ] each ] over first make ] unless ;

library/compiler/intrinsics.factor

@@ -77,13 +77,13 @@ namespaces sequences words ;
 \ getenv [
     { { f "env" } } { "out" } [
         T{ vreg f 0 } "out" set
-        "out" get "env" get %getenv ,
+        "env" get "out" get %getenv ,
     ] with-template
 ] "intrinsic" set-word-prop
 
 \ setenv [
     { { 0 "value" } { f "env" } } { } [
-        "env" get "value" get %setenv ,
+        "value" get "env" get %setenv ,
     ] with-template
 ] "intrinsic" set-word-prop
 

library/compiler/linearizer.factor

@@ -58,11 +58,7 @@ SYMBOL: renamed-labels
 M: node linearize* ( node -- next ) drop iterate-next ;
 
 : linearize-call ( label -- next )
-    tail-call? [
+    tail-call? [ %jump , f ] [ %call , iterate-next ] if ;
-        %jump , f
-    ] [
-        %call , iterate-next
-    ] if ;
 
 : rename-label ( label -- label )
     <label> dup rot renamed-labels get set-hash ;
@@ -78,49 +74,7 @@ M: #label linearize* ( node -- next )
     #! to avoid problems with two IR #label nodes having the
     #! same label in different lexical scopes.
     dup node-param dup linearize-call-label >r
-    renamed-label swap node-child linearize-1
+    renamed-label swap node-child linearize-1 r> ;
-    r> ;
-
-: 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 ;
-
-: load-literal ( obj vreg -- )
-    over immediate? [ %immediate ] [ %indirect ] if , ;
-
-GENERIC: load-value ( vreg loc value -- operand )
-
-M: object load-value ( vreg loc value -- operand )
-    drop dupd %peek , ;
-
-M: value load-value ( vreg loc value -- operand )
-    nip value-literal swap [ [ load-literal ] keep ] when* ;
-
-: (template-inputs) ( seq template -- inputs )
-    dup length reverse-slice [ <ds-loc> ] map rot 3array flip
-    [ first3 load-value ] map ;
-
-: template-inputs ( node template -- )
-    flip first2 >r [ dup [ <vreg> ] when ] map
-    >r node-in-d r> (template-inputs)
-    r> [ set ] 2each ;
-
-: stacks<>vregs ( values quot quot -- )
-    >r >r dup reverse-slice swap length r> map r> 2each ; inline
-
-: template-outputs ( template -- )
-    [ get ] map [ <ds-loc> ] [ %replace , ] stacks<>vregs ;
-
-: with-template ( node in out quot -- )
-    [
-        >r
-        pick pick template-inputs
-        dup rot [ length ] 2apply - %inc-d ,
-        swap node set
-        r> swap slip template-outputs
-    ] with-scope ; inline
 
 : intrinsic ( #call -- quot ) node-param "intrinsic" word-prop ;
 
@@ -145,6 +99,43 @@ M: #call linearize* ( node -- next )
 M: #call-label linearize* ( node -- next )
     node-param renamed-label linearize-call ;
 
+SYMBOL: live-d
+SYMBOL: live-r
+
+: value-dropped? ( value -- ? )
+    dup value?
+    over live-d get member? not
+    rot live-r get member? not and
+    or ;
+
+: filter-dropped ( seq -- seq )
+    [ dup value-dropped? [ drop f ] when ] map ;
+
+: prepare-inputs ( values -- values templates )
+    filter-dropped dup [ any-reg swap 2array ] map ;
+
+: do-inputs ( node -- )
+    dup node-in-d prepare-inputs rot node-in-r prepare-inputs
+    template-inputs ;
+
+: live-stores ( instack outstack -- stack )
+    #! Avoid storing a value into its former position.
+    dup length [ pick ?nth dupd eq? [ drop f ] when ] 2map nip ;
+
+: shuffle-height ( node -- )
+    dup node-out-d length over node-in-d length - %inc-d ,
+    dup node-out-r length swap node-in-r length - %inc-r , ;
+
+M: #shuffle linearize* ( #shuffle -- )
+    [
+        0 vreg-allocator set
+        dup node-in-d over node-out-d live-stores live-d set
+        dup node-in-r over node-out-r live-stores live-r set
+        dup do-inputs
+        shuffle-height
+        live-d get live-r get template-outputs
+    ] with-scope iterate-next ;
+
 : ?static-branch ( node -- n )
     node-in-d first dup value?
     [ value-literal 0 1 ? ] [ drop f ] if ;

library/compiler/stack.factor

@@ -1,68 +0,0 @@
-! Copyright (C) 2005 Slava Pestov.
-! See http://factor.sf.net/license.txt for BSD license.
-IN: compiler-frontend
-USING: compiler-backend generic inference kernel math namespaces
-sequences vectors words ;
-
-SYMBOL: vreg-allocator
-SYMBOL: live-d
-SYMBOL: live-r
-
-: value-dropped? ( value -- ? )
-    dup value?
-    over live-d get member? not
-    rot live-r get member? not and
-    or ;
-
-: stack>vreg ( value stack-pos -- )
-    vreg-allocator get <vreg> pick set
-    over value-dropped? [ 2drop ] [ >r get r> %peek , ] if
-    vreg-allocator inc ;
-
-: stacks>vregs ( #shuffle -- )
-    dup
-    node-in-d [ <ds-loc> ] [ stack>vreg ] stacks<>vregs
-    node-in-r [ <cs-loc> ] [ stack>vreg ] stacks<>vregs ;
-
-: shuffle-height ( #shuffle -- )
-    dup node-out-d length over node-in-d length - %inc-d ,
-    dup node-out-r length swap node-in-r length - %inc-r , ;
-
-: literal>stack ( value stack-pos -- )
-    swap value-literal fixnum-imm? over immediate? and
-    [ T{ vreg f 0 } load-literal T{ vreg f 0 } ] unless
-    swap %replace , ; inline
-
-: vreg>stack ( value stack-pos -- )
-    {
-        { [ over not ] [ 2drop ] }
-        { [ over value? ] [ literal>stack ] }
-        { [ t ] [ >r get r> %replace , ] }
-    } cond ;
-
-: (vregs>stacks) ( stack stack -- )
-    [ <cs-loc> ] [ vreg>stack ] stacks<>vregs
-    [ <ds-loc> ] [ vreg>stack ] stacks<>vregs ;
-
-: literals/computed ( stack -- literals computed )
-    dup [ dup value? [ drop f ] unless ] map
-    swap [ dup value? [ drop f ] when ] map ;
-
-: vregs>stacks ( -- )
-    #! We store literals last because storing a literal to a
-    #! stack slot actually clobbers a vreg.
-    live-d get literals/computed
-    live-r get literals/computed
-    swapd (vregs>stacks) (vregs>stacks) ;
-
-: live-stores ( instack outstack -- stack )
-    #! Avoid storing a value into its former position.
-    dup length [ pick ?nth dupd eq? [ drop f ] when ] 2map nip ;
-
-M: #shuffle linearize* ( #shuffle -- )
-    [
-        0 vreg-allocator set
-        dup node-in-d over node-out-d live-stores live-d set
-        dup node-in-r over node-out-r live-stores live-r set
-        dup stacks>vregs shuffle-height vregs>stacks
-    ] with-scope iterate-next ;

library/compiler/templates.factor

@@ -0,0 +1,103 @@
+! Copyright (C) 2006 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+IN: compiler-frontend
+USING: arrays compiler-backend generic inference kernel math
+namespaces sequences vectors words ;
+
+! SYMBOL: d-height
+! SYMBOL: r-height
+! 
+! : adjust-stacks ( inc-d inc-r -- )
+!     r-height [ + ] change d-height [ + ] change ;
+! 
+! : finalize-stack ( quot symbol -- )
+!     [
+!         get dup zero? [ 2drop ] [ swap execute , ] if 0
+!     ] keep set ; inline
+! 
+! : end-basic-block ( -- )
+!     \ %inc-r r-height finalize-stack
+!     \ %inc-d d-height finalize-stack ;
+
+: 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 ;
+
+: load-literal ( obj vreg -- )
+    over immediate? [ %immediate ] [ %indirect ] if , ;
+
+GENERIC: stack>vreg* ( vreg loc value -- operand )
+
+M: object stack>vreg* ( vreg loc value -- operand )
+    drop >r <vreg> dup r> %peek , ;
+
+M: value stack>vreg* ( vreg loc value -- operand )
+    nip value-literal swap <vreg> [ load-literal ] keep ;
+
+SYMBOL: vreg-allocator
+
+SYMBOL: any-reg
+
+: alloc-value ( loc value -- operand )
+    vreg-allocator [ inc ] keep get -rot stack>vreg* ;
+
+: stack>vreg ( vreg loc value -- operand )
+    {
+        { [ dup not ] [ 3drop f ] }
+        { [ pick any-reg eq? ] [ alloc-value nip ] }
+        { [ pick not ] [ 2nip value-literal ] }
+        { [ t ] [ stack>vreg* ] }
+    } cond ;
+
+: (stack>vregs) ( names values template quot -- inputs )
+    >r dup length reverse r> map 3array flip
+    [ first3 rot stack>vreg ] map swap [ set ] 2each ; inline
+
+: stack>vregs ( stack template quot -- )
+    >r unpair -rot r> (stack>vregs) ; inline
+
+: template-inputs ( stack template stack template -- )
+    [ <cs-loc> ] stack>vregs [ <ds-loc> ] stack>vregs ;
+
+: literal>stack ( value stack-pos -- )
+    swap value-literal fixnum-imm? over immediate? and
+    [ T{ vreg f 0 } load-literal T{ vreg f 0 } ] unless
+    swap %replace , ; inline
+
+: vreg>stack ( value stack-pos -- )
+    {
+        { [ over not ] [ 2drop ] }
+        { [ over value? ] [ literal>stack ] }
+        { [ t ] [ >r get r> %replace , ] }
+    } cond ;
+
+: vregs>stack ( values quot -- )
+    >r dup reverse-slice swap length r> map
+    [ vreg>stack ] 2each ; inline
+
+: template-outputs ( stack stack -- )
+    [ <cs-loc> ] vregs>stack [ <ds-loc> ] vregs>stack ;
+
+SYMBOL: template-height
+
+: with-template ( node in out quot -- )
+    [
+        0 vreg-allocator set
+        pick length pick length swap - template-height set
+        swap >r >r
+        >r dup node-in-d r> { } { } template-inputs
+        template-height get %inc-d ,
+         node set r> call r> { } template-outputs
+    ] with-scope ; inline
+
+: literals/computed ( stack -- literals computed )
+    dup [ dup value? [ drop f ] unless ] map
+    swap [ dup value? [ drop f ] when ] map ;
+
+: vregs>stacks ( ds cs -- )
+    #! We store literals last because storing a literal to a
+    #! stack slot actually clobbers a vreg.
+    >r literals/computed r> literals/computed swapd
+    template-outputs template-outputs ;

library/compiler/vops.factor

@@ -324,7 +324,7 @@ M: %tag basic-block? drop t ;
 
 TUPLE: %getenv ;
 C: %getenv make-vop ;
-: %getenv swap src/dest-vop <%getenv> ;
+: %getenv src/dest-vop <%getenv> ;
 M: %getenv basic-block? drop t ;
 
 TUPLE: %setenv ;

library/help/crossref.factor

@@ -52,7 +52,6 @@ SYMBOL: help-graph
     [ links-out ] help-graph get remove-vertex ;
 
 : xref-articles ( -- )
-    H{ } clone help-graph set
     all-articles [ links-out ] help-graph get add-vertices ;
 
 : help-outliner ( seq quot -- | quot: obj -- )

library/io/null-stream.factor

@@ -3,7 +3,7 @@ USING: kernel ;
 
 ! Think '/dev/null'.
 M: f stream-close drop ;
-M: f set-timeout drop ;
+M: f set-timeout 2drop ;
 
 M: f stream-readln drop f ;
 M: f stream-read1 drop f ;

library/test/compiler/intrinsics.factor

@@ -27,6 +27,9 @@ math-internals sequences strings test words ;
 [ "axc" ] [ CHAR: x 1 [ "abc" [ set-char-slot ] keep dup rehash-string ] compile-1 ] unit-test
 [ "axc" ] [ CHAR: x [ 1 "abc" [ set-char-slot ] keep dup rehash-string ] compile-1 ] unit-test
 
+[ ] [ [ 0 getenv ] compile-1 drop ] unit-test
+[ ] [ 1 getenv [ 1 setenv ] compile-1 ] unit-test
+
 [ ] [ 1 [ drop ] compile-1 ] unit-test
 [ ] [ [ 1 drop ] compile-1 ] unit-test
 [ ] [ [ 1 2 2drop ] compile-1 ] unit-test

library/test/io/io.factor

@@ -60,3 +60,5 @@ unit-test
 [ f ]
 [ "" <string-reader> stream-readln ]
 unit-test
+
+[ ] [ 10000 f set-timeout ] unit-test

library/test/test.factor

@@ -1,8 +1,8 @@
 ! Factor test suite.
 
 IN: test
-USING: arrays errors inspector io kernel lists math memory
+USING: arrays errors hashtables inspector io kernel lists math
-namespaces parser prettyprint sequences strings words ;
+memory namespaces parser prettyprint sequences strings words ;
 
 TUPLE: assert got expect ;
 
@@ -54,9 +54,7 @@ SYMBOL: failures
         ] assert-depth drop
     ] test-handler ;
 
-: prepare-tests ( -- )
+: prepare-tests ( -- ) failures off "temporary" forget-vocab ;
-    failures off
-    vocabularies get [ "temporary" off ] bind ;
 
 : passed.
     "Tests passed:" print . ;

library/words.factor

@@ -116,7 +116,7 @@ SYMBOL: vocabularies
     all-words swap subset-with ; inline
 
 : xref-words ( -- )
-    H{ } clone crossref set
+    crossref get clear-hash
     all-words [ uses ] crossref get add-vertices ;
 
 : lookup ( name vocab -- word ) vocab ?hash ;
@@ -141,6 +141,9 @@ SYMBOL: vocabularies
     dup unxref-word
     dup word-name swap word-vocabulary vocab remove-hash ;
 
+: forget-vocab ( vocab -- )
+    vocabularies get remove-hash xref-words ;
+
 : target-word ( word -- word )
     dup word-name swap word-vocabulary lookup ;