Merge branch 'master' of http://factorcode.org/git/factor into morse
Conflicts: extra/semantic-db/semantic-db.factordb4
Alex Chapman
commit
2f48f21eaf
|
|
@ -2,6 +2,7 @@
|
|||
_darcs
|
||||
*.obj
|
||||
*.o
|
||||
*.s
|
||||
*.exe
|
||||
Factor/factor
|
||||
*.a
|
||||
|
|
|
|||
|
|
@ -439,7 +439,7 @@ install_build_system_port() {
|
|||
}
|
||||
|
||||
usage() {
|
||||
echo "usage: $0 install|install-x11|install-macosx|self-update|quick-update|update|bootstrap|net-bootstrap|make-target"
|
||||
echo "usage: $0 install|install-x11|install-macosx|self-update|quick-update|update|bootstrap|dlls|net-bootstrap|make-target"
|
||||
echo "If you are behind a firewall, invoke as:"
|
||||
echo "env GIT_PROTOCOL=http $0 <command>"
|
||||
}
|
||||
|
|
|
|||
|
|
@ -28,12 +28,6 @@ M: f expired? drop t ;
|
|||
: <alien> ( address -- alien )
|
||||
f <displaced-alien> { simple-c-ptr } declare ; inline
|
||||
|
||||
: alien>native-string ( alien -- string )
|
||||
os windows? [ alien>u16-string ] [ alien>char-string ] if ;
|
||||
|
||||
: dll-path ( dll -- string )
|
||||
(dll-path) alien>native-string ;
|
||||
|
||||
M: alien equal?
|
||||
over alien? [
|
||||
2dup [ expired? ] either? [
|
||||
|
|
|
|||
|
|
@ -18,7 +18,6 @@ ARTICLE: "c-arrays-factor" "Converting C arrays to and from Factor arrays"
|
|||
{ $subsection >c-ushort-array }
|
||||
{ $subsection >c-void*-array }
|
||||
{ $subsection c-bool-array> }
|
||||
{ $subsection c-char*-array> }
|
||||
{ $subsection c-char-array> }
|
||||
{ $subsection c-double-array> }
|
||||
{ $subsection c-float-array> }
|
||||
|
|
@ -30,7 +29,6 @@ ARTICLE: "c-arrays-factor" "Converting C arrays to and from Factor arrays"
|
|||
{ $subsection c-uint-array> }
|
||||
{ $subsection c-ulong-array> }
|
||||
{ $subsection c-ulonglong-array> }
|
||||
{ $subsection c-ushort*-array> }
|
||||
{ $subsection c-ushort-array> }
|
||||
{ $subsection c-void*-array> } ;
|
||||
|
||||
|
|
@ -61,9 +59,7 @@ ARTICLE: "c-arrays-get/set" "Reading and writing elements in C arrays"
|
|||
{ $subsection double-nth }
|
||||
{ $subsection set-double-nth }
|
||||
{ $subsection void*-nth }
|
||||
{ $subsection set-void*-nth }
|
||||
{ $subsection char*-nth }
|
||||
{ $subsection ushort*-nth } ;
|
||||
{ $subsection set-void*-nth } ;
|
||||
|
||||
ARTICLE: "c-arrays" "C arrays"
|
||||
"C arrays are allocated in the same manner as other C data; see " { $link "c-byte-arrays" } " and " { $link "malloc" } "."
|
||||
|
|
|
|||
|
|
@ -1,8 +1,7 @@
|
|||
! Copyright (C) 2007 Slava Pestov.
|
||||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien arrays alien.c-types alien.structs
|
||||
sequences math kernel generator.registers
|
||||
namespaces libc ;
|
||||
sequences math kernel namespaces libc cpu.architecture ;
|
||||
IN: alien.arrays
|
||||
|
||||
UNION: value-type array struct-type ;
|
||||
|
|
@ -27,7 +26,9 @@ M: array stack-size drop "void*" stack-size ;
|
|||
|
||||
M: value-type c-type-reg-class drop int-regs ;
|
||||
|
||||
M: value-type c-type-prep drop f ;
|
||||
M: value-type c-type-boxer-quot drop f ;
|
||||
|
||||
M: value-type c-type-unboxer-quot drop f ;
|
||||
|
||||
M: value-type c-type-getter
|
||||
drop [ swap <displaced-alien> ] ;
|
||||
|
|
|
|||
|
|
@ -62,28 +62,6 @@ HELP: <c-object>
|
|||
|
||||
{ <c-object> malloc-object } related-words
|
||||
|
||||
HELP: string>char-alien ( string -- array )
|
||||
{ $values { "string" string } { "array" byte-array } }
|
||||
{ $description "Copies the string to a new byte array, converting it to 8-bit ASCII and adding a trailing null byte." }
|
||||
{ $errors "Throws an error if the string contains null characters, or characters beyond the 8-bit range." } ;
|
||||
|
||||
{ string>char-alien alien>char-string malloc-char-string } related-words
|
||||
|
||||
HELP: alien>char-string ( c-ptr -- string )
|
||||
{ $values { "c-ptr" c-ptr } { "string" string } }
|
||||
{ $description "Reads a null-terminated 8-bit C string from the specified address." } ;
|
||||
|
||||
HELP: string>u16-alien ( string -- array )
|
||||
{ $values { "string" string } { "array" byte-array } }
|
||||
{ $description "Copies the string to a new byte array in UCS-2 format with a trailing null byte." }
|
||||
{ $errors "Throws an error if the string contains null characters." } ;
|
||||
|
||||
{ string>u16-alien alien>u16-string malloc-u16-string } related-words
|
||||
|
||||
HELP: alien>u16-string ( c-ptr -- string )
|
||||
{ $values { "c-ptr" c-ptr } { "string" string } }
|
||||
{ $description "Reads a null-terminated UCS-2 string from the specified address." } ;
|
||||
|
||||
HELP: memory>byte-array
|
||||
{ $values { "alien" c-ptr } { "len" "a non-negative integer" } { "byte-array" byte-array } }
|
||||
{ $description "Reads " { $snippet "len" } " bytes starting from " { $snippet "base" } " and stores them in a new byte array." } ;
|
||||
|
|
@ -111,18 +89,6 @@ HELP: malloc-byte-array
|
|||
{ $warning "Don't forget to deallocate the memory with a call to " { $link free } "." }
|
||||
{ $errors "Throws an error if memory allocation fails." } ;
|
||||
|
||||
HELP: malloc-char-string
|
||||
{ $values { "string" string } { "alien" c-ptr } }
|
||||
{ $description "Allocates an unmanaged memory block, and stores a string in 8-bit ASCII encoding with a trailing null byte to the block." }
|
||||
{ $warning "Don't forget to deallocate the memory with a call to " { $link free } "." }
|
||||
{ $errors "Throws an error if memory allocation fails." } ;
|
||||
|
||||
HELP: malloc-u16-string
|
||||
{ $values { "string" string } { "alien" c-ptr } }
|
||||
{ $description "Allocates an unmanaged memory block, and stores a string in UCS2 encoding with a trailing null character to the block." }
|
||||
{ $warning "Don't forget to deallocate the memory with a call to " { $link free } "." }
|
||||
{ $errors "Throws an error if memory allocation fails." } ;
|
||||
|
||||
HELP: define-nth
|
||||
{ $values { "name" "a word name" } { "vocab" "a vocabulary name" } }
|
||||
{ $description "Defines a word " { $snippet { $emphasis "name" } "-nth" } " with stack effect " { $snippet "( n c-ptr -- value )" } " for reading the value with C type " { $snippet "name" } " stored at an alien pointer, displaced by a multiple of the C type's size." }
|
||||
|
|
@ -202,8 +168,6 @@ $nl
|
|||
{ $subsection *float }
|
||||
{ $subsection *double }
|
||||
{ $subsection *void* }
|
||||
{ $subsection *char* }
|
||||
{ $subsection *ushort* }
|
||||
"Note that while structure and union types do not get these words defined for them, there is no loss of generality since " { $link <void*> } " and " { $link *void* } " may be used." ;
|
||||
|
||||
ARTICLE: "c-types-specs" "C type specifiers"
|
||||
|
|
@ -267,26 +231,6 @@ $nl
|
|||
"A wrapper for temporarily allocating a block of memory:"
|
||||
{ $subsection with-malloc } ;
|
||||
|
||||
ARTICLE: "c-strings" "C strings"
|
||||
"The C library interface defines two types of C strings:"
|
||||
{ $table
|
||||
{ "C type" "Notes" }
|
||||
{ { $snippet "char*" } "8-bit per character null-terminated ASCII" }
|
||||
{ { $snippet "ushort*" } "16-bit per character null-terminated UCS-2" }
|
||||
}
|
||||
"Passing a Factor string to a C function expecting a C string allocates a " { $link byte-array } " in the Factor heap; the string is then converted to the requested format and a raw pointer is passed to the function. If the conversion fails, for example if the string contains null bytes or characters with values higher than 255, a " { $link c-string-error. } " is thrown."
|
||||
"Sometimes a C function has a parameter type of " { $snippet "void*" } ", and various data types, among them strings, can be passed in. In this case, strings are not automatically converted to aliens, and instead you must call one of these words:"
|
||||
{ $subsection string>char-alien }
|
||||
{ $subsection string>u16-alien }
|
||||
{ $subsection malloc-char-string }
|
||||
{ $subsection malloc-u16-string }
|
||||
"The first two allocate " { $link byte-array } "s, and the latter allocates manually-managed memory which is not moved by the garbage collector and has to be explicitly freed by calling " { $link free } ". See " { $link "byte-arrays-gc" } " for a discussion of the two approaches."
|
||||
$nl
|
||||
"Finally, a set of words can be used to read and write " { $snippet "char*" } " and " { $snippet "ushort*" } " strings at arbitrary addresses:"
|
||||
{ $subsection alien>char-string }
|
||||
{ $subsection alien>u16-string }
|
||||
"For example, if a C function returns a " { $snippet "char*" } " but stipulates that the caller must deallocate the memory afterward, you must define the function as returning " { $snippet "void*" } ", and call one of the above words before passing the pointer to " { $link free } "." ;
|
||||
|
||||
ARTICLE: "c-data" "Passing data between Factor and C"
|
||||
"Two defining characteristics of Factor are dynamic typing and automatic memory management, which are somewhat incompatible with the machine-level data model exposed by C. Factor's C library interface defines its own set of C data types, distinct from Factor language types, together with automatic conversion between Factor values and C types. For example, C integer types must be declared and are fixed-width, whereas Factor supports arbitrary-precision integers."
|
||||
$nl
|
||||
|
|
|
|||
|
|
@ -1,30 +1,6 @@
|
|||
IN: alien.c-types.tests
|
||||
USING: alien alien.syntax alien.c-types kernel tools.test
|
||||
sequences system libc ;
|
||||
|
||||
[ "\u0000ff" ]
|
||||
[ "\u0000ff" string>char-alien alien>char-string ]
|
||||
unit-test
|
||||
|
||||
[ "hello world" ]
|
||||
[ "hello world" string>char-alien alien>char-string ]
|
||||
unit-test
|
||||
|
||||
[ "hello\u00abcdworld" ]
|
||||
[ "hello\u00abcdworld" string>u16-alien alien>u16-string ]
|
||||
unit-test
|
||||
|
||||
[ t ] [ f expired? ] unit-test
|
||||
|
||||
[ "hello world" ] [
|
||||
"hello world" malloc-char-string
|
||||
dup alien>char-string swap free
|
||||
] unit-test
|
||||
|
||||
[ "hello world" ] [
|
||||
"hello world" malloc-u16-string
|
||||
dup alien>u16-string swap free
|
||||
] unit-test
|
||||
sequences system libc alien.strings io.encodings.utf8 ;
|
||||
|
||||
: foo ( -- n ) "fdafd" f dlsym [ 123 ] unless* ;
|
||||
|
||||
|
|
@ -67,7 +43,7 @@ TYPEDEF: int* MyIntArray
|
|||
|
||||
TYPEDEF: uchar* MyLPBYTE
|
||||
|
||||
[ t ] [ "char*" c-type "MyLPBYTE" c-type eq? ] unit-test
|
||||
[ t ] [ { "char*" utf8 } c-type "MyLPBYTE" c-type = ] unit-test
|
||||
|
||||
[
|
||||
0 B{ 1 2 3 4 } <displaced-alien> <void*>
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2004, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: bit-arrays byte-arrays float-arrays arrays
|
||||
generator.registers assocs kernel kernel.private libc math
|
||||
assocs kernel kernel.private libc math
|
||||
namespaces parser sequences strings words assocs splitting
|
||||
math.parser cpu.architecture alien alien.accessors quotations
|
||||
layouts system compiler.units io.files io.encodings.binary
|
||||
|
|
@ -14,7 +14,7 @@ DEFER: *char
|
|||
: little-endian? ( -- ? ) 1 <int> *char 1 = ; foldable
|
||||
|
||||
TUPLE: c-type
|
||||
boxer prep unboxer
|
||||
boxer boxer-quot unboxer unboxer-quot
|
||||
getter setter
|
||||
reg-class size align stack-align? ;
|
||||
|
||||
|
|
@ -149,23 +149,12 @@ M: float-array byte-length length "double" heap-size * ;
|
|||
: malloc-byte-array ( byte-array -- alien )
|
||||
dup length dup malloc [ -rot memcpy ] keep ;
|
||||
|
||||
: malloc-char-string ( string -- alien )
|
||||
string>char-alien malloc-byte-array ;
|
||||
|
||||
: malloc-u16-string ( string -- alien )
|
||||
string>u16-alien malloc-byte-array ;
|
||||
|
||||
: memory>byte-array ( alien len -- byte-array )
|
||||
dup <byte-array> [ -rot memcpy ] keep ;
|
||||
|
||||
: byte-array>memory ( byte-array base -- )
|
||||
swap dup length memcpy ;
|
||||
|
||||
DEFER: >c-ushort-array
|
||||
|
||||
: string>u16-memory ( string base -- )
|
||||
>r >c-ushort-array r> byte-array>memory ;
|
||||
|
||||
: (define-nth) ( word type quot -- )
|
||||
>r heap-size [ rot * ] swap prefix r> append define-inline ;
|
||||
|
||||
|
|
@ -378,7 +367,7 @@ M: long-long-type box-return ( type -- )
|
|||
"box_float" >>boxer
|
||||
"to_float" >>unboxer
|
||||
single-float-regs >>reg-class
|
||||
[ >float ] >>prep
|
||||
[ >float ] >>unboxer-quot
|
||||
"float" define-primitive-type
|
||||
|
||||
<c-type>
|
||||
|
|
@ -389,30 +378,8 @@ M: long-long-type box-return ( type -- )
|
|||
"box_double" >>boxer
|
||||
"to_double" >>unboxer
|
||||
double-float-regs >>reg-class
|
||||
[ >float ] >>prep
|
||||
[ >float ] >>unboxer-quot
|
||||
"double" define-primitive-type
|
||||
|
||||
<c-type>
|
||||
[ alien-cell alien>char-string ] >>getter
|
||||
[ set-alien-cell ] >>setter
|
||||
bootstrap-cell >>size
|
||||
bootstrap-cell >>align
|
||||
"box_char_string" >>boxer
|
||||
"alien_offset" >>unboxer
|
||||
[ string>char-alien ] >>prep
|
||||
"char*" define-primitive-type
|
||||
|
||||
"char*" "uchar*" typedef
|
||||
|
||||
<c-type>
|
||||
[ alien-cell alien>u16-string ] >>getter
|
||||
[ set-alien-cell ] >>setter
|
||||
4 >>size
|
||||
4 >>align
|
||||
"box_u16_string" >>boxer
|
||||
"alien_offset" >>unboxer
|
||||
[ string>u16-alien ] >>prep
|
||||
"ushort*" define-primitive-type
|
||||
|
||||
os winnt? cpu x86.64? and "longlong" "long" ? "ptrdiff_t" typedef
|
||||
] with-compilation-unit
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@ 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 ;
|
||||
tools.test math ;
|
||||
|
||||
FUNCTION: void ffi_test_0 ;
|
||||
[ ] [ ffi_test_0 ] unit-test
|
||||
|
|
@ -280,6 +280,10 @@ 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 "void" { } "cdecl" [ ] alien-callback ;
|
||||
|
|
@ -354,3 +358,18 @@ FUNCTION: double ffi_test_36 ( test-struct-12 x ) ;
|
|||
] alien-callback ;
|
||||
|
||||
[ ] [ callback-8 callback_test_1 ] unit-test
|
||||
|
||||
: callback-9
|
||||
"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
|
||||
|
|
|
|||
|
|
@ -3,10 +3,11 @@
|
|||
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.structs
|
||||
alien.syntax cpu.architecture alien inspector quotations assocs
|
||||
kernel.private threads continuations.private libc combinators
|
||||
compiler.errors continuations layouts accessors ;
|
||||
math.parser classes alien.arrays alien.c-types alien.strings
|
||||
alien.structs alien.syntax cpu.architecture alien inspector
|
||||
quotations assocs kernel.private threads continuations.private
|
||||
libc combinators compiler.errors continuations layouts accessors
|
||||
;
|
||||
IN: alien.compiler
|
||||
|
||||
TUPLE: #alien-node < node return parameters abi ;
|
||||
|
|
@ -20,9 +21,7 @@ TUPLE: #alien-invoke < #alien-node library function ;
|
|||
: large-struct? ( ctype -- ? )
|
||||
dup c-struct? [
|
||||
heap-size struct-small-enough? not
|
||||
] [
|
||||
drop f
|
||||
] if ;
|
||||
] [ drop f ] if ;
|
||||
|
||||
: alien-node-parameters* ( node -- seq )
|
||||
dup parameters>>
|
||||
|
|
@ -162,17 +161,16 @@ M: long-long-type flatten-value-type ( type -- )
|
|||
dup return>> "void" = 0 1 ?
|
||||
swap produce-values ;
|
||||
|
||||
: (make-prep-quot) ( parameters -- )
|
||||
: (param-prep-quot) ( parameters -- )
|
||||
dup empty? [
|
||||
drop
|
||||
] [
|
||||
unclip c-type c-type-prep %
|
||||
\ >r , (make-prep-quot) \ r> ,
|
||||
unclip c-type c-type-unboxer-quot %
|
||||
\ >r , (param-prep-quot) \ r> ,
|
||||
] if ;
|
||||
|
||||
: make-prep-quot ( node -- quot )
|
||||
parameters>>
|
||||
[ <reversed> (make-prep-quot) ] [ ] make ;
|
||||
: param-prep-quot ( node -- quot )
|
||||
parameters>> [ <reversed> (param-prep-quot) ] [ ] make ;
|
||||
|
||||
: unbox-parameters ( offset node -- )
|
||||
parameters>> [
|
||||
|
|
@ -200,6 +198,20 @@ M: long-long-type flatten-value-type ( type -- )
|
|||
: box-return* ( node -- )
|
||||
return>> [ ] [ box-return ] if-void ;
|
||||
|
||||
: (return-prep-quot) ( parameters -- )
|
||||
dup empty? [
|
||||
drop
|
||||
] [
|
||||
unclip c-type c-type-boxer-quot %
|
||||
\ >r , (return-prep-quot) \ r> ,
|
||||
] if ;
|
||||
|
||||
: callback-prep-quot ( node -- quot )
|
||||
parameters>> [ <reversed> (return-prep-quot) ] [ ] make ;
|
||||
|
||||
: return-prep-quot ( node -- quot )
|
||||
[ return>> [ ] [ 1array (return-prep-quot) ] if-void ] [ ] make ;
|
||||
|
||||
M: alien-invoke-error summary
|
||||
drop
|
||||
"Words calling ``alien-invoke'' must be compiled with the optimizing compiler." ;
|
||||
|
|
@ -258,15 +270,15 @@ M: no-such-symbol compiler-error-type
|
|||
pop-literal nip >>library
|
||||
pop-literal nip >>return
|
||||
! Quotation which coerces parameters to required types
|
||||
dup make-prep-quot recursive-state get infer-quot
|
||||
dup param-prep-quot f infer-quot
|
||||
! Set ABI
|
||||
dup library>>
|
||||
library [ abi>> ] [ "cdecl" ] if*
|
||||
>>abi
|
||||
dup library>> library [ abi>> ] [ "cdecl" ] if* >>abi
|
||||
! Add node to IR
|
||||
dup node,
|
||||
! Magic #: consume exactly the number of inputs
|
||||
0 alien-invoke-stack
|
||||
dup 0 alien-invoke-stack
|
||||
! Quotation which coerces return value to required type
|
||||
return-prep-quot f infer-quot
|
||||
] "infer" set-word-prop
|
||||
|
||||
M: #alien-invoke generate-node
|
||||
|
|
@ -294,11 +306,13 @@ M: alien-indirect-error summary
|
|||
pop-parameters >>parameters
|
||||
pop-literal nip >>return
|
||||
! Quotation which coerces parameters to required types
|
||||
dup make-prep-quot [ dip ] curry recursive-state get infer-quot
|
||||
dup param-prep-quot [ dip ] curry f infer-quot
|
||||
! Add node to IR
|
||||
dup node,
|
||||
! Magic #: consume the function pointer, too
|
||||
1 alien-invoke-stack
|
||||
dup 1 alien-invoke-stack
|
||||
! Quotation which coerces return value to required type
|
||||
return-prep-quot f infer-quot
|
||||
] "infer" set-word-prop
|
||||
|
||||
M: #alien-indirect generate-node
|
||||
|
|
@ -331,7 +345,7 @@ M: alien-callback-error summary
|
|||
|
||||
: callback-bottom ( node -- )
|
||||
xt>> [ word-xt drop <alien> ] curry
|
||||
recursive-state get infer-quot ;
|
||||
f infer-quot ;
|
||||
|
||||
\ alien-callback [
|
||||
4 ensure-values
|
||||
|
|
@ -371,16 +385,18 @@ TUPLE: callback-context ;
|
|||
slip
|
||||
wait-to-return ; inline
|
||||
|
||||
: prepare-callback-return ( ctype -- quot )
|
||||
: callback-return-quot ( ctype -- quot )
|
||||
return>> {
|
||||
{ [ dup "void" = ] [ drop [ ] ] }
|
||||
{ [ dup large-struct? ] [ heap-size [ memcpy ] curry ] }
|
||||
[ c-type c-type-prep ]
|
||||
[ c-type c-type-unboxer-quot ]
|
||||
} cond ;
|
||||
|
||||
: wrap-callback-quot ( node -- quot )
|
||||
[
|
||||
[ quot>> ] [ prepare-callback-return ] bi append ,
|
||||
[ callback-prep-quot ]
|
||||
[ quot>> ]
|
||||
[ callback-return-quot ] tri 3append ,
|
||||
[ callback-context new do-callback ] %
|
||||
] [ ] make ;
|
||||
|
||||
|
|
@ -403,12 +419,12 @@ TUPLE: callback-context ;
|
|||
: generate-callback ( node -- )
|
||||
dup xt>> dup [
|
||||
init-templates
|
||||
%save-word-xt
|
||||
%prologue-later
|
||||
dup alien-stack-frame [
|
||||
dup registers>objects
|
||||
dup wrap-callback-quot %alien-callback
|
||||
%callback-return
|
||||
[ registers>objects ]
|
||||
[ wrap-callback-quot %alien-callback ]
|
||||
[ %callback-return ]
|
||||
tri
|
||||
] with-stack-frame
|
||||
] with-generator ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,12 +1,12 @@
|
|||
! Copyright (C) 2007 Slava Pestov.
|
||||
! Copyright (C) 2007, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien alien.c-types parser threads words kernel.private
|
||||
kernel ;
|
||||
USING: alien alien.c-types alien.strings parser threads words
|
||||
kernel.private kernel io.encodings.utf8 ;
|
||||
IN: alien.remote-control
|
||||
|
||||
: eval-callback
|
||||
"void*" { "char*" } "cdecl"
|
||||
[ eval>string malloc-char-string ] alien-callback ;
|
||||
[ eval>string utf8 malloc-string ] alien-callback ;
|
||||
|
||||
: yield-callback
|
||||
"void" { } "cdecl" [ yield ] alien-callback ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1,52 @@
|
|||
USING: help.markup help.syntax strings byte-arrays alien libc
|
||||
debugger ;
|
||||
IN: alien.strings
|
||||
|
||||
HELP: string>alien
|
||||
{ $values { "string" string } { "encoding" "an encoding descriptor" } { "byte-array" byte-array } }
|
||||
{ $description "Encodes a string together with a trailing null code point using the given encoding, and stores the resulting bytes in a freshly-allocated byte array." }
|
||||
{ $errors "Throws an error if the string contains null characters, or characters not representable in the given encoding." } ;
|
||||
|
||||
{ string>alien alien>string malloc-string } related-words
|
||||
|
||||
HELP: alien>string
|
||||
{ $values { "c-ptr" c-ptr } { "encoding" "an encoding descriptor" } { "string/f" "a string or " { $link f } } }
|
||||
{ $description "Reads a null-terminated C string from the specified address with the given encoding." } ;
|
||||
|
||||
HELP: malloc-string
|
||||
{ $values { "string" string } { "encoding" "an encoding descriptor" } { "alien" c-ptr } }
|
||||
{ $description "Encodes a string together with a trailing null code point using the given encoding, and stores the resulting bytes in a freshly-allocated unmanaged memory block." }
|
||||
{ $warning "Don't forget to deallocate the memory with a call to " { $link free } "." }
|
||||
{ $errors "Throws an error if one of the following conditions occurs:"
|
||||
{ $list
|
||||
"the string contains null code points"
|
||||
"the string contains characters not representable using the encoding specified"
|
||||
"memory allocation fails"
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: string>symbol
|
||||
{ $values { "str" string } { "alien" alien } }
|
||||
{ $description "Converts the string to a format which is a valid symbol name for the Factor VM's compiled code linker. By performing this conversion ahead of time, the image loader can run without allocating memory."
|
||||
$nl
|
||||
"On Windows CE, symbols are represented as UCS2 strings, and on all other platforms they are ASCII strings." } ;
|
||||
|
||||
HELP: utf16n
|
||||
{ $class-description "The encoding descriptor for UTF-16 without a byte order mark in native endian order. This is useful mostly for FFI calls which take input of strings of the type wchar_t*" }
|
||||
{ $see-also "encodings-introduction" } ;
|
||||
|
||||
ARTICLE: "c-strings" "C strings"
|
||||
"C string types are arrays with shape " { $snippet "{ \"char*\" encoding }" } ", where " { $snippet "encoding" } " is an encoding descriptor. The type " { $snippet "\"char*\"" } " is an alias for " { $snippet "{ \"char*\" utf8 }" } ". See " { $link "encodings-descriptors" } " for information about encoding descriptors."
|
||||
$nl
|
||||
"Passing a Factor string to a C function expecting a C string allocates a " { $link byte-array } " in the Factor heap; the string is then converted to the requested format and a raw pointer is passed to the function. If the conversion fails, for example if the string contains null bytes or characters with values higher than 255, a " { $link c-string-error. } " is thrown."
|
||||
$nl
|
||||
"Sometimes a C function has a parameter type of " { $snippet "void*" } ", and various data types, among them strings, can be passed in. In this case, strings are not automatically converted to aliens, and instead you must call one of these words:"
|
||||
{ $subsection string>alien }
|
||||
{ $subsection malloc-string }
|
||||
"The first allocates " { $link byte-array } "s, and the latter allocates manually-managed memory which is not moved by the garbage collector and has to be explicitly freed by calling " { $link free } ". See " { $link "byte-arrays-gc" } " for a discussion of the two approaches."
|
||||
$nl
|
||||
"A word to read strings from arbitrary addresses:"
|
||||
{ $subsection alien>string }
|
||||
"For example, if a C function returns a " { $snippet "char*" } " but stipulates that the caller must deallocate the memory afterward, you must define the function as returning " { $snippet "void*" } ", and call one of the above words before passing the pointer to " { $link free } "." ;
|
||||
|
||||
ABOUT: "c-strings"
|
||||
|
|
@ -0,0 +1,30 @@
|
|||
USING: alien.strings tools.test kernel libc
|
||||
io.encodings.8-bit io.encodings.utf8 io.encodings.utf16
|
||||
io.encodings.ascii alien ;
|
||||
IN: alien.strings.tests
|
||||
|
||||
[ "\u0000ff" ]
|
||||
[ "\u0000ff" latin1 string>alien latin1 alien>string ]
|
||||
unit-test
|
||||
|
||||
[ "hello world" ]
|
||||
[ "hello world" latin1 string>alien latin1 alien>string ]
|
||||
unit-test
|
||||
|
||||
[ "hello\u00abcdworld" ]
|
||||
[ "hello\u00abcdworld" utf16le string>alien utf16le alien>string ]
|
||||
unit-test
|
||||
|
||||
[ t ] [ f expired? ] unit-test
|
||||
|
||||
[ "hello world" ] [
|
||||
"hello world" ascii malloc-string
|
||||
dup ascii alien>string swap free
|
||||
] unit-test
|
||||
|
||||
[ "hello world" ] [
|
||||
"hello world" utf16n malloc-string
|
||||
dup utf16n alien>string swap free
|
||||
] unit-test
|
||||
|
||||
[ f ] [ f utf8 alien>string ] unit-test
|
||||
|
|
@ -0,0 +1,111 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays sequences kernel accessors math alien.accessors
|
||||
alien.c-types byte-arrays words io io.encodings
|
||||
io.streams.byte-array io.streams.memory io.encodings.utf8
|
||||
io.encodings.utf16 system alien strings cpu.architecture ;
|
||||
IN: alien.strings
|
||||
|
||||
GENERIC# alien>string 1 ( c-ptr encoding -- string/f )
|
||||
|
||||
M: c-ptr alien>string
|
||||
>r <memory-stream> r> <decoder>
|
||||
"\0" swap stream-read-until drop ;
|
||||
|
||||
M: f alien>string
|
||||
drop ;
|
||||
|
||||
ERROR: invalid-c-string string ;
|
||||
|
||||
: check-string ( string -- )
|
||||
0 over memq? [ invalid-c-string ] [ drop ] if ;
|
||||
|
||||
GENERIC# string>alien 1 ( string encoding -- byte-array )
|
||||
|
||||
M: c-ptr string>alien drop ;
|
||||
|
||||
M: string string>alien
|
||||
over check-string
|
||||
<byte-writer>
|
||||
[ stream-write ]
|
||||
[ 0 swap stream-write1 ]
|
||||
[ stream>> >byte-array ]
|
||||
tri ;
|
||||
|
||||
: malloc-string ( string encoding -- alien )
|
||||
string>alien malloc-byte-array ;
|
||||
|
||||
PREDICATE: string-type < pair
|
||||
first2 [ "char*" = ] [ word? ] bi* and ;
|
||||
|
||||
M: string-type c-type ;
|
||||
|
||||
M: string-type heap-size
|
||||
drop "void*" heap-size ;
|
||||
|
||||
M: string-type c-type-align
|
||||
drop "void*" c-type-align ;
|
||||
|
||||
M: string-type c-type-stack-align?
|
||||
drop "void*" c-type-stack-align? ;
|
||||
|
||||
M: string-type unbox-parameter
|
||||
drop "void*" unbox-parameter ;
|
||||
|
||||
M: string-type unbox-return
|
||||
drop "void*" unbox-return ;
|
||||
|
||||
M: string-type box-parameter
|
||||
drop "void*" box-parameter ;
|
||||
|
||||
M: string-type box-return
|
||||
drop "void*" box-return ;
|
||||
|
||||
M: string-type stack-size
|
||||
drop "void*" stack-size ;
|
||||
|
||||
M: string-type c-type-reg-class
|
||||
drop int-regs ;
|
||||
|
||||
M: string-type c-type-boxer
|
||||
drop "void*" c-type-boxer ;
|
||||
|
||||
M: string-type c-type-unboxer
|
||||
drop "void*" c-type-unboxer ;
|
||||
|
||||
M: string-type c-type-boxer-quot
|
||||
second [ alien>string ] curry [ ] like ;
|
||||
|
||||
M: string-type c-type-unboxer-quot
|
||||
second [ string>alien ] curry [ ] like ;
|
||||
|
||||
M: string-type c-type-getter
|
||||
drop [ alien-cell ] ;
|
||||
|
||||
M: string-type c-type-setter
|
||||
drop [ set-alien-cell ] ;
|
||||
|
||||
TUPLE: utf16n ;
|
||||
|
||||
! Native-order UTF-16
|
||||
|
||||
: utf16n ( -- descriptor )
|
||||
little-endian? utf16le utf16be ? ; foldable
|
||||
|
||||
M: utf16n <decoder> drop utf16n <decoder> ;
|
||||
|
||||
M: utf16n <encoder> drop utf16n <encoder> ;
|
||||
|
||||
: alien>native-string ( alien -- string )
|
||||
os windows? [ utf16n ] [ utf8 ] if alien>string ;
|
||||
|
||||
: dll-path ( dll -- string )
|
||||
(dll-path) alien>native-string ;
|
||||
|
||||
: string>symbol ( str -- alien )
|
||||
[ os wince? [ utf16n ] [ utf8 ] if string>alien ]
|
||||
over string? [ call ] [ map ] if ;
|
||||
|
||||
{ "char*" utf8 } "char*" typedef
|
||||
{ "char*" utf16n } "wchar_t*" typedef
|
||||
"char*" "uchar*" typedef
|
||||
|
|
@ -1,6 +1,6 @@
|
|||
IN: alien.structs.tests
|
||||
USING: alien alien.syntax alien.c-types kernel tools.test
|
||||
sequences system libc words vocabs namespaces ;
|
||||
sequences system libc words vocabs namespaces layouts ;
|
||||
|
||||
C-STRUCT: bar
|
||||
{ "int" "x" }
|
||||
|
|
@ -9,20 +9,20 @@ C-STRUCT: bar
|
|||
[ 36 ] [ "bar" heap-size ] unit-test
|
||||
[ t ] [ \ <displaced-alien> "bar" c-type c-type-getter memq? ] unit-test
|
||||
|
||||
! This was actually only correct on Windows/x86:
|
||||
C-STRUCT: align-test
|
||||
{ "int" "x" }
|
||||
{ "double" "y" } ;
|
||||
|
||||
! C-STRUCT: align-test
|
||||
! { "int" "x" }
|
||||
! { "double" "y" } ;
|
||||
!
|
||||
! [ 16 ] [ "align-test" heap-size ] unit-test
|
||||
!
|
||||
! cell 4 = [
|
||||
! C-STRUCT: one
|
||||
! { "long" "a" } { "double" "b" } { "int" "c" } ;
|
||||
!
|
||||
! [ 24 ] [ "one" heap-size ] unit-test
|
||||
! ] when
|
||||
os winnt? cpu x86? and [
|
||||
[ 16 ] [ "align-test" heap-size ] unit-test
|
||||
|
||||
cell 4 = [
|
||||
C-STRUCT: one
|
||||
{ "long" "a" } { "double" "b" } { "int" "c" } ;
|
||||
|
||||
[ 24 ] [ "one" heap-size ] unit-test
|
||||
] when
|
||||
] when
|
||||
|
||||
: MAX_FOOS 30 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -20,14 +20,19 @@ IN: alien.structs
|
|||
|
||||
: define-getter ( type spec -- )
|
||||
[ set-reader-props ] keep
|
||||
dup slot-spec-reader
|
||||
over slot-spec-type c-getter
|
||||
[ ]
|
||||
[ slot-spec-reader ]
|
||||
[
|
||||
slot-spec-type
|
||||
[ c-getter ] [ c-type c-type-boxer-quot ] bi append
|
||||
] tri
|
||||
define-struct-slot-word ;
|
||||
|
||||
: define-setter ( type spec -- )
|
||||
[ set-writer-props ] keep
|
||||
dup slot-spec-writer
|
||||
over slot-spec-type c-setter
|
||||
[ ]
|
||||
[ slot-spec-writer ]
|
||||
[ slot-spec-type c-setter ] tri
|
||||
define-struct-slot-word ;
|
||||
|
||||
: define-field ( type spec -- )
|
||||
|
|
|
|||
|
|
@ -1,9 +1,9 @@
|
|||
! Copyright (C) 2005, 2008 Slava Pestov, Alex Chapman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays alien alien.c-types alien.structs alien.arrays
|
||||
kernel math namespaces parser sequences words quotations
|
||||
math.parser splitting effects prettyprint prettyprint.sections
|
||||
prettyprint.backend assocs combinators ;
|
||||
alien.strings kernel math namespaces parser sequences words
|
||||
quotations math.parser splitting effects prettyprint
|
||||
prettyprint.sections prettyprint.backend assocs combinators ;
|
||||
IN: alien.syntax
|
||||
|
||||
<PRIVATE
|
||||
|
|
|
|||
|
|
@ -58,16 +58,13 @@ num-types get f <array> builtins set
|
|||
"alien.accessors"
|
||||
"arrays"
|
||||
"bit-arrays"
|
||||
"bit-vectors"
|
||||
"byte-arrays"
|
||||
"byte-vectors"
|
||||
"classes.private"
|
||||
"classes.tuple"
|
||||
"classes.tuple.private"
|
||||
"compiler.units"
|
||||
"continuations.private"
|
||||
"float-arrays"
|
||||
"float-vectors"
|
||||
"generator"
|
||||
"growable"
|
||||
"hashtables"
|
||||
|
|
@ -455,54 +452,6 @@ tuple
|
|||
}
|
||||
} define-tuple-class
|
||||
|
||||
"byte-vector" "byte-vectors" create
|
||||
tuple
|
||||
{
|
||||
{
|
||||
{ "byte-array" "byte-arrays" }
|
||||
"underlying"
|
||||
{ "underlying" "growable" }
|
||||
{ "set-underlying" "growable" }
|
||||
} {
|
||||
{ "array-capacity" "sequences.private" }
|
||||
"fill"
|
||||
{ "length" "sequences" }
|
||||
{ "set-fill" "growable" }
|
||||
}
|
||||
} define-tuple-class
|
||||
|
||||
"bit-vector" "bit-vectors" create
|
||||
tuple
|
||||
{
|
||||
{
|
||||
{ "bit-array" "bit-arrays" }
|
||||
"underlying"
|
||||
{ "underlying" "growable" }
|
||||
{ "set-underlying" "growable" }
|
||||
} {
|
||||
{ "array-capacity" "sequences.private" }
|
||||
"fill"
|
||||
{ "length" "sequences" }
|
||||
{ "set-fill" "growable" }
|
||||
}
|
||||
} define-tuple-class
|
||||
|
||||
"float-vector" "float-vectors" create
|
||||
tuple
|
||||
{
|
||||
{
|
||||
{ "float-array" "float-arrays" }
|
||||
"underlying"
|
||||
{ "underlying" "growable" }
|
||||
{ "set-underlying" "growable" }
|
||||
} {
|
||||
{ "array-capacity" "sequences.private" }
|
||||
"fill"
|
||||
{ "length" "sequences" }
|
||||
{ "set-fill" "growable" }
|
||||
}
|
||||
} define-tuple-class
|
||||
|
||||
"curry" "kernel" create
|
||||
tuple
|
||||
{
|
||||
|
|
@ -689,10 +638,6 @@ tuple
|
|||
{ "set-alien-double" "alien.accessors" }
|
||||
{ "alien-cell" "alien.accessors" }
|
||||
{ "set-alien-cell" "alien.accessors" }
|
||||
{ "alien>char-string" "alien" }
|
||||
{ "string>char-alien" "alien" }
|
||||
{ "alien>u16-string" "alien" }
|
||||
{ "string>u16-alien" "alien" }
|
||||
{ "(throw)" "kernel.private" }
|
||||
{ "alien-address" "alien" }
|
||||
{ "slot" "slots.private" }
|
||||
|
|
|
|||
|
|
@ -27,10 +27,6 @@ SYMBOL: bootstrap-time
|
|||
diff
|
||||
[ "bootstrap." prepend require ] each ;
|
||||
|
||||
! : compile-remaining ( -- )
|
||||
! "Compiling remaining words..." print flush
|
||||
! vocabs [ words [ compiled? not ] subset compile ] each ;
|
||||
|
||||
: count-words ( pred -- )
|
||||
all-words swap subset length number>string write ;
|
||||
|
||||
|
|
|
|||
|
|
@ -14,16 +14,13 @@ IN: bootstrap.syntax
|
|||
";"
|
||||
"<PRIVATE"
|
||||
"?{"
|
||||
"?V{"
|
||||
"BIN:"
|
||||
"B{"
|
||||
"BV{"
|
||||
"C:"
|
||||
"CHAR:"
|
||||
"DEFER:"
|
||||
"ERROR:"
|
||||
"F{"
|
||||
"FV{"
|
||||
"FORGET:"
|
||||
"GENERIC#"
|
||||
"GENERIC:"
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@ kernel math namespaces parser prettyprint sequences strings
|
|||
tools.test vectors words quotations classes classes.algebra
|
||||
classes.private classes.union classes.mixin classes.predicate
|
||||
vectors definitions source-files compiler.units growable
|
||||
random inference effects kernel.private ;
|
||||
random inference effects kernel.private sbufs ;
|
||||
|
||||
: class= [ class< ] 2keep swap class< and ;
|
||||
|
||||
|
|
@ -144,6 +144,48 @@ UNION: z1 b1 c1 ;
|
|||
|
||||
[ f ] [ null class-not null class= ] unit-test
|
||||
|
||||
[ t ] [
|
||||
fixnum class-not
|
||||
fixnum fixnum class-not class-or
|
||||
class<
|
||||
] unit-test
|
||||
|
||||
! Test method inlining
|
||||
[ f ] [ fixnum { } min-class ] unit-test
|
||||
|
||||
[ string ] [
|
||||
\ string
|
||||
[ integer string array reversed sbuf
|
||||
slice vector quotation ]
|
||||
sort-classes min-class
|
||||
] unit-test
|
||||
|
||||
[ fixnum ] [
|
||||
\ fixnum
|
||||
[ fixnum integer object ]
|
||||
sort-classes min-class
|
||||
] unit-test
|
||||
|
||||
[ integer ] [
|
||||
\ fixnum
|
||||
[ integer float object ]
|
||||
sort-classes min-class
|
||||
] unit-test
|
||||
|
||||
[ object ] [
|
||||
\ word
|
||||
[ integer float object ]
|
||||
sort-classes min-class
|
||||
] unit-test
|
||||
|
||||
[ reversed ] [
|
||||
\ reversed
|
||||
[ integer reversed slice ]
|
||||
sort-classes min-class
|
||||
] unit-test
|
||||
|
||||
[ f ] [ null { number fixnum null } min-class ] unit-test
|
||||
|
||||
! Test for hangs?
|
||||
: random-class classes random ;
|
||||
|
||||
|
|
|
|||
|
|
@ -77,10 +77,10 @@ C: <anonymous-complement> anonymous-complement
|
|||
{ [ 2dup [ anonymous-complement? ] both? ] [ anonymous-complement< ] }
|
||||
{ [ over anonymous-union? ] [ left-anonymous-union< ] }
|
||||
{ [ over anonymous-intersection? ] [ left-anonymous-intersection< ] }
|
||||
{ [ over anonymous-complement? ] [ 2drop f ] }
|
||||
{ [ over members ] [ left-union-class< ] }
|
||||
{ [ dup anonymous-union? ] [ right-anonymous-union< ] }
|
||||
{ [ dup anonymous-intersection? ] [ right-anonymous-intersection< ] }
|
||||
{ [ over anonymous-complement? ] [ 2drop f ] }
|
||||
{ [ dup anonymous-complement? ] [ class>> classes-intersect? not ] }
|
||||
{ [ dup members ] [ right-union-class< ] }
|
||||
{ [ over superclass ] [ superclass< ] }
|
||||
|
|
@ -193,9 +193,8 @@ C: <anonymous-complement> anonymous-complement
|
|||
[ ] unfold nip ;
|
||||
|
||||
: min-class ( class seq -- class/f )
|
||||
[ dupd classes-intersect? ] subset dup empty? [
|
||||
2drop f
|
||||
] [
|
||||
over [ classes-intersect? ] curry subset
|
||||
dup empty? [ 2drop f ] [
|
||||
tuck [ class< ] with all? [ peek ] [ drop f ] if
|
||||
] if ;
|
||||
|
||||
|
|
|
|||
|
|
@ -3,7 +3,8 @@ math.constants parser sequences tools.test words assocs
|
|||
namespaces quotations sequences.private classes continuations
|
||||
generic.standard effects classes.tuple classes.tuple.private
|
||||
arrays vectors strings compiler.units accessors classes.algebra
|
||||
calendar prettyprint io.streams.string splitting inspector ;
|
||||
calendar prettyprint io.streams.string splitting inspector
|
||||
columns ;
|
||||
IN: classes.tuple.tests
|
||||
|
||||
TUPLE: rect x y w h ;
|
||||
|
|
|
|||
|
|
@ -150,7 +150,7 @@ M: hashtable hashcode*
|
|||
drop
|
||||
] [
|
||||
dup length 4 <=
|
||||
over keys [ word? ] contains? or
|
||||
over keys [ [ word? ] [ wrapper? ] bi or ] contains? or
|
||||
[
|
||||
linear-case-quot
|
||||
] [
|
||||
|
|
|
|||
|
|
@ -4,8 +4,8 @@ math.constants math.private sequences strings tools.test words
|
|||
continuations sequences.private hashtables.private byte-arrays
|
||||
strings.private system random layouts vectors.private
|
||||
sbufs.private strings.private slots.private alien
|
||||
alien.accessors alien.c-types alien.syntax namespaces libc
|
||||
sequences.private ;
|
||||
alien.accessors alien.c-types alien.syntax alien.strings
|
||||
namespaces libc sequences.private io.encodings.ascii ;
|
||||
|
||||
! Make sure that intrinsic ops compile to correct code.
|
||||
[ ] [ 1 [ drop ] compile-call ] unit-test
|
||||
|
|
@ -361,11 +361,11 @@ cell 8 = [
|
|||
[ ] [ "b" get free ] unit-test
|
||||
] when
|
||||
|
||||
[ ] [ "hello world" malloc-char-string "s" set ] unit-test
|
||||
[ ] [ "hello world" ascii malloc-string "s" set ] unit-test
|
||||
|
||||
"s" get [
|
||||
[ "hello world" ] [ "s" get <void*> [ { byte-array } declare *void* ] compile-call alien>char-string ] unit-test
|
||||
[ "hello world" ] [ "s" get <void*> [ { c-ptr } declare *void* ] compile-call alien>char-string ] unit-test
|
||||
[ "hello world" ] [ "s" get <void*> [ { byte-array } declare *void* ] compile-call ascii alien>string ] unit-test
|
||||
[ "hello world" ] [ "s" get <void*> [ { c-ptr } declare *void* ] compile-call ascii alien>string ] unit-test
|
||||
|
||||
[ ] [ "s" get free ] unit-test
|
||||
] when
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
USING: compiler.units tools.test kernel kernel.private
|
||||
sequences.private math.private math combinators strings
|
||||
alien arrays memory ;
|
||||
alien arrays memory vocabs parser ;
|
||||
IN: compiler.tests
|
||||
|
||||
! Test empty word
|
||||
|
|
@ -230,3 +230,11 @@ M: f single-combination-test-2 single-combination-test-4 ;
|
|||
|
||||
! Regression
|
||||
[ 100 ] [ [ 100 [ [ ] times ] keep ] compile-call ] unit-test
|
||||
|
||||
! Regression
|
||||
10 [
|
||||
[ "compiler.tests.foo" forget-vocab ] with-compilation-unit
|
||||
[ t ] [
|
||||
"USING: prettyprint words ; IN: compiler.tests.foo : (recursive) ( -- ) (recursive) (recursive) ; inline : recursive ( -- ) (recursive) ; \\ (recursive) compiled?" eval
|
||||
] unit-test
|
||||
] times
|
||||
|
|
|
|||
|
|
@ -2,7 +2,8 @@
|
|||
IN: compiler.tests
|
||||
USING: compiler generator generator.registers
|
||||
generator.registers.private tools.test namespaces sequences
|
||||
words kernel math effects definitions compiler.units accessors ;
|
||||
words kernel math effects definitions compiler.units accessors
|
||||
cpu.architecture ;
|
||||
|
||||
: <int-vreg> ( n -- vreg ) int-regs <vreg> ;
|
||||
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@ USING: arrays compiler kernel kernel.private math
|
|||
hashtables.private math.private namespaces sequences
|
||||
sequences.private tools.test namespaces.private slots.private
|
||||
sequences.private byte-arrays alien alien.accessors layouts
|
||||
words definitions compiler.units io combinators ;
|
||||
words definitions compiler.units io combinators vectors ;
|
||||
IN: compiler.tests
|
||||
|
||||
! Oops!
|
||||
|
|
@ -246,3 +246,12 @@ TUPLE: my-tuple ;
|
|||
} cleave ;
|
||||
|
||||
[ t ] [ \ float-spill-bug compiled? ] unit-test
|
||||
|
||||
! Regression
|
||||
: dispatch-alignment-regression ( -- c )
|
||||
{ tuple vector } 3 slot { word } declare
|
||||
dup 1 slot 0 fixnum-bitand { [ ] } dispatch ;
|
||||
|
||||
[ t ] [ \ dispatch-alignment-regression compiled? ] unit-test
|
||||
|
||||
[ vector ] [ dispatch-alignment-regression ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,10 +1,17 @@
|
|||
! Copyright (C) 2006, 2007 Slava Pestov.
|
||||
! Copyright (C) 2006, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays generic kernel kernel.private math memory
|
||||
namespaces sequences layouts system hashtables classes alien
|
||||
byte-arrays bit-arrays float-arrays combinators words sets ;
|
||||
IN: cpu.architecture
|
||||
|
||||
! Register classes
|
||||
SINGLETON: int-regs
|
||||
SINGLETON: single-float-regs
|
||||
SINGLETON: double-float-regs
|
||||
UNION: float-regs single-float-regs double-float-regs ;
|
||||
UNION: reg-class int-regs float-regs ;
|
||||
|
||||
! A pseudo-register class for parameters spilled on the stack
|
||||
SINGLETON: stack-params
|
||||
|
||||
|
|
@ -56,7 +63,7 @@ HOOK: %call cpu ( word -- )
|
|||
HOOK: %jump-label cpu ( label -- )
|
||||
|
||||
! Test if vreg is 'f' or not
|
||||
HOOK: %jump-t cpu ( label -- )
|
||||
HOOK: %jump-f cpu ( label -- )
|
||||
|
||||
HOOK: %dispatch cpu ( -- )
|
||||
|
||||
|
|
@ -187,6 +194,9 @@ HOOK: %unbox-any-c-ptr cpu ( dst src -- )
|
|||
|
||||
HOOK: %box-alien cpu ( dst src -- )
|
||||
|
||||
! GC check
|
||||
HOOK: %gc cpu
|
||||
|
||||
: operand ( var -- op ) get v>operand ; inline
|
||||
|
||||
: unique-operands ( operands quot -- )
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
! Copyright (C) 2006, 2007 Slava Pestov.
|
||||
! Copyright (C) 2006, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel cpu.ppc.architecture cpu.ppc.assembler
|
||||
kernel.private namespaces math sequences generic arrays
|
||||
|
|
@ -7,7 +7,7 @@ cpu.architecture alien ;
|
|||
IN: cpu.ppc.allot
|
||||
|
||||
: load-zone-ptr ( reg -- )
|
||||
"nursery" f pick %load-dlsym dup 0 LWZ ;
|
||||
>r "nursery" f r> %load-dlsym ;
|
||||
|
||||
: %allot ( header size -- )
|
||||
#! Store a pointer to 'size' bytes allocated from the
|
||||
|
|
@ -25,6 +25,19 @@ IN: cpu.ppc.allot
|
|||
: %store-tagged ( reg tag -- )
|
||||
>r dup fresh-object v>operand 11 r> tag-number ORI ;
|
||||
|
||||
M: ppc %gc
|
||||
"end" define-label
|
||||
12 load-zone-ptr
|
||||
11 12 cell LWZ ! nursery.here -> r11
|
||||
12 12 3 cells LWZ ! nursery.end -> r12
|
||||
11 11 1024 ADDI ! add ALLOT_BUFFER_ZONE to here
|
||||
11 0 12 CMP ! is here >= end?
|
||||
"end" get BLE
|
||||
0 frame-required
|
||||
%prepare-alien-invoke
|
||||
"minor_gc" f %alien-invoke
|
||||
"end" resolve-label ;
|
||||
|
||||
: %allot-float ( reg -- )
|
||||
#! exits with tagged ptr to object in r12, untagged in r11
|
||||
float 16 %allot
|
||||
|
|
|
|||
|
|
@ -106,8 +106,8 @@ M: ppc %call ( label -- ) BL ;
|
|||
|
||||
M: ppc %jump-label ( label -- ) B ;
|
||||
|
||||
M: ppc %jump-t ( label -- )
|
||||
0 "flag" operand f v>operand CMPI BNE ;
|
||||
M: ppc %jump-f ( label -- )
|
||||
0 "flag" operand f v>operand CMPI BEQ ;
|
||||
|
||||
M: ppc %dispatch ( -- )
|
||||
[
|
||||
|
|
|
|||
|
|
@ -217,11 +217,11 @@ IN: cpu.ppc.intrinsics
|
|||
2array define-if-intrinsics ;
|
||||
|
||||
{
|
||||
{ fixnum< BLT }
|
||||
{ fixnum<= BLE }
|
||||
{ fixnum> BGT }
|
||||
{ fixnum>= BGE }
|
||||
{ eq? BEQ }
|
||||
{ fixnum< BGE }
|
||||
{ fixnum<= BGT }
|
||||
{ fixnum> BLE }
|
||||
{ fixnum>= BLT }
|
||||
{ eq? BNE }
|
||||
} [
|
||||
first2 define-fixnum-jump
|
||||
] each
|
||||
|
|
@ -356,11 +356,11 @@ IN: cpu.ppc.intrinsics
|
|||
{ { float "x" } { float "y" } } define-if-intrinsic ;
|
||||
|
||||
{
|
||||
{ float< BLT }
|
||||
{ float<= BLE }
|
||||
{ float> BGT }
|
||||
{ float>= BGE }
|
||||
{ float= BEQ }
|
||||
{ float< BGE }
|
||||
{ float<= BGT }
|
||||
{ float> BLE }
|
||||
{ float>= BLT }
|
||||
{ float= BNE }
|
||||
} [
|
||||
first2 define-float-jump
|
||||
] each
|
||||
|
|
|
|||
|
|
@ -16,8 +16,9 @@ IN: cpu.x86.32
|
|||
M: x86.32 ds-reg ESI ;
|
||||
M: x86.32 rs-reg EDI ;
|
||||
M: x86.32 stack-reg ESP ;
|
||||
M: x86.32 xt-reg ECX ;
|
||||
M: x86.32 stack-save-reg EDX ;
|
||||
M: x86.32 temp-reg-1 EAX ;
|
||||
M: x86.32 temp-reg-2 ECX ;
|
||||
|
||||
M: temp-reg v>operand drop EBX ;
|
||||
|
||||
|
|
@ -267,7 +268,7 @@ os windows? [
|
|||
EDX 26 SHR
|
||||
EDX 1 AND
|
||||
{ EAX EBX ECX EDX } [ POP ] each
|
||||
JNE
|
||||
JE
|
||||
] { } define-if-intrinsic
|
||||
|
||||
"-no-sse2" cli-args member? [
|
||||
|
|
|
|||
|
|
@ -11,8 +11,9 @@ IN: cpu.x86.64
|
|||
M: x86.64 ds-reg R14 ;
|
||||
M: x86.64 rs-reg R15 ;
|
||||
M: x86.64 stack-reg RSP ;
|
||||
M: x86.64 xt-reg RCX ;
|
||||
M: x86.64 stack-save-reg RSI ;
|
||||
M: x86.64 temp-reg-1 RAX ;
|
||||
M: x86.64 temp-reg-2 RCX ;
|
||||
|
||||
M: temp-reg v>operand drop RBX ;
|
||||
|
||||
|
|
|
|||
|
|
@ -16,12 +16,12 @@ IN: cpu.x86.allot
|
|||
|
||||
: object@ ( n -- operand ) cells (object@) ;
|
||||
|
||||
: load-zone-ptr ( -- )
|
||||
: load-zone-ptr ( reg -- )
|
||||
#! Load pointer to start of zone array
|
||||
"nursery" f allot-reg %alien-global ;
|
||||
0 MOV "nursery" f rc-absolute-cell rel-dlsym ;
|
||||
|
||||
: load-allot-ptr ( -- )
|
||||
load-zone-ptr
|
||||
allot-reg load-zone-ptr
|
||||
allot-reg PUSH
|
||||
allot-reg dup cell [+] MOV ;
|
||||
|
||||
|
|
@ -29,6 +29,19 @@ IN: cpu.x86.allot
|
|||
allot-reg POP
|
||||
allot-reg cell [+] swap 8 align ADD ;
|
||||
|
||||
M: x86 %gc ( -- )
|
||||
"end" define-label
|
||||
temp-reg-1 load-zone-ptr
|
||||
temp-reg-2 temp-reg-1 cell [+] MOV
|
||||
temp-reg-2 1024 ADD
|
||||
temp-reg-1 temp-reg-1 3 cells [+] MOV
|
||||
temp-reg-2 temp-reg-1 CMP
|
||||
"end" get JLE
|
||||
0 frame-required
|
||||
%prepare-alien-invoke
|
||||
"minor_gc" f %alien-invoke
|
||||
"end" resolve-label ;
|
||||
|
||||
: store-header ( header -- )
|
||||
0 object@ swap type-number tag-fixnum MOV ;
|
||||
|
||||
|
|
|
|||
|
|
@ -9,7 +9,6 @@ IN: cpu.x86.architecture
|
|||
HOOK: ds-reg cpu
|
||||
HOOK: rs-reg cpu
|
||||
HOOK: stack-reg cpu
|
||||
HOOK: xt-reg cpu
|
||||
HOOK: stack-save-reg cpu
|
||||
|
||||
: stack@ stack-reg swap [+] ;
|
||||
|
|
@ -35,6 +34,10 @@ GENERIC: push-return-reg ( reg-class -- )
|
|||
GENERIC: load-return-reg ( stack@ reg-class -- )
|
||||
GENERIC: store-return-reg ( stack@ reg-class -- )
|
||||
|
||||
! Only used by inline allocation
|
||||
HOOK: temp-reg-1 cpu
|
||||
HOOK: temp-reg-2 cpu
|
||||
|
||||
HOOK: address-operand cpu ( address -- operand )
|
||||
|
||||
HOOK: fixnum>slot@ cpu
|
||||
|
|
@ -47,13 +50,13 @@ M: x86 stack-frame ( n -- i )
|
|||
3 cells + 16 align cell - ;
|
||||
|
||||
M: x86 %save-word-xt ( -- )
|
||||
xt-reg 0 MOV rc-absolute-cell rel-this ;
|
||||
temp-reg v>operand 0 MOV rc-absolute-cell rel-this ;
|
||||
|
||||
: factor-area-size 4 cells ;
|
||||
|
||||
M: x86 %prologue ( n -- )
|
||||
dup cell + PUSH
|
||||
xt-reg PUSH
|
||||
temp-reg v>operand PUSH
|
||||
stack-reg swap 2 cells - SUB ;
|
||||
|
||||
M: x86 %epilogue ( n -- )
|
||||
|
|
@ -76,8 +79,8 @@ M: x86 %call ( label -- ) CALL ;
|
|||
|
||||
M: x86 %jump-label ( label -- ) JMP ;
|
||||
|
||||
M: x86 %jump-t ( label -- )
|
||||
"flag" operand f v>operand CMP JNE ;
|
||||
M: x86 %jump-f ( label -- )
|
||||
"flag" operand f v>operand CMP JE ;
|
||||
|
||||
: code-alignment ( -- n )
|
||||
building get length dup cell align swap - ;
|
||||
|
|
|
|||
|
|
@ -212,11 +212,11 @@ IN: cpu.x86.intrinsics
|
|||
2array define-if-intrinsics ;
|
||||
|
||||
{
|
||||
{ fixnum< JL }
|
||||
{ fixnum<= JLE }
|
||||
{ fixnum> JG }
|
||||
{ fixnum>= JGE }
|
||||
{ eq? JE }
|
||||
{ fixnum< JGE }
|
||||
{ fixnum<= JG }
|
||||
{ fixnum> JLE }
|
||||
{ fixnum>= JL }
|
||||
{ eq? JNE }
|
||||
} [
|
||||
first2 define-fixnum-jump
|
||||
] each
|
||||
|
|
|
|||
|
|
@ -27,11 +27,11 @@ IN: cpu.x86.sse2
|
|||
{ { float "x" } { float "y" } } define-if-intrinsic ;
|
||||
|
||||
{
|
||||
{ float< JB }
|
||||
{ float<= JBE }
|
||||
{ float> JA }
|
||||
{ float>= JAE }
|
||||
{ float= JE }
|
||||
{ float< JAE }
|
||||
{ float<= JA }
|
||||
{ float> JBE }
|
||||
{ float>= JB }
|
||||
{ float= JNE }
|
||||
} [
|
||||
first2 define-float-jump
|
||||
] each
|
||||
|
|
|
|||
|
|
@ -13,12 +13,6 @@ 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: string>symbol
|
||||
{ $values { "str" string } { "alien" alien } }
|
||||
{ $description "Converts the string to a format which is a valid symbol name for the Factor VM's compiled code linker. By performing this conversion ahead of time, the image loader can run without allocating memory."
|
||||
$nl
|
||||
"On Windows CE, symbols are represented as UCS2 strings, and on all other platforms they are ASCII strings." } ;
|
||||
|
||||
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."
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays generic assocs hashtables
|
||||
kernel kernel.private math namespaces sequences words
|
||||
quotations strings alien layouts system combinators
|
||||
quotations strings alien.strings layouts system combinators
|
||||
math.bitfields words.private cpu.architecture ;
|
||||
IN: generator.fixup
|
||||
|
||||
|
|
@ -110,10 +110,6 @@ SYMBOL: literal-table
|
|||
|
||||
: add-literal ( obj -- n ) literal-table get push-new* ;
|
||||
|
||||
: string>symbol ( str -- alien )
|
||||
[ os wince? [ string>u16-alien ] [ string>char-alien ] if ]
|
||||
over string? [ call ] [ map ] if ;
|
||||
|
||||
: add-dlsym-literals ( symbol dll -- )
|
||||
>r string>symbol r> 2array literal-table get push-all ;
|
||||
|
||||
|
|
|
|||
|
|
@ -40,16 +40,16 @@ SYMBOL: current-label-start
|
|||
compiled-stack-traces?
|
||||
compiling-word get f ?
|
||||
1vector literal-table set
|
||||
f compiling-word get compiled get set-at ;
|
||||
f compiling-label get compiled get set-at ;
|
||||
|
||||
: finish-compiling ( literals relocation labels code -- )
|
||||
: 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
|
||||
finish-compiling
|
||||
save-machine-code
|
||||
] with-scope ; inline
|
||||
|
||||
GENERIC: generate-node ( node -- next )
|
||||
|
|
@ -73,6 +73,7 @@ GENERIC: generate-node ( node -- next )
|
|||
: word-dataflow ( word -- effect dataflow )
|
||||
[
|
||||
dup "no-effect" word-prop [ no-effect ] when
|
||||
dup "no-compile" word-prop [ no-effect ] when
|
||||
dup specialized-def over dup 2array 1array infer-quot
|
||||
finish-word
|
||||
] with-infer ;
|
||||
|
|
@ -131,14 +132,14 @@ M: #loop generate-node
|
|||
|
||||
: generate-if ( node label -- next )
|
||||
<label> [
|
||||
>r >r node-children first2 generate-branch
|
||||
>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-t ]
|
||||
[ <label> dup %jump-f ]
|
||||
H{ { +input+ { { f "flag" } } } }
|
||||
with-template
|
||||
generate-if ;
|
||||
|
|
@ -189,13 +190,13 @@ M: #dispatch generate-node
|
|||
"if-intrinsics" set-word-prop ;
|
||||
|
||||
: if>boolean-intrinsic ( quot -- )
|
||||
"true" define-label
|
||||
"false" define-label
|
||||
"end" define-label
|
||||
"true" get swap call
|
||||
f "if-scratch" get load-literal
|
||||
"end" get %jump-label
|
||||
"true" resolve-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
|
||||
|
||||
|
|
|
|||
|
|
@ -13,13 +13,6 @@ SYMBOL: +scratch+
|
|||
SYMBOL: +clobber+
|
||||
SYMBOL: known-tag
|
||||
|
||||
! Register classes
|
||||
SINGLETON: int-regs
|
||||
SINGLETON: single-float-regs
|
||||
SINGLETON: double-float-regs
|
||||
UNION: float-regs single-float-regs double-float-regs ;
|
||||
UNION: reg-class int-regs float-regs ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
! Value protocol
|
||||
|
|
@ -65,9 +58,7 @@ M: float-regs move-spec drop float ;
|
|||
M: float-regs operand-class* drop float ;
|
||||
|
||||
! Temporary register for stack shuffling
|
||||
TUPLE: temp-reg reg-class>> ;
|
||||
|
||||
: temp-reg T{ temp-reg f int-regs } ;
|
||||
SINGLETON: temp-reg
|
||||
|
||||
M: temp-reg move-spec drop f ;
|
||||
|
||||
|
|
@ -470,11 +461,6 @@ M: loc lazy-store
|
|||
: finalize-contents ( -- )
|
||||
finalize-locs finalize-vregs reset-phantoms ;
|
||||
|
||||
: %gc ( -- )
|
||||
0 frame-required
|
||||
%prepare-alien-invoke
|
||||
"simple_gc" f %alien-invoke ;
|
||||
|
||||
! Loading stacks to vregs
|
||||
: free-vregs? ( int# float# -- ? )
|
||||
double-float-regs free-vregs length <=
|
||||
|
|
|
|||
|
|
@ -29,6 +29,9 @@ PREDICATE: method-spec < pair
|
|||
: order ( generic -- seq )
|
||||
"methods" word-prop keys sort-classes ;
|
||||
|
||||
: specific-method ( class word -- class )
|
||||
order min-class ;
|
||||
|
||||
GENERIC: effective-method ( ... generic -- method )
|
||||
|
||||
: next-method-class ( class generic -- class/f )
|
||||
|
|
|
|||
|
|
@ -1,8 +1,11 @@
|
|||
IN: generic.standard.engines.tuple
|
||||
! Copyright (c) 2008 Slava Pestov
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel classes.tuple.private hashtables assocs sorting
|
||||
accessors combinators sequences slots.private math.parser words
|
||||
effects namespaces generic generic.standard.engines
|
||||
classes.algebra math math.private quotations arrays ;
|
||||
classes.algebra math math.private kernel.private
|
||||
quotations arrays ;
|
||||
IN: generic.standard.engines.tuple
|
||||
|
||||
TUPLE: echelon-dispatch-engine n methods ;
|
||||
|
||||
|
|
@ -27,14 +30,7 @@ TUPLE: tuple-dispatch-engine echelons ;
|
|||
|
||||
: <tuple-dispatch-engine> ( methods -- engine )
|
||||
echelon-sort
|
||||
[
|
||||
over zero? [
|
||||
dup assoc-empty?
|
||||
[ drop f ] [ values first ] if
|
||||
] [
|
||||
dupd <echelon-dispatch-engine>
|
||||
] if
|
||||
] assoc-map [ nip ] assoc-subset
|
||||
[ dupd <echelon-dispatch-engine> ] assoc-map
|
||||
\ tuple-dispatch-engine boa ;
|
||||
|
||||
: convert-tuple-methods ( assoc -- assoc' )
|
||||
|
|
@ -48,52 +44,51 @@ M: trivial-tuple-dispatch-engine engine>quot
|
|||
>alist V{ } clone [ hashcode 1array ] distribute-buckets
|
||||
[ <trivial-tuple-dispatch-engine> ] map ;
|
||||
|
||||
: word-hashcode% [ 1 slot ] % ;
|
||||
|
||||
: class-hash-dispatch-quot ( methods -- quot )
|
||||
#! 1 slot == word hashcode
|
||||
[
|
||||
[ dup 1 slot ] %
|
||||
\ dup ,
|
||||
word-hashcode%
|
||||
hash-methods [ engine>quot ] map hash-dispatch-quot %
|
||||
] [ ] make ;
|
||||
|
||||
: tuple-dispatch-engine-word-name ( engine -- string )
|
||||
[
|
||||
generic get word-name %
|
||||
"/tuple-dispatch-engine/" %
|
||||
n>> #
|
||||
] "" make ;
|
||||
: engine-word-name ( -- string )
|
||||
generic get word-name "/tuple-dispatch-engine" append ;
|
||||
|
||||
PREDICATE: tuple-dispatch-engine-word < word
|
||||
PREDICATE: engine-word < word
|
||||
"tuple-dispatch-generic" word-prop generic? ;
|
||||
|
||||
M: tuple-dispatch-engine-word stack-effect
|
||||
M: engine-word stack-effect
|
||||
"tuple-dispatch-generic" word-prop
|
||||
[ extra-values ] [ stack-effect ] bi
|
||||
dup [ clone [ length + ] change-in ] [ 2drop f ] if ;
|
||||
|
||||
M: tuple-dispatch-engine-word compiled-crossref?
|
||||
M: engine-word compiled-crossref?
|
||||
drop t ;
|
||||
|
||||
: remember-engine ( word -- )
|
||||
generic get "engines" word-prop push ;
|
||||
|
||||
: <tuple-dispatch-engine-word> ( engine -- word )
|
||||
tuple-dispatch-engine-word-name f <word>
|
||||
[ generic get "tuple-dispatch-generic" set-word-prop ]
|
||||
[ remember-engine ]
|
||||
[ ]
|
||||
tri ;
|
||||
: <engine-word> ( -- word )
|
||||
engine-word-name f <word>
|
||||
dup generic get "tuple-dispatch-generic" set-word-prop ;
|
||||
|
||||
: define-tuple-dispatch-engine-word ( engine quot -- word )
|
||||
>r <tuple-dispatch-engine-word> dup r> define ;
|
||||
: define-engine-word ( quot -- word )
|
||||
>r <engine-word> dup r> define ;
|
||||
|
||||
: array-nth% 2 + , [ slot { word } declare ] % ;
|
||||
|
||||
: tuple-layout-superclasses ( obj -- array )
|
||||
{ tuple } declare
|
||||
1 slot { tuple-layout } declare
|
||||
4 slot { array } declare ; inline
|
||||
|
||||
: tuple-dispatch-engine-body ( engine -- quot )
|
||||
#! 1 slot == tuple-layout
|
||||
#! 2 slot == 0 array-nth
|
||||
#! 4 slot == layout-superclasses
|
||||
[
|
||||
picker %
|
||||
[ 1 slot 4 slot ] %
|
||||
[ n>> 2 + , [ slot ] % ]
|
||||
[ tuple-layout-superclasses ] %
|
||||
[ n>> array-nth% ]
|
||||
[
|
||||
methods>> [
|
||||
<trivial-tuple-dispatch-engine> engine>quot
|
||||
|
|
@ -104,25 +99,54 @@ M: tuple-dispatch-engine-word compiled-crossref?
|
|||
] [ ] make ;
|
||||
|
||||
M: echelon-dispatch-engine engine>quot
|
||||
dup tuple-dispatch-engine-body
|
||||
define-tuple-dispatch-engine-word
|
||||
1quotation ;
|
||||
dup n>> zero? [
|
||||
methods>> dup assoc-empty?
|
||||
[ drop default get ] [ values first engine>quot ] if
|
||||
] [
|
||||
[
|
||||
picker %
|
||||
[ tuple-layout-superclasses ] %
|
||||
[ n>> array-nth% ]
|
||||
[
|
||||
methods>> [
|
||||
<trivial-tuple-dispatch-engine> engine>quot
|
||||
] [
|
||||
class-hash-dispatch-quot
|
||||
] if-small? %
|
||||
] bi
|
||||
] [ ] make
|
||||
] if ;
|
||||
|
||||
: >=-case-quot ( alist -- quot )
|
||||
default get [ drop ] prepend swap
|
||||
[ >r [ dupd fixnum>= ] curry r> \ drop prefix ] assoc-map
|
||||
alist>quot ;
|
||||
|
||||
: tuple-layout-echelon ( obj -- array )
|
||||
{ tuple } declare
|
||||
1 slot { tuple-layout } declare
|
||||
5 slot ; inline
|
||||
|
||||
: unclip-last [ 1 head* ] [ peek ] bi ;
|
||||
|
||||
M: tuple-dispatch-engine engine>quot
|
||||
#! 1 slot == tuple-layout
|
||||
#! 5 slot == layout-echelon
|
||||
[
|
||||
picker %
|
||||
[ 1 slot 5 slot ] %
|
||||
echelons>>
|
||||
[ tuple-layout-echelon ] %
|
||||
[
|
||||
tuple assumed set
|
||||
[ engine>quot dup default set ] assoc-map
|
||||
echelons>> dup empty? [
|
||||
unclip-last
|
||||
[
|
||||
[
|
||||
engine>quot define-engine-word
|
||||
[ remember-engine ] [ 1quotation ] bi
|
||||
dup default set
|
||||
] assoc-map
|
||||
]
|
||||
[ first2 engine>quot 2array ] bi*
|
||||
suffix
|
||||
] unless
|
||||
] with-scope
|
||||
>=-case-quot %
|
||||
] [ ] make ;
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@ USING: tools.test math math.functions math.constants
|
|||
generic.standard strings sequences arrays kernel accessors
|
||||
words float-arrays byte-arrays bit-arrays parser namespaces
|
||||
quotations inference vectors growable hashtables sbufs
|
||||
prettyprint ;
|
||||
prettyprint byte-vectors bit-vectors float-vectors ;
|
||||
|
||||
GENERIC: lo-tag-test
|
||||
|
||||
|
|
@ -251,6 +251,14 @@ HOOK: my-tuple-hook my-var ( -- x )
|
|||
|
||||
M: sequence my-tuple-hook my-hook ;
|
||||
|
||||
TUPLE: m-t-h-a ;
|
||||
|
||||
M: m-t-h-a my-tuple-hook "foo" ;
|
||||
|
||||
TUPLE: m-t-h-b < m-t-h-a ;
|
||||
|
||||
M: m-t-h-b my-tuple-hook "bar" ;
|
||||
|
||||
[ f ] [
|
||||
\ my-tuple-hook [ "engines" word-prop ] keep prefix
|
||||
[ 1quotation infer ] map all-equal?
|
||||
|
|
|
|||
|
|
@ -48,10 +48,6 @@ HELP: no-effect
|
|||
{ $description "Throws a " { $link no-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: collect-recursion
|
||||
{ $values { "#label" "a " { $link #label } " node" } { "seq" "a new sequence" } }
|
||||
{ $description "Collect the input stacks of all child " { $link #call-label } " nodes that call the given label." } ;
|
||||
|
||||
HELP: inline-word
|
||||
{ $values { "word" word } }
|
||||
{ $description "Called during inference to infer stack effects of inline words."
|
||||
|
|
|
|||
|
|
@ -15,7 +15,7 @@ GENERIC: inline? ( word -- ? )
|
|||
M: method-body inline?
|
||||
"method-generic" word-prop inline? ;
|
||||
|
||||
M: tuple-dispatch-engine-word inline?
|
||||
M: engine-word inline?
|
||||
"tuple-dispatch-generic" word-prop inline? ;
|
||||
|
||||
M: word inline?
|
||||
|
|
@ -130,25 +130,27 @@ TUPLE: too-many->r ;
|
|||
|
||||
TUPLE: too-many-r> ;
|
||||
|
||||
: check-r> ( -- )
|
||||
meta-r get empty?
|
||||
: check-r> ( n -- )
|
||||
meta-r get length >
|
||||
[ \ too-many-r> inference-error ] when ;
|
||||
|
||||
: infer->r ( -- )
|
||||
1 ensure-values
|
||||
: infer->r ( n -- )
|
||||
dup ensure-values
|
||||
#>r
|
||||
1 0 pick node-inputs
|
||||
pop-d push-r
|
||||
0 1 pick node-outputs
|
||||
node, ;
|
||||
over 0 pick node-inputs
|
||||
over [ drop pop-d ] map reverse [ push-r ] each
|
||||
0 pick pick node-outputs
|
||||
node,
|
||||
drop ;
|
||||
|
||||
: infer-r> ( -- )
|
||||
check-r>
|
||||
: infer-r> ( n -- )
|
||||
dup check-r>
|
||||
#r>
|
||||
0 1 pick node-inputs
|
||||
pop-r push-d
|
||||
1 0 pick node-outputs
|
||||
node, ;
|
||||
0 pick pick node-inputs
|
||||
over [ drop pop-r ] map reverse [ push-d ] each
|
||||
over 0 pick node-outputs
|
||||
node,
|
||||
drop ;
|
||||
|
||||
: undo-infer ( -- )
|
||||
recorded get [ f "inferred-effect" set-word-prop ] each ;
|
||||
|
|
@ -199,18 +201,18 @@ M: object constructor drop f ;
|
|||
dup infer-uncurry
|
||||
constructor [
|
||||
peek-d reify-curry
|
||||
infer->r
|
||||
1 infer->r
|
||||
peek-d reify-curry
|
||||
infer-r>
|
||||
1 infer-r>
|
||||
2 1 <effect> swap #call consume/produce
|
||||
] when* ;
|
||||
|
||||
: reify-curries ( n -- )
|
||||
meta-d get reverse [
|
||||
dup special? [
|
||||
over [ infer->r ] times
|
||||
over infer->r
|
||||
dup reify-curry
|
||||
over [ infer-r> ] times
|
||||
over infer-r>
|
||||
] when 2drop
|
||||
] 2each ;
|
||||
|
||||
|
|
@ -407,6 +409,25 @@ TUPLE: recursive-declare-error word ;
|
|||
\ recursive-declare-error 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 )
|
||||
|
|
@ -417,27 +438,17 @@ TUPLE: recursive-declare-error word ;
|
|||
|
||||
: <inlined-block> gensym dup t "inlined-block" set-word-prop ;
|
||||
|
||||
: inline-block ( word -- node-block data )
|
||||
: inline-block ( word -- #label data )
|
||||
[
|
||||
copy-inference nest-node
|
||||
dup word-def swap <inlined-block>
|
||||
[ infer-quot-recursive ] 2keep
|
||||
#label unnest-node
|
||||
dup collect-label-info
|
||||
] H{ } make-assoc ;
|
||||
|
||||
GENERIC: collect-recursion* ( label node -- )
|
||||
|
||||
M: node collect-recursion* 2drop ;
|
||||
|
||||
M: #call-label collect-recursion*
|
||||
tuck node-param eq? [ , ] [ drop ] if ;
|
||||
|
||||
: collect-recursion ( #label -- seq )
|
||||
dup node-param
|
||||
[ [ swap collect-recursion* ] curry each-node ] { } make ;
|
||||
|
||||
: join-values ( node -- )
|
||||
collect-recursion [ node-in-d ] map meta-d get suffix
|
||||
: join-values ( #label -- )
|
||||
calls>> [ node-in-d ] map meta-d get suffix
|
||||
unify-lengths unify-stacks
|
||||
meta-d [ length tail* ] change ;
|
||||
|
||||
|
|
@ -458,7 +469,7 @@ M: #call-label collect-recursion*
|
|||
drop join-values inline-block apply-infer
|
||||
r> over set-node-in-d
|
||||
dup node,
|
||||
collect-recursion [
|
||||
calls>> [
|
||||
[ flatten-curries ] modify-values
|
||||
] each
|
||||
] [
|
||||
|
|
|
|||
|
|
@ -4,7 +4,12 @@ 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 ;
|
||||
system layouts vectors optimizer.math.partial accessors
|
||||
optimizer.inlining ;
|
||||
|
||||
[ 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
|
||||
|
|
@ -13,9 +18,15 @@ system layouts vectors ;
|
|||
! Ensure type inference works as it is supposed to by checking
|
||||
! if various methods get inlined
|
||||
|
||||
: inlined? ( quot word -- ? )
|
||||
: inlined? ( quot seq/word -- ? )
|
||||
dup word? [ 1array ] when
|
||||
swap dataflow optimize
|
||||
[ node-param eq? ] with node-exists? not ;
|
||||
[ node-param swap member? ] with node-exists? not ;
|
||||
|
||||
[ f ] [
|
||||
[ { integer } declare >fixnum ]
|
||||
\ >fixnum inlined?
|
||||
] unit-test
|
||||
|
||||
GENERIC: mynot ( x -- y )
|
||||
|
||||
|
|
@ -109,12 +120,17 @@ M: object xyz ;
|
|||
[ { fixnum } declare [ ] times ] \ fixnum+ inlined?
|
||||
] unit-test
|
||||
|
||||
[ f ] [
|
||||
[ t ] [
|
||||
[ { integer fixnum } declare dupd < [ 1 + ] when ]
|
||||
\ + inlined?
|
||||
] unit-test
|
||||
|
||||
[ f ] [ [ dup 0 < [ neg ] when ] \ neg inlined? ] unit-test
|
||||
[ f ] [
|
||||
[ { integer fixnum } declare dupd < [ 1 + ] when ]
|
||||
\ +-integer-fixnum inlined?
|
||||
] unit-test
|
||||
|
||||
[ f ] [ [ dup 0 < [ neg ] when ] \ - inlined? ] unit-test
|
||||
|
||||
[ f ] [
|
||||
[
|
||||
|
|
@ -137,13 +153,13 @@ M: object xyz ;
|
|||
|
||||
DEFER: blah
|
||||
|
||||
[ t ] [
|
||||
[ ] [
|
||||
[
|
||||
\ blah
|
||||
[ dup V{ } eq? [ foo ] when ] dup second dup push define
|
||||
] with-compilation-unit
|
||||
|
||||
\ blah compiled?
|
||||
\ blah word-def dataflow optimize drop
|
||||
] unit-test
|
||||
|
||||
GENERIC: detect-fx ( n -- n )
|
||||
|
|
@ -158,14 +174,20 @@ M: fixnum detect-fx ;
|
|||
] \ detect-fx inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[
|
||||
1000000000000000000000000000000000 [ ] times
|
||||
] \ + inlined?
|
||||
] unit-test
|
||||
[ f ] [
|
||||
[
|
||||
1000000000000000000000000000000000 [ ] times
|
||||
] \ 1+ inlined?
|
||||
] \ +-integer-fixnum inlined?
|
||||
] unit-test
|
||||
|
||||
[ f ] [
|
||||
[ { bignum } declare [ ] times ] \ 1+ inlined?
|
||||
[ { bignum } declare [ ] times ]
|
||||
\ +-integer-fixnum inlined?
|
||||
] unit-test
|
||||
|
||||
|
||||
|
|
@ -251,19 +273,24 @@ M: float detect-float ;
|
|||
[ 3 + = ] \ equal? inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ f ] [
|
||||
[ { fixnum fixnum } declare 7 bitand neg shift ]
|
||||
\ shift inlined?
|
||||
\ fixnum-shift-fast inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ { fixnum fixnum } declare 7 bitand neg shift ]
|
||||
\ fixnum-shift inlined?
|
||||
{ shift fixnum-shift } inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ { fixnum fixnum } declare 1 swap 7 bitand shift ]
|
||||
\ fixnum-shift inlined?
|
||||
{ shift fixnum-shift } inlined?
|
||||
] unit-test
|
||||
|
||||
[ f ] [
|
||||
[ { fixnum fixnum } declare 1 swap 7 bitand shift ]
|
||||
{ fixnum-shift-fast } inlined?
|
||||
] unit-test
|
||||
|
||||
cell-bits 32 = [
|
||||
|
|
@ -278,6 +305,11 @@ cell-bits 32 = [
|
|||
] unit-test
|
||||
] when
|
||||
|
||||
[ f ] [
|
||||
[ { integer } declare -63 shift 4095 bitand ]
|
||||
\ shift inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ B{ 1 0 } *short 0 number= ]
|
||||
\ number= inlined?
|
||||
|
|
@ -323,3 +355,228 @@ cell-bits 32 = [
|
|||
] 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
|
||||
|
||||
! Later
|
||||
|
||||
! [ t ] [
|
||||
! [
|
||||
! { integer } declare [ 256 mod ] map
|
||||
! ] { mod fixnum-mod } inlined?
|
||||
! ] unit-test
|
||||
!
|
||||
! [ t ] [
|
||||
! [
|
||||
! { integer } declare [ 0 >= ] map
|
||||
! ] { >= fixnum>= } inlined?
|
||||
! ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,9 +1,9 @@
|
|||
! Copyright (C) 2004, 2007 Slava Pestov.
|
||||
! 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 ;
|
||||
inference.backend combinators accessors ;
|
||||
IN: inference.class
|
||||
|
||||
! Class inference
|
||||
|
|
@ -25,12 +25,10 @@ C: <literal-constraint> literal-constraint
|
|||
|
||||
M: literal-constraint equal?
|
||||
over literal-constraint? [
|
||||
2dup
|
||||
[ literal-constraint-literal ] bi@ eql? >r
|
||||
[ literal-constraint-value ] bi@ = r> and
|
||||
] [
|
||||
2drop f
|
||||
] if ;
|
||||
[ [ literal>> ] bi@ eql? ]
|
||||
[ [ value>> ] bi@ = ]
|
||||
2bi and
|
||||
] [ 2drop f ] if ;
|
||||
|
||||
TUPLE: class-constraint class value ;
|
||||
|
||||
|
|
@ -43,8 +41,8 @@ C: <interval-constraint> interval-constraint
|
|||
GENERIC: apply-constraint ( constraint -- )
|
||||
GENERIC: constraint-satisfied? ( constraint -- ? )
|
||||
|
||||
: `input node get node-in-d nth ;
|
||||
: `output node get node-out-d nth ;
|
||||
: `input node get in-d>> nth ;
|
||||
: `output node get out-d>> nth ;
|
||||
: class, <class-constraint> , ;
|
||||
: literal, <literal-constraint> , ;
|
||||
: interval, <interval-constraint> , ;
|
||||
|
|
@ -84,14 +82,12 @@ SYMBOL: value-classes
|
|||
set-value-interval* ;
|
||||
|
||||
M: interval-constraint apply-constraint
|
||||
dup interval-constraint-interval
|
||||
swap interval-constraint-value intersect-value-interval ;
|
||||
[ interval>> ] [ value>> ] bi intersect-value-interval ;
|
||||
|
||||
: set-class-interval ( class value -- )
|
||||
over class? [
|
||||
over "interval" word-prop [
|
||||
>r "interval" word-prop r> set-value-interval*
|
||||
] [ 2drop ] if
|
||||
>r "interval" word-prop r> over
|
||||
[ set-value-interval* ] [ 2drop ] if
|
||||
] [ 2drop ] if ;
|
||||
|
||||
: value-class* ( value -- class )
|
||||
|
|
@ -110,18 +106,21 @@ M: interval-constraint apply-constraint
|
|||
[ value-class* class-and ] keep set-value-class* ;
|
||||
|
||||
M: class-constraint apply-constraint
|
||||
dup class-constraint-class
|
||||
swap class-constraint-value intersect-value-class ;
|
||||
[ class>> ] [ value>> ] bi intersect-value-class ;
|
||||
|
||||
: literal-interval ( value -- interval/f )
|
||||
dup real? [ [a,a] ] [ drop f ] if ;
|
||||
|
||||
: set-value-literal* ( literal value -- )
|
||||
over class over set-value-class*
|
||||
over real? [ over [a,a] over set-value-interval* ] when
|
||||
2dup <literal-constraint> assume
|
||||
value-literals get set-at ;
|
||||
{
|
||||
[ >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
|
||||
dup literal-constraint-literal
|
||||
swap literal-constraint-value set-value-literal* ;
|
||||
[ literal>> ] [ value>> ] bi set-value-literal* ;
|
||||
|
||||
! For conditionals, an assoc of child node # --> constraint
|
||||
GENERIC: child-constraints ( node -- seq )
|
||||
|
|
@ -133,19 +132,18 @@ GENERIC: infer-classes-around ( node -- )
|
|||
M: node infer-classes-before drop ;
|
||||
|
||||
M: node child-constraints
|
||||
node-children length
|
||||
children>> length
|
||||
dup zero? [ drop f ] [ f <repetition> ] if ;
|
||||
|
||||
: value-literal* ( value -- obj ? )
|
||||
value-literals get at* ;
|
||||
|
||||
M: literal-constraint constraint-satisfied?
|
||||
dup literal-constraint-value value-literal*
|
||||
[ swap literal-constraint-literal eql? ] [ 2drop f ] if ;
|
||||
dup value>> value-literal*
|
||||
[ swap literal>> eql? ] [ 2drop f ] if ;
|
||||
|
||||
M: class-constraint constraint-satisfied?
|
||||
dup class-constraint-value value-class*
|
||||
swap class-constraint-class class< ;
|
||||
[ value>> value-class* ] [ class>> ] bi class< ;
|
||||
|
||||
M: pair apply-constraint
|
||||
first2 2dup constraints get set-at
|
||||
|
|
@ -154,19 +152,18 @@ M: pair apply-constraint
|
|||
M: pair constraint-satisfied?
|
||||
first constraint-satisfied? ;
|
||||
|
||||
: extract-keys ( assoc seq -- newassoc )
|
||||
dup length <hashtable> swap [
|
||||
dup >r pick at* [ r> pick set-at ] [ r> 2drop ] if
|
||||
] each nip f assoc-like ;
|
||||
: extract-keys ( seq assoc -- newassoc )
|
||||
[ dupd at ] curry H{ } map>assoc [ nip ] assoc-subset f assoc-like ;
|
||||
|
||||
: annotate-node ( node -- )
|
||||
#! Annotate the node with the currently-inferred set of
|
||||
#! value classes.
|
||||
dup node-values
|
||||
value-intervals get over extract-keys pick set-node-intervals
|
||||
value-classes get over extract-keys pick set-node-classes
|
||||
value-literals get over extract-keys pick set-node-literals
|
||||
2drop ;
|
||||
dup node-values {
|
||||
[ value-intervals get extract-keys >>intervals ]
|
||||
[ value-classes get extract-keys >>classes ]
|
||||
[ value-literals get extract-keys >>literals ]
|
||||
[ 2drop ]
|
||||
} cleave ;
|
||||
|
||||
: intersect-classes ( classes values -- )
|
||||
[ intersect-value-class ] 2each ;
|
||||
|
|
@ -190,31 +187,29 @@ M: pair constraint-satisfied?
|
|||
] 2bi ;
|
||||
|
||||
: compute-constraints ( #call -- )
|
||||
dup node-param "constraints" word-prop [
|
||||
dup param>> "constraints" word-prop [
|
||||
call
|
||||
] [
|
||||
dup node-param "predicating" word-prop dup
|
||||
dup param>> "predicating" word-prop dup
|
||||
[ swap predicate-constraints ] [ 2drop ] if
|
||||
] if* ;
|
||||
|
||||
: compute-output-classes ( node word -- classes intervals )
|
||||
dup node-param "output-classes" word-prop
|
||||
dup param>> "output-classes" word-prop
|
||||
dup [ call ] [ 2drop f f ] if ;
|
||||
|
||||
: output-classes ( node -- classes intervals )
|
||||
dup compute-output-classes >r
|
||||
[ ] [ node-param "default-output-classes" word-prop ] ?if
|
||||
[ ] [ param>> "default-output-classes" word-prop ] ?if
|
||||
r> ;
|
||||
|
||||
M: #call infer-classes-before
|
||||
dup compute-constraints
|
||||
dup node-out-d swap output-classes
|
||||
>r over intersect-classes
|
||||
r> swap intersect-intervals ;
|
||||
[ compute-constraints ] keep
|
||||
[ output-classes ] [ out-d>> ] bi
|
||||
tuck [ intersect-classes ] [ intersect-intervals ] 2bi* ;
|
||||
|
||||
M: #push infer-classes-before
|
||||
node-out-d
|
||||
[ [ value-literal ] keep set-value-literal* ] each ;
|
||||
out-d>> [ [ value-literal ] keep set-value-literal* ] each ;
|
||||
|
||||
M: #if child-constraints
|
||||
[
|
||||
|
|
@ -224,19 +219,17 @@ M: #if child-constraints
|
|||
|
||||
M: #dispatch child-constraints
|
||||
dup [
|
||||
node-children length [
|
||||
0 `input literal,
|
||||
] each
|
||||
children>> length [ 0 `input literal, ] each
|
||||
] make-constraints ;
|
||||
|
||||
M: #declare infer-classes-before
|
||||
dup node-param swap node-in-d
|
||||
[ param>> ] [ in-d>> ] bi
|
||||
[ intersect-value-class ] 2each ;
|
||||
|
||||
DEFER: (infer-classes)
|
||||
|
||||
: infer-children ( node -- )
|
||||
dup node-children swap child-constraints [
|
||||
[ children>> ] [ child-constraints ] bi [
|
||||
[
|
||||
value-classes [ clone ] change
|
||||
value-literals [ clone ] change
|
||||
|
|
@ -251,27 +244,27 @@ DEFER: (infer-classes)
|
|||
>r dup [ length ] map supremum r> [ pad-left ] 2curry map ;
|
||||
|
||||
: (merge-classes) ( nodes -- seq )
|
||||
[ node-input-classes ] map
|
||||
null pad-all flip [ null [ class-or ] reduce ] map ;
|
||||
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 -- )
|
||||
node-out-d [ set-value-class* ] 2reverse-each ;
|
||||
out-d>> [ set-value-class* ] 2reverse-each ;
|
||||
|
||||
: merge-classes ( nodes node -- )
|
||||
>r (merge-classes) r> set-classes ;
|
||||
|
||||
: (merge-intervals) ( nodes quot -- seq )
|
||||
>r
|
||||
[ node-input-intervals ] map
|
||||
f pad-all flip
|
||||
r> map ; inline
|
||||
|
||||
: set-intervals ( seq node -- )
|
||||
node-out-d [ set-value-interval* ] 2reverse-each ;
|
||||
out-d>> [ set-value-interval* ] 2reverse-each ;
|
||||
|
||||
: merge-intervals ( nodes node -- )
|
||||
>r [ dup first [ interval-union ] reduce ]
|
||||
(merge-intervals) r> set-intervals ;
|
||||
>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 ;
|
||||
|
|
@ -280,28 +273,68 @@ DEFER: (infer-classes)
|
|||
dup node-successor dup #merge? [
|
||||
swap active-children dup empty?
|
||||
[ 2drop ] [ swap annotate-merge ] if
|
||||
] [
|
||||
2drop
|
||||
] if ;
|
||||
] [ 2drop ] if ;
|
||||
|
||||
: classes= ( inferred current -- ? )
|
||||
2dup min-length [ tail* ] curry bi@ sequence= ;
|
||||
|
||||
SYMBOL: fixed-point?
|
||||
|
||||
SYMBOL: nested-labels
|
||||
|
||||
: annotate-entry ( nodes #label -- )
|
||||
node-child merge-classes ;
|
||||
>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 -- )
|
||||
#! First, infer types under the hypothesis which hold on
|
||||
#! entry to the recursive label.
|
||||
[ 1array ] keep annotate-entry ;
|
||||
[ 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.
|
||||
{
|
||||
[ annotate-node ]
|
||||
[ infer-classes-before ]
|
||||
[ infer-children ]
|
||||
[ [ collect-recursion ] [ suffix ] [ annotate-entry ] tri ]
|
||||
[ node-child (infer-classes) ]
|
||||
} cleave ;
|
||||
[
|
||||
{
|
||||
[ 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 extract-keys ] keep
|
||||
set-node-classes
|
||||
] [ drop ] if
|
||||
] [ call-next-method ] if
|
||||
] [ call-next-method ] if ;
|
||||
|
||||
M: object infer-classes-around
|
||||
{
|
||||
|
|
@ -314,11 +347,13 @@ M: object infer-classes-around
|
|||
: (infer-classes) ( node -- )
|
||||
[
|
||||
[ infer-classes-around ]
|
||||
[ node-successor (infer-classes) ] bi
|
||||
[ 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
|
||||
|
|
@ -326,13 +361,11 @@ M: object infer-classes-around
|
|||
(infer-classes)
|
||||
] with-scope ;
|
||||
|
||||
: infer-classes ( node -- )
|
||||
f f f infer-classes-with ;
|
||||
: 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.
|
||||
dup node-classes
|
||||
over node-literals
|
||||
rot node-intervals
|
||||
[ classes>> ] [ literals>> ] [ intervals>> ] tri
|
||||
infer-classes-with ;
|
||||
|
|
|
|||
|
|
@ -90,7 +90,7 @@ M: object flatten-curry , ;
|
|||
|
||||
: node-child node-children first ;
|
||||
|
||||
TUPLE: #label < node word loop? ;
|
||||
TUPLE: #label < node word loop? returns calls ;
|
||||
|
||||
: #label ( word label -- node )
|
||||
\ #label param-node swap >>word ;
|
||||
|
|
@ -290,6 +290,9 @@ SYMBOL: node-stack
|
|||
: 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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -54,9 +54,9 @@ IN: inference.known-words
|
|||
{ swap T{ effect f 2 { 1 0 } } }
|
||||
} [ define-shuffle ] assoc-each
|
||||
|
||||
\ >r [ infer->r ] "infer" set-word-prop
|
||||
\ >r [ 1 infer->r ] "infer" set-word-prop
|
||||
|
||||
\ r> [ infer-r> ] "infer" set-word-prop
|
||||
\ r> [ 1 infer-r> ] "infer" set-word-prop
|
||||
|
||||
\ declare [
|
||||
1 ensure-values
|
||||
|
|
@ -81,8 +81,8 @@ M: curried infer-call
|
|||
|
||||
M: composed infer-call
|
||||
infer-uncurry
|
||||
infer->r peek-d infer-call
|
||||
terminated? get [ infer-r> peek-d infer-call ] unless ;
|
||||
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 ;
|
||||
|
|
@ -92,6 +92,8 @@ M: object infer-call
|
|||
peek-d infer-call
|
||||
] "infer" set-word-prop
|
||||
|
||||
\ call t "no-compile" set-word-prop
|
||||
|
||||
\ execute [
|
||||
1 ensure-values
|
||||
pop-literal nip
|
||||
|
|
@ -471,18 +473,6 @@ set-primitive-effect
|
|||
|
||||
\ set-alien-cell { c-ptr c-ptr integer } { } <effect> set-primitive-effect
|
||||
|
||||
\ alien>char-string { c-ptr } { string } <effect> set-primitive-effect
|
||||
\ alien>char-string make-flushable
|
||||
|
||||
\ string>char-alien { string } { byte-array } <effect> set-primitive-effect
|
||||
\ string>char-alien make-flushable
|
||||
|
||||
\ alien>u16-string { c-ptr } { string } <effect> set-primitive-effect
|
||||
\ alien>u16-string make-flushable
|
||||
|
||||
\ string>u16-alien { string } { byte-array } <effect> set-primitive-effect
|
||||
\ string>u16-alien make-flushable
|
||||
|
||||
\ alien-address { alien } { integer } <effect> set-primitive-effect
|
||||
\ alien-address make-flushable
|
||||
|
||||
|
|
|
|||
|
|
@ -41,12 +41,13 @@ $low-level-note ;
|
|||
|
||||
ARTICLE: "encodings-descriptors" "Encoding descriptors"
|
||||
"An encoding descriptor is something which can be used for input or output streams to encode or decode files. It must conform to the " { $link "encodings-protocol" } ". Encodings which you can use are defined in the following vocabularies:"
|
||||
{ $vocab-subsection "ASCII" "io.encodings.ascii" }
|
||||
{ $vocab-subsection "Binary" "io.encodings.binary" }
|
||||
{ $subsection "io.encodings.binary" }
|
||||
{ $subsection "io.encodings.utf8" }
|
||||
{ $subsection "io.encodings.utf16" }
|
||||
{ $vocab-subsection "Strict encodings" "io.encodings.strict" }
|
||||
"Legacy encodings:"
|
||||
{ $vocab-subsection "8-bit encodings" "io.encodings.8-bit" }
|
||||
{ $vocab-subsection "UTF-8" "io.encodings.utf8" }
|
||||
{ $vocab-subsection "UTF-16" "io.encodings.utf16" }
|
||||
{ $vocab-subsection "ASCII" "io.encodings.ascii" }
|
||||
{ $see-also "encodings-introduction" } ;
|
||||
|
||||
ARTICLE: "encodings-protocol" "Encoding protocol"
|
||||
|
|
|
|||
|
|
@ -5,8 +5,7 @@ ARTICLE: "io.encodings.utf16" "UTF-16"
|
|||
"The UTF-16 encoding is a variable-width encoding. Unicode code points are encoded as 2 or 4 byte sequences. There are three encoding descriptor classes for working with UTF-16, depending on endianness or the presence of a BOM:"
|
||||
{ $subsection utf16 }
|
||||
{ $subsection utf16le }
|
||||
{ $subsection utf16be }
|
||||
{ $subsection utf16n } ;
|
||||
{ $subsection utf16be } ;
|
||||
|
||||
ABOUT: "io.encodings.utf16"
|
||||
|
||||
|
|
@ -22,8 +21,4 @@ HELP: utf16
|
|||
{ $class-description "The encoding descriptor for UTF-16, that is, UTF-16 with a byte order mark. This is the most useful for general input and output in UTF-16. Streams can be made which read or write wth this encoding." }
|
||||
{ $see-also "encodings-introduction" } ;
|
||||
|
||||
HELP: utf16n
|
||||
{ $class-description "The encoding descriptor for UTF-16 without a byte order mark in native endian order. This is useful mostly for FFI calls which take input of strings of the type wchar_t*" }
|
||||
{ $see-also "encodings-introduction" } ;
|
||||
|
||||
{ utf16 utf16le utf16be utf16n } related-words
|
||||
{ utf16 utf16le utf16be } related-words
|
||||
|
|
@ -1,6 +1,6 @@
|
|||
USING: kernel tools.test io.encodings.utf16 arrays sbufs
|
||||
io.streams.byte-array sequences io.encodings io unicode
|
||||
io.encodings.string alien.c-types accessors classes ;
|
||||
io.encodings.string alien.c-types alien.strings accessors classes ;
|
||||
IN: io.encodings.utf16.tests
|
||||
|
||||
[ { CHAR: x } ] [ { 0 CHAR: x } utf16be decode >array ] unit-test
|
||||
|
|
@ -1,8 +1,7 @@
|
|||
! Copyright (C) 2006, 2008 Daniel Ehrenberg.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: math kernel sequences sbufs vectors namespaces io.binary
|
||||
io.encodings combinators splitting io byte-arrays inspector
|
||||
alien.c-types ;
|
||||
io.encodings combinators splitting io byte-arrays inspector ;
|
||||
IN: io.encodings.utf16
|
||||
|
||||
TUPLE: utf16be ;
|
||||
|
|
@ -11,8 +10,6 @@ TUPLE: utf16le ;
|
|||
|
||||
TUPLE: utf16 ;
|
||||
|
||||
TUPLE: utf16n ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
! UTF-16BE decoding
|
||||
|
|
@ -124,13 +121,4 @@ M: utf16 <decoder> ( stream utf16 -- decoder )
|
|||
M: utf16 <encoder> ( stream utf16 -- encoder )
|
||||
drop bom-le over stream-write utf16le <encoder> ;
|
||||
|
||||
! Native-order UTF-16
|
||||
|
||||
: native-utf16 ( -- descriptor )
|
||||
little-endian? utf16le utf16be ? ;
|
||||
|
||||
M: utf16n <decoder> drop native-utf16 <decoder> ;
|
||||
|
||||
M: utf16n <encoder> drop native-utf16 <encoder> ;
|
||||
|
||||
PRIVATE>
|
||||
|
|
@ -0,0 +1,13 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel accessors alien.accessors math io ;
|
||||
IN: io.streams.memory
|
||||
|
||||
TUPLE: memory-stream alien index ;
|
||||
|
||||
: <memory-stream> ( alien -- stream )
|
||||
0 memory-stream boa ;
|
||||
|
||||
M: memory-stream stream-read1
|
||||
[ [ alien>> ] [ index>> ] bi alien-unsigned-1 ]
|
||||
[ [ 1+ ] change-index drop ] bi ;
|
||||
|
|
@ -184,3 +184,10 @@ unit-test
|
|||
[ HEX: 988a259c3433f237 ] [
|
||||
B{ HEX: 37 HEX: f2 HEX: 33 HEX: 34 HEX: 9c HEX: 25 HEX: 8a HEX: 98 } byte-array>bignum
|
||||
] unit-test
|
||||
|
||||
[ t ] [ 256 power-of-2? ] unit-test
|
||||
[ f ] [ 123 power-of-2? ] unit-test
|
||||
|
||||
[ f ] [ -128 power-of-2? ] unit-test
|
||||
[ f ] [ 0 power-of-2? ] unit-test
|
||||
[ t ] [ 1 power-of-2? ] unit-test
|
||||
|
|
|
|||
|
|
@ -96,6 +96,8 @@ C: <interval> interval
|
|||
|
||||
: interval-bitnot ( i1 -- i2 ) interval-neg interval-1- ;
|
||||
|
||||
: interval-sq ( i1 -- i2 ) dup interval* ;
|
||||
|
||||
: make-interval ( from to -- int )
|
||||
over first over first {
|
||||
{ [ 2dup > ] [ 2drop 2drop f ] }
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
USING: help.markup help.syntax kernel sequences quotations
|
||||
math.private math.functions ;
|
||||
math.private ;
|
||||
IN: math
|
||||
|
||||
ARTICLE: "division-by-zero" "Division by zero"
|
||||
|
|
@ -26,17 +26,13 @@ $nl
|
|||
{ $subsection < }
|
||||
{ $subsection <= }
|
||||
{ $subsection > }
|
||||
{ $subsection >= }
|
||||
"Inexact comparison:"
|
||||
{ $subsection ~ } ;
|
||||
{ $subsection >= } ;
|
||||
|
||||
ARTICLE: "modular-arithmetic" "Modular arithmetic"
|
||||
{ $subsection mod }
|
||||
{ $subsection rem }
|
||||
{ $subsection /mod }
|
||||
{ $subsection /i }
|
||||
{ $subsection mod-inv }
|
||||
{ $subsection ^mod }
|
||||
{ $see-also "integer-functions" } ;
|
||||
|
||||
ARTICLE: "bitwise-arithmetic" "Bitwise arithmetic"
|
||||
|
|
@ -363,6 +359,10 @@ HELP: next-power-of-2
|
|||
{ $values { "m" "a non-negative integer" } { "n" "an integer" } }
|
||||
{ $description "Outputs the smallest power of 2 greater than " { $snippet "m" } ". The output value is always at least 1." } ;
|
||||
|
||||
HELP: power-of-2?
|
||||
{ $values { "n" integer } { "?" "a boolean" } }
|
||||
{ $description "Tests if " { $snippet "n" } " is a power of 2." } ;
|
||||
|
||||
HELP: each-integer
|
||||
{ $values { "n" integer } { "quot" "a quotation with stack effect " { $snippet "( i -- )" } } }
|
||||
{ $description "Applies the quotation to each integer from 0 up to " { $snippet "n" } ", excluding " { $snippet "n" } "." }
|
||||
|
|
|
|||
|
|
@ -55,26 +55,26 @@ GENERIC: zero? ( x -- ? ) foldable
|
|||
|
||||
M: object zero? drop f ;
|
||||
|
||||
: 1+ ( x -- y ) 1 + ; foldable
|
||||
: 1- ( x -- y ) 1 - ; foldable
|
||||
: 2/ ( x -- y ) -1 shift ; foldable
|
||||
: sq ( x -- y ) dup * ; foldable
|
||||
: neg ( x -- -x ) 0 swap - ; foldable
|
||||
: recip ( x -- y ) 1 swap / ; foldable
|
||||
: 1+ ( x -- y ) 1 + ; inline
|
||||
: 1- ( x -- y ) 1 - ; inline
|
||||
: 2/ ( x -- y ) -1 shift ; inline
|
||||
: sq ( x -- y ) dup * ; inline
|
||||
: neg ( x -- -x ) 0 swap - ; inline
|
||||
: recip ( x -- y ) 1 swap / ; inline
|
||||
|
||||
: ?1+ [ 1+ ] [ 0 ] if* ; inline
|
||||
|
||||
: /f ( x y -- z ) >r >float r> >float float/f ; inline
|
||||
|
||||
: max ( x y -- z ) [ > ] most ; foldable
|
||||
: min ( x y -- z ) [ < ] most ; foldable
|
||||
: max ( x y -- z ) [ > ] most ; inline
|
||||
: min ( x y -- z ) [ < ] most ; inline
|
||||
|
||||
: between? ( x y z -- ? )
|
||||
pick >= [ >= ] [ 2drop f ] if ; inline
|
||||
|
||||
: rem ( x y -- z ) tuck mod over + swap mod ; foldable
|
||||
|
||||
: sgn ( x -- n ) dup 0 < -1 0 ? swap 0 > 1 0 ? bitor ; foldable
|
||||
: sgn ( x -- n ) dup 0 < [ drop -1 ] [ 0 > 1 0 ? ] if ; inline
|
||||
|
||||
: [-] ( x y -- z ) - 0 max ; inline
|
||||
|
||||
|
|
@ -121,7 +121,11 @@ M: float fp-nan?
|
|||
|
||||
: next-power-of-2 ( m -- n ) 2 swap (next-power-of-2) ; foldable
|
||||
|
||||
: align ( m w -- n ) 1- [ + ] keep bitnot bitand ; inline
|
||||
: power-of-2? ( n -- ? )
|
||||
dup 0 <= [ drop f ] [ dup 1- bitand zero? ] if ; foldable
|
||||
|
||||
: align ( m w -- n )
|
||||
1- [ + ] keep bitnot bitand ; inline
|
||||
|
||||
<PRIVATE
|
||||
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@
|
|||
USING: arrays generic assocs inference inference.class
|
||||
inference.dataflow inference.backend inference.state io kernel
|
||||
math namespaces sequences vectors words quotations hashtables
|
||||
combinators classes optimizer.def-use ;
|
||||
combinators classes optimizer.def-use accessors ;
|
||||
IN: optimizer.backend
|
||||
|
||||
SYMBOL: class-substitutions
|
||||
|
|
@ -16,37 +16,32 @@ SYMBOL: optimizer-changed
|
|||
|
||||
GENERIC: optimize-node* ( node -- node/t changed? )
|
||||
|
||||
: ?union ( assoc/f assoc -- hash )
|
||||
over [ assoc-union ] [ nip ] if ;
|
||||
: ?union ( assoc assoc/f -- assoc' )
|
||||
dup assoc-empty? [ drop ] [ swap assoc-union ] if ;
|
||||
|
||||
: add-node-literals ( assoc node -- )
|
||||
over assoc-empty? [
|
||||
: add-node-literals ( node assoc -- )
|
||||
[ ?union ] curry change-literals drop ;
|
||||
|
||||
: add-node-classes ( node assoc -- )
|
||||
[ ?union ] curry change-classes drop ;
|
||||
|
||||
: substitute-values ( node assoc -- )
|
||||
dup assoc-empty? [
|
||||
2drop
|
||||
] [
|
||||
[ node-literals ?union ] keep set-node-literals
|
||||
] if ;
|
||||
|
||||
: add-node-classes ( assoc node -- )
|
||||
over assoc-empty? [
|
||||
2drop
|
||||
] [
|
||||
[ node-classes ?union ] keep set-node-classes
|
||||
] if ;
|
||||
|
||||
: substitute-values ( assoc node -- )
|
||||
over assoc-empty? [
|
||||
2drop
|
||||
] [
|
||||
2dup node-in-d swap substitute-here
|
||||
2dup node-in-r swap substitute-here
|
||||
2dup node-out-d swap substitute-here
|
||||
node-out-r swap substitute-here
|
||||
{
|
||||
[ >r in-d>> r> substitute-here ]
|
||||
[ >r in-r>> r> substitute-here ]
|
||||
[ >r out-d>> r> substitute-here ]
|
||||
[ >r out-r>> r> substitute-here ]
|
||||
} 2cleave
|
||||
] if ;
|
||||
|
||||
: perform-substitutions ( node -- )
|
||||
class-substitutions get over add-node-classes
|
||||
literal-substitutions get over add-node-literals
|
||||
value-substitutions get swap substitute-values ;
|
||||
[ class-substitutions get add-node-classes ]
|
||||
[ literal-substitutions get add-node-literals ]
|
||||
[ value-substitutions get substitute-values ]
|
||||
tri ;
|
||||
|
||||
DEFER: optimize-nodes
|
||||
|
||||
|
|
@ -90,18 +85,21 @@ M: node optimize-node* drop t f ;
|
|||
#! Not very efficient.
|
||||
dupd union* update ;
|
||||
|
||||
: compute-value-substitutions ( #return/#values #call/#merge -- assoc )
|
||||
node-out-d swap node-in-d 2array unify-lengths flip
|
||||
: compute-value-substitutions ( #call/#merge #return/#values -- assoc )
|
||||
[ out-d>> ] [ in-d>> ] bi* 2array unify-lengths flip
|
||||
[ = not ] assoc-subset >hashtable ;
|
||||
|
||||
: cleanup-inlining ( #return/#values -- newnode changed? )
|
||||
dup node-successor dup [
|
||||
class-substitutions get pick node-classes update
|
||||
literal-substitutions get pick node-literals update
|
||||
tuck compute-value-substitutions value-substitutions get swap update*
|
||||
node-successor t
|
||||
dup node-successor [
|
||||
[ node-successor ] keep
|
||||
{
|
||||
[ nip classes>> class-substitutions get swap update ]
|
||||
[ nip literals>> literal-substitutions get swap update ]
|
||||
[ compute-value-substitutions value-substitutions get swap update* ]
|
||||
[ drop node-successor ]
|
||||
} 2cleave t
|
||||
] [
|
||||
2drop t f
|
||||
drop t f
|
||||
] if ;
|
||||
|
||||
! #return
|
||||
|
|
|
|||
|
|
@ -0,0 +1,10 @@
|
|||
! Copyright (C) 2006, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: inference.dataflow inference.backend kernel ;
|
||||
IN: optimizer
|
||||
|
||||
: collect-label-infos ( node -- node )
|
||||
dup [
|
||||
dup #label? [ collect-label-info ] [ drop ] if
|
||||
] each-node ;
|
||||
|
||||
|
|
@ -27,22 +27,22 @@ optimizer ;
|
|||
dup [ 1+ loop-test-1 ] [ drop ] if ; inline
|
||||
|
||||
[ t ] [
|
||||
[ loop-test-1 ] dataflow dup detect-loops
|
||||
[ loop-test-1 ] dataflow detect-loops
|
||||
\ loop-test-1 label-is-loop?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ loop-test-1 1 2 3 ] dataflow dup detect-loops
|
||||
[ loop-test-1 1 2 3 ] dataflow detect-loops
|
||||
\ loop-test-1 label-is-loop?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ [ loop-test-1 ] each ] dataflow dup detect-loops
|
||||
[ [ loop-test-1 ] each ] dataflow detect-loops
|
||||
\ loop-test-1 label-is-loop?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ [ loop-test-1 ] each ] dataflow dup detect-loops
|
||||
[ [ loop-test-1 ] each ] dataflow detect-loops
|
||||
\ (each-integer) label-is-loop?
|
||||
] unit-test
|
||||
|
||||
|
|
@ -50,7 +50,7 @@ optimizer ;
|
|||
dup [ 1+ loop-test-2 1- ] [ drop ] if ; inline
|
||||
|
||||
[ t ] [
|
||||
[ loop-test-2 ] dataflow dup detect-loops
|
||||
[ loop-test-2 ] dataflow detect-loops
|
||||
\ loop-test-2 label-is-not-loop?
|
||||
] unit-test
|
||||
|
||||
|
|
@ -58,7 +58,7 @@ optimizer ;
|
|||
dup [ [ loop-test-3 ] each ] [ drop ] if ; inline
|
||||
|
||||
[ t ] [
|
||||
[ loop-test-3 ] dataflow dup detect-loops
|
||||
[ loop-test-3 ] dataflow detect-loops
|
||||
\ loop-test-3 label-is-not-loop?
|
||||
] unit-test
|
||||
|
||||
|
|
@ -73,7 +73,7 @@ optimizer ;
|
|||
dup #label? [ node-successor find-label ] unless ;
|
||||
|
||||
: test-loop-exits
|
||||
dataflow dup detect-loops find-label
|
||||
dataflow detect-loops find-label
|
||||
dup node-param swap
|
||||
[ node-child find-tail find-loop-exits [ class ] map ] keep
|
||||
#label-loop? ;
|
||||
|
|
@ -113,7 +113,7 @@ optimizer ;
|
|||
] unit-test
|
||||
|
||||
[ f ] [
|
||||
[ [ [ ] map ] map ] dataflow dup detect-loops
|
||||
[ [ [ ] map ] map ] dataflow detect-loops
|
||||
[ dup #label? swap #loop? not and ] node-exists?
|
||||
] unit-test
|
||||
|
||||
|
|
@ -128,22 +128,22 @@ DEFER: a
|
|||
blah [ b ] [ a ] if ; inline
|
||||
|
||||
[ t ] [
|
||||
[ a ] dataflow dup detect-loops
|
||||
[ a ] dataflow detect-loops
|
||||
\ a label-is-loop?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ a ] dataflow dup detect-loops
|
||||
[ a ] dataflow detect-loops
|
||||
\ b label-is-loop?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ b ] dataflow dup detect-loops
|
||||
[ b ] dataflow detect-loops
|
||||
\ a label-is-loop?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ a ] dataflow dup detect-loops
|
||||
[ a ] dataflow detect-loops
|
||||
\ b label-is-loop?
|
||||
] unit-test
|
||||
|
||||
|
|
@ -156,12 +156,12 @@ DEFER: a'
|
|||
blah [ b' ] [ a' ] if ; inline
|
||||
|
||||
[ f ] [
|
||||
[ a' ] dataflow dup detect-loops
|
||||
[ a' ] dataflow detect-loops
|
||||
\ a' label-is-loop?
|
||||
] unit-test
|
||||
|
||||
[ f ] [
|
||||
[ b' ] dataflow dup detect-loops
|
||||
[ b' ] dataflow detect-loops
|
||||
\ b' label-is-loop?
|
||||
] unit-test
|
||||
|
||||
|
|
@ -171,11 +171,11 @@ DEFER: a'
|
|||
! a standard iterative dataflow problem after all -- so I'm
|
||||
! tempted to believe the computer here
|
||||
[ t ] [
|
||||
[ b' ] dataflow dup detect-loops
|
||||
[ b' ] dataflow detect-loops
|
||||
\ a' label-is-loop?
|
||||
] unit-test
|
||||
|
||||
[ f ] [
|
||||
[ a' ] dataflow dup detect-loops
|
||||
[ a' ] dataflow detect-loops
|
||||
\ b' label-is-loop?
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -109,8 +109,9 @@ SYMBOL: potential-loops
|
|||
] [ 2drop ] if
|
||||
] assoc-each [ remove-non-loop-calls ] when ;
|
||||
|
||||
: detect-loops ( nodes -- )
|
||||
: detect-loops ( node -- node )
|
||||
[
|
||||
dup
|
||||
collect-label-info
|
||||
remove-non-tail-calls
|
||||
remove-non-loop-calls
|
||||
|
|
|
|||
|
|
@ -3,12 +3,12 @@ USING: inference inference.dataflow optimizer optimizer.def-use
|
|||
namespaces assocs kernel sequences math tools.test words ;
|
||||
|
||||
[ 3 { 1 1 1 } ] [
|
||||
[ 1 2 3 ] dataflow compute-def-use
|
||||
[ 1 2 3 ] dataflow compute-def-use drop
|
||||
def-use get values dup length swap [ length ] map
|
||||
] unit-test
|
||||
|
||||
: kill-set ( quot -- seq )
|
||||
dataflow compute-def-use compute-dead-literals keys
|
||||
dataflow compute-def-use drop compute-dead-literals keys
|
||||
[ value-literal ] map ;
|
||||
|
||||
: subset? [ member? ] curry all? ;
|
||||
|
|
|
|||
|
|
@ -1,8 +1,9 @@
|
|||
! Copyright (C) 2004, 2007 Slava Pestov.
|
||||
! Copyright (C) 2004, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
IN: optimizer.def-use
|
||||
USING: namespaces assocs sequences inference.dataflow
|
||||
inference.backend kernel generic assocs classes vectors ;
|
||||
inference.backend kernel generic assocs classes vectors
|
||||
accessors combinators ;
|
||||
IN: optimizer.def-use
|
||||
|
||||
SYMBOL: def-use
|
||||
|
||||
|
|
@ -21,17 +22,20 @@ SYMBOL: def-use
|
|||
|
||||
GENERIC: node-def-use ( node -- )
|
||||
|
||||
: compute-def-use ( node -- )
|
||||
H{ } clone def-use set [ node-def-use ] each-node ;
|
||||
: compute-def-use ( node -- node )
|
||||
H{ } clone def-use set
|
||||
dup [ node-def-use ] each-node ;
|
||||
|
||||
: nest-def-use ( node -- def-use )
|
||||
[ compute-def-use def-use get ] with-scope ;
|
||||
[ compute-def-use drop def-use get ] with-scope ;
|
||||
|
||||
: (node-def-use) ( node -- )
|
||||
dup dup node-in-d uses-values
|
||||
dup dup node-in-r uses-values
|
||||
dup node-out-d defs-values
|
||||
node-out-r defs-values ;
|
||||
{
|
||||
[ dup in-d>> uses-values ]
|
||||
[ dup in-r>> uses-values ]
|
||||
[ out-d>> defs-values ]
|
||||
[ out-r>> defs-values ]
|
||||
} cleave ;
|
||||
|
||||
M: object node-def-use (node-def-use) ;
|
||||
|
||||
|
|
@ -43,7 +47,7 @@ M: #passthru node-def-use drop ;
|
|||
|
||||
M: #return node-def-use
|
||||
#! Values returned by local labels can be killed.
|
||||
dup node-param [ drop ] [ (node-def-use) ] if ;
|
||||
dup param>> [ drop ] [ (node-def-use) ] if ;
|
||||
|
||||
! nodes that don't use their values directly
|
||||
UNION: #killable
|
||||
|
|
@ -56,13 +60,13 @@ UNION: #killable
|
|||
|
||||
M: #label node-def-use
|
||||
[
|
||||
dup node-in-d ,
|
||||
dup node-child node-out-d ,
|
||||
dup collect-recursion [ node-in-d , ] each
|
||||
dup in-d>> ,
|
||||
dup node-child out-d>> ,
|
||||
dup calls>> [ in-d>> , ] each
|
||||
] { } make purge-invariants uses-values ;
|
||||
|
||||
: branch-def-use ( #branch -- )
|
||||
active-children [ node-in-d ] map
|
||||
active-children [ in-d>> ] map
|
||||
purge-invariants t swap uses-values ;
|
||||
|
||||
M: #branch node-def-use
|
||||
|
|
@ -85,16 +89,16 @@ M: node kill-node* drop t ;
|
|||
inline
|
||||
|
||||
M: #shuffle kill-node*
|
||||
[
|
||||
dup node-in-d empty? swap node-out-d empty? and
|
||||
] prune-if ;
|
||||
[ [ in-d>> empty? ] [ out-d>> empty? ] bi and ] prune-if ;
|
||||
|
||||
M: #push kill-node*
|
||||
[ node-out-d empty? ] prune-if ;
|
||||
[ out-d>> empty? ] prune-if ;
|
||||
|
||||
M: #>r kill-node* [ node-in-d empty? ] prune-if ;
|
||||
M: #>r kill-node*
|
||||
[ in-d>> empty? ] prune-if ;
|
||||
|
||||
M: #r> kill-node* [ node-in-r empty? ] prune-if ;
|
||||
M: #r> kill-node*
|
||||
[ in-r>> empty? ] prune-if ;
|
||||
|
||||
: kill-node ( node -- node )
|
||||
dup [
|
||||
|
|
@ -116,7 +120,7 @@ M: #r> kill-node* [ node-in-r empty? ] prune-if ;
|
|||
] if ;
|
||||
|
||||
: sole-consumer ( #call -- node/f )
|
||||
node-out-d first used-by
|
||||
out-d>> first used-by
|
||||
dup length 1 = [ first ] [ drop f ] if ;
|
||||
|
||||
: splice-def-use ( node -- )
|
||||
|
|
@ -128,5 +132,5 @@ M: #r> kill-node* [ node-in-r empty? ] prune-if ;
|
|||
#! degree of accuracy; the new values should be marked as
|
||||
#! having _some_ usage, so that flushing doesn't erronously
|
||||
#! flush them away.
|
||||
[ compute-def-use def-use get keys ] with-scope
|
||||
nest-def-use keys
|
||||
def-use get [ [ t swap ?push ] change-at ] curry each ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1,10 @@
|
|||
IN: optimizer.inlining.tests
|
||||
USING: tools.test optimizer.inlining ;
|
||||
|
||||
\ word-flat-length must-infer
|
||||
|
||||
\ inlining-math-method must-infer
|
||||
|
||||
\ optimistic-inline? must-infer
|
||||
|
||||
\ find-identity must-infer
|
||||
|
|
@ -3,10 +3,11 @@
|
|||
USING: arrays generic assocs inference inference.class
|
||||
inference.dataflow inference.backend inference.state io kernel
|
||||
math namespaces sequences vectors words quotations hashtables
|
||||
combinators classes classes.algebra generic.math continuations
|
||||
optimizer.def-use optimizer.backend generic.standard
|
||||
optimizer.specializers optimizer.def-use optimizer.pattern-match
|
||||
generic.standard optimizer.control kernel.private ;
|
||||
combinators classes classes.algebra generic.math
|
||||
optimizer.math.partial continuations optimizer.def-use
|
||||
optimizer.backend generic.standard optimizer.specializers
|
||||
optimizer.def-use optimizer.pattern-match generic.standard
|
||||
optimizer.control kernel.private ;
|
||||
IN: optimizer.inlining
|
||||
|
||||
: remember-inlining ( node history -- )
|
||||
|
|
@ -53,8 +54,6 @@ DEFER: (flat-length)
|
|||
[ word-def (flat-length) ] with-scope ;
|
||||
|
||||
! Single dispatch method inlining optimization
|
||||
: specific-method ( class word -- class ) order min-class ;
|
||||
|
||||
: node-class# ( node n -- class )
|
||||
over node-in-d <reversed> ?nth node-class ;
|
||||
|
||||
|
|
@ -72,6 +71,7 @@ DEFER: (flat-length)
|
|||
! Partial dispatch of math-generic words
|
||||
: normalize-math-class ( class -- class' )
|
||||
{
|
||||
null
|
||||
fixnum bignum integer
|
||||
ratio rational
|
||||
float real
|
||||
|
|
@ -79,21 +79,31 @@ DEFER: (flat-length)
|
|||
object
|
||||
} [ class< ] with find nip ;
|
||||
|
||||
: math-both-known? ( word left right -- ? )
|
||||
math-class-max swap specific-method ;
|
||||
|
||||
: inline-math-method ( #call word -- node )
|
||||
over node-input-classes
|
||||
: inlining-math-method ( #call word -- quot/f )
|
||||
swap node-input-classes
|
||||
[ first normalize-math-class ]
|
||||
[ second normalize-math-class ] bi
|
||||
3dup math-both-known?
|
||||
[ math-method f splice-quot ]
|
||||
[ 2drop 2drop t ] if ;
|
||||
3dup math-both-known? [ math-method* ] [ 3drop f ] if ;
|
||||
|
||||
: inline-math-method ( #call word -- node/t )
|
||||
[ drop ] [ inlining-math-method ] 2bi
|
||||
dup [ f splice-quot ] [ 2drop t ] if ;
|
||||
|
||||
: inline-math-partial ( #call word -- node/t )
|
||||
[ drop ]
|
||||
[
|
||||
"derived-from" word-prop first
|
||||
inlining-math-method dup
|
||||
]
|
||||
[ nip 1quotation ] 2tri
|
||||
[ = not ] [ drop ] 2bi and
|
||||
[ f splice-quot ] [ 2drop t ] if ;
|
||||
|
||||
: inline-method ( #call -- node )
|
||||
dup node-param {
|
||||
{ [ dup standard-generic? ] [ inline-standard-method ] }
|
||||
{ [ dup math-generic? ] [ inline-math-method ] }
|
||||
{ [ dup math-partial? ] [ inline-math-partial ] }
|
||||
[ 2drop t ]
|
||||
} cond ;
|
||||
|
||||
|
|
@ -183,7 +193,7 @@ DEFER: (flat-length)
|
|||
nip dup [ second ] when ;
|
||||
|
||||
: apply-identities ( node -- node/f )
|
||||
dup find-identity dup [ f splice-quot ] [ 2drop f ] if ;
|
||||
dup find-identity f splice-quot ;
|
||||
|
||||
: optimistic-inline? ( #call -- ? )
|
||||
dup node-param "specializer" word-prop dup [
|
||||
|
|
|
|||
|
|
@ -60,7 +60,8 @@ sequences.private combinators ;
|
|||
[ value-literal sequence? ] [ drop f ] if ;
|
||||
|
||||
: member-quot ( seq -- newquot )
|
||||
[ [ t ] ] { } map>assoc [ drop f ] suffix [ nip case ] curry ;
|
||||
[ literalize [ t ] ] { } map>assoc
|
||||
[ drop f ] suffix [ nip case ] curry ;
|
||||
|
||||
: expand-member ( #call -- )
|
||||
dup node-in-d peek value-literal member-quot f splice-quot ;
|
||||
|
|
@ -83,21 +84,11 @@ sequences.private combinators ;
|
|||
] "constraints" set-word-prop
|
||||
|
||||
! eq? on the same object is always t
|
||||
{ eq? bignum= float= number= = } {
|
||||
{ eq? = } {
|
||||
{ { @ @ } [ 2drop t ] }
|
||||
} define-identities
|
||||
|
||||
! Specializers
|
||||
{ 1+ 1- sq neg recip sgn } [
|
||||
{ number } "specializer" set-word-prop
|
||||
] each
|
||||
|
||||
\ 2/ { fixnum } "specializer" set-word-prop
|
||||
|
||||
{ min max } [
|
||||
{ number number } "specializer" set-word-prop
|
||||
] each
|
||||
|
||||
{ first first2 first3 first4 }
|
||||
[ { array } "specializer" set-word-prop ] each
|
||||
|
||||
|
|
|
|||
|
|
@ -8,103 +8,104 @@ namespaces assocs quotations math.intervals sequences.private
|
|||
combinators splitting layouts math.parser classes
|
||||
classes.algebra generic.math optimizer.pattern-match
|
||||
optimizer.backend optimizer.def-use optimizer.inlining
|
||||
generic.standard system ;
|
||||
optimizer.math.partial generic.standard system accessors ;
|
||||
|
||||
{ + bignum+ float+ fixnum+fast } {
|
||||
: define-math-identities ( word identities -- )
|
||||
>r all-derived-ops r> define-identities ;
|
||||
|
||||
\ number= {
|
||||
{ { @ @ } [ 2drop t ] }
|
||||
} define-math-identities
|
||||
|
||||
\ + {
|
||||
{ { number 0 } [ drop ] }
|
||||
{ { 0 number } [ nip ] }
|
||||
} define-identities
|
||||
} define-math-identities
|
||||
|
||||
{ fixnum+ } {
|
||||
{ { number 0 } [ drop ] }
|
||||
{ { 0 number } [ nip ] }
|
||||
} define-identities
|
||||
|
||||
{ - fixnum- bignum- float- fixnum-fast } {
|
||||
\ - {
|
||||
{ { number 0 } [ drop ] }
|
||||
{ { @ @ } [ 2drop 0 ] }
|
||||
} define-identities
|
||||
} define-math-identities
|
||||
|
||||
{ < fixnum< bignum< float< } {
|
||||
\ < {
|
||||
{ { @ @ } [ 2drop f ] }
|
||||
} define-identities
|
||||
} define-math-identities
|
||||
|
||||
{ <= fixnum<= bignum<= float<= } {
|
||||
\ <= {
|
||||
{ { @ @ } [ 2drop t ] }
|
||||
} define-identities
|
||||
} define-math-identities
|
||||
|
||||
{ > fixnum> bignum> float>= } {
|
||||
\ > {
|
||||
{ { @ @ } [ 2drop f ] }
|
||||
} define-identities
|
||||
} define-math-identities
|
||||
|
||||
{ >= fixnum>= bignum>= float>= } {
|
||||
\ >= {
|
||||
{ { @ @ } [ 2drop t ] }
|
||||
} define-identities
|
||||
} define-math-identities
|
||||
|
||||
{ * fixnum* bignum* float* } {
|
||||
\ * {
|
||||
{ { number 1 } [ drop ] }
|
||||
{ { 1 number } [ nip ] }
|
||||
{ { number 0 } [ nip ] }
|
||||
{ { 0 number } [ drop ] }
|
||||
{ { number -1 } [ drop 0 swap - ] }
|
||||
{ { -1 number } [ nip 0 swap - ] }
|
||||
} define-identities
|
||||
} define-math-identities
|
||||
|
||||
{ / fixnum/i bignum/i float/f } {
|
||||
\ / {
|
||||
{ { number 1 } [ drop ] }
|
||||
{ { number -1 } [ drop 0 swap - ] }
|
||||
} define-identities
|
||||
} define-math-identities
|
||||
|
||||
{ fixnum-mod bignum-mod } {
|
||||
{ { number 1 } [ 2drop 0 ] }
|
||||
} define-identities
|
||||
\ mod {
|
||||
{ { integer 1 } [ 2drop 0 ] }
|
||||
} define-math-identities
|
||||
|
||||
{ bitand fixnum-bitand bignum-bitand } {
|
||||
\ rem {
|
||||
{ { integer 1 } [ 2drop 0 ] }
|
||||
} define-math-identities
|
||||
|
||||
\ bitand {
|
||||
{ { number -1 } [ drop ] }
|
||||
{ { -1 number } [ nip ] }
|
||||
{ { @ @ } [ drop ] }
|
||||
{ { number 0 } [ nip ] }
|
||||
{ { 0 number } [ drop ] }
|
||||
} define-identities
|
||||
} define-math-identities
|
||||
|
||||
{ bitor fixnum-bitor bignum-bitor } {
|
||||
\ bitor {
|
||||
{ { number 0 } [ drop ] }
|
||||
{ { 0 number } [ nip ] }
|
||||
{ { @ @ } [ drop ] }
|
||||
{ { number -1 } [ nip ] }
|
||||
{ { -1 number } [ drop ] }
|
||||
} define-identities
|
||||
} define-math-identities
|
||||
|
||||
{ bitxor fixnum-bitxor bignum-bitxor } {
|
||||
\ bitxor {
|
||||
{ { number 0 } [ drop ] }
|
||||
{ { 0 number } [ nip ] }
|
||||
{ { number -1 } [ drop bitnot ] }
|
||||
{ { -1 number } [ nip bitnot ] }
|
||||
{ { @ @ } [ 2drop 0 ] }
|
||||
} define-identities
|
||||
} define-math-identities
|
||||
|
||||
{ shift fixnum-shift fixnum-shift-fast bignum-shift } {
|
||||
\ shift {
|
||||
{ { 0 number } [ drop ] }
|
||||
{ { number 0 } [ drop ] }
|
||||
} define-identities
|
||||
} define-math-identities
|
||||
|
||||
: math-closure ( class -- newclass )
|
||||
{ fixnum integer rational real }
|
||||
{ null fixnum bignum integer rational float real number }
|
||||
[ class< ] with find nip number or ;
|
||||
|
||||
: fits? ( interval class -- ? )
|
||||
"interval" word-prop dup
|
||||
[ interval-subset? ] [ 2drop t ] if ;
|
||||
|
||||
: math-output-class ( node min -- newclass )
|
||||
#! if min is f, it means we just want to use the declared
|
||||
#! output class from the "infer-effect".
|
||||
dup [
|
||||
swap node-in-d
|
||||
[ value-class* math-closure math-class-max ] each
|
||||
] [
|
||||
2drop f
|
||||
] if ;
|
||||
: math-output-class ( node upgrades -- newclass )
|
||||
>r
|
||||
in-d>> null [ value-class* math-closure math-class-max ] reduce
|
||||
dup r> at swap or ;
|
||||
|
||||
: won't-overflow? ( interval node -- ? )
|
||||
node-in-d [ value-class* fixnum class< ] all?
|
||||
|
|
@ -123,28 +124,18 @@ generic.standard system ;
|
|||
2drop f
|
||||
] if ; inline
|
||||
|
||||
: math-output-class/interval-1 ( node min word -- classes intervals )
|
||||
pick >r
|
||||
>r over r>
|
||||
math-output-interval-1
|
||||
>r math-output-class r>
|
||||
r> post-process ; inline
|
||||
: math-output-class/interval-1 ( node word -- classes intervals )
|
||||
[ drop { } math-output-class 1array ]
|
||||
[ math-output-interval-1 1array ] 2bi ;
|
||||
|
||||
{
|
||||
{ 1+ integer interval-1+ }
|
||||
{ 1- integer interval-1- }
|
||||
{ neg integer interval-neg }
|
||||
{ shift integer interval-recip }
|
||||
{ bitnot fixnum interval-bitnot }
|
||||
{ fixnum-bitnot f interval-bitnot }
|
||||
{ bignum-bitnot f interval-bitnot }
|
||||
{ 2/ fixnum interval-2/ }
|
||||
{ sq integer f }
|
||||
{ bitnot interval-bitnot }
|
||||
{ fixnum-bitnot interval-bitnot }
|
||||
{ bignum-bitnot interval-bitnot }
|
||||
} [
|
||||
first3 [
|
||||
math-output-class/interval-1
|
||||
] 2curry "output-classes" set-word-prop
|
||||
] each
|
||||
[ math-output-class/interval-1 ] curry
|
||||
"output-classes" set-word-prop
|
||||
] assoc-each
|
||||
|
||||
: intervals ( node -- i1 i2 )
|
||||
node-in-d first2 [ value-interval* ] bi@ ;
|
||||
|
|
@ -156,7 +147,7 @@ generic.standard system ;
|
|||
2drop f
|
||||
] if ; inline
|
||||
|
||||
: math-output-class/interval-2 ( node min word -- classes intervals )
|
||||
: math-output-class/interval-2 ( node upgrades word -- classes intervals )
|
||||
pick >r
|
||||
>r over r>
|
||||
math-output-interval-2
|
||||
|
|
@ -164,47 +155,18 @@ generic.standard system ;
|
|||
r> post-process ; inline
|
||||
|
||||
{
|
||||
{ + integer interval+ }
|
||||
{ - integer interval- }
|
||||
{ * integer interval* }
|
||||
{ / rational interval/ }
|
||||
{ /i integer interval/i }
|
||||
|
||||
{ fixnum+ f interval+ }
|
||||
{ fixnum+fast f interval+ }
|
||||
{ fixnum- f interval- }
|
||||
{ fixnum-fast f interval- }
|
||||
{ fixnum* f interval* }
|
||||
{ fixnum*fast f interval* }
|
||||
{ fixnum/i f interval/i }
|
||||
|
||||
{ bignum+ f interval+ }
|
||||
{ bignum- f interval- }
|
||||
{ bignum* f interval* }
|
||||
{ bignum/i f interval/i }
|
||||
{ bignum-shift f interval-shift-safe }
|
||||
|
||||
{ float+ f interval+ }
|
||||
{ float- f interval- }
|
||||
{ float* f interval* }
|
||||
{ float/f f interval/ }
|
||||
|
||||
{ min fixnum interval-min }
|
||||
{ max fixnum interval-max }
|
||||
{ + { { fixnum integer } } interval+ }
|
||||
{ - { { fixnum integer } } interval- }
|
||||
{ * { { fixnum integer } } interval* }
|
||||
{ / { { fixnum rational } { integer rational } } interval/ }
|
||||
{ /i { { fixnum integer } } interval/i }
|
||||
{ shift { { fixnum integer } } interval-shift-safe }
|
||||
} [
|
||||
first3 [
|
||||
math-output-class/interval-2
|
||||
] 2curry "output-classes" set-word-prop
|
||||
] each
|
||||
|
||||
{ fixnum-shift fixnum-shift-fast shift } [
|
||||
[
|
||||
dup
|
||||
node-in-d second value-interval*
|
||||
-1./0. 0 [a,b] interval-subset? fixnum integer ?
|
||||
\ interval-shift-safe
|
||||
math-output-class/interval-2
|
||||
] "output-classes" set-word-prop
|
||||
[
|
||||
math-output-class/interval-2
|
||||
] 2curry "output-classes" set-word-prop
|
||||
] 2curry each-derived-op
|
||||
] each
|
||||
|
||||
: real-value? ( value -- n ? )
|
||||
|
|
@ -235,22 +197,18 @@ generic.standard system ;
|
|||
r> post-process ; inline
|
||||
|
||||
{
|
||||
{ mod fixnum mod-range }
|
||||
{ fixnum-mod f mod-range }
|
||||
{ bignum-mod f mod-range }
|
||||
{ float-mod f mod-range }
|
||||
{ mod { } mod-range }
|
||||
{ rem { { fixnum integer } } rem-range }
|
||||
|
||||
{ rem integer rem-range }
|
||||
|
||||
{ bitand fixnum bitand-range }
|
||||
{ fixnum-bitand f bitand-range }
|
||||
|
||||
{ bitor fixnum f }
|
||||
{ bitxor fixnum f }
|
||||
{ bitand { } bitand-range }
|
||||
{ bitor { } f }
|
||||
{ bitxor { } f }
|
||||
} [
|
||||
first3 [
|
||||
math-output-class/interval-special
|
||||
] 2curry "output-classes" set-word-prop
|
||||
[
|
||||
math-output-class/interval-special
|
||||
] 2curry "output-classes" set-word-prop
|
||||
] 2curry each-derived-op
|
||||
] each
|
||||
|
||||
: twiddle-interval ( i1 -- i2 )
|
||||
|
|
@ -280,26 +238,12 @@ generic.standard system ;
|
|||
{ <= assume<= assume> }
|
||||
{ > assume> assume<= }
|
||||
{ >= assume>= assume< }
|
||||
|
||||
{ fixnum< assume< assume>= }
|
||||
{ fixnum<= assume<= assume> }
|
||||
{ fixnum> assume> assume<= }
|
||||
{ fixnum>= assume>= assume< }
|
||||
|
||||
{ bignum< assume< assume>= }
|
||||
{ bignum<= assume<= assume> }
|
||||
{ bignum> assume> assume<= }
|
||||
{ bignum>= assume>= assume< }
|
||||
|
||||
{ float< assume< assume>= }
|
||||
{ float<= assume<= assume> }
|
||||
{ float> assume> assume<= }
|
||||
{ float>= assume>= assume< }
|
||||
} [
|
||||
first3
|
||||
[
|
||||
[ comparison-constraints ] with-scope
|
||||
] 2curry "constraints" set-word-prop
|
||||
first3 [
|
||||
[
|
||||
[ comparison-constraints ] with-scope
|
||||
] 2curry "constraints" set-word-prop
|
||||
] 2curry each-derived-op
|
||||
] each
|
||||
|
||||
{
|
||||
|
|
@ -348,22 +292,20 @@ most-negative-fixnum most-positive-fixnum [a,b]
|
|||
|
||||
! Removing overflow checks
|
||||
: remove-overflow-check? ( #call -- ? )
|
||||
dup node-out-d first node-class fixnum class< ;
|
||||
dup out-d>> first node-class
|
||||
[ fixnum class< ] [ null eq? not ] bi and ;
|
||||
|
||||
{
|
||||
{ + [ fixnum+fast ] }
|
||||
{ +-integer-fixnum [ fixnum+fast ] }
|
||||
{ - [ fixnum-fast ] }
|
||||
{ * [ fixnum*fast ] }
|
||||
{ *-integer-fixnum [ fixnum*fast ] }
|
||||
{ shift [ fixnum-shift-fast ] }
|
||||
{ fixnum+ [ fixnum+fast ] }
|
||||
{ fixnum- [ fixnum-fast ] }
|
||||
{ fixnum* [ fixnum*fast ] }
|
||||
! these are here as an optimization. if they weren't given
|
||||
! explicitly, the same would be inferred after an extra
|
||||
! optimization step (see optimistic-inline?)
|
||||
{ 1+ [ 1 fixnum+fast ] }
|
||||
{ 1- [ 1 fixnum-fast ] }
|
||||
{ 2/ [ -1 fixnum-shift ] }
|
||||
{ neg [ 0 swap fixnum-fast ] }
|
||||
{ fixnum-shift [ fixnum-shift-fast ] }
|
||||
} [
|
||||
[
|
||||
[ dup remove-overflow-check? ] ,
|
||||
|
|
@ -397,26 +339,13 @@ most-negative-fixnum most-positive-fixnum [a,b]
|
|||
{ <= interval<= }
|
||||
{ > interval> }
|
||||
{ >= interval>= }
|
||||
|
||||
{ fixnum< interval< }
|
||||
{ fixnum<= interval<= }
|
||||
{ fixnum> interval> }
|
||||
{ fixnum>= interval>= }
|
||||
|
||||
{ bignum< interval< }
|
||||
{ bignum<= interval<= }
|
||||
{ bignum> interval> }
|
||||
{ bignum>= interval>= }
|
||||
|
||||
{ float< interval< }
|
||||
{ float<= interval<= }
|
||||
{ float> interval> }
|
||||
{ float>= interval>= }
|
||||
} [
|
||||
[
|
||||
dup [ dupd foldable-comparison? ] curry ,
|
||||
[ fold-comparison ] curry ,
|
||||
] { } make 1array define-optimizers
|
||||
[
|
||||
dup [ dupd foldable-comparison? ] curry ,
|
||||
[ fold-comparison ] curry ,
|
||||
] { } make 1array define-optimizers
|
||||
] curry each-derived-op
|
||||
] assoc-each
|
||||
|
||||
! The following words are handled in a similar way except if
|
||||
|
|
@ -426,44 +355,68 @@ most-negative-fixnum most-positive-fixnum [a,b]
|
|||
swap sole-consumer
|
||||
dup #call? [ node-param eq? ] [ 2drop f ] if ;
|
||||
|
||||
: coereced-to-fixnum? ( #call -- ? )
|
||||
\ >fixnum consumed-by? ;
|
||||
: coerced-to-fixnum? ( #call -- ? )
|
||||
dup dup node-in-d [ node-class integer class< ] with all?
|
||||
[ \ >fixnum consumed-by? ] [ drop f ] if ;
|
||||
|
||||
{
|
||||
{ fixnum+ [ fixnum+fast ] }
|
||||
{ fixnum- [ fixnum-fast ] }
|
||||
{ fixnum* [ fixnum*fast ] }
|
||||
{ + [ [ >fixnum ] bi@ fixnum+fast ] }
|
||||
{ - [ [ >fixnum ] bi@ fixnum-fast ] }
|
||||
{ * [ [ >fixnum ] bi@ fixnum*fast ] }
|
||||
} [
|
||||
[
|
||||
>r derived-ops r> [
|
||||
[
|
||||
dup remove-overflow-check?
|
||||
over coereced-to-fixnum? or
|
||||
] ,
|
||||
[ f splice-quot ] curry ,
|
||||
] { } make 1array define-optimizers
|
||||
[
|
||||
dup remove-overflow-check?
|
||||
over coerced-to-fixnum? or
|
||||
] ,
|
||||
[ f splice-quot ] curry ,
|
||||
] { } make 1array define-optimizers
|
||||
] curry each
|
||||
] assoc-each
|
||||
|
||||
: fixnum-shift-fast-pos? ( node -- ? )
|
||||
#! Shifting 1 to the left won't overflow if the shift
|
||||
#! count is small enough
|
||||
dup dup node-in-d first node-literal 1 = [
|
||||
dup node-in-d second node-interval
|
||||
0 cell-bits tag-bits get - 2 - [a,b] interval-subset?
|
||||
] [ drop f ] if ;
|
||||
: convert-rem-to-and? ( #call -- ? )
|
||||
dup node-in-d {
|
||||
{ [ 2dup first node-class integer class< not ] [ f ] }
|
||||
{ [ 2dup second node-literal integer? not ] [ f ] }
|
||||
{ [ 2dup second node-literal power-of-2? not ] [ f ] }
|
||||
[ t ]
|
||||
} cond 2nip ;
|
||||
|
||||
: fixnum-shift-fast-neg? ( node -- ? )
|
||||
#! Shifting any number to the right won't overflow if the
|
||||
#! shift count is small enough
|
||||
dup node-in-d second node-interval
|
||||
cell-bits 1- neg 0 [a,b] interval-subset? ;
|
||||
: convert-mod-to-and? ( #call -- ? )
|
||||
dup dup node-in-d first node-interval 0 [a,inf] interval-subset?
|
||||
[ convert-rem-to-and? ] [ drop f ] if ;
|
||||
|
||||
: fixnum-shift-fast? ( node -- ? )
|
||||
dup fixnum-shift-fast-pos?
|
||||
[ drop t ] [ fixnum-shift-fast-neg? ] if ;
|
||||
: convert-mod-to-and ( #call -- node )
|
||||
dup
|
||||
dup node-in-d second node-literal 1-
|
||||
[ nip bitand ] curry f splice-quot ;
|
||||
|
||||
\ fixnum-shift {
|
||||
\ mod [
|
||||
{
|
||||
[ dup fixnum-shift-fast? ]
|
||||
[ [ fixnum-shift-fast ] f splice-quot ]
|
||||
{
|
||||
[ dup convert-mod-to-and? ]
|
||||
[ convert-mod-to-and ]
|
||||
}
|
||||
} define-optimizers
|
||||
] each-derived-op
|
||||
|
||||
\ rem {
|
||||
{
|
||||
[ dup convert-rem-to-and? ]
|
||||
[ convert-mod-to-and ]
|
||||
}
|
||||
} define-optimizers
|
||||
|
||||
: fixnumify-bitand? ( #call -- ? )
|
||||
dup node-in-d second node-interval fixnum fits? ;
|
||||
|
||||
: fixnumify-bitand ( #call -- node )
|
||||
[ [ >fixnum ] bi@ fixnum-bitand ] f splice-quot ;
|
||||
|
||||
\ bitand {
|
||||
{
|
||||
[ dup fixnumify-bitand? ]
|
||||
[ fixnumify-bitand ]
|
||||
}
|
||||
} define-optimizers
|
||||
|
|
|
|||
|
|
@ -0,0 +1,13 @@
|
|||
IN: optimizer.math.partial.tests
|
||||
USING: optimizer.math.partial tools.test math kernel
|
||||
sequences ;
|
||||
|
||||
[ t ] [ \ + integer fixnum math-both-known? ] unit-test
|
||||
[ t ] [ \ + bignum fixnum math-both-known? ] unit-test
|
||||
[ t ] [ \ + integer bignum math-both-known? ] unit-test
|
||||
[ t ] [ \ + float fixnum math-both-known? ] unit-test
|
||||
[ f ] [ \ + real fixnum math-both-known? ] unit-test
|
||||
[ f ] [ \ + object number math-both-known? ] unit-test
|
||||
[ f ] [ \ number= fixnum object math-both-known? ] unit-test
|
||||
[ t ] [ \ number= integer fixnum math-both-known? ] unit-test
|
||||
[ f ] [ \ >fixnum \ shift derived-ops memq? ] unit-test
|
||||
|
|
@ -0,0 +1,172 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel kernel.private math math.private words
|
||||
sequences parser namespaces assocs quotations arrays
|
||||
generic generic.math hashtables effects ;
|
||||
IN: optimizer.math.partial
|
||||
|
||||
! Partial dispatch.
|
||||
|
||||
! This code will be overhauled and generalized when
|
||||
! multi-methods go into the core.
|
||||
PREDICATE: math-partial < word
|
||||
"derived-from" word-prop >boolean ;
|
||||
|
||||
: fixnum-integer-op ( a b fix-word big-word -- c )
|
||||
pick tag 0 eq? [
|
||||
drop execute
|
||||
] [
|
||||
>r drop >r fixnum>bignum r> r> execute
|
||||
] if ; inline
|
||||
|
||||
: integer-fixnum-op ( a b fix-word big-word -- c )
|
||||
>r pick tag 0 eq? [
|
||||
r> drop execute
|
||||
] [
|
||||
drop fixnum>bignum r> execute
|
||||
] if ; inline
|
||||
|
||||
: integer-integer-op ( a b fix-word big-word -- c )
|
||||
pick tag 0 eq? [
|
||||
integer-fixnum-op
|
||||
] [
|
||||
>r drop over tag 0 eq? [
|
||||
>r fixnum>bignum r> r> execute
|
||||
] [
|
||||
r> execute
|
||||
] if
|
||||
] if ; inline
|
||||
|
||||
<<
|
||||
: integer-op-combinator ( triple -- word )
|
||||
[
|
||||
[ second word-name % "-" % ]
|
||||
[ third word-name % "-op" % ]
|
||||
bi
|
||||
] "" make in get lookup ;
|
||||
|
||||
: integer-op-word ( triple fix-word big-word -- word )
|
||||
[
|
||||
drop
|
||||
word-name "fast" tail? >r
|
||||
[ "-" % ] [ word-name % ] interleave
|
||||
r> [ "-fast" % ] when
|
||||
] "" make in get create ;
|
||||
|
||||
: integer-op-quot ( word fix-word big-word -- quot )
|
||||
rot integer-op-combinator 1quotation 2curry ;
|
||||
|
||||
: define-integer-op-word ( word fix-word big-word -- )
|
||||
[
|
||||
[ integer-op-word ] [ integer-op-quot ] 3bi
|
||||
2 1 <effect> define-declared
|
||||
]
|
||||
[
|
||||
[ integer-op-word ] [ 2drop ] 3bi
|
||||
"derived-from" set-word-prop
|
||||
] 3bi ;
|
||||
|
||||
: define-integer-op-words ( words fix-word big-word -- )
|
||||
[ define-integer-op-word ] 2curry each ;
|
||||
|
||||
: integer-op-triples ( word -- triples )
|
||||
{
|
||||
{ fixnum integer }
|
||||
{ integer fixnum }
|
||||
{ integer integer }
|
||||
} swap [ prefix ] curry map ;
|
||||
|
||||
: define-integer-ops ( word fix-word big-word -- )
|
||||
>r >r integer-op-triples r> r>
|
||||
[ define-integer-op-words ]
|
||||
[ [ 2drop ] [ [ integer-op-word ] 2curry map ] 3bi zip % ]
|
||||
3bi ;
|
||||
|
||||
: define-math-ops ( op -- )
|
||||
{ fixnum bignum float }
|
||||
[ [ dup 3array ] [ swap method ] 2bi ] with { } map>assoc
|
||||
[ nip ] assoc-subset
|
||||
[ word-def peek ] assoc-map % ;
|
||||
|
||||
SYMBOL: math-ops
|
||||
|
||||
[
|
||||
\ + define-math-ops
|
||||
\ - define-math-ops
|
||||
\ * define-math-ops
|
||||
\ shift define-math-ops
|
||||
\ mod define-math-ops
|
||||
\ /i define-math-ops
|
||||
|
||||
\ bitand define-math-ops
|
||||
\ bitor define-math-ops
|
||||
\ bitxor define-math-ops
|
||||
|
||||
\ < define-math-ops
|
||||
\ <= define-math-ops
|
||||
\ > define-math-ops
|
||||
\ >= define-math-ops
|
||||
\ number= define-math-ops
|
||||
|
||||
\ + \ fixnum+ \ bignum+ define-integer-ops
|
||||
\ - \ fixnum- \ bignum- define-integer-ops
|
||||
\ * \ fixnum* \ bignum* define-integer-ops
|
||||
\ shift \ fixnum-shift \ bignum-shift define-integer-ops
|
||||
\ mod \ fixnum-mod \ bignum-mod define-integer-ops
|
||||
\ /i \ fixnum/i \ bignum/i define-integer-ops
|
||||
|
||||
\ bitand \ fixnum-bitand \ bignum-bitand define-integer-ops
|
||||
\ bitor \ fixnum-bitor \ bignum-bitor define-integer-ops
|
||||
\ bitxor \ fixnum-bitxor \ bignum-bitxor define-integer-ops
|
||||
|
||||
\ < \ fixnum< \ bignum< define-integer-ops
|
||||
\ <= \ fixnum<= \ bignum<= define-integer-ops
|
||||
\ > \ fixnum> \ bignum> define-integer-ops
|
||||
\ >= \ fixnum>= \ bignum>= define-integer-ops
|
||||
\ number= \ eq? \ bignum= define-integer-ops
|
||||
] { } make >hashtable math-ops set-global
|
||||
|
||||
SYMBOL: fast-math-ops
|
||||
|
||||
[
|
||||
{ { + fixnum fixnum } fixnum+fast } ,
|
||||
{ { - fixnum fixnum } fixnum-fast } ,
|
||||
{ { * fixnum fixnum } fixnum*fast } ,
|
||||
{ { shift fixnum fixnum } fixnum-shift-fast } ,
|
||||
|
||||
\ + \ fixnum+fast \ bignum+ define-integer-ops
|
||||
\ - \ fixnum-fast \ bignum- define-integer-ops
|
||||
\ * \ fixnum*fast \ bignum* define-integer-ops
|
||||
\ shift \ fixnum-shift-fast \ bignum-shift define-integer-ops
|
||||
] { } make >hashtable fast-math-ops set-global
|
||||
|
||||
>>
|
||||
|
||||
: math-op ( word left right -- word' ? )
|
||||
3array math-ops get at* ;
|
||||
|
||||
: math-method* ( word left right -- quot )
|
||||
3dup math-op
|
||||
[ >r 3drop r> 1quotation ] [ drop math-method ] if ;
|
||||
|
||||
: math-both-known? ( word left right -- ? )
|
||||
3dup math-op
|
||||
[ 2drop 2drop t ]
|
||||
[ drop math-class-max swap specific-method >boolean ] if ;
|
||||
|
||||
: (derived-ops) ( word assoc -- words )
|
||||
swap [ rot first eq? nip ] curry assoc-subset values ;
|
||||
|
||||
: derived-ops ( word -- words )
|
||||
[ 1array ]
|
||||
[ math-ops get (derived-ops) ]
|
||||
bi append ;
|
||||
|
||||
: fast-derived-ops ( word -- words )
|
||||
fast-math-ops get (derived-ops) ;
|
||||
|
||||
: all-derived-ops ( word -- words )
|
||||
[ derived-ops ] [ fast-derived-ops ] bi append ;
|
||||
|
||||
: each-derived-op ( word quot -- )
|
||||
>r derived-ops r> each ; inline
|
||||
|
|
@ -1,9 +1,9 @@
|
|||
USING: arrays compiler.units generic hashtables inference kernel
|
||||
kernel.private math optimizer prettyprint sequences sbufs
|
||||
strings tools.test vectors words sequences.private quotations
|
||||
optimizer.backend classes classes.algebra inference.dataflow
|
||||
classes.tuple.private continuations growable optimizer.inlining
|
||||
namespaces hints ;
|
||||
kernel.private math optimizer generator prettyprint sequences
|
||||
sbufs strings tools.test vectors words sequences.private
|
||||
quotations optimizer.backend classes classes.algebra
|
||||
inference.dataflow classes.tuple.private continuations growable
|
||||
optimizer.inlining namespaces hints ;
|
||||
IN: optimizer.tests
|
||||
|
||||
[ H{ { 1 5 } { 3 4 } { 2 5 } } ] [
|
||||
|
|
@ -14,40 +14,6 @@ IN: optimizer.tests
|
|||
H{ { 1 2 } { 3 4 } } H{ { 2 3 } } union*
|
||||
] unit-test
|
||||
|
||||
! Test method inlining
|
||||
[ f ] [ fixnum { } min-class ] unit-test
|
||||
|
||||
[ string ] [
|
||||
\ string
|
||||
[ integer string array reversed sbuf
|
||||
slice vector quotation ]
|
||||
sort-classes min-class
|
||||
] unit-test
|
||||
|
||||
[ fixnum ] [
|
||||
\ fixnum
|
||||
[ fixnum integer object ]
|
||||
sort-classes min-class
|
||||
] unit-test
|
||||
|
||||
[ integer ] [
|
||||
\ fixnum
|
||||
[ integer float object ]
|
||||
sort-classes min-class
|
||||
] unit-test
|
||||
|
||||
[ object ] [
|
||||
\ word
|
||||
[ integer float object ]
|
||||
sort-classes min-class
|
||||
] unit-test
|
||||
|
||||
[ reversed ] [
|
||||
\ reversed
|
||||
[ integer reversed slice ]
|
||||
sort-classes min-class
|
||||
] unit-test
|
||||
|
||||
GENERIC: xyz ( obj -- obj )
|
||||
M: array xyz xyz ;
|
||||
|
||||
|
|
@ -325,7 +291,6 @@ TUPLE: silly-tuple a b ;
|
|||
|
||||
[ 1 2 3 ] [ lift-loop-tail-test-2 ] unit-test
|
||||
|
||||
! Make sure we don't lose
|
||||
GENERIC: generic-inline-test ( x -- y )
|
||||
M: integer generic-inline-test ;
|
||||
|
||||
|
|
@ -342,6 +307,7 @@ M: integer generic-inline-test ;
|
|||
generic-inline-test
|
||||
generic-inline-test ;
|
||||
|
||||
! Inlining all of the above should only take two passes
|
||||
[ { t f } ] [
|
||||
\ generic-inline-test-1 word-def dataflow
|
||||
[ optimize-1 , optimize-1 , drop ] { } make
|
||||
|
|
@ -374,3 +340,19 @@ HINTS: recursive-inline-hang-3 array ;
|
|||
USE: sequences.private
|
||||
|
||||
[ ] [ { (3append) } compile ] unit-test
|
||||
|
||||
! Wow
|
||||
: counter-example ( a b c d -- a' b' c' d' )
|
||||
dup 0 > [ 1 - >r rot 2 * r> counter-example ] when ; inline
|
||||
|
||||
: counter-example' ( -- a' b' c' d' )
|
||||
1 2 3.0 3 counter-example ;
|
||||
|
||||
[ 2 4 6.0 0 ] [ counter-example' ] unit-test
|
||||
|
||||
: member-test { + - * / /i } member? ;
|
||||
|
||||
\ member-test must-infer
|
||||
[ ] [ \ member-test word-dataflow optimize 2drop ] unit-test
|
||||
[ t ] [ \ + member-test ] unit-test
|
||||
[ f ] [ \ append member-test ] unit-test
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel namespaces optimizer.backend optimizer.def-use
|
||||
optimizer.known-words optimizer.math optimizer.control
|
||||
optimizer.inlining inference.class ;
|
||||
optimizer.collect optimizer.inlining inference.class ;
|
||||
IN: optimizer
|
||||
|
||||
: optimize-1 ( node -- newnode ? )
|
||||
|
|
@ -10,10 +10,13 @@ IN: optimizer
|
|||
H{ } clone class-substitutions set
|
||||
H{ } clone literal-substitutions set
|
||||
H{ } clone value-substitutions set
|
||||
dup compute-def-use
|
||||
|
||||
collect-label-infos
|
||||
compute-def-use
|
||||
kill-values
|
||||
dup detect-loops
|
||||
dup infer-classes
|
||||
detect-loops
|
||||
infer-classes
|
||||
|
||||
optimizer-changed off
|
||||
optimize-nodes
|
||||
optimizer-changed get
|
||||
|
|
|
|||
|
|
@ -1,11 +1,10 @@
|
|||
! Copyright (C) 2003, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays byte-arrays byte-vectors bit-arrays bit-vectors
|
||||
generic hashtables io assocs kernel math namespaces sequences
|
||||
strings sbufs io.styles vectors words prettyprint.config
|
||||
prettyprint.sections quotations io io.files math.parser effects
|
||||
classes.tuple classes.tuple.private classes float-arrays
|
||||
float-vectors ;
|
||||
USING: arrays byte-arrays bit-arrays generic hashtables io
|
||||
assocs kernel math namespaces sequences strings sbufs io.styles
|
||||
vectors words prettyprint.config prettyprint.sections quotations
|
||||
io io.files math.parser effects classes.tuple
|
||||
classes.tuple.private classes float-arrays ;
|
||||
IN: prettyprint.backend
|
||||
|
||||
GENERIC: pprint* ( obj -- )
|
||||
|
|
@ -140,11 +139,8 @@ M: curry pprint-delims drop \ [ \ ] ;
|
|||
M: compose pprint-delims drop \ [ \ ] ;
|
||||
M: array pprint-delims drop \ { \ } ;
|
||||
M: byte-array pprint-delims drop \ B{ \ } ;
|
||||
M: byte-vector pprint-delims drop \ BV{ \ } ;
|
||||
M: bit-array pprint-delims drop \ ?{ \ } ;
|
||||
M: bit-vector pprint-delims drop \ ?V{ \ } ;
|
||||
M: float-array pprint-delims drop \ F{ \ } ;
|
||||
M: float-vector pprint-delims drop \ FV{ \ } ;
|
||||
M: vector pprint-delims drop \ V{ \ } ;
|
||||
M: hashtable pprint-delims drop \ H{ \ } ;
|
||||
M: tuple pprint-delims drop \ T{ \ } ;
|
||||
|
|
@ -156,9 +152,6 @@ GENERIC: >pprint-sequence ( obj -- seq )
|
|||
M: object >pprint-sequence ;
|
||||
|
||||
M: vector >pprint-sequence ;
|
||||
M: bit-vector >pprint-sequence ;
|
||||
M: byte-vector >pprint-sequence ;
|
||||
M: float-vector >pprint-sequence ;
|
||||
M: curry >pprint-sequence ;
|
||||
M: compose >pprint-sequence ;
|
||||
M: hashtable >pprint-sequence >alist ;
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2003, 2007 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
IN: prettyprint.config
|
||||
USING: alien arrays generic assocs io kernel math
|
||||
USING: arrays generic assocs io kernel math
|
||||
namespaces sequences strings io.styles vectors words
|
||||
continuations ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2003, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
IN: prettyprint
|
||||
USING: alien arrays generic generic.standard assocs io kernel
|
||||
USING: arrays generic generic.standard assocs io kernel
|
||||
math namespaces sequences strings io.styles io.streams.string
|
||||
vectors words prettyprint.backend prettyprint.sections
|
||||
prettyprint.config sorting splitting math.parser vocabs
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2003, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien arrays generic hashtables io kernel math assocs
|
||||
USING: arrays generic hashtables io kernel math assocs
|
||||
namespaces sequences strings io.styles vectors words
|
||||
prettyprint.config splitting classes continuations
|
||||
io.streams.nested accessors ;
|
||||
|
|
|
|||
|
|
@ -76,10 +76,7 @@ ARTICLE: "sequences-reshape" "Reshaping sequences"
|
|||
{ $subsection reversed }
|
||||
{ $subsection <reversed> }
|
||||
"Transposing a matrix:"
|
||||
{ $subsection flip }
|
||||
"A " { $emphasis "column" } " presents a column of a matrix represented as a sequence of rows:"
|
||||
{ $subsection column }
|
||||
{ $subsection <column> } ;
|
||||
{ $subsection flip } ;
|
||||
|
||||
ARTICLE: "sequences-appending" "Appending sequences"
|
||||
{ $subsection append }
|
||||
|
|
@ -785,23 +782,6 @@ HELP: <slice>
|
|||
|
||||
{ <slice> subseq } related-words
|
||||
|
||||
HELP: column
|
||||
{ $class-description "A virtual sequence which presents a fixed column of a matrix represented as a sequence of rows. New instances can be created by calling " { $link <column> } "." } ;
|
||||
|
||||
HELP: <column> ( seq n -- column )
|
||||
{ $values { "seq" sequence } { "n" "a non-negative integer" } { "column" column } }
|
||||
{ $description "Outputs a new virtual sequence which presents a fixed column of a matrix represented as a sequence of rows." "The " { $snippet "i" } "th element of a column is the " { $snippet "n" } "th element of the " { $snippet "i" } "th element of" { $snippet "seq" } ". Every element of " { $snippet "seq" } " must be a sequence, and all sequences must have equal length." }
|
||||
{ $examples
|
||||
{ $example
|
||||
"USING: arrays prettyprint sequences ;"
|
||||
"{ { 1 2 3 } { 4 5 6 } { 7 8 9 } } 0 <column> >array ."
|
||||
"{ 1 4 7 }"
|
||||
}
|
||||
}
|
||||
{ $notes
|
||||
"In the same sense that " { $link <reversed> } " is a virtual variant of " { $link reverse } ", " { $link <column> } " is a virtual variant of " { $snippet "swap [ nth ] curry map" } "."
|
||||
} ;
|
||||
|
||||
HELP: repetition
|
||||
{ $class-description "A virtual sequence consisting of " { $link repetition-elt } " repeated " { $link repetition-len } " times. Repetitions are created by calling " { $link <repetition> } "." } ;
|
||||
|
||||
|
|
|
|||
|
|
@ -224,13 +224,6 @@ unit-test
|
|||
[ V{ 1 2 3 } ]
|
||||
[ 3 V{ 1 3 2 } clone [ push-new ] keep ] unit-test
|
||||
|
||||
! Columns
|
||||
{ { 1 2 3 } { 4 5 6 } { 7 8 9 } } [ clone ] map "seq" set
|
||||
|
||||
[ { 1 4 7 } ] [ "seq" get 0 <column> >array ] unit-test
|
||||
[ ] [ "seq" get 1 <column> [ sq ] change-each ] unit-test
|
||||
[ { 4 25 64 } ] [ "seq" get 1 <column> >array ] unit-test
|
||||
|
||||
! erg's random tester found this one
|
||||
[ SBUF" 12341234" ] [
|
||||
9 <sbuf> dup "1234" swap push-all dup dup swap push-all
|
||||
|
|
|
|||
|
|
@ -215,18 +215,6 @@ M: slice length dup slice-to swap slice-from - ;
|
|||
|
||||
INSTANCE: slice virtual-sequence
|
||||
|
||||
! A column of a matrix
|
||||
TUPLE: column seq col ;
|
||||
|
||||
C: <column> column
|
||||
|
||||
M: column virtual-seq column-seq ;
|
||||
M: column virtual@
|
||||
dup column-col -rot column-seq nth bounds-check ;
|
||||
M: column length column-seq length ;
|
||||
|
||||
INSTANCE: column virtual-sequence
|
||||
|
||||
! One element repeated many times
|
||||
TUPLE: repetition len elt ;
|
||||
|
||||
|
|
@ -703,5 +691,5 @@ PRIVATE>
|
|||
: flip ( matrix -- newmatrix )
|
||||
dup empty? [
|
||||
dup [ length ] map infimum
|
||||
[ <column> dup like ] with map
|
||||
swap [ [ nth-unsafe ] with { } map-as ] curry { } map-as
|
||||
] unless ;
|
||||
|
|
|
|||
|
|
@ -150,18 +150,6 @@ ARTICLE: "syntax-byte-arrays" "Byte array syntax"
|
|||
{ $subsection POSTPONE: B{ }
|
||||
"Byte arrays are documented in " { $link "byte-arrays" } "." ;
|
||||
|
||||
ARTICLE: "syntax-bit-vectors" "Bit vector syntax"
|
||||
{ $subsection POSTPONE: ?V{ }
|
||||
"Bit vectors are documented in " { $link "bit-vectors" } "." ;
|
||||
|
||||
ARTICLE: "syntax-float-vectors" "Float vector syntax"
|
||||
{ $subsection POSTPONE: FV{ }
|
||||
"Float vectors are documented in " { $link "float-vectors" } "." ;
|
||||
|
||||
ARTICLE: "syntax-byte-vectors" "Byte vector syntax"
|
||||
{ $subsection POSTPONE: BV{ }
|
||||
"Byte vectors are documented in " { $link "byte-vectors" } "." ;
|
||||
|
||||
ARTICLE: "syntax-pathnames" "Pathname syntax"
|
||||
{ $subsection POSTPONE: P" }
|
||||
"Pathnames are documented in " { $link "pathnames" } "." ;
|
||||
|
|
@ -182,9 +170,6 @@ $nl
|
|||
{ $subsection "syntax-float-arrays" }
|
||||
{ $subsection "syntax-vectors" }
|
||||
{ $subsection "syntax-sbufs" }
|
||||
{ $subsection "syntax-bit-vectors" }
|
||||
{ $subsection "syntax-byte-vectors" }
|
||||
{ $subsection "syntax-float-vectors" }
|
||||
{ $subsection "syntax-hashtables" }
|
||||
{ $subsection "syntax-tuples" }
|
||||
{ $subsection "syntax-pathnames" } ;
|
||||
|
|
@ -291,30 +276,12 @@ HELP: B{
|
|||
{ $description "Marks the beginning of a literal byte array. Literal byte arrays are terminated by " { $link POSTPONE: } } "." }
|
||||
{ $examples { $code "B{ 1 2 3 }" } } ;
|
||||
|
||||
HELP: BV{
|
||||
{ $syntax "BV{ elements... }" }
|
||||
{ $values { "elements" "a list of bytes" } }
|
||||
{ $description "Marks the beginning of a literal byte vector. Literal byte vectors are terminated by " { $link POSTPONE: } } "." }
|
||||
{ $examples { $code "BV{ 1 2 3 12 }" } } ;
|
||||
|
||||
HELP: ?{
|
||||
{ $syntax "?{ elements... }" }
|
||||
{ $values { "elements" "a list of booleans" } }
|
||||
{ $description "Marks the beginning of a literal bit array. Literal bit arrays are terminated by " { $link POSTPONE: } } "." }
|
||||
{ $examples { $code "?{ t f t }" } } ;
|
||||
|
||||
HELP: ?V{
|
||||
{ $syntax "?V{ elements... }" }
|
||||
{ $values { "elements" "a list of booleans" } }
|
||||
{ $description "Marks the beginning of a literal bit vector. Literal bit vectors are terminated by " { $link POSTPONE: } } "." }
|
||||
{ $examples { $code "?V{ t f t }" } } ;
|
||||
|
||||
HELP: FV{
|
||||
{ $syntax "FV{ elements... }" }
|
||||
{ $values { "elements" "a list of real numbers" } }
|
||||
{ $description "Marks the beginning of a literal float vector. Literal float vectors are terminated by " { $link POSTPONE: } } "." }
|
||||
{ $examples { $code "FV{ 1.0 2.0 3.0 }" } } ;
|
||||
|
||||
HELP: F{
|
||||
{ $syntax "F{ elements... }" }
|
||||
{ $values { "elements" "a list of real numbers" } }
|
||||
|
|
|
|||
|
|
@ -1,10 +1,10 @@
|
|||
! Copyright (C) 2004, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien arrays bit-arrays bit-vectors byte-arrays
|
||||
byte-vectors definitions generic hashtables kernel math
|
||||
USING: alien arrays bit-arrays byte-arrays
|
||||
definitions generic hashtables kernel math
|
||||
namespaces parser sequences strings sbufs vectors words
|
||||
quotations io assocs splitting classes.tuple generic.standard
|
||||
generic.math classes io.files vocabs float-arrays float-vectors
|
||||
generic.math classes io.files vocabs float-arrays
|
||||
classes.union classes.mixin classes.predicate classes.singleton
|
||||
compiler.units combinators debugger ;
|
||||
IN: bootstrap.syntax
|
||||
|
|
@ -79,11 +79,8 @@ IN: bootstrap.syntax
|
|||
"{" [ \ } [ >array ] parse-literal ] define-syntax
|
||||
"V{" [ \ } [ >vector ] parse-literal ] define-syntax
|
||||
"B{" [ \ } [ >byte-array ] parse-literal ] define-syntax
|
||||
"BV{" [ \ } [ >byte-vector ] parse-literal ] define-syntax
|
||||
"?{" [ \ } [ >bit-array ] parse-literal ] define-syntax
|
||||
"?V{" [ \ } [ >bit-vector ] parse-literal ] define-syntax
|
||||
"F{" [ \ } [ >float-array ] parse-literal ] define-syntax
|
||||
"FV{" [ \ } [ >float-vector ] parse-literal ] define-syntax
|
||||
"H{" [ \ } [ >hashtable ] parse-literal ] define-syntax
|
||||
"T{" [ \ } [ >tuple ] parse-literal ] define-syntax
|
||||
"W{" [ \ } [ first <wrapper> ] parse-literal ] define-syntax
|
||||
|
|
|
|||
|
|
@ -26,7 +26,7 @@ ARTICLE: "threads-yield" "Yielding and suspending threads"
|
|||
{ $subsection resume }
|
||||
{ $subsection resume-with } ;
|
||||
|
||||
ARTICLE: "thread-state" "Thread-local state"
|
||||
ARTICLE: "thread-state" "Thread-local state and variables"
|
||||
"Threads form a class of objects:"
|
||||
{ $subsection thread }
|
||||
"The current thread:"
|
||||
|
|
@ -36,6 +36,8 @@ ARTICLE: "thread-state" "Thread-local state"
|
|||
{ $subsection tget }
|
||||
{ $subsection tset }
|
||||
{ $subsection tchange }
|
||||
"Each thread has its own independent set of thread-local variables and newly-spawned threads begin with an empty set."
|
||||
$nl
|
||||
"Global hashtable of all threads, keyed by " { $link thread-id } ":"
|
||||
{ $subsection threads }
|
||||
"Threads have an identity independent of continuations. If a continuation is refied in one thread and then resumed in another thread, the code running in that continuation will observe a change in the value output by " { $link self } "." ;
|
||||
|
|
|
|||
|
|
@ -1,4 +1,5 @@
|
|||
USING: namespaces io tools.test threads kernel ;
|
||||
USING: namespaces io tools.test threads kernel
|
||||
concurrency.combinators math ;
|
||||
IN: threads.tests
|
||||
|
||||
3 "x" set
|
||||
|
|
@ -16,3 +17,13 @@ yield
|
|||
] unit-test
|
||||
|
||||
[ f ] [ f get-global ] unit-test
|
||||
|
||||
{ { 0 3 6 9 12 15 18 21 24 27 } } [
|
||||
10 [
|
||||
0 "i" tset
|
||||
[
|
||||
"i" [ yield 3 + ] tchange
|
||||
] times yield
|
||||
"i" tget
|
||||
] parallel-map
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -27,7 +27,7 @@ mailbox variables sleep-entry ;
|
|||
tnamespace set-at ;
|
||||
|
||||
: tchange ( key quot -- )
|
||||
tnamespace change-at ; inline
|
||||
tnamespace swap change-at ; inline
|
||||
|
||||
: threads 41 getenv ;
|
||||
|
||||
|
|
|
|||
|
|
@ -0,0 +1,55 @@
|
|||
USING: kernel math accessors prettyprint io locals sequences
|
||||
math.ranges ;
|
||||
IN: benchmark.binary-trees
|
||||
|
||||
TUPLE: tree-node item left right ;
|
||||
|
||||
C: <tree-node> tree-node
|
||||
|
||||
: bottom-up-tree ( item depth -- tree )
|
||||
dup 0 > [
|
||||
1 -
|
||||
[ drop ]
|
||||
[ >r 2 * 1 - r> bottom-up-tree ]
|
||||
[ >r 2 * r> bottom-up-tree ] 2tri
|
||||
] [
|
||||
drop f f
|
||||
] if <tree-node> ;
|
||||
|
||||
GENERIC: item-check ( node -- n )
|
||||
|
||||
M: tree-node item-check
|
||||
[ item>> ] [ left>> ] [ right>> ] tri [ item-check ] bi@ - + ;
|
||||
|
||||
M: f item-check drop 0 ;
|
||||
|
||||
: min-depth 4 ; inline
|
||||
|
||||
: stretch-tree ( max-depth -- )
|
||||
1 + 0 over bottom-up-tree item-check
|
||||
[ "stretch tree of depth " write pprint ]
|
||||
[ "\t check: " write . ] bi* ;
|
||||
|
||||
:: long-lived-tree ( max-depth -- )
|
||||
0 max-depth bottom-up-tree
|
||||
|
||||
min-depth max-depth 2 <range> [| depth |
|
||||
max-depth depth - min-depth + 2^ [
|
||||
[1,b] 0 [
|
||||
dup neg
|
||||
[ depth bottom-up-tree item-check + ] bi@
|
||||
] reduce
|
||||
]
|
||||
[ 2 * ] bi
|
||||
pprint "\t trees of depth " write depth pprint
|
||||
"\t check: " write .
|
||||
] each
|
||||
|
||||
"long lived tree of depth " write max-depth pprint
|
||||
"\t check: " write item-check . ;
|
||||
|
||||
: binary-trees ( n -- )
|
||||
min-depth 2 + max [ stretch-tree ] [ long-lived-tree ] bi ;
|
||||
|
||||
: binary-trees-main ( -- )
|
||||
16 binary-trees ;
|
||||
|
|
@ -1,4 +1,4 @@
|
|||
USING: namespaces math sequences splitting kernel ;
|
||||
USING: namespaces math sequences splitting kernel columns ;
|
||||
IN: benchmark.dispatch2
|
||||
|
||||
: sequences
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
USING: sequences math mirrors splitting kernel namespaces
|
||||
assocs alien.syntax ;
|
||||
assocs alien.syntax columns ;
|
||||
IN: benchmark.dispatch3
|
||||
|
||||
GENERIC: g ( obj -- str )
|
||||
|
|
|
|||
|
|
@ -1,38 +1,37 @@
|
|||
USING: math kernel hints prettyprint io combinators ;
|
||||
IN: benchmark.recursive
|
||||
USING: math kernel hints prettyprint io ;
|
||||
|
||||
: fib ( m -- n )
|
||||
dup 2 < [ drop 1 ] [ dup 1 - fib swap 2 - fib + ] if ;
|
||||
dup 2 < [ drop 1 ] [ [ 1 - fib ] [ 2 - fib ] bi + ] if ;
|
||||
inline
|
||||
|
||||
: ack ( m n -- x )
|
||||
over zero? [
|
||||
nip 1+
|
||||
] [
|
||||
dup zero? [
|
||||
drop 1- 1 ack
|
||||
] [
|
||||
dupd 1- ack >r 1- r> ack
|
||||
] if
|
||||
] if ;
|
||||
{
|
||||
{ [ over zero? ] [ nip 1+ ] }
|
||||
{ [ dup zero? ] [ drop 1- 1 ack ] }
|
||||
[ [ drop 1- ] [ 1- ack ] 2bi ack ]
|
||||
} cond ; inline
|
||||
|
||||
: tak ( x y z -- t )
|
||||
2over swap < [
|
||||
[ rot 1- -rot tak ] 3keep
|
||||
[ -rot 1- -rot tak ] 3keep
|
||||
1- -rot tak
|
||||
tak
|
||||
] [
|
||||
2over <= [
|
||||
2nip
|
||||
] if ;
|
||||
] [
|
||||
[ rot 1- -rot tak ]
|
||||
[ -rot 1- -rot tak ]
|
||||
[ 1- -rot tak ]
|
||||
3tri
|
||||
tak
|
||||
] if ; inline
|
||||
|
||||
: recursive ( n -- )
|
||||
3 over ack . flush
|
||||
dup 27.0 + fib . flush
|
||||
1-
|
||||
dup 3 * over 2 * rot tak . flush
|
||||
[ 3 swap ack . flush ]
|
||||
[ 27.0 + fib . flush ]
|
||||
[ 1- [ 3 * ] [ 2 * ] [ ] tri tak . flush ] tri
|
||||
3 fib . flush
|
||||
3.0 2.0 1.0 tak . flush ;
|
||||
|
||||
HINTS: recursive fixnum ;
|
||||
|
||||
: recursive-main 11 recursive ;
|
||||
|
||||
MAIN: recursive-main
|
||||
|
|
|
|||
|
|
@ -1,48 +1,44 @@
|
|||
! Factor port of
|
||||
! http://shootout.alioth.debian.org/gp4/benchmark.php?test=spectralnorm&lang=all
|
||||
USING: float-arrays kernel math math.functions math.vectors
|
||||
sequences sequences.private prettyprint words tools.time hints ;
|
||||
sequences sequences.private prettyprint words
|
||||
hints locals ;
|
||||
IN: benchmark.spectral-norm
|
||||
|
||||
: fast-truncate >fixnum >float ; inline
|
||||
:: inner-loop ( u n quot -- seq )
|
||||
n [| i |
|
||||
n 0.0 [| j |
|
||||
u i j quot call +
|
||||
] reduce
|
||||
] F{ } map-as ; inline
|
||||
|
||||
: eval-A ( i j -- n )
|
||||
[ >float ] bi@
|
||||
dupd + dup 1+ * 2 /f fast-truncate + 1+
|
||||
recip ; inline
|
||||
[ drop ] [ + [ ] [ 1 + ] bi * 0.5 * ] 2bi
|
||||
+ 1 + recip ; inline
|
||||
|
||||
: (eval-A-times-u) ( u i j -- x )
|
||||
tuck eval-A >r swap nth-unsafe r> * ; inline
|
||||
tuck [ swap nth-unsafe ] [ eval-A ] 2bi* * ; inline
|
||||
|
||||
: eval-A-times-u ( n u -- seq )
|
||||
over [
|
||||
pick 0.0 [
|
||||
swap >r >r 2dup r> (eval-A-times-u) r> +
|
||||
] reduce nip
|
||||
] F{ } map-as 2nip ; inline
|
||||
[ (eval-A-times-u) ] inner-loop ; inline
|
||||
|
||||
: (eval-At-times-u) ( u i j -- x )
|
||||
tuck swap eval-A >r swap nth-unsafe r> * ; inline
|
||||
tuck [ swap nth-unsafe ] [ swap eval-A ] 2bi* * ; inline
|
||||
|
||||
: eval-At-times-u ( n u -- seq )
|
||||
over [
|
||||
pick 0.0 [
|
||||
swap >r >r 2dup r> (eval-At-times-u) r> +
|
||||
] reduce nip
|
||||
] F{ } map-as 2nip ; inline
|
||||
: eval-At-times-u ( u n -- seq )
|
||||
[ (eval-At-times-u) ] inner-loop ; inline
|
||||
|
||||
: eval-AtA-times-u ( n u -- seq )
|
||||
dupd eval-A-times-u eval-At-times-u ; inline
|
||||
: eval-AtA-times-u ( u n -- seq )
|
||||
[ eval-A-times-u ] [ eval-At-times-u ] bi ; inline
|
||||
|
||||
: u/v ( n -- u v )
|
||||
dup 1.0 <float-array> dup
|
||||
:: u/v ( n -- u v )
|
||||
n 1.0 <float-array> dup
|
||||
10 [
|
||||
drop
|
||||
dupd eval-AtA-times-u
|
||||
2dup eval-AtA-times-u
|
||||
swap
|
||||
] times
|
||||
rot drop ; inline
|
||||
n eval-AtA-times-u
|
||||
[ n eval-AtA-times-u ] keep
|
||||
] times ; inline
|
||||
|
||||
: spectral-norm ( n -- norm )
|
||||
u/v [ v. ] keep norm-sq /f sqrt ;
|
||||
|
|
@ -50,6 +46,6 @@ IN: benchmark.spectral-norm
|
|||
HINTS: spectral-norm fixnum ;
|
||||
|
||||
: spectral-norm-main ( -- )
|
||||
2000 spectral-norm . ;
|
||||
5500 spectral-norm . ;
|
||||
|
||||
MAIN: spectral-norm-main
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@ bit-vectors.private combinators ;
|
|||
IN: bit-vectors
|
||||
|
||||
ARTICLE: "bit-vectors" "Bit vectors"
|
||||
"A bit vector is a resizable mutable sequence of bits. The literal syntax is covered in " { $link "syntax-bit-vectors" } ". Bit vector words are found in the " { $vocab-link "bit-vectors" } " vocabulary."
|
||||
"A bit vector is a resizable mutable sequence of bits. Bit vector words are found in the " { $vocab-link "bit-vectors" } " vocabulary."
|
||||
$nl
|
||||
"Bit vectors form a class:"
|
||||
{ $subsection bit-vector }
|
||||
|
|
@ -11,13 +11,15 @@ $nl
|
|||
"Creating bit vectors:"
|
||||
{ $subsection >bit-vector }
|
||||
{ $subsection <bit-vector> }
|
||||
"Literal syntax:"
|
||||
{ $subsection POSTPONE: ?V{ }
|
||||
"If you don't care about initial capacity, a more elegant way to create a new bit vector is to write:"
|
||||
{ $code "?V{ } clone" } ;
|
||||
|
||||
ABOUT: "bit-vectors"
|
||||
|
||||
HELP: bit-vector
|
||||
{ $description "The class of resizable bit vectors. See " { $link "syntax-bit-vectors" } " for syntax and " { $link "bit-vectors" } " for general information." } ;
|
||||
{ $description "The class of resizable bit vectors. See " { $link "bit-vectors" } " for information." } ;
|
||||
|
||||
HELP: <bit-vector>
|
||||
{ $values { "n" "a positive integer specifying initial capacity" } { "bit-vector" bit-vector } }
|
||||
|
|
@ -31,3 +33,10 @@ HELP: bit-array>vector
|
|||
{ $values { "bit-array" "an array" } { "length" "a non-negative integer" } { "bit-vector" bit-vector } }
|
||||
{ $description "Creates a new bit vector using the array for underlying storage with the specified initial length." }
|
||||
{ $warning "This word is in the " { $vocab-link "bit-vectors.private" } " vocabulary because it does not perform type or bounds checks. User code should call " { $link >bit-vector } " instead." } ;
|
||||
|
||||
HELP: ?V{
|
||||
{ $syntax "?V{ elements... }" }
|
||||
{ $values { "elements" "a list of booleans" } }
|
||||
{ $description "Marks the beginning of a literal bit vector. Literal bit vectors are terminated by " { $link POSTPONE: } } "." }
|
||||
{ $examples { $code "?V{ t f t }" } } ;
|
||||
|
||||
|
|
@ -1,9 +1,20 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays kernel kernel.private math sequences
|
||||
sequences.private growable bit-arrays ;
|
||||
sequences.private growable bit-arrays prettyprint.backend
|
||||
parser accessors ;
|
||||
IN: bit-vectors
|
||||
|
||||
TUPLE: bit-vector underlying fill ;
|
||||
|
||||
M: bit-vector underlying underlying>> { bit-array } declare ;
|
||||
|
||||
M: bit-vector set-underlying (>>underlying) ;
|
||||
|
||||
M: bit-vector length fill>> { array-capacity } declare ;
|
||||
|
||||
M: bit-vector set-fill (>>fill) ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: bit-array>vector ( bit-array length -- bit-vector )
|
||||
|
|
@ -14,7 +25,8 @@ PRIVATE>
|
|||
: <bit-vector> ( n -- bit-vector )
|
||||
<bit-array> 0 bit-array>vector ; inline
|
||||
|
||||
: >bit-vector ( seq -- bit-vector ) ?V{ } clone-like ;
|
||||
: >bit-vector ( seq -- bit-vector )
|
||||
T{ bit-vector f ?{ } 0 } clone-like ;
|
||||
|
||||
M: bit-vector like
|
||||
drop dup bit-vector? [
|
||||
|
|
@ -31,3 +43,9 @@ M: bit-vector equal?
|
|||
M: bit-array new-resizable drop <bit-vector> ;
|
||||
|
||||
INSTANCE: bit-vector growable
|
||||
|
||||
: ?V{ \ } [ >bit-vector ] parse-literal ; parsing
|
||||
|
||||
M: bit-vector >pprint-sequence ;
|
||||
|
||||
M: bit-vector pprint-delims drop \ ?V{ \ } ;
|
||||
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue