-USING: generalizations accessors arrays compiler 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 ;
+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 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
[ ] [
[
[ 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
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
] 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
{ float } declare dup 0 =
[ drop 1 ] [
dup 0 >=
- [ 2 "double" "libm" "pow" { "double" "double" } alien-invoke ]
- [ -0.5 "double" "libm" "pow" { "double" "double" } alien-invoke ]
+ [ 2 double "libm" "pow" { double double } alien-invoke ]
+ [ -0.5 double "libm" "pow" { double double } alien-invoke ]
if
] if ;
[ 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
! 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
[ "0.169967142900241" "0.9854497299884601" ] [ 1.4 [ [ fcos ] [ fsin ] bi ] compile-call [ number>string ] bi@ ] unit-test
[ 1 "0.169967142900241" "0.9854497299884601" ] [ 1.4 1 [ swap >float [ fcos ] [ fsin ] bi ] compile-call [ number>string ] bi@ ] unit-test
-[ 6.0 ] [ 1.0 [ >float 3.0 + [ B{ 0 0 0 0 } 0 set-alien-float ] [ 2.0 + ] bi ] compile-call ] unit-test
\ No newline at end of file
+[ 6.0 ] [ 1.0 [ >float 3.0 + [ B{ 0 0 0 0 } 0 set-alien-float ] [ 2.0 + ] bi ] compile-call ] unit-test
+
+! Bug in linearization
+[ 283686952174081 ] [
+ B{ 1 1 1 1 } [
+ { byte-array } declare
+ [ 0 2 ] dip
+ [
+ [ drop ] 2dip
+ [
+ swap 1 < [ [ ] dip ] [ [ ] dip ] if
+ 0 alien-signed-4
+ ] curry dup bi *
+ ] curry each-integer
+ ] compile-call
+] unit-test
+
+! Bug in CSSA construction
+TUPLE: myseq { underlying1 byte-array read-only } { underlying2 byte-array read-only } ;
+
+[ 2 ] [
+ little-endian?
+ T{ myseq f B{ 1 0 0 0 } B{ 1 0 0 0 } }
+ T{ myseq f B{ 0 0 0 1 } B{ 0 0 0 1 } } ?
+ [
+ { myseq } declare
+ [ 0 2 ] dip dup
+ [
+ [
+ over 1 < [ underlying1>> ] [ [ 1 - ] dip underlying2>> ] if
+ swap 4 * >fixnum alien-signed-4
+ ] bi-curry@ bi * +
+ ] 2curry each-integer
+ ] compile-call
+] unit-test
+
+! Bug in linear scan's partial sync point logic
+[ t ] [
+ [ 1.0 100 [ fsin ] times 1.0 float+ ] compile-call
+ 1.168852488727981 1.e-9 ~
+] unit-test
+
+[ 65537.0 ] [
+ [ 2.0 4 [ 2.0 fpow ] times 1.0 float+ ] compile-call
+] unit-test
+
+! ##box-displaced-alien is a def-is-use instruction
+[ ALIEN: 3e9 ] [
+ [
+ f
+ 100 [ 10 swap <displaced-alien> ] times
+ 1 swap <displaced-alien>
+ ] compile-call
+] unit-test
+
+! Forgot to two-operand shifts
+[ 2 0 ] [
+ 1 1
+ [ [ 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
projects / factor.git / blobdiff