kernel errors a bit better, inference cleanup

library/assoc.factor

@@ -76,3 +76,11 @@ USE: kernel
             2drop
         ] ifte r>
     ] each drop ;
+
+: 2cons ( car1 car2 cdr1 cdr2 -- cons1 cons2 )
+    rot swons >r cons r> ;
+
+: unzip ( assoc -- keys values )
+    #! Split an association list into two lists of keys and
+    #! values.
+    [ uncons >r uncons r> unzip 2cons ] [ [ ] [ ] ] ifte* ;

library/compiler/generator-x86.factor

@@ -41,10 +41,14 @@ USE: math
     #! immediate just compiled.
     "ds" f f rel-dlsym ;
 
+: PEEK-DS ( -- )
+    #! Peek datastack to EAX.
+    DS ECX [I]>R  absolute-ds
+    ECX EAX [R]>R ;
+
 : POP-DS ( -- )
     #! Pop datastack to EAX.
-    DS ECX [I]>R  absolute-ds
-    ECX EAX [R]>R
+    PEEK-DS
     4 ECX R-I
     ECX DS R>[I]  absolute-ds ;
 
@@ -76,6 +80,11 @@ USE: math
     ECX DS R>[I]  absolute-ds
 ] "generator" set-word-property
 
+#slot [
+    PEEK-DS
+    
+] "generator" set-word-property
+
 #call [
     dup dup postpone-word
     CALL compiled-offset defer-xt

library/inference/branches.factor

@@ -39,75 +39,70 @@ USE: words
 USE: hashtables
 USE: prettyprint
 
-: longest-vector ( list -- length )
-    [ vector-length ] map [ > ] top ;
+: vector-length< ( vec1 vec2 -- ? )
+    swap vector-length swap vector-length < ;
 
-: computed-value-vector ( n -- vector )
-    [ drop object <computed> ] vector-project ;
+: unify-length ( vec1 vec2 -- vec1 )
+    2dup vector-length< [ swap ] unless [
+        vector-length over vector-length -
+        empty-vector [ swap vector-append ] keep
+    ] keep ;
 
-: add-inputs ( count stack -- count stack )
-    #! Add this many inputs to the given stack.
-    [ vector-length - dup ] keep
-    >r computed-value-vector dup r> vector-append ;
-
-: unify-lengths ( list -- list )
-    #! Pad all vectors to the same length. If one vector is
-    #! shorter, pad it with unknown results at the bottom.
-    dup longest-vector swap [ dupd add-inputs nip ] map nip ;
-
-: unify-classes ( value value -- value )
-    value-class swap value-class class-or <computed> ;
+: unify-classes ( value value -- class )
+    #! If one of the values is f, it was added as a result of
+    #! length unification so we just replace it with a computed
+    #! object value.
+    2dup and [
+        value-class swap value-class class-or
+    ] [
+        2drop object
+    ] ifte ;
 
 : unify-results ( value value -- value )
     #! Replace values with unknown result if they differ,
     #! otherwise retain them.
-    2dup = [ drop ] [ unify-classes ] ifte ;
+    2dup = [ drop ] [ unify-classes <computed> ] ifte ;
 
 : unify-stacks ( list -- stack )
     #! Replace differing literals in stacks with unknown
     #! results.
-    uncons [ [ unify-results ] vector-2map ] each ;
-
-: unify-d-in ( list -- d-in )
-    [ [ d-in get ] bind ] map unify-lengths unify-stacks ;
-
-: filter-terminators ( list -- list )
-    [ [ d-in get meta-d get and ] bind ] subset ;
+    uncons [
+        unify-length vector-zip [
+            uncons unify-results
+        ] vector-map
+    ] each ;
 
 : balanced? ( list -- ? )
-    [
-        [
-            d-in get vector-length
-            meta-d get vector-length -
-        ] bind
-    ] map all=? ;
+    #! Check if a list of [ instack | outstack ] pairs is
+    #! balanced.
+    [ uncons vector-length swap vector-length - ] map all=? ;
 
-: unify-datastacks ( list -- datastack )
-    [ [ meta-d get ] bind ] map
-    unify-lengths unify-stacks ;
-
-: check-lengths ( list -- )
-    dup [ vector-length ] map all=? [
-        drop
-    ] [
-        "Unbalanced return stack effect:" <multi-error> throw
-    ] ifte ;
-
-: unify-callstacks ( list -- datastack )
-    [ [ meta-r get ] bind ] map
-    dup check-lengths unify-stacks ;
-
-: unify-effects ( list -- )
-    filter-terminators
-    [ "No branch has a stack effect" throw ] unless*
+: unify-effect ( list -- in out )
+    #! Unify a list of [ instack | outstack ] pairs.
     dup balanced? [
-        dup unify-d-in d-in set
-        dup unify-datastacks meta-d set
-        unify-callstacks meta-r set
+        unzip unify-stacks >r unify-stacks r>
     ] [
         "Unbalanced branches" throw
     ] ifte ;
 
+: datastack-effect ( list -- )
+    [ [ d-in get meta-d get ] bind cons ] map
+    unify-effect
+    meta-d set d-in set ;
+
+: callstack-effect ( list -- )
+    [ [ { } meta-r get ] bind cons ] map
+    unify-effect
+    meta-r set drop ;
+
+: filter-terminators ( list -- list )
+    [ [ d-in get meta-d get and ] bind ] subset [
+        "No branch has a stack effect" throw
+    ] unless* ;
+
+: unify-effects ( list -- )
+    filter-terminators  dup datastack-effect callstack-effect ;
+
 : deep-clone ( vector -- vector )
     #! Clone a vector of vectors.
     [ vector-clone ] vector-map ;

library/inference/dataflow.factor

@@ -68,6 +68,9 @@ SYMBOL: #pick
 SYMBOL: #>r
 SYMBOL: #r>
 
+SYMBOL: #slot
+SYMBOL: #set-slot
+
 SYMBOL: node-consume-d
 SYMBOL: node-produce-d
 SYMBOL: node-consume-r

library/inference/inference.factor

@@ -37,6 +37,7 @@ USE: vectors
 USE: words
 USE: hashtables
 USE: generic
+USE: prettyprint
 
 ! Word properties that affect inference:
 ! - infer-effect -- must be set. controls number of inputs
@@ -166,7 +167,11 @@ DEFER: apply-word
 : infer-quot ( quot -- )
     #! Recursive calls to this word are made for nested
     #! quotations.
-    [ apply-object ] each ;
+    [
+        [ apply-object ] each
+    ] [
+        [ swap <chained-error> rethrow ] when*
+    ] catch ;
 
 : raise ( [ in | out ] -- [ in | out ] )
     uncons 2dup min tuck - >r - r> cons ;
@@ -201,7 +206,8 @@ DEFER: apply-word
 : check-return ( -- )
     #! Raise an error if word leaves values on return stack.
     meta-r get vector-length 0 = [
-        "Word leaves elements on return stack" throw
+        "Word leaves elements on return stack"
+        <chained-error> throw
     ] unless ;
 
 : values-node ( op -- )

library/inference/types.factor

@@ -0,0 +1,79 @@
+! :folding=indent:collapseFolds=1:
+
+! $Id$
+!
+! Copyright (C) 2004 Slava Pestov.
+! 
+! Redistribution and use in source and binary forms, with or without
+! modification, are permitted provided that the following conditions are met:
+! 
+! 1. Redistributions of source code must retain the above copyright notice,
+!    this list of conditions and the following disclaimer.
+! 
+! 2. Redistributions in binary form must reproduce the above copyright notice,
+!    this list of conditions and the following disclaimer in the documentation
+!    and/or other materials provided with the distribution.
+! 
+! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
+! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
+! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
+! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
+! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
+! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
+! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+IN: inference
+USE: errors
+USE: generic
+USE: interpreter
+USE: kernel
+USE: kernel-internals
+USE: lists
+USE: math
+USE: namespaces
+USE: strings
+USE: vectors
+USE: words
+USE: stdio
+
+! Enhanced inference of primitives relating to data types.
+! Optimizes type checks and slot access.
+
+: infer-check ( assert class -- )
+    peek-d dup value-class pick = [
+        [
+            "Optimized out " , rot word-name , " check." ,
+        ] make-string print 2drop
+    ] [
+        value-class-and
+        dup "infer-effect" word-property consume/produce
+    ] ifte ;
+
+\ >cons [
+    \ >cons \ cons infer-check
+] "infer" set-word-property
+
+\ >vector [
+    \ >vector \ vector infer-check
+] "infer" set-word-property
+
+\ >string [
+    \ >string \ string infer-check
+] "infer" set-word-property
+
+\ slot [
+    dataflow-drop, pop-d literal-value
+    peek-d value-class builtin-supertypes dup length 1 = [
+        cons #slot dataflow, [
+            1 0 node-inputs
+            [ object ] consume-d
+            [ object ] produce-d
+            1 0 node-outputs
+        ] bind
+    ] [
+        "slot called without static type knowledge" throw
+    ] ifte
+] "infer" set-word-property

library/inference/words.factor

@@ -102,7 +102,11 @@ USE: parser
 : inline-compound ( word -- effect )
     #! Infer the stack effect of a compound word in the current
     #! inferencer instance.
-    gensym [ word-parameter infer-quot effect ] with-block ;
+    [
+        gensym [ word-parameter infer-quot effect ] with-block
+    ] [
+        [ swap <chained-error> rethrow ] when*
+    ] catch ;
 
 : (infer-compound) ( word -- effect )
     #! Infer a word's stack effect in a separate inferencer

library/primitives.factor

@@ -210,9 +210,13 @@ USE: words
     [ memory>string          " address length -- str "            [ [ integer integer ] [ string ] ] ]
     [ local-alien?           " alien -- ? "                       [ [ alien ] [ object ] ] ]
     [ alien-address          " alien -- address "                 [ [ alien ] [ integer ] ] ]
-    [ >cons                  " cons -- cons "                     [ [ cons ] [ cons ] ] ]
-    [ >vector                " vector -- vector "                 [ [ vector ] [ vector ] ] ]
-    [ >string                " string -- string "                 [ [ string ] [ string ] ] ]
+    ! Note: a correct type spec for these would have [ X ] as
+    ! input, not [ object ]. However, we rely on the inferencer
+    ! to handle these specially, since they are also optimized
+    ! out in some cases, etc.
+    [ >cons                  " cons -- cons "                     [ [ object ] [ cons ] ] ]
+    [ >vector                " vector -- vector "                 [ [ object ] [ vector ] ] ]
+    [ >string                " string -- string "                 [ [ object ] [ string ] ] ]
     [ >word                  " word -- word "                     [ [ word ] [ word ] ] ]
     [ slot                   " obj n -- obj "                     [ [ object fixnum ] [ object ] ] ]
     [ set-slot               " obj obj n -- "                     [ [ object object fixnum ] [ ] ] ]

library/test/inference.factor

@@ -22,10 +22,8 @@ USE: generic
     [ 3 | 4 ]
 ] "effects" set
 
-[ 3 ] [ [ { 1 2 } { 1 2 3 } ] longest-vector ] unit-test
-
-[ t ] [
-    [ { 1 2 } { 1 2 3 } ] unify-lengths [ vector-length ] map all=?
+[ { f 1 2 } { 1 2 3 } ] [
+    { 1 2 } { 1 2 3 } unify-lengths
 ] unit-test
 
 [ [ sq ] ] [
@@ -214,6 +212,6 @@ SYMBOL: sym-test
 [ [ [ object object ] [ cons ] ] ] [ [ cons ] infer ] unit-test
 [ [ [ cons ] [ cons ] ] ] [ [ uncons cons ] infer ] unit-test
 [ [ [ object ] [ object ] ] ] [ [ dup [ car ] when ] infer ] unit-test
-[ [ [ vector ] [ vector ] ] ] [ [ vector-clone ] infer ] unit-test
+! [ [ [ vector ] [ vector ] ] ] [ [ vector-clone ] infer ] unit-test
 ! [ [ [ number ] [ number ] ] ] [ [ dup + ] infer ] unit-test
 ! [ [ [ number number number ] [ number ] ] ] [ [ digit+ ] infer ] unit-test

library/test/lists/assoc.factor

@@ -45,3 +45,6 @@ USE: test
 [ [ [ "one" + ] [ "four" * ] ] ] [
     "three" "quot-alist" get remove-assoc
 ] unit-test
+
+[ [ "one" "three" "four" ] [ [ + ] [ - ] [ * ] ] ]
+[ "quot-alist" get unzip ] unit-test

library/test/vectors.factor

@@ -5,6 +5,7 @@ USE: random
 USE: test
 USE: vectors
 USE: strings
+USE: namespaces
 
 [ [ t f t ] vector-length ] unit-test-fails
 [ 3 ] [ { t f t } vector-length ] unit-test
@@ -56,7 +57,7 @@ USE: strings
 unit-test
 
 [ { 6 8 10 12 } ]
-[ { 1 2 3 4 } { 5 6 7 8 } [ + ] vector-2map ]
+[ { 1 2 3 4 } { 5 6 7 8 } vector-zip [ uncons + ] vector-map ]
 unit-test
 
 [ { [ 1 | 5 ] [ 2 | 6 ] [ 3 | 7 ] [ 4 | 8 ] } ]
@@ -69,3 +70,15 @@ unit-test
 [ 2 [ ] vector-tail ] unit-test-fails
 
 [ [ 3 ] ] [ 1 { 1 2 3 } vector-tail* ] unit-test
+
+0 <vector> "funny-stack" set
+
+[ ] [ { 1 5 } "funny-stack" get vector-push ] unit-test
+[ ] [ { 2 3 } "funny-stack" get vector-push ] unit-test
+[ { 2 3 } ] [ "funny-stack" get vector-pop ] unit-test
+[ { 1 5 } ] [ "funny-stack" get vector-peek ] unit-test
+[ { 1 5 } ] [ "funny-stack" get vector-pop ] unit-test
+[ "funny-stack" get vector-pop ] unit-test-fails
+[ "funny-stack" get vector-pop ] unit-test-fails
+[ ] [ "funky" "funny-stack" get vector-push ] unit-test
+[ "funky" ] [ "funny-stack" get vector-pop ] unit-test

library/tools/debugger.factor

@@ -108,10 +108,10 @@ USE: generic
 GENERIC: error. ( error -- )
 
 PREDICATE: cons kernel-error ( obj -- ? )
-    uncons cons? swap fixnum? and ;
+    car kernel-error = ;
 
 M: kernel-error error. ( error -- )
-    uncons car swap {
+    cdr uncons car swap {
         expired-error
         io-task-twice-error
         no-io-tasks-error
@@ -207,7 +207,8 @@ M: object error. ( error -- )
 : init-error-handler ( -- )
     [ 1 exit* ] >c ( last resort )
     [ print-error 1 exit* ] >c
-    [ dup save-error rethrow ] 5 setenv ( kernel calls on error ) ;
+    [ dup save-error rethrow ] 5 setenv ( kernel calls on error )
+    kernel-error 12 setenv ;
 
 ! So that stage 2 boot gives a useful error message if something
 ! fails after this file is loaded.

library/tools/interpreter.factor

@@ -47,6 +47,7 @@ SYMBOL: meta-r
 SYMBOL: meta-d
 : push-d meta-d get vector-push ;
 : pop-d meta-d get vector-pop ;
+: peek-d meta-d get vector-peek ;
 SYMBOL: meta-n
 SYMBOL: meta-c
 

library/vectors.factor

@@ -58,7 +58,7 @@ BUILTIN: vector 11
         "Vector length must be positive" throw 2drop
     ] [
         2dup (set-vector-length) grow-vector-array
-    ] ifte ;
+    ] ifte ; inline
 
 : empty-vector ( len -- vec )
     #! Creates a vector with 'len' elements set to f. Unlike
@@ -73,6 +73,10 @@ BUILTIN: vector 11
     #! Push a value on the end of a vector.
     dup vector-length swap set-vector-nth ;
 
+: vector-peek ( vector -- obj )
+    #! Get value at end of vector.
+    dup vector-length pred swap vector-nth ;
+
 : vector-pop ( vector -- obj )
     #! Get value at end of vector and remove it.
     dup vector-length pred ( vector top )
@@ -122,15 +126,6 @@ BUILTIN: vector 11
         pick pick >r over >r vector-nth r> r> vector-nth cons
     ] vector-project nip nip ;
 
-: vector-2map ( v1 v2 quot -- v )
-    #! Apply a quotation with stack effect ( obj obj -- obj ) to
-    #! each pair of elements from v1 and v2, collecting them
-    #! into a new list. Behavior is undefined if vector lengths
-    #! differ.
-    -rot vector-zip [
-        swap dup >r >r uncons r> call r> swap
-    ] vector-map nip ; inline
-
 : vector-clone ( vector -- vector )
     #! Shallow copy of a vector.
     [ ] vector-map ;

native/error.c

@@ -57,7 +57,7 @@ void primitive_throw(void)
 void general_error(CELL error, CELL tagged)
 {
 	early_error(error);
-	throw_error(cons(error,cons(tagged,F)),true);
+	throw_error(cons(userenv[ERROR_ENV],cons(error,cons(tagged,F))),true);
 }
 
 /* It is not safe to access 'ds' from a signal handler, so we just not
@@ -65,7 +65,9 @@ touch it */
 void signal_error(int signal)
 {
 	early_error(ERROR_SIGNAL);
-	throw_error(cons(ERROR_SIGNAL,cons(tag_fixnum(signal),F)),false);
+	throw_error(cons(userenv[ERROR_ENV],
+		cons(ERROR_SIGNAL,
+			cons(tag_fixnum(signal),F))),false);
 }
 
 void type_error(CELL type, CELL tagged)

native/run.h

@@ -12,6 +12,7 @@
 #define RUNQUEUE_ENV   9 /* used by library only */
 #define ARGS_ENV       10
 #define OS_ENV         11
+#define ERROR_ENV      12 /* a marker consed onto kernel errors */
 
 /* Profiling timer */
 #ifndef WIN32