Debugging new codegen

basis/compiler/cfg/builder/builder.factor

@@ -158,8 +158,6 @@ M: #if emit-node
             init-phantoms
             ##prologue
             [ emit-nodes ] with-node-iterator
-            ##epilogue
-            ##return
         ] with-cfg-builder
     ] keep ;
 
@@ -304,7 +302,8 @@ M: #return-recursive emit-node
     [ ##epilogue ##return ] unless stop-iterating ;
 
 ! #terminate
-M: #terminate emit-node drop stop-iterating ;
+M: #terminate emit-node
+    drop finalize-phantoms stop-iterating ;
 
 ! FFI
 : return-size ( ctype -- n )

basis/compiler/cfg/stacks/stacks.factor

@@ -305,9 +305,7 @@ M: loc lazy-store
 : set-value-classes ( classes -- )
     phantom-datastack get
     over length over add-locs
-    stack>> [
+    stack>> [ set-value-class ] 2reverse-each ;
-        [ value-class class-and ] keep set-value-class
-    ] 2reverse-each ;
 
 : finalize-phantoms ( -- )
     #! Commit all deferred stacking shuffling, and ensure the

basis/compiler/codegen/codegen.factor

@@ -144,7 +144,8 @@ M: _branch-t generate-insn
 
 M: ##dispatch-label generate-insn label>> %dispatch-label ;
 
-M: ##dispatch generate-insn drop %dispatch ;
+M: ##dispatch generate-insn
+    [ src>> v>operand ] [ temp>> v>operand ] bi %dispatch ;
 
 : dst/src ( insn -- dst src )
     [ dst>> v>operand ] [ src>> v>operand ] bi ;

basis/compiler/tests/intrinsics.factor

@@ -461,3 +461,21 @@ TUPLE: alien-accessor-regression { b byte-array } { i fixnum } ;
     ] compile-call
     b>>
 ] unit-test
+
+: mutable-value-bug-1 ( a b -- c )
+    swap [
+        { tuple } declare 1 slot
+    ] [
+        0 slot
+    ] if ;
+
+[ t ] [ f B{ } mutable-value-bug-1 byte-array type-number = ] unit-test
+
+: mutable-value-bug-2 ( a b -- c )
+    swap [
+        0 slot
+    ] [
+        { tuple } declare 1 slot
+    ] if ;
+
+[ t ] [ t B{ } mutable-value-bug-2 byte-array type-number = ] unit-test

basis/compiler/tree/finalization/finalization.factor

@@ -1,9 +1,9 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel arrays accessors sequences sequences.private words
-fry namespaces make math math.order memoize classes.builtin
+fry namespaces make math math.private math.order memoize
-classes.tuple.private slots.private combinators layouts
+classes.builtin classes.tuple.private classes.algebra
-byte-arrays alien.accessors
+slots.private combinators layouts byte-arrays alien.accessors
 compiler.intrinsics
 compiler.tree
 compiler.tree.combinators
@@ -23,6 +23,10 @@ IN: compiler.tree.finalization
 
 GENERIC: finalize* ( node -- nodes )
 
+: finalize ( nodes -- nodes' ) [ finalize* ] map-nodes ;
+
+: splice-final ( quot -- nodes ) splice-quot finalize ;
+
 M: #copy finalize* drop f ;
 
 M: #shuffle finalize*
@@ -34,30 +38,30 @@ M: #shuffle finalize*
     word>> "predicating" word-prop builtin-class? ;
 
 MEMO: builtin-predicate-expansion ( word -- nodes )
-    def>> splice-quot ;
+    def>> splice-final ;
 
 : expand-builtin-predicate ( #call -- nodes )
     word>> builtin-predicate-expansion ;
 
-: first-literal ( #call -- obj ) node-input-infos first literal>> ;
-
-: last-literal ( #call -- obj ) node-input-infos peek literal>> ;
-
 : expand-tuple-boa? ( #call -- ? )
     dup word>> \ <tuple-boa> eq? [
         last-literal tuple-layout?
     ] [ drop f ] if ;
 
-MEMO: (tuple-boa-expansion) ( n -- quot )
+MEMO: (tuple-boa-expansion) ( n -- nodes )
     [
-        [ 2 + ] map <reversed>
+        [ '[ _ (tuple) ] % ]
-        [ '[ [ _ set-slot ] keep ] % ] each
+        [
-    ] [ ] make ;
+            [ 2 + ] map <reversed>
+            [ '[ [ _ set-slot ] keep ] % ] each
+        ] bi
+    ] [ ] make '[ _ dip ] splice-final ;
 
 : tuple-boa-expansion ( layout -- quot )
     #! No memoization here since otherwise we'd hang on to
     #! tuple layout objects.
-    size>> (tuple-boa-expansion) \ (tuple) prefix splice-quot ;
+    size>> (tuple-boa-expansion)
+    [ over 1 set-slot ] splice-final append ;
 
 : expand-tuple-boa ( #call -- node )
     last-literal tuple-boa-expansion ;
@@ -65,14 +69,15 @@ MEMO: (tuple-boa-expansion) ( n -- quot )
 MEMO: <array>-expansion ( n -- quot )
     [
         [ swap (array) ] %
-        [ \ 2dup , , [ swap set-array-nth ] % ] each
+        [ '[ _ over 1 set-slot ] % ]
+        [ [ '[ 2dup _ swap set-array-nth ] % ] each ] bi
         \ nip ,
-    ] [ ] make splice-quot ;
+    ] [ ] make splice-final ;
 
 : expand-<array>? ( #call -- ? )
     dup word>> \ <array> eq? [
         first-literal dup integer?
-        [ 0 32 between? ] [ drop f ] if
+        [ 0 8 between? ] [ drop f ] if
     ] [ drop f ] if ;
 
 : expand-<array> ( #call -- node )
@@ -83,28 +88,62 @@ MEMO: <array>-expansion ( n -- quot )
 MEMO: <byte-array>-expansion ( n -- quot )
     [
         [ (byte-array) ] %
-        bytes>cells [ cell * ] map
+        [ '[ _ over 1 set-slot ] % ]
-        [ [ 0 over ] % , [ set-alien-unsigned-cell ] % ] each
+        [
-    ] [ ] make splice-quot ;
+            bytes>cells [
+                cell *
+                '[ 0 over _ set-alien-unsigned-cell ] %
+            ] each
+        ] bi
+    ] [ ] make splice-final ;
 
 : expand-<byte-array>? ( #call -- ? )
     dup word>> \ <byte-array> eq? [
         first-literal dup integer?
-        [ 0 128 between? ] [ drop f ] if
+        [ 0 32 between? ] [ drop f ] if
     ] [ drop f ] if ;
 
 : expand-<byte-array> ( #call -- nodes )
     first-literal <byte-array>-expansion ;
 
+MEMO: <ratio>-expansion ( -- quot )
+    [ (ratio) [ 1 set-slot ] keep [ 2 set-slot ] keep ] splice-final ;
+
+: expand-<ratio> ( #call -- nodes )
+    drop <ratio>-expansion ;
+
+MEMO: <complex>-expansion ( -- quot )
+    [ (complex) [ 1 set-slot ] keep [ 2 set-slot ] keep ] splice-final ;
+
+: expand-<complex> ( #call -- nodes )
+    drop <complex>-expansion ;
+
+MEMO: <wrapper>-expansion ( -- quot )
+    [ (wrapper) [ 1 set-slot ] keep ] splice-final ;
+
+: expand-<wrapper> ( #call -- nodes )
+    drop <wrapper>-expansion ;
+
+: expand-set-slot ( #call -- nodes )
+    dup in-d>> first node-value-info class>> immediate class<=
+    [ (set-slot) ] [ over >r (set-slot) r> (write-barrier) ] ?
+    splice-final ;
+
 M: #call finalize*
     {
         { [ dup builtin-predicate? ] [ expand-builtin-predicate ] }
         { [ dup expand-tuple-boa? ] [ expand-tuple-boa ] }
         { [ dup expand-<array>? ] [ expand-<array> ] }
         { [ dup expand-<byte-array>? ] [ expand-<byte-array> ] }
-        [ ]
+        [
+            dup word>> {
+                { \ <ratio> [ expand-<ratio> ] }
+                { \ <complex> [ expand-<complex> ] }
+                { \ <wrapper> [ expand-<wrapper> ] }
+                { \ set-slot [ expand-set-slot ] }
+                [ drop ]
+            } case
+        ]
     } cond ;
 
 M: node finalize* ;
-
-: finalize ( nodes -- nodes' ) [ finalize* ] map-nodes ;

basis/cpu/architecture/architecture.factor

@@ -63,7 +63,7 @@ HOOK: %jump-f cpu ( label vreg -- )
 ! Test if vreg is 't' or not
 HOOK: %jump-t cpu ( label vreg -- )
 
-HOOK: %dispatch cpu ( -- )
+HOOK: %dispatch cpu ( src temp -- )
 
 HOOK: %dispatch-label cpu ( word -- )
 

basis/cpu/x86/architecture/architecture.factor

@@ -69,9 +69,9 @@ M: x86 stack-frame-size ( n -- i )
 
 M: x86 %prologue ( n -- )
     temp-reg-1 0 MOV rc-absolute-cell rel-this
-    dup cell + PUSH
+    dup PUSH
     temp-reg-1 PUSH
-    stack-reg swap 2 cells - SUB ;
+    stack-reg swap 3 cells - SUB ;
 
 : incr-stack-reg ( n -- )
     dup 0 = [ drop ] [ stack-reg swap ADD ] if ;

basis/stack-checker/branches/branches.factor

@@ -78,21 +78,23 @@ SYMBOL: quotations
     V{ } clone meta-r set
     d-in [ ] change ;
 
-: infer-branch ( literal -- namespace )
+: infer-branch ( literal quot -- namespace )
     [
         copy-inference
         nest-visitor
-        [ value>> quotation set ] [ infer-literal-quot ] bi
+        [ [ value>> quotation set ] [ infer-literal-quot ] bi ] dip
         check->r
+        call
     ] H{ } make-assoc ; inline
 
-: infer-branches ( branches -- input children data )
+: infer-branches ( branches quot -- input children data )
-    [ pop-d ] dip
+    [ pop-d ] 2dip
-    [ infer-branch ] map
+    [ infer-branch ] curry map
-    [ stack-visitor branch-variable ] keep ;
+    [ stack-visitor branch-variable ] keep ; inline
 
 : (infer-if) ( branches -- )
-    infer-branches [ first2 #if, ] dip compute-phi-function ;
+    [ ] infer-branches
+    [ first2 #if, ] dip compute-phi-function ;
 
 : infer-if ( -- )
     2 consume-d
@@ -106,4 +108,5 @@ SYMBOL: quotations
 
 : infer-dispatch ( -- )
     pop-literal nip [ <literal> ] map
-    infer-branches [ #dispatch, ] dip compute-phi-function ;
+    [ f #return, ] infer-branches
+    [ #dispatch, ] dip compute-phi-function ;