Compiler fixes
Slava Pestov
parent
86f11713e3
commit
9aa6d8ae04
|
|
@ -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
|
||||
|
|
@ -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
|
||||
words kernel math effects definitions compiler.units accessors
|
||||
cpu.architecture ;
|
||||
compiler.generator.registers.private tools.test namespaces
|
||||
sequences words kernel math effects definitions compiler.units
|
||||
accessors cpu.architecture ;
|
||||
|
||||
: <int-vreg> ( n -- vreg ) int-regs <vreg> ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
[ in-d>> add-escaping-values ]
|
||||
[ out-d>> unknown-allocations ] bi
|
||||
]
|
||||
[ drop record-unknown-allocation ]
|
||||
} case ;
|
||||
|
||||
M: #return escape-analysis*
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -26,4 +26,7 @@ IN: compiler.tree.optimizer
|
|||
compute-def-use
|
||||
remove-dead-code
|
||||
! strength-reduce
|
||||
USE: kernel
|
||||
compute-def-use
|
||||
dup check-nodes
|
||||
;
|
||||
|
|
|
|||
|
|
@ -1,9 +1,9 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: assocs classes classes.algebra kernel
|
||||
accessors math math.intervals namespaces sequences words
|
||||
combinators combinators.short-circuit arrays
|
||||
compiler.tree.propagation.copy ;
|
||||
USING: assocs classes classes.algebra classes.tuple
|
||||
classes.tuple.private kernel accessors math math.intervals
|
||||
namespaces sequences words combinators combinators.short-circuit
|
||||
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 ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
! ]
|
||||
! bi 2array
|
||||
prepare-slot-access slot-access-shuffle
|
||||
] 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 ]
|
||||
|
|
|
|||
Loading…
Reference in New Issue