FFI compile errors now reported separately; new kill literals phase design

core/alien/compiler/compiler.factor

@@ -5,7 +5,8 @@ hashtables kernel math namespaces sequences words
 inference.state inference.backend inference.dataflow system
 math.parser classes alien.arrays alien.c-types alien.structs
 alien.syntax cpu.architecture alien inspector quotations assocs
-kernel.private threads continuations.private libc combinators ;
+kernel.private threads continuations.private libc combinators
+compiler.errors continuations ;
 IN: alien.compiler
 
 ! Common protocol for alien-invoke/alien-callback/alien-indirect
@@ -207,9 +208,21 @@ M: alien-invoke-error summary
     swap alien-node-parameters parameter-sizes drop
     number>string 3append ;
 
+TUPLE: no-such-library name ;
+
+M: no-such-library summary
+    drop "Library not found" ;
+
+: no-such-library ( name -- )
+    \ no-such-library +linkage+ (inference-error) ;
+
 : (alien-invoke-dlsym) ( node -- symbol dll )
     dup alien-invoke-function
-    swap alien-invoke-library load-library ;
+    swap alien-invoke-library [
+        load-library
+    ] [
+        2drop no-such-library
+    ] recover ;
 
 TUPLE: no-such-symbol ;
 
@@ -217,7 +230,7 @@ M: no-such-symbol summary
     drop "Symbol not found" ;
 
 : no-such-symbol ( -- )
