New front-end and high-level optimizer lands
Slava Pestov
parent
d42edecffb
commit
f2a5a30c6f
|
|
@ -1,375 +0,0 @@
|
|||
IN: alien.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,417 +0,0 @@
|
|||
! Copyright (C) 2006, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays generator generator.registers generator.fixup
|
||||
hashtables kernel math namespaces sequences words
|
||||
inference.state inference.backend inference.dataflow system
|
||||
math.parser classes alien.arrays alien.c-types alien.strings
|
||||
alien.structs alien.syntax cpu.architecture alien summary
|
||||
quotations assocs kernel.private threads continuations.private
|
||||
libc combinators compiler.errors continuations layouts accessors
|
||||
init sets ;
|
||||
IN: alien.compiler
|
||||
|
||||
TUPLE: #alien-node < node return parameters abi ;
|
||||
|
||||
TUPLE: #alien-callback < #alien-node quot xt ;
|
||||
|
||||
TUPLE: #alien-indirect < #alien-node ;
|
||||
|
||||
TUPLE: #alien-invoke < #alien-node library function ;
|
||||
|
||||
: large-struct? ( ctype -- ? )
|
||||
dup c-struct? [
|
||||
heap-size struct-small-enough? not
|
||||
] [ drop f ] if ;
|
||||
|
||||
: alien-node-parameters* ( node -- seq )
|
||||
dup parameters>>
|
||||
swap return>> large-struct? [ "void*" prefix ] when ;
|
||||
|
||||
: alien-node-return* ( node -- ctype )
|
||||
return>> dup large-struct? [ drop "void" ] when ;
|
||||
|
||||
: c-type-stack-align ( type -- align )
|
||||
dup c-type-stack-align? [ c-type-align ] [ drop cell ] if ;
|
||||
|
||||
: parameter-align ( n type -- n delta )
|
||||
over >r c-type-stack-align align dup r> - ;
|
||||
|
||||
: parameter-sizes ( types -- total offsets )
|
||||
#! Compute stack frame locations.
|
||||
[
|
||||
0 [
|
||||
[ parameter-align drop dup , ] keep stack-size +
|
||||
] reduce cell align
|
||||
] { } make ;
|
||||
|
||||
: return-size ( ctype -- n )
|
||||
#! Amount of space we reserve for a return value.
|
||||
dup large-struct? [ heap-size ] [ drop 0 ] if ;
|
||||
|
||||
: alien-stack-frame ( node -- n )
|
||||
alien-node-parameters* parameter-sizes drop ;
|
||||
|
||||
: alien-invoke-frame ( node -- n )
|
||||
#! One cell is temporary storage, temp@
|
||||
dup return>> return-size
|
||||
swap alien-stack-frame +
|
||||
cell + ;
|
||||
|
||||
: set-stack-frame ( n -- )
|
||||
dup [ frame-required ] when* \ stack-frame set ;
|
||||
|
||||
: with-stack-frame ( n quot -- )
|
||||
swap set-stack-frame
|
||||
call
|
||||
f set-stack-frame ; inline
|
||||
|
||||
GENERIC: reg-size ( register-class -- n )
|
||||
|
||||
M: int-regs reg-size drop cell ;
|
||||
|
||||
M: single-float-regs reg-size drop 4 ;
|
||||
|
||||
M: double-float-regs reg-size drop 8 ;
|
||||
|
||||
GENERIC: reg-class-variable ( register-class -- symbol )
|
||||
|
||||
M: reg-class reg-class-variable ;
|
||||
|
||||
M: float-regs reg-class-variable drop float-regs ;
|
||||
|
||||
GENERIC: inc-reg-class ( register-class -- )
|
||||
|
||||
M: reg-class inc-reg-class
|
||||
dup reg-class-variable inc
|
||||
fp-shadows-int? [ reg-size stack-params +@ ] [ drop ] if ;
|
||||
|
||||
M: float-regs inc-reg-class
|
||||
dup call-next-method
|
||||
fp-shadows-int? [ reg-size cell /i int-regs +@ ] [ drop ] if ;
|
||||
|
||||
: reg-class-full? ( class -- ? )
|
||||
[ reg-class-variable get ] [ param-regs length ] bi >= ;
|
||||
|
||||
: spill-param ( reg-class -- n reg-class )
|
||||
stack-params get
|
||||
>r reg-size stack-params +@ r>
|
||||
stack-params ;
|
||||
|
||||
: fastcall-param ( reg-class -- n reg-class )
|
||||
[ reg-class-variable get ] [ inc-reg-class ] [ ] tri ;
|
||||
|
||||
: alloc-parameter ( parameter -- reg reg-class )
|
||||
c-type-reg-class dup reg-class-full?
|
||||
[ spill-param ] [ fastcall-param ] if
|
||||
[ param-reg ] keep ;
|
||||
|
||||
: (flatten-int-type) ( size -- )
|
||||
cell /i "void*" c-type <repetition> % ;
|
||||
|
||||
GENERIC: flatten-value-type ( type -- )
|
||||
|
||||
M: object flatten-value-type , ;
|
||||
|
||||
M: struct-type flatten-value-type ( type -- )
|
||||
stack-size cell align (flatten-int-type) ;
|
||||
|
||||
M: long-long-type flatten-value-type ( type -- )
|
||||
stack-size cell align (flatten-int-type) ;
|
||||
|
||||
: flatten-value-types ( params -- params )
|
||||
#! Convert value type structs to consecutive void*s.
|
||||
[
|
||||
0 [
|
||||
c-type
|
||||
[ parameter-align (flatten-int-type) ] keep
|
||||
[ stack-size cell align + ] keep
|
||||
flatten-value-type
|
||||
] reduce drop
|
||||
] { } make ;
|
||||
|
||||
: each-parameter ( parameters quot -- )
|
||||
>r [ parameter-sizes nip ] keep r> 2each ; inline
|
||||
|
||||
: reverse-each-parameter ( parameters quot -- )
|
||||
>r [ parameter-sizes nip ] keep r> 2reverse-each ; inline
|
||||
|
||||
: reset-freg-counts ( -- )
|
||||
{ int-regs float-regs stack-params } [ 0 swap set ] each ;
|
||||
|
||||
: with-param-regs ( quot -- )
|
||||
#! In quot you can call alloc-parameter
|
||||
[ reset-freg-counts call ] with-scope ; inline
|
||||
|
||||
: move-parameters ( node word -- )
|
||||
#! Moves values from C stack to registers (if word is
|
||||
#! %load-param-reg) and registers to C stack (if word is
|
||||
#! %save-param-reg).
|
||||
>r
|
||||
alien-node-parameters*
|
||||
flatten-value-types
|
||||
r> [ >r alloc-parameter r> execute ] curry each-parameter ;
|
||||
inline
|
||||
|
||||
: if-void ( type true false -- )
|
||||
pick "void" = [ drop nip call ] [ nip call ] if ; inline
|
||||
|
||||
: alien-invoke-stack ( node extra -- )
|
||||
over parameters>> length + dup reify-curries
|
||||
over consume-values
|
||||
dup return>> "void" = 0 1 ?
|
||||
swap produce-values ;
|
||||
|
||||
: param-prep-quot ( node -- quot )
|
||||
parameters>> [ c-type c-type-unboxer-quot ] map spread>quot ;
|
||||
|
||||
: unbox-parameters ( offset node -- )
|
||||
parameters>> [
|
||||
%prepare-unbox >r over + r> unbox-parameter
|
||||
] reverse-each-parameter drop ;
|
||||
|
||||
: prepare-box-struct ( node -- offset )
|
||||
#! Return offset on C stack where to store unboxed
|
||||
#! parameters. If the C function is returning a structure,
|
||||
#! the first parameter is an implicit target area pointer,
|
||||
#! so we need to use a different offset.
|
||||
return>> dup large-struct?
|
||||
[ heap-size %prepare-box-struct cell ] [ drop 0 ] if ;
|
||||
|
||||
: objects>registers ( node -- )
|
||||
#! Generate code for unboxing a list of C types, then
|
||||
#! generate code for moving these parameters to register on
|
||||
#! architectures where parameters are passed in registers.
|
||||
[
|
||||
[ prepare-box-struct ] keep
|
||||
[ unbox-parameters ] keep
|
||||
\ %load-param-reg move-parameters
|
||||
] with-param-regs ;
|
||||
|
||||
: box-return* ( node -- )
|
||||
return>> [ ] [ box-return ] if-void ;
|
||||
|
||||
: callback-prep-quot ( node -- quot )
|
||||
parameters>> [ c-type c-type-boxer-quot ] map spread>quot ;
|
||||
|
||||
: return-prep-quot ( node -- quot )
|
||||
return>> [ [ ] ] [ c-type c-type-boxer-quot ] if-void ;
|
||||
|
||||
M: alien-invoke-error summary
|
||||
drop
|
||||
"Words calling ``alien-invoke'' must be compiled with the optimizing compiler." ;
|
||||
|
||||
: pop-parameters ( -- seq )
|
||||
pop-literal nip [ expand-constants ] map ;
|
||||
|
||||
: stdcall-mangle ( symbol node -- symbol )
|
||||
"@"
|
||||
swap parameters>> parameter-sizes drop
|
||||
number>string 3append ;
|
||||
|
||||
TUPLE: no-such-library name ;
|
||||
|
||||
M: no-such-library summary
|
||||
drop "Library not found" ;
|
||||
|
||||
M: no-such-library compiler-error-type
|
||||
drop +linkage+ ;
|
||||
|
||||
: no-such-library ( name -- )
|
||||
\ no-such-library boa
|
||||
compiling-word get compiler-error ;
|
||||
|
||||
TUPLE: no-such-symbol name ;
|
||||
|
||||
M: no-such-symbol summary
|
||||
drop "Symbol not found" ;
|
||||
|
||||
M: no-such-symbol compiler-error-type
|
||||
drop +linkage+ ;
|
||||
|
||||
: no-such-symbol ( name -- )
|
||||
\ no-such-symbol boa
|
||||
compiling-word get compiler-error ;
|
||||
|
||||
: check-dlsym ( symbols dll -- )
|
||||
dup dll-valid? [
|
||||
dupd [ dlsym ] curry contains?
|
||||
[ drop ] [ no-such-symbol ] if
|
||||
] [
|
||||
dll-path no-such-library drop
|
||||
] if ;
|
||||
|
||||
: alien-invoke-dlsym ( node -- symbols dll )
|
||||
dup function>> dup pick stdcall-mangle 2array
|
||||
swap library>> library dup [ dll>> ] when
|
||||
2dup check-dlsym ;
|
||||
|
||||
\ alien-invoke [
|
||||
! Four literals
|
||||
4 ensure-values
|
||||
#alien-invoke new
|
||||
! Compile-time parameters
|
||||
pop-parameters >>parameters
|
||||
pop-literal nip >>function
|
||||
pop-literal nip >>library
|
||||
pop-literal nip >>return
|
||||
! Quotation which coerces parameters to required types
|
||||
dup param-prep-quot recursive-state get infer-quot
|
||||
! Set ABI
|
||||
dup library>> library [ abi>> ] [ "cdecl" ] if* >>abi
|
||||
! Add node to IR
|
||||
dup node,
|
||||
! Magic #: consume exactly the number of inputs
|
||||
dup 0 alien-invoke-stack
|
||||
! Quotation which coerces return value to required type
|
||||
return-prep-quot recursive-state get infer-quot
|
||||
] "infer" set-word-prop
|
||||
|
||||
M: #alien-invoke generate-node
|
||||
dup alien-invoke-frame [
|
||||
end-basic-block
|
||||
%prepare-alien-invoke
|
||||
dup objects>registers
|
||||
%prepare-var-args
|
||||
dup alien-invoke-dlsym %alien-invoke
|
||||
dup %cleanup
|
||||
box-return*
|
||||
iterate-next
|
||||
] with-stack-frame ;
|
||||
|
||||
M: alien-indirect-error summary
|
||||
drop "Words calling ``alien-indirect'' must be compiled with the optimizing compiler." ;
|
||||
|
||||
\ alien-indirect [
|
||||
! Three literals and function pointer
|
||||
4 ensure-values
|
||||
4 reify-curries
|
||||
#alien-indirect new
|
||||
! Compile-time parameters
|
||||
pop-literal nip >>abi
|
||||
pop-parameters >>parameters
|
||||
pop-literal nip >>return
|
||||
! Quotation which coerces parameters to required types
|
||||
dup param-prep-quot [ dip ] curry recursive-state get infer-quot
|
||||
! Add node to IR
|
||||
dup node,
|
||||
! Magic #: consume the function pointer, too
|
||||
dup 1 alien-invoke-stack
|
||||
! Quotation which coerces return value to required type
|
||||
return-prep-quot recursive-state get infer-quot
|
||||
] "infer" set-word-prop
|
||||
|
||||
M: #alien-indirect generate-node
|
||||
dup alien-invoke-frame [
|
||||
! Flush registers
|
||||
end-basic-block
|
||||
! Save registers for GC
|
||||
%prepare-alien-invoke
|
||||
! Save alien at top of stack to temporary storage
|
||||
%prepare-alien-indirect
|
||||
dup objects>registers
|
||||
%prepare-var-args
|
||||
! Call alien in temporary storage
|
||||
%alien-indirect
|
||||
dup %cleanup
|
||||
box-return*
|
||||
iterate-next
|
||||
] with-stack-frame ;
|
||||
|
||||
! Callbacks are registered in a global hashtable. If you clear
|
||||
! this hashtable, they will all be blown away by code GC, beware
|
||||
SYMBOL: callbacks
|
||||
|
||||
[ H{ } clone callbacks set-global ] "alien.compiler" add-init-hook
|
||||
|
||||
: register-callback ( word -- ) callbacks get conjoin ;
|
||||
|
||||
M: alien-callback-error summary
|
||||
drop "Words calling ``alien-callback'' must be compiled with the optimizing compiler." ;
|
||||
|
||||
: callback-bottom ( node -- )
|
||||
xt>> [ [ register-callback ] [ word-xt drop <alien> ] bi ] curry
|
||||
recursive-state get infer-quot ;
|
||||
|
||||
\ alien-callback [
|
||||
4 ensure-values
|
||||
#alien-callback new dup node,
|
||||
pop-literal nip >>quot
|
||||
pop-literal nip >>abi
|
||||
pop-parameters >>parameters
|
||||
pop-literal nip >>return
|
||||
gensym >>xt
|
||||
callback-bottom
|
||||
] "infer" set-word-prop
|
||||
|
||||
: box-parameters ( node -- )
|
||||
alien-node-parameters* [ box-parameter ] each-parameter ;
|
||||
|
||||
: registers>objects ( node -- )
|
||||
[
|
||||
dup \ %save-param-reg move-parameters
|
||||
"nest_stacks" f %alien-invoke
|
||||
box-parameters
|
||||
] with-param-regs ;
|
||||
|
||||
TUPLE: callback-context ;
|
||||
|
||||
: current-callback 2 getenv ;
|
||||
|
||||
: wait-to-return ( token -- )
|
||||
dup current-callback eq? [
|
||||
drop
|
||||
] [
|
||||
yield wait-to-return
|
||||
] if ;
|
||||
|
||||
: do-callback ( quot token -- )
|
||||
init-catchstack
|
||||
dup 2 setenv
|
||||
slip
|
||||
wait-to-return ; inline
|
||||
|
||||
: callback-return-quot ( ctype -- quot )
|
||||
return>> {
|
||||
{ [ dup "void" = ] [ drop [ ] ] }
|
||||
{ [ dup large-struct? ] [ heap-size [ memcpy ] curry ] }
|
||||
[ c-type c-type-unboxer-quot ]
|
||||
} cond ;
|
||||
|
||||
: wrap-callback-quot ( node -- quot )
|
||||
[
|
||||
[ callback-prep-quot ]
|
||||
[ quot>> ]
|
||||
[ callback-return-quot ] tri 3append ,
|
||||
[ callback-context new do-callback ] %
|
||||
] [ ] make ;
|
||||
|
||||
: %unnest-stacks ( -- ) "unnest_stacks" f %alien-invoke ;
|
||||
|
||||
: callback-unwind ( node -- n )
|
||||
{
|
||||
{ [ dup abi>> "stdcall" = ] [ alien-stack-frame ] }
|
||||
{ [ dup return>> large-struct? ] [ drop 4 ] }
|
||||
[ drop 0 ]
|
||||
} cond ;
|
||||
|
||||
: %callback-return ( node -- )
|
||||
#! All the extra book-keeping for %unwind is only for x86.
|
||||
#! On other platforms its an alias for %return.
|
||||
dup alien-node-return*
|
||||
[ %unnest-stacks ] [ %callback-value ] if-void
|
||||
callback-unwind %unwind ;
|
||||
|
||||
: generate-callback ( node -- )
|
||||
dup xt>> dup [
|
||||
init-templates
|
||||
%prologue-later
|
||||
dup alien-stack-frame [
|
||||
[ registers>objects ]
|
||||
[ wrap-callback-quot %alien-callback ]
|
||||
[ %callback-return ]
|
||||
tri
|
||||
] with-stack-frame
|
||||
] with-generator ;
|
||||
|
||||
M: #alien-callback generate-node
|
||||
end-basic-block generate-callback iterate-next ;
|
||||
|
|
@ -1 +0,0 @@
|
|||
C library interface implementation
|
||||
|
|
@ -1,16 +0,0 @@
|
|||
USING: help.syntax help.markup math kernel
|
||||
words strings alien ;
|
||||
IN: generator.fixup
|
||||
|
||||
HELP: frame-required
|
||||
{ $values { "n" "a non-negative integer" } }
|
||||
{ $description "Notify the code generator that the currently compiling code block needs a stack frame with room for at least " { $snippet "n" } " parameters." } ;
|
||||
|
||||
HELP: add-literal
|
||||
{ $values { "obj" object } { "n" integer } }
|
||||
{ $description "Adds a literal to the " { $link literal-table } ", if it is not already there, and outputs the index of the literal in the table. This literal can then be used as an argument for a " { $link rt-literal } " relocation with " { $link rel-fixup } "." } ;
|
||||
|
||||
HELP: rel-dlsym
|
||||
{ $values { "name" string } { "dll" "a " { $link dll } " or " { $link f } } { "class" "a relocation class" } }
|
||||
{ $description "Records that the most recently assembled instruction contains a reference to the " { $snippet "name" } " symbol from " { $snippet "dll" } ". The correct " { $snippet "class" } " to use depends on instruction formats."
|
||||
} ;
|
||||
|
|
@ -1,154 +0,0 @@
|
|||
! Copyright (C) 2007, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays byte-arrays generic assocs hashtables io.binary
|
||||
kernel kernel.private math namespaces sequences words
|
||||
quotations strings alien.accessors alien.strings layouts system
|
||||
combinators math.bitfields words.private cpu.architecture
|
||||
math.order accessors growable ;
|
||||
IN: generator.fixup
|
||||
|
||||
: no-stack-frame -1 ; inline
|
||||
|
||||
TUPLE: frame-required n ;
|
||||
|
||||
: frame-required ( n -- ) \ frame-required boa , ;
|
||||
|
||||
: stack-frame-size ( code -- n )
|
||||
no-stack-frame [
|
||||
dup frame-required? [ frame-required-n max ] [ drop ] if
|
||||
] reduce ;
|
||||
|
||||
GENERIC: fixup* ( frame-size obj -- frame-size )
|
||||
|
||||
: code-format 22 getenv ;
|
||||
|
||||
: compiled-offset ( -- n ) building get length code-format * ;
|
||||
|
||||
TUPLE: label offset ;
|
||||
|
||||
: <label> ( -- label ) label new ;
|
||||
|
||||
M: label fixup*
|
||||
compiled-offset swap set-label-offset ;
|
||||
|
||||
: define-label ( name -- ) <label> swap set ;
|
||||
|
||||
: resolve-label ( label/name -- ) dup label? [ get ] unless , ;
|
||||
|
||||
: if-stack-frame ( frame-size quot -- )
|
||||
swap dup no-stack-frame =
|
||||
[ 2drop ] [ stack-frame swap call ] if ; inline
|
||||
|
||||
M: word fixup*
|
||||
{
|
||||
{ \ %prologue-later [ dup [ %prologue ] if-stack-frame ] }
|
||||
{ \ %epilogue-later [ dup [ %epilogue ] if-stack-frame ] }
|
||||
} case ;
|
||||
|
||||
SYMBOL: relocation-table
|
||||
SYMBOL: label-table
|
||||
|
||||
! Relocation classes
|
||||
: rc-absolute-cell 0 ;
|
||||
: rc-absolute 1 ;
|
||||
: rc-relative 2 ;
|
||||
: rc-absolute-ppc-2/2 3 ;
|
||||
: rc-relative-ppc-2 4 ;
|
||||
: rc-relative-ppc-3 5 ;
|
||||
: rc-relative-arm-3 6 ;
|
||||
: rc-indirect-arm 7 ;
|
||||
: rc-indirect-arm-pc 8 ;
|
||||
|
||||
: rc-absolute? ( n -- ? )
|
||||
dup rc-absolute-cell =
|
||||
over rc-absolute =
|
||||
rot rc-absolute-ppc-2/2 = or or ;
|
||||
|
||||
! Relocation types
|
||||
: rt-primitive 0 ;
|
||||
: rt-dlsym 1 ;
|
||||
: rt-literal 2 ;
|
||||
: rt-dispatch 3 ;
|
||||
: rt-xt 4 ;
|
||||
: rt-here 5 ;
|
||||
: rt-label 6 ;
|
||||
: rt-immediate 7 ;
|
||||
|
||||
TUPLE: label-fixup label class ;
|
||||
|
||||
: label-fixup ( label class -- ) \ label-fixup boa , ;
|
||||
|
||||
M: label-fixup fixup*
|
||||
dup class>> rc-absolute?
|
||||
[ "Absolute labels not supported" throw ] when
|
||||
dup label>> swap class>> compiled-offset 4 - rot
|
||||
3array label-table get push ;
|
||||
|
||||
TUPLE: rel-fixup arg class type ;
|
||||
|
||||
: rel-fixup ( arg class type -- ) \ rel-fixup boa , ;
|
||||
|
||||
: push-4 ( value vector -- )
|
||||
[ length ] [ B{ 0 0 0 0 } swap push-all ] [ underlying>> ] tri
|
||||
swap set-alien-unsigned-4 ;
|
||||
|
||||
M: rel-fixup fixup*
|
||||
[ [ arg>> ] [ class>> ] [ type>> ] tri { 0 8 16 } bitfield ]
|
||||
[ class>> rc-absolute-cell = cell 4 ? compiled-offset swap - ] bi
|
||||
[ relocation-table get push-4 ] bi@ ;
|
||||
|
||||
M: frame-required fixup* drop ;
|
||||
|
||||
M: integer fixup* , ;
|
||||
|
||||
: adjoin* ( obj table -- n )
|
||||
2dup swap [ eq? ] curry find drop
|
||||
[ 2nip ] [ dup length >r push r> ] if* ;
|
||||
|
||||
SYMBOL: literal-table
|
||||
|
||||
: add-literal ( obj -- n ) literal-table get adjoin* ;
|
||||
|
||||
: add-dlsym-literals ( symbol dll -- )
|
||||
>r string>symbol r> 2array literal-table get push-all ;
|
||||
|
||||
: rel-dlsym ( name dll class -- )
|
||||
>r literal-table get length >r
|
||||
add-dlsym-literals
|
||||
r> r> rt-dlsym rel-fixup ;
|
||||
|
||||
: rel-word ( word class -- )
|
||||
>r add-literal r> rt-xt rel-fixup ;
|
||||
|
||||
: rel-primitive ( word class -- )
|
||||
>r def>> first r> rt-primitive rel-fixup ;
|
||||
|
||||
: rel-literal ( literal class -- )
|
||||
>r add-literal r> rt-literal rel-fixup ;
|
||||
|
||||
: rel-this ( class -- )
|
||||
0 swap rt-label rel-fixup ;
|
||||
|
||||
: rel-here ( class -- )
|
||||
0 swap rt-here rel-fixup ;
|
||||
|
||||
: init-fixup ( -- )
|
||||
BV{ } clone relocation-table set
|
||||
V{ } clone label-table set ;
|
||||
|
||||
: resolve-labels ( labels -- labels' )
|
||||
[
|
||||
first3 label-offset
|
||||
[ "Unresolved label" throw ] unless*
|
||||
3array
|
||||
] map concat ;
|
||||
|
||||
: fixup ( code -- literals relocation labels code )
|
||||
[
|
||||
init-fixup
|
||||
dup stack-frame-size swap [ fixup* ] each drop
|
||||
|
||||
literal-table get >array
|
||||
relocation-table get >byte-array
|
||||
label-table get resolve-labels
|
||||
] { } make ;
|
||||
|
|
@ -1,92 +0,0 @@
|
|||
USING: help.markup help.syntax words debugger generator.fixup
|
||||
generator.registers quotations kernel vectors arrays effects
|
||||
sequences ;
|
||||
IN: generator
|
||||
|
||||
ARTICLE: "generator" "Compiled code generator"
|
||||
"Most of the words in the " { $vocab-link "generator" } " vocabulary are internal to the compiler and user code has no reason to call them."
|
||||
$nl
|
||||
"Debugging information can be enabled or disabled; this hook is used by " { $link "tools.deploy" } ":"
|
||||
{ $subsection compiled-stack-traces? }
|
||||
"Assembler intrinsics can be defined for low-level optimization:"
|
||||
{ $subsection define-intrinsic }
|
||||
{ $subsection define-intrinsics }
|
||||
{ $subsection define-if-intrinsic }
|
||||
{ $subsection define-if-intrinsics }
|
||||
"The main entry point into the code generator:"
|
||||
{ $subsection generate } ;
|
||||
|
||||
ABOUT: "generator"
|
||||
|
||||
HELP: compiled
|
||||
{ $var-description "During compilation, holds a hashtable mapping words to 5-element arrays holding compiled code." } ;
|
||||
|
||||
HELP: compiling-word
|
||||
{ $var-description "The word currently being compiled, set by " { $link with-generator } "." } ;
|
||||
|
||||
HELP: compiling-label
|
||||
{ $var-description "The label currently being compiled, set by " { $link with-generator } "." } ;
|
||||
|
||||
HELP: compiled-stack-traces?
|
||||
{ $values { "?" "a boolean" } }
|
||||
{ $description "Iftrue, compiled code blocks will retain what word they were compiled from. This information is used by " { $link :c } " to display call stack traces after an error is thrown from compiled code. This is on by default; the deployment tool switches it off to save some space in the deployed image." } ;
|
||||
|
||||
HELP: literal-table
|
||||
{ $var-description "Holds a vector of literal objects referenced from the currently compiling word. If " { $link compiled-stack-traces? } " is on, " { $link begin-compiling } " ensures that the first entry is the word being compiled." } ;
|
||||
|
||||
HELP: begin-compiling
|
||||
{ $values { "word" word } { "label" word } }
|
||||
{ $description "Prepares to generate machine code for a word." } ;
|
||||
|
||||
HELP: with-generator
|
||||
{ $values { "node" "a dataflow node" } { "word" word } { "label" word } { "quot" "a quotation with stack effect " { $snippet "( node -- )" } } }
|
||||
{ $description "Generates machine code for " { $snippet "label" } " by applying the quotation to the dataflow node." } ;
|
||||
|
||||
HELP: generate-node
|
||||
{ $values { "node" "a dataflow node" } { "next" "a dataflow node" } }
|
||||
{ $contract "Generates machine code for a dataflow node, and outputs the next node to generate machine code for." }
|
||||
{ $notes "This word can only be called from inside the quotation passed to " { $link with-generator } "." } ;
|
||||
|
||||
HELP: generate-nodes
|
||||
{ $values { "node" "a dataflow node" } }
|
||||
{ $description "Recursively generate machine code for a dataflow graph." }
|
||||
{ $notes "This word can only be called from inside the quotation passed to " { $link with-generator } "." } ;
|
||||
|
||||
HELP: generate
|
||||
{ $values { "word" word } { "label" word } { "node" "a dataflow node" } }
|
||||
{ $description "Generates machine code for " { $snippet "label" } " from " { $snippet "node" } ". The value of " { $snippet "word" } " is retained for debugging purposes; it is the word which will appear in a call stack trace if this compiled code block throws an error when run." } ;
|
||||
|
||||
HELP: word-dataflow
|
||||
{ $values { "word" word } { "effect" effect } { "dataflow" "a dataflow graph" } }
|
||||
{ $description "Outputs the dataflow graph of a word, taking specializers into account (see " { $link "specializers" } ")." } ;
|
||||
|
||||
HELP: define-intrinsics
|
||||
{ $values { "word" word } { "intrinsics" "a sequence of " { $snippet "{ quot assoc }" } " pairs" } }
|
||||
{ $description "Defines a set of assembly intrinsics for the word. When a call to the word is being compiled, each intrinsic is tested in turn; the first applicable one will be called to generate machine code. If no suitable intrinsic is found, a simple call to the word is compiled instead."
|
||||
$nl
|
||||
"See " { $link with-template } " for an explanation of the keys which may appear in " { $snippet "assoc" } "." } ;
|
||||
|
||||
HELP: define-intrinsic
|
||||
{ $values { "word" word } { "quot" quotation } { "assoc" "an assoc" } }
|
||||
{ $description "Defines an assembly intrinsic for the word. When a call to the word is being compiled, this intrinsic will be used if it is found to be applicable. If it is not applicable, a simple call to the word is compiled instead."
|
||||
$nl
|
||||
"See " { $link with-template } " for an explanation of the keys which may appear in " { $snippet "assoc" } "." } ;
|
||||
|
||||
HELP: if>boolean-intrinsic
|
||||
{ $values { "quot" "a quotation with stack effect " { $snippet "( label -- )" } } }
|
||||
{ $description "Generates code which pushes " { $link t } " or " { $link f } " on the data stack, depending on whether the quotation jumps to the label or not." } ;
|
||||
|
||||
HELP: define-if-intrinsics
|
||||
{ $values { "word" word } { "intrinsics" "a sequence of " { $snippet "{ quot inputs }" } " pairs" } }
|
||||
{ $description "Defines a set of conditional assembly intrinsics for the word, which must have a boolean value as its single output."
|
||||
$nl
|
||||
"The quotations must have stack effect " { $snippet "( label -- )" } "; they are required to branch to the label if the word evaluates to true."
|
||||
$nl
|
||||
"The " { $snippet "inputs" } " are in the same format as the " { $link +input+ } " key to " { $link with-template } "; a description can be found in the documentation for thatt word." }
|
||||
{ $notes "Conditional intrinsics are used when the word is followed by a call to " { $link if } ". They allow for tighter code to be generated in certain situations; for example, if two integers are being compared and the result is immediately used to branch, the intermediate boolean does not need to be pushed at all." } ;
|
||||
|
||||
HELP: define-if-intrinsic
|
||||
{ $values { "word" word } { "quot" "a quotation with stack effect " { $snippet "( label -- )" } } { "inputs" "a sequence of input register specifiers" } }
|
||||
{ $description "Defines a conditional assembly intrinsic for the word, which must have a boolean value as its single output."
|
||||
$nl
|
||||
"See " { $link define-if-intrinsics } " for a description of the parameters." } ;
|
||||
|
|
@ -1,274 +0,0 @@
|
|||
! Copyright (C) 2004, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays assocs classes combinators cpu.architecture
|
||||
effects generator.fixup generator.registers generic hashtables
|
||||
inference inference.backend inference.dataflow io kernel
|
||||
kernel.private layouts math namespaces optimizer
|
||||
optimizer.specializers prettyprint quotations sequences system
|
||||
threads words vectors sets dequeues ;
|
||||
IN: generator
|
||||
|
||||
SYMBOL: compile-queue
|
||||
SYMBOL: compiled
|
||||
|
||||
: queue-compile ( word -- )
|
||||
{
|
||||
{ [ dup "forgotten" word-prop ] [ ] }
|
||||
{ [ dup compiled get key? ] [ ] }
|
||||
{ [ dup inlined-block? ] [ ] }
|
||||
{ [ dup primitive? ] [ ] }
|
||||
[ dup compile-queue get push-front ]
|
||||
} cond drop ;
|
||||
|
||||
: maybe-compile ( word -- )
|
||||
dup compiled>> [ drop ] [ queue-compile ] if ;
|
||||
|
||||
SYMBOL: compiling-word
|
||||
|
||||
SYMBOL: compiling-label
|
||||
|
||||
SYMBOL: compiling-loops
|
||||
|
||||
! Label of current word, after prologue, makes recursion faster
|
||||
SYMBOL: current-label-start
|
||||
|
||||
: compiled-stack-traces? ( -- ? ) 59 getenv ;
|
||||
|
||||
: begin-compiling ( word label -- )
|
||||
H{ } clone compiling-loops set
|
||||
compiling-label set
|
||||
compiling-word set
|
||||
compiled-stack-traces?
|
||||
compiling-word get f ?
|
||||
1vector literal-table set
|
||||
f compiling-label get compiled get set-at ;
|
||||
|
||||
: save-machine-code ( literals relocation labels code -- )
|
||||
4array compiling-label get compiled get set-at ;
|
||||
|
||||
: with-generator ( node word label quot -- )
|
||||
[
|
||||
>r begin-compiling r>
|
||||
{ } make fixup
|
||||
save-machine-code
|
||||
] with-scope ; inline
|
||||
|
||||
GENERIC: generate-node ( node -- next )
|
||||
|
||||
: generate-nodes ( node -- )
|
||||
[ node@ generate-node ] iterate-nodes end-basic-block ;
|
||||
|
||||
: init-generate-nodes ( -- )
|
||||
init-templates
|
||||
%save-word-xt
|
||||
%prologue-later
|
||||
current-label-start define-label
|
||||
current-label-start resolve-label ;
|
||||
|
||||
: generate ( node word label -- )
|
||||
[
|
||||
init-generate-nodes
|
||||
[ generate-nodes ] with-node-iterator
|
||||
] with-generator ;
|
||||
|
||||
: word-dataflow ( word -- effect dataflow )
|
||||
[
|
||||
[
|
||||
dup "cannot-infer" word-prop [ cannot-infer-effect ] when
|
||||
dup "no-compile" word-prop [ cannot-infer-effect ] when
|
||||
dup specialized-def over dup 2array 1array infer-quot
|
||||
finish-word
|
||||
] maybe-cannot-infer
|
||||
] with-infer ;
|
||||
|
||||
: intrinsics ( #call -- quot )
|
||||
node-param "intrinsics" word-prop ;
|
||||
|
||||
: if-intrinsics ( #call -- quot )
|
||||
node-param "if-intrinsics" word-prop ;
|
||||
|
||||
! node
|
||||
M: node generate-node drop iterate-next ;
|
||||
|
||||
: %jump ( word -- )
|
||||
dup compiling-label get eq?
|
||||
[ drop current-label-start get ] [ %epilogue-later ] if
|
||||
%jump-label ;
|
||||
|
||||
: generate-call ( label -- next )
|
||||
dup maybe-compile
|
||||
end-basic-block
|
||||
dup compiling-loops get at [
|
||||
%jump-label f
|
||||
] [
|
||||
tail-call? [
|
||||
%jump f
|
||||
] [
|
||||
0 frame-required
|
||||
%call
|
||||
iterate-next
|
||||
] if
|
||||
] ?if ;
|
||||
|
||||
! #label
|
||||
M: #label generate-node
|
||||
dup node-param generate-call >r
|
||||
dup node-child over #label-word rot node-param generate
|
||||
r> ;
|
||||
|
||||
! #loop
|
||||
: compiling-loop ( word -- )
|
||||
<label> dup resolve-label swap compiling-loops get set-at ;
|
||||
|
||||
M: #loop generate-node
|
||||
end-basic-block
|
||||
dup node-param compiling-loop
|
||||
node-child generate-nodes
|
||||
iterate-next ;
|
||||
|
||||
! #if
|
||||
: end-false-branch ( label -- )
|
||||
tail-call? [ %return drop ] [ %jump-label ] if ;
|
||||
|
||||
: generate-branch ( node -- )
|
||||
[ copy-templates generate-nodes ] with-scope ;
|
||||
|
||||
: generate-if ( node label -- next )
|
||||
<label> [
|
||||
>r >r node-children first2 swap generate-branch
|
||||
r> r> end-false-branch resolve-label
|
||||
generate-branch
|
||||
init-templates
|
||||
] keep resolve-label iterate-next ;
|
||||
|
||||
M: #if generate-node
|
||||
[ <label> dup %jump-f ]
|
||||
H{ { +input+ { { f "flag" } } } }
|
||||
with-template
|
||||
generate-if ;
|
||||
|
||||
! #dispatch
|
||||
: dispatch-branch ( node word -- label )
|
||||
gensym [
|
||||
[
|
||||
copy-templates
|
||||
%save-dispatch-xt
|
||||
%prologue-later
|
||||
[ generate-nodes ] with-node-iterator
|
||||
] with-generator
|
||||
] keep ;
|
||||
|
||||
: dispatch-branches ( node -- )
|
||||
node-children [
|
||||
compiling-word get dispatch-branch
|
||||
%dispatch-label
|
||||
] each ;
|
||||
|
||||
: generate-dispatch ( node -- )
|
||||
%dispatch dispatch-branches init-templates ;
|
||||
|
||||
M: #dispatch generate-node
|
||||
#! The order here is important, dispatch-branches must
|
||||
#! run after %dispatch, so that each branch gets the
|
||||
#! correct register state
|
||||
tail-call? [
|
||||
generate-dispatch iterate-next
|
||||
] [
|
||||
compiling-word get gensym [
|
||||
[
|
||||
init-generate-nodes
|
||||
generate-dispatch
|
||||
] with-generator
|
||||
] keep generate-call
|
||||
] if ;
|
||||
|
||||
! #call
|
||||
: define-intrinsics ( word intrinsics -- )
|
||||
"intrinsics" set-word-prop ;
|
||||
|
||||
: define-intrinsic ( word quot assoc -- )
|
||||
2array 1array define-intrinsics ;
|
||||
|
||||
: define-if>branch-intrinsics ( word intrinsics -- )
|
||||
"if-intrinsics" set-word-prop ;
|
||||
|
||||
: if>boolean-intrinsic ( quot -- )
|
||||
"false" define-label
|
||||
"end" define-label
|
||||
"false" get swap call
|
||||
t "if-scratch" get load-literal
|
||||
"end" get %jump-label
|
||||
"false" resolve-label
|
||||
f "if-scratch" get load-literal
|
||||
"end" resolve-label
|
||||
"if-scratch" get phantom-push ; inline
|
||||
|
||||
: define-if>boolean-intrinsics ( word intrinsics -- )
|
||||
[
|
||||
>r [ if>boolean-intrinsic ] curry r>
|
||||
{ { f "if-scratch" } } +scratch+ associate assoc-union
|
||||
] assoc-map "intrinsics" set-word-prop ;
|
||||
|
||||
: define-if-intrinsics ( word intrinsics -- )
|
||||
[ +input+ associate ] assoc-map
|
||||
2dup define-if>branch-intrinsics
|
||||
define-if>boolean-intrinsics ;
|
||||
|
||||
: define-if-intrinsic ( word quot inputs -- )
|
||||
2array 1array define-if-intrinsics ;
|
||||
|
||||
: do-if-intrinsic ( pair -- next )
|
||||
<label> [
|
||||
swap do-template
|
||||
node> node-successor dup >node
|
||||
] keep generate-if ;
|
||||
|
||||
: find-intrinsic ( #call -- pair/f )
|
||||
intrinsics find-template ;
|
||||
|
||||
: find-if-intrinsic ( #call -- pair/f )
|
||||
dup node-successor #if? [
|
||||
if-intrinsics find-template
|
||||
] [
|
||||
drop f
|
||||
] if ;
|
||||
|
||||
M: #call generate-node
|
||||
dup node-input-classes set-operand-classes
|
||||
dup find-if-intrinsic [
|
||||
do-if-intrinsic
|
||||
] [
|
||||
dup find-intrinsic [
|
||||
do-template iterate-next
|
||||
] [
|
||||
node-param generate-call
|
||||
] ?if
|
||||
] ?if ;
|
||||
|
||||
! #call-label
|
||||
M: #call-label generate-node node-param generate-call ;
|
||||
|
||||
! #push
|
||||
M: #push generate-node
|
||||
node-out-d [ value-literal <constant> phantom-push ] each
|
||||
iterate-next ;
|
||||
|
||||
! #shuffle
|
||||
M: #shuffle generate-node
|
||||
node-shuffle phantom-shuffle iterate-next ;
|
||||
|
||||
M: #>r generate-node
|
||||
node-in-d length
|
||||
phantom->r
|
||||
iterate-next ;
|
||||
|
||||
M: #r> generate-node
|
||||
node-out-d length
|
||||
phantom-r>
|
||||
iterate-next ;
|
||||
|
||||
! #return
|
||||
M: #return generate-node
|
||||
end-basic-block
|
||||
node-param compiling-loops get key?
|
||||
[ %return ] unless f ;
|
||||
|
|
@ -1,660 +0,0 @@
|
|||
! Copyright (C) 2006, 2007 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays assocs classes classes.private classes.algebra
|
||||
combinators cpu.architecture generator.fixup hashtables kernel
|
||||
layouts math namespaces quotations sequences system vectors
|
||||
words effects alien byte-arrays
|
||||
accessors sets math.order ;
|
||||
IN: generator.registers
|
||||
|
||||
SYMBOL: +input+
|
||||
SYMBOL: +output+
|
||||
SYMBOL: +scratch+
|
||||
SYMBOL: +clobber+
|
||||
SYMBOL: known-tag
|
||||
|
||||
<PRIVATE
|
||||
|
||||
! Value protocol
|
||||
GENERIC: set-operand-class ( class obj -- )
|
||||
GENERIC: operand-class* ( operand -- class )
|
||||
GENERIC: move-spec ( obj -- spec )
|
||||
GENERIC: live-vregs* ( obj -- )
|
||||
GENERIC: live-loc? ( actual current -- ? )
|
||||
GENERIC# (lazy-load) 1 ( value spec -- value )
|
||||
GENERIC: lazy-store ( dst src -- )
|
||||
GENERIC: minimal-ds-loc* ( min obj -- min )
|
||||
|
||||
! This will be a multimethod soon
|
||||
DEFER: %move
|
||||
|
||||
MIXIN: value
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: operand-class ( operand -- class )
|
||||
operand-class* object or ;
|
||||
|
||||
! Default implementation
|
||||
M: value set-operand-class 2drop ;
|
||||
M: value operand-class* drop f ;
|
||||
M: value live-vregs* drop ;
|
||||
M: value live-loc? 2drop f ;
|
||||
M: value minimal-ds-loc* drop ;
|
||||
M: value lazy-store 2drop ;
|
||||
|
||||
! A scratch register for computations
|
||||
TUPLE: vreg n reg-class ;
|
||||
|
||||
C: <vreg> vreg ( n reg-class -- vreg )
|
||||
|
||||
M: vreg v>operand [ n>> ] [ reg-class>> ] bi vregs nth ;
|
||||
M: vreg live-vregs* , ;
|
||||
M: vreg move-spec reg-class>> move-spec ;
|
||||
|
||||
INSTANCE: vreg value
|
||||
|
||||
M: float-regs move-spec drop float ;
|
||||
M: float-regs operand-class* drop float ;
|
||||
|
||||
! Temporary register for stack shuffling
|
||||
SINGLETON: temp-reg
|
||||
|
||||
M: temp-reg move-spec drop f ;
|
||||
|
||||
INSTANCE: temp-reg value
|
||||
|
||||
! A data stack location.
|
||||
TUPLE: ds-loc n class ;
|
||||
|
||||
: <ds-loc> ( n -- loc ) f ds-loc boa ;
|
||||
|
||||
M: ds-loc minimal-ds-loc* ds-loc-n min ;
|
||||
M: ds-loc operand-class* ds-loc-class ;
|
||||
M: ds-loc set-operand-class set-ds-loc-class ;
|
||||
M: ds-loc live-loc?
|
||||
over ds-loc? [ [ ds-loc-n ] bi@ = not ] [ 2drop t ] if ;
|
||||
|
||||
! A retain stack location.
|
||||
TUPLE: rs-loc n class ;
|
||||
|
||||
: <rs-loc> ( n -- loc ) f rs-loc boa ;
|
||||
M: rs-loc operand-class* rs-loc-class ;
|
||||
M: rs-loc set-operand-class set-rs-loc-class ;
|
||||
M: rs-loc live-loc?
|
||||
over rs-loc? [ [ rs-loc-n ] bi@ = not ] [ 2drop t ] if ;
|
||||
|
||||
UNION: loc ds-loc rs-loc ;
|
||||
|
||||
M: loc move-spec drop loc ;
|
||||
|
||||
INSTANCE: loc value
|
||||
|
||||
M: f move-spec drop loc ;
|
||||
M: f operand-class* ;
|
||||
|
||||
! A stack location which has been loaded into a register. To
|
||||
! read the location, we just read the register, but when time
|
||||
! comes to save it back to the stack, we know the register just
|
||||
! contains a stack value so we don't have to redundantly write
|
||||
! it back.
|
||||
TUPLE: cached loc vreg ;
|
||||
|
||||
C: <cached> cached
|
||||
|
||||
M: cached set-operand-class cached-vreg set-operand-class ;
|
||||
M: cached operand-class* cached-vreg operand-class* ;
|
||||
M: cached move-spec drop cached ;
|
||||
M: cached live-vregs* cached-vreg live-vregs* ;
|
||||
M: cached live-loc? cached-loc live-loc? ;
|
||||
M: cached (lazy-load) >r cached-vreg r> (lazy-load) ;
|
||||
M: cached lazy-store
|
||||
2dup cached-loc live-loc?
|
||||
[ "live-locs" get at %move ] [ 2drop ] if ;
|
||||
M: cached minimal-ds-loc* cached-loc minimal-ds-loc* ;
|
||||
|
||||
INSTANCE: cached value
|
||||
|
||||
! A tagged pointer
|
||||
TUPLE: tagged vreg class ;
|
||||
|
||||
: <tagged> ( vreg -- tagged )
|
||||
f tagged boa ;
|
||||
|
||||
M: tagged v>operand tagged-vreg v>operand ;
|
||||
M: tagged set-operand-class set-tagged-class ;
|
||||
M: tagged operand-class* tagged-class ;
|
||||
M: tagged move-spec drop f ;
|
||||
M: tagged live-vregs* tagged-vreg , ;
|
||||
|
||||
INSTANCE: tagged value
|
||||
|
||||
! Unboxed alien pointers
|
||||
TUPLE: unboxed-alien vreg ;
|
||||
C: <unboxed-alien> unboxed-alien
|
||||
M: unboxed-alien v>operand unboxed-alien-vreg v>operand ;
|
||||
M: unboxed-alien operand-class* drop simple-alien ;
|
||||
M: unboxed-alien move-spec class ;
|
||||
M: unboxed-alien live-vregs* unboxed-alien-vreg , ;
|
||||
|
||||
INSTANCE: unboxed-alien value
|
||||
|
||||
TUPLE: unboxed-byte-array vreg ;
|
||||
C: <unboxed-byte-array> unboxed-byte-array
|
||||
M: unboxed-byte-array v>operand unboxed-byte-array-vreg v>operand ;
|
||||
M: unboxed-byte-array operand-class* drop c-ptr ;
|
||||
M: unboxed-byte-array move-spec class ;
|
||||
M: unboxed-byte-array live-vregs* unboxed-byte-array-vreg , ;
|
||||
|
||||
INSTANCE: unboxed-byte-array value
|
||||
|
||||
TUPLE: unboxed-f vreg ;
|
||||
C: <unboxed-f> unboxed-f
|
||||
M: unboxed-f v>operand unboxed-f-vreg v>operand ;
|
||||
M: unboxed-f operand-class* drop \ f ;
|
||||
M: unboxed-f move-spec class ;
|
||||
M: unboxed-f live-vregs* unboxed-f-vreg , ;
|
||||
|
||||
INSTANCE: unboxed-f value
|
||||
|
||||
TUPLE: unboxed-c-ptr vreg ;
|
||||
C: <unboxed-c-ptr> unboxed-c-ptr
|
||||
M: unboxed-c-ptr v>operand unboxed-c-ptr-vreg v>operand ;
|
||||
M: unboxed-c-ptr operand-class* drop c-ptr ;
|
||||
M: unboxed-c-ptr move-spec class ;
|
||||
M: unboxed-c-ptr live-vregs* unboxed-c-ptr-vreg , ;
|
||||
|
||||
INSTANCE: unboxed-c-ptr value
|
||||
|
||||
! A constant value
|
||||
TUPLE: constant value ;
|
||||
C: <constant> constant
|
||||
M: constant operand-class* constant-value class ;
|
||||
M: constant move-spec class ;
|
||||
|
||||
INSTANCE: constant value
|
||||
|
||||
<PRIVATE
|
||||
|
||||
! Moving values between locations and registers
|
||||
: %move-bug ( -- * ) "Bug in generator.registers" throw ;
|
||||
|
||||
: %unbox-c-ptr ( dst src -- )
|
||||
dup operand-class {
|
||||
{ [ dup \ f class<= ] [ drop %unbox-f ] }
|
||||
{ [ dup simple-alien class<= ] [ drop %unbox-alien ] }
|
||||
{ [ dup byte-array class<= ] [ drop %unbox-byte-array ] }
|
||||
[ drop %unbox-any-c-ptr ]
|
||||
} cond ; inline
|
||||
|
||||
: %move-via-temp ( dst src -- )
|
||||
#! For many transfers, such as loc to unboxed-alien, we
|
||||
#! don't have an intrinsic, so we transfer the source to
|
||||
#! temp then temp to the destination.
|
||||
temp-reg over %move
|
||||
operand-class temp-reg
|
||||
tagged new
|
||||
swap >>vreg
|
||||
swap >>class
|
||||
%move ;
|
||||
|
||||
: %move ( dst src -- )
|
||||
2dup [ move-spec ] bi@ 2array {
|
||||
{ { f f } [ %move-bug ] }
|
||||
{ { f unboxed-c-ptr } [ %move-bug ] }
|
||||
{ { f unboxed-byte-array } [ %move-bug ] }
|
||||
|
||||
{ { f constant } [ constant-value swap load-literal ] }
|
||||
|
||||
{ { f float } [ %box-float ] }
|
||||
{ { f unboxed-alien } [ %box-alien ] }
|
||||
{ { f loc } [ %peek ] }
|
||||
|
||||
{ { float f } [ %unbox-float ] }
|
||||
{ { unboxed-alien f } [ %unbox-alien ] }
|
||||
{ { unboxed-byte-array f } [ %unbox-byte-array ] }
|
||||
{ { unboxed-f f } [ %unbox-f ] }
|
||||
{ { unboxed-c-ptr f } [ %unbox-c-ptr ] }
|
||||
{ { loc f } [ swap %replace ] }
|
||||
|
||||
[ drop %move-via-temp ]
|
||||
} case ;
|
||||
|
||||
! A compile-time stack
|
||||
TUPLE: phantom-stack height stack ;
|
||||
|
||||
M: phantom-stack clone
|
||||
call-next-method [ clone ] change-stack ;
|
||||
|
||||
GENERIC: finalize-height ( stack -- )
|
||||
|
||||
: new-phantom-stack ( class -- stack )
|
||||
>r 0 V{ } clone r> boa ; inline
|
||||
|
||||
: (loc) ( m stack -- n )
|
||||
#! Utility for methods on <loc>
|
||||
height>> - ;
|
||||
|
||||
: (finalize-height) ( stack word -- )
|
||||
#! We consolidate multiple stack height changes until the
|
||||
#! last moment, and we emit the final height changing
|
||||
#! instruction here.
|
||||
[
|
||||
over zero? [ 2drop ] [ execute ] if 0
|
||||
] curry change-height drop ; inline
|
||||
|
||||
GENERIC: <loc> ( n stack -- loc )
|
||||
|
||||
TUPLE: phantom-datastack < phantom-stack ;
|
||||
|
||||
: <phantom-datastack> ( -- stack )
|
||||
phantom-datastack new-phantom-stack ;
|
||||
|
||||
M: phantom-datastack <loc> (loc) <ds-loc> ;
|
||||
|
||||
M: phantom-datastack finalize-height
|
||||
\ %inc-d (finalize-height) ;
|
||||
|
||||
TUPLE: phantom-retainstack < phantom-stack ;
|
||||
|
||||
: <phantom-retainstack> ( -- stack )
|
||||
phantom-retainstack new-phantom-stack ;
|
||||
|
||||
M: phantom-retainstack <loc> (loc) <rs-loc> ;
|
||||
|
||||
M: phantom-retainstack finalize-height
|
||||
\ %inc-r (finalize-height) ;
|
||||
|
||||
: phantom-locs ( n phantom -- locs )
|
||||
#! A sequence of n ds-locs or rs-locs indexing the stack.
|
||||
>r <reversed> r> [ <loc> ] curry map ;
|
||||
|
||||
: phantom-locs* ( phantom -- locs )
|
||||
[ stack>> length ] keep phantom-locs ;
|
||||
|
||||
: phantoms ( -- phantom phantom )
|
||||
phantom-datastack get phantom-retainstack get ;
|
||||
|
||||
: (each-loc) ( phantom quot -- )
|
||||
>r [ phantom-locs* ] [ stack>> ] bi r> 2each ; inline
|
||||
|
||||
: each-loc ( quot -- )
|
||||
phantoms 2array swap [ (each-loc) ] curry each ; inline
|
||||
|
||||
: adjust-phantom ( n phantom -- )
|
||||
swap [ + ] curry change-height drop ;
|
||||
|
||||
: cut-phantom ( n phantom -- seq )
|
||||
swap [ cut* swap ] curry change-stack drop ;
|
||||
|
||||
: phantom-append ( seq stack -- )
|
||||
over length over adjust-phantom stack>> push-all ;
|
||||
|
||||
: add-locs ( n phantom -- )
|
||||
2dup stack>> length <= [
|
||||
2drop
|
||||
] [
|
||||
[ phantom-locs ] keep
|
||||
[ stack>> length head-slice* ] keep
|
||||
[ append >vector ] change-stack drop
|
||||
] if ;
|
||||
|
||||
: phantom-input ( n phantom -- seq )
|
||||
2dup add-locs
|
||||
2dup cut-phantom
|
||||
>r >r neg r> adjust-phantom r> ;
|
||||
|
||||
: each-phantom ( quot -- ) phantoms rot bi@ ; inline
|
||||
|
||||
: finalize-heights ( -- ) [ finalize-height ] each-phantom ;
|
||||
|
||||
: live-vregs ( -- seq )
|
||||
[ [ stack>> [ live-vregs* ] each ] each-phantom ] { } make ;
|
||||
|
||||
: (live-locs) ( phantom -- seq )
|
||||
#! Discard locs which haven't moved
|
||||
[ phantom-locs* ] [ stack>> ] bi zip
|
||||
[ live-loc? ] assoc-filter
|
||||
values ;
|
||||
|
||||
: live-locs ( -- seq )
|
||||
[ (live-locs) ] each-phantom append prune ;
|
||||
|
||||
! Operands holding pointers to freshly-allocated objects which
|
||||
! are guaranteed to be in the nursery
|
||||
SYMBOL: fresh-objects
|
||||
|
||||
! Computing free registers and initializing allocator
|
||||
: reg-spec>class ( spec -- class )
|
||||
float eq? double-float-regs int-regs ? ;
|
||||
|
||||
: free-vregs ( reg-class -- seq )
|
||||
#! Free vregs in a given register class
|
||||
\ free-vregs get at ;
|
||||
|
||||
: alloc-vreg ( spec -- reg )
|
||||
[ reg-spec>class free-vregs pop ] keep {
|
||||
{ f [ <tagged> ] }
|
||||
{ unboxed-alien [ <unboxed-alien> ] }
|
||||
{ unboxed-byte-array [ <unboxed-byte-array> ] }
|
||||
{ unboxed-f [ <unboxed-f> ] }
|
||||
{ unboxed-c-ptr [ <unboxed-c-ptr> ] }
|
||||
[ drop ]
|
||||
} case ;
|
||||
|
||||
: compatible? ( value spec -- ? )
|
||||
>r move-spec r> {
|
||||
{ [ 2dup = ] [ t ] }
|
||||
{ [ dup unboxed-c-ptr eq? ] [
|
||||
over { unboxed-byte-array unboxed-alien } member?
|
||||
] }
|
||||
[ f ]
|
||||
} cond 2nip ;
|
||||
|
||||
: allocation ( value spec -- reg-class )
|
||||
{
|
||||
{ [ dup quotation? ] [ 2drop f ] }
|
||||
{ [ 2dup compatible? ] [ 2drop f ] }
|
||||
[ nip reg-spec>class ]
|
||||
} cond ;
|
||||
|
||||
: alloc-vreg-for ( value spec -- vreg )
|
||||
alloc-vreg swap operand-class
|
||||
over tagged? [ >>class ] [ drop ] if ;
|
||||
|
||||
M: value (lazy-load)
|
||||
2dup allocation [
|
||||
dupd alloc-vreg-for dup rot %move
|
||||
] [
|
||||
drop
|
||||
] if ;
|
||||
|
||||
: (compute-free-vregs) ( used class -- vector )
|
||||
#! Find all vregs in 'class' which are not in 'used'.
|
||||
[ vregs length reverse ] keep
|
||||
[ <vreg> ] curry map swap diff
|
||||
>vector ;
|
||||
|
||||
: compute-free-vregs ( -- )
|
||||
#! Create a new hashtable for thee free-vregs variable.
|
||||
live-vregs
|
||||
{ int-regs double-float-regs }
|
||||
[ 2dup (compute-free-vregs) ] H{ } map>assoc
|
||||
\ free-vregs set
|
||||
drop ;
|
||||
|
||||
M: loc lazy-store
|
||||
2dup live-loc? [ "live-locs" get at %move ] [ 2drop ] if ;
|
||||
|
||||
: do-shuffle ( hash -- )
|
||||
dup assoc-empty? [
|
||||
drop
|
||||
] [
|
||||
"live-locs" set
|
||||
[ lazy-store ] each-loc
|
||||
] if ;
|
||||
|
||||
: fast-shuffle ( locs -- )
|
||||
#! We have enough free registers to load all shuffle inputs
|
||||
#! at once
|
||||
[ dup f (lazy-load) ] H{ } map>assoc do-shuffle ;
|
||||
|
||||
: minimal-ds-loc ( phantom -- n )
|
||||
#! When shuffling more values than can fit in registers, we
|
||||
#! need to find an area on the data stack which isn't in
|
||||
#! use.
|
||||
[ stack>> ] [ height>> neg ] bi [ minimal-ds-loc* ] reduce ;
|
||||
|
||||
: find-tmp-loc ( -- n )
|
||||
#! Find an area of the data stack which is not referenced
|
||||
#! from the phantom stacks. We can clobber there all we want
|
||||
[ minimal-ds-loc ] each-phantom min 1- ;
|
||||
|
||||
: slow-shuffle-mapping ( locs tmp -- pairs )
|
||||
>r dup length r>
|
||||
[ swap - <ds-loc> ] curry map zip ;
|
||||
|
||||
: slow-shuffle ( locs -- )
|
||||
#! We don't have enough free registers to load all shuffle
|
||||
#! inputs, so we use a single temporary register, together
|
||||
#! with the area of the data stack above the stack pointer
|
||||
find-tmp-loc slow-shuffle-mapping [
|
||||
[
|
||||
swap dup cached? [ cached-vreg ] when %move
|
||||
] assoc-each
|
||||
] keep >hashtable do-shuffle ;
|
||||
|
||||
: fast-shuffle? ( live-locs -- ? )
|
||||
#! Test if we have enough free registers to load all
|
||||
#! shuffle inputs at once.
|
||||
int-regs free-vregs [ length ] bi@ <= ;
|
||||
|
||||
: finalize-locs ( -- )
|
||||
#! Perform any deferred stack shuffling.
|
||||
[
|
||||
\ free-vregs [ [ clone ] assoc-map ] change
|
||||
live-locs dup fast-shuffle?
|
||||
[ fast-shuffle ] [ slow-shuffle ] if
|
||||
] with-scope ;
|
||||
|
||||
: finalize-vregs ( -- )
|
||||
#! Store any vregs to their final stack locations.
|
||||
[
|
||||
dup loc? over cached? or [ 2drop ] [ %move ] if
|
||||
] each-loc ;
|
||||
|
||||
: reset-phantom ( phantom -- )
|
||||
#! Kill register assignments but preserve constants and
|
||||
#! class information.
|
||||
dup phantom-locs*
|
||||
over stack>> [
|
||||
dup constant? [ nip ] [
|
||||
operand-class over set-operand-class
|
||||
] if
|
||||
] 2map
|
||||
over stack>> delete-all
|
||||
swap stack>> push-all ;
|
||||
|
||||
: reset-phantoms ( -- )
|
||||
[ reset-phantom ] each-phantom ;
|
||||
|
||||
: finalize-contents ( -- )
|
||||
finalize-locs finalize-vregs reset-phantoms ;
|
||||
|
||||
! Loading stacks to vregs
|
||||
: free-vregs? ( int# float# -- ? )
|
||||
double-float-regs free-vregs length <=
|
||||
>r int-regs free-vregs length <= r> and ;
|
||||
|
||||
: phantom&spec ( phantom spec -- phantom' spec' )
|
||||
>r stack>> r>
|
||||
[ length f pad-left ] keep
|
||||
[ <reversed> ] bi@ ; inline
|
||||
|
||||
: phantom&spec-agree? ( phantom spec quot -- ? )
|
||||
>r phantom&spec r> 2all? ; inline
|
||||
|
||||
: vreg-substitution ( value vreg -- pair )
|
||||
dupd <cached> 2array ;
|
||||
|
||||
: substitute-vreg? ( old new -- ? )
|
||||
#! We don't substitute locs for float or alien vregs,
|
||||
#! since in those cases the boxing overhead might kill us.
|
||||
cached-vreg tagged? >r loc? r> and ;
|
||||
|
||||
: substitute-vregs ( values vregs -- )
|
||||
[ vreg-substitution ] 2map
|
||||
[ substitute-vreg? ] assoc-filter >hashtable
|
||||
[ >r stack>> r> substitute-here ] curry each-phantom ;
|
||||
|
||||
: set-operand ( value var -- )
|
||||
>r dup constant? [ constant-value ] when r> set ;
|
||||
|
||||
: lazy-load ( values template -- )
|
||||
#! Set operand vars here.
|
||||
2dup [ first (lazy-load) ] 2map
|
||||
dup rot [ second set-operand ] 2each
|
||||
substitute-vregs ;
|
||||
|
||||
: load-inputs ( -- )
|
||||
+input+ get
|
||||
[ length phantom-datastack get phantom-input ] keep
|
||||
lazy-load ;
|
||||
|
||||
: output-vregs ( -- seq seq )
|
||||
+output+ +clobber+ [ get [ get ] map ] bi@ ;
|
||||
|
||||
: clash? ( seq -- ? )
|
||||
phantoms [ stack>> ] bi@ append [
|
||||
dup cached? [ cached-vreg ] when swap member?
|
||||
] with contains? ;
|
||||
|
||||
: outputs-clash? ( -- ? )
|
||||
output-vregs append clash? ;
|
||||
|
||||
: count-vregs ( reg-classes -- ) [ [ inc ] when* ] each ;
|
||||
|
||||
: count-input-vregs ( phantom spec -- )
|
||||
phantom&spec [
|
||||
>r dup cached? [ cached-vreg ] when r> first allocation
|
||||
] 2map count-vregs ;
|
||||
|
||||
: count-scratch-regs ( spec -- )
|
||||
[ first reg-spec>class ] map count-vregs ;
|
||||
|
||||
: guess-vregs ( dinput rinput scratch -- int# float# )
|
||||
[
|
||||
0 int-regs set
|
||||
0 double-float-regs set
|
||||
count-scratch-regs
|
||||
phantom-retainstack get swap count-input-vregs
|
||||
phantom-datastack get swap count-input-vregs
|
||||
int-regs get double-float-regs get
|
||||
] with-scope ;
|
||||
|
||||
: alloc-scratch ( -- )
|
||||
+scratch+ get [ >r alloc-vreg r> set ] assoc-each ;
|
||||
|
||||
: guess-template-vregs ( -- int# float# )
|
||||
+input+ get { } +scratch+ get guess-vregs ;
|
||||
|
||||
: template-inputs ( -- )
|
||||
! Load input values into registers
|
||||
load-inputs
|
||||
! Allocate scratch registers
|
||||
alloc-scratch
|
||||
! If outputs clash, we write values back to the stack
|
||||
outputs-clash? [ finalize-contents ] when ;
|
||||
|
||||
: template-outputs ( -- )
|
||||
+output+ get [ get ] map phantom-datastack get phantom-append ;
|
||||
|
||||
: value-matches? ( value spec -- ? )
|
||||
#! If the spec is a quotation and the value is a literal
|
||||
#! fixnum, see if the quotation yields true when applied
|
||||
#! to the fixnum. Otherwise, the values don't match. If the
|
||||
#! spec is not a quotation, its a reg-class, in which case
|
||||
#! the value is always good.
|
||||
dup quotation? [
|
||||
over constant?
|
||||
[ >r constant-value r> call ] [ 2drop f ] if
|
||||
] [
|
||||
2drop t
|
||||
] if ;
|
||||
|
||||
: class-matches? ( actual expected -- ? )
|
||||
{
|
||||
{ f [ drop t ] }
|
||||
{ known-tag [ dup [ class-tag >boolean ] when ] }
|
||||
[ class<= ]
|
||||
} case ;
|
||||
|
||||
: spec-matches? ( value spec -- ? )
|
||||
2dup first value-matches?
|
||||
>r >r operand-class 2 r> ?nth class-matches? r> and ;
|
||||
|
||||
: template-matches? ( spec -- ? )
|
||||
phantom-datastack get +input+ rot at
|
||||
[ spec-matches? ] phantom&spec-agree? ;
|
||||
|
||||
: ensure-template-vregs ( -- )
|
||||
guess-template-vregs free-vregs? [
|
||||
finalize-contents compute-free-vregs
|
||||
] unless ;
|
||||
|
||||
: clear-phantoms ( -- )
|
||||
[ stack>> delete-all ] each-phantom ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: set-operand-classes ( classes -- )
|
||||
phantom-datastack get
|
||||
over length over add-locs
|
||||
stack>> [ set-operand-class ] 2reverse-each ;
|
||||
|
||||
: end-basic-block ( -- )
|
||||
#! Commit all deferred stacking shuffling, and ensure the
|
||||
#! in-memory data and retain stacks are up to date with
|
||||
#! respect to the compiler's current picture.
|
||||
finalize-contents
|
||||
clear-phantoms
|
||||
finalize-heights
|
||||
fresh-objects get [ empty? [ %gc ] unless ] [ delete-all ] bi ;
|
||||
|
||||
: with-template ( quot hash -- )
|
||||
clone [
|
||||
ensure-template-vregs
|
||||
template-inputs call template-outputs
|
||||
] bind
|
||||
compute-free-vregs ; inline
|
||||
|
||||
: do-template ( pair -- )
|
||||
#! Use with return value from find-template
|
||||
first2 with-template ;
|
||||
|
||||
: fresh-object ( obj -- ) fresh-objects get push ;
|
||||
|
||||
: fresh-object? ( obj -- ? ) fresh-objects get memq? ;
|
||||
|
||||
: init-templates ( -- )
|
||||
#! Initialize register allocator.
|
||||
V{ } clone fresh-objects set
|
||||
<phantom-datastack> phantom-datastack set
|
||||
<phantom-retainstack> phantom-retainstack set
|
||||
compute-free-vregs ;
|
||||
|
||||
: copy-templates ( -- )
|
||||
#! Copies register allocator state, used when compiling
|
||||
#! branches.
|
||||
fresh-objects [ clone ] change
|
||||
phantom-datastack [ clone ] change
|
||||
phantom-retainstack [ clone ] change
|
||||
compute-free-vregs ;
|
||||
|
||||
: find-template ( templates -- pair/f )
|
||||
#! Pair has shape { quot hash }
|
||||
[ second template-matches? ] find nip ;
|
||||
|
||||
: operand-tag ( operand -- tag/f )
|
||||
operand-class dup [ class-tag ] when ;
|
||||
|
||||
UNION: immediate fixnum POSTPONE: f ;
|
||||
|
||||
: operand-immediate? ( operand -- ? )
|
||||
operand-class immediate class<= ;
|
||||
|
||||
: phantom-push ( obj -- )
|
||||
1 phantom-datastack get adjust-phantom
|
||||
phantom-datastack get stack>> push ;
|
||||
|
||||
: phantom-shuffle ( shuffle -- )
|
||||
[ effect-in length phantom-datastack get phantom-input ] keep
|
||||
shuffle* phantom-datastack get phantom-append ;
|
||||
|
||||
: phantom->r ( n -- )
|
||||
phantom-datastack get phantom-input
|
||||
phantom-retainstack get phantom-append ;
|
||||
|
||||
: phantom-r> ( n -- )
|
||||
phantom-retainstack get phantom-input
|
||||
phantom-datastack get phantom-append ;
|
||||
|
|
@ -1,72 +0,0 @@
|
|||
USING: help.syntax help.markup words effects inference.dataflow
|
||||
inference.state kernel sequences
|
||||
kernel.private combinators sequences.private ;
|
||||
IN: inference.backend
|
||||
|
||||
HELP: literal-expected
|
||||
{ $error-description "Thrown when inference encounters a " { $link call } " or " { $link if } " being applied to a value which is not known to be a literal. Such a form can have an arbitrary stack effect, and does not compile." }
|
||||
{ $notes "This error will be thrown when compiling any combinator, such as " { $link each } ". However, words calling combinators can compile if the combinator is declared " { $link POSTPONE: inline } " and the quotation being passed in is a literal." } ;
|
||||
|
||||
HELP: too-many->r
|
||||
{ $error-description "Thrown if inference notices a quotation pushing elements on the retain stack without popping them at the end." }
|
||||
{ $notes "See " { $link "shuffle-words" } " for retain stack usage conventions." } ;
|
||||
|
||||
HELP: too-many-r>
|
||||
{ $error-description "Thrown if inference notices a quotation popping elements from the return stack it did not place there." }
|
||||
{ $notes "See " { $link "shuffle-words" } " for retain stack usage conventions." } ;
|
||||
|
||||
HELP: unify-lengths
|
||||
{ $values { "seq" sequence } { "newseq" "a new sequence" } }
|
||||
{ $description "Pads sequences in " { $snippet "seq" } " with computed value placeholders to ensure they are all the same length." } ;
|
||||
|
||||
HELP: cannot-unify-specials
|
||||
{ $description "Throws an " { $link cannot-unify-specials } "." }
|
||||
{ $error-description "Thrown when some but not all branches in a conditional output " { $link curry } " or " { $link compose } " values. This case is not supported by stack effect inference yet. It does not indicate there is a programming error." } ;
|
||||
|
||||
HELP: unify-values
|
||||
{ $values { "seq" sequence } { "value" "an object" } }
|
||||
{ $description "If all values in the sequence are equal, outputs the value, otherwise outputs a computed value placeholder." } ;
|
||||
|
||||
HELP: unbalanced-branches-error
|
||||
{ $values { "in" "a sequence of integers" } { "out" "a sequence of integers" } }
|
||||
{ $description "Throws an " { $link unbalanced-branches-error } "." }
|
||||
{ $error-description "Thrown when inference encounters an " { $link if } ", " { $link dispatch } " or " { $link cond } " where the branches do not all exit with the same stack height." }
|
||||
{ $notes "Conditionals with variable stack effects are considered to be bad style and should be avoided since they do not compile."
|
||||
$nl
|
||||
"If this error comes up when inferring the stack effect of a recursive word, check the word's stack effect declaration; it might be wrong." } ;
|
||||
|
||||
HELP: unify-effect
|
||||
{ $values { "quots" "a sequence of quotations" } { "in" "a sequence of integers" } { "out" "a sequence of stacks" } { "newin" "a sequence of integers" } { "newout" "a sequence of stacks" } }
|
||||
{ $description "Unifies the stack effects of a number of branches, and outputs new values for " { $link d-in } " and " { $link meta-d } "." } ;
|
||||
|
||||
HELP: consume/produce
|
||||
{ $values { "node" "a dataflow node" } { "effect" "an instance of " { $link effect } } }
|
||||
{ $description "Adds a node to the dataflow graph that calls " { $snippet "word" } " with a stack effect of " { $snippet "effect" } "." } ;
|
||||
|
||||
HELP: cannot-infer-effect
|
||||
{ $values { "word" word } }
|
||||
{ $description "Throws a " { $link cannot-infer-effect } " error." }
|
||||
{ $error-description "Thrown when inference encounters a call to a word which is already known not to have a static stack effect, due to a prior inference attempt failing." } ;
|
||||
|
||||
HELP: inline-word
|
||||
{ $values { "word" word } }
|
||||
{ $description "Called during inference to infer stack effects of inline words."
|
||||
$nl
|
||||
"If the inline word is recursive, a new " { $link #label } " node is added to the dataflow graph, and the word has to be inferred twice, to determine which literals survive the recursion (eg, quotations) and which don't (loop indices, etc)."
|
||||
$nl
|
||||
"If the inline word is not recursive, the resulting nodes are spliced into the dataflow graph, and no " { $link #label } " node is created." } ;
|
||||
|
||||
HELP: effect-error
|
||||
{ $values { "word" word } { "effect" "an instance of " { $link effect } } }
|
||||
{ $description "Throws an " { $link effect-error } "." }
|
||||
{ $error-description "Thrown when a word's inferred stack effect does not match its declared stack effect." } ;
|
||||
|
||||
HELP: missing-effect
|
||||
{ $error-description "Thrown when inference encounters a word lacking a stack effect declaration. Stack effects of words must be declared, with the exception of words which only push literals on the stack." } ;
|
||||
|
||||
HELP: recursive-quotation-error
|
||||
{ $error-description "Thrown when a quotation calls itself, directly or indirectly, within the same word. Stack effect inference becomes equivalent to the halting problem if quotation recursion has to be taken into account, hence it is not permitted." }
|
||||
{ $examples
|
||||
"Here is an example of quotation recursion:"
|
||||
{ $code "[ [ dup call ] dup call ] infer." }
|
||||
} ;
|
||||
|
|
@ -1,570 +0,0 @@
|
|||
! Copyright (C) 2004, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: inference.dataflow inference.state arrays generic io
|
||||
io.streams.string kernel math namespaces parser prettyprint
|
||||
sequences strings vectors words quotations effects classes
|
||||
continuations debugger assocs combinators compiler.errors
|
||||
generic.standard.engines.tuple accessors math.order definitions
|
||||
sets ;
|
||||
IN: inference.backend
|
||||
|
||||
: recursive-label ( word -- label/f )
|
||||
recursive-state get at ;
|
||||
|
||||
GENERIC: inline? ( word -- ? )
|
||||
|
||||
M: method-body inline?
|
||||
"method-generic" word-prop inline? ;
|
||||
|
||||
M: engine-word inline?
|
||||
"tuple-dispatch-generic" word-prop inline? ;
|
||||
|
||||
M: word inline?
|
||||
"inline" word-prop ;
|
||||
|
||||
SYMBOL: visited
|
||||
|
||||
: reset-on-redefine { "inferred-effect" "cannot-infer" } ; inline
|
||||
|
||||
: (redefined) ( word -- )
|
||||
dup visited get key? [ drop ] [
|
||||
[ reset-on-redefine reset-props ]
|
||||
[ visited get conjoin ]
|
||||
[
|
||||
crossref get at keys
|
||||
[ word? ] filter
|
||||
[
|
||||
[ reset-on-redefine [ word-prop ] with contains? ]
|
||||
[ inline? ]
|
||||
bi or
|
||||
] filter
|
||||
[ (redefined) ] each
|
||||
] tri
|
||||
] if ;
|
||||
|
||||
M: word redefined H{ } clone visited [ (redefined) ] with-variable ;
|
||||
|
||||
: local-recursive-state ( -- assoc )
|
||||
recursive-state get dup keys
|
||||
[ dup word? [ inline? ] when not ] find drop
|
||||
[ head-slice ] when* ;
|
||||
|
||||
: inline-recursive-label ( word -- label/f )
|
||||
local-recursive-state at ;
|
||||
|
||||
: recursive-quotation? ( quot -- ? )
|
||||
local-recursive-state [ first eq? ] with contains? ;
|
||||
|
||||
TUPLE: inference-error error type rstate ;
|
||||
|
||||
M: inference-error compiler-error-type type>> ;
|
||||
|
||||
M: inference-error error-help error>> error-help ;
|
||||
|
||||
: (inference-error) ( ... class type -- * )
|
||||
>r boa r>
|
||||
recursive-state get
|
||||
\ inference-error boa throw ; inline
|
||||
|
||||
: inference-error ( ... class -- * )
|
||||
+error+ (inference-error) ; inline
|
||||
|
||||
: inference-warning ( ... class -- * )
|
||||
+warning+ (inference-error) ; inline
|
||||
|
||||
TUPLE: literal-expected ;
|
||||
|
||||
M: object value-literal \ literal-expected inference-warning ;
|
||||
|
||||
: pop-literal ( -- rstate obj )
|
||||
1 #drop node,
|
||||
pop-d dup value-literal >r value-recursion r> ;
|
||||
|
||||
: value-vector ( n -- vector ) [ <computed> ] V{ } replicate-as ;
|
||||
|
||||
: add-inputs ( seq stack -- n stack )
|
||||
tuck [ length ] bi@ - dup 0 >
|
||||
[ dup value-vector [ swapd push-all ] keep ]
|
||||
[ drop 0 swap ] if ;
|
||||
|
||||
: ensure-values ( seq -- )
|
||||
meta-d [ add-inputs ] change d-in [ + ] change ;
|
||||
|
||||
: current-effect ( -- effect )
|
||||
d-in get
|
||||
meta-d get length <effect>
|
||||
terminated? get >>terminated? ;
|
||||
|
||||
: init-inference ( -- )
|
||||
terminated? off
|
||||
V{ } clone meta-d set
|
||||
V{ } clone meta-r set
|
||||
0 d-in set
|
||||
dataflow-graph off
|
||||
current-node off ;
|
||||
|
||||
GENERIC: apply-object ( obj -- )
|
||||
|
||||
: apply-literal ( obj -- )
|
||||
<value> push-d #push 1 0 pick node-outputs node, ;
|
||||
|
||||
M: object apply-object apply-literal ;
|
||||
|
||||
M: wrapper apply-object
|
||||
wrapped>> dup +called+ depends-on apply-literal ;
|
||||
|
||||
: terminate ( -- )
|
||||
terminated? on #terminate node, ;
|
||||
|
||||
: infer-quot ( quot rstate -- )
|
||||
recursive-state get [
|
||||
recursive-state set
|
||||
[ apply-object terminated? get not ] all? drop
|
||||
] dip recursive-state set ;
|
||||
|
||||
: infer-quot-recursive ( quot word label -- )
|
||||
2array recursive-state get swap prefix infer-quot ;
|
||||
|
||||
: time-bomb ( error -- )
|
||||
[ throw ] curry recursive-state get infer-quot ;
|
||||
|
||||
: bad-call ( -- )
|
||||
"call must be given a callable" time-bomb ;
|
||||
|
||||
TUPLE: recursive-quotation-error quot ;
|
||||
|
||||
: infer-quot-value ( value -- )
|
||||
dup recursive-quotation? [
|
||||
value-literal recursive-quotation-error inference-error
|
||||
] [
|
||||
dup value-literal callable? [
|
||||
[ value-literal ]
|
||||
[ [ value-recursion ] keep f 2array prefix ]
|
||||
bi infer-quot
|
||||
] [
|
||||
drop bad-call
|
||||
] if
|
||||
] if ;
|
||||
|
||||
TUPLE: too-many->r ;
|
||||
|
||||
: check->r ( -- )
|
||||
meta-r get empty? terminated? get or
|
||||
[ \ too-many->r inference-error ] unless ;
|
||||
|
||||
TUPLE: too-many-r> ;
|
||||
|
||||
: check-r> ( n -- )
|
||||
meta-r get length >
|
||||
[ \ too-many-r> inference-error ] when ;
|
||||
|
||||
: infer->r ( n -- )
|
||||
dup ensure-values
|
||||
#>r
|
||||
over 0 pick node-inputs
|
||||
over [ pop-d ] replicate reverse [ push-r ] each
|
||||
0 pick pick node-outputs
|
||||
node,
|
||||
drop ;
|
||||
|
||||
: infer-r> ( n -- )
|
||||
dup check-r>
|
||||
#r>
|
||||
0 pick pick node-inputs
|
||||
over [ pop-r ] replicate reverse [ push-d ] each
|
||||
over 0 pick node-outputs
|
||||
node,
|
||||
drop ;
|
||||
|
||||
: undo-infer ( -- )
|
||||
recorded get [ f "inferred-effect" set-word-prop ] each ;
|
||||
|
||||
: (consume-values) ( n -- )
|
||||
meta-d get [ length swap - ] keep set-length ;
|
||||
|
||||
: consume-values ( seq node -- )
|
||||
>r length r>
|
||||
over ensure-values
|
||||
over 0 rot node-inputs
|
||||
(consume-values) ;
|
||||
|
||||
: produce-values ( seq node -- )
|
||||
>r value-vector dup r> set-node-out-d
|
||||
meta-d get push-all ;
|
||||
|
||||
: if-inline ( word true false -- )
|
||||
[ dup inline? ] 2dip if ; inline
|
||||
|
||||
: consume/produce ( effect node -- )
|
||||
[ [ in>> ] dip consume-values ]
|
||||
[ [ out>> ] dip produce-values ]
|
||||
[ node, terminated?>> [ terminate ] when ]
|
||||
2tri ;
|
||||
|
||||
GENERIC: constructor ( value -- word/f )
|
||||
|
||||
GENERIC: infer-uncurry ( value -- )
|
||||
|
||||
M: curried infer-uncurry
|
||||
drop pop-d [ obj>> push-d ] [ quot>> push-d ] bi ;
|
||||
|
||||
M: curried constructor
|
||||
drop \ curry ;
|
||||
|
||||
M: composed infer-uncurry
|
||||
drop pop-d [ quot1>> push-d ] [ quot2>> push-d ] bi ;
|
||||
|
||||
M: composed constructor
|
||||
drop \ compose ;
|
||||
|
||||
M: object infer-uncurry drop ;
|
||||
|
||||
M: object constructor drop f ;
|
||||
|
||||
: reify-curry ( value -- )
|
||||
dup infer-uncurry
|
||||
constructor [
|
||||
peek-d reify-curry
|
||||
1 infer->r
|
||||
peek-d reify-curry
|
||||
1 infer-r>
|
||||
(( obj quot -- curry )) swap #call consume/produce
|
||||
] when* ;
|
||||
|
||||
: reify-curries ( n -- )
|
||||
meta-d get reverse [
|
||||
dup special? [
|
||||
over infer->r
|
||||
dup reify-curry
|
||||
over infer-r>
|
||||
] when 2drop
|
||||
] 2each ;
|
||||
|
||||
: reify-all ( -- )
|
||||
meta-d get length reify-curries ;
|
||||
|
||||
: end-infer ( -- )
|
||||
check->r
|
||||
reify-all
|
||||
f #return node, ;
|
||||
|
||||
: unify-lengths ( seq -- newseq )
|
||||
dup empty? [
|
||||
dup [ length ] map supremum
|
||||
[ swap add-inputs nip ] curry map
|
||||
] unless ;
|
||||
|
||||
DEFER: unify-values
|
||||
|
||||
: unify-curries ( seq -- value )
|
||||
[ [ obj>> ] map unify-values ]
|
||||
[ [ quot>> ] map unify-values ] bi
|
||||
<curried> ;
|
||||
|
||||
: unify-composed ( seq -- value )
|
||||
[ [ quot1>> ] map unify-values ]
|
||||
[ [ quot2>> ] map unify-values ] bi
|
||||
<composed> ;
|
||||
|
||||
TUPLE: cannot-unify-specials ;
|
||||
|
||||
: cannot-unify-specials ( -- * )
|
||||
\ cannot-unify-specials inference-warning ;
|
||||
|
||||
: unify-values ( seq -- value )
|
||||
{
|
||||
{ [ dup all-eq? ] [ first ] }
|
||||
{ [ dup [ curried? ] all? ] [ unify-curries ] }
|
||||
{ [ dup [ composed? ] all? ] [ unify-composed ] }
|
||||
{ [ dup [ special? ] contains? ] [ cannot-unify-specials ] }
|
||||
[ drop <computed> ]
|
||||
} cond ;
|
||||
|
||||
: unify-stacks ( seq -- stack )
|
||||
flip [ unify-values ] V{ } map-as ;
|
||||
|
||||
: balanced? ( in out -- ? )
|
||||
[ dup [ length - ] [ 2drop f ] if ] 2map
|
||||
sift all-equal? ;
|
||||
|
||||
TUPLE: unbalanced-branches-error quots in out ;
|
||||
|
||||
: unbalanced-branches-error ( quots in out -- * )
|
||||
\ unbalanced-branches-error inference-error ;
|
||||
|
||||
: unify-inputs ( max-d-in d-in meta-d -- meta-d )
|
||||
dup [
|
||||
[ [ - ] dip length + ] keep add-inputs nip
|
||||
] [
|
||||
2nip
|
||||
] if ;
|
||||
|
||||
: unify-effect ( quots in out -- newin newout )
|
||||
#! in is a sequence of integers, out is a sequence of
|
||||
#! stacks.
|
||||
2dup balanced? [
|
||||
over supremum -rot
|
||||
[ >r dupd r> unify-inputs ] 2map
|
||||
sift unify-stacks
|
||||
rot drop
|
||||
] [
|
||||
unbalanced-branches-error
|
||||
] if ;
|
||||
|
||||
: active-variable ( seq symbol -- seq )
|
||||
[
|
||||
swap terminated? over at [ 2drop f ] [ at ] if
|
||||
] curry map ;
|
||||
|
||||
: branch-variable ( seq symbol -- seq )
|
||||
[ swap at ] curry map ;
|
||||
|
||||
: datastack-effect ( seq -- )
|
||||
[ quotation branch-variable ]
|
||||
[ d-in branch-variable ]
|
||||
[ meta-d active-variable ] tri
|
||||
unify-effect
|
||||
[ d-in set ] [ meta-d set ] bi* ;
|
||||
|
||||
: retainstack-effect ( seq -- )
|
||||
[ quotation branch-variable ]
|
||||
[ length 0 <repetition> ]
|
||||
[ meta-r active-variable ] tri
|
||||
unify-effect
|
||||
[ drop ] [ meta-r set ] bi* ;
|
||||
|
||||
: unify-effects ( seq -- )
|
||||
[ datastack-effect ]
|
||||
[ retainstack-effect ]
|
||||
[ [ terminated? swap at ] all? terminated? set ]
|
||||
tri ;
|
||||
|
||||
: unify-dataflow ( effects -- nodes )
|
||||
dataflow-graph branch-variable ;
|
||||
|
||||
: copy-inference ( -- )
|
||||
meta-d [ clone ] change
|
||||
meta-r [ clone ] change
|
||||
d-in [ ] change
|
||||
dataflow-graph off
|
||||
current-node off ;
|
||||
|
||||
: infer-branch ( last value -- namespace )
|
||||
[
|
||||
copy-inference
|
||||
|
||||
[ value-literal quotation set ]
|
||||
[ infer-quot-value ]
|
||||
bi
|
||||
|
||||
terminated? get [ drop ] [ call node, ] if
|
||||
] H{ } make-assoc ; inline
|
||||
|
||||
: (infer-branches) ( last branches -- list )
|
||||
[ infer-branch ] with map
|
||||
[ unify-effects ] [ unify-dataflow ] bi ; inline
|
||||
|
||||
: infer-branches ( last branches node -- )
|
||||
#! last -> #return or #values
|
||||
#! node -> #if or #dispatch
|
||||
1 reify-curries
|
||||
call dup node,
|
||||
pop-d drop
|
||||
>r (infer-branches) r> set-node-children
|
||||
#merge node, ; inline
|
||||
|
||||
: make-call-node ( word effect -- )
|
||||
swap dup inline?
|
||||
over dup recursive-label eq? not and [
|
||||
meta-d get clone -rot
|
||||
recursive-label #call-label [ consume/produce ] keep
|
||||
set-node-in-d
|
||||
] [
|
||||
over effect-in length reify-curries
|
||||
#call consume/produce
|
||||
] if ;
|
||||
|
||||
TUPLE: cannot-infer-effect word ;
|
||||
|
||||
: cannot-infer-effect ( word -- * )
|
||||
\ cannot-infer-effect inference-warning ;
|
||||
|
||||
TUPLE: effect-error word inferred declared ;
|
||||
|
||||
: effect-error ( word inferred declared -- * )
|
||||
\ effect-error inference-error ;
|
||||
|
||||
TUPLE: missing-effect word ;
|
||||
|
||||
: effect-required? ( word -- ? )
|
||||
{
|
||||
{ [ dup inline? ] [ drop f ] }
|
||||
{ [ dup deferred? ] [ drop f ] }
|
||||
{ [ dup crossref? not ] [ drop f ] }
|
||||
[ def>> [ [ word? ] [ primitive? not ] bi and ] contains? ]
|
||||
} cond ;
|
||||
|
||||
: ?missing-effect ( word -- )
|
||||
dup effect-required?
|
||||
[ missing-effect inference-error ] [ drop ] if ;
|
||||
|
||||
: check-effect ( word effect -- )
|
||||
over stack-effect {
|
||||
{ [ dup not ] [ 2drop ?missing-effect ] }
|
||||
{ [ 2dup effect<= ] [ 3drop ] }
|
||||
[ effect-error ]
|
||||
} cond ;
|
||||
|
||||
: finish-word ( word -- )
|
||||
current-effect
|
||||
[ check-effect ]
|
||||
[ drop recorded get push ]
|
||||
[ "inferred-effect" set-word-prop ]
|
||||
2tri ;
|
||||
|
||||
: maybe-cannot-infer ( word quot -- )
|
||||
[ ] [ t "cannot-infer" set-word-prop ] cleanup ; inline
|
||||
|
||||
: infer-word ( word -- effect )
|
||||
[
|
||||
[
|
||||
init-inference
|
||||
dependencies off
|
||||
dup def>> over dup infer-quot-recursive
|
||||
end-infer
|
||||
finish-word
|
||||
current-effect
|
||||
] with-scope
|
||||
] maybe-cannot-infer ;
|
||||
|
||||
: custom-infer ( word -- )
|
||||
#! Customized inference behavior
|
||||
[ +inlined+ depends-on ] [ "infer" word-prop call ] bi ;
|
||||
|
||||
: cached-infer ( word -- )
|
||||
dup "inferred-effect" word-prop make-call-node ;
|
||||
|
||||
: apply-word ( word -- )
|
||||
{
|
||||
{ [ dup "infer" word-prop ] [ custom-infer ] }
|
||||
{ [ dup "cannot-infer" word-prop ] [ cannot-infer-effect ] }
|
||||
{ [ dup "inferred-effect" word-prop ] [ cached-infer ] }
|
||||
[ dup infer-word make-call-node ]
|
||||
} cond ;
|
||||
|
||||
: declared-infer ( word -- )
|
||||
dup stack-effect [
|
||||
make-call-node
|
||||
] [
|
||||
\ missing-effect inference-error
|
||||
] if* ;
|
||||
|
||||
GENERIC: collect-label-info* ( label node -- )
|
||||
|
||||
M: node collect-label-info* 2drop ;
|
||||
|
||||
: (collect-label-info) ( label node vector -- )
|
||||
>r tuck [ param>> ] bi@ eq? r> [ push ] curry [ drop ] if ;
|
||||
inline
|
||||
|
||||
M: #call-label collect-label-info*
|
||||
over calls>> (collect-label-info) ;
|
||||
|
||||
M: #return collect-label-info*
|
||||
over returns>> (collect-label-info) ;
|
||||
|
||||
: collect-label-info ( #label -- )
|
||||
V{ } clone >>calls
|
||||
V{ } clone >>returns
|
||||
dup [ collect-label-info* ] with each-node ;
|
||||
|
||||
: nest-node ( -- ) #entry node, ;
|
||||
|
||||
: unnest-node ( new-node -- new-node )
|
||||
dup node-param #return node,
|
||||
dataflow-graph get 1array over set-node-children ;
|
||||
|
||||
: inlined-block? ( word -- ? )
|
||||
"inlined-block" word-prop ;
|
||||
|
||||
: <inlined-block> ( -- word )
|
||||
gensym dup t "inlined-block" set-word-prop ;
|
||||
|
||||
: inline-block ( word -- #label data )
|
||||
[
|
||||
copy-inference nest-node
|
||||
[ def>> ] [ <inlined-block> ] bi
|
||||
[ infer-quot-recursive ] 2keep
|
||||
#label unnest-node
|
||||
dup collect-label-info
|
||||
] H{ } make-assoc ;
|
||||
|
||||
: join-values ( #label -- )
|
||||
calls>> [ in-d>> ] map meta-d get suffix
|
||||
unify-lengths unify-stacks
|
||||
meta-d [ length tail* ] change ;
|
||||
|
||||
: splice-node ( node -- )
|
||||
dup successor>> [
|
||||
[ node, ] [ penultimate-node ] bi
|
||||
f >>successor
|
||||
current-node set
|
||||
] [ drop ] if ;
|
||||
|
||||
: apply-infer ( data -- )
|
||||
{ meta-d meta-r d-in terminated? } swap extract-keys
|
||||
namespace swap update ;
|
||||
|
||||
: current-stack-height ( -- n )
|
||||
d-in get meta-d get length - ;
|
||||
|
||||
: word-stack-height ( word -- n )
|
||||
stack-effect effect-height ;
|
||||
|
||||
: bad-recursive-declaration ( word inferred -- )
|
||||
dup 0 < [ 0 swap ] [ 0 ] if <effect>
|
||||
over stack-effect
|
||||
effect-error ;
|
||||
|
||||
: check-stack-height ( word height -- )
|
||||
over word-stack-height over =
|
||||
[ 2drop ] [ bad-recursive-declaration ] if ;
|
||||
|
||||
: inline-recursive-word ( word #label -- )
|
||||
current-stack-height [
|
||||
flatten-meta-d [ join-values inline-block apply-infer ] dip >>in-d
|
||||
[ node, ]
|
||||
[ calls>> [ [ flatten-curries ] modify-values ] each ]
|
||||
[ word>> ]
|
||||
tri
|
||||
] dip
|
||||
current-stack-height -
|
||||
check-stack-height ;
|
||||
|
||||
: inline-word ( word -- )
|
||||
dup inline-block over recursive-label?
|
||||
[ drop inline-recursive-word ]
|
||||
[ apply-infer node-child successor>> splice-node drop ] if ;
|
||||
|
||||
M: word apply-object
|
||||
[
|
||||
dup +inlined+ depends-on
|
||||
dup inline-recursive-label
|
||||
[ declared-infer ] [ inline-word ] if
|
||||
] [
|
||||
dup +called+ depends-on
|
||||
dup recursive-label
|
||||
[ declared-infer ] [ apply-word ] if
|
||||
] if-inline ;
|
||||
|
||||
: with-infer ( quot -- effect dataflow )
|
||||
[
|
||||
[
|
||||
V{ } clone recorded set
|
||||
init-inference
|
||||
call
|
||||
end-infer
|
||||
current-effect
|
||||
dataflow-graph get
|
||||
] [ ] [ undo-infer ] cleanup
|
||||
] with-scope ;
|
||||
|
|
@ -1,637 +0,0 @@
|
|||
IN: inference.class.tests
|
||||
USING: arrays math.private kernel math compiler inference
|
||||
inference.dataflow optimizer tools.test kernel.private generic
|
||||
sequences words inference.class quotations alien
|
||||
alien.c-types strings sbufs sequences.private
|
||||
slots.private combinators definitions compiler.units
|
||||
system layouts vectors optimizer.math.partial
|
||||
optimizer.inlining optimizer.backend math.order math.functions
|
||||
accessors hashtables classes assocs io.encodings.utf8
|
||||
io.encodings.ascii io.encodings ;
|
||||
|
||||
[ t ] [ T{ literal-constraint f 1 2 } T{ literal-constraint f 1 2 } equal? ] unit-test
|
||||
|
||||
[ f ] [ T{ literal-constraint f 1 3 } T{ literal-constraint f 1 2 } equal? ] unit-test
|
||||
|
||||
! Make sure these compile even though this is invalid code
|
||||
[ ] [ [ 10 mod 3.0 /i ] dataflow optimize drop ] unit-test
|
||||
[ ] [ [ 10 mod 3.0 shift ] dataflow optimize drop ] unit-test
|
||||
|
||||
! Ensure type inference works as it is supposed to by checking
|
||||
! if various methods get inlined
|
||||
|
||||
: inlined? ( quot seq/word -- ? )
|
||||
dup word? [ 1array ] when
|
||||
swap dataflow optimize
|
||||
[ node-param swap member? ] with node-exists? not ;
|
||||
|
||||
[ f ] [
|
||||
[ { integer } declare >fixnum ]
|
||||
\ >fixnum inlined?
|
||||
] unit-test
|
||||
|
||||
GENERIC: mynot ( x -- y )
|
||||
|
||||
M: f mynot drop t ;
|
||||
|
||||
M: object mynot drop f ;
|
||||
|
||||
GENERIC: detect-f ( x -- y )
|
||||
|
||||
M: f detect-f ;
|
||||
|
||||
[ t ] [
|
||||
[ dup [ mynot ] [ ] if detect-f ] \ detect-f inlined?
|
||||
] unit-test
|
||||
|
||||
[ ] [ [ fixnum< ] dataflow optimize drop ] unit-test
|
||||
|
||||
[ ] [ [ fixnum< [ ] [ ] if ] dataflow optimize drop ] unit-test
|
||||
|
||||
GENERIC: xyz ( n -- n )
|
||||
|
||||
M: integer xyz ;
|
||||
|
||||
M: object xyz ;
|
||||
|
||||
[ t ] [
|
||||
[ { integer } declare xyz ] \ xyz inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ dup fixnum? [ xyz ] [ drop "hi" ] if ]
|
||||
\ xyz inlined?
|
||||
] unit-test
|
||||
|
||||
: (fx-repeat) ( i n quot -- )
|
||||
2over fixnum>= [
|
||||
3drop
|
||||
] [
|
||||
[ swap >r call 1 fixnum+fast r> ] keep (fx-repeat)
|
||||
] if ; inline
|
||||
|
||||
: fx-repeat ( n quot -- )
|
||||
0 -rot (fx-repeat) ; inline
|
||||
|
||||
! The + should be optimized into fixnum+, if it was not, then
|
||||
! the type of the loop index was not inferred correctly
|
||||
[ t ] [
|
||||
[ [ dup 2 + drop ] fx-repeat ] \ + inlined?
|
||||
] unit-test
|
||||
|
||||
: (i-repeat) ( i n quot -- )
|
||||
2over dup xyz drop >= [
|
||||
3drop
|
||||
] [
|
||||
[ swap >r call 1+ r> ] keep (i-repeat)
|
||||
] if ; inline
|
||||
|
||||
: i-repeat >r { integer } declare r> 0 -rot (i-repeat) ; inline
|
||||
|
||||
[ t ] [
|
||||
[ [ dup xyz drop ] i-repeat ] \ xyz inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ { fixnum } declare dup 100 >= [ 1 + ] unless ] \ fixnum+ inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ { fixnum fixnum } declare dupd < [ 1 + 1 + ] when ]
|
||||
\ + inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ { fixnum fixnum } declare dupd < [ 1 + 1 + ] when ]
|
||||
\ + inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ { fixnum } declare [ ] times ] \ >= inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ { fixnum } declare [ ] times ] \ 1+ inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ { fixnum } declare [ ] times ] \ + inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ { fixnum } declare [ ] times ] \ fixnum+ inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ { integer fixnum } declare dupd < [ 1 + ] when ]
|
||||
\ + inlined?
|
||||
] unit-test
|
||||
|
||||
[ f ] [
|
||||
[ { integer fixnum } declare dupd < [ 1 + ] when ]
|
||||
\ +-integer-fixnum inlined?
|
||||
] unit-test
|
||||
|
||||
[ f ] [ [ dup 0 < [ neg ] when ] \ - inlined? ] unit-test
|
||||
|
||||
[ f ] [
|
||||
[
|
||||
[ no-cond ] 1
|
||||
[ 1array dup quotation? [ >quotation ] unless ] times
|
||||
] \ quotation? inlined?
|
||||
] unit-test
|
||||
|
||||
[ f ] [ [ <reversed> length ] \ slot inlined? ] unit-test
|
||||
|
||||
! We don't want to use = to compare literals
|
||||
: foo ( seq -- seq' ) reverse ;
|
||||
|
||||
\ foo [
|
||||
[
|
||||
fixnum 0 `output class,
|
||||
V{ } dup dup push 0 `input literal,
|
||||
] set-constraints
|
||||
] "constraints" set-word-prop
|
||||
|
||||
DEFER: blah
|
||||
|
||||
[ ] [
|
||||
[
|
||||
\ blah
|
||||
[ dup V{ } eq? [ foo ] when ] dup second dup push define
|
||||
] with-compilation-unit
|
||||
|
||||
\ blah def>> dataflow optimize drop
|
||||
] unit-test
|
||||
|
||||
GENERIC: detect-fx ( n -- n )
|
||||
|
||||
M: fixnum detect-fx ;
|
||||
|
||||
[ t ] [
|
||||
[
|
||||
[ uchar-nth ] 2keep [ uchar-nth ] 2keep uchar-nth
|
||||
>r >r 298 * r> 100 * - r> 208 * - 128 + -8 shift
|
||||
255 min 0 max detect-fx
|
||||
] \ detect-fx inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[
|
||||
1000000000000000000000000000000000 [ ] times
|
||||
] \ + inlined?
|
||||
] unit-test
|
||||
[ f ] [
|
||||
[
|
||||
1000000000000000000000000000000000 [ ] times
|
||||
] \ +-integer-fixnum inlined?
|
||||
] unit-test
|
||||
|
||||
[ f ] [
|
||||
[ { bignum } declare [ ] times ]
|
||||
\ +-integer-fixnum inlined?
|
||||
] unit-test
|
||||
|
||||
|
||||
[ t ] [
|
||||
[ { string sbuf } declare ] \ push-all def>> append \ + inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ { string sbuf } declare ] \ push-all def>> append \ fixnum+ inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ { string sbuf } declare ] \ push-all def>> append \ >fixnum inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ { array-capacity } declare 0 < ] \ < inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ { array-capacity } declare 0 < ] \ fixnum< inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ { array-capacity } declare 1 fixnum- ] \ fixnum- inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ 5000 [ 5000 [ ] times ] times ] \ 1+ inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ 5000 [ [ ] times ] each ] \ 1+ inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ 5000 0 [ dup 2 - swap [ 2drop ] curry each ] reduce ]
|
||||
\ 1+ inlined?
|
||||
] unit-test
|
||||
|
||||
GENERIC: annotate-entry-test-1 ( x -- )
|
||||
|
||||
M: fixnum annotate-entry-test-1 drop ;
|
||||
|
||||
: (annotate-entry-test-2) ( from to quot -- )
|
||||
2over >= [
|
||||
3drop
|
||||
] [
|
||||
[ swap >r call dup annotate-entry-test-1 1+ r> ] keep (annotate-entry-test-2)
|
||||
] if ; inline
|
||||
|
||||
: annotate-entry-test-2 0 -rot (annotate-entry-test-2) ; inline
|
||||
|
||||
[ f ] [
|
||||
[ { bignum } declare [ ] annotate-entry-test-2 ]
|
||||
\ annotate-entry-test-1 inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ { float } declare 10 [ 2.3 * ] times >float ]
|
||||
\ >float inlined?
|
||||
] unit-test
|
||||
|
||||
GENERIC: detect-float ( a -- b )
|
||||
|
||||
M: float detect-float ;
|
||||
|
||||
[ t ] [
|
||||
[ { real float } declare + detect-float ]
|
||||
\ detect-float inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ { float real } declare + detect-float ]
|
||||
\ detect-float inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ 3 + = ] \ equal? inlined?
|
||||
] unit-test
|
||||
|
||||
[ f ] [
|
||||
[ { fixnum fixnum } declare 7 bitand neg shift ]
|
||||
\ fixnum-shift-fast inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ { fixnum fixnum } declare 7 bitand neg shift ]
|
||||
{ shift fixnum-shift } inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ { fixnum fixnum } declare 1 swap 7 bitand shift ]
|
||||
{ shift fixnum-shift } inlined?
|
||||
] unit-test
|
||||
|
||||
[ f ] [
|
||||
[ { fixnum fixnum } declare 1 swap 7 bitand shift ]
|
||||
{ fixnum-shift-fast } inlined?
|
||||
] unit-test
|
||||
|
||||
cell-bits 32 = [
|
||||
[ t ] [
|
||||
[ { fixnum fixnum } declare 1 swap 31 bitand shift ]
|
||||
\ shift inlined?
|
||||
] unit-test
|
||||
|
||||
[ f ] [
|
||||
[ { fixnum fixnum } declare 1 swap 31 bitand shift ]
|
||||
\ fixnum-shift inlined?
|
||||
] unit-test
|
||||
] when
|
||||
|
||||
[ f ] [
|
||||
[ { integer } declare -63 shift 4095 bitand ]
|
||||
\ shift inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ B{ 1 0 } *short 0 number= ]
|
||||
\ number= inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ B{ 1 0 } *short 0 { number number } declare number= ]
|
||||
\ number= inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ B{ 1 0 } *short 0 = ]
|
||||
\ number= inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ B{ 1 0 } *short dup number? [ 0 number= ] [ drop f ] if ]
|
||||
\ number= inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ HEX: ff bitand 0 HEX: ff between? ]
|
||||
\ >= inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ HEX: ff swap HEX: ff bitand >= ]
|
||||
\ >= inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ { vector } declare nth-unsafe ] \ nth-unsafe inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[
|
||||
dup integer? [
|
||||
dup fixnum? [
|
||||
1 +
|
||||
] [
|
||||
2 +
|
||||
] if
|
||||
] when
|
||||
] \ + inlined?
|
||||
] unit-test
|
||||
|
||||
[ f ] [
|
||||
[
|
||||
256 mod
|
||||
] { mod fixnum-mod } inlined?
|
||||
] unit-test
|
||||
|
||||
[ f ] [
|
||||
[
|
||||
dup 0 >= [ 256 mod ] when
|
||||
] { mod fixnum-mod } inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[
|
||||
{ integer } declare dup 0 >= [ 256 mod ] when
|
||||
] { mod fixnum-mod } inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[
|
||||
{ integer } declare 256 rem
|
||||
] { mod fixnum-mod } inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[
|
||||
{ integer } declare [ 256 rem ] map
|
||||
] { mod fixnum-mod rem } inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ 1000 [ 1+ ] map ] { 1+ fixnum+ } inlined?
|
||||
] unit-test
|
||||
|
||||
: rec ( a -- b )
|
||||
dup 0 > [ 1 - rec ] when ; inline
|
||||
|
||||
[ t ] [
|
||||
[ { fixnum } declare rec 1 + ]
|
||||
{ > - + } inlined?
|
||||
] unit-test
|
||||
|
||||
: fib ( m -- n )
|
||||
dup 2 < [ drop 1 ] [ dup 1 - fib swap 2 - fib + ] if ; inline
|
||||
|
||||
[ t ] [
|
||||
[ 27.0 fib ] { < - + } inlined?
|
||||
] unit-test
|
||||
|
||||
[ f ] [
|
||||
[ 27.0 fib ] { +-integer-integer } inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ 27 fib ] { < - + } inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ 27 >bignum fib ] { < - + } inlined?
|
||||
] unit-test
|
||||
|
||||
[ f ] [
|
||||
[ 27/2 fib ] { < - } inlined?
|
||||
] unit-test
|
||||
|
||||
: hang-regression ( m n -- x )
|
||||
over 0 number= [
|
||||
nip
|
||||
] [
|
||||
dup [
|
||||
drop 1 hang-regression
|
||||
] [
|
||||
dupd hang-regression hang-regression
|
||||
] if
|
||||
] if ; inline
|
||||
|
||||
[ t ] [
|
||||
[ dup fixnum? [ 3 over hang-regression ] [ 3 over hang-regression ] if
|
||||
] { } inlined? ] unit-test
|
||||
|
||||
: detect-null ( a -- b ) dup drop ;
|
||||
|
||||
\ detect-null {
|
||||
{ [ dup dup in-d>> first node-class null eq? ] [ [ ] f splice-quot ] }
|
||||
} define-optimizers
|
||||
|
||||
[ t ] [
|
||||
[ { null } declare detect-null ] \ detect-null inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ { null null } declare + detect-null ] \ detect-null inlined?
|
||||
] unit-test
|
||||
|
||||
[ f ] [
|
||||
[ { null fixnum } declare + detect-null ] \ detect-null inlined?
|
||||
] unit-test
|
||||
|
||||
GENERIC: detect-integer ( a -- b )
|
||||
|
||||
M: integer detect-integer ;
|
||||
|
||||
[ t ] [
|
||||
[ { null fixnum } declare + detect-integer ] \ detect-integer inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ { fixnum } declare 10 [ -1 shift ] times ] \ shift inlined?
|
||||
] unit-test
|
||||
|
||||
[ f ] [
|
||||
[ { integer } declare 10 [ -1 shift ] times ] \ shift inlined?
|
||||
] unit-test
|
||||
|
||||
[ f ] [
|
||||
[ { fixnum } declare 1048575 fixnum-bitand 524288 fixnum- ]
|
||||
\ fixnum-bitand inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ { integer } declare 127 bitand 3 + ]
|
||||
{ + +-integer-fixnum +-integer-fixnum-fast bitand } inlined?
|
||||
] unit-test
|
||||
|
||||
[ f ] [
|
||||
[ { integer } declare 127 bitand 3 + ]
|
||||
{ >fixnum } inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ { fixnum } declare [ drop ] each-integer ]
|
||||
{ < <-integer-fixnum +-integer-fixnum + } inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ { fixnum } declare length [ drop ] each-integer ]
|
||||
{ < <-integer-fixnum +-integer-fixnum + } inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ { fixnum } declare [ drop ] each ]
|
||||
{ < <-integer-fixnum +-integer-fixnum + } inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ { fixnum } declare 0 [ + ] reduce ]
|
||||
{ < <-integer-fixnum } inlined?
|
||||
] unit-test
|
||||
|
||||
[ f ] [
|
||||
[ { fixnum } declare 0 [ + ] reduce ]
|
||||
\ +-integer-fixnum inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[
|
||||
{ integer } declare
|
||||
dup 0 >= [
|
||||
615949 * 797807 + 20 2^ mod dup 19 2^ -
|
||||
] [ dup ] if
|
||||
] { * + shift mod fixnum-mod fixnum* fixnum+ fixnum- } inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[
|
||||
{ fixnum } declare
|
||||
615949 * 797807 + 20 2^ mod dup 19 2^ -
|
||||
] { >fixnum } inlined?
|
||||
] unit-test
|
||||
|
||||
[ f ] [
|
||||
[
|
||||
{ integer } declare [ ] map
|
||||
] \ >fixnum inlined?
|
||||
] unit-test
|
||||
|
||||
[ f ] [
|
||||
[
|
||||
{ integer } declare { } set-nth-unsafe
|
||||
] \ >fixnum inlined?
|
||||
] unit-test
|
||||
|
||||
[ f ] [
|
||||
[
|
||||
{ integer } declare 1 + { } set-nth-unsafe
|
||||
] \ >fixnum inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[
|
||||
{ integer } declare 0 swap
|
||||
[
|
||||
drop 615949 * 797807 + 20 2^ rem dup 19 2^ -
|
||||
] map
|
||||
] { * + shift rem mod fixnum-mod fixnum* fixnum+ fixnum- } inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[
|
||||
{ fixnum } declare 0 swap
|
||||
[
|
||||
drop 615949 * 797807 + 20 2^ rem dup 19 2^ -
|
||||
] map
|
||||
] { * + shift rem mod fixnum-mod fixnum* fixnum+ fixnum- >fixnum } inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ { integer } declare bitnot detect-integer ]
|
||||
\ detect-integer inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ hashtable new ] \ new inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ dup hashtable eq? [ new ] when ] \ new inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ { hashtable } declare hashtable instance? ] \ instance? inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ { vector } declare hashtable instance? ] \ instance? inlined?
|
||||
] unit-test
|
||||
|
||||
[ f ] [
|
||||
[ { assoc } declare hashtable instance? ] \ instance? inlined?
|
||||
] unit-test
|
||||
|
||||
TUPLE: declared-fixnum { x fixnum } ;
|
||||
|
||||
[ t ] [
|
||||
[ { declared-fixnum } declare [ 1 + ] change-x ]
|
||||
{ + fixnum+ >fixnum } inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ { declared-fixnum } declare x>> drop ]
|
||||
{ slot } inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[
|
||||
{ array } declare length
|
||||
1 + dup 100 fixnum> [ 1 fixnum+ ] when
|
||||
] \ fixnum+ inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ [ resize-array ] keep length ] \ length inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ dup 0 > [ sqrt ] when ] \ sqrt inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ { utf8 } declare decode-char ] \ decode-char inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ { ascii } declare decode-char ] \ decode-char inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [ [ { 1 2 } length ] { length length>> slot } inlined? ] unit-test
|
||||
|
||||
! Later
|
||||
|
||||
! [ t ] [
|
||||
! [
|
||||
! { integer } declare [ 256 mod ] map
|
||||
! ] { mod fixnum-mod } inlined?
|
||||
! ] unit-test
|
||||
!
|
||||
! [ t ] [
|
||||
! [
|
||||
! { integer } declare [ 0 >= ] map
|
||||
! ] { >= fixnum>= } inlined?
|
||||
! ] unit-test
|
||||
|
|
@ -1,384 +0,0 @@
|
|||
! Copyright (C) 2004, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays generic assocs hashtables inference kernel
|
||||
math namespaces sequences words parser math.intervals
|
||||
effects classes classes.algebra inference.dataflow
|
||||
inference.backend combinators accessors ;
|
||||
IN: inference.class
|
||||
|
||||
! Class inference
|
||||
|
||||
! A constraint is a statement about a value.
|
||||
|
||||
! We need a notion of equality which doesn't recurse so cannot
|
||||
! infinite loop on circular data
|
||||
GENERIC: eql? ( obj1 obj2 -- ? )
|
||||
M: object eql? eq? ;
|
||||
M: number eql? number= ;
|
||||
|
||||
! Maps constraints to constraints
|
||||
SYMBOL: constraints
|
||||
|
||||
TUPLE: literal-constraint literal value ;
|
||||
|
||||
C: <literal-constraint> literal-constraint
|
||||
|
||||
M: literal-constraint equal?
|
||||
over literal-constraint? [
|
||||
[ [ literal>> ] bi@ eql? ]
|
||||
[ [ value>> ] bi@ = ]
|
||||
2bi and
|
||||
] [ 2drop f ] if ;
|
||||
|
||||
TUPLE: class-constraint class value ;
|
||||
|
||||
C: <class-constraint> class-constraint
|
||||
|
||||
TUPLE: interval-constraint interval value ;
|
||||
|
||||
C: <interval-constraint> interval-constraint
|
||||
|
||||
GENERIC: apply-constraint ( constraint -- )
|
||||
GENERIC: constraint-satisfied? ( constraint -- ? )
|
||||
|
||||
: `input ( n -- value ) node get in-d>> nth ;
|
||||
: `output ( n -- value ) node get out-d>> nth ;
|
||||
: class, ( class value -- ) <class-constraint> , ;
|
||||
: literal, ( literal value -- ) <literal-constraint> , ;
|
||||
: interval, ( interval value -- ) <interval-constraint> , ;
|
||||
|
||||
M: f apply-constraint drop ;
|
||||
|
||||
: make-constraints ( node quot -- constraint )
|
||||
[ swap node set call ] { } make ; inline
|
||||
|
||||
: set-constraints ( node quot -- )
|
||||
make-constraints
|
||||
unclip [ 2array ] reduce
|
||||
apply-constraint ; inline
|
||||
|
||||
: assume ( constraint -- )
|
||||
constraints get at [ apply-constraint ] when* ;
|
||||
|
||||
! Variables used by the class inferencer
|
||||
|
||||
! Current value --> literal mapping
|
||||
SYMBOL: value-literals
|
||||
|
||||
! Current value --> interval mapping
|
||||
SYMBOL: value-intervals
|
||||
|
||||
! Current value --> class mapping
|
||||
SYMBOL: value-classes
|
||||
|
||||
: value-interval* ( value -- interval/f )
|
||||
value-intervals get at ;
|
||||
|
||||
: set-value-interval* ( interval value -- )
|
||||
value-intervals get set-at ;
|
||||
|
||||
: intersect-value-interval ( interval value -- )
|
||||
[ value-interval* interval-intersect ] keep
|
||||
set-value-interval* ;
|
||||
|
||||
M: interval-constraint apply-constraint
|
||||
[ interval>> ] [ value>> ] bi intersect-value-interval ;
|
||||
|
||||
: set-class-interval ( class value -- )
|
||||
over class? [
|
||||
>r "interval" word-prop r> over
|
||||
[ set-value-interval* ] [ 2drop ] if
|
||||
] [ 2drop ] if ;
|
||||
|
||||
: value-class* ( value -- class )
|
||||
value-classes get at object or ;
|
||||
|
||||
: set-value-class* ( class value -- )
|
||||
over [
|
||||
dup value-intervals get at [
|
||||
2dup set-class-interval
|
||||
] unless
|
||||
2dup <class-constraint> assume
|
||||
] when
|
||||
value-classes get set-at ;
|
||||
|
||||
: intersect-value-class ( class value -- )
|
||||
[ value-class* class-and ] keep set-value-class* ;
|
||||
|
||||
M: class-constraint apply-constraint
|
||||
[ class>> ] [ value>> ] bi intersect-value-class ;
|
||||
|
||||
: literal-interval ( value -- interval/f )
|
||||
dup real? [ [a,a] ] [ drop f ] if ;
|
||||
|
||||
: set-value-literal* ( literal value -- )
|
||||
{
|
||||
[ >r class r> set-value-class* ]
|
||||
[ >r literal-interval r> set-value-interval* ]
|
||||
[ <literal-constraint> assume ]
|
||||
[ value-literals get set-at ]
|
||||
} 2cleave ;
|
||||
|
||||
M: literal-constraint apply-constraint
|
||||
[ literal>> ] [ value>> ] bi set-value-literal* ;
|
||||
|
||||
! For conditionals, an assoc of child node # --> constraint
|
||||
GENERIC: child-constraints ( node -- seq )
|
||||
|
||||
GENERIC: infer-classes-before ( node -- )
|
||||
|
||||
GENERIC: infer-classes-around ( node -- )
|
||||
|
||||
GENERIC: infer-classes-after ( node -- )
|
||||
|
||||
M: node infer-classes-before drop ;
|
||||
|
||||
M: node infer-classes-after drop ;
|
||||
|
||||
M: node child-constraints
|
||||
children>> length
|
||||
dup zero? [ drop f ] [ f <repetition> ] if ;
|
||||
|
||||
: value-literal* ( value -- obj ? )
|
||||
value-literals get at* ;
|
||||
|
||||
M: literal-constraint constraint-satisfied?
|
||||
dup value>> value-literal*
|
||||
[ swap literal>> eql? ] [ 2drop f ] if ;
|
||||
|
||||
M: class-constraint constraint-satisfied?
|
||||
[ value>> value-class* ] [ class>> ] bi class<= ;
|
||||
|
||||
M: pair apply-constraint
|
||||
first2 2dup constraints get set-at
|
||||
constraint-satisfied? [ apply-constraint ] [ drop ] if ;
|
||||
|
||||
M: pair constraint-satisfied?
|
||||
first constraint-satisfied? ;
|
||||
|
||||
: valid-keys ( seq assoc -- newassoc )
|
||||
extract-keys [ nip ] assoc-filter f assoc-like ;
|
||||
|
||||
: annotate-node ( node -- )
|
||||
#! Annotate the node with the currently-inferred set of
|
||||
#! value classes.
|
||||
dup node-values {
|
||||
[ value-intervals get valid-keys >>intervals ]
|
||||
[ value-classes get valid-keys >>classes ]
|
||||
[ value-literals get valid-keys >>literals ]
|
||||
[ 2drop ]
|
||||
} cleave ;
|
||||
|
||||
: intersect-classes ( classes values -- )
|
||||
[ intersect-value-class ] 2each ;
|
||||
|
||||
: intersect-intervals ( intervals values -- )
|
||||
[ intersect-value-interval ] 2each ;
|
||||
|
||||
: predicate-constraints ( class #call -- )
|
||||
[
|
||||
! If word outputs true, input is an instance of class
|
||||
[
|
||||
0 `input class,
|
||||
\ f class-not 0 `output class,
|
||||
] set-constraints
|
||||
] [
|
||||
! If word outputs false, input is not an instance of class
|
||||
[
|
||||
class-not 0 `input class,
|
||||
\ f 0 `output class,
|
||||
] set-constraints
|
||||
] 2bi ;
|
||||
|
||||
: compute-constraints ( #call -- )
|
||||
dup param>> "constraints" word-prop [
|
||||
call
|
||||
] [
|
||||
dup param>> "predicating" word-prop dup
|
||||
[ swap predicate-constraints ] [ 2drop ] if
|
||||
] if* ;
|
||||
|
||||
: compute-output-classes ( node word -- classes intervals )
|
||||
dup param>> "output-classes" word-prop
|
||||
dup [ call ] [ 2drop f f ] if ;
|
||||
|
||||
: output-classes ( node -- classes intervals )
|
||||
dup compute-output-classes >r
|
||||
[ ] [ param>> "default-output-classes" word-prop ] ?if
|
||||
r> ;
|
||||
|
||||
: intersect-values ( classes intervals values -- )
|
||||
tuck [ intersect-classes ] [ intersect-intervals ] 2bi* ;
|
||||
|
||||
M: #call infer-classes-before
|
||||
[ compute-constraints ]
|
||||
[ [ output-classes ] [ out-d>> ] bi intersect-values ] bi ;
|
||||
|
||||
: input-classes ( #call -- classes )
|
||||
param>> "input-classes" word-prop ;
|
||||
|
||||
M: #call infer-classes-after
|
||||
[ input-classes ] [ in-d>> ] bi intersect-classes ;
|
||||
|
||||
M: #push infer-classes-before
|
||||
out-d>> [ [ value-literal ] keep set-value-literal* ] each ;
|
||||
|
||||
M: #if child-constraints
|
||||
[
|
||||
\ f class-not 0 `input class,
|
||||
f 0 `input literal,
|
||||
] make-constraints ;
|
||||
|
||||
M: #dispatch child-constraints
|
||||
dup [
|
||||
children>> length [ 0 `input literal, ] each
|
||||
] make-constraints ;
|
||||
|
||||
M: #declare infer-classes-before
|
||||
[ param>> ] [ in-d>> ] bi
|
||||
[ intersect-value-class ] 2each ;
|
||||
|
||||
DEFER: (infer-classes)
|
||||
|
||||
: infer-children ( node -- )
|
||||
[ children>> ] [ child-constraints ] bi [
|
||||
[
|
||||
value-classes [ clone ] change
|
||||
value-literals [ clone ] change
|
||||
value-intervals [ clone ] change
|
||||
constraints [ clone ] change
|
||||
apply-constraint
|
||||
(infer-classes)
|
||||
] with-scope
|
||||
] 2each ;
|
||||
|
||||
: pad-all ( seqs elt -- seq )
|
||||
>r dup [ length ] map supremum r> [ pad-left ] 2curry map ;
|
||||
|
||||
: (merge-classes) ( nodes -- seq )
|
||||
dup length 1 = [
|
||||
first node-input-classes
|
||||
] [
|
||||
[ node-input-classes ] map null pad-all flip
|
||||
[ null [ class-or ] reduce ] map
|
||||
] if ;
|
||||
|
||||
: set-classes ( seq node -- )
|
||||
out-d>> [ set-value-class* ] 2reverse-each ;
|
||||
|
||||
: merge-classes ( nodes node -- )
|
||||
>r (merge-classes) r> set-classes ;
|
||||
|
||||
: set-intervals ( seq node -- )
|
||||
out-d>> [ set-value-interval* ] 2reverse-each ;
|
||||
|
||||
: merge-intervals ( nodes node -- )
|
||||
>r
|
||||
[ node-input-intervals ] map f pad-all flip
|
||||
[ dup first [ interval-union ] reduce ] map
|
||||
r> set-intervals ;
|
||||
|
||||
: annotate-merge ( nodes #merge/#entry -- )
|
||||
[ merge-classes ] [ merge-intervals ] 2bi ;
|
||||
|
||||
: merge-children ( node -- )
|
||||
dup node-successor dup #merge? [
|
||||
swap active-children dup empty?
|
||||
[ 2drop ] [ swap annotate-merge ] if
|
||||
] [ 2drop ] if ;
|
||||
|
||||
: classes= ( inferred current -- ? )
|
||||
2dup min-length [ tail* ] curry bi@ sequence= ;
|
||||
|
||||
SYMBOL: fixed-point?
|
||||
|
||||
SYMBOL: nested-labels
|
||||
|
||||
: annotate-entry ( nodes #label -- )
|
||||
>r (merge-classes) r> node-child
|
||||
2dup node-output-classes classes=
|
||||
[ 2drop ] [ set-classes fixed-point? off ] if ;
|
||||
|
||||
: init-recursive-calls ( #label -- )
|
||||
#! We set recursive calls to output the empty type, then
|
||||
#! repeat inference until a fixed point is reached.
|
||||
#! Hopefully, our type functions are monotonic so this
|
||||
#! will always converge.
|
||||
returns>> [ dup in-d>> [ null ] { } map>assoc >>classes drop ] each ;
|
||||
|
||||
M: #label infer-classes-before ( #label -- )
|
||||
[ init-recursive-calls ]
|
||||
[ [ 1array ] keep annotate-entry ] bi ;
|
||||
|
||||
: infer-label-loop ( #label -- )
|
||||
fixed-point? on
|
||||
dup node-child (infer-classes)
|
||||
dup [ calls>> ] [ suffix ] [ annotate-entry ] tri
|
||||
fixed-point? get [ drop ] [ infer-label-loop ] if ;
|
||||
|
||||
M: #label infer-classes-around ( #label -- )
|
||||
#! Now merge the types at every recursion point with the
|
||||
#! entry types.
|
||||
[
|
||||
{
|
||||
[ nested-labels get push ]
|
||||
[ annotate-node ]
|
||||
[ infer-classes-before ]
|
||||
[ infer-label-loop ]
|
||||
[ drop nested-labels get pop* ]
|
||||
} cleave
|
||||
] with-scope ;
|
||||
|
||||
: find-label ( param -- #label )
|
||||
param>> nested-labels get [ param>> eq? ] with find nip ;
|
||||
|
||||
M: #call-label infer-classes-before ( #call-label -- )
|
||||
[ find-label returns>> (merge-classes) ] [ out-d>> ] bi
|
||||
[ set-value-class* ] 2each ;
|
||||
|
||||
M: #return infer-classes-around
|
||||
nested-labels get length 0 > [
|
||||
dup param>> nested-labels get peek param>> eq? [
|
||||
[ ] [ node-input-classes ] [ in-d>> [ value-class* ] map ] tri
|
||||
classes= not [
|
||||
fixed-point? off
|
||||
[ in-d>> value-classes get valid-keys ] keep
|
||||
set-node-classes
|
||||
] [ drop ] if
|
||||
] [ call-next-method ] if
|
||||
] [ call-next-method ] if ;
|
||||
|
||||
M: object infer-classes-around
|
||||
{
|
||||
[ infer-classes-before ]
|
||||
[ annotate-node ]
|
||||
[ infer-classes-after ]
|
||||
[ infer-children ]
|
||||
[ merge-children ]
|
||||
} cleave ;
|
||||
|
||||
: (infer-classes) ( node -- )
|
||||
[
|
||||
[ infer-classes-around ]
|
||||
[ node-successor ] bi
|
||||
(infer-classes)
|
||||
] when* ;
|
||||
|
||||
: infer-classes-with ( node classes literals intervals -- )
|
||||
[
|
||||
V{ } clone nested-labels set
|
||||
H{ } assoc-like value-intervals set
|
||||
H{ } assoc-like value-literals set
|
||||
H{ } assoc-like value-classes set
|
||||
H{ } clone constraints set
|
||||
(infer-classes)
|
||||
] with-scope ;
|
||||
|
||||
: infer-classes ( node -- node )
|
||||
dup f f f infer-classes-with ;
|
||||
|
||||
: infer-classes/node ( node existing -- )
|
||||
#! Infer classes, using the existing node's class info as a
|
||||
#! starting point.
|
||||
[ classes>> ] [ literals>> ] [ intervals>> ] tri
|
||||
infer-classes-with ;
|
||||
|
|
@ -1 +0,0 @@
|
|||
Static type and class inference
|
||||
|
|
@ -1,6 +0,0 @@
|
|||
USING: help.syntax help.markup ;
|
||||
IN: inference.dataflow
|
||||
|
||||
HELP: #return
|
||||
{ $values { "label" "a word or " { $link f } } { "node" "a new " { $link node } } }
|
||||
{ $description "Creates a node which returns from a nested label, or if " { $snippet "label" } " is " { $link f } ", the top-level word being compiled." } ;
|
||||
|
|
@ -1,320 +0,0 @@
|
|||
! Copyright (C) 2004, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays generic assocs kernel math namespaces parser
|
||||
sequences words vectors math.intervals effects classes
|
||||
inference.state accessors combinators ;
|
||||
IN: inference.dataflow
|
||||
|
||||
! Computed value
|
||||
: <computed> ( -- value ) \ <computed> counter ;
|
||||
|
||||
! Literal value
|
||||
TUPLE: value < identity-tuple literal uid recursion ;
|
||||
|
||||
: <value> ( obj -- value )
|
||||
<computed> recursive-state get value boa ;
|
||||
|
||||
M: value hashcode* nip value-uid ;
|
||||
|
||||
! Result of curry
|
||||
TUPLE: curried obj quot ;
|
||||
|
||||
C: <curried> curried
|
||||
|
||||
! Result of compose
|
||||
TUPLE: composed quot1 quot2 ;
|
||||
|
||||
C: <composed> composed
|
||||
|
||||
UNION: special curried composed ;
|
||||
|
||||
TUPLE: node < identity-tuple
|
||||
param
|
||||
in-d out-d in-r out-r
|
||||
classes literals intervals
|
||||
history successor children ;
|
||||
|
||||
M: node hashcode* drop node hashcode* ;
|
||||
|
||||
GENERIC: flatten-curry ( value -- )
|
||||
|
||||
M: curried flatten-curry
|
||||
[ obj>> flatten-curry ]
|
||||
[ quot>> flatten-curry ] bi ;
|
||||
|
||||
M: composed flatten-curry
|
||||
[ quot1>> flatten-curry ]
|
||||
[ quot2>> flatten-curry ] bi ;
|
||||
|
||||
M: object flatten-curry , ;
|
||||
|
||||
: flatten-curries ( seq -- newseq )
|
||||
dup [ special? ] contains? [
|
||||
[ [ flatten-curry ] each ] { } make
|
||||
] when ;
|
||||
|
||||
: flatten-meta-d ( -- seq )
|
||||
meta-d get clone flatten-curries ;
|
||||
|
||||
: modify-values ( node quot -- )
|
||||
{
|
||||
[ change-in-d ]
|
||||
[ change-in-r ]
|
||||
[ change-out-d ]
|
||||
[ change-out-r ]
|
||||
} cleave drop ; inline
|
||||
|
||||
: node-shuffle ( node -- shuffle )
|
||||
[ in-d>> ] [ out-d>> ] bi <effect> ;
|
||||
|
||||
: param-node ( param class -- node )
|
||||
new swap >>param ; inline
|
||||
|
||||
: in-node ( seq class -- node )
|
||||
new swap >>in-d ; inline
|
||||
|
||||
: all-in-node ( class -- node )
|
||||
flatten-meta-d swap in-node ; inline
|
||||
|
||||
: out-node ( seq class -- node )
|
||||
new swap >>out-d ; inline
|
||||
|
||||
: all-out-node ( class -- node )
|
||||
flatten-meta-d swap out-node ; inline
|
||||
|
||||
: d-tail ( n -- seq )
|
||||
dup zero? [ drop f ] [ meta-d get swap tail* ] if ;
|
||||
|
||||
: r-tail ( n -- seq )
|
||||
dup zero? [ drop f ] [ meta-r get swap tail* ] if ;
|
||||
|
||||
: node-child ( node -- child ) node-children first ;
|
||||
|
||||
TUPLE: #label < node word loop? returns calls ;
|
||||
|
||||
: #label ( word label -- node )
|
||||
\ #label param-node swap >>word ;
|
||||
|
||||
PREDICATE: #loop < #label #label-loop? ;
|
||||
|
||||
TUPLE: #entry < node ;
|
||||
|
||||
: #entry ( -- node ) \ #entry all-out-node ;
|
||||
|
||||
TUPLE: #call < node ;
|
||||
|
||||
: #call ( word -- node ) \ #call param-node ;
|
||||
|
||||
TUPLE: #call-label < node ;
|
||||
|
||||
: #call-label ( label -- node ) \ #call-label param-node ;
|
||||
|
||||
TUPLE: #push < node ;
|
||||
|
||||
: #push ( -- node ) \ #push new ;
|
||||
|
||||
TUPLE: #shuffle < node ;
|
||||
|
||||
: #shuffle ( -- node ) \ #shuffle new ;
|
||||
|
||||
TUPLE: #>r < node ;
|
||||
|
||||
: #>r ( -- node ) \ #>r new ;
|
||||
|
||||
TUPLE: #r> < node ;
|
||||
|
||||
: #r> ( -- node ) \ #r> new ;
|
||||
|
||||
TUPLE: #values < node ;
|
||||
|
||||
: #values ( -- node ) \ #values all-in-node ;
|
||||
|
||||
TUPLE: #return < node ;
|
||||
|
||||
: #return ( label -- node )
|
||||
\ #return all-in-node swap >>param ;
|
||||
|
||||
TUPLE: #branch < node ;
|
||||
|
||||
TUPLE: #if < #branch ;
|
||||
|
||||
: #if ( -- node ) peek-d 1array \ #if in-node ;
|
||||
|
||||
TUPLE: #dispatch < #branch ;
|
||||
|
||||
: #dispatch ( -- node ) peek-d 1array \ #dispatch in-node ;
|
||||
|
||||
! Phi node: merging is a sequence of sequences of values
|
||||
TUPLE: #merge < node merging ;
|
||||
|
||||
: #merge ( -- node ) \ #merge all-out-node ;
|
||||
|
||||
TUPLE: #terminate < node ;
|
||||
|
||||
: #terminate ( -- node ) \ #terminate new ;
|
||||
|
||||
TUPLE: #declare < node ;
|
||||
|
||||
: #declare ( classes -- node ) \ #declare param-node ;
|
||||
|
||||
: node-inputs ( d-count r-count node -- )
|
||||
tuck
|
||||
[ swap d-tail flatten-curries >>in-d drop ]
|
||||
[ swap r-tail flatten-curries >>in-r drop ] 2bi* ;
|
||||
|
||||
: node-outputs ( d-count r-count node -- )
|
||||
tuck
|
||||
[ swap d-tail flatten-curries >>out-d drop ]
|
||||
[ swap r-tail flatten-curries >>out-r drop ] 2bi* ;
|
||||
|
||||
: node, ( node -- )
|
||||
dataflow-graph get [
|
||||
dup current-node [ set-node-successor ] change
|
||||
] [
|
||||
dup dataflow-graph set current-node set
|
||||
] if ;
|
||||
|
||||
: node-values ( node -- values )
|
||||
{ [ in-d>> ] [ out-d>> ] [ in-r>> ] [ out-r>> ] } cleave
|
||||
4array concat ;
|
||||
|
||||
: last-node ( node -- last )
|
||||
dup successor>> [ last-node ] [ ] ?if ;
|
||||
|
||||
: penultimate-node ( node -- penultimate )
|
||||
dup successor>> dup [
|
||||
dup successor>>
|
||||
[ nip penultimate-node ] [ drop ] if
|
||||
] [
|
||||
2drop f
|
||||
] if ;
|
||||
|
||||
: #drop ( n -- #shuffle )
|
||||
d-tail flatten-curries \ #shuffle in-node ;
|
||||
|
||||
: node-exists? ( node quot: ( node -- ? ) -- ? )
|
||||
over [
|
||||
2dup 2slip rot [
|
||||
2drop t
|
||||
] [
|
||||
>r [ children>> ] [ successor>> ] bi suffix r>
|
||||
[ node-exists? ] curry contains?
|
||||
] if
|
||||
] [
|
||||
2drop f
|
||||
] if ; inline recursive
|
||||
|
||||
GENERIC: calls-label* ( label node -- ? )
|
||||
|
||||
M: node calls-label* 2drop f ;
|
||||
|
||||
M: #call-label calls-label* param>> eq? ;
|
||||
|
||||
: calls-label? ( label node -- ? )
|
||||
[ calls-label* ] with node-exists? ;
|
||||
|
||||
: recursive-label? ( node -- ? )
|
||||
[ param>> ] keep calls-label? ;
|
||||
|
||||
SYMBOL: node-stack
|
||||
|
||||
: >node ( node -- ) node-stack get push ;
|
||||
: node> ( -- node ) node-stack get pop ;
|
||||
: node@ ( -- node ) node-stack get peek ;
|
||||
|
||||
: iterate-next ( -- node ) node@ successor>> ;
|
||||
|
||||
: iterate-nodes ( node quot: ( -- ) -- )
|
||||
over [
|
||||
[ swap >node call node> drop ] keep iterate-nodes
|
||||
] [
|
||||
2drop
|
||||
] if ; inline recursive
|
||||
|
||||
: (each-node) ( quot: ( node -- ) -- next )
|
||||
node@ [ swap call ] 2keep
|
||||
node-children [
|
||||
[
|
||||
[ (each-node) ] keep swap
|
||||
] iterate-nodes
|
||||
] each drop
|
||||
iterate-next ; inline recursive
|
||||
|
||||
: with-node-iterator ( quot -- )
|
||||
>r V{ } clone node-stack r> with-variable ; inline
|
||||
|
||||
: each-node ( node quot -- )
|
||||
[
|
||||
swap [
|
||||
[ (each-node) ] keep swap
|
||||
] iterate-nodes drop
|
||||
] with-node-iterator ; inline
|
||||
|
||||
: map-children ( node quot -- )
|
||||
over [
|
||||
over children>> [
|
||||
[ map ] curry change-children drop
|
||||
] [
|
||||
2drop
|
||||
] if
|
||||
] [
|
||||
2drop
|
||||
] if ; inline
|
||||
|
||||
: (transform-nodes) ( prev node quot: ( node -- newnode ) -- )
|
||||
dup >r call dup [
|
||||
>>successor
|
||||
successor>> dup successor>>
|
||||
r> (transform-nodes)
|
||||
] [
|
||||
r> 2drop f >>successor drop
|
||||
] if ; inline recursive
|
||||
|
||||
: transform-nodes ( node quot -- new-node )
|
||||
over [
|
||||
[ call dup dup successor>> ] keep (transform-nodes)
|
||||
] [ drop ] if ; inline
|
||||
|
||||
: node-literal? ( node value -- ? )
|
||||
dup value? >r swap literals>> key? r> or ;
|
||||
|
||||
: node-literal ( node value -- obj )
|
||||
dup value?
|
||||
[ nip value-literal ] [ swap literals>> at ] if ;
|
||||
|
||||
: node-interval ( node value -- interval )
|
||||
swap intervals>> at ;
|
||||
|
||||
: node-class ( node value -- class )
|
||||
swap classes>> at object or ;
|
||||
|
||||
: node-input-classes ( node -- seq )
|
||||
dup in-d>> [ node-class ] with map ;
|
||||
|
||||
: node-output-classes ( node -- seq )
|
||||
dup out-d>> [ node-class ] with map ;
|
||||
|
||||
: node-input-intervals ( node -- seq )
|
||||
dup in-d>> [ node-interval ] with map ;
|
||||
|
||||
: node-class-first ( node -- class )
|
||||
dup in-d>> first node-class ;
|
||||
|
||||
: active-children ( node -- seq )
|
||||
children>> [ last-node ] map [ #terminate? not ] filter ;
|
||||
|
||||
DEFER: #tail?
|
||||
|
||||
PREDICATE: #tail-merge < #merge node-successor #tail? ;
|
||||
|
||||
PREDICATE: #tail-values < #values node-successor #tail? ;
|
||||
|
||||
UNION: #tail
|
||||
POSTPONE: f #return #tail-values #tail-merge #terminate ;
|
||||
|
||||
: tail-call? ( -- ? )
|
||||
#! We don't consider calls which do non-local exits to be
|
||||
#! tail calls, because this gives better error traces.
|
||||
node-stack get [
|
||||
successor>> [ #tail? ] [ #terminate? not ] bi and
|
||||
] all? ;
|
||||
|
|
@ -1 +0,0 @@
|
|||
Dataflow IR used by stack effect inference and compiler
|
||||
|
|
@ -1,54 +0,0 @@
|
|||
! Copyright (C) 2006, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel generic sequences prettyprint io words arrays
|
||||
summary effects debugger assocs accessors inference.backend
|
||||
inference.dataflow ;
|
||||
IN: inference.errors
|
||||
|
||||
M: inference-error error-help error>> error-help ;
|
||||
|
||||
M: inference-error error.
|
||||
dup rstate>>
|
||||
keys [ dup value? [ value-literal ] when ] map
|
||||
dup empty? [ "Word: " write dup peek . ] unless
|
||||
swap error>> error. "Nesting: " write . ;
|
||||
|
||||
M: unbalanced-branches-error error.
|
||||
"Unbalanced branches:" print
|
||||
[ quots>> ] [ in>> ] [ out>> [ length ] map ] tri 3array flip
|
||||
[ [ bl ] [ pprint ] interleave nl ] each ;
|
||||
|
||||
M: literal-expected summary
|
||||
drop "Literal value expected" ;
|
||||
|
||||
M: too-many->r summary
|
||||
drop
|
||||
"Quotation pushes elements on retain stack without popping them" ;
|
||||
|
||||
M: too-many-r> summary
|
||||
drop
|
||||
"Quotation pops retain stack elements which it did not push" ;
|
||||
|
||||
M: cannot-infer-effect error.
|
||||
"Unable to infer stack effect of " write word>> . ;
|
||||
|
||||
M: missing-effect error.
|
||||
"The word " write
|
||||
word>> pprint
|
||||
" must declare a stack effect" print ;
|
||||
|
||||
M: effect-error error.
|
||||
"Stack effects of the word " write
|
||||
[ word>> pprint " do not match." print ]
|
||||
[ "Inferred: " write inferred>> effect>string . ]
|
||||
[ "Declared: " write declared>> effect>string . ] tri ;
|
||||
|
||||
M: recursive-quotation-error error.
|
||||
"The quotation " write
|
||||
quot>> pprint
|
||||
" calls itself." print
|
||||
"Stack effect inference is undecidable when quotation-level recursion is permitted." print ;
|
||||
|
||||
M: cannot-unify-specials summary
|
||||
drop
|
||||
"Cannot unify branches with inconsistent special values" ;
|
||||
|
|
@ -1,161 +0,0 @@
|
|||
USING: help.syntax help.markup kernel sequences words io
|
||||
effects inference.dataflow inference.backend classes
|
||||
math combinators inference.transforms inference.state ;
|
||||
IN: inference
|
||||
|
||||
ARTICLE: "inference-simple" "Straight-line stack effects"
|
||||
"The simplest case to look at is that of a quotation which does not have any branches or recursion, and just pushes literals and calls words, each of which has a known stack effect."
|
||||
$nl
|
||||
"Stack effect inference works by stepping through the quotation, while maintaining a \"shadow stack\" which tracks stack height at the current position in the quotation. Initially, the shadow stack is empty. If a word is encountered which expects more values than there are on the shadow stack, a global counter is incremented. This counter keeps track of the number of inputs the quotation expects on the stack. When inference is done, this counter, together with the final height of the shadow stack, gives the inferred stack effect."
|
||||
{ $subsection d-in }
|
||||
{ $subsection meta-d }
|
||||
"When a literal is encountered, it is simply pushed on the shadow stack. For example, the stack effect of the following quotation is inferred by pushing all three literals on the shadow stack, then taking the value of " { $link d-in } " and the length of " { $link meta-d } ":"
|
||||
{ $example "[ 1 2 3 ] infer." "( -- object object object )" }
|
||||
"In the following example, the call to " { $link + } " expects two values on the shadow stack, but only one value is present, the literal which was pushed previously. This increments the " { $link d-in } " counter by one:"
|
||||
{ $example "[ 2 + ] infer." "( object -- object )" }
|
||||
"After the call to " { $link + } ", the shadow stack contains a \"computed value placeholder\", since the inferencer has no way to know what the resulting value actually is (in fact it is arbitrary)." ;
|
||||
|
||||
ARTICLE: "inference-combinators" "Combinator stack effects"
|
||||
"Without further information, one cannot say what the stack effect of " { $link call } " is; it depends on the given quotation. If the inferencer encounters a " { $link call } " without further information, a " { $link literal-expected } " error is raised."
|
||||
{ $example "[ dup call ] infer." "... an error ..." }
|
||||
"On the other hand, the stack effect of applying " { $link call } " to a literal quotation or a " { $link curry } " of a literal quotation is easy to compute; it behaves as if the quotation was substituted at that point:"
|
||||
{ $example "[ [ 2 + ] call ] infer." "( object -- object )" }
|
||||
"Consider a combinator such as " { $link keep } ". The combinator itself does not have a stack effect, because it applies " { $link call } " to a potentially arbitrary quotation. However, since the combinator is declared " { $link POSTPONE: inline } ", a given usage of it can have a stack effect:"
|
||||
{ $example "[ [ 2 + ] keep ] infer." "( object -- object object )" }
|
||||
"Another example is the " { $link compose } " combinator. Because it is decared " { $link POSTPONE: inline } ", we can infer the stack effect of applying " { $link call } " to the result of " { $link compose } ":"
|
||||
{ $example "[ 2 [ + ] curry [ sq ] compose ] infer." "( -- object object )" }
|
||||
"Incidentally, this example demonstrates that the stack effect of nested currying and composition can also be inferred."
|
||||
$nl
|
||||
"A general rule of thumb is that any word which applies " { $link call } " or " { $link curry } " to one of its inputs must be declared " { $link POSTPONE: inline } "."
|
||||
$nl
|
||||
"Here is an example where the stack effect cannot be inferred:"
|
||||
{ $code ": foo 0 [ + ] ;" "[ foo reduce ] infer." }
|
||||
"However if " { $snippet "foo" } " was declared " { $link POSTPONE: inline } ", everything would work, since the " { $link reduce } " combinator is also " { $link POSTPONE: inline } ", and the inferencer can see the literal quotation value at the point it is passed to " { $link call } ":"
|
||||
{ $example ": foo 0 [ + ] ; inline" "[ foo reduce ] infer." "( object -- object )" } ;
|
||||
|
||||
ARTICLE: "inference-branches" "Branch stack effects"
|
||||
"Conditionals such as " { $link if } " and combinators built on " { $link if } " present a problem, in that if the two branches leave the stack at a different height, it is not clear what the stack effect should be. In this case, inference throws a " { $link unbalanced-branches-error } "."
|
||||
$nl
|
||||
"If all branches leave the stack at the same height, then the stack effect of the conditional is just the maximum of the stack effect of each branch. For example,"
|
||||
{ $example "[ [ + ] [ drop ] if ] infer." "( object object object -- object )" }
|
||||
"The call to " { $link if } " takes one value from the stack, a generalized boolean. The first branch " { $snippet "[ + ]" } " has stack effect " { $snippet "( x x -- x )" } " and the second has stack effect " { $snippet "( x -- )" } ". Since both branches decrease the height of the stack by one, we say that the stack effect of the two branches is " { $snippet "( x x -- x )" } ", and together with the boolean popped off the stack by " { $link if } ", this gives a total stack effect of " { $snippet "( x x x -- x )" } "." ;
|
||||
|
||||
ARTICLE: "inference-recursive" "Stack effects of recursive words"
|
||||
"Recursive words must declare a stack effect. When a recursive call is encountered, the declared stack effect is substituted in. When inference is complete, the inferred stack effect is compared with the declared stack effect."
|
||||
$nl
|
||||
"Attempting to infer the stack effect of a recursive word which outputs a variable number of objects on the stack will fail. For example, the following will throw an " { $link unbalanced-branches-error } ":"
|
||||
{ $code ": foo ( seq -- ) dup empty? [ drop ] [ dup pop foo ] if" "[ foo ] infer." }
|
||||
"If you declare an incorrect stack effect, inference will fail also. Badly defined recursive words cannot confuse the inferencer." ;
|
||||
|
||||
ARTICLE: "inference-limitations" "Inference limitations"
|
||||
"Mutually recursive words are supported, but mutually recursive " { $emphasis "inline" } " words are not."
|
||||
$nl
|
||||
"An inline recursive word cannot pass a quotation through the recursive call. For example, the following will not infer:"
|
||||
{ $code ": foo ( a b c -- d e f ) [ f foo drop ] when 2dup call ; inline" "[ 1 [ 1+ ] foo ] infer." }
|
||||
"However a small change can be made:"
|
||||
{ $example ": foo ( a b c -- d ) [ 2dup f foo drop ] when call ; inline" "[ 1 [ 1+ ] t foo ] infer." "( -- object )" }
|
||||
"An inline recursive word must have a fixed stack effect in its base case. The following will not infer:"
|
||||
{ $code
|
||||
": foo ( quot ? -- ) [ f foo ] [ call ] if ; inline"
|
||||
"[ [ 5 ] t foo ] infer."
|
||||
} ;
|
||||
|
||||
ARTICLE: "compiler-transforms" "Compiler transforms"
|
||||
"Compiler transforms can be used to allow words to compile which would otherwise not have a stack effect, and to expand combinators into more efficient code at compile time."
|
||||
{ $subsection define-transform }
|
||||
"An example is the " { $link cond } " word. If the association list of quotations it is given is literal, the entire form is expanded into a series of nested calls to " { $link if } "."
|
||||
$nl
|
||||
"Further customization can be achieved by hooking into the lower-level machinery used by " { $link define-transform } ", the " { $snippet "\"infer\"" } " word property."
|
||||
$nl
|
||||
"This property can hold a quotation to be called when the stack effect of a call to this word is being inferred. This quotation can access all internal state of the stack effect inferencer, such as the known literals on the data stack."
|
||||
{ $subsection pop-literal }
|
||||
{ $subsection infer-quot }
|
||||
{ $subsection infer-quot-value }
|
||||
"The " { $vocab-link "macros" } " vocabulary defines some nice syntax sugar which makes compiler transforms easier to work with." ;
|
||||
|
||||
ARTICLE: "dataflow-graphs" "Inspecting the dataflow graph"
|
||||
"The dataflow graph used by " { $link "compiler" } " can be obtained:"
|
||||
{ $subsection dataflow }
|
||||
"The " { $vocab-link "optimizer.debugger" } " tool prints the dataflow graph in human readable form."
|
||||
$nl ;
|
||||
|
||||
ARTICLE: "inference-errors" "Inference errors"
|
||||
"Main wrapper for all inference errors:"
|
||||
{ $subsection inference-error }
|
||||
"Specific inference errors:"
|
||||
{ $subsection cannot-infer-effect }
|
||||
{ $subsection literal-expected }
|
||||
{ $subsection too-many->r }
|
||||
{ $subsection too-many-r> }
|
||||
{ $subsection unbalanced-branches-error }
|
||||
{ $subsection effect-error }
|
||||
{ $subsection missing-effect } ;
|
||||
|
||||
ARTICLE: "inference" "Stack effect inference"
|
||||
"The stack effect inference tool is used to check correctness of code before it is run. It is also used by the optimizing compiler to build a dataflow graph on which optimizations can be performed. Only words for which a stack effect can be inferred will compile with the optimizing compiler; all other words will be compiled with the non-optimizing compiler (see " { $link "compiler" } ")."
|
||||
$nl
|
||||
"The main entry point is a single word which takes a quotation and prints its stack effect and variable usage:"
|
||||
{ $subsection infer. }
|
||||
"Instead of printing the inferred information, it can be returned as objects on the stack:"
|
||||
{ $subsection infer }
|
||||
"Static stack effect inference can be combined with unit tests; see " { $link "tools.test.write" } "."
|
||||
$nl
|
||||
"The following articles describe the implementation of the stack effect inference algorithm:"
|
||||
{ $subsection "inference-simple" }
|
||||
{ $subsection "inference-combinators" }
|
||||
{ $subsection "inference-branches" }
|
||||
{ $subsection "inference-recursive" }
|
||||
{ $subsection "inference-limitations" }
|
||||
{ $subsection "inference-errors" }
|
||||
{ $subsection "dataflow-graphs" }
|
||||
{ $subsection "compiler-transforms" }
|
||||
{ $see-also "effects" } ;
|
||||
|
||||
ABOUT: "inference"
|
||||
|
||||
HELP: inference-error
|
||||
{ $values { "class" class } }
|
||||
{ $description "Creates an instance of " { $snippet "class" } ", wraps it in an " { $link inference-error } " and throws the result." }
|
||||
{ $error-description
|
||||
"Thrown by " { $link infer } " and " { $link dataflow } " when the stack effect of a quotation cannot be inferred."
|
||||
$nl
|
||||
"The " { $snippet "error" } " slot contains one of several possible " { $link "inference-errors" } "."
|
||||
} ;
|
||||
|
||||
|
||||
HELP: dataflow-graph
|
||||
{ $var-description "In the dynamic extent of " { $link infer } " and " { $link dataflow } ", holds the first node of the dataflow graph being constructed." } ;
|
||||
|
||||
HELP: current-node
|
||||
{ $var-description "In the dynamic extent of " { $link infer } " and " { $link dataflow } ", holds the most recently added node of the dataflow graph being constructed." } ;
|
||||
|
||||
HELP: infer
|
||||
{ $values { "quot" "a quotation" } { "effect" "an instance of " { $link effect } } }
|
||||
{ $description "Attempts to infer the quotation's stack effect. For interactive testing, the " { $link infer. } " word should be called instead since it presents the output in a nicely formatted manner." }
|
||||
{ $errors "Throws an " { $link inference-error } " if stack effect inference fails." } ;
|
||||
|
||||
HELP: infer.
|
||||
{ $values { "quot" "a quotation" } }
|
||||
{ $description "Attempts to infer the quotation's stack effect, and prints this data to " { $link output-stream } "." }
|
||||
{ $errors "Throws an " { $link inference-error } " if stack effect inference fails." } ;
|
||||
|
||||
{ infer infer. } related-words
|
||||
|
||||
HELP: dataflow
|
||||
{ $values { "quot" "a quotation" } { "dataflow" "a dataflow node" } }
|
||||
{ $description "Attempts to construct a dataflow graph showing stack flow in the quotation." }
|
||||
{ $notes "This is the first stage of the compiler." }
|
||||
{ $errors "Throws an " { $link inference-error } " if stack effect inference fails." } ;
|
||||
|
||||
HELP: dataflow-with
|
||||
{ $values { "quot" "a quotation" } { "stack" "a vector" } { "dataflow" "a dataflow node" } }
|
||||
{ $description "Attempts to construct a dataflow graph showing stack flow in the quotation, starting with an initial data stack of values." }
|
||||
{ $errors "Throws an " { $link inference-error } " if stack effect inference fails." } ;
|
||||
|
||||
HELP: forget-errors
|
||||
{ $description "Removes markers indicating which words do not have stack effects."
|
||||
$nl
|
||||
"The stack effect inference code remembers which words failed to infer as an optimization, so that it does not try to infer the stack effect of words which do not have one over and over again." }
|
||||
{ $notes "Usually this word does not need to be called directly; if a word failed to compile because of a stack effect error, fixing the word definition clears the flag automatically. However, if words failed to compile due to external factors which were subsequently rectified, such as an unavailable C library or a missing or broken compiler transform, this flag can be cleared for all words:"
|
||||
{ $code "forget-errors" }
|
||||
"Subsequent invocations of the compiler will consider all words for compilation." } ;
|
||||
|
|
@ -1,573 +0,0 @@
|
|||
USING: accessors arrays generic inference inference.backend
|
||||
inference.dataflow kernel classes kernel.private math
|
||||
math.parser math.private namespaces namespaces.private parser
|
||||
sequences strings vectors words quotations effects tools.test
|
||||
continuations generic.standard sorting assocs definitions
|
||||
prettyprint io inspector classes.tuple classes.union
|
||||
classes.predicate debugger threads.private io.streams.string
|
||||
io.timeouts io.thread sequences.private destructors eval ;
|
||||
IN: inference.tests
|
||||
|
||||
[ ] [ [ 1 ] dataflow [ ] transform-nodes drop ] unit-test
|
||||
[ ] [ [ 1 2 3 ] dataflow [ ] transform-nodes drop ] unit-test
|
||||
|
||||
{ 0 2 } [ 2 "Hello" ] must-infer-as
|
||||
{ 1 2 } [ dup ] must-infer-as
|
||||
|
||||
{ 1 2 } [ [ dup ] call ] must-infer-as
|
||||
[ [ call ] infer ] must-fail
|
||||
|
||||
{ 2 4 } [ 2dup ] must-infer-as
|
||||
|
||||
{ 1 0 } [ [ ] [ ] if ] must-infer-as
|
||||
[ [ if ] infer ] must-fail
|
||||
[ [ [ ] if ] infer ] must-fail
|
||||
[ [ [ 2 ] [ ] if ] infer ] must-fail
|
||||
{ 4 3 } [ [ rot ] [ -rot ] if ] must-infer-as
|
||||
|
||||
{ 4 3 } [
|
||||
[
|
||||
[ swap 3 ] [ nip 5 5 ] if
|
||||
] [
|
||||
-rot
|
||||
] if
|
||||
] must-infer-as
|
||||
|
||||
{ 1 1 } [ dup [ ] when ] must-infer-as
|
||||
{ 1 1 } [ dup [ dup fixnum* ] when ] must-infer-as
|
||||
{ 2 1 } [ [ dup fixnum* ] when ] must-infer-as
|
||||
|
||||
{ 1 0 } [ [ drop ] when* ] must-infer-as
|
||||
{ 1 1 } [ [ { { [ ] } } ] unless* ] must-infer-as
|
||||
|
||||
{ 0 1 }
|
||||
[ [ 2 2 fixnum+ ] dup [ ] when call ] must-infer-as
|
||||
|
||||
[
|
||||
[ [ [ 2 2 fixnum+ ] ] [ [ 2 2 fixnum* ] ] if call ] infer
|
||||
] must-fail
|
||||
|
||||
! Test inference of termination of control flow
|
||||
: termination-test-1 ( -- * ) "foo" throw ;
|
||||
|
||||
: termination-test-2 ( ? -- x ) [ termination-test-1 ] [ 3 ] if ;
|
||||
|
||||
{ 1 1 } [ termination-test-2 ] must-infer-as
|
||||
|
||||
: simple-recursion-1 ( obj -- obj )
|
||||
dup [ simple-recursion-1 ] [ ] if ;
|
||||
|
||||
{ 1 1 } [ simple-recursion-1 ] must-infer-as
|
||||
|
||||
: simple-recursion-2 ( obj -- obj )
|
||||
dup [ ] [ simple-recursion-2 ] if ;
|
||||
|
||||
{ 1 1 } [ simple-recursion-2 ] must-infer-as
|
||||
|
||||
: bad-recursion-2 ( obj -- obj )
|
||||
dup [ dup first swap second bad-recursion-2 ] [ ] if ;
|
||||
|
||||
[ [ bad-recursion-2 ] infer ] must-fail
|
||||
|
||||
: funny-recursion ( obj -- obj )
|
||||
dup [ funny-recursion 1 ] [ 2 ] if drop ;
|
||||
|
||||
{ 1 1 } [ funny-recursion ] must-infer-as
|
||||
|
||||
! Simple combinators
|
||||
{ 1 2 } [ [ first ] keep second ] must-infer-as
|
||||
|
||||
! Mutual recursion
|
||||
DEFER: foe
|
||||
|
||||
: fie ( element obj -- ? )
|
||||
dup array? [ foe ] [ eq? ] if ;
|
||||
|
||||
: foe ( element tree -- ? )
|
||||
dup [
|
||||
2dup first fie [
|
||||
nip
|
||||
] [
|
||||
second dup array? [
|
||||
foe
|
||||
] [
|
||||
fie
|
||||
] if
|
||||
] if
|
||||
] [
|
||||
2drop f
|
||||
] if ;
|
||||
|
||||
{ 2 1 } [ fie ] must-infer-as
|
||||
{ 2 1 } [ foe ] must-infer-as
|
||||
|
||||
: nested-when ( -- )
|
||||
t [
|
||||
t [
|
||||
5 drop
|
||||
] when
|
||||
] when ;
|
||||
|
||||
{ 0 0 } [ nested-when ] must-infer-as
|
||||
|
||||
: nested-when* ( obj -- )
|
||||
[
|
||||
[
|
||||
drop
|
||||
] when*
|
||||
] when* ;
|
||||
|
||||
{ 1 0 } [ nested-when* ] must-infer-as
|
||||
|
||||
SYMBOL: sym-test
|
||||
|
||||
{ 0 1 } [ sym-test ] must-infer-as
|
||||
|
||||
: terminator-branch ( a -- b )
|
||||
dup [
|
||||
length
|
||||
] [
|
||||
"foo" throw
|
||||
] if ;
|
||||
|
||||
{ 1 1 } [ terminator-branch ] must-infer-as
|
||||
|
||||
: recursive-terminator ( obj -- )
|
||||
dup [
|
||||
recursive-terminator
|
||||
] [
|
||||
"Hi" throw
|
||||
] if ;
|
||||
|
||||
{ 1 0 } [ recursive-terminator ] must-infer-as
|
||||
|
||||
GENERIC: potential-hang ( obj -- obj )
|
||||
M: fixnum potential-hang dup [ potential-hang ] when ;
|
||||
|
||||
[ ] [ [ 5 potential-hang ] infer drop ] unit-test
|
||||
|
||||
TUPLE: funny-cons car cdr ;
|
||||
GENERIC: iterate ( obj -- )
|
||||
M: funny-cons iterate funny-cons-cdr iterate ;
|
||||
M: f iterate drop ;
|
||||
M: real iterate drop ;
|
||||
|
||||
{ 1 0 } [ iterate ] must-infer-as
|
||||
|
||||
! Regression
|
||||
: cat ( obj -- * ) dup [ throw ] [ throw ] if ;
|
||||
: dog ( a b c -- ) dup [ cat ] [ 3drop ] if ;
|
||||
{ 3 0 } [ dog ] must-infer-as
|
||||
|
||||
! Regression
|
||||
DEFER: monkey
|
||||
: friend ( a b c -- ) dup [ friend ] [ monkey ] if ;
|
||||
: monkey ( a b c -- ) dup [ 3drop ] [ friend ] if ;
|
||||
{ 3 0 } [ friend ] must-infer-as
|
||||
|
||||
! Regression -- same as above but we infer the second word first
|
||||
DEFER: blah2
|
||||
: blah ( a b c -- ) dup [ blah ] [ blah2 ] if ;
|
||||
: blah2 ( a b c -- ) dup [ blah ] [ 3drop ] if ;
|
||||
{ 3 0 } [ blah2 ] must-infer-as
|
||||
|
||||
! Regression
|
||||
DEFER: blah4
|
||||
: blah3 ( a b c -- )
|
||||
dup [ blah3 ] [ dup [ blah4 ] [ blah3 ] if ] if ;
|
||||
: blah4 ( a b c -- )
|
||||
dup [ blah4 ] [ dup [ 3drop ] [ blah3 ] if ] if ;
|
||||
{ 3 0 } [ blah4 ] must-infer-as
|
||||
|
||||
! Regression
|
||||
: bad-combinator ( obj quot -- )
|
||||
over [
|
||||
2drop
|
||||
] [
|
||||
[ swap slip ] keep swap bad-combinator
|
||||
] if ; inline
|
||||
|
||||
[ [ [ 1 ] [ ] bad-combinator ] infer ] must-fail
|
||||
|
||||
! Regression
|
||||
{ 2 2 } [
|
||||
dup string? [ 2array throw ] unless
|
||||
over string? [ 2array throw ] unless
|
||||
] must-infer-as
|
||||
|
||||
! Regression
|
||||
|
||||
! This order of branches works
|
||||
DEFER: do-crap
|
||||
: more-crap ( obj -- ) dup [ drop ] [ dup do-crap call ] if ;
|
||||
: do-crap ( obj -- ) dup [ more-crap ] [ do-crap ] if ;
|
||||
[ [ do-crap ] infer ] must-fail
|
||||
|
||||
! This one does not
|
||||
DEFER: do-crap*
|
||||
: more-crap* ( obj -- ) dup [ drop ] [ dup do-crap* call ] if ;
|
||||
: do-crap* ( obj -- ) dup [ do-crap* ] [ more-crap* ] if ;
|
||||
[ [ do-crap* ] infer ] must-fail
|
||||
|
||||
! Regression
|
||||
: too-deep ( a b -- c )
|
||||
dup [ drop ] [ 2dup too-deep too-deep * ] if ; inline
|
||||
{ 2 1 } [ too-deep ] must-infer-as
|
||||
|
||||
! Error reporting is wrong
|
||||
MATH: xyz ( a b -- c )
|
||||
M: fixnum xyz 2array ;
|
||||
M: float xyz
|
||||
[ 3 ] bi@ swapd >r 2array swap r> 2array swap ;
|
||||
|
||||
[ [ xyz ] infer ] [ inference-error? ] must-fail-with
|
||||
|
||||
! Doug Coleman discovered this one while working on the
|
||||
! calendar library
|
||||
DEFER: A
|
||||
DEFER: B
|
||||
DEFER: C
|
||||
|
||||
: A ( a -- )
|
||||
dup {
|
||||
[ drop ]
|
||||
[ A ]
|
||||
[ \ A no-method ]
|
||||
[ dup C A ]
|
||||
} dispatch ;
|
||||
|
||||
: B ( b -- )
|
||||
dup {
|
||||
[ C ]
|
||||
[ B ]
|
||||
[ \ B no-method ]
|
||||
[ dup B B ]
|
||||
} dispatch ;
|
||||
|
||||
: C ( c -- )
|
||||
dup {
|
||||
[ A ]
|
||||
[ C ]
|
||||
[ \ C no-method ]
|
||||
[ dup B C ]
|
||||
} dispatch ;
|
||||
|
||||
{ 1 0 } [ A ] must-infer-as
|
||||
{ 1 0 } [ B ] must-infer-as
|
||||
{ 1 0 } [ C ] must-infer-as
|
||||
|
||||
! I found this bug by thinking hard about the previous one
|
||||
DEFER: Y
|
||||
: X ( a b -- c d ) dup [ swap Y ] [ ] if ;
|
||||
: Y ( a b -- c d ) X ;
|
||||
|
||||
{ 2 2 } [ X ] must-infer-as
|
||||
{ 2 2 } [ Y ] must-infer-as
|
||||
|
||||
! This one comes from UI code
|
||||
DEFER: #1
|
||||
: #2 ( a b -- ) dup [ call ] [ 2drop ] if ; inline
|
||||
: #3 ( a -- ) [ #1 ] #2 ;
|
||||
: #4 ( a -- ) dup [ drop ] [ dup #4 dup #3 call ] if ;
|
||||
: #1 ( a -- ) dup [ dup #4 dup #3 ] [ ] if drop ;
|
||||
|
||||
[ \ #4 def>> infer ] must-fail
|
||||
[ [ #1 ] infer ] must-fail
|
||||
|
||||
! Similar
|
||||
DEFER: bar
|
||||
: foo ( a b -- c d ) dup [ 2drop f f bar ] [ ] if ;
|
||||
: bar ( a b -- ) [ 2 2 + ] t foo drop call drop ;
|
||||
|
||||
[ [ foo ] infer ] must-fail
|
||||
|
||||
[ 1234 infer ] must-fail
|
||||
|
||||
! This used to hang
|
||||
[ [ [ dup call ] dup call ] infer ]
|
||||
[ inference-error? ] must-fail-with
|
||||
|
||||
: m dup call ; inline
|
||||
|
||||
[ [ [ m ] m ] infer ] [ inference-error? ] must-fail-with
|
||||
|
||||
: m' dup curry call ; inline
|
||||
|
||||
[ [ [ m' ] m' ] infer ] [ inference-error? ] must-fail-with
|
||||
|
||||
: m'' [ dup curry ] ; inline
|
||||
|
||||
: m''' m'' call call ; inline
|
||||
|
||||
[ [ [ m''' ] m''' ] infer ] [ inference-error? ] must-fail-with
|
||||
|
||||
: m-if t over if ; inline
|
||||
|
||||
[ [ [ m-if ] m-if ] infer ] [ inference-error? ] must-fail-with
|
||||
|
||||
! This doesn't hang but it's also an example of the
|
||||
! undedicable case
|
||||
[ [ [ [ drop 3 ] swap call ] dup call ] infer ]
|
||||
[ inference-error? ] must-fail-with
|
||||
|
||||
! This form should not have a stack effect
|
||||
|
||||
: bad-recursion-1 ( a -- b )
|
||||
dup [ drop bad-recursion-1 5 ] [ ] if ;
|
||||
|
||||
[ [ bad-recursion-1 ] infer ] must-fail
|
||||
|
||||
: bad-bin ( a b -- ) 5 [ 5 bad-bin bad-bin 5 ] [ 2drop ] if ;
|
||||
[ [ bad-bin ] infer ] must-fail
|
||||
|
||||
[ [ r> ] infer ] [ inference-error? ] must-fail-with
|
||||
|
||||
! Regression
|
||||
[ [ get-slots ] infer ] [ inference-error? ] must-fail-with
|
||||
|
||||
! Test some curry stuff
|
||||
{ 1 1 } [ 3 [ ] curry 4 [ ] curry if ] must-infer-as
|
||||
|
||||
{ 2 1 } [ [ ] curry 4 [ ] curry if ] must-infer-as
|
||||
|
||||
[ [ 3 [ ] curry 1 2 [ ] 2curry if ] infer ] must-fail
|
||||
|
||||
! Test number protocol
|
||||
\ bitor must-infer
|
||||
\ bitand must-infer
|
||||
\ bitxor must-infer
|
||||
\ mod must-infer
|
||||
\ /i must-infer
|
||||
\ /f must-infer
|
||||
\ /mod must-infer
|
||||
\ + must-infer
|
||||
\ - must-infer
|
||||
\ * must-infer
|
||||
\ / must-infer
|
||||
\ < must-infer
|
||||
\ <= must-infer
|
||||
\ > must-infer
|
||||
\ >= must-infer
|
||||
\ number= must-infer
|
||||
|
||||
! Test object protocol
|
||||
\ = must-infer
|
||||
\ clone must-infer
|
||||
\ hashcode* must-infer
|
||||
|
||||
! Test sequence protocol
|
||||
\ length must-infer
|
||||
\ nth must-infer
|
||||
\ set-length must-infer
|
||||
\ set-nth must-infer
|
||||
\ new must-infer
|
||||
\ new-resizable must-infer
|
||||
\ like must-infer
|
||||
\ lengthen must-infer
|
||||
|
||||
! Test assoc protocol
|
||||
\ at* must-infer
|
||||
\ set-at must-infer
|
||||
\ new-assoc must-infer
|
||||
\ delete-at must-infer
|
||||
\ clear-assoc must-infer
|
||||
\ assoc-size must-infer
|
||||
\ assoc-like must-infer
|
||||
\ assoc-clone-like must-infer
|
||||
\ >alist must-infer
|
||||
{ 1 3 } [ [ 2drop f ] assoc-find ] must-infer-as
|
||||
|
||||
! Test some random library words
|
||||
\ 1quotation must-infer
|
||||
\ string>number must-infer
|
||||
\ get must-infer
|
||||
|
||||
\ push must-infer
|
||||
\ append must-infer
|
||||
\ peek must-infer
|
||||
|
||||
\ reverse must-infer
|
||||
\ member? must-infer
|
||||
\ remove must-infer
|
||||
\ natural-sort must-infer
|
||||
|
||||
\ forget must-infer
|
||||
\ define-class must-infer
|
||||
\ define-tuple-class must-infer
|
||||
\ define-union-class must-infer
|
||||
\ define-predicate-class must-infer
|
||||
\ instance? must-infer
|
||||
\ next-method-quot must-infer
|
||||
|
||||
! Test words with continuations
|
||||
{ 0 0 } [ [ drop ] callcc0 ] must-infer-as
|
||||
{ 0 1 } [ [ 4 swap continue-with ] callcc1 ] must-infer-as
|
||||
{ 2 1 } [ [ + ] [ ] [ ] cleanup ] must-infer-as
|
||||
{ 2 1 } [ [ + ] [ 3drop 0 ] recover ] must-infer-as
|
||||
|
||||
\ dispose must-infer
|
||||
|
||||
! Test stream protocol
|
||||
\ set-timeout must-infer
|
||||
\ stream-read must-infer
|
||||
\ stream-read1 must-infer
|
||||
\ stream-readln must-infer
|
||||
\ stream-read-until must-infer
|
||||
\ stream-write must-infer
|
||||
\ stream-write1 must-infer
|
||||
\ stream-nl must-infer
|
||||
\ stream-format must-infer
|
||||
\ stream-write-table must-infer
|
||||
\ stream-flush must-infer
|
||||
\ make-span-stream must-infer
|
||||
\ make-block-stream must-infer
|
||||
\ make-cell-stream must-infer
|
||||
|
||||
! Test stream utilities
|
||||
\ lines must-infer
|
||||
\ contents must-infer
|
||||
|
||||
! Test prettyprinting
|
||||
\ . must-infer
|
||||
\ short. must-infer
|
||||
\ unparse must-infer
|
||||
|
||||
\ describe must-infer
|
||||
\ error. must-infer
|
||||
|
||||
! Test odds and ends
|
||||
\ io-thread must-infer
|
||||
|
||||
! Incorrect stack declarations on inline recursive words should
|
||||
! be caught
|
||||
: fooxxx ( a b -- c ) over [ foo ] when ; inline
|
||||
: barxxx ( a b -- c ) fooxxx ;
|
||||
|
||||
[ [ barxxx ] infer ] must-fail
|
||||
|
||||
! A typo
|
||||
{ 1 0 } [ { [ ] } dispatch ] must-infer-as
|
||||
|
||||
DEFER: inline-recursive-2
|
||||
: inline-recursive-1 ( -- ) inline-recursive-2 ;
|
||||
: inline-recursive-2 ( -- ) inline-recursive-1 ;
|
||||
|
||||
{ 0 0 } [ inline-recursive-1 ] must-infer-as
|
||||
|
||||
! Hooks
|
||||
SYMBOL: my-var
|
||||
HOOK: my-hook my-var ( -- x )
|
||||
|
||||
M: integer my-hook "an integer" ;
|
||||
M: string my-hook "a string" ;
|
||||
|
||||
{ 0 1 } [ my-hook ] must-infer-as
|
||||
|
||||
DEFER: deferred-word
|
||||
|
||||
{ 1 1 } [ [ deferred-word ] [ 3 ] if ] must-infer-as
|
||||
|
||||
USE: inference.dataflow
|
||||
|
||||
{ 1 0 } [ [ iterate-next ] iterate-nodes ] must-infer-as
|
||||
|
||||
{ 1 0 }
|
||||
[
|
||||
[ [ iterate-next ] iterate-nodes ] with-node-iterator
|
||||
] must-infer-as
|
||||
|
||||
: nilpotent ( quot -- )
|
||||
t [ [ call ] keep nilpotent ] [ drop ] if ; inline
|
||||
|
||||
: semisimple ( quot -- )
|
||||
[ call ] keep [ [ semisimple ] keep ] nilpotent drop ; inline
|
||||
|
||||
{ 0 1 }
|
||||
[ [ ] [ call ] keep [ [ call ] keep ] nilpotent ]
|
||||
must-infer-as
|
||||
|
||||
{ 0 0 } [ [ ] semisimple ] must-infer-as
|
||||
|
||||
{ 1 0 } [ [ drop ] each-node ] must-infer-as
|
||||
|
||||
DEFER: an-inline-word
|
||||
|
||||
: normal-word-3 ( -- )
|
||||
3 [ [ 2 + ] curry ] an-inline-word call drop ;
|
||||
|
||||
: normal-word-2 ( -- )
|
||||
normal-word-3 ;
|
||||
|
||||
: normal-word ( x -- x )
|
||||
dup [ normal-word-2 ] when ;
|
||||
|
||||
: an-inline-word ( obj quot -- )
|
||||
>r normal-word r> call ; inline
|
||||
|
||||
{ 1 1 } [ [ 3 * ] an-inline-word ] must-infer-as
|
||||
|
||||
{ 0 1 } [ [ 2 ] [ 2 ] [ + ] compose compose call ] must-infer-as
|
||||
|
||||
ERROR: custom-error ;
|
||||
|
||||
[ T{ effect f 0 0 t } ] [
|
||||
[ custom-error ] infer
|
||||
] unit-test
|
||||
|
||||
: funny-throw throw ; inline
|
||||
|
||||
[ T{ effect f 0 0 t } ] [
|
||||
[ 3 funny-throw ] infer
|
||||
] unit-test
|
||||
|
||||
[ T{ effect f 0 0 t } ] [
|
||||
[ custom-error inference-error ] infer
|
||||
] unit-test
|
||||
|
||||
[ T{ effect f 1 1 t } ] [
|
||||
[ dup >r 3 throw r> ] infer
|
||||
] unit-test
|
||||
|
||||
! This was a false trigger of the undecidable quotation
|
||||
! recursion bug
|
||||
{ 2 1 } [ find-last-sep ] must-infer-as
|
||||
|
||||
! Regression
|
||||
: missing->r-check >r ;
|
||||
|
||||
[ [ missing->r-check ] infer ] must-fail
|
||||
|
||||
{ 1 0 } [ [ ] map-children ] must-infer-as
|
||||
|
||||
! Corner case
|
||||
[ [ [ f dup ] [ dup ] [ ] produce ] infer ] must-fail
|
||||
|
||||
[ [ [ f dup ] [ ] [ ] while ] infer ] must-fail
|
||||
|
||||
: erg's-inference-bug ( -- ) f dup [ erg's-inference-bug ] when ; inline
|
||||
|
||||
[ [ erg's-inference-bug ] infer ] must-fail
|
||||
|
||||
: inference-invalidation-a ( -- ) ;
|
||||
: inference-invalidation-b ( quot -- ) [ inference-invalidation-a ] dip call ; inline
|
||||
: inference-invalidation-c ( a b -- c ) [ + ] inference-invalidation-b ; inline
|
||||
|
||||
[ 7 ] [ 4 3 inference-invalidation-c ] unit-test
|
||||
|
||||
{ 2 1 } [ [ + ] inference-invalidation-b ] must-infer-as
|
||||
|
||||
[ ] [ "IN: inference.tests : inference-invalidation-a ( -- a b ) 1 2 ;" eval ] unit-test
|
||||
|
||||
[ 3 ] [ inference-invalidation-c ] unit-test
|
||||
|
||||
{ 0 1 } [ inference-invalidation-c ] must-infer-as
|
||||
|
||||
GENERIC: inference-invalidation-d ( obj -- )
|
||||
|
||||
M: object inference-invalidation-d inference-invalidation-c 2drop ;
|
||||
|
||||
\ inference-invalidation-d must-infer
|
||||
|
||||
[ ] [ "IN: inference.tests : inference-invalidation-a ( -- ) ;" eval ] unit-test
|
||||
|
||||
[ [ inference-invalidation-d ] infer ] must-fail
|
||||
|
|
@ -1,37 +0,0 @@
|
|||
! Copyright (C) 2004, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: inference.backend inference.state inference.dataflow
|
||||
inference.known-words inference.transforms inference.errors
|
||||
kernel io effects namespaces sequences quotations vocabs
|
||||
generic words ;
|
||||
IN: inference
|
||||
|
||||
GENERIC: infer ( quot -- effect )
|
||||
|
||||
M: callable infer ( quot -- effect )
|
||||
[ recursive-state get infer-quot ] with-infer drop ;
|
||||
|
||||
: infer. ( quot -- )
|
||||
#! Safe to call from inference transforms.
|
||||
infer effect>string print ;
|
||||
|
||||
GENERIC: dataflow ( quot -- dataflow )
|
||||
|
||||
M: callable dataflow
|
||||
#! Not safe to call from inference transforms.
|
||||
[ f infer-quot ] with-infer nip ;
|
||||
|
||||
GENERIC# dataflow-with 1 ( quot stack -- dataflow )
|
||||
|
||||
M: callable dataflow-with
|
||||
#! Not safe to call from inference transforms.
|
||||
[
|
||||
V{ } like meta-d set
|
||||
f infer-quot
|
||||
] with-infer nip ;
|
||||
|
||||
: forget-errors ( -- )
|
||||
all-words [
|
||||
dup subwords [ f "cannot-infer" set-word-prop ] each
|
||||
f "cannot-infer" set-word-prop
|
||||
] each ;
|
||||
|
|
@ -1,582 +0,0 @@
|
|||
! Copyright (C) 2004, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors alien alien.accessors arrays byte-arrays
|
||||
classes sequences.private continuations.private effects generic
|
||||
hashtables hashtables.private inference.state inference.backend
|
||||
inference.dataflow io io.backend io.files io.files.private
|
||||
io.streams.c kernel kernel.private math math.private memory
|
||||
namespaces namespaces.private parser prettyprint quotations
|
||||
quotations.private sbufs sbufs.private sequences
|
||||
sequences.private slots.private strings strings.private system
|
||||
threads.private classes.tuple classes.tuple.private vectors
|
||||
vectors.private words words.private assocs summary
|
||||
compiler.units system.private ;
|
||||
IN: inference.known-words
|
||||
|
||||
! Shuffle words
|
||||
: infer-shuffle-inputs ( shuffle node -- )
|
||||
>r effect-in length 0 r> node-inputs ;
|
||||
|
||||
: shuffle-stacks ( shuffle -- )
|
||||
meta-d [ swap shuffle ] change ;
|
||||
|
||||
: infer-shuffle-outputs ( shuffle node -- )
|
||||
>r effect-out length 0 r> node-outputs ;
|
||||
|
||||
: infer-shuffle ( shuffle -- )
|
||||
dup effect-in ensure-values
|
||||
#shuffle
|
||||
2dup infer-shuffle-inputs
|
||||
over shuffle-stacks
|
||||
2dup infer-shuffle-outputs
|
||||
node, drop ;
|
||||
|
||||
: define-shuffle ( word shuffle -- )
|
||||
[ infer-shuffle ] curry "infer" set-word-prop ;
|
||||
|
||||
{
|
||||
{ drop T{ effect f 1 { } } }
|
||||
{ 2drop T{ effect f 2 { } } }
|
||||
{ 3drop T{ effect f 3 { } } }
|
||||
{ dup T{ effect f 1 { 0 0 } } }
|
||||
{ 2dup T{ effect f 2 { 0 1 0 1 } } }
|
||||
{ 3dup T{ effect f 3 { 0 1 2 0 1 2 } } }
|
||||
{ rot T{ effect f 3 { 1 2 0 } } }
|
||||
{ -rot T{ effect f 3 { 2 0 1 } } }
|
||||
{ dupd T{ effect f 2 { 0 0 1 } } }
|
||||
{ swapd T{ effect f 3 { 1 0 2 } } }
|
||||
{ nip T{ effect f 2 { 1 } } }
|
||||
{ 2nip T{ effect f 3 { 2 } } }
|
||||
{ tuck T{ effect f 2 { 1 0 1 } } }
|
||||
{ over T{ effect f 2 { 0 1 0 } } }
|
||||
{ pick T{ effect f 3 { 0 1 2 0 } } }
|
||||
{ swap T{ effect f 2 { 1 0 } } }
|
||||
} [ define-shuffle ] assoc-each
|
||||
|
||||
\ >r [ 1 infer->r ] "infer" set-word-prop
|
||||
|
||||
\ r> [ 1 infer-r> ] "infer" set-word-prop
|
||||
|
||||
\ declare [
|
||||
1 ensure-values
|
||||
pop-literal nip
|
||||
dup ensure-values
|
||||
dup length d-tail
|
||||
swap #declare
|
||||
[ 2dup set-node-in-d set-node-out-d ] keep
|
||||
node,
|
||||
] "infer" set-word-prop
|
||||
|
||||
! Primitive combinators
|
||||
GENERIC: infer-call ( value -- )
|
||||
|
||||
M: value infer-call
|
||||
drop
|
||||
1 #drop node,
|
||||
pop-d infer-quot-value ;
|
||||
|
||||
M: curried infer-call
|
||||
infer-uncurry peek-d infer-call ;
|
||||
|
||||
M: composed infer-call
|
||||
infer-uncurry
|
||||
1 infer->r peek-d infer-call
|
||||
terminated? get [ 1 infer-r> peek-d infer-call ] unless ;
|
||||
|
||||
M: object infer-call
|
||||
\ literal-expected inference-warning ;
|
||||
|
||||
\ call [
|
||||
1 ensure-values
|
||||
peek-d infer-call
|
||||
] "infer" set-word-prop
|
||||
|
||||
\ call t "no-compile" set-word-prop
|
||||
|
||||
\ execute [
|
||||
1 ensure-values
|
||||
pop-literal nip
|
||||
dup word? [
|
||||
apply-object
|
||||
] [
|
||||
drop
|
||||
"execute must be given a word" time-bomb
|
||||
] if
|
||||
] "infer" set-word-prop
|
||||
|
||||
\ execute t "no-compile" set-word-prop
|
||||
|
||||
\ if [
|
||||
3 ensure-values
|
||||
2 d-tail [ special? ] contains? [
|
||||
[ rot [ drop call ] [ nip call ] if ]
|
||||
recursive-state get infer-quot
|
||||
] [
|
||||
[ #values ]
|
||||
2 #drop node, pop-d pop-d swap 2array
|
||||
[ #if ] infer-branches
|
||||
] if
|
||||
] "infer" set-word-prop
|
||||
|
||||
\ dispatch [
|
||||
2 ensure-values
|
||||
[ gensym #return ]
|
||||
pop-literal nip [ <value> ] map
|
||||
[ #dispatch ] infer-branches
|
||||
] "infer" set-word-prop
|
||||
|
||||
\ dispatch t "no-compile" set-word-prop
|
||||
|
||||
\ curry [
|
||||
2 ensure-values
|
||||
pop-d pop-d swap <curried> push-d
|
||||
] "infer" set-word-prop
|
||||
|
||||
\ compose [
|
||||
2 ensure-values
|
||||
pop-d pop-d swap <composed> push-d
|
||||
] "infer" set-word-prop
|
||||
|
||||
! Variadic tuple constructor
|
||||
\ <tuple-boa> [
|
||||
\ <tuple-boa>
|
||||
peek-d value-literal size>> { tuple } <effect>
|
||||
make-call-node
|
||||
] "infer" set-word-prop
|
||||
|
||||
! Non-standard control flow
|
||||
\ (throw) [
|
||||
\ (throw)
|
||||
peek-d value-literal 2 + { } <effect>
|
||||
t over set-effect-terminated?
|
||||
make-call-node
|
||||
] "infer" set-word-prop
|
||||
|
||||
: set-primitive-effect ( word effect -- )
|
||||
[ in>> "input-classes" set-word-prop ]
|
||||
[ out>> "default-output-classes" set-word-prop ]
|
||||
[ dupd [ make-call-node ] 2curry "infer" set-word-prop ]
|
||||
2tri ;
|
||||
|
||||
! Stack effects for all primitives
|
||||
\ fixnum< { fixnum fixnum } { object } <effect> set-primitive-effect
|
||||
\ fixnum< make-foldable
|
||||
|
||||
\ fixnum<= { fixnum fixnum } { object } <effect> set-primitive-effect
|
||||
\ fixnum<= make-foldable
|
||||
|
||||
\ fixnum> { fixnum fixnum } { object } <effect> set-primitive-effect
|
||||
\ fixnum> make-foldable
|
||||
|
||||
\ fixnum>= { fixnum fixnum } { object } <effect> set-primitive-effect
|
||||
\ fixnum>= make-foldable
|
||||
|
||||
\ eq? { object object } { object } <effect> set-primitive-effect
|
||||
\ eq? make-foldable
|
||||
|
||||
\ rehash-string { string } { } <effect> set-primitive-effect
|
||||
|
||||
\ bignum>fixnum { bignum } { fixnum } <effect> set-primitive-effect
|
||||
\ bignum>fixnum make-foldable
|
||||
|
||||
\ float>fixnum { float } { fixnum } <effect> set-primitive-effect
|
||||
\ bignum>fixnum make-foldable
|
||||
|
||||
\ fixnum>bignum { fixnum } { bignum } <effect> set-primitive-effect
|
||||
\ fixnum>bignum make-foldable
|
||||
|
||||
\ float>bignum { float } { bignum } <effect> set-primitive-effect
|
||||
\ float>bignum make-foldable
|
||||
|
||||
\ fixnum>float { fixnum } { float } <effect> set-primitive-effect
|
||||
\ fixnum>float make-foldable
|
||||
|
||||
\ bignum>float { bignum } { float } <effect> set-primitive-effect
|
||||
\ bignum>float make-foldable
|
||||
|
||||
\ <ratio> { integer integer } { ratio } <effect> set-primitive-effect
|
||||
\ <ratio> make-foldable
|
||||
|
||||
\ string>float { string } { float } <effect> set-primitive-effect
|
||||
\ string>float make-foldable
|
||||
|
||||
\ float>string { float } { string } <effect> set-primitive-effect
|
||||
\ float>string make-foldable
|
||||
|
||||
\ float>bits { real } { integer } <effect> set-primitive-effect
|
||||
\ float>bits make-foldable
|
||||
|
||||
\ double>bits { real } { integer } <effect> set-primitive-effect
|
||||
\ double>bits make-foldable
|
||||
|
||||
\ bits>float { integer } { float } <effect> set-primitive-effect
|
||||
\ bits>float make-foldable
|
||||
|
||||
\ bits>double { integer } { float } <effect> set-primitive-effect
|
||||
\ bits>double make-foldable
|
||||
|
||||
\ <complex> { real real } { complex } <effect> set-primitive-effect
|
||||
\ <complex> make-foldable
|
||||
|
||||
\ fixnum+ { fixnum fixnum } { integer } <effect> set-primitive-effect
|
||||
\ fixnum+ make-foldable
|
||||
|
||||
\ fixnum+fast { fixnum fixnum } { fixnum } <effect> set-primitive-effect
|
||||
\ fixnum+fast make-foldable
|
||||
|
||||
\ fixnum- { fixnum fixnum } { integer } <effect> set-primitive-effect
|
||||
\ fixnum- make-foldable
|
||||
|
||||
\ fixnum-fast { fixnum fixnum } { fixnum } <effect> set-primitive-effect
|
||||
\ fixnum-fast make-foldable
|
||||
|
||||
\ fixnum* { fixnum fixnum } { integer } <effect> set-primitive-effect
|
||||
\ fixnum* make-foldable
|
||||
|
||||
\ fixnum*fast { fixnum fixnum } { fixnum } <effect> set-primitive-effect
|
||||
\ fixnum*fast make-foldable
|
||||
|
||||
\ fixnum/i { fixnum fixnum } { integer } <effect> set-primitive-effect
|
||||
\ fixnum/i make-foldable
|
||||
|
||||
\ fixnum-mod { fixnum fixnum } { fixnum } <effect> set-primitive-effect
|
||||
\ fixnum-mod make-foldable
|
||||
|
||||
\ fixnum/mod { fixnum fixnum } { integer fixnum } <effect> set-primitive-effect
|
||||
\ fixnum/mod make-foldable
|
||||
|
||||
\ fixnum-bitand { fixnum fixnum } { fixnum } <effect> set-primitive-effect
|
||||
\ fixnum-bitand make-foldable
|
||||
|
||||
\ fixnum-bitor { fixnum fixnum } { fixnum } <effect> set-primitive-effect
|
||||
\ fixnum-bitor make-foldable
|
||||
|
||||
\ fixnum-bitxor { fixnum fixnum } { fixnum } <effect> set-primitive-effect
|
||||
\ fixnum-bitxor make-foldable
|
||||
|
||||
\ fixnum-bitnot { fixnum } { fixnum } <effect> set-primitive-effect
|
||||
\ fixnum-bitnot make-foldable
|
||||
|
||||
\ fixnum-shift { fixnum fixnum } { integer } <effect> set-primitive-effect
|
||||
\ fixnum-shift make-foldable
|
||||
|
||||
\ fixnum-shift-fast { fixnum fixnum } { fixnum } <effect> set-primitive-effect
|
||||
\ fixnum-shift-fast make-foldable
|
||||
|
||||
\ bignum= { bignum bignum } { object } <effect> set-primitive-effect
|
||||
\ bignum= make-foldable
|
||||
|
||||
\ bignum+ { bignum bignum } { bignum } <effect> set-primitive-effect
|
||||
\ bignum+ make-foldable
|
||||
|
||||
\ bignum- { bignum bignum } { bignum } <effect> set-primitive-effect
|
||||
\ bignum- make-foldable
|
||||
|
||||
\ bignum* { bignum bignum } { bignum } <effect> set-primitive-effect
|
||||
\ bignum* make-foldable
|
||||
|
||||
\ bignum/i { bignum bignum } { bignum } <effect> set-primitive-effect
|
||||
\ bignum/i make-foldable
|
||||
|
||||
\ bignum-mod { bignum bignum } { bignum } <effect> set-primitive-effect
|
||||
\ bignum-mod make-foldable
|
||||
|
||||
\ bignum/mod { bignum bignum } { bignum bignum } <effect> set-primitive-effect
|
||||
\ bignum/mod make-foldable
|
||||
|
||||
\ bignum-bitand { bignum bignum } { bignum } <effect> set-primitive-effect
|
||||
\ bignum-bitand make-foldable
|
||||
|
||||
\ bignum-bitor { bignum bignum } { bignum } <effect> set-primitive-effect
|
||||
\ bignum-bitor make-foldable
|
||||
|
||||
\ bignum-bitxor { bignum bignum } { bignum } <effect> set-primitive-effect
|
||||
\ bignum-bitxor make-foldable
|
||||
|
||||
\ bignum-bitnot { bignum } { bignum } <effect> set-primitive-effect
|
||||
\ bignum-bitnot make-foldable
|
||||
|
||||
\ bignum-shift { bignum bignum } { bignum } <effect> set-primitive-effect
|
||||
\ bignum-shift make-foldable
|
||||
|
||||
\ bignum< { bignum bignum } { object } <effect> set-primitive-effect
|
||||
\ bignum< make-foldable
|
||||
|
||||
\ bignum<= { bignum bignum } { object } <effect> set-primitive-effect
|
||||
\ bignum<= make-foldable
|
||||
|
||||
\ bignum> { bignum bignum } { object } <effect> set-primitive-effect
|
||||
\ bignum> make-foldable
|
||||
|
||||
\ bignum>= { bignum bignum } { object } <effect> set-primitive-effect
|
||||
\ bignum>= make-foldable
|
||||
|
||||
\ bignum-bit? { bignum integer } { object } <effect> set-primitive-effect
|
||||
\ bignum-bit? make-foldable
|
||||
|
||||
\ bignum-log2 { bignum } { bignum } <effect> set-primitive-effect
|
||||
\ bignum-log2 make-foldable
|
||||
|
||||
\ byte-array>bignum { byte-array } { bignum } <effect> set-primitive-effect
|
||||
\ byte-array>bignum make-foldable
|
||||
|
||||
\ float= { float float } { object } <effect> set-primitive-effect
|
||||
\ float= make-foldable
|
||||
|
||||
\ float+ { float float } { float } <effect> set-primitive-effect
|
||||
\ float+ make-foldable
|
||||
|
||||
\ float- { float float } { float } <effect> set-primitive-effect
|
||||
\ float- make-foldable
|
||||
|
||||
\ float* { float float } { float } <effect> set-primitive-effect
|
||||
\ float* make-foldable
|
||||
|
||||
\ float/f { float float } { float } <effect> set-primitive-effect
|
||||
\ float/f make-foldable
|
||||
|
||||
\ float< { float float } { object } <effect> set-primitive-effect
|
||||
\ float< make-foldable
|
||||
|
||||
\ float-mod { float float } { float } <effect> set-primitive-effect
|
||||
\ float-mod make-foldable
|
||||
|
||||
\ float<= { float float } { object } <effect> set-primitive-effect
|
||||
\ float<= make-foldable
|
||||
|
||||
\ float> { float float } { object } <effect> set-primitive-effect
|
||||
\ float> make-foldable
|
||||
|
||||
\ float>= { float float } { object } <effect> set-primitive-effect
|
||||
\ float>= make-foldable
|
||||
|
||||
\ <word> { object object } { word } <effect> set-primitive-effect
|
||||
\ <word> make-flushable
|
||||
|
||||
\ word-xt { word } { integer integer } <effect> set-primitive-effect
|
||||
\ word-xt make-flushable
|
||||
|
||||
\ getenv { fixnum } { object } <effect> set-primitive-effect
|
||||
\ getenv make-flushable
|
||||
|
||||
\ setenv { object fixnum } { } <effect> set-primitive-effect
|
||||
|
||||
\ (exists?) { string } { object } <effect> set-primitive-effect
|
||||
|
||||
\ (directory) { string } { array } <effect> set-primitive-effect
|
||||
|
||||
\ gc { } { } <effect> set-primitive-effect
|
||||
|
||||
\ gc-stats { } { array } <effect> set-primitive-effect
|
||||
|
||||
\ save-image { string } { } <effect> set-primitive-effect
|
||||
|
||||
\ save-image-and-exit { string } { } <effect> set-primitive-effect
|
||||
|
||||
\ exit { integer } { } <effect>
|
||||
t over set-effect-terminated?
|
||||
set-primitive-effect
|
||||
|
||||
\ data-room { } { integer integer array } <effect> set-primitive-effect
|
||||
\ data-room make-flushable
|
||||
|
||||
\ code-room { } { integer integer integer integer } <effect> set-primitive-effect
|
||||
\ code-room make-flushable
|
||||
|
||||
\ os-env { string } { object } <effect> set-primitive-effect
|
||||
|
||||
\ millis { } { integer } <effect> set-primitive-effect
|
||||
\ millis make-flushable
|
||||
|
||||
\ tag { object } { fixnum } <effect> set-primitive-effect
|
||||
\ tag make-foldable
|
||||
|
||||
\ cwd { } { string } <effect> set-primitive-effect
|
||||
|
||||
\ cd { string } { } <effect> set-primitive-effect
|
||||
|
||||
\ dlopen { string } { dll } <effect> set-primitive-effect
|
||||
|
||||
\ dlsym { string object } { c-ptr } <effect> set-primitive-effect
|
||||
|
||||
\ dlclose { dll } { } <effect> set-primitive-effect
|
||||
|
||||
\ <byte-array> { integer } { byte-array } <effect> set-primitive-effect
|
||||
\ <byte-array> make-flushable
|
||||
|
||||
\ <displaced-alien> { integer c-ptr } { c-ptr } <effect> set-primitive-effect
|
||||
\ <displaced-alien> make-flushable
|
||||
|
||||
\ alien-signed-cell { c-ptr integer } { integer } <effect> set-primitive-effect
|
||||
\ alien-signed-cell make-flushable
|
||||
|
||||
\ set-alien-signed-cell { integer c-ptr integer } { } <effect> set-primitive-effect
|
||||
|
||||
\ alien-unsigned-cell { c-ptr integer } { integer } <effect> set-primitive-effect
|
||||
\ alien-unsigned-cell make-flushable
|
||||
|
||||
\ set-alien-unsigned-cell { integer c-ptr integer } { } <effect> set-primitive-effect
|
||||
|
||||
\ alien-signed-8 { c-ptr integer } { integer } <effect> set-primitive-effect
|
||||
\ alien-signed-8 make-flushable
|
||||
|
||||
\ set-alien-signed-8 { integer c-ptr integer } { } <effect> set-primitive-effect
|
||||
|
||||
\ alien-unsigned-8 { c-ptr integer } { integer } <effect> set-primitive-effect
|
||||
\ alien-unsigned-8 make-flushable
|
||||
|
||||
\ set-alien-unsigned-8 { integer c-ptr integer } { } <effect> set-primitive-effect
|
||||
|
||||
\ alien-signed-4 { c-ptr integer } { integer } <effect> set-primitive-effect
|
||||
\ alien-signed-4 make-flushable
|
||||
|
||||
\ set-alien-signed-4 { integer c-ptr integer } { } <effect> set-primitive-effect
|
||||
|
||||
\ alien-unsigned-4 { c-ptr integer } { integer } <effect> set-primitive-effect
|
||||
\ alien-unsigned-4 make-flushable
|
||||
|
||||
\ set-alien-unsigned-4 { integer c-ptr integer } { } <effect> set-primitive-effect
|
||||
|
||||
\ alien-signed-2 { c-ptr integer } { fixnum } <effect> set-primitive-effect
|
||||
\ alien-signed-2 make-flushable
|
||||
|
||||
\ set-alien-signed-2 { integer c-ptr integer } { } <effect> set-primitive-effect
|
||||
|
||||
\ alien-unsigned-2 { c-ptr integer } { fixnum } <effect> set-primitive-effect
|
||||
\ alien-unsigned-2 make-flushable
|
||||
|
||||
\ set-alien-unsigned-2 { integer c-ptr integer } { } <effect> set-primitive-effect
|
||||
|
||||
\ alien-signed-1 { c-ptr integer } { fixnum } <effect> set-primitive-effect
|
||||
\ alien-signed-1 make-flushable
|
||||
|
||||
\ set-alien-signed-1 { integer c-ptr integer } { } <effect> set-primitive-effect
|
||||
|
||||
\ alien-unsigned-1 { c-ptr integer } { fixnum } <effect> set-primitive-effect
|
||||
\ alien-unsigned-1 make-flushable
|
||||
|
||||
\ set-alien-unsigned-1 { integer c-ptr integer } { } <effect> set-primitive-effect
|
||||
|
||||
\ alien-float { c-ptr integer } { float } <effect> set-primitive-effect
|
||||
\ alien-float make-flushable
|
||||
|
||||
\ set-alien-float { float c-ptr integer } { } <effect> set-primitive-effect
|
||||
|
||||
\ alien-double { c-ptr integer } { float } <effect> set-primitive-effect
|
||||
\ alien-double make-flushable
|
||||
|
||||
\ set-alien-double { float c-ptr integer } { } <effect> set-primitive-effect
|
||||
|
||||
\ alien-cell { c-ptr integer } { simple-c-ptr } <effect> set-primitive-effect
|
||||
\ alien-cell make-flushable
|
||||
|
||||
\ set-alien-cell { c-ptr c-ptr integer } { } <effect> set-primitive-effect
|
||||
|
||||
\ alien-address { alien } { integer } <effect> set-primitive-effect
|
||||
\ alien-address make-flushable
|
||||
|
||||
\ slot { object fixnum } { object } <effect> set-primitive-effect
|
||||
\ slot make-flushable
|
||||
|
||||
\ set-slot { object object fixnum } { } <effect> set-primitive-effect
|
||||
|
||||
\ string-nth { fixnum string } { fixnum } <effect> set-primitive-effect
|
||||
\ string-nth make-flushable
|
||||
|
||||
\ set-string-nth { fixnum fixnum string } { } <effect> set-primitive-effect
|
||||
|
||||
\ resize-array { integer array } { array } <effect> set-primitive-effect
|
||||
\ resize-array make-flushable
|
||||
|
||||
\ resize-byte-array { integer byte-array } { byte-array } <effect> set-primitive-effect
|
||||
\ resize-byte-array make-flushable
|
||||
|
||||
\ resize-string { integer string } { string } <effect> set-primitive-effect
|
||||
\ resize-string make-flushable
|
||||
|
||||
\ <array> { integer object } { array } <effect> set-primitive-effect
|
||||
\ <array> make-flushable
|
||||
|
||||
\ begin-scan { } { } <effect> set-primitive-effect
|
||||
|
||||
\ next-object { } { object } <effect> set-primitive-effect
|
||||
|
||||
\ end-scan { } { } <effect> set-primitive-effect
|
||||
|
||||
\ size { object } { fixnum } <effect> set-primitive-effect
|
||||
\ size make-flushable
|
||||
|
||||
\ die { } { } <effect> set-primitive-effect
|
||||
|
||||
\ fopen { string string } { alien } <effect> set-primitive-effect
|
||||
|
||||
\ fgetc { alien } { object } <effect> set-primitive-effect
|
||||
|
||||
\ fwrite { string alien } { } <effect> set-primitive-effect
|
||||
|
||||
\ fputc { object alien } { } <effect> set-primitive-effect
|
||||
|
||||
\ fread { integer string } { object } <effect> set-primitive-effect
|
||||
|
||||
\ fflush { alien } { } <effect> set-primitive-effect
|
||||
|
||||
\ fclose { alien } { } <effect> set-primitive-effect
|
||||
|
||||
\ <wrapper> { object } { wrapper } <effect> set-primitive-effect
|
||||
\ <wrapper> make-foldable
|
||||
|
||||
\ (clone) { object } { object } <effect> set-primitive-effect
|
||||
\ (clone) make-flushable
|
||||
|
||||
\ <string> { integer integer } { string } <effect> set-primitive-effect
|
||||
\ <string> make-flushable
|
||||
|
||||
\ array>quotation { array } { quotation } <effect> set-primitive-effect
|
||||
\ array>quotation make-flushable
|
||||
|
||||
\ quotation-xt { quotation } { integer } <effect> set-primitive-effect
|
||||
\ quotation-xt make-flushable
|
||||
|
||||
\ <tuple> { tuple-layout } { tuple } <effect> set-primitive-effect
|
||||
\ <tuple> make-flushable
|
||||
|
||||
\ <tuple-layout> { word fixnum array fixnum } { tuple-layout } <effect> set-primitive-effect
|
||||
\ <tuple-layout> make-foldable
|
||||
|
||||
\ datastack { } { array } <effect> set-primitive-effect
|
||||
\ datastack make-flushable
|
||||
|
||||
\ retainstack { } { array } <effect> set-primitive-effect
|
||||
\ retainstack make-flushable
|
||||
|
||||
\ callstack { } { callstack } <effect> set-primitive-effect
|
||||
\ callstack make-flushable
|
||||
|
||||
\ callstack>array { callstack } { array } <effect> set-primitive-effect
|
||||
\ callstack>array make-flushable
|
||||
|
||||
\ (sleep) { integer } { } <effect> set-primitive-effect
|
||||
|
||||
\ become { array array } { } <effect> set-primitive-effect
|
||||
|
||||
\ innermost-frame-quot { callstack } { quotation } <effect> set-primitive-effect
|
||||
|
||||
\ innermost-frame-scan { callstack } { fixnum } <effect> set-primitive-effect
|
||||
|
||||
\ set-innermost-frame-quot { quotation callstack } { } <effect> set-primitive-effect
|
||||
|
||||
\ (os-envs) { } { array } <effect> set-primitive-effect
|
||||
|
||||
\ set-os-env { string string } { } <effect> set-primitive-effect
|
||||
|
||||
\ unset-os-env { string } { } <effect> set-primitive-effect
|
||||
|
||||
\ (set-os-envs) { array } { } <effect> set-primitive-effect
|
||||
|
||||
\ do-primitive [ \ do-primitive cannot-infer-effect ] "infer" set-word-prop
|
||||
|
||||
\ dll-valid? { object } { object } <effect> set-primitive-effect
|
||||
|
||||
\ modify-code-heap { array object } { } <effect> set-primitive-effect
|
||||
|
||||
\ unimplemented { } { } <effect> set-primitive-effect
|
||||
|
|
@ -1,11 +0,0 @@
|
|||
USING: help.markup help.syntax inference.state ;
|
||||
|
||||
HELP: d-in
|
||||
{ $var-description "During inference, holds the number of inputs which the quotation has been inferred to require so far." } ;
|
||||
|
||||
HELP: recursive-state
|
||||
{ $var-description "During inference, holds an association list mapping words to labels." } ;
|
||||
|
||||
HELP: terminated?
|
||||
{ $var-description "During inference, a flag set to " { $link t } " if the current control flow path unconditionally throws an error." } ;
|
||||
|
||||
|
|
@ -1,30 +0,0 @@
|
|||
IN: inference.state.tests
|
||||
USING: tools.test inference.state words kernel namespaces
|
||||
definitions ;
|
||||
|
||||
: computing-dependencies ( quot -- dependencies )
|
||||
H{ } clone [ dependencies rot with-variable ] keep ;
|
||||
inline
|
||||
|
||||
SYMBOL: a
|
||||
SYMBOL: b
|
||||
|
||||
[ ] [ a +called+ depends-on ] unit-test
|
||||
|
||||
[ H{ { a +called+ } } ] [
|
||||
[ a +called+ depends-on ] computing-dependencies
|
||||
] unit-test
|
||||
|
||||
[ H{ { a +called+ } { b +inlined+ } } ] [
|
||||
[
|
||||
a +called+ depends-on b +inlined+ depends-on
|
||||
] computing-dependencies
|
||||
] unit-test
|
||||
|
||||
[ H{ { a +inlined+ } { b +inlined+ } } ] [
|
||||
[
|
||||
a +inlined+ depends-on
|
||||
a +called+ depends-on
|
||||
b +inlined+ depends-on
|
||||
] computing-dependencies
|
||||
] unit-test
|
||||
|
|
@ -1,43 +0,0 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: assocs namespaces sequences kernel definitions ;
|
||||
IN: inference.state
|
||||
|
||||
! Nesting state to solve recursion
|
||||
SYMBOL: recursive-state
|
||||
|
||||
! Number of inputs current word expects from the stack
|
||||
SYMBOL: d-in
|
||||
|
||||
! Compile-time data stack
|
||||
SYMBOL: meta-d
|
||||
|
||||
: push-d ( obj -- ) meta-d get push ;
|
||||
: pop-d ( -- obj ) meta-d get pop ;
|
||||
: peek-d ( -- obj ) meta-d get peek ;
|
||||
|
||||
! Compile-time retain stack
|
||||
SYMBOL: meta-r
|
||||
|
||||
: push-r ( obj -- ) meta-r get push ;
|
||||
: pop-r ( -- obj ) meta-r get pop ;
|
||||
: peek-r ( -- obj ) meta-r get peek ;
|
||||
|
||||
! Head of dataflow IR
|
||||
SYMBOL: dataflow-graph
|
||||
|
||||
SYMBOL: current-node
|
||||
|
||||
! Words that the current dataflow IR depends on
|
||||
SYMBOL: dependencies
|
||||
|
||||
: depends-on ( word how -- )
|
||||
swap dependencies get dup [
|
||||
2dup at +inlined+ eq? [ 3drop ] [ set-at ] if
|
||||
] [ 3drop ] if ;
|
||||
|
||||
! Did the current control-flow path throw an error?
|
||||
SYMBOL: terminated?
|
||||
|
||||
! Words we've inferred the stack effect of, for rollback
|
||||
SYMBOL: recorded
|
||||
|
|
@ -1,14 +0,0 @@
|
|||
IN: inference.transforms
|
||||
USING: help.markup help.syntax combinators words kernel ;
|
||||
|
||||
HELP: define-transform
|
||||
{ $values { "word" word } { "quot" "a quotation taking " { $snippet "n" } " inputs from the stack and producing another quotation as output" } { "n" "a non-negative integer" } }
|
||||
{ $description "Defines a compiler transform for the optimizing compiler. When a call to " { $snippet "word" } " is being compiled, the compiler ensures that the top " { $snippet "n" } " stack values are literal; if they are not, compilation fails. The literal values are passed to the quotation, which is expected to produce a new quotation. The call to the word is then replaced by this quotation." }
|
||||
{ $examples "Here is a word which pops " { $snippet "n" } " values from the stack:"
|
||||
{ $code ": ndrop ( n -- ) [ drop ] times ;" }
|
||||
"This word is inefficient; it does not have a static stack effect. This means that words calling " { $snippet "ndrop" } " cannot be compiled by the optimizing compiler, and additionally, a call to this word will always involve a loop with arithmetic, even if the value of " { $snippet "n" } " is known at compile time. A compiler transform can fix this:"
|
||||
{ $code "\\ ndrop [ \\ drop <repetition> >quotation ] 1 define-transform" }
|
||||
"Now, a call like " { $snippet "4 ndrop" } " is replaced with " { $snippet "drop drop drop drop" } " at compile time; the optimizer then ensures that this compiles as a single machine instruction, which is a lot cheaper than an actual call to " { $snippet "ndrop" } "."
|
||||
$nl
|
||||
"The " { $link cond } " word compiles to efficient code because it is transformed using " { $link cond>quot } ":"
|
||||
{ $code "\\ cond [ cond>quot ] 1 define-transform" } } ;
|
||||
|
|
@ -1,44 +0,0 @@
|
|||
IN: inference.transforms.tests
|
||||
USING: sequences inference.transforms tools.test math kernel
|
||||
quotations inference accessors combinators words arrays
|
||||
classes classes.tuple ;
|
||||
|
||||
: compose-n-quot ( word -- quot' ) <repetition> >quotation ;
|
||||
: compose-n ( quot -- ) compose-n-quot call ;
|
||||
\ compose-n [ compose-n-quot ] 2 define-transform
|
||||
: compose-n-test ( a b c -- x ) 2 \ + compose-n ;
|
||||
|
||||
[ 6 ] [ 1 2 3 compose-n-test ] unit-test
|
||||
|
||||
TUPLE: color r g b ;
|
||||
|
||||
C: <color> color
|
||||
|
||||
: cleave-test ( color -- r g b )
|
||||
{ [ r>> ] [ g>> ] [ b>> ] } cleave ;
|
||||
|
||||
{ 1 3 } [ cleave-test ] must-infer-as
|
||||
|
||||
[ 1 2 3 ] [ 1 2 3 <color> cleave-test ] unit-test
|
||||
|
||||
[ 1 2 3 ] [ 1 2 3 <color> \ cleave-test def>> call ] unit-test
|
||||
|
||||
: 2cleave-test ( a b -- c d e ) { [ 2array ] [ + ] [ - ] } 2cleave ;
|
||||
|
||||
[ { 1 2 } 3 -1 ] [ 1 2 2cleave-test ] unit-test
|
||||
|
||||
[ { 1 2 } 3 -1 ] [ 1 2 \ 2cleave-test def>> call ] unit-test
|
||||
|
||||
: spread-test ( a b c -- d e f ) { [ sq ] [ neg ] [ recip ] } spread ;
|
||||
|
||||
[ 16 -3 1/6 ] [ 4 3 6 spread-test ] unit-test
|
||||
|
||||
[ 16 -3 1/6 ] [ 4 3 6 \ spread-test def>> call ] unit-test
|
||||
|
||||
[ fixnum instance? ] must-infer
|
||||
|
||||
: bad-new-test ( -- obj ) V{ } new ;
|
||||
|
||||
[ bad-new-test ] must-infer
|
||||
|
||||
[ bad-new-test ] must-fail
|
||||
|
|
@ -1,80 +0,0 @@
|
|||
! Copyright (C) 2007, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays kernel words sequences generic math
|
||||
namespaces quotations assocs combinators
|
||||
inference.backend inference.dataflow inference.state
|
||||
classes.tuple classes.tuple.private effects summary hashtables
|
||||
classes generic sets definitions generic.standard slots.private ;
|
||||
IN: inference.transforms
|
||||
|
||||
: pop-literals ( n -- rstate seq )
|
||||
dup zero? [
|
||||
drop recursive-state get { }
|
||||
] [
|
||||
dup ensure-values
|
||||
f swap [ 2drop pop-literal ] map reverse
|
||||
] if ;
|
||||
|
||||
: transform-quot ( quot n -- newquot )
|
||||
[ pop-literals [ ] each ] curry
|
||||
swap
|
||||
[ swap infer-quot ] 3compose ;
|
||||
|
||||
: define-transform ( word quot n -- )
|
||||
transform-quot "infer" set-word-prop ;
|
||||
|
||||
! Combinators
|
||||
\ cond [
|
||||
cond>quot
|
||||
] 1 define-transform
|
||||
|
||||
\ case [
|
||||
dup empty? [
|
||||
drop [ no-case ]
|
||||
] [
|
||||
dup peek quotation? [
|
||||
dup peek swap but-last
|
||||
] [
|
||||
[ no-case ] swap
|
||||
] if case>quot
|
||||
] if
|
||||
] 1 define-transform
|
||||
|
||||
\ cleave [ cleave>quot ] 1 define-transform
|
||||
|
||||
\ 2cleave [ 2cleave>quot ] 1 define-transform
|
||||
|
||||
\ 3cleave [ 3cleave>quot ] 1 define-transform
|
||||
|
||||
\ spread [ spread>quot ] 1 define-transform
|
||||
|
||||
! Tuple operations
|
||||
: [get-slots] ( slots -- quot )
|
||||
[ [ 1quotation , \ keep , ] each \ drop , ] [ ] make ;
|
||||
|
||||
\ get-slots [ [get-slots] ] 1 define-transform
|
||||
|
||||
ERROR: duplicated-slots-error names ;
|
||||
|
||||
M: duplicated-slots-error summary
|
||||
drop "Calling set-slots with duplicate slot setters" ;
|
||||
|
||||
\ set-slots [
|
||||
dup all-unique?
|
||||
[ <reversed> [get-slots] ] [ duplicated-slots-error ] if
|
||||
] 1 define-transform
|
||||
|
||||
\ boa [
|
||||
dup tuple-class? [
|
||||
dup +inlined+ depends-on
|
||||
[ "boa-check" word-prop ]
|
||||
[ tuple-layout [ <tuple-boa> ] curry ]
|
||||
bi append
|
||||
] [
|
||||
\ boa \ no-method boa time-bomb
|
||||
] if
|
||||
] 1 define-transform
|
||||
|
||||
\ (call-next-method) [
|
||||
[ [ +inlined+ depends-on ] bi@ ] [ next-method-quot ] 2bi
|
||||
] 2 define-transform
|
||||
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue