merge project-euler.factor
Guillaume Nargeot
commit
f97ede3d91
14
Makefile
14
Makefile
|
|
@ -31,6 +31,7 @@ ifdef CONFIG
|
|||
endif
|
||||
|
||||
DLL_OBJS = $(PLAF_DLL_OBJS) \
|
||||
vm/aging_collector.o \
|
||||
vm/alien.o \
|
||||
vm/arrays.o \
|
||||
vm/bignum.o \
|
||||
|
|
@ -38,30 +39,33 @@ DLL_OBJS = $(PLAF_DLL_OBJS) \
|
|||
vm/byte_arrays.o \
|
||||
vm/callstack.o \
|
||||
vm/code_block.o \
|
||||
vm/code_gc.o \
|
||||
vm/code_heap.o \
|
||||
vm/contexts.o \
|
||||
vm/data_gc.o \
|
||||
vm/data_heap.o \
|
||||
vm/debug.o \
|
||||
vm/dispatch.o \
|
||||
vm/errors.o \
|
||||
vm/factor.o \
|
||||
vm/full_collector.o \
|
||||
vm/gc.o \
|
||||
vm/heap.o \
|
||||
vm/image.o \
|
||||
vm/inline_cache.o \
|
||||
vm/io.o \
|
||||
vm/jit.o \
|
||||
vm/local_roots.o \
|
||||
vm/math.o \
|
||||
vm/nursery_collector.o \
|
||||
vm/old_space.o \
|
||||
vm/primitives.o \
|
||||
vm/profiler.o \
|
||||
vm/quotations.o \
|
||||
vm/run.o \
|
||||
vm/strings.o \
|
||||
vm/to_tenured_collector.o \
|
||||
vm/tuples.o \
|
||||
vm/utilities.o \
|
||||
vm/words.o \
|
||||
vm/write_barrier.o
|
||||
vm/vm.o \
|
||||
vm/words.o
|
||||
|
||||
EXE_OBJS = $(PLAF_EXE_OBJS)
|
||||
|
||||
|
|
|
|||
154
README.txt
154
README.txt
|
|
@ -1,154 +0,0 @@
|
|||
The Factor programming language
|
||||
-------------------------------
|
||||
|
||||
This file covers installation and basic usage of the Factor
|
||||
implementation. It is not an introduction to the language itself.
|
||||
|
||||
* Contents
|
||||
|
||||
- Compiling the Factor VM
|
||||
- Libraries needed for compilation
|
||||
- Bootstrapping the Factor image
|
||||
- Running Factor on Unix with X11
|
||||
- Running Factor on Mac OS X - Cocoa UI
|
||||
- Running Factor on Mac OS X - X11 UI
|
||||
- Running Factor on Windows
|
||||
- Command line usage
|
||||
- The Factor FAQ
|
||||
- Source organization
|
||||
- Community
|
||||
|
||||
* Compiling the Factor VM
|
||||
|
||||
Factor supports various platforms. For an up-to-date list, see
|
||||
<http://factorcode.org>.
|
||||
|
||||
The Factor VM is written in C++ and uses GNU extensions. When compiling
|
||||
with GCC 3.x, boost::unordered_map must be installed. On GCC 4.x, Factor
|
||||
uses std::tr1::unordered_map which is shipped as part of GCC.
|
||||
|
||||
Run 'make' ('gmake' on *BSD) with no parameters to build the Factor VM.
|
||||
|
||||
* Bootstrapping the Factor image
|
||||
|
||||
Once you have compiled the Factor VM, you must bootstrap the Factor
|
||||
system using the image that corresponds to your CPU architecture.
|
||||
|
||||
Boot images can be obtained from <http://factorcode.org/images/latest/>.
|
||||
|
||||
Once you download the right image, bootstrap Factor with the
|
||||
following command line:
|
||||
|
||||
./factor -i=boot.<cpu>.image
|
||||
|
||||
Bootstrap can take a while, depending on your system. When the process
|
||||
completes, a 'factor.image' file will be generated. Note that this image
|
||||
is both CPU and OS-specific, so in general cannot be shared between
|
||||
machines.
|
||||
|
||||
* Running Factor on Unix with X11
|
||||
|
||||
On Unix, Factor can either run a graphical user interface using X11, or
|
||||
a terminal listener.
|
||||
|
||||
For X11 support, you need recent development libraries for libc,
|
||||
Pango, X11, and OpenGL. On a Debian-derived Linux distribution
|
||||
(like Ubuntu), you can use the following line to grab everything:
|
||||
|
||||
sudo apt-get install libc6-dev libpango1.0-dev libx11-dev libgl1-mesa-dev
|
||||
|
||||
Note that if you are using a proprietary OpenGL driver, you should
|
||||
probably leave out the last package in the list.
|
||||
|
||||
If your DISPLAY environment variable is set, the UI will start
|
||||
automatically when you run Factor:
|
||||
|
||||
./factor
|
||||
|
||||
To run an interactive terminal listener:
|
||||
|
||||
./factor -run=listener
|
||||
|
||||
* Running Factor on Mac OS X - Cocoa UI
|
||||
|
||||
On Mac OS X, a Cocoa UI is available in addition to the terminal
|
||||
listener.
|
||||
|
||||
The 'factor' executable runs the terminal listener:
|
||||
|
||||
./factor
|
||||
|
||||
The 'Factor.app' bundle runs the Cocoa UI. Note that this is not a
|
||||
self-contained bundle, it must be run from the same directory which
|
||||
contains factor.image and the library sources.
|
||||
|
||||
* Running Factor on Mac OS X - X11 UI
|
||||
|
||||
The X11 UI is also available on Mac OS X, however its use is not
|
||||
recommended since it does not integrate with the host OS.
|
||||
|
||||
When compiling Factor, pass the X11=1 parameter:
|
||||
|
||||
make X11=1
|
||||
|
||||
Then bootstrap with the following switches:
|
||||
|
||||
./factor -i=boot.<cpu>.image -ui-backend=x11
|
||||
|
||||
Now if $DISPLAY is set, running ./factor will start the UI.
|
||||
|
||||
* Running Factor on Windows XP/Vista
|
||||
|
||||
The Factor runtime is compiled into two binaries:
|
||||
|
||||
factor.com - a Windows console application
|
||||
factor.exe - a Windows native application, without a console
|
||||
|
||||
If you did not download the binary package, you can bootstrap Factor in
|
||||
the command prompt using the console application:
|
||||
|
||||
factor.com -i=boot.<cpu>.image
|
||||
|
||||
Once bootstrapped, double-clicking factor.exe or factor.com starts
|
||||
the Factor UI.
|
||||
|
||||
To run the listener in the command prompt:
|
||||
|
||||
factor.com -run=listener
|
||||
|
||||
* The Factor FAQ
|
||||
|
||||
The Factor FAQ is available at the following location:
|
||||
|
||||
<http://concatenative.org/wiki/view/Factor/FAQ>
|
||||
|
||||
* Command line usage
|
||||
|
||||
Factor supports a number of command line switches. To read command line
|
||||
usage documentation, enter the following in the UI listener:
|
||||
|
||||
"command-line" about
|
||||
|
||||
* Source organization
|
||||
|
||||
The Factor source tree is organized as follows:
|
||||
|
||||
build-support/ - scripts used for compiling Factor
|
||||
vm/ - Factor VM
|
||||
core/ - Factor core library
|
||||
basis/ - Factor basis library, compiler, tools
|
||||
extra/ - more libraries and applications
|
||||
misc/ - editor modes, icons, etc
|
||||
unmaintained/ - unmaintained contributions, please help!
|
||||
|
||||
* Community
|
||||
|
||||
The Factor homepage is located at <http://factorcode.org/>.
|
||||
|
||||
Factor developers meet in the #concatenative channel on the
|
||||
irc.freenode.net server. Drop by if you want to discuss anything related
|
||||
to Factor or language design in general.
|
||||
|
||||
Have fun!
|
||||
|
||||
:tabSize=2:indentSize=2:noTabs=true:
|
||||
|
|
@ -24,10 +24,12 @@ HELP: every
|
|||
|
||||
ARTICLE: "alarms" "Alarms"
|
||||
"The " { $vocab-link "alarms" } " vocabulary provides a lightweight way to schedule one-time and recurring tasks without spawning a new thread."
|
||||
{ $subsection alarm }
|
||||
{ $subsection add-alarm }
|
||||
{ $subsection later }
|
||||
{ $subsection cancel-alarm }
|
||||
{ $subsections
|
||||
alarm
|
||||
add-alarm
|
||||
later
|
||||
cancel-alarm
|
||||
}
|
||||
"Alarms do not persist across image saves. Saving and restoring an image has the effect of calling " { $link cancel-alarm } " on all " { $link alarm } " instances." ;
|
||||
|
||||
ABOUT: "alarms"
|
||||
|
|
|
|||
|
|
@ -1,12 +0,0 @@
|
|||
USING: help.syntax help.markup byte-arrays alien.c-types alien.data ;
|
||||
IN: alien.arrays
|
||||
|
||||
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" } "."
|
||||
$nl
|
||||
"C type specifiers for array types are documented in " { $link "c-types-specs" } "."
|
||||
$nl
|
||||
"Specialized sequences are provided for accessing memory as an array of primitive type values. These sequences are implemented in the " { $vocab-link "specialized-arrays" } " vocabulary set. They can also be loaded and constructed through their primitive C types:"
|
||||
{ $subsection require-c-array }
|
||||
{ $subsection <c-array> }
|
||||
{ $subsection <c-direct-array> } ;
|
||||
|
|
@ -3,6 +3,7 @@ byte-arrays strings hashtables alien.syntax alien.strings sequences
|
|||
io.encodings.string debugger destructors vocabs.loader
|
||||
classes.struct ;
|
||||
QUALIFIED: math
|
||||
QUALIFIED: sequences
|
||||
IN: alien.c-types
|
||||
|
||||
HELP: byte-length
|
||||
|
|
@ -10,25 +11,24 @@ HELP: byte-length
|
|||
{ $contract "Outputs the size of the byte array, struct, or specialized array data in bytes." } ;
|
||||
|
||||
HELP: heap-size
|
||||
{ $values { "type" string } { "size" math:integer } }
|
||||
{ $values { "name" "a C type name" } { "size" math:integer } }
|
||||
{ $description "Outputs the number of bytes needed for a heap-allocated value of this C type." }
|
||||
{ $examples
|
||||
"On a 32-bit system, you will get the following output:"
|
||||
{ $unchecked-example "USE: alien\n\"void*\" heap-size ." "4" }
|
||||
{ $example "USING: alien alien.c-types prettyprint ;\nint heap-size ." "4" }
|
||||
}
|
||||
{ $errors "Throws a " { $link no-c-type } " error if the type does not exist." } ;
|
||||
|
||||
HELP: stack-size
|
||||
{ $values { "type" string } { "size" math:integer } }
|
||||
{ $values { "name" "a C type name" } { "size" math:integer } }
|
||||
{ $description "Outputs the number of bytes to reserve on the C stack by a value of this C type. In most cases this is equal to " { $link heap-size } ", except on some platforms where C structs are passed by invisible reference, in which case a C struct type only uses as much space as a pointer on the C stack." }
|
||||
{ $errors "Throws a " { $link no-c-type } " error if the type does not exist." } ;
|
||||
|
||||
HELP: <c-type>
|
||||
{ $values { "type" hashtable } }
|
||||
{ $values { "c-type" c-type } }
|
||||
{ $description "Creates a prototypical C type. User code should use higher-level facilities to define C types; see " { $link "c-data" } "." } ;
|
||||
|
||||
HELP: no-c-type
|
||||
{ $values { "type" string } }
|
||||
{ $values { "name" "a C type name" } }
|
||||
{ $description "Throws a " { $link no-c-type } " error." }
|
||||
{ $error-description "Thrown by " { $link c-type } " if a given string does not name a C type. When thrown during compile time, indicates a typo in an " { $link alien-invoke } " or " { $link alien-callback } " form." } ;
|
||||
|
||||
|
|
@ -36,32 +36,32 @@ HELP: c-types
|
|||
{ $var-description "Global variable holding a hashtable mapping C type names to C types. Use the " { $link c-type } " word to look up C types." } ;
|
||||
|
||||
HELP: c-type
|
||||
{ $values { "name" string } { "type" hashtable } }
|
||||
{ $values { "name" "a C type" } { "c-type" c-type } }
|
||||
{ $description "Looks up a C type by name." }
|
||||
{ $errors "Throws a " { $link no-c-type } " error if the type does not exist." } ;
|
||||
|
||||
HELP: c-getter
|
||||
{ $values { "name" string } { "quot" { $quotation "( c-ptr n -- obj )" } } }
|
||||
{ $values { "name" "a C type" } { "quot" { $quotation "( c-ptr n -- obj )" } } }
|
||||
{ $description "Outputs a quotation which reads values of this C type from a C structure." }
|
||||
{ $errors "Throws a " { $link no-c-type } " error if the type does not exist." } ;
|
||||
|
||||
HELP: c-setter
|
||||
{ $values { "name" string } { "quot" { $quotation "( obj c-ptr n -- )" } } }
|
||||
{ $values { "name" "a C type" } { "quot" { $quotation "( obj c-ptr n -- )" } } }
|
||||
{ $description "Outputs a quotation which writes values of this C type to a C structure." }
|
||||
{ $errors "Throws an error if the type does not exist." } ;
|
||||
|
||||
HELP: box-parameter
|
||||
{ $values { "n" math:integer } { "ctype" string } }
|
||||
{ $values { "n" math:integer } { "c-type" "a C type" } }
|
||||
{ $description "Generates code for converting a C value stored at offset " { $snippet "n" } " from the top of the stack into a Factor object to be pushed on the data stack." }
|
||||
{ $notes "This is an internal word used by the compiler when compiling callbacks." } ;
|
||||
|
||||
HELP: box-return
|
||||
{ $values { "ctype" string } }
|
||||
{ $values { "c-type" "a C type" } }
|
||||
{ $description "Generates code for converting a C value stored in return registers into a Factor object to be pushed on the data stack." }
|
||||
{ $notes "This is an internal word used by the compiler when compiling alien calls." } ;
|
||||
|
||||
HELP: unbox-return
|
||||
{ $values { "ctype" string } }
|
||||
{ $values { "c-type" "a C type" } }
|
||||
{ $description "Generates code for converting a Factor value on the data stack into a C value to be stored in the return registers." }
|
||||
{ $notes "This is an internal word used by the compiler when compiling callbacks." } ;
|
||||
|
||||
|
|
@ -89,16 +89,24 @@ HELP: uint
|
|||
{ $description "This C type represents a four-byte unsigned integer type. Input values will be converted to " { $link math:integer } "s and truncated to 32 bits; output values will be returned as " { $link math:integer } "s." } ;
|
||||
HELP: long
|
||||
{ $description "This C type represents a four- or eight-byte signed integer type. On Windows and on 32-bit Unix platforms, it will be four bytes. On 64-bit Unix platforms, it will be eight bytes. Input values will be converted to " { $link math:integer } "s and truncated to 32 or 64 bits; output values will be returned as " { $link math:integer } "s." } ;
|
||||
HELP: intptr_t
|
||||
{ $description "This C type represents a signed integer type large enough to hold any pointer value; that is, on 32-bit platforms, it will be four bytes, and on 64-bit platforms, it will be eight bytes. Input values will be converted to " { $link math:integer } "s and truncated to 32 or 64 bits; output values will be returned as " { $link math:integer } "s." } ;
|
||||
HELP: ulong
|
||||
{ $description "This C type represents a four- or eight-byte unsigned integer type. On Windows and on 32-bit Unix platforms, it will be four bytes. On 64-bit Unix platforms, it will be eight bytes. Input values will be converted to " { $link math:integer } "s and truncated to 32 or 64 bits; output values will be returned as " { $link math:integer } "s." } ;
|
||||
HELP: uintptr_t
|
||||
{ $description "This C type represents an unsigned integer type large enough to hold any pointer value; that is, on 32-bit platforms, it will be four bytes, and on 64-bit platforms, it will be eight bytes. Input values will be converted to " { $link math:integer } "s and truncated to 32 or 64 bits; output values will be returned as " { $link math:integer } "s." } ;
|
||||
HELP: ptrdiff_t
|
||||
{ $description "This C type represents a signed integer type large enough to hold the distance between two pointer values; that is, on 32-bit platforms, it will be four bytes, and on 64-bit platforms, it will be eight bytes. Input values will be converted to " { $link math:integer } "s and truncated to 32 or 64 bits; output values will be returned as " { $link math:integer } "s." } ;
|
||||
HELP: size_t
|
||||
{ $description "This C type represents unsigned size values of the size expected by the platform's standard C library (usually four bytes on a 32-bit platform, and eight on a 64-bit platform). Input values will be converted to " { $link math:integer } "s and truncated to the appropriate size; output values will be returned as " { $link math:integer } "s." } ;
|
||||
HELP: longlong
|
||||
{ $description "This C type represents an eight-byte signed integer type. Input values will be converted to " { $link math:integer } "s and truncated to 64 bits; output values will be returned as " { $link math:integer } "s." } ;
|
||||
HELP: ulonglong
|
||||
{ $description "This C type represents an eight-byte unsigned integer type. Input values will be converted to " { $link math:integer } "s and truncated to 64 bits; output values will be returned as " { $link math:integer } "s." } ;
|
||||
HELP: void
|
||||
{ $description "This symbol is not a valid C type, but it can be used as the return type for a " { $link POSTPONE: FUNCTION: } " or " { $link POSTPONE: CALLBACK: } " definition, or an " { $link alien-invoke } " or " { $link alien-callback } " call." } ;
|
||||
{ $description "This symbol is not a valid C type, but it can be used as the return type for a " { $link POSTPONE: FUNCTION: } " or " { $link POSTPONE: CALLBACK: } " definition or for an " { $link alien-invoke } " or " { $link alien-callback } " call." } ;
|
||||
HELP: void*
|
||||
{ $description "This C type represents a pointer to C memory. " { $link byte-array } " and " { $link alien } " values can be passed as inputs, but see " { $link "byte-arrays-gc" } " for notes about passing byte arrays into C functions. Output values are returned as " { $link alien } "s." } ;
|
||||
{ $description "This C type represents a pointer to C memory. " { $link byte-array } " and " { $link alien } " values can be passed as " { $snippet "void*" } " function inputs, but see " { $link "byte-arrays-gc" } " for notes about passing byte arrays into C functions. " { $snippet "void*" } " output values are returned as " { $link alien } "s." } ;
|
||||
HELP: char*
|
||||
{ $description "This C type represents a pointer to a C string. See " { $link "c-strings" } " for details about using strings with the FFI." } ;
|
||||
HELP: float
|
||||
|
|
@ -128,39 +136,41 @@ ARTICLE: "c-out-params" "Output parameters in C"
|
|||
"A frequently-occurring idiom in C code is the \"out parameter\". If a C function returns more than one value, the caller passes pointers of the correct type, and the C function writes its return values to those locations."
|
||||
$nl
|
||||
"Each numerical C type, together with " { $snippet "void*" } ", has an associated " { $emphasis "out parameter constructor" } " word which takes a Factor object as input, constructs a byte array of the correct size, and converts the Factor object to a C value stored into the byte array:"
|
||||
{ $subsection <char> }
|
||||
{ $subsection <uchar> }
|
||||
{ $subsection <short> }
|
||||
{ $subsection <ushort> }
|
||||
{ $subsection <int> }
|
||||
{ $subsection <uint> }
|
||||
{ $subsection <long> }
|
||||
{ $subsection <ulong> }
|
||||
{ $subsection <longlong> }
|
||||
{ $subsection <ulonglong> }
|
||||
{ $subsection <float> }
|
||||
{ $subsection <double> }
|
||||
{ $subsection <void*> }
|
||||
{ $subsections
|
||||
<char>
|
||||
<uchar>
|
||||
<short>
|
||||
<ushort>
|
||||
<int>
|
||||
<uint>
|
||||
<long>
|
||||
<ulong>
|
||||
<longlong>
|
||||
<ulonglong>
|
||||
<float>
|
||||
<double>
|
||||
<void*>
|
||||
}
|
||||
"You call the out parameter constructor with the required initial value, then pass the byte array to the C function, which receives a pointer to the start of the byte array's data area. The C function then returns, leaving the result in the byte array; you read it back using the next set of words:"
|
||||
{ $subsection *char }
|
||||
{ $subsection *uchar }
|
||||
{ $subsection *short }
|
||||
{ $subsection *ushort }
|
||||
{ $subsection *int }
|
||||
{ $subsection *uint }
|
||||
{ $subsection *long }
|
||||
{ $subsection *ulong }
|
||||
{ $subsection *longlong }
|
||||
{ $subsection *ulonglong }
|
||||
{ $subsection *float }
|
||||
{ $subsection *double }
|
||||
{ $subsection *void* }
|
||||
{ $subsections
|
||||
*char
|
||||
*uchar
|
||||
*short
|
||||
*ushort
|
||||
*int
|
||||
*uint
|
||||
*long
|
||||
*ulong
|
||||
*longlong
|
||||
*ulonglong
|
||||
*float
|
||||
*double
|
||||
*void*
|
||||
}
|
||||
"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"
|
||||
"C types are identified by special words, and type names occur as parameters to the " { $link alien-invoke } ", " { $link alien-indirect } " and " { $link alien-callback } " words. New C types can be defined by the words " { $link POSTPONE: STRUCT: } ", " { $link POSTPONE: UNION-STRUCT: } ", " { $link POSTPONE: CALLBACK: } ", and " { $link POSTPONE: TYPEDEF: } "."
|
||||
$nl
|
||||
"The following numerical types are available; a " { $snippet "u" } " prefix denotes an unsigned type:"
|
||||
ARTICLE: "c-types.primitives" "Primitive C types"
|
||||
"The following numerical types are defined in the " { $vocab-link "alien.c-types" } " vocabulary; a " { $snippet "u" } " prefix denotes an unsigned type:"
|
||||
{ $table
|
||||
{ "C type" "Notes" }
|
||||
{ { $link char } "always 1 byte" }
|
||||
|
|
@ -175,15 +185,68 @@ $nl
|
|||
{ { $link ulonglong } { } }
|
||||
{ { $link float } { "single-precision float (not the same as Factor's " { $link math:float } " class!)" } }
|
||||
{ { $link double } { "double-precision float (the same format as Factor's " { $link math:float } " objects)" } }
|
||||
}
|
||||
"The following C99 complex number types are defined in the " { $vocab-link "alien.complex" } " vocabulary:"
|
||||
{ $table
|
||||
{ { $link complex-float } { "C99 or Fortran " { $snippet "complex float" } " type, converted to and from Factor " { $link math:complex } " values" } }
|
||||
{ { $link complex-double } { "C99 or Fortran " { $snippet "complex double" } " type, converted to and from Factor " { $link math:complex } " values" } }
|
||||
}
|
||||
"When making alien calls, Factor numbers are converted to and from the above types in a canonical way. Converting a Factor number to a C value may result in a loss of precision."
|
||||
$nl
|
||||
"When making alien calls, Factor numbers are converted to and from the above types in a canonical way. Converting a Factor number to a C value may result in a loss of precision." ;
|
||||
|
||||
ARTICLE: "c-types.pointers" "Pointer and array types"
|
||||
"Pointer types are specified by suffixing a C type with " { $snippet "*" } ", for example " { $snippet "float*" } ". One special case is " { $link void* } ", which denotes a generic pointer; " { $link void } " by itself is not a valid C type specifier. With the exception of strings (see " { $link "c-strings" } "), all pointer types are identical to " { $snippet "void*" } " as far as the C library interface is concerned."
|
||||
$nl
|
||||
"Fixed-size array types are supported; the syntax consists of a C type name followed by dimension sizes in brackets; the following denotes a 3 by 4 array of integers:"
|
||||
{ $code "int[3][4]" }
|
||||
"Fixed-size arrays differ from pointers in that they are allocated inside structures and unions; however when used as function parameters they behave exactly like pointers and thus the dimensions only serve as documentation."
|
||||
"Fixed-size arrays differ from pointers in that they are allocated inside structures and unions; however when used as function parameters they behave exactly like pointers and thus the dimensions only serve as documentation." ;
|
||||
|
||||
ARTICLE: "c-types.ambiguity" "Word name clashes with C types"
|
||||
"Note that some of the C type word names clash with commonly-used Factor words:"
|
||||
{ $list
|
||||
{ { $link short } " clashes with the " { $link sequences:short } " word in the " { $vocab-link "sequences" } " vocabulary" }
|
||||
{ { $link float } " clashes with the " { $link math:float } " word in the " { $vocab-link "math" } " vocabulary" }
|
||||
}
|
||||
"If you use the wrong vocabulary, you will see a " { $link no-c-type } " error. For example, the following is " { $strong "not" } " valid, and will raise an error because the " { $link math:float } " word from the " { $vocab-link "math" } " vocabulary is not a C type:"
|
||||
{ $code
|
||||
"USING: alien.syntax math prettyprint ;"
|
||||
"FUNCTION: float magic_number ( ) ;"
|
||||
"magic_number 3.0 + ."
|
||||
}
|
||||
"The following won't work either; now the problem is that there are two vocabularies in the search path that define a word named " { $snippet "float" } ":"
|
||||
{ $code
|
||||
"USING: alien.c-types alien.syntax math prettyprint ;"
|
||||
"FUNCTION: float magic_number ( ) ;"
|
||||
"magic_number 3.0 + ."
|
||||
}
|
||||
"The correct solution is to use one of " { $link POSTPONE: FROM: } ", " { $link POSTPONE: QUALIFIED: } " or " { $link POSTPONE: QUALIFIED-WITH: } " to disambiguate word lookup:"
|
||||
{ $code
|
||||
"USING: alien.syntax math prettyprint ;"
|
||||
"QUALIFIED-WITH: alien.c-types c"
|
||||
"FUNCTION: c:float magic_number ( ) ;"
|
||||
"magic_number 3.0 + ."
|
||||
}
|
||||
"See " { $link "word-search-semantics" } " for details." ;
|
||||
|
||||
ARTICLE: "c-types.structs" "Struct and union types"
|
||||
"Struct and union types are identified by their class word. See " { $link "classes.struct" } "." ;
|
||||
|
||||
ARTICLE: "c-types-specs" "C type specifiers"
|
||||
"C types are identified by special words, and type names occur as parameters to the " { $link alien-invoke } ", " { $link alien-indirect } " and " { $link alien-callback } " words."
|
||||
$nl
|
||||
"Structure and union types are specified by the name of the structure or union." ;
|
||||
"Defining new C types:"
|
||||
{ $subsections
|
||||
POSTPONE: STRUCT:
|
||||
POSTPONE: UNION-STRUCT:
|
||||
POSTPONE: CALLBACK:
|
||||
POSTPONE: TYPEDEF:
|
||||
}
|
||||
{ $heading "Related articles" }
|
||||
{ $subsections
|
||||
"c-types.primitives"
|
||||
"c-types.pointers"
|
||||
"c-types.ambiguity"
|
||||
"c-types.structs"
|
||||
}
|
||||
;
|
||||
|
||||
ABOUT: "c-types-specs"
|
||||
|
|
|
|||
|
|
@ -1,49 +1,50 @@
|
|||
USING: alien alien.syntax alien.c-types kernel tools.test
|
||||
sequences system libc alien.strings io.encodings.utf8 ;
|
||||
USING: alien alien.syntax alien.c-types alien.parser
|
||||
eval kernel tools.test sequences system libc alien.strings
|
||||
io.encodings.utf8 math.constants classes.struct classes ;
|
||||
IN: alien.c-types.tests
|
||||
|
||||
CONSTANT: xyz 123
|
||||
|
||||
[ 492 ] [ { "int" xyz } heap-size ] unit-test
|
||||
[ 492 ] [ { int xyz } heap-size ] unit-test
|
||||
|
||||
[ -1 ] [ -1 <char> *char ] unit-test
|
||||
[ -1 ] [ -1 <short> *short ] unit-test
|
||||
[ -1 ] [ -1 <int> *int ] unit-test
|
||||
|
||||
C-UNION: foo
|
||||
"int"
|
||||
"int" ;
|
||||
UNION-STRUCT: foo
|
||||
{ a int }
|
||||
{ b int } ;
|
||||
|
||||
[ f ] [ "char*" c-type "void*" c-type eq? ] unit-test
|
||||
[ t ] [ "char**" c-type "void*" c-type eq? ] unit-test
|
||||
[ f ] [ char resolve-pointer-type c-type void* c-type eq? ] unit-test
|
||||
[ t ] [ char* resolve-pointer-type c-type void* c-type eq? ] unit-test
|
||||
|
||||
[ t ] [ "foo" heap-size "int" heap-size = ] unit-test
|
||||
[ t ] [ foo heap-size int heap-size = ] unit-test
|
||||
|
||||
TYPEDEF: int MyInt
|
||||
|
||||
[ t ] [ "int" c-type "MyInt" c-type eq? ] unit-test
|
||||
[ t ] [ "void*" c-type "MyInt*" c-type eq? ] unit-test
|
||||
[ t ] [ int c-type MyInt c-type eq? ] unit-test
|
||||
[ t ] [ void* c-type MyInt resolve-pointer-type c-type eq? ] unit-test
|
||||
|
||||
TYPEDEF: char MyChar
|
||||
|
||||
[ t ] [ "char" c-type "MyChar" c-type eq? ] unit-test
|
||||
[ f ] [ "void*" c-type "MyChar*" c-type eq? ] unit-test
|
||||
[ t ] [ "char*" c-type "MyChar*" c-type eq? ] unit-test
|
||||
[ t ] [ char c-type MyChar c-type eq? ] unit-test
|
||||
[ f ] [ void* c-type MyChar resolve-pointer-type c-type eq? ] unit-test
|
||||
[ t ] [ char* c-type MyChar resolve-pointer-type c-type eq? ] unit-test
|
||||
|
||||
[ 32 ] [ { "int" 8 } heap-size ] unit-test
|
||||
[ 32 ] [ { int 8 } heap-size ] unit-test
|
||||
|
||||
TYPEDEF: char* MyString
|
||||
|
||||
[ t ] [ "char*" c-type "MyString" c-type eq? ] unit-test
|
||||
[ t ] [ "void*" c-type "MyString*" c-type eq? ] unit-test
|
||||
[ t ] [ char* c-type MyString c-type eq? ] unit-test
|
||||
[ t ] [ void* c-type MyString resolve-pointer-type c-type eq? ] unit-test
|
||||
|
||||
TYPEDEF: int* MyIntArray
|
||||
|
||||
[ t ] [ "void*" c-type "MyIntArray" c-type eq? ] unit-test
|
||||
[ t ] [ void* c-type MyIntArray c-type eq? ] unit-test
|
||||
|
||||
TYPEDEF: uchar* MyLPBYTE
|
||||
|
||||
[ t ] [ { char* utf8 } c-type "MyLPBYTE" c-type = ] unit-test
|
||||
[ t ] [ { char* utf8 } c-type MyLPBYTE c-type = ] unit-test
|
||||
|
||||
[
|
||||
0 B{ 1 2 3 4 } <displaced-alien> <void*>
|
||||
|
|
@ -52,3 +53,50 @@ TYPEDEF: uchar* MyLPBYTE
|
|||
os windows? cpu x86.64? and [
|
||||
[ -2147467259 ] [ 2147500037 <long> *long ] unit-test
|
||||
] when
|
||||
|
||||
[ 0 ] [ -10 uchar c-type-clamp ] unit-test
|
||||
[ 12 ] [ 12 uchar c-type-clamp ] unit-test
|
||||
[ -10 ] [ -10 char c-type-clamp ] unit-test
|
||||
[ 127 ] [ 230 char c-type-clamp ] unit-test
|
||||
[ t ] [ pi dup float c-type-clamp = ] unit-test
|
||||
|
||||
C-TYPE: opaque
|
||||
|
||||
[ t ] [ void* c-type opaque resolve-pointer-type c-type eq? ] unit-test
|
||||
[ opaque c-type ] [ no-c-type? ] must-fail-with
|
||||
|
||||
[ """
|
||||
USING: alien.syntax ;
|
||||
IN: alien.c-types.tests
|
||||
FUNCTION: opaque return_opaque ( ) ;
|
||||
""" eval( -- ) ] [ no-c-type? ] must-fail-with
|
||||
|
||||
C-TYPE: forward
|
||||
STRUCT: backward { x forward* } ;
|
||||
STRUCT: forward { x backward* } ;
|
||||
|
||||
[ t ] [ forward c-type struct-c-type? ] unit-test
|
||||
[ t ] [ backward c-type struct-c-type? ] unit-test
|
||||
|
||||
DEFER: struct-redefined
|
||||
|
||||
[ f ]
|
||||
[
|
||||
|
||||
"""
|
||||
USING: alien.c-types classes.struct ;
|
||||
IN: alien.c-types.tests
|
||||
|
||||
STRUCT: struct-redefined { x int } ;
|
||||
""" eval( -- )
|
||||
|
||||
"""
|
||||
USING: alien.syntax ;
|
||||
IN: alien.c-types.tests
|
||||
|
||||
C-TYPE: struct-redefined
|
||||
""" eval( -- )
|
||||
|
||||
\ struct-redefined class?
|
||||
] unit-test
|
||||
|
||||
|
|
|
|||
|
|
@ -1,11 +1,12 @@
|
|||
! Copyright (C) 2004, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: byte-arrays arrays assocs kernel kernel.private math
|
||||
namespaces make parser sequences strings words splitting math.parser
|
||||
cpu.architecture alien alien.accessors alien.strings quotations
|
||||
layouts system compiler.units io io.files io.encodings.binary
|
||||
io.streams.memory accessors combinators effects continuations fry
|
||||
classes vocabs vocabs.loader words.symbol ;
|
||||
math.order math.parser namespaces make parser sequences strings
|
||||
words splitting cpu.architecture alien alien.accessors
|
||||
alien.strings quotations layouts system compiler.units io
|
||||
io.files io.encodings.binary io.streams.memory accessors
|
||||
combinators effects continuations fry classes vocabs
|
||||
vocabs.loader words.symbol ;
|
||||
QUALIFIED: math
|
||||
IN: alien.c-types
|
||||
|
||||
|
|
@ -38,8 +39,8 @@ unboxer
|
|||
{ rep initial: int-rep }
|
||||
stack-align? ;
|
||||
|
||||
: <c-type> ( -- type )
|
||||
\ c-type new ;
|
||||
: <c-type> ( -- c-type )
|
||||
\ c-type new ; inline
|
||||
|
||||
SYMBOL: c-types
|
||||
|
||||
|
|
@ -55,13 +56,19 @@ PREDICATE: c-type-word < word
|
|||
UNION: c-type-name string c-type-word ;
|
||||
|
||||
! C type protocol
|
||||
GENERIC: c-type ( name -- type ) foldable
|
||||
GENERIC: c-type ( name -- c-type ) foldable
|
||||
|
||||
GENERIC: resolve-pointer-type ( name -- c-type )
|
||||
|
||||
<< \ void \ void* "pointer-c-type" set-word-prop >>
|
||||
|
||||
: void? ( c-type -- ? )
|
||||
{ void "void" } member? ;
|
||||
|
||||
M: word resolve-pointer-type
|
||||
dup "pointer-c-type" word-prop
|
||||
[ ] [ drop void* ] ?if ;
|
||||
|
||||
M: string resolve-pointer-type
|
||||
dup "*" append dup c-types get at
|
||||
[ nip ] [
|
||||
|
|
@ -70,14 +77,15 @@ M: string resolve-pointer-type
|
|||
[ resolve-pointer-type ] [ drop void* ] if
|
||||
] if ;
|
||||
|
||||
: resolve-typedef ( name -- type )
|
||||
: resolve-typedef ( name -- c-type )
|
||||
dup void? [ no-c-type ] when
|
||||
dup c-type-name? [ c-type ] when ;
|
||||
|
||||
: parse-array-type ( name -- dims type )
|
||||
: parse-array-type ( name -- dims c-type )
|
||||
"[" split unclip
|
||||
[ [ "]" ?tail drop string>number ] map ] dip ;
|
||||
|
||||
M: string c-type ( name -- type )
|
||||
M: string c-type ( name -- c-type )
|
||||
CHAR: ] over member? [
|
||||
parse-array-type prefix
|
||||
] [
|
||||
|
|
@ -87,12 +95,10 @@ M: string c-type ( name -- type )
|
|||
] if ;
|
||||
|
||||
M: word c-type
|
||||
"c-type" word-prop resolve-typedef ;
|
||||
dup "c-type" word-prop resolve-typedef
|
||||
[ ] [ no-c-type ] ?if ;
|
||||
|
||||
: void? ( c-type -- ? )
|
||||
{ void "void" } member? ;
|
||||
|
||||
GENERIC: c-struct? ( type -- ? )
|
||||
GENERIC: c-struct? ( c-type -- ? )
|
||||
|
||||
M: object c-struct?
|
||||
drop f ;
|
||||
|
|
@ -168,33 +174,33 @@ M: c-type c-type-stack-align? stack-align?>> ;
|
|||
|
||||
M: c-type-name c-type-stack-align? c-type c-type-stack-align? ;
|
||||
|
||||
: c-type-box ( n type -- )
|
||||
: c-type-box ( n c-type -- )
|
||||
[ c-type-rep ] [ c-type-boxer [ "No boxer" throw ] unless* ] bi
|
||||
%box ;
|
||||
|
||||
: c-type-unbox ( n ctype -- )
|
||||
: c-type-unbox ( n c-type -- )
|
||||
[ c-type-rep ] [ c-type-unboxer [ "No unboxer" throw ] unless* ] bi
|
||||
%unbox ;
|
||||
|
||||
GENERIC: box-parameter ( n ctype -- )
|
||||
GENERIC: box-parameter ( n c-type -- )
|
||||
|
||||
M: c-type box-parameter c-type-box ;
|
||||
|
||||
M: c-type-name box-parameter c-type box-parameter ;
|
||||
|
||||
GENERIC: box-return ( ctype -- )
|
||||
GENERIC: box-return ( c-type -- )
|
||||
|
||||
M: c-type box-return f swap c-type-box ;
|
||||
|
||||
M: c-type-name box-return c-type box-return ;
|
||||
|
||||
GENERIC: unbox-parameter ( n ctype -- )
|
||||
GENERIC: unbox-parameter ( n c-type -- )
|
||||
|
||||
M: c-type unbox-parameter c-type-unbox ;
|
||||
|
||||
M: c-type-name unbox-parameter c-type unbox-parameter ;
|
||||
|
||||
GENERIC: unbox-return ( ctype -- )
|
||||
GENERIC: unbox-return ( c-type -- )
|
||||
|
||||
M: c-type unbox-return f swap c-type-unbox ;
|
||||
|
||||
|
|
@ -202,13 +208,13 @@ M: c-type-name unbox-return c-type unbox-return ;
|
|||
|
||||
: little-endian? ( -- ? ) 1 <int> *char 1 = ; foldable
|
||||
|
||||
GENERIC: heap-size ( type -- size ) foldable
|
||||
GENERIC: heap-size ( name -- size ) foldable
|
||||
|
||||
M: c-type-name heap-size c-type heap-size ;
|
||||
|
||||
M: abstract-c-type heap-size size>> ;
|
||||
|
||||
GENERIC: stack-size ( type -- size ) foldable
|
||||
GENERIC: stack-size ( name -- size ) foldable
|
||||
|
||||
M: c-type-name stack-size c-type stack-size ;
|
||||
|
||||
|
|
@ -235,7 +241,7 @@ MIXIN: value-type
|
|||
[ "Cannot write struct fields with this type" throw ]
|
||||
] unless* ;
|
||||
|
||||
: array-accessor ( type quot -- def )
|
||||
: array-accessor ( c-type quot -- def )
|
||||
[
|
||||
\ swap , [ heap-size , [ * >fixnum ] % ] [ % ] bi*
|
||||
] [ ] make ;
|
||||
|
|
@ -261,19 +267,19 @@ M: word typedef ( old new -- )
|
|||
|
||||
TUPLE: long-long-type < c-type ;
|
||||
|
||||
: <long-long-type> ( -- type )
|
||||
: <long-long-type> ( -- c-type )
|
||||
long-long-type new ;
|
||||
|
||||
M: long-long-type unbox-parameter ( n type -- )
|
||||
M: long-long-type unbox-parameter ( n c-type -- )
|
||||
c-type-unboxer %unbox-long-long ;
|
||||
|
||||
M: long-long-type unbox-return ( type -- )
|
||||
M: long-long-type unbox-return ( c-type -- )
|
||||
f swap unbox-parameter ;
|
||||
|
||||
M: long-long-type box-parameter ( n type -- )
|
||||
M: long-long-type box-parameter ( n c-type -- )
|
||||
c-type-boxer %box-long-long ;
|
||||
|
||||
M: long-long-type box-return ( type -- )
|
||||
M: long-long-type box-return ( c-type -- )
|
||||
f swap box-parameter ;
|
||||
|
||||
: define-deref ( name -- )
|
||||
|
|
@ -285,13 +291,13 @@ M: long-long-type box-return ( type -- )
|
|||
[ dup c-setter '[ _ heap-size <byte-array> [ 0 @ ] keep ] ] bi
|
||||
(( value -- c-ptr )) define-inline ;
|
||||
|
||||
: define-primitive-type ( type name -- )
|
||||
: define-primitive-type ( c-type name -- )
|
||||
[ typedef ]
|
||||
[ name>> define-deref ]
|
||||
[ name>> define-out ]
|
||||
tri ;
|
||||
|
||||
: if-void ( type true false -- )
|
||||
: if-void ( c-type true false -- )
|
||||
pick void? [ drop nip call ] [ nip call ] if ; inline
|
||||
|
||||
CONSTANT: primitive-types
|
||||
|
|
@ -306,7 +312,7 @@ CONSTANT: primitive-types
|
|||
}
|
||||
|
||||
SYMBOLS:
|
||||
ptrdiff_t intptr_t size_t
|
||||
ptrdiff_t intptr_t uintptr_t size_t
|
||||
char* uchar* ;
|
||||
|
||||
[
|
||||
|
|
@ -467,8 +473,33 @@ SYMBOLS:
|
|||
[ >float ] >>unboxer-quot
|
||||
\ double define-primitive-type
|
||||
|
||||
\ long \ ptrdiff_t typedef
|
||||
\ long \ intptr_t typedef
|
||||
\ ulong \ size_t typedef
|
||||
\ long c-type \ ptrdiff_t typedef
|
||||
\ long c-type \ intptr_t typedef
|
||||
\ ulong c-type \ uintptr_t typedef
|
||||
\ ulong c-type \ size_t typedef
|
||||
] with-compilation-unit
|
||||
|
||||
M: char-16-rep rep-component-type drop char ;
|
||||
M: uchar-16-rep rep-component-type drop uchar ;
|
||||
M: short-8-rep rep-component-type drop short ;
|
||||
M: ushort-8-rep rep-component-type drop ushort ;
|
||||
M: int-4-rep rep-component-type drop int ;
|
||||
M: uint-4-rep rep-component-type drop uint ;
|
||||
M: longlong-2-rep rep-component-type drop longlong ;
|
||||
M: ulonglong-2-rep rep-component-type drop ulonglong ;
|
||||
M: float-4-rep rep-component-type drop float ;
|
||||
M: double-2-rep rep-component-type drop double ;
|
||||
|
||||
: (unsigned-interval) ( bytes -- from to ) [ 0 ] dip 8 * 2^ 1 - ; foldable
|
||||
: unsigned-interval ( c-type -- from to ) heap-size (unsigned-interval) ; foldable
|
||||
: (signed-interval) ( bytes -- from to ) 8 * 1 - 2^ [ neg ] [ 1 - ] bi ; foldable
|
||||
: signed-interval ( c-type -- from to ) heap-size (signed-interval) ; foldable
|
||||
|
||||
: c-type-interval ( c-type -- from to )
|
||||
{
|
||||
{ [ dup { float double } memq? ] [ drop -1/0. 1/0. ] }
|
||||
{ [ dup { char short int long longlong } memq? ] [ signed-interval ] }
|
||||
{ [ dup { uchar ushort uint ulong ulonglong } memq? ] [ unsigned-interval ] }
|
||||
} cond ; foldable
|
||||
|
||||
: c-type-clamp ( value c-type -- value' ) c-type-interval clamp ; inline
|
||||
|
|
|
|||
|
|
@ -16,6 +16,6 @@ STRUCT: complex-holder
|
|||
|
||||
[ C{ 1.0 2.0 } ] [ "h" get z>> ] unit-test
|
||||
|
||||
[ number ] [ "complex-float" c-type-boxed-class ] unit-test
|
||||
[ complex ] [ "complex-float" c-type-boxed-class ] unit-test
|
||||
|
||||
[ number ] [ "complex-double" c-type-boxed-class ] unit-test
|
||||
[ complex ] [ "complex-double" c-type-boxed-class ] unit-test
|
||||
|
|
|
|||
|
|
@ -25,7 +25,7 @@ STRUCT: T-class { real N } { imaginary N } ;
|
|||
T-class c-type
|
||||
<T> 1quotation >>unboxer-quot
|
||||
*T 1quotation >>boxer-quot
|
||||
number >>boxed-class
|
||||
complex >>boxed-class
|
||||
drop
|
||||
|
||||
;FUNCTOR
|
||||
|
|
|
|||
|
|
@ -1,6 +1,7 @@
|
|||
USING: alien alien.c-types help.syntax help.markup libc kernel.private
|
||||
byte-arrays math strings hashtables alien.syntax alien.strings sequences
|
||||
io.encodings.string debugger destructors vocabs.loader ;
|
||||
USING: alien alien.c-types help.syntax help.markup libc
|
||||
kernel.private byte-arrays math strings hashtables alien.syntax
|
||||
alien.strings sequences io.encodings.string debugger destructors
|
||||
vocabs.loader classes.struct ;
|
||||
IN: alien.data
|
||||
|
||||
HELP: <c-array>
|
||||
|
|
@ -26,7 +27,7 @@ HELP: byte-array>memory
|
|||
{ $warning "This word is unsafe. Improper use can corrupt memory." } ;
|
||||
|
||||
HELP: malloc-array
|
||||
{ $values { "n" "a non-negative integer" } { "type" "a C type" } { "alien" alien } }
|
||||
{ $values { "n" "a non-negative integer" } { "type" "a C type" } { "array" "a specialized array" } }
|
||||
{ $description "Allocates an unmanaged memory block large enough to hold " { $snippet "n" } " values of a C type, then wraps the memory in a sequence object using " { $link <c-direct-array> } "." }
|
||||
{ $notes "The appropriate specialized array vocabulary must be loaded; otherwise, an error will be thrown. The vocabulary can be loaded with the " { $link require-c-array } " word. See the " { $vocab-link "specialized-arrays" } " vocabulary for details on the underlying sequence type constructed." }
|
||||
{ $warning "Don't forget to deallocate the memory with a call to " { $link free } "." }
|
||||
|
|
@ -52,60 +53,70 @@ ARTICLE: "malloc" "Manual memory management"
|
|||
"Sometimes data passed to C functions must be allocated at a fixed address. See " { $link "byte-arrays-gc" } " for an explanation of when this is the case."
|
||||
$nl
|
||||
"Allocating a C datum with a fixed address:"
|
||||
{ $subsection malloc-object }
|
||||
{ $subsection malloc-array }
|
||||
{ $subsection malloc-byte-array }
|
||||
"There is a set of words in the " { $vocab-link "libc" } " vocabulary which directly call C standard library memory management functions:"
|
||||
{ $subsection malloc }
|
||||
{ $subsection calloc }
|
||||
{ $subsection realloc }
|
||||
{ $subsections
|
||||
malloc-object
|
||||
malloc-byte-array
|
||||
}
|
||||
"The " { $vocab-link "libc" } " vocabulary defines several words which directly call C standard library memory management functions:"
|
||||
{ $subsections
|
||||
malloc
|
||||
calloc
|
||||
realloc
|
||||
}
|
||||
"You must always free pointers returned by any of the above words when the block of memory is no longer in use:"
|
||||
{ $subsection free }
|
||||
{ $subsections free }
|
||||
"Utilities for automatically freeing memory in conjunction with " { $link with-destructors } ":"
|
||||
{ $subsection &free }
|
||||
{ $subsection |free }
|
||||
{ $subsections
|
||||
&free
|
||||
|free
|
||||
}
|
||||
"The " { $link &free } " and " { $link |free } " words are generated using " { $link "alien.destructors" } "."
|
||||
$nl
|
||||
"You can unsafely copy a range of bytes from one memory location to another:"
|
||||
{ $subsection memcpy }
|
||||
{ $subsections memcpy }
|
||||
"You can copy a range of bytes from memory into a byte array:"
|
||||
{ $subsection memory>byte-array }
|
||||
{ $subsections memory>byte-array }
|
||||
"You can copy a byte array to memory unsafely:"
|
||||
{ $subsection byte-array>memory } ;
|
||||
{ $subsections byte-array>memory } ;
|
||||
|
||||
|
||||
ARTICLE: "c-byte-arrays" "Passing data in byte arrays"
|
||||
"Instances of the " { $link byte-array } " class can be passed to C functions; the C function receives a pointer to the first element of the array."
|
||||
$nl
|
||||
"Byte arrays can be allocated directly with a byte count using the " { $link <byte-array> } " word. However in most cases, instead of computing a size in bytes directly, it is easier to use a higher-level word which expects C type and outputs a byte array large enough to hold that type:"
|
||||
{ $subsection <c-object> }
|
||||
{ $subsection <c-array> }
|
||||
ARTICLE: "c-pointers" "Passing pointers to C functions"
|
||||
"The following Factor objects may be passed to C function parameters with pointer types:"
|
||||
{ $list
|
||||
{ "Instances of " { $link alien } "." }
|
||||
{ "Instances of " { $link f } "; this is interpreted as a null pointer." }
|
||||
{ "Instances of " { $link byte-array } "; the C function receives a pointer to the first element of the array." }
|
||||
{ "Any data type which defines a method on " { $link >c-ptr } " that returns an instance of one of the above. This includes " { $link "classes.struct" } " and " { $link "specialized-arrays" } "." }
|
||||
}
|
||||
"The class of primitive C pointer types:"
|
||||
{ $subsections c-ptr }
|
||||
"A generic word for converting any object to a C pointer; user-defined types may add methods to this generic word:"
|
||||
{ $subsections >c-ptr }
|
||||
"More about the " { $link alien } " type:"
|
||||
{ $subsections "aliens" }
|
||||
{ $warning
|
||||
"The Factor garbage collector can move byte arrays around, and code passing byte arrays to C must obey important guidelines. See " { $link "byte-arrays-gc" } "." }
|
||||
{ $see-also "c-arrays" } ;
|
||||
"The Factor garbage collector can move byte arrays around, and code passing byte arrays, or objects backed by byte arrays, must obey important guidelines. See " { $link "byte-arrays-gc" } "." } ;
|
||||
|
||||
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
|
||||
"Furthermore, Factor's garbage collector can move objects in memory; for a discussion of the consequences, see " { $link "byte-arrays-gc" } "."
|
||||
{ $subsection "c-types-specs" }
|
||||
{ $subsection "c-byte-arrays" }
|
||||
{ $subsection "malloc" }
|
||||
{ $subsection "c-strings" }
|
||||
{ $subsection "c-arrays" }
|
||||
{ $subsection "c-out-params" }
|
||||
{ $subsections
|
||||
"c-types-specs"
|
||||
"c-pointers"
|
||||
"malloc"
|
||||
"c-strings"
|
||||
"c-out-params"
|
||||
}
|
||||
"Important guidelines for passing data in byte arrays:"
|
||||
{ $subsection "byte-arrays-gc" }
|
||||
{ $subsections "byte-arrays-gc" }
|
||||
"C-style enumerated types are supported:"
|
||||
{ $subsection POSTPONE: C-ENUM: }
|
||||
{ $subsections POSTPONE: C-ENUM: }
|
||||
"C types can be aliased for convenience and consitency with native library documentation:"
|
||||
{ $subsection POSTPONE: TYPEDEF: }
|
||||
"New C types can be defined:"
|
||||
{ $subsection "c-structs" }
|
||||
{ $subsection "c-unions" }
|
||||
{ $subsections POSTPONE: TYPEDEF: }
|
||||
"A utility for defining " { $link "destructors" } " for deallocating memory:"
|
||||
{ $subsection "alien.destructors" }
|
||||
{ $see-also "aliens" } ;
|
||||
{ $subsections "alien.destructors" }
|
||||
"C struct and union types can be defined with " { $link POSTPONE: STRUCT: } " and " { $link POSTPONE: UNION: } ". See " { $link "classes.struct" } " for details. For passing arrays to and from C, use the " { $link "specialized-arrays" } " vocabulary." ;
|
||||
|
||||
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." }
|
||||
|
|
@ -138,11 +149,13 @@ $nl
|
|||
"Care must be taken if the C function expects a " { $link char* } " with a length in bytes, rather than a null-terminated " { $link char* } "; passing the result of calling " { $link length } " on the string object will not suffice. This is because a Factor string of " { $emphasis "n" } " characters will not necessarily encode to " { $emphasis "n" } " bytes. The correct idiom for C functions which take a string with a length is to first encode the string using " { $link encode } ", and then pass the resulting byte array together with the length of this byte array."
|
||||
$nl
|
||||
"Sometimes a C function has a parameter type of " { $link 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 }
|
||||
{ $subsections
|
||||
string>alien
|
||||
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 }
|
||||
{ $subsections alien>string }
|
||||
"For example, if a C function returns a " { $link char* } " but stipulates that the caller must deallocate the memory afterward, you must define the function as returning " { $link void* } ", and call one of the above words before passing the pointer to " { $link free } "." ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,35 +1,35 @@
|
|||
! (c)2009 Slava Pestov, Joe Groff bsd license
|
||||
USING: accessors alien alien.c-types alien.strings arrays
|
||||
byte-arrays cpu.architecture fry io io.encodings.binary
|
||||
io.files io.streams.memory kernel libc math sequences ;
|
||||
io.files io.streams.memory kernel libc math sequences words ;
|
||||
IN: alien.data
|
||||
|
||||
GENERIC: require-c-array ( c-type -- )
|
||||
|
||||
M: array require-c-array first require-c-array ;
|
||||
|
||||
GENERIC: c-array-constructor ( c-type -- word )
|
||||
GENERIC: c-array-constructor ( c-type -- word ) foldable
|
||||
|
||||
GENERIC: c-(array)-constructor ( c-type -- word )
|
||||
GENERIC: c-(array)-constructor ( c-type -- word ) foldable
|
||||
|
||||
GENERIC: c-direct-array-constructor ( c-type -- word )
|
||||
GENERIC: c-direct-array-constructor ( c-type -- word ) foldable
|
||||
|
||||
GENERIC: <c-array> ( len c-type -- array )
|
||||
|
||||
M: c-type-name <c-array>
|
||||
M: word <c-array>
|
||||
c-array-constructor execute( len -- array ) ; inline
|
||||
|
||||
GENERIC: (c-array) ( len c-type -- array )
|
||||
|
||||
M: c-type-name (c-array)
|
||||
M: word (c-array)
|
||||
c-(array)-constructor execute( len -- array ) ; inline
|
||||
|
||||
GENERIC: <c-direct-array> ( alien len c-type -- array )
|
||||
|
||||
M: c-type-name <c-direct-array>
|
||||
M: word <c-direct-array>
|
||||
c-direct-array-constructor execute( alien len -- array ) ; inline
|
||||
|
||||
: malloc-array ( n type -- alien )
|
||||
: malloc-array ( n type -- array )
|
||||
[ heap-size calloc ] [ <c-direct-array> ] 2bi ; inline
|
||||
|
||||
: (malloc-array) ( n type -- alien )
|
||||
|
|
@ -56,9 +56,6 @@ M: c-type-name <c-direct-array>
|
|||
: malloc-string ( string encoding -- alien )
|
||||
string>alien malloc-byte-array ;
|
||||
|
||||
: malloc-file-contents ( path -- alien len )
|
||||
binary file-contents [ malloc-byte-array ] [ length ] bi ;
|
||||
|
||||
M: memory-stream stream-read
|
||||
[
|
||||
[ index>> ] [ alien>> ] bi <displaced-alien>
|
||||
|
|
@ -81,3 +78,4 @@ M: value-type c-type-setter ( type -- quot )
|
|||
[ c-type-getter ] [ c-type-unboxer-quot ] [ heap-size ] tri
|
||||
'[ @ swap @ _ memcpy ] ;
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -25,6 +25,6 @@ HELP: DESTRUCTOR:
|
|||
|
||||
ARTICLE: "alien.destructors" "Alien destructors"
|
||||
"The " { $vocab-link "alien.destructors" } " vocabulary defines a utility parsing word for defining new disposable classes."
|
||||
{ $subsection POSTPONE: DESTRUCTOR: } ;
|
||||
{ $subsections POSTPONE: DESTRUCTOR: } ;
|
||||
|
||||
ABOUT: "alien.destructors"
|
||||
|
|
@ -56,13 +56,14 @@ HELP: fortran-invoke
|
|||
|
||||
ARTICLE: "alien.fortran" "Fortran FFI"
|
||||
"The " { $vocab-link "alien.fortran" } " vocabulary provides an interface to code in shared libraries written in Fortran."
|
||||
{ $subsection "alien.fortran-types" }
|
||||
{ $subsection "alien.fortran-abis" }
|
||||
{ $subsection add-fortran-library }
|
||||
{ $subsection POSTPONE: LIBRARY: }
|
||||
{ $subsection POSTPONE: FUNCTION: }
|
||||
{ $subsection POSTPONE: SUBROUTINE: }
|
||||
{ $subsection fortran-invoke }
|
||||
;
|
||||
{ $subsections
|
||||
"alien.fortran-types"
|
||||
"alien.fortran-abis"
|
||||
add-fortran-library
|
||||
POSTPONE: LIBRARY:
|
||||
POSTPONE: FUNCTION:
|
||||
POSTPONE: SUBROUTINE:
|
||||
fortran-invoke
|
||||
} ;
|
||||
|
||||
ABOUT: "alien.fortran"
|
||||
|
|
|
|||
|
|
@ -45,10 +45,12 @@ HELP: load-library
|
|||
|
||||
HELP: add-library
|
||||
{ $values { "name" string } { "path" string } { "abi" "one of " { $snippet "\"cdecl\"" } " or " { $snippet "\"stdcall\"" } } }
|
||||
{ $description "Defines a new logical library named " { $snippet "name" } " located in the file system at " { $snippet "path" } "and the specified ABI." }
|
||||
{ $notes "Because the entire source file is parsed before top-level forms are executed, " { $link add-library } " cannot be used in the same file as " { $link POSTPONE: FUNCTION: } " definitions from that library. The " { $link add-library } " call will happen too late, after compilation, and the alien calls will not work."
|
||||
{ $description "Defines a new logical library named " { $snippet "name" } " located in the file system at " { $snippet "path" } " and the specified ABI. The logical library name can then be used by a " { $link POSTPONE: LIBRARY: } " form to specify the logical library for subsequent " { $link POSTPONE: FUNCTION: } " definitions." }
|
||||
{ $notes "Because the entire source file is parsed before top-level forms are executed, " { $link add-library } " must be placed within a " { $snippet "<< ... >>" } " parse-time evaluation block."
|
||||
$nl
|
||||
"Instead, " { $link add-library } " calls must either be placed in different source files from those that use that library, or alternatively, " { $link "syntax-immediate" } " can be used to load the library before compilation." }
|
||||
"This ensures that if the logical library is later used in the same file, for example by a " { $link POSTPONE: FUNCTION: } " definition. Otherwise, the " { $link add-library } " call will happen too late, after compilation, and the C function calls will not refer to the correct library."
|
||||
$nl
|
||||
"For details about parse-time evaluation, see " { $link "syntax-immediate" } "." }
|
||||
{ $examples "Here is a typical usage of " { $link add-library } ":"
|
||||
{ $code
|
||||
"<< \"freetype\" {"
|
||||
|
|
@ -65,8 +67,10 @@ HELP: remove-library
|
|||
|
||||
ARTICLE: "loading-libs" "Loading native libraries"
|
||||
"Before calling a C library, you must associate its path name on disk with a logical name which Factor uses to identify the library:"
|
||||
{ $subsection add-library }
|
||||
{ $subsection remove-library }
|
||||
{ $subsections
|
||||
add-library
|
||||
remove-library
|
||||
}
|
||||
"Once a library has been defined, you can try loading it to see if the path name is correct:"
|
||||
{ $subsection load-library }
|
||||
{ $subsections load-library }
|
||||
"If the compiler cannot load a library, or cannot resolve a symbol in a library, a linkage error is reported using the compiler error mechanism (see " { $link "compiler-errors" } "). Once you install the right library, reload the source file containing the " { $link add-library } " form to force the compiler to try loading the library again." ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1,43 @@
|
|||
! (c)2009 Joe Groff bsd license
|
||||
USING: accessors alien.c-types alien.parser alien.syntax
|
||||
tools.test vocabs.parser parser eval vocabs.parser debugger
|
||||
continuations ;
|
||||
IN: alien.parser.tests
|
||||
|
||||
TYPEDEF: char char2
|
||||
|
||||
SYMBOL: not-c-type
|
||||
|
||||
[
|
||||
"alien.parser.tests" use-vocab
|
||||
"alien.c-types" use-vocab
|
||||
|
||||
[ int ] [ "int" parse-c-type ] unit-test
|
||||
[ { int 5 } ] [ "int[5]" parse-c-type ] unit-test
|
||||
[ { int 5 10 11 } ] [ "int[5][10][11]" parse-c-type ] unit-test
|
||||
[ void* ] [ "int*" parse-c-type ] unit-test
|
||||
[ void* ] [ "int**" parse-c-type ] unit-test
|
||||
[ void* ] [ "int***" parse-c-type ] unit-test
|
||||
[ void* ] [ "int****" parse-c-type ] unit-test
|
||||
[ char* ] [ "char*" parse-c-type ] unit-test
|
||||
[ void* ] [ "char**" parse-c-type ] unit-test
|
||||
[ void* ] [ "char***" parse-c-type ] unit-test
|
||||
[ void* ] [ "char****" parse-c-type ] unit-test
|
||||
[ char2 ] [ "char2" parse-c-type ] unit-test
|
||||
[ char* ] [ "char2*" parse-c-type ] unit-test
|
||||
|
||||
[ "not-c-type" parse-c-type ] [ no-c-type? ] must-fail-with
|
||||
[ "not-word" parse-c-type ] [ error>> no-word-error? ] must-fail-with
|
||||
|
||||
] with-file-vocabs
|
||||
|
||||
! Reported by mnestic
|
||||
TYPEDEF: int alien-parser-test-int ! reasonably unique name...
|
||||
|
||||
[ "OK!" ] [
|
||||
[
|
||||
"USE: specialized-arrays SPECIALIZED-ARRAY: alien-parser-test-int" eval( -- )
|
||||
! after restart, we end up here
|
||||
"OK!"
|
||||
] [ :1 ] recover
|
||||
] unit-test
|
||||
|
|
@ -1,22 +1,23 @@
|
|||
! Copyright (C) 2008, 2009 Slava Pestov, Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors alien alien.c-types arrays assocs
|
||||
combinators combinators.short-circuit effects grouping
|
||||
USING: accessors alien alien.c-types alien.parser
|
||||
alien.libraries arrays assocs classes combinators
|
||||
combinators.short-circuit compiler.units effects grouping
|
||||
kernel parser sequences splitting words fry locals lexer
|
||||
namespaces summary math vocabs.parser ;
|
||||
IN: alien.parser
|
||||
|
||||
: parse-c-type-name ( name -- word/string )
|
||||
[ search ] keep or ;
|
||||
: parse-c-type-name ( name -- word )
|
||||
dup search [ ] [ no-word ] ?if ;
|
||||
|
||||
: parse-c-type ( string -- array )
|
||||
: parse-c-type ( string -- type )
|
||||
{
|
||||
{ [ dup "void" = ] [ drop void ] }
|
||||
{ [ CHAR: ] over member? ] [ parse-array-type parse-c-type-name prefix ] }
|
||||
{ [ dup search c-type-word? ] [ parse-c-type-name ] }
|
||||
{ [ dup c-types get at ] [ ] }
|
||||
{ [ "**" ?tail ] [ drop void* ] }
|
||||
{ [ "*" ?tail ] [ parse-c-type-name resolve-pointer-type ] }
|
||||
[ no-c-type ]
|
||||
[ dup search [ no-c-type ] [ no-word ] ?if ]
|
||||
} cond ;
|
||||
|
||||
: scan-c-type ( -- c-type )
|
||||
|
|
@ -25,10 +26,22 @@ IN: alien.parser
|
|||
[ parse-c-type ] if ;
|
||||
|
||||
: reset-c-type ( word -- )
|
||||
{ "c-type" "pointer-c-type" "callback-effect" "callback-abi" } reset-props ;
|
||||
dup "struct-size" word-prop
|
||||
[ dup [ forget-class ] [ { "struct-size" } reset-props ] bi ] when
|
||||
{
|
||||
"c-type"
|
||||
"pointer-c-type"
|
||||
"callback-effect"
|
||||
"callback-library"
|
||||
} reset-props ;
|
||||
|
||||
: CREATE-C-TYPE ( -- word )
|
||||
scan current-vocab create dup reset-c-type ;
|
||||
scan current-vocab create {
|
||||
[ fake-definition ]
|
||||
[ set-word ]
|
||||
[ reset-c-type ]
|
||||
[ ]
|
||||
} cleave ;
|
||||
|
||||
: normalize-c-arg ( type name -- type' name' )
|
||||
[ length ]
|
||||
|
|
@ -67,17 +80,21 @@ IN: alien.parser
|
|||
: callback-quot ( return types abi -- quot )
|
||||
[ [ ] 3curry dip alien-callback ] 3curry ;
|
||||
|
||||
:: make-callback-type ( abi return! type-name! parameters -- word quot effect )
|
||||
: library-abi ( lib -- abi )
|
||||
library [ abi>> ] [ "cdecl" ] if* ;
|
||||
|
||||
:: make-callback-type ( lib return! type-name! parameters -- word quot effect )
|
||||
return type-name normalize-c-arg type-name! return!
|
||||
type-name current-vocab create :> type-word
|
||||
type-word [ reset-generic ] [ reset-c-type ] bi
|
||||
void* type-word typedef
|
||||
parameters return parse-arglist :> callback-effect :> types
|
||||
type-word callback-effect "callback-effect" set-word-prop
|
||||
type-word abi "callback-abi" set-word-prop
|
||||
type-word return types abi callback-quot (( quot -- alien )) ;
|
||||
type-word lib "callback-library" set-word-prop
|
||||
type-word return types lib library-abi callback-quot (( quot -- alien )) ;
|
||||
|
||||
: (CALLBACK:) ( abi -- word quot effect )
|
||||
: (CALLBACK:) ( -- word quot effect )
|
||||
"c-library" get
|
||||
scan scan parse-arg-tokens make-callback-type ;
|
||||
|
||||
PREDICATE: alien-function-word < word
|
||||
|
|
|
|||
|
|
@ -45,13 +45,16 @@ M: typedef-word synopsis*
|
|||
first2 pprint-function-arg
|
||||
] if-empty ;
|
||||
|
||||
: pprint-library ( library -- )
|
||||
[ \ LIBRARY: [ text ] pprint-prefix ] when* ;
|
||||
|
||||
M: alien-function-word definer
|
||||
drop \ FUNCTION: \ ; ;
|
||||
M: alien-function-word definition drop f ;
|
||||
M: alien-function-word synopsis*
|
||||
{
|
||||
[ seeing-word ]
|
||||
[ def>> second [ \ LIBRARY: [ text ] pprint-prefix ] when* ]
|
||||
[ def>> second pprint-library ]
|
||||
[ definer. ]
|
||||
[ def>> first pprint-c-type ]
|
||||
[ pprint-word ]
|
||||
|
|
@ -64,13 +67,12 @@ M: alien-function-word synopsis*
|
|||
} cleave ;
|
||||
|
||||
M: alien-callback-type-word definer
|
||||
"callback-abi" word-prop "stdcall" =
|
||||
\ STDCALL-CALLBACK: \ CALLBACK: ?
|
||||
f ;
|
||||
drop \ CALLBACK: \ ; ;
|
||||
M: alien-callback-type-word definition drop f ;
|
||||
M: alien-callback-type-word synopsis*
|
||||
{
|
||||
[ seeing-word ]
|
||||
[ "callback-library" word-prop pprint-library ]
|
||||
[ definer. ]
|
||||
[ def>> first pprint-c-type ]
|
||||
[ pprint-word ]
|
||||
|
|
|
|||
|
|
@ -1,45 +0,0 @@
|
|||
! Copyright (C) 2005, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays kernel kernel.private math namespaces
|
||||
make sequences strings words effects combinators alien.c-types ;
|
||||
IN: alien.structs.fields
|
||||
|
||||
TUPLE: field-spec name offset type reader writer ;
|
||||
|
||||
: reader-word ( class name vocab -- word )
|
||||
[ "-" glue ] dip create dup make-deprecated ;
|
||||
|
||||
: writer-word ( class name vocab -- word )
|
||||
[ [ swap "set-" % % "-" % % ] "" make ] dip create dup make-deprecated ;
|
||||
|
||||
: <field-spec> ( struct-name vocab type field-name -- spec )
|
||||
field-spec new
|
||||
0 >>offset
|
||||
swap >>name
|
||||
swap >>type
|
||||
3dup name>> swap reader-word >>reader
|
||||
3dup name>> swap writer-word >>writer
|
||||
2nip ;
|
||||
|
||||
: align-offset ( offset type -- offset )
|
||||
c-type-align align ;
|
||||
|
||||
: struct-offsets ( specs -- size )
|
||||
0 [
|
||||
[ type>> align-offset ] keep
|
||||
[ (>>offset) ] [ type>> heap-size + ] 2bi
|
||||
] reduce ;
|
||||
|
||||
: define-struct-slot-word ( word quot spec effect -- )
|
||||
[ offset>> prefix ] dip define-inline ;
|
||||
|
||||
: define-getter ( spec -- )
|
||||
[ reader>> ] [ type>> c-type-getter-boxer ] [ ] tri
|
||||
(( c-ptr -- value )) define-struct-slot-word ;
|
||||
|
||||
: define-setter ( spec -- )
|
||||
[ writer>> ] [ type>> c-setter ] [ ] tri
|
||||
(( value c-ptr -- )) define-struct-slot-word ;
|
||||
|
||||
: define-field ( spec -- )
|
||||
[ define-getter ] [ define-setter ] bi ;
|
||||
|
|
@ -1 +0,0 @@
|
|||
Struct field implementation and reflection support
|
||||
|
|
@ -1,33 +0,0 @@
|
|||
USING: alien.c-types alien.data strings help.markup help.syntax alien.syntax
|
||||
sequences io arrays kernel words assocs namespaces ;
|
||||
IN: alien.structs
|
||||
|
||||
ARTICLE: "c-structs" "C structure types"
|
||||
"A " { $snippet "struct" } " in C is essentially a block of memory with the value of each structure field stored at a fixed offset from the start of the block. The C library interface provides some utilities to define words which read and write structure fields given a base address."
|
||||
{ $subsection POSTPONE: C-STRUCT: }
|
||||
"Great care must be taken when working with C structures since no type or bounds checking is possible."
|
||||
$nl
|
||||
"An example:"
|
||||
{ $code
|
||||
"C-STRUCT: XVisualInfo"
|
||||
" { \"Visual*\" \"visual\" }"
|
||||
" { \"VisualID\" \"visualid\" }"
|
||||
" { \"int\" \"screen\" }"
|
||||
" { \"uint\" \"depth\" }"
|
||||
" { \"int\" \"class\" }"
|
||||
" { \"ulong\" \"red_mask\" }"
|
||||
" { \"ulong\" \"green_mask\" }"
|
||||
" { \"ulong\" \"blue_mask\" }"
|
||||
" { \"int\" \"colormap_size\" }"
|
||||
" { \"int\" \"bits_per_rgb\" } ;"
|
||||
}
|
||||
"C structure objects can be allocated by calling " { $link <c-object> } " or " { $link malloc-object } "."
|
||||
$nl
|
||||
"Arrays of C structures can be created with the " { $vocab-link "specialized-arrays" } " vocabulary." ;
|
||||
|
||||
ARTICLE: "c-unions" "C unions"
|
||||
"A " { $snippet "union" } " in C defines a type large enough to hold its largest member. This is usually used to allocate a block of memory which can hold one of several types of values."
|
||||
{ $subsection POSTPONE: C-UNION: }
|
||||
"C union objects can be allocated by calling " { $link <c-object> } " or " { $link malloc-object } "."
|
||||
$nl
|
||||
"Arrays of C unions can be created with the " { $vocab-link "specialized-arrays" } " vocabulary." ;
|
||||
|
|
@ -1,59 +0,0 @@
|
|||
USING: alien alien.syntax alien.c-types alien.data kernel tools.test
|
||||
sequences system libc words vocabs namespaces layouts ;
|
||||
IN: alien.structs.tests
|
||||
|
||||
C-STRUCT: bar
|
||||
{ "int" "x" }
|
||||
{ { "int" 8 } "y" } ;
|
||||
|
||||
[ 36 ] [ "bar" heap-size ] unit-test
|
||||
[ t ] [ \ <displaced-alien> "bar" c-type-getter memq? ] unit-test
|
||||
|
||||
C-STRUCT: align-test
|
||||
{ "int" "x" }
|
||||
{ "double" "y" } ;
|
||||
|
||||
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
|
||||
|
||||
CONSTANT: MAX_FOOS 30
|
||||
|
||||
C-STRUCT: foox
|
||||
{ { "int" MAX_FOOS } "x" } ;
|
||||
|
||||
[ 120 ] [ "foox" heap-size ] unit-test
|
||||
|
||||
C-UNION: barx
|
||||
{ "int" MAX_FOOS }
|
||||
"float" ;
|
||||
|
||||
[ 120 ] [ "barx" heap-size ] unit-test
|
||||
|
||||
"help" vocab [
|
||||
"print-topic" "help" lookup "help" set
|
||||
[ ] [ \ foox-x "help" get execute ] unit-test
|
||||
[ ] [ \ set-foox-x "help" get execute ] unit-test
|
||||
] when
|
||||
|
||||
C-STRUCT: nested
|
||||
{ "int" "x" } ;
|
||||
|
||||
C-STRUCT: nested-2
|
||||
{ "nested" "y" } ;
|
||||
|
||||
[ 4 ] [
|
||||
"nested-2" <c-object>
|
||||
"nested" <c-object>
|
||||
4 over set-nested-x
|
||||
over set-nested-2-y
|
||||
nested-2-y
|
||||
nested-x
|
||||
] unit-test
|
||||
|
|
@ -1,71 +0,0 @@
|
|||
! Copyright (C) 2004, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays assocs generic hashtables kernel kernel.private
|
||||
math namespaces parser sequences strings words libc fry
|
||||
alien.c-types alien.structs.fields cpu.architecture math.order
|
||||
quotations byte-arrays ;
|
||||
IN: alien.structs
|
||||
|
||||
TUPLE: struct-type < abstract-c-type fields return-in-registers? ;
|
||||
|
||||
INSTANCE: struct-type value-type
|
||||
|
||||
M: struct-type c-type ;
|
||||
|
||||
M: struct-type c-type-stack-align? drop f ;
|
||||
|
||||
: if-value-struct ( ctype true false -- )
|
||||
[ dup value-struct? ] 2dip '[ drop void* @ ] if ; inline
|
||||
|
||||
M: struct-type unbox-parameter
|
||||
[ %unbox-large-struct ] [ unbox-parameter ] if-value-struct ;
|
||||
|
||||
M: struct-type box-parameter
|
||||
[ %box-large-struct ] [ box-parameter ] if-value-struct ;
|
||||
|
||||
: if-small-struct ( c-type true false -- ? )
|
||||
[ dup return-struct-in-registers? ] 2dip '[ f swap @ ] if ; inline
|
||||
|
||||
M: struct-type unbox-return
|
||||
[ %unbox-small-struct ] [ %unbox-large-struct ] if-small-struct ;
|
||||
|
||||
M: struct-type box-return
|
||||
[ %box-small-struct ] [ %box-large-struct ] if-small-struct ;
|
||||
|
||||
M: struct-type stack-size
|
||||
[ heap-size ] [ stack-size ] if-value-struct ;
|
||||
|
||||
M: struct-type c-struct? drop t ;
|
||||
|
||||
: (define-struct) ( name size align fields class -- )
|
||||
[ [ align ] keep ] 2dip new
|
||||
byte-array >>class
|
||||
byte-array >>boxed-class
|
||||
swap >>fields
|
||||
swap >>align
|
||||
swap >>size
|
||||
swap typedef ;
|
||||
|
||||
: make-fields ( name vocab fields -- fields )
|
||||
[ first2 <field-spec> ] with with map ;
|
||||
|
||||
: compute-struct-align ( types -- n )
|
||||
[ c-type-align ] [ max ] map-reduce ;
|
||||
|
||||
: define-struct ( name vocab fields -- )
|
||||
[ 2drop ] [ make-fields ] 3bi
|
||||
[ struct-offsets ] keep
|
||||
[ [ type>> ] map compute-struct-align ] keep
|
||||
[ struct-type (define-struct) ] keep
|
||||
[ define-field ] each ; deprecated
|
||||
|
||||
: define-union ( name members -- )
|
||||
[ [ heap-size ] [ max ] map-reduce ] keep
|
||||
compute-struct-align f struct-type (define-struct) ; deprecated
|
||||
|
||||
: offset-of ( field struct -- offset )
|
||||
c-types get at fields>>
|
||||
[ name>> = ] with find nip offset>> ;
|
||||
|
||||
USE: vocabs.loader
|
||||
"specialized-arrays" require
|
||||
|
|
@ -1 +0,0 @@
|
|||
C structure support
|
||||
|
|
@ -1,6 +1,6 @@
|
|||
IN: alien.syntax
|
||||
USING: alien alien.c-types alien.parser alien.structs
|
||||
classes.struct help.markup help.syntax ;
|
||||
USING: alien alien.c-types alien.parser alien.libraries
|
||||
classes.struct help.markup help.syntax see ;
|
||||
|
||||
HELP: DLL"
|
||||
{ $syntax "DLL\" path\"" }
|
||||
|
|
@ -14,13 +14,16 @@ HELP: ALIEN:
|
|||
{ $notes "Alien objects are invalidated between image saves and loads, and hence source files should not contain alien literals; this word is for interactive use only. See " { $link "alien-expiry" } " for details." } ;
|
||||
|
||||
ARTICLE: "syntax-aliens" "Alien object literal syntax"
|
||||
{ $subsection POSTPONE: ALIEN: }
|
||||
{ $subsection POSTPONE: DLL" } ;
|
||||
{ $subsections
|
||||
POSTPONE: ALIEN:
|
||||
POSTPONE: DLL"
|
||||
} ;
|
||||
|
||||
HELP: LIBRARY:
|
||||
{ $syntax "LIBRARY: name" }
|
||||
{ $values { "name" "a logical library name" } }
|
||||
{ $description "Sets the logical library for consequent " { $link POSTPONE: FUNCTION: } " definitions that follow." } ;
|
||||
{ $description "Sets the logical library for consequent " { $link POSTPONE: FUNCTION: } ", " { $link POSTPONE: C-GLOBAL: } " and " { $link POSTPONE: CALLBACK: } " definitions, as well as " { $link POSTPONE: &: } " forms." }
|
||||
{ $notes "Logical library names are defined with the " { $link add-library } " word." } ;
|
||||
|
||||
HELP: FUNCTION:
|
||||
{ $syntax "FUNCTION: return name ( parameters )" }
|
||||
|
|
@ -54,21 +57,6 @@ HELP: TYPEDEF:
|
|||
{ $description "Aliases the C type " { $snippet "old" } " under the name " { $snippet "new" } " if ." }
|
||||
{ $notes "This word differs from " { $link typedef } " in that it runs at parse time, to ensure correct ordering of operations when loading source files. Words defined in source files are compiled before top-level forms are run, so if a source file defines C binding words and uses " { $link typedef } ", the type alias won't be available at compile time." } ;
|
||||
|
||||
HELP: C-STRUCT:
|
||||
{ $deprecated "New code should use " { $link "classes.struct" } ". See the " { $link POSTPONE: STRUCT: } " word." }
|
||||
{ $syntax "C-STRUCT: name pairs... ;" }
|
||||
{ $values { "name" "a new C type name" } { "pairs" "C type / field name string pairs" } }
|
||||
{ $description "Defines a C struct layout and accessor words." }
|
||||
{ $notes "C type names are documented in " { $link "c-types-specs" } "." } ;
|
||||
|
||||
HELP: C-UNION:
|
||||
{ $deprecated "New code should use " { $link "classes.struct" } ". See the " { $link POSTPONE: UNION-STRUCT: } " word." }
|
||||
{ $syntax "C-UNION: name members... ;" }
|
||||
{ $values { "name" "a new C type name" } { "members" "a sequence of C types" } }
|
||||
{ $description "Defines a new C type sized to fit its largest member." }
|
||||
{ $notes "C type names are documented in " { $link "c-types-specs" } "." }
|
||||
{ $examples { $code "C-UNION: event \"active-event\" \"keyboard-event\" \"mouse-event\" ;" } } ;
|
||||
|
||||
HELP: C-ENUM:
|
||||
{ $syntax "C-ENUM: words... ;" }
|
||||
{ $values { "words" "a sequence of word names" } }
|
||||
|
|
@ -81,10 +69,20 @@ HELP: C-ENUM:
|
|||
{ $code "CONSTANT: red 0" "CONSTANT: green 1" "CONSTANT: blue 2" }
|
||||
} ;
|
||||
|
||||
HELP: C-TYPE:
|
||||
{ $syntax "C-TYPE: type" }
|
||||
{ $values { "type" "a new C type" } }
|
||||
{ $description "Defines a new, opaque C type. Since it is opaque, " { $snippet "type" } " will not be directly usable as a parameter or return type of a " { $link POSTPONE: FUNCTION: } " or as a slot of a " { $link POSTPONE: STRUCT: } ". However, it can be used as the type of a pointer (that is, as " { $snippet "type*" } ")." $nl
|
||||
{ $snippet "C-TYPE:" } " can also be used to forward-declare C types to enable circular dependencies. For example:"
|
||||
{ $code """C-TYPE: forward
|
||||
STRUCT: backward { x forward* } ;
|
||||
STRUCT: forward { x backward* } ; """ } }
|
||||
{ $notes "Primitive C types are also displayed using " { $snippet "C-TYPE:" } " syntax when they are displayed by " { $link see } "." } ;
|
||||
|
||||
HELP: CALLBACK:
|
||||
{ $syntax "CALLBACK: return type ( parameters ) ;" }
|
||||
{ $values { "return" "a C return type" } { "type" "a type name" } { "parameters" "a comma-separated sequence of type/name pairs; " { $snippet "type1 arg1, type2 arg2, ..." } } }
|
||||
{ $description "Defines a new function pointer C type word " { $snippet "type" } ". The newly defined word works both as a C type and as a wrapper for " { $link alien-callback } " for callbacks that accept the given return type and parameters with the " { $snippet "\"cdecl\"" } " ABI." }
|
||||
{ $description "Defines a new function pointer C type word " { $snippet "type" } ". The newly defined word works both as a C type and as a wrapper for " { $link alien-callback } " for callbacks that accept the given return type and parameters. The ABI of the callback is decided from the ABI of the active " { $link POSTPONE: LIBRARY: } " declaration." }
|
||||
{ $examples
|
||||
{ $code
|
||||
"CALLBACK: bool FakeCallback ( int message, void* payload ) ;"
|
||||
|
|
@ -98,42 +96,28 @@ HELP: CALLBACK:
|
|||
}
|
||||
} ;
|
||||
|
||||
HELP: STDCALL-CALLBACK:
|
||||
{ $syntax "STDCALL-CALLBACK: return type ( parameters ) ;" }
|
||||
{ $values { "return" "a C return type" } { "type" "a type name" } { "parameters" "a comma-separated sequence of type/name pairs; " { $snippet "type1 arg1, type2 arg2, ..." } } }
|
||||
{ $description "Defines a new function pointer C type word " { $snippet "type" } ". The newly defined word works both as a C type and as a wrapper for " { $link alien-callback } " for callbacks that accept the given return type and parameters with the " { $snippet "\"stdcall\"" } " ABI." }
|
||||
{ $examples
|
||||
{ $code
|
||||
"STDCALL-CALLBACK: bool FakeCallback ( int message, void* payload ) ;"
|
||||
": MyFakeCallback ( -- alien )"
|
||||
" [| message payload |"
|
||||
" \"message #\" write"
|
||||
" message number>string write"
|
||||
" \" received\" write nl"
|
||||
" t"
|
||||
" ] FakeCallback ;"
|
||||
}
|
||||
} ;
|
||||
|
||||
{ POSTPONE: CALLBACK: POSTPONE: STDCALL-CALLBACK: } related-words
|
||||
|
||||
HELP: &:
|
||||
{ $syntax "&: symbol" }
|
||||
{ $values { "symbol" "A C library symbol name" } }
|
||||
{ $values { "symbol" "A C global variable name" } }
|
||||
{ $description "Pushes the address of a symbol named " { $snippet "symbol" } " from the current library, set with " { $link POSTPONE: LIBRARY: } "." } ;
|
||||
|
||||
HELP: typedef
|
||||
{ $values { "old" "a string" } { "new" "a string" } }
|
||||
{ $values { "old" "a C type" } { "new" "a C type" } }
|
||||
{ $description "Aliases the C type " { $snippet "old" } " under the name " { $snippet "new" } "." }
|
||||
{ $notes "Using this word in the same source file which defines C bindings can cause problems, because words are compiled before top-level forms are run. Use the " { $link POSTPONE: TYPEDEF: } " word instead." } ;
|
||||
|
||||
{ POSTPONE: TYPEDEF: typedef } related-words
|
||||
|
||||
HELP: c-struct?
|
||||
{ $values { "type" "a string" } { "?" "a boolean" } }
|
||||
{ $description "Tests if a C type is a structure defined by " { $link POSTPONE: C-STRUCT: } "." } ;
|
||||
{ $values { "c-type" "a C type" } { "?" "a boolean" } }
|
||||
{ $description "Tests if a C type is a structure defined by " { $link POSTPONE: STRUCT: } "." } ;
|
||||
|
||||
HELP: define-function
|
||||
{ $values { "return" "a C return type" } { "library" "a logical library name" } { "function" "a C function name" } { "parameters" "a sequence of C parameter types" } }
|
||||
{ $description "Defines a word named " { $snippet "function" } " in the current vocabulary (see " { $link "vocabularies" } "). The word calls " { $link alien-invoke } " with the specified parameters." }
|
||||
{ $notes "This word is used to implement the " { $link POSTPONE: FUNCTION: } " parsing word." } ;
|
||||
|
||||
HELP: C-GLOBAL:
|
||||
{ $syntax "C-GLOBAL: type name" }
|
||||
{ $values { "type" "a C type" } { "name" "a C global variable name" } }
|
||||
{ $description "Defines a new word named " { $snippet "name" } " which accesses a global variable in the current library, set with " { $link POSTPONE: LIBRARY: } "." } ;
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2005, 2009 Slava Pestov, Alex Chapman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays alien alien.c-types alien.structs
|
||||
USING: accessors arrays alien alien.c-types
|
||||
alien.arrays alien.strings kernel math namespaces parser
|
||||
sequences words quotations math.parser splitting grouping
|
||||
effects assocs combinators lexer strings.parser alien.parser
|
||||
|
|
@ -19,26 +19,17 @@ SYNTAX: FUNCTION:
|
|||
(FUNCTION:) define-declared ;
|
||||
|
||||
SYNTAX: CALLBACK:
|
||||
"cdecl" (CALLBACK:) define-inline ;
|
||||
|
||||
SYNTAX: STDCALL-CALLBACK:
|
||||
"stdcall" (CALLBACK:) define-inline ;
|
||||
(CALLBACK:) define-inline ;
|
||||
|
||||
SYNTAX: TYPEDEF:
|
||||
scan-c-type CREATE-C-TYPE typedef ;
|
||||
|
||||
SYNTAX: C-STRUCT:
|
||||
scan current-vocab parse-definition define-struct ; deprecated
|
||||
|
||||
SYNTAX: C-UNION:
|
||||
scan parse-definition define-union ; deprecated
|
||||
|
||||
SYNTAX: C-ENUM:
|
||||
";" parse-tokens
|
||||
[ [ create-in ] dip define-constant ] each-index ;
|
||||
|
||||
SYNTAX: C-TYPE:
|
||||
"Primitive C type definition not supported" throw ;
|
||||
void CREATE-C-TYPE typedef ;
|
||||
|
||||
ERROR: no-such-symbol name library ;
|
||||
|
||||
|
|
@ -47,3 +38,12 @@ ERROR: no-such-symbol name library ;
|
|||
|
||||
SYNTAX: &:
|
||||
scan "c-library" get '[ _ _ address-of ] over push-all ;
|
||||
|
||||
: global-quot ( type word -- quot )
|
||||
name>> "c-library" get '[ _ _ address-of 0 ]
|
||||
swap c-type-getter-boxer append ;
|
||||
|
||||
: define-global ( type word -- )
|
||||
[ nip ] [ global-quot ] 2bi (( -- value )) define-declared ;
|
||||
|
||||
SYNTAX: C-GLOBAL: scan-c-type CREATE-WORD define-global ;
|
||||
|
|
|
|||
|
|
@ -61,18 +61,22 @@ ARTICLE: "ascii" "ASCII"
|
|||
"The " { $vocab-link "ascii" } " vocabulary implements support for the legacy ASCII character set. Most applications should use " { $link "unicode" } " instead."
|
||||
$nl
|
||||
"ASCII character classes:"
|
||||
{ $subsection blank? }
|
||||
{ $subsection letter? }
|
||||
{ $subsection LETTER? }
|
||||
{ $subsection digit? }
|
||||
{ $subsection printable? }
|
||||
{ $subsection control? }
|
||||
{ $subsection quotable? }
|
||||
{ $subsection ascii? }
|
||||
{ $subsections
|
||||
blank?
|
||||
letter?
|
||||
LETTER?
|
||||
digit?
|
||||
printable?
|
||||
control?
|
||||
quotable?
|
||||
ascii?
|
||||
}
|
||||
"ASCII case conversion:"
|
||||
{ $subsection ch>lower }
|
||||
{ $subsection ch>upper }
|
||||
{ $subsection >lower }
|
||||
{ $subsection >upper } ;
|
||||
{ $subsections
|
||||
ch>lower
|
||||
ch>upper
|
||||
>lower
|
||||
>upper
|
||||
} ;
|
||||
|
||||
ABOUT: "ascii"
|
||||
|
|
|
|||
|
|
@ -36,12 +36,16 @@ HELP: encode-base64-lines
|
|||
ARTICLE: "base64" "Base 64 conversions"
|
||||
"The " { $vocab-link "base64" } " vocabulary implements conversions of sequences to printable characters in base 64. These plain-text representations of binary data may be passed around and converted back to binary data later." $nl
|
||||
"Converting to and from base64 as strings:"
|
||||
{ $subsection >base64 }
|
||||
{ $subsection >base64-lines }
|
||||
{ $subsection base64> }
|
||||
{ $subsections
|
||||
>base64
|
||||
>base64-lines
|
||||
base64>
|
||||
}
|
||||
"Using base64 from streams:"
|
||||
{ $subsection encode-base64 }
|
||||
{ $subsection encode-base64-lines }
|
||||
{ $subsection decode-base64 } ;
|
||||
{ $subsections
|
||||
encode-base64
|
||||
encode-base64-lines
|
||||
decode-base64
|
||||
} ;
|
||||
|
||||
ABOUT: "base64"
|
||||
|
|
|
|||
|
|
@ -26,12 +26,16 @@ $nl
|
|||
"Bidirectional assocs implement the entire " { $link "assocs-protocol" } " with the exception of " { $link delete-at } ". Duplicate values are allowed, however value lookups with " { $link value-at } " only return the first key that a given value was stored with."
|
||||
$nl
|
||||
"The class of biassocs:"
|
||||
{ $subsection biassoc }
|
||||
{ $subsection biassoc? }
|
||||
{ $subsections
|
||||
biassoc
|
||||
biassoc?
|
||||
}
|
||||
"Creating new biassocs:"
|
||||
{ $subsection <biassoc> }
|
||||
{ $subsection <bihash> }
|
||||
{ $subsections
|
||||
<biassoc>
|
||||
<bihash>
|
||||
}
|
||||
"Converting existing assocs to biassocs:"
|
||||
{ $subsection >biassoc } ;
|
||||
{ $subsections >biassoc } ;
|
||||
|
||||
ABOUT: "biassocs"
|
||||
|
|
|
|||
|
|
@ -33,11 +33,13 @@ HELP: sorted-memq?
|
|||
|
||||
ARTICLE: "binary-search" "Binary search"
|
||||
"The " { $emphasis "binary search" } " algorithm allows elements to be located in sorted sequence in " { $snippet "O(log n)" } " time."
|
||||
{ $subsection search }
|
||||
{ $subsections search }
|
||||
"Variants of sequence words optimized for sorted sequences:"
|
||||
{ $subsection sorted-index }
|
||||
{ $subsection sorted-member? }
|
||||
{ $subsection sorted-memq? }
|
||||
{ $subsections
|
||||
sorted-index
|
||||
sorted-member?
|
||||
sorted-memq?
|
||||
}
|
||||
{ $see-also "order-specifiers" "sequences-sorting" } ;
|
||||
|
||||
ABOUT: "binary-search"
|
||||
|
|
|
|||
|
|
@ -7,22 +7,30 @@ ARTICLE: "bit-arrays" "Bit arrays"
|
|||
$nl
|
||||
"Bit array words are in the " { $vocab-link "bit-arrays" } " vocabulary."
|
||||
$nl
|
||||
"Bit arrays play a special role in the C library interface; they can be used to pass binary data back and forth between Factor and C. See " { $link "c-byte-arrays" } "."
|
||||
"Bit arrays play a special role in the C library interface; they can be used to pass binary data back and forth between Factor and C. See " { $link "c-pointers" } "."
|
||||
$nl
|
||||
"Bit arrays form a class of objects:"
|
||||
{ $subsection bit-array }
|
||||
{ $subsection bit-array? }
|
||||
{ $subsections
|
||||
bit-array
|
||||
bit-array?
|
||||
}
|
||||
"Creating new bit arrays:"
|
||||
{ $subsection >bit-array }
|
||||
{ $subsection <bit-array> }
|
||||
{ $subsections
|
||||
>bit-array
|
||||
<bit-array>
|
||||
}
|
||||
"Efficiently setting and clearing all bits in a bit array:"
|
||||
{ $subsection set-bits }
|
||||
{ $subsection clear-bits }
|
||||
{ $subsections
|
||||
set-bits
|
||||
clear-bits
|
||||
}
|
||||
"Converting between unsigned integers and their binary representation:"
|
||||
{ $subsection integer>bit-array }
|
||||
{ $subsection bit-array>integer }
|
||||
{ $subsections
|
||||
integer>bit-array
|
||||
bit-array>integer
|
||||
}
|
||||
"Bit array literal syntax:"
|
||||
{ $subsection POSTPONE: ?{ } ;
|
||||
{ $subsections POSTPONE: ?{ } ;
|
||||
|
||||
ABOUT: "bit-arrays"
|
||||
|
||||
|
|
|
|||
|
|
@ -6,13 +6,17 @@ ARTICLE: "bit-vectors" "Bit vectors"
|
|||
"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 }
|
||||
{ $subsection bit-vector? }
|
||||
{ $subsections
|
||||
bit-vector
|
||||
bit-vector?
|
||||
}
|
||||
"Creating bit vectors:"
|
||||
{ $subsection >bit-vector }
|
||||
{ $subsection <bit-vector> }
|
||||
{ $subsections
|
||||
>bit-vector
|
||||
<bit-vector>
|
||||
}
|
||||
"Literal syntax:"
|
||||
{ $subsection POSTPONE: ?V{ }
|
||||
{ $subsections 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" } ;
|
||||
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@ IN: bootstrap.image
|
|||
|
||||
ARTICLE: "bootstrap.image" "Bootstrapping new images"
|
||||
"A new image can be built from source; this is known as " { $emphasis "bootstrap" } ". Bootstrap is a two-step process. The first stage is the creation of a bootstrap image from a running Factor instance:"
|
||||
{ $subsection make-image }
|
||||
{ $subsections make-image }
|
||||
"The second bootstrapping stage is initiated by running the resulting bootstrap image:"
|
||||
{ $code "./factor -i=boot.x86.32.image" }
|
||||
"This stage loads additional code, compiles all words, and dumps a final " { $snippet "factor.image" } "."
|
||||
|
|
|
|||
|
|
@ -163,6 +163,7 @@ USERENV: jit-3dip 40
|
|||
USERENV: jit-execute-word 41
|
||||
USERENV: jit-execute-jump 42
|
||||
USERENV: jit-execute-call 43
|
||||
USERENV: jit-declare-word 44
|
||||
|
||||
! PIC stubs
|
||||
USERENV: pic-load 47
|
||||
|
|
@ -493,6 +494,7 @@ M: quotation '
|
|||
\ inline-cache-miss-tail \ pic-miss-tail-word set
|
||||
\ mega-cache-lookup \ mega-lookup-word set
|
||||
\ mega-cache-miss \ mega-miss-word set
|
||||
\ declare jit-declare-word set
|
||||
[ undefined ] undefined-quot set ;
|
||||
|
||||
: emit-userenvs ( -- )
|
||||
|
|
|
|||
|
|
@ -24,14 +24,16 @@ HELP: ?box
|
|||
|
||||
ARTICLE: "boxes" "Boxes"
|
||||
"A " { $emphasis "box" } " is a container which can either be empty or hold a single value."
|
||||
{ $subsection box }
|
||||
{ $subsections box }
|
||||
"Creating an empty box:"
|
||||
{ $subsection <box> }
|
||||
{ $subsections <box> }
|
||||
"Storing a value and removing a value from a box:"
|
||||
{ $subsection >box }
|
||||
{ $subsection box> }
|
||||
{ $subsections
|
||||
>box
|
||||
box>
|
||||
}
|
||||
"Safely removing a value:"
|
||||
{ $subsection ?box }
|
||||
{ $subsections ?box }
|
||||
"Testing if a box is full can be done by reading the " { $snippet "occupied" } " slot." ;
|
||||
|
||||
ABOUT: "boxes"
|
||||
|
|
|
|||
|
|
@ -520,125 +520,142 @@ HELP: since-1970
|
|||
|
||||
ARTICLE: "calendar" "Calendar"
|
||||
"The two data types used throughout the calendar library:"
|
||||
{ $subsection timestamp }
|
||||
{ $subsection duration }
|
||||
{ $subsections
|
||||
timestamp
|
||||
duration
|
||||
}
|
||||
"Durations represent spans of time:"
|
||||
{ $subsection "using-durations" }
|
||||
{ $subsections "using-durations" }
|
||||
"Arithmetic on timestamps and durations:"
|
||||
{ $subsection "timestamp-arithmetic" }
|
||||
{ $subsections "timestamp-arithmetic" }
|
||||
"Getting the current timestamp:"
|
||||
{ $subsection now }
|
||||
{ $subsection gmt }
|
||||
{ $subsections
|
||||
now
|
||||
gmt
|
||||
}
|
||||
"Converting between timestamps:"
|
||||
{ $subsection >local-time }
|
||||
{ $subsection >gmt }
|
||||
{ $subsections
|
||||
>local-time
|
||||
>gmt
|
||||
}
|
||||
"Converting between timezones:"
|
||||
{ $subsection convert-timezone }
|
||||
{ $subsections convert-timezone }
|
||||
"Timestamps relative to each other:"
|
||||
{ $subsection "relative-timestamps" }
|
||||
{ $subsections "relative-timestamps" }
|
||||
"Operations on units of time:"
|
||||
{ $subsection "years" }
|
||||
{ $subsection "months" }
|
||||
{ $subsection "days" }
|
||||
{ $subsections
|
||||
"years"
|
||||
"months"
|
||||
"days"
|
||||
}
|
||||
"Meta-data about the calendar:"
|
||||
{ $subsection "calendar-facts" }
|
||||
{ $subsections "calendar-facts" }
|
||||
;
|
||||
|
||||
ARTICLE: "timestamp-arithmetic" "Timestamp arithmetic"
|
||||
"Adding timestamps and durations, or durations and durations:"
|
||||
{ $subsection time+ }
|
||||
{ $subsections time+ }
|
||||
"Subtracting:"
|
||||
{ $subsection time- }
|
||||
{ $subsections time- }
|
||||
"Element-wise multiplication:"
|
||||
{ $subsection time* } ;
|
||||
{ $subsections time* } ;
|
||||
|
||||
ARTICLE: "using-durations" "Using durations"
|
||||
"Creating a duration object:"
|
||||
{ $subsection years }
|
||||
{ $subsection months }
|
||||
{ $subsection weeks }
|
||||
{ $subsection days }
|
||||
{ $subsection hours }
|
||||
{ $subsection minutes }
|
||||
{ $subsection seconds }
|
||||
{ $subsection milliseconds }
|
||||
{ $subsection microseconds }
|
||||
{ $subsection nanoseconds }
|
||||
{ $subsection instant }
|
||||
{ $subsections
|
||||
years
|
||||
months
|
||||
weeks
|
||||
days
|
||||
hours
|
||||
minutes
|
||||
seconds
|
||||
milliseconds
|
||||
microseconds
|
||||
nanoseconds
|
||||
instant
|
||||
}
|
||||
"Converting a duration to a number:"
|
||||
{ $subsection duration>years }
|
||||
{ $subsection duration>months }
|
||||
{ $subsection duration>days }
|
||||
{ $subsection duration>hours }
|
||||
{ $subsection duration>minutes }
|
||||
{ $subsection duration>seconds }
|
||||
{ $subsection duration>milliseconds }
|
||||
{ $subsection duration>microseconds }
|
||||
{ $subsection duration>nanoseconds } ;
|
||||
{ $subsections
|
||||
duration>years
|
||||
duration>months
|
||||
duration>days
|
||||
duration>hours
|
||||
duration>minutes
|
||||
duration>seconds
|
||||
duration>milliseconds
|
||||
duration>microseconds
|
||||
duration>nanoseconds
|
||||
} ;
|
||||
|
||||
ARTICLE: "relative-timestamps" "Relative timestamps"
|
||||
"In the future:"
|
||||
{ $subsection hence }
|
||||
{ $subsections hence }
|
||||
"In the past:"
|
||||
{ $subsection ago }
|
||||
{ $subsections ago }
|
||||
"Invert a duration:"
|
||||
{ $subsection before }
|
||||
{ $subsections before }
|
||||
"Days of the week relative to " { $link now } ":"
|
||||
{ $subsection sunday }
|
||||
{ $subsection monday }
|
||||
{ $subsection tuesday }
|
||||
{ $subsection wednesday }
|
||||
{ $subsection thursday }
|
||||
{ $subsection friday }
|
||||
{ $subsection saturday }
|
||||
{ $subsections
|
||||
sunday
|
||||
monday
|
||||
tuesday
|
||||
wednesday
|
||||
thursday
|
||||
friday
|
||||
saturday
|
||||
}
|
||||
"New timestamps relative to calendar events:"
|
||||
{ $subsection beginning-of-year }
|
||||
{ $subsection beginning-of-month }
|
||||
{ $subsection beginning-of-week }
|
||||
{ $subsection midnight }
|
||||
{ $subsection noon }
|
||||
;
|
||||
{ $subsections
|
||||
beginning-of-year
|
||||
beginning-of-month
|
||||
beginning-of-week
|
||||
midnight
|
||||
noon
|
||||
} ;
|
||||
|
||||
ARTICLE: "days" "Day operations"
|
||||
"Naming days:"
|
||||
{ $subsection day-abbreviation2 }
|
||||
{ $subsection day-abbreviations2 }
|
||||
{ $subsection day-abbreviation3 }
|
||||
{ $subsection day-abbreviations3 }
|
||||
{ $subsection day-name }
|
||||
{ $subsection day-names }
|
||||
{ $subsections
|
||||
day-abbreviation2
|
||||
day-abbreviations2
|
||||
day-abbreviation3
|
||||
day-abbreviations3
|
||||
day-name
|
||||
day-names
|
||||
}
|
||||
"Calculating a Julian day number:"
|
||||
{ $subsection julian-day-number }
|
||||
{ $subsections julian-day-number }
|
||||
"Calculate a timestamp:"
|
||||
{ $subsection julian-day-number>date }
|
||||
;
|
||||
{ $subsections julian-day-number>date } ;
|
||||
|
||||
ARTICLE: "calendar-facts" "Calendar facts"
|
||||
"Calendar facts:"
|
||||
{ $subsection average-month }
|
||||
{ $subsection months-per-year }
|
||||
{ $subsection days-per-year }
|
||||
{ $subsection hours-per-year }
|
||||
{ $subsection minutes-per-year }
|
||||
{ $subsection seconds-per-year }
|
||||
{ $subsection days-in-month }
|
||||
{ $subsection day-of-year }
|
||||
{ $subsection day-of-week }
|
||||
;
|
||||
{ $subsections
|
||||
average-month
|
||||
months-per-year
|
||||
days-per-year
|
||||
hours-per-year
|
||||
minutes-per-year
|
||||
seconds-per-year
|
||||
days-in-month
|
||||
day-of-year
|
||||
day-of-week
|
||||
} ;
|
||||
|
||||
ARTICLE: "years" "Year operations"
|
||||
"Leap year predicate:"
|
||||
{ $subsection leap-year? }
|
||||
{ $subsections leap-year? }
|
||||
"Find the number of days in a year:"
|
||||
{ $subsection days-in-year }
|
||||
;
|
||||
{ $subsections days-in-year } ;
|
||||
|
||||
ARTICLE: "months" "Month operations"
|
||||
"Naming months:"
|
||||
{ $subsection month-name }
|
||||
{ $subsection month-names }
|
||||
{ $subsection month-abbreviation }
|
||||
{ $subsection month-abbreviations }
|
||||
;
|
||||
{ $subsections
|
||||
month-name
|
||||
month-names
|
||||
month-abbreviation
|
||||
month-abbreviations
|
||||
} ;
|
||||
|
||||
ABOUT: "calendar"
|
||||
|
|
|
|||
|
|
@ -37,10 +37,10 @@ HELP: from
|
|||
ARTICLE: "channels" "Channels"
|
||||
"The " { $vocab-link "channels" } " vocabulary provides a simple abstraction to send and receive objects." $nl
|
||||
"Opening a channel:"
|
||||
{ $subsection <channel> }
|
||||
{ $subsections <channel> }
|
||||
"Sending a message:"
|
||||
{ $subsection to }
|
||||
{ $subsections to }
|
||||
"Receiving a message:"
|
||||
{ $subsection from } ;
|
||||
{ $subsections from } ;
|
||||
|
||||
ABOUT: "channels"
|
||||
|
|
|
|||
|
|
@ -6,6 +6,6 @@ HELP: adler-32
|
|||
|
||||
ARTICLE: "checksums.adler-32" "Adler-32 checksum"
|
||||
"The Adler-32 checksum algorithm implements simple and fast checksum. It is used in zlib and rsync."
|
||||
{ $subsection adler-32 } ;
|
||||
{ $subsections adler-32 } ;
|
||||
|
||||
ABOUT: "checksums.adler-32"
|
||||
|
|
|
|||
|
|
@ -44,24 +44,29 @@ HELP: fnv1a-1024
|
|||
|
||||
ARTICLE: "checksums.fnv1" "Fowler-Noll-Vo checksum"
|
||||
"The Fowler-Noll-Vo checksum algorithm is another simple and fast checksum. It comes in 32, 64, 128, 256, 512 and 1024-bit versions, each in 1 and 1a variants. The 1a variants tend to produce a slightly better result. See http://en.wikipedia.org/wiki/Fowler_Noll_Vo_hash for more details."
|
||||
|
||||
{ $subsection fnv1-32 }
|
||||
{ $subsection fnv1a-32 }
|
||||
|
||||
{ $subsection fnv1-64 }
|
||||
{ $subsection fnv1a-64 }
|
||||
|
||||
{ $subsection fnv1-128 }
|
||||
{ $subsection fnv1a-128 }
|
||||
|
||||
{ $subsection fnv1-256 }
|
||||
{ $subsection fnv1a-256 }
|
||||
|
||||
{ $subsection fnv1-512 }
|
||||
{ $subsection fnv1a-512 }
|
||||
|
||||
{ $subsection fnv1-1024 }
|
||||
{ $subsection fnv1a-1024 }
|
||||
;
|
||||
{ $subsections
|
||||
fnv1-32
|
||||
fnv1a-32
|
||||
}
|
||||
{ $subsections
|
||||
fnv1-64
|
||||
fnv1a-64
|
||||
}
|
||||
{ $subsections
|
||||
fnv1-128
|
||||
fnv1a-128
|
||||
}
|
||||
{ $subsections
|
||||
fnv1-256
|
||||
fnv1a-256
|
||||
}
|
||||
{ $subsections
|
||||
fnv1-512
|
||||
fnv1a-512
|
||||
}
|
||||
{ $subsections
|
||||
fnv1-1024
|
||||
fnv1a-1024
|
||||
} ;
|
||||
|
||||
ABOUT: "checksums.fnv1"
|
||||
|
|
|
|||
|
|
@ -6,6 +6,6 @@ HELP: md5
|
|||
|
||||
ARTICLE: "checksums.md5" "MD5 checksum"
|
||||
"The MD5 checksum algorithm implements a one-way hash function. While it is widely used, many weaknesses are known and it should not be used in new applications (" { $url "http://www.schneier.com/blog/archives/2005/03/more_hash_funct.html" } ")."
|
||||
{ $subsection md5 } ;
|
||||
{ $subsections md5 } ;
|
||||
|
||||
ABOUT: "checksums.md5"
|
||||
|
|
|
|||
|
|
@ -1,7 +1,8 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: byte-arrays checksums checksums.md5 io.encodings.binary
|
||||
io.streams.byte-array kernel math namespaces tools.test ;
|
||||
io.streams.byte-array kernel math namespaces tools.test
|
||||
sequences ;
|
||||
IN: checksums.md5.tests
|
||||
|
||||
[ "d41d8cd98f00b204e9800998ecf8427e" ] [ "" >byte-array md5 checksum-bytes hex-string ] unit-test
|
||||
|
|
@ -33,3 +34,9 @@ IN: checksums.md5.tests
|
|||
<md5-state> "asdf" binary <byte-reader> add-checksum-stream
|
||||
[ get-checksum ] [ get-checksum ] bi =
|
||||
] unit-test
|
||||
|
||||
[
|
||||
t
|
||||
] [
|
||||
{ "abcd" "efg" } md5 checksum-lines length 16 =
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -21,14 +21,16 @@ HELP: unknown-digest
|
|||
|
||||
ARTICLE: "checksums.openssl" "OpenSSL checksums"
|
||||
"The OpenSSL library provides a large number of efficient checksum (message digest) algorithms which may be used independently of its SSL functionality."
|
||||
{ $subsection openssl-checksum }
|
||||
{ $subsections openssl-checksum }
|
||||
"Constructing a checksum from a known name:"
|
||||
{ $subsection <openssl-checksum> }
|
||||
{ $subsections <openssl-checksum> }
|
||||
"Two utility words:"
|
||||
{ $subsection openssl-md5 }
|
||||
{ $subsection openssl-sha1 }
|
||||
{ $subsections
|
||||
openssl-md5
|
||||
openssl-sha1
|
||||
}
|
||||
"An error thrown if the digest name is unrecognized:"
|
||||
{ $subsection unknown-digest }
|
||||
{ $subsections unknown-digest }
|
||||
"An example where we compute the SHA1 checksum of a string using the OpenSSL implementation of SHA1:"
|
||||
{ $example "USING: byte-arrays checksums checksums.openssl ;" "\"hello world\" >byte-array openssl-sha1 checksum-bytes hex-string ." "\"2aae6c35c94fcfb415dbe95f408b9ce91ee846ed\"" }
|
||||
"If we use the Factor implementation, we get the same result, just slightly slower:"
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
! Copyright (C) 2008 Slava Pestov
|
||||
! copyright (C) 2008 Slava Pestov
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors byte-arrays alien.c-types alien.data kernel
|
||||
continuations destructors sequences io openssl openssl.libcrypto
|
||||
|
|
@ -23,10 +23,10 @@ TUPLE: evp-md-context < disposable handle ;
|
|||
|
||||
: <evp-md-context> ( -- ctx )
|
||||
evp-md-context new-disposable
|
||||
EVP_MD_CTX <struct> dup EVP_MD_CTX_init >>handle ;
|
||||
EVP_MD_CTX_create >>handle ;
|
||||
|
||||
M: evp-md-context dispose*
|
||||
handle>> EVP_MD_CTX_cleanup drop ;
|
||||
handle>> EVP_MD_CTX_destroy ;
|
||||
|
||||
: with-evp-md-context ( quot -- )
|
||||
maybe-init-ssl [ <evp-md-context> ] dip with-disposal ; inline
|
||||
|
|
|
|||
|
|
@ -10,9 +10,11 @@ HELP: sha-256
|
|||
ARTICLE: "checksums.sha" "SHA-2 checksum"
|
||||
"The SHA family of checksum algorithms are one-way hashes useful for checksumming data. SHA-1 is considered insecure, while SHA-2 It is generally considered to be pretty strong." $nl
|
||||
"SHA-2 checksums:"
|
||||
{ $subsection sha-224 }
|
||||
{ $subsection sha-256 }
|
||||
{ $subsections
|
||||
sha-224
|
||||
sha-256
|
||||
}
|
||||
"SHA-1 checksum:"
|
||||
{ $subsection sha1 } ;
|
||||
{ $subsections sha1 } ;
|
||||
|
||||
ABOUT: "checksums.sha"
|
||||
|
|
|
|||
|
|
@ -51,14 +51,20 @@ HELP: rotate-circular
|
|||
ARTICLE: "circular" "Circular sequences"
|
||||
"The " { $vocab-link "circular" } " vocabulary implements the " { $link "sequence-protocol" } " to allow an arbitrary start index and wrap-around indexing." $nl
|
||||
"Creating a new circular object:"
|
||||
{ $subsection <circular> }
|
||||
{ $subsection <circular-string> }
|
||||
{ $subsection <growing-circular> }
|
||||
{ $subsections
|
||||
<circular>
|
||||
<circular-string>
|
||||
<growing-circular>
|
||||
}
|
||||
"Changing the start index:"
|
||||
{ $subsection change-circular-start }
|
||||
{ $subsection rotate-circular }
|
||||
{ $subsections
|
||||
change-circular-start
|
||||
rotate-circular
|
||||
}
|
||||
"Pushing new elements:"
|
||||
{ $subsection push-circular }
|
||||
{ $subsection push-growing-circular } ;
|
||||
{ $subsections
|
||||
push-circular
|
||||
push-growing-circular
|
||||
} ;
|
||||
|
||||
ABOUT: "circular"
|
||||
|
|
|
|||
|
|
@ -0,0 +1,7 @@
|
|||
! Copyright (C) 2009 Daniel Ehrenberg
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: classes.struct.bit-accessors tools.test effects kernel random stack-checker ;
|
||||
IN: classes.struct.bit-accessors.test
|
||||
|
||||
[ t ] [ 20 random 20 random bit-reader infer (( alien -- n )) effect= ] unit-test
|
||||
[ t ] [ 20 random 20 random bit-writer infer (( n alien -- )) effect= ] unit-test
|
||||
|
|
@ -0,0 +1,46 @@
|
|||
! Copyright (C) 2009 Daniel Ehrenberg
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel sequences math fry locals math.order alien.accessors ;
|
||||
IN: classes.struct.bit-accessors
|
||||
|
||||
! Bitfield accessors are little-endian on all platforms
|
||||
! Why not? It's unspecified in C
|
||||
|
||||
: ones-between ( start end -- n )
|
||||
[ 2^ 1 - ] bi@ swap bitnot bitand ;
|
||||
|
||||
:: manipulate-bits ( offset bits step-quot -- quot shift-amount offset' bits' )
|
||||
offset 8 /mod :> start-bit :> i
|
||||
start-bit bits + 8 min :> end-bit
|
||||
start-bit end-bit ones-between :> mask
|
||||
end-bit start-bit - :> used-bits
|
||||
|
||||
i mask start-bit step-quot call( i mask start-bit -- quot )
|
||||
used-bits
|
||||
i 1 + 8 *
|
||||
bits used-bits - ; inline
|
||||
|
||||
:: bit-manipulator ( offset bits
|
||||
step-quot: ( i mask start-bit -- quot )
|
||||
combine-quot: ( prev-quot shift-amount next-quot -- quot )
|
||||
-- quot )
|
||||
offset bits step-quot manipulate-bits
|
||||
dup zero? [ 3drop ] [
|
||||
step-quot combine-quot bit-manipulator
|
||||
combine-quot call( prev shift next -- quot )
|
||||
] if ; inline recursive
|
||||
|
||||
: bit-reader ( offset bits -- quot: ( alien -- n ) )
|
||||
[ neg '[ _ alien-unsigned-1 _ bitand _ shift ] ]
|
||||
[ swap '[ _ _ bi _ shift bitor ] ]
|
||||
bit-manipulator ;
|
||||
|
||||
:: write-bits ( n alien i mask start-bit -- )
|
||||
n start-bit shift mask bitand
|
||||
alien i alien-unsigned-1 mask bitnot bitand
|
||||
bitor alien i set-alien-unsigned-1 ; inline
|
||||
|
||||
: bit-writer ( offset bits -- quot: ( n alien -- ) )
|
||||
[ '[ _ _ _ write-bits ] ]
|
||||
[ '[ _ [ [ _ neg shift ] dip @ ] 2bi ] ]
|
||||
bit-manipulator ;
|
||||
|
|
@ -23,6 +23,11 @@ IN: classes.struct.prettyprint
|
|||
[ type>> pprint-c-type ]
|
||||
[ read-only>> [ \ read-only pprint-word ] when ]
|
||||
[ initial>> [ \ initial: pprint-word pprint* ] when* ]
|
||||
[
|
||||
dup struct-bit-slot-spec?
|
||||
[ \ bits: pprint-word bits>> pprint* ]
|
||||
[ drop ] if
|
||||
]
|
||||
} cleave block>
|
||||
\ } pprint-word block> ;
|
||||
|
||||
|
|
|
|||
|
|
@ -95,21 +95,84 @@ HELP: struct
|
|||
HELP: struct-class
|
||||
{ $class-description "The metaclass of all " { $link struct } " classes." } ;
|
||||
|
||||
ARTICLE: "classes.struct" "Struct classes"
|
||||
{ $link struct } " classes are similar to " { $link tuple } "s, but their slots exhibit value semantics, and they are backed by a contiguous structured block of memory. Structs can be used for structured access to C memory or Factor byte arrays and for passing struct values in and out of the FFI. Struct types are defined using a syntax similar to tuple syntax:"
|
||||
{ $subsection POSTPONE: STRUCT: }
|
||||
ARTICLE: "classes.struct.examples" "Struct class examples"
|
||||
"A struct with a variety of fields:"
|
||||
{ $code
|
||||
"USING: alien.c-types classes.struct ;"
|
||||
""
|
||||
"STRUCT: test-struct"
|
||||
" { i int }"
|
||||
" { chicken char[16] }"
|
||||
" { data void* } ;"
|
||||
}
|
||||
"Creating a new instance of this struct, and printing out:"
|
||||
{ $code "test-struct <struct> ." }
|
||||
"Creating a new instance with slots initialized from the stack:"
|
||||
{ $code
|
||||
"USING: libc specialized-arrays ;"
|
||||
"SPECIALIZED-ARRAY: char"
|
||||
""
|
||||
"42"
|
||||
"\"Hello, chicken.\" >char-array"
|
||||
"1024 malloc"
|
||||
"test-struct <struct-boa> ."
|
||||
} ;
|
||||
|
||||
ARTICLE: "classes.struct.define" "Defining struct classes"
|
||||
"Struct classes are defined using a syntax similar to the " { $link POSTPONE: TUPLE: } " syntax for defining tuple classes:"
|
||||
{ $subsections POSTPONE: STRUCT: }
|
||||
"Union structs are also supported, which behave like structs but share the same memory for all the slots."
|
||||
{ $subsections POSTPONE: UNION-STRUCT: } ;
|
||||
|
||||
ARTICLE: "classes.struct.create" "Creating instances of structs"
|
||||
"Structs can be allocated with " { $link new } "- and " { $link boa } "-like constructor words. Additional words are provided for building structs from C memory and from existing buffers:"
|
||||
{ $subsection <struct> }
|
||||
{ $subsection <struct-boa> }
|
||||
{ $subsection malloc-struct }
|
||||
{ $subsection memory>struct }
|
||||
{ $subsections
|
||||
<struct>
|
||||
<struct-boa>
|
||||
malloc-struct
|
||||
memory>struct
|
||||
}
|
||||
"When the contents of a struct will be immediately reset, faster primitive words are available that will create a struct without initializing its contents:"
|
||||
{ $subsection (struct) }
|
||||
{ $subsection (malloc-struct) }
|
||||
"Structs have literal syntax like tuples:"
|
||||
{ $subsection POSTPONE: S{ }
|
||||
"Union structs are also supported, which behave like structs but share the same memory for all the type's slots."
|
||||
{ $subsection POSTPONE: UNION-STRUCT: }
|
||||
;
|
||||
{ $subsections
|
||||
(struct)
|
||||
(malloc-struct)
|
||||
}
|
||||
"Structs have literal syntax, similar to " { $link POSTPONE: T{ } " for tuples:"
|
||||
{ $subsections POSTPONE: S{ } ;
|
||||
|
||||
ARTICLE: "classes.struct.c" "Passing structs to C functions"
|
||||
"Structs can be passed and returned by value, or by reference."
|
||||
$nl
|
||||
"If a parameter is declared with a struct type, the parameter is passed by value. To pass a struct by reference, declare a parameter with a pointer to struct type."
|
||||
$nl
|
||||
"If a C function is declared as returning a struct type, the struct is returned by value, and wrapped in an instance of the correct struct class automatically. If a C function is declared as returning a pointer to a struct, it will return an " { $link alien } " instance. This is because there is no way to distinguish between a pointer to a single struct and a pointer to an array of zero or more structs. It is up to the caller to wrap it in a struct, or a specialized array of structs, respectively."
|
||||
$nl
|
||||
"An example of a struct declaration:"
|
||||
{ $code
|
||||
"USING: alien.c-types classes.struct ;"
|
||||
""
|
||||
"STRUCT: Point"
|
||||
" { x int }"
|
||||
" { y int }"
|
||||
" { z int } ;"
|
||||
}
|
||||
"A C function which returns a struct by value:"
|
||||
{ $code
|
||||
"USING: alien.syntax ;"
|
||||
"FUNCTION: Point give_me_a_point ( char* description ) ;"
|
||||
}
|
||||
"A C function which takes a struct parameter by reference:"
|
||||
{ $code
|
||||
"FUNCTION: void print_point ( Point* p ) ;"
|
||||
} ;
|
||||
|
||||
ARTICLE: "classes.struct" "Struct classes"
|
||||
"The " { $vocab-link "classes.struct" } " vocabulary implements " { $link struct } " classes. They are similar to " { $link tuple } " classes, but their slots exhibit value semantics, and they are backed by a contiguous structured block of memory. Structs can be used for space-efficient storage of data in the Factor heap, as well as for passing data to and from C libraries using the " { $link "alien" } "."
|
||||
{ $subsections
|
||||
"classes.struct.examples"
|
||||
"classes.struct.define"
|
||||
"classes.struct.create"
|
||||
"classes.struct.c"
|
||||
} ;
|
||||
|
||||
ABOUT: "classes.struct"
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@ USING: accessors alien alien.c-types alien.data ascii
|
|||
assocs byte-arrays classes.struct classes.tuple.private
|
||||
combinators compiler.tree.debugger compiler.units destructors
|
||||
io.encodings.utf8 io.pathnames io.streams.string kernel libc
|
||||
literals math mirrors multiline namespaces prettyprint
|
||||
literals math mirrors namespaces prettyprint
|
||||
prettyprint.config see sequences specialized-arrays system
|
||||
tools.test parser lexer eval layouts ;
|
||||
FROM: math => float ;
|
||||
|
|
@ -183,18 +183,18 @@ STRUCT: struct-test-string-ptr
|
|||
] with-scope
|
||||
] unit-test
|
||||
|
||||
[ <" USING: alien.c-types classes.struct ;
|
||||
[ "USING: alien.c-types classes.struct ;
|
||||
IN: classes.struct.tests
|
||||
STRUCT: struct-test-foo
|
||||
{ x char initial: 0 } { y int initial: 123 } { z bool } ;
|
||||
"> ]
|
||||
" ]
|
||||
[ [ struct-test-foo see ] with-string-writer ] unit-test
|
||||
|
||||
[ <" USING: alien.c-types classes.struct ;
|
||||
[ "USING: alien.c-types classes.struct ;
|
||||
IN: classes.struct.tests
|
||||
UNION-STRUCT: struct-test-float-and-bits
|
||||
{ f float initial: 0.0 } { bits uint initial: 0 } ;
|
||||
"> ]
|
||||
" ]
|
||||
[ [ struct-test-float-and-bits see ] with-string-writer ] unit-test
|
||||
|
||||
[ {
|
||||
|
|
@ -352,3 +352,16 @@ STRUCT: struct-that's-a-word { x int } ;
|
|||
] unit-test
|
||||
|
||||
[ f ] [ "a-struct" c-types get key? ] unit-test
|
||||
|
||||
STRUCT: bit-field-test
|
||||
{ a uint bits: 12 }
|
||||
{ b int bits: 2 }
|
||||
{ c char } ;
|
||||
|
||||
[ S{ bit-field-test f 0 0 0 } ] [ bit-field-test <struct> ] unit-test
|
||||
[ S{ bit-field-test f 1 -2 3 } ] [ bit-field-test <struct> 1 >>a 2 >>b 3 >>c ] unit-test
|
||||
[ 4095 ] [ bit-field-test <struct> 8191 >>a a>> ] unit-test
|
||||
[ 1 ] [ bit-field-test <struct> 1 >>b b>> ] unit-test
|
||||
[ -2 ] [ bit-field-test <struct> 2 >>b b>> ] unit-test
|
||||
[ 1 ] [ bit-field-test <struct> 257 >>c c>> ] unit-test
|
||||
[ 3 ] [ bit-field-test heap-size ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
! (c)Joe Groff bsd license
|
||||
! (c)Joe Groff, Daniel Ehrenberg bsd license
|
||||
USING: accessors alien alien.c-types alien.data alien.parser arrays
|
||||
byte-arrays classes classes.parser classes.tuple classes.tuple.parser
|
||||
classes.tuple.private combinators combinators.short-circuit
|
||||
|
|
@ -6,7 +6,9 @@ combinators.smart cpu.architecture definitions functors.backend
|
|||
fry generalizations generic.parser kernel kernel.private lexer
|
||||
libc locals macros make math math.order parser quotations
|
||||
sequences slots slots.private specialized-arrays vectors words
|
||||
summary namespaces assocs vocabs.parser ;
|
||||
summary namespaces assocs vocabs.parser math.functions
|
||||
classes.struct.bit-accessors bit-arrays ;
|
||||
QUALIFIED: math
|
||||
IN: classes.struct
|
||||
|
||||
SPECIALIZED-ARRAY: uchar
|
||||
|
|
@ -22,14 +24,19 @@ TUPLE: struct
|
|||
TUPLE: struct-slot-spec < slot-spec
|
||||
type ;
|
||||
|
||||
! For a struct-bit-slot-spec, offset is in bits, not bytes
|
||||
TUPLE: struct-bit-slot-spec < struct-slot-spec
|
||||
bits signed? ;
|
||||
|
||||
PREDICATE: struct-class < tuple-class
|
||||
superclass \ struct eq? ;
|
||||
|
||||
M: struct-class valid-superclass? drop f ;
|
||||
|
||||
GENERIC: struct-slots ( struct-class -- slots )
|
||||
SLOT: fields
|
||||
|
||||
M: struct-class struct-slots "struct-slots" word-prop ;
|
||||
: struct-slots ( struct-class -- slots )
|
||||
"c-type" word-prop fields>> ;
|
||||
|
||||
! struct allocation
|
||||
|
||||
|
|
@ -83,14 +90,36 @@ MACRO: <struct-boa> ( class -- quot: ( ... -- struct ) )
|
|||
: pad-struct-slots ( values class -- values' class )
|
||||
[ struct-slots [ initial>> ] map over length tail append ] keep ;
|
||||
|
||||
: (reader-quot) ( slot -- quot )
|
||||
: sign-extend ( n bits -- n' )
|
||||
! formula from:
|
||||
! http://guru.multimedia.cx/fast-sign-extension/
|
||||
1 - -1 swap shift [ + ] keep bitxor ; inline
|
||||
|
||||
: sign-extender ( signed? bits -- quot )
|
||||
'[ _ [ _ sign-extend ] when ] ;
|
||||
|
||||
GENERIC: (reader-quot) ( slot -- quot )
|
||||
|
||||
M: struct-slot-spec (reader-quot)
|
||||
[ type>> c-type-getter-boxer ]
|
||||
[ offset>> [ >c-ptr ] swap suffix ] bi prepend ;
|
||||
|
||||
: (writer-quot) ( slot -- quot )
|
||||
M: struct-bit-slot-spec (reader-quot)
|
||||
[ [ offset>> ] [ bits>> ] bi bit-reader ]
|
||||
[ [ signed?>> ] [ bits>> ] bi sign-extender ]
|
||||
bi compose
|
||||
[ >c-ptr ] prepose ;
|
||||
|
||||
GENERIC: (writer-quot) ( slot -- quot )
|
||||
|
||||
M: struct-slot-spec (writer-quot)
|
||||
[ type>> c-setter ]
|
||||
[ offset>> [ >c-ptr ] swap suffix ] bi prepend ;
|
||||
|
||||
M: struct-bit-slot-spec (writer-quot)
|
||||
[ offset>> ] [ bits>> ] bi bit-writer
|
||||
[ >c-ptr ] prepose ;
|
||||
|
||||
: (boxer-quot) ( class -- quot )
|
||||
'[ _ memory>struct ] ;
|
||||
|
||||
|
|
@ -103,6 +132,8 @@ M: struct-class boa>object
|
|||
[ <struct> ] [ struct-slots ] bi
|
||||
[ [ (writer-quot) call( value struct -- ) ] with 2each ] curry keep ;
|
||||
|
||||
M: struct-class initial-value* <struct> ; inline
|
||||
|
||||
! Struct slot accessors
|
||||
|
||||
GENERIC: struct-slot-values ( struct -- sequence )
|
||||
|
|
@ -113,6 +144,9 @@ M: struct-class reader-quot
|
|||
M: struct-class writer-quot
|
||||
nip (writer-quot) ;
|
||||
|
||||
: offset-of ( field struct -- offset )
|
||||
struct-slots slot-named offset>> ; inline
|
||||
|
||||
! c-types
|
||||
|
||||
TUPLE: struct-c-type < abstract-c-type
|
||||
|
|
@ -170,31 +204,34 @@ M: struct-c-type c-struct? drop t ;
|
|||
[ \ clone-underlying swap literalize \ memory>struct [ ] 3sequence ] bi
|
||||
define-inline-method ;
|
||||
|
||||
: c-type-for-class ( class -- c-type )
|
||||
struct-c-type new swap {
|
||||
[ drop byte-array >>class ]
|
||||
[ >>boxed-class ]
|
||||
[ struct-slots >>fields ]
|
||||
[ "struct-size" word-prop >>size ]
|
||||
[ "struct-align" word-prop >>align ]
|
||||
[ (unboxer-quot) >>unboxer-quot ]
|
||||
[ (boxer-quot) >>boxer-quot ]
|
||||
} cleave ;
|
||||
:: c-type-for-class ( class slots size align -- c-type )
|
||||
struct-c-type new
|
||||
byte-array >>class
|
||||
class >>boxed-class
|
||||
slots >>fields
|
||||
size >>size
|
||||
align >>align
|
||||
class (unboxer-quot) >>unboxer-quot
|
||||
class (boxer-quot) >>boxer-quot ;
|
||||
|
||||
: align-offset ( offset class -- offset' )
|
||||
c-type-align align ;
|
||||
GENERIC: align-offset ( offset class -- offset' )
|
||||
|
||||
M: struct-slot-spec align-offset
|
||||
[ type>> c-type-align 8 * align ] keep
|
||||
[ [ 8 /i ] dip (>>offset) ] [ type>> heap-size 8 * + ] 2bi ;
|
||||
|
||||
M: struct-bit-slot-spec align-offset
|
||||
[ (>>offset) ] [ bits>> + ] 2bi ;
|
||||
|
||||
: struct-offsets ( slots -- size )
|
||||
0 [
|
||||
[ type>> align-offset ] keep
|
||||
[ (>>offset) ] [ type>> heap-size + ] 2bi
|
||||
] reduce ;
|
||||
0 [ align-offset ] reduce 8 align 8 /i ;
|
||||
|
||||
: union-struct-offsets ( slots -- size )
|
||||
[ 0 >>offset type>> heap-size ] [ max ] map-reduce ;
|
||||
1 [ 0 >>offset type>> heap-size max ] reduce ;
|
||||
|
||||
: struct-align ( slots -- align )
|
||||
[ type>> c-type-align ] [ max ] map-reduce ;
|
||||
[ struct-bit-slot-spec? not ] filter
|
||||
1 [ type>> c-type-align max ] reduce ;
|
||||
PRIVATE>
|
||||
|
||||
M: struct byte-length class "struct-size" word-prop ; foldable
|
||||
|
|
@ -202,50 +239,55 @@ M: struct byte-length class "struct-size" word-prop ; foldable
|
|||
! class definition
|
||||
|
||||
<PRIVATE
|
||||
GENERIC: binary-zero? ( value -- ? )
|
||||
|
||||
M: object binary-zero? drop f ;
|
||||
M: f binary-zero? drop t ;
|
||||
M: number binary-zero? zero? ;
|
||||
M: struct binary-zero?
|
||||
[ byte-length iota ] [ >c-ptr ] bi
|
||||
[ <displaced-alien> *uchar zero? ] curry all? ;
|
||||
|
||||
: struct-needs-prototype? ( class -- ? )
|
||||
struct-slots [ initial>> binary-zero? ] all? not ;
|
||||
|
||||
: make-struct-prototype ( class -- prototype )
|
||||
[ "struct-size" word-prop <byte-array> ]
|
||||
[ memory>struct ]
|
||||
[ struct-slots ] tri
|
||||
[
|
||||
[ initial>> ]
|
||||
[ (writer-quot) ] bi
|
||||
over [ swapd [ call( value struct -- ) ] curry keep ] [ 2drop ] if
|
||||
] each ;
|
||||
dup struct-needs-prototype? [
|
||||
[ "c-type" word-prop size>> <byte-array> ]
|
||||
[ memory>struct ]
|
||||
[ struct-slots ] tri
|
||||
[
|
||||
[ initial>> ]
|
||||
[ (writer-quot) ] bi
|
||||
over [ swapd [ call( value struct -- ) ] curry keep ] [ 2drop ] if
|
||||
] each
|
||||
] [ drop f ] if ;
|
||||
|
||||
: (struct-methods) ( class -- )
|
||||
[ (define-struct-slot-values-method) ]
|
||||
[ (define-clone-method) ]
|
||||
bi ;
|
||||
|
||||
: (struct-word-props) ( class slots size align -- )
|
||||
[
|
||||
[ "struct-slots" set-word-prop ]
|
||||
[ define-accessors ] 2bi
|
||||
]
|
||||
[ "struct-size" set-word-prop ]
|
||||
[ "struct-align" set-word-prop ] tri-curry*
|
||||
[ tri ] 3curry
|
||||
[ dup make-struct-prototype "prototype" set-word-prop ]
|
||||
[ (struct-methods) ] tri ;
|
||||
|
||||
: check-struct-slots ( slots -- )
|
||||
[ type>> c-type drop ] each ;
|
||||
|
||||
: redefine-struct-tuple-class ( class -- )
|
||||
[ dup class? [ forget-class ] [ drop ] if ] [ struct f define-tuple-class ] bi ;
|
||||
|
||||
: (define-struct-class) ( class slots offsets-quot -- )
|
||||
[
|
||||
empty?
|
||||
[ struct-must-have-slots ]
|
||||
[ redefine-struct-tuple-class ] if
|
||||
]
|
||||
swap '[
|
||||
make-slots dup
|
||||
[ check-struct-slots ] _ [ struct-align [ align ] keep ] tri
|
||||
(struct-word-props)
|
||||
]
|
||||
[ drop [ c-type-for-class ] keep typedef ] 2tri ; inline
|
||||
:: (define-struct-class) ( class slots offsets-quot -- )
|
||||
slots empty? [ struct-must-have-slots ] when
|
||||
class redefine-struct-tuple-class
|
||||
slots make-slots dup check-struct-slots :> slot-specs
|
||||
slot-specs struct-align :> alignment
|
||||
slot-specs offsets-quot call alignment align :> size
|
||||
|
||||
class slot-specs size alignment c-type-for-class :> c-type
|
||||
|
||||
c-type class typedef
|
||||
class slot-specs define-accessors
|
||||
class size "struct-size" set-word-prop
|
||||
class dup make-struct-prototype "prototype" set-word-prop
|
||||
class (struct-methods) ; inline
|
||||
PRIVATE>
|
||||
|
||||
: define-struct-class ( class slots -- )
|
||||
|
|
@ -263,11 +305,43 @@ ERROR: invalid-struct-slot token ;
|
|||
c-type c-type-boxed-class
|
||||
dup \ byte-array = [ drop \ c-ptr ] when ;
|
||||
|
||||
SYMBOL: bits:
|
||||
|
||||
<PRIVATE
|
||||
|
||||
ERROR: bad-type-for-bits type ;
|
||||
|
||||
:: set-bits ( slot-spec n -- slot-spec )
|
||||
struct-bit-slot-spec new
|
||||
n >>bits
|
||||
slot-spec type>> {
|
||||
{ int [ t ] }
|
||||
{ uint [ f ] }
|
||||
[ bad-type-for-bits ]
|
||||
} case >>signed?
|
||||
slot-spec name>> >>name
|
||||
slot-spec class>> >>class
|
||||
slot-spec type>> >>type
|
||||
slot-spec read-only>> >>read-only
|
||||
slot-spec initial>> >>initial ;
|
||||
|
||||
: peel-off-struct-attributes ( slot-spec array -- slot-spec array )
|
||||
dup empty? [
|
||||
unclip {
|
||||
{ initial: [ [ first >>initial ] [ rest ] bi ] }
|
||||
{ read-only [ [ t >>read-only ] dip ] }
|
||||
{ bits: [ [ first set-bits ] [ rest ] bi ] }
|
||||
[ bad-slot-attribute ]
|
||||
} case
|
||||
] unless ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: <struct-slot-spec> ( name c-type attributes -- slot-spec )
|
||||
[ struct-slot-spec new ] 3dip
|
||||
[ >>name ]
|
||||
[ [ >>type ] [ struct-slot-class >>class ] bi ]
|
||||
[ [ dup empty? ] [ peel-off-attributes ] until drop ] tri* ;
|
||||
[ [ dup empty? ] [ peel-off-struct-attributes ] until drop ] tri* ;
|
||||
|
||||
<PRIVATE
|
||||
: parse-struct-slot ( -- slot )
|
||||
|
|
|
|||
|
|
@ -41,14 +41,18 @@ HELP: objc-error
|
|||
|
||||
ARTICLE: "cocoa-application-utils" "Cocoa application utilities"
|
||||
"Utilities:"
|
||||
{ $subsection NSApp }
|
||||
{ $subsection add-observer }
|
||||
{ $subsection remove-observer }
|
||||
{ $subsection install-delegate }
|
||||
{ $subsections
|
||||
NSApp
|
||||
add-observer
|
||||
remove-observer
|
||||
install-delegate
|
||||
}
|
||||
"Combinators:"
|
||||
{ $subsection cocoa-app }
|
||||
{ $subsection with-autorelease-pool }
|
||||
{ $subsection with-cocoa } ;
|
||||
{ $subsections
|
||||
cocoa-app
|
||||
with-autorelease-pool
|
||||
with-cocoa
|
||||
} ;
|
||||
|
||||
IN: cocoa.application
|
||||
ABOUT: "cocoa-application-utils"
|
||||
|
|
|
|||
|
|
@ -25,15 +25,19 @@ HELP: IMPORT:
|
|||
|
||||
ARTICLE: "objc-calling" "Calling Objective C code"
|
||||
"Before an Objective C class can be used, it must be imported; by default, a small set of common classes are imported automatically, but additional classes can be imported as needed."
|
||||
{ $subsection POSTPONE: IMPORT: }
|
||||
{ $subsections POSTPONE: IMPORT: }
|
||||
"Every imported Objective C class has as corresponding class word in the " { $vocab-link "cocoa.classes" } " vocabulary. Class words push the class object in the stack, allowing class methods to be invoked."
|
||||
$nl
|
||||
"Messages can be sent to classes and instances using a pair of parsing words:"
|
||||
{ $subsection POSTPONE: -> }
|
||||
{ $subsection POSTPONE: SUPER-> }
|
||||
{ $subsections
|
||||
POSTPONE: ->
|
||||
POSTPONE: SUPER->
|
||||
}
|
||||
"These parsing words are actually syntax sugar for a pair of ordinary words; they can be used instead of the parsing words if the selector name is dynamically computed:"
|
||||
{ $subsection send }
|
||||
{ $subsection super-send } ;
|
||||
{ $subsections
|
||||
send
|
||||
super-send
|
||||
} ;
|
||||
|
||||
ARTICLE: "cocoa" "Cocoa bridge"
|
||||
"The " { $vocab-link "cocoa" } " vocabulary implements a Factor-Cocoa bridge for Mac OS X (GNUstep is not supported)."
|
||||
|
|
@ -41,14 +45,18 @@ $nl
|
|||
"The lowest layer uses the " { $link "alien" } " to define bindings for the various functions in Apple's Objective-C runtime. This is defined in the " { $vocab-link "cocoa.runtime" } " vocabulary."
|
||||
$nl
|
||||
"On top of this, a dynamic message send facility is built:"
|
||||
{ $subsection "objc-calling" }
|
||||
{ $subsection "objc-subclassing" }
|
||||
{ $subsections
|
||||
"objc-calling"
|
||||
"objc-subclassing"
|
||||
}
|
||||
"A utility library is built to faciliate the development of Cocoa applications in Factor:"
|
||||
{ $subsection "cocoa-application-utils" }
|
||||
{ $subsection "cocoa-dialogs" }
|
||||
{ $subsection "cocoa-pasteboard-utils" }
|
||||
{ $subsection "cocoa-view-utils" }
|
||||
{ $subsection "cocoa-window-utils" } ;
|
||||
{ $subsections
|
||||
"cocoa-application-utils"
|
||||
"cocoa-dialogs"
|
||||
"cocoa-pasteboard-utils"
|
||||
"cocoa-view-utils"
|
||||
"cocoa-window-utils"
|
||||
} ;
|
||||
|
||||
IN: cocoa
|
||||
ABOUT: "cocoa"
|
||||
|
|
|
|||
|
|
@ -19,11 +19,15 @@ HELP: save-panel
|
|||
|
||||
ARTICLE: "cocoa-dialogs" "Cocoa file dialogs"
|
||||
"Open dialogs:"
|
||||
{ $subsection <NSOpenPanel> }
|
||||
{ $subsection open-panel }
|
||||
{ $subsections
|
||||
<NSOpenPanel>
|
||||
open-panel
|
||||
}
|
||||
"Save dialogs:"
|
||||
{ $subsection <NSSavePanel> }
|
||||
{ $subsection save-panel } ;
|
||||
{ $subsections
|
||||
<NSSavePanel>
|
||||
save-panel
|
||||
} ;
|
||||
|
||||
IN: cocoa.dialogs
|
||||
ABOUT: "cocoa-dialogs"
|
||||
|
|
|
|||
|
|
@ -14,9 +14,11 @@ HELP: set-pasteboard-string
|
|||
{ $description "Sets the contents of the pasteboard." } ;
|
||||
|
||||
ARTICLE: "cocoa-pasteboard-utils" "Cocoa pasteboard utilities"
|
||||
{ $subsection pasteboard-string? }
|
||||
{ $subsection pasteboard-string }
|
||||
{ $subsection set-pasteboard-string } ;
|
||||
{ $subsections
|
||||
pasteboard-string?
|
||||
pasteboard-string
|
||||
set-pasteboard-string
|
||||
} ;
|
||||
|
||||
IN: cocoa.pasteboard
|
||||
ABOUT: "cocoa-pasteboard-utils"
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2006, 2007 Slava Pestov
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien.syntax classes.struct ;
|
||||
USING: alien.c-types alien.syntax classes.struct ;
|
||||
IN: cocoa.runtime
|
||||
|
||||
TYPEDEF: void* SEL
|
||||
|
|
|
|||
|
|
@ -37,9 +37,9 @@ HELP: CLASS:
|
|||
|
||||
ARTICLE: "objc-subclassing" "Subclassing Objective C classes"
|
||||
"Objective C classes can be subclassed, with new methods defined in Factor, using a parsing word:"
|
||||
{ $subsection POSTPONE: CLASS: }
|
||||
{ $subsections POSTPONE: CLASS: }
|
||||
"This word is actually syntax sugar for an ordinary word:"
|
||||
{ $subsection define-objc-class }
|
||||
{ $subsections define-objc-class }
|
||||
"Objective C class definitions are saved in the image. If the image is saved and Factor is restarted with the saved image, custom class definitions are made available to the Objective C runtime when they are first accessed from within Factor." ;
|
||||
|
||||
IN: cocoa.subclassing
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2006, 2009 Slava Pestov
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien.c-types alien.syntax combinators kernel layouts
|
||||
classes.struct core-graphics.types ;
|
||||
classes.struct cocoa.runtime core-graphics.types ;
|
||||
IN: cocoa.types
|
||||
|
||||
TYPEDEF: long NSInteger
|
||||
|
|
|
|||
|
|
@ -14,9 +14,11 @@ HELP: mouse-location
|
|||
{ $description "Outputs the current mouse location." } ;
|
||||
|
||||
ARTICLE: "cocoa-view-utils" "Cocoa view utilities"
|
||||
{ $subsection <GLView> }
|
||||
{ $subsection view-dim }
|
||||
{ $subsection mouse-location } ;
|
||||
{ $subsections
|
||||
<GLView>
|
||||
view-dim
|
||||
mouse-location
|
||||
} ;
|
||||
|
||||
IN: cocoa.views
|
||||
ABOUT: "cocoa-view-utils"
|
||||
|
|
|
|||
|
|
@ -40,7 +40,9 @@ CONSTANT: NSOpenGLPFAScreenMask 84
|
|||
CONSTANT: NSOpenGLPFAPixelBuffer 90
|
||||
CONSTANT: NSOpenGLPFAAllowOfflineRenderers 96
|
||||
CONSTANT: NSOpenGLPFAVirtualScreenCount 128
|
||||
|
||||
CONSTANT: NSOpenGLCPSwapInterval 222
|
||||
CONSTANT: NSOpenGLCPSurfaceOpacity 236
|
||||
|
||||
: <GLView> ( class dim pixel-format -- view )
|
||||
[ -> alloc ]
|
||||
|
|
|
|||
|
|
@ -10,8 +10,10 @@ HELP: <ViewWindow>
|
|||
{ $description "Creates a new " { $snippet "NSWindow" } " with the specified dimensions, containing the given view." } ;
|
||||
|
||||
ARTICLE: "cocoa-window-utils" "Cocoa window utilities"
|
||||
{ $subsection <NSWindow> }
|
||||
{ $subsection <ViewWindow> } ;
|
||||
{ $subsections
|
||||
<NSWindow>
|
||||
<ViewWindow>
|
||||
} ;
|
||||
|
||||
IN: cocoa.windows
|
||||
ABOUT: "cocoa-window-utils"
|
||||
|
|
|
|||
|
|
@ -5,11 +5,12 @@ sequences math.bitwise ;
|
|||
IN: cocoa.windows
|
||||
|
||||
! Window styles
|
||||
CONSTANT: NSBorderlessWindowMask 0
|
||||
CONSTANT: NSTitledWindowMask 1
|
||||
CONSTANT: NSClosableWindowMask 2
|
||||
CONSTANT: NSMiniaturizableWindowMask 4
|
||||
CONSTANT: NSResizableWindowMask 8
|
||||
CONSTANT: NSBorderlessWindowMask 0
|
||||
CONSTANT: NSTitledWindowMask 1
|
||||
CONSTANT: NSClosableWindowMask 2
|
||||
CONSTANT: NSMiniaturizableWindowMask 4
|
||||
CONSTANT: NSResizableWindowMask 8
|
||||
CONSTANT: NSTexturedBackgroundWindowMask 256
|
||||
|
||||
! Additional panel-only styles
|
||||
CONSTANT: NSUtilityWindowMask 16
|
||||
|
|
@ -26,7 +27,7 @@ CONSTANT: NSBackingStoreBuffered 2
|
|||
-> initWithContentRect:styleMask:backing:defer: ;
|
||||
|
||||
: class-for-style ( style -- NSWindow/NSPanel )
|
||||
HEX: 1ff0 bitand zero? NSWindow NSPanel ? ;
|
||||
HEX: 1ef0 bitand zero? NSWindow NSPanel ? ;
|
||||
|
||||
: <ViewWindow> ( view rect style -- window )
|
||||
dup class-for-style <NSWindow> [ swap -> setContentView: ] keep
|
||||
|
|
|
|||
|
|
@ -13,7 +13,7 @@ HELP: >rgba
|
|||
|
||||
ARTICLE: "colors.protocol" "Color protocol"
|
||||
"Abstract superclass for colors:"
|
||||
{ $subsection color }
|
||||
{ $subsections color }
|
||||
"All color objects must are required to implement a method on the " { $link >rgba } " generic word."
|
||||
$nl
|
||||
"Optionally, they can provide methods on the accessors " { $link red>> } ", " { $link green>> } ", " { $link blue>> } " and " { $link alpha>> } ", either by defining slots with the appropriate names, or with methods which calculate the color component values. The accessors should return color components which are real numbers in the range between 0 and 1."
|
||||
|
|
@ -24,15 +24,19 @@ ARTICLE: "colors" "Colors"
|
|||
"The " { $vocab-link "colors" } " vocabulary defines a protocol for colors, with a concrete implementation for RGBA colors. This vocabulary is used by " { $vocab-link "io.styles" } ", " { $vocab-link "ui" } " and other vocabularies, but it is independent of them."
|
||||
$nl
|
||||
"RGBA colors with floating point components in the range " { $snippet "[0,1]" } ":"
|
||||
{ $subsection rgba }
|
||||
{ $subsection <rgba> }
|
||||
{ $subsections
|
||||
rgba
|
||||
<rgba>
|
||||
}
|
||||
"Converting a color to RGBA:"
|
||||
{ $subsection >rgba }
|
||||
{ $subsections >rgba }
|
||||
"Extracting RGBA components of colors:"
|
||||
{ $subsection >rgba-components }
|
||||
{ $subsections >rgba-components }
|
||||
"Further topics:"
|
||||
{ $subsection "colors.protocol" }
|
||||
{ $subsection "colors.constants" }
|
||||
{ $subsections
|
||||
"colors.protocol"
|
||||
"colors.constants"
|
||||
}
|
||||
{ $vocab-subsection "Grayscale colors" "colors.gray" }
|
||||
{ $vocab-subsection "HSV colors" "colors.hsv" } ;
|
||||
|
||||
|
|
|
|||
|
|
@ -24,8 +24,10 @@ HELP: COLOR:
|
|||
|
||||
ARTICLE: "colors.constants" "Standard color database"
|
||||
"The " { $vocab-link "colors.constants" } " vocabulary bundles the X11 " { $snippet "rgb.txt" } " database and Factor's " { $snippet "factor-colors.txt" } " theme database to provide words for looking up color values by name."
|
||||
{ $subsection named-color }
|
||||
{ $subsection named-colors }
|
||||
{ $subsection POSTPONE: COLOR: } ;
|
||||
{ $subsections
|
||||
named-color
|
||||
named-colors
|
||||
POSTPONE: COLOR:
|
||||
} ;
|
||||
|
||||
ABOUT: "colors.constants"
|
||||
|
|
@ -4,3 +4,4 @@
|
|||
172 167 147 FactorDarkTan
|
||||
81 91 105 FactorLightSlateBlue
|
||||
55 62 72 FactorDarkSlateBlue
|
||||
0 51 0 FactorDarkGreen
|
||||
|
|
|
|||
|
|
@ -3,7 +3,9 @@ IN: colors.gray
|
|||
|
||||
ARTICLE: "colors.gray" "Grayscale colors"
|
||||
"The " { $vocab-link "colors.gray" } " vocabulary implements grayscale colors. These colors hold a single value, and respond to " { $link red>> } ", " { $link green>> } ", " { $link blue>> } " with that value. They also have an independent alpha channel, " { $link alpha>> } "."
|
||||
{ $subsection gray }
|
||||
{ $subsection <gray> } ;
|
||||
{ $subsections
|
||||
gray
|
||||
<gray>
|
||||
} ;
|
||||
|
||||
ABOUT: "colors.gray"
|
||||
|
|
@ -6,8 +6,10 @@ HELP: hsva
|
|||
|
||||
ARTICLE: "colors.hsv" "HSV colors"
|
||||
"The " { $vocab-link "colors.hsv" } " vocabulary implements colors specified by their hue, saturation, and value, together with an alpha channel."
|
||||
{ $subsection hsva }
|
||||
{ $subsection <hsva> }
|
||||
{ $subsections
|
||||
hsva
|
||||
<hsva>
|
||||
}
|
||||
{ $see-also "colors" } ;
|
||||
|
||||
ABOUT: "colors.hsv"
|
||||
|
|
@ -25,9 +25,11 @@ HELP: <flipped>
|
|||
|
||||
ARTICLE: "columns" "Column sequences"
|
||||
"A " { $emphasis "column" } " presents a column of a matrix represented as a sequence of rows:"
|
||||
{ $subsection column }
|
||||
{ $subsection <column> }
|
||||
{ $subsections
|
||||
column
|
||||
<column>
|
||||
}
|
||||
"A utility word:"
|
||||
{ $subsection <flipped> } ;
|
||||
{ $subsections <flipped> } ;
|
||||
|
||||
ABOUT: "columns"
|
||||
|
|
|
|||
|
|
@ -51,18 +51,24 @@ HELP: n||
|
|||
ARTICLE: "combinators.short-circuit" "Short-circuit combinators"
|
||||
"The " { $vocab-link "combinators.short-circuit" } " vocabulary stops a computation early once a condition is met." $nl
|
||||
"AND combinators:"
|
||||
{ $subsection 0&& }
|
||||
{ $subsection 1&& }
|
||||
{ $subsection 2&& }
|
||||
{ $subsection 3&& }
|
||||
{ $subsections
|
||||
0&&
|
||||
1&&
|
||||
2&&
|
||||
3&&
|
||||
}
|
||||
"OR combinators:"
|
||||
{ $subsection 0|| }
|
||||
{ $subsection 1|| }
|
||||
{ $subsection 2|| }
|
||||
{ $subsection 3|| }
|
||||
{ $subsections
|
||||
0||
|
||||
1||
|
||||
2||
|
||||
3||
|
||||
}
|
||||
"Generalized combinators:"
|
||||
{ $subsection n&& }
|
||||
{ $subsection n|| }
|
||||
{ $subsections
|
||||
n&&
|
||||
n||
|
||||
}
|
||||
;
|
||||
|
||||
ABOUT: "combinators.short-circuit"
|
||||
|
|
|
|||
|
|
@ -31,8 +31,8 @@ ARTICLE: "combinators.short-circuit.smart" "Smart short-circuit combinators"
|
|||
"The " { $vocab-link "combinators.short-circuit.smart" } " vocabulary is similar to " { $vocab-link "combinators.short-circuit" } " except the combinators here infer the number of inputs that the sequence of quotations takes."
|
||||
$nl
|
||||
"Generalized AND:"
|
||||
{ $subsection && }
|
||||
{ $subsections && }
|
||||
"Generalized OR:"
|
||||
{ $subsection || } ;
|
||||
{ $subsections || } ;
|
||||
|
||||
ABOUT: "combinators.short-circuit.smart"
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: help.markup help.syntax kernel quotations math sequences
|
||||
multiline stack-checker ;
|
||||
stack-checker ;
|
||||
IN: combinators.smart
|
||||
|
||||
HELP: input<sequence
|
||||
|
|
@ -26,10 +26,10 @@ HELP: output>array
|
|||
{ $description "Infers the number or outputs from the quotation and constructs an array from those outputs." }
|
||||
{ $examples
|
||||
{ $example
|
||||
<" USING: combinators combinators.smart math prettyprint ;
|
||||
"USING: combinators combinators.smart math prettyprint ;
|
||||
9 [
|
||||
{ [ 1 - ] [ 1 + ] [ sq ] } cleave
|
||||
] output>array .">
|
||||
] output>array ."
|
||||
"{ 8 10 81 }"
|
||||
}
|
||||
} ;
|
||||
|
|
@ -119,20 +119,26 @@ HELP: keep-inputs
|
|||
ARTICLE: "combinators.smart" "Smart combinators"
|
||||
"A " { $emphasis "smart combinator" } " is a macro which reflects on the stack effect of an input quotation. The " { $vocab-link "combinators.smart" } " vocabulary implements a few simple smart combinators which look at the static stack effects of input quotations and generate code which produces or consumes the relevant number of stack values." $nl
|
||||
"Call a quotation and discard all output values or preserve all input values:"
|
||||
{ $subsection drop-outputs }
|
||||
{ $subsection keep-inputs }
|
||||
{ $subsections
|
||||
drop-outputs
|
||||
keep-inputs
|
||||
}
|
||||
"Take all input values from a sequence:"
|
||||
{ $subsection input<sequence }
|
||||
{ $subsections input<sequence }
|
||||
"Store all output values to a sequence:"
|
||||
{ $subsection output>sequence }
|
||||
{ $subsection output>array }
|
||||
{ $subsections
|
||||
output>sequence
|
||||
output>array
|
||||
}
|
||||
"Reducing the set of output values:"
|
||||
{ $subsection reduce-outputs }
|
||||
{ $subsections reduce-outputs }
|
||||
"Summing output values:"
|
||||
{ $subsection sum-outputs }
|
||||
{ $subsections sum-outputs }
|
||||
"Concatenating output values:"
|
||||
{ $subsection append-outputs }
|
||||
{ $subsection append-outputs-as }
|
||||
{ $subsections
|
||||
append-outputs
|
||||
append-outputs-as
|
||||
}
|
||||
"New smart combinators can be created by defining " { $link "macros" } " which call " { $link infer } "." ;
|
||||
|
||||
ABOUT: "combinators.smart"
|
||||
|
|
|
|||
|
|
@ -25,7 +25,7 @@ HELP: (command-line)
|
|||
{ $description "Outputs the command line parameters which were passed to the Factor VM on startup." } ;
|
||||
|
||||
HELP: command-line
|
||||
{ $var-description "The command line parameters which follow the name of the script on the command line." } ;
|
||||
{ $var-description "When Factor is run with a script, this variable contains command line parameters which follow the name of the script on the command line. In deployed applications, it contains the entire command line. In all other cases it is set to " { $link f } "." } ;
|
||||
|
||||
HELP: main-vocab-hook
|
||||
{ $var-description "Global variable holding a quotation which outputs a vocabulary name. UI backends set this so that the UI can automatically start if the prerequisites are met (for example, " { $snippet "$DISPLAY" } " being set on X11)." } ;
|
||||
|
|
@ -47,7 +47,6 @@ ARTICLE: "runtime-cli-args" "Command line switches for the VM"
|
|||
{ { $snippet "-i=" { $emphasis "image" } } { "Specifies the image file to use; see " { $link "images" } } }
|
||||
{ { $snippet "-datastack=" { $emphasis "n" } } "Data stack size, kilobytes" }
|
||||
{ { $snippet "-retainstack=" { $emphasis "n" } } "Retain stack size, kilobytes" }
|
||||
{ { $snippet "-generations=" { $emphasis "n" } } "Number of generations, must equal 1, 2 or 3" }
|
||||
{ { $snippet "-young=" { $emphasis "n" } } { "Size of youngest generation (0), megabytes" } }
|
||||
{ { $snippet "-aging=" { $emphasis "n" } } "Size of aging generation (1), megabytes" }
|
||||
{ { $snippet "-tenured=" { $emphasis "n" } } "Size of oldest generation (2), megabytes" }
|
||||
|
|
@ -99,26 +98,28 @@ ARTICLE: "factor-boot-rc" "Bootstrap initialization file"
|
|||
"The botstrap initialization file is named " { $snippet "factor-boot-rc" } " on Windows and " { $snippet ".factor-boot-rc" } " on Unix. This file can contain " { $link require } " calls for vocabularies you use frequently, and other such long-running tasks that you do not want to perform every time Factor starts."
|
||||
$nl
|
||||
"A word to run this file from an existing Factor session:"
|
||||
{ $subsection run-bootstrap-init }
|
||||
{ $subsections run-bootstrap-init }
|
||||
"For example, if you changed " { $snippet ".factor-boot-rc" } " and do not want to bootstrap again, you can just invoke " { $link run-bootstrap-init } " in the listener." ;
|
||||
|
||||
ARTICLE: "factor-rc" "Startup initialization file"
|
||||
"The startup initialization file is named " { $snippet "factor-rc" } " on Windows and " { $snippet ".factor-rc" } " on Unix. If it exists, it is run every time Factor starts."
|
||||
$nl
|
||||
"A word to run this file from an existing Factor session:"
|
||||
{ $subsection run-user-init } ;
|
||||
{ $subsections run-user-init } ;
|
||||
|
||||
ARTICLE: "factor-roots" "Additional vocabulary roots file"
|
||||
"The vocabulary roots file is named " { $snippet "factor-roots" } " on Windows and " { $snippet ".factor-roots" } " on Unix. If it exists, it is loaded every time Factor starts. It contains a newline-separated list of " { $link "vocabs.roots" } "."
|
||||
$nl
|
||||
"A word to run this file from an existing Factor session:"
|
||||
{ $subsection load-vocab-roots } ;
|
||||
{ $subsections load-vocab-roots } ;
|
||||
|
||||
ARTICLE: "rc-files" "Running code on startup"
|
||||
"Factor looks for three optional files in your home directory."
|
||||
{ $subsection "factor-boot-rc" }
|
||||
{ $subsection "factor-rc" }
|
||||
{ $subsection "factor-roots" }
|
||||
{ $subsections
|
||||
"factor-boot-rc"
|
||||
"factor-rc"
|
||||
"factor-roots"
|
||||
}
|
||||
"The " { $snippet "-no-user-init" } " command line switch will inhibit loading running of these files."
|
||||
$nl
|
||||
"If you are unsure where the files should be located, evaluate the following code:"
|
||||
|
|
@ -127,19 +128,17 @@ $nl
|
|||
"\"factor-rc\" rc-path print"
|
||||
"\"factor-boot-rc\" rc-path print"
|
||||
}
|
||||
"Here is an example " { $snippet ".factor-boot-rc" } " which sets up GVIM editor integration, adds an additional vocabulary root (see " { $link "vocabs.roots" } "), and increases the font size in the UI by setting the DPI (dots-per-inch) variable:"
|
||||
"Here is an example " { $snippet ".factor-boot-rc" } " which sets up GVIM editor integration:"
|
||||
{ $code
|
||||
"USING: editors.gvim vocabs.loader ui.freetype namespaces sequences ;"
|
||||
"USING: editors.gvim namespaces ;"
|
||||
"\"/opt/local/bin\" \\ gvim-path set-global"
|
||||
"\"/home/jane/src/\" vocab-roots get push"
|
||||
"100 dpi set-global"
|
||||
} ;
|
||||
|
||||
ARTICLE: "cli" "Command line arguments"
|
||||
"Factor command line usage:"
|
||||
{ $code "factor [system switches...] [script args...]" }
|
||||
"Zero or more system switches can be passed in, followed by an optional script file name. If the script file is specified, it will be run on startup, any arguments after the script file are stored in a variable, with no further processing by Factor itself:"
|
||||
{ $subsection command-line }
|
||||
{ $code "factor [VM args...] [script] [args...]" }
|
||||
"Zero or more VM arguments can be passed in, followed by an optional script file name. If the script file is specified, it will be run on startup, any arguments after the script file are stored in the following variable, with no further processing by Factor itself:"
|
||||
{ $subsections command-line }
|
||||
"Instead of running a script, it is also possible to run a vocabulary; this invokes the vocabulary's " { $link POSTPONE: MAIN: } " word:"
|
||||
{ $code "factor [system switches...] -run=<vocab name>" }
|
||||
"If no script file or " { $snippet "-run=" } " switch is specified, Factor will start " { $link "listener" } " or " { $link "ui-tools" } ", depending on the operating system."
|
||||
|
|
@ -152,12 +151,14 @@ $nl
|
|||
{ { $snippet "-no-" { $emphasis "foo" } } " - sets the global variable " { $snippet "\"" { $emphasis "foo" } "\"" } " to " { $link f } }
|
||||
{ { $snippet "-" { $emphasis "foo" } "=" { $emphasis "bar" } } " - sets the global variable " { $snippet "\"" { $emphasis "foo" } "\"" } " to " { $snippet "\"" { $emphasis "bar" } "\"" } }
|
||||
}
|
||||
{ $subsection "runtime-cli-args" }
|
||||
{ $subsection "bootstrap-cli-args" }
|
||||
{ $subsection "standard-cli-args" }
|
||||
{ $subsections
|
||||
"runtime-cli-args"
|
||||
"bootstrap-cli-args"
|
||||
"standard-cli-args"
|
||||
}
|
||||
"The raw list of command line arguments can also be obtained and inspected directly:"
|
||||
{ $subsection (command-line) }
|
||||
{ $subsections (command-line) }
|
||||
"There is a way to override the default vocabulary to run on startup, if no script name or " { $snippet "-run" } " switch is specified:"
|
||||
{ $subsection main-vocab-hook } ;
|
||||
{ $subsections main-vocab-hook } ;
|
||||
|
||||
ABOUT: "cli"
|
||||
|
|
|
|||
|
|
@ -1,10 +1,17 @@
|
|||
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel math namespaces assocs hashtables sequences arrays
|
||||
accessors vectors combinators sets classes cpu.architecture
|
||||
compiler.cfg compiler.cfg.registers compiler.cfg.instructions
|
||||
compiler.cfg.def-use compiler.cfg.copy-prop compiler.cfg.rpo
|
||||
compiler.cfg.liveness ;
|
||||
accessors words vectors combinators combinators.short-circuit
|
||||
sets classes layouts cpu.architecture
|
||||
compiler.cfg
|
||||
compiler.cfg.rpo
|
||||
compiler.cfg.def-use
|
||||
compiler.cfg.liveness
|
||||
compiler.cfg.copy-prop
|
||||
compiler.cfg.registers
|
||||
compiler.cfg.comparisons
|
||||
compiler.cfg.instructions
|
||||
compiler.cfg.representations.preferred ;
|
||||
IN: compiler.cfg.alias-analysis
|
||||
|
||||
! We try to eliminate redundant slot operations using some simple heuristics.
|
||||
|
|
@ -77,10 +84,15 @@ SYMBOL: acs>vregs
|
|||
|
||||
: ac>vregs ( ac -- vregs ) acs>vregs get at ;
|
||||
|
||||
: aliases ( vreg -- vregs )
|
||||
GENERIC: aliases ( vreg -- vregs )
|
||||
|
||||
M: integer aliases
|
||||
#! All vregs which may contain the same value as vreg.
|
||||
vreg>ac ac>vregs ;
|
||||
|
||||
M: word aliases
|
||||
1array ;
|
||||
|
||||
: each-alias ( vreg quot -- )
|
||||
[ aliases ] dip each ; inline
|
||||
|
||||
|
|
@ -181,7 +193,6 @@ SYMBOL: constants
|
|||
#! assigned by an ##load-immediate.
|
||||
resolve constants get at ;
|
||||
|
||||
! We treat slot accessors and stack traffic alike
|
||||
GENERIC: insn-slot# ( insn -- slot#/f )
|
||||
GENERIC: insn-object ( insn -- vreg )
|
||||
|
||||
|
|
@ -190,7 +201,7 @@ M: ##slot-imm insn-slot# slot>> ;
|
|||
M: ##set-slot insn-slot# slot>> constant ;
|
||||
M: ##set-slot-imm insn-slot# slot>> ;
|
||||
M: ##alien-global insn-slot# [ library>> ] [ symbol>> ] bi 2array ;
|
||||
M: ##vm-field-ptr insn-slot# fieldname>> 1array ; ! is this right?
|
||||
M: ##vm-field-ptr insn-slot# field-name>> ;
|
||||
|
||||
M: ##slot insn-object obj>> resolve ;
|
||||
M: ##slot-imm insn-object obj>> resolve ;
|
||||
|
|
@ -206,18 +217,33 @@ M: ##vm-field-ptr insn-object drop \ ##vm-field-ptr ;
|
|||
H{ } clone live-slots set
|
||||
H{ } clone constants set
|
||||
H{ } clone copies set
|
||||
|
||||
|
||||
0 ac-counter set
|
||||
next-ac heap-ac set
|
||||
|
||||
\ ##vm-field-ptr set-new-ac
|
||||
\ ##alien-global set-new-ac
|
||||
|
||||
dup local-live-in [ set-heap-ac ] each ;
|
||||
|
||||
GENERIC: analyze-aliases* ( insn -- insn' )
|
||||
|
||||
M: insn analyze-aliases*
|
||||
dup defs-vreg [ set-heap-ac ] when* ;
|
||||
! If an instruction defines a value with a non-integer
|
||||
! representation it means that the value will be boxed
|
||||
! anywhere its used as a tagged pointer. Boxing allocates
|
||||
! a new value, except boxing instructions haven't been
|
||||
! inserted yet.
|
||||
dup defs-vreg [
|
||||
over defs-vreg-rep int-rep eq?
|
||||
[ set-heap-ac ] [ set-new-ac ] if
|
||||
] when* ;
|
||||
|
||||
M: ##phi analyze-aliases*
|
||||
dup defs-vreg set-heap-ac ;
|
||||
|
||||
M: ##load-immediate analyze-aliases*
|
||||
call-next-method
|
||||
dup [ val>> ] [ dst>> ] bi constants get set-at ;
|
||||
|
||||
M: ##allocation analyze-aliases*
|
||||
|
|
@ -249,6 +275,19 @@ M: ##copy analyze-aliases*
|
|||
#! vreg, since they both contain the same value.
|
||||
dup record-copy ;
|
||||
|
||||
: useless-compare? ( insn -- ? )
|
||||
{
|
||||
[ cc>> cc= eq? ]
|
||||
[ [ src1>> ] [ src2>> ] bi [ resolve vreg>ac ] bi@ = not ]
|
||||
} 1&& ; inline
|
||||
|
||||
M: ##compare analyze-aliases*
|
||||
call-next-method
|
||||
dup useless-compare? [
|
||||
dst>> \ f tag-number \ ##load-immediate new-insn
|
||||
analyze-aliases*
|
||||
] when ;
|
||||
|
||||
: analyze-aliases ( insns -- insns' )
|
||||
[ insn# set analyze-aliases* ] map-index sift ;
|
||||
|
||||
|
|
|
|||
|
|
@ -25,7 +25,7 @@ M: stack-frame-insn compute-stack-frame*
|
|||
M: ##call compute-stack-frame*
|
||||
word>> sub-primitive>> [ frame-required? on ] unless ;
|
||||
|
||||
M: _gc compute-stack-frame*
|
||||
M: ##gc compute-stack-frame*
|
||||
frame-required? on
|
||||
stack-frame new swap tagged-values>> length cells >>gc-root-size
|
||||
request-stack-frame ;
|
||||
|
|
|
|||
|
|
@ -4,6 +4,7 @@ compiler.tree.optimizer compiler.cfg.builder compiler.cfg.debugger
|
|||
compiler.cfg.optimizer compiler.cfg.predecessors compiler.cfg.checker
|
||||
compiler.cfg arrays locals byte-arrays kernel.private math
|
||||
slots.private vectors sbufs strings math.partial-dispatch
|
||||
hashtables assocs combinators.short-circuit
|
||||
strings.private accessors compiler.cfg.instructions ;
|
||||
IN: compiler.cfg.builder.tests
|
||||
|
||||
|
|
@ -158,9 +159,12 @@ IN: compiler.cfg.builder.tests
|
|||
{ pinned-c-ptr class fixnum } \ set-alien-cell '[ _ declare _ execute ] unit-test-cfg
|
||||
] each
|
||||
|
||||
: contains-insn? ( quot insn-check -- ? )
|
||||
: count-insns ( quot insn-check -- ? )
|
||||
[ test-mr [ instructions>> ] map ] dip
|
||||
'[ _ any? ] any? ; inline
|
||||
'[ _ count ] sigma ; inline
|
||||
|
||||
: contains-insn? ( quot insn-check -- ? )
|
||||
count-insns 0 > ; inline
|
||||
|
||||
[ t ] [ [ swap ] [ ##replace? ] contains-insn? ] unit-test
|
||||
|
||||
|
|
@ -196,12 +200,17 @@ IN: compiler.cfg.builder.tests
|
|||
[ f t ] [
|
||||
[ { byte-array fixnum } declare alien-cell 4 alien-float ]
|
||||
[ [ ##box-alien? ] contains-insn? ]
|
||||
[ [ ##box-float? ] contains-insn? ] bi
|
||||
[ [ ##allot? ] contains-insn? ] bi
|
||||
] unit-test
|
||||
|
||||
[ f t ] [
|
||||
[ { byte-array fixnum } declare alien-cell { simple-alien } declare 4 alien-float ]
|
||||
[ [ ##box-alien? ] contains-insn? ]
|
||||
[ [ ##box-float? ] contains-insn? ] bi
|
||||
[ [ ##allot? ] contains-insn? ] bi
|
||||
] unit-test
|
||||
] when
|
||||
|
||||
[ 1 ] [ [ dup float+ ] [ ##alien-double? ] count-insns ] unit-test
|
||||
] when
|
||||
|
||||
! Regression. Make sure everything is inlined correctly
|
||||
[ f ] [ M\ hashtable set-at [ { [ ##call? ] [ word>> \ set-slot eq? ] } 1&& ] contains-insn? ] unit-test
|
||||
|
|
@ -9,6 +9,9 @@ SYMBOLS:
|
|||
cc< cc<= cc= cc> cc>= cc<> cc<>=
|
||||
cc/< cc/<= cc/= cc/> cc/>= cc/<> cc/<>= ;
|
||||
|
||||
SYMBOLS:
|
||||
vcc-all vcc-notall vcc-any vcc-none ;
|
||||
|
||||
: negate-cc ( cc -- cc' )
|
||||
H{
|
||||
{ cc< cc/< }
|
||||
|
|
@ -27,6 +30,14 @@ SYMBOLS:
|
|||
{ cc/<>= cc<>= }
|
||||
} at ;
|
||||
|
||||
: negate-vcc ( cc -- cc' )
|
||||
H{
|
||||
{ vcc-all vcc-notall }
|
||||
{ vcc-any vcc-none }
|
||||
{ vcc-none vcc-any }
|
||||
{ vcc-notall vcc-all }
|
||||
} at ;
|
||||
|
||||
: swap-cc ( cc -- cc' )
|
||||
H{
|
||||
{ cc< cc> }
|
||||
|
|
|
|||
|
|
@ -7,10 +7,10 @@ prettyprint.sections parser compiler.tree.builder
|
|||
compiler.tree.optimizer cpu.architecture compiler.cfg.builder
|
||||
compiler.cfg.linearization compiler.cfg.registers
|
||||
compiler.cfg.stack-frame compiler.cfg.linear-scan
|
||||
compiler.cfg.two-operand compiler.cfg.optimizer
|
||||
compiler.cfg.instructions compiler.cfg.utilities
|
||||
compiler.cfg.def-use compiler.cfg.rpo compiler.cfg.mr
|
||||
compiler.cfg.representations.preferred compiler.cfg ;
|
||||
compiler.cfg.optimizer compiler.cfg.instructions
|
||||
compiler.cfg.utilities compiler.cfg.def-use compiler.cfg.rpo
|
||||
compiler.cfg.mr compiler.cfg.representations.preferred
|
||||
compiler.cfg ;
|
||||
IN: compiler.cfg.debugger
|
||||
|
||||
GENERIC: test-cfg ( quot -- cfgs )
|
||||
|
|
@ -44,6 +44,9 @@ M: word test-cfg
|
|||
nl
|
||||
] each ;
|
||||
|
||||
: test-mr. ( quot -- )
|
||||
test-mr mr. ; inline
|
||||
|
||||
! Prettyprinting
|
||||
: pprint-loc ( loc word -- ) <block pprint-word n>> pprint* block> ;
|
||||
|
||||
|
|
@ -79,4 +82,4 @@ M: rs-loc pprint* \ R pprint-loc ;
|
|||
[ [ defs-vreg ] [ defs-vreg-rep ] bi 2dup and [ 2array ] [ 2drop f ] if ]
|
||||
bi [ suffix ] when*
|
||||
] map concat
|
||||
] map concat >hashtable representations set ;
|
||||
] map concat >hashtable representations set ;
|
||||
|
|
|
|||
|
|
@ -16,7 +16,7 @@ V{
|
|||
} 0 test-bb
|
||||
|
||||
V{
|
||||
T{ ##box-float f 0 1 }
|
||||
T{ ##box-alien f 0 1 }
|
||||
} 1 test-bb
|
||||
|
||||
0 1 edge
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors kernel sequences assocs fry
|
||||
cpu.architecture
|
||||
cpu.architecture layouts
|
||||
compiler.cfg.rpo
|
||||
compiler.cfg.registers
|
||||
compiler.cfg.instructions
|
||||
|
|
@ -17,11 +17,26 @@ IN: compiler.cfg.gc-checks
|
|||
: blocks-with-gc ( cfg -- bbs )
|
||||
post-order [ insert-gc-check? ] filter ;
|
||||
|
||||
GENERIC: allocation-size* ( insn -- n )
|
||||
|
||||
M: ##allot allocation-size* size>> ;
|
||||
|
||||
M: ##box-alien allocation-size* drop 4 cells ;
|
||||
|
||||
M: ##box-displaced-alien allocation-size* drop 4 cells ;
|
||||
|
||||
: allocation-size ( bb -- n )
|
||||
instructions>> [ ##allocation? ] filter [ allocation-size* ] sigma ;
|
||||
|
||||
: insert-gc-check ( bb -- )
|
||||
dup '[
|
||||
dup dup '[
|
||||
int-rep next-vreg-rep
|
||||
int-rep next-vreg-rep
|
||||
f f _ uninitialized-locs \ ##gc new-insn
|
||||
_ allocation-size
|
||||
f
|
||||
f
|
||||
_ uninitialized-locs
|
||||
\ ##gc new-insn
|
||||
prefix
|
||||
] change-instructions drop ;
|
||||
|
||||
|
|
|
|||
|
|
@ -45,16 +45,15 @@ insn-classes get [
|
|||
[ next-vreg dup ] dip {
|
||||
{ [ dup not ] [ drop \ f tag-number ##load-immediate ] }
|
||||
{ [ dup fixnum? ] [ tag-fixnum ##load-immediate ] }
|
||||
{ [ dup float? ] [ ##load-constant ] }
|
||||
[ ##load-reference ]
|
||||
} cond ; inline
|
||||
} cond ;
|
||||
|
||||
: ^^unbox-c-ptr ( src class -- dst )
|
||||
[ next-vreg dup ] 2dip next-vreg ##unbox-c-ptr ; inline
|
||||
: ^^offset>slot ( slot -- vreg' )
|
||||
cell 4 = [ 1 ^^shr-imm ] [ any-rep ^^copy ] if ;
|
||||
|
||||
: ^^neg ( src -- dst ) [ 0 ^^load-literal ] dip ^^sub ; inline
|
||||
: ^^allot-tuple ( n -- dst ) 2 + cells tuple ^^allot ; inline
|
||||
: ^^allot-array ( n -- dst ) 2 + cells array ^^allot ; inline
|
||||
: ^^allot-byte-array ( n -- dst ) 2 cells + byte-array ^^allot ; inline
|
||||
: ^^offset>slot ( vreg -- vreg' ) cell 4 = [ 1 ^^shr-imm ] [ any-rep ^^copy ] if ; inline
|
||||
: ^^tag-fixnum ( src -- dst ) tag-bits get ^^shl-imm ; inline
|
||||
: ^^untag-fixnum ( src -- dst ) tag-bits get ^^sar-imm ; inline
|
||||
: ^^tag-fixnum ( src -- dst )
|
||||
tag-bits get ^^shl-imm ;
|
||||
|
||||
: ^^untag-fixnum ( src -- dst )
|
||||
tag-bits get ^^sar-imm ;
|
||||
|
|
|
|||
|
|
@ -29,6 +29,10 @@ INSN: ##load-reference
|
|||
def: dst/int-rep
|
||||
constant: obj ;
|
||||
|
||||
INSN: ##load-constant
|
||||
def: dst/int-rep
|
||||
constant: obj ;
|
||||
|
||||
INSN: ##peek
|
||||
def: dst/int-rep
|
||||
literal: loc ;
|
||||
|
|
@ -63,9 +67,7 @@ temp: temp/int-rep ;
|
|||
! Slot access
|
||||
INSN: ##slot
|
||||
def: dst/int-rep
|
||||
use: obj/int-rep slot/int-rep
|
||||
literal: tag
|
||||
temp: temp/int-rep ;
|
||||
use: obj/int-rep slot/int-rep ;
|
||||
|
||||
INSN: ##slot-imm
|
||||
def: dst/int-rep
|
||||
|
|
@ -73,9 +75,7 @@ use: obj/int-rep
|
|||
literal: slot tag ;
|
||||
|
||||
INSN: ##set-slot
|
||||
use: src/int-rep obj/int-rep slot/int-rep
|
||||
literal: tag
|
||||
temp: temp/int-rep ;
|
||||
use: src/int-rep obj/int-rep slot/int-rep ;
|
||||
|
||||
INSN: ##set-slot-imm
|
||||
use: src/int-rep obj/int-rep
|
||||
|
|
@ -190,31 +190,15 @@ PURE-INSN: ##not
|
|||
def: dst/int-rep
|
||||
use: src/int-rep ;
|
||||
|
||||
PURE-INSN: ##neg
|
||||
def: dst/int-rep
|
||||
use: src/int-rep ;
|
||||
|
||||
PURE-INSN: ##log2
|
||||
def: dst/int-rep
|
||||
use: src/int-rep ;
|
||||
|
||||
! Bignum/integer conversion
|
||||
PURE-INSN: ##integer>bignum
|
||||
def: dst/int-rep
|
||||
use: src/int-rep
|
||||
temp: temp/int-rep ;
|
||||
|
||||
PURE-INSN: ##bignum>integer
|
||||
def: dst/int-rep
|
||||
use: src/int-rep
|
||||
temp: temp/int-rep ;
|
||||
|
||||
! Float arithmetic
|
||||
PURE-INSN: ##unbox-float
|
||||
def: dst/double-rep
|
||||
use: src/int-rep ;
|
||||
|
||||
PURE-INSN: ##box-float
|
||||
def: dst/int-rep
|
||||
use: src/double-rep
|
||||
temp: temp/int-rep ;
|
||||
|
||||
PURE-INSN: ##add-float
|
||||
def: dst/double-rep
|
||||
use: src1/double-rep src2/double-rep ;
|
||||
|
|
@ -273,21 +257,12 @@ def: dst/double-rep
|
|||
use: src/int-rep ;
|
||||
|
||||
! SIMD operations
|
||||
|
||||
PURE-INSN: ##box-vector
|
||||
def: dst/int-rep
|
||||
use: src
|
||||
literal: rep
|
||||
temp: temp/int-rep ;
|
||||
|
||||
PURE-INSN: ##unbox-vector
|
||||
PURE-INSN: ##zero-vector
|
||||
def: dst
|
||||
use: src/int-rep
|
||||
literal: rep ;
|
||||
|
||||
PURE-INSN: ##broadcast-vector
|
||||
PURE-INSN: ##fill-vector
|
||||
def: dst
|
||||
use: src/scalar-rep
|
||||
literal: rep ;
|
||||
|
||||
PURE-INSN: ##gather-vector-2
|
||||
|
|
@ -300,21 +275,118 @@ def: dst
|
|||
use: src1/scalar-rep src2/scalar-rep src3/scalar-rep src4/scalar-rep
|
||||
literal: rep ;
|
||||
|
||||
PURE-INSN: ##shuffle-vector
|
||||
def: dst
|
||||
use: src shuffle
|
||||
literal: rep ;
|
||||
|
||||
PURE-INSN: ##shuffle-vector-imm
|
||||
def: dst
|
||||
use: src
|
||||
literal: shuffle rep ;
|
||||
|
||||
PURE-INSN: ##tail>head-vector
|
||||
def: dst
|
||||
use: src
|
||||
literal: rep ;
|
||||
|
||||
PURE-INSN: ##merge-vector-head
|
||||
def: dst
|
||||
use: src1 src2
|
||||
literal: rep ;
|
||||
|
||||
PURE-INSN: ##merge-vector-tail
|
||||
def: dst
|
||||
use: src1 src2
|
||||
literal: rep ;
|
||||
|
||||
PURE-INSN: ##signed-pack-vector
|
||||
def: dst
|
||||
use: src1 src2
|
||||
literal: rep ;
|
||||
|
||||
PURE-INSN: ##unsigned-pack-vector
|
||||
def: dst
|
||||
use: src1 src2
|
||||
literal: rep ;
|
||||
|
||||
PURE-INSN: ##unpack-vector-head
|
||||
def: dst
|
||||
use: src
|
||||
literal: rep ;
|
||||
|
||||
PURE-INSN: ##unpack-vector-tail
|
||||
def: dst
|
||||
use: src
|
||||
literal: rep ;
|
||||
|
||||
PURE-INSN: ##integer>float-vector
|
||||
def: dst
|
||||
use: src
|
||||
literal: rep ;
|
||||
|
||||
PURE-INSN: ##float>integer-vector
|
||||
def: dst
|
||||
use: src
|
||||
literal: rep ;
|
||||
|
||||
PURE-INSN: ##compare-vector
|
||||
def: dst
|
||||
use: src1 src2
|
||||
literal: rep cc ;
|
||||
|
||||
PURE-INSN: ##test-vector
|
||||
def: dst/int-rep
|
||||
use: src1
|
||||
temp: temp/int-rep
|
||||
literal: rep vcc ;
|
||||
|
||||
INSN: ##test-vector-branch
|
||||
use: src1
|
||||
temp: temp/int-rep
|
||||
literal: rep vcc ;
|
||||
|
||||
INSN: _test-vector-branch
|
||||
literal: label
|
||||
use: src1
|
||||
temp: temp/int-rep
|
||||
literal: rep vcc ;
|
||||
|
||||
PURE-INSN: ##add-vector
|
||||
def: dst
|
||||
use: src1 src2
|
||||
literal: rep ;
|
||||
|
||||
PURE-INSN: ##saturated-add-vector
|
||||
def: dst
|
||||
use: src1 src2
|
||||
literal: rep ;
|
||||
|
||||
PURE-INSN: ##add-sub-vector
|
||||
def: dst
|
||||
use: src1 src2
|
||||
literal: rep ;
|
||||
|
||||
PURE-INSN: ##sub-vector
|
||||
def: dst
|
||||
use: src1 src2
|
||||
literal: rep ;
|
||||
|
||||
PURE-INSN: ##saturated-sub-vector
|
||||
def: dst
|
||||
use: src1 src2
|
||||
literal: rep ;
|
||||
|
||||
PURE-INSN: ##mul-vector
|
||||
def: dst
|
||||
use: src1 src2
|
||||
literal: rep ;
|
||||
|
||||
PURE-INSN: ##saturated-mul-vector
|
||||
def: dst
|
||||
use: src1 src2
|
||||
literal: rep ;
|
||||
|
||||
PURE-INSN: ##div-vector
|
||||
def: dst
|
||||
use: src1 src2
|
||||
|
|
@ -330,9 +402,9 @@ def: dst
|
|||
use: src1 src2
|
||||
literal: rep ;
|
||||
|
||||
PURE-INSN: ##sqrt-vector
|
||||
def: dst
|
||||
use: src
|
||||
PURE-INSN: ##dot-vector
|
||||
def: dst/scalar-rep
|
||||
use: src1 src2
|
||||
literal: rep ;
|
||||
|
||||
PURE-INSN: ##horizontal-add-vector
|
||||
|
|
@ -340,6 +412,87 @@ def: dst/scalar-rep
|
|||
use: src
|
||||
literal: rep ;
|
||||
|
||||
PURE-INSN: ##horizontal-sub-vector
|
||||
def: dst/scalar-rep
|
||||
use: src
|
||||
literal: rep ;
|
||||
|
||||
PURE-INSN: ##horizontal-shl-vector
|
||||
def: dst
|
||||
use: src1
|
||||
literal: src2 rep ;
|
||||
|
||||
PURE-INSN: ##horizontal-shr-vector
|
||||
def: dst
|
||||
use: src1
|
||||
literal: src2 rep ;
|
||||
|
||||
PURE-INSN: ##abs-vector
|
||||
def: dst
|
||||
use: src
|
||||
literal: rep ;
|
||||
|
||||
PURE-INSN: ##sqrt-vector
|
||||
def: dst
|
||||
use: src
|
||||
literal: rep ;
|
||||
|
||||
PURE-INSN: ##and-vector
|
||||
def: dst
|
||||
use: src1 src2
|
||||
literal: rep ;
|
||||
|
||||
PURE-INSN: ##andn-vector
|
||||
def: dst
|
||||
use: src1 src2
|
||||
literal: rep ;
|
||||
|
||||
PURE-INSN: ##or-vector
|
||||
def: dst
|
||||
use: src1 src2
|
||||
literal: rep ;
|
||||
|
||||
PURE-INSN: ##xor-vector
|
||||
def: dst
|
||||
use: src1 src2
|
||||
literal: rep ;
|
||||
|
||||
PURE-INSN: ##not-vector
|
||||
def: dst
|
||||
use: src
|
||||
literal: rep ;
|
||||
|
||||
PURE-INSN: ##shl-vector
|
||||
def: dst
|
||||
use: src1 src2/int-scalar-rep
|
||||
literal: rep ;
|
||||
|
||||
PURE-INSN: ##shr-vector
|
||||
def: dst
|
||||
use: src1 src2/int-scalar-rep
|
||||
literal: rep ;
|
||||
|
||||
! Scalar/vector conversion
|
||||
PURE-INSN: ##scalar>integer
|
||||
def: dst/int-rep
|
||||
use: src
|
||||
literal: rep ;
|
||||
|
||||
PURE-INSN: ##integer>scalar
|
||||
def: dst
|
||||
use: src/int-rep
|
||||
literal: rep ;
|
||||
|
||||
PURE-INSN: ##vector>scalar
|
||||
def: dst/scalar-rep
|
||||
use: src
|
||||
literal: rep ;
|
||||
|
||||
PURE-INSN: ##scalar>vector
|
||||
def: dst
|
||||
use: src/scalar-rep
|
||||
literal: rep ;
|
||||
|
||||
! Boxing and unboxing aliens
|
||||
PURE-INSN: ##box-alien
|
||||
def: dst/int-rep
|
||||
|
|
@ -375,65 +528,88 @@ use: src/int-rep ;
|
|||
! Alien accessors
|
||||
INSN: ##alien-unsigned-1
|
||||
def: dst/int-rep
|
||||
use: src/int-rep ;
|
||||
use: src/int-rep
|
||||
literal: offset ;
|
||||
|
||||
INSN: ##alien-unsigned-2
|
||||
def: dst/int-rep
|
||||
use: src/int-rep ;
|
||||
use: src/int-rep
|
||||
literal: offset ;
|
||||
|
||||
INSN: ##alien-unsigned-4
|
||||
def: dst/int-rep
|
||||
use: src/int-rep ;
|
||||
use: src/int-rep
|
||||
literal: offset ;
|
||||
|
||||
INSN: ##alien-signed-1
|
||||
def: dst/int-rep
|
||||
use: src/int-rep ;
|
||||
use: src/int-rep
|
||||
literal: offset ;
|
||||
|
||||
INSN: ##alien-signed-2
|
||||
def: dst/int-rep
|
||||
use: src/int-rep ;
|
||||
use: src/int-rep
|
||||
literal: offset ;
|
||||
|
||||
INSN: ##alien-signed-4
|
||||
def: dst/int-rep
|
||||
use: src/int-rep ;
|
||||
use: src/int-rep
|
||||
literal: offset ;
|
||||
|
||||
INSN: ##alien-cell
|
||||
def: dst/int-rep
|
||||
use: src/int-rep ;
|
||||
use: src/int-rep
|
||||
literal: offset ;
|
||||
|
||||
INSN: ##alien-float
|
||||
def: dst/float-rep
|
||||
use: src/int-rep ;
|
||||
use: src/int-rep
|
||||
literal: offset ;
|
||||
|
||||
INSN: ##alien-double
|
||||
def: dst/double-rep
|
||||
use: src/int-rep ;
|
||||
use: src/int-rep
|
||||
literal: offset ;
|
||||
|
||||
INSN: ##alien-vector
|
||||
def: dst
|
||||
use: src/int-rep
|
||||
literal: rep ;
|
||||
literal: offset rep ;
|
||||
|
||||
INSN: ##set-alien-integer-1
|
||||
use: src/int-rep value/int-rep ;
|
||||
use: src/int-rep
|
||||
literal: offset
|
||||
use: value/int-rep ;
|
||||
|
||||
INSN: ##set-alien-integer-2
|
||||
use: src/int-rep value/int-rep ;
|
||||
use: src/int-rep
|
||||
literal: offset
|
||||
use: value/int-rep ;
|
||||
|
||||
INSN: ##set-alien-integer-4
|
||||
use: src/int-rep value/int-rep ;
|
||||
use: src/int-rep
|
||||
literal: offset
|
||||
use: value/int-rep ;
|
||||
|
||||
INSN: ##set-alien-cell
|
||||
use: src/int-rep value/int-rep ;
|
||||
use: src/int-rep
|
||||
literal: offset
|
||||
use: value/int-rep ;
|
||||
|
||||
INSN: ##set-alien-float
|
||||
use: src/int-rep value/float-rep ;
|
||||
use: src/int-rep
|
||||
literal: offset
|
||||
use: value/float-rep ;
|
||||
|
||||
INSN: ##set-alien-double
|
||||
use: src/int-rep value/double-rep ;
|
||||
use: src/int-rep
|
||||
literal: offset
|
||||
use: value/double-rep ;
|
||||
|
||||
INSN: ##set-alien-vector
|
||||
use: src/int-rep value
|
||||
use: src/int-rep
|
||||
literal: offset
|
||||
use: value
|
||||
literal: rep ;
|
||||
|
||||
! Memory allocation
|
||||
|
|
@ -452,7 +628,7 @@ literal: symbol library ;
|
|||
|
||||
INSN: ##vm-field-ptr
|
||||
def: dst/int-rep
|
||||
literal: fieldname ;
|
||||
literal: field-name ;
|
||||
|
||||
! FFI
|
||||
INSN: ##alien-invoke
|
||||
|
|
@ -535,7 +711,7 @@ use: src1/int-rep src2/int-rep ;
|
|||
|
||||
INSN: ##gc
|
||||
temp: temp1/int-rep temp2/int-rep
|
||||
literal: data-values tagged-values uninitialized-locs ;
|
||||
literal: size data-values tagged-values uninitialized-locs ;
|
||||
|
||||
INSN: ##save-context
|
||||
temp: temp1/int-rep temp2/int-rep
|
||||
|
|
@ -600,35 +776,29 @@ literal: label
|
|||
def: dst/int-rep
|
||||
use: src1/int-rep src2/int-rep ;
|
||||
|
||||
TUPLE: spill-slot n ; C: <spill-slot> spill-slot
|
||||
|
||||
INSN: _gc
|
||||
temp: temp1 temp2
|
||||
literal: data-values tagged-values uninitialized-locs ;
|
||||
TUPLE: spill-slot { n integer } ;
|
||||
C: <spill-slot> spill-slot
|
||||
|
||||
! These instructions operate on machine registers and not
|
||||
! virtual registers
|
||||
INSN: _spill
|
||||
use: src
|
||||
literal: rep n ;
|
||||
literal: rep dst ;
|
||||
|
||||
INSN: _reload
|
||||
def: dst
|
||||
literal: rep n ;
|
||||
literal: rep src ;
|
||||
|
||||
INSN: _spill-area-size
|
||||
literal: n ;
|
||||
|
||||
UNION: ##allocation
|
||||
##allot
|
||||
##box-float
|
||||
##box-vector
|
||||
##box-alien
|
||||
##box-displaced-alien
|
||||
##integer>bignum ;
|
||||
##box-displaced-alien ;
|
||||
|
||||
! For alias analysis
|
||||
UNION: ##read ##slot ##slot-imm ;
|
||||
UNION: ##read ##slot ##slot-imm ##vm-field-ptr ##alien-global ;
|
||||
UNION: ##write ##set-slot ##set-slot-imm ;
|
||||
|
||||
! Instructions that kill all live vregs but cannot trigger GC
|
||||
|
|
@ -648,8 +818,9 @@ UNION: kill-vreg-insn
|
|||
! Instructions that have complex expansions and require that the
|
||||
! output registers are not equal to any of the input registers
|
||||
UNION: def-is-use-insn
|
||||
##integer>bignum
|
||||
##bignum>integer
|
||||
##box-alien
|
||||
##box-displaced-alien
|
||||
##string-nth
|
||||
##unbox-any-c-ptr ;
|
||||
|
||||
SYMBOL: vreg-insn
|
||||
|
|
|
|||
|
|
@ -3,8 +3,9 @@
|
|||
USING: accessors kernel sequences alien math classes.algebra fry
|
||||
locals combinators combinators.short-circuit cpu.architecture
|
||||
compiler.tree.propagation.info compiler.cfg.hats
|
||||
compiler.cfg.stacks compiler.cfg.instructions
|
||||
compiler.cfg.utilities compiler.cfg.builder.blocks ;
|
||||
compiler.cfg.registers compiler.cfg.stacks
|
||||
compiler.cfg.instructions compiler.cfg.utilities
|
||||
compiler.cfg.builder.blocks ;
|
||||
IN: compiler.cfg.intrinsics.alien
|
||||
|
||||
: emit-<displaced-alien>? ( node -- ? )
|
||||
|
|
@ -33,10 +34,13 @@ IN: compiler.cfg.intrinsics.alien
|
|||
[ second class>> fixnum class<= ]
|
||||
bi and ;
|
||||
|
||||
: prepare-alien-accessor ( info -- offset-vreg )
|
||||
class>> [ 2inputs ^^untag-fixnum swap ] dip ^^unbox-c-ptr ^^add ;
|
||||
: ^^unbox-c-ptr ( src class -- dst )
|
||||
[ next-vreg dup ] 2dip next-vreg ##unbox-c-ptr ;
|
||||
|
||||
: prepare-alien-getter ( infos -- offset-vreg )
|
||||
: prepare-alien-accessor ( info -- ptr-vreg offset )
|
||||
class>> [ 2inputs ^^untag-fixnum swap ] dip ^^unbox-c-ptr ^^add 0 ;
|
||||
|
||||
: prepare-alien-getter ( infos -- ptr-vreg offset )
|
||||
first prepare-alien-accessor ;
|
||||
|
||||
: inline-alien-getter ( node quot -- )
|
||||
|
|
@ -49,7 +53,7 @@ IN: compiler.cfg.intrinsics.alien
|
|||
[ third class>> fixnum class<= ]
|
||||
tri and and ;
|
||||
|
||||
: prepare-alien-setter ( infos -- offset-vreg )
|
||||
: prepare-alien-setter ( infos -- ptr-vreg offset )
|
||||
second prepare-alien-accessor ;
|
||||
|
||||
: inline-alien-integer-setter ( node quot -- )
|
||||
|
|
|
|||
|
|
@ -18,6 +18,9 @@ IN: compiler.cfg.intrinsics.allot
|
|||
: tuple-slot-regs ( layout -- vregs )
|
||||
[ second ds-load ] [ ^^load-literal ] bi prefix ;
|
||||
|
||||
: ^^allot-tuple ( n -- dst )
|
||||
2 + cells tuple ^^allot ;
|
||||
|
||||
: emit-<tuple-boa> ( node -- )
|
||||
dup node-input-infos last literal>>
|
||||
dup array? [
|
||||
|
|
@ -36,6 +39,9 @@ IN: compiler.cfg.intrinsics.allot
|
|||
: expand-<array>? ( obj -- ? )
|
||||
dup integer? [ 0 8 between? ] [ drop f ] if ;
|
||||
|
||||
: ^^allot-array ( n -- dst )
|
||||
2 + cells array ^^allot ;
|
||||
|
||||
:: emit-<array> ( node -- )
|
||||
[let | len [ node node-input-infos first literal>> ] |
|
||||
len expand-<array>? [
|
||||
|
|
@ -49,18 +55,24 @@ IN: compiler.cfg.intrinsics.allot
|
|||
] [ node emit-primitive ] if
|
||||
] ;
|
||||
|
||||
: expand-(byte-array)? ( obj -- ? )
|
||||
dup integer? [ 0 1024 between? ] [ drop f ] if ;
|
||||
|
||||
: expand-<byte-array>? ( obj -- ? )
|
||||
dup integer? [ 0 32 between? ] [ drop f ] if ;
|
||||
|
||||
: bytes>cells ( m -- n ) cell align cell /i ;
|
||||
|
||||
: ^^allot-byte-array ( n -- dst )
|
||||
2 cells + byte-array ^^allot ;
|
||||
|
||||
: emit-allot-byte-array ( len -- dst )
|
||||
ds-drop
|
||||
dup ^^allot-byte-array
|
||||
[ byte-array store-length ] [ ds-push ] [ ] tri ;
|
||||
|
||||
: emit-(byte-array) ( node -- )
|
||||
dup node-input-infos first literal>> dup expand-<byte-array>?
|
||||
dup node-input-infos first literal>> dup expand-(byte-array)?
|
||||
[ nip emit-allot-byte-array drop ] [ drop emit-primitive ] if ;
|
||||
|
||||
:: emit-<byte-array> ( node -- )
|
||||
|
|
|
|||
|
|
@ -57,12 +57,6 @@ IN: compiler.cfg.intrinsics.fixnum
|
|||
: emit-fixnum-comparison ( cc -- )
|
||||
'[ _ ^^compare ] emit-fixnum-op ;
|
||||
|
||||
: emit-bignum>fixnum ( -- )
|
||||
ds-pop ^^bignum>integer ^^tag-fixnum ds-push ;
|
||||
|
||||
: emit-fixnum>bignum ( -- )
|
||||
ds-pop ^^untag-fixnum ^^integer>bignum ds-push ;
|
||||
|
||||
: emit-no-overflow-case ( dst -- final-bb )
|
||||
[ ds-drop ds-drop ds-push ] with-branch ;
|
||||
|
||||
|
|
|
|||
|
|
@ -151,27 +151,64 @@ IN: compiler.cfg.intrinsics
|
|||
{ math.integers.private:fixnum-log2 [ drop emit-fixnum-log2 ] }
|
||||
} enable-intrinsics ;
|
||||
|
||||
: enable-sse2-simd ( -- )
|
||||
: enable-simd ( -- )
|
||||
{
|
||||
{ math.vectors.simd.intrinsics:assert-positive [ drop ] }
|
||||
{ math.vectors.simd.intrinsics:(simd-v+) [ [ ^^add-vector ] emit-binary-vector-op ] }
|
||||
{ math.vectors.simd.intrinsics:(simd-vs+) [ [ ^^saturated-add-vector ] emit-binary-vector-op ] }
|
||||
{ math.vectors.simd.intrinsics:(simd-v+-) [ [ ^^add-sub-vector ] emit-binary-vector-op ] }
|
||||
{ math.vectors.simd.intrinsics:(simd-v-) [ [ ^^sub-vector ] emit-binary-vector-op ] }
|
||||
{ math.vectors.simd.intrinsics:(simd-vs-) [ [ ^^saturated-sub-vector ] emit-binary-vector-op ] }
|
||||
{ math.vectors.simd.intrinsics:(simd-vneg) [ [ generate-neg-vector ] emit-unary-vector-op ] }
|
||||
{ math.vectors.simd.intrinsics:(simd-v*) [ [ ^^mul-vector ] emit-binary-vector-op ] }
|
||||
{ math.vectors.simd.intrinsics:(simd-vs*) [ [ ^^saturated-mul-vector ] emit-binary-vector-op ] }
|
||||
{ math.vectors.simd.intrinsics:(simd-v/) [ [ ^^div-vector ] emit-binary-vector-op ] }
|
||||
{ math.vectors.simd.intrinsics:(simd-vmin) [ [ ^^min-vector ] emit-binary-vector-op ] }
|
||||
{ math.vectors.simd.intrinsics:(simd-vmax) [ [ ^^max-vector ] emit-binary-vector-op ] }
|
||||
{ math.vectors.simd.intrinsics:(simd-vsqrt) [ [ ^^sqrt-vector ] emit-binary-vector-op ] }
|
||||
{ math.vectors.simd.intrinsics:(simd-broadcast) [ [ ^^broadcast-vector ] emit-unary-vector-op ] }
|
||||
{ math.vectors.simd.intrinsics:(simd-v.) [ [ ^^dot-vector ] emit-binary-vector-op ] }
|
||||
{ math.vectors.simd.intrinsics:(simd-vabs) [ [ generate-abs-vector ] emit-unary-vector-op ] }
|
||||
{ math.vectors.simd.intrinsics:(simd-vsqrt) [ [ ^^sqrt-vector ] emit-unary-vector-op ] }
|
||||
{ math.vectors.simd.intrinsics:(simd-vbitand) [ [ ^^and-vector ] emit-binary-vector-op ] }
|
||||
{ math.vectors.simd.intrinsics:(simd-vbitandn) [ [ ^^andn-vector ] emit-binary-vector-op ] }
|
||||
{ math.vectors.simd.intrinsics:(simd-vbitor) [ [ ^^or-vector ] emit-binary-vector-op ] }
|
||||
{ math.vectors.simd.intrinsics:(simd-vbitxor) [ [ ^^xor-vector ] emit-binary-vector-op ] }
|
||||
{ math.vectors.simd.intrinsics:(simd-vbitnot) [ [ generate-not-vector ] emit-unary-vector-op ] }
|
||||
{ math.vectors.simd.intrinsics:(simd-vand) [ [ ^^and-vector ] emit-binary-vector-op ] }
|
||||
{ math.vectors.simd.intrinsics:(simd-vandn) [ [ ^^andn-vector ] emit-binary-vector-op ] }
|
||||
{ math.vectors.simd.intrinsics:(simd-vor) [ [ ^^or-vector ] emit-binary-vector-op ] }
|
||||
{ math.vectors.simd.intrinsics:(simd-vxor) [ [ ^^xor-vector ] emit-binary-vector-op ] }
|
||||
{ math.vectors.simd.intrinsics:(simd-vnot) [ [ generate-not-vector ] emit-unary-vector-op ] }
|
||||
{ math.vectors.simd.intrinsics:(simd-v<=) [ [ cc<= generate-compare-vector ] emit-binary-vector-op ] }
|
||||
{ math.vectors.simd.intrinsics:(simd-v<) [ [ cc< generate-compare-vector ] emit-binary-vector-op ] }
|
||||
{ math.vectors.simd.intrinsics:(simd-v=) [ [ cc= generate-compare-vector ] emit-binary-vector-op ] }
|
||||
{ math.vectors.simd.intrinsics:(simd-v>) [ [ cc> generate-compare-vector ] emit-binary-vector-op ] }
|
||||
{ math.vectors.simd.intrinsics:(simd-v>=) [ [ cc>= generate-compare-vector ] emit-binary-vector-op ] }
|
||||
{ math.vectors.simd.intrinsics:(simd-vunordered?) [ [ cc/<>= generate-compare-vector ] emit-binary-vector-op ] }
|
||||
{ math.vectors.simd.intrinsics:(simd-vany?) [ [ vcc-any ^^test-vector ] emit-unary-vector-op ] }
|
||||
{ math.vectors.simd.intrinsics:(simd-vall?) [ [ vcc-all ^^test-vector ] emit-unary-vector-op ] }
|
||||
{ math.vectors.simd.intrinsics:(simd-vnone?) [ [ vcc-none ^^test-vector ] emit-unary-vector-op ] }
|
||||
{ math.vectors.simd.intrinsics:(simd-vlshift) [ [ ^^shl-vector ] emit-binary-vector-op ] }
|
||||
{ math.vectors.simd.intrinsics:(simd-vrshift) [ [ ^^shr-vector ] emit-binary-vector-op ] }
|
||||
{ math.vectors.simd.intrinsics:(simd-hlshift) [ [ ^^horizontal-shl-vector ] emit-horizontal-shift ] }
|
||||
{ math.vectors.simd.intrinsics:(simd-hrshift) [ [ ^^horizontal-shr-vector ] emit-horizontal-shift ] }
|
||||
{ math.vectors.simd.intrinsics:(simd-with) [ [ ^^with-vector ] emit-unary-vector-op ] }
|
||||
{ math.vectors.simd.intrinsics:(simd-gather-2) [ emit-gather-vector-2 ] }
|
||||
{ math.vectors.simd.intrinsics:(simd-gather-4) [ emit-gather-vector-4 ] }
|
||||
{ math.vectors.simd.intrinsics:(simd-vshuffle-elements) [ emit-shuffle-vector ] }
|
||||
{ math.vectors.simd.intrinsics:(simd-vshuffle-bytes) [ emit-shuffle-vector-var ] }
|
||||
{ math.vectors.simd.intrinsics:(simd-(vmerge-head)) [ [ ^^merge-vector-head ] emit-binary-vector-op ] }
|
||||
{ math.vectors.simd.intrinsics:(simd-(vmerge-tail)) [ [ ^^merge-vector-tail ] emit-binary-vector-op ] }
|
||||
{ math.vectors.simd.intrinsics:(simd-(v>float)) [ [ ^^integer>float-vector ] emit-unary-vector-op ] }
|
||||
{ math.vectors.simd.intrinsics:(simd-(v>integer)) [ [ ^^float>integer-vector ] emit-unary-vector-op ] }
|
||||
{ math.vectors.simd.intrinsics:(simd-(vpack-signed)) [ [ ^^signed-pack-vector ] emit-binary-vector-op ] }
|
||||
{ math.vectors.simd.intrinsics:(simd-(vpack-unsigned)) [ [ ^^unsigned-pack-vector ] emit-binary-vector-op ] }
|
||||
{ math.vectors.simd.intrinsics:(simd-(vunpack-head)) [ [ generate-unpack-vector-head ] emit-unary-vector-op ] }
|
||||
{ math.vectors.simd.intrinsics:(simd-(vunpack-tail)) [ [ generate-unpack-vector-tail ] emit-unary-vector-op ] }
|
||||
{ math.vectors.simd.intrinsics:(simd-select) [ emit-select-vector ] }
|
||||
{ math.vectors.simd.intrinsics:(simd-sum) [ [ ^^horizontal-add-vector ] emit-unary-vector-op ] }
|
||||
{ math.vectors.simd.intrinsics:alien-vector [ emit-alien-vector ] }
|
||||
{ math.vectors.simd.intrinsics:set-alien-vector [ emit-set-alien-vector ] }
|
||||
} enable-intrinsics ;
|
||||
|
||||
: enable-sse3-simd ( -- )
|
||||
{
|
||||
{ math.vectors.simd.intrinsics:(simd-sum) [ [ ^^horizontal-add-vector ] emit-unary-vector-op ] }
|
||||
} enable-intrinsics ;
|
||||
|
||||
: emit-intrinsic ( node word -- )
|
||||
"intrinsic" word-prop call( node -- ) ;
|
||||
|
|
|
|||
|
|
@ -12,5 +12,5 @@ IN: compiler.cfg.intrinsics.misc
|
|||
: emit-getenv ( node -- )
|
||||
"userenv" ^^vm-field-ptr
|
||||
swap node-input-infos first literal>>
|
||||
[ ds-drop 0 ^^slot-imm ] [ ds-pop ^^offset>slot 0 ^^slot ] if*
|
||||
[ ds-drop 0 ^^slot-imm ] [ ds-pop ^^offset>slot ^^slot ] if*
|
||||
ds-push ;
|
||||
|
|
|
|||
|
|
@ -1,22 +1,63 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors byte-arrays fry cpu.architecture kernel
|
||||
sequences compiler.tree.propagation.info
|
||||
compiler.cfg.builder.blocks compiler.cfg.stacks
|
||||
compiler.cfg.stacks.local compiler.cfg.hats
|
||||
USING: accessors alien byte-arrays fry classes.algebra
|
||||
cpu.architecture kernel math sequences math.vectors
|
||||
math.vectors.simd.intrinsics macros generalizations combinators
|
||||
combinators.short-circuit arrays locals
|
||||
compiler.tree.propagation.info compiler.cfg.builder.blocks
|
||||
compiler.cfg.comparisons
|
||||
compiler.cfg.stacks compiler.cfg.stacks.local compiler.cfg.hats
|
||||
compiler.cfg.instructions compiler.cfg.registers
|
||||
compiler.cfg.intrinsics.alien ;
|
||||
compiler.cfg.intrinsics.alien
|
||||
specialized-arrays ;
|
||||
FROM: alien.c-types => heap-size char uchar float double ;
|
||||
SPECIALIZED-ARRAYS: float double ;
|
||||
IN: compiler.cfg.intrinsics.simd
|
||||
|
||||
MACRO: check-elements ( quots -- )
|
||||
[ length '[ _ firstn ] ]
|
||||
[ '[ _ spread ] ]
|
||||
[ length 1 - \ and <repetition> [ ] like ]
|
||||
tri 3append ;
|
||||
|
||||
MACRO: if-literals-match ( quots -- )
|
||||
[ length ] [ ] [ length ] tri
|
||||
! n quots n
|
||||
'[
|
||||
! node quot
|
||||
[
|
||||
dup node-input-infos
|
||||
_ tail-slice* [ literal>> ] map
|
||||
dup _ check-elements
|
||||
] dip
|
||||
swap [
|
||||
! node literals quot
|
||||
[ _ firstn ] dip call
|
||||
drop
|
||||
] [ 2drop emit-primitive ] if
|
||||
] ;
|
||||
|
||||
: emit-vector-op ( node quot: ( rep -- ) -- )
|
||||
[ dup node-input-infos last literal>> ] dip over representation?
|
||||
[ [ drop ] 2dip call ] [ 2drop emit-primitive ] if ; inline
|
||||
{ [ representation? ] } if-literals-match ; inline
|
||||
|
||||
: [binary] ( quot -- quot' )
|
||||
'[ [ ds-drop 2inputs ] dip @ ds-push ] ; inline
|
||||
|
||||
: emit-binary-vector-op ( node quot -- )
|
||||
'[ [ ds-drop 2inputs ] dip @ ds-push ] emit-vector-op ; inline
|
||||
[binary] emit-vector-op ; inline
|
||||
|
||||
: [unary] ( quot -- quot' )
|
||||
'[ [ ds-drop ds-pop ] dip @ ds-push ] ; inline
|
||||
|
||||
: emit-unary-vector-op ( node quot -- )
|
||||
'[ [ ds-drop ds-pop ] dip @ ds-push ] emit-vector-op ; inline
|
||||
[unary] emit-vector-op ; inline
|
||||
|
||||
: [unary/param] ( quot -- quot' )
|
||||
'[ [ -2 inc-d ds-pop ] 2dip @ ds-push ] ; inline
|
||||
|
||||
: emit-horizontal-shift ( node quot -- )
|
||||
[unary/param]
|
||||
{ [ integer? ] [ representation? ] } if-literals-match ; inline
|
||||
|
||||
: emit-gather-vector-2 ( node -- )
|
||||
[ ^^gather-vector-2 ] emit-binary-vector-op ;
|
||||
|
|
@ -35,6 +76,61 @@ IN: compiler.cfg.intrinsics.simd
|
|||
ds-push
|
||||
] emit-vector-op ;
|
||||
|
||||
: shuffle? ( obj -- ? ) { [ array? ] [ [ integer? ] all? ] } 1&& ;
|
||||
|
||||
: >variable-shuffle ( shuffle rep -- shuffle' )
|
||||
rep-component-type heap-size
|
||||
[ dup <repetition> >byte-array ]
|
||||
[ iota >byte-array ] bi
|
||||
'[ _ n*v _ v+ ] map concat ;
|
||||
|
||||
: generate-shuffle-vector-imm ( src shuffle rep -- dst )
|
||||
dup %shuffle-vector-imm-reps member?
|
||||
[ ^^shuffle-vector-imm ]
|
||||
[
|
||||
[ >variable-shuffle ^^load-constant ] keep
|
||||
^^shuffle-vector
|
||||
] if ;
|
||||
|
||||
: emit-shuffle-vector-imm ( node -- )
|
||||
! Pad the permutation with zeroes if it's too short, since we
|
||||
! can't throw an error at this point.
|
||||
[ [ rep-components 0 pad-tail ] keep generate-shuffle-vector-imm ] [unary/param]
|
||||
{ [ shuffle? ] [ representation? ] } if-literals-match ;
|
||||
|
||||
: emit-shuffle-vector-var ( node -- )
|
||||
[ ^^shuffle-vector ] [binary]
|
||||
{ [ %shuffle-vector-reps member? ] } if-literals-match ;
|
||||
|
||||
: emit-shuffle-vector ( node -- )
|
||||
dup node-input-infos {
|
||||
[ length 3 = ]
|
||||
[ first class>> byte-array class<= ]
|
||||
[ second class>> byte-array class<= ]
|
||||
[ third literal>> representation? ]
|
||||
} 1&& [ emit-shuffle-vector-var ] [ emit-shuffle-vector-imm ] if ;
|
||||
|
||||
: ^^broadcast-vector ( src n rep -- dst )
|
||||
[ rep-components swap <array> ] keep
|
||||
generate-shuffle-vector-imm ;
|
||||
|
||||
: emit-broadcast-vector ( node -- )
|
||||
[ ^^broadcast-vector ] [unary/param]
|
||||
{ [ integer? ] [ representation? ] } if-literals-match ;
|
||||
|
||||
: ^^with-vector ( src rep -- dst )
|
||||
[ ^^scalar>vector ] keep [ 0 ] dip ^^broadcast-vector ;
|
||||
|
||||
: ^^select-vector ( src n rep -- dst )
|
||||
[ ^^broadcast-vector ] keep ^^vector>scalar ;
|
||||
|
||||
: emit-select-vector ( node -- )
|
||||
[ ^^select-vector ] [unary/param]
|
||||
{ [ integer? ] [ representation? ] } if-literals-match ; inline
|
||||
|
||||
: emit-alien-vector-op ( node quot: ( rep -- ) -- )
|
||||
{ [ %alien-vector-reps member? ] } if-literals-match ; inline
|
||||
|
||||
: emit-alien-vector ( node -- )
|
||||
dup [
|
||||
'[
|
||||
|
|
@ -42,7 +138,7 @@ IN: compiler.cfg.intrinsics.simd
|
|||
_ ^^alien-vector ds-push
|
||||
]
|
||||
[ inline-alien-getter? ] inline-alien
|
||||
] with emit-vector-op ;
|
||||
] with emit-alien-vector-op ;
|
||||
|
||||
: emit-set-alien-vector ( node -- )
|
||||
dup [
|
||||
|
|
@ -52,4 +148,106 @@ IN: compiler.cfg.intrinsics.simd
|
|||
]
|
||||
[ byte-array inline-alien-setter? ]
|
||||
inline-alien
|
||||
] with emit-vector-op ;
|
||||
] with emit-alien-vector-op ;
|
||||
|
||||
: generate-not-vector ( src rep -- dst )
|
||||
dup %not-vector-reps member?
|
||||
[ ^^not-vector ]
|
||||
[ [ ^^fill-vector ] [ ^^xor-vector ] bi ] if ;
|
||||
|
||||
:: (generate-compare-vector) ( src1 src2 rep {cc,swap} -- dst )
|
||||
{cc,swap} first2 :> swap? :> cc
|
||||
swap?
|
||||
[ src2 src1 rep cc ^^compare-vector ]
|
||||
[ src1 src2 rep cc ^^compare-vector ] if ;
|
||||
|
||||
:: generate-compare-vector ( src1 src2 rep orig-cc -- dst )
|
||||
rep orig-cc %compare-vector-ccs :> not? :> ccs
|
||||
|
||||
ccs empty?
|
||||
[ rep not? [ ^^fill-vector ] [ ^^zero-vector ] if ]
|
||||
[
|
||||
ccs unclip :> first-cc :> rest-ccs
|
||||
src1 src2 rep first-cc (generate-compare-vector) :> first-dst
|
||||
|
||||
rest-ccs first-dst
|
||||
[ [ src1 src2 rep ] dip (generate-compare-vector) rep ^^or-vector ]
|
||||
reduce
|
||||
|
||||
not? [ rep generate-not-vector ] when
|
||||
] if ;
|
||||
|
||||
:: generate-unpack-vector-head ( src rep -- dst )
|
||||
{
|
||||
{
|
||||
[ rep %unpack-vector-head-reps member? ]
|
||||
[ src rep ^^unpack-vector-head ]
|
||||
}
|
||||
[
|
||||
rep ^^zero-vector :> zero
|
||||
zero src rep cc> ^^compare-vector :> sign
|
||||
src sign rep ^^merge-vector-head
|
||||
]
|
||||
} cond ;
|
||||
|
||||
:: generate-unpack-vector-tail ( src rep -- dst )
|
||||
{
|
||||
{
|
||||
[ rep %unpack-vector-tail-reps member? ]
|
||||
[ src rep ^^unpack-vector-tail ]
|
||||
}
|
||||
{
|
||||
[ rep %unpack-vector-head-reps member? ]
|
||||
[
|
||||
src rep ^^tail>head-vector :> tail
|
||||
tail rep ^^unpack-vector-head
|
||||
]
|
||||
}
|
||||
[
|
||||
rep ^^zero-vector :> zero
|
||||
zero src rep cc> ^^compare-vector :> sign
|
||||
src sign rep ^^merge-vector-tail
|
||||
]
|
||||
} cond ;
|
||||
|
||||
:: generate-load-neg-zero-vector ( rep -- dst )
|
||||
rep {
|
||||
{ float-4-rep [ float-array{ -0.0 -0.0 -0.0 -0.0 } underlying>> ^^load-constant ] }
|
||||
{ double-2-rep [ double-array{ -0.0 -0.0 } underlying>> ^^load-constant ] }
|
||||
[ drop rep ^^zero-vector ]
|
||||
} case ;
|
||||
|
||||
:: generate-neg-vector ( src rep -- dst )
|
||||
rep generate-load-neg-zero-vector
|
||||
src rep ^^sub-vector ;
|
||||
|
||||
:: generate-blend-vector ( mask true false rep -- dst )
|
||||
mask true rep ^^and-vector
|
||||
mask false rep ^^andn-vector
|
||||
rep ^^or-vector ;
|
||||
|
||||
:: generate-abs-vector ( src rep -- dst )
|
||||
{
|
||||
{
|
||||
[ rep unsigned-int-vector-rep? ]
|
||||
[ src ]
|
||||
}
|
||||
{
|
||||
[ rep %abs-vector-reps member? ]
|
||||
[ src rep ^^abs-vector ]
|
||||
}
|
||||
{
|
||||
[ rep float-vector-rep? ]
|
||||
[
|
||||
rep generate-load-neg-zero-vector
|
||||
src rep ^^andn-vector
|
||||
]
|
||||
}
|
||||
[
|
||||
rep ^^zero-vector :> zero
|
||||
zero src rep ^^sub-vector :> -src
|
||||
zero src rep cc> ^^compare-vector :> sign
|
||||
sign -src src rep generate-blend-vector
|
||||
]
|
||||
} cond ;
|
||||
|
||||
|
|
|
|||
|
|
@ -8,9 +8,12 @@ IN: compiler.cfg.intrinsics.slots
|
|||
|
||||
: value-tag ( info -- n ) class>> class-tag ; inline
|
||||
|
||||
: ^^tag-offset>slot ( slot tag -- vreg' )
|
||||
[ ^^offset>slot ] dip ^^sub-imm ;
|
||||
|
||||
: (emit-slot) ( infos -- dst )
|
||||
[ 2inputs ^^offset>slot ] [ first value-tag ] bi*
|
||||
^^slot ;
|
||||
[ 2inputs ] [ first value-tag ] bi*
|
||||
^^tag-offset>slot ^^slot ;
|
||||
|
||||
: (emit-slot-imm) ( infos -- dst )
|
||||
ds-drop
|
||||
|
|
@ -28,8 +31,8 @@ IN: compiler.cfg.intrinsics.slots
|
|||
] [ drop emit-primitive ] if ;
|
||||
|
||||
: (emit-set-slot) ( infos -- obj-reg )
|
||||
[ 3inputs ^^offset>slot ] [ second value-tag ] bi*
|
||||
pick [ next-vreg ##set-slot ] dip ;
|
||||
[ 3inputs ] [ second value-tag ] bi*
|
||||
^^tag-offset>slot over [ ##set-slot ] dip ;
|
||||
|
||||
: (emit-set-slot-imm) ( infos -- obj-reg )
|
||||
ds-drop
|
||||
|
|
|
|||
|
|
@ -34,11 +34,15 @@ IN: compiler.cfg.linear-scan.allocation
|
|||
[ drop assign-blocked-register ]
|
||||
} cond ;
|
||||
|
||||
: spill-at-sync-point ( live-interval n -- ? )
|
||||
! If the live interval has a usage at 'n', don't spill it,
|
||||
! since this means its being defined by the sync point
|
||||
! instruction. Output t if this is the case.
|
||||
2dup [ uses>> ] dip swap member? [ 2drop t ] [ spill f ] if ;
|
||||
|
||||
: handle-sync-point ( n -- )
|
||||
[ active-intervals get values ] dip
|
||||
[ '[ [ _ spill ] each ] each ]
|
||||
[ drop [ delete-all ] each ]
|
||||
2bi ;
|
||||
'[ [ _ spill-at-sync-point ] filter-here ] each ;
|
||||
|
||||
:: handle-progress ( n sync? -- )
|
||||
n {
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays assocs combinators fry hints kernel locals
|
||||
math sequences sets sorting splitting namespaces
|
||||
math sequences sets sorting splitting namespaces linked-assocs
|
||||
combinators.short-circuit compiler.utilities
|
||||
compiler.cfg.linear-scan.allocation.state
|
||||
compiler.cfg.linear-scan.allocation.splitting
|
||||
|
|
@ -83,7 +83,7 @@ ERROR: bad-live-ranges interval ;
|
|||
find-use-positions ;
|
||||
|
||||
: spill-status ( new -- use-pos )
|
||||
H{ } clone
|
||||
H{ } <linked-assoc>
|
||||
[ inactive-positions ] [ active-positions ] [ nip ] 2tri
|
||||
>alist alist-max ;
|
||||
|
||||
|
|
|
|||
|
|
@ -2,8 +2,8 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors assocs combinators cpu.architecture fry heaps
|
||||
kernel math math.order namespaces sequences vectors
|
||||
compiler.cfg compiler.cfg.registers
|
||||
compiler.cfg.linear-scan.live-intervals ;
|
||||
linked-assocs compiler.cfg compiler.cfg.registers
|
||||
compiler.cfg.instructions compiler.cfg.linear-scan.live-intervals ;
|
||||
IN: compiler.cfg.linear-scan.allocation.state
|
||||
|
||||
! Start index of current live interval. We ensure that all
|
||||
|
|
@ -118,7 +118,8 @@ SYMBOL: unhandled-intervals
|
|||
|
||||
: next-spill-slot ( rep -- n )
|
||||
rep-size cfg get
|
||||
[ swap [ align dup ] [ + ] bi ] change-spill-area-size drop ;
|
||||
[ swap [ align dup ] [ + ] bi ] change-spill-area-size drop
|
||||
<spill-slot> ;
|
||||
|
||||
! Minheap of sync points which still need to be processed
|
||||
SYMBOL: unhandled-sync-points
|
||||
|
|
@ -126,7 +127,7 @@ SYMBOL: unhandled-sync-points
|
|||
! Mapping from vregs to spill slots
|
||||
SYMBOL: spill-slots
|
||||
|
||||
: vreg-spill-slot ( vreg -- n )
|
||||
: vreg-spill-slot ( vreg -- spill-slot )
|
||||
spill-slots get [ rep-of next-spill-slot ] cache ;
|
||||
|
||||
: init-allocator ( registers -- )
|
||||
|
|
@ -147,7 +148,8 @@ SYMBOL: spill-slots
|
|||
|
||||
! A utility used by register-status and spill-status words
|
||||
: free-positions ( new -- assoc )
|
||||
vreg>> rep-of reg-class-of registers get at [ 1/0. ] H{ } map>assoc ;
|
||||
vreg>> rep-of reg-class-of registers get at
|
||||
[ 1/0. ] H{ } <linked-assoc> map>assoc ;
|
||||
|
||||
: add-use-position ( n reg assoc -- ) [ [ min ] when* ] change-at ;
|
||||
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors kernel math assocs namespaces sequences heaps
|
||||
fry make combinators sets locals arrays
|
||||
cpu.architecture
|
||||
cpu.architecture layouts
|
||||
compiler.cfg
|
||||
compiler.cfg.def-use
|
||||
compiler.cfg.liveness
|
||||
|
|
@ -33,7 +33,7 @@ ERROR: bad-vreg vreg ;
|
|||
: (vreg>reg) ( vreg pending -- reg )
|
||||
! If a live vreg is not in the pending set, then it must
|
||||
! have been spilled.
|
||||
?at [ spill-slots get ?at [ <spill-slot> ] [ bad-vreg ] if ] unless ;
|
||||
?at [ spill-slots get ?at [ ] [ bad-vreg ] if ] unless ;
|
||||
|
||||
: vreg>reg ( vreg -- reg )
|
||||
pending-interval-assoc get (vreg>reg) ;
|
||||
|
|
@ -117,8 +117,6 @@ RENAMING: assign [ vreg>reg ] [ vreg>reg ] [ vreg>reg ]
|
|||
M: vreg-insn assign-registers-in-insn
|
||||
[ assign-insn-defs ] [ assign-insn-uses ] [ assign-insn-temps ] tri ;
|
||||
|
||||
! TODO: needs tagged-rep
|
||||
|
||||
: trace-on-gc ( assoc -- assoc' )
|
||||
! When a GC occurs, virtual registers which contain tagged data
|
||||
! are traced by the GC. Outputs a sequence physical registers.
|
||||
|
|
@ -141,12 +139,16 @@ M: vreg-insn assign-registers-in-insn
|
|||
] assoc-each
|
||||
] { } make ;
|
||||
|
||||
: gc-root-offsets ( registers -- alist )
|
||||
! Outputs a sequence of { offset register/spill-slot } pairs
|
||||
[ length iota [ cell * ] map ] keep zip ;
|
||||
|
||||
M: ##gc assign-registers-in-insn
|
||||
! Since ##gc is always the first instruction in a block, the set of
|
||||
! values live at the ##gc is just live-in.
|
||||
dup call-next-method
|
||||
basic-block get register-live-ins get at
|
||||
[ trace-on-gc >>tagged-values ] [ spill-on-gc >>data-values ] bi
|
||||
[ trace-on-gc gc-root-offsets >>tagged-values ] [ spill-on-gc >>data-values ] bi
|
||||
drop ;
|
||||
|
||||
M: insn assign-registers-in-insn drop ;
|
||||
|
|
|
|||
|
|
@ -92,7 +92,7 @@ H{
|
|||
{ end 2 }
|
||||
{ uses V{ 0 1 } }
|
||||
{ ranges V{ T{ live-range f 0 2 } } }
|
||||
{ spill-to 0 }
|
||||
{ spill-to T{ spill-slot f 0 } }
|
||||
}
|
||||
T{ live-interval
|
||||
{ vreg 1 }
|
||||
|
|
@ -100,7 +100,7 @@ H{
|
|||
{ end 5 }
|
||||
{ uses V{ 5 } }
|
||||
{ ranges V{ T{ live-range f 5 5 } } }
|
||||
{ reload-from 0 }
|
||||
{ reload-from T{ spill-slot f 0 } }
|
||||
}
|
||||
] [
|
||||
T{ live-interval
|
||||
|
|
@ -119,7 +119,7 @@ H{
|
|||
{ end 1 }
|
||||
{ uses V{ 0 } }
|
||||
{ ranges V{ T{ live-range f 0 1 } } }
|
||||
{ spill-to 4 }
|
||||
{ spill-to T{ spill-slot f 4 } }
|
||||
}
|
||||
T{ live-interval
|
||||
{ vreg 2 }
|
||||
|
|
@ -127,7 +127,7 @@ H{
|
|||
{ end 5 }
|
||||
{ uses V{ 1 5 } }
|
||||
{ ranges V{ T{ live-range f 1 5 } } }
|
||||
{ reload-from 4 }
|
||||
{ reload-from T{ spill-slot f 4 } }
|
||||
}
|
||||
] [
|
||||
T{ live-interval
|
||||
|
|
@ -146,7 +146,7 @@ H{
|
|||
{ end 1 }
|
||||
{ uses V{ 0 } }
|
||||
{ ranges V{ T{ live-range f 0 1 } } }
|
||||
{ spill-to 8 }
|
||||
{ spill-to T{ spill-slot f 8 } }
|
||||
}
|
||||
T{ live-interval
|
||||
{ vreg 3 }
|
||||
|
|
@ -154,7 +154,7 @@ H{
|
|||
{ end 30 }
|
||||
{ uses V{ 20 30 } }
|
||||
{ ranges V{ T{ live-range f 20 30 } } }
|
||||
{ reload-from 8 }
|
||||
{ reload-from T{ spill-slot f 8 } }
|
||||
}
|
||||
] [
|
||||
T{ live-interval
|
||||
|
|
@ -1042,8 +1042,8 @@ V{
|
|||
|
||||
[ _spill ] [ 1 get instructions>> second class ] unit-test
|
||||
[ _reload ] [ 4 get instructions>> 4 swap nth class ] unit-test
|
||||
[ V{ 3 2 1 } ] [ 8 get instructions>> [ _spill? ] filter [ n>> cell / ] map ] unit-test
|
||||
[ V{ 3 2 1 } ] [ 9 get instructions>> [ _reload? ] filter [ n>> cell / ] map ] unit-test
|
||||
[ V{ 3 2 1 } ] [ 8 get instructions>> [ _spill? ] filter [ dst>> n>> cell / ] map ] unit-test
|
||||
[ V{ 3 2 1 } ] [ 9 get instructions>> [ _reload? ] filter [ src>> n>> cell / ] map ] unit-test
|
||||
|
||||
! Resolve pass should insert this
|
||||
[ _reload ] [ 5 get predecessors>> first instructions>> first class ] unit-test
|
||||
|
|
@ -1465,7 +1465,7 @@ V{
|
|||
|
||||
[ ] [ { 1 2 3 } test-linear-scan-on-cfg ] unit-test
|
||||
|
||||
[ { 3 } ] [ 1 get instructions>> first tagged-values>> ] unit-test
|
||||
[ { { 0 1 } } ] [ 1 get instructions>> first tagged-values>> ] unit-test
|
||||
|
||||
V{
|
||||
T{ ##peek f 0 D 0 }
|
||||
|
|
@ -1487,4 +1487,4 @@ V{
|
|||
|
||||
[ ] [ { 1 2 3 } test-linear-scan-on-cfg ] unit-test
|
||||
|
||||
[ { 3 } ] [ 1 get instructions>> first tagged-values>> ] unit-test
|
||||
[ { { 0 1 } } ] [ 1 get instructions>> first tagged-values>> ] unit-test
|
||||
|
|
|
|||
|
|
@ -17,7 +17,7 @@ IN: compiler.cfg.linear-scan.resolve.tests
|
|||
|
||||
[
|
||||
{
|
||||
T{ _reload { dst 1 } { rep int-rep } { n 0 } }
|
||||
T{ _reload { dst 1 } { rep int-rep } { src T{ spill-slot f 0 } } }
|
||||
}
|
||||
] [
|
||||
[
|
||||
|
|
@ -27,7 +27,7 @@ IN: compiler.cfg.linear-scan.resolve.tests
|
|||
|
||||
[
|
||||
{
|
||||
T{ _spill { src 1 } { rep int-rep } { n 0 } }
|
||||
T{ _spill { src 1 } { rep int-rep } { dst T{ spill-slot f 0 } } }
|
||||
}
|
||||
] [
|
||||
[
|
||||
|
|
@ -54,14 +54,14 @@ H{ } clone spill-temps set
|
|||
{ { { 0 int-rep } { 1 int-rep } } { { 1 int-rep } { 0 int-rep } } }
|
||||
mapping-instructions {
|
||||
{
|
||||
T{ _spill { src 0 } { rep int-rep } { n 8 } }
|
||||
T{ _spill { src 0 } { rep int-rep } { dst T{ spill-slot f 8 } } }
|
||||
T{ ##copy { dst 0 } { src 1 } { rep int-rep } }
|
||||
T{ _reload { dst 1 } { rep int-rep } { n 8 } }
|
||||
T{ _reload { dst 1 } { rep int-rep } { src T{ spill-slot f 8 } } }
|
||||
}
|
||||
{
|
||||
T{ _spill { src 1 } { rep int-rep } { n 8 } }
|
||||
T{ _spill { src 1 } { rep int-rep } { dst T{ spill-slot f 8 } } }
|
||||
T{ ##copy { dst 1 } { src 0 } { rep int-rep } }
|
||||
T{ _reload { dst 0 } { rep int-rep } { n 8 } }
|
||||
T{ _reload { dst 0 } { rep int-rep } { src T{ spill-slot f 8 } } }
|
||||
}
|
||||
} member?
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -34,10 +34,10 @@ SYMBOL: spill-temps
|
|||
] if ;
|
||||
|
||||
: memory->register ( from to -- )
|
||||
swap [ first2 ] [ first n>> ] bi* _reload ;
|
||||
swap [ first2 ] [ first ] bi* _reload ;
|
||||
|
||||
: register->memory ( from to -- )
|
||||
[ first2 ] [ first n>> ] bi* _spill ;
|
||||
[ first2 ] [ first ] bi* _spill ;
|
||||
|
||||
: temp->register ( from to -- )
|
||||
nip [ first ] [ second ] [ second spill-temp ] tri _reload ;
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel math accessors sequences namespaces make
|
||||
combinators assocs arrays locals layouts hashtables
|
||||
cpu.architecture
|
||||
cpu.architecture generalizations
|
||||
compiler.cfg
|
||||
compiler.cfg.comparisons
|
||||
compiler.cfg.stack-frame
|
||||
|
|
@ -42,14 +42,26 @@ M: ##branch linearize-insn
|
|||
|
||||
: successors ( bb -- first second ) successors>> first2 ; inline
|
||||
|
||||
:: conditional ( bb insn n conditional-quot negate-cc-quot -- bb successor label ... )
|
||||
bb insn
|
||||
conditional-quot
|
||||
[ drop dup successors>> second useless-branch? ] 2bi
|
||||
[ [ swap block-number ] n ndip ]
|
||||
[ [ block-number ] n ndip negate-cc-quot call ] if ; inline
|
||||
|
||||
: (binary-conditional) ( bb insn -- bb successor1 successor2 src1 src2 cc )
|
||||
[ dup successors ]
|
||||
[ [ src1>> ] [ src2>> ] [ cc>> ] tri ] bi* ; inline
|
||||
|
||||
: binary-conditional ( bb insn -- bb successor label2 src1 src2 cc )
|
||||
[ (binary-conditional) ]
|
||||
[ drop dup successors>> second useless-branch? ] 2bi
|
||||
[ [ swap block-number ] 3dip ] [ [ block-number ] 3dip negate-cc ] if ;
|
||||
3 [ (binary-conditional) ] [ negate-cc ] conditional ;
|
||||
|
||||
: (test-vector-conditional) ( bb insn -- bb successor1 successor2 src1 temp rep vcc )
|
||||
[ dup successors ]
|
||||
[ { [ src1>> ] [ temp>> ] [ rep>> ] [ vcc>> ] } cleave ] bi* ; inline
|
||||
|
||||
: test-vector-conditional ( bb insn -- bb successor label src1 temp rep vcc )
|
||||
4 [ (test-vector-conditional) ] [ negate-vcc ] conditional ;
|
||||
|
||||
M: ##compare-branch linearize-insn
|
||||
binary-conditional _compare-branch emit-branch ;
|
||||
|
|
@ -63,6 +75,9 @@ M: ##compare-float-ordered-branch linearize-insn
|
|||
M: ##compare-float-unordered-branch linearize-insn
|
||||
binary-conditional _compare-float-unordered-branch emit-branch ;
|
||||
|
||||
M: ##test-vector-branch linearize-insn
|
||||
test-vector-conditional _test-vector-branch emit-branch ;
|
||||
|
||||
: overflow-conditional ( bb insn -- bb successor label2 dst src1 src2 )
|
||||
[ dup successors block-number ]
|
||||
[ [ dst>> ] [ src1>> ] [ src2>> ] tri ] bi* ; inline
|
||||
|
|
@ -82,21 +97,6 @@ M: ##dispatch linearize-insn
|
|||
[ successors>> [ block-number _dispatch-label ] each ]
|
||||
bi* ;
|
||||
|
||||
: gc-root-offsets ( registers -- alist )
|
||||
! Outputs a sequence of { offset register/spill-slot } pairs
|
||||
[ length iota [ cell * ] map ] keep zip ;
|
||||
|
||||
M: ##gc linearize-insn
|
||||
nip
|
||||
{
|
||||
[ temp1>> ]
|
||||
[ temp2>> ]
|
||||
[ data-values>> ]
|
||||
[ tagged-values>> gc-root-offsets ]
|
||||
[ uninitialized-locs>> ]
|
||||
} cleave
|
||||
_gc ;
|
||||
|
||||
: linearize-basic-blocks ( cfg -- insns )
|
||||
[
|
||||
[
|
||||
|
|
|
|||
|
|
@ -12,7 +12,6 @@ compiler.cfg.copy-prop
|
|||
compiler.cfg.dce
|
||||
compiler.cfg.write-barrier
|
||||
compiler.cfg.representations
|
||||
compiler.cfg.two-operand
|
||||
compiler.cfg.ssa.destruction
|
||||
compiler.cfg.empty-blocks
|
||||
compiler.cfg.checker ;
|
||||
|
|
@ -37,7 +36,6 @@ SYMBOL: check-optimizer?
|
|||
eliminate-dead-code
|
||||
eliminate-write-barriers
|
||||
select-representations
|
||||
convert-two-operand
|
||||
destruct-ssa
|
||||
delete-empty-blocks
|
||||
?check ;
|
||||
|
|
|
|||
|
|
@ -3,8 +3,8 @@
|
|||
USING: kernel accessors sequences arrays fry namespaces generic
|
||||
words sets combinators generalizations cpu.architecture compiler.units
|
||||
compiler.cfg.utilities compiler.cfg compiler.cfg.rpo
|
||||
compiler.cfg.instructions compiler.cfg.instructions.syntax
|
||||
compiler.cfg.def-use ;
|
||||
compiler.cfg.instructions compiler.cfg.def-use ;
|
||||
FROM: compiler.cfg.instructions.syntax => insn-def-slot insn-use-slots insn-temp-slots scalar-rep ;
|
||||
IN: compiler.cfg.representations.preferred
|
||||
|
||||
GENERIC: defs-vreg-rep ( insn -- rep/f )
|
||||
|
|
|
|||
|
|
@ -1,8 +1,10 @@
|
|||
! Copyright (C) 2009 Slava Pestov
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel fry accessors sequences assocs sets namespaces
|
||||
arrays combinators make locals deques dlists
|
||||
cpu.architecture compiler.utilities
|
||||
arrays combinators combinators.short-circuit math make locals
|
||||
deques dlists layouts byte-arrays cpu.architecture
|
||||
compiler.utilities
|
||||
compiler.constants
|
||||
compiler.cfg
|
||||
compiler.cfg.rpo
|
||||
compiler.cfg.hats
|
||||
|
|
@ -22,28 +24,44 @@ ERROR: bad-conversion dst src dst-rep src-rep ;
|
|||
GENERIC: emit-box ( dst src rep -- )
|
||||
GENERIC: emit-unbox ( dst src rep -- )
|
||||
|
||||
M: float-rep emit-box
|
||||
drop
|
||||
[ double-rep next-vreg-rep dup ] dip ##single>double-float
|
||||
int-rep next-vreg-rep ##box-float ;
|
||||
M:: float-rep emit-box ( dst src rep -- )
|
||||
double-rep next-vreg-rep :> temp
|
||||
temp src ##single>double-float
|
||||
dst temp double-rep emit-box ;
|
||||
|
||||
M: float-rep emit-unbox
|
||||
drop
|
||||
[ double-rep next-vreg-rep dup ] dip ##unbox-float
|
||||
##double>single-float ;
|
||||
M:: float-rep emit-unbox ( dst src rep -- )
|
||||
double-rep next-vreg-rep :> temp
|
||||
temp src double-rep emit-unbox
|
||||
dst temp ##double>single-float ;
|
||||
|
||||
M: double-rep emit-box
|
||||
drop
|
||||
int-rep next-vreg-rep ##box-float ;
|
||||
[ drop 16 float int-rep next-vreg-rep ##allot ]
|
||||
[ float-offset swap ##set-alien-double ]
|
||||
2bi ;
|
||||
|
||||
M: double-rep emit-unbox
|
||||
drop ##unbox-float ;
|
||||
drop float-offset ##alien-double ;
|
||||
|
||||
M: vector-rep emit-box
|
||||
int-rep next-vreg-rep ##box-vector ;
|
||||
M:: vector-rep emit-box ( dst src rep -- )
|
||||
int-rep next-vreg-rep :> temp
|
||||
dst 16 2 cells + byte-array int-rep next-vreg-rep ##allot
|
||||
temp 16 tag-fixnum ##load-immediate
|
||||
temp dst 1 byte-array tag-number ##set-slot-imm
|
||||
dst byte-array-offset src rep ##set-alien-vector ;
|
||||
|
||||
M: vector-rep emit-unbox
|
||||
##unbox-vector ;
|
||||
[ byte-array-offset ] dip ##alien-vector ;
|
||||
|
||||
M:: scalar-rep emit-box ( dst src rep -- )
|
||||
int-rep next-vreg-rep :> temp
|
||||
temp src rep ##scalar>integer
|
||||
dst temp tag-bits get ##shl-imm ;
|
||||
|
||||
M:: scalar-rep emit-unbox ( dst src rep -- )
|
||||
int-rep next-vreg-rep :> temp
|
||||
temp src tag-bits get ##sar-imm
|
||||
dst temp rep ##integer>scalar ;
|
||||
|
||||
: emit-conversion ( dst src dst-rep src-rep -- )
|
||||
{
|
||||
|
|
@ -87,9 +105,8 @@ SYMBOL: always-boxed
|
|||
H{ } clone [
|
||||
'[
|
||||
[
|
||||
dup ##load-reference? [ drop ] [
|
||||
[ _ (compute-always-boxed) ] each-def-rep
|
||||
] if
|
||||
dup [ ##load-reference? ] [ ##load-constant? ] bi or
|
||||
[ drop ] [ [ _ (compute-always-boxed) ] each-def-rep ] if
|
||||
] each-non-phi
|
||||
] each-basic-block
|
||||
] keep ;
|
||||
|
|
@ -135,6 +152,9 @@ SYMBOL: costs
|
|||
! Insert conversions. This introduces new temporaries, so we need
|
||||
! to rename opearands too.
|
||||
|
||||
! Mapping from vreg,rep pairs to vregs
|
||||
SYMBOL: alternatives
|
||||
|
||||
:: emit-def-conversion ( dst preferred required -- new-dst' )
|
||||
! If an instruction defines a register with representation 'required',
|
||||
! but the register has preferred representation 'preferred', then
|
||||
|
|
@ -147,7 +167,13 @@ SYMBOL: costs
|
|||
! but the register has preferred representation 'preferred', then
|
||||
! we rename the instruction's input to a new register, which
|
||||
! becomes the output of a conversion instruction.
|
||||
required next-vreg-rep [ src required preferred emit-conversion ] keep ;
|
||||
preferred required eq? [ src ] [
|
||||
src required alternatives get [
|
||||
required next-vreg-rep :> new-src
|
||||
[ new-src ] 2dip preferred emit-conversion
|
||||
new-src
|
||||
] 2cache
|
||||
] if ;
|
||||
|
||||
SYMBOLS: renaming-set needs-renaming? ;
|
||||
|
||||
|
|
@ -200,6 +226,41 @@ SYMBOL: phi-mappings
|
|||
M: ##phi conversions-for-insn
|
||||
[ , ] [ [ inputs>> values ] [ dst>> ] bi phi-mappings get set-at ] bi ;
|
||||
|
||||
! When a literal zeroes/ones vector is unboxed, we replace the ##load-reference
|
||||
! with a ##zero-vector or ##fill-vector instruction since this is more efficient.
|
||||
: convert-to-zero-vector? ( insn -- ? )
|
||||
{
|
||||
[ dst>> rep-of vector-rep? ]
|
||||
[ obj>> B{ 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 } = ]
|
||||
} 1&& ;
|
||||
: convert-to-fill-vector? ( insn -- ? )
|
||||
{
|
||||
[ dst>> rep-of vector-rep? ]
|
||||
[ obj>> B{ 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 } = ]
|
||||
} 1&& ;
|
||||
|
||||
: (convert-to-zero/fill-vector) ( insn -- dst rep )
|
||||
dst>> dup rep-of ; inline
|
||||
|
||||
: conversions-for-load-insn ( insn -- ?insn )
|
||||
{
|
||||
{
|
||||
[ dup convert-to-zero-vector? ]
|
||||
[ (convert-to-zero/fill-vector) ##zero-vector f ]
|
||||
}
|
||||
{
|
||||
[ dup convert-to-fill-vector? ]
|
||||
[ (convert-to-zero/fill-vector) ##fill-vector f ]
|
||||
}
|
||||
[ ]
|
||||
} cond ;
|
||||
|
||||
M: ##load-reference conversions-for-insn
|
||||
conversions-for-load-insn [ call-next-method ] when* ;
|
||||
|
||||
M: ##load-constant conversions-for-insn
|
||||
conversions-for-load-insn [ call-next-method ] when* ;
|
||||
|
||||
M: vreg-insn conversions-for-insn
|
||||
[ compute-renaming-set ] [ perform-renaming ] bi ;
|
||||
|
||||
|
|
@ -209,6 +270,7 @@ M: insn conversions-for-insn , ;
|
|||
dup kill-block? [ drop ] [
|
||||
[
|
||||
[
|
||||
H{ } clone alternatives set
|
||||
[ conversions-for-insn ] each
|
||||
] V{ } make
|
||||
] change-instructions drop
|
||||
|
|
@ -266,4 +328,4 @@ PRIVATE>
|
|||
[ insert-conversions ]
|
||||
[ ]
|
||||
} cleave
|
||||
representations get cfg get (>>reps) ;
|
||||
representations get cfg get (>>reps) ;
|
||||
|
|
|
|||
|
|
@ -1,8 +1,9 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors assocs kernel locals fry
|
||||
USING: accessors assocs kernel locals fry sequences
|
||||
cpu.architecture
|
||||
compiler.cfg.rpo
|
||||
compiler.cfg.def-use
|
||||
compiler.cfg.utilities
|
||||
compiler.cfg.registers
|
||||
compiler.cfg.instructions
|
||||
|
|
@ -13,10 +14,19 @@ IN: compiler.cfg.ssa.cssa
|
|||
! selection, so it must keep track of representations when introducing
|
||||
! new values.
|
||||
|
||||
: insert-copy? ( bb vreg -- ? )
|
||||
! If the last instruction defines a value (which means it is
|
||||
! ##fixnum-add, ##fixnum-sub or ##fixnum-mul) then we don't
|
||||
! need to insert a copy since in fact doing so will result
|
||||
! in incorrect code.
|
||||
[ instructions>> last defs-vreg ] dip eq? not ;
|
||||
|
||||
:: insert-copy ( bb src rep -- bb dst )
|
||||
rep next-vreg-rep :> dst
|
||||
bb [ dst src rep src rep-of emit-conversion ] add-instructions
|
||||
bb dst ;
|
||||
bb src insert-copy? [
|
||||
rep next-vreg-rep :> dst
|
||||
bb [ dst src rep src rep-of emit-conversion ] add-instructions
|
||||
bb dst
|
||||
] [ bb src ] if ;
|
||||
|
||||
: convert-phi ( ##phi -- )
|
||||
dup dst>> rep-of '[ [ _ insert-copy ] assoc-map ] change-inputs drop ;
|
||||
|
|
|
|||
|
|
@ -6,6 +6,7 @@ sets vectors
|
|||
compiler.cfg.rpo
|
||||
compiler.cfg.def-use
|
||||
compiler.cfg.renaming
|
||||
compiler.cfg.registers
|
||||
compiler.cfg.dominance
|
||||
compiler.cfg.instructions
|
||||
compiler.cfg.liveness.ssa
|
||||
|
|
@ -60,15 +61,23 @@ SYMBOL: copies
|
|||
|
||||
GENERIC: prepare-insn ( insn -- )
|
||||
|
||||
: try-to-coalesce ( dst src -- ) 2array copies get push ;
|
||||
|
||||
M: insn prepare-insn
|
||||
[ defs-vreg ] [ uses-vregs ] bi
|
||||
2dup empty? not and [
|
||||
first
|
||||
2dup [ rep-of ] bi@ eq?
|
||||
[ try-to-coalesce ] [ 2drop ] if
|
||||
] [ 2drop ] if ;
|
||||
|
||||
M: ##copy prepare-insn
|
||||
[ dst>> ] [ src>> ] bi 2array copies get push ;
|
||||
[ dst>> ] [ src>> ] bi try-to-coalesce ;
|
||||
|
||||
M: ##phi prepare-insn
|
||||
[ dst>> ] [ inputs>> values ] bi
|
||||
[ eliminate-copy ] with each ;
|
||||
|
||||
M: insn prepare-insn drop ;
|
||||
|
||||
: prepare-block ( bb -- )
|
||||
instructions>> [ prepare-insn ] each ;
|
||||
|
||||
|
|
|
|||
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue