preliminary implementation of recursive effect deduction, compiler work

TODO.FACTOR.txt

@@ -36,6 +36,7 @@
 
 + listener/plugin:
 
+- twice in completion list
 - accept multi-line input in listener
 - don't show listener on certain commands
 - NPE in ErrorHighlight

library/compiler/assembly-x86.factor

@@ -113,7 +113,7 @@ USE: combinators
 
 : [R]>R ( reg reg -- )
     #! MOV INDIRECT <reg> TO <reg>.
-    HEX: 8b compile-byte  swap 0 MOD-R/M ;
+    HEX: 8b compile-byte  0 MOD-R/M ;
 
 : R>[R] ( reg reg -- )
     #! MOV <reg> TO INDIRECT <reg>.
@@ -164,19 +164,20 @@ USE: combinators
     BIN: 100 BIN: 11 MOD-R/M
     compile-byte ;
 
-: CMP-I-[R] ( imm reg -- )
+: CMP-I-R ( imm reg -- )
-    #! There are two forms of CMP we assemble
+    #! There are three forms of CMP we assemble
-    #! 83 38 03                cmpl   $0x3,(%eax)
+    #! 83 f8 03                cmpl   $0x3,%eax
-    #! 81 38 33 33 33 00       cmpl   $0x333333,(%eax)
+    #! 81 fa 33 33 33 00       cmpl   $0x333333,%edx
-    over byte? [
+    #! 3d 33 33 33 00          cmpl   $0x333333,%eax
+    [
         HEX: 83 compile-byte
-        BIN: 111 0 MOD-R/M
+        BIN: 111 BIN: 11 MOD-R/M
-        compile-byte
+    ] [
+        HEX: 3d compile-byte
     ] [
         HEX: 81 compile-byte
-        BIN: 111 0 MOD-R/M
+        BIN: 111 BIN: 11 MOD-R/M
-        compile-cell
+    ] byte/eax/cell ;
-    ] ifte ;
 
 : JUMP-FIXUP ( addr where -- )
     #! Encode a relative offset to addr from where at where.

library/compiler/compiler-macros.factor

@@ -30,30 +30,25 @@ USE: alien
 
 : LITERAL ( cell -- )
     #! Push literal on data stack.
-    ESI I>[R]
+    4 ESI R+I
-    4 ESI R+I ;
+    ESI I>[R] ;
 
 : [LITERAL] ( cell -- )
     #! Push complex literal on data stack by following an
     #! indirect pointer.
+    4 ESI R+I
     EAX [I]>R
-    EAX ESI R>[R]
+    EAX ESI R>[R] ;
-    4 ESI R+I ;
 
 : PUSH-DS ( -- )
     #! Push contents of EAX onto datastack.
-    EAX ESI R>[R]
+    4 ESI R+I
-    4 ESI R+I ;
+    EAX ESI R>[R] ;
-
-: PEEK-DS ( -- )
-    #! Peek datastack, store pointer to datastack top in EAX.
-    ESI EAX R>R
-    4 EAX R-I ;
 
 : POP-DS ( -- )
     #! Pop datastack, store pointer to datastack top in EAX.
-    PEEK-DS
+    ESI EAX [R]>R
-    EAX ESI R>R ;
+    4 ESI R-I ;
 
 : SELF-CALL ( name -- )
     #! Call named C function in Factor interpreter executable.
@@ -61,14 +56,13 @@ USE: alien
 
 : TYPE ( -- )
     #! Peek datastack, store type # in EAX.
-    PEEK-DS
+    ESI PUSH-[R]
-    EAX PUSH-[R]
     "type_of" SELF-CALL
     4 ESP R+I ;
 
 : ARITHMETIC-TYPE ( -- )
     #! Peek top two on datastack, store arithmetic type # in EAX.
-    PEEK-DS
+    ESI EAX R>R
     EAX PUSH-[R]
     4 EAX R-I
     EAX PUSH-[R]

library/compiler/ifte.factor

@@ -35,8 +35,8 @@ USE: lists
 
 : compile-test ( -- )
     POP-DS
-    ! ptr to condition is now in EAX
+    ! condition is now in EAX
-    f address EAX CMP-I-[R] ;
+    f address EAX CMP-I-R ;
 
 : compile-f-test ( -- fixup )
     #! Push addr where we write the branch target address.

library/platform/native/boot-stage2.factor