-    \ no-such-symbol inference-error ;
+    \ no-such-symbol +linkage+ (inference-error) ;
 
 : alien-invoke-dlsym ( node -- symbol dll )
     dup (alien-invoke-dlsym) 2dup dlsym [

core/compiler/errors/errors-docs.factor

@@ -1,14 +1,15 @@
 IN: compiler.errors
 USING: help.markup help.syntax vocabs.loader words io
-quotations ;
+quotations compiler.errors.private ;
 
 ARTICLE: "compiler-errors" "Compiler warnings and errors"
-"The compiler saves compile warnings and errors in a global variable:"
+"The compiler saves various notifications in a global variable:"
 { $subsection compiler-errors }
-"The warnings and errors can be viewed later:"
+"These notifications can be viewed later:"
-{ $subsection :warnings }
 { $subsection :errors }
-"Normally, all warnings and errors are displayed at the end of a batch compilation, such as a call to " { $link require } " or " { $link refresh-all } ". This can be controlled with a combinator:"
+{ $subsection :warnings }
+{ $subsection :linkage }
+"Words such as " { $link require } " and " { $link refresh-all } " use a combinator which counts errors and prints a report at the end:"
 { $link with-compiler-errors } ;
 
 HELP: compiler-errors
@@ -16,7 +17,7 @@ HELP: compiler-errors
 
 HELP: compiler-error
 { $values { "error" "an error" } { "word" word } }
-{ $description "If inside a " { $link with-compiler-errors } ", saves the error for future persual via " { $link :errors } " and " { $link :warnings } ", otherwise ignores the error." } ;
+{ $description "If inside a " { $link with-compiler-errors } ", saves the error for future persual via " { $link :errors } ", " { $link :warnings } " and " { $link :linkage } ". If not inside a " { $link with-compiler-errors } ", ignores the error." } ;
 
 HELP: compiler-error.
 { $values { "error" "an error" } { "word" word } }
@@ -25,24 +26,18 @@ HELP: compiler-error.
 HELP: compiler-errors.
 { $values { "errors" "an assoc mapping words to errors" } }
 { $description "Prints a set of compiler errors to the " { $link stdio } " stream." } ;
-
-HELP: (:errors)
-{ $values { "seq" "an alist" } }
-{ $description "Outputs all serious compiler errors from the most recent compile."  } ;
-
 HELP: :errors
 { $description "Prints all serious compiler errors from the most recent compile to the " { $link stdio } " stream." } ;
 
-HELP: (:warnings)
-{ $values { "seq" "an alist" } }
-{ $description "Outputs all ignorable compiler warnings from the most recent compile."  } ;
-
 HELP: :warnings
 { $description "Prints all ignorable compiler warnings from the most recent compile to the " { $link stdio } " stream." } ;
 
-{ :errors (:errors) :warnings (:warnings) } related-words
+HELP: :linkage
+{ $description "Prints all C library interface linkage errors from the most recent compile to the " { $link stdio } " stream." } ;
+
+{ :errors :warnings } related-words
 
 HELP: with-compiler-errors
 { $values { "quot" quotation } }
-{ $description "Calls the quotation and collects any compiler warnings and errors. Compiler warnings and errors are summarized at the end and can be viewed with " { $link :warnings } " and " { $link :errors } "." }
+{ $description "Calls the quotation and collects any compiler warnings and errors. Compiler warnings and errors are summarized at the end and can be viewed with " { $link :errors } ", " { $link :warnings } ", and " { $link :linkage } "." }
 { $notes "Nested calls to " { $link with-compiler-errors } " are ignored, and only the outermost call collects warnings and errors." } ;

core/compiler/errors/errors.factor

@@ -4,51 +4,66 @@ USING: kernel namespaces assocs prettyprint io sequences
 sorting continuations debugger math math.parser ;
 IN: compiler.errors
 
+SYMBOL: +error+
+SYMBOL: +warning+
+SYMBOL: +linkage+
+
+GENERIC: compiler-error-type ( error -- ? )
+
+M: object compiler-error-type drop +error+ ;
+
+<PRIVATE
+
 SYMBOL: compiler-errors
 
 SYMBOL: with-compiler-errors?
 
-: compiler-error ( error word -- )
-    with-compiler-errors? get [
-        compiler-errors get pick
-        [ set-at ] [ delete-at drop ] if
-    ] [ 2drop ] if ;
-
 : compiler-error. ( error word -- )
     nl
     "While compiling " write pprint ": " print
     nl
     print-error ;
 
-: compiler-errors. ( assoc -- )
+: errors-of-type ( type -- assoc )
-    >alist sort-keys [ swap compiler-error. ] assoc-each ;
-
-GENERIC: compiler-warning? ( error -- ? )
-
-M: object compiler-warning? drop f ;
-
-: (:errors) ( -- assoc )
     compiler-errors get-global
-    [ nip compiler-warning? not ] assoc-subset ;
+    swap [ >r nip compiler-error-type r> eq? ] curry
+    assoc-subset ;
 
-: :errors (:errors) compiler-errors. ;
+: compiler-errors. ( type -- )
+    errors-of-type >alist sort-keys
+    [ swap compiler-error. ] assoc-each ;
 
-: (:warnings) ( -- seq )
+: (compiler-report) ( what type word -- )
-    compiler-errors get-global
+    over errors-of-type assoc-empty? [ 3drop ] [
-    [ nip compiler-warning? ] assoc-subset ;
-
-: :warnings (:warnings) compiler-errors. ;
-
-: (compiler-report) ( what assoc -- )
-    length dup zero? [ 2drop ] [
         [
-            ":" % over % " - print " % # " compiler " % % "." %
+            ":" %
+            %
+            " - print " %
+            errors-of-type assoc-size #
+            " " %
+            %
+            "." %
         ] "" make print
     ] if ;
 
 : compiler-report ( -- )
-    "errors" (:errors) (compiler-report)
+    "semantic errors" +error+ "errors" (compiler-report)
-    "warnings" (:warnings) (compiler-report) ;
+    "semantic warnings" +warning+ "warnings" (compiler-report)
+    "linkage errors" +linkage+ "linkage" (compiler-report) ;
+
+PRIVATE>
+
+: compiler-error ( error word -- )
+    with-compiler-errors? get [
+        compiler-errors get pick
+        [ set-at ] [ delete-at drop ] if
+    ] [ 2drop ] if ;
+
+: :errors +error+ compiler-errors. ;
+
+: :warnings +warning+ compiler-errors. ;
+
+: :linkage +linkage+ compiler-errors. ;
 
 : with-compiler-errors ( quot -- )
     with-compiler-errors? get "quiet" get or [ call ] [

core/inference/backend/backend.factor

@@ -24,24 +24,24 @@ IN: inference.backend
 : recursive-quotation? ( quot -- ? )
     local-recursive-state [ first eq? ] with contains? ;
 
-TUPLE: inference-error rstate major? ;
+TUPLE: inference-error rstate type ;
 
-M: inference-error compiler-warning?
+M: inference-error compiler-error-type
-    inference-error-major? not ;
+    inference-error-type ;
 
-: (inference-error) ( ... class important? -- * )
+: (inference-error) ( ... class type -- * )
     >r construct-boa r>
     recursive-state get {
         set-delegate
-        set-inference-error-major?
+        set-inference-error-type
         set-inference-error-rstate
     } \ inference-error construct throw ; inline
 
 : inference-error ( ... class -- * )
-    t (inference-error) ; inline
+    +error+ (inference-error) ; inline
 
 : inference-warning ( ... class -- * )
-    f (inference-error) ; inline
+    +warning+ (inference-error) ; inline
 
 TUPLE: literal-expected ;
 

core/inference/class/class-tests.factor

@@ -269,7 +269,17 @@ cell-bits 32 = [
     \ number= inlined?
 ] unit-test
 
+[ t ] [
+    [ B{ 1 0 } *short 0 { number number } declare number= ]
+    \ number= inlined?
+] unit-test
+
 [ t ] [
     [ B{ 1 0 } *short 0 = ]
     \ number= inlined?
 ] unit-test
+
+[ t ] [
+    [ B{ 1 0 } *short dup number? [ 0 number= ] [ drop f ] if ]
+    \ number= inlined?
+] unit-test

core/inference/class/class.factor

@@ -73,17 +73,27 @@ SYMBOL: value-intervals
 ! Current value --> class mapping
 SYMBOL: value-classes
 
+: value-interval* ( value -- interval/f )
+    value-intervals get at ;
+
 : set-value-interval* ( interval value -- )
     value-intervals get set-at ;
 
+: intersect-value-interval ( interval value -- )
+    [ value-interval* interval-intersect ] keep
+    set-value-interval* ;
+
 M: interval-constraint apply-constraint
     dup interval-constraint-interval
-    swap interval-constraint-value set-value-interval* ;
+    swap interval-constraint-value intersect-value-interval ;
 
 : set-class-interval ( class value -- )
     >r "interval" word-prop dup
     [ r> set-value-interval* ] [ r> 2drop ] if ;
 
+: value-class* ( value -- class )
+    value-classes get at object or ;
+
 : set-value-class* ( class value -- )
     over [
         dup value-intervals get at [
@@ -93,9 +103,12 @@ M: interval-constraint apply-constraint
     ] when
     value-classes get set-at ;
 
+: intersect-value-class ( class value -- )
+    [ value-class* class-and ] keep set-value-class* ;
+
 M: class-constraint apply-constraint
     dup class-constraint-class
-    swap class-constraint-value set-value-class* ;
+    swap class-constraint-value intersect-value-class ;
 
 : set-value-literal* ( literal value -- )
     over class over set-value-class*
@@ -127,16 +140,10 @@ M: literal-constraint constraint-satisfied?
     dup literal-constraint-value value-literal*
     [ swap literal-constraint-literal eql? ] [ 2drop f ] if ;
 
-: value-class* ( value -- class )
-    value-classes get at object or ;
-
 M: class-constraint constraint-satisfied?
     dup class-constraint-value value-class*
     swap class-constraint-class class< ;
 
-: value-interval* ( value -- interval/f )
-    value-intervals get at ;
-
 M: pair apply-constraint
     first2 2dup constraints get set-at
     constraint-satisfied? [ apply-constraint ] [ drop ] if ;
@@ -159,13 +166,10 @@ M: pair constraint-satisfied?
     2drop ;
 
 : intersect-classes ( classes values -- )
-    [ [ value-class* class-and ] keep set-value-class* ] 2each ;
+    [ intersect-value-class ] 2each ;
 
 : intersect-intervals ( intervals values -- )
-    [
+    [ intersect-value-interval ] 2each ;
-        [ value-interval* interval-intersect ] keep
-        set-value-interval*
-    ] 2each ;
 
 : predicate-constraints ( class #call -- )
     [
@@ -220,7 +224,8 @@ M: #dispatch child-constraints
     ] make-constraints ;
 
 M: #declare infer-classes-before
-    dup node-param swap node-in-d [ set-value-class* ] 2each ;
+    dup node-param swap node-in-d
+    [ intersect-value-class ] 2each ;
 
 DEFER: (infer-classes)
 

core/inference/dataflow/dataflow.factor

@@ -256,6 +256,28 @@ SYMBOL: node-stack
         ] iterate-nodes drop
     ] with-node-iterator ; inline
 
+: change-children ( node quot -- )
+    over [
+        >r dup node-children dup r>
+        [ map swap set-node-children ] curry
+        [ 2drop ] if
+    ] [
+        2drop
+    ] if ; inline
+
+: (transform-nodes) ( prev node quot -- )
+    dup >r call dup [
+        dup rot set-node-successor
+        dup node-successor r> (transform-nodes)
+    ] [
+        r> drop f swap set-node-successor drop
+    ] if ; inline
+
+: transform-nodes ( node quot -- new-node )
+    over [
+        [ call dup dup node-successor ] keep (transform-nodes)
+    ] [ drop ] if ; inline
+
 : node-literal? ( node value -- ? )
     dup value? >r swap node-literals key? r> or ;
 

core/optimizer/backend/backend.factor

@@ -52,13 +52,7 @@ GENERIC: optimize-node* ( node -- node/t changed? )
 DEFER: optimize-nodes
 
 : optimize-children ( node -- )
-    [
+    [ optimize-nodes ] change-children ;
-        dup node-children dup [
-            [ optimize-nodes ] map swap set-node-children
-        ] [
-            2drop
-        ] if
-    ] when* ;
 
 : optimize-node ( node -- node )
     dup [
@@ -76,39 +70,17 @@ DEFER: optimize-nodes
 
 M: f set-node-successor 2drop ;
 
-: (optimize-nodes) ( prev node -- )
-    optimize-node [
-        dup rot set-node-successor
-        dup node-successor (optimize-nodes)
-    ] [
-        f swap set-node-successor
-    ] if* ;
-
 : optimize-nodes ( node -- newnode )
     [
         class-substitutions [ clone ] change
         literal-substitutions [ clone ] change
-        dup [
+        [ optimize-node ] transform-nodes
-            optimize-node
+        optimizer-changed get
-            dup dup node-successor (optimize-nodes)
-        ] when optimizer-changed get
     ] with-scope optimizer-changed set ;
 
-: prune-if ( node quot -- successor/t )
-    over >r call [ r> node-successor t ] [ r> drop t f ] if ;
-    inline
-
 ! Generic nodes
 M: node optimize-node* drop t f ;
 
-M: #shuffle optimize-node* 
-    [
-        dup node-in-d empty? swap node-out-d empty? and
-    ] prune-if ;
-
-M: #push optimize-node* 
-    [ node-out-d empty? ] prune-if ;
-
 : cleanup-inlining ( node -- newnode changed? )
     node-successor [ node-successor t ] [ t f ] if* ;
 
@@ -118,12 +90,6 @@ M: #return optimize-node* cleanup-inlining ;
 ! #values
 M: #values optimize-node* cleanup-inlining ;
 
-! #>r
-M: #>r optimize-node* [ node-in-d empty? ] prune-if ;
-
-! #r>
-M: #r> optimize-node* [ node-in-r empty? ] prune-if ;
-
 ! Some utilities for splicing in dataflow IR subtrees
 : follow ( key assoc -- value )
     2dup at* [ swap follow nip ] [ 2drop ] if ;
@@ -194,10 +160,8 @@ M: node remember-method*
 
 ! Constant branch folding
 : fold-branch ( node branch# -- node )
-    over drop-inputs >r
     over node-children nth
-    swap node-successor over substitute-node
+    swap node-successor over substitute-node ;
-    r> [ set-node-successor ] keep ;
 
 ! #if
 : known-boolean-value? ( node value -- value ? )
@@ -213,12 +177,18 @@ M: node remember-method*
     ] if ;
 
 M: #if optimize-node*
-    dup dup node-in-d first known-boolean-value?
+    dup dup node-in-d first known-boolean-value? [
-    [ 0 1 ? fold-branch t ] [ 2drop t f ] if ;
+        over drop-inputs >r
+        0 1 ? fold-branch
+        r> [ set-node-successor ] keep
+        t
+    ] [ 2drop t f ] if ;
 
 M: #dispatch optimize-node*
     dup dup node-in-d first 2dup node-literal? [
-        node-literal fold-branch t
+        "Optimizing #dispatch" print
+        node-literal
+        over drop-inputs >r fold-branch r> [ set-node-successor ] keep t
     ] [
         3drop t f
     ] if ;
@@ -322,9 +292,19 @@ DEFER: (flat-length)
     #! Make #shuffle -> #push -> #return -> successor
     dupd literal-quot splice-quot ;
 
-: optimize-predicate ( #call -- node )
+: evaluate-predicate ( #call -- ? )
     dup node-param "predicating" word-prop >r
-    dup node-class-first r> class< 1array inline-literals ;
+    node-class-first r> class< ;
+
+: optimize-predicate ( #call -- node )
+    dup evaluate-predicate swap
+    dup node-successor #if? [
+        dup drop-inputs >r
+        node-successor swap 0 1 ? fold-branch
+        r> [ set-node-successor ] keep
+    ] [
+        swap 1array inline-literals
+    ] if ;
 
 : optimizer-hooks ( node -- conditions )
     node-param "optimizer-hooks" word-prop ;

core/optimizer/def-use/def-use.factor

@@ -70,19 +70,66 @@ M: #branch node-def-use
     #! #values node.
     dup branch-def-use (node-def-use) ;
 
-: dead-literals ( -- values )
+! : dead-literals ( -- values )
+!     def-use get [ >r value? r> empty? and ] assoc-subset ;
+! 
+! : kill-node* ( node values -- )
+!     [ swap remove-all ] curry modify-values ;
+! 
+! : kill-node ( node values -- )
+!     dup assoc-empty?
+!     [ 2drop ] [ [ kill-node* ] curry each-node ] if ;
+! 
+! : kill-values ( node -- )
+!     #! Remove literals which are not actually used anywhere.
+!     dead-literals kill-node ;
+
+: compute-dead-literals ( -- values )
     def-use get [ >r value? r> empty? and ] assoc-subset ;
 
-: kill-node* ( node values -- )
+DEFER: kill-nodes
-    [ swap remove-all ] curry modify-values ;
+SYMBOL: dead-literals
 
-: kill-node ( node values -- )
+GENERIC: kill-node* ( node -- node/t )
-    dup assoc-empty?
-    [ 2drop ] [ [ kill-node* ] curry each-node ] if ;
 
-: kill-values ( node -- )
+M: node kill-node* drop t ;
+
+: prune-if ( node quot -- successor/t )
+    over >r call [ r> node-successor ] [ r> drop t ] if ;
+    inline
+
+M: #shuffle kill-node* 
+    [
+        dup node-in-d empty? swap node-out-d empty? and
+    ] prune-if ;
+
+M: #push kill-node* 
+    [ node-out-d empty? ] prune-if ;
+
+M: #>r kill-node* [ node-in-d empty? ] prune-if ;
+
+M: #r> kill-node* [ node-in-r empty? ] prune-if ;
+
+: kill-node ( node -- node )
+    dup [
+        dup [ dead-literals get swap remove-all ] modify-values
+        dup kill-node* dup t eq? [
+            drop dup [ kill-nodes ] change-children
+        ] [
+            nip kill-node
+        ] if
+    ] when ;
+
+: kill-nodes ( node -- newnode )
+    [ kill-node ] transform-nodes ;
+
+: kill-values ( node -- new-node )
     #! Remove literals which are not actually used anywhere.
-    dead-literals kill-node ;
+    compute-dead-literals dup assoc-empty? [ drop ] [
+        dead-literals [ kill-nodes ] with-variable
+    ] if ;
+
+!
 
 : sole-consumer ( #call -- node/f )
     node-out-d first used-by

core/optimizer/known-words/known-words.factor

@@ -98,7 +98,7 @@ float-arrays combinators.private combinators ;
     [
         num-types get swap [
             [
-                [ type>class 0 `input class, ] keep
+                [ type>class object or 0 `input class, ] keep
                 0 `output literal,
             ] set-constraints
         ] curry each

core/optimizer/optimizer.factor

@@ -4,13 +4,16 @@ USING: kernel namespaces optimizer.backend optimizer.def-use
 optimizer.known-words optimizer.math inference.class ;
 IN: optimizer
 
+SYMBOL: optimize-count
+
 : optimize-1 ( node -- newnode ? )
     [
+        global [ optimize-count inc ] bind
         H{ } clone class-substitutions set
         H{ } clone literal-substitutions set
         H{ } clone value-substitutions set
         dup compute-def-use
-        dup kill-values
+        kill-values
         dup infer-classes
         optimizer-changed off
         optimize-nodes