use radix literals

[factor.git] / basis / compiler / tests / codegen.factor

diff --git a/basis/compiler/tests/codegen.factor b/basis/compiler/tests/codegen.factor
index 18f3a618f69116502b891e6a19bd27f147591e46..3fe62936368185f023fb24f2fb08d916971c4c56 100644 (file)
--- a/basis/compiler/tests/codegen.factor
+++ b/basis/compiler/tests/codegen.factor
@@ -1,10 +1,11 @@
-USING: generalizations accessors arrays compiler kernel
+USING: generalizations accessors arrays compiler.test kernel
 kernel.private math hashtables.private math.private namespaces
 sequences tools.test namespaces.private slots.private
 sequences.private byte-arrays alien alien.accessors layouts
 words definitions compiler.units io combinators vectors grouping
-make alien.c-types combinators.short-circuit math.order
-math.libm math.parser math.functions alien.syntax ;
+make alien.c-types alien.data combinators.short-circuit math.order
+math.libm math.parser math.functions alien.syntax memory
+stack-checker ;
 FROM: math => float ;
 QUALIFIED: namespaces.private
 IN: compiler.tests.codegen
@@ -105,7 +106,7 @@ unit-test
 [ ] [
     [
         [ 200 dup [ 200 3array ] curry map drop ] times
-    ] [ (( n -- )) define-temp ] with-compilation-unit drop
+    ] [ ( n -- ) define-temp ] with-compilation-unit drop
 ] unit-test
 
 ! Test how dispatch handles the end of a basic block
@@ -116,7 +117,7 @@ unit-test
     1 1.0 2.5 try-breaking-dispatch "bye" = [ 3.5 = ] dip and ;
 
 [ t ] [
-    10000000 [ drop try-breaking-dispatch-2 ] all?
+    10000000 [ drop try-breaking-dispatch-2 ] all-integers?
 ] unit-test
 
 ! Regression
@@ -175,20 +176,6 @@ TUPLE: my-tuple ;
     ] compile-call
 ] unit-test
 
-[ 1 t ] [
-    B{ 1 2 3 4 } [
-        { c-ptr } declare
-        [ 0 alien-unsigned-1 ] keep hi-tag
-    ] compile-call byte-array type-number =
-] unit-test
-
-[ t ] [
-    B{ 1 2 3 4 } [
-        { c-ptr } declare
-        0 alien-cell hi-tag
-    ] compile-call alien type-number =
-] unit-test
-
 [ 2 1 ] [
     2 1
     [ 2dup fixnum< [ [ die ] dip ] when ] compile-call
@@ -288,7 +275,8 @@ M: cucumber equal? "The cucumber has no equal" throw ;
 
 [ 4294967295 B{ 255 255 255 255 } -1 ]
 [
-    -1 <int> -1 <int>
+    -1 int <ref>
+    -1 int <ref>
     [ [ 0 alien-unsigned-4 swap ] [ 0 alien-signed-2 ] bi ]
     compile-call
 ] unit-test
@@ -328,7 +316,7 @@ cell 4 = [
 
 ! Bug with ##return node construction
 : return-recursive-bug ( nodes -- ? )
-    { fixnum } declare [
+    { fixnum } declare iota [
         dup 3 bitand 1 = [ drop t ] [
             dup 3 bitand 2 = [
                 return-recursive-bug
@@ -474,5 +462,65 @@ TUPLE: myseq { underlying1 byte-array read-only } { underlying2 byte-array read-
 ! Forgot to two-operand shifts
 [ 2 0 ] [
     1 1
-    [ [ HEX: f bitand ] bi@ [ shift ] [ drop -3 shift ] 2bi ] compile-call
+    [ [ 0xf bitand ] bi@ [ shift ] [ drop -3 shift ] 2bi ] compile-call
 ] unit-test
+
+! Alias analysis bug
+[ t ] [
+    [
+        10 10 <byte-array> [ <displaced-alien> underlying>> ] keep eq?
+    ] compile-call
+] unit-test
+
+! GC root offsets were computed wrong on x86
+: gc-root-messup ( a -- b )
+    dup [
+        1024 (byte-array) 2array
+        10 void* "libc" "malloc" { ulong } alien-invoke
+        void "libc" "free" { void* } alien-invoke
+    ] when ;
+
+[ ] [ 2000 [ "hello" clone dup gc-root-messup first eq? t assert= ] times ] unit-test
+
+! Write barrier elimination was being done before scheduling and
+! GC check insertion, and didn't take subroutine calls into
+! account. Oops...
+: write-barrier-elim-in-wrong-place ( -- obj )
+    ! A callback used below
+    void { } cdecl [ compact-gc ] alien-callback
+    ! Allocate an object A in the nursery
+    1 f <array>
+    ! Subroutine call promotes the object to tenured
+    swap void { } cdecl alien-indirect
+    ! Allocate another object B in the nursery, store it into
+    ! the first
+    1 f <array> over set-first
+    ! Now object A's card should be marked and minor GC should
+    ! promote B to aging
+    minor-gc
+    ! Do stuff
+    [ 100 [ ] times ] infer.
+    ;
+
+[ { { f } } ] [ write-barrier-elim-in-wrong-place ] unit-test
+
+! GC maps must support derived pointers
+: (derived-pointer-test-1) ( -- byte-array )
+    2 <byte-array> ;
+
+: derived-pointer-test-1 ( -- byte-array )
+    ! A callback used below
+    void { } cdecl [ compact-gc ] alien-callback
+    ! Put the construction in a word since instruction selection
+    ! eliminates the untagged pointer entirely if the value is a
+    ! byte array
+    (derived-pointer-test-1) { c-ptr } declare
+    ! Store into an array, an untagged pointer to the payload
+    ! is now an available expression
+    123 over 0 set-alien-unsigned-1
+    ! GC, moving the array and derived pointer
+    swap void { } cdecl alien-indirect
+    ! Store into the array again
+    231 over 1 set-alien-unsigned-1 ;
+
+[ B{ 123 231 } ] [ derived-pointer-test-1 ] unit-test