@@ -153,6 +153,7 @@ cpu "x86" = [
         "/library/compiler/compiler.factor"
         "/library/compiler/ifte.factor"
         "/library/compiler/generic.factor"
+        "/library/compiler/stack.factor"
         "/library/compiler/interpret-only.factor"
         "/library/compiler/compile-all.factor"
         "/library/compiler/alien-types.factor"

library/platform/native/stack.factor

@@ -37,7 +37,7 @@ USE: vectors
 : dupd ( x y -- x x y ) >r dup r> ;
 : swapd ( x y z -- y x z ) >r swap r> ;
 : transp ( x y z -- z y x ) swap rot ;
-: 2swap ( x y z t -- z t x y ) rot >r rot r> ;
+: 2nip ( x y z t -- z t ) >r >r drop drop r> r> ;
 
 : clear ( -- )
     #! Clear the datastack. For interactive use only; invoking

library/test/inference.factor

@@ -6,6 +6,7 @@ USE: stack
 USE: combinators
 USE: vectors
 USE: kernel
+USE: lists
 
 [ 6 ] [ 6 gensym-vector vector-length ] unit-test
 
@@ -57,3 +58,28 @@ USE: kernel
 [
     [ [ 2 2 fixnum+ ] ] [ [ 2 2 fixnum* ] ] ifte call
 ] unit-test-fails
+
+: infinite-loop infinite-loop ;
+
+[ [ infinite-loop ] infer ] unit-test-fails
+
+: simple-recursion-1
+    dup [ simple-recursion-1 ] [ ] ifte ;
+
+[ [ 1 | 1 ] ] [ [ simple-recursion-1 ] infer ] unit-test
+
+: simple-recursion-2
+    dup [ ] [ simple-recursion-2 ] ifte ;
+
+[ [ 1 | 1 ] ] [ [ simple-recursion-2 ] infer ] unit-test
+
+[ [ 2 | 1 ] ] [ [ 2list ] infer ] unit-test
+[ [ 3 | 1 ] ] [ [ 3list ] infer ] unit-test
+[ [ 2 | 1 ] ] [ [ append ] infer ] unit-test
+[ [ 2 | 1 ] ] [ [ swons ] infer ] unit-test
+[ [ 1 | 2 ] ] [ [ uncons ] infer ] unit-test
+[ [ 1 | 1 ] ] [ [ unit ] infer ] unit-test
+[ [ 1 | 2 ] ] [ [ unswons ] infer ] unit-test
+! [ [ 1 | 1 ] ] [ [ last* ] infer ] unit-test
+! [ [ 1 | 1 ] ] [ [ last ] infer ] unit-test
+! [ [ 1 | 1 ] ] [ [ list? ] infer ] unit-test

library/tools/inference.factor

@@ -31,12 +31,14 @@ USE: errors
 USE: interpreter
 USE: kernel
 USE: lists
+USE: logic
 USE: math
 USE: namespaces
 USE: stack
 USE: strings
 USE: vectors
 USE: words
+USE: hashtables
 
 ! Word properties that affect inference:
 ! - infer-effect -- must be set. controls number of inputs
@@ -45,8 +47,12 @@ USE: words
 ! - infer - quotation with custom inference behavior; ifte uses
 ! this. Word is passed on the stack.
 
+! Amount of results we had to add to the datastack
 SYMBOL: d-in
+! Amount of results we had to add to the callstack
 SYMBOL: r-in
+! Recursive state. Alist maps words to base case effects
+SYMBOL: recursive-state
 
 : gensym-vector ( n --  vector )
     dup <vector> swap [ gensym over vector-push ] times ;
@@ -75,6 +81,9 @@ SYMBOL: r-in
     #! Push count of unknown results.
     [ gensym push-d ] times ;
 
+: consume/produce ( [ in | out ] -- )
+    unswons dup ensure-d consume-d produce-d ;
+
 : standard-effect ( word [ in | out ] -- )
     #! If a word does not have special inference behavior, we
     #! either execute the word in the meta interpreter (if it is
@@ -83,7 +92,7 @@ SYMBOL: r-in
     over "meta-infer" word-property [
         drop host-word
     ] [
-        unswons consume-d produce-d drop
+        nip consume/produce
     ] ifte ;
 
 : apply-effect ( word [ in | out ] -- )
@@ -100,22 +109,49 @@ SYMBOL: r-in
 
 DEFER: (infer)
 
+: apply-compound ( word -- )
+    t over recursive-state acons@
+    word-parameter (infer)
+    recursive-state uncons@ drop ;
+
 : apply-word ( word -- )
-    #! Apply the word's stack effect to the inferencer's state.
+    #! Apply the word's stack effect to the inferencer state.
     dup "infer-effect" word-property dup [
         apply-effect
     ] [
-        drop dup compound? [
+        drop dup compound? [ apply-compound ] [ no-effect ] ifte
-            word-parameter (infer)
+    ] ifte ;
+
+: current-word ( -- word )
+    #! Push word we're currently inferring effect of.
+    recursive-state get car car ;
+
+: no-base-case ( -- )
+    current-word word-name
+    " does not have a base case." cat2 throw ;
+
+: recursive-word ( word effect -- )
+    #! Handle a recursive call, by either applying a previously
+    #! inferred base case, or raising an error.
+    dup t = [ drop no-base-case ] [ nip consume/produce ] ifte ;
+
+: apply-object ( obj -- )
+    #! Apply the object's stack effect to the inferencer state.
+    dup word? [
+        dup recursive-state get assoc [
+            recursive-word
         ] [
-            no-effect
+            apply-word
-        ] ifte
+        ] ifte*
+    ] [
+        push-d
     ] ifte ;
 
 : init-inference ( -- )
     init-interpreter
     0 d-in set
-    0 r-in set ;
+    0 r-in set
+    f recursive-state set ;
 
 : effect ( -- [ in | out ] )
     #! After inference is finished, collect information.
@@ -124,13 +160,9 @@ DEFER: (infer)
 : (infer) ( quot -- )
     #! Recursive calls to this word are made for nested
     #! quotations.
-    [ dup word? [ apply-word ] [ push-d ] ifte ] each ;
+    [ apply-object ] each ;
 
-: infer ( quot -- [ in | out ] )
+: (infer-branch) ( quot -- [ in-d | datastack ] )
-    #! Stack effect of a quotation.
-    [ init-inference (infer)  effect ] with-scope ;
-
-: infer-branch ( quot -- [ in-d | datastack ] )
     #! Infer the quotation's effect, restoring the meta
     #! interpreter state afterwards.
     [
@@ -138,6 +170,10 @@ DEFER: (infer)
         d-in get  meta-d get cons
     ] with-scope ;
 
+: infer-branch ( quot -- [ in-d | datastack ] )
+    #! Push f if inference failed.
+    [ (infer-branch) ] [ [ drop f ] when ] catch ;
+
 : difference ( [ in | stack ] -- diff )
     #! Stack height difference of infer-branch return value.
     uncons vector-length - ;
@@ -175,10 +211,43 @@ DEFER: (infer)
         "Unbalanced ifte branches" throw
     ] ifte ;
 
+: set-base ( [ in | stack ] -- )
+    #! Set the base case of the current word.
+    recursive-state uncons@ car >r
+    uncons vector-length cons r>
+    recursive-state acons@ ;
+
+: recursive-branches ( false true fe te -- fe te )
+    #! At least one of the branches did not have a computable
+    #! stack effect. Set the base case to the other branch, and
+    #! try again.
+    2dup or [
+        dup [
+            dup set-base >r 2drop infer-branch r>
+        ] [
+            drop dup set-base swap infer-branch rot drop
+        ] ifte
+    ] [
+        no-base-case
+    ] ifte ;
+
+: infer-branches ( false true -- [ in | stack ] [ in | stack ] )
+    #! Recursive stack effect inference is done here. If one of
+    #! the branches has an undecidable stack effect, we set the
+    #! base case to this stack effect and try again.
+    over infer-branch over infer-branch 2dup and [
+        2nip ( all good )
+    ] [
+        recursive-branches
+    ] ifte ;
+
 : infer-ifte ( -- )
     #! Infer effects for both branches, unify.
-    pop-d pop-d pop-d  drop ( condition )
+    pop-d pop-d pop-d drop ( condition ) infer-branches unify ;
-    >r infer-branch r> infer-branch unify ;
+
+: infer ( quot -- [ in | out ] )
+    #! Stack effect of a quotation.
+    [ init-inference (infer)  effect ] with-scope ;
 
 \ call [ pop-d (infer) ] "infer" set-word-property
 \ call [ 1 | 0 ] "infer-effect" set-word-property
@@ -206,6 +275,13 @@ DEFER: (infer)
 \ rot t "meta-infer" set-word-property
 \ rot [ 3 | 3 ] "infer-effect" set-word-property
 
+\ type [ 1 | 1 ] "infer-effect" set-word-property
+\ eq? [ 2 | 1 ] "infer-effect" set-word-property
+
+\ car [ 1 | 1 ] "infer-effect" set-word-property
+\ cdr [ 1 | 1 ] "infer-effect" set-word-property
+\ cons [ 2 | 1 ] "infer-effect" set-word-property
+
 \ fixnum+ [ 2 | 1 ] "infer-effect" set-word-property
 \ fixnum- [ 2 | 1 ] "infer-effect" set-word-property
 \ fixnum* [ 2 | 1 ] "infer-effect" set-word-property

native/gc.c

@@ -120,10 +120,10 @@ void collect_roots(void)
 	copy_bignum_constants();
 	copy_object(&callframe);
 
-	for(ptr = ds_bot; ptr < ds; ptr += CELLS)
+	for(ptr = ds_bot; ptr <= ds; ptr += CELLS)
 		copy_object((void*)ptr);
 
