making a mess of type inference; fixing overflowing /mod

TODO.FACTOR.txt

@@ -1,10 +1,16 @@
 + compiler:
 
-- type inference fails with some assembler words
+- investigate why : foo t or ; doesn't partially evaluate
-- more accurate type inference in some cases
+- investigate why ' doesn't infer
+- recursive? and tree-contains? should handle vectors
+- type inference and recursion flaw
+- type inference fails with some assembler words;
+  displaced, register and other predicates need to inherit from list
+  not cons, and need stronger branch partial eval
+- more accurate type inference in some cases
 - optimize away dispatch
-- goal: to compile hash* optimally
+- goal: to compile hash* optimally
-- type check/not-check entry points for compiled words
+- type check/not-check entry points for compiled words
 - getenv/setenv: if literal arg, compile as a load/store
 
 + oop:
@@ -23,33 +29,39 @@
 
 + listener/plugin:
 
+- update plugin docs
+- extract word keeps indent
+- word preview for remote words
 - WordPreview calls markTokens() -> NPE
-- stream server can hang because of exception handler limitations
 - listener should be multithreaded
-- compile all, infer all commands
+- compile all commands
 - faster completion
-- errors don't always disappear
 - NPE in ErrorHighlight
 - maple-like: press enter at old commands to evaluate there
 - completion in the listener
 - special completion for USE:/IN:
 
++ i/o:
+
+- stream server can hang because of exception handler limitations
+- better i/o scheduler
+- nicer way to combine two paths
+- add a socket timeout
+- rename f* words to stream-*
+- <file[bc][rw]> is badly named -- <file-reader>, <file-writer>
+
 + kernel:
 
 - ppc register decls
 - do partial objects cause problems?
-- better i/o scheduler
 - remove sbufs
 - cat, reverse-cat primitives
 - first-class hashtables
-- add a socket timeout
 
 + misc:
 
 - perhaps /i should work with all numbers
-- unit test weirdness: 2 lines appears at end
 - jedit ==> jedit-word, jedit takes a file name
-- nicer way to combine two paths
 - browser responder for word links in HTTPd
 - worddef props
 - prettyprint: when unparse called due to recursion, write a link

library/bootstrap/image.factor

@@ -215,7 +215,7 @@ M: f ' ( obj -- ptr )
 : transfer-word ( word -- word )
     #! This is a hack. See doc/bootstrap.txt.
     dup dup word-name swap word-vocabulary unit search
-    [ "Missing DEFER: " word-error ] ?unless ;
+    [ dup "Missing DEFER: " word-error ] ?unless ;
 
 : fixup-word ( word -- offset )
     dup pooled-object [ "Not in image: " word-error ] ?unless ;

library/compiler/x86/assembler.factor

@@ -105,7 +105,7 @@ M: register register "register" word-property ;
 M: register displacement drop ;
 
 ( Indirect register operands -- eg, [ ECX ]                    )
-PREDICATE: list indirect
+PREDICATE: cons indirect
     dup length 1 = [ car register? ] [ drop f ] ifte ;
 
 M: indirect modifier drop BIN: 00 ;
@@ -117,7 +117,7 @@ M: indirect register
 M: indirect displacement drop ;
 
 ( Displaced indirect register operands -- eg, [ EAX 4 ]        )
-PREDICATE: list displaced
+PREDICATE: cons displaced
     dup length 2 = [
         2unlist integer? swap register? and
     ] [
@@ -130,7 +130,7 @@ M: displaced displacement
     cdr car dup byte? [ compile-byte ] [ compile-cell ] ifte ;
 
 ( Displacement-only operands -- eg, [ 1234 ]                   )
-PREDICATE: list disp-only
+PREDICATE: cons disp-only
     dup length 1 = [ car integer? ] [ drop f ] ifte ;
 
 M: disp-only modifier drop BIN: 00 ;

library/compiler/x86/fixnum.factor

@@ -135,7 +135,7 @@ USE: math-internals
     [ ECX ] IDIV
     EAX 3 SHL
     0 JNO fixup
-    \ fixnum/i compile-call
+    \ fixnum/mod compile-call
     0 JMP fixup >r
     compiled-offset swap patch
     [ ECX -4 ] EAX MOV

library/inference/branches.factor

@@ -47,7 +47,7 @@ USE: prettyprint
 
 : add-inputs ( count stack -- stack )
     #! Add this many inputs to the given stack.
-    dup >r vector-length - computed-value-vector dup r>
+    [ vector-length - computed-value-vector ] keep
     vector-append ;
 
 : unify-lengths ( list -- list )
@@ -89,7 +89,7 @@ USE: prettyprint
     ] ifte ;
 
 : datastack-effect ( list -- )
-    [ [ d-in get meta-d get ] bind cons ] map
+    [ [ effect ] bind ] map
     unify-effect
     meta-d set d-in set ;
 
@@ -161,7 +161,7 @@ SYMBOL: cloned
     #! for the given branch.
     [
         [
-            inferring-base-case get [
+            branches-can-fail? [
                 [
                     infer-branch ,
                 ] [
@@ -182,7 +182,7 @@ SYMBOL: cloned
     #! the branches has an undecidable stack effect, we set the
     #! base case to this stack effect and try again. The inputs
     #! parameter is a vector.
-    (infer-branches)  dup unify-effects unify-dataflow ;
+    (infer-branches) dup unify-effects unify-dataflow ;
 
 : (with-block) ( label quot -- )
     #! Call a quotation in a new namespace, and transfer
@@ -196,7 +196,7 @@ SYMBOL: cloned
     meta-r set meta-d set d-in set ;
 
 : static-branch? ( value -- )
-    literal? inferring-base-case get not and ;
+    literal? branches-can-fail? not and ;
 
 : static-ifte ( true false -- )
     #! If the branch taken is statically known, just infer
@@ -222,11 +222,11 @@ SYMBOL: cloned
     [ object general-list general-list ] ensure-d
     dataflow-drop, pop-d
     dataflow-drop, pop-d swap
-!    peek-d static-branch? [
+    peek-d static-branch? [
-!        static-ifte
+        static-ifte
-!    ] [
+    ] [
         dynamic-ifte
-    ( ] ifte ) ;
+    ] ifte ;
 
 \ ifte [ infer-ifte ] "infer" set-word-property
 

library/inference/inference.factor

@@ -39,10 +39,18 @@ USE: hashtables
 USE: generic
 USE: prettyprint
 
-! If this symbol is on, partial evalution of conditionals is
+! If this variable is on, partial evalution of conditionals is
 ! disabled.
 SYMBOL: inferring-base-case
 
+! If this variable is on, we are inferring the entry effect, so
+! we unify all entry point effects to the vecto stored in this
+! variable.
+SYMBOL: inferring-entry-effect
+
+: branches-can-fail? ( -- ? )
+    inferring-base-case get inferring-entry-effect get or ;
+
 ! Word properties that affect inference:
 ! - infer-effect -- must be set. controls number of inputs
 ! expected, and number of outputs produced.
@@ -130,7 +138,7 @@ M: literal set-value-class ( class value -- )
     ] ifte ;
 
 : vector-prepend ( values stack -- stack )
-    >r list>vector dup r> vector-append ;
+    >r list>vector r> vector-append ;
 
 : ensure-d ( typelist -- )
     dup meta-d get ensure-types
@@ -138,17 +146,23 @@ M: literal set-value-class ( class value -- )
     meta-d [ vector-prepend ] change
     d-in [ vector-prepend ] change ;
 
-: effect ( -- [ in-types out-types ] )
+: (present-effect) ( vector -- list )
+    [ value-class ] vector-map vector>list ;
+
+: present-effect ( [ d-in | meta-d ] -- [ in-types out-types ] )
     #! After inference is finished, collect information.
-    d-in get [ value-class ] vector-map vector>list
+    uncons >r (present-effect) r> (present-effect) 2list ;
-    meta-d get [ value-class ] vector-map vector>list 2list ;
+
+: effect ( -- [ d-in | meta-d ] )
+    d-in get meta-d get cons ;
 
 : init-inference ( recursive-state -- )
     init-interpreter
     0 <vector> d-in set
     recursive-state set
     dataflow-graph off
-    inferring-base-case off ;
+    inferring-base-case off
+    inferring-entry-effect off ;
 
 DEFER: apply-word
 
@@ -186,7 +200,7 @@ DEFER: apply-word
 
 : infer ( quot -- [ in | out ] )
     #! Stack effect of a quotation.
-    [ (infer) effect ] with-scope ;
+    [ (infer) effect present-effect ] with-scope ;
 
 : dataflow ( quot -- dataflow )
     #! Data flow of a quotation.

library/inference/words.factor

@@ -2,7 +2,7 @@
 
 ! $Id$
 !
-! Copyright (C) 2004 Slava Pestov.
+! Copyright (C) 2004, 2005 Slava Pestov.
 ! 
 ! Redistribution and use in source and binary forms, with or without
 ! modification, are permitted provided that the following conditions are met:
@@ -88,17 +88,32 @@ USE: prettyprint
         r> call
     ] (with-block) ;
 
+: entry-effect ( quot -- )
+    [
+        meta-d get inferring-entry-effect set
+        copy-inference
+        infer-quot
+        inferring-entry-effect off
+    ] with-scope ;
+
+: recursive? ( word -- ? )
+    dup word-parameter tree-contains? ;
+
 : inline-compound ( word -- effect )
     #! Infer the stack effect of a compound word in the current
-    #! inferencer instance.
+    #! inferencer instance. If the word in question is recursive
-    gensym [ word-parameter infer-quot effect ] with-block ;
+    #! we infer its stack effect inside a new block.
+    gensym [
+        dup recursive? [ dup word-parameter entry-effect ] when
+        word-parameter infer-quot effect
+    ] with-block ;
 
 : infer-compound ( word -- effect )
     #! Infer a word's stack effect in a separate inferencer
     #! instance.
     [
         recursive-state get init-inference
-        dup dup inline-compound
+        dup dup inline-compound present-effect
         [ "infer-effect" set-word-property ] keep
     ] with-scope consume/produce ;
 
@@ -135,32 +150,77 @@ M: symbol (apply-word) ( word -- )
         ] when
     ] when ;
 
-: decompose ( x y -- effect )
+: decompose ( x y -- [ d-in | meta-d ] )
     #! Return a stack effect such that x*effect = y.
-    2unlist >r
+    uncons >r swap uncons >r
-    swap 2unlist >r
+    over vector-length over vector-length -
-    over length over length - head nip
+    swap vector-head nip
-    r> append
+    r> vector-append r> cons ;
-    r> 2list ;
 
-: base-case ( word -- effect )
+: base-case ( word -- [ d-in | meta-d ] )
-    effect swap
     [
         inferring-base-case on
         copy-inference
         inline-compound
         inferring-base-case off
-    ] with-scope decompose ;
+    ] with-scope effect swap decompose ;
+
+: no-base-case ( word -- )
+    word-name " does not have a base case." cat2 throw ;
+
+: raise# ( n vec -- n )
+    #! Parameter is a vector of pairs. Return the highest index
+    #! where pairs are equal.
+    2dup vector-length >= [
+        drop
+    ] [
+        2dup vector-nth uncons = [
+            >r 1 + r> raise#
+        ] [
+            drop
+        ] ifte
+    ] ifte ;
+
+: raise ( vec1 vec2 -- list )
+    #! Return a new vector consisting of the remainder of vec1,
+    #! without any leading elements equal to those from vec2.
+    over vector-zip 0 swap raise# swap vector-tail ;
+
+: unify-entry-effect ( vector list -- )
+    #! If any elements are not equal, the vector's element is
+    #! replaced with the list's.
+    over vector-length over length - -rot [
+        ( n vector elt )
+        pick pick vector-nth over = [
+            drop
+        ] [
+            pick pick set-vector-nth
+        ] ifte
+        >r 1 + r>
+    ] each 2drop ;
+
+: apply-entry-effect ( word -- )
+    #! Called at a recursive call point. We need this to compute
+    #! the set of literals that is retained across a recursive
+    #! call -- this is NOT the same as the literals present on
+    #! entry. This word mutates the inferring-entry-effect
+    #! vector.
+    base-case uncons raise
+    inferring-entry-effect get swap unify-entry-effect ;
 
 : recursive-word ( word label -- )
     #! Handle a recursive call, by either applying a previously
     #! inferred base case, or raising an error. If the recursive
     #! call is to a local block, emit a label call node.
     inferring-base-case get [
-        drop word-name " does not have a base case." cat2 throw
+        drop no-base-case
     ] [
-        2dup [ drop #call-label ] [ nip #call ] ifte
+        inferring-entry-effect get [
-        rot base-case (consume/produce)
+            apply-entry-effect  "Bail out" throw
+        ] [
+            dup [ #call-label ] [ #call ] ?ifte
+            rot base-case present-effect (consume/produce)
+        ] ifte
     ] ifte ;
 
 : apply-word ( word -- )
@@ -186,6 +246,7 @@ M: symbol (apply-word) ( word -- )
 
 \ call [ infer-call ] "infer" set-word-property
 
+! These hacks will go away soon
 \ * [ [ number number ] [ number ] ] "infer-effect" set-word-property
 
 \ undefined-method t "terminator" set-word-property

library/test/inference.factor

@@ -11,23 +11,35 @@ USE: kernel
 USE: math-internals
 USE: generic
 
-[ [ [ object object ] f ] ]
+[ 0 ]
-[ [ [ object ] [ object object ] ] [ [ object ] f ] decompose ]
+[ { 1 2 3 } { 4 5 6 } vector-zip 0 swap raise# ]
 unit-test
 
-[ [ [ cons vector cons integer object cons ] [ cons vector cons ] ] ]
+[ 2 ]
-[
+[ { 1 2 3 } { 1 2 6 } vector-zip 0 swap raise# ]
-    [ [ vector ] [ cons vector cons integer object cons ] ]
+unit-test
-    [ [ vector ] [ cons vector cons ] ]
-    decompose
-] unit-test
 
-[ [ [ object ] [ object ] ] ]
+[ { 4 5 6 } ]
-[
+[ { 1 2 3 } dup [ 4 5 6 ] unify-entry-effect ]
-    [ [ object number ] [ object ] ]
+unit-test
-    [ [ object number ] [ object ] ]
+
-    decompose
+! [ [ [ object object ] f ] ]
-] unit-test
+! [ [ [ object ] [ object object ] ] [ [ object ] f ] decompose ]
+! unit-test
+! 
+! [ [ [ cons vector cons integer object cons ] [ cons vector cons ] ] ]
+! [
+!     [ [ vector ] [ cons vector cons integer object cons ] ]
+!     [ [ vector ] [ cons vector cons ] ]
+!     decompose
+! ] unit-test
+! 
+! [ [ [ object ] [ object ] ] ]
+! [
+!     [ [ object number ] [ object ] ]
+!     [ [ object number ] [ object ] ]
+!     decompose
+! ] unit-test
 
 : old-effect ( [ in-types out-types ] -- [ in | out ] )
     uncons car length >r length r> cons ;

library/test/vectors.factor

@@ -50,7 +50,7 @@ USE: namespaces
 [ t ] [ { } hashcode { } hashcode = ] unit-test
 
 [ { 1 2 3 4 5 6 } ]
-[ { 1 2 3 } vector-clone dup { 4 5 6 } vector-append ] unit-test
+[ { 1 2 3 } { 4 5 6 } vector-append ] unit-test
 
 [ { "" "a" "aa" "aaa" } ]
 [ 4 [ CHAR: a fill ] vector-project ]

library/vectors.factor

@@ -107,10 +107,15 @@ BUILTIN: vector 11
 : vector-all? ( vector pred -- ? )
     vector-map vector-and ; inline
 
-: vector-append ( v1 v2 -- )
+: vector-nappend ( v1 v2 -- )
     #! Destructively append v2 to v1.
     [ over vector-push ] vector-each drop ;
 
+: vector-append ( v1 v2 -- vec )
+    over vector-length over vector-length + <vector>
+    [ rot vector-nappend ] keep
+    [ swap vector-nappend ] keep ;
+
 : vector-project ( n quot -- accum )
     #! Execute the quotation n times, passing the loop counter
     #! the quotation as it ranges from 0..n-1. Collect results
@@ -122,7 +127,7 @@ BUILTIN: vector 11
 : vector-zip ( v1 v2 -- v )
     #! Make a new vector with each pair of elements from the
     #! first two in a pair.
-    over vector-length [
+    over vector-length over vector-length min [
         pick pick >r over >r vector-nth r> r> vector-nth cons
     ] vector-project nip nip ;
 
@@ -168,8 +173,13 @@ M: vector hashcode ( vec -- n )
         over ?vector-nth hashcode rot bitxor swap
     ] times* drop ;
 
+: vector-head ( n vector -- list )
+    #! Return a new list with all elements up to the nth
+    #! element.
+    swap [ over vector-nth ] vector-project nip ;
+
 : vector-tail ( n vector -- list )
-    #! Return a new vector, with all elements from the nth
+    #! Return a new list with all elements from the nth
     #! index upwards.
     2dup vector-length swap - [
         pick + over vector-nth