Compiler fixes

basis/compiler/tests/alien.factor

@@ -0,0 +1,375 @@
+IN: compiler.tests
+USING: alien alien.c-types alien.syntax compiler kernel
+namespaces namespaces tools.test sequences inference words
+arrays parser quotations continuations inference.backend effects
+namespaces.private io io.streams.string memory system threads
+tools.test math ;
+
+FUNCTION: void ffi_test_0 ;
+[ ] [ ffi_test_0 ] unit-test
+
+FUNCTION: int ffi_test_1 ;
+[ 3 ] [ ffi_test_1 ] unit-test
+
+FUNCTION: int ffi_test_2 int x int y ;
+[ 5 ] [ 2 3 ffi_test_2 ] unit-test
+[ "hi" 3 ffi_test_2 ] must-fail
+
+FUNCTION: int ffi_test_3 int x int y int z int t ;
+[ 25 ] [ 2 3 4 5 ffi_test_3 ] unit-test
+
+FUNCTION: float ffi_test_4 ;
+[ 1.5 ] [ ffi_test_4 ] unit-test
+
+FUNCTION: double ffi_test_5 ;
+[ 1.5 ] [ ffi_test_5 ] unit-test
+
+FUNCTION: int ffi_test_9 int a int b int c int d int e int f int g ;
+[ 28 ] [ 1 2 3 4 5 6 7 ffi_test_9 ] unit-test
+[ "a" 2 3 4 5 6 7 ffi_test_9 ] must-fail
+[ 1 2 3 4 5 6 "a" ffi_test_9 ] must-fail
+
+C-STRUCT: foo
+    { "int" "x" }
+    { "int" "y" }
+;
+
+: make-foo ( x y -- foo )
+    "foo" <c-object> [ set-foo-y ] keep [ set-foo-x ] keep ;
+
+FUNCTION: int ffi_test_11 int a foo b int c ;
+
+[ 14 ] [ 1 2 3 make-foo 4 ffi_test_11 ] unit-test
+
+FUNCTION: int ffi_test_13 int a int b int c int d int e int f int g int h int i int j int k ;
+
+[ 66 ] [ 1 2 3 4 5 6 7 8 9 10 11 ffi_test_13 ] unit-test
+
+FUNCTION: foo ffi_test_14 int x int y ;
+
+[ 11 6 ] [ 11 6 ffi_test_14 dup foo-x swap foo-y ] unit-test
+
+FUNCTION: char* ffi_test_15 char* x char* y ;
+
+[ "foo" ] [ "xy" "zt" ffi_test_15 ] unit-test
+[ "bar" ] [ "xy" "xy" ffi_test_15 ] unit-test
+[ 1 2 ffi_test_15 ] must-fail
+
+C-STRUCT: bar
+    { "long" "x" }
+    { "long" "y" }
+    { "long" "z" }
+;
+
+FUNCTION: bar ffi_test_16 long x long y long z ;
+
+[ 11 6 -7 ] [
+    11 6 -7 ffi_test_16 dup bar-x over bar-y rot bar-z
+] unit-test
+
+C-STRUCT: tiny
+    { "int" "x" }
+;
+
+FUNCTION: tiny ffi_test_17 int x ;
+
+[ 11 ] [ 11 ffi_test_17 tiny-x ] unit-test
+
+[ [ alien-indirect ] infer ] [ inference-error? ] must-fail-with
+
+: indirect-test-1 ( ptr -- result )
+    "int" { } "cdecl" alien-indirect ;
+
+{ 1 1 } [ indirect-test-1 ] must-infer-as
+
+[ 3 ] [ "ffi_test_1" f dlsym indirect-test-1 ] unit-test
+
+[ -1 indirect-test-1 ] must-fail
+
+: indirect-test-2 ( x y ptr -- result )
+    "int" { "int" "int" } "cdecl" alien-indirect gc ;
+
+{ 3 1 } [ indirect-test-2 ] must-infer-as
+
+[ 5 ]
+[ 2 3 "ffi_test_2" f dlsym indirect-test-2 ]
+unit-test
+
+: indirect-test-3 ( a b c d ptr -- result )
+    "int" { "int" "int" "int" "int" } "stdcall" alien-indirect
+    gc ;
+
+<< "f-stdcall" f "stdcall" add-library >>
+
+[ f ] [ "f-stdcall" load-library ] unit-test
+[ "stdcall" ] [ "f-stdcall" library library-abi ] unit-test
+
+: ffi_test_18 ( w x y z -- int )
+    "int" "f-stdcall" "ffi_test_18" { "int" "int" "int" "int" }
+    alien-invoke gc ;
+
+[ 25 ] [ 2 3 4 5 ffi_test_18 ] unit-test
+
+: ffi_test_19 ( x y z -- bar )
+    "bar" "f-stdcall" "ffi_test_19" { "long" "long" "long" }
+    alien-invoke gc ;
+
+[ 11 6 -7 ] [
+    11 6 -7 ffi_test_19 dup bar-x over bar-y rot bar-z
+] unit-test
+
+FUNCTION: double ffi_test_6 float x float y ;
+[ 6.0 ] [ 3.0 2.0 ffi_test_6 ] unit-test
+[ "a" "b" ffi_test_6 ] must-fail
+
+FUNCTION: double ffi_test_7 double x double y ;
+[ 6.0 ] [ 3.0 2.0 ffi_test_7 ] unit-test
+
+FUNCTION: double ffi_test_8 double x float y double z float t int w ;
+[ 19.0 ] [ 3.0 2.0 1.0 6.0 7 ffi_test_8 ] unit-test
+
+FUNCTION: int ffi_test_10 int a int b double c int d float e int f int g int h ;
+[ -34 ] [ 1 2 3.0 4 5.0 6 7 8 ffi_test_10 ] unit-test
+
+FUNCTION: void ffi_test_20 double x1, double x2, double x3,
+    double y1, double y2, double y3,
+    double z1, double z2, double z3 ;
+
+[ ] [ 1.0 2.0 3.0 4.0 5.0 6.0 7.0 8.0 9.0 ffi_test_20 ] unit-test
+
+! Make sure XT doesn't get clobbered in stack frame
+
+: ffi_test_31 ( a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a ptr -- result y )
+    "void"
+    f "ffi_test_31"
+    { "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" }
+    alien-invoke gc 3 ;
+
+[ 3 ] [ 42 [ ] each ffi_test_31 ] unit-test
+
+FUNCTION: longlong ffi_test_21 long x long y ;
+
+[ 121932631112635269 ]
+[ 123456789 987654321 ffi_test_21 ] unit-test
+
+FUNCTION: long ffi_test_22 long x longlong y longlong z ;
+
+[ 987655432 ]
+[ 1111 121932631112635269 123456789 ffi_test_22 ] unit-test
+
+[ 1111 f 123456789 ffi_test_22 ] must-fail
+
+C-STRUCT: rect
+    { "float" "x" }
+    { "float" "y" }
+    { "float" "w" }
+    { "float" "h" }
+;
+
+: <rect>
+    "rect" <c-object>
+    [ set-rect-h ] keep
+    [ set-rect-w ] keep
+    [ set-rect-y ] keep
+    [ set-rect-x ] keep ;
+
+FUNCTION: int ffi_test_12 int a int b rect c int d int e int f ;
+
+[ 45 ] [ 1 2 3.0 4.0 5.0 6.0 <rect> 7 8 9 ffi_test_12 ] unit-test
+
+[ 1 2 { 1 2 3 } 7 8 9 ffi_test_12 ] must-fail
+
+FUNCTION: float ffi_test_23 ( float[3] x, float[3] y ) ;
+
+[ 32.0 ] [ { 1.0 2.0 3.0 } >c-float-array { 4.0 5.0 6.0 } >c-float-array ffi_test_23 ] unit-test
+
+! Test odd-size structs
+C-STRUCT: test-struct-1 { { "char" 1 } "x" } ;
+
+FUNCTION: test-struct-1 ffi_test_24 ;
+
+[ B{ 1 } ] [ ffi_test_24 ] unit-test
+
+C-STRUCT: test-struct-2 { { "char" 2 } "x" } ;
+
+FUNCTION: test-struct-2 ffi_test_25 ;
+
+[ B{ 1 2 } ] [ ffi_test_25 ] unit-test
+
+C-STRUCT: test-struct-3 { { "char" 3 } "x" } ;
+
+FUNCTION: test-struct-3 ffi_test_26 ;
+
+[ B{ 1 2 3 } ] [ ffi_test_26 ] unit-test
+
+C-STRUCT: test-struct-4 { { "char" 4 } "x" } ;
+
+FUNCTION: test-struct-4 ffi_test_27 ;
+
+[ B{ 1 2 3 4 } ] [ ffi_test_27 ] unit-test
+
+C-STRUCT: test-struct-5 { { "char" 5 } "x" } ;
+
+FUNCTION: test-struct-5 ffi_test_28 ;
+
+[ B{ 1 2 3 4 5 } ] [ ffi_test_28 ] unit-test
+
+C-STRUCT: test-struct-6 { { "char" 6 } "x" } ;
+
+FUNCTION: test-struct-6 ffi_test_29 ;
+
+[ B{ 1 2 3 4 5 6 } ] [ ffi_test_29 ] unit-test
+
+C-STRUCT: test-struct-7 { { "char" 7 } "x" } ;
+
+FUNCTION: test-struct-7 ffi_test_30 ;
+
+[ B{ 1 2 3 4 5 6 7 } ] [ ffi_test_30 ] unit-test
+
+C-STRUCT: test-struct-8 { "double" "x" } { "double" "y" } ;
+
+FUNCTION: double ffi_test_32 test-struct-8 x int y ;
+
+[ 9.0 ] [
+    "test-struct-8" <c-object>
+    1.0 over set-test-struct-8-x
+    2.0 over set-test-struct-8-y
+    3 ffi_test_32
+] unit-test
+
+C-STRUCT: test-struct-9 { "float" "x" } { "float" "y" } ;
+
+FUNCTION: double ffi_test_33 test-struct-9 x int y ;
+
+[ 9.0 ] [
+    "test-struct-9" <c-object>
+    1.0 over set-test-struct-9-x
+    2.0 over set-test-struct-9-y
+    3 ffi_test_33
+] unit-test
+
+C-STRUCT: test-struct-10 { "float" "x" } { "int" "y" } ;
+
+FUNCTION: double ffi_test_34 test-struct-10 x int y ;
+
+[ 9.0 ] [
+    "test-struct-10" <c-object>
+    1.0 over set-test-struct-10-x
+    2 over set-test-struct-10-y
+    3 ffi_test_34
+] unit-test
+
+C-STRUCT: test-struct-11 { "int" "x" } { "int" "y" } ;
+
+FUNCTION: double ffi_test_35 test-struct-11 x int y ;
+
+[ 9.0 ] [
+    "test-struct-11" <c-object>
+    1 over set-test-struct-11-x
+    2 over set-test-struct-11-y
+    3 ffi_test_35
+] unit-test
+
+C-STRUCT: test-struct-12 { "int" "a" } { "double" "x" } ;
+
+: make-struct-12
+    "test-struct-12" <c-object>
+    [ set-test-struct-12-x ] keep ;
+
+FUNCTION: double ffi_test_36 ( test-struct-12 x ) ;
+
+[ 1.23456 ] [ 1.23456 make-struct-12 ffi_test_36 ] unit-test
+
+FUNCTION: ulonglong ffi_test_38 ( ulonglong x, ulonglong y ) ;
+
+[ t ] [ 31 2^ 32 2^ ffi_test_38 63 2^ = ] unit-test
+
+! Test callbacks
+
+: callback-1 ( -- callback ) "void" { } "cdecl" [ ] alien-callback ;
+
+[ 0 1 ] [ [ callback-1 ] infer dup effect-in swap effect-out ] unit-test
+
+[ t ] [ callback-1 alien? ] unit-test
+
+: callback_test_1 ( ptr -- ) "void" { } "cdecl" alien-indirect ;
+
+[ ] [ callback-1 callback_test_1 ] unit-test
+
+: callback-2 ( -- callback ) "void" { } "cdecl" [ [ 5 throw ] ignore-errors ] alien-callback ;
+
+[ ] [ callback-2 callback_test_1 ] unit-test
+
+: callback-3 ( -- callback ) "void" { } "cdecl" [ 5 "x" set ] alien-callback ;
+
+[ t ] [
+    namestack*
+    3 "x" set callback-3 callback_test_1
+    namestack* eq?
+] unit-test
+
+[ 5 ] [
+    [
+        3 "x" set callback-3 callback_test_1 "x" get
+    ] with-scope
+] unit-test
+
+: callback-4 ( -- callback )
+    "void" { } "cdecl" [ "Hello world" write ] alien-callback
+    gc ;
+
+[ "Hello world" ] [
+    [ callback-4 callback_test_1 ] with-string-writer
+] unit-test
+
+: callback-5 ( -- callback )
+    "void" { } "cdecl" [ gc ] alien-callback ;
+
+[ "testing" ] [
+    "testing" callback-5 callback_test_1
+] unit-test
+
+: callback-5a ( -- callback )
+    "void" { } "cdecl" [ 8000000 f <array> drop ] alien-callback ;
+
+! Hack; if we're on ARM, we probably don't have much RAM, so
+! skip this test.
+! cpu "arm" = [
+!     [ "testing" ] [
+!         "testing" callback-5a callback_test_1
+!     ] unit-test
+! ] unless
+
+: callback-6 ( -- callback )
+    "void" { } "cdecl" [ [ continue ] callcc0 ] alien-callback ;
+
+[ 1 2 3 ] [ callback-6 callback_test_1 1 2 3 ] unit-test
+
+: callback-7 ( -- callback )
+    "void" { } "cdecl" [ 1000 sleep ] alien-callback ;
+
+[ 1 2 3 ] [ callback-7 callback_test_1 1 2 3 ] unit-test
+
+[ f ] [ namespace global eq? ] unit-test
+
+: callback-8 ( -- callback )
+    "void" { } "cdecl" [
+        [ continue ] callcc0
+    ] alien-callback ;
+
+[ ] [ callback-8 callback_test_1 ] unit-test
+
+: callback-9 ( -- callback )
+    "int" { "int" "int" "int" } "cdecl" [
+        + + 1+
+    ] alien-callback ;
+
+FUNCTION: void ffi_test_36_point_5 ( ) ;
+
+[ ] [ ffi_test_36_point_5 ] unit-test
+
+FUNCTION: int ffi_test_37 ( void* func ) ;
+
+[ 1 ] [ callback-9 ffi_test_37 ] unit-test
+
+[ 7 ] [ callback-9 ffi_test_37 ] unit-test