-	for(ptr = cs_bot; ptr < cs; ptr += CELLS)
+	for(ptr = cs_bot; ptr <= cs; ptr += CELLS)
 		copy_object((void*)ptr);
 
 	for(i = 0; i < USER_ENV; i++)

native/run.h

@@ -49,41 +49,43 @@ CELL profile_depth;
 
 INLINE CELL dpop(void)
 {
+	CELL value = get(ds);
 	ds -= CELLS;
-	return get(ds);
+	return value;
 }
 
 INLINE void drepl(CELL top)
 {
-	put(ds - CELLS,top);
+	put(ds,top);
 }
 
 INLINE void dpush(CELL top)
 {
-	put(ds,top);
 	ds += CELLS;
+	put(ds,top);
 }
 
 INLINE CELL dpeek(void)
 {
-	return get(ds - CELLS);
+	return get(ds);
 }
 
 INLINE CELL cpop(void)
 {
+	CELL value = get(cs);
 	cs -= CELLS;
-	return get(cs);
+	return value;
 }
 
 INLINE void cpush(CELL top)
 {
-	put(cs,top);
 	cs += CELLS;
+	put(cs,top);
 }
 
 INLINE CELL cpeek(void)
 {
-	return get(cs - CELLS);
+	return get(cs);
 }
 
 INLINE void call(CELL quot)

native/stack.c

@@ -2,12 +2,12 @@
 
 void reset_datastack(void)
 {
-	ds = ds_bot;
+	ds = ds_bot - CELLS;
 }
 
 void reset_callstack(void)
 {
-	cs = cs_bot;
+	cs = cs_bot - CELLS;
 }
 
 void init_stacks(void)
@@ -32,44 +32,44 @@ void primitive_dup(void)
 void primitive_swap(void)
 {
 	CELL top = dpeek();
-	CELL next = get(ds - CELLS * 2);
+	CELL next = get(ds - CELLS);
-	put(ds - CELLS,next);
+	put(ds,next);
-	put(ds - CELLS * 2,top);
+	put(ds - CELLS,top);
 }
 
 void primitive_over(void)
 {
-	dpush(get(ds - CELLS * 2));
+	dpush(get(ds - CELLS));
 }
 
 void primitive_pick(void)
 {
-	dpush(get(ds - CELLS * 3));
+	dpush(get(ds - CELLS * 2));
 }
 
 void primitive_nip(void)
 {
 	CELL top = dpop();
-	put(ds - CELLS,top);
+	put(ds,top);
 }
 
 void primitive_tuck(void)
 {
 	CELL top = dpeek();
-	CELL next = get(ds - CELLS * 2);
+	CELL next = get(ds - CELLS);
-	put(ds - CELLS * 2,top);
+	put(ds - CELLS,top);
-	put(ds - CELLS,next);
+	put(ds,next);
 	dpush(top);
 }
 
 void primitive_rot(void)
 {
 	CELL top = dpeek();
-	CELL next = get(ds - CELLS * 2);
+	CELL next = get(ds - CELLS);
-	CELL next_next = get(ds - CELLS * 3);
+	CELL next_next = get(ds - CELLS * 2);
-	put(ds - CELLS * 3,next);
+	put(ds - CELLS * 2,next);
-	put(ds - CELLS * 2,top);
+	put(ds - CELLS,top);
-	put(ds - CELLS,next_next);
+	put(ds,next_next);
 }
 
 void primitive_to_r(void)
@@ -84,7 +84,7 @@ void primitive_from_r(void)
 
 VECTOR* stack_to_vector(CELL bottom, CELL top)
 {
-	CELL depth = (top - bottom) / CELLS;
+	CELL depth = (top - bottom + CELLS) / CELLS;
 	VECTOR* v = vector(depth);
 	ARRAY* a = v->array;
 	memcpy(a + 1,(void*)bottom,depth * CELLS);
@@ -110,7 +110,7 @@ CELL vector_to_stack(VECTOR* vector, CELL bottom)
 	CELL start = bottom;
 	CELL len = vector->top * CELLS;
 	memcpy((void*)start,vector->array + 1,len);
-	return start + len;
+	return start + len - CELLS;
 }
 
 void primitive_set_datastack(void)

native/stack.h

@@ -1,5 +1,5 @@
-#define STACK_UNDERFLOW(stack,bot) ((stack) < UNTAG(bot))
+#define STACK_UNDERFLOW(stack,bot) ((stack) + CELLS < UNTAG(bot))
-#define STACK_OVERFLOW(stack,bot) ((stack) >= UNTAG(bot) + STACK_SIZE)
+#define STACK_OVERFLOW(stack,bot) ((stack) + CELLS >= UNTAG(bot) + STACK_SIZE)
 
 void reset_datastack(void);
 void reset_callstack(void);