f throw no longer a no-op

library/alien/compiler.factor

@@ -162,6 +162,6 @@ M: compound (uncrossref)
     over "infer" word-prop or [
         drop
     ] [
-        dup { "infer-effect" "base-case" "no-effect" }
+        dup { "infer-effect" "base-case" "no-effect" "terminates" }
         reset-props update-xt
     ] ifte ;

library/bootstrap/boot-stage2.factor

@@ -2,8 +2,8 @@
 ! See http://factor.sf.net/license.txt for BSD license.
 USING: alien assembler command-line compiler compiler-backend
 errors generic hashtables io io-internals kernel
-kernel-internals lists math memory namespaces parser sequences
-sequences-internals words ;
+kernel-internals lists math memory namespaces optimizer parser
+sequences sequences-internals words ;
 
 : pull-in ( ? list -- )
     swap [
@@ -78,7 +78,8 @@ compile? [
     {
         uncons 1+ 1- + <= > >= mod length
         nth-unsafe set-nth-unsafe
-        = string>number number>string scan (generate)
+        = string>number number>string scan solve-recursion
+        kill-set kill-node (generate)
     } [ compile ] each
 ] when
 

library/bootstrap/image.factor

@@ -167,8 +167,7 @@ M: f ' ( obj -- ptr )
     0 emit ;
 
 : word-error ( word msg -- )
-    [ % dup word-vocabulary % " " % word-name % ] "" make
-    throw ; inline
+    [ % dup word-vocabulary % " " % word-name % ] "" make throw ;
 
 : transfer-word ( word -- word )
     #! This is a hack. See doc/bootstrap.txt.

library/collections/sequences-epilogue.factor

@@ -156,7 +156,7 @@ IN: kernel
     #! Push the number of elements on the datastack.
     datastack length ;
 
-: no-cond "cond fall-through" throw ; inline
+: no-cond "cond fall-through" throw ;
 
 : cond ( conditions -- )
     #! Conditions is a sequence of quotation pairs.

library/collections/sequences.factor

@@ -45,7 +45,7 @@ GENERIC: resize ( n seq -- seq )
 
 TUPLE: bounds-error index seq ;
 
-: bounds-error <bounds-error> throw ; inline
+: bounds-error <bounds-error> throw ;
 
 : growable-check ( n seq -- fx seq )
     >r >fixnum dup 0 fixnum<

library/errors.factor

@@ -11,7 +11,7 @@ USING: kernel-internals lists ;
 
 TUPLE: no-method object generic ;
 
-: no-method ( object generic -- ) <no-method> throw ; inline
+: no-method ( object generic -- ) <no-method> throw ;
 
 : catchstack ( -- cs ) 6 getenv ;
 : set-catchstack ( cs -- ) 6 setenv ;

library/generic/math-combination.factor

@@ -31,7 +31,7 @@ math namespaces sequences words ;
 TUPLE: no-math-method left right generic ;
 
 : no-math-method ( left right generic -- )
-    3dup <no-math-method> throw ; inline
+    3dup <no-math-method> throw ;
 
 : applicable-method ( generic class -- quot )
     over "methods" word-prop hash [ ] [

library/inference/branches.factor

@@ -83,8 +83,7 @@ namespaces parser prettyprint sequences strings vectors words ;
     ] make-hash ;
 
 : (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

library/inference/dataflow.factor

@@ -55,8 +55,8 @@ M: node = eq? ;
 
 : empty-node f { } { } { } { } ;
 : param-node ( label) { } { } { } { } ;
-: in-d-node ( inputs) >r f r> { } { } { } ;
-: out-d-node ( outputs) >r f { } r> { } { } ;
+: in-node ( inputs) >r f r> { } { } { } ;
+: out-node ( outputs) >r f { } r> { } { } ;
 
 : d-tail ( n -- list ) meta-d get tail* ;
 : r-tail ( n -- list ) meta-r get tail* ;
@@ -69,7 +69,7 @@ C: #label make-node ;
 
 TUPLE: #entry ;
 C: #entry make-node ;
-: #entry ( -- node ) meta-d get clone in-d-node <#entry> ;
+: #entry ( -- node ) meta-d get clone in-node <#entry> ;
 
 TUPLE: #call ;
 C: #call make-node ;
@@ -82,31 +82,35 @@ C: #call-label make-node ;
 TUPLE: #shuffle ;
 C: #shuffle make-node ;
 : #shuffle ( -- node ) empty-node <#shuffle> ;
-: #push ( outputs -- node ) d-tail out-d-node <#shuffle> ;
+: #push ( outputs -- node ) d-tail out-node <#shuffle> ;
 
 TUPLE: #values ;
 C: #values make-node ;
-: #values ( -- node ) meta-d get clone in-d-node <#values> ;
+: #values ( -- node ) meta-d get clone in-node <#values> ;
 
 TUPLE: #return ;
 C: #return make-node ;
 : #return ( label -- node )
     #! The parameter is the label we are returning from, or if
     #! f, this is a top-level return.
-    meta-d get clone in-d-node <#return>
+    meta-d get clone in-node <#return>
     [ set-node-param ] keep ;
 
 TUPLE: #ifte ;
 C: #ifte make-node ;
-: #ifte ( in -- node ) 1 d-tail in-d-node <#ifte> ;
+: #ifte ( in -- node ) 1 d-tail in-node <#ifte> ;
 
 TUPLE: #dispatch ;
 C: #dispatch make-node ;
-: #dispatch ( in -- node ) 1 d-tail in-d-node <#dispatch> ;
+: #dispatch ( in -- node ) 1 d-tail in-node <#dispatch> ;
 
 TUPLE: #merge ;
 C: #merge make-node ;
-: #merge ( -- node ) meta-d get clone out-d-node <#merge> ;
+: #merge ( -- node ) meta-d get clone out-node <#merge> ;
+
+TUPLE: #terminate ;
+C: #terminate make-node ;
+: #terminate ( -- node ) empty-node <#terminate> ;
 
 : node-inputs ( d-count r-count node -- )
     tuck
@@ -169,10 +173,10 @@ SYMBOL: current-node
     ] ifte ;
 
 : drop-inputs ( node -- #shuffle )
-    node-in-d clone in-d-node <#shuffle> ;
+    node-in-d clone in-node <#shuffle> ;
 
 : #drop ( n -- #shuffle )
-    d-tail in-d-node <#shuffle> ;
+    d-tail in-node <#shuffle> ;
 
 : each-node ( node quot -- | quot: node -- )
     over [

library/inference/inference.factor

@@ -15,7 +15,7 @@ TUPLE: inference-error message rstate data-stack call-stack ;
 
 : inference-error ( msg -- )
     recursive-state get meta-d get meta-r get
-    <inference-error> throw ; inline
+    <inference-error> throw ;
 
 M: inference-error error. ( error -- )
     "! Inference error:" print
@@ -78,11 +78,11 @@ M: wrapper apply-object wrapped apply-literal ;
 
 : active? ( -- ? )
     #! Is this branch not terminated?
-    d-in get meta-d get and ;
+    meta-d get meta-r get and ;
 
 : terminate ( -- )
     #! Ignore this branch's stack effect.
-    meta-d off meta-r off d-in off ;
+    meta-d off meta-r off #terminate node, ;
 
 : infer-quot ( quot -- )
     #! Recursive calls to this word are made for nested

library/inference/words.factor

@@ -41,15 +41,16 @@ hashtables parser prettyprint ;
         ] with-nesting
     ] with-recursive-state ;
 
-: infer-compound ( word base-case -- effect )
+: infer-compound ( word base-case -- terminates? effect )
     #! Infer a word's stack effect in a separate inferencer
-    #! instance.
+    #! instance. Outputs a boolean if the word terminates
+    #! control flow by throwing an exception or restoring a
+    #! continuation.
     [
         inferring-base-case set
         recursive-state get init-inference
-        dup inline-block drop
-        effect
-    ] with-scope [ consume/produce ] keep ;
+        [ inline-block drop active? not effect ] keep
+    ] with-scope over consume/produce over [ terminate ] when ;
 
 GENERIC: apply-word
 
@@ -60,7 +61,9 @@ M: object apply-word ( word -- )
 M: compound apply-word ( word -- )
     #! Infer a compound word's stack effect.
     [
-        dup f infer-compound "infer-effect" set-word-prop
+        dup dup f infer-compound
+        >r "terminates" set-word-prop r>
+        "infer-effect" set-word-prop
     ] [
         [ swap t "no-effect" set-word-prop rethrow ] when*
     ] catch ;
@@ -73,7 +76,8 @@ M: compound apply-word ( word -- )
             over "infer" word-prop [
                 swap first length ensure-values call drop
             ] [
-                consume/produce
+                dupd consume/produce
+                "terminates" word-prop [ terminate ] when
             ] ifte*
         ] [
             apply-word
@@ -93,7 +97,7 @@ M: symbol apply-object ( word -- )
         [ #call-label ] [ #call ] ?ifte
         r> over set-node-in-d node,
     ] [
-        drop dup t infer-compound "base-case" set-word-prop
+        drop dup t infer-compound nip "base-case" set-word-prop
     ] ifte ;
 
 : base-case ( word label -- )

library/math/complex.factor

@@ -21,7 +21,7 @@ M: number = ( n n -- ? ) number= ;
     over real? over real? and [
         (rect>)
     ] [
-        "Complex number must have real components" throw drop
+        "Complex number must have real components" throw
     ] ifte ; inline
 
 : >rect ( x -- xr xi ) dup real swap imaginary ; inline

library/math/integer.factor

@@ -31,8 +31,7 @@ IN: math-internals
 : fraction> ( a b -- a/b )
     dup 1 number= [ drop ] [ (fraction>) ] ifte ; inline
 
-: division-by-zero ( x y -- )
-    "Division by zero" throw drop ; inline
+: division-by-zero ( x y -- ) "Division by zero" throw ;
 
 M: integer / ( x y -- x/y )
     dup 0 number= [

library/math/parse-numbers.factor

@@ -6,7 +6,7 @@ strings ;
 
 ! Number parsing
 
-: not-a-number "Not a number" throw ; inline
+: not-a-number "Not a number" throw ;
 
 GENERIC: digit> ( ch -- n )
 M: digit  digit> CHAR: 0 - ;

library/test/errors.factor

@@ -1,5 +1,4 @@
 IN: temporary
-USING: memory ;
 USE: errors
 USE: kernel
 USE: namespaces
@@ -7,6 +6,7 @@ USE: test
 USE: lists
 USE: parser
 USE: io
+USE: memory
 
 [ f ] [ [ ] [ ] catch ] unit-test
 

library/test/inference.factor

@@ -1,6 +1,6 @@
 IN: temporary
-USING: arrays generic inference kernel lists math math-internals
-namespaces parser sequences test vectors ;
+USING: arrays errors generic inference kernel lists math
+math-internals namespaces parser sequences test vectors ;
 
 [
     << shuffle f { "a" } { } { "a" } { "a" } >>
@@ -57,6 +57,14 @@ namespaces parser sequences test vectors ;
     [ [ 2 2 fixnum+ ] ] [ [ 2 2 fixnum* ] ] ifte call
 ] unit-test-fails
 
+! Test inference of termination of control flow
+: termination-test-1
+    "foo" throw ;
+
+: termination-test-2 [ termination-test-1 ] [ 3 ] ifte ;
+
+[ @{ 1 1 }@ ] [ [ termination-test-2 ] infer ] unit-test
+
 : infinite-loop infinite-loop ;
 
 : simple-recursion-1

library/unix/io.factor

@@ -74,7 +74,7 @@ M: port set-timeout ( timeout port -- )
 : >port< dup port-handle swap delegate ;
 
 : pending-error ( port -- )
-    dup port-error f rot set-port-error throw ;
+    dup port-error f rot set-port-error [ throw ] when* ;
 
 : report-error ( error port -- )
     [ "Error on fd " % dup port-handle # ": " % swap % ] "" make

native/error.c

@@ -50,9 +50,7 @@ void throw_error(CELL error, bool keep_stacks)
 
 void primitive_throw(void)
 {
-	CELL error = dpop();
-	if(error != F)
-		throw_error(error,true);
+	throw_error(dpop(),true);
 }
 
 void primitive_die(void)