various fixes to inference, experimenting with %char-slot vops and interruption checks

TODO.FACTOR.txt

@@ -1,12 +1,12 @@
 - make-pane: if no input, just return pane-output
-- intrinsic char-slot set-char-slot
+- intrinsic char-slot set-char-slot for x86
+- closing ui does not stop timers
+- adding/removing timers automatically for animated gadgets
+- saving image with UI open
 
 - default library names are not useful
 - fix remaining GL issues
 - fix up the min thumb size hack
-- closing ui does not stop timers
-- adding/removing timers automatically for animated gadgets
-- saving image with UI open
 - bug: left click to bring up context menu, click splitter bar
   and pane grows to 100%
 - bug: click tutorial, full screen, the right-most arrow icon
@@ -16,8 +16,6 @@
 - FIELD: char key_vector[32];
 - FIELD: union { char b[20]; short s[10]; long l[5]; } data;
 - MEMBER: long pad[24];
-- inference: try changing nth and set-nth array methods to call -unsafe,
-  unbalanced branches error
 - floating point intrinsics
 - new basic block optimizer
 - declare slot types for built-ins

library/cli.factor

@@ -4,6 +4,10 @@ IN: kernel
 USING: errors hashtables io kernel-internals lists namespaces
 parser sequences strings ;
 
+: try-run-file ( file -- )
+    #! Run a file and trap errors, printing them to stdio.
+    [ [ run-file ] keep ] try drop ;
+
 : run-user-init ( -- )
     #! Run user init file if it exists
     "user-init" get [

library/collections/arrays.factor

@@ -18,8 +18,8 @@ IN: arrays
 
 M: array clone (clone) ;
 M: array length array-capacity ;
-M: array nth bounds-check >r >fixnum r> array-nth ;
+M: array nth bounds-check nth-unsafe ;
-M: array set-nth bounds-check >r >fixnum r> set-array-nth ;
+M: array set-nth bounds-check set-nth-unsafe ;
 M: array nth-unsafe >r >fixnum r> array-nth ;
 M: array set-nth-unsafe >r >fixnum r> set-array-nth ;
 M: array resize resize-array ;

library/compiler/intrinsics.factor

@@ -22,7 +22,7 @@ namespaces sequences words ;
 
 : slot@ ( node -- n/f )
     #! Compute slot offset.
-    dup node-in-d reverse dup first dup literal? [
+    dup node-in-d reverse-slice dup first dup literal? [
         literal-value cell * swap second
         rot value-tag dup [ - ] [ 2drop f ] if
     ] [
@@ -59,6 +59,21 @@ namespaces sequences words ;
     1 %write-barrier ,
 ] "intrinsic" set-word-prop
 
+! \ char-slot [
+!     drop
+!     in-2
+!     -1 %inc-d ,
+!     0 1 %char-slot ,
+!     1 <vreg> 0 %replace-d ,
+! ] "intrinsic" set-word-prop
+! 
+! \ set-char-slot [
+!     drop
+!     in-3
+!     -3 %inc-d ,
+!     0 2 1 %set-char-slot ,
+! ] "intrinsic" set-word-prop
+
 \ type [
     drop
     in-1

library/compiler/ppc/fixnum.factor

@@ -18,8 +18,8 @@ namespaces words ;
     "end" get BNO
     dup >3-vop< 3dup r> execute
     2dup
-    dup tag-bits SRAWI
+    dup untag-fixnum
-    dup tag-bits SRAWI
+    dup untag-fixnum
     3 -rot r> execute
     drop
     "s48_long_to_bignum" f compile-c-call
@@ -39,7 +39,7 @@ M: %fixnum- generate-node ( vop -- )
 
 M: %fixnum* generate-node ( vop -- )
     #! Note that this assumes the output will be in r3.
-    >3-vop< dup dup tag-bits SRAWI
+    >3-vop< dup dup untag-fixnum
     0 MTXER
     [ >r >r drop 6 r> r> MULLWO. 3 ] 2keep
     <label> "end" set
@@ -135,7 +135,7 @@ M: %fixnum<< generate-node ( vop -- )
     ! is there going to be an overflow?
     "no-overflow" get BGE
     ! there is going to be an overflow, make a bignum
-    3 3 tag-bits SRAWI
+    3 3 untag-fixnum
     "s48_long_to_bignum" f compile-c-call
     dup 4 LI
     "s48_bignum_arithmetic_shift" f compile-c-call

library/compiler/ppc/generator.factor

@@ -75,6 +75,8 @@ M: %untag generate-node ( vop -- )
 
 : tag-fixnum ( src dest -- ) tag-bits SLWI ;
 
+: untag-fixnum ( src dest -- ) tag-bits SRAWI ;
+
 M: %dispatch generate-node ( vop -- )
     0 <vreg> check-src
     3 3 1 SRAWI

library/compiler/ppc/slots.factor

@@ -4,26 +4,32 @@ IN: compiler-backend
 USING: alien assembler compiler inference kernel
 kernel-internals lists math memory namespaces sequences words ;
 
-M: %slot generate-node ( vop -- )
+: generate-slot ( vop size quot -- )
-    dest/src
+    >r >r dest/src
     ! turn tagged fixnum slot # into an offset, multiple of 4
-    dup dup 1 SRAWI
+    dup dup tag-bits r> - SRAWI
     ! compute slot address in 0 vop-out
     >r dup dup r> ADD
     ! load slot value in 0 vop-out
-    dup 0 LWZ ;
+    dup r> call ; inline
+
+M: %slot generate-node ( vop -- )
+    cell log2 [ 0 LWZ ] generate-slot ;
 
 M: %fast-slot generate-node ( vop -- )
     dup 0 vop-out v>operand dup rot 0 vop-in LWZ ;
 
-M: %set-slot generate-node ( vop -- )
+: generate-set-slot ( vop size quot -- )
-    dup 2 vop-in v>operand over 1 vop-in v>operand
+    >r >r dup 2 vop-in v>operand over 1 vop-in v>operand
     ! turn tagged fixnum slot # into an offset, multiple of 4
-    over dup 1 SRAWI
+    over dup tag-bits r> - SRAWI
     ! compute slot address in 1 vop-in
     over dup rot ADD
     ! store new slot value
-    >r 0 vop-in v>operand r> 0 STW ;
+    >r 0 vop-in v>operand r> r> call ; inline
+
+M: %set-slot generate-node ( vop -- )
+    cell log2 [ 0 STW ] generate-set-slot ;
 
 M: %fast-set-slot generate-node ( vop -- )
     [ 0 vop-in v>operand ] keep
@@ -40,6 +46,17 @@ M: %write-barrier generate-node ( vop -- )
     6 6 card-mark ORI
     6 swap 0 STB ;
 
+: string-offset cell 3 * object-tag - ;
+
+M: %char-slot generate-node ( vop -- )
+    dup 1 [ string-offset LHZ ] generate-slot
+    0 vop-out v>operand dup tag-fixnum ;
+
+M: %set-char-slot generate-node ( vop -- )
+    ! untag the new value in 0 vop-in
+    dup 0 vop-in v>operand dup untag-fixnum
+    1 [ string-offset STH ] generate-set-slot ;
+
 : userenv ( reg -- )
     #! Load the userenv pointer in a virtual register.
     "userenv" f dlsym swap LOAD32 0 1 rel-userenv ;

library/compiler/vops.factor

@@ -202,18 +202,22 @@ C: %untag make-vop ;
 : %untag <vreg> dest-vop <%untag> ;
 M: %untag basic-block? drop t ;
 
+: slot-vop [ <vreg> ] 2apply 2-vop ;
+
 TUPLE: %slot ;
 C: %slot make-vop ;
-: %slot ( n vreg ) >r <vreg> r> <vreg> 2-vop <%slot> ;
+: %slot ( n vreg ) slot-vop <%slot> ;
 M: %slot basic-block? drop t ;
 
+: set-slot-vop
+    rot <vreg> rot <vreg> rot <vreg> over >r 3array r> 1array f ;
+
 TUPLE: %set-slot ;
 C: %set-slot make-vop ;
 
 : %set-slot ( value obj n )
     #! %set-slot writes to vreg obj.
-    rot <vreg> rot <vreg> rot <vreg> over >r 3array r> 1array
+    set-slot-vop <%set-slot> ;
-    f <%set-slot> ;
 
 M: %set-slot basic-block? drop t ;
 
@@ -233,6 +237,21 @@ C: %fast-set-slot make-vop ;
     <%fast-set-slot> ;
 M: %fast-set-slot basic-block? drop t ;
 
+! Char readers and writers
+TUPLE: %char-slot ;
+C: %char-slot make-vop ;
+: %char-slot ( n vreg ) slot-vop <%char-slot> ;
+M: %char-slot basic-block? drop t ;
+
+TUPLE: %set-char-slot ;
+C: %set-char-slot make-vop ;
+
+: %set-char-slot ( value ch n )
+    #! %set-char-slot writes to vreg obj.
+    set-slot-vop <%set-char-slot> ;
+
+M: %set-char-slot basic-block? drop t ;
+
 TUPLE: %write-barrier ;
 C: %write-barrier make-vop ;
 : %write-barrier ( ptr ) <vreg> dest-vop <%write-barrier> ;

library/inference/branches.factor

@@ -62,7 +62,8 @@ namespaces parser prettyprint sequences strings vectors words ;
     unify-effect meta-r set drop ;
 
 : unify-effects ( seq -- )
-    dup datastack-effect callstack-effect ;
+    dup datastack-effect dup callstack-effect
+    [ terminated? swap hash ] all? terminated? set ;
 
 : unify-dataflow ( effects -- nodes )
     [ [ dataflow-graph get ] bind ] map ;

library/inference/known-words.factor

@@ -466,9 +466,9 @@ prettyprint ;
 \ char-slot [ [ fixnum object ] [ fixnum ] ] "infer-effect" set-word-prop
 \ char-slot t "flushable" set-word-prop
 
-\ set-char-slot [ [ integer fixnum object ] [ ] ] "infer-effect" set-word-prop
+\ set-char-slot [ [ fixnum fixnum object ] [ ] ] "infer-effect" set-word-prop
-\ resize-array [ [ integer array ] [ array ] ] "infer-effect" set-word-prop
+\ resize-array [ [ fixnum array ] [ array ] ] "infer-effect" set-word-prop
-\ resize-string [ [ integer string ] [ string ] ] "infer-effect" set-word-prop
+\ resize-string [ [ fixnum string ] [ string ] ] "infer-effect" set-word-prop
 
 \ <hashtable> [ [ number ] [ hashtable ] ] "infer-effect" set-word-prop
 \ <hashtable> t "flushable" set-word-prop

library/inference/words.factor

@@ -25,14 +25,16 @@ hashtables parser prettyprint ;
     " was already attempted, and failed" append3
     inference-error ;
 
-: with-recursive-state ( word label quot -- )
+TUPLE: rstate label quot base-case? ;
-    >r over word-def cons cons
+
+: with-recursive-state ( word label base-case quot -- )
+    >r >r over word-def r> <rstate> cons
     recursive-state [ cons ] change r>
     call
     recursive-state [ cdr ] change ; inline
 
-: inline-block ( word -- node-block )
+: inline-block ( word base-case -- node-block )
-    gensym 2dup [
+    >r gensym 2dup r> [
         [
             dup #label >r
             #entry node,
@@ -47,9 +49,8 @@ hashtables parser prettyprint ;
     #! control flow by throwing an exception or restoring a
     #! continuation.
     [
-        inferring-base-case set
         recursive-state get init-inference
-        [ inline-block drop terminated? get effect ] keep
+        over >r inline-block drop terminated? get effect r>
     ] with-scope over consume/produce over [ terminate ] when ;
 
 GENERIC: apply-word
@@ -90,19 +91,19 @@ M: word apply-object ( word -- )
 M: symbol apply-object ( word -- )
     apply-literal ;
 
-: (base-case) ( word label -- )
+: inline-base-case ( word label -- )
-    over "inline" word-prop [
     meta-d get clone >r
-        over inline-block drop
+    over t inline-block drop
     [ #call-label ] [ #call ] ?if
-        r> over set-node-in-d node,
+    r> over set-node-in-d node, ;
-    ] [
-        drop dup t infer-compound nip "base-case" set-word-prop
-    ] if ;
 
 : base-case ( word label -- )
-    [ inferring-base-case on (base-case) ]
+    over "inline" word-prop [
-    [ inferring-base-case off ] cleanup ;
+        inline-base-case
+    ] [
+        drop dup t infer-compound swap
+        [ 2drop ] [ "base-case" set-word-prop ] if
+    ] if ;
 
 : no-base-case ( word -- )
     {
@@ -115,7 +116,7 @@ M: symbol apply-object ( word -- )
     base-case-continuation get
     [ t swap continue-with ] [ no-base-case ] if* ;
 
-: recursive-word ( word [[ label quot ]] -- )
+: recursive-word ( word rstate -- )
     #! 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.
@@ -125,10 +126,10 @@ M: symbol apply-object ( word -- )
         over "base-case" word-prop [
             nip consume/produce
         ] [
-            inferring-base-case get [
+            dup rstate-base-case? [
                 notify-base-case
             ] [
-                car base-case
+                rstate-label base-case
             ] if
         ] if*
     ] if* ;
@@ -154,5 +155,5 @@ M: compound apply-object ( word -- )
         recursive-word
     ] [
         dup "inline" word-prop
-        [ inline-block block, ] [ apply-default ] if
+        [ f inline-block block, ] [ apply-default ] if
     ] if* ;

library/syntax/parse-stream.factor

@@ -23,10 +23,6 @@ USING: errors io kernel lists math namespaces sequences words ;
 : run-file ( file -- )
     parse-file call ;
 
-: try-run-file ( file -- )
-    #! Run a file and trap errors, printing them to stdio.
-    [ [ run-file ] keep ] try drop ;
-
 : parse-resource ( path -- quot )
     #! Resources are loaded from the resource-path variable, or
     #! the current directory if it is not set. Words defined in

library/test/compiler/intrinsics.factor

@@ -1,6 +1,6 @@
 IN: temporary
 USING: arrays compiler kernel kernel-internals lists math
-math-internals sequences test words ;
+math-internals sequences strings test words ;
 
 ! Oops!
 [ 5000 ] [ [ 5000 ] compile-1 ] unit-test
@@ -18,6 +18,14 @@ math-internals sequences test words ;
 ! Write barrier hits on the wrong value were causing segfaults
 [ -3 ] [ -3 1 2 [ cons [ 1 set-slot ] keep ] compile-1 cdr ] unit-test
 
+[ CHAR: b ] [ 1 "abc" [ char-slot ] compile-1 ] unit-test
+[ CHAR: b ] [ 1 [ "abc" char-slot ] compile-1 ] unit-test
+[ CHAR: b ] [ [ 1 "abc" char-slot ] compile-1 ] unit-test
+
+[ "axc" ] [ CHAR: x 1 "abc" [ [ set-char-slot ] keep dup rehash-string ] compile-1 ] unit-test
+[ "axc" ] [ CHAR: x 1 [ "abc" [ set-char-slot ] keep dup rehash-string ] compile-1 ] unit-test
+[ "axc" ] [ CHAR: x [ 1 "abc" [ set-char-slot ] keep dup rehash-string ] compile-1 ] unit-test
+
 [ ] [ 1 [ drop ] compile-1 ] unit-test
 [ ] [ [ 1 drop ] compile-1 ] unit-test
 [ ] [ [ 1 2 2drop ] compile-1 ] unit-test

library/test/inference.factor

@@ -181,6 +181,29 @@ DEFER: agent
 : no-base-case-2 no-base-case-2 ;
 [ [ no-base-case-2 ] infer ] unit-test-fails
 
+! Regression
+: cat dup [ throw ] [ throw ] if ;
+: dog dup [ cat ] [ 3drop ] if ;
+[ { 3 0 } ] [ [ dog ] infer ] unit-test
+
+! Regression
+DEFER: monkey
+: friend dup [ friend ] [ monkey ] if ;
+: monkey dup [ 3drop ] [ friend ] if ;
+[ { 3 0 } ] [ [ friend ] infer ] unit-test
+
+! Regression -- same as above but we infer the second word first
+DEFER: blah2
+: blah dup [ blah ] [ blah2 ] if ;
+: blah2 dup [ blah ] [ 3drop ] if ;
+[ { 3 0 } ] [ [ blah2 ] infer ] unit-test
+
+! Regression
+DEFER: blah4
+: blah3 dup [ blah3 ] [ dup [ blah4 ] [ blah3 ] if ] if ;
+: blah4 dup [ blah4 ] [ dup [ 3drop ] [ blah3 ] if ] if ;
+[ { 3 0 } ] [ [ blah4 ] infer ] unit-test
+
 [ { 2 1 } ] [ [ swons ] infer ] unit-test
 [ { 1 2 } ] [ [ uncons ] infer ] unit-test
 [ { 1 1 } ] [ [ unit ] infer ] unit-test

native/factor.c

@@ -43,7 +43,7 @@ int main(int argc, char** argv)
 	CELL young_size = 8;
 	CELL aging_size = 16;
 	CELL code_size = 2;
-	CELL literal_size = 64;
+	CELL literal_size = 128;
 	CELL args;
 	CELL i;