basis/compiler/tests/templates-early.factor

@@ -1,9 +1,9 @@
 ! Testing templates machinery without compiling anything
 IN: compiler.tests
 USING: compiler compiler.generator compiler.generator.registers
-generator.registers.private tools.test namespaces sequences
+compiler.generator.registers.private tools.test namespaces
-words kernel math effects definitions compiler.units accessors
+sequences words kernel math effects definitions compiler.units
-cpu.architecture ;
+accessors cpu.architecture ;
 
 : <int-vreg> ( n -- vreg ) int-regs <vreg> ;
 

basis/compiler/tree/cleanup/cleanup.factor

@@ -30,13 +30,10 @@ M: node delete-node drop ;
 
 GENERIC: cleanup* ( node -- node/nodes )
 
-: termination-cleanup ( nodes -- nodes' )
-    dup [ #terminate? ] find drop [ 1+ cut delete-nodes ] when* ;
-
 : cleanup ( nodes -- nodes' )
     #! We don't recurse into children here, instead the methods
     #! do it since the logic is a bit more involved
-    [ cleanup* ] map flatten ; ! termination-cleanup ;
+    [ cleanup* ] map flatten ;
 
 : cleanup-folding? ( #call -- ? )
     node-output-infos dup empty?
@@ -70,21 +67,11 @@ GENERIC: cleanup* ( node -- node/nodes )
 : remove-overflow-check ( #call -- #call )
     [ in-d>> ] [ out-d>> ] [ word>> no-overflow-variant ] tri #call cleanup* ;
 
-: immutable-tuple-boa? ( #call -- ? )
-    dup word>> \ <tuple-boa> eq? [
-        dup in-d>> peek node-value-info
-        literal>> class>> immutable-tuple-class?
-    ] [ drop f ] if ;
-
-: immutable-tuple-boa ( #call -- #call )
-    \ <immutable-tuple-boa> >>word ;
-
 M: #call cleanup*
     {
         { [ dup body>> ] [ cleanup-inlining ] }
         { [ dup cleanup-folding? ] [ cleanup-folding ] }
         { [ dup remove-overflow-check? ] [ remove-overflow-check ] }
-        { [ dup immutable-tuple-boa? ] [ immutable-tuple-boa ] }
         [ ]
     } cond ;
 

basis/compiler/tree/escape-analysis/escape-analysis-tests.factor

@@ -6,7 +6,8 @@ compiler.tree.propagation compiler.tree.cleanup
 compiler.tree.combinators compiler.tree sequences math math.private
 kernel tools.test accessors slots.private quotations.private
 prettyprint classes.tuple.private classes classes.tuple
-compiler.tree.intrinsics namespaces ;
+compiler.tree.intrinsics namespaces compiler.tree.propagation.info
+stack-checker.errors ;
 
 \ escape-analysis must-infer
 
@@ -16,7 +17,7 @@ GENERIC: count-unboxed-allocations* ( m node -- n )
     out-d>> first escaping-allocation? [ 1+ ] unless ;
 
 M: #call count-unboxed-allocations*
-    dup word>> { <immutable-tuple-boa> <complex> } memq?
+    dup [ immutable-tuple-boa? ] [ word>> \ <complex> eq? ] bi or
     [ (count-unboxed-allocations) ] [ drop ] if ;
 
 M: #push count-unboxed-allocations*
@@ -310,3 +311,8 @@ C: <ro-box> ro-box
     [ dup -1 over >= [ 0 >= [ "A" throw ] unless ] [ drop ] if ]
     count-unboxed-allocations
 ] unit-test
+
+[ 0 ] [
+    [ \ too-many->r boa f f \ inference-error boa ]
+    count-unboxed-allocations
+] unit-test

basis/compiler/tree/escape-analysis/recursive/recursive.factor

@@ -42,14 +42,13 @@ IN: compiler.tree.escape-analysis.recursive
     ] 2bi ;
 
 M: #recursive escape-analysis* ( #recursive -- )
-    { 0 } clone [ USE: math
+    [
-        dup first 10 = [ "OOPS" throw ] [ dup first 1+ swap set-first ] if
         child>>
         [ first out-d>> introduce-values ]
         [ first analyze-recursive-phi ]
         [ (escape-analysis) ]
         tri
-    ] curry until-fixed-point ;
+    ] until-fixed-point ;
 
 M: #enter-recursive escape-analysis* ( #enter-recursive -- )
     #! Handled by #recursive

basis/compiler/tree/escape-analysis/simple/simple.factor

@@ -40,8 +40,15 @@ M: #push escape-analysis*
     #! Delegation.
     [ out-d>> first ] [ literal>> ] bi record-literal-allocation ;
 
+: record-unknown-allocation ( #call -- )
+    [ in-d>> add-escaping-values ]
+    [ out-d>> unknown-allocations ] bi ;
+
 : record-tuple-allocation ( #call -- )
-    [ in-d>> but-last ] [ out-d>> first ] bi record-allocation ;
+    dup immutable-tuple-boa?
+    [ [ in-d>> but-last ] [ out-d>> first ] bi record-allocation ]
+    [ record-unknown-allocation ]
+    if ;
 
 : record-complex-allocation ( #call -- )
     [ in-d>> ] [ out-d>> first ] bi record-allocation ;
@@ -66,14 +73,10 @@ M: #push escape-analysis*
 
 M: #call escape-analysis*
     dup word>> {
-        { \ <immutable-tuple-boa> [ record-tuple-allocation ] }
+        { \ <tuple-boa> [ record-tuple-allocation ] }
         { \ <complex> [ record-complex-allocation ] }
         { \ slot [ record-slot-call ] }
-        [
+        [ drop record-unknown-allocation ]
-            drop
-            [ in-d>> add-escaping-values ]
-            [ out-d>> unknown-allocations ] bi
-        ]
     } case ;
 
 M: #return escape-analysis*

basis/compiler/tree/intrinsics/intrinsics.factor

@@ -4,8 +4,6 @@ USING: kernel classes.tuple classes.tuple.private math arrays
 byte-arrays words stack-checker.known-words ;
 IN: compiler.tree.intrinsics
 
-: <immutable-tuple-boa> ( ... class -- tuple ) <tuple-boa> ;
-
 : (tuple) ( layout -- tuple )
     "BUG: missing (tuple) intrinsic" throw ;
 

basis/compiler/tree/optimizer/optimizer.factor

@@ -26,4 +26,7 @@ IN: compiler.tree.optimizer
     compute-def-use
     remove-dead-code
     ! strength-reduce
+    USE: kernel
+    compute-def-use
+    dup check-nodes
     ;

basis/compiler/tree/propagation/info/info.factor

@@ -1,9 +1,9 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: assocs classes classes.algebra kernel
+USING: assocs classes classes.algebra classes.tuple
-accessors math math.intervals namespaces sequences words
+classes.tuple.private kernel accessors math math.intervals
-combinators combinators.short-circuit arrays
+namespaces sequences words combinators combinators.short-circuit
-compiler.tree.propagation.copy ;
+arrays compiler.tree.propagation.copy ;
 IN: compiler.tree.propagation.info
 
 : false-class? ( class -- ? ) \ f class<= ;
@@ -276,3 +276,9 @@ SYMBOL: value-infos
 
 : node-output-infos ( node -- seq )
     dup out-d>> [ node-value-info ] with map ;
+
+: immutable-tuple-boa? ( #call -- ? )
+    dup word>> \ <tuple-boa> eq? [
+        dup in-d>> peek node-value-info
+        literal>> class>> immutable-tuple-class?
+    ] [ drop f ] if ;

basis/compiler/tree/propagation/recursive/recursive.factor

@@ -52,8 +52,7 @@ IN: compiler.tree.propagation.recursive
     3bi ;
 
 M: #recursive propagate-around ( #recursive -- )
-    { 0 } clone [ USE: math
+    [
-        dup first 10 = [ "OOPS" throw ] [ dup first 1+ swap set-first ] if
         constraints [ clone ] change
 
         child>>
@@ -61,7 +60,7 @@ M: #recursive propagate-around ( #recursive -- )
         [ first propagate-recursive-phi ]
         [ (propagate) ]
         tri
-    ] curry until-fixed-point ;
+    ] until-fixed-point ;
 
 : generalize-return-interval ( info -- info' )
     dup [ literal?>> ] [ class>> null-class? ] bi or

basis/compiler/tree/tuple-unboxing/tuple-unboxing.factor

@@ -7,6 +7,7 @@ stack-checker.branches
 compiler.tree
 compiler.tree.intrinsics
 compiler.tree.combinators
+compiler.tree.propagation.info
 compiler.tree.escape-analysis.simple
 compiler.tree.escape-analysis.allocations ;
 IN: compiler.tree.tuple-unboxing
@@ -58,16 +59,12 @@ M: #push unbox-tuples* ( #push -- nodes )
 
 : unbox-slot-access ( #call -- nodes )
     dup out-d>> first unboxed-slot-access? [
-       !  [ in-d>> second 1array #drop ]
+        prepare-slot-access slot-access-shuffle
-       ! [
-    prepare-slot-access slot-access-shuffle
-    ! ]
-    !    bi 2array
     ] when ;
 
 M: #call unbox-tuples*
     dup word>> {
-        { \ <immutable-tuple-boa> [ unbox-<tuple-boa> ] }
+        { \ <tuple-boa> [ unbox-<tuple-boa> ] }
         { \ <complex> [ unbox-<complex> ] }
         { \ slot [ unbox-slot-access ] }
         [ drop ]