CFLAGS += -O3
endif
+ifdef REENTRANT
+ CFLAGS += -DFACTOR_REENTRANT
+endif
+
CFLAGS += $(SITE_CFLAGS)
ENGINE = $(DLL_PREFIX)factor$(DLL_SUFFIX)$(DLL_EXTENSION)
Factor.app/Contents/MacOS/factor
$(EXECUTABLE): $(DLL_OBJS) $(EXE_OBJS)
- $(LINKER) $(ENGINE) $(DLL_OBJS)
- $(CPP) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \
+ $(TOOLCHAIN_PREFIX)$(LINKER) $(ENGINE) $(DLL_OBJS)
+ $(TOOLCHAIN_PREFIX)$(CPP) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \
$(CFLAGS) -o $@$(EXE_SUFFIX)$(EXE_EXTENSION) $(EXE_OBJS)
$(CONSOLE_EXECUTABLE): $(DLL_OBJS) $(EXE_OBJS)
- $(LINKER) $(ENGINE) $(DLL_OBJS)
- $(CPP) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \
+ $(TOOLCHAIN_PREFIX)$(LINKER) $(ENGINE) $(DLL_OBJS)
+ $(TOOLCHAIN_PREFIX)$(CPP) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \
$(CFLAGS) $(CFLAGS_CONSOLE) -o factor$(EXE_SUFFIX)$(CONSOLE_EXTENSION) $(EXE_OBJS)
$(TEST_LIBRARY): vm/ffi_test.o
- $(CC) $(LIBPATH) $(CFLAGS) $(FFI_TEST_CFLAGS) $(SHARED_FLAG) -o libfactor-ffi-test$(SHARED_DLL_EXTENSION) $(TEST_OBJS)
+ $(TOOLCHAIN_PREFIX)$(CC) $(LIBPATH) $(CFLAGS) $(FFI_TEST_CFLAGS) $(SHARED_FLAG) -o libfactor-ffi-test$(SHARED_DLL_EXTENSION) $(TEST_OBJS)
clean:
rm -f vm/*.o
etags vm/*.{cpp,hpp,mm,S,c}
vm/resources.o:
- $(WINDRES) vm/factor.rs vm/resources.o
+ $(TOOLCHAIN_PREFIX)$(WINDRES) vm/factor.rs vm/resources.o
vm/ffi_test.o: vm/ffi_test.c
- $(CC) -c $(CFLAGS) $(FFI_TEST_CFLAGS) -o $@ $<
+ $(TOOLCHAIN_PREFIX)$(CC) -c $(CFLAGS) $(FFI_TEST_CFLAGS) -o $@ $<
.c.o:
- $(CC) -c $(CFLAGS) -o $@ $<
+ $(TOOLCHAIN_PREFIX)$(CC) -c $(CFLAGS) -o $@ $<
.cpp.o:
- $(CPP) -c $(CFLAGS) -o $@ $<
+ $(TOOLCHAIN_PREFIX)$(CPP) -c $(CFLAGS) -o $@ $<
.S.o:
- $(CC) -x assembler-with-cpp -c $(CFLAGS) -o $@ $<
+ $(TOOLCHAIN_PREFIX)$(CC) -x assembler-with-cpp -c $(CFLAGS) -o $@ $<
.mm.o:
- $(CPP) -c $(CFLAGS) -o $@ $<
+ $(TOOLCHAIN_PREFIX)$(CPP) -c $(CFLAGS) -o $@ $<
.PHONY: factor tags clean
+USING: help.syntax help.markup byte-arrays alien.c-types alien.data ;\r
IN: alien.arrays\r
-USING: help.syntax help.markup byte-arrays alien.c-types ;\r
\r
ARTICLE: "c-arrays" "C arrays"\r
"C arrays are allocated in the same manner as other C data; see " { $link "c-byte-arrays" } " and " { $link "malloc" } "."\r
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.strings alien.c-types alien.accessors alien.structs
-arrays words sequences math kernel namespaces fry libc cpu.architecture
+USING: alien alien.strings alien.c-types alien.data alien.accessors
+arrays words sequences math kernel namespaces fry cpu.architecture
io.encodings.utf8 accessors ;
IN: alien.arrays
-UNION: value-type array struct-type ;
+INSTANCE: array value-type
M: array c-type ;
M: array c-type-stack-align? drop f ;
-M: array unbox-parameter drop "void*" unbox-parameter ;
+M: array unbox-parameter drop void* unbox-parameter ;
-M: array unbox-return drop "void*" unbox-return ;
+M: array unbox-return drop void* unbox-return ;
-M: array box-parameter drop "void*" box-parameter ;
+M: array box-parameter drop void* box-parameter ;
-M: array box-return drop "void*" box-return ;
+M: array box-return drop void* box-return ;
-M: array stack-size drop "void*" stack-size ;
+M: array stack-size drop void* stack-size ;
M: array c-type-boxer-quot
unclip
M: array c-type-unboxer-quot drop [ >c-ptr ] ;
-M: value-type c-type-rep drop int-rep ;
-
-M: value-type c-type-getter
- drop [ swap <displaced-alien> ] ;
-
-M: value-type c-type-setter ( type -- quot )
- [ c-type-getter ] [ c-type-unboxer-quot ] [ heap-size ] tri
- '[ @ swap @ _ memcpy ] ;
-
PREDICATE: string-type < pair
- first2 [ "char*" = ] [ word? ] bi* and ;
+ first2 [ char* = ] [ word? ] bi* and ;
M: string-type c-type ;
M: string-type c-type-boxed-class drop object ;
M: string-type heap-size
- drop "void*" heap-size ;
+ drop void* heap-size ;
M: string-type c-type-align
- drop "void*" c-type-align ;
+ drop void* c-type-align ;
M: string-type c-type-stack-align?
- drop "void*" c-type-stack-align? ;
+ drop void* c-type-stack-align? ;
M: string-type unbox-parameter
- drop "void*" unbox-parameter ;
+ drop void* unbox-parameter ;
M: string-type unbox-return
- drop "void*" unbox-return ;
+ drop void* unbox-return ;
M: string-type box-parameter
- drop "void*" box-parameter ;
+ drop void* box-parameter ;
M: string-type box-return
- drop "void*" box-return ;
+ drop void* box-return ;
M: string-type stack-size
- drop "void*" stack-size ;
+ drop void* stack-size ;
M: string-type c-type-rep
drop int-rep ;
M: string-type c-type-boxer
- drop "void*" c-type-boxer ;
+ drop void* c-type-boxer ;
M: string-type c-type-unboxer
- drop "void*" c-type-unboxer ;
+ drop void* c-type-unboxer ;
M: string-type c-type-boxer-quot
second '[ _ alien>string ] ;
M: string-type c-type-setter
drop [ set-alien-cell ] ;
-{ "char*" utf8 } "char*" typedef
-"char*" "uchar*" typedef
+{ char* utf8 } char* typedef
+char* uchar* typedef
+char char* "pointer-c-type" set-word-prop
+uchar uchar* "pointer-c-type" set-word-prop
+USING: alien alien.complex help.syntax help.markup libc kernel.private
+byte-arrays strings hashtables alien.syntax alien.strings sequences
+io.encodings.string debugger destructors vocabs.loader
+classes.struct ;
+QUALIFIED: math
IN: alien.c-types
-USING: alien help.syntax help.markup libc kernel.private
-byte-arrays math strings hashtables alien.syntax alien.strings sequences
-io.encodings.string debugger destructors vocabs.loader ;
+
+HELP: byte-length
+{ $values { "seq" "A byte array or float array" } { "n" "a non-negative integer" } }
+{ $contract "Outputs the size of the byte array, struct, or specialized array data in bytes." } ;
+
+HELP: heap-size
+{ $values { "type" string } { "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" }
+}
+{ $errors "Throws a " { $link no-c-type } " error if the type does not exist." } ;
+
+HELP: stack-size
+{ $values { "type" string } { "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 } }
{ $description "Looks up a C type by name." }
{ $errors "Throws a " { $link no-c-type } " error if the type does not exist." } ;
-HELP: heap-size
-{ $values { "type" string } { "size" 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" }
-}
-{ $errors "Throws a " { $link no-c-type } " error if the type does not exist." } ;
-
-HELP: stack-size
-{ $values { "type" string } { "size" 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: byte-length
-{ $values { "seq" "A byte array or float array" } { "n" "a non-negative integer" } }
-{ $contract "Outputs the size of the byte array or float array data in bytes as presented to the C library interface." } ;
-
HELP: c-getter
{ $values { "name" string } { "quot" { $quotation "( c-ptr n -- obj )" } } }
{ $description "Outputs a quotation which reads values of this C type from a C structure." }
{ $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: <c-array>
-{ $values { "len" "a non-negative integer" } { "c-type" "a C type" } { "array" byte-array } }
-{ $description "Creates a byte array large enough to hold " { $snippet "n" } " values of a C type." }
-{ $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." }
-{ $errors "Throws an error if the type does not exist, the necessary specialized array vocabulary is not loaded, or the requested size is negative." } ;
-
-HELP: <c-object>
-{ $values { "type" "a C type" } { "array" byte-array } }
-{ $description "Creates a byte array suitable for holding a value with the given C type." }
-{ $errors "Throws an " { $link no-c-type } " error if the type does not exist." } ;
-
-{ <c-object> malloc-object } related-words
-
-HELP: memory>byte-array
-{ $values { "alien" c-ptr } { "len" "a non-negative integer" } { "byte-array" byte-array } }
-{ $description "Reads " { $snippet "len" } " bytes starting from " { $snippet "base" } " and stores them in a new byte array." } ;
-
-HELP: byte-array>memory
-{ $values { "byte-array" byte-array } { "base" c-ptr } }
-{ $description "Writes a byte array to memory starting from the " { $snippet "base" } " address." }
-{ $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 } }
-{ $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 } "." }
-{ $errors "Throws an error if the type does not exist, if the requested size is negative, if a direct specialized array class appropriate to the type is not loaded, or if memory allocation fails." } ;
-
-HELP: malloc-object
-{ $values { "type" "a C type" } { "alien" alien } }
-{ $description "Allocates an unmanaged memory block large enough to hold a value of a C type." }
-{ $warning "Don't forget to deallocate the memory with a call to " { $link free } "." }
-{ $errors "Throws an error if the type does not exist or if memory allocation fails." } ;
-
-HELP: malloc-byte-array
-{ $values { "byte-array" byte-array } { "alien" alien } }
-{ $description "Allocates an unmanaged memory block of the same size as the byte array, and copies the contents of the byte array there." }
-{ $warning "Don't forget to deallocate the memory with a call to " { $link free } "." }
-{ $errors "Throws an error if memory allocation fails." } ;
-
-{ <c-array> <c-direct-array> malloc-array } related-words
-
HELP: box-parameter
-{ $values { "n" integer } { "ctype" string } }
+{ $values { "n" math:integer } { "ctype" string } }
{ $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." } ;
{ $description "Defines a word " { $snippet "<" { $emphasis "name" } ">" } " with stack effect " { $snippet "( value -- array )" } ". This word allocates a byte array large enough to hold a value with C type " { $snippet "name" } ", and writes the value at the top of the stack to the array." }
{ $notes "This is an internal word called when defining C types, there is no need to call it on your own." } ;
-{ string>alien alien>string malloc-string } related-words
-
-HELP: malloc-string
-{ $values { "string" string } { "encoding" "an encoding descriptor" } { "alien" c-ptr } }
-{ $description "Encodes a string together with a trailing null code point using the given encoding, and stores the resulting bytes in a freshly-allocated unmanaged memory block." }
-{ $warning "Don't forget to deallocate the memory with a call to " { $link free } "." }
-{ $errors "Throws an error if one of the following conditions occurs:"
- { $list
- "the string contains null code points"
- "the string contains characters not representable using the encoding specified"
- "memory allocation fails"
- }
-} ;
-
-HELP: require-c-array
-{ $values { "c-type" "a C type" } }
-{ $description "Generates a specialized array of " { $snippet "c-type" } " using the " { $link <c-array> } " or " { $link <c-direct-array> } " vocabularies." }
-{ $notes "This word must be called inside a compilation unit. See the " { $vocab-link "specialized-arrays" } " vocabulary for details on the underlying sequence types loaded." } ;
+HELP: char
+{ $description "This C type represents a one-byte signed integer type. Input values will be converted to " { $link math:integer } "s and truncated to eight bits; output values will be returned as " { $link math:fixnum } "s." } ;
+HELP: uchar
+{ $description "This C type represents a one-byte unsigned integer type. Input values will be converted to " { $link math:integer } "s and truncated to eight bits; output values will be returned as " { $link math:fixnum } "s." } ;
+HELP: short
+{ $description "This C type represents a two-byte signed integer type. Input values will be converted to " { $link math:integer } "s and truncated to sixteen bits; output values will be returned as " { $link math:fixnum } "s." } ;
+HELP: ushort
+{ $description "This C type represents a two-byte unsigned integer type. Input values will be converted to " { $link math:integer } "s and truncated to sixteen bits; output values will be returned as " { $link math:fixnum } "s." } ;
+HELP: int
+{ $description "This C type represents a four-byte signed 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: 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: 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: 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." } ;
+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." } ;
+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
+{ $description "This C type represents a single-precision IEEE 754 floating-point type. Input values will be converted to Factor " { $link math:float } "s and demoted to single-precision; output values will be returned as Factor " { $link math:float } "s." } ;
+HELP: double
+{ $description "This C type represents a double-precision IEEE 754 floating-point type. Input values will be converted to Factor " { $link math:float } "s; output values will be returned as Factor " { $link math:float } "s." } ;
+HELP: complex-float
+{ $description "This C type represents a single-precision IEEE 754 floating-point complex type. Input values will be converted from Factor " { $link math:complex } " objects into a single-precision complex float type; output values will be returned as Factor " { $link math:complex } " objects." } ;
+HELP: complex-double
+{ $description "This C type represents a double-precision IEEE 754 floating-point complex type. Input values will be converted from Factor " { $link math:complex } " objects into a double-precision complex float type; output values will be returned as Factor " { $link math:complex } " objects." } ;
-HELP: <c-direct-array>
-{ $values { "alien" c-ptr } { "len" integer } { "c-type" "a C type" } { "array" "a specialized direct array" } }
-{ $description "Constructs a new specialized array of length " { $snippet "len" } " and element type " { $snippet "c-type" } " over the range of memory referenced by " { $snippet "alien" } "." }
-{ $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." } ;
-
-ARTICLE: "c-strings" "C strings"
-"C string types are arrays with shape " { $snippet "{ \"char*\" encoding }" } ", where " { $snippet "encoding" } " is an encoding descriptor. The type " { $snippet "\"char*\"" } " is an alias for " { $snippet "{ \"char*\" utf8 }" } ". See " { $link "encodings-descriptors" } " for information about encoding descriptors."
-$nl
-"Passing a Factor string to a C function expecting a C string allocates a " { $link byte-array } " in the Factor heap; the string is then converted to the requested format and a raw pointer is passed to the function."
-$nl
-"If the conversion fails, for example if the string contains null bytes or characters with values higher than 255, a " { $link c-string-error. } " is thrown."
-$nl
-"Care must be taken if the C function expects a " { $snippet "char*" } " with a length in bytes, rather than a null-terminated " { $snippet "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 " { $snippet "void*" } ", and various data types, among them strings, can be passed in. In this case, strings are not automatically converted to aliens, and instead you must call one of these words:"
-{ $subsection string>alien }
-{ $subsection malloc-string }
-"The first allocates " { $link byte-array } "s, and the latter allocates manually-managed memory which is not moved by the garbage collector and has to be explicitly freed by calling " { $link free } ". See " { $link "byte-arrays-gc" } " for a discussion of the two approaches."
-$nl
-"A word to read strings from arbitrary addresses:"
-{ $subsection alien>string }
-"For example, if a C function returns a " { $snippet "char*" } " but stipulates that the caller must deallocate the memory afterward, you must define the function as returning " { $snippet "void*" } ", and call one of the above words before passing the pointer to " { $link free } "." ;
ARTICLE: "byte-arrays-gc" "Byte arrays and the garbage collector"
"The Factor garbage collector can move byte arrays around, and it is only safe to pass byte arrays to C functions if the garbage collector will not run while C code still has a reference to the data."
"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 strings, and type names occur as parameters to the " { $link alien-invoke } ", " { $link alien-indirect } " and " { $link alien-callback } " words, as well as " { $link POSTPONE: C-STRUCT: } ", " { $link POSTPONE: C-UNION: } " and " { $link POSTPONE: TYPEDEF: } "."
+"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:"
{ $table
{ "C type" "Notes" }
- { { $snippet "char" } "always 1 byte" }
- { { $snippet "uchar" } { } }
- { { $snippet "short" } "always 2 bytes" }
- { { $snippet "ushort" } { } }
- { { $snippet "int" } "always 4 bytes" }
- { { $snippet "uint" } { } }
- { { $snippet "long" } { "same size as CPU word size and " { $snippet "void*" } ", except on 64-bit Windows, where it is 4 bytes" } }
- { { $snippet "ulong" } { } }
- { { $snippet "longlong" } "always 8 bytes" }
- { { $snippet "ulonglong" } { } }
- { { $snippet "float" } { } }
- { { $snippet "double" } { "same format as " { $link float } " objects" } }
- { { $snippet "complex-float" } { "C99 " { $snippet "complex float" } " type, converted to and from " { $link complex } " values" } }
- { { $snippet "complex-double" } { "C99 " { $snippet "complex double" } " type, converted to and from " { $link complex } " values" } }
+ { { $link char } "always 1 byte" }
+ { { $link uchar } { } }
+ { { $link short } "always 2 bytes" }
+ { { $link ushort } { } }
+ { { $link int } "always 4 bytes" }
+ { { $link uint } { } }
+ { { $link long } { "same size as CPU word size and " { $link void* } ", except on 64-bit Windows, where it is 4 bytes" } }
+ { { $link ulong } { } }
+ { { $link longlong } "always 8 bytes" }
+ { { $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)" } }
+ { { $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
-"Pointer types are specified by suffixing a C type with " { $snippet "*" } ", for example " { $snippet "float*" } ". One special case is " { $snippet "void*" } ", which denotes a generic pointer; " { $snippet "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."
+"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."
$nl
"Structure and union types are specified by the name of the structure or union." ;
-
-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> }
-{ $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" } ;
-
-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 }
-"You must always free pointers returned by any of the above words when the block of memory is no longer in use:"
-{ $subsection free }
-"Utilities for automatically freeing memory in conjunction with " { $link with-destructors } ":"
-{ $subsection &free }
-{ $subsection |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 }
-"You can copy a range of bytes from memory into a byte array:"
-{ $subsection memory>byte-array }
-"You can copy a byte array to memory unsafely:"
-{ $subsection byte-array>memory } ;
-
-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" }
-"Important guidelines for passing data in byte arrays:"
-{ $subsection "byte-arrays-gc" }
-"C-style enumerated types are supported:"
-{ $subsection 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" }
-"A utility for defining " { $link "destructors" } " for deallocating memory:"
-{ $subsection "alien.destructors" }
-{ $see-also "aliens" } ;
USING: alien alien.syntax alien.c-types kernel tools.test
-sequences system libc alien.strings io.encodings.utf8 ;
+sequences system libc alien.strings io.encodings.utf8
+math.constants ;
IN: alien.c-types.tests
CONSTANT: xyz 123
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*>
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
! Copyright (C) 2004, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: byte-arrays arrays assocs kernel kernel.private libc 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 ;
+USING: byte-arrays arrays assocs kernel kernel.private math
+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
+SYMBOLS:
+ char uchar
+ short ushort
+ int uint
+ long ulong
+ longlong ulonglong
+ float double
+ void* bool
+ void ;
+
DEFER: <int>
DEFER: *char
-: little-endian? ( -- ? ) 1 <int> *char 1 = ; foldable
-
TUPLE: abstract-c-type
{ class class initial: object }
{ boxed-class class initial: object }
ERROR: no-c-type name ;
-: (c-type) ( name -- type/f )
- c-types get-global at dup [
- dup string? [ (c-type) ] when
- ] when ;
+PREDICATE: c-type-word < word
+ "c-type" word-prop ;
+
+UNION: c-type-name string c-type-word ;
! C type protocol
GENERIC: c-type ( name -- type ) foldable
-: resolve-pointer-type ( name -- name )
- c-types get at dup string?
- [ "*" append ] [ drop "void*" ] if
- c-type ;
+GENERIC: resolve-pointer-type ( name -- c-type )
+
+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 ] [
+ drop
+ c-types get at dup c-type-name?
+ [ resolve-pointer-type ] [ drop void* ] if
+ ] if ;
: resolve-typedef ( name -- type )
- dup string? [ c-type ] when ;
+ dup c-type-name? [ c-type ] when ;
-: parse-array-type ( name -- array )
+: parse-array-type ( name -- dims type )
"[" split unclip
- [ [ "]" ?tail drop string>number ] map ] dip prefix ;
+ [ [ "]" ?tail drop string>number ] map ] dip ;
M: string c-type ( name -- type )
CHAR: ] over member? [
- parse-array-type
+ parse-array-type prefix
] [
- dup c-types get at [
- resolve-typedef
- ] [
+ dup c-types get at [ ] [
"*" ?tail [ resolve-pointer-type ] [ no-c-type ] if
- ] ?if
+ ] ?if resolve-typedef
] if ;
-! These words being foldable means that words need to be
-! recompiled if a C type is redefined. Even so, folding the
-! size facilitates some optimizations.
-GENERIC: heap-size ( type -- size ) foldable
-
-M: string heap-size c-type heap-size ;
-
-M: abstract-c-type heap-size size>> ;
-
-GENERIC: require-c-array ( c-type -- )
+M: word c-type
+ "c-type" word-prop resolve-typedef ;
-M: array require-c-array first require-c-array ;
+: void? ( c-type -- ? )
+ { void "void" } member? ;
-GENERIC: c-array-constructor ( c-type -- word )
+GENERIC: c-struct? ( type -- ? )
-GENERIC: c-(array)-constructor ( c-type -- word )
-
-GENERIC: c-direct-array-constructor ( c-type -- word )
-
-GENERIC: <c-array> ( len c-type -- array )
-
-M: string <c-array>
- c-array-constructor execute( len -- array ) ; inline
-
-GENERIC: (c-array) ( len c-type -- array )
-
-M: string (c-array)
- c-(array)-constructor execute( len -- array ) ; inline
-
-GENERIC: <c-direct-array> ( alien len c-type -- array )
-
-M: string <c-direct-array>
- c-direct-array-constructor execute( alien len -- array ) ; inline
-
-: malloc-array ( n type -- alien )
- [ heap-size calloc ] [ <c-direct-array> ] 2bi ; inline
-
-: (malloc-array) ( n type -- alien )
- [ heap-size * malloc ] [ <c-direct-array> ] 2bi ; inline
+M: object c-struct?
+ drop f ;
+M: c-type-name c-struct?
+ dup void? [ drop f ] [ c-type c-struct? ] if ;
+! These words being foldable means that words need to be
+! recompiled if a C type is redefined. Even so, folding the
+! size facilitates some optimizations.
GENERIC: c-type-class ( name -- class )
M: abstract-c-type c-type-class class>> ;
-M: string c-type-class c-type c-type-class ;
+M: c-type-name c-type-class c-type c-type-class ;
GENERIC: c-type-boxed-class ( name -- class )
M: abstract-c-type c-type-boxed-class boxed-class>> ;
-M: string c-type-boxed-class c-type c-type-boxed-class ;
+M: c-type-name c-type-boxed-class c-type c-type-boxed-class ;
GENERIC: c-type-boxer ( name -- boxer )
M: c-type c-type-boxer boxer>> ;
-M: string c-type-boxer c-type c-type-boxer ;
+M: c-type-name c-type-boxer c-type c-type-boxer ;
GENERIC: c-type-boxer-quot ( name -- quot )
M: abstract-c-type c-type-boxer-quot boxer-quot>> ;
-M: string c-type-boxer-quot c-type c-type-boxer-quot ;
+M: c-type-name c-type-boxer-quot c-type c-type-boxer-quot ;
GENERIC: c-type-unboxer ( name -- boxer )
M: c-type c-type-unboxer unboxer>> ;
-M: string c-type-unboxer c-type c-type-unboxer ;
+M: c-type-name c-type-unboxer c-type c-type-unboxer ;
GENERIC: c-type-unboxer-quot ( name -- quot )
M: abstract-c-type c-type-unboxer-quot unboxer-quot>> ;
-M: string c-type-unboxer-quot c-type c-type-unboxer-quot ;
+M: c-type-name c-type-unboxer-quot c-type c-type-unboxer-quot ;
GENERIC: c-type-rep ( name -- rep )
M: c-type c-type-rep rep>> ;
-M: string c-type-rep c-type c-type-rep ;
+M: c-type-name c-type-rep c-type c-type-rep ;
GENERIC: c-type-getter ( name -- quot )
M: c-type c-type-getter getter>> ;
-M: string c-type-getter c-type c-type-getter ;
+M: c-type-name c-type-getter c-type c-type-getter ;
GENERIC: c-type-setter ( name -- quot )
M: c-type c-type-setter setter>> ;
-M: string c-type-setter c-type c-type-setter ;
+M: c-type-name c-type-setter c-type c-type-setter ;
GENERIC: c-type-align ( name -- n )
M: abstract-c-type c-type-align align>> ;
-M: string c-type-align c-type c-type-align ;
+M: c-type-name c-type-align c-type c-type-align ;
GENERIC: c-type-stack-align? ( name -- ? )
M: c-type c-type-stack-align? stack-align?>> ;
-M: string c-type-stack-align? c-type c-type-stack-align? ;
+M: c-type-name c-type-stack-align? c-type c-type-stack-align? ;
: c-type-box ( n type -- )
[ c-type-rep ] [ c-type-boxer [ "No boxer" throw ] unless* ] bi
M: c-type box-parameter c-type-box ;
-M: string box-parameter c-type box-parameter ;
+M: c-type-name box-parameter c-type box-parameter ;
GENERIC: box-return ( ctype -- )
M: c-type box-return f swap c-type-box ;
-M: string box-return c-type box-return ;
+M: c-type-name box-return c-type box-return ;
GENERIC: unbox-parameter ( n ctype -- )
M: c-type unbox-parameter c-type-unbox ;
-M: string unbox-parameter c-type unbox-parameter ;
+M: c-type-name unbox-parameter c-type unbox-parameter ;
GENERIC: unbox-return ( ctype -- )
M: c-type unbox-return f swap c-type-unbox ;
-M: string unbox-return c-type unbox-return ;
+M: c-type-name unbox-return c-type unbox-return ;
+
+: little-endian? ( -- ? ) 1 <int> *char 1 = ; foldable
+
+GENERIC: heap-size ( type -- 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
-M: string stack-size c-type stack-size ;
+M: c-type-name stack-size c-type stack-size ;
M: c-type stack-size size>> cell align ;
M: f byte-length drop 0 ; inline
+MIXIN: value-type
+
: c-getter ( name -- quot )
c-type-getter [
[ "Cannot read struct fields with this type" throw ]
[ "Cannot write struct fields with this type" throw ]
] unless* ;
-: <c-object> ( type -- array )
- heap-size <byte-array> ; inline
-
-: (c-object) ( type -- array )
- heap-size (byte-array) ; inline
-
-: malloc-object ( type -- alien )
- 1 swap heap-size calloc ; inline
-
-: (malloc-object) ( type -- alien )
- heap-size malloc ; inline
-
-: malloc-byte-array ( byte-array -- alien )
- dup byte-length [ nip malloc dup ] 2keep memcpy ;
-
-: memory>byte-array ( alien len -- byte-array )
- [ nip (byte-array) dup ] 2keep memcpy ;
-
-: malloc-string ( string encoding -- alien )
- string>alien malloc-byte-array ;
-
-M: memory-stream stream-read
- [
- [ index>> ] [ alien>> ] bi <displaced-alien>
- swap memory>byte-array
- ] [ [ + ] change-index drop ] 2bi ;
-
-: byte-array>memory ( byte-array base -- )
- swap dup byte-length memcpy ; inline
-
: array-accessor ( type quot -- def )
[
\ swap , [ heap-size , [ * >fixnum ] % ] [ % ] bi*
] [ ] make ;
-: typedef ( old new -- ) c-types get set-at ;
+GENERIC: typedef ( old new -- )
+
+PREDICATE: typedef-word < c-type-word
+ "c-type" word-prop c-type-name? ;
+
+M: string typedef ( old new -- ) c-types get set-at ;
+M: word typedef ( old new -- )
+ {
+ [ nip define-symbol ]
+ [ name>> typedef ]
+ [ swap "c-type" set-word-prop ]
+ [
+ swap dup c-type-name? [
+ resolve-pointer-type
+ "pointer-c-type" set-word-prop
+ ] [ 2drop ] if
+ ]
+ } 2cleave ;
TUPLE: long-long-type < c-type ;
: define-out ( name -- )
[ "alien.c-types" constructor-word ]
- [ dup c-setter '[ _ <c-object> [ 0 @ ] keep ] ] bi
+ [ dup c-setter '[ _ heap-size <byte-array> [ 0 @ ] keep ] ] bi
(( value -- c-ptr )) define-inline ;
-: >c-bool ( ? -- int ) 1 0 ? ; inline
-
-: c-bool> ( int -- ? ) 0 = not ; inline
-
: define-primitive-type ( type name -- )
[ typedef ]
- [ define-deref ]
- [ define-out ]
+ [ name>> define-deref ]
+ [ name>> define-out ]
tri ;
-: malloc-file-contents ( path -- alien len )
- binary file-contents [ malloc-byte-array ] [ length ] bi ;
-
: if-void ( type true false -- )
- pick "void" = [ drop nip call ] [ nip call ] if ; inline
+ pick void? [ drop nip call ] [ nip call ] if ; inline
CONSTANT: primitive-types
{
- "char" "uchar"
- "short" "ushort"
- "int" "uint"
- "long" "ulong"
- "longlong" "ulonglong"
- "float" "double"
- "void*" "bool"
+ char uchar
+ short ushort
+ int uint
+ long ulong
+ longlong ulonglong
+ float double
+ void* bool
}
+SYMBOLS:
+ ptrdiff_t intptr_t size_t
+ char* uchar* ;
+
[
<c-type>
c-ptr >>class
[ >c-ptr ] >>unboxer-quot
"box_alien" >>boxer
"alien_offset" >>unboxer
- "void*" define-primitive-type
+ \ void* define-primitive-type
<long-long-type>
integer >>class
8 >>align
"box_signed_8" >>boxer
"to_signed_8" >>unboxer
- "longlong" define-primitive-type
+ \ longlong define-primitive-type
<long-long-type>
integer >>class
8 >>align
"box_unsigned_8" >>boxer
"to_unsigned_8" >>unboxer
- "ulonglong" define-primitive-type
+ \ ulonglong define-primitive-type
<c-type>
integer >>class
bootstrap-cell >>align
"box_signed_cell" >>boxer
"to_fixnum" >>unboxer
- "long" define-primitive-type
+ \ long define-primitive-type
<c-type>
integer >>class
bootstrap-cell >>align
"box_unsigned_cell" >>boxer
"to_cell" >>unboxer
- "ulong" define-primitive-type
+ \ ulong define-primitive-type
<c-type>
integer >>class
4 >>align
"box_signed_4" >>boxer
"to_fixnum" >>unboxer
- "int" define-primitive-type
+ \ int define-primitive-type
<c-type>
integer >>class
4 >>align
"box_unsigned_4" >>boxer
"to_cell" >>unboxer
- "uint" define-primitive-type
+ \ uint define-primitive-type
<c-type>
fixnum >>class
2 >>align
"box_signed_2" >>boxer
"to_fixnum" >>unboxer
- "short" define-primitive-type
+ \ short define-primitive-type
<c-type>
fixnum >>class
2 >>align
"box_unsigned_2" >>boxer
"to_cell" >>unboxer
- "ushort" define-primitive-type
+ \ ushort define-primitive-type
<c-type>
fixnum >>class
1 >>align
"box_signed_1" >>boxer
"to_fixnum" >>unboxer
- "char" define-primitive-type
+ \ char define-primitive-type
<c-type>
fixnum >>class
1 >>align
"box_unsigned_1" >>boxer
"to_cell" >>unboxer
- "uchar" define-primitive-type
+ \ uchar define-primitive-type
<c-type>
- [ alien-unsigned-1 c-bool> ] >>getter
- [ [ >c-bool ] 2dip set-alien-unsigned-1 ] >>setter
+ [ alien-unsigned-1 0 = not ] >>getter
+ [ [ 1 0 ? ] 2dip set-alien-unsigned-1 ] >>setter
1 >>size
1 >>align
"box_boolean" >>boxer
"to_boolean" >>unboxer
- "bool" define-primitive-type
+ \ bool define-primitive-type
<c-type>
- float >>class
- float >>boxed-class
+ math:float >>class
+ math:float >>boxed-class
[ alien-float ] >>getter
[ [ >float ] 2dip set-alien-float ] >>setter
4 >>size
"to_float" >>unboxer
float-rep >>rep
[ >float ] >>unboxer-quot
- "float" define-primitive-type
+ \ float define-primitive-type
<c-type>
- float >>class
- float >>boxed-class
+ math:float >>class
+ math:float >>boxed-class
[ alien-double ] >>getter
[ [ >float ] 2dip set-alien-double ] >>setter
8 >>size
"to_double" >>unboxer
double-rep >>rep
[ >float ] >>unboxer-quot
- "double" define-primitive-type
+ \ double define-primitive-type
- "long" "ptrdiff_t" typedef
- "long" "intptr_t" typedef
- "ulong" "size_t" typedef
+ \ long \ ptrdiff_t typedef
+ \ long \ intptr_t typedef
+ \ ulong \ 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
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.c-types alien.structs alien.complex.functor accessors
+USING: alien.c-types alien.complex.functor accessors
sequences kernel ;
IN: alien.complex
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien alien.structs alien.c-types classes.struct math
+USING: accessors alien alien.c-types classes.struct math
math.functions sequences arrays kernel functors vocabs.parser
namespaces quotations ;
IN: alien.complex.functor
--- /dev/null
+Slava Pestov
--- /dev/null
+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 ;
+IN: alien.data
+
+HELP: <c-array>
+{ $values { "len" "a non-negative integer" } { "c-type" "a C type" } { "array" byte-array } }
+{ $description "Creates a byte array large enough to hold " { $snippet "n" } " values of a C type." }
+{ $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." }
+{ $errors "Throws an error if the type does not exist, the necessary specialized array vocabulary is not loaded, or the requested size is negative." } ;
+
+HELP: <c-object>
+{ $values { "type" "a C type" } { "array" byte-array } }
+{ $description "Creates a byte array suitable for holding a value with the given C type." }
+{ $errors "Throws an " { $link no-c-type } " error if the type does not exist." } ;
+
+{ <c-object> malloc-object } related-words
+
+HELP: memory>byte-array
+{ $values { "alien" c-ptr } { "len" "a non-negative integer" } { "byte-array" byte-array } }
+{ $description "Reads " { $snippet "len" } " bytes starting from " { $snippet "base" } " and stores them in a new byte array." } ;
+
+HELP: byte-array>memory
+{ $values { "byte-array" byte-array } { "base" c-ptr } }
+{ $description "Writes a byte array to memory starting from the " { $snippet "base" } " address." }
+{ $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 } }
+{ $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 } "." }
+{ $errors "Throws an error if the type does not exist, if the requested size is negative, if a direct specialized array class appropriate to the type is not loaded, or if memory allocation fails." } ;
+
+HELP: malloc-object
+{ $values { "type" "a C type" } { "alien" alien } }
+{ $description "Allocates an unmanaged memory block large enough to hold a value of a C type." }
+{ $warning "Don't forget to deallocate the memory with a call to " { $link free } "." }
+{ $errors "Throws an error if the type does not exist or if memory allocation fails." } ;
+
+HELP: malloc-byte-array
+{ $values { "byte-array" byte-array } { "alien" alien } }
+{ $description "Allocates an unmanaged memory block of the same size as the byte array, and copies the contents of the byte array there." }
+{ $warning "Don't forget to deallocate the memory with a call to " { $link free } "." }
+{ $errors "Throws an error if memory allocation fails." } ;
+
+{ <c-array> <c-direct-array> malloc-array } related-words
+
+{ string>alien alien>string malloc-string } related-words
+
+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 }
+"You must always free pointers returned by any of the above words when the block of memory is no longer in use:"
+{ $subsection free }
+"Utilities for automatically freeing memory in conjunction with " { $link with-destructors } ":"
+{ $subsection &free }
+{ $subsection |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 }
+"You can copy a range of bytes from memory into a byte array:"
+{ $subsection memory>byte-array }
+"You can copy a byte array to memory unsafely:"
+{ $subsection 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> }
+{ $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" } ;
+
+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" }
+"Important guidelines for passing data in byte arrays:"
+{ $subsection "byte-arrays-gc" }
+"C-style enumerated types are supported:"
+{ $subsection 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" }
+"A utility for defining " { $link "destructors" } " for deallocating memory:"
+{ $subsection "alien.destructors" }
+{ $see-also "aliens" } ;
+HELP: malloc-string
+{ $values { "string" string } { "encoding" "an encoding descriptor" } { "alien" c-ptr } }
+{ $description "Encodes a string together with a trailing null code point using the given encoding, and stores the resulting bytes in a freshly-allocated unmanaged memory block." }
+{ $warning "Don't forget to deallocate the memory with a call to " { $link free } "." }
+{ $errors "Throws an error if one of the following conditions occurs:"
+ { $list
+ "the string contains null code points"
+ "the string contains characters not representable using the encoding specified"
+ "memory allocation fails"
+ }
+} ;
+
+HELP: require-c-array
+{ $values { "c-type" "a C type" } }
+{ $description "Generates a specialized array of " { $snippet "c-type" } " using the " { $link <c-array> } " or " { $link <c-direct-array> } " vocabularies." }
+{ $notes "This word must be called inside a compilation unit. See the " { $vocab-link "specialized-arrays" } " vocabulary for details on the underlying sequence types loaded." } ;
+
+HELP: <c-direct-array>
+{ $values { "alien" c-ptr } { "len" integer } { "c-type" "a C type" } { "array" "a specialized direct array" } }
+{ $description "Constructs a new specialized array of length " { $snippet "len" } " and element type " { $snippet "c-type" } " over the range of memory referenced by " { $snippet "alien" } "." }
+{ $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." } ;
+
+ARTICLE: "c-strings" "C strings"
+"C string types are arrays with shape " { $snippet "{ char* encoding }" } ", where " { $snippet "encoding" } " is an encoding descriptor. The type " { $link char* } " is an alias for " { $snippet "{ char* utf8 }" } ". See " { $link "encodings-descriptors" } " for information about encoding descriptors."
+$nl
+"Passing a Factor string to a C function expecting a C string allocates a " { $link byte-array } " in the Factor heap; the string is then converted to the requested format and a raw pointer is passed to the function."
+$nl
+"If the conversion fails, for example if the string contains null bytes or characters with values higher than 255, a " { $link c-string-error. } " is thrown."
+$nl
+"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 }
+"The first allocates " { $link byte-array } "s, and the latter allocates manually-managed memory which is not moved by the garbage collector and has to be explicitly freed by calling " { $link free } ". See " { $link "byte-arrays-gc" } " for a discussion of the two approaches."
+$nl
+"A word to read strings from arbitrary addresses:"
+{ $subsection alien>string }
+"For example, if a C function returns a " { $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 } "." ;
+
--- /dev/null
+! (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 ;
+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 )
+
+GENERIC: c-direct-array-constructor ( c-type -- word )
+
+GENERIC: <c-array> ( len c-type -- array )
+
+M: c-type-name <c-array>
+ c-array-constructor execute( len -- array ) ; inline
+
+GENERIC: (c-array) ( len c-type -- array )
+
+M: c-type-name (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>
+ c-direct-array-constructor execute( alien len -- array ) ; inline
+
+: malloc-array ( n type -- alien )
+ [ heap-size calloc ] [ <c-direct-array> ] 2bi ; inline
+
+: (malloc-array) ( n type -- alien )
+ [ heap-size * malloc ] [ <c-direct-array> ] 2bi ; inline
+
+: <c-object> ( type -- array )
+ heap-size <byte-array> ; inline
+
+: (c-object) ( type -- array )
+ heap-size (byte-array) ; inline
+
+: malloc-object ( type -- alien )
+ 1 swap heap-size calloc ; inline
+
+: (malloc-object) ( type -- alien )
+ heap-size malloc ; inline
+
+: malloc-byte-array ( byte-array -- alien )
+ dup byte-length [ nip malloc dup ] 2keep memcpy ;
+
+: memory>byte-array ( alien len -- byte-array )
+ [ nip (byte-array) dup ] 2keep memcpy ;
+
+: 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>
+ swap memory>byte-array
+ ] [ [ + ] change-index drop ] 2bi ;
+
+: byte-array>memory ( byte-array base -- )
+ swap dup byte-length memcpy ; inline
+
+: >c-bool ( ? -- int ) 1 0 ? ; inline
+
+: c-bool> ( int -- ? ) 0 = not ; inline
+
+M: value-type c-type-rep drop int-rep ;
+
+M: value-type c-type-getter
+ drop [ swap <displaced-alien> ] ;
+
+M: value-type c-type-setter ( type -- quot )
+ [ c-type-getter ] [ c-type-unboxer-quot ] [ heap-size ] tri
+ '[ @ swap @ _ memcpy ] ;
+
--- /dev/null
+Words for allocating objects and arrays of C types
! Copyright (C) 2009 Joe Groff
! See http://factorcode.org/license.txt for BSD license.
-USING: help.markup help.syntax kernel quotations sequences strings words.symbol ;
+USING: help.markup help.syntax kernel quotations sequences strings words.symbol classes.struct ;
QUALIFIED-WITH: alien.syntax c
IN: alien.fortran
{ { $snippet "DOUBLE-COMPLEX" } " specifies a double-precision floating-point complex value. The alias " { $snippet "COMPLEX*16" } " is also recognized." }
{ { $snippet "CHARACTER(n)" } " specifies a character string of length " { $snippet "n" } ". The Fortran 77 syntax " { $snippet "CHARACTER*n" } " is also recognized." }
{ "Fortran arrays can be specified by suffixing a comma-separated set of dimensions in parentheses, e.g. " { $snippet "REAL(2,3,4)" } ". Arrays of unspecified length can be specified using " { $snippet "*" } " as a dimension. Arrays are passed in as flat " { $link "specialized-arrays" } "." }
- { "Fortran records defined by " { $link POSTPONE: RECORD: } " and C structs defined by " { $link POSTPONE: c:C-STRUCT: } " are also supported as parameter and return types." }
+ { "Struct classes defined by " { $link POSTPONE: STRUCT: } " are also supported as parameter and return types." }
}
"When declaring the parameters of Fortran functions, an output argument can be specified by prefixing an exclamation point to the type name. This will cause the function word to leave the final value of the parameter on the stack." ;
{ $values { "name" "a logical library name" } }
{ $description "Sets the logical library for subsequent " { $link POSTPONE: FUNCTION: } " and " { $link POSTPONE: SUBROUTINE: } " definitions. The given library name must have been opened with a previous call to " { $link add-fortran-library } "." } ;
-HELP: RECORD:
-{ $syntax "RECORD: NAME { \"TYPE\" \"SLOT\" } ... ;" }
-{ $description "Defines a Fortran record type with the given slots. The record is defined as the corresponding C struct and can be used as a type for subsequent Fortran or C function declarations." } ;
-
HELP: add-fortran-library
{ $values { "name" string } { "soname" string } { "fortran-abi" symbol } }
{ $description "Opens the shared library in the file specified by " { $snippet "soname" } " under the logical name " { $snippet "name" } " so that it may be used in subsequent " { $link POSTPONE: LIBRARY: } " and " { $link fortran-invoke } " calls. Functions and subroutines from the library will be defined using the specified " { $snippet "fortran-abi" } ", which must be one of the supported " { $link "alien.fortran-abis" } "." }
{ $subsection POSTPONE: LIBRARY: }
{ $subsection POSTPONE: FUNCTION: }
{ $subsection POSTPONE: SUBROUTINE: }
-{ $subsection POSTPONE: RECORD: }
{ $subsection fortran-invoke }
;
! (c) 2009 Joe Groff, see BSD license
USING: accessors alien alien.c-types alien.complex
-alien.fortran alien.fortran.private alien.strings alien.structs
-arrays assocs byte-arrays combinators fry
+alien.data alien.fortran alien.fortran.private alien.strings
+classes.struct arrays assocs byte-arrays combinators fry
generalizations io.encodings.ascii kernel macros
macros.expander namespaces sequences shuffle tools.test ;
IN: alien.fortran.tests
<< intel-unix-abi "(alien.fortran-tests)" (add-fortran-library) >>
LIBRARY: (alien.fortran-tests)
-RECORD: FORTRAN_TEST_RECORD
- { "INTEGER" "FOO" }
- { "REAL(2)" "BAR" }
- { "CHARACTER*4" "BAS" } ;
+STRUCT: FORTRAN_TEST_RECORD
+ { FOO int }
+ { BAR double[2] }
+ { BAS char[4] } ;
intel-unix-abi fortran-abi [
[ "complex" { "character*17" "character" "integer" } fortran-sig>c-sig ]
unit-test
- ! fortran-record>c-struct
-
- [ {
- { "double" "ex" }
- { "float" "wye" }
- { "int" "zee" }
- { "char[20]" "woo" }
- } ] [
- {
- { "DOUBLE-PRECISION" "EX" }
- { "REAL" "WYE" }
- { "INTEGER" "ZEE" }
- { "CHARACTER(20)" "WOO" }
- } fortran-record>c-struct
- ] unit-test
-
- ! RECORD:
-
- [ 16 ] [ "fortran_test_record" heap-size ] unit-test
- [ 0 ] [ "foo" "fortran_test_record" offset-of ] unit-test
- [ 4 ] [ "bar" "fortran_test_record" offset-of ] unit-test
- [ 12 ] [ "bas" "fortran_test_record" offset-of ] unit-test
-
! (fortran-invoke)
[ [
! (c) 2009 Joe Groff, see BSD license
-USING: accessors alien alien.c-types alien.complex alien.parser
-alien.strings alien.structs alien.syntax arrays ascii assocs
+USING: accessors alien alien.c-types alien.complex alien.data grouping
+alien.strings alien.syntax arrays ascii assocs
byte-arrays combinators combinators.short-circuit fry generalizations
kernel lexer macros math math.parser namespaces parser sequences
splitting stack-checker vectors vocabs.parser words locals
: fortran-sig>c-sig ( fortran-return fortran-args -- c-return c-args )
[ fortran-ret-type>c-type ] [ fortran-arg-types>c-types ] bi* append ;
-: fortran-record>c-struct ( record -- struct )
- [ first2 [ fortran-type>c-type ] [ >lower ] bi* 2array ] map ;
-
-: define-fortran-record ( name vocab fields -- )
- [ >lower ] [ ] [ fortran-record>c-struct ] tri* define-struct ;
-
-SYNTAX: RECORD: scan current-vocab parse-definition define-fortran-record ;
-
: set-fortran-abi ( library -- )
library-fortran-abis get-global at fortran-abi set ;
MACRO: fortran-invoke ( return library function parameters -- )
{ [ 2drop nip set-fortran-abi ] [ (fortran-invoke) ] } 4 ncleave ;
+: parse-arglist ( parameters return -- types effect )
+ [ 2 group unzip [ "," ?tail drop ] map ]
+ [ [ { } ] [ 1array ] if-void ]
+ bi* <effect> ;
+
:: define-fortran-function ( return library function parameters -- )
function create-in dup reset-generic
return library function parameters return [ "void" ] unless* parse-arglist
! Copyright (C) 2008, 2009 Slava Pestov, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.c-types arrays assocs effects grouping kernel
-parser sequences splitting words fry locals lexer namespaces
-summary math ;
+USING: accessors alien alien.c-types arrays assocs
+combinators combinators.short-circuit 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 ( string -- array )
+ {
+ { [ 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 ] [ parse-c-type-name resolve-pointer-type ] }
+ [ no-c-type ]
+ } cond ;
+
+: scan-c-type ( -- c-type )
+ scan dup "{" =
+ [ drop \ } parse-until >array ]
+ [ parse-c-type ] if ;
+
+: reset-c-type ( word -- )
+ { "c-type" "pointer-c-type" "callback-effect" "callback-abi" } reset-props ;
+
+: CREATE-C-TYPE ( -- word )
+ scan current-vocab create dup reset-c-type ;
+
: normalize-c-arg ( type name -- type' name' )
[ length ]
[
[ CHAR: * = ] trim-head
[ length - CHAR: * <array> append ] keep
- ] bi ;
+ ] bi
+ [ parse-c-type ] dip ;
: parse-arglist ( parameters return -- types effect )
[
return library function
parameters return parse-arglist [ function-quot ] dip ;
+: parse-arg-tokens ( -- tokens )
+ ";" parse-tokens [ "()" subseq? not ] filter ;
+
: (FUNCTION:) ( -- word quot effect )
- scan "c-library" get scan ";" parse-tokens
- [ "()" subseq? not ] filter
- make-function ;
+ scan "c-library" get scan parse-arg-tokens make-function ;
: define-function ( return library function parameters -- )
make-function define-declared ;
+
+: callback-quot ( return types abi -- quot )
+ [ [ ] 3curry dip alien-callback ] 3curry ;
+
+:: make-callback-type ( abi 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 )) ;
+
+: (CALLBACK:) ( abi -- word quot effect )
+ scan scan parse-arg-tokens make-callback-type ;
+
+PREDICATE: alien-function-word < word
+ def>> {
+ [ length 5 = ]
+ [ last \ alien-invoke eq? ]
+ } 1&& ;
+
+PREDICATE: alien-callback-type-word < typedef-word
+ "callback-effect" word-prop ;
+
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel combinators alien alien.strings alien.syntax
-math.parser prettyprint.backend prettyprint.custom
-prettyprint.sections ;
+USING: accessors kernel combinators alien alien.strings alien.c-types
+alien.parser alien.syntax arrays assocs effects math.parser
+prettyprint.backend prettyprint.custom prettyprint.sections
+definitions see see.private sequences strings words ;
IN: alien.prettyprint
M: alien pprint*
} cond ;
M: dll pprint* dll-path dup "DLL\" " "\"" pprint-string ;
+
+M: c-type-word definer drop \ C-TYPE: f ;
+M: c-type-word definition drop f ;
+M: c-type-word declarations. drop ;
+
+GENERIC: pprint-c-type ( c-type -- )
+M: word pprint-c-type pprint-word ;
+M: wrapper pprint-c-type wrapped>> pprint-word ;
+M: string pprint-c-type text ;
+M: array pprint-c-type pprint* ;
+
+M: typedef-word definer drop \ TYPEDEF: f ;
+
+M: typedef-word synopsis*
+ {
+ [ seeing-word ]
+ [ definer. ]
+ [ "c-type" word-prop pprint-c-type ]
+ [ pprint-word ]
+ } cleave ;
+
+: pprint-function-arg ( type name -- )
+ [ pprint-c-type ] [ text ] bi* ;
+
+: pprint-function-args ( types names -- )
+ zip [ ] [
+ unclip-last
+ [ [ first2 "," append pprint-function-arg ] each ] dip
+ first2 pprint-function-arg
+ ] if-empty ;
+
+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* ]
+ [ definer. ]
+ [ def>> first pprint-c-type ]
+ [ pprint-word ]
+ [
+ <block "(" text
+ [ def>> fourth ] [ stack-effect in>> ] bi
+ pprint-function-args
+ ")" text block>
+ ]
+ } cleave ;
+
+M: alien-callback-type-word definer
+ "callback-abi" word-prop "stdcall" =
+ \ STDCALL-CALLBACK: \ CALLBACK: ?
+ f ;
+M: alien-callback-type-word definition drop f ;
+M: alien-callback-type-word synopsis*
+ {
+ [ seeing-word ]
+ [ definer. ]
+ [ def>> first pprint-c-type ]
+ [ pprint-word ]
+ [
+ <block "(" text
+ [ def>> second ] [ "callback-effect" word-prop in>> ] bi
+ pprint-function-args
+ ")" text block>
+ ]
+ } cleave ;
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien alien.c-types alien.strings parser
+USING: accessors alien alien.data alien.strings parser
threads words kernel.private kernel io.encodings.utf8 eval ;
IN: alien.remote-control
-USING: alien.c-types strings help.markup help.syntax alien.syntax
+USING: alien.c-types alien.data strings help.markup help.syntax alien.syntax
sequences io arrays kernel words assocs namespaces ;
IN: alien.structs
-USING: alien alien.syntax alien.c-types kernel tools.test
+USING: alien alien.syntax alien.c-types alien.data kernel tools.test
sequences system libc words vocabs namespaces layouts ;
IN: alien.structs.tests
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
+ [ dup value-struct? ] 2dip '[ drop void* @ ] if ; inline
M: struct-type unbox-parameter
[ %unbox-large-struct ] [ unbox-parameter ] if-value-struct ;
M: struct-type stack-size
[ heap-size ] [ stack-size ] if-value-struct ;
-: c-struct? ( type -- ? ) (c-type) struct-type? ;
+M: struct-type c-struct? drop t ;
: (define-struct) ( name size align fields class -- )
[ [ align ] keep ] 2dip new
{ $syntax "C-ENUM: words... ;" }
{ $values { "words" "a sequence of word names" } }
{ $description "Creates a sequence of word definitions in the current vocabulary. Each word pushes an integer according to its index in the enumeration definition. The first word pushes 0." }
-{ $notes "This word emulates a C-style " { $snippet "enum" } " in Factor. While this feature can be used for any purpose, using integer constants is discouraged unless it is for interfacing with C libraries. Factor code should use symbolic constants instead." }
+{ $notes "This word emulates a C-style " { $snippet "enum" } " in Factor. While this feature can be used for any purpose, using integer constants is discouraged unless it is for interfacing with C libraries. Factor code should use " { $link "words.symbol" } " or " { $link "singletons" } " instead." }
{ $examples
- "The following two lines are equivalent:"
- { $code "C-ENUM: red green blue ;" ": red 0 ; : green 1 ; : blue 2 ;" }
+ "Here is an example enumeration definition:"
+ { $code "C-ENUM: red green blue ;" }
+ "It is equivalent to the following series of definitions:"
+ { $code "CONSTANT: red 0" "CONSTANT: green 1" "CONSTANT: blue 2" }
} ;
+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." }
+{ $examples
+ { $code
+ "CALLBACK: bool FakeCallback ( int message, void* payload ) ;"
+ ": MyFakeCallback ( -- alien )"
+ " [| message payload |"
+ " \"message #\" write"
+ " message number>string write"
+ " \" received\" write nl"
+ " t"
+ " ] FakeCallback ;"
+ }
+} ;
+
+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" } }
HELP: typedef
{ $values { "old" "a string" } { "new" "a string" } }
-{ $description "Alises the C type " { $snippet "old" } " under the name " { $snippet "new" } "." }
+{ $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
SYNTAX: FUNCTION:
(FUNCTION:) define-declared ;
+SYNTAX: CALLBACK:
+ "cdecl" (CALLBACK:) define-inline ;
+
+SYNTAX: STDCALL-CALLBACK:
+ "stdcall" (CALLBACK:) define-inline ;
+
SYNTAX: TYPEDEF:
- scan scan typedef ;
+ scan-c-type CREATE-C-TYPE typedef ;
SYNTAX: C-STRUCT:
scan current-vocab parse-definition define-struct ; deprecated
";" parse-tokens
[ [ create-in ] dip define-constant ] each-index ;
+SYNTAX: C-TYPE:
+ "Primitive C type definition not supported" throw ;
+
ERROR: no-such-symbol name library ;
: address-of ( name library -- value )
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.c-types accessors math alien.accessors kernel
+USING: alien.c-types alien.data accessors math alien.accessors kernel
kernel.private sequences sequences.private byte-arrays
parser prettyprint.custom fry ;
IN: bit-arrays
USING: system combinators alien alien.syntax alien.c-types
alien.destructors kernel accessors sequences arrays ui.gadgets
-alien.libraries ;
+alien.libraries classes.struct ;
IN: cairo.ffi
<< {
TYPEDEF: void* cairo_t
TYPEDEF: void* cairo_surface_t
-C-STRUCT: cairo_matrix_t
- { "double" "xx" }
- { "double" "yx" }
- { "double" "xy" }
- { "double" "yy" }
- { "double" "x0" }
- { "double" "y0" } ;
+STRUCT: cairo_matrix_t
+ { xx double }
+ { yx double }
+ { xy double }
+ { yy double }
+ { x0 double }
+ { y0 double } ;
TYPEDEF: void* cairo_pattern_t
TYPEDEF: void* cairo_destroy_func_t
: cairo-destroy-func ( quot -- callback )
- [ "void" { "void*" } "cdecl" ] dip alien-callback ; inline
+ [ void { void* } "cdecl" ] dip alien-callback ; inline
! See cairo.h for details
-C-STRUCT: cairo_user_data_key_t
- { "int" "unused" } ;
+STRUCT: cairo_user_data_key_t
+ { unused int } ;
TYPEDEF: int cairo_status_t
C-ENUM:
TYPEDEF: void* cairo_write_func_t
: cairo-write-func ( quot -- callback )
- [ "cairo_status_t" { "void*" "uchar*" "int" } "cdecl" ] dip alien-callback ; inline
+ [ cairo_status_t { void* uchar* int } "cdecl" ] dip alien-callback ; inline
TYPEDEF: void* cairo_read_func_t
: cairo-read-func ( quot -- callback )
- [ "cairo_status_t" { "void*" "uchar*" "int" } "cdecl" ] dip alien-callback ; inline
+ [ cairo_status_t { void* uchar* int } "cdecl" ] dip alien-callback ; inline
! Functions for manipulating state objects
FUNCTION: cairo_t*
FUNCTION: void
cairo_clip_extents ( cairo_t* cr, double* x1, double* y1, double* x2, double* y2 ) ;
-C-STRUCT: cairo_rectangle_t
- { "double" "x" }
- { "double" "y" }
- { "double" "width" }
- { "double" "height" } ;
+STRUCT: cairo_rectangle_t
+ { x double }
+ { y double }
+ { width double }
+ { height double } ;
-C-STRUCT: cairo_rectangle_list_t
- { "cairo_status_t" "status" }
- { "cairo_rectangle_t*" "rectangles" }
- { "int" "num_rectangles" } ;
+STRUCT: cairo_rectangle_list_t
+ { status cairo_status_t }
+ { rectangles cairo_rectangle_t* }
+ { num_rectangles int } ;
FUNCTION: cairo_rectangle_list_t*
cairo_copy_clip_rectangle_list ( cairo_t* cr ) ;
TYPEDEF: void* cairo_font_face_t
-C-STRUCT: cairo_glyph_t
- { "ulong" "index" }
- { "double" "x" }
- { "double" "y" } ;
-
-C-STRUCT: cairo_text_extents_t
- { "double" "x_bearing" }
- { "double" "y_bearing" }
- { "double" "width" }
- { "double" "height" }
- { "double" "x_advance" }
- { "double" "y_advance" } ;
-
-C-STRUCT: cairo_font_extents_t
- { "double" "ascent" }
- { "double" "descent" }
- { "double" "height" }
- { "double" "max_x_advance" }
- { "double" "max_y_advance" } ;
+STRUCT: cairo_glyph_t
+ { index ulong }
+ { x double }
+ { y double } ;
+
+STRUCT: cairo_text_extents_t
+ { x_bearing double }
+ { y_bearing double }
+ { width double }
+ { height double }
+ { x_advance double }
+ { y_advance double } ;
+
+STRUCT: cairo_font_extents_t
+ { ascent double }
+ { descent double }
+ { height double }
+ { max_x_advance double }
+ { max_y_advance double } ;
TYPEDEF: int cairo_font_slant_t
C-ENUM:
CAIRO_PATH_CLOSE_PATH ;
! NEED TO DO UNION HERE
-C-STRUCT: cairo_path_data_t-point
- { "double" "x" }
- { "double" "y" } ;
-
-C-STRUCT: cairo_path_data_t-header
- { "cairo_path_data_type_t" "type" }
- { "int" "length" } ;
-
-C-UNION: cairo_path_data_t "cairo_path_data_t-point" "cairo_path_data_t-header" ;
-
-C-STRUCT: cairo_path_t
- { "cairo_status_t" "status" }
- { "cairo_path_data_t*" "data" }
- { "int" "num_data" } ;
+STRUCT: cairo_path_data_t-point
+ { x double }
+ { y double } ;
+
+STRUCT: cairo_path_data_t-header
+ { type cairo_path_data_type_t }
+ { length int } ;
+
+UNION-STRUCT: cairo_path_data_t
+ { point cairo_path_data_t-point }
+ { header cairo_path_data_t-header } ;
+
+STRUCT: cairo_path_t
+ { status cairo_status_t }
+ { data cairo_path_data_t* }
+ { num_data int } ;
FUNCTION: cairo_path_t*
cairo_copy_path ( cairo_t* cr ) ;
-! 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 kernel continuations
-destructors sequences io openssl openssl.libcrypto checksums
-checksums.stream ;
+USING: accessors byte-arrays alien.c-types alien.data kernel
+continuations destructors sequences io openssl openssl.libcrypto
+checksums checksums.stream classes.struct ;
IN: checksums.openssl
ERROR: unknown-digest name ;
: <evp-md-context> ( -- ctx )
evp-md-context new-disposable
- "EVP_MD_CTX" <c-object> 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
! (c)Joe Groff bsd license
-USING: accessors alien alien.c-types arrays assocs classes
-classes.struct combinators combinators.short-circuit continuations
-fry kernel libc make math math.parser mirrors prettyprint.backend
-prettyprint.custom prettyprint.sections see.private sequences
-slots strings summary words ;
+USING: accessors alien alien.c-types alien.data alien.prettyprint arrays
+assocs classes classes.struct combinators combinators.short-circuit
+continuations fry kernel libc make math math.parser mirrors
+prettyprint.backend prettyprint.custom prettyprint.sections
+see.private sequences slots strings summary words ;
IN: classes.struct.prettyprint
<PRIVATE
<flow \ { pprint-word
f <inset {
[ name>> text ]
- [ c-type>> dup string? [ text ] [ pprint* ] if ]
+ [ type>> pprint-c-type ]
[ read-only>> [ \ read-only pprint-word ] when ]
[ initial>> [ \ initial: pprint-word pprint* ] when* ]
} cleave block>
] [
'[
_ struct>assoc
- [ [ [ name>> ] [ c-type>> ] bi 2array ] dip ] assoc-map
+ [ [ [ name>> ] [ type>> ] bi 2array ] dip ] assoc-map
] [ drop { } ] recover
] bi append ;
! (c)Joe Groff bsd license
-USING: accessors alien alien.c-types alien.structs.fields ascii
+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 ;
+tools.test parser lexer eval layouts ;
+FROM: math => float ;
+QUALIFIED-WITH: alien.c-types c
SPECIALIZED-ARRAY: char
SPECIALIZED-ARRAY: int
SPECIALIZED-ARRAY: ushort
[ {
{ "underlying" B{ 98 0 0 98 127 0 0 127 0 0 0 0 } }
- { { "x" "char" } 98 }
- { { "y" "int" } HEX: 7F00007F }
- { { "z" "bool" } f }
+ { { "x" char } 98 }
+ { { "y" int } HEX: 7F00007F }
+ { { "z" bool } f }
} ] [
B{ 98 0 0 98 127 0 0 127 0 0 0 0 } struct-test-foo memory>struct
make-mirror >alist
] unit-test
UNION-STRUCT: struct-test-float-and-bits
- { f float }
+ { f c:float }
{ bits uint } ;
[ 1.0 ] [ struct-test-float-and-bits <struct> 1.0 float>bits >>bits f>> ] unit-test
] with-scope
] unit-test
-[ <" USING: 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: 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
[ {
- T{ field-spec
+ T{ struct-slot-spec
{ name "x" }
{ offset 0 }
- { type "char" }
- { reader x>> }
- { writer (>>x) }
+ { initial 0 }
+ { class fixnum }
+ { type char }
}
- T{ field-spec
+ T{ struct-slot-spec
{ name "y" }
{ offset 4 }
- { type "int" }
- { reader y>> }
- { writer (>>y) }
+ { initial 123 }
+ { class integer }
+ { type int }
}
- T{ field-spec
+ T{ struct-slot-spec
{ name "z" }
{ offset 8 }
- { type "bool" }
- { reader z>> }
- { writer (>>z) }
+ { initial f }
+ { type bool }
+ { class object }
}
} ] [ "struct-test-foo" c-type fields>> ] unit-test
[ {
- T{ field-spec
+ T{ struct-slot-spec
{ name "f" }
{ offset 0 }
- { type "float" }
- { reader f>> }
- { writer (>>f) }
+ { type c:float }
+ { class float }
+ { initial 0.0 }
}
- T{ field-spec
+ T{ struct-slot-spec
{ name "bits" }
{ offset 0 }
- { type "uint" }
- { reader bits>> }
- { writer (>>bits) }
+ { type uint }
+ { class integer }
+ { initial 0 }
}
} ] [ "struct-test-float-and-bits" c-type fields>> ] unit-test
] unit-test
STRUCT: struct-test-optimization
- { x { "int" 3 } } { y int } ;
+ { x { int 3 } } { y int } ;
SPECIALIZED-ARRAY: struct-test-optimization
! (c)Joe Groff bsd license
-USING: accessors alien alien.c-types alien.structs
-alien.structs.fields arrays byte-arrays classes classes.parser
-classes.tuple classes.tuple.parser classes.tuple.private
-combinators combinators.short-circuit combinators.smart
-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
-compiler.tree.propagation.transforms ;
-FROM: slots => reader-word writer-word ;
+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
+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 ;
IN: classes.struct
SPECIALIZED-ARRAY: uchar
{ (underlying) c-ptr read-only } ;
TUPLE: struct-slot-spec < slot-spec
- c-type ;
+ type ;
PREDICATE: struct-class < tuple-class
superclass \ struct eq? ;
[ struct-slots [ initial>> ] map over length tail append ] keep ;
: (reader-quot) ( slot -- quot )
- [ c-type>> c-type-getter-boxer ]
+ [ type>> c-type-getter-boxer ]
[ offset>> [ >c-ptr ] swap suffix ] bi prepend ;
: (writer-quot) ( slot -- quot )
- [ c-type>> c-setter ]
+ [ type>> c-setter ]
[ offset>> [ >c-ptr ] swap suffix ] bi prepend ;
: (boxer-quot) ( class -- quot )
[ <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 )
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
+ fields
+ return-in-registers? ;
+
+INSTANCE: struct-c-type value-type
+
+M: struct-c-type c-type ;
+
+M: struct-c-type c-type-stack-align? drop f ;
+
+: if-value-struct ( ctype true false -- )
+ [ dup value-struct? ] 2dip '[ drop void* @ ] if ; inline
+
+M: struct-c-type unbox-parameter
+ [ %unbox-large-struct ] [ unbox-parameter ] if-value-struct ;
+
+M: struct-c-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-c-type unbox-return
+ [ %unbox-small-struct ] [ %unbox-large-struct ] if-small-struct ;
+
+M: struct-c-type box-return
+ [ %box-small-struct ] [ %box-large-struct ] if-small-struct ;
+
+M: struct-c-type stack-size
+ [ heap-size ] [ stack-size ] if-value-struct ;
+
+M: struct-c-type c-struct? drop t ;
+
<PRIVATE
: struct-slot-values-quot ( class -- quot )
struct-slots
[ \ clone-underlying swap literalize \ memory>struct [ ] 3sequence ] bi
define-inline-method ;
-: slot>field ( slot -- field )
- field-spec new swap {
- [ name>> >>name ]
- [ offset>> >>offset ]
- [ c-type>> >>type ]
- [ name>> reader-word >>reader ]
- [ name>> writer-word >>writer ]
+: 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 ;
-
-: define-struct-for-class ( class -- )
- [
- {
- [ name>> ]
- [ "struct-size" word-prop ]
- [ "struct-align" word-prop ]
- [ struct-slots [ slot>field ] map ]
- } cleave
- struct-type (define-struct)
- ] [
- {
- [ name>> c-type ]
- [ (unboxer-quot) >>unboxer-quot ]
- [ (boxer-quot) >>boxer-quot ]
- [ >>boxed-class ]
- } cleave drop
- ] bi ;
-
+
: align-offset ( offset class -- offset' )
c-type-align align ;
: struct-offsets ( slots -- size )
0 [
- [ c-type>> align-offset ] keep
- [ (>>offset) ] [ c-type>> heap-size + ] 2bi
+ [ type>> align-offset ] keep
+ [ (>>offset) ] [ type>> heap-size + ] 2bi
] reduce ;
: union-struct-offsets ( slots -- size )
- [ 0 >>offset c-type>> heap-size ] [ max ] map-reduce ;
+ [ 0 >>offset type>> heap-size ] [ max ] map-reduce ;
: struct-align ( slots -- align )
- [ c-type>> c-type-align ] [ max ] map-reduce ;
+ [ type>> c-type-align ] [ max ] map-reduce ;
PRIVATE>
-M: struct-class c-type name>> c-type ;
-
-M: struct-class c-type-align c-type c-type-align ;
-
-M: struct-class c-type-getter c-type c-type-getter ;
-
-M: struct-class c-type-setter c-type c-type-setter ;
-
-M: struct-class c-type-boxer-quot c-type c-type-boxer-quot ;
-
-M: struct-class c-type-unboxer-quot c-type c-type-boxer-quot ;
-
-M: struct-class heap-size c-type heap-size ;
-
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? [
+ [ "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
+ ] [ drop f ] if ;
: (struct-methods) ( class -- )
[ (define-struct-slot-values-method) ]
[ (struct-methods) ] tri ;
: check-struct-slots ( slots -- )
- [ c-type>> c-type drop ] each ;
+ [ type>> c-type drop ] each ;
: redefine-struct-tuple-class ( class -- )
[ dup class? [ forget-class ] [ drop ] if ] [ struct f define-tuple-class ] bi ;
[ check-struct-slots ] _ [ struct-align [ align ] keep ] tri
(struct-word-props)
]
- [ drop define-struct-for-class ] 2tri ; inline
+ [ drop [ c-type-for-class ] keep typedef ] 2tri ; inline
PRIVATE>
: define-struct-class ( class slots -- )
: <struct-slot-spec> ( name c-type attributes -- slot-spec )
[ struct-slot-spec new ] 3dip
[ >>name ]
- [ [ >>c-type ] [ struct-slot-class >>class ] bi ]
+ [ [ >>type ] [ struct-slot-class >>class ] bi ]
[ [ dup empty? ] [ peel-off-attributes ] until drop ] tri* ;
<PRIVATE
-: scan-c-type ( -- c-type )
- scan dup "{" = [ drop \ } parse-until >array ] when ;
-
: parse-struct-slot ( -- slot )
scan scan-c-type \ } parse-until <struct-slot-spec> ;
<PRIVATE
: scan-c-type` ( -- c-type/param )
- scan dup "{" = [ drop \ } parse-until >array ] [ >string-param ] if ;
+ scan dup "{" = [ drop \ } parse-until >array ] [ search ] if ;
: parse-struct-slot` ( accum -- accum )
scan-string-param scan-c-type` \ } parse-until
! Copyright (C) 2008 Joe Groff.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel classes.struct cocoa cocoa.types alien.c-types
-locals math sequences vectors fry libc destructors ;
+USING: accessors kernel classes.struct cocoa cocoa.runtime cocoa.types alien.data
+locals math sequences vectors fry libc destructors specialized-arrays ;
+SPECIALIZED-ARRAY: id
IN: cocoa.enumeration
-<< "id" require-c-array >>
-
CONSTANT: NS-EACH-BUFFER-SIZE 16
: with-enumeration-buffers ( quot -- )
'[
NSFastEnumerationState malloc-struct &free
- NS-EACH-BUFFER-SIZE "id" malloc-array &free
+ NS-EACH-BUFFER-SIZE id malloc-array &free
NS-EACH-BUFFER-SIZE
@
] with-destructors ; inline
:: (NSFastEnumeration-each) ( object quot: ( elt -- ) state stackbuf count -- )
object state stackbuf count -> countByEnumeratingWithState:objects:count: :> items-count
items-count 0 = [
- state itemsPtr>> [ items-count "id" <c-direct-array> ] [ stackbuf ] if* :> items
+ state itemsPtr>> [ items-count id <c-direct-array> ] [ stackbuf ] if* :> items
items-count iota [ items nth quot call ] each
object quot state stackbuf count (NSFastEnumeration-each)
] unless ; inline recursive
USING: strings arrays hashtables assocs sequences fry macros
cocoa.messages cocoa.classes cocoa.application cocoa kernel
namespaces io.backend math cocoa.enumeration byte-arrays
-combinators alien.c-types words core-foundation quotations
-core-foundation.data core-foundation.utilities ;
+combinators alien.c-types alien.data words core-foundation
+quotations core-foundation.data core-foundation.utilities ;
IN: cocoa.plists
: >plist ( value -- plist ) >cf -> autorelease ;
! 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
{ $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 }"
}
} ;
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel namespaces make math sequences layouts
-alien.c-types alien.structs cpu.architecture ;
+alien.c-types cpu.architecture ;
IN: compiler.alien
: large-struct? ( ctype -- ? )
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: ##slot insn-object obj>> resolve ;
M: ##slot-imm insn-object obj>> resolve ;
M: ##set-slot insn-object obj>> resolve ;
M: ##set-slot-imm insn-object obj>> resolve ;
M: ##alien-global insn-object drop \ ##alien-global ;
+M: ##vm-field-ptr insn-object drop \ ##vm-field-ptr ;
: init-alias-analysis ( insns -- insns' )
H{ } clone histories set
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs combinators hashtables kernel
math fry namespaces make sequences words byte-arrays
-layouts alien.c-types alien.structs
+layouts alien.c-types
stack-checker.inlining cpu.architecture
compiler.tree
compiler.tree.builder
M: #phi emit-node drop ;
-M: #declare emit-node drop ;
\ No newline at end of file
+M: #declare emit-node drop ;
: ^^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
\ No newline at end of file
+: ^^untag-fixnum ( src -- dst ) tag-bits get ^^sar-imm ; inline
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
use: src1 src2
literal: rep ;
-PURE-INSN: ##sqrt-vector
+PURE-INSN: ##horizontal-add-vector
+def: dst/scalar-rep
+use: src
+literal: rep ;
+
+PURE-INSN: ##abs-vector
def: dst
use: src
literal: rep ;
-PURE-INSN: ##horizontal-add-vector
-def: dst/scalar-rep
+PURE-INSN: ##sqrt-vector
+def: dst
use: src
literal: rep ;
+PURE-INSN: ##and-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 ;
+
! Boxing and unboxing aliens
PURE-INSN: ##box-alien
def: dst/int-rep
def: dst/int-rep
literal: symbol library ;
+INSN: ##vm-field-ptr
+def: dst/int-rep
+literal: fieldname ;
+
! FFI
INSN: ##alien-invoke
literal: params stack-frame ;
{ 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-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-vabs) [ [ ^^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-vbitor) [ [ ^^or-vector ] emit-binary-vector-op ] }
+ { math.vectors.simd.intrinsics:(simd-vbitxor) [ [ ^^xor-vector ] emit-binary-vector-op ] }
{ math.vectors.simd.intrinsics:(simd-broadcast) [ [ ^^broadcast-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-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 -- ) ;
ds-pop tag-mask get ^^and-imm ^^tag-fixnum ds-push ;
: emit-getenv ( node -- )
- "userenv" f ^^alien-global
+ "userenv" ^^vm-field-ptr
swap node-input-infos first literal>>
[ ds-drop 0 ^^slot-imm ] [ ds-pop ^^offset>slot 0 ^^slot ] if*
ds-push ;
: remove-pending ( live-interval -- )
vreg>> pending-interval-assoc get delete-at ;
+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> ] unless ;
+ ?at [ spill-slots get ?at [ <spill-slot> ] [ bad-vreg ] if ] unless ;
: vreg>reg ( vreg -- reg )
pending-interval-assoc get (vreg>reg) ;
: end-block ( bb -- )
[ live-out vregs>regs ] keep register-live-outs get set-at ;
-ERROR: bad-vreg vreg ;
-
: vreg-at-start ( vreg bb -- state )
register-live-ins get at ?at [ bad-vreg ] unless ;
compiler.cfg.linearization.order ;
IN: compiler.cfg.linear-scan.numbering
-: number-instructions ( rpo -- )
- linearization-order 0 [
- instructions>> [
- [ (>>insn#) ] [ drop 2 + ] 2bi
- ] each
- ] reduce drop ;
+ERROR: already-numbered insn ;
+
+: number-instruction ( n insn -- n' )
+ [ nip dup insn#>> [ already-numbered ] [ drop ] if ]
+ [ (>>insn#) ]
+ [ drop 2 + ]
+ 2tri ;
+
+: number-instructions ( cfg -- )
+ linearization-order
+ 0 [ instructions>> [ number-instruction ] each ] reduce
+ drop ;
SYMBOL: check-numbering?
--- /dev/null
+USING: compiler.cfg.debugger compiler.cfg compiler.cfg.linearization.order
+kernel accessors sequences sets tools.test namespaces ;
+IN: compiler.cfg.linearization.order.tests
+
+V{ } 0 test-bb
+
+V{ } 1 test-bb
+
+V{ } 2 test-bb
+
+0 { 1 1 } edges
+1 2 edge
+
+[ t ] [ cfg new 0 get >>entry linearization-order [ id>> ] map all-unique? ] unit-test
USING: accessors assocs deques dlists kernel make sorting
namespaces sequences combinators combinators.short-circuit
fry math sets compiler.cfg.rpo compiler.cfg.utilities
-compiler.cfg.loop-detection ;
+compiler.cfg.loop-detection compiler.cfg.predecessors ;
IN: compiler.cfg.linearization.order
! This is RPO except loops are rotated. Based on SBCL's src/compiler/control.lisp
successors>> <reversed> [ loop-nesting-at ] sort-with ;
: process-block ( bb -- )
- [ , ]
- [ visited get conjoin ]
- [ sorted-successors [ process-successor ] each ]
- tri ;
+ dup visited? [ drop ] [
+ [ , ]
+ [ visited get conjoin ]
+ [ sorted-successors [ process-successor ] each ]
+ tri
+ ] if ;
: (linearization-order) ( cfg -- bbs )
init-linearization-order
PRIVATE>
: linearization-order ( cfg -- bbs )
- needs-post-order needs-loops
+ needs-post-order needs-loops needs-predecessors
dup linear-order>> [ ] [
dup (linearization-order)
! 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
! 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 ;
##min-float
##max-float
##add-vector
+ ##saturated-add-vector
+ ##add-sub-vector
##sub-vector
+ ##saturated-sub-vector
##mul-vector
+ ##saturated-mul-vector
##div-vector
##min-vector
- ##max-vector ;
+ ##max-vector
+ ##and-vector
+ ##or-vector
+ ##xor-vector ;
GENERIC: convert-two-operand* ( insn -- )
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces make math math.order math.parser sequences accessors
kernel kernel.private layouts assocs words summary arrays
-combinators classes.algebra alien alien.c-types alien.structs
+combinators classes.algebra alien alien.c-types
alien.strings alien.arrays alien.complex alien.libraries sets libc
continuations.private fry cpu.architecture classes locals
source-files.errors slots parser generic.parser
compiler.cfg.builder
compiler.codegen.fixup
compiler.utilities ;
+QUALIFIED: classes.struct
+QUALIFIED: alien.structs
IN: compiler.codegen
SYMBOL: insn-counts
CODEGEN: ##gather-vector-4 %gather-vector-4
CODEGEN: ##box-vector %box-vector
CODEGEN: ##add-vector %add-vector
+CODEGEN: ##saturated-add-vector %saturated-add-vector
+CODEGEN: ##add-sub-vector %add-sub-vector
CODEGEN: ##sub-vector %sub-vector
+CODEGEN: ##saturated-sub-vector %saturated-sub-vector
CODEGEN: ##mul-vector %mul-vector
+CODEGEN: ##saturated-mul-vector %saturated-mul-vector
CODEGEN: ##div-vector %div-vector
CODEGEN: ##min-vector %min-vector
CODEGEN: ##max-vector %max-vector
CODEGEN: ##sqrt-vector %sqrt-vector
CODEGEN: ##horizontal-add-vector %horizontal-add-vector
+CODEGEN: ##abs-vector %abs-vector
+CODEGEN: ##and-vector %and-vector
+CODEGEN: ##or-vector %or-vector
+CODEGEN: ##xor-vector %xor-vector
CODEGEN: ##box-alien %box-alien
CODEGEN: ##box-displaced-alien %box-displaced-alien
CODEGEN: ##unbox-alien %unbox-alien
[ dst>> ] [ symbol>> ] [ library>> ] tri
%alien-global ;
+M: ##vm-field-ptr generate-insn
+ [ dst>> ] [ fieldname>> ] bi %vm-field-ptr ;
+
! ##alien-invoke
GENERIC: next-fastcall-param ( rep -- )
M: object flatten-value-type 1array ;
-M: struct-type flatten-value-type ( type -- types )
+M: alien.structs:struct-type flatten-value-type ( type -- types )
+ stack-size cell align (flatten-int-type) ;
+
+M: classes.struct:struct-c-type flatten-value-type ( type -- types )
stack-size cell align (flatten-int-type) ;
M: long-long-type flatten-value-type ( type -- types )
! Generate code for boxing input parameters in a callback.
[
dup \ %save-param-reg move-parameters
- "nest_stacks" f %alien-invoke
+ "nest_stacks" %vm-invoke-1st-arg
box-parameters
] with-param-regs ;
: callback-return-quot ( ctype -- quot )
return>> {
- { [ dup "void" = ] [ drop [ ] ] }
+ { [ dup void? ] [ drop [ ] ] }
{ [ dup large-struct? ] [ heap-size '[ _ memcpy ] ] }
[ c-type c-type-unboxer-quot ]
} cond ;
[ callback-context new do-callback ] %
] [ ] make ;
-: %unnest-stacks ( -- ) "unnest_stacks" f %alien-invoke ;
+: %unnest-stacks ( -- ) "unnest_stacks" %vm-invoke-1st-arg ;
M: ##callback-return generate-insn
#! All the extra book-keeping for %unwind is only for x86.
CONSTANT: rt-stack-chain 9
CONSTANT: rt-untagged 10
CONSTANT: rt-megamorphic-cache-hits 11
+CONSTANT: rt-vm 12
: rc-absolute? ( n -- ? )
${ rc-absolute-ppc-2/2 rc-absolute-cell rc-absolute } member? ;
namespaces.private parser quotations sequences
specialized-arrays stack-checker stack-checker.errors
system threads tools.test words ;
+FROM: alien.c-types => float short ;
SPECIALIZED-ARRAY: float
SPECIALIZED-ARRAY: char
IN: compiler.tests.alien
namespaces.private slots.private sequences.private byte-arrays alien
alien.accessors layouts words definitions compiler.units io
combinators vectors grouping make alien.c-types combinators.short-circuit
-math.order math.libm math.parser ;
+math.order math.libm math.parser alien.c-types ;
+FROM: math => float ;
QUALIFIED: namespaces.private
IN: compiler.tests.codegen
[ "0.169967142900241" "0.9854497299884601" ] [ 1.4 [ [ fcos ] [ fsin ] bi ] compile-call [ number>string ] bi@ ] unit-test
[ 1 "0.169967142900241" "0.9854497299884601" ] [ 1.4 1 [ swap >float [ fcos ] [ fsin ] bi ] compile-call [ number>string ] bi@ ] unit-test
-[ 6.0 ] [ 1.0 [ >float 3.0 + [ B{ 0 0 0 0 } 0 set-alien-float ] [ 2.0 + ] bi ] compile-call ] unit-test
\ No newline at end of file
+[ 6.0 ] [ 1.0 [ >float 3.0 + [ B{ 0 0 0 0 } 0 set-alien-float ] [ 2.0 + ] bi ] compile-call ] unit-test
+
+! Bug in linearization
+[ 283686952174081 ] [
+ B{ 1 1 1 1 } [
+ { byte-array } declare
+ [ 0 2 ] dip
+ [
+ [ drop ] 2dip
+ [
+ swap 1 < [ [ ] dip ] [ [ ] dip ] if
+ 0 alien-signed-4
+ ] curry dup bi *
+ ] curry each-integer
+ ] compile-call
+] unit-test
+
+TUPLE: myseq { underlying1 byte-array read-only } { underlying2 byte-array read-only } ;
+
+[ 2 ] [
+ little-endian?
+ T{ myseq f B{ 1 0 0 0 } B{ 1 0 0 0 } }
+ T{ myseq f B{ 0 0 0 1 } B{ 0 0 0 1 } } ?
+ [
+ { myseq } declare
+ [ 0 2 ] dip dup
+ [
+ [
+ over 1 < [ underlying1>> ] [ [ 1 - ] dip underlying2>> ] if
+ swap 4 * >fixnum alien-signed-4
+ ] bi-curry@ bi * +
+ ] 2curry each-integer
+ ] compile-call
+] unit-test
-USING: eval tools.test compiler.units vocabs multiline words
+USING: eval tools.test compiler.units vocabs words
kernel classes.mixin arrays ;
IN: compiler.tests.folding
[ ] [ [ "compiler.tests.redefine11" forget-vocab ] with-compilation-unit ] unit-test
[ ] [
- <"
- USING: math arrays ;
+ "USING: math arrays ;
IN: compiler.tests.folding
GENERIC: foldable-generic ( a -- b ) foldable
- M: integer foldable-generic f <array> ;
- "> eval( -- )
+ M: integer foldable-generic f <array> ;"
+ eval( -- )
] unit-test
[ ] [
- <"
- USING: math arrays ;
+ "USING: math arrays ;
IN: compiler.tests.folding
- : fold-test ( -- x ) 10 foldable-generic ;
- "> eval( -- )
+ : fold-test ( -- x ) 10 foldable-generic ;"
+ eval( -- )
] unit-test
[ t ] [
strings tools.test words continuations sequences.private
hashtables.private byte-arrays system random layouts vectors
sbufs strings.private slots.private alien math.order
-alien.accessors alien.c-types alien.syntax alien.strings
+alien.accessors alien.c-types alien.data alien.syntax alien.strings
namespaces libc io.encodings.ascii classes compiler ;
+FROM: math => float ;
IN: compiler.tests.intrinsics
! Make sure that intrinsic ops compile to correct code.
compile-cfg ;
: compile-test-bb ( insns -- result )
- V{ T{ ##prologue } T{ ##branch } } 0 test-bb
+ V{ T{ ##prologue } T{ ##branch } } [ clone ] map 0 test-bb
V{
T{ ##inc-d f 1 }
T{ ##replace f 0 D 0 }
[ t ] [
V{
T{ ##load-reference f 0 { t f t } }
- T{ ##slot-imm f 0 0 2 $[ array tag-number ] 2 }
+ T{ ##slot-imm f 0 0 2 $[ array tag-number ] }
} compile-test-bb
] unit-test
[ t ] [ \ <tuple>-regression optimized? ] unit-test
-GENERIC: foozul ( a -- b )
-M: reversed foozul ;
-M: integer foozul ;
-M: slice foozul ;
-
-[ t ] [
- reversed \ foozul specific-method
- reversed \ foozul method
- eq?
-] unit-test
-
! regression
: constant-fold-2 ( -- value ) f ; foldable
: constant-fold-3 ( -- value ) 4 ; foldable
-USING: eval tools.test compiler.units vocabs multiline words
-kernel ;
+USING: eval tools.test compiler.units vocabs words kernel ;
IN: compiler.tests.redefine10
! Mixin redefinition did not recompile all necessary words.
[ ] [ [ "compiler.tests.redefine10" forget-vocab ] with-compilation-unit ] unit-test
[ ] [
- <"
- USING: kernel math classes ;
+ "USING: kernel math classes ;
IN: compiler.tests.redefine10
MIXIN: my-mixin
INSTANCE: fixnum my-mixin
- : my-inline ( a -- b ) dup my-mixin instance? [ 1 + ] when ;
- "> eval( -- )
+ : my-inline ( a -- b ) dup my-mixin instance? [ 1 + ] when ;"
+ eval( -- )
] unit-test
[ ] [
- <"
- USE: math
+ "USE: math
IN: compiler.tests.redefine10
- INSTANCE: float my-mixin
- "> eval( -- )
+ INSTANCE: float my-mixin"
+ eval( -- )
] unit-test
[ 2.0 ] [
-USING: eval tools.test compiler.units vocabs multiline words
+USING: eval tools.test compiler.units vocabs words
kernel classes.mixin arrays ;
IN: compiler.tests.redefine11
[ ] [ [ "compiler.tests.redefine11" forget-vocab ] with-compilation-unit ] unit-test
[ ] [
- <"
- USING: kernel math classes arrays ;
+ "USING: kernel math classes arrays ;
IN: compiler.tests.redefine11
MIXIN: my-mixin
INSTANCE: array my-mixin
GENERIC: my-generic ( a -- b )
M: my-mixin my-generic drop 0 ;
M: object my-generic drop 1 ;
- : my-inline ( -- b ) { } my-generic ;
- "> eval( -- )
+ : my-inline ( -- b ) { } my-generic ;"
+ eval( -- )
] unit-test
[ ] [
-USING: eval tools.test compiler.units vocabs multiline words
-kernel ;
+USING: eval tools.test compiler.units vocabs words kernel ;
IN: compiler.tests.redefine5
! Regression: if dispatch was eliminated but method was not inlined,
[ "compiler.tests.redefine5" forget-vocab ] with-compilation-unit
[ ] [
- <"
- USING: sorting kernel math.order ;
+ "USING: sorting kernel math.order ;
IN: compiler.tests.redefine5
GENERIC: my-generic ( a -- b )
M: object my-generic [ <=> ] sort ;
- : my-inline ( a -- b ) my-generic ;
- "> eval( -- )
+ : my-inline ( a -- b ) my-generic ;"
+ eval( -- )
] unit-test
[ ] [
- <"
- USE: kernel
+ "USE: kernel
IN: compiler.tests.redefine5
TUPLE: my-tuple ;
- M: my-tuple my-generic drop 0 ;
- "> eval( -- )
+ M: my-tuple my-generic drop 0 ;" eval( -- )
] unit-test
[ 0 ] [
-USING: eval tools.test compiler.units vocabs multiline words
+USING: eval tools.test compiler.units vocabs words
kernel ;
IN: compiler.tests.redefine6
[ ] [ [ "compiler.tests.redefine6" forget-vocab ] with-compilation-unit ] unit-test
[ ] [
- <"
- USING: kernel kernel.private ;
+ "USING: kernel kernel.private ;
IN: compiler.tests.redefine6
GENERIC: my-generic ( a -- b )
MIXIN: my-mixin
M: my-mixin my-generic drop 0 ;
- : my-inline ( a -- b ) { my-mixin } declare my-generic ;
- "> eval( -- )
+ : my-inline ( a -- b ) { my-mixin } declare my-generic ;"
+ eval( -- )
] unit-test
[ ] [
- <"
- USING: kernel ;
+ "USING: kernel ;
IN: compiler.tests.redefine6
TUPLE: my-tuple ;
M: my-tuple my-generic drop 1 ;
- INSTANCE: my-tuple my-mixin
- "> eval( -- )
+ INSTANCE: my-tuple my-mixin"
+ eval( -- )
] unit-test
[ 1 ] [
-USING: eval tools.test compiler.units vocabs multiline words
+USING: eval tools.test compiler.units vocabs words
kernel ;
IN: compiler.tests.redefine7
[ ] [ [ "compiler.tests.redefine7" forget-vocab ] with-compilation-unit ] unit-test
[ ] [
- <"
- USING: kernel math ;
+ "USING: kernel math ;
IN: compiler.tests.redefine7
MIXIN: my-mixin
INSTANCE: fixnum my-mixin
- : my-inline ( a -- b ) dup my-mixin? [ 1 + ] when ;
- "> eval( -- )
+ : my-inline ( a -- b ) dup my-mixin? [ 1 + ] when ;"
+ eval( -- )
] unit-test
[ ] [
- <"
- USE: math
+ "USE: math
IN: compiler.tests.redefine7
- INSTANCE: float my-mixin
- "> eval( -- )
+ INSTANCE: float my-mixin"
+ eval( -- )
] unit-test
[ 2.0 ] [
-USING: eval tools.test compiler.units vocabs multiline words
+USING: eval tools.test compiler.units vocabs words
kernel ;
IN: compiler.tests.redefine8
[ ] [ [ "compiler.tests.redefine8" forget-vocab ] with-compilation-unit ] unit-test
[ ] [
- <"
- USING: kernel math math.order sorting ;
+ "USING: kernel math math.order sorting ;
IN: compiler.tests.redefine8
MIXIN: my-mixin
INSTANCE: fixnum my-mixin
GENERIC: my-generic ( a -- b )
! We add the bogus quotation here to hinder inlining
! since otherwise we cannot trigger this bug.
- M: my-mixin my-generic 1 + [ [ <=> ] sort ] drop ;
- "> eval( -- )
+ M: my-mixin my-generic 1 + [ [ <=> ] sort ] drop ;"
+ eval( -- )
] unit-test
[ ] [
- <"
- USE: math
+ "USE: math
IN: compiler.tests.redefine8
- INSTANCE: float my-mixin
- "> eval( -- )
+ INSTANCE: float my-mixin"
+ eval( -- )
] unit-test
[ 2.0 ] [
-USING: eval tools.test compiler.units vocabs multiline words
+USING: eval tools.test compiler.units vocabs words
kernel generic.math ;
IN: compiler.tests.redefine9
[ ] [ [ "compiler.tests.redefine9" forget-vocab ] with-compilation-unit ] unit-test
[ ] [
- <"
- USING: kernel math math.order sorting ;
+ "USING: kernel math math.order sorting ;
IN: compiler.tests.redefine9
MIXIN: my-mixin
INSTANCE: fixnum my-mixin
GENERIC: my-generic ( a -- b )
! We add the bogus quotation here to hinder inlining
! since otherwise we cannot trigger this bug.
- M: my-mixin my-generic 1 + [ [ <=> ] sort ] drop ;
- "> eval( -- )
+ M: my-mixin my-generic 1 + [ [ <=> ] sort ] drop ;"
+ eval( -- )
] unit-test
[ ] [
- <"
- USE: math
+ "USE: math
IN: compiler.tests.redefine9
TUPLE: my-tuple ;
- INSTANCE: my-tuple my-mixin
- "> eval( -- )
+ INSTANCE: my-tuple my-mixin"
+ eval( -- )
] unit-test
[
compiler.tree.propagation.info
compiler.tree.checker
compiler.tree.debugger ;
+FROM: math => float ;
IN: compiler.tree.cleanup.tests
[ t ] [ [ [ 1 ] [ 2 ] if ] cleaned-up-tree [ #if? ] contains-node? ] unit-test
! See http://factorcode.org/license.txt for BSD license.
USING: fry kernel sequences assocs accessors namespaces
math.intervals arrays classes.algebra combinators columns
-stack-checker.branches
+stack-checker.branches locals
compiler.utilities
compiler.tree
compiler.tree.combinators
[ [ phi-info-d>> flip ] [ out-d>> ] bi merge-value-infos ]
bi ;
+:: update-constraints ( new old -- )
+ new [| key value | key old [ value append ] change-at ] assoc-each ;
+
+: include-child-constraints ( i -- )
+ infer-children-data get nth constraints swap at last
+ constraints get last update-constraints ;
+
: branch-phi-constraints ( output values booleans -- )
{
{
swap t-->
]
}
- ! {
- ! { { t f } { } }
- ! [ B
- ! first
- ! [ [ =t ] bi@ <--> ]
- ! [ [ =f ] bi@ <--> ] 2bi /\
- ! ]
- ! }
- ! {
- ! { { } { t f } }
- ! [
- ! second
- ! [ [ =t ] bi@ <--> ]
- ! [ [ =f ] bi@ <--> ] 2bi /\
- ! ]
- ! }
+ {
+ { { t f } { } }
+ [
+ first
+ [ [ =t ] bi@ <--> ]
+ [ [ =f ] bi@ <--> ] 2bi /\
+ 0 include-child-constraints
+ ]
+ }
+ {
+ { { } { t f } }
+ [
+ second
+ [ [ =t ] bi@ <--> ]
+ [ [ =f ] bi@ <--> ] 2bi /\
+ 1 include-child-constraints
+ ]
+ }
[ 3drop f ]
} case assume ;
] 3each
] [ drop ] if ;
-M: #phi propagate-around ( #phi -- )
- [ propagate-before ] [ propagate-after ] bi ;
-
M: #branch propagate-around
dup live-branches >>live-branches
[ infer-children ] [ annotate-node ] bi ;
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs math math.intervals kernel accessors
sequences namespaces classes classes.algebra
-combinators words
+combinators words combinators.short-circuit
compiler.tree
compiler.tree.propagation.info
compiler.tree.propagation.copy ;
! Boolean constraints
TUPLE: true-constraint value ;
-: =t ( value -- constriant ) resolve-copy true-constraint boa ;
+: =t ( value -- constraint ) resolve-copy true-constraint boa ;
+
+: follow-implications ( constraint -- )
+ constraints get assoc-stack [ assume ] when* ;
M: true-constraint assume*
[ \ f class-not <class-info> swap value>> refine-value-info ]
- [ constraints get assoc-stack [ assume ] when* ]
+ [ follow-implications ]
bi ;
M: true-constraint satisfied?
- value>> value-info class>> true-class? ;
+ value>> value-info class>>
+ { [ true-class? ] [ null-class? not ] } 1&& ;
TUPLE: false-constraint value ;
M: false-constraint assume*
[ \ f <class-info> swap value>> refine-value-info ]
- [ constraints get assoc-stack [ assume ] when* ]
+ [ follow-implications ]
bi ;
M: false-constraint satisfied?
- value>> value-info class>> false-class? ;
+ value>> value-info class>>
+ { [ false-class? ] [ null-class? not ] } 1&& ;
! Class constraints
TUPLE: class-constraint value class ;
C: --> implication
-: assume-implication ( p q -- )
+: assume-implication ( q p -- )
[ constraints get [ assoc-stack swap suffix ] 2keep last set-at ]
[ satisfied? [ assume ] [ drop ] if ] 2bi ;
: refine-value-info ( info value -- )
resolve-copy value-infos get
- [ assoc-stack value-info-intersect ] 2keep
+ [ assoc-stack [ value-info-intersect ] when* ] 2keep
last set-at ;
: value-literal ( value -- obj ? )
2dup [ in-d>> length ] [ dispatch# ] bi* <= [ 2drop f f ] [
[ in-d>> <reversed> ] [ [ dispatch# ] keep ] bi*
[ swap nth value-info class>> dup ] dip
- specific-method
+ method-for-class
] if
] if ;
compiler.tree.propagation.call-effect
compiler.tree.propagation.transforms
compiler.tree.propagation.simd ;
+FROM: alien.c-types => (signed-interval) (unsigned-interval) ;
IN: compiler.tree.propagation.known-words
{ + - * / }
class>> dup null-class? [ drop null ] [ math-closure ] if ;
: unary-op-interval ( info quot -- newinterval )
- [ interval>> ] dip call ; inline
+ [
+ dup class>> real classes-intersect?
+ [ interval>> ] [ drop full-interval ] if
+ ] dip call ; inline
: unary-op ( word interval-quot post-proc-quot -- )
'[
alien-unsigned-8
} [
dup name>> {
- {
- [ "alien-signed-" ?head ]
- [ string>number 8 * 1 - 2^ dup neg swap 1 - [a,b] ]
- }
- {
- [ "alien-unsigned-" ?head ]
- [ string>number 8 * 2^ 1 - 0 swap [a,b] ]
- }
- } cond
+ { [ "alien-signed-" ?head ] [ string>number (signed-interval) ] }
+ { [ "alien-unsigned-" ?head ] [ string>number (unsigned-interval) ] }
+ } cond [a,b]
[ fits-in-fixnum? fixnum integer ? ] keep <class/interval-info>
'[ 2drop _ ] "outputs" set-word-prop
] each
slots.private words hashtables classes assocs locals
specialized-arrays system sorting math.libm
math.intervals quotations effects alien ;
+FROM: math => float ;
SPECIALIZED-ARRAY: double
IN: compiler.tree.propagation.tests
[ t ] [ [ { complex } declare absq ] final-info first interval>> [0,inf] = ] unit-test
+[ t ] [ [ { float float } declare rect> C{ 0.0 0.0 } + absq ] final-info first interval>> [0,inf] = ] unit-test
+
+[ V{ float } ] [ [ { float float } declare rect> C{ 0.0 0.0 } + absq ] final-classes ] unit-test
+
[ t ] [ [ [ - absq ] [ + ] 2map-reduce ] final-info first interval>> [0,inf] = ] unit-test
[ t ] [ [ { double-array double-array } declare [ - absq ] [ + ] 2map-reduce ] final-info first interval>> [0,inf] = ] unit-test
[ { word object } declare equal? ] final-classes
] unit-test
-! [ V{ string } ] [
-! [ dup string? t xor [ "A" throw ] [ ] if ] final-classes
-! ] unit-test
+[ V{ string } ] [
+ [ dup string? t xor [ "A" throw ] [ ] if ] final-classes
+] unit-test
-! [ t ] [ [ dup t xor or ] final-classes first true-class? ] unit-test
+[ t ] [ [ dup t xor or ] final-classes first true-class? ] unit-test
-! [ t ] [ [ dup t xor swap or ] final-classes first true-class? ] unit-test
+[ t ] [ [ dup t xor swap or ] final-classes first true-class? ] unit-test
-! [ t ] [ [ dup t xor and ] final-classes first false-class? ] unit-test
+[ t ] [ [ dup t xor and ] final-classes first false-class? ] unit-test
-! [ t ] [ [ dup t xor swap and ] final-classes first false-class? ] unit-test
+[ t ] [ [ dup t xor swap and ] final-classes first false-class? ] unit-test
! generalize-counter-interval wasn't being called in all the right places.
! bug found by littledan
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors byte-arrays combinators fry
+USING: accessors byte-arrays combinators fry sequences
compiler.tree.propagation.info cpu.architecture kernel words math
math.intervals math.vectors.simd.intrinsics ;
IN: compiler.tree.propagation.simd
-\ (simd-v+) { byte-array } "default-output-classes" set-word-prop
-
-\ (simd-v-) { byte-array } "default-output-classes" set-word-prop
-
-\ (simd-v*) { byte-array } "default-output-classes" set-word-prop
-
-\ (simd-v/) { byte-array } "default-output-classes" set-word-prop
-
-\ (simd-vmin) { byte-array } "default-output-classes" set-word-prop
-
-\ (simd-vmax) { byte-array } "default-output-classes" set-word-prop
-
-\ (simd-vsqrt) { byte-array } "default-output-classes" set-word-prop
+{
+ (simd-v+)
+ (simd-v-)
+ (simd-v+-)
+ (simd-v*)
+ (simd-v/)
+ (simd-vmin)
+ (simd-vmax)
+ (simd-sum)
+ (simd-vabs)
+ (simd-vsqrt)
+ (simd-vbitand)
+ (simd-vbitor)
+ (simd-vbitxor)
+ (simd-broadcast)
+ (simd-gather-2)
+ (simd-gather-4)
+ alien-vector
+} [ { byte-array } "default-output-classes" set-word-prop ] each
\ (simd-sum) [
nip dup literal?>> [
literal>> scalar-rep-of {
{ float-rep [ float ] }
{ double-rep [ float ] }
+ { int-rep [ integer ] }
} case
] [ drop real ] if
<class-info>
] "outputs" set-word-prop
-\ (simd-broadcast) { byte-array } "default-output-classes" set-word-prop
-
-\ (simd-gather-2) { byte-array } "default-output-classes" set-word-prop
-
-\ (simd-gather-4) { byte-array } "default-output-classes" set-word-prop
-
\ assert-positive [
real [0,inf] <class/interval-info> value-info-intersect
] "outputs" set-word-prop
-\ alien-vector { byte-array } "default-output-classes" set-word-prop
-
! If SIMD is not available, inline alien-vector and set-alien-vector
! to get a speedup
: inline-unless-intrinsic ( word -- )
! If first input has a known type and second input is an
! object, we convert this to [ swap equal? ].
in-d>> first2 value-info class>> object class= [
- value-info class>> \ equal? specific-method
+ value-info class>> \ equal? method-for-class
[ swap equal? ] f ?
] [ drop f ] if
] "custom-inlining" set-word-prop
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types alien.syntax kernel math core-foundation ;
+FROM: math => float ;
IN: core-foundation.numbers
TYPEDEF: void* CFNumberRef
! On x86, floating point registers are really vector registers
SINGLETONS:
-float-4-rep
-double-2-rep
char-16-rep
uchar-16-rep
short-8-rep
ushort-8-rep
int-4-rep
-uint-4-rep ;
+uint-4-rep
+longlong-2-rep
+ulonglong-2-rep ;
-UNION: vector-rep
+SINGLETONS:
float-4-rep
-double-2-rep
+double-2-rep ;
+
+UNION: int-vector-rep
char-16-rep
uchar-16-rep
short-8-rep
ushort-8-rep
int-4-rep
-uint-4-rep ;
+uint-4-rep
+longlong-2-rep
+ulonglong-2-rep ;
+
+UNION: float-vector-rep
+float-4-rep
+double-2-rep ;
+
+UNION: vector-rep
+int-vector-rep
+float-vector-rep ;
UNION: representation
any-rep
M: stack-params rep-size drop cell ;
M: vector-rep rep-size drop 16 ;
+GENERIC: rep-component-type ( rep -- n )
+
+! Methods defined in alien.c-types
+
GENERIC: scalar-rep-of ( rep -- rep' )
M: float-4-rep scalar-rep-of drop float-rep ;
M: double-2-rep scalar-rep-of drop double-rep ;
+M: int-vector-rep scalar-rep-of drop int-rep ;
! Mapping from register class to machine registers
HOOK: machine-registers cpu ( -- assoc )
HOOK: %broadcast-vector cpu ( dst src rep -- )
HOOK: %gather-vector-2 cpu ( dst src1 src2 rep -- )
HOOK: %gather-vector-4 cpu ( dst src1 src2 src3 src4 rep -- )
-
HOOK: %add-vector cpu ( dst src1 src2 rep -- )
+HOOK: %saturated-add-vector cpu ( dst src1 src2 rep -- )
+HOOK: %add-sub-vector cpu ( dst src1 src2 rep -- )
HOOK: %sub-vector cpu ( dst src1 src2 rep -- )
+HOOK: %saturated-sub-vector cpu ( dst src1 src2 rep -- )
HOOK: %mul-vector cpu ( dst src1 src2 rep -- )
+HOOK: %saturated-mul-vector cpu ( dst src1 src2 rep -- )
HOOK: %div-vector cpu ( dst src1 src2 rep -- )
HOOK: %min-vector cpu ( dst src1 src2 rep -- )
HOOK: %max-vector cpu ( dst src1 src2 rep -- )
HOOK: %sqrt-vector cpu ( dst src rep -- )
HOOK: %horizontal-add-vector cpu ( dst src rep -- )
+HOOK: %abs-vector cpu ( dst src rep -- )
+HOOK: %and-vector cpu ( dst src1 src2 rep -- )
+HOOK: %or-vector cpu ( dst src1 src2 rep -- )
+HOOK: %xor-vector cpu ( dst src1 src2 rep -- )
+
+HOOK: %broadcast-vector-reps cpu ( -- reps )
+HOOK: %gather-vector-2-reps cpu ( -- reps )
+HOOK: %gather-vector-4-reps cpu ( -- reps )
+HOOK: %add-vector-reps cpu ( -- reps )
+HOOK: %saturated-add-vector-reps cpu ( -- reps )
+HOOK: %add-sub-vector-reps cpu ( -- reps )
+HOOK: %sub-vector-reps cpu ( -- reps )
+HOOK: %saturated-sub-vector-reps cpu ( -- reps )
+HOOK: %mul-vector-reps cpu ( -- reps )
+HOOK: %saturated-mul-vector-reps cpu ( -- reps )
+HOOK: %div-vector-reps cpu ( -- reps )
+HOOK: %min-vector-reps cpu ( -- reps )
+HOOK: %max-vector-reps cpu ( -- reps )
+HOOK: %sqrt-vector-reps cpu ( -- reps )
+HOOK: %horizontal-add-vector-reps cpu ( -- reps )
+HOOK: %abs-vector-reps cpu ( -- reps )
+HOOK: %and-vector-reps cpu ( -- reps )
+HOOK: %or-vector-reps cpu ( -- reps )
+HOOK: %xor-vector-reps cpu ( -- reps )
HOOK: %unbox-alien cpu ( dst src -- )
HOOK: %unbox-any-c-ptr cpu ( dst src temp -- )
HOOK: %set-alien-vector cpu ( ptr value rep -- )
HOOK: %alien-global cpu ( dst symbol library -- )
+HOOK: %vm-field-ptr cpu ( dst fieldname -- )
HOOK: %allot cpu ( dst size class temp -- )
HOOK: %write-barrier cpu ( src card# table -- )
HOOK: %alien-invoke cpu ( function library -- )
+HOOK: %vm-invoke-1st-arg cpu ( function -- )
+HOOK: %vm-invoke-3rd-arg cpu ( function -- )
+
HOOK: %cleanup cpu ( params -- )
M: object %cleanup ( params -- ) drop ;
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs sequences kernel combinators make math
math.order math.ranges system namespaces locals layouts words
-alien alien.accessors alien.c-types literals cpu.architecture
+alien alien.accessors alien.c-types alien.data literals cpu.architecture
cpu.ppc.assembler cpu.ppc.assembler.backend compiler.cfg.registers
compiler.cfg.instructions compiler.cfg.comparisons
compiler.codegen.fixup compiler.cfg.intrinsics
compiler.cfg.stack-frame compiler.cfg.build-stack-frame
-compiler.units compiler.constants compiler.codegen ;
+compiler.units compiler.constants compiler.codegen vm ;
FROM: cpu.ppc.assembler => B ;
+FROM: layouts => cell ;
+FROM: math => float ;
IN: cpu.ppc
! PowerPC register assignments:
\ ##float>integer t frame-required? set-word-prop
>>
+: %load-vm-addr ( reg -- )
+ 0 swap LOAD32 rc-absolute-ppc-2/2 rt-vm rel-fixup ;
+
+: %load-vm-field-addr ( reg symbol -- )
+ [ drop %load-vm-addr ]
+ [ [ dup ] dip vm-field-offset ADDI ] 2bi ;
+
+M: ppc %vm-field-ptr ( dst field -- ) %load-vm-field-addr ;
+
+M: ppc %vm-invoke-1st-arg ( function -- ) f %alien-invoke ;
+M: ppc %vm-invoke-3rd-arg ( function -- ) f %alien-invoke ;
+
M: ppc machine-registers
{
{ int-regs $[ 2 12 [a,b] 15 29 [a,b] append ] }
M: ppc %double>single-float FMR ;
+! VMX/AltiVec not supported yet
+M: %broadcast-vector-reps drop { } ;
+M: %gather-vector-2-reps drop { } ;
+M: %gather-vector-4-reps drop { } ;
+M: %add-vector-reps drop { } ;
+M: %saturated-add-vector-reps drop { } ;
+M: %add-sub-vector-reps drop { } ;
+M: %sub-vector-reps drop { } ;
+M: %saturated-sub-vector-reps drop { } ;
+M: %mul-vector-reps drop { } ;
+M: %saturated-mul-vector-reps drop { } ;
+M: %div-vector-reps drop { } ;
+M: %min-vector-reps drop { } ;
+M: %max-vector-reps drop { } ;
+M: %sqrt-vector-reps drop { } ;
+M: %horizontal-add-vector-reps drop { } ;
+M: %abs-vector-reps drop { } ;
+M: %and-vector-reps drop { } ;
+M: %or-vector-reps drop { } ;
+M: %xor-vector-reps drop { } ;
+
M: ppc %unbox-alien ( dst src -- )
alien-offset LWZ ;
M: ppc %set-alien-double swap 0 STFD ;
: load-zone-ptr ( reg -- )
- "nursery" f %alien-global ;
+ "nursery" %load-vm-field-addr ;
: load-allot-ptr ( nursery-ptr allot-ptr -- )
[ drop load-zone-ptr ] [ swap 4 LWZ ] 2bi ;
dst class store-tagged ;
: load-cards-offset ( dst -- )
- [ "cards_offset" f %alien-global ] [ dup 0 LWZ ] bi ;
+ [ "cards_offset" %load-vm-field-addr ] [ dup 0 LWZ ] bi ;
: load-decks-offset ( dst -- )
- [ "decks_offset" f %alien-global ] [ dup 0 LWZ ] bi ;
+ [ "decks_offset" %load-vm-field-addr ] [ dup 0 LWZ ] bi ;
M:: ppc %write-barrier ( src card# table -- )
card-mark scratch-reg LI
#! Save Factor stack pointers in case the C code calls a
#! callback which does a GC, which must reliably trace
#! all roots.
- temp1 "stack_chain" f %alien-global
+ temp1 "stack_chain" %load-vm-field-addr
temp1 temp1 0 LWZ
1 temp1 0 STW
callback-allowed? [
4 >>align
"box_boolean" >>boxer
"to_boolean" >>unboxer
- "bool" define-primitive-type
+ bool define-primitive-type
] with-compilation-unit
M: x86.32 %alien-invoke 0 CALL rc-relative rel-dlsym ;
+: push-vm-ptr ( -- )
+ temp-reg 0 MOV rc-absolute-cell rt-vm rel-fixup ! push the vm ptr as an argument
+ temp-reg PUSH ;
+
+M: x86.32 %vm-invoke-1st-arg ( function -- )
+ push-vm-ptr
+ f %alien-invoke
+ temp-reg POP ;
+
+M: x86.32 %vm-invoke-3rd-arg ( function -- )
+ %vm-invoke-1st-arg ; ! first 2 args are regs, 3rd is stack so vm-invoke-1st-arg works here
+
M: x86.32 return-struct-in-registers? ( c-type -- ? )
c-type
[ return-in-registers?>> ]
#! parameter being passed to a callback from C.
over [ load-return-reg ] [ 2drop ] if ;
+CONSTANT: vm-ptr-size 4
+
M:: x86.32 %box ( n rep func -- )
n rep (%box)
- rep rep-size [
+ rep rep-size vm-ptr-size + [
+ push-vm-ptr
rep push-return-reg
func f %alien-invoke
] with-aligned-stack ;
M: x86.32 %box-long-long ( n func -- )
[ (%box-long-long) ] dip
- 8 [
+ 8 vm-ptr-size + [
+ push-vm-ptr
EDX PUSH
EAX PUSH
f %alien-invoke
M:: x86.32 %box-large-struct ( n c-type -- )
! Compute destination address
- ECX n struct-return@ LEA
- 8 [
+ EDX n struct-return@ LEA
+ 8 vm-ptr-size + [
+ push-vm-ptr
! Push struct size
c-type heap-size PUSH
! Push destination address
- ECX PUSH
+ EDX PUSH
! Copy the struct from the C stack
"box_value_struct" f %alien-invoke
] with-aligned-stack ;
M: x86.32 %box-small-struct ( c-type -- )
#! Box a <= 8-byte struct returned in EAX:EDX. OS X only.
- 12 [
+ 12 vm-ptr-size + [
+ push-vm-ptr
heap-size PUSH
EDX PUSH
EAX PUSH
ESI 4 SUB ;
: call-unbox-func ( func -- )
- 4 [
+ 8 [
+ ! push the vm ptr as an argument
+ push-vm-ptr
! Push parameter
EAX PUSH
! Call the unboxer
: %unbox-struct-1 ( -- )
#! Alien must be in EAX.
- 4 [
+ 4 vm-ptr-size + [
+ push-vm-ptr
EAX PUSH
"alien_offset" f %alien-invoke
! Load first cell
: %unbox-struct-2 ( -- )
#! Alien must be in EAX.
- 4 [
+ 4 vm-ptr-size + [
+ push-vm-ptr
EAX PUSH
"alien_offset" f %alien-invoke
! Load second cell
M:: x86.32 %unbox-large-struct ( n c-type -- )
! Alien must be in EAX.
! Compute destination address
- ECX n stack@ LEA
- 12 [
+ EDX n stack@ LEA
+ 12 vm-ptr-size + [
+ push-vm-ptr
! Push struct size
c-type heap-size PUSH
! Push destination address
- ECX PUSH
+ EDX PUSH
! Push source address
EAX PUSH
! Copy the struct to the stack
] with-aligned-stack ;
M: x86.32 %prepare-alien-indirect ( -- )
- "unbox_alien" f %alien-invoke
+ push-vm-ptr "unbox_alien" f %alien-invoke
+ temp-reg POP
EBP EAX MOV ;
M: x86.32 %alien-indirect ( -- )
4 [
EAX swap %load-reference
EAX PUSH
+ param-reg-2 0 MOV rc-absolute-cell rt-vm rel-fixup
"c_to_factor" f %alien-invoke
] with-aligned-stack ;
! Save top of data stack in non-volatile register
%prepare-unbox
EAX PUSH
+ push-vm-ptr
! Restore data/call/retain stacks
"unnest_stacks" f %alien-invoke
! Place top of data stack in EAX
+ temp-reg POP
EAX POP
! Restore C stack
ESP 12 ADD
4 "double" c-type (>>align)
] unless
-"cpu.x86.features" require
+check-sse
: div-arg ( -- reg ) EAX ;
: mod-arg ( -- reg ) EDX ;
: arg ( -- reg ) EAX ;
+: arg2 ( -- reg ) EDX ;
: temp0 ( -- reg ) EAX ;
: temp1 ( -- reg ) EDX ;
: temp2 ( -- reg ) ECX ;
temp0 0 [] MOV rc-absolute-cell rt-stack-chain jit-rel
! save stack pointer
temp0 [] stack-reg MOV
+ ! pass vm ptr to primitive
+ arg 0 MOV rc-absolute-cell rt-vm jit-rel
! call the primitive
0 JMP rc-relative rt-primitive jit-rel
] jit-primitive jit-define
! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays kernel math namespaces make sequences system
-layouts alien alien.c-types alien.accessors alien.structs slots
+layouts alien alien.c-types alien.accessors slots
splitting assocs combinators locals compiler.constants
compiler.codegen compiler.codegen.fixup compiler.cfg.instructions
compiler.cfg.builder compiler.cfg.intrinsics compiler.cfg.stack-frame
param-reg-1 R14 [] MOV
R14 cell SUB ;
+M: x86.64 %vm-invoke-1st-arg ( function -- )
+ param-reg-1 0 MOV rc-absolute-cell rt-vm rel-fixup
+ f %alien-invoke ;
+
+: %vm-invoke-2nd-arg ( function -- )
+ param-reg-2 0 MOV rc-absolute-cell rt-vm rel-fixup
+ f %alien-invoke ;
+
+M: x86.64 %vm-invoke-3rd-arg ( function -- )
+ param-reg-3 0 MOV rc-absolute-cell rt-vm rel-fixup
+ f %alien-invoke ;
+
+: %vm-invoke-4th-arg ( function -- )
+ int-regs param-regs fourth 0 MOV rc-absolute-cell rt-vm rel-fixup
+ f %alien-invoke ;
+
+
M:: x86.64 %unbox ( n rep func -- )
! Call the unboxer
- func f %alien-invoke
+ func %vm-invoke-2nd-arg
! Store the return value on the C stack if this is an
! alien-invoke, otherwise leave it the return register if
! this is the end of alien-callback
{ float-regs [ float-regs get pop swap MOVSD ] }
} case ;
+
M: x86.64 %unbox-small-struct ( c-type -- )
! Alien must be in param-reg-1.
- "alien_offset" f %alien-invoke
+ "alien_offset" %vm-invoke-2nd-arg
! Move alien_offset() return value to R11 so that we don't
! clobber it.
R11 RAX MOV
! Load structure size into param-reg-3
param-reg-3 c-type heap-size MOV
! Copy the struct to the C stack
- "to_value_struct" f %alien-invoke ;
+ "to_value_struct" %vm-invoke-4th-arg ;
: load-return-value ( rep -- )
[ [ 0 ] dip reg-class-of param-reg ]
[ ]
tri copy-register ;
+
+
M:: x86.64 %box ( n rep func -- )
n [
n
] [
rep load-return-value
] if
- func f %alien-invoke ;
+ rep int-rep? [ func %vm-invoke-2nd-arg ] [ func %vm-invoke-1st-arg ] if ;
M: x86.64 %box-long-long ( n func -- )
[ int-rep ] dip %box ;
[ param-reg-3 swap heap-size MOV ] bi
param-reg-1 0 box-struct-field@ MOV
param-reg-2 1 box-struct-field@ MOV
- "box_small_struct" f %alien-invoke
+ "box_small_struct" %vm-invoke-4th-arg
] with-return-regs ;
: struct-return@ ( n -- operand )
! Compute destination address
param-reg-1 swap struct-return@ LEA
! Copy the struct from the C stack
- "box_value_struct" f %alien-invoke ;
+ "box_value_struct" %vm-invoke-3rd-arg ;
M: x86.64 %prepare-box-struct ( -- )
! Compute target address for value struct return
rc-absolute-cell rel-dlsym
R11 CALL ;
+
M: x86.64 %prepare-alien-indirect ( -- )
- "unbox_alien" f %alien-invoke
+ "unbox_alien" %vm-invoke-1st-arg
RBP RAX MOV ;
M: x86.64 %alien-indirect ( -- )
M: x86.64 %alien-callback ( quot -- )
param-reg-1 swap %load-reference
- "c_to_factor" f %alien-invoke ;
+ "c_to_factor" %vm-invoke-2nd-arg ;
M: x86.64 %callback-value ( ctype -- )
! Save top of data stack
RSP 8 SUB
param-reg-1 PUSH
! Restore data/call/retain stacks
- "unnest_stacks" f %alien-invoke
+ "unnest_stacks" %vm-invoke-1st-arg
! Put former top of data stack in param-reg-1
param-reg-1 POP
RSP 8 ADD
{ [ os winnt? ] [ "cpu.x86.64.winnt" require ] }
} cond
-"cpu.x86.features" require
+check-sse
: rex-length ( -- n ) 1 ;
[
+
! load stack_chain
temp0 0 MOV rc-absolute-cell rt-stack-chain jit-rel
temp0 temp0 [] MOV
temp0 [] stack-reg MOV
! load XT
temp1 0 MOV rc-absolute-cell rt-primitive jit-rel
+ ! load vm ptr
+ arg 0 MOV rc-absolute-cell rt-vm jit-rel
! go
temp1 JMP
] jit-primitive jit-define
: stack-frame-size ( -- n ) 4 bootstrap-cells ;
: arg ( -- reg ) RDI ;
+: arg2 ( -- reg ) RSI ;
<< "vocab:cpu/x86/64/bootstrap.factor" parse-file parsed >>
call
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays sequences math splitting make assocs kernel
-layouts system alien.c-types alien.structs cpu.architecture
+layouts system alien.c-types cpu.architecture
cpu.x86.assembler cpu.x86.assembler.operands cpu.x86 compiler.codegen
compiler.cfg.registers ;
+QUALIFIED: alien.structs
+QUALIFIED: classes.struct
IN: cpu.x86.64.unix
M: int-regs param-regs
M: x86.64 reserved-area-size 0 ;
-! The ABI for passing structs by value is pretty messed up
-<< "void*" c-type clone "__stack_value" define-primitive-type
-stack-params "__stack_value" c-type (>>rep) >>
+SYMBOL: (stack-value)
+! The ABI for passing structs by value is pretty great
+<< void* c-type clone \ (stack-value) define-primitive-type
+stack-params \ (stack-value) c-type (>>rep) >>
: struct-types&offset ( struct-type -- pairs )
fields>> [
: flatten-small-struct ( c-type -- seq )
struct-types&offset split-struct [
[ c-type c-type-rep reg-class-of ] map
- int-regs swap member? "void*" "double" ? c-type
+ int-regs swap member? void* double ? c-type
] map ;
: flatten-large-struct ( c-type -- seq )
heap-size cell align
- cell /i "__stack_value" c-type <repetition> ;
+ cell /i \ (stack-value) c-type <repetition> ;
-M: struct-type flatten-value-type ( type -- seq )
+: flatten-struct ( c-type -- seq )
dup heap-size 16 > [
flatten-large-struct
] [
flatten-small-struct
] if ;
+M: alien.structs:struct-type flatten-value-type ( type -- seq )
+ flatten-struct ;
+M: classes.struct:struct-c-type flatten-value-type ( type -- seq )
+ flatten-struct ;
+
M: x86.64 return-struct-in-registers? ( c-type -- ? )
heap-size 2 cells <= ;
: stack-frame-size ( -- n ) 8 bootstrap-cells ;
: arg ( -- reg ) RCX ;
+: arg2 ( -- reg ) RDX ;
<< "vocab:cpu/x86/64/bootstrap.factor" parse-file parsed >>
call
M: x86.64 temp-reg RAX ;
<<
-"longlong" "ptrdiff_t" typedef
-"longlong" "intptr_t" typedef
-"int" c-type "long" define-primitive-type
-"uint" c-type "ulong" define-primitive-type
+longlong ptrdiff_t typedef
+longlong intptr_t typedef
+int c-type long define-primitive-type
+uint c-type ulong define-primitive-type
>>
M: operand POP { BIN: 000 f HEX: 8f } 1-operand ;
! MOV where the src is immediate.
+<PRIVATE
+
GENERIC: (MOV-I) ( src dst -- )
M: register (MOV-I) t HEX: b8 short-operand cell, ;
M: operand (MOV-I)
{ BIN: 000 t HEX: c6 }
pick byte? [ immediate-1 ] [ immediate-4 ] if ;
+PRIVATE>
+
GENERIC: MOV ( dst src -- )
M: immediate MOV swap (MOV-I) ;
M: operand MOV HEX: 88 2-operand ;
M: integer CALL HEX: e8 , 4, ;
M: operand CALL { BIN: 010 t HEX: ff } 1-operand ;
+<PRIVATE
+
GENERIC# JUMPcc 1 ( addr opcode -- )
M: integer JUMPcc extended-opcode, 4, ;
+PRIVATE>
+
: JO ( dst -- ) HEX: 80 JUMPcc ;
: JNO ( dst -- ) HEX: 81 JUMPcc ;
: JB ( dst -- ) HEX: 82 JUMPcc ;
: CDQ ( -- ) HEX: 99 , ;
: CQO ( -- ) HEX: 48 , CDQ ;
+<PRIVATE
+
: (SHIFT) ( dst src op -- )
over CL eq? [
nip t HEX: d3 3array 1-operand
swapd t HEX: c0 3array immediate-1
] if ; inline
+PRIVATE>
+
: ROL ( dst n -- ) BIN: 000 (SHIFT) ;
: ROR ( dst n -- ) BIN: 001 (SHIFT) ;
: RCL ( dst n -- ) BIN: 010 (SHIFT) ;
--- /dev/null
+Slava Pestov
+Joe Groff
--- /dev/null
+x86 registers and memory operands
arg ds-reg [] MOV
! pop stack
ds-reg bootstrap-cell SUB
+ ! pass vm pointer
+ arg2 0 MOV rc-absolute-cell rt-vm jit-rel
! call quotation
arg quot-xt-offset [+] JMP
] \ (call) define-sub-primitive
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: system kernel math math.order math.parser namespaces
-alien.syntax combinators locals init io cpu.x86 compiler
-compiler.units accessors ;
+USING: system kernel memoize math math.order math.parser
+namespaces alien.c-types alien.syntax combinators locals init io
+compiler compiler.units accessors ;
IN: cpu.x86.features
<PRIVATE
PRIVATE>
-ALIAS: sse-version sse_version
+MEMO: sse-version ( -- n )
+ sse_version
+ "sse-version" get string>number [ min ] when* ;
+
+[ \ sse-version reset-memoized ] "cpu.x86.features" add-init-hook
+
+: sse? ( -- ? ) sse-version 10 >= ;
+: sse2? ( -- ? ) sse-version 20 >= ;
+: sse3? ( -- ? ) sse-version 30 >= ;
+: ssse3? ( -- ? ) sse-version 33 >= ;
+: sse4.1? ( -- ? ) sse-version 41 >= ;
+: sse4.2? ( -- ? ) sse-version 42 >= ;
: sse-string ( version -- string )
{
: count-instructions ( quot -- n )
instruction-count [ call ] dip instruction-count swap - ; inline
-
-USING: cpu.x86.features cpu.x86.features.private ;
-
-:: install-sse-check ( version -- )
- [
- sse-version version < [
- "This image was built to use " write
- version sse-string write
- " but your CPU only supports " write
- sse-version sse-string write "." print
- "You will need to bootstrap Factor again." print
- flush
- 1 exit
- ] when
- ] "cpu.x86" add-init-hook ;
-
-: enable-sse ( version -- )
- {
- { 00 [ ] }
- { 10 [ ] }
- { 20 [ enable-sse2 ] }
- { 30 [ enable-sse3 ] }
- { 33 [ enable-sse3 ] }
- { 41 [ enable-sse3 ] }
- { 42 [ enable-sse3 ] }
- } case ;
-
-[ { sse_version } compile ] with-optimizer
-
-"Checking for multimedia extensions: " write sse-version
-"sse-version" get [ string>number min ] when*
-[ sse-string write " detected" print ]
-[ install-sse-check ]
-[ enable-sse ] tri
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs alien alien.c-types arrays strings
cpu.x86.assembler cpu.x86.assembler.private cpu.x86.assembler.operands
-cpu.architecture kernel kernel.private math memory namespaces make
-sequences words system layouts combinators math.order fry locals
-compiler.constants byte-arrays
+cpu.x86.features cpu.x86.features.private cpu.architecture kernel
+kernel.private math memory namespaces make sequences words system
+layouts combinators math.order fry locals compiler.constants
+byte-arrays io macros quotations compiler compiler.units init vm
compiler.cfg.registers
compiler.cfg.instructions
compiler.cfg.intrinsics
compiler.cfg.comparisons
compiler.cfg.stack-frame
-compiler.codegen
compiler.codegen.fixup ;
+FROM: layouts => cell ;
+FROM: math => float ;
IN: cpu.x86
-<< enable-fixnum-log2 >>
-
! Add some methods to the assembler to be more useful to the backend
M: label JMP 0 JMP rc-relative label-fixup ;
M: label JUMPcc [ 0 ] dip JUMPcc rc-relative label-fixup ;
dst src byte-array-offset [+]
rep copy-register ;
+MACRO: available-reps ( alist -- )
+ ! Each SSE version adds new representations and supports
+ ! all old ones
+ unzip { } [ append ] accumulate rest swap suffix
+ [ [ 1quotation ] map ] bi@ zip
+ reverse [ { } ] suffix
+ '[ _ cond ] ;
+
M: x86 %broadcast-vector ( dst src rep -- )
{
- { float-4-rep [ [ MOVSS ] [ drop dup 0 SHUFPS ] 2bi ] }
- { double-2-rep [ [ MOVSD ] [ drop dup UNPCKLPD ] 2bi ] }
+ { float-4-rep [ [ float-4-rep copy-register ] [ drop dup 0 SHUFPS ] 2bi ] }
+ { double-2-rep [ [ double-2-rep copy-register ] [ drop dup UNPCKLPD ] 2bi ] }
} case ;
+M: x86 %broadcast-vector-reps
+ {
+ { sse? { float-4-rep } }
+ { sse2? { double-2-rep } }
+ } available-reps ;
+
M:: x86 %gather-vector-4 ( dst src1 src2 src3 src4 rep -- )
rep {
{
float-4-rep
[
- dst src1 MOVSS
+ dst src1 float-4-rep copy-register
dst src2 UNPCKLPS
src3 src4 UNPCKLPS
dst src3 MOVLHPS
}
} case ;
+M: x86 %gather-vector-4-reps
+ {
+ { sse? { float-4-rep } }
+ } available-reps ;
+
M:: x86 %gather-vector-2 ( dst src1 src2 rep -- )
rep {
{
double-2-rep
[
- dst src1 MOVSD
+ dst src1 double-2-rep copy-register
dst src2 UNPCKLPD
]
}
} case ;
+M: x86 %gather-vector-2-reps
+ {
+ { sse2? { double-2-rep } }
+ } available-reps ;
+
M: x86 %add-vector ( dst src1 src2 rep -- )
{
{ float-4-rep [ ADDPS ] }
{ ushort-8-rep [ PADDW ] }
{ int-4-rep [ PADDD ] }
{ uint-4-rep [ PADDD ] }
+ { longlong-2-rep [ PADDQ ] }
+ { ulonglong-2-rep [ PADDQ ] }
+ } case drop ;
+
+M: x86 %add-vector-reps
+ {
+ { sse? { float-4-rep } }
+ { sse2? { double-2-rep char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep } }
+ } available-reps ;
+
+M: x86 %saturated-add-vector ( dst src1 src2 rep -- )
+ {
+ { char-16-rep [ PADDSB ] }
+ { uchar-16-rep [ PADDUSB ] }
+ { short-8-rep [ PADDSW ] }
+ { ushort-8-rep [ PADDUSW ] }
+ } case drop ;
+
+M: x86 %saturated-add-vector-reps
+ {
+ { sse2? { char-16-rep uchar-16-rep short-8-rep ushort-8-rep } }
+ } available-reps ;
+
+M: x86 %add-sub-vector ( dst src1 src2 rep -- )
+ {
+ { float-4-rep [ ADDSUBPS ] }
+ { double-2-rep [ ADDSUBPD ] }
} case drop ;
+M: x86 %add-sub-vector-reps
+ {
+ { sse3? { float-4-rep double-2-rep } }
+ } available-reps ;
+
M: x86 %sub-vector ( dst src1 src2 rep -- )
{
{ float-4-rep [ SUBPS ] }
{ ushort-8-rep [ PSUBW ] }
{ int-4-rep [ PSUBD ] }
{ uint-4-rep [ PSUBD ] }
+ { longlong-2-rep [ PSUBQ ] }
+ { ulonglong-2-rep [ PSUBQ ] }
} case drop ;
+M: x86 %sub-vector-reps
+ {
+ { sse? { float-4-rep } }
+ { sse2? { double-2-rep char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep } }
+ } available-reps ;
+
+M: x86 %saturated-sub-vector ( dst src1 src2 rep -- )
+ {
+ { char-16-rep [ PSUBSB ] }
+ { uchar-16-rep [ PSUBUSB ] }
+ { short-8-rep [ PSUBSW ] }
+ { ushort-8-rep [ PSUBUSW ] }
+ } case drop ;
+
+M: x86 %saturated-sub-vector-reps
+ {
+ { sse2? { char-16-rep uchar-16-rep short-8-rep ushort-8-rep } }
+ } available-reps ;
+
M: x86 %mul-vector ( dst src1 src2 rep -- )
{
{ float-4-rep [ MULPS ] }
{ double-2-rep [ MULPD ] }
- { int-4-rep [ PMULLW ] }
+ { short-8-rep [ PMULLW ] }
+ { ushort-8-rep [ PMULLW ] }
+ { int-4-rep [ PMULLD ] }
+ { uint-4-rep [ PMULLD ] }
} case drop ;
+M: x86 %mul-vector-reps
+ {
+ { sse? { float-4-rep } }
+ { sse2? { double-2-rep short-8-rep ushort-8-rep } }
+ { sse4.1? { int-4-rep uint-4-rep } }
+ } available-reps ;
+
+M: x86 %saturated-mul-vector-reps
+ ! No multiplication with saturation on x86
+ { } ;
+
M: x86 %div-vector ( dst src1 src2 rep -- )
{
{ float-4-rep [ DIVPS ] }
{ double-2-rep [ DIVPD ] }
} case drop ;
+M: x86 %div-vector-reps
+ {
+ { sse? { float-4-rep } }
+ { sse2? { double-2-rep } }
+ } available-reps ;
+
M: x86 %min-vector ( dst src1 src2 rep -- )
{
+ { char-16-rep [ PMINSB ] }
+ { uchar-16-rep [ PMINUB ] }
+ { short-8-rep [ PMINSW ] }
+ { ushort-8-rep [ PMINUW ] }
+ { int-4-rep [ PMINSD ] }
+ { uint-4-rep [ PMINUD ] }
{ float-4-rep [ MINPS ] }
{ double-2-rep [ MINPD ] }
} case drop ;
+M: x86 %min-vector-reps
+ {
+ { sse? { float-4-rep } }
+ { sse2? { uchar-16-rep short-8-rep double-2-rep short-8-rep uchar-16-rep } }
+ { sse4.1? { char-16-rep ushort-8-rep int-4-rep uint-4-rep } }
+ } available-reps ;
+
M: x86 %max-vector ( dst src1 src2 rep -- )
{
+ { char-16-rep [ PMAXSB ] }
+ { uchar-16-rep [ PMAXUB ] }
+ { short-8-rep [ PMAXSW ] }
+ { ushort-8-rep [ PMAXUW ] }
+ { int-4-rep [ PMAXSD ] }
+ { uint-4-rep [ PMAXUD ] }
{ float-4-rep [ MAXPS ] }
{ double-2-rep [ MAXPD ] }
} case drop ;
+M: x86 %max-vector-reps
+ {
+ { sse? { float-4-rep } }
+ { sse2? { uchar-16-rep short-8-rep double-2-rep short-8-rep uchar-16-rep } }
+ { sse4.1? { char-16-rep ushort-8-rep int-4-rep uint-4-rep } }
+ } available-reps ;
+
+M: x86 %horizontal-add-vector ( dst src rep -- )
+ {
+ { float-4-rep [ [ float-4-rep copy-register ] [ HADDPS ] [ HADDPS ] 2tri ] }
+ { double-2-rep [ [ double-2-rep copy-register ] [ HADDPD ] 2bi ] }
+ } case ;
+
+M: x86 %horizontal-add-vector-reps
+ {
+ { sse3? { float-4-rep double-2-rep } }
+ } available-reps ;
+
+M: x86 %abs-vector ( dst src rep -- )
+ {
+ { char-16-rep [ PABSB ] }
+ { short-8-rep [ PABSW ] }
+ { int-4-rep [ PABSD ] }
+ } case ;
+
+M: x86 %abs-vector-reps
+ {
+ { ssse3? { char-16-rep short-8-rep int-4-rep } }
+ } available-reps ;
+
M: x86 %sqrt-vector ( dst src rep -- )
{
{ float-4-rep [ SQRTPS ] }
{ double-2-rep [ SQRTPD ] }
} case ;
-M: x86 %horizontal-add-vector ( dst src rep -- )
+M: x86 %sqrt-vector-reps
{
- { float-4-rep [ [ MOVAPS ] [ HADDPS ] [ HADDPS ] 2tri ] }
- { double-2-rep [ [ MOVAPD ] [ HADDPD ] 2bi ] }
- } case ;
+ { sse? { float-4-rep } }
+ { sse2? { double-2-rep } }
+ } available-reps ;
+
+M: x86 %and-vector ( dst src1 src2 rep -- )
+ {
+ { float-4-rep [ ANDPS ] }
+ { double-2-rep [ ANDPD ] }
+ [ drop PAND ]
+ } case drop ;
+
+M: x86 %and-vector-reps
+ {
+ { sse? { float-4-rep } }
+ { sse2? { double-2-rep char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep } }
+ } available-reps ;
+
+M: x86 %or-vector ( dst src1 src2 rep -- )
+ {
+ { float-4-rep [ ORPS ] }
+ { double-2-rep [ ORPD ] }
+ [ drop POR ]
+ } case drop ;
+
+M: x86 %or-vector-reps
+ {
+ { sse? { float-4-rep } }
+ { sse2? { double-2-rep char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep } }
+ } available-reps ;
+
+M: x86 %xor-vector ( dst src1 src2 rep -- )
+ {
+ { float-4-rep [ XORPS ] }
+ { double-2-rep [ XORPD ] }
+ [ drop PXOR ]
+ } case drop ;
+
+M: x86 %xor-vector-reps
+ {
+ { sse? { float-4-rep } }
+ { sse2? { double-2-rep char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep } }
+ } available-reps ;
M: x86 %unbox-alien ( dst src -- )
alien-offset [+] MOV ;
[ quot call ] with-save/restore
] if ; inline
-: ?MOV ( dst src -- )
- 2dup = [ 2drop ] [ MOV ] if ; inline
-
M:: x86 %string-nth ( dst src index temp -- )
! We request a small-reg of size 8 since those of size 16 are
! a superset.
! Compute code point
new-dst temp XOR
"end" resolve-label
- dst new-dst ?MOV
+ dst new-dst int-rep copy-register
] with-small-register ;
M:: x86 %set-string-nth-fast ( ch str index temp -- )
ch { index str temp } 8 [| new-ch |
- new-ch ch ?MOV
+ new-ch ch int-rep copy-register
temp str index [+] LEA
temp string-offset [+] new-ch 8-bit-version-of MOV
] with-small-register ;
dst { src } size [| new-dst |
new-dst dup size n-bit-version-of dup src [] MOV
quot call
- dst new-dst ?MOV
+ dst new-dst int-rep copy-register
] with-small-register ; inline
: %alien-unsigned-getter ( dst src size -- )
:: %alien-integer-setter ( ptr value size -- )
value { ptr } size [| new-value |
- new-value value ?MOV
+ new-value value int-rep copy-register
ptr [] new-value size n-bit-version-of MOV
] with-small-register ; inline
M: x86 %shr [ SHR ] emit-shift ;
M: x86 %sar [ SAR ] emit-shift ;
+M: x86 %vm-field-ptr ( dst field -- )
+ [ drop 0 MOV rc-absolute-cell rt-vm rel-fixup ]
+ [ vm-field-offset ADD ] 2bi ;
+
: load-zone-ptr ( reg -- )
#! Load pointer to start of zone array
- 0 MOV "nursery" f rc-absolute-cell rel-dlsym ;
+ "nursery" %vm-field-ptr ;
: load-allot-ptr ( nursery-ptr allot-ptr -- )
[ drop load-zone-ptr ] [ swap cell [+] MOV ] 2bi ;
dst class store-tagged
nursery-ptr size inc-allot-ptr ;
+
M:: x86 %write-barrier ( src card# table -- )
#! Mark the card pointed to by vreg.
! Mark the card
card# src MOV
card# card-bits SHR
- table "cards_offset" f %alien-global
+ table "cards_offset" %vm-field-ptr
table table [] MOV
table card# [+] card-mark <byte> MOV
! Mark the card deck
card# deck-bits card-bits - SHR
- table "decks_offset" f %alien-global
+ table "decks_offset" %vm-field-ptr
table table [] MOV
table card# [+] card-mark <byte> MOV ;
! Pass number of roots as second parameter
param-reg-2 gc-root-count MOV
! Call GC
- "inline_gc" f %alien-invoke ;
+ "inline_gc" %vm-invoke-3rd-arg ;
-M: x86 %alien-global
- [ 0 MOV ] 2dip rc-absolute-cell rel-dlsym ;
+M: x86 %alien-global ( dst symbol library -- )
+ [ 0 MOV ] 2dip rc-absolute-cell rel-dlsym ;
M: x86 %epilogue ( n -- ) cell - incr-stack-reg ;
#! Save Factor stack pointers in case the C code calls a
#! callback which does a GC, which must reliably trace
#! all roots.
- temp1 "stack_chain" f %alien-global
- temp1 temp1 [] MOV
+ temp1 0 MOV rc-absolute-cell rt-vm rel-fixup
+ temp1 temp1 "stack_chain" vm-field-offset [+] MOV
temp2 stack-reg cell neg [+] LEA
temp1 [] temp2 MOV
callback-allowed? [
#! set up by the caller.
stack-frame get total-size>> + stack@ ;
-: enable-sse2 ( -- )
- enable-float-intrinsics
- enable-fsqrt
- enable-float-min/max
- enable-sse2-simd ;
+enable-simd
+enable-min/max
+enable-fixnum-log2
-: enable-sse3 ( -- )
- enable-sse2
- enable-sse3-simd ;
+:: install-sse2-check ( -- )
+ [
+ sse-version 20 < [
+ "This image was built to use SSE2 but your CPU does not support it." print
+ "You will need to bootstrap Factor again." print
+ flush
+ 1 exit
+ ] when
+ ] "cpu.x86" add-init-hook ;
+
+: enable-sse2 ( version -- )
+ 20 >= [
+ enable-float-intrinsics
+ enable-fsqrt
+ enable-float-min/max
+ install-sse2-check
+ ] when ;
-enable-min/max
+: check-sse ( -- )
+ [ { sse_version } compile ] with-optimizer
+ "Checking for multimedia extensions: " write sse-version
+ [ sse-string write " detected" print ] [ enable-sse2 ] bi ;
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: classes kernel help.markup help.syntax sequences
-alien assocs strings math multiline quotations db.private ;
+alien assocs strings math quotations db.private ;
IN: db
HELP: db-connection
{ $subsection sql-query }
"Here's an example usage where we'll make a book table, insert some objects, and query them." $nl
"First, let's set up a custom combinator for using our database. See " { $link "db-custom-database-combinators" } " for more details."
-{ $code <"
-USING: db.sqlite db io.files ;
+{ $code """
+USING: db.sqlite db io.files io.files.temp ;
: with-book-db ( quot -- )
- "book.db" temp-file <sqlite-db> swap with-db ; inline"> }
+ "book.db" temp-file <sqlite-db> swap with-db ; inline" }
"Now let's create the table manually:"
-{ $code <" "create table books
+{ $code " "create table books
(id integer primary key, title text, author text, date_published timestamp,
edition integer, cover_price double, condition text)"
- [ sql-command ] with-book-db" "> }
+ [ sql-command ] with-book-db""" }
"Time to insert some books:"
-{ $code <"
+{ $code """
"insert into books
(title, author, date_published, edition, cover_price, condition)
values('Factor for Sheeple', 'Mister Stacky Pants', date('now'), 1, 13.37, 'mint')"
-[ sql-command ] with-book-db"> }
+[ sql-command ] with-book-db""" }
"Now let's select the book:"
-{ $code <"
-"select id, title, cover_price from books;" [ sql-query ] with-book-db "> }
+{ $code """
+"select id, title, cover_price from books;" [ sql-query ] with-book-db""" }
"Notice that the result of this query is a Factor array containing the database rows as arrays of strings. We would have to convert the " { $snippet "cover_price" } " from a string to a number in order to use it in a calculation." $nl
"In conclusion, this method of accessing a database is supported, but it is fairly low-level and generally specific to a single database. The " { $vocab-link "db.tuples" } " vocabulary is a good alternative to writing SQL by hand." ;
"Make a " { $snippet "with-" } " combinator to open and close a database so that resources are not leaked." $nl
"SQLite example combinator:"
-{ $code <"
+{ $code """
USING: db.sqlite db io.files io.files.temp ;
: with-sqlite-db ( quot -- )
- "my-database.db" temp-file <sqlite-db> swap with-db ; inline"> }
+ "my-database.db" temp-file <sqlite-db> swap with-db ; inline""" }
"PostgreSQL example combinator:"
-{ $code <" USING: db.postgresql db ;
+{ $code """USING: db.postgresql db ;
: with-postgresql-db ( quot -- )
<postgresql-db>
"localhost" >>host
"erg" >>username
"secrets?" >>password
"factor-test" >>database
- swap with-db ; inline">
+ swap with-db ; inline"""
} ;
ABOUT: "db"
! See http://factorcode.org/license.txt for BSD license.
USING: arrays continuations db io kernel math namespaces
quotations sequences db.postgresql.ffi alien alien.c-types
-db.types tools.walker ascii splitting math.parser combinators
-libc calendar.format byte-arrays destructors prettyprint
-accessors strings serialize io.encodings.binary io.encodings.utf8
-alien.strings io.streams.byte-array summary present urls
-specialized-arrays db.private ;
+alien.data db.types tools.walker ascii splitting math.parser
+combinators libc calendar.format byte-arrays destructors
+prettyprint accessors strings serialize io.encodings.binary
+io.encodings.utf8 alien.strings io.streams.byte-array summary
+present urls specialized-arrays db.private ;
SPECIALIZED-ARRAY: uint
SPECIALIZED-ARRAY: void*
IN: db.postgresql.lib
! Copyright (C) 2008 Chris Double, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.c-types arrays assocs kernel math math.parser
+USING: alien.c-types alien.data arrays assocs kernel math math.parser
namespaces sequences db.sqlite.ffi db combinators
continuations db.types calendar.format serialize
io.streams.byte-array byte-arrays io.encodings.binary
db.sqlite.lib db.sqlite.ffi db.tuples words db.types combinators
math.intervals io nmake accessors vectors math.ranges random
math.bitwise db.queries destructors db.tuples.private interpolate
-io.streams.string multiline make db.private sequences.deep
+io.streams.string make db.private sequences.deep
db.errors.sqlite ;
IN: db.sqlite
: insert-trigger ( -- string )
[
- <"
+ """
CREATE TRIGGER fki_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id
BEFORE INSERT ON ${table-name}
FOR EACH ROW BEGIN
SELECT RAISE(ROLLBACK, 'insert on table "${table-name}" violates foreign key constraint "fki_${table-name}_$table-id}_${foreign-table-name}_${foreign-table-id}_id"')
WHERE (SELECT ${foreign-table-id} FROM ${foreign-table-name} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
END;
- "> interpolate
+ """ interpolate
] with-string-writer ;
: insert-trigger-not-null ( -- string )
[
- <"
+ """
CREATE TRIGGER fki_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id
BEFORE INSERT ON ${table-name}
FOR EACH ROW BEGIN
WHERE NEW.${table-id} IS NOT NULL
AND (SELECT ${foreign-table-id} FROM ${foreign-table-name} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
END;
- "> interpolate
+ """ interpolate
] with-string-writer ;
: update-trigger ( -- string )
[
- <"
+ """
CREATE TRIGGER fku_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id
BEFORE UPDATE ON ${table-name}
FOR EACH ROW BEGIN
SELECT RAISE(ROLLBACK, 'update on table "${table-name}" violates foreign key constraint "fku_${table-name}_$table-id}_${foreign-table-name}_${foreign-table-id}_id"')
WHERE (SELECT ${foreign-table-id} FROM ${foreign-table-name} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
END;
- "> interpolate
+ """ interpolate
] with-string-writer ;
: update-trigger-not-null ( -- string )
[
- <"
+ """
CREATE TRIGGER fku_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id
BEFORE UPDATE ON ${table-name}
FOR EACH ROW BEGIN
WHERE NEW.${table-id} IS NOT NULL
AND (SELECT ${foreign-table-id} FROM ${foreign-table-name} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
END;
- "> interpolate
+ """ interpolate
] with-string-writer ;
: delete-trigger-restrict ( -- string )
[
- <"
+ """
CREATE TRIGGER fkd_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id
BEFORE DELETE ON ${foreign-table-name}
FOR EACH ROW BEGIN
SELECT RAISE(ROLLBACK, 'delete on table "${foreign-table-name}" violates foreign key constraint "fkd_${table-name}_$table-id}_${foreign-table-name}_${foreign-table-id}_id"')
WHERE (SELECT ${foreign-table-id} FROM ${foreign-table-name} WHERE ${foreign-table-id} = OLD.${foreign-table-id}) IS NOT NULL;
END;
- "> interpolate
+ """ interpolate
] with-string-writer ;
: delete-trigger-cascade ( -- string )
[
- <"
+ """
CREATE TRIGGER fkd_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id
BEFORE DELETE ON ${foreign-table-name}
FOR EACH ROW BEGIN
DELETE from ${table-name} WHERE ${table-id} = OLD.${foreign-table-id};
END;
- "> interpolate
+ """ interpolate
] with-string-writer ;
: can-be-null? ( -- ? )
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: classes help.markup help.syntax io.streams.string kernel
-quotations sequences strings multiline math db.types
-db.tuples.private db ;
+quotations sequences strings math db.types db.tuples.private db ;
IN: db.tuples
HELP: random-id-generator
"The title, author, and publisher should be strings; the date-published a timestamp; the edition an integer; the cover-price a float. These are the Factor types for which we will need to look up the corresponding " { $link "db.types" } ". " $nl
"To actually bind the tuple slots to the database types, we'll use " { $link define-persistent } "."
{ $code
-<" USING: db.tuples db.types ;
+"""USING: db.tuples db.types ;
book "BOOK"
{
{ "id" "ID" +db-assigned-id+ }
{ "edition" "EDITION" INTEGER }
{ "cover-price" "COVER_PRICE" DOUBLE }
{ "condition" "CONDITION" VARCHAR }
-} define-persistent "> }
+} define-persistent""" }
"That's all we'll have to do with the database for this tutorial. Now let's make a book."
-{ $code <" USING: calendar namespaces ;
+{ $code """USING: calendar namespaces ;
T{ book
{ title "Factor for Sheeple" }
{ author "Mister Stacky Pants" }
{ edition 1 }
{ cover-price 13.37 }
} book set
-"> }
+""" }
"Now we've created a book. Let's save it to the database."
-{ $code <" USING: db db.sqlite fry io.files ;
+{ $code """USING: db db.sqlite fry io.files ;
: with-book-tutorial ( quot -- )
'[ "book-tutorial.db" temp-file <sqlite-db> _ with-db ] call ;
book recreate-table
book get insert-tuple
] with-book-tutorial
-"> }
+""" }
"Is it really there?"
-{ $code <" [
+{ $code """[
T{ book { title "Factor for Sheeple" } } select-tuples .
-] with-book-tutorial "> }
+] with-book-tutorial""" }
"Oops, we spilled some orange juice on the book cover."
-{ $code <" book get "Small orange juice stain on cover" >>condition "> }
+{ $code """book get "Small orange juice stain on cover" >>condition""" }
"Now let's save the modified book."
-{ $code <" [
+{ $code """[
book get update-tuple
-] with-book-tutorial "> }
+] with-book-tutorial""" }
"And select it again. You can query the database by any field -- just set it in the exemplar tuple you pass to " { $link select-tuples } "."
-{ $code <" [
+{ $code """[
T{ book { title "Factor for Sheeple" } } select-tuples
-] with-book-tutorial "> }
+] with-book-tutorial""" }
"Let's drop the table because we're done."
-{ $code <" [
+{ $code """[
book drop-table
-] with-book-tutorial "> }
+] with-book-tutorial""" }
"To summarize, the steps for using Factor's tuple database are:"
{ $list
"Make a new tuple to represent your data"
M: bad-slot-value summary drop "Bad store to specialized slot" ;
+M: bad-slot-name summary drop "Bad slot name in object literal" ;
+
M: no-math-method summary
drop "No suitable arithmetic method" ;
M: bad-effect summary
drop "Bad stack effect declaration" ;
-M: bad-escape summary drop "Bad escape code" ;
+M: bad-escape error.
+ "Bad escape code: \\" write
+ char>> 1string print ;
M: bad-literal-tuple summary drop "Bad literal tuple" ;
! Replacing a method definition with a consultation would cause problems
[ [ ] ] [
- <" IN: delegate.tests
+ "IN: delegate.tests
USE: kernel
- M: a-tuple do-me drop ; "> <string-reader> "delegate-test" parse-stream
+ M: a-tuple do-me drop ;" <string-reader> "delegate-test" parse-stream
] unit-test
[ ] [ T{ a-tuple } do-me ] unit-test
! Change method definition to consultation
[ [ ] ] [
- <" IN: delegate.tests
+ "IN: delegate.tests
USE: kernel
USE: delegate
- CONSULT: silly-protocol a-tuple drop f ; "> <string-reader> "delegate-test" parse-stream
+ CONSULT: silly-protocol a-tuple drop f ; " <string-reader> "delegate-test" parse-stream
] unit-test
! Method should be there
! Now try removing the consulation
[ [ ] ] [
- <" IN: delegate.tests "> <string-reader> "delegate-test" parse-stream
+ "IN: delegate.tests" <string-reader> "delegate-test" parse-stream
] unit-test
! Method should be gone
[ f ] [ \ slot-protocol-test-3 \ y>> method >boolean ] unit-test
[ [ ] ] [
- <" IN: delegate.tests
+ "IN: delegate.tests
USING: accessors delegate ;
TUPLE: slot-protocol-test-3 x ;
-CONSULT: y>> slot-protocol-test-3 x>> ;">
+CONSULT: y>> slot-protocol-test-3 x>> ;"
<string-reader> "delegate-test-1" parse-stream
] unit-test
[ t ] [ \ slot-protocol-test-3 \ y>> method >boolean ] unit-test
[ [ ] ] [
- <" IN: delegate.tests
-TUPLE: slot-protocol-test-3 x y ;">
+ "IN: delegate.tests
+TUPLE: slot-protocol-test-3 x y ;"
<string-reader> "delegate-test-1" parse-stream
] unit-test
! We want to be able to override methods after consultation
[ [ ] ] [
- <" IN: delegate.tests
+ "IN: delegate.tests
USING: delegate kernel sequences delegate.protocols accessors ;
TUPLE: override-method-test seq ;
CONSULT: sequence-protocol override-method-test seq>> ;
- M: override-method-test like drop ; ">
+ M: override-method-test like drop ; "
<string-reader> "delegate-test-2" parse-stream
] unit-test
! See if removing a consultation updates protocol-consult word prop
[ [ ] ] [
- <" IN: delegate.tests
+ "IN: delegate.tests
USING: accessors delegate delegate.protocols ;
TUPLE: seq-delegate seq ;
- CONSULT: sequence-protocol seq-delegate seq>> ;">
+ CONSULT: sequence-protocol seq-delegate seq>> ;"
<string-reader> "remove-consult-test" parse-stream
] unit-test
] unit-test
[ [ ] ] [
- <" IN: delegate.tests
+ "IN: delegate.tests
USING: delegate delegate.protocols ;
- TUPLE: seq-delegate seq ;">
+ TUPLE: seq-delegate seq ;"
<string-reader> "remove-consult-test" parse-stream
] unit-test
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test namespaces documents documents.elements multiline ;
+USING: tools.test namespaces documents documents.elements ;
IN: document.elements.tests
SYMBOL: doc
! page-elt
<document> doc set
-<" First line
+"First line
Second line
Third line
Fourth line
Fifth line
-Sixth line"> doc get set-doc-string
+Sixth line" doc get set-doc-string
[ { 0 0 } ] [ { 3 3 } doc get 4 <page-elt> prev-elt ] unit-test
[ { 1 2 } ] [ { 5 2 } doc get 4 <page-elt> prev-elt ] unit-test
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.c-types alien.strings alien.syntax kernel
-layouts sequences system unix environment io.encodings.utf8
-unix.utilities vocabs.loader combinators alien.accessors ;
+USING: alien alien.c-types alien.data alien.strings
+alien.syntax kernel layouts sequences system unix
+environment io.encodings.utf8 unix.utilities vocabs.loader
+combinators alien.accessors ;
IN: environment.unix
HOOK: environ os ( -- void* )
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.strings fry io.encodings.utf16n kernel
-splitting windows windows.kernel32 system environment
-alien.c-types sequences windows.errors io.streams.memory
-io.encodings io ;
+splitting windows windows.kernel32 windows.types system
+environment alien.data sequences windows.errors
+io.streams.memory io.encodings io specialized-arrays ;
+SPECIALIZED-ARRAY: TCHAR
IN: environment.winnt
-<< "TCHAR" require-c-array >>
-
M: winnt os-env ( key -- value )
- MAX_UNICODE_PATH "TCHAR" <c-array>
+ MAX_UNICODE_PATH TCHAR <c-array>
[ dup length GetEnvironmentVariable ] keep over 0 = [
2drop f
] [
USING: classes.struct functors tools.test math words kernel
multiline parser io.streams.string generic ;
+QUALIFIED-WITH: alien.c-types c
IN: functors.tests
<<
! Does replacing an ordinary word with a functor-generated one work?
[ [ ] ] [
- <" IN: functors.tests
+ "IN: functors.tests
TUPLE: some-tuple ;
: some-word ( -- ) ;
GENERIC: some-generic ( a -- b )
M: some-tuple some-generic ;
- SYMBOL: some-symbol
- "> <string-reader> "functors-test" parse-stream
+ SYMBOL: some-symbol" <string-reader> "functors-test" parse-stream
] unit-test
: test-redefinition ( -- )
;FUNCTOR
[ [ ] ] [
- <" IN: functors.tests
- << "some" redefine-test >>
- "> <string-reader> "functors-test" parse-stream
+ """IN: functors.tests
+ << "some" redefine-test >>""" <string-reader> "functors-test" parse-stream
] unit-test
test-redefinition
WHERE
STRUCT: T-class
- { NAME int }
+ { NAME c:int }
{ x { TYPE 4 } }
- { y { "short" N } }
+ { y { c:short N } }
{ z TYPE initial: 5 }
- { float { "float" 2 } } ;
+ { float { c:float 2 } } ;
;FUNCTOR
-"a-struct" "nemo" "char" 2 define-a-struct
+"a-struct" "nemo" c:char 2 define-a-struct
>>
{ offset 0 }
{ class integer }
{ initial 0 }
- { c-type "int" }
+ { type c:int }
}
T{ struct-slot-spec
{ name "x" }
{ offset 4 }
{ class object }
{ initial f }
- { c-type { "char" 4 } }
+ { type { c:char 4 } }
}
T{ struct-slot-spec
{ name "y" }
{ offset 8 }
{ class object }
{ initial f }
- { c-type { "short" 2 } }
+ { type { c:short 2 } }
}
T{ struct-slot-spec
{ name "z" }
{ offset 12 }
{ class fixnum }
{ initial 5 }
- { c-type "char" }
+ { type c:char }
}
T{ struct-slot-spec
{ name "float" }
{ offset 16 }
{ class object }
{ initial f }
- { c-type { "float" 2 } }
+ { type { c:float 2 } }
}
}
] [ a-struct struct-slots ] unit-test
USING: assocs classes help.markup help.syntax io.streams.string
http http.server.dispatchers http.server.responses
-furnace.redirection strings multiline html.forms ;
+furnace.redirection strings html.forms ;
IN: furnace.actions
HELP: <action>
{ $examples
"A simple validator from " { $vocab-link "webapps.todo" } "; this word is invoked from the " { $slot "validate" } " quotation of action for editing a todo list item:"
{ $code
- <" : validate-todo ( -- )
+ """: validate-todo ( -- )
{
{ "summary" [ v-one-line ] }
{ "priority" [ v-integer 0 v-min-value 10 v-max-value ] }
{ "description" [ v-required ] }
- } validate-params ;">
+ } validate-params ;"""
}
} ;
+USING: help.markup help.syntax db ;
IN: furnace.alloy
-USING: help.markup help.syntax db multiline ;
HELP: init-furnace-tables
{ $description "Initializes database tables used by asides, conversations and session management. This word must be invoked inside a " { $link with-db } " scope." } ;
{ $examples
"The " { $vocab-link "webapps.counter" } " vocabulary uses an alloy to configure the counter:"
{ $code
- <" : counter-db ( -- db ) "counter.db" <sqlite-db> ;
+ """: counter-db ( -- db ) "counter.db" <sqlite-db> ;
: run-counter ( -- )
<counter-app>
counter-db <alloy>
main-responder set-global
- 8080 httpd ;">
+ 8080 httpd ;"""
}
} ;
USING: assocs classes help.markup help.syntax kernel
quotations strings words words.symbol furnace.auth.providers.db
checksums.sha furnace.auth.providers math byte-arrays
-http multiline ;
+http ;
IN: furnace.auth
HELP: <protected>
ARTICLE: "furnace.auth.example" "Furnace authentication example"
"The " { $vocab-link "webapps.todo" } " vocabulary wraps all of its responders in a protected responder. The " { $slot "description" } " slot is set so that the login page contains the message “You must log in to view your todo list”:"
{ $code
- "view your todo list" >>description">
+ "view your todo list" >>description"""
}
"The " { $vocab-link "webapps.wiki" } " vocabulary defines a mix of protected and unprotected actions. One example of a protected action is that for deleting wiki pages, an action normally reserved for administrators. This action is protected with the following code:"
{ $code
"delete wiki articles" >>description
- { can-delete-wiki-articles? } >>capabilities">
+ { can-delete-wiki-articles? } >>capabilities"""
}
"The " { $vocab-link "websites.concatenative" } " vocabulary wraps all of its responders, including the wiki, in a login authentication realm:"
{ $code
-<" : <login-config> ( responder -- responder' )
+""": <login-config> ( responder -- responder' )
"Factor website" <login-realm>
"Factor website" >>name
allow-registration
allow-password-recovery
allow-edit-profile
- allow-deactivation ;">
+ allow-deactivation ;"""
} ;
ARTICLE: "furnace.auth" "Furnace authentication"
--- /dev/null
+Doug Coleman
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors db.sqlite furnace.actions furnace.alloy
+furnace.conversations furnace.recaptcha furnace.redirection
+html.templates.chloe.compiler http.server
+http.server.dispatchers http.server.responses io.streams.string
+kernel urls xml.syntax ;
+IN: furnace.recaptcha.example
+
+TUPLE: recaptcha-app < dispatcher recaptcha ;
+
+: recaptcha-db ( -- obj ) "recaptcha-example" <sqlite-db> ;
+
+: <recaptcha-challenge> ( -- obj )
+ <page-action>
+ [
+ begin-conversation
+ validate-recaptcha
+ recaptcha-valid? cget
+ "?good" "?bad" ? >url <continue-conversation>
+ ] >>submit
+ { recaptcha-app "example" } >>template ;
+
+: <recaptcha-app> ( -- obj )
+ \ recaptcha-app new-dispatcher
+ <recaptcha-challenge> "" add-responder
+ <recaptcha>
+ "concatenative.org" >>domain
+ "6LeJWQgAAAAAAFlYV7SuBClE9uSpGtV_ZS-qVON7" >>public-key
+ "6LeJWQgAAAAAALh-XJgSSQ6xKygRgJ8-029Ip2Xv" >>private-key
+ recaptcha-db <alloy> ;
--- /dev/null
+<?xml version='1.0' ?>
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+<html><body><form submit="" method="post"><t:recaptcha/></form></body></html>
+</t:chloe>
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax http.server.filters kernel
+multiline furnace.actions furnace.alloy furnace.conversations ;
+IN: furnace.recaptcha
+
+HELP: <recaptcha>
+{ $values
+ { "responder" "a responder" }
+ { "obj" object }
+}
+{ $description "A " { $link filter-responder } " wrapping another responder. Set the domain, public, and private keys using the key you get by registering with Recaptcha." } ;
+
+HELP: recaptcha-error
+{ $var-description "Set to the error string returned by the Recaptcha server." } ;
+
+HELP: recaptcha-valid?
+{ $var-description "Set to " { $link t } " if the user solved the last Recaptcha correctly." } ;
+
+HELP: validate-recaptcha
+{ $description "Validates a Recaptcha using the Recaptcha web service API." } ;
+
+ARTICLE: "recaptcha-example" "Recaptcha example"
+"There are several steps to using the Recaptcha library."
+{ $list
+ { "Wrap the responder in a " { $link <recaptcha> } }
+ { "Wrap the responder in a " { $link <conversations> } " if it is not already" }
+ { "Ensure that there is a database connected, with the " { $link <alloy> } " word" }
+ { "Start a conversation to move values between requests" }
+ { "Add a handler calling " { $link validate-recaptcha } " in the " { $slot "submit" } " of the " { $link page-action } }
+ { "Pass the conversation from your submit action using " { $link <continue-conversation> } }
+ { "Put the chloe tag " { $snippet "<recaptcha/>" } " inside a form tag in the template for your " { $link page-action } }
+}
+$nl
+"Run this example vocabulary:"
+{ $code
+ "USE: furnace.recaptcha.example"
+ "<recaptcha-app> main-responder set-global"
+} ;
+
+ARTICLE: "furnace.recaptcha" "Recaptcha"
+"The " { $vocab-link "furnace.recaptcha" } " vocabulary implements support for the Recaptcha. Recaptcha is a web service that provides the user with a captcha, a test that is easy to solve by visual inspection, but hard to solve by writing a computer program. Use a captcha to protect forms from abusive users." $nl
+
+"The recaptcha responder is a " { $link filter-responder } " that wraps another responder. Set the " { $slot "domain" } ", " { $slot "public-key" } ", and " { $slot "private-key" } " slots of this responder to your Recaptcha account information." $nl
+
+"Wrapping a responder with Recaptcha:"
+{ $subsection <recaptcha> }
+"Validating recaptcha:"
+{ $subsection validate-recaptcha }
+"Symbols set after validation:"
+{ $subsection recaptcha-valid? }
+{ $subsection recaptcha-error }
+{ $subsection "recaptcha-example" } ;
+
+ABOUT: "furnace.recaptcha"
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors furnace.actions furnace.redirection html.forms
+html.templates.chloe.compiler html.templates.chloe.syntax
+http.client http.server http.server.filters io.sockets kernel
+locals namespaces sequences splitting urls validators
+xml.syntax furnace.conversations ;
+IN: furnace.recaptcha
+
+TUPLE: recaptcha < filter-responder domain public-key private-key ;
+
+SYMBOLS: recaptcha-valid? recaptcha-error ;
+
+: <recaptcha> ( responder -- obj )
+ recaptcha new
+ swap >>responder ;
+
+M: recaptcha call-responder*
+ dup \ recaptcha set
+ responder>> call-responder ;
+
+<PRIVATE
+
+: (render-recaptcha) ( private-key -- xml )
+ dup
+[XML <script type="text/javascript"
+ src=<->>
+</script>
+
+<noscript>
+ <iframe src=<->
+ height="300" width="500" frameborder="0"></iframe><br/>
+ <textarea name="recaptcha_challenge_field" rows="3" cols="40">
+ </textarea>
+ <input type="hidden" name="recaptcha_response_field"
+ value="manual_challenge"/>
+</noscript>
+XML] ;
+
+: recaptcha-url ( secure? -- ? )
+ [ "https://api.recaptcha.net/challenge" ]
+ [ "http://api.recaptcha.net/challenge" ] if
+ recaptcha-error cget [ "?error=" glue ] when* >url ;
+
+: render-recaptcha ( -- xml )
+ secure-connection? recaptcha-url
+ recaptcha get public-key>> "k" set-query-param (render-recaptcha) ;
+
+: parse-recaptcha-response ( string -- valid? error )
+ "\n" split first2 [ "true" = ] dip ;
+
+:: (validate-recaptcha) ( challenge response recaptcha -- valid? error )
+ recaptcha private-key>> :> private-key
+ remote-address get host>> :> remote-ip
+ H{
+ { "challenge" challenge }
+ { "response" response }
+ { "privatekey" private-key }
+ { "remoteip" remote-ip }
+ } URL" http://api-verify.recaptcha.net/verify"
+ <post-request> http-request nip parse-recaptcha-response ;
+
+CHLOE: recaptcha
+ drop [ render-recaptcha ] [xml-code] ;
+
+PRIVATE>
+
+: validate-recaptcha ( -- )
+ {
+ { "recaptcha_challenge_field" [ v-required ] }
+ { "recaptcha_response_field" [ v-required ] }
+ } validate-params
+ "recaptcha_challenge_field" value
+ "recaptcha_response_field" value
+ \ recaptcha get (validate-recaptcha)
+ [ recaptcha-valid? cset ] [ recaptcha-error cset ] bi* ;
--- /dev/null
+<?xml version='1.0' ?>
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+<html>
+ <body><t:recaptcha/>
+ </body>
+</html>
+</t:chloe>
--- /dev/null
+Recaptcha library
specialized-arrays ui.backend.windows vectors windows.com
windows.dinput windows.dinput.constants windows.errors
windows.kernel32 windows.messages windows.ole32
-windows.user32 classes.struct ;
+windows.user32 classes.struct alien.data ;
SPECIALIZED-ARRAY: DIDEVICEOBJECTDATA
IN: game-input.dinput
[ device-attached? not ] filter
[ remove-controller ] each ;
-: device-interface? ( dbt-broadcast-hdr -- ? )
- dbch_devicetype>> DBT_DEVTYP_DEVICEINTERFACE = ;
+: ?device-interface ( dbt-broadcast-hdr -- ? )
+ dup dbch_devicetype>> DBT_DEVTYP_DEVICEINTERFACE =
+ [ >c-ptr DEV_BROADCAST_DEVICEW memory>struct ]
+ [ drop f ] if ; inline
: device-arrived ( dbt-broadcast-hdr -- )
- device-interface? [ find-controllers ] when ;
+ ?device-interface [ find-controllers ] when ; inline
: device-removed ( dbt-broadcast-hdr -- )
- device-interface? [ find-and-remove-detached-devices ] when ;
+ ?device-interface [ find-and-remove-detached-devices ] when ; inline
+
+: <DEV_BROADCAST_HDR> ( wParam -- struct )
+ <alien> DEV_BROADCAST_HDR memory>struct ;
: handle-wm-devicechange ( hWnd uMsg wParam lParam -- )
[ 2drop ] 2dip swap {
- { [ dup DBT_DEVICEARRIVAL = ] [ drop <alien> device-arrived ] }
- { [ dup DBT_DEVICEREMOVECOMPLETE = ] [ drop <alien> device-removed ] }
+ { [ dup DBT_DEVICEARRIVAL = ] [ drop <DEV_BROADCAST_HDR> device-arrived ] }
+ { [ dup DBT_DEVICEREMOVECOMPLETE = ] [ drop <DEV_BROADCAST_HDR> device-removed ] }
[ 2drop ]
} cond ;
-USING: sequences sequences.private math alien.c-types
-accessors ;
+USING: sequences sequences.private math
+accessors alien.data ;
IN: game-input.dinput.keys-array
TUPLE: keys-array
sequences locals combinators.short-circuit threads
namespaces assocs arrays combinators hints alien
core-foundation.run-loop accessors sequences.private
-alien.c-types math parser game-input vectors bit-arrays ;
+alien.c-types alien.data math parser game-input vectors
+bit-arrays ;
IN: game-input.iokit
SINGLETON: iokit-game-input-backend
USING: help.markup help.syntax io kernel math parser
prettyprint sequences vocabs.loader namespaces stack-checker
-help command-line multiline see ;
+help command-line see ;
IN: help.cookbook
ARTICLE: "cookbook-syntax" "Basic syntax cookbook"
{ $heading "Example: ls" }
"Here is an example implementing a simplified version of the Unix " { $snippet "ls" } " command in Factor:"
{ $code
- <" USING: command-line namespaces io io.files
+ """USING: command-line namespaces io io.files
io.pathnames tools.files sequences kernel ;
command-line get [
dup length 1 = [ first directory. ] [
[ [ nl write ":" print ] [ directory. ] bi ] each
] if
-] if-empty">
+] if-empty"""
}
"You can put it in a file named " { $snippet "ls.factor" } ", and then run it, to list the " { $snippet "/usr/bin" } " directory for example:"
{ $code "./factor ls.factor /usr/bin" }
{ $heading "Example: grep" }
"The following is a more complicated example, implementing something like the Unix " { $snippet "grep" } " command:"
-{ $code <" USING: kernel fry io io.files io.encodings.ascii sequences
+{ $code """USING: kernel fry io io.files io.encodings.ascii sequences
regexp command-line namespaces ;
IN: grep
] [
[ grep-file ] with each
] if-empty
-] if-empty"> }
+] if-empty""" }
"You can run it like so,"
{ $code "./factor grep.factor '.*hello.*' myfile.txt" }
"You'll notice this script takes a while to start. This is because it is loading and compiling the " { $vocab-link "regexp" } " vocabulary every time. To speed up startup, load the vocabulary into your image, and save the image:"
-USING: help.html tools.test help.topics kernel ;
+USING: help.html tools.test help.topics kernel sequences vocabs ;
IN: help.html.tests
[ ] [ "xml" >link help>html drop ] unit-test
[ "article-foobar.html" ] [ "foobar" >link topic>filename ] unit-test
+
+[ t ] [ all-vocabs-really [ vocab-spec? ] all? ] unit-test
+
+[ t ] [ all-vocabs-really [ vocab-name "sequences.private" = ] any? ] unit-test
+
+[ f ] [ all-vocabs-really [ vocab-name "scratchpad" = ] any? ] unit-test
dup topic>filename utf8 [ help>html write-xml ] with-file-writer ;
: all-vocabs-really ( -- seq )
- all-vocabs-recursive >hashtable f over delete-at no-roots remove-redundant-prefixes ;
+ all-vocabs-recursive >hashtable no-roots remove-redundant-prefixes
+ [ vocab-name "scratchpad" = not ] filter ;
: all-topics ( -- topics )
[
{ $description "Compiles code which pushes an attribute value previously extracted by " { $link required-attr } " or " { $link optional-attr } " on the stack. If the attribute value begins with " { $snippet "@" } ", compiles into code which pushes the a form value." } ;
HELP: CHLOE:
-{ $syntax "name definition... ;" }
+{ $syntax "CHLOE: name definition... ;" }
{ $values { "name" "the tag name" } { "definition" { $quotation "( tag -- )" } } }
{ $description "Defines compilation semantics for the Chloe tag named " { $snippet "tag" } ". The definition body receives a " { $link tag } " on the stack." } ;
USING: io io.files io.streams.string io.encodings.utf8
-html.templates html.templates.fhtml kernel multiline
+html.templates html.templates.fhtml kernel
tools.test sequences parser splitting prettyprint ;
IN: html.templates.fhtml.tests
[
[ ] [
- <"
- <%
+ """<%
IN: html.templates.fhtml.tests
: test-word ( -- ) ;
- %>
- "> parse-template drop
+ %>""" parse-template drop
] unit-test
] with-file-vocabs
-USING: help.markup help.syntax http.server.static multiline ;
+USING: help.markup help.syntax http.server.static ;
IN: http.server.cgi
HELP: enable-cgi
{ $description "Enables the responder to serve " { $snippet ".cgi" } " scripts by executing them as per the CGI specification." }
{ $examples
{ $code
- <" <dispatcher>
- "/var/www/cgi/" <static> enable-cgi "cgi-bin" add-responder" ">
+ """<dispatcher>
+ "/var/www/cgi/" <static> enable-cgi "cgi-bin" add-responder"""
}
}
{ $side-effects "responder" } ;
-! Copyright (C) 2008 Your name.
+! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: classes help.markup help.syntax io.streams.string
-multiline ;
+USING: classes help.markup help.syntax io.streams.string ;
IN: http.server.dispatchers
HELP: new-dispatcher
ARTICLE: "http.server.dispatchers.example" "HTTP dispatcher examples"
{ $heading "Simple pathname dispatcher" }
{ $code
- <" <dispatcher>
+ """<dispatcher>
<new-action> "new" add-responder
<edit-action> "edit" add-responder
<delete-action> "delete" add-responder
<list-action> "" add-responder
-main-responder set-global">
+main-responder set-global"""
}
"In the above example, visiting any URL other than " { $snippet "/new" } ", " { $snippet "/edit" } ", " { $snippet "/delete" } ", or " { $snippet "/" } " will result in a 404 error."
{ $heading "Another pathname dispatcher" }
"On the other hand, suppose we wanted to route all unrecognized paths to a “view” action:"
{ $code
- <" <dispatcher>
+ """<dispatcher>
<new-action> "new" add-responder
<edit-action> "edit" add-responder
<delete-action> "delete" add-responder
<view-action> >>default
-main-responder set-global">
+main-responder set-global"""
}
"The " { $slot "default" } " slot holds a responder to which all unrecognized paths are sent to."
{ $heading "Dispatcher subclassing example" }
{ $code
- <" TUPLE: golf-courses < dispatcher ;
+ """TUPLE: golf-courses < dispatcher ;
: <golf-courses> ( -- golf-courses )
golf-courses new-dispatcher ;
<edit-action> "edit" add-responder
<delete-action> "delete" add-responder
<list-action> "" add-responder
-main-responder set-global">
+main-responder set-global"""
}
"The action templates can now emit links to responder-relative URLs prefixed by " { $snippet "$golf-courses/" } "."
{ $heading "Virtual hosting example" }
{ $code
- <" <vhost-dispatcher>
+ """<vhost-dispatcher>
<casino> "concatenative-casino.com" add-responder
<dating> "raptor-dating.com" add-responder
-main-responder set-global">
+main-responder set-global"""
}
"Note that the virtual host dispatcher strips off a " { $snippet "www." } " prefix, so " { $snippet "www.concatenative-casino.com" } " would be routed to the " { $snippet "<casino>" } " responder instead of receiving a 404." ;
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien.c-types destructors fry images kernel
-libc math sequences ;
+USING: accessors alien.c-types alien.data destructors fry images
+kernel libc math sequences ;
IN: images.memory
! Some code shared by core-graphics and cairo for constructing
: make-memory-bitmap ( dim quot -- image )
'[
[ malloc-bitmap-data ] keep _ [ <bitmap-image> ] 2bi
- ] with-destructors ; inline
\ No newline at end of file
+ ] with-destructors ; inline
H{ } describe
H{ } describe
-[ "fixnum instance\n\n" ] [ [ 3 describe ] with-string-writer ] unit-test
+[ "fixnum\n\n" ] [ [ 3 describe ] with-string-writer ] unit-test
[ ] [ H{ } clone inspect ] unit-test
-USING: alien alien.c-types alien.syntax arrays continuations\r
-destructors generic io.mmap io.ports io.backend.windows io.files.windows\r
-kernel libc math math.bitwise namespaces quotations sequences windows\r
-windows.advapi32 windows.kernel32 io.backend system accessors\r
-io.backend.windows.privileges windows.errors ;\r
-IN: io.backend.windows.nt.privileges\r
-\r
-TYPEDEF: TOKEN_PRIVILEGES* PTOKEN_PRIVILEGES\r
-\r
-! Security tokens\r
-! http://msdn.microsoft.com/msdnmag/issues/05/03/TokenPrivileges/\r
-\r
-: (open-process-token) ( handle -- handle )\r
- { TOKEN_ADJUST_PRIVILEGES TOKEN_QUERY } flags "PHANDLE" <c-object>\r
- [ OpenProcessToken win32-error=0/f ] keep *void* ;\r
-\r
-: open-process-token ( -- handle )\r
- #! remember to CloseHandle\r
- GetCurrentProcess (open-process-token) ;\r
-\r
-: with-process-token ( quot -- )\r
- #! quot: ( token-handle -- token-handle )\r
- [ open-process-token ] dip\r
- [ keep ] curry\r
- [ CloseHandle drop ] [ ] cleanup ; inline\r
-\r
-: lookup-privilege ( string -- luid )\r
- [ f ] dip "LUID" <c-object>\r
- [ LookupPrivilegeValue win32-error=0/f ] keep ;\r
-\r
-: make-token-privileges ( name ? -- obj )\r
- "TOKEN_PRIVILEGES" <c-object>\r
- 1 over set-TOKEN_PRIVILEGES-PrivilegeCount\r
- "LUID_AND_ATTRIBUTES" malloc-object &free\r
- over set-TOKEN_PRIVILEGES-Privileges\r
-\r
- swap [\r
- SE_PRIVILEGE_ENABLED over TOKEN_PRIVILEGES-Privileges\r
- set-LUID_AND_ATTRIBUTES-Attributes\r
- ] when\r
-\r
- [ lookup-privilege ] dip\r
- [\r
- TOKEN_PRIVILEGES-Privileges\r
- set-LUID_AND_ATTRIBUTES-Luid\r
- ] keep ;\r
-\r
-M: winnt set-privilege ( name ? -- )\r
- [\r
- -rot 0 -rot make-token-privileges\r
- dup length f f AdjustTokenPrivileges win32-error=0/f\r
- ] with-process-token ;\r
+USING: alien alien.c-types alien.data alien.syntax arrays continuations
+destructors generic io.mmap io.ports io.backend.windows io.files.windows
+kernel libc locals math math.bitwise namespaces quotations sequences windows
+windows.advapi32 windows.kernel32 windows.types io.backend system accessors
+io.backend.windows.privileges classes.struct windows.errors ;
+IN: io.backend.windows.nt.privileges
+
+TYPEDEF: TOKEN_PRIVILEGES* PTOKEN_PRIVILEGES
+
+! Security tokens
+! http://msdn.microsoft.com/msdnmag/issues/05/03/TokenPrivileges/
+
+: (open-process-token) ( handle -- handle )
+ { TOKEN_ADJUST_PRIVILEGES TOKEN_QUERY } flags PHANDLE <c-object>
+ [ OpenProcessToken win32-error=0/f ] keep *void* ;
+
+: open-process-token ( -- handle )
+ #! remember to CloseHandle
+ GetCurrentProcess (open-process-token) ;
+
+: with-process-token ( quot -- )
+ #! quot: ( token-handle -- token-handle )
+ [ open-process-token ] dip
+ [ keep ] curry
+ [ CloseHandle drop ] [ ] cleanup ; inline
+
+: lookup-privilege ( string -- luid )
+ [ f ] dip LUID <struct>
+ [ LookupPrivilegeValue win32-error=0/f ] keep ;
+
+:: make-token-privileges ( name enabled? -- obj )
+ TOKEN_PRIVILEGES <struct>
+ 1 >>PrivilegeCount
+ LUID_AND_ATTRIBUTES malloc-struct &free
+ enabled? [ SE_PRIVILEGE_ENABLED >>Attributes ] when
+ name lookup-privilege >>Luid
+ >>Privileges ;
+
+M: winnt set-privilege ( name ? -- )
+ [
+ -rot 0 -rot make-token-privileges
+ dup byte-length f f AdjustTokenPrivileges win32-error=0/f
+ ] with-process-token ;
IN: io.buffers.tests
-USING: alien alien.c-types io.buffers kernel kernel.private libc
-sequences tools.test namespaces byte-arrays strings accessors
-destructors ;
+USING: alien alien.c-types alien.data io.buffers kernel
+kernel.private libc sequences tools.test namespaces byte-arrays
+strings accessors destructors ;
: buffer-set ( string buffer -- )
over >byte-array over ptr>> byte-array>memory
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien alien.accessors alien.c-types
-alien.syntax kernel libc math sequences byte-arrays strings
-hints math.order destructors combinators ;
+alien.data alien.syntax kernel libc math sequences byte-arrays
+strings hints math.order destructors combinators ;
IN: io.buffers
TUPLE: buffer
generalizations system alien.strings io.encodings.utf16n
sequences splitting windows.errors fry continuations destructors
calendar ascii combinators.short-circuit locals classes.struct
-specialized-arrays ;
+specialized-arrays alien.data ;
SPECIALIZED-ARRAY: ushort
IN: io.files.info.windows
windows windows.kernel32 windows.time calendar combinators
math.functions sequences namespaces make words system
destructors accessors math.bitwise continuations windows.errors
-arrays byte-arrays generalizations ;
+arrays byte-arrays generalizations alien.data ;
IN: io.files.windows
: open-file ( path access-mode create-mode flags -- handle )
! See http://factorcode.org/license.txt for BSD license.
USING: continuations destructors io.files io.files.info
io.backend kernel quotations system alien alien.accessors
-accessors vocabs.loader combinators alien.c-types
+accessors vocabs.loader combinators alien.c-types alien.data
math ;
IN: io.mmap
! Copyright (C) 2008 Doug Coleman, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.c-types alien.strings libc destructors locals
-kernel math assocs namespaces make continuations sequences
+USING: alien alien.c-types alien.data alien.strings libc destructors
+locals kernel math assocs namespaces make continuations sequences
hashtables sorting arrays combinators math.bitwise strings
system accessors threads splitting io.backend io.backend.windows
io.backend.windows.nt io.files.windows.nt io.monitors io.ports
! Copyright (C) 2007, 2008, Slava Pestov, Elie CHAFTARI.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors byte-arrays kernel sequences namespaces math
-math.order combinators init alien alien.c-types alien.strings
-libc continuations destructors summary splitting assocs random
-math.parser locals unicode.case openssl openssl.libcrypto
-openssl.libssl io.backend io.ports io.pathnames
+math.order combinators init alien alien.c-types alien.data
+alien.strings libc continuations destructors summary splitting
+assocs random math.parser locals unicode.case openssl
+openssl.libcrypto openssl.libssl io.backend io.ports io.pathnames
io.encodings.8-bit io.timeouts io.sockets.secure ;
IN: io.sockets.secure.openssl
] [ drop ] if ;
: password-callback ( -- alien )
- "int" { "void*" "int" "bool" "void*" } "cdecl"
+ int { void* int bool void* } "cdecl"
[| buf size rwflag password! |
password [ B{ 0 } password! ] unless
alien.strings io.binary accessors destructors classes byte-arrays
parser alien.c-types math.parser splitting grouping math assocs
summary system vocabs.loader combinators present fry vocabs.parser
-classes.struct ;
+classes.struct alien.data ;
IN: io.sockets
<< {
io.streams.duplex io.backend io.pathnames io.sockets.private
io.files.private io.encodings.utf8 math.parser continuations
libc combinators system accessors destructors unix locals init
-classes.struct ;
+classes.struct alien.data ;
EXCLUDE: namespaces => bind ;
EXCLUDE: io => read write ;
-USING: alien alien.accessors alien.c-types byte-arrays
+USING: alien alien.accessors alien.c-types alien.data byte-arrays
continuations destructors io.ports io.timeouts io.sockets
io.sockets.private io namespaces io.streams.duplex
io.backend.windows io.sockets.windows io.backend.windows.nt
TYPEDEF: UInt32 IOHIDValueScaleType
TYPEDEF: UInt32 IOHIDTransactionDirectionType
-TYPEDEF: void* IOHIDCallback
-: IOHIDCallback ( quot -- alien )
- [ "void" { "void*" "IOReturn" "void*" } "cdecl" ]
- dip alien-callback ; inline
-
-TYPEDEF: void* IOHIDReportCallback
-: IOHIDReportCallback ( quot -- alien )
- [ "void" { "void*" "IOReturn" "void*" "IOHIDReportType" "UInt32" "uchar*" "CFIndex" } "cdecl" ]
- dip alien-callback ; inline
-
-TYPEDEF: void* IOHIDValueCallback
-: IOHIDValueCallback ( quot -- alien )
- [ "void" { "void*" "IOReturn" "void*" "IOHIDValueRef" } "cdecl" ]
- dip alien-callback ; inline
-
-TYPEDEF: void* IOHIDValueMultipleCallback
-: IOHIDValueMultipleCallback ( quot -- alien )
- [ "void" { "void*" "IOReturn" "void*" "CFDictionaryRef" } "cdecl" ]
- dip alien-callback ; inline
-
-TYPEDEF: void* IOHIDDeviceCallback
-: IOHIDDeviceCallback ( quot -- alien )
- [ "void" { "void*" "IOReturn" "void*" "IOHIDDeviceRef" } "cdecl" ]
- dip alien-callback ; inline
+CALLBACK: void IOHIDCallback ( void* context, IOReturn result, void* sender ) ;
+CALLBACK: void IOHIDReportCallback ( void* context, IOReturn result, void* sender, IOHIDReportType type, UInt32 reportID, uchar* report, CFIndex reportLength ) ;
+CALLBACK: void IOHIDValueCallback ( void* context, IOReturn result, void* sender, IOHIDValueRef value ) ;
+CALLBACK: void IOHIDValueMultipleCallback ( void* context, IOReturn result, void* sender, CFDictionaryRef multiple ) ;
+CALLBACK: void IOHIDDeviceCallback ( void* context, IOReturn result, void* sender, IOHIDDeviceRef device ) ;
! IOHIDDevice
-USING: arrays json.reader kernel multiline strings tools.test
+USING: arrays json.reader kernel strings tools.test
hashtables json ;
IN: json.reader.tests
! feature to get
{ -0.0 } [ "-0.0" json> ] unit-test
-{ " fuzzy pickles " } [ <" " fuzzy pickles " "> json> ] unit-test
-{ "while 1:\n\tpass" } [ <" "while 1:\n\tpass" "> json> ] unit-test
+{ " fuzzy pickles " } [ """ " fuzzy pickles " """ json> ] unit-test
+{ "while 1:\n\tpass" } [ """ "while 1:\n\tpass" """ json> ] unit-test
! unicode is allowed in json
-{ "ß∂¬ƒ˚∆" } [ <" "ß∂¬ƒ˚∆""> json> ] unit-test
-{ 8 9 10 12 13 34 47 92 } >string 1array [ <" "\b\t\n\f\r\"\/\\" "> json> ] unit-test
-{ HEX: abcd } >string 1array [ <" "\uaBCd" "> json> ] unit-test
+{ "ß∂¬ƒ˚∆" } [ """ "ß∂¬ƒ˚∆"""" json> ] unit-test
+{ 8 9 10 12 13 34 47 92 } >string 1array [ """ "\\b\\t\\n\\f\\r\\"\\/\\\\" """ json> ] unit-test
+{ HEX: abcd } >string 1array [ """ "\\uaBCd" """ json> ] unit-test
{ H{ { "a" { } } { "b" 123 } } } [ "{\"a\":[],\"b\":123}" json> ] unit-test
{ { } } [ "[]" json> ] unit-test
-{ { 1 "two" 3.0 } } [ <" [1, "two", 3.0] "> json> ] unit-test
+{ { 1 "two" 3.0 } } [ """ [1, "two", 3.0] """ json> ] unit-test
{ H{ } } [ "{}" json> ] unit-test
! the returned hashtable should be different every time
{ H{ } } [ "key" "value" "{}" json> ?set-at "{}" json> nip ] unit-test
-{ H{ { "US$" 1.0 } { "EU€" 1.5 } } } [ <" { "US$":1.00, "EU\u20AC":1.50 } "> json> ] unit-test
+{ H{ { "US$" 1.0 } { "EU€" 1.5 } } } [ """ { "US$":1.00, "EU\\u20AC":1.50 } """ json> ] unit-test
{ H{
{ "fib" { 1 1 2 3 5 8 H{ { "etc" "etc" } } } }
{ "prime" { 2 3 5 7 11 13 } }
-} } [ <" {
+} } [ """ {
"fib": [1, 1, 2, 3, 5, 8,
{ "etc":"etc" } ],
"prime":
11,
13
] }
-"> json> ] unit-test
+""" json> ] unit-test
{ 0 } [ " 0" json> ] unit-test
{ 0 } [ "0 " json> ] unit-test
-USING: json.writer tools.test multiline json.reader json ;
+USING: json.writer tools.test json.reader json ;
IN: json.writer.tests
{ "false" } [ f >json ] unit-test
{ "102.5" } [ 102.5 >json ] unit-test
{ "[1,\"two\",3.0]" } [ { 1 "two" 3.0 } >json ] unit-test
-{ <" {"US$":1.0,"EU€":1.5}"> } [ H{ { "US$" 1.0 } { "EU€" 1.5 } } >json ] unit-test
+{ """{"US$":1.0,"EU€":1.5}""" } [ H{ { "US$" 1.0 } { "EU€" 1.5 } } >json ] unit-test
! Random symbols are written simply as strings
SYMBOL: testSymbol
-{ <" "testSymbol""> } [ testSymbol >json ] unit-test
+{ """"testSymbol"""" } [ testSymbol >json ] unit-test
-[ { 0.5 } ] [ { 1/2 } >json json> ] unit-test
\ No newline at end of file
+[ { 0.5 } ] [ { 1/2 } >json json> ] unit-test
! Copyright (C) 2007, 2009 Slava Pestov
! Copyright (C) 2007, 2008 Doug Coleman
! See http://factorcode.org/license.txt for BSD license.
-USING: alien assocs continuations alien.destructors kernel
+USING: alien alien.c-types assocs continuations alien.destructors kernel
namespaces accessors sets summary destructors destructors.private ;
IN: libc
: errno ( -- int )
- "int" "factor" "err_no" { } alien-invoke ;
+ int "factor" "err_no" { } alien-invoke ;
: clear-errno ( -- )
- "void" "factor" "clear_err_no" { } alien-invoke ;
+ void "factor" "clear_err_no" { } alien-invoke ;
<PRIVATE
: (malloc) ( size -- alien )
- "void*" "libc" "malloc" { "ulong" } alien-invoke ;
+ void* "libc" "malloc" { ulong } alien-invoke ;
: (calloc) ( count size -- alien )
- "void*" "libc" "calloc" { "ulong" "ulong" } alien-invoke ;
+ void* "libc" "calloc" { ulong ulong } alien-invoke ;
: (free) ( alien -- )
- "void" "libc" "free" { "void*" } alien-invoke ;
+ void "libc" "free" { void* } alien-invoke ;
: (realloc) ( alien size -- newalien )
- "void*" "libc" "realloc" { "void*" "ulong" } alien-invoke ;
+ void* "libc" "realloc" { void* ulong } alien-invoke ;
! We stick malloc-ptr instances in the global disposables set
TUPLE: malloc-ptr value continuation ;
>c-ptr [ delete-malloc ] [ (free) ] bi ;
: memcpy ( dst src size -- )
- "void" "libc" "memcpy" { "void*" "void*" "ulong" } alien-invoke ;
+ void "libc" "memcpy" { void* void* ulong } alien-invoke ;
: memcmp ( a b size -- cmp )
- "int" "libc" "memcmp" { "void*" "void*" "ulong" } alien-invoke ;
+ int "libc" "memcmp" { void* void* ulong } alien-invoke ;
: memory= ( a b size -- ? )
memcmp 0 = ;
: strlen ( alien -- len )
- "size_t" "libc" "strlen" { "char*" } alien-invoke ;
+ size_t "libc" "strlen" { char* } alien-invoke ;
DESTRUCTOR: free
{ $notes { $snippet "word" } "'s definition is looked up and " { $link call } "ed at parse time, so words that reference words in the current compilation unit cannot be used with " { $snippet "$" } "." }
{ $examples
- { $example <"
+ { $example """
USING: kernel literals prettyprint ;
IN: scratchpad
CONSTANT: five 5
{ $ five } .
- "> "{ 5 }" }
+ """ "{ 5 }" }
- { $example <"
+ { $example """
USING: kernel literals prettyprint ;
IN: scratchpad
: seven-eleven ( -- a b ) 7 11 ;
{ $ seven-eleven } .
- "> "{ 7 11 }" }
+ """ "{ 7 11 }" }
} ;
{ $notes "Since " { $snippet "code" } " is " { $link call } "ed at parse time, it cannot reference any words defined in the same compilation unit." }
{ $examples
- { $example <"
+ { $example """
USING: kernel literals math prettyprint ;
IN: scratchpad
<< CONSTANT: five 5 >>
{ $[ five dup 1 + dup 2 + ] } .
- "> "{ 5 6 8 }" }
+ """ "{ 5 6 8 }" }
} ;
{ $notes { $snippet "code" } "'s definition is looked up and " { $link call } "ed at parse time, so words that reference words in the current compilation unit cannot be used with " { $snippet "$" } "." }
{ $examples
- { $example <"
+ { $example """
USING: kernel literals math prettyprint ;
IN: scratchpad
CONSTANT: five 5
CONSTANT: six 6
${ five six 7 } .
- "> "{ 5 6 7 }"
+ """ "{ 5 6 7 }"
}
} ;
ARTICLE: "literals" "Interpolating code results into literal values"
"The " { $vocab-link "literals" } " vocabulary contains words to run code at parse time and insert the results into more complex literal values."
-{ $example <"
+{ $example """
USE: literals
IN: scratchpad
CONSTANT: five 5
{ $ five $[ five dup 1 + dup 2 + ] } .
- "> "{ 5 5 6 8 }" }
+ """ "{ 5 5 6 8 }" }
{ $subsection POSTPONE: $ }
{ $subsection POSTPONE: $[ }
{ $subsection POSTPONE: ${ }
-USING: alien.fortran help.markup help.syntax math.blas.config multiline ;
+USING: alien.fortran help.markup help.syntax math.blas.config ;
IN: math.blas.config
ARTICLE: "math.blas.config" "Configuring the BLAS interface"
{ $subsection blas-library }
{ $subsection blas-fortran-abi }
"The interface attempts to set default values based on the ones encountered on the Factor project's build machines. If these settings don't work with your system's BLAS, or you wish to use a commercial BLAS, you may change the global values of those variables in your " { $link "factor-rc" } ". For example, to use AMD's ACML library on Windows with " { $snippet "math.blas" } ", your " { $snippet "factor-rc" } " would look like this:"
-{ $code <"
+{ $code """
USING: math.blas.config namespaces ;
"X:\\path\\to\\acml.dll" blas-library set-global
intel-windows-abi blas-fortran-abi set-global
-"> }
+""" }
"To take effect, the " { $snippet "blas-library" } " and " { $snippet "blas-fortran-abi" } " variables must be set before any other " { $snippet "math.blas" } " vocabularies are loaded."
;
-USING: alien byte-arrays help.markup help.syntax math math.blas.vectors sequences strings multiline ;
+USING: alien byte-arrays help.markup help.syntax math math.blas.vectors sequences strings ;
IN: math.blas.matrices
ARTICLE: "math.blas-summary" "Basic Linear Algebra Subroutines (BLAS) interface"
{ $description "Return a vector of zeros with the given " { $snippet "length" } " and the same element type as " { $snippet "v" } "." } ;
HELP: smatrix{
-{ $syntax <" smatrix{
+{ $syntax """smatrix{
{ 1.0 0.0 0.0 1.0 }
{ 0.0 1.0 0.0 2.0 }
{ 0.0 0.0 1.0 3.0 }
{ 0.0 0.0 0.0 1.0 }
-} "> }
+}""" }
{ $description "Construct a literal " { $link float-blas-matrix } ". Note that although BLAS matrices are stored in column-major order, the literal is specified in row-major order." } ;
HELP: dmatrix{
-{ $syntax <" dmatrix{
+{ $syntax """dmatrix{
{ 1.0 0.0 0.0 1.0 }
{ 0.0 1.0 0.0 2.0 }
{ 0.0 0.0 1.0 3.0 }
{ 0.0 0.0 0.0 1.0 }
-} "> }
+}""" }
{ $description "Construct a literal " { $link double-blas-matrix } ". Note that although BLAS matrices are stored in column-major order, the literal is specified in row-major order." } ;
HELP: cmatrix{
-{ $syntax <" cmatrix{
+{ $syntax """cmatrix{
{ 1.0 0.0 0.0 1.0 }
{ 0.0 C{ 0.0 1.0 } 0.0 2.0 }
{ 0.0 0.0 -1.0 3.0 }
{ 0.0 0.0 0.0 C{ 0.0 -1.0 } }
-} "> }
+}""" }
{ $description "Construct a literal " { $link complex-float-blas-matrix } ". Note that although BLAS matrices are stored in column-major order, the literal is specified in row-major order." } ;
HELP: zmatrix{
-{ $syntax <" zmatrix{
+{ $syntax """zmatrix{
{ 1.0 0.0 0.0 1.0 }
{ 0.0 C{ 0.0 1.0 } 0.0 2.0 }
{ 0.0 0.0 -1.0 3.0 }
{ 0.0 0.0 0.0 C{ 0.0 -1.0 } }
-} "> }
+}""" }
{ $description "Construct a literal " { $link complex-double-blas-matrix } ". Note that although BLAS matrices are stored in column-major order, the literal is specified in row-major order." } ;
{
-USING: accessors alien alien.c-types arrays byte-arrays combinators
-combinators.short-circuit fry kernel locals macros
-math math.blas.ffi math.blas.vectors math.blas.vectors.private
-math.complex math.functions math.order functors words
-sequences sequences.merged sequences.private shuffle
-parser prettyprint.backend prettyprint.custom ascii
-specialized-arrays ;
+USING: accessors alien alien.c-types alien.data arrays
+byte-arrays combinators combinators.short-circuit fry
+kernel locals macros math math.blas.ffi math.blas.vectors
+math.blas.vectors.private math.complex math.functions
+math.order functors words sequences sequences.merged
+sequences.private shuffle parser prettyprint.backend
+prettyprint.custom ascii specialized-arrays ;
+FROM: alien.c-types => float ;
SPECIALIZED-ARRAY: float
SPECIALIZED-ARRAY: double
SPECIALIZED-ARRAY: complex-float
math.complex math.functions math.order sequences sequences.private
functors words locals parser prettyprint.backend prettyprint.custom
specialized-arrays ;
+FROM: alien.c-types => float ;
SPECIALIZED-ARRAY: float
SPECIALIZED-ARRAY: double
SPECIALIZED-ARRAY: complex-float
-USING: help.markup help.syntax kernel math math.order multiline sequences ;
+USING: help.markup help.syntax kernel math math.order sequences ;
IN: math.combinatorics
HELP: factorial
{ $examples
{ $example "USING: math.combinatorics prettyprint ;"
"{ \"a\" \"b\" \"c\" \"d\" } 2 all-combinations ."
-<" {
+"""{
{ "a" "b" }
{ "a" "c" }
{ "a" "d" }
{ "b" "c" }
{ "b" "d" }
{ "c" "d" }
-}"> } } ;
+}""" } } ;
HELP: each-combination
{ $values { "seq" sequence } { "k" "a non-negative integer" } { "quot" { $quotation "( seq -- )" } } }
set_x87_env ;
M: x86 (fp-env-registers)
- sse-version 20 >=
- [ <sse-env> <x87-env> 2array ]
- [ <x87-env> 1array ] if ;
+ sse2? [ <sse-env> <x87-env> 2array ] [ <x87-env> 1array ] if ;
CONSTANT: sse-exception-flag-bits HEX: 3f
CONSTANT: sse-exception-flag>bit
"Squares:"
{ $subsections sq sqrt }
"Exponential and natural logarithm:"
-{ $subsections
- exp
- cis
- log
- log1+
- log10
-}
+{ $subsections exp cis log }
+"Other logarithms:"
+{ $subsection log1+ log10 }
"Raising a number to a power:"
{ $subsections ^ 10^ }
"Converting between rectangular and polar form:"
[ t ] [ 4.0000001 4.0000001 .000001 ~ ] unit-test
[ f ] [ -4.0000001 4.0000001 .00001 ~ ] unit-test
[ t ] [ -.0000000000001 0 .0000000001 ~ ] unit-test
+[ t ] [ 100 101 -.9 ~ ] unit-test
+[ f ] [ 100 120 -.09 ~ ] unit-test
+[ t ] [ 0 0 -.9 ~ ] unit-test
+[ f ] [ 0 10 -.9 ~ ] unit-test
! Lets get the argument order correct, eh?
[ 0.0 ] [ 0.0 1.0 fatan2 ] unit-test
[ - abs ] dip < ;
: ~rel ( x y epsilon -- ? )
- [ [ - abs ] 2keep [ abs ] bi@ + ] dip * < ;
+ [ [ - abs ] 2keep [ abs ] bi@ + ] dip * <= ;
: ~ ( x y epsilon -- ? )
{
{ [ 2over [ fp-nan? ] either? ] [ 3drop f ] }
{ [ dup zero? ] [ drop number= ] }
- { [ dup 0 < ] [ ~rel ] }
+ { [ dup 0 < ] [ neg ~rel ] }
[ ~abs ]
} cond ;
{ $warning
"These functions are unsafe. The compiler special-cases them to operate on floats only. They can be called directly, however there is little reason to do so, since they only implement real-valued functions, and in some cases place restrictions on the domain:"
{ $example "USE: math.functions" "2.0 acos ." "C{ 0.0 1.316957896924817 }" }
-{ $unchecked-example "USE: math.libm" "2 facos ." "0/0." } }
+{ $unchecked-example "USE: math.libm" "2.0 facos ." "0/0." } }
"Trigonometric functions:"
{ $subsection fcos }
{ $subsection fsin }
"Exponentials and logarithms:"
{ $subsection fexp }
{ $subsection flog }
+{ $subsection flog10 }
"Powers:"
{ $subsection fpow }
{ $subsection fsqrt } ;
{ $values { "x" real } { "y" real } }
{ $description "Calls the natural logarithm function from the C standard library. User code should call " { $link log } " instead." } ;
+HELP: flog10
+{ $values { "x" real } { "y" real } }
+{ $description "Calls the base 10 logarithm function from the C standard library. User code should call " { $link log10 } " instead." } ;
+
HELP: fpow
{ $values { "x" real } { "y" real } { "z" real } }
{ $description "Calls the power function (" { $snippet "z=x^y" } ") from the C standard library. User code should call " { $link ^ } " instead." } ;
! Copyright (C) 2006 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien ;
+USING: alien alien.c-types ;
IN: math.libm
: facos ( x -- y )
- "double" "libm" "acos" { "double" } alien-invoke ;
+ double "libm" "acos" { double } alien-invoke ;
: fasin ( x -- y )
- "double" "libm" "asin" { "double" } alien-invoke ;
+ double "libm" "asin" { double } alien-invoke ;
: fatan ( x -- y )
- "double" "libm" "atan" { "double" } alien-invoke ;
+ double "libm" "atan" { double } alien-invoke ;
: fatan2 ( x y -- z )
- "double" "libm" "atan2" { "double" "double" } alien-invoke ;
+ double "libm" "atan2" { double double } alien-invoke ;
: fcos ( x -- y )
- "double" "libm" "cos" { "double" } alien-invoke ;
+ double "libm" "cos" { double } alien-invoke ;
: fsin ( x -- y )
- "double" "libm" "sin" { "double" } alien-invoke ;
+ double "libm" "sin" { double } alien-invoke ;
: ftan ( x -- y )
- "double" "libm" "tan" { "double" } alien-invoke ;
+ double "libm" "tan" { double } alien-invoke ;
: fcosh ( x -- y )
- "double" "libm" "cosh" { "double" } alien-invoke ;
+ double "libm" "cosh" { double } alien-invoke ;
: fsinh ( x -- y )
- "double" "libm" "sinh" { "double" } alien-invoke ;
+ double "libm" "sinh" { double } alien-invoke ;
: ftanh ( x -- y )
- "double" "libm" "tanh" { "double" } alien-invoke ;
+ double "libm" "tanh" { double } alien-invoke ;
: fexp ( x -- y )
- "double" "libm" "exp" { "double" } alien-invoke ;
+ double "libm" "exp" { double } alien-invoke ;
: flog ( x -- y )
- "double" "libm" "log" { "double" } alien-invoke ;
+ double "libm" "log" { double } alien-invoke ;
: flog10 ( x -- y )
- "double" "libm" "log10" { "double" } alien-invoke ;
+ double "libm" "log10" { double } alien-invoke ;
: fpow ( x y -- z )
- "double" "libm" "pow" { "double" "double" } alien-invoke ;
+ double "libm" "pow" { double double } alien-invoke ;
: fsqrt ( x -- y )
- "double" "libm" "sqrt" { "double" } alien-invoke ;
+ double "libm" "sqrt" { double } alien-invoke ;
! Windows doesn't have these...
: flog1+ ( x -- y )
- "double" "libm" "log1p" { "double" } alien-invoke ;
+ double "libm" "log1p" { double } alien-invoke ;
: facosh ( x -- y )
- "double" "libm" "acosh" { "double" } alien-invoke ;
+ double "libm" "acosh" { double } alien-invoke ;
: fasinh ( x -- y )
- "double" "libm" "asinh" { "double" } alien-invoke ;
+ double "libm" "asinh" { double } alien-invoke ;
: fatanh ( x -- y )
- "double" "libm" "atanh" { "double" } alien-invoke ;
+ double "libm" "atanh" { double } alien-invoke ;
: math-both-known? ( word left right -- ? )
3dup math-op
[ 2drop 2drop t ]
- [ drop math-class-max swap specific-method >boolean ] if ;
+ [ drop math-class-max swap method-for-class >boolean ] if ;
: (derived-ops) ( word assoc -- words )
swap '[ swap first _ eq? nip ] assoc-filter ;
+++ /dev/null
-USING: cpu.architecture math.vectors.simd
-math.vectors.simd.intrinsics accessors math.vectors.simd.alien
-kernel classes.struct tools.test compiler sequences byte-arrays
-alien math kernel.private specialized-arrays combinators ;
-SPECIALIZED-ARRAY: float
-IN: math.vectors.simd.alien.tests
-
-! Vector alien intrinsics
-[ float-4{ 1 2 3 4 } ] [
- [
- float-4{ 1 2 3 4 }
- underlying>> 0 float-4-rep alien-vector
- ] compile-call float-4 boa
-] unit-test
-
-[ B{ 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 } ] [
- 16 [ 1 ] B{ } replicate-as 16 <byte-array>
- [
- 0 [
- { byte-array c-ptr fixnum } declare
- float-4-rep set-alien-vector
- ] compile-call
- ] keep
-] unit-test
-
-[ float-array{ 1 2 3 4 } ] [
- [
- float-array{ 1 2 3 4 } underlying>>
- float-array{ 4 3 2 1 } clone
- [ underlying>> 0 float-4-rep set-alien-vector ] keep
- ] compile-call
-] unit-test
-
-STRUCT: simd-struct
-{ x float-4 }
-{ y double-2 }
-{ z double-4 }
-{ w float-8 } ;
-
-[ t ] [ [ simd-struct <struct> ] compile-call >c-ptr [ 0 = ] all? ] unit-test
-
-[
- float-4{ 1 2 3 4 }
- double-2{ 2 1 }
- double-4{ 4 3 2 1 }
- float-8{ 1 2 3 4 5 6 7 8 }
-] [
- simd-struct <struct>
- float-4{ 1 2 3 4 } >>x
- double-2{ 2 1 } >>y
- double-4{ 4 3 2 1 } >>z
- float-8{ 1 2 3 4 5 6 7 8 } >>w
- { [ x>> ] [ y>> ] [ z>> ] [ w>> ] } cleave
-] unit-test
-
-[
- float-4{ 1 2 3 4 }
- double-2{ 2 1 }
- double-4{ 4 3 2 1 }
- float-8{ 1 2 3 4 5 6 7 8 }
-] [
- [
- simd-struct <struct>
- float-4{ 1 2 3 4 } >>x
- double-2{ 2 1 } >>y
- double-4{ 4 3 2 1 } >>z
- float-8{ 1 2 3 4 5 6 7 8 } >>w
- { [ x>> ] [ y>> ] [ z>> ] [ w>> ] } cleave
- ] compile-call
-] unit-test
+++ /dev/null
-! Copyright (C) 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: alien accessors alien.c-types byte-arrays compiler.units
-cpu.architecture locals kernel math math.vectors.simd
-math.vectors.simd.intrinsics ;
-IN: math.vectors.simd.alien
-
-:: define-simd-128-type ( class rep -- )
- <c-type>
- byte-array >>class
- class >>boxed-class
- [ rep alien-vector class boa ] >>getter
- [ [ underlying>> ] 2dip rep set-alien-vector ] >>setter
- 16 >>size
- 8 >>align
- rep >>rep
- class name>> typedef ;
-
-:: define-simd-256-type ( class rep -- )
- <c-type>
- class >>class
- class >>boxed-class
- [
- [ rep alien-vector ]
- [ 16 + >fixnum rep alien-vector ] 2bi
- class boa
- ] >>getter
- [
- [ [ underlying1>> ] 2dip rep set-alien-vector ]
- [ [ underlying2>> ] 2dip 16 + >fixnum rep set-alien-vector ]
- 3bi
- ] >>setter
- 32 >>size
- 8 >>align
- rep >>rep
- class name>> typedef ;
-[
- float-4 float-4-rep define-simd-128-type
- double-2 double-2-rep define-simd-128-type
- float-8 float-4-rep define-simd-256-type
- double-4 double-2-rep define-simd-256-type
-] with-compilation-unit
+++ /dev/null
-Slava Pestov
\ No newline at end of file
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien.c-types byte-arrays classes functors
-kernel math parser prettyprint.custom sequences
-sequences.private literals ;
+USING: accessors alien.c-types assocs byte-arrays classes
+effects fry functors generalizations kernel literals locals
+math math.functions math.vectors math.vectors.simd.intrinsics
+math.vectors.specialization parser prettyprint.custom sequences
+sequences.private strings words definitions macros cpu.architecture
+namespaces arrays quotations ;
+QUALIFIED-WITH: math m
IN: math.vectors.simd.functor
ERROR: bad-length got expected ;
+MACRO: simd-boa ( rep class -- simd-array )
+ [ rep-components ] [ new ] bi* '[ _ _ nsequence ] ;
+
+:: define-boa-custom-inlining ( word rep class -- )
+ word [
+ drop
+ rep rep rep-gather-word supported-simd-op? [
+ [ rep (simd-boa) class boa ]
+ ] [ word def>> ] if
+ ] "custom-inlining" set-word-prop ;
+
+: simd-with ( rep class x -- simd-array )
+ [ rep-components ] [ new ] [ '[ _ ] ] tri* swap replicate-as ; inline
+
+:: define-with-custom-inlining ( word rep class -- )
+ word [
+ drop
+ rep \ (simd-broadcast) supported-simd-op? [
+ [ rep rep-coerce rep (simd-broadcast) class boa ]
+ ] [ word def>> ] if
+ ] "custom-inlining" set-word-prop ;
+
+: boa-effect ( rep n -- effect )
+ [ rep-components ] dip *
+ [ CHAR: a + 1string ] map
+ { "simd-vector" } <effect> ;
+
+: supported-simd-ops ( assoc rep -- assoc' )
+ [ simd-ops get ] dip
+ '[ nip _ swap supported-simd-op? ] assoc-filter
+ '[ drop _ key? ] assoc-filter ;
+
+ERROR: bad-schema schema ;
+
+: low-level-ops ( box-quot: ( inputs... simd-op -- outputs... ) -- alist )
+ [ simd-ops get ] dip '[
+ 1quotation
+ over word-schema _ ?at [ bad-schema ] unless
+ [ ] 2sequence
+ ] assoc-map ;
+
+:: high-level-ops ( ctor elt-class -- assoc )
+ ! Some SIMD operations are defined in terms of others.
+ {
+ { vneg [ [ dup v- ] keep v- ] }
+ { n+v [ [ ctor execute ] dip v+ ] }
+ { v+n [ ctor execute v+ ] }
+ { n-v [ [ ctor execute ] dip v- ] }
+ { v-n [ ctor execute v- ] }
+ { n*v [ [ ctor execute ] dip v* ] }
+ { v*n [ ctor execute v* ] }
+ { n/v [ [ ctor execute ] dip v/ ] }
+ { v/n [ ctor execute v/ ] }
+ { norm-sq [ dup v. assert-positive ] }
+ { norm [ norm-sq sqrt ] }
+ { normalize [ dup norm v/n ] }
+ }
+ ! To compute dot product and distance with integer vectors, we
+ ! have to do things less efficiently, with integer overflow checks,
+ ! in the general case.
+ elt-class m:float = [
+ {
+ { distance [ v- norm ] }
+ { v. [ v* sum ] }
+ } append
+ ] when ;
+
+:: simd-vector-words ( class ctor rep vv->v v->v v->n -- )
+ rep rep-component-type c-type-boxed-class :> elt-class
+ class
+ elt-class
+ {
+ { { +vector+ +vector+ -> +vector+ } vv->v }
+ { { +vector+ -> +vector+ } v->v }
+ { { +vector+ -> +scalar+ } v->n }
+ { { +vector+ -> +nonnegative+ } v->n }
+ } low-level-ops
+ rep supported-simd-ops
+ ctor elt-class high-level-ops assoc-union
+ specialize-vector-words ;
+
+:: define-simd-128-type ( class rep -- )
+ <c-type>
+ byte-array >>class
+ class >>boxed-class
+ [ rep alien-vector class boa ] >>getter
+ [ [ underlying>> ] 2dip rep set-alien-vector ] >>setter
+ 16 >>size
+ 8 >>align
+ rep >>rep
+ class typedef ;
+
FUNCTOR: define-simd-128 ( T -- )
N [ 16 T heap-size /i ]
A DEFINES-CLASS ${T}-${N}
+A-boa DEFINES ${A}-boa
+A-with DEFINES ${A}-with
>A DEFINES >${A}
A{ DEFINES ${A}{
NTH [ T dup c-type-getter-boxer array-accessor ]
SET-NTH [ T dup c-setter array-accessor ]
-A-rep IS ${A}-rep
+A-rep [ A name>> "-rep" append "cpu.architecture" lookup ]
A-vv->v-op DEFINES-PRIVATE ${A}-vv->v-op
+A-v->v-op DEFINES-PRIVATE ${A}-v->v-op
A-v->n-op DEFINES-PRIVATE ${A}-v->n-op
WHERE
M: A byte-length underlying>> length ; inline
+M: A element-type drop A-rep rep-component-type ;
+
M: A pprint-delims drop \ A{ \ } ;
M: A >pprint-sequence ;
SYNTAX: A{ \ } [ >A ] parse-literal ;
+: A-with ( x -- simd-array ) [ A-rep A ] dip simd-with ;
+
+\ A-with \ A-rep \ A define-with-custom-inlining
+
+\ A-boa [ \ A-rep \ A simd-boa ] \ A-rep 1 boa-effect define-declared
+
+\ A-rep rep-gather-word [
+ \ A-boa \ A-rep \ A define-boa-custom-inlining
+] when
+
INSTANCE: A sequence
<PRIVATE
: A-vv->v-op ( v1 v2 quot -- v3 )
[ [ underlying>> ] bi@ A-rep ] dip call \ A boa ; inline
+: A-v->v-op ( v1 quot -- v2 )
+ [ underlying>> A-rep ] dip call \ A boa ; inline
+
: A-v->n-op ( v quot -- n )
[ underlying>> A-rep ] dip call ; inline
+\ A \ A-with \ A-rep \ A-vv->v-op \ A-v->v-op \ A-v->n-op simd-vector-words
+\ A \ A-rep define-simd-128-type
+
PRIVATE>
;FUNCTOR
! Synthesize 256-bit vectors from a pair of 128-bit vectors
+SLOT: underlying1
+SLOT: underlying2
+
+:: define-simd-256-type ( class rep -- )
+ <c-type>
+ class >>class
+ class >>boxed-class
+ [
+ [ rep alien-vector ]
+ [ 16 + >fixnum rep alien-vector ] 2bi
+ class boa
+ ] >>getter
+ [
+ [ [ underlying1>> ] 2dip rep set-alien-vector ]
+ [ [ underlying2>> ] 2dip 16 + >fixnum rep set-alien-vector ]
+ 3bi
+ ] >>setter
+ 32 >>size
+ 8 >>align
+ rep >>rep
+ class typedef ;
+
FUNCTOR: define-simd-256 ( T -- )
N [ 32 T heap-size /i ]
N/2 [ N 2 / ]
A/2 IS ${T}-${N/2}
+A/2-boa IS ${A/2}-boa
+A/2-with IS ${A/2}-with
A DEFINES-CLASS ${T}-${N}
+A-boa DEFINES ${A}-boa
+A-with DEFINES ${A}-with
>A DEFINES >${A}
A{ DEFINES ${A}{
A-deref DEFINES-PRIVATE ${A}-deref
-A-rep IS ${A/2}-rep
+A-rep [ A/2 name>> "-rep" append "cpu.architecture" lookup ]
A-vv->v-op DEFINES-PRIVATE ${A}-vv->v-op
+A-v->v-op DEFINES-PRIVATE ${A}-v->v-op
A-v->n-op DEFINES-PRIVATE ${A}-v->n-op
WHERE
M: A byte-length drop 32 ; inline
+M: A element-type drop A-rep rep-component-type ;
+
SYNTAX: A{ \ } [ >A ] parse-literal ;
M: A pprint-delims drop \ A{ \ } ;
M: A pprint* pprint-object ;
+: A-with ( x -- simd-array )
+ [ A/2-with ] [ A/2-with ] bi [ underlying>> ] bi@
+ \ A boa ; inline
+
+: A-boa ( ... -- simd-array )
+ [ A/2-boa ] N/2 ndip A/2-boa [ underlying>> ] bi@
+ \ A boa ; inline
+
+\ A-rep 2 boa-effect \ A-boa set-stack-effect
+
INSTANCE: A sequence
: A-vv->v-op ( v1 v2 quot -- v3 )
[ [ [ underlying2>> ] bi@ A-rep ] dip call ] 3bi
\ A boa ; inline
-: A-v->n-op ( v1 combine-quot reduce-quot -- v2 )
- [ [ [ underlying1>> ] [ underlying2>> ] bi A-rep ] dip call A-rep ]
- dip call ; inline
+: A-v->v-op ( v1 combine-quot -- v2 )
+ [ [ underlying1>> A-rep ] dip call ]
+ [ [ underlying2>> A-rep ] dip call ] 2bi
+ \ A boa ; inline
+
+: A-v->n-op ( v1 combine-quot -- v2 )
+ [ [ underlying1>> ] [ underlying2>> ] bi A-rep (simd-v+) A-rep ] dip call ; inline
+
+\ A \ A-with \ A-rep \ A-vv->v-op \ A-v->v-op \ A-v->n-op simd-vector-words
+\ A \ A-rep define-simd-256-type
;FUNCTOR
--- /dev/null
+IN: math.vectors.simd.intrinsics.tests
+USING: math.vectors.simd.intrinsics cpu.architecture tools.test ;
+
+[ 16 ] [ uchar-16-rep rep-components ] unit-test
+[ 16 ] [ char-16-rep rep-components ] unit-test
+[ 8 ] [ ushort-8-rep rep-components ] unit-test
+[ 8 ] [ short-8-rep rep-components ] unit-test
+[ 4 ] [ uint-4-rep rep-components ] unit-test
+[ 4 ] [ int-4-rep rep-components ] unit-test
+[ 4 ] [ float-4-rep rep-components ] unit-test
+[ 2 ] [ double-2-rep rep-components ] unit-test
+
+{ 4 1 } [ uint-4-rep (simd-boa) ] must-infer-as
+{ 4 1 } [ int-4-rep (simd-boa) ] must-infer-as
+{ 4 1 } [ float-4-rep (simd-boa) ] must-infer-as
+{ 2 1 } [ double-2-rep (simd-boa) ] must-infer-as
+
+
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel alien alien.c-types cpu.architecture libc ;
+USING: alien alien.c-types alien.data assocs combinators
+cpu.architecture fry generalizations kernel libc macros math
+sequences effects accessors namespaces lexer parser vocabs.parser
+words arrays math.vectors ;
IN: math.vectors.simd.intrinsics
ERROR: bad-simd-call ;
-: (simd-v+) ( v1 v2 rep -- v3 ) bad-simd-call ;
-: (simd-v-) ( v1 v2 rep -- v3 ) bad-simd-call ;
-: (simd-v*) ( v1 v2 rep -- v3 ) bad-simd-call ;
-: (simd-v/) ( v1 v2 rep -- v3 ) bad-simd-call ;
-: (simd-vmin) ( v1 v2 rep -- v3 ) bad-simd-call ;
-: (simd-vmax) ( v1 v2 rep -- v3 ) bad-simd-call ;
-: (simd-vsqrt) ( v1 v2 rep -- v3 ) bad-simd-call ;
-: (simd-sum) ( v1 rep -- v2 ) bad-simd-call ;
+<<
+
+: simd-effect ( word -- effect )
+ stack-effect [ in>> "rep" suffix ] [ out>> ] bi <effect> ;
+
+SYMBOL: simd-ops
+
+V{ } clone simd-ops set-global
+
+SYNTAX: SIMD-OP:
+ scan-word dup name>> "(simd-" ")" surround create-in
+ [ nip [ bad-simd-call ] define ]
+ [ [ simd-effect ] dip set-stack-effect ]
+ [ 2array simd-ops get push ]
+ 2tri ;
+
+>>
+
+SIMD-OP: v+
+SIMD-OP: v-
+SIMD-OP: v+-
+SIMD-OP: vs+
+SIMD-OP: vs-
+SIMD-OP: vs*
+SIMD-OP: v*
+SIMD-OP: v/
+SIMD-OP: vmin
+SIMD-OP: vmax
+SIMD-OP: vsqrt
+SIMD-OP: sum
+SIMD-OP: vabs
+SIMD-OP: vbitand
+SIMD-OP: vbitor
+SIMD-OP: vbitxor
+
: (simd-broadcast) ( x rep -- v ) bad-simd-call ;
: (simd-gather-2) ( a b rep -- v ) bad-simd-call ;
: (simd-gather-4) ( a b c d rep -- v ) bad-simd-call ;
! Inefficient version for when intrinsics are missing
[ swap <displaced-alien> swap ] dip rep-size memcpy ;
+<<
+
+: rep-components ( rep -- n )
+ 16 swap rep-component-type heap-size /i ; foldable
+
+: rep-coercer ( rep -- quot )
+ {
+ { [ dup int-vector-rep? ] [ [ >fixnum ] ] }
+ { [ dup float-vector-rep? ] [ [ >float ] ] }
+ } cond nip ; foldable
+
+: rep-coerce ( value rep -- value' )
+ rep-coercer call( value -- value' ) ; inline
+
+CONSTANT: rep-gather-words
+ {
+ { 2 (simd-gather-2) }
+ { 4 (simd-gather-4) }
+ }
+
+: rep-gather-word ( rep -- word )
+ rep-components rep-gather-words at ;
+
+>>
+
+MACRO: (simd-boa) ( rep -- quot )
+ {
+ [ rep-coercer ]
+ [ rep-components ]
+ [ ]
+ [ rep-gather-word ]
+ } cleave
+ '[ _ _ napply _ _ execute ] ;
+
+GENERIC# supported-simd-op? 1 ( rep intrinsic -- ? )
+
+M: vector-rep supported-simd-op?
+ {
+ { \ (simd-v+) [ %add-vector-reps ] }
+ { \ (simd-vs+) [ %saturated-add-vector-reps ] }
+ { \ (simd-v+-) [ %add-sub-vector-reps ] }
+ { \ (simd-v-) [ %sub-vector-reps ] }
+ { \ (simd-vs-) [ %saturated-sub-vector-reps ] }
+ { \ (simd-v*) [ %mul-vector-reps ] }
+ { \ (simd-vs*) [ %saturated-mul-vector-reps ] }
+ { \ (simd-v/) [ %div-vector-reps ] }
+ { \ (simd-vmin) [ %min-vector-reps ] }
+ { \ (simd-vmax) [ %max-vector-reps ] }
+ { \ (simd-vsqrt) [ %sqrt-vector-reps ] }
+ { \ (simd-sum) [ %horizontal-add-vector-reps ] }
+ { \ (simd-vabs) [ %abs-vector-reps ] }
+ { \ (simd-vbitand) [ %and-vector-reps ] }
+ { \ (simd-vbitor) [ %or-vector-reps ] }
+ { \ (simd-vbitxor) [ %xor-vector-reps ] }
+ { \ (simd-broadcast) [ %broadcast-vector-reps ] }
+ { \ (simd-gather-2) [ %gather-vector-2-reps ] }
+ { \ (simd-gather-4) [ %gather-vector-4-reps ] }
+ } case member? ;
-USING: help.markup help.syntax sequences math math.vectors
-multiline kernel.private classes.tuple.private
-math.vectors.simd.intrinsics cpu.architecture ;
+USING: classes.tuple.private cpu.architecture help.markup
+help.syntax kernel.private math math.vectors
+math.vectors.simd.intrinsics sequences ;
IN: math.vectors.simd
ARTICLE: "math.vectors.simd.intro" "Introduction to SIMD support"
"There should never be any reason to use " { $link "math.vectors.simd.intrinsics" } " directly, but they too have a straightforward, but lower-level, interface." ;
ARTICLE: "math.vectors.simd.support" "Supported SIMD instruction sets and operations"
-"At present, the SIMD support makes use of SSE2 and a few SSE3 instructions on x86 CPUs."
+"At present, the SIMD support makes use of a subset of SSE up to SSE4.1. The subset used depends on the current CPU type."
$nl
-"SSE3 introduces horizontal adds (summing all components of a single vector register), which is useful for computing dot products. Where available, SSE3 operations are used to speed up " { $link sum } ", " { $link v. } ", " { $link norm-sq } ", " { $link norm } ", and " { $link distance } ". If SSE3 is not available, software fallbacks are used for " { $link sum } " and related words, decreasing performance."
+"SSE1 only supports single-precision SIMD (" { $snippet "float-4" } " and " { $snippet "float-8" } ")."
$nl
-"On PowerPC, or older x86 chips without SSE2, software fallbacks are used for all high-level vector operations. SIMD code can run with no loss in functionality, just decreased performance."
+"SSE2 introduces double-precision SIMD (" { $snippet "double-2" } " and " { $snippet "double-4" } ") and integer SIMD (all types). Integer SIMD in missing a few features, in particular the " { $link vmin } " and " { $link vmax } " operations only work on " { $snippet "uchar-16" } " and " { $snippet "short-8" } "."
+$nl
+"SSE3 introduces horizontal adds (summing all components of a single vector register), which is useful for computing dot products. Where available, SSE3 operations are used to speed up " { $link sum } ", " { $link v. } ", " { $link norm-sq } ", " { $link norm } ", and " { $link distance } "."
+$nl
+"SSSE3 introduces " { $link vabs } " for " { $snippet "char-16" } ", " { $snippet "short-8" } " and " { $snippet "int-4" } "."
+$nl
+"SSE4.1 introduces " { $link vmin } " and " { $link vmax } " for all remaining integer types."
+$nl
+"On PowerPC, or older x86 chips without SSE, software fallbacks are used for all high-level vector operations. SIMD code can run with no loss in functionality, just decreased performance."
$nl
"The primities in the " { $vocab-link "math.vectors.simd.intrinsics" } " vocabulary do not have software fallbacks, but they should not be called directly in any case." ;
ARTICLE: "math.vectors.simd.types" "SIMD vector types"
-"Each SIMD vector type is named " { $snippet "scalar-count" } ", where " { $snippet "scalar" } " is a scalar C type such as " { $snippet "float" } " or " { $snippet "double" } ", and " { $snippet "count" } " is a vector dimension, such as 2, 4, or 8."
-$nl
-"The following vector types are defined:"
-{ $subsection float-4 }
-{ $subsection double-2 }
-{ $subsection float-8 }
-{ $subsection double-4 }
-"For each vector type, several words are defined:"
+"Each SIMD vector type is named " { $snippet "scalar-count" } ", where " { $snippet "scalar" } " is a scalar C type and " { $snippet "count" } " is a vector dimension."
+$nl
+"To use a SIMD vector type, a parsing word is used to generate the relevant code and bring it into the vocabulary search path; this is the same idea as with " { $link "specialized-arrays" } ":"
+{ $subsection POSTPONE: SIMD: }
+"The following vector types are supported:"
+{ $code
+ "char-16"
+ "uchar-16"
+ "char-32"
+ "uchar-32"
+ "short-8"
+ "ushort-8"
+ "short-16"
+ "ushort-16"
+ "int-4"
+ "uint-4"
+ "int-8"
+ "uint-8"
+ "longlong-2"
+ "ulonglong-2"
+ "longlong-4"
+ "ulonglong-4"
+ "float-4"
+ "float-8"
+ "double-2"
+ "double-4"
+} ;
+
+ARTICLE: "math.vectors.simd.words" "SIMD vector words"
+"For each SIMD vector type, several words are defined:"
{ $table
{ "Word" "Stack effect" "Description" }
{ { $snippet "type-with" } { $snippet "( x -- simd-array )" } "creates a new instance where all components are set to a single scalar" }
{ { $snippet ">type" } { $snippet "( seq -- simd-array )" } "creates a new instance initialized with the elements of an existing sequence, which must have the correct length" }
{ { $snippet "type{" } { $snippet "type{ elements... }" } "parsing word defining literal syntax for an SIMD vector; the correct number of elements must be given" }
}
-"The " { $link float-4 } " and " { $link double-2 } " types correspond to 128-bit vector registers. The " { $link float-8 } " and " { $link double-4 } " types are not directly supported in hardware, and instead unbox to a pair of 128-bit vector registers."
-$nl
-"Operations on " { $link float-4 } " instances:"
-{ $subsection float-4-with }
-{ $subsection float-4-boa }
-{ $subsection POSTPONE: float-4{ }
-"Operations on " { $link double-2 } " instances:"
-{ $subsection double-2-with }
-{ $subsection double-2-boa }
-{ $subsection POSTPONE: double-2{ }
-"Operations on " { $link float-8 } " instances:"
-{ $subsection float-8-with }
-{ $subsection float-8-boa }
-{ $subsection POSTPONE: float-8{ }
-"Operations on " { $link double-4 } " instances:"
-{ $subsection double-4-with }
-{ $subsection double-4-boa }
-{ $subsection POSTPONE: double-4{ }
"To actually perform vector arithmetic on SIMD vectors, use " { $link "math-vectors" } " words."
{ $see-also "c-types-specs" } ;
$nl
"For example, in the following, no SIMD operations are used at all, because the compiler's propagation pass does not consider dynamic variable usage:"
{ $code
-<" USING: compiler.tree.debugger math.vectors
+"""USING: compiler.tree.debugger math.vectors
math.vectors.simd ;
SYMBOLS: x y ;
double-4{ 1.5 2.0 3.7 0.4 } x set
double-4{ 1.5 2.0 3.7 0.4 } y set
x get y get v+
-] optimizer-report."> }
+] optimizer-report.""" }
"The following word benefits from SIMD optimization, because it begins with an unsafe declaration:"
{ $code
-<" USING: compiler.tree.debugger kernel.private
+"""USING: compiler.tree.debugger kernel.private
math.vectors math.vectors.simd ;
+SIMD: float
+IN: simd-demo
: interpolate ( v a b -- w )
{ float-4 float-4 float-4 } declare
[ v* ] [ [ 1.0 ] dip n-v v* ] bi-curry* bi v+ ;
-\ interpolate optimizer-report. "> }
+\ interpolate optimizer-report.""" }
"Note that using " { $link declare } " is not recommended. Safer ways of getting type information for the input parameters to a word include defining methods on a generic word (the value being dispatched upon has a statically known type in the method body), as well as using " { $link "hints" } " and " { $link POSTPONE: inline } " declarations."
$nl
"Here is a better version of the " { $snippet "interpolate" } " words above that uses hints:"
{ $code
-<" USING: compiler.tree.debugger hints
+"""USING: compiler.tree.debugger hints
math.vectors math.vectors.simd ;
+SIMD: float
+IN: simd-demo
: interpolate ( v a b -- w )
[ v* ] [ [ 1.0 ] dip n-v v* ] bi-curry* bi v+ ;
HINTS: interpolate float-4 float-4 float-4 ;
-\ interpolate optimizer-report. "> }
+\ interpolate optimizer-report. """ }
"This time, the optimizer report lists calls to both SIMD primitives and high-level vector words, because hints cause two code paths to be generated. The " { $snippet "optimized." } " word can be used to make sure that the fast code path consists entirely of calls to primitives."
$nl
"If the " { $snippet "interpolate" } " word was to be used in several places with different types of vectors, it would be best to declare it " { $link POSTPONE: inline } "."
$nl
"In the " { $snippet "interpolate" } " word, there is still a call to the " { $link <tuple-boa> } " primitive, because the return value at the end is being boxed on the heap. In the next example, no memory allocation occurs at all because the SIMD vectors are stored inside a struct class (see " { $link "classes.struct" } "); also note the use of inlining:"
{ $code
-<" USING: compiler.tree.debugger math.vectors math.vectors.simd ;
+"""USING: compiler.tree.debugger math.vectors math.vectors.simd ;
+SIMD: float
IN: simd-demo
STRUCT: actor
[ >float ] dip
[ update-velocity ] [ update-position ] 2bi ;
-M\ actor advance optimized.">
+M\ actor advance optimized."""
}
"The " { $vocab-link "compiler.cfg.debugger" } " vocabulary can give a lower-level picture of the generated code, that includes register assignments and other low-level details. To look at low-level optimizer output, call " { $snippet "test-mr mr." } " on a word or quotation:"
{ $code
-<" USE: compiler.tree.debugger
+"""USE: compiler.tree.debugger
-M\ actor advance test-mr mr."> }
+M\ actor advance test-mr mr.""" }
"An example of a high-performance algorithm that uses SIMD primitives can be found in the " { $vocab-link "benchmark.nbody-simd" } " vocabulary." ;
ARTICLE: "math.vectors.simd.intrinsics" "Low-level SIMD primitives"
}
"The compiler converts " { $link "math-vectors" } " into SIMD primitives automatically in cases where it is safe; this means that the input types are known to be SIMD vectors, and the CPU supports SIMD."
$nl
-"It is best to avoid calling these primitives directly. To write efficient high-level code that compiles down to primitives and avoids memory allocation, see " { $link "math.vectors.simd.efficiency" } "."
-{ $subsection (simd-v+) }
-{ $subsection (simd-v-) }
-{ $subsection (simd-v/) }
-{ $subsection (simd-vmin) }
-{ $subsection (simd-vmax) }
-{ $subsection (simd-vsqrt) }
-{ $subsection (simd-sum) }
-{ $subsection (simd-broadcast) }
-{ $subsection (simd-gather-2) }
-{ $subsection (simd-gather-4) }
+"It is best to avoid calling SIMD primitives directly. To write efficient high-level code that compiles down to primitives and avoids memory allocation, see " { $link "math.vectors.simd.efficiency" } "."
+$nl
"There are two primitives which are used to implement accessing SIMD vector fields of " { $link "classes.struct" } ":"
{ $subsection alien-vector }
{ $subsection set-alien-vector }
"For the most part, the above primitives correspond directly to vector arithmetic words. They take a representation parameter, which is one of the singleton members of the " { $link vector-rep } " union in the " { $vocab-link "cpu.architecture" } " vocabulary." ;
ARTICLE: "math.vectors.simd.alien" "SIMD data in struct classes"
-"Struct classes may contain fields which store SIMD data; use one of the following C type names:"
-{ $code
-<" float-4
-double-2
-float-8
-double-4"> }
-"Passing SIMD data as function parameters is not yet supported." ;
+"Struct classes may contain fields which store SIMD data; for each SIMD vector type listed in " { $snippet "math.vectors.simd.types" } " there is a C type with the same name."
+$nl
+"Only SIMD struct fields are allowed at the moment; passing SIMD data as function parameters is not yet supported." ;
+
+ARTICLE: "math.vectors.simd.accuracy" "Numerical accuracy of SIMD primitives"
+"No guarantees are made that " { $vocab-link "math.vectors.simd" } " words will give identical results on different SSE versions, or between the hardware intrinsics and the software fallbacks."
+$nl
+"In particular, horizontal operations on " { $snippet "float-4" } " and " { $snippet "float-8" } " are affected by this. They are computed with lower precision in intrinsics than the software fallback. Horizontal opeartions include anything involving adding together the components of a vector, such as " { $link sum } " or " { $link normalize } "." ;
ARTICLE: "math.vectors.simd" "Hardware vector arithmetic (SIMD)"
"The " { $vocab-link "math.vectors.simd" } " vocabulary extends the " { $vocab-link "math.vectors" } " vocabulary to support efficient vector arithmetic on small, fixed-size vectors."
{ $subsection "math.vectors.simd.intro" }
{ $subsection "math.vectors.simd.types" }
+{ $subsection "math.vectors.simd.words" }
{ $subsection "math.vectors.simd.support" }
+{ $subsection "math.vectors.simd.accuracy" }
{ $subsection "math.vectors.simd.efficiency" }
{ $subsection "math.vectors.simd.alien" }
{ $subsection "math.vectors.simd.intrinsics" } ;
-! ! ! float-4
-
-HELP: float-4
-{ $class-description "A sequence of four single-precision floating point values. New instances can be created with " { $link float-4-with } " or " { $link float-4-boa } "." } ;
-
-HELP: float-4-with
-{ $values { "x" float } { "simd-array" float-4 } }
-{ $description "Creates a new vector with all four components equal to a scalar." } ;
-
-HELP: float-4-boa
-{ $values { "a" float } { "b" float } { "c" float } { "d" float } { "simd-array" float-4 } }
-{ $description "Creates a new vector from four scalar components." } ;
-
-HELP: float-4{
-{ $syntax "float-4{ a b c d }" }
-{ $description "Literal syntax for a " { $link float-4 } "." } ;
-
-! ! ! double-2
-
-HELP: double-2
-{ $class-description "A sequence of two double-precision floating point values. New instances can be created with " { $link double-2-with } " or " { $link double-2-boa } "." } ;
-
-HELP: double-2-with
-{ $values { "x" float } { "simd-array" double-2 } }
-{ $description "Creates a new vector with both components equal to a scalar." } ;
-
-HELP: double-2-boa
-{ $values { "a" float } { "b" float } { "simd-array" double-2 } }
-{ $description "Creates a new vector from two scalar components." } ;
-
-HELP: double-2{
-{ $syntax "double-2{ a b }" }
-{ $description "Literal syntax for a " { $link double-2 } "." } ;
-
-! ! ! float-8
-
-HELP: float-8
-{ $class-description "A sequence of eight single-precision floating point values. New instances can be created with " { $link float-8-with } " or " { $link float-8-boa } "." } ;
-
-HELP: float-8-with
-{ $values { "x" float } { "simd-array" float-8 } }
-{ $description "Creates a new vector with all eight components equal to a scalar." } ;
-
-HELP: float-8-boa
-{ $values { "a" float } { "b" float } { "c" float } { "d" float } { "e" float } { "f" float } { "g" float } { "h" float } { "simd-array" float-8 } }
-{ $description "Creates a new vector from eight scalar components." } ;
-
-HELP: float-8{
-{ $syntax "float-8{ a b c d e f g h }" }
-{ $description "Literal syntax for a " { $link float-8 } "." } ;
-
-! ! ! double-4
-
-HELP: double-4
-{ $class-description "A sequence of four double-precision floating point values. New instances can be created with " { $link double-4-with } " or " { $link double-4-boa } "." } ;
-
-HELP: double-4-with
-{ $values { "x" float } { "simd-array" double-4 } }
-{ $description "Creates a new vector with all four components equal to a scalar." } ;
-
-HELP: double-4-boa
-{ $values { "a" float } { "b" float } { "c" float } { "d" float } { "simd-array" double-4 } }
-{ $description "Creates a new vector from four scalar components." } ;
-
-HELP: double-4{
-{ $syntax "double-4{ a b c d }" }
-{ $description "Literal syntax for a " { $link double-4 } "." } ;
+HELP: SIMD:
+{ $syntax "SIMD: type" }
+{ $values { "type" "a scalar C type" } }
+{ $description "Defines 128-bit and 256-bit SIMD arrays for holding elements of " { $snippet "type" } " into the vocabulary search path. The possible type/length combinations are listed in " { $link "math.vectors.simd.types" } " and the generated words are documented in " { $link "math.vectors.simd.words" } "." } ;
ABOUT: "math.vectors.simd"
+USING: accessors arrays classes compiler compiler.tree.debugger
+effects fry io kernel kernel.private math math.functions
+math.private math.vectors math.vectors.simd
+math.vectors.simd.private prettyprint random sequences system
+tools.test vocabs assocs compiler.cfg.debugger words
+locals math.vectors.specialization combinators cpu.architecture
+math.vectors.simd.intrinsics namespaces byte-arrays alien
+specialized-arrays classes.struct eval ;
+FROM: alien.c-types => c-type-boxed-class ;
+SPECIALIZED-ARRAY: float
+SIMD: char
+SIMD: uchar
+SIMD: short
+SIMD: ushort
+SIMD: int
+SIMD: uint
+SIMD: longlong
+SIMD: ulonglong
+SIMD: float
+SIMD: double
IN: math.vectors.simd.tests
-USING: math math.vectors.simd math.vectors.simd.private
-math.vectors math.functions math.private kernel.private compiler
-sequences tools.test compiler.tree.debugger accessors kernel
-system ;
-[ float-4{ 0 0 0 0 } ] [ float-4 new ] unit-test
+! Make sure the functor doesn't generate bogus vocabularies
+2 [ [ "USE: math.vectors.simd SIMD: rubinius" eval( -- ) ] must-fail ] times
-[ float-4{ 0 0 0 0 } ] [ [ float-4 new ] compile-call ] unit-test
+[ f ] [ "math.vectors.simd.instances.rubinius" vocab ] unit-test
+! Test type propagation
[ V{ float } ] [ [ { float-4 } declare norm-sq ] final-classes ] unit-test
[ V{ float } ] [ [ { float-4 } declare norm ] final-classes ] unit-test
-[ float-4{ 12 12 12 12 } ] [
- 12 [ float-4-with ] compile-call
-] unit-test
-
-[ float-4{ 1 2 3 4 } ] [
- 1 2 3 4 [ float-4-boa ] compile-call
-] unit-test
-
-[ float-4{ 11 22 33 44 } ] [
- float-4{ 1 2 3 4 } float-4{ 10 20 30 40 }
- [ { float-4 float-4 } declare v+ ] compile-call
-] unit-test
-
-[ float-4{ -9 -18 -27 -36 } ] [
- float-4{ 1 2 3 4 } float-4{ 10 20 30 40 }
- [ { float-4 float-4 } declare v- ] compile-call
-] unit-test
-
-[ float-4{ 10 40 90 160 } ] [
- float-4{ 1 2 3 4 } float-4{ 10 20 30 40 }
- [ { float-4 float-4 } declare v* ] compile-call
-] unit-test
-
-[ float-4{ 10 100 1000 10000 } ] [
- float-4{ 100 2000 30000 400000 } float-4{ 10 20 30 40 }
- [ { float-4 float-4 } declare v/ ] compile-call
-] unit-test
-
-[ float-4{ -10 -20 -30 -40 } ] [
- float-4{ -10 20 -30 40 } float-4{ 10 -20 30 -40 }
- [ { float-4 float-4 } declare vmin ] compile-call
-] unit-test
-
-[ float-4{ 10 20 30 40 } ] [
- float-4{ -10 20 -30 40 } float-4{ 10 -20 30 -40 }
- [ { float-4 float-4 } declare vmax ] compile-call
-] unit-test
-
-[ 10.0 ] [
- float-4{ 1 2 3 4 }
- [ { float-4 } declare sum ] compile-call
-] unit-test
+[ V{ float-4 } ] [ [ { float-4 } declare normalize ] final-classes ] unit-test
-[ 13.0 ] [
- float-4{ 1 2 3 4 }
- [ { float-4 } declare sum 3.0 + ] compile-call
-] unit-test
+[ V{ float-4 } ] [ [ { float-4 float-4 } declare v+ ] final-classes ] unit-test
-[ 8.0 ] [
- float-4{ 1 2 3 4 } float-4{ 2 0 2 0 }
- [ { float-4 float-4 } declare v. ] compile-call
-] unit-test
+! Test puns; only on x86
+cpu x86? [
+ [ double-2{ 4 1024 } ] [
+ float-4{ 0 1 0 2 }
+ [ { float-4 } declare dup v+ underlying>> double-2 boa dup v+ ] compile-call
+ ] unit-test
+
+ [ 33.0 ] [
+ double-2{ 1 2 } double-2{ 10 20 }
+ [ { double-2 double-2 } declare v+ underlying>> 3.0 float* ] compile-call
+ ] unit-test
+] when
-[ float-4{ 5 10 15 20 } ] [
- 5.0 float-4{ 1 2 3 4 }
- [ { float float-4 } declare n*v ] compile-call
+! Fuzz testing
+CONSTANT: simd-classes
+ {
+ char-16
+ uchar-16
+ char-32
+ uchar-32
+ short-8
+ ushort-8
+ short-16
+ ushort-16
+ int-4
+ uint-4
+ int-8
+ uint-8
+ longlong-2
+ ulonglong-2
+ longlong-4
+ ulonglong-4
+ float-4
+ float-8
+ double-2
+ double-4
+ }
+
+: with-ctors ( -- seq )
+ simd-classes [ [ name>> "-with" append ] [ vocabulary>> ] bi lookup ] map ;
+
+: boa-ctors ( -- seq )
+ simd-classes [ [ name>> "-boa" append ] [ vocabulary>> ] bi lookup ] map ;
+
+: check-optimizer ( seq inputs quot eq-quot -- )
+ '[
+ @
+ [ "print-mr" get [ nip test-mr mr. ] [ 2drop ] if ]
+ [ [ call ] dip call ]
+ [ [ call ] dip compile-call ] 2tri @ not
+ ] filter ; inline
+
+"== Checking -new constructors" print
+
+[ { } ] [
+ simd-classes [ [ [ ] ] dip '[ _ new ] ] [ = ] check-optimizer
+] unit-test
+
+[ { } ] [
+ simd-classes [ '[ _ new ] compile-call [ zero? ] all? not ] filter
+] unit-test
+
+"== Checking -with constructors" print
+
+[ { } ] [
+ with-ctors [
+ [ 1000 random '[ _ ] ] dip '[ { fixnum } declare _ execute ]
+ ] [ = ] check-optimizer
+] unit-test
+
+"== Checking -boa constructors" print
+
+[ { } ] [
+ boa-ctors [
+ dup stack-effect in>> length
+ [ nip [ 1000 random ] [ ] replicate-as ]
+ [ fixnum <array> swap '[ _ declare _ execute ] ]
+ 2bi
+ ] [ = ] check-optimizer
+] unit-test
+
+"== Checking vector operations" print
+
+: random-vector ( class -- vec )
+ new [ drop 1000 random ] map ;
+
+:: check-vector-op ( word inputs class elt-class -- inputs quot )
+ inputs [
+ [
+ {
+ { +vector+ [ class random-vector ] }
+ { +scalar+ [ 1000 random elt-class float = [ >float ] when ] }
+ } case
+ ] [ ] map-as
+ ] [
+ [
+ {
+ { +vector+ [ class ] }
+ { +scalar+ [ elt-class ] }
+ } case
+ ] map
+ ] bi
+ word '[ _ declare _ execute ] ;
+
+: remove-float-words ( alist -- alist' )
+ [ drop { vsqrt n/v v/n v/ normalize } member? not ] assoc-filter ;
+
+: ops-to-check ( elt-class -- alist )
+ [ vector-words >alist ] dip
+ float = [ remove-float-words ] unless ;
+
+: check-vector-ops ( class elt-class compare-quot -- )
+ [
+ [ nip ops-to-check ] 2keep
+ '[ first2 inputs _ _ check-vector-op ]
+ ] dip check-optimizer ; inline
+
+: approx= ( x y -- ? )
+ {
+ { [ 2dup [ float? ] both? ] [ -1.e8 ~ ] }
+ { [ 2dup [ sequence? ] both? ] [
+ [
+ {
+ { [ 2dup [ fp-nan? ] both? ] [ 2drop t ] }
+ { [ 2dup [ fp-nan? ] either? not ] [ -1.e8 ~ ] }
+ } cond
+ ] 2all?
+ ] }
+ } cond ;
+
+: simd-classes&reps ( -- alist )
+ simd-classes [
+ {
+ { [ dup name>> "float" head? ] [ float [ approx= ] ] }
+ { [ dup name>> "double" tail? ] [ float [ = ] ] }
+ [ fixnum [ = ] ]
+ } cond 3array
+ ] map ;
+
+simd-classes&reps [
+ [ [ { } ] ] dip first3 '[ _ _ _ check-vector-ops ] unit-test
+] each
+
+! Other regressions
+[ 8000000 ] [
+ int-8{ 1000 1000 1000 1000 1000 1000 1000 1000 }
+ [ { int-8 } declare dup [ * ] [ + ] 2map-reduce ] compile-call
+] unit-test
+
+! Vector alien intrinsics
+[ float-4{ 1 2 3 4 } ] [
+ [
+ float-4{ 1 2 3 4 }
+ underlying>> 0 float-4-rep alien-vector
+ ] compile-call float-4 boa
] unit-test
-[ float-4{ 5 10 15 20 } ] [
- float-4{ 1 2 3 4 } 5.0
- [ { float float-4 } declare v*n ] compile-call
+[ B{ 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 } ] [
+ 16 [ 1 ] B{ } replicate-as 16 <byte-array>
+ [
+ 0 [
+ { byte-array c-ptr fixnum } declare
+ float-4-rep set-alien-vector
+ ] compile-call
+ ] keep
] unit-test
-[ float-4{ 10 5 2 5 } ] [
- 10.0 float-4{ 1 2 5 2 }
- [ { float float-4 } declare n/v ] compile-call
+[ float-array{ 1 2 3 4 } ] [
+ [
+ float-array{ 1 2 3 4 } underlying>>
+ float-array{ 4 3 2 1 } clone
+ [ underlying>> 0 float-4-rep set-alien-vector ] keep
+ ] compile-call
] unit-test
-[ float-4{ 0.5 1 1.5 2 } ] [
- float-4{ 1 2 3 4 } 2
- [ { float float-4 } declare v/n ] compile-call
-] unit-test
+STRUCT: simd-struct
+{ x float-4 }
+{ y double-2 }
+{ z double-4 }
+{ w float-8 } ;
-[ float-4{ 1 0 0 0 } ] [
- float-4{ 10 0 0 0 }
- [ { float-4 } declare normalize ] compile-call
-] unit-test
+[ t ] [ [ simd-struct <struct> ] compile-call >c-ptr [ 0 = ] all? ] unit-test
-[ 30.0 ] [
+[
float-4{ 1 2 3 4 }
- [ { float-4 } declare norm-sq ] compile-call
-] unit-test
-
-[ t ] [
- float-4{ 1 0 0 0 }
- float-4{ 0 1 0 0 }
- [ { float-4 float-4 } declare distance ] compile-call
- 2 sqrt 1.0e-6 ~
-] unit-test
-
-[ double-2{ 12 12 } ] [
- 12 [ double-2-with ] compile-call
-] unit-test
-
-[ double-2{ 1 2 } ] [
- 1 2 [ double-2-boa ] compile-call
-] unit-test
-
-[ double-2{ 11 22 } ] [
- double-2{ 1 2 } double-2{ 10 20 }
- [ { double-2 double-2 } declare v+ ] compile-call
-] unit-test
-
-[ double-2{ -9 -18 } ] [
- double-2{ 1 2 } double-2{ 10 20 }
- [ { double-2 double-2 } declare v- ] compile-call
-] unit-test
-
-[ double-2{ 10 40 } ] [
- double-2{ 1 2 } double-2{ 10 20 }
- [ { double-2 double-2 } declare v* ] compile-call
-] unit-test
-
-[ double-2{ 10 100 } ] [
- double-2{ 100 2000 } double-2{ 10 20 }
- [ { double-2 double-2 } declare v/ ] compile-call
-] unit-test
-
-[ double-2{ -10 -20 } ] [
- double-2{ -10 20 } double-2{ 10 -20 }
- [ { double-2 double-2 } declare vmin ] compile-call
-] unit-test
-
-[ double-2{ 10 20 } ] [
- double-2{ -10 20 } double-2{ 10 -20 }
- [ { double-2 double-2 } declare vmax ] compile-call
-] unit-test
-
-[ 3.0 ] [
- double-2{ 1 2 }
- [ { double-2 } declare sum ] compile-call
-] unit-test
-
-[ 7.0 ] [
- double-2{ 1 2 }
- [ { double-2 } declare sum 4.0 + ] compile-call
-] unit-test
-
-[ 16.0 ] [
- double-2{ 1 2 } double-2{ 2 7 }
- [ { double-2 double-2 } declare v. ] compile-call
-] unit-test
-
-[ double-2{ 5 10 } ] [
- 5.0 double-2{ 1 2 }
- [ { float double-2 } declare n*v ] compile-call
-] unit-test
-
-[ double-2{ 5 10 } ] [
- double-2{ 1 2 } 5.0
- [ { float double-2 } declare v*n ] compile-call
-] unit-test
-
-[ double-2{ 10 5 } ] [
- 10.0 double-2{ 1 2 }
- [ { float double-2 } declare n/v ] compile-call
-] unit-test
-
-[ double-2{ 0.5 1 } ] [
- double-2{ 1 2 } 2
- [ { float double-2 } declare v/n ] compile-call
-] unit-test
-
-[ double-2{ 0 0 } ] [ double-2 new ] unit-test
-
-[ double-2{ 1 0 } ] [
- double-2{ 10 0 }
- [ { double-2 } declare normalize ] compile-call
-] unit-test
-
-[ 5.0 ] [
- double-2{ 1 2 }
- [ { double-2 } declare norm-sq ] compile-call
-] unit-test
-
-[ t ] [
- double-2{ 1 0 }
- double-2{ 0 1 }
- [ { double-2 double-2 } declare distance ] compile-call
- 2 sqrt 1.0e-6 ~
-] unit-test
-
-[ double-4{ 0 0 0 0 } ] [ double-4 new ] unit-test
-
-[ double-4{ 1 2 3 4 } ] [
- 1 2 3 4 double-4-boa
-] unit-test
-
-[ double-4{ 1 1 1 1 } ] [
- 1 double-4-with
-] unit-test
-
-[ double-4{ 0 1 2 3 } ] [
- 1 double-4-with [ * ] map-index
-] unit-test
-
-[ V{ float } ] [ [ { double-4 } declare norm-sq ] final-classes ] unit-test
-
-[ V{ float } ] [ [ { double-4 } declare norm ] final-classes ] unit-test
-
-[ double-4{ 12 12 12 12 } ] [
- 12 [ double-4-with ] compile-call
-] unit-test
-
-[ double-4{ 1 2 3 4 } ] [
- 1 2 3 4 [ double-4-boa ] compile-call
-] unit-test
-
-[ double-4{ 11 22 33 44 } ] [
- double-4{ 1 2 3 4 } double-4{ 10 20 30 40 }
- [ { double-4 double-4 } declare v+ ] compile-call
-] unit-test
-
-[ double-4{ -9 -18 -27 -36 } ] [
- double-4{ 1 2 3 4 } double-4{ 10 20 30 40 }
- [ { double-4 double-4 } declare v- ] compile-call
-] unit-test
-
-[ double-4{ 10 40 90 160 } ] [
- double-4{ 1 2 3 4 } double-4{ 10 20 30 40 }
- [ { double-4 double-4 } declare v* ] compile-call
-] unit-test
-
-[ double-4{ 10 100 1000 10000 } ] [
- double-4{ 100 2000 30000 400000 } double-4{ 10 20 30 40 }
- [ { double-4 double-4 } declare v/ ] compile-call
-] unit-test
-
-[ double-4{ -10 -20 -30 -40 } ] [
- double-4{ -10 20 -30 40 } double-4{ 10 -20 30 -40 }
- [ { double-4 double-4 } declare vmin ] compile-call
-] unit-test
-
-[ double-4{ 10 20 30 40 } ] [
- double-4{ -10 20 -30 40 } double-4{ 10 -20 30 -40 }
- [ { double-4 double-4 } declare vmax ] compile-call
-] unit-test
-
-[ 10.0 ] [
- double-4{ 1 2 3 4 }
- [ { double-4 } declare sum ] compile-call
-] unit-test
-
-[ 13.0 ] [
- double-4{ 1 2 3 4 }
- [ { double-4 } declare sum 3.0 + ] compile-call
-] unit-test
-
-[ 8.0 ] [
- double-4{ 1 2 3 4 } double-4{ 2 0 2 0 }
- [ { double-4 double-4 } declare v. ] compile-call
-] unit-test
-
-[ double-4{ 5 10 15 20 } ] [
- 5.0 double-4{ 1 2 3 4 }
- [ { float double-4 } declare n*v ] compile-call
-] unit-test
-
-[ double-4{ 5 10 15 20 } ] [
- double-4{ 1 2 3 4 } 5.0
- [ { float double-4 } declare v*n ] compile-call
-] unit-test
-
-[ double-4{ 10 5 2 5 } ] [
- 10.0 double-4{ 1 2 5 2 }
- [ { float double-4 } declare n/v ] compile-call
-] unit-test
-
-[ double-4{ 0.5 1 1.5 2 } ] [
- double-4{ 1 2 3 4 } 2
- [ { float double-4 } declare v/n ] compile-call
-] unit-test
-
-[ double-4{ 1 0 0 0 } ] [
- double-4{ 10 0 0 0 }
- [ { double-4 } declare normalize ] compile-call
-] unit-test
-
-[ 30.0 ] [
- double-4{ 1 2 3 4 }
- [ { double-4 } declare norm-sq ] compile-call
-] unit-test
-
-[ t ] [
- double-4{ 1 0 0 0 }
- double-4{ 0 1 0 0 }
- [ { double-4 double-4 } declare distance ] compile-call
- 2 sqrt 1.0e-6 ~
-] unit-test
-
-[ float-8{ 0 0 0 0 0 0 0 0 } ] [ float-8 new ] unit-test
-
-[ float-8{ 0 0 0 0 0 0 0 0 } ] [ [ float-8 new ] compile-call ] unit-test
-
-[ float-8{ 1 1 1 1 1 1 1 1 } ] [ 1 float-8-with ] unit-test
-
-[ float-8{ 1 1 1 1 1 1 1 1 } ] [ [ 1 float-8-with ] compile-call ] unit-test
-
-[ float-8{ 1 2 3 4 5 6 7 8 } ] [ 1 2 3 4 5 6 7 8 float-8-boa ] unit-test
-
-[ float-8{ 1 2 3 4 5 6 7 8 } ] [ [ 1 2 3 4 5 6 7 8 float-8-boa ] compile-call ] unit-test
-
-[ float-8{ 3 6 9 12 15 18 21 24 } ] [
+ double-2{ 2 1 }
+ double-4{ 4 3 2 1 }
float-8{ 1 2 3 4 5 6 7 8 }
- float-8{ 2 4 6 8 10 12 14 16 }
- [ { float-8 float-8 } declare v+ ] compile-call
+] [
+ simd-struct <struct>
+ float-4{ 1 2 3 4 } >>x
+ double-2{ 2 1 } >>y
+ double-4{ 4 3 2 1 } >>z
+ float-8{ 1 2 3 4 5 6 7 8 } >>w
+ { [ x>> ] [ y>> ] [ z>> ] [ w>> ] } cleave
] unit-test
-[ float-8{ -1 -2 -3 -4 -5 -6 -7 -8 } ] [
+[
+ float-4{ 1 2 3 4 }
+ double-2{ 2 1 }
+ double-4{ 4 3 2 1 }
float-8{ 1 2 3 4 5 6 7 8 }
- float-8{ 2 4 6 8 10 12 14 16 }
- [ { float-8 float-8 } declare v- ] compile-call
-] unit-test
-
-[ float-8{ -1 -2 -3 -4 -5 -6 -7 -8 } ] [
- -0.5
- float-8{ 2 4 6 8 10 12 14 16 }
- [ { float float-8 } declare n*v ] compile-call
-] unit-test
-
-[ float-8{ -1 -2 -3 -4 -5 -6 -7 -8 } ] [
- float-8{ 2 4 6 8 10 12 14 16 }
- -0.5
- [ { float-8 float } declare v*n ] compile-call
-] unit-test
-
-[ float-8{ 256 128 64 32 16 8 4 2 } ] [
- 256.0
- float-8{ 1 2 4 8 16 32 64 128 }
- [ { float float-8 } declare n/v ] compile-call
-] unit-test
-
-[ float-8{ -1 -2 -3 -4 -5 -6 -7 -8 } ] [
- float-8{ 2 4 6 8 10 12 14 16 }
- -2.0
- [ { float-8 float } declare v/n ] compile-call
-] unit-test
-
-! Test puns; only on x86
-cpu x86? [
- [ double-2{ 4 1024 } ] [
- float-4{ 0 1 0 2 }
- [ { float-4 } declare dup v+ underlying>> double-2 boa dup v+ ] compile-call
- ] unit-test
-
- [ 33.0 ] [
- double-2{ 1 2 } double-2{ 10 20 }
- [ { double-2 double-2 } declare v+ underlying>> 3.0 float* ] compile-call
- ] unit-test
-] when
+] [
+ [
+ simd-struct <struct>
+ float-4{ 1 2 3 4 } >>x
+ double-2{ 2 1 } >>y
+ double-4{ 4 3 2 1 } >>z
+ float-8{ 1 2 3 4 5 6 7 8 } >>w
+ { [ x>> ] [ y>> ] [ z>> ] [ w>> ] } cleave
+ ] compile-call
+] unit-test
+
+[ ] [ char-16 new 1array stack. ] unit-test
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien.c-types byte-arrays cpu.architecture
-kernel math math.functions math.vectors
-math.vectors.simd.functor math.vectors.simd.intrinsics
-math.vectors.specialization parser prettyprint.custom sequences
-sequences.private locals assocs words fry ;
+USING: alien.c-types combinators fry kernel lexer math math.parser
+math.vectors.simd.functor sequences splitting vocabs.generated
+vocabs.loader vocabs.parser words ;
+QUALIFIED-WITH: alien.c-types c
IN: math.vectors.simd
-<<
-
-DEFER: float-4
-DEFER: double-2
-DEFER: float-8
-DEFER: double-4
-
-"double" define-simd-128
-"float" define-simd-128
-"double" define-simd-256
-"float" define-simd-256
-
->>
-
-: float-4-with ( x -- simd-array )
- [ 4 ] dip >float '[ _ ] \ float-4 new replicate-as ;
-
-: float-4-boa ( a b c d -- simd-array )
- \ float-4 new 4sequence ;
-
-: double-2-with ( x -- simd-array )
- [ 2 ] dip >float '[ _ ] \ double-2 new replicate-as ;
-
-: double-2-boa ( a b -- simd-array )
- \ double-2 new 2sequence ;
-
-! More efficient expansions for the above, used when SIMD is
-! actually available.
-
-<<
-
-\ float-4-with [
- drop
- \ (simd-broadcast) "intrinsic" word-prop [
- [ >float float-4-rep (simd-broadcast) \ float-4 boa ]
- ] [ \ float-4-with def>> ] if
-] "custom-inlining" set-word-prop
-
-\ float-4-boa [
- drop
- \ (simd-gather-4) "intrinsic" word-prop [
- [| a b c d |
- a >float b >float c >float d >float
- float-4-rep (simd-gather-4) \ float-4 boa
- ]
- ] [ \ float-4-boa def>> ] if
-] "custom-inlining" set-word-prop
-
-\ double-2-with [
- drop
- \ (simd-broadcast) "intrinsic" word-prop [
- [ >float double-2-rep (simd-broadcast) \ double-2 boa ]
- ] [ \ double-2-with def>> ] if
-] "custom-inlining" set-word-prop
-
-\ double-2-boa [
- drop
- \ (simd-gather-4) "intrinsic" word-prop [
- [ [ >float ] bi@ double-2-rep (simd-gather-2) \ double-2 boa ]
- ] [ \ double-2-boa def>> ] if
-] "custom-inlining" set-word-prop
-
->>
-
-: float-8-with ( x -- simd-array )
- [ float-4-with ] [ float-4-with ] bi [ underlying>> ] bi@
- \ float-8 boa ; inline
-
-:: float-8-boa ( a b c d e f g h -- simd-array )
- a b c d float-4-boa
- e f g h float-4-boa
- [ underlying>> ] bi@
- \ float-8 boa ; inline
-
-: double-4-with ( x -- simd-array )
- [ double-2-with ] [ double-2-with ] bi [ underlying>> ] bi@
- \ double-4 boa ; inline
-
-:: double-4-boa ( a b c d -- simd-array )
- a b double-2-boa
- c d double-2-boa
- [ underlying>> ] bi@
- \ double-4 boa ; inline
-
-<<
+ERROR: bad-base-type type ;
<PRIVATE
-! Filter out operations that are not available, eg horizontal adds
-! on SSE2. Fallback code in math.vectors is used in that case.
-
-: supported-simd-ops ( assoc -- assoc' )
- {
- { v+ (simd-v+) }
- { v- (simd-v-) }
- { v* (simd-v*) }
- { v/ (simd-v/) }
- { vmin (simd-vmin) }
- { vmax (simd-vmax) }
- { sum (simd-sum) }
- } [ nip "intrinsic" word-prop ] assoc-filter
- '[ drop _ key? ] assoc-filter ;
-
-! Some SIMD operations are defined in terms of others.
+: simd-vocab ( base-type -- vocab )
+ "math.vectors.simd.instances." prepend ;
-:: high-level-ops ( ctor -- assoc )
+: parse-base-type ( string -- c-type )
{
- { vneg [ [ dup v- ] keep v- ] }
- { v. [ v* sum ] }
- { n+v [ [ ctor execute ] dip v+ ] }
- { v+n [ ctor execute v+ ] }
- { n-v [ [ ctor execute ] dip v- ] }
- { v-n [ ctor execute v- ] }
- { n*v [ [ ctor execute ] dip v* ] }
- { v*n [ ctor execute v* ] }
- { n/v [ [ ctor execute ] dip v/ ] }
- { v/n [ ctor execute v/ ] }
- { norm-sq [ dup v. assert-positive ] }
- { norm [ norm-sq sqrt ] }
- { normalize [ dup norm v/n ] }
- { distance [ v- norm ] }
- } ;
-
-:: simd-vector-words ( class ctor elt-type assoc -- )
- class elt-type assoc supported-simd-ops ctor high-level-ops assoc-union
- specialize-vector-words ;
+ { "char" [ c:char ] }
+ { "uchar" [ c:uchar ] }
+ { "short" [ c:short ] }
+ { "ushort" [ c:ushort ] }
+ { "int" [ c:int ] }
+ { "uint" [ c:uint ] }
+ { "longlong" [ c:longlong ] }
+ { "ulonglong" [ c:ulonglong ] }
+ { "float" [ c:float ] }
+ { "double" [ c:double ] }
+ [ bad-base-type ]
+ } case ;
PRIVATE>
-\ float-4 \ float-4-with float H{
- { v+ [ [ (simd-v+) ] float-4-vv->v-op ] }
- { v- [ [ (simd-v-) ] float-4-vv->v-op ] }
- { v* [ [ (simd-v*) ] float-4-vv->v-op ] }
- { v/ [ [ (simd-v/) ] float-4-vv->v-op ] }
- { vmin [ [ (simd-vmin) ] float-4-vv->v-op ] }
- { vmax [ [ (simd-vmax) ] float-4-vv->v-op ] }
- { sum [ [ (simd-sum) ] float-4-v->n-op ] }
-} simd-vector-words
-
-\ double-2 \ double-2-with float H{
- { v+ [ [ (simd-v+) ] double-2-vv->v-op ] }
- { v- [ [ (simd-v-) ] double-2-vv->v-op ] }
- { v* [ [ (simd-v*) ] double-2-vv->v-op ] }
- { v/ [ [ (simd-v/) ] double-2-vv->v-op ] }
- { vmin [ [ (simd-vmin) ] double-2-vv->v-op ] }
- { vmax [ [ (simd-vmax) ] double-2-vv->v-op ] }
- { sum [ [ (simd-sum) ] double-2-v->n-op ] }
-} simd-vector-words
-
-\ float-8 \ float-8-with float H{
- { v+ [ [ (simd-v+) ] float-8-vv->v-op ] }
- { v- [ [ (simd-v-) ] float-8-vv->v-op ] }
- { v* [ [ (simd-v*) ] float-8-vv->v-op ] }
- { v/ [ [ (simd-v/) ] float-8-vv->v-op ] }
- { vmin [ [ (simd-vmin) ] float-8-vv->v-op ] }
- { vmax [ [ (simd-vmax) ] float-8-vv->v-op ] }
- { sum [ [ (simd-sum) ] [ + ] float-8-v->n-op ] }
-} simd-vector-words
-
-\ double-4 \ double-4-with float H{
- { v+ [ [ (simd-v+) ] double-4-vv->v-op ] }
- { v- [ [ (simd-v-) ] double-4-vv->v-op ] }
- { v* [ [ (simd-v*) ] double-4-vv->v-op ] }
- { v/ [ [ (simd-v/) ] double-4-vv->v-op ] }
- { vmin [ [ (simd-vmin) ] double-4-vv->v-op ] }
- { vmax [ [ (simd-vmax) ] double-4-vv->v-op ] }
- { sum [ [ (simd-v+) ] [ (simd-sum) ] double-4-v->n-op ] }
-} simd-vector-words
-
->>
-
-USE: vocabs.loader
+: define-simd-vocab ( type -- vocab )
+ [ simd-vocab ] keep '[
+ _ parse-base-type
+ [ define-simd-128 ]
+ [ define-simd-256 ] bi
+ ] generate-vocab ;
-"math.vectors.simd.alien" require
+SYNTAX: SIMD:
+ scan define-simd-vocab use-vocab ;
--- /dev/null
+Single-instruction-multiple-data parallel vector operations
{ norm-sq { +vector+ -> +nonnegative+ } }
{ normalize { +vector+ -> +vector+ } }
{ v* { +vector+ +vector+ -> +vector+ } }
+ { vs* { +vector+ +vector+ -> +vector+ } }
{ v*n { +vector+ +scalar+ -> +vector+ } }
{ v+ { +vector+ +vector+ -> +vector+ } }
+ { vs+ { +vector+ +vector+ -> +vector+ } }
+ { v+- { +vector+ +vector+ -> +vector+ } }
{ v+n { +vector+ +scalar+ -> +vector+ } }
{ v- { +vector+ +vector+ -> +vector+ } }
+ { vs- { +vector+ +vector+ -> +vector+ } }
{ v-n { +vector+ +scalar+ -> +vector+ } }
{ v. { +vector+ +vector+ -> +scalar+ } }
{ v/ { +vector+ +vector+ -> +vector+ } }
{ vneg { +vector+ -> +vector+ } }
{ vtruncate { +vector+ -> +vector+ } }
{ sum { +vector+ -> +scalar+ } }
+ { vabs { +vector+ -> +vector+ } }
+ { vsqrt { +vector+ -> +vector+ } }
+ { vbitand { +vector+ +vector+ -> +vector+ } }
+ { vbitor { +vector+ +vector+ -> +vector+ } }
+ { vbitxor { +vector+ +vector+ -> +vector+ } }
}
PREDICATE: vector-word < word vector-words key? ;
-USING: help.markup help.syntax math sequences ;
+USING: help.markup help.syntax math math.functions sequences ;
IN: math.vectors
ARTICLE: "math-vectors" "Vector arithmetic"
{ $subsection n+v }
{ $subsection v-n }
{ $subsection n-v }
-"Combining two vectors to form another vector with " { $link 2map } ":"
+"Vector unary operations:"
+{ $subsection vneg }
+{ $subsection vabs }
+{ $subsection vsqrt }
+{ $subsection vfloor }
+{ $subsection vceiling }
+{ $subsection vtruncate }
+"Vector/vector binary operations:"
{ $subsection v+ }
{ $subsection v- }
+{ $subsection v+- }
{ $subsection v* }
{ $subsection v/ }
+"Saturated arithmetic (only on " { $link "specialized-arrays" } "):"
+{ $subsection vs+ }
+{ $subsection vs- }
+{ $subsection vs* }
+"Comparisons:"
{ $subsection vmax }
{ $subsection vmin }
+"Bitwise operations:"
+{ $subsection vbitand }
+{ $subsection vbitor }
+{ $subsection vbitxor }
"Inner product and norm:"
{ $subsection v. }
{ $subsection norm }
{ $subsection norm-sq }
-{ $subsection normalize } ;
+{ $subsection normalize }
+"Comparing vectors:"
+{ $subsection distance }
+{ $subsection v~ }
+"Other functions:"
+{ $subsection vsupremum }
+{ $subsection vinfimum }
+{ $subsection trilerp }
+{ $subsection bilerp }
+{ $subsection vlerp }
+{ $subsection vnlerp }
+{ $subsection vbilerp } ;
ABOUT: "math-vectors"
{ $values { "u" "a sequence of numbers" } { "v" "a sequence of numbers" } }
{ $description "Negates each element of " { $snippet "u" } "." } ;
+HELP: vabs
+{ $values { "u" "a sequence of numbers" } { "v" "a sequence of non-negative real numbers" } }
+{ $description "Takes the absolute value of each element of " { $snippet "u" } "." } ;
+
+HELP: vsqrt
+{ $values { "u" "a sequence of non-negative real numbers" } { "v" "a sequence of non-negative real numbers" } }
+{ $description "Takes the square root of each element of " { $snippet "u" } "." }
+{ $warning "For performance reasons, this does not work with negative inputs, unlike " { $link sqrt } "." } ;
+
+HELP: vfloor
+{ $values { "u" "a sequence of real numbers" } { "v" "a sequence of real numbers" } }
+{ $description "Takes the " { $link floor } " of each element of " { $snippet "u" } "." } ;
+
+HELP: vceiling
+{ $values { "u" "a sequence of real numbers" } { "v" "a sequence of real numbers" } }
+{ $description "Takes the " { $link ceiling } " of each element of " { $snippet "u" } "." } ;
+
+HELP: vtruncate
+{ $values { "u" "a sequence of real numbers" } { "v" "a sequence of real numbers" } }
+{ $description "Truncates each element of " { $snippet "u" } "." } ;
+
+HELP: n+v
+{ $values { "n" "a number" } { "u" "a sequence of numbers" } { "v" "a sequence of numbers" } }
+{ $description "Adds " { $snippet "n" } " to each element of " { $snippet "u" } "." } ;
+
+HELP: v+n
+{ $values { "u" "a sequence of numbers" } { "n" "a number" } { "v" "a sequence of numbers" } }
+{ $description "Adds " { $snippet "n" } " to each element of " { $snippet "u" } "." } ;
+
+HELP: n-v
+{ $values { "n" "a number" } { "u" "a sequence of numbers" } { "v" "a sequence of numbers" } }
+{ $description "Subtracts each element of " { $snippet "u" } " from " { $snippet "n" } "." } ;
+
+HELP: v-n
+{ $values { "u" "a sequence of numbers" } { "n" "a number" } { "v" "a sequence of numbers" } }
+{ $description "Subtracts " { $snippet "n" } " from each element of " { $snippet "u" } "." } ;
+
HELP: n*v
{ $values { "n" "a number" } { "u" "a sequence of numbers" } { "v" "a sequence of numbers" } }
{ $description "Multiplies each element of " { $snippet "u" } " by " { $snippet "n" } "." } ;
HELP: n/v
{ $values { "n" "a number" } { "u" "a sequence of numbers" } { "v" "a sequence of numbers" } }
-{ $description "Divides " { $snippet "n" } " by each element of " { $snippet "u" } "." } ;
+{ $description "Divides " { $snippet "n" } " by each element of " { $snippet "u" } "." }
+{ $errors "May throw an error if a division by zero occurs; see " { $link "division-by-zero" } "." } ;
HELP: v/n
{ $values { "u" "a sequence of numbers" } { "n" "a number" } { "v" "a sequence of numbers" } }
-{ $description "Divides each element of " { $snippet "u" } " by " { $snippet "n" } "." } ;
+{ $description "Divides each element of " { $snippet "u" } " by " { $snippet "n" } "." }
+{ $errors "May throw an error if a division by zero occurs; see " { $link "division-by-zero" } "." } ;
HELP: v+
{ $values { "u" "a sequence of numbers" } { "v" "a sequence of numbers" } { "w" "a sequence of numbers" } }
{ $values { "u" "a sequence of numbers" } { "v" "a sequence of numbers" } { "w" "a sequence of numbers" } }
{ $description "Subtracts " { $snippet "v" } " from " { $snippet "u" } " component-wise." } ;
+HELP: v+-
+{ $values { "u" "a sequence of numbers" } { "v" "a sequence of numbers" } { "w" "a sequence of numbers" } }
+{ $description "Adds and subtracts alternate elements of " { $snippet "v" } " and " { $snippet "u" } " component-wise." }
+{ $examples
+ { $example
+ "USING: math.vectors prettyprint ;"
+ "{ 1 2 3 } { 2 3 2 } v+- ."
+ "{ -1 5 1 }"
+ }
+} ;
+
HELP: [v-]
{ $values { "u" "a sequence of real numbers" } { "v" "a sequence of real numbers" } { "w" "a sequence of real numbers" } }
{ $description "Subtracts " { $snippet "v" } " from " { $snippet "u" } " component-wise; any components which become negative are set to zero." } ;
HELP: v/
{ $values { "u" "a sequence of numbers" } { "v" "a sequence of numbers" } { "w" "a sequence of numbers" } }
{ $description "Divides " { $snippet "u" } " by " { $snippet "v" } " component-wise." }
-{ $errors "Throws an error if an integer division by zero occurs." } ;
+{ $errors "May throw an error if a division by zero occurs; see " { $link "division-by-zero" } "." } ;
HELP: vmax
{ $values { "u" "a sequence of real numbers" } { "v" "a sequence of real numbers" } { "w" "a sequence of real numbers" } }
{ $description "Computes the real-valued dot product." }
{ $notes
"This word can also take complex number sequences as input, however mathematically it will compute the wrong result. The complex-valued dot product is defined differently:"
- { $snippet "0 [ conjugate * + ] 2reduce" }
+ { $code "0 [ conjugate * + ] 2reduce" }
+} ;
+
+HELP: vs+
+{ $values { "u" "a sequence of numbers" } { "v" "a sequence of numbers" } { "w" "a sequence of numbers" } }
+{ $description "Adds " { $snippet "u" } " and " { $snippet "v" } " component-wise with saturation." }
+{ $examples
+ "With saturation:"
+ { $example
+ "USING: math.vectors prettyprint specialized-arrays ;"
+ "SPECIALIZED-ARRAY: uchar"
+ "uchar-array{ 100 200 150 } uchar-array{ 70 70 70 } vs+ ."
+ "uchar-array{ 170 255 220 }"
+ }
+ "Without saturation:"
+ { $example
+ "USING: math.vectors prettyprint specialized-arrays ;"
+ "SPECIALIZED-ARRAY: uchar"
+ "uchar-array{ 100 200 150 } uchar-array{ 70 70 70 } v+ ."
+ "uchar-array{ 170 14 220 }"
+ }
} ;
+HELP: vs-
+{ $values { "u" "a sequence of numbers" } { "v" "a sequence of numbers" } { "w" "a sequence of numbers" } }
+{ $description "Subtracts " { $snippet "v" } " from " { $snippet "u" } " component-wise with saturation." } ;
+
+HELP: vs*
+{ $values { "u" "a sequence of numbers" } { "v" "a sequence of numbers" } { "w" "a sequence of numbers" } }
+{ $description "Multiplies " { $snippet "u" } " and " { $snippet "v" } " component-wise with saturation." } ;
+
+HELP: vbitand
+{ $values { "u" "a sequence of real numbers" } { "v" "a sequence of real numbers" } { "w" "a sequence of real numbers" } }
+{ $description "Takes the bitwise and of " { $snippet "u" } " and " { $snippet "v" } " component-wise." }
+{ $notes "Unlike " { $link bitand } ", this word may be used on a specialized array of floats or doubles, in which case the bitwise representation of the floating point numbers is operated upon." } ;
+
+HELP: vbitor
+{ $values { "u" "a sequence of real numbers" } { "v" "a sequence of real numbers" } { "w" "a sequence of real numbers" } }
+{ $description "Takes the bitwise or of " { $snippet "u" } " and " { $snippet "v" } " component-wise." }
+{ $notes "Unlike " { $link bitor } ", this word may be used on a specialized array of floats or doubles, in which case the bitwise representation of the floating point numbers is operated upon." } ;
+
+HELP: vbitxor
+{ $values { "u" "a sequence of real numbers" } { "v" "a sequence of real numbers" } { "w" "a sequence of real numbers" } }
+{ $description "Takes the bitwise exclusive or of " { $snippet "u" } " and " { $snippet "v" } " component-wise." }
+{ $notes "Unlike " { $link bitxor } ", this word may be used on a specialized array of floats or doubles, in which case the bitwise representation of the floating point numbers is operated upon." } ;
+
HELP: norm-sq
{ $values { "v" "a sequence of numbers" } { "x" "a non-negative real number" } }
{ $description "Computes the squared length of a mathematical vector." } ;
{ $values { "u" "a sequence of numbers, not all zero" } { "v" "a sequence of numbers" } }
{ $description "Outputs a vector with the same direction as " { $snippet "u" } " but length 1." } ;
+HELP: distance
+{ $values { "u" "a sequence of numbers" } { "v" "a sequence of numbers" } { "x" "a non-negative real number" } }
+{ $description "Outputs the Euclidean distance between two vectors." } ;
+
HELP: set-axis
{ $values { "u" "a sequence of numbers" } { "v" "a sequence of numbers" } { "axis" "a sequence of 0/1" } { "w" "a sequence of numbers" } }
{ $description "Using " { $snippet "w" } " as a template, creates a new sequence containing corresponding elements from " { $snippet "u" } " in place of 0, and corresponding elements from " { $snippet "v" } " in place of 1." }
{ 2map v+ v- v* v/ } related-words
{ 2reduce v. } related-words
+
+{ vs+ vs- vs* } related-words
[ 1.125 ] [ 0.0 1.0 2.0 4.0 { 0.5 0.25 } bilerp ] unit-test
-[ 17 ] [ 0 1 2 3 4 5 6 7 { 1 2 3 } trilerp ] unit-test
\ No newline at end of file
+[ 17 ] [ 0 1 2 3 4 5 6 7 { 1 2 3 } trilerp ] unit-test
+
+[ { 0 3 2 5 4 } ] [ { 1 2 3 4 5 } { 1 1 1 1 1 } v+- ] unit-test
\ No newline at end of file
-! Copyright (C) 2005, 2008 Slava Pestov.
+! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays kernel sequences math math.functions hints
-math.order ;
+USING: arrays alien.c-types kernel sequences math math.functions
+hints math.order math.libm fry combinators ;
+QUALIFIED-WITH: alien.c-types c
IN: math.vectors
+GENERIC: element-type ( obj -- c-type )
+
: vneg ( u -- v ) [ neg ] map ;
: v+n ( u n -- v ) [ + ] curry map ;
: vmax ( u v -- w ) [ max ] 2map ;
: vmin ( u v -- w ) [ min ] 2map ;
-: vfloor ( v -- _v_ ) [ floor ] map ;
-: vceiling ( v -- ^v^ ) [ ceiling ] map ;
-: vtruncate ( v -- -v- ) [ truncate ] map ;
+: v+- ( u v -- w )
+ [ t ] 2dip
+ [ [ not ] 2dip pick [ + ] [ - ] if ] 2map
+ nip ;
+
+<PRIVATE
+
+: 2saturate-map ( u v quot -- w )
+ pick element-type '[ @ _ c-type-clamp ] 2map ; inline
+
+PRIVATE>
+
+: vs+ ( u v -- w ) [ + ] 2saturate-map ;
+: vs- ( u v -- w ) [ - ] 2saturate-map ;
+: vs* ( u v -- w ) [ * ] 2saturate-map ;
+
+: vabs ( u -- v ) [ abs ] map ;
+: vsqrt ( u -- v ) [ >float fsqrt ] map ;
+
+<PRIVATE
+
+: fp-bitwise-op ( x y seq quot -- z )
+ swap element-type {
+ { c:double [ [ [ double>bits ] bi@ ] dip call bits>double ] }
+ { c:float [ [ [ float>bits ] bi@ ] dip call bits>float ] }
+ [ drop call ]
+ } case ; inline
+
+PRIVATE>
+
+: vbitand ( u v -- w ) over '[ _ [ bitand ] fp-bitwise-op ] 2map ;
+: vbitor ( u v -- w ) over '[ _ [ bitor ] fp-bitwise-op ] 2map ;
+: vbitxor ( u v -- w ) over '[ _ [ bitxor ] fp-bitwise-op ] 2map ;
+
+: vfloor ( u -- v ) [ floor ] map ;
+: vceiling ( u -- v ) [ ceiling ] map ;
+: vtruncate ( u -- v ) [ truncate ] map ;
: vsupremum ( seq -- vmax ) [ ] [ vmax ] map-reduce ;
: vinfimum ( seq -- vmin ) [ ] [ vmin ] map-reduce ;
{ $syntax "STRING: name\nfoo\n;" }
{ $description "Forms a multiline string literal, or 'here document' stored in the word called name. A semicolon is used to signify the end, and that semicolon must be on a line by itself, not preceeded or followed by any whitespace. The string will have newlines in between lines but not at the end, unless there is a blank line before the semicolon." } ;
-HELP: <"
-{ $syntax "<\" text \">" }
-{ $description "This forms a multiline string literal ending in \">. Unlike the " { $link POSTPONE: STRING: } " form, you can end it in the middle of a line. This construct is non-nesting. In the example above, the string would be parsed as \"text\"." } ;
-
HELP: /*
{ $syntax "/* comment */" }
{ $description "Provides C-like comments that can span multiple lines. One caveat is that " { $snippet "/*" } " and " { $snippet "*/" } " are still tokens and must not abut the comment text itself." }
}
} ;
-{ POSTPONE: <" POSTPONE: STRING: } related-words
-
HELP: parse-multiline-string
{ $values { "end-text" "a string delineating the end" } { "str" "the parsed string" } }
{ $description "Parses the input stream until the " { $snippet "end-text" } " is reached and returns the parsed text as a string." }
-{ $notes "Used to implement " { $link POSTPONE: /* } " and " { $link POSTPONE: <" } "." } ;
+{ $notes "Used to implement " { $link POSTPONE: /* } "." } ;
ARTICLE: "multiline" "Multiline"
"Multiline strings:"
{ $subsection POSTPONE: STRING: }
-{ $subsection POSTPONE: <" }
{ $subsection POSTPONE: HEREDOC: }
{ $subsection POSTPONE: DELIMITED: }
"Multiline comments:"
;
[ "foo\nbar\n" ] [ test-it ] unit-test
-[ "foo\nbar\n" ] [ <" foo
-bar
-"> ] unit-test
-
-[ "hello\nworld" ] [ <" hello
-world"> ] unit-test
-
-[ "hello" "world" ] [ <" hello"> <" world"> ] unit-test
-
-[ "\nhi" ] [ <"
-hi"> ] unit-test
! HEREDOC:
: parse-multiline-string ( end-text -- str )
1 (parse-multiline-string) ;
-SYNTAX: <"
- "\">" parse-multiline-string parsed ;
-
-SYNTAX: <'
- "'>" parse-multiline-string parsed ;
-
-SYNTAX: {'
- "'}" parse-multiline-string parsed ;
-
-SYNTAX: {"
- "\"}" parse-multiline-string parsed ;
-
SYNTAX: /* "*/" parse-multiline-string drop ;
SYNTAX: HEREDOC:
USING: help.markup help.syntax io kernel math quotations
-opengl.gl multiline assocs ;
+opengl.gl assocs ;
IN: opengl.capabilities
HELP: gl-version
{ $values { "extensions" "A sequence of extension name strings" } { "?" "A boolean value" } }
{ $description "Returns true if the set of " { $snippet "extensions" } " is a subset of the implementation-supported extensions returned by " { $link gl-extensions } ". Elements of " { $snippet "extensions" } " can be sequences, in which case true will be returned if any one of the extensions in the subsequence are available." }
{ $examples "Testing for framebuffer object and pixel buffer support:"
- { $code <" {
+ { $code """{
{ "GL_EXT_framebuffer_object" "GL_ARB_framebuffer_object" }
"GL_ARB_pixel_buffer_object"
-} has-gl-extensions? "> }
+} has-gl-extensions?""" }
} ;
HELP: has-gl-version-or-extensions?
! (c)2009 Joe Groff bsd license
-USING: help.markup help.syntax multiline tools.continuations ;
+USING: help.markup help.syntax tools.continuations ;
IN: opengl.debug
HELP: G
{ $description "Makes the OpenGL context associated with " { $link G-world } " active for subsequent OpenGL calls. This is intended to be used from the listener, where interactively entered OpenGL calls can be directed to any window. Note that the Factor UI resets the OpenGL context every time a window is updated, so every code snippet entered in the listener must be prefixed with " { $snippet "G" } " in this use case." }
-{ $examples { $code <" USING: opengl.debug ui ;
+{ $examples { $code """USING: opengl.debug ui ;
[ drop t ] find-window G-world set
G 0.0 0.0 1.0 1.0 glClearColor
-G GL_COLOR_BUFFER_BIT glClear
-"> } } ;
+G GL_COLOR_BUFFER_BIT glClear""" } } ;
HELP: F
{ $description "Flushes the OpenGL context associated with " { $link G-world } ", thereby committing any outstanding drawing operations." } ;
sequences splitting words byte-arrays assocs vocabs
colors colors.constants accessors generalizations locals fry
specialized-arrays ;
+FROM: alien.c-types => float ;
SPECIALIZED-ARRAY: float
SPECIALIZED-ARRAY: uint
IN: opengl
! Copyright (C) 2008 Joe Groff.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel opengl.gl alien.c-types continuations namespaces
-assocs alien alien.strings libc opengl math sequences combinators
+assocs alien alien.data alien.strings libc opengl math sequences combinators
macros arrays io.encodings.ascii fry specialized-arrays
destructors accessors ;
SPECIALIZED-ARRAY: uint
!
! export LD_LIBRARY_PATH=/opt/local/lib
-USING: alien alien.syntax combinators kernel system
-alien.libraries ;
+USING: alien alien.c-types alien.syntax combinators kernel system
+alien.libraries classes.struct ;
IN: openssl.libcrypto
} cond
>>
-C-STRUCT: bio-method
- { "int" "type" }
- { "void*" "name" }
- { "void*" "bwrite" }
- { "void*" "bread" }
- { "void*" "bputs" }
- { "void*" "bgets" }
- { "void*" "ctrl" }
- { "void*" "create" }
- { "void*" "destroy" }
- { "void*" "callback-ctrl" } ;
-
-C-STRUCT: bio
- { "void*" "method" }
- { "void*" "callback" }
- { "void*" "cb-arg" }
- { "int" "init" }
- { "int" "shutdown" }
- { "int" "flags" }
- { "int" "retry-reason" }
- { "int" "num" }
- { "void*" "ptr" }
- { "void*" "next-bio" }
- { "void*" "prev-bio" }
- { "int" "references" }
- { "ulong" "num-read" }
- { "ulong" "num-write" }
- { "void*" "crypto-ex-data-stack" }
- { "int" "crypto-ex-data-dummy" } ;
+STRUCT: bio-method
+ { type int }
+ { name void* }
+ { bwrite void* }
+ { bread void* }
+ { bputs void* }
+ { bgets void* }
+ { ctrl void* }
+ { create void* }
+ { destroy void* }
+ { callback-ctrl void* } ;
+
+STRUCT: bio
+ { method void* }
+ { callback void* }
+ { cb-arg void* }
+ { init int }
+ { shutdown int }
+ { flags int }
+ { retry-reason int }
+ { num int }
+ { ptr void* }
+ { next-bio void* }
+ { prev-bio void* }
+ { references int }
+ { num-read ulong }
+ { num-write ulong }
+ { crypto-ex-data-stack void* }
+ { crypto-ex-data-dummy int } ;
CONSTANT: BIO_NOCLOSE HEX: 00
CONSTANT: BIO_CLOSE HEX: 01
CONSTANT: EVP_MAX_MD_SIZE 64
-C-STRUCT: EVP_MD_CTX
- { "EVP_MD*" "digest" }
- { "ENGINE*" "engine" }
- { "ulong" "flags" }
- { "void*" "md_data" } ;
+STRUCT: EVP_MD_CTX
+ { digest EVP_MD* }
+ { engine ENGINE* }
+ { flags ulong }
+ { md_data void* } ;
TYPEDEF: void* EVP_MD*
TYPEDEF: void* ENGINE*
[ "USE: peg.ebnf [EBNF EBNF]" eval( -- ) ] must-fail
-[ <" USE: peg.ebnf [EBNF
+[ """USE: peg.ebnf [EBNF
lol = a
lol = b
- EBNF] "> eval( -- )
+ EBNF]""" eval( -- )
] [
error>> [ redefined-rule? ] [ name>> "lol" = ] bi and
] must-fail-with
] when ;
: pprint-elements ( seq -- )
+ >array
do-length-limit
[ [ pprint* ] each ] dip
[ "~" swap number>string " more~" 3append text ] when* ;
HELP: line-limit
{ $var-description "The maximum number of lines output by the prettyprinter before output is truncated with \"...\". The default is " { $link f } ", denoting unlimited line count." } ;
+HELP: number-base
+{ $var-description "The number base in which the prettyprinter will output numeric literals. A value of " { $snippet "2" } " will print integers and ratios in binary with " { $link POSTPONE: BIN: } ", and " { $snippet "8" } " will print them in octal with " { $link POSTPONE: OCT: } ". A value of " { $snippet "16" } " will print all integers, ratios, and floating-point values in hexadecimal with " { $link POSTPONE: HEX: } ". Other values of " { $snippet "number-base" } " will print numbers in decimal, which is the default." } ;
+
HELP: string-limit?
{ $var-description "Toggles whether printed strings are truncated to the margin." } ;
{ $subsection nesting-limit }
{ $subsection length-limit }
{ $subsection line-limit }
+{ $subsection number-base }
{ $subsection string-limit? }
{ $subsection boa-tuples? }
{ $subsection c-object-pointers? }
{ $description "Outputs an integer in octal." } ;
HELP: .h
-{ $values { "n" "an integer" } }
-{ $description "Outputs an integer in hexadecimal." } ;
+{ $values { "n" "an integer or floating-point value" } }
+{ $description "Outputs an integer or floating-point value in hexadecimal." } ;
HELP: stack.
{ $values { "seq" "a sequence" } }
! Copyright (C) 2009 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test quoted-printable multiline io.encodings.string
+USING: tools.test quoted-printable io.encodings.string
sequences io.encodings.8-bit splitting kernel ;
IN: quoted-printable.tests
-[ <" José was the
+[ """José was the
person who knew how to write the letters:
ő and ü
-and we didn't know hów tö do thât"> ]
-[ <" Jos=E9 was the
+and we didn't know hów tö do thât""" ]
+[ """Jos=E9 was the
person who knew how to write the letters:
=F5 and =FC=20
and w=
-e didn't know h=F3w t=F6 do th=E2t"> quoted> latin2 decode ] unit-test
+e didn't know h=F3w t=F6 do th=E2t""" quoted> latin2 decode ] unit-test
-[ <" Jos=E9 was the=0Aperson who knew how to write the letters:=0A =F5 and =FC=0Aand we didn't know h=F3w t=F6 do th=E2t"> ]
-[ <" José was the
+[ """Jos=E9 was the=0Aperson who knew how to write the letters:=0A =F5 and =FC=0Aand we didn't know h=F3w t=F6 do th=E2t""" ]
+[ """José was the
person who knew how to write the letters:
ő and ü
-and we didn't know hów tö do thât"> latin2 encode >quoted ] unit-test
+and we didn't know hów tö do thât""" latin2 encode >quoted ] unit-test
: message ( -- str )
55 [ "hello" ] replicate concat ;
}
{ $description "Randomizes a sequence in-place with the Fisher-Yates algorithm and returns the sequence." } ;
+HELP: sample
+{ $values
+ { "seq" sequence } { "n" integer }
+ { "seq'" sequence }
+}
+{ $description "Takes " { $snippet "n" } " samples at random without replacement from a sequence. Throws an error if " { $snippet "n" } " is longer than the sequence." }
+{ $examples
+ { $unchecked-example "USING: random prettyprint ; { 1 2 3 } 2 sample ."
+ "{ 3 2 }"
+ }
+} ;
+
HELP: delete-random
{ $values
{ "seq" sequence }
{ $subsection "random-protocol" }
"Randomizing a sequence:"
{ $subsection randomize }
+"Sampling a sequences:"
+{ $subsection sample }
"Deleting a random element from a sequence:"
{ $subsection delete-random }
"Random numbers with " { $snippet "n" } " bits:"
[ 100 [ { 0 1 } random ] replicate all-equal? ] unit-test
[ 49 ] [ 50 random-bits* log2 ] unit-test
+
+[ { 1 2 } 3 sample ] [ too-many-samples? ] must-fail-with
+
+[ 3 ] [ { 1 2 3 4 } 3 sample prune length ] unit-test
+[ 99 ] [ 100 99 sample prune length ] unit-test
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.c-types kernel math namespaces sequences
-io.backend io.binary combinators system vocabs.loader
-summary math.bitwise byte-vectors fry byte-arrays
-math.ranges math.constants math.functions accessors ;
+USING: accessors alien.c-types assocs byte-arrays byte-vectors
+combinators fry io.backend io.binary kernel locals math
+math.bitwise math.constants math.functions math.ranges
+namespaces sequences sets summary system vocabs.loader ;
IN: random
SYMBOL: system-random-generator
[ [ iota random ] [ 1 - ] bi [ pick exchange ] keep ]
while drop ;
+ERROR: too-many-samples seq n ;
+
+<PRIVATE
+
+:: next-sample ( length n seq hashtable -- elt )
+ n hashtable key? [
+ length n 1 + length mod seq hashtable next-sample
+ ] [
+ n hashtable conjoin
+ n seq nth
+ ] if ;
+
+PRIVATE>
+
+: sample ( seq n -- seq' )
+ 2dup [ length ] dip < [ too-many-samples ] when
+ swap [ length ] [ ] bi H{ } clone
+ '[ _ dup random _ _ next-sample ] replicate ;
+
: delete-random ( seq -- elt )
[ length random-integer ] keep [ nth ] 2keep delete-nth ;
-USING: accessors alien.c-types byte-arrays
+USING: accessors alien.c-types alien.data byte-arrays
combinators.short-circuit continuations destructors init kernel
locals namespaces random windows.advapi32 windows.errors
windows.kernel32 math.bitwise ;
! Copyright (C) 2008, 2009 Doug Coleman, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel strings help.markup help.syntax math regexp.parser
-regexp.ast multiline ;
+regexp.ast ;
IN: regexp
ABOUT: "regexp"
"The " { $snippet "+" } " operator matches one or more occurrences of the previous expression; in this case " { $snippet "o" } ". Another useful feature is alternation. Say we want to do this replacement with fooooo or boooo. Then we could use the code"
{ $code "R/ (f|b)oo+/ \"bar\" re-replace" }
"To search a file for all lines that match a given regular expression, you could use code like this:"
-{ $code <" "file.txt" ascii file-lines [ R/ (f|b)oo+/ re-contains? ] filter "> }
+{ $code """"file.txt" ascii file-lines [ R/ (f|b)oo+/ re-contains? ] filter""" }
"To test if a string in its entirety matches a regular expression, the following can be used:"
-{ $example <" USE: regexp "fooo" R/ (b|f)oo+/ matches? . "> "t" }
+{ $example """USE: regexp "fooo" R/ (b|f)oo+/ matches? .""" "t" }
"Regular expressions can't be used for all parsing tasks. For example, they are not powerful enough to match balancing parentheses." ;
ARTICLE: { "regexp" "construction" } "Constructing regular expressions"
-USING: help.markup help.syntax math multiline
+USING: help.markup help.syntax math
sequences sequences.complex-components ;
IN: sequences.complex-components
HELP: complex-components
{ $class-description "Sequence wrapper class that transforms a sequence of " { $link complex } " number values into a sequence of " { $link real } " values, interleaving the real and imaginary parts of the complex values in the original sequence." }
-{ $examples { $example <"
-USING: prettyprint sequences arrays sequences.complex-components ;
-{ C{ 1.0 -1.0 } -2.0 C{ 3.0 1.0 } } <complex-components> >array .
-"> "{ 1.0 -1.0 -2.0 0 3.0 1.0 }" } } ;
+{ $examples { $example """USING: prettyprint sequences arrays sequences.complex-components ;
+{ C{ 1.0 -1.0 } -2.0 C{ 3.0 1.0 } } <complex-components> >array ."""
+"{ 1.0 -1.0 -2.0 0 3.0 1.0 }" } } ;
HELP: <complex-components>
{ $values { "sequence" sequence } { "complex-components" complex-components } }
{ $description "Wraps " { $snippet "sequence" } " in a " { $link complex-components } " wrapper." }
{ $examples
-{ $example <"
-USING: prettyprint sequences arrays
+{ $example """USING: prettyprint sequences arrays
sequences.complex-components ;
-{ C{ 1.0 -1.0 } -2.0 C{ 3.0 1.0 } } <complex-components> third .
-"> "-2.0" }
-{ $example <"
-USING: prettyprint sequences arrays
+{ C{ 1.0 -1.0 } -2.0 C{ 3.0 1.0 } } <complex-components> third ."""
+"-2.0" }
+{ $example """USING: prettyprint sequences arrays
sequences.complex-components ;
-{ C{ 1.0 -1.0 } -2.0 C{ 3.0 1.0 } } <complex-components> fourth .
-"> "0" }
+{ C{ 1.0 -1.0 } -2.0 C{ 3.0 1.0 } } <complex-components> fourth ."""
+"0" }
} ;
{ complex-components <complex-components> } related-words
-USING: help.markup help.syntax math multiline
-sequences sequences.complex ;
+USING: help.markup help.syntax math sequences
+sequences.complex ;
IN: sequences.complex
ARTICLE: "sequences.complex" "Complex virtual sequences"
HELP: complex-sequence
{ $class-description "Sequence wrapper class that transforms a sequence of " { $link real } " number values into a sequence of " { $link complex } " values, treating the underlying sequence as pairs of alternating real and imaginary values." }
-{ $examples { $example <"
-USING: prettyprint specialized-arrays
+{ $examples { $example """USING: prettyprint specialized-arrays
sequences.complex sequences arrays ;
SPECIALIZED-ARRAY: double
-double-array{ 1.0 -1.0 -2.0 2.0 3.0 0.0 } <complex-sequence> >array .
-"> "{ C{ 1.0 -1.0 } C{ -2.0 2.0 } C{ 3.0 0.0 } }" } } ;
+double-array{ 1.0 -1.0 -2.0 2.0 3.0 0.0 } <complex-sequence> >array ."""
+"{ C{ 1.0 -1.0 } C{ -2.0 2.0 } C{ 3.0 0.0 } }" } } ;
HELP: <complex-sequence>
{ $values { "sequence" sequence } { "complex-sequence" complex-sequence } }
{ $description "Wraps " { $snippet "sequence" } " in a " { $link complex-sequence } "." }
-{ $examples { $example <"
-USING: prettyprint specialized-arrays
+{ $examples { $example """USING: prettyprint specialized-arrays
sequences.complex sequences arrays ;
SPECIALIZED-ARRAY: double
-double-array{ 1.0 -1.0 -2.0 2.0 3.0 0.0 } <complex-sequence> second .
-"> "C{ -2.0 2.0 }" } } ;
+double-array{ 1.0 -1.0 -2.0 2.0 3.0 0.0 } <complex-sequence> second ."""
+"C{ -2.0 2.0 }" } } ;
{ complex-sequence <complex-sequence> } related-words
kernel arrays combinators compiler compiler.units classes.struct
combinators.smart compiler.tree.debugger math libc destructors
sequences.private multiline eval words vocabs namespaces
-assocs prettyprint ;
+assocs prettyprint alien.data math.vectors ;
+FROM: alien.c-types => float ;
SPECIALIZED-ARRAY: int
SPECIALIZED-ARRAY: bool
SPECIALIZED-ARRAY: char
SPECIALIZED-ARRAY: uint
SPECIALIZED-ARRAY: float
+SPECIALIZED-ARRAY: ulonglong
+
+[ ulonglong ] [ ulonglong-array{ } element-type ] unit-test
[ t ] [ { 1 2 3 } >int-array int-array? ] unit-test
] unit-test
[
- <"
+ """
IN: specialized-arrays.tests
USING: specialized-arrays ;
-SPECIALIZED-ARRAY: __does_not_exist__ "> eval( -- )
+SPECIALIZED-ARRAY: __does_not_exist__ """ eval( -- )
] must-fail
[ ] [
- <"
+ """
IN: specialized-arrays.tests
USING: classes.struct specialized-arrays ;
STRUCT: __does_not_exist__ { x int } ;
SPECIALIZED-ARRAY: __does_not_exist__
-"> eval( -- )
+""" eval( -- )
] unit-test
[ f ] [
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien alien.c-types assocs byte-arrays classes
-compiler.units functors kernel lexer libc math
-math.vectors.specialization namespaces parser prettyprint.custom
-sequences sequences.private strings summary vocabs vocabs.loader
-vocabs.parser words fry combinators ;
+USING: accessors alien alien.c-types alien.data alien.parser
+assocs byte-arrays classes compiler.units functors kernel lexer
+libc math math.vectors math.vectors.specialization namespaces
+parser prettyprint.custom sequences sequences.private strings
+summary vocabs vocabs.loader vocabs.parser vocabs.generated
+words fry combinators present ;
IN: specialized-arrays
MIXIN: specialized-array
: <direct-A> ( alien len -- specialized-array ) A boa ; inline
-: <A> ( n -- specialized-array ) [ T <underlying> ] keep <direct-A> ; inline
+: <A> ( n -- specialized-array ) [ \ T <underlying> ] keep <direct-A> ; inline
-: (A) ( n -- specialized-array ) [ T (underlying) ] keep <direct-A> ; inline
+: (A) ( n -- specialized-array ) [ \ T (underlying) ] keep <direct-A> ; inline
-: malloc-A ( len -- specialized-array ) [ T heap-size calloc ] keep <direct-A> ; inline
+: malloc-A ( len -- specialized-array ) [ \ T heap-size calloc ] keep <direct-A> ; inline
: byte-array>A ( byte-array -- specialized-array )
- dup length T heap-size /mod 0 = [ drop T bad-byte-array-length ] unless
+ dup length \ T heap-size /mod 0 = [ drop \ T bad-byte-array-length ] unless
<direct-A> ; inline
M: A clone [ underlying>> clone ] [ length>> ] bi <direct-A> ; inline
M: A resize
[
- [ T heap-size * ] [ underlying>> ] bi*
+ [ \ T heap-size * ] [ underlying>> ] bi*
resize-byte-array
] [ drop ] 2bi
<direct-A> ; inline
-M: A byte-length length T heap-size * ; inline
+M: A byte-length length \ T heap-size * ; inline
+
+M: A element-type drop \ T ; inline
M: A direct-array-syntax drop \ A@ ;
;FUNCTOR
+GENERIC: (underlying-type) ( c-type -- c-type' )
+
+M: string (underlying-type) c-types get at ;
+M: word (underlying-type) "c-type" word-prop ;
+
: underlying-type ( c-type -- c-type' )
- dup c-types get at {
+ dup (underlying-type) {
{ [ dup not ] [ drop no-c-type ] }
- { [ dup string? ] [ nip underlying-type ] }
+ { [ dup c-type-name? ] [ nip underlying-type ] }
[ drop ]
} cond ;
+: underlying-type-name ( c-type -- name )
+ underlying-type present ;
+
: specialized-array-vocab ( c-type -- vocab )
- "specialized-arrays.instances." prepend ;
+ present "specialized-arrays.instances." prepend ;
PRIVATE>
-: generate-vocab ( vocab-name quot -- vocab )
- [ dup vocab [ ] ] dip '[
- [
- [
- _ with-current-vocab
- ] with-compilation-unit
- ] keep
- ] ?if ; inline
-
: define-array-vocab ( type -- vocab )
underlying-type
[ specialized-array-vocab ] [ '[ _ define-array ] ] bi
generate-vocab ;
-M: string require-c-array define-array-vocab drop ;
+M: c-type-name require-c-array define-array-vocab drop ;
ERROR: specialized-array-vocab-not-loaded c-type ;
-M: string c-array-constructor
- underlying-type
+M: c-type-name c-array-constructor
+ underlying-type-name
dup [ "<" "-array>" surround ] [ specialized-array-vocab ] bi lookup
[ ] [ specialized-array-vocab-not-loaded ] ?if ; foldable
-M: string c-(array)-constructor
- underlying-type
+M: c-type-name c-(array)-constructor
+ underlying-type-name
dup [ "(" "-array)" surround ] [ specialized-array-vocab ] bi lookup
[ ] [ specialized-array-vocab-not-loaded ] ?if ; foldable
-M: string c-direct-array-constructor
- underlying-type
+M: c-type-name c-direct-array-constructor
+ underlying-type-name
dup [ "<direct-" "-array>" surround ] [ specialized-array-vocab ] bi lookup
[ ] [ specialized-array-vocab-not-loaded ] ?if ; foldable
SYNTAX: SPECIALIZED-ARRAY:
- scan define-array-vocab use-vocab ;
+ scan-c-type define-array-vocab use-vocab ;
"prettyprint" vocab [
"specialized-arrays.prettyprint" require
}
"Behind the scenes, these words are placed in a vocabulary named " { $snippet "specialized-vectors.instances.T" } ", however this vocabulary should not be placed in a " { $link POSTPONE: USING: } " form directly. Instead, always use " { $link POSTPONE: SPECIALIZED-VECTOR: } ". This ensures that the vocabulary can get generated the first time it is needed." ;
-ARTICLE: "specialized-vector-c" "Passing specialized arrays to C functions"
-"Each specialized array has a " { $slot "underlying" } " slot holding a specialized array, which in turn has an " { $slot "underlying" } " slot holding a " { $link byte-array } " with the raw data. Passing a specialized vector as a parameter to a C function call will automatically extract the underlying data. To get at the underlying data directly, call the " { $link >c-ptr } " word on a specialized vector." ;
+ARTICLE: "specialized-vector-c" "Passing specialized vectors to C functions"
+"Each specialized vector has a " { $slot "underlying" } " slot holding a specialized array, which in turn has an " { $slot "underlying" } " slot holding a " { $link byte-array } " with the raw data. Passing a specialized vector as a parameter to a C function call will automatically extract the underlying data. To get at the underlying data directly, call the " { $link >c-ptr } " word on a specialized vector." ;
ARTICLE: "specialized-vectors" "Specialized vectors"
"The " { $vocab-link "specialized-vectors" } " vocabulary implements resizable sequence types for storing machine values in a space-efficient manner without boxing."
USING: accessors alien.c-types assocs compiler.units functors
growable kernel lexer namespaces parser prettyprint.custom
sequences specialized-arrays specialized-arrays.private strings
-vocabs vocabs.parser fry ;
+vocabs vocabs.parser vocabs.generated fry ;
QUALIFIED: vectors.functor
IN: specialized-vectors
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: help.markup help.syntax kernel quotations classes sequences
-multiline ;
+USING: help.markup help.syntax kernel quotations classes sequences ;
IN: splitting.monotonic
HELP: monotonic-slice
{ $example
"USING: splitting.monotonic math prettyprint ;"
"{ 1 2 3 2 3 4 } [ < ] upward-slice monotonic-slice ."
- <" {
+ """{
T{ upward-slice
{ from 0 }
{ to 3 }
{ to 6 }
{ seq { 1 2 3 2 3 4 } }
}
-}">
+}"""
}
} ;
{ $example
"USING: splitting.monotonic math prettyprint ;"
"{ 1 2 3 3 2 1 } trends ."
- <" {
+ """{
T{ upward-slice
{ from 0 }
{ to 3 }
{ to 6 }
{ seq { 1 2 3 3 2 1 } }
}
-}">
+}"""
}
} ;
: alien-stack ( params extra -- )
over parameters>> length + consume-d >>in-d
- dup return>> "void" = 0 1 ? produce-d >>out-d
+ dup return>> void? 0 1 ? produce-d >>out-d
drop ;
: return-prep-quot ( node -- quot )
USING: help.markup help.syntax kernel effects sequences
-sequences.private words ;
+sequences.private words combinators ;
IN: stack-checker.errors
+HELP: do-not-compile
+{ $error-description "Thrown when inference encounters a macro being applied to a value which is not known to be a literal. Such code needs changes before it can compile and run. See " { $link "inference-combinators" } " and " { $link "inference-escape" } " for details." }
+{ $examples
+ "In this example, " { $link cleave } " is being applied to an array that is constructed on the fly. This is not allowed and fails to compile with a " { $link do-not-compile } " error:"
+ { $code
+ ": cannot-compile-call-example ( x -- y z )"
+ " [ 1 + ] [ 1 - ] 2array cleave ;"
+ }
+} ;
+
HELP: literal-expected
{ $error-description "Thrown when inference encounters a combinator or macro being applied to a value which is not known to be a literal, or constructed in a manner which can be analyzed statically. Such code needs changes before it can compile and run. See " { $link "inference-combinators" } " and " { $link "inference-escape" } " for details." }
{ $examples
- "In this example, words calling " { $snippet "literal-expected-example" } " will have a static stac keffect, even if " { $snippet "literal-expected-example" } " does not:"
+ "In this example, the words being defined cannot be called, because they fail to compile with a " { $link literal-expected } " error:"
{ $code
- ": literal-expected-example ( quot -- )"
+ ": bad-example ( quot -- )"
+ " [ call ] [ call ] bi ;"
+ ""
+ ": usage ( -- )"
+ " 10 [ 2 * ] bad-example . ;"
+ }
+ "One fix is to declare the combinator as inline:"
+ { $code
+ ": good-example ( quot -- )"
" [ call ] [ call ] bi ; inline"
+ ""
+ ": usage ( -- )"
+ " 10 [ 2 * ] good-example . ;"
+ }
+ "Another fix is to use " { $link POSTPONE: call( } ":"
+ { $code
+ ": good-example ( quot -- )"
+ " [ call( x -- y ) ] [ call( x -- y ) ] bi ;"
+ ""
+ ": usage ( -- )"
+ " 10 [ 2 * ] good-example . ;"
}
} ;
{ { $link "tools.inference" } " throws them as errors" }
{ "The " { $link "compiler" } " reports them via " { $link "tools.errors" } }
}
-"Error thrown when insufficient information is available to calculate the stack effect of a combinator call (see " { $link "inference-combinators" } "):"
+"Errors thrown when insufficient information is available to calculate the stack effect of a call to a combinator or macro (see " { $link "inference-combinators" } "):"
+{ $subsection do-not-compile }
{ $subsection literal-expected }
"Error thrown when a word's stack effect declaration does not match the composition of the stack effects of its factors:"
{ $subsection effect-error }
GENERIC: summary ( object -- string )
: object-summary ( object -- string )
- class name>> " instance" append ;
+ class name>> ;
M: object summary object-summary ;
--- /dev/null
+Doug Coleman
--- /dev/null
+Doug Coleman
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: system ;
+IN: system-info.backend
+
+HOOK: cpus os ( -- n )
+HOOK: cpu-mhz os ( -- n )
+HOOK: memory-load os ( -- n )
+HOOK: physical-mem os ( -- n )
+HOOK: available-mem os ( -- n )
+HOOK: total-page-file os ( -- n )
+HOOK: available-page-file os ( -- n )
+HOOK: total-virtual-mem os ( -- n )
+HOOK: available-virtual-mem os ( -- n )
+HOOK: available-virtual-extended-mem os ( -- n )
--- /dev/null
+Doug Coleman
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: unix alien alien.c-types kernel math sequences strings
+io.backend.unix splitting io.encodings.utf8 io.encodings.string
+specialized-arrays ;
+SPECIALIZED-ARRAY: char
+IN: system-info.linux
+
+: (uname) ( buf -- int )
+ "int" f "uname" { "char*" } alien-invoke ;
+
+: uname ( -- seq )
+ 65536 <char-array> [ (uname) io-error ] keep
+ "\0" split harvest [ utf8 decode ] map
+ 6 "" pad-tail ;
+
+: sysname ( -- string ) uname first ;
+: nodename ( -- string ) uname second ;
+: release ( -- string ) uname third ;
+: version ( -- string ) uname fourth ;
+: machine ( -- string ) uname 4 swap nth ;
+: domainname ( -- string ) uname 5 swap nth ;
+
+: kernel-version ( -- seq )
+ release ".-" split harvest 5 "" pad-tail ;
--- /dev/null
+unportable
--- /dev/null
+Doug Coleman
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien alien.c-types alien.strings alien.syntax
+byte-arrays kernel namespaces sequences unix
+system-info.backend system io.encodings.utf8 ;
+IN: system-info.macosx
+
+! See /usr/include/sys/sysctl.h for constants
+
+LIBRARY: libc
+FUNCTION: int sysctl ( int* name, uint namelen, void* oldp, size_t* oldlenp, void* newp, size_t newlen ) ;
+
+: make-int-array ( seq -- byte-array )
+ [ <int> ] map concat ;
+
+: (sysctl-query) ( name namelen oldp oldlenp -- oldp )
+ over [ f 0 sysctl io-error ] dip ;
+
+: sysctl-query ( seq n -- byte-array )
+ [ [ make-int-array ] [ length ] bi ] dip
+ [ <byte-array> ] [ <uint> ] bi (sysctl-query) ;
+
+: sysctl-query-string ( seq -- n )
+ 4096 sysctl-query utf8 alien>string ;
+
+: sysctl-query-uint ( seq -- n )
+ 4 sysctl-query *uint ;
+
+: sysctl-query-ulonglong ( seq -- n )
+ 8 sysctl-query *ulonglong ;
+
+: machine ( -- str ) { 6 1 } sysctl-query-string ;
+: model ( -- str ) { 6 2 } sysctl-query-string ;
+M: macosx cpus ( -- n ) { 6 3 } sysctl-query-uint ;
+: byte-order ( -- n ) { 6 4 } sysctl-query-uint ;
+M: macosx physical-mem ( -- n ) { 6 5 } sysctl-query-uint ;
+: user-mem ( -- n ) { 6 6 } sysctl-query-uint ;
+: page-size ( -- n ) { 6 7 } sysctl-query-uint ;
+: disknames ( -- n ) { 6 8 } 8 sysctl-query ;
+: diskstats ( -- n ) { 6 9 } 8 sysctl-query ;
+: epoch ( -- n ) { 6 10 } sysctl-query-uint ;
+: floating-point ( -- n ) { 6 11 } sysctl-query-uint ;
+: machine-arch ( -- n ) { 6 12 } sysctl-query-string ;
+: vector-unit ( -- n ) { 6 13 } sysctl-query-uint ;
+: bus-frequency ( -- n ) { 6 14 } sysctl-query-uint ;
+M: macosx cpu-mhz ( -- n ) { 6 15 } sysctl-query-uint ;
+: cacheline-size ( -- n ) { 6 16 } sysctl-query-uint ;
+: l1-icache-size ( -- n ) { 6 17 } sysctl-query-uint ;
+: l1-dcache-size ( -- n ) { 6 18 } sysctl-query-uint ;
+: l2-cache-settings ( -- n ) { 6 19 } sysctl-query-uint ;
+: l2-cache-size ( -- n ) { 6 20 } sysctl-query-uint ;
+: l3-cache-settings ( -- n ) { 6 21 } sysctl-query-uint ;
+: l3-cache-size ( -- n ) { 6 22 } sysctl-query-uint ;
+: tb-frequency ( -- n ) { 6 23 } sysctl-query-uint ;
+: mem-size ( -- n ) { 6 24 } sysctl-query-ulonglong ;
+: available-cpus ( -- n ) { 6 25 } sysctl-query-uint ;
--- /dev/null
+unportable
--- /dev/null
+Query the operating system for hardware information in a platform-independent way
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.syntax kernel math prettyprint io math.parser
+combinators vocabs.loader system-info.backend system ;
+IN: system-info
+
+: write-unit ( x n str -- )
+ [ 2^ /f number>string write bl ] [ write ] bi* ;
+
+: kb ( x -- ) 10 "kB" write-unit ;
+: megs ( x -- ) 20 "MB" write-unit ;
+: gigs ( x -- ) 30 "GB" write-unit ;
+: ghz ( x -- ) 1000000000 /f number>string write bl "GHz" write ;
+
+<< {
+ { [ os windows? ] [ "system-info.windows" ] }
+ { [ os linux? ] [ "system-info.linux" ] }
+ { [ os macosx? ] [ "system-info.macosx" ] }
+ [ f ]
+} cond [ require ] when* >>
+
+: system-report. ( -- )
+ "CPUs: " write cpus number>string write nl
+ "CPU Speed: " write cpu-mhz ghz nl
+ "Physical RAM: " write physical-mem megs nl ;
--- /dev/null
+Doug Coleman
--- /dev/null
+Doug Coleman
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.c-types alien.data system-info kernel math namespaces
+windows windows.kernel32 system-info.backend system ;
+IN: system-info.windows.ce
+
+: memory-status ( -- MEMORYSTATUS )
+ "MEMORYSTATUS" <c-object>
+ "MEMORYSTATUS" heap-size over set-MEMORYSTATUS-dwLength
+ dup GlobalMemoryStatus ;
+
+M: wince cpus ( -- n ) 1 ;
+
+M: wince memory-load ( -- n )
+ memory-status MEMORYSTATUS-dwMemoryLoad ;
+
+M: wince physical-mem ( -- n )
+ memory-status MEMORYSTATUS-dwTotalPhys ;
+
+M: wince available-mem ( -- n )
+ memory-status MEMORYSTATUS-dwAvailPhys ;
+
+M: wince total-page-file ( -- n )
+ memory-status MEMORYSTATUS-dwTotalPageFile ;
+
+M: wince available-page-file ( -- n )
+ memory-status MEMORYSTATUS-dwAvailPageFile ;
+
+M: wince total-virtual-mem ( -- n )
+ memory-status MEMORYSTATUS-dwTotalVirtual ;
+
+M: wince available-virtual-mem ( -- n )
+ memory-status MEMORYSTATUS-dwAvailVirtual ;
--- /dev/null
+unportable
--- /dev/null
+Doug Coleman
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien alien.c-types alien.strings
+kernel libc math namespaces system-info.backend
+system-info.windows windows windows.advapi32
+windows.kernel32 system byte-arrays windows.errors
+classes classes.struct accessors ;
+IN: system-info.windows.nt
+
+M: winnt cpus ( -- n )
+ system-info dwNumberOfProcessors>> ;
+
+: memory-status ( -- MEMORYSTATUSEX )
+ "MEMORYSTATUSEX" <struct>
+ dup class heap-size >>dwLength
+ dup GlobalMemoryStatusEx win32-error=0/f ;
+
+M: winnt memory-load ( -- n )
+ memory-status dwMemoryLoad>> ;
+
+M: winnt physical-mem ( -- n )
+ memory-status ullTotalPhys>> ;
+
+M: winnt available-mem ( -- n )
+ memory-status ullAvailPhys>> ;
+
+M: winnt total-page-file ( -- n )
+ memory-status ullTotalPageFile>> ;
+
+M: winnt available-page-file ( -- n )
+ memory-status ullAvailPageFile>> ;
+
+M: winnt total-virtual-mem ( -- n )
+ memory-status ullTotalVirtual>> ;
+
+M: winnt available-virtual-mem ( -- n )
+ memory-status ullAvailVirtual>> ;
+
+: computer-name ( -- string )
+ MAX_COMPUTERNAME_LENGTH 1 +
+ [ <byte-array> dup ] keep <uint>
+ GetComputerName win32-error=0/f alien>native-string ;
+
+: username ( -- string )
+ UNLEN 1 +
+ [ <byte-array> dup ] keep <uint>
+ GetUserName win32-error=0/f alien>native-string ;
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien alien.c-types classes.struct accessors kernel
+math namespaces windows windows.kernel32 windows.advapi32 words
+combinators vocabs.loader system-info.backend system
+alien.strings windows.errors specialized-arrays ;
+SPECIALIZED-ARRAY: ushort
+IN: system-info.windows
+
+: system-info ( -- SYSTEM_INFO )
+ SYSTEM_INFO <struct> [ GetSystemInfo ] keep ;
+
+: page-size ( -- n )
+ system-info dwPageSize>> ;
+
+! 386, 486, 586, 2200 (IA64), 8664 (AMD_X8664)
+: processor-type ( -- n )
+ system-info dwProcessorType>> ;
+
+! 0 = x86, 6 = Intel Itanium, 9 = x64 (AMD or Intel), 10 = WOW64, 0xffff = Unk
+: processor-architecture ( -- n )
+ system-info dwOemId>> HEX: ffff0000 bitand ;
+
+: os-version ( -- os-version )
+ OSVERSIONINFO <struct>
+ OSVERSIONINFO heap-size >>dwOSVersionInfoSize
+ dup GetVersionEx win32-error=0/f ;
+
+: windows-major ( -- n )
+ os-version dwMajorVersion>> ;
+
+: windows-minor ( -- n )
+ os-version dwMinorVersion>> ;
+
+: windows-build# ( -- n )
+ os-version dwBuildNumber>> ;
+
+: windows-platform-id ( -- n )
+ os-version dwPlatformId>> ;
+
+: windows-service-pack ( -- string )
+ os-version szCSDVersion>> alien>native-string ;
+
+: feature-present? ( n -- ? )
+ IsProcessorFeaturePresent zero? not ;
+
+: sse2? ( -- ? )
+ PF_XMMI64_INSTRUCTIONS_AVAILABLE feature-present? ;
+
+: sse3? ( -- ? )
+ PF_SSE3_INSTRUCTIONS_AVAILABLE feature-present? ;
+
+: get-directory ( word -- str )
+ [ MAX_UNICODE_PATH [ <ushort-array> ] keep dupd ] dip
+ execute win32-error=0/f alien>native-string ; inline
+
+: windows-directory ( -- str )
+ \ GetWindowsDirectory get-directory ;
+
+: system-directory ( -- str )
+ \ GetSystemDirectory get-directory ;
+
+: system-windows-directory ( -- str )
+ \ GetSystemWindowsDirectory get-directory ;
+
+<<
+{
+ { [ os wince? ] [ "system-info.windows.ce" ] }
+ { [ os winnt? ] [ "system-info.windows.nt" ] }
+} cond require >>
"Printing messages when a word is called or returns:"
{ $subsection watch }
{ $subsection watch-vars }
-"Starting the walker when a word is called:"
-{ $subsection breakpoint }
-{ $subsection breakpoint-if }
"Timing words:"
{ $subsection reset-word-timing }
{ $subsection add-timing }
{ watch watch-vars reset } related-words
-HELP: breakpoint
-{ $values { "word" word } }
-{ $description "Annotates a word definition to enter the single stepper when executed." } ;
-
-HELP: breakpoint-if
-{ $values { "quot" { $quotation "( -- ? )" } } { "word" word } }
-{ $description "Annotates a word definition to enter the single stepper if the quotation yields true." } ;
-
HELP: reset
{ $values
{ "word" word } }
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel math sorting words parser io summary
quotations sequences prettyprint continuations effects
-definitions compiler.units namespaces assocs tools.walker
-tools.time generic inspector fry tools.continuations
-locals generalizations macros ;
+definitions compiler.units namespaces assocs tools.time generic
+inspector fry locals generalizations macros ;
IN: tools.annotations
<PRIVATE
: watch-vars ( word vars -- )
dupd '[ [ _ _ ] dip (watch-vars) ] annotate ;
-: breakpoint ( word -- )
- [ add-breakpoint ] annotate ;
-
-: breakpoint-if ( word quot -- )
- '[ [ _ [ [ break ] when ] ] dip 3append ] annotate ;
-
SYMBOL: word-timing
word-timing [ H{ } clone ] initialize
-USING: help.markup help.syntax words alien.c-types assocs
+USING: help.markup help.syntax words alien.c-types alien.data assocs
kernel math ;
IN: tools.deploy.config
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types arrays byte-arrays combinators
destructors generic io kernel libc math sequences system tr
-vocabs.loader words ;
+vocabs.loader words alien.data ;
IN: tools.disassembler
GENERIC: disassemble ( obj -- )
alien alien.syntax alien.c-types lexer parser kernel
sequences layouts math math.order alien.libraries
math.parser system make fry arrays libc destructors
-tools.disassembler.utils splitting ;
+tools.disassembler.utils splitting alien.data
+classes.struct ;
IN: tools.disassembler.udis
<<
LIBRARY: libudis86
-C-STRUCT: ud_operand
- { "int" "type" }
- { "uchar" "size" }
- { "ulonglong" "lval" }
- { "int" "base" }
- { "int" "index" }
- { "uchar" "offset" }
- { "uchar" "scale" } ;
-
-C-STRUCT: ud
- { "void*" "inp_hook" }
- { "uchar" "inp_curr" }
- { "uchar" "inp_fill" }
- { "FILE*" "inp_file" }
- { "uchar" "inp_ctr" }
- { "uchar*" "inp_buff" }
- { "uchar*" "inp_buff_end" }
- { "uchar" "inp_end" }
- { "void*" "translator" }
- { "ulonglong" "insn_offset" }
- { "char[32]" "insn_hexcode" }
- { "char[64]" "insn_buffer" }
- { "uint" "insn_fill" }
- { "uchar" "dis_mode" }
- { "ulonglong" "pc" }
- { "uchar" "vendor" }
- { "struct map_entry*" "mapen" }
- { "int" "mnemonic" }
- { "ud_operand[3]" "operand" }
- { "uchar" "error" }
- { "uchar" "pfx_rex" }
- { "uchar" "pfx_seg" }
- { "uchar" "pfx_opr" }
- { "uchar" "pfx_adr" }
- { "uchar" "pfx_lock" }
- { "uchar" "pfx_rep" }
- { "uchar" "pfx_repe" }
- { "uchar" "pfx_repne" }
- { "uchar" "pfx_insn" }
- { "uchar" "default64" }
- { "uchar" "opr_mode" }
- { "uchar" "adr_mode" }
- { "uchar" "br_far" }
- { "uchar" "br_near" }
- { "uchar" "implicit_addr" }
- { "uchar" "c1" }
- { "uchar" "c2" }
- { "uchar" "c3" }
- { "uchar[256]" "inp_cache" }
- { "uchar[64]" "inp_sess" }
- { "ud_itab_entry*" "itab_entry" } ;
+STRUCT: ud_operand
+ { type int }
+ { size uchar }
+ { lval ulonglong }
+ { base int }
+ { index int }
+ { offset uchar }
+ { scale uchar } ;
+
+STRUCT: ud
+ { inp_hook void* }
+ { inp_curr uchar }
+ { inp_fill uchar }
+ { inp_file FILE* }
+ { inp_ctr uchar }
+ { inp_buff uchar* }
+ { inp_buff_end uchar* }
+ { inp_end uchar }
+ { translator void* }
+ { insn_offset ulonglong }
+ { insn_hexcode char[32] }
+ { insn_buffer char[64] }
+ { insn_fill uint }
+ { dis_mode uchar }
+ { pc ulonglong }
+ { vendor uchar }
+ { mapen void* }
+ { mnemonic int }
+ { operand ud_operand[3] }
+ { error uchar }
+ { pfx_rex uchar }
+ { pfx_seg uchar }
+ { pfx_opr uchar }
+ { pfx_adr uchar }
+ { pfx_lock uchar }
+ { pfx_rep uchar }
+ { pfx_repe uchar }
+ { pfx_repne uchar }
+ { pfx_insn uchar }
+ { default64 uchar }
+ { opr_mode uchar }
+ { adr_mode uchar }
+ { br_far uchar }
+ { br_near uchar }
+ { implicit_addr uchar }
+ { c1 uchar }
+ { c2 uchar }
+ { c3 uchar }
+ { inp_cache uchar[256] }
+ { inp_sess uchar[64] }
+ { itab_entry ud_itab_entry* } ;
FUNCTION: void ud_translate_intel ( ud* u ) ;
FUNCTION: void ud_translate_att ( ud* u ) ;
FUNCTION: char* ud_lookup_mnemonic ( int c ) ;
: <ud> ( -- ud )
- "ud" malloc-object &free
+ ud malloc-struct &free
dup ud_init
dup cell-bits ud_set_mode
dup UD_SYN_INTEL ud_set_syntax ;
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: tools.test tools.scaffold unicode.case kernel
-multiline tools.scaffold.private io.streams.string ;
+tools.scaffold.private io.streams.string ;
IN: tools.scaffold.tests
: undocumented-word ( obj1 obj2 -- obj3 obj4 )
[ >lower ] [ >upper ] bi* ;
[
-<" HELP: undocumented-word
+"""HELP: undocumented-word
{ $values
{ "obj1" object } { "obj2" object }
{ "obj3" object } { "obj4" object }
}
{ $description "" } ;
-">
+"""
]
[
[ \ undocumented-word (help.) ] with-string-writer
IN: tools.walker
-USING: help.syntax help.markup tools.continuations ;
+USING: help.syntax help.markup tools.continuations sequences math words ;
+
+HELP: breakpoint
+{ $values { "word" word } }
+{ $description "Annotates a word definition to enter the single stepper when executed." } ;
+
+HELP: breakpoint-if
+{ $values { "quot" { $quotation "( -- ? )" } } { "word" word } }
+{ $description "Annotates a word definition to enter the single stepper if the quotation yields true." } ;
HELP: B
-{ $description "An alias for " { $link break } ", defined in the " { $vocab-link "syntax" } " vocabulary so that it is always available." } ;
\ No newline at end of file
+{ $description "An alias for " { $link break } ", defined in the " { $vocab-link "syntax" } " vocabulary so that it is always available." } ;
+
+ARTICLE: "breakpoints" "Setting breakpoints"
+"In addition to invoking the walker explicitly through the UI, it is possible to set breakpoints on words using words in the " { $vocab-link "tools.walker" } " vocabulary."
+$nl
+"Annotating a word with a breakpoint (see " { $link "tools.annotations" } "):"
+{ $subsection breakpoint }
+{ $subsection breakpoint-if }
+"Breakpoints can be inserted directly into code:"
+{ $subsection break }
+{ $subsection POSTPONE: B }
+"Note that because the walker calls various core library and UI words while rendering its own user interface, setting a breakpoint on a word such as " { $link append } " or " { $link + } " will hang the UI." ;
+
+ABOUT: "breakpoints"
concurrency.messaging quotations kernel.private words
sequences.private assocs models models.arrow arrays accessors
generic generic.standard definitions make sbufs
-tools.continuations parser ;
+tools.continuations parser tools.annotations fry ;
IN: tools.walker
SYMBOL: show-walker-hook ! ( status continuation thread -- )
"Walker on " self name>> append spawn
[ associate-thread ] keep ;
+: breakpoint ( word -- )
+ [ add-breakpoint ] annotate ;
+
+: breakpoint-if ( word quot -- )
+ '[ [ _ [ [ break ] when ] ] dip 3append ] annotate ;
+
! For convenience
IN: syntax
! Copyright (C) 2006, 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien alien.c-types alien.strings arrays assocs
-cocoa kernel math cocoa.messages cocoa.subclassing cocoa.classes
-cocoa.views cocoa.application cocoa.pasteboard cocoa.types
-cocoa.windows sequences io.encodings.utf8 ui ui.private ui.gadgets
-ui.gadgets.private ui.gadgets.worlds ui.gestures
+USING: accessors alien alien.c-types alien.data alien.strings
+arrays assocs cocoa kernel math cocoa.messages cocoa.subclassing
+cocoa.classes cocoa.views cocoa.application cocoa.pasteboard
+cocoa.types cocoa.windows sequences io.encodings.utf8 ui ui.private
+ui.gadgets ui.gadgets.private ui.gadgets.worlds ui.gestures
core-foundation.strings core-graphics core-graphics.types threads
combinators math.rectangles ;
IN: ui.backend.cocoa.views
math.order calendar ascii sets io.encodings.utf16n
windows.errors literals ui.pixel-formats
ui.pixel-formats.private memoize classes
-specialized-arrays classes.struct ;
+specialized-arrays classes.struct alien.data ;
SPECIALIZED-ARRAY: POINT
IN: ui.backend.windows
: init-win32-ui ( -- )
V{ } clone nc-buttons set-global
- "MSG" malloc-object msg-obj set-global
+ MSG malloc-struct msg-obj set-global
GetDoubleClickTime milliseconds double-click-timeout set-global ;
: cleanup-win32-ui ( -- )
[ append theme-image ] tri-curry@ tri
] 2dip <tile-pen> ;
-CONSTANT: button-background COLOR: FactorLightTan
+CONSTANT: button-background COLOR: FactorTan
CONSTANT: button-clicked-background COLOR: FactorDarkSlateBlue
: <border-button-pen> ( -- pen )
-USING: destructors help.markup help.syntax kernel math multiline sequences
+USING: destructors help.markup help.syntax kernel math sequences
vocabs vocabs.parser words namespaces ;
IN: ui.pixel-formats
{ $subsection samples }
{ $examples
"The following " { $link world } " subclass will request a double-buffered window with minimum 24-bit color and depth buffers, and will throw an error if the requirements aren't met:"
-{ $code <"
+{ $code """
USING: kernel ui.worlds ui.pixel-formats ;
IN: ui.pixel-formats.examples
[ color-bits pixel-format-attribute 24 < [ "Not enough color bits!" throw ] when ]
[ depth-bits pixel-format-attribute 24 < [ "Not enough depth bits!" throw ] when ]
tri ;
-"> } }
+""" } }
;
HELP: double-buffered
$nl\r
"The " { $link com-back } " command travels backwards through time, and restore stacks. This does not undo side effects (modifying array entries, writing to files, formatting the hard drive, etc) and therefore can only be used reliably on referentially transparent code." ;\r
\r
-ARTICLE: "breakpoints" "Setting breakpoints"\r
-"In addition to invoking the walker explicitly through the UI, it is possible to set breakpoints on words. See " { $link "tools.annotations" } "."\r
-$nl\r
-"Breakpoints can be inserted directly into code:"\r
-{ $subsection break }\r
-{ $subsection POSTPONE: B }\r
-"Note that because the walker calls various core library and UI words while rendering its own user interface, setting a breakpoint on a word such as " { $link append } " or " { $link draw-gadget } " will hang the UI." ;\r
-\r
ARTICLE: "ui-walker" "UI walker"\r
"The walker single-steps through quotations. To use the walker, enter a piece of code in the listener's input area and press " { $operation walk } "."\r
$nl\r
-USING: alien.syntax unix.time classes.struct ;
+USING: alien.c-types alien.syntax unix.time unix.types
+unix.types.macosx classes.struct ;
IN: unix
CONSTANT: FD_SETSIZE 1024
CONSTANT: _UTX_IDSIZE 4
CONSTANT: _UTX_HOSTSIZE 256
-C-STRUCT: utmpx
- { { "char" _UTX_USERSIZE } "ut_user" }
- { { "char" _UTX_IDSIZE } "ut_id" }
- { { "char" _UTX_LINESIZE } "ut_line" }
- { "pid_t" "ut_pid" }
- { "short" "ut_type" }
- { "timeval" "ut_tv" }
- { { "char" _UTX_HOSTSIZE } "ut_host" }
- { { "uint" 16 } "ut_pad" } ;
+STRUCT: utmpx
+ { ut_user { char _UTX_USERSIZE } }
+ { ut_id { char _UTX_IDSIZE } }
+ { ut_line { char _UTX_LINESIZE } }
+ { ut_pid pid_t }
+ { ut_type short }
+ { ut_tv timeval }
+ { ut_host { char _UTX_HOSTSIZE } }
+ { ut_pad { uint 16 } } ;
CONSTANT: __DARWIN_MAXPATHLEN 1024
CONSTANT: __DARWIN_MAXNAMELEN 255
{ d_reclen __uint16_t }
{ d_type __uint8_t }
{ d_namlen __uint8_t }
- { d_name { "char" __DARWIN_MAXNAMELEN+1 } } ;
+ { d_name { char __DARWIN_MAXNAMELEN+1 } } ;
CONSTANT: EPERM 1
CONSTANT: ENOENT 2
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax unix.time classes.struct ;
+USING: alien.c-types alien.syntax unix.time unix.types
+unix.types.netbsd classes.struct ;
IN: unix
STRUCT: sockaddr_storage
{ ss_len __uint8_t }
{ ss_family sa_family_t }
- { __ss_pad1 { "char" _SS_PAD1SIZE } }
+ { __ss_pad1 { char _SS_PAD1SIZE } }
{ __ss_align __int64_t }
- { __ss_pad2 { "char" _SS_PAD2SIZE } } ;
+ { __ss_pad2 { char _SS_PAD2SIZE } } ;
STRUCT: exit_struct
{ e_termination uint16_t }
{ e_exit uint16_t } ;
-C-STRUCT: utmpx
- { { "char" _UTX_USERSIZE } "ut_user" }
- { { "char" _UTX_IDSIZE } "ut_id" }
- { { "char" _UTX_LINESIZE } "ut_line" }
- { { "char" _UTX_HOSTSIZE } "ut_host" }
- { "uint16_t" "ut_session" }
- { "uint16_t" "ut_type" }
- { "pid_t" "ut_pid" }
- { "exit_struct" "ut_exit" }
- { "sockaddr_storage" "ut_ss" }
- { "timeval" "ut_tv" }
- { { "uint32_t" 10 } "ut_pad" } ;
+STRUCT: utmpx
+ { ut_user { char _UTX_USERSIZE } }
+ { ut_id { char _UTX_IDSIZE } }
+ { ut_line { char _UTX_LINESIZE } }
+ { ut_host { char _UTX_HOSTSIZE } }
+ { ut_session uint16_t }
+ { ut_type uint16_t }
+ { ut_pid pid_t }
+ { ut_exit exit_struct }
+ { ut_ss sockaddr_storage }
+ { ut_tv timeval }
+ { ut_pad { uint32_t 10 } } ;
-USING: kernel alien.c-types alien.strings sequences math alien.syntax
-unix namespaces continuations threads assocs io.backend.unix
-io.encodings.utf8 unix.utilities fry ;
+USING: kernel alien.c-types alien.data alien.strings sequences
+math alien.syntax unix namespaces continuations threads assocs
+io.backend.unix io.encodings.utf8 unix.utilities fry ;
IN: unix.process
! Low-level Unix process launching utilities. These are used
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.c-types alien.strings
+USING: alien alien.c-types alien.data alien.strings
combinators.short-circuit fry kernel layouts sequences accessors
specialized-arrays ;
IN: unix.utilities
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.c-types alien.syntax combinators continuations
-io.encodings.string io.encodings.utf8 kernel sequences strings
-unix calendar system accessors unix.time calendar.unix
-vocabs.loader ;
+USING: alien.c-types alien.data alien.syntax combinators
+continuations io.encodings.string io.encodings.utf8 kernel
+sequences strings unix calendar system accessors unix.time
+calendar.unix vocabs.loader classes.struct ;
IN: unix.utmpx
CONSTANT: EMPTY 0
utmpx-record new ;
M: unix utmpx>utmpx-record ( utmpx -- utmpx-record )
- [ new-utmpx-record ] dip
+ [ new-utmpx-record ] dip \ utmpx memory>struct
{
- [ utmpx-ut_user _UTX_USERSIZE memory>string >>user ]
- [ utmpx-ut_id _UTX_IDSIZE memory>string >>id ]
- [ utmpx-ut_line _UTX_LINESIZE memory>string >>line ]
- [ utmpx-ut_pid >>pid ]
- [ utmpx-ut_type >>type ]
- [ utmpx-ut_tv timeval>unix-time >>timestamp ]
- [ utmpx-ut_host _UTX_HOSTSIZE memory>string >>host ]
+ [ ut_user>> _UTX_USERSIZE memory>string >>user ]
+ [ ut_id>> _UTX_IDSIZE memory>string >>id ]
+ [ ut_line>> _UTX_LINESIZE memory>string >>line ]
+ [ ut_pid>> >>pid ]
+ [ ut_type>> >>type ]
+ [ ut_tv>> timeval>unix-time >>timestamp ]
+ [ ut_host>> _UTX_HOSTSIZE memory>string >>host ]
} cleave ;
: with-utmpx ( quot -- )
+USING: strings help.markup help.syntax assocs ;
IN: urls.encoding
-USING: strings help.markup help.syntax assocs multiline urls ;
HELP: url-decode
{ $values { "str" string } { "decoded" string } }
"USING: prettyprint urls.encoding ;"
"\"gender=female&agefrom=22&ageto=28&location=Omaha+NE\""
"query>assoc ."
- <" H{
+ """H{
{ "gender" "female" }
{ "agefrom" "22" }
{ "ageto" "28" }
{ "location" "Omaha NE" }
-}">
+}"""
}
} ;
USING: assocs hashtables help.markup help.syntax
io.streams.string io.files io.pathnames kernel strings present
-math multiline ;
+math ;
IN: urls
HELP: url
}
{ $examples
{ $code
- <" USING: kernel http.client urls ;
+ """USING: kernel http.client urls ;
URL" http://search.yahooapis.com/WebSearchService/V1/webSearch" clone
"concatenative programming (NSFW)" "query" set-query-param
"1" "adult_ok" set-query-param
-http-get">
+http-get"""
}
"(For a complete Yahoo! search web service implementation, see the " { $vocab-link "yahoo" } " vocabulary.)"
}
--- /dev/null
+Phil Dawes
\ No newline at end of file
--- /dev/null
+Layout of the C vm structure
--- /dev/null
+! Copyright (C) 2009 Phil Dawes.
+! See http://factorcode.org/license.txt for BSD license.
+USING: classes.struct alien.syntax ;
+IN: vm
+
+TYPEDEF: void* cell
+
+STRUCT: zone
+ { start cell }
+ { here cell }
+ { size cell }
+ { end cell } ;
+
+STRUCT: vm
+ { stack_chain context* }
+ { nursery zone }
+ { cards_offset cell }
+ { decks_offset cell }
+ { userenv cell[70] } ;
+
+: vm-field-offset ( field -- offset ) vm offset-of ; inline
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: compiler.units continuations fry kernel vocabs vocabs.parser ;
+IN: vocabs.generated
+
+: generate-vocab ( vocab-name quot -- vocab )
+ [ dup vocab [ ] ] dip '[
+ [
+ [
+ [ _ with-current-vocab ] [ ] [ forget-vocab ] cleanup
+ ] with-compilation-unit
+ ] keep
+ ] ?if ; inline
+USING: vocabs.prettyprint tools.test io.streams.string eval ;
IN: vocabs.prettyprint.tests
-USING: vocabs.prettyprint tools.test io.streams.string multiline eval ;
: manifest-test-1 ( -- string )
- <" USING: kernel namespaces vocabs.parser vocabs.prettyprint ;
+ """USING: kernel namespaces vocabs.parser vocabs.prettyprint ;
- << manifest get pprint-manifest >> "> ;
+ << manifest get pprint-manifest >>""" ;
[
-<" USING: kernel namespaces vocabs.parser vocabs.prettyprint ;">
+"""USING: kernel namespaces vocabs.parser vocabs.prettyprint ;"""
]
[ [ manifest-test-1 eval( -- ) ] with-string-writer ] unit-test
: manifest-test-2 ( -- string )
- <" USING: kernel namespaces vocabs.parser vocabs.prettyprint ;
+ """USING: kernel namespaces vocabs.parser vocabs.prettyprint ;
IN: vocabs.prettyprint.tests
- << manifest get pprint-manifest >> "> ;
+ << manifest get pprint-manifest >>""" ;
[
-<" USING: kernel namespaces vocabs.parser vocabs.prettyprint ;
-IN: vocabs.prettyprint.tests">
+"""USING: kernel namespaces vocabs.parser vocabs.prettyprint ;
+IN: vocabs.prettyprint.tests"""
]
[ [ manifest-test-2 eval( -- ) ] with-string-writer ] unit-test
: manifest-test-3 ( -- string )
- <" USING: kernel namespaces vocabs.parser vocabs.prettyprint ;
+ """USING: kernel namespaces vocabs.parser vocabs.prettyprint ;
FROM: math => + - ;
QUALIFIED: system
QUALIFIED-WITH: assocs a
EXCLUDE: parser => run-file ;
IN: vocabs.prettyprint.tests
- << manifest get pprint-manifest >> "> ;
+ << manifest get pprint-manifest >>""" ;
[
-<" USING: kernel namespaces vocabs.parser vocabs.prettyprint ;
+"""USING: kernel namespaces vocabs.parser vocabs.prettyprint ;
FROM: math => + - ;
QUALIFIED: system
QUALIFIED-WITH: assocs a
EXCLUDE: parser => run-file ;
-IN: vocabs.prettyprint.tests">
+IN: vocabs.prettyprint.tests"""
]
-[ [ manifest-test-3 eval( -- ) ] with-string-writer ] unit-test
\ No newline at end of file
+[ [ manifest-test-3 eval( -- ) ] with-string-writer ] unit-test
USING: alien.syntax kernel math windows.types windows.kernel32
-math.bitwise ;
+math.bitwise classes.struct ;
IN: windows.advapi32
LIBRARY: advapi32
CONSTANT: CRYPT_MACHINE_KEYSET HEX: 20
CONSTANT: CRYPT_SILENT HEX: 40
-C-STRUCT: ACL
- { "BYTE" "AclRevision" }
- { "BYTE" "Sbz1" }
- { "WORD" "AclSize" }
- { "WORD" "AceCount" }
- { "WORD" "Sbz2" } ;
+STRUCT: ACL
+ { AclRevision BYTE }
+ { Sbz1 BYTE }
+ { AclSize WORD }
+ { AceCount WORD }
+ { Sbz2 WORD } ;
TYPEDEF: ACL* PACL
CONSTANT: INHERIT_ONLY_ACE HEX: 8
CONSTANT: VALID_INHERIT_FLAGS HEX: f
-C-STRUCT: ACE_HEADER
- { "BYTE" "AceType" }
- { "BYTE" "AceFlags" }
- { "WORD" "AceSize" } ;
+STRUCT: ACE_HEADER
+ { AceType BYTE }
+ { AceFlags BYTE }
+ { AceSize WORD } ;
TYPEDEF: ACE_HEADER* PACE_HEADER
-C-STRUCT: ACCESS_ALLOWED_ACE
- { "ACE_HEADER" "Header" }
- { "DWORD" "Mask" }
- { "DWORD" "SidStart" } ;
+STRUCT: ACCESS_ALLOWED_ACE
+ { Header ACE_HEADER }
+ { Mask DWORD }
+ { SidStart DWORD } ;
TYPEDEF: ACCESS_ALLOWED_ACE* PACCESS_ALLOWED_ACE
-C-STRUCT: ACCESS_DENIED_ACE
- { "ACE_HEADER" "Header" }
- { "DWORD" "Mask" }
- { "DWORD" "SidStart" } ;
+STRUCT: ACCESS_DENIED_ACE
+ { Header ACE_HEADER }
+ { Mask DWORD }
+ { SidStart DWORD } ;
TYPEDEF: ACCESS_DENIED_ACE* PACCESS_DENIED_ACE
-C-STRUCT: SYSTEM_AUDIT_ACE
- { "ACE_HEADER" "Header" }
- { "DWORD" "Mask" }
- { "DWORD" "SidStart" } ;
+STRUCT: SYSTEM_AUDIT_ACE
+ { Header ACE_HEADER }
+ { Mask DWORD }
+ { SidStart DWORD } ;
TYPEDEF: SYSTEM_AUDIT_ACE* PSYSTEM_AUDIT_ACE
-C-STRUCT: SYSTEM_ALARM_ACE
- { "ACE_HEADER" "Header" }
- { "DWORD" "Mask" }
- { "DWORD" "SidStart" } ;
+STRUCT: SYSTEM_ALARM_ACE
+ { Header ACE_HEADER }
+ { Mask DWORD }
+ { SidStart DWORD } ;
TYPEDEF: SYSTEM_ALARM_ACE* PSYSTEM_ALARM_ACE
-C-STRUCT: ACCESS_ALLOWED_CALLBACK_ACE
- { "ACE_HEADER" "Header" }
- { "DWORD" "Mask" }
- { "DWORD" "SidStart" } ;
+STRUCT: ACCESS_ALLOWED_CALLBACK_ACE
+ { Header ACE_HEADER }
+ { Mask DWORD }
+ { SidStart DWORD } ;
TYPEDEF: ACCESS_ALLOWED_CALLBACK_ACE* PACCESS_ALLOWED_CALLBACK_ACE
-C-STRUCT: SECURITY_DESCRIPTOR
- { "UCHAR" "Revision" }
- { "UCHAR" "Sbz1" }
- { "WORD" "Control" }
- { "PVOID" "Owner" }
- { "PVOID" "Group" }
- { "PACL" "Sacl" }
- { "PACL" "Dacl" } ;
+STRUCT: SECURITY_DESCRIPTOR
+ { Revision UCHAR }
+ { Sbz1 UCHAR }
+ { Control WORD }
+ { Owner PVOID }
+ { Group PVOID }
+ { Sacl PACL }
+ { Dacl PACL } ;
TYPEDEF: SECURITY_DESCRIPTOR* PSECURITY_DESCRIPTOR
TYPEDEF: TRUSTEE* PTRUSTEE
-C-STRUCT: TRUSTEE
- { "PTRUSTEE" "pMultipleTrustee" }
- { "MULTIPLE_TRUSTEE_OPERATION" "MultipleTrusteeOperation" }
- { "TRUSTEE_FORM" "TrusteeForm" }
- { "TRUSTEE_TYPE" "TrusteeType" }
- { "LPTSTR" "ptstrName" } ;
-
-C-STRUCT: EXPLICIT_ACCESS
- { "DWORD" "grfAccessPermissions" }
- { "ACCESS_MODE" "grfAccessMode" }
- { "DWORD" "grfInheritance" }
- { "TRUSTEE" "Trustee" } ;
-
-C-STRUCT: SID_IDENTIFIER_AUTHORITY
- { { "BYTE" 6 } "Value" } ;
+STRUCT: TRUSTEE
+ { pMultipleTrustee PTRUSTEE }
+ { MultipleTrusteeOperation MULTIPLE_TRUSTEE_OPERATION }
+ { TrusteeForm TRUSTEE_FORM }
+ { TrusteeType TRUSTEE_TYPE }
+ { ptstrName LPTSTR } ;
+
+STRUCT: EXPLICIT_ACCESS
+ { grfAccessPermissions DWORD }
+ { grfAccessMode ACCESS_MODE }
+ { grfInheritance DWORD }
+ { Trustee TRUSTEE } ;
+
+STRUCT: SID_IDENTIFIER_AUTHORITY
+ { Value { BYTE 6 } } ;
TYPEDEF: SID_IDENTIFIER_AUTHORITY* PSID_IDENTIFIER_AUTHORITY
USING: alien alien.c-types alien.destructors windows.com.syntax\r
windows.ole32 windows.types continuations kernel alien.syntax\r
-libc destructors accessors ;\r
+libc destructors accessors alien.data ;\r
IN: windows.com\r
\r
LIBRARY: ole32\r
-USING: help.markup help.syntax io kernel math quotations
-multiline ;
+USING: help.markup help.syntax io kernel math quotations ;
IN: windows.com.syntax
HELP: GUID:
{ $description "\nCreate a COM globally-unique identifier (GUID) literal at parse time, and push it onto the data stack." } ;
HELP: COM-INTERFACE:
-{ $syntax <"
-COM-INTERFACE: <interface> <parent> <iid>
+{ $syntax """COM-INTERFACE: <interface> <parent> <iid>
<function-1> ( <params1> )
<function-2> ( <params2> )
... ;
-"> }
+""" }
{ $description "\nFor the interface " { $snippet "<interface>" } ", a word " { $snippet "<interface>-iid ( -- iid )" } " is defined to push the interface GUID (IID) onto the stack. Words of the form " { $snippet "<interface>::<function>" } " are also defined to invoke each method, as well as the methods inherited from " { $snippet "<parent>" } ". A " { $snippet "<parent>" } " of " { $snippet "f" } " indicates that the interface is a root interface. (Note that COM conventions demand that all interfaces at least inherit from " { $snippet "IUnknown" } ".)\n\nExample:" }
-{ $code <"
+{ $code """
COM-INTERFACE: IUnknown f {00000000-0000-0000-C000-000000000046}
HRESULT QueryInterface ( REFGUID iid, void** ppvObject )
ULONG AddRef ( )
COM-INTERFACE: IInherited ISimple {9620ecec-8438-423b-bb14-86f835aa40dd}
int getX ( )
void setX ( int newX ) ;
-"> } ;
+""" } ;
: (stack-effect-from-return-and-parameters) ( return parameters -- stack-effect )
swap
[ [ second ] map ]
- [ dup "void" = [ drop { } ] [ 1array ] if ] bi*
+ [ dup void? [ drop { } ] [ 1array ] if ] bi*
<effect> ;
: (define-word-for-function) ( function interface n -- )
USING: help.markup help.syntax io kernel math quotations\r
-multiline alien windows.com windows.com.syntax continuations\r
+alien windows.com windows.com.syntax continuations\r
destructors ;\r
IN: windows.com.wrapper\r
\r
HELP: <com-wrapper>\r
{ $values { "implementations" "an assoc relating COM interface names to arrays of quotations implementing that interface" } { "wrapper" "a " { $link com-wrapper } " tuple" } }\r
{ $description "Constructs a " { $link com-wrapper } " tuple. Each key in the " { $snippet "implementations" } " assoc must be the name of an interface defined with " { $link POSTPONE: COM-INTERFACE: } ". The corresponding value must be an array of quotations implementing the methods of that interface in order, including those of its parent interfaces. The " { $snippet "IUnknown" } " methods (" { $link IUnknown::QueryInterface } ", " { $link IUnknown::AddRef } ", and " { $link IUnknown::Release } ") will be defined automatically and must not be specified in the array. These quotations should have stack effects mirroring those of the interface methods being implemented; for example, a method " { $snippet "void foobar ( int foo, int bar )" } " should be implemented with a quotation of effect " { $snippet "( this foo bar -- )" } ". The " { $snippet "this" } " parameter (that is, the leftmost parameter of any COM method) will be automatically converted from an alien pointer to the underlying Factor object before the quotation is invoked.\n\nThe resulting wrapper can be applied to a Factor object using the " { $link com-wrap } " word. The COM interface pointer returned by " { $snippet "com-wrap" } " can then be passed to C functions requiring a COM object as a parameter. The vtables constructed by " { $snippet "<com-wrapper>" } " are stored on the non-GC heap in order to be accessible to C functions; when the wrapper object and its vtables are no longer needed, the object's resources must be freed using " { $link dispose } ".\n\nExample:" }\r
-{ $code <"\r
+{ $code """\r
COM-INTERFACE: ISimple IUnknown {216fb341-0eb2-44b1-8edb-60b76e353abc}\r
HRESULT returnOK ( )\r
HRESULT returnError ( ) ;\r
[ swap x>> + ] ! IUnrelated::xPlus\r
[ spin x>> * + ] ! IUnrealted::xMulAdd\r
} }\r
-} <com-wrapper>\r
-"> } ;\r
+} <com-wrapper>""" } ;\r
\r
HELP: com-wrap\r
{ $values { "object" "The factor object to wrap" } { "wrapper" "A " { $link com-wrapper } " object" } { "wrapped-object" "A COM object referencing " { $snippet "object" } } }\r
-USING: alien alien.c-types alien.accessors windows.com.syntax
-init windows.com.syntax.private windows.com continuations kernel
-namespaces windows.ole32 libc vocabs assocs accessors arrays
-sequences quotations combinators math words compiler.units
-destructors fry math.parser generalizations sets
-specialized-arrays windows.kernel32 classes.struct ;
+USING: alien alien.c-types alien.data alien.accessors
+windows.com.syntax init windows.com.syntax.private windows.com
+continuations kernel namespaces windows.ole32 libc vocabs
+assocs accessors arrays sequences quotations combinators math
+words compiler.units destructors fry math.parser generalizations
+sets specialized-arrays windows.kernel32 classes.struct ;
SPECIALIZED-ARRAY: void*
IN: windows.com.wrapper
USING: windows.dinput windows.kernel32 windows.ole32 windows.com
-windows.com.syntax alien alien.c-types alien.syntax kernel system namespaces
-combinators sequences fry math accessors macros words quotations
-libc continuations generalizations splitting locals assocs init
-specialized-arrays memoize classes.struct ;
+windows.com.syntax alien alien.c-types alien.data alien.syntax
+kernel system namespaces combinators sequences fry math accessors
+macros words quotations libc continuations generalizations
+splitting locals assocs init specialized-arrays memoize
+classes.struct strings arrays ;
SPECIALIZED-ARRAY: DIOBJECTDATAFORMAT
IN: windows.dinput.constants
MEMO: c-type* ( name -- c-type ) c-type ;
MEMO: heap-size* ( c-type -- n ) heap-size ;
+GENERIC: array-base-type ( c-type -- c-type' )
+M: object array-base-type ;
+M: string array-base-type "[" split1 drop ;
+M: array array-base-type first ;
+
: (field-spec-of) ( field struct -- field-spec )
c-type* fields>> [ name>> = ] with find nip ;
: (offsetof) ( field struct -- offset )
[ (field-spec-of) offset>> ] [ drop 0 ] if* ;
: (sizeof) ( field struct -- size )
- [ (field-spec-of) type>> "[" split1 drop heap-size* ] [ drop 1 ] if* ;
+ [ (field-spec-of) type>> array-base-type heap-size* ] [ drop 1 ] if* ;
: (flag) ( thing -- integer )
{
LIBRARY: dinput
-TYPEDEF: void* LPDIENUMDEVICESCALLBACKW
-: LPDIENUMDEVICESCALLBACKW ( quot -- alien )
- [ "BOOL" { "LPCDIDEVICEINSTANCEW" "LPVOID" } "stdcall" ]
- dip alien-callback ; inline
-TYPEDEF: void* LPDIENUMDEVICESBYSEMANTICSCBW
-: LPDIENUMDEVICESBYSEMANTICSCBW ( quot -- alien )
- [ "BOOL" { "LPCDIDEVICEINSTANCEW" "IDirectInputDevice8W*" "DWORD" "DWORD" "LPVOID" } "stdcall" ]
- dip alien-callback ; inline
-TYPEDEF: void* LPDICONFIGUREDEVICESCALLBACK
-: LPDICONFIGUREDEVICESCALLBACK ( quot -- alien )
- [ "BOOL" { "IUnknown*" "LPVOID" } "stdcall" ]
- dip alien-callback ; inline
-TYPEDEF: void* LPDIENUMEFFECTSCALLBACKW
-: LPDIENUMEFFECTSCALLBACKW ( quot -- alien )
- [ "BOOL" { "LPCDIEFFECTINFOW" "LPVOID" } "stdcall" ]
- dip alien-callback ; inline
-TYPEDEF: void* LPDIENUMCREATEDEFFECTOBJECTSCALLBACK
-: LPDIENUMCREATEDEFFECTOBJECTSCALLBACK ( quot -- callback )
- [ "BOOL" { "LPDIRECTINPUTEFFECT" "LPVOID" } "stdcall" ]
- dip alien-callback ; inline
-TYPEDEF: void* LPDIENUMEFFECTSINFILECALLBACK
-: LPDIENUMEFFECTSINFILECALLBACK ( quot -- callback )
- [ "BOOL" { "LPCDIFILEEFFECT" "LPVOID" } "stdcall" ]
- dip alien-callback ; inline
-TYPEDEF: void* LPDIENUMDEVICEOBJECTSCALLBACKW
-: LPDIENUMDEVICEOBJECTSCALLBACKW ( quot -- callback )
- [ "BOOL" { "LPCDIDEVICEOBJECTINSTANCEW" "LPVOID" } "stdcall" ]
- dip alien-callback ; inline
-
TYPEDEF: DWORD D3DCOLOR
STRUCT: DIDEVICEINSTANCEW
TYPEDEF: DIJOYSTATE2* LPDIJOYSTATE2
TYPEDEF: DIJOYSTATE2* LPCDIJOYSTATE2
+STDCALL-CALLBACK: BOOL LPDIENUMDEVICESCALLBACKW (
+ LPCDIDEVICEINSTANCEW lpddi,
+ LPVOID pvRef
+) ;
+STDCALL-CALLBACK: BOOL LPDICONFIGUREDEVICESCALLBACK (
+ IUnknown* lpDDSTarget,
+ LPVOID pvRef
+) ;
+STDCALL-CALLBACK: BOOL LPDIENUMEFFECTSCALLBACKW (
+ LPCDIEFFECTINFOW pdei,
+ LPVOID pvRef
+) ;
+STDCALL-CALLBACK: BOOL LPDIENUMEFFECTSINFILECALLBACK (
+ LPCDIFILEEFFECT lpDiFileEf,
+ LPVOID pvRef
+) ;
+STDCALL-CALLBACK: BOOL LPDIENUMDEVICEOBJECTSCALLBACKW (
+ LPCDIDEVICEOBJECTINSTANCEW lpddoi,
+ LPVOID pvRef
+) ;
+
COM-INTERFACE: IDirectInputEffect IUnknown {E7E1F7C0-88D2-11D0-9AD0-00A0C9A06E35}
HRESULT Initialize ( HINSTANCE hinst, DWORD dwVersion, REFGUID rguid )
HRESULT GetEffectGuid ( LPGUID pguid )
HRESULT Unload ( )
HRESULT Escape ( LPDIEFFESCAPE pesc ) ;
+STDCALL-CALLBACK: BOOL LPDIENUMCREATEDEFFECTOBJECTSCALLBACK (
+ IDirectInputEffect* peff,
+ LPVOID pvRef
+) ;
+
COM-INTERFACE: IDirectInputDevice8W IUnknown {54D41081-DC15-4833-A41B-748F73A38179}
HRESULT GetCapabilities ( LPDIDEVCAPS lpDIDeviceCaps )
HRESULT EnumObjects ( LPDIENUMDEVICEOBJECTSCALLBACKW lpCallback, LPVOID pvRef, DWORD dwFlags )
HRESULT SetActionMap ( LPDIACTIONFORMATW lpdiActionFormat, LPCWSTR lpwszUserName, DWORD dwFlags )
HRESULT GetImageInfo ( LPDIDEVICEIMAGEINFOHEADERW lpdiDeviceImageInfoHeader ) ;
+STDCALL-CALLBACK: BOOL LPDIENUMDEVICESBYSEMANTICSCBW (
+ LPCDIDEVICEINSTANCEW lpddi,
+ IDirectInputDevice8W* lpdid,
+ DWORD dwFlags,
+ DWORD dwRemaining,
+ LPVOID pvRef
+) ;
+
COM-INTERFACE: IDirectInput8W IUnknown {BF798031-483A-4DA2-AA99-5D64ED369700}
HRESULT CreateDevice ( REFGUID rguid, IDirectInputDevice8W** lplpDevice, LPUNKNOWN pUnkOuter )
HRESULT EnumDevices ( DWORD dwDevType, LPDIENUMDEVICESCALLBACKW lpCallback, LPVOID pvRef, DWORD dwFlags )
USING: alien.strings io.encodings.utf16n windows.com\r
windows.com.wrapper combinators windows.kernel32 windows.ole32\r
-windows.shell32 kernel accessors\r
+windows.shell32 kernel accessors windows.types\r
prettyprint namespaces ui.tools.listener ui.tools.workspace\r
-alien.c-types alien sequences math ;\r
+alien.data alien sequences math classes.struct ;\r
+SPECIALIZED-ARRAY: WCHAR\r
IN: windows.dragdrop-listener\r
\r
-<< "WCHAR" require-c-array >>\r
-\r
: filenames-from-hdrop ( hdrop -- filenames )\r
dup HEX: FFFFFFFF f 0 DragQueryFile ! get count of files\r
[\r
2dup f 0 DragQueryFile 1 + ! get size of filename buffer\r
- dup "WCHAR" <c-array>\r
+ dup WCHAR <c-array>\r
[ swap DragQueryFile drop ] keep\r
utf16n alien>string\r
] with map ;\r
\r
: filenames-from-data-object ( data-object -- filenames )\r
- "FORMATETC" <c-object>\r
- CF_HDROP over set-FORMATETC-cfFormat\r
- f over set-FORMATETC-ptd\r
- DVASPECT_CONTENT over set-FORMATETC-dwAspect\r
- -1 over set-FORMATETC-lindex\r
- TYMED_HGLOBAL over set-FORMATETC-tymed\r
- "STGMEDIUM" <c-object>\r
+ FORMATETC <struct>\r
+ CF_HDROP >>cfFormat\r
+ f >>ptd\r
+ DVASPECT_CONTENT >>dwAspect\r
+ -1 >>lindex\r
+ TYMED_HGLOBAL >>tymed\r
+ STGMEDIUM <struct>\r
[ IDataObject::GetData ] keep swap succeeded? [\r
- dup STGMEDIUM-data\r
+ dup data>>\r
[ filenames-from-hdrop ] with-global-lock\r
swap ReleaseStgMedium\r
] [ drop f ] if ;\r
-USING: alien.c-types kernel locals math math.bitwise
+USING: alien.data kernel locals math math.bitwise
windows.kernel32 sequences byte-arrays unicode.categories
io.encodings.string io.encodings.utf16n alien.strings
-arrays literals ;
+arrays literals windows.types specialized-arrays ;
+SPECIALIZED-ARRAY: TCHAR
IN: windows.errors
-<< "TCHAR" require-c-array >>
-
CONSTANT: ERROR_SUCCESS 0
CONSTANT: ERROR_INVALID_FUNCTION 1
CONSTANT: ERROR_FILE_NOT_FOUND 2
: make-lang-id ( lang1 lang2 -- n )
10 shift bitor ; inline
-<< "TCHAR" require-c-array >>
-
ERROR: error-message-failed id ;
:: n>win32-error-string ( id -- string )
{
f
id
LANG_NEUTRAL SUBLANG_DEFAULT make-lang-id
- 32768 [ "TCHAR" <c-array> ] [ ] bi
+ 32768 [ TCHAR <c-array> ] [ ] bi
f pick [ FormatMessage 0 = [ id error-message-failed ] when ] dip
utf16n alien>string [ blank? ] trim ;
USING: assocs memoize locals kernel accessors init fonts math
-combinators windows.errors windows.types windows.gdi32 ;
+combinators system-info.windows windows.errors windows.types
+windows.gdi32 ;
IN: windows.fonts
-: windows-font-name ( string -- string' )
+MEMO: windows-fonts ( -- fonts )
+ windows-major 6 >=
+ H{
+ { "sans-serif" "Segoe UI" }
+ { "serif" "Cambria" }
+ { "monospace" "Consolas" }
+ }
H{
{ "sans-serif" "Tahoma" }
{ "serif" "Times New Roman" }
{ "monospace" "Courier New" }
- } ?at drop ;
+ } ? ;
+
+: windows-font-name ( string -- string' )
+ windows-fonts ?at drop ;
MEMO:: (cache-font) ( font -- HFONT )
font size>> neg ! nHeight
TYPEDEF: void* LPOSVERSIONINFO
-C-STRUCT: MEMORY_BASIC_INFORMATION
- { "void*" "BaseAddress" }
- { "void*" "AllocationBase" }
- { "DWORD" "AllocationProtect" }
- { "SIZE_T" "RegionSize" }
- { "DWORD" "state" }
- { "DWORD" "protect" }
- { "DWORD" "type" } ;
+STRUCT: MEMORY_BASIC_INFORMATION
+ { BaseAddress void* }
+ { AllocationBase void* }
+ { AllocationProtect DWORD }
+ { RegionSize SIZE_T }
+ { state DWORD }
+ { protect DWORD }
+ { type DWORD } ;
STRUCT: GUID
{ Data1 ULONG }
CONSTANT: EV_EVENT1 HEX: 800
CONSTANT: EV_EVENT2 HEX: 1000
-C-STRUCT: DCB
- { "DWORD" "DCBlength" }
- { "DWORD" "BaudRate" }
- { "DWORD" "flags" }
- { "WORD" "wReserved" }
- { "WORD" "XonLim" }
- { "WORD" "XoffLim" }
- { "BYTE" "ByteSize" }
- { "BYTE" "Parity" }
- { "BYTE" "StopBits" }
- { "char" "XonChar" }
- { "char" "XoffChar" }
- { "char" "ErrorChar" }
- { "char" "EofChar" }
- { "char" "EvtChar" }
- { "WORD" "wReserved1" } ;
+STRUCT: DCB
+ { DCBlength DWORD }
+ { BaudRate DWORD }
+ { flags DWORD }
+ { wReserved WORD }
+ { XonLim WORD }
+ { XoffLim WORD }
+ { ByteSize BYTE }
+ { Parity BYTE }
+ { StopBits BYTE }
+ { XonChar char }
+ { XoffChar char }
+ { ErrorChar char }
+ { EofChar char }
+ { EvtChar char }
+ { wReserved1 WORD } ;
TYPEDEF: DCB* PDCB
TYPEDEF: DCB* LPDCB
-C-STRUCT: COMM_CONFIG
- { "DWORD" "dwSize" }
- { "WORD" "wVersion" }
- { "WORD" "wReserved" }
- { "DCB" "dcb" }
- { "DWORD" "dwProviderSubType" }
- { "DWORD" "dwProviderOffset" }
- { "DWORD" "dwProviderSize" }
- { { "WCHAR" 1 } "wcProviderData" } ;
+STRUCT: COMM_CONFIG
+ { dwSize DWORD }
+ { wVersion WORD }
+ { wReserved WORD }
+ { dcb DCB }
+ { dwProviderSubType DWORD }
+ { dwProviderOffset DWORD }
+ { dwProviderSize DWORD }
+ { wcProviderData { WCHAR 1 } } ;
TYPEDEF: COMMCONFIG* LPCOMMCONFIG
-C-STRUCT: COMMPROP
- { "WORD" "wPacketLength" }
- { "WORD" "wPacketVersion" }
- { "DWORD" "dwServiceMask" }
- { "DWORD" "dwReserved1" }
- { "DWORD" "dwMaxTxQueue" }
- { "DWORD" "dwMaxRxQueue" }
- { "DWORD" "dwMaxBaud" }
- { "DWORD" "dwProvSubType" }
- { "DWORD" "dwProvCapabilities" }
- { "DWORD" "dwSettableParams" }
- { "DWORD" "dwSettableBaud" }
- { "WORD" "wSettableData" }
- { "WORD" "wSettableStopParity" }
- { "DWORD" "dwCurrentTxQueue" }
- { "DWORD" "dwCurrentRxQueue" }
- { "DWORD" "dwProvSpec1" }
- { "DWORD" "dwProvSpec2" }
- { { "WCHAR" 1 } "wcProvChar" } ;
+STRUCT: COMMPROP
+ { wPacketLength WORD }
+ { wPacketVersion WORD }
+ { dwServiceMask DWORD }
+ { dwReserved1 DWORD }
+ { dwMaxTxQueue DWORD }
+ { dwMaxRxQueue DWORD }
+ { dwMaxBaud DWORD }
+ { dwProvSubType DWORD }
+ { dwProvCapabilities DWORD }
+ { dwSettableParams DWORD }
+ { dwSettableBaud DWORD }
+ { wSettableData WORD }
+ { wSettableStopParity WORD }
+ { dwCurrentTxQueue DWORD }
+ { dwCurrentRxQueue DWORD }
+ { dwProvSpec1 DWORD }
+ { dwProvSpec2 DWORD }
+ { wcProvChar { WCHAR 1 } } ;
TYPEDEF: COMMPROP* LPCOMMPROP
CONSTANT: WAIT_IO_COMPLETION HEX: c0
CONSTANT: WAIT_FAILED HEX: ffffffff
-C-STRUCT: LUID
- { "DWORD" "LowPart" }
- { "LONG" "HighPart" } ;
+STRUCT: LUID
+ { LowPart DWORD }
+ { HighPart LONG } ;
TYPEDEF: LUID* PLUID
-C-STRUCT: LUID_AND_ATTRIBUTES
- { "LUID" "Luid" }
- { "DWORD" "Attributes" } ;
+STRUCT: LUID_AND_ATTRIBUTES
+ { Luid LUID }
+ { Attributes DWORD } ;
TYPEDEF: LUID_AND_ATTRIBUTES* PLUID_AND_ATTRIBUTES
-C-STRUCT: TOKEN_PRIVILEGES
- { "DWORD" "PrivilegeCount" }
- { "LUID_AND_ATTRIBUTES*" "Privileges" } ;
+STRUCT: TOKEN_PRIVILEGES
+ { PrivilegeCount DWORD }
+ { Privileges LUID_AND_ATTRIBUTES* } ;
TYPEDEF: TOKEN_PRIVILEGES* PTOKEN_PRIVILEGES
STRUCT: WIN32_FILE_ATTRIBUTE_DATA
{ nFileSizeLow DWORD } ;
TYPEDEF: WIN32_FILE_ATTRIBUTE_DATA* LPWIN32_FILE_ATTRIBUTE_DATA
-C-STRUCT: BY_HANDLE_FILE_INFORMATION
- { "DWORD" "dwFileAttributes" }
- { "FILETIME" "ftCreationTime" }
- { "FILETIME" "ftLastAccessTime" }
- { "FILETIME" "ftLastWriteTime" }
- { "DWORD" "dwVolumeSerialNumber" }
- { "DWORD" "nFileSizeHigh" }
- { "DWORD" "nFileSizeLow" }
- { "DWORD" "nNumberOfLinks" }
- { "DWORD" "nFileIndexHigh" }
- { "DWORD" "nFileIndexLow" } ;
+STRUCT: BY_HANDLE_FILE_INFORMATION
+ { dwFileAttributes DWORD }
+ { ftCreationTime FILETIME }
+ { ftLastAccessTime FILETIME }
+ { ftLastWriteTime FILETIME }
+ { dwVolumeSerialNumber DWORD }
+ { nFileSizeHigh DWORD }
+ { nFileSizeLow DWORD }
+ { nNumberOfLinks DWORD }
+ { nFileIndexHigh DWORD }
+ { nFileIndexLow DWORD } ;
TYPEDEF: BY_HANDLE_FILE_INFORMATION* LPBY_HANDLE_FILE_INFORMATION
CONSTANT: OFS_MAXPATHNAME 128
-C-STRUCT: OFSTRUCT
- { "BYTE" "cBytes" }
- { "BYTE" "fFixedDisk" }
- { "WORD" "nErrCode" }
- { "WORD" "Reserved1" }
- { "WORD" "Reserved2" }
- ! { { "CHAR" OFS_MAXPATHNAME } "szPathName" } ;
- { { "CHAR" 128 } "szPathName" } ;
+STRUCT: OFSTRUCT
+ { cBytes BYTE }
+ { fFixedDisk BYTE }
+ { nErrCode WORD }
+ { Reserved1 WORD }
+ { Reserved2 WORD }
+ { szPathName { CHAR 128 } } ;
+ ! { szPathName { CHAR OFS_MAXPATHNAME } } ;
TYPEDEF: OFSTRUCT* LPOFSTRUCT
{ cFileName { "TCHAR" MAX_PATH } }
{ cAlternateFileName TCHAR[14] } ;
-STRUCT: BY_HANDLE_FILE_INFORMATION
- { dwFileAttributes DWORD }
- { ftCreationTime FILETIME }
- { ftLastAccessTime FILETIME }
- { ftLastWriteTime FILETIME }
- { dwVolumeSerialNumber DWORD }
- { nFileSizeHigh DWORD }
- { nFileSizeLow DWORD }
- { nNumberOfLinks DWORD }
- { nFileIndexHigh DWORD }
- { nFileIndexLow DWORD } ;
-
TYPEDEF: WIN32_FIND_DATA* PWIN32_FIND_DATA
TYPEDEF: WIN32_FIND_DATA* LPWIN32_FIND_DATA
TYPEDEF: void* POVERLAPPED
! Copyright (C) 2009 Joe Groff, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.c-types kernel combinators sequences
-math windows.gdi32 windows.types images destructors
-accessors fry locals classes.struct ;
+USING: alien.c-types alien.data kernel combinators
+sequences math windows.gdi32 windows.types images
+destructors accessors fry locals classes.struct ;
IN: windows.offscreen
: (bitmap-info) ( dim -- BITMAPINFO )
-USING: alien alien.syntax alien.c-types alien.strings math
-kernel sequences windows.errors windows.types io accessors
+USING: alien alien.syntax alien.c-types alien.data alien.strings
+math kernel sequences windows.errors windows.types io accessors
math.order namespaces make math.parser windows.kernel32
combinators locals specialized-arrays literals splitting
grouping classes.struct combinators.smart ;
CONSTANT: TYMED_ENHMF 64
CONSTANT: TYMED_NULL 0
-C-STRUCT: DVTARGETDEVICE
- { "DWORD" "tdSize" }
- { "WORD" "tdDriverNameOffset" }
- { "WORD" "tdDeviceNameOffset" }
- { "WORD" "tdPortNameOffset" }
- { "WORD" "tdExtDevmodeOffset" }
- { "BYTE[1]" "tdData" } ;
+STRUCT: DVTARGETDEVICE
+ { tdSize DWORD }
+ { tdDriverNameOffset WORD }
+ { tdDeviceNameOffset WORD }
+ { tdPortNameOffset WORD }
+ { tdExtDevmodeOffset WORD }
+ { tdData BYTE[1] } ;
TYPEDEF: WORD CLIPFORMAT
TYPEDEF: POINT POINTL
-C-STRUCT: FORMATETC
- { "CLIPFORMAT" "cfFormat" }
- { "DVTARGETDEVICE*" "ptd" }
- { "DWORD" "dwAspect" }
- { "LONG" "lindex" }
- { "DWORD" "tymed" } ;
+STRUCT: FORMATETC
+ { cfFormat CLIPFORMAT }
+ { ptd DVTARGETDEVICE* }
+ { dwAspect DWORD }
+ { lindex LONG }
+ { tymed DWORD } ;
TYPEDEF: FORMATETC* LPFORMATETC
-C-STRUCT: STGMEDIUM
- { "DWORD" "tymed" }
- { "void*" "data" }
- { "LPUNKNOWN" "punkForRelease" } ;
+STRUCT: STGMEDIUM
+ { tymed DWORD }
+ { data void* }
+ { punkForRelease LPUNKNOWN } ;
TYPEDEF: STGMEDIUM* LPSTGMEDIUM
CONSTANT: COINIT_MULTITHREADED 0
USING: alien alien.c-types alien.syntax namespaces kernel words
sequences math math.bitwise math.vectors colors
io.encodings.utf16n classes.struct accessors ;
+FROM: alien.c-types => float short ;
IN: windows.types
TYPEDEF: char CHAR
TYPEDEF: uchar BYTE
TYPEDEF: ushort wchar_t
+SYMBOL: wchar_t*
+<<
+{ char* utf16n } \ wchar_t* typedef
+\ wchar_t \ wchar_t* "pointer-c-type" set-word-prop
+>>
+
TYPEDEF: wchar_t WCHAR
TYPEDEF: short SHORT
TYPEDEF: LARGE_INTEGER* PLARGE_INTEGER
TYPEDEF: ULARGE_INTEGER* PULARGE_INTEGER
-<< { "char*" utf16n } "wchar_t*" typedef >>
-
TYPEDEF: wchar_t* LPCSTR
TYPEDEF: wchar_t* LPWSTR
TYPEDEF: WCHAR TCHAR
{ right LONG }
{ bottom LONG } ;
-C-STRUCT: PAINTSTRUCT
- { "HDC" " hdc" }
- { "BOOL" "fErase" }
- { "RECT" "rcPaint" }
- { "BOOL" "fRestore" }
- { "BOOL" "fIncUpdate" }
- { "BYTE[32]" "rgbReserved" }
-;
+STRUCT: PAINTSTRUCT
+ { hdc HDC }
+ { fErase BOOL }
+ { rcPaint RECT }
+ { fRestore BOOL }
+ { fIncUpdate BOOL }
+ { rgbReserved BYTE[32] } ;
STRUCT: BITMAPINFOHEADER
{ biSize DWORD }
TYPEDEF: void* LPPAINTSTRUCT
TYPEDEF: void* PAINTSTRUCT
-C-STRUCT: POINT
- { "LONG" "x" }
- { "LONG" "y" } ;
+STRUCT: POINT
+ { x LONG }
+ { y LONG } ;
STRUCT: SIZE
{ cx LONG }
{ cy LONG } ;
-C-STRUCT: MSG
- { "HWND" "hWnd" }
- { "UINT" "message" }
- { "WPARAM" "wParam" }
- { "LPARAM" "lParam" }
- { "DWORD" "time" }
- { "POINT" "pt" } ;
+STRUCT: MSG
+ { hWnd HWND }
+ { message UINT }
+ { wParam WPARAM }
+ { lParam LPARAM }
+ { time DWORD }
+ { pt POINT } ;
TYPEDEF: MSG* LPMSG
TYPEDEF: HANDLE HGLRC
TYPEDEF: HANDLE HRGN
-C-STRUCT: LVITEM
- { "uint" "mask" }
- { "int" "iItem" }
- { "int" "iSubItem" }
- { "uint" "state" }
- { "uint" "stateMask" }
- { "void*" "pszText" }
- { "int" "cchTextMax" }
- { "int" "iImage" }
- { "long" "lParam" }
- { "int" "iIndent" }
- { "int" "iGroupId" }
- { "uint" "cColumns" }
- { "uint*" "puColumns" }
- { "int*" "piColFmt" }
- { "int" "iGroup" } ;
-
-C-STRUCT: LVFINDINFO
- { "uint" "flags" }
- { "char*" "psz" }
- { "long" "lParam" }
- { "POINT" "pt" }
- { "uint" "vkDirection" } ;
-
-C-STRUCT: ACCEL
- { "BYTE" "fVirt" }
- { "WORD" "key" }
- { "WORD" "cmd" } ;
+STRUCT: LVITEM
+ { mask uint }
+ { iItem int }
+ { iSubItem int }
+ { state uint }
+ { stateMask uint }
+ { pszText void* }
+ { cchTextMax int }
+ { iImage int }
+ { lParam long }
+ { iIndent int }
+ { iGroupId int }
+ { cColumns uint }
+ { puColumns uint* }
+ { piColFmt int* }
+ { iGroup int } ;
+
+STRUCT: LVFINDINFO
+ { flags uint }
+ { psz char* }
+ { lParam long }
+ { pt POINT }
+ { vkDirection uint } ;
+
+STRUCT: ACCEL
+ { fVirt BYTE }
+ { key WORD }
+ { cmd WORD } ;
TYPEDEF: ACCEL* LPACCEL
TYPEDEF: DWORD COLORREF
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax alien.destructors ;
+USING: alien.syntax alien.destructors classes.struct ;
IN: windows.usp10
LIBRARY: usp10
-C-STRUCT: SCRIPT_CONTROL
- { "DWORD" "flags" } ;
+STRUCT: SCRIPT_CONTROL
+ { flags DWORD } ;
-C-STRUCT: SCRIPT_STATE
- { "WORD" "flags" } ;
+STRUCT: SCRIPT_STATE
+ { flags WORD } ;
-C-STRUCT: SCRIPT_ANALYSIS
- { "WORD" "flags" }
- { "SCRIPT_STATE" "s" } ;
+STRUCT: SCRIPT_ANALYSIS
+ { flags WORD }
+ { s SCRIPT_STATE } ;
-C-STRUCT: SCRIPT_ITEM
- { "int" "iCharPos" }
- { "SCRIPT_ANALYSIS" "a" } ;
+STRUCT: SCRIPT_ITEM
+ { iCharPos int }
+ { a SCRIPT_ANALYSIS } ;
FUNCTION: HRESULT ScriptItemize (
WCHAR* pwcInChars,
SCRIPT_JUSTIFY_SEEN
SCRIPT_JUSTIFFY_RESERVED4 ;
-C-STRUCT: SCRIPT_VISATTR
- { "WORD" "flags" } ;
+STRUCT: SCRIPT_VISATTR
+ { flags WORD } ;
FUNCTION: HRESULT ScriptShape (
HDC hdc,
int* pcGlyphs
) ;
-C-STRUCT: GOFFSET
- { "LONG" "du" }
- { "LONG" "dv" } ;
+STRUCT: GOFFSET
+ { du LONG }
+ { dv LONG } ;
FUNCTION: HRESULT ScriptPlace (
HDC hdc,
int* piJustify
) ;
-C-STRUCT: SCRIPT_LOGATTR
- { "BYTE" "flags" } ;
+STRUCT: SCRIPT_LOGATTR
+ { flags BYTE } ;
FUNCTION: HRESULT ScriptBreak (
WCHAR* pwcChars,
ABC* pABC
) ;
-C-STRUCT: SCRIPT_PROPERTIES
- { "DWORD" "flags" } ;
+STRUCT: SCRIPT_PROPERTIES
+ { flags DWORD } ;
FUNCTION: HRESULT ScriptGetProperties (
SCRIPT_PROPERTIES*** ppSp,
int* piNumScripts
) ;
-C-STRUCT: SCRIPT_FONTPROPERTIES
- { "int" "cBytes" }
- { "WORD" "wgBlank" }
- { "WORD" "wgDefault" }
- { "WORD" "wgInvalid" }
- { "WORD" "wgKashida" }
- { "int" "iKashidaWidth" } ;
+STRUCT: SCRIPT_FONTPROPERTIES
+ { cBytes int }
+ { wgBlank WORD }
+ { wgDefault WORD }
+ { wgInvalid WORD }
+ { wgKashida WORD }
+ { iKashidaWidth int } ;
FUNCTION: HRESULT ScriptGetFontProperties (
HDC hdc,
CONSTANT: SSA_DONTGLYPH HEX: 40000000
CONSTANT: SSA_NOKASHIDA HEX: 80000000
-C-STRUCT: SCRIPT_TABDEF
- { "int" "cTabStops" }
- { "int" "iScale" }
- { "int*" "pTabStops" }
- { "int" "iTabOrigin" } ;
+STRUCT: SCRIPT_TABDEF
+ { cTabStops int }
+ { iScale int }
+ { pTabStops int* }
+ { iTabOrigin int } ;
TYPEDEF: void* SCRIPT_STRING_ANALYSIS
DWORD dwFlags
) ;
-C-STRUCT: SCRIPT_DIGITSUBSTITUTE
- { "DWORD" "flags" } ;
+STRUCT: SCRIPT_DIGITSUBSTITUTE
+ { flags DWORD } ;
FUNCTION: HRESULT ScriptRecordDigitSubstitution (
LCID Locale,
SCRIPT_DIGITSUBSTITUTE* psds,
SCRIPT_CONTROL* psc,
SCRIPT_STATE* pss
-) ;
\ No newline at end of file
+) ;
byte-arrays kernel literals math sequences windows.types
windows.kernel32 windows.errors math.bitwise io.encodings.utf16n
classes.struct windows.com.syntax init ;
+FROM: alien.c-types => short ;
IN: windows.winsock
TYPEDEF: void* SOCKET
{ addr sockaddr* }
{ next addrinfo* } ;
-C-STRUCT: timeval
- { "long" "sec" }
- { "long" "usec" } ;
+STRUCT: timeval
+ { sec long }
+ { usec long } ;
LIBRARY: winsock
TYPEDEF: LPHANDLE LPWSAEVENT
TYPEDEF: sockaddr* LPSOCKADDR
-C-STRUCT: FLOWSPEC
- { "uint" "TokenRate" }
- { "uint" "TokenBucketSize" }
- { "uint" "PeakBandwidth" }
- { "uint" "Latency" }
- { "uint" "DelayVariation" }
- { "SERVICETYPE" "ServiceType" }
- { "uint" "MaxSduSize" }
- { "uint" "MinimumPolicedSize" } ;
+STRUCT: FLOWSPEC
+ { TokenRate uint }
+ { TokenBucketSize uint }
+ { PeakBandwidth uint }
+ { Latency uint }
+ { DelayVariation uint }
+ { ServiceType SERVICETYPE }
+ { MaxSduSize uint }
+ { MinimumPolicedSize uint } ;
TYPEDEF: FLOWSPEC* PFLOWSPEC
TYPEDEF: FLOWSPEC* LPFLOWSPEC
{ buf void* } ;
TYPEDEF: WSABUF* LPWSABUF
-C-STRUCT: QOS
- { "FLOWSPEC" "SendingFlowspec" }
- { "FLOWSPEC" "ReceivingFlowspec" }
- { "WSABUF" "ProviderSpecific" } ;
+STRUCT: QOS
+ { SendingFlowspec FLOWSPEC }
+ { ReceivingFlowspec FLOWSPEC }
+ { ProviderSpecific WSABUF } ;
TYPEDEF: QOS* LPQOS
CONSTANT: MAX_PROTOCOL_CHAIN 7
-C-STRUCT: WSAPROTOCOLCHAIN
- { "int" "ChainLen" }
- ! { { "DWORD" MAX_PROTOCOL_CHAIN } "ChainEntries" } ;
- { { "DWORD" 7 } "ChainEntries" } ;
+STRUCT: WSAPROTOCOLCHAIN
+ { ChainLen int }
+ { ChainEntries { DWORD 7 } } ;
+ ! { ChainEntries { DWORD MAX_PROTOCOL_CHAIN } } ;
TYPEDEF: WSAPROTOCOLCHAIN* LPWSAPROTOCOLCHAIN
CONSTANT: WSAPROTOCOL_LEN 255
-C-STRUCT: WSAPROTOCOL_INFOW
- { "DWORD" "dwServiceFlags1" }
- { "DWORD" "dwServiceFlags2" }
- { "DWORD" "dwServiceFlags3" }
- { "DWORD" "dwServiceFlags4" }
- { "DWORD" "dwProviderFlags" }
- { "GUID" "ProviderId" }
- { "DWORD" "dwCatalogEntryId" }
- { "WSAPROTOCOLCHAIN" "ProtocolChain" }
- { "int" "iVersion" }
- { "int" "iAddressFamily" }
- { "int" "iMaxSockAddr" }
- { "int" "iMinSockAddr" }
- { "int" "iSocketType" }
- { "int" "iProtocol" }
- { "int" "iProtocolMaxOffset" }
- { "int" "iNetworkByteOrder" }
- { "int" "iSecurityScheme" }
- { "DWORD" "dwMessageSize" }
- { "DWORD" "dwProviderReserved" }
- { { "WCHAR" 256 } "szProtocol" } ;
- ! { { "WCHAR" 256 } "szProtocol"[WSAPROTOCOL_LEN+1] } ;
+STRUCT: WSAPROTOCOL_INFOW
+ { dwServiceFlags1 DWORD }
+ { dwServiceFlags2 DWORD }
+ { dwServiceFlags3 DWORD }
+ { dwServiceFlags4 DWORD }
+ { dwProviderFlags DWORD }
+ { ProviderId GUID }
+ { dwCatalogEntryId DWORD }
+ { ProtocolChain WSAPROTOCOLCHAIN }
+ { iVersion int }
+ { iAddressFamily int }
+ { iMaxSockAddr int }
+ { iMinSockAddr int }
+ { iSocketType int }
+ { iProtocol int }
+ { iProtocolMaxOffset int }
+ { iNetworkByteOrder int }
+ { iSecurityScheme int }
+ { dwMessageSize DWORD }
+ { dwProviderReserved DWORD }
+ { szProtocol { WCHAR 256 } } ;
+ ! { szProtocol[WSAPROTOCOL_LEN+1] { WCHAR 256 } } ;
TYPEDEF: WSAPROTOCOL_INFOW* PWSAPROTOCOL_INFOW
TYPEDEF: WSAPROTOCOL_INFOW* LPWSAPROTOCOL_INFOW
TYPEDEF: WSAPROTOCOL_INFOW WSAPROTOCOL_INFO
TYPEDEF: WSAPROTOCOL_INFOW* LPWSAPROTOCOL_INFO
-C-STRUCT: WSANAMESPACE_INFOW
- { "GUID" "NSProviderId" }
- { "DWORD" "dwNameSpace" }
- { "BOOL" "fActive" }
- { "DWORD" "dwVersion" }
- { "LPWSTR" "lpszIdentifier" } ;
+STRUCT: WSANAMESPACE_INFOW
+ { NSProviderId GUID }
+ { dwNameSpace DWORD }
+ { fActive BOOL }
+ { dwVersion DWORD }
+ { lpszIdentifier LPWSTR } ;
TYPEDEF: WSANAMESPACE_INFOW* PWSANAMESPACE_INFOW
TYPEDEF: WSANAMESPACE_INFOW* LPWSANAMESPACE_INFOW
TYPEDEF: WSANAMESPACE_INFOW WSANAMESPACE_INFO
CONSTANT: FD_MAX_EVENTS 10
-C-STRUCT: WSANETWORKEVENTS
- { "long" "lNetworkEvents" }
- { { "int" FD_MAX_EVENTS } "iErrorCode" } ;
+STRUCT: WSANETWORKEVENTS
+ { lNetworkEvents long }
+ { iErrorCode { int FD_MAX_EVENTS } } ;
TYPEDEF: WSANETWORKEVENTS* PWSANETWORKEVENTS
TYPEDEF: WSANETWORKEVENTS* LPWSANETWORKEVENTS
-! C-STRUCT: WSAOVERLAPPED
- ! { "DWORD" "Internal" }
- ! { "DWORD" "InternalHigh" }
- ! { "DWORD" "Offset" }
- ! { "DWORD" "OffsetHigh" }
- ! { "WSAEVENT" "hEvent" }
- ! { "DWORD" "bytesTransferred" } ;
+! STRUCT: WSAOVERLAPPED
+ ! { Internal DWORD }
+ ! { InternalHigh DWORD }
+ ! { Offset DWORD }
+ ! { OffsetHigh DWORD }
+ ! { hEvent WSAEVENT }
+ ! { bytesTransferred DWORD } ;
! TYPEDEF: WSAOVERLAPPED* LPWSAOVERLAPPED
FUNCTION: SOCKET WSAAccept ( SOCKET s,
! Copyright (C) 2008, 2009 Daniel Ehrenberg, Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
-USING: wrap.strings tools.test multiline ;
+USING: wrap.strings tools.test ;
IN: wrap.strings.tests
[
- <" This is a
+ """This is a
long piece
of text
that we
wish to
-word wrap.">
+word wrap."""
] [
- <" This is a long piece of text that we wish to word wrap."> 10
+ """This is a long piece of text that we wish to word wrap.""" 10
wrap-string
] unit-test
[
- <" This is a
+ """ This is a
long piece
of text
that we
wish to
- word wrap.">
+ word wrap."""
] [
- <" This is a long piece of text that we wish to word wrap."> 12
+ """This is a long piece of text that we wish to word wrap.""" 12
" " wrap-indented-string
] unit-test
! add to this library and are wondering what part of the file to
! modify, just find the function or data structure in the manual
! and note the section.
-USING: accessors kernel arrays alien alien.c-types alien.strings
-alien.syntax classes.struct math math.bitwise words sequences
-namespaces continuations io io.encodings.ascii x11.syntax ;
+USING: accessors kernel arrays alien alien.c-types alien.data
+alien.strings alien.syntax classes.struct math math.bitwise words
+sequences namespaces continuations io io.encodings.ascii x11.syntax ;
+FROM: alien.c-types => short ;
IN: x11.xlib
LIBRARY: xlib
! Copyright (C) 2005, 2009 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
-USING: help.markup help.syntax xml.data present multiline ;
+USING: help.markup help.syntax xml.data present ;
IN: xml.syntax
ABOUT: "xml.syntax"
$nl
"These forms can be used where a tag might go, as in " { $snippet "[XML <foo><-></foo> XML]" } " or where an attribute might go, as in " { $snippet "[XML <foo bar=<->/> XML]" } ". When an attribute is spliced in, it is not included if the value is " { $snippet "f" } " and if the value is not a string, the value is put through " { $link present } ". Here is an example of the fry style of XML interpolation:"
{ $example
-{" USING: splitting xml.writer xml.syntax ;
+"""USING: splitting xml.writer xml.syntax ;
"one two three" " " split
[ [XML <item><-></item> XML] ] map
-<XML <doc><-></doc> XML> pprint-xml"}
-{" <?xml version="1.0" encoding="UTF-8"?>
+<XML <doc><-></doc> XML> pprint-xml"""
+
+"""<?xml version="1.0" encoding="UTF-8"?>
<doc>
<item>
one
<item>
three
</item>
-</doc>"} }
+</doc>""" }
"Here is an example of the locals version:"
{ $example
-{" USING: locals urls xml.syntax xml.writer ;
+"""USING: locals urls xml.syntax xml.writer ;
[let |
number [ 3 ]
false [ f ]
url [ URL" http://factorcode.org/" ]
string [ "hello" ]
- word [ \ drop ] |
+ word [ \\ drop ] |
<XML
<x
number=<-number->
url=<-url->
string=<-string->
word=<-word-> />
- XML> pprint-xml ] "}
-{" <?xml version="1.0" encoding="UTF-8"?>
-<x number="3" url="http://factorcode.org/" string="hello" word="drop"/>"} }
+ XML> pprint-xml
+]"""
+
+"""<?xml version="1.0" encoding="UTF-8"?>
+<x number="3" url="http://factorcode.org/" string="hello" word="drop"/>""" }
"XML interpolation can also be used, in conjunction with " { $vocab-link "inverse" } " in pattern matching. For example:"
-{ $example {" USING: xml.syntax inverse ;
+{ $example """USING: xml.syntax inverse ;
: dispatch ( xml -- string )
{
{ [ [XML <a><-></a> XML] ] [ "a" prepend ] }
{ [ [XML <b val='yes'/> XML] ] [ "yes" ] }
{ [ [XML <b val=<->/> XML] ] [ "no" prepend ] }
} switch ;
-[XML <a>pple</a> XML] dispatch write "} "apple" } ;
+[XML <a>pple</a> XML] dispatch write"""
+"apple" } ;
HELP: XML-NS:
{ $syntax "XML-NS: name http://url" }
[ extract-variables ] tri
] unit-test
-[ {" <?xml version="1.0" encoding="UTF-8"?>
+[ """<?xml version="1.0" encoding="UTF-8"?>
<x>
one
<b val="two"/>
y
<foo/>
-</x>"} ] [
+</x>""" ] [
[let* | a [ "one" ] c [ "two" ] x [ "y" ]
d [ [XML <-x-> <foo/> XML] ] |
<XML
]
] unit-test
-[ {" <?xml version="1.0" encoding="UTF-8"?>
+[ """<?xml version="1.0" encoding="UTF-8"?>
<doc>
<item>
one
<item>
three
</item>
-</doc>"} ] [
+</doc>""" ] [
"one two three" " " split
[ [XML <item><-></item> XML] ] map
<XML <doc><-></doc> XML> pprint-xml>string
] unit-test
-[ {" <?xml version="1.0" encoding="UTF-8"?>
-<x number="3" url="http://factorcode.org/" string="hello" word="drop"/>"} ]
+[ """<?xml version="1.0" encoding="UTF-8"?>
+<x number="3" url="http://factorcode.org/" string="hello" word="drop"/>""" ]
[ 3 f "http://factorcode.org/" "hello" \ drop
<XML <x number=<-> false=<-> url=<-> string=<-> word=<->/> XML>
pprint-xml>string ] unit-test
! Copyright (C) 2005, 2009 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
-USING: help.markup help.syntax xml.data sequences strings multiline ;
+USING: help.markup help.syntax xml.data sequences strings ;
IN: xml.traversal
ABOUT: "xml.traversal"
ARTICLE: { "xml.traversal" "intro" } "An example of XML processing"
"To illustrate how to use the XML library, we develop a simple Atom parser in Factor. Atom is an XML-based syndication format, like RSS. To see the full version of what we develop here, look at " { $snippet "basis/syndication" } " at the " { $snippet "atom1.0" } " word. First, we want to load a file and get a DOM tree for it."
-{ $code <" "file.xml" file>xml "> }
+{ $code """"file.xml" file>xml""" }
"No encoding descriptor is needed, because XML files contain sufficient information to auto-detect the encoding. Next, we want to extract information from the tree. To get the title, we can use the following:"
-{ $code <" "title" tag-named children>string "> }
+{ $code """"title" tag-named children>string""" }
"The " { $link tag-named } " word finds the first tag named " { $snippet "title" } " in the top level (just under the main tag). Then, with a tag on the stack, its children are asserted to be a string, and the string is returned." $nl
"For a slightly more complicated example, we can look at how entries are parsed. To get a sequence of tags with the name " { $snippet "entry" } ":"
-{ $code <" "entry" tags-named "> }
+{ $code """"entry" tags-named""" }
"Imagine that, for each of these, we want to get the URL of the entry. In Atom, the URLs are in a " { $snippet "link" } " tag which is contained in the " { $snippet "entry" } " tag. There are multiple " { $snippet "link" } " tags, but one of them contains the attribute " { $snippet "rel=alternate" } ", and the " { $snippet "href" } " attribute has the URL. So, given an element of the sequence produced in the above quotation, we run the code:"
-{ $code <" "link" tags-named [ "rel" attr "alternate" = ] find nip "> }
+{ $code """"link" tags-named [ "rel" attr "alternate" = ] find nip """ }
"to get the link tag on the stack, and"
-{ $code <" "href" attr >url "> }
+{ $code """"href" attr >url """ }
"to extract the URL from it." ;
HELP: deep-tag-named
HELP: indenter
{ $var-description "Contains the string which is used for indenting in the XML prettyprinter. For example, to print an XML document using " { $snippet "%%%%" } " for indentation, you can use the following:" }
-{ $example {" USING: xml.syntax xml.writer namespaces ;
-[XML <foo>bar</foo> XML] "%%%%" indenter [ pprint-xml ] with-variable "} {"
+{ $example """USING: xml.syntax xml.writer namespaces ;
+[XML <foo>bar</foo> XML] "%%%%" indenter [ pprint-xml ] with-variable """ """
<foo>
%%%%bar
-</foo>"} } ;
+</foo>""" } ;
HELP: sensitive-tags
{ $var-description "Contains a sequence of " { $link name } "s where whitespace should be considered significant for prettyprinting purposes. The sequence can contain " { $link string } "s in place of names. For example, to preserve whitespace inside a " { $snippet "pre" } " tag:" }
-{ $example {" USING: xml.syntax xml.writer namespaces ;
+{ $example """USING: xml.syntax xml.writer namespaces ;
[XML <html> <head> <title> something</title></head><body><pre>bing
bang
- bong</pre></body></html> XML] { "pre" } sensitive-tags [ pprint-xml ] with-variable "} {"
+ bong</pre></body></html> XML] { "pre" } sensitive-tags [ pprint-xml ] with-variable"""
+"""
<html>
<head>
<title>
bang
bong</pre>
</body>
-</html>"} } ;
+</html>""" } ;
"<?xml version=\"1.0\" encoding=\"UTF-8\"?><x/>" reprints-same
-{" <?xml version="1.0" encoding="UTF-8"?>
+"""<?xml version="1.0" encoding="UTF-8"?>
<!DOCTYPE foo [<!ENTITY foo "bar">]>
-<x>bar</x> "}
-{" <?xml version="1.0" encoding="UTF-8"?>
+<x>bar</x>"""
+"""<?xml version="1.0" encoding="UTF-8"?>
<!DOCTYPE foo [<!ENTITY foo 'bar'>]>
-<x>&foo;</x> "} reprints-as
+<x>&foo;</x>""" reprints-as
-{" <?xml version="1.0" encoding="UTF-8"?>
+"""<?xml version="1.0" encoding="UTF-8"?>
<!DOCTYPE foo [
<!ENTITY foo "bar">
<!ELEMENT br EMPTY>
]>
<x>
bar
-</x>"}
-{" <?xml version="1.0" encoding="UTF-8"?>
+</x>"""
+"""<?xml version="1.0" encoding="UTF-8"?>
<!DOCTYPE foo [ <!ENTITY foo 'bar'> <!ELEMENT br EMPTY>
<!ATTLIST list
type (bullets|ordered|glossary) "ordered">
<!NOTATION foo bar> <?baz bing bang bong?>
<!--wtf-->
]>
-<x>&foo;</x>"} pprint-reprints-as
+<x>&foo;</x>""" pprint-reprints-as
[ t ] [ "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.1//EN\" \"http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd\" >" dup string>xml-chunk xml>string = ] unit-test
[ "<?xml version=\"1.0\" encoding=\"UTF-8\"?><a b=\"c\"/>" ]
[XML <tr><td><-></td><td><-></td></tr> XML]
] map [XML <h2>Timings</h2> <table><-></table> XML]
pprint-xml
-] unit-test
\ No newline at end of file
+] unit-test
[ ] [ \ (load-mode) reset-memoized ] unit-test
[ ] [
- <" <style type="text/css" media="screen" >
- * {margin:0; padding:0; border:0;} ">
+ """<style type="text/css" media="screen" >
+ * {margin:0; padding:0; border:0;}"""
string-lines "html" htmlize-lines drop
] unit-test
[ ] [
"test.c"
- <" int x = "hi";
-/* a comment */ "> <string-reader> htmlize-stream
+ """int x = "hi";
+/* a comment */""" <string-reader> htmlize-stream
write-xml
] unit-test
[ ":foo" ] [
{ ":foo" } "factor" htmlize-lines xml>string
-] unit-test
\ No newline at end of file
+] unit-test
ARTICLE: "alien-callback" "Calling Factor from C"
"Callbacks can be defined and passed to C code as function pointers; the C code can then invoke the callback and run Factor code:"
{ $subsection alien-callback }
+{ $subsection POSTPONE: CALLBACK: }
+{ $subsection POSTPONE: STDCALL-CALLBACK: }
"There are some caveats concerning the conversion of Factor objects to C values, and vice versa. See " { $link "c-data" } "."
{ $subsection "alien-callback-gc" }
{ $see-also "byte-arrays-gc" } ;
-USING: alien.strings alien.c-types tools.test kernel libc
+USING: alien.strings alien.c-types alien.data tools.test kernel libc
io.encodings.8-bit io.encodings.utf8 io.encodings.utf16
io.encodings.utf16n io.encodings.ascii alien io.encodings.string ;
IN: alien.strings.tests
"words"
"vectors"
"vectors.private"
+ "vm"
} [ create-vocab drop ] each
! Builtin classes
{ "inline-cache-stats" "generic.single" (( -- stats )) }
{ "optimized?" "words" (( word -- ? )) }
{ "quot-compiled?" "quotations" (( quot -- ? )) }
+ { "vm-ptr" "vm" (( -- ptr )) }
} [ [ first3 ] dip swap make-primitive ] each-index
! Bump build number
"bootstrap.layouts" require
[
- "vocab:bootstrap/stage2.factor"
+ "resource:basis/bootstrap/stage2.factor"
dup exists? [
run-file
] [
{ $subsection class-and }\r
{ $subsection class-or }\r
{ $subsection classes-intersect? }\r
-{ $subsection min-class }\r
"Low-level implementation detail:"\r
{ $subsection flatten-class }\r
{ $subsection flatten-builtin-class }\r
"Operations:"\r
{ $subsection class< }\r
{ $subsection sort-classes }\r
+{ $subsection smallest-class }\r
"Metaclass order:"\r
{ $subsection rank-class } ;\r
\r
{ $values { "first" class } { "second" class } { "?" "a boolean" } }\r
{ $description "Tests if two classes have a non-empty intersection. If the intersection is empty, no object can be an instance of both classes at once." } ;\r
\r
-HELP: min-class\r
-{ $values { "class" class } { "seq" "a sequence of class words" } { "class/f" "a class word or " { $link f } } }\r
-{ $description "If all classes in " { $snippet "seq" } " that intersect " { $snippet "class" } " are subtypes of " { $snippet "class" } ", outputs the last such element of " { $snippet "seq" } ". If any conditions fail to hold, outputs " { $link f } "." } ;\r
+HELP: smallest-class\r
+{ $values { "classes" "a sequence of class words" } { "class/f" { $maybe class } } }\r
+{ $description "Outputs a minimum class from the given sequence." } ;\r
classes.private classes.union classes.mixin classes.predicate\r
vectors source-files compiler.units growable random\r
stack-checker effects kernel.private sbufs math.order\r
-classes.tuple accessors ;\r
+classes.tuple accessors generic.private ;\r
IN: classes.algebra.tests\r
\r
: class-and* ( cls1 cls2 cls3 -- ? ) [ class-and ] dip class= ;\r
] unit-test\r
\r
! Test method inlining\r
+[ real ] [ { real sequence } smallest-class ] unit-test\r
+[ real ] [ { sequence real } smallest-class ] unit-test\r
+\r
+: min-class ( class classes -- class/f )\r
+ interesting-classes smallest-class ;\r
+\r
[ f ] [ fixnum { } min-class ] unit-test\r
\r
[ string ] [\r
[ dup largest-class [ over delete-nth ] dip ]\r
produce nip ;\r
\r
-: min-class ( class seq -- class/f )\r
- over [ classes-intersect? ] curry filter\r
- [ drop f ] [\r
- [ nip ] [ [ class<= ] with all? ] 2bi [ last ] [ drop f ] if\r
+: smallest-class ( classes -- class/f )\r
+ [ f ] [\r
+ natural-sort <reversed>\r
+ [ ] [ [ class<= ] most ] map-reduce\r
] if-empty ;\r
\r
GENERIC: (flatten-class) ( class -- )\r
! So the user has some code...
[ ] [
- <" IN: classes.test.a
+ """IN: classes.test.a
GENERIC: g ( a -- b )
TUPLE: x ;
M: x g ;
- TUPLE: z < x ;"> <string-reader>
+ TUPLE: z < x ;""" <string-reader>
"class-intersect-no-method-a" parse-stream drop
] unit-test
! Note that q inlines M: x g ;
[ ] [
- <" IN: classes.test.b
+ """IN: classes.test.b
USE: classes.test.a
USE: kernel
- : q ( -- b ) z new g ;"> <string-reader>
+ : q ( -- b ) z new g ;""" <string-reader>
"class-intersect-no-method-b" parse-stream drop
] unit-test
! Now, the user removes the z class and adds a method,
[ ] [
- <" IN: classes.test.a
+ """IN: classes.test.a
GENERIC: g ( a -- b )
TUPLE: x ;
M: x g ;
TUPLE: j ;
- M: j g ;"> <string-reader>
+ M: j g ;""" <string-reader>
"class-intersect-no-method-a" parse-stream drop
] unit-test
! And changes the definition of q
[ ] [
- <" IN: classes.test.b
+ """IN: classes.test.b
USE: classes.test.a
USE: kernel
- : q ( -- b ) j new g ;"> <string-reader>
+ : q ( -- b ) j new g ;""" <string-reader>
"class-intersect-no-method-b" parse-stream drop
] unit-test
! Similar problem, but with anonymous classes
[ ] [
- <" IN: classes.test.c
+ """IN: classes.test.c
USE: kernel
GENERIC: g ( a -- b )
M: object g ;
- TUPLE: z ;"> <string-reader>
+ TUPLE: z ;""" <string-reader>
"class-intersect-no-method-c" parse-stream drop
] unit-test
[ ] [
- <" IN: classes.test.d
+ """IN: classes.test.d
USE: classes.test.c
USE: kernel
- : q ( a -- b ) dup z? [ g ] unless ;"> <string-reader>
+ : q ( a -- b ) dup z? [ g ] unless ;""" <string-reader>
"class-intersect-no-method-d" parse-stream drop
] unit-test
! Now, the user removes the z class and adds a method,
[ ] [
- <" IN: classes.test.c
+ """IN: classes.test.c
USE: kernel
GENERIC: g ( a -- b )
M: object g ;
TUPLE: j ;
- M: j g ;"> <string-reader>
+ M: j g ;""" <string-reader>
"class-intersect-no-method-c" parse-stream drop
] unit-test
M: tuple-class boa>object
swap prefix >tuple ;
+ERROR: bad-slot-name class slot ;
+
+: check-slot-exists ( class initials slot-spec/f index/f name -- class initials slot-spec index )
+ over [ drop ] [ nip nip nip bad-slot-name ] if ;
+
+: slot-named-checked ( class initials name slots -- class initials slot-spec )
+ over [ slot-named* ] dip check-slot-exists drop ;
+
: assoc>object ( class slots values -- tuple )
[ [ [ initial>> ] map ] keep ] dip
- swap [ [ slot-named* drop ] curry dip ] curry assoc-map
+ swap [ [ slot-named-checked ] curry dip ] curry assoc-map
[ dup <enum> ] dip update boa>object ;
: parse-tuple-literal-slots ( class slots -- tuple )
} ;
ARTICLE: "spread-combinators" "Spread combinators"
-"The spread combinators apply multiple quotations to multiple values. The " { $snippet "*" } " suffix signifies spreading."
+"The spread combinators apply multiple quotations to multiple values. In this case, " { $snippet "*" } " suffix signify spreading."
$nl
"Two quotations:"
{ $subsections bi* 2bi* }
-USING: accessors alien arrays definitions generic generic.standard
-generic.math assocs hashtables io kernel math namespaces parser
-prettyprint sequences strings tools.test vectors words
-quotations classes classes.algebra classes.tuple continuations
-layouts classes.union sorting compiler.units eval multiline
-io.streams.string ;
+USING: accessors alien arrays assocs classes classes.algebra
+classes.tuple classes.union compiler.units continuations
+definitions eval generic generic.math generic.standard
+hashtables io io.streams.string kernel layouts math math.order
+namespaces parser prettyprint quotations sequences sorting
+strings tools.test vectors words ;
IN: generic.tests
GENERIC: foobar ( x -- y )
! erg's regression
[ ] [
- <"
- IN: compiler.tests
+ """IN: compiler.tests
GENERIC: jeah ( a -- b )
TUPLE: boii ;
M: boii jeah ;
GENERIC: jeah* ( a -- b )
- M: boii jeah* jeah ;
- "> eval( -- )
+ M: boii jeah* jeah ;""" eval( -- )
- <"
- IN: compiler.tests
- FORGET: boii
- "> eval( -- )
+ """IN: compiler.tests
+ FORGET: boii""" eval( -- )
- <"
- IN: compiler.tests
+ """IN: compiler.tests
TUPLE: boii ;
- M: boii jeah ;
- "> eval( -- )
+ M: boii jeah ;""" eval( -- )
] unit-test
! call-next-method cache test
[ ] [ "IN: generic.tests.a" <string-reader> "move-method-test-1" parse-stream drop ] unit-test
[ { string } ] [ \ move-method-generic order ] unit-test
+
+GENERIC: foozul ( a -- b )
+M: reversed foozul ;
+M: integer foozul ;
+M: slice foozul ;
+
+[ t ] [
+ reversed \ foozul method-for-class
+ reversed \ foozul method
+ eq?
+] unit-test
+
+[ t ] [
+ fixnum \ <=> method-for-class
+ real \ <=> method
+ eq?
+] unit-test
: method ( class generic -- method/f )
"methods" word-prop at ;
+<PRIVATE
+
+: interesting-class? ( class1 class2 -- ? )
+ {
+ ! Case 1: no intersection. Discard and keep going
+ { [ 2dup classes-intersect? not ] [ 2drop t ] }
+ ! Case 2: class1 contained in class2. Add to
+ ! interesting set and keep going.
+ { [ 2dup class<= ] [ nip , t ] }
+ ! Case 3: class1 and class2 are incomparable. Give up
+ [ 2drop f ]
+ } cond ;
+
+: interesting-classes ( class classes -- interesting/f )
+ [ [ interesting-class? ] with all? ] { } make and ;
+
+PRIVATE>
+
+: method-classes ( generic -- classes )
+ "methods" word-prop keys ;
+
: order ( generic -- seq )
- "methods" word-prop keys sort-classes ;
+ method-classes sort-classes ;
+
+: nearest-class ( class generic -- class/f )
+ method-classes interesting-classes smallest-class ;
-: specific-method ( class generic -- method/f )
- [ nip ] [ order min-class ] 2bi
- dup [ swap method ] [ 2drop f ] if ;
+: method-for-class ( class generic -- method/f )
+ [ nip ] [ nearest-class ] 2bi dup [ swap method ] [ 2drop f ] if ;
GENERIC: effective-method ( generic -- method )
\ effective-method t "no-compile" set-word-prop
: next-method-class ( class generic -- class/f )
- order [ class<= ] with filter reverse dup length 1 =
- [ drop f ] [ second ] if ;
+ method-classes [ class< ] with filter smallest-class ;
: next-method ( class generic -- method/f )
[ next-method-class ] keep method ;
M: hook-generic definer drop \ HOOK: f ;
M: hook-generic effective-method
- [ "combination" word-prop var>> get ] keep (effective-method) ;
\ No newline at end of file
+ [ "combination" word-prop var>> get ] keep method-for-object ;
\ No newline at end of file
<PRIVATE
-: applicable-method ( generic class -- quot )
+: (math-method) ( generic class -- quot )
over method
[ 1quotation ]
[ default-math-method ] ?if ;
PRIVATE>
: object-method ( generic -- quot )
- object bootstrap-word applicable-method ;
+ object bootstrap-word (math-method) ;
: math-method ( word class1 class2 -- quot )
2dup and [
[ 2array [ declare ] curry nip ]
[ math-upgrade nip ]
- [ math-class-max over order min-class applicable-method ]
+ [ math-class-max over nearest-class (math-method) ]
3tri 3append
] [
2drop object-method
] [ 3drop f ] if
] with-combination ;
-: (effective-method) ( obj word -- method )
- [ [ order [ instance? ] with find-last nip ] keep method ]
+: method-for-object ( obj word -- method )
+ [ [ method-classes [ instance? ] with filter smallest-class ] keep method ]
[ "default-method" word-prop ]
bi or ;
M: standard-generic effective-method
[ datastack ] dip [ "combination" word-prop #>> swap <reversed> nth ] keep
- (effective-method) ;
+ method-for-object ;
: inline-cache-quot ( word methods miss-word -- quot )
[ [ literalize , ] [ , ] [ combination get #>> , { } , , ] tri* ] [ ] make ;
{ $description "Converts a byte-array, interpreted as little-endian, into a bignum integer. User code should call " { $link le> } " or " { $link be> } " instead." } ;
ARTICLE: "division-by-zero" "Division by zero"
-"Floating point division never raises an error if the denominator is zero. This means that if at least one of the two inputs to " { $link / } ", " { $link /f } " or " { $link mod } " is a float, the result will be a floating point infinity or not a number value."
+"Behavior of division operations when a denominator of zero is used depends on the data types in question, as well as the platform being used."
+$nl
+"Floating point division only throws an error if the appropriate traps are enabled in the floating point environment. If traps are disabled, a Not-a-number value or an infinity is output, depending on whether the numerator is zero or non-zero."
+$nl
+"Floating point traps are disabled by default and the " { $vocab-link "math.floats.env" } " vocabulary provides words to enable them. Floating point division is performed by " { $link / } ", " { $link /f } " or " { $link mod } " if at least one of the two inputs is a float. Floating point division is always performed by " { $link /f } "."
$nl
"The behavior of integer division is hardware specific. On x86 processors, " { $link /i } " and " { $link mod } " raise an error if both inputs are integers and the denominator is zero. On PowerPC, integer division by zero yields a result of zero."
$nl
-"On the other hand, the " { $link / } " word, when given integer arguments, implements a much more expensive division algorithm which always yields an exact rational answer, and this word always tests for division by zero explicitly." ;
+"The " { $link / } " word, when given integer arguments, implements a much more expensive division algorithm which always yields an exact rational answer, and this word always tests for division by zero explicitly." ;
ARTICLE: "number-protocol" "Number protocol"
"Math operations obey certain numerical upgrade rules. If one of the inputs is a bignum and the other is a fixnum, the latter is first coerced to a bignum; if one of the inputs is a float, the other is coerced to a float."
{ $subsection > }
{ $subsection >= }
"Numbers can be compared for equality using " { $link = } ", or a less precise test which disregards types:"
-{ $subsection number= } ;
+{ $subsection number= }
+{ $see-also "math.floats.compare" } ;
ARTICLE: "modular-arithmetic" "Modular arithmetic"
{ $subsection mod }
$nl
"Outputs " { $link f } " if the string does not represent a number." } ;
-{ bin> POSTPONE: BIN: bin> .b } related-words
+{ >bin POSTPONE: BIN: bin> .b } related-words
HELP: oct>
{ $values { "str" string } { "n/f" "a real number or " { $link f } } }
$nl
"Outputs " { $link f } " if the string does not represent a number." } ;
-{ oct> POSTPONE: OCT: oct> .o } related-words
+{ >oct POSTPONE: OCT: oct> .o } related-words
HELP: hex>
{ $values { "str" string } { "n/f" "a real number or " { $link f } } }
$nl
"Outputs " { $link f } " if the string does not represent a number." } ;
-{ hex> POSTPONE: HEX: hex> .h } related-words
+{ >hex POSTPONE: HEX: hex> .h } related-words
HELP: >base
{ $values { "n" real } { "radix" "an integer between 2 and 36" } { "str" string } }
[ "1.0p0" ] [ 1.0 >hex ] unit-test
[ "1.8p2" ] [ 6.0 >hex ] unit-test
+[ "1.08p2" ] [ 4.125 >hex ] unit-test
[ "1.8p-2" ] [ 0.375 >hex ] unit-test
[ "-1.8p2" ] [ -6.0 >hex ] unit-test
[ "1.8p10" ] [ 1536.0 >hex ] unit-test
[ "-0.0" ] [ -0.0 >hex ] unit-test
[ 1.0 ] [ "1.0" hex> ] unit-test
+[ 1.5 ] [ "1.8" hex> ] unit-test
+[ 1.03125 ] [ "1.08" hex> ] unit-test
[ 15.5 ] [ "f.8" hex> ] unit-test
[ 15.53125 ] [ "f.88" hex> ] unit-test
[ -15.5 ] [ "-f.8" hex> ] unit-test
-0.0 double>bits bitand zero? "" "-" ? ;
: float>hex-value ( mantissa -- str )
- 16 >base [ CHAR: 0 = ] trim-tail [ "0" ] [ ] if-empty "1." prepend ;
+ 16 >base 13 CHAR: 0 pad-head [ CHAR: 0 = ] trim-tail
+ [ "0" ] [ ] if-empty "1." prepend ;
: float>hex-expt ( mantissa -- str )
10 >base "p" prepend ;
+USING: accessors eval strings.parser strings.parser.private
+tools.test ;
IN: strings.parser.tests
-USING: strings.parser tools.test ;
[ "Hello\n\rworld" ] [ "Hello\\n\\rworld" unescape-string ] unit-test
+
+[ "Hello\n\rworld" ] [ "Hello\n\rworld" ] unit-test
+[ "Hello\n\rworld" ] [ """Hello\n\rworld""" ] unit-test
+[ "Hello\n\rworld\n" ] [ "Hello\n\rworld
+" ] unit-test
+[ "Hello\n\rworld" "hi" ] [ "Hello\n\rworld" "hi" ] unit-test
+[ "Hello\n\rworld" "hi" ] [ """Hello\n\rworld""" """hi""" ] unit-test
+[ "Hello\n\rworld\n" "hi" ] [ """Hello\n\rworld
+""" """hi""" ] unit-test
+[ "Hello\n\rworld\"" "hi" ] [ """Hello\n\rworld\"""" """hi""" ] unit-test
+
+[
+ "\"\"\"Hello\n\rworld\\\n\"\"\"" eval( -- obj )
+] [
+ error>> escaped-char-expected?
+] must-fail-with
+
+[
+ " \" abc \" "
+] [
+ "\"\"\" \" abc \" \"\"\"" eval( -- string )
+] unit-test
+
+[
+ "\"abc\""
+] [
+ "\"\"\"\"abc\"\"\"\"" eval( -- string )
+] unit-test
+
+
+[ "\"\\" ] [ "\"\\" ] unit-test
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel assocs namespaces make splitting sequences
-strings math.parser lexer accessors ;
+USING: accessors assocs kernel lexer make math math.parser
+namespaces parser sequences splitting strings arrays
+math.order ;
IN: strings.parser
-ERROR: bad-escape ;
+ERROR: bad-escape char ;
: escape ( escape -- ch )
H{
{ CHAR: 0 CHAR: \0 }
{ CHAR: \\ CHAR: \\ }
{ CHAR: \" CHAR: \" }
- } at [ bad-escape ] unless* ;
+ } ?at [ bad-escape ] unless ;
SYMBOL: name>char-hook
unclip-slice escape swap
] if ;
+: (unescape-string) ( str -- )
+ CHAR: \\ over index dup [
+ cut-slice [ % ] dip rest-slice
+ next-escape [ , ] dip
+ (unescape-string)
+ ] [
+ drop %
+ ] if ;
+
+: unescape-string ( str -- str' )
+ [ (unescape-string) ] "" make ;
+
: (parse-string) ( str -- m )
dup [ "\"\\" member? ] find dup [
[ cut-slice [ % ] dip rest-slice ] dip
[ swap tail-slice (parse-string) ] "" make swap
] change-lexer-column ;
-: (unescape-string) ( str -- )
- CHAR: \\ over index dup [
- cut-slice [ % ] dip rest-slice
- next-escape [ , ] dip
- (unescape-string)
+<PRIVATE
+
+: lexer-before ( i -- before )
+ [
+ [
+ lexer get
+ [ column>> ] [ line-text>> ] bi
+ ] dip swap subseq
] [
- drop %
+ lexer get (>>column)
+ ] bi ;
+
+: find-next-token ( ch -- i elt )
+ CHAR: \ 2array
+ [ lexer get [ column>> ] [ line-text>> ] bi ] dip
+ [ member? ] curry find-from ;
+
+: rest-of-line ( lexer -- seq )
+ [ line-text>> ] [ column>> ] bi tail-slice ;
+
+: current-char ( lexer -- ch/f )
+ [ column>> ] [ line-text>> ] bi ?nth ;
+
+: advance-char ( lexer -- )
+ [ 1 + ] change-column drop ;
+
+ERROR: escaped-char-expected ;
+
+: next-char ( lexer -- ch )
+ dup still-parsing-line? [
+ [ current-char ] [ advance-char ] bi
+ ] [
+ escaped-char-expected
] if ;
-: unescape-string ( str -- str' )
- [ (unescape-string) ] "" make ;
+: next-line% ( lexer -- )
+ [ rest-of-line % ]
+ [ next-line "\n" % ] bi ;
+
+: rest-begins? ( string -- ? )
+ [
+ lexer get [ line-text>> ] [ column>> ] bi tail-slice
+ ] dip head? ;
+
+: advance-lexer ( n -- )
+ [ lexer get ] dip [ + ] curry change-column drop ; inline
+
+: take-double-quotes ( -- string )
+ lexer get dup current-char CHAR: " = [
+ [ ] [ column>> ] [ line-text>> ] tri
+ [ CHAR: " = not ] find-from drop [
+ swap column>> - CHAR: " <repetition>
+ ] [
+ rest-of-line
+ ] if*
+ ] [
+ drop f
+ ] if dup length advance-lexer ;
+
+: end-string-parse ( delimiter -- )
+ length 3 = [
+ take-double-quotes 3 tail %
+ ] [
+ lexer get advance-char
+ ] if ;
+
+DEFER: (parse-long-string)
+
+: parse-found-token ( i string token -- )
+ [ lexer-before % ] dip
+ CHAR: \ = [
+ lexer get [ next-char , ] [ next-char , ] bi (parse-long-string)
+ ] [
+ dup rest-begins? [
+ end-string-parse
+ ] [
+ lexer get next-char , (parse-long-string)
+ ] if
+ ] if ;
+
+ERROR: trailing-characters string ;
+
+: (parse-long-string) ( string -- )
+ lexer get still-parsing? [
+ dup first find-next-token [
+ parse-found-token
+ ] [
+ drop lexer get next-line%
+ (parse-long-string)
+ ] if*
+ ] [
+ unexpected-eof
+ ] if ;
+
+PRIVATE>
+
+: parse-long-string ( string -- string' )
+ [ (parse-long-string) ] "" make ;
+
+: parse-multiline-string ( -- string )
+ lexer get rest-of-line "\"\"" head? [
+ lexer get [ 2 + ] change-column drop
+ "\"\"\""
+ ] [
+ "\""
+ ] if parse-long-string unescape-string ;
M: string equal?
over string? [
- over hashcode over hashcode eq?
+ 2dup [ hashcode ] bi@ eq?
[ sequence= ] [ 2drop f ] if
] [
2drop f
} ;
HELP: "
-{ $syntax "\"string...\"" }
+{ $syntax "\"string...\"" "\"\"\"string...\"\"\"" }
{ $values { "string" "literal and escaped characters" } }
-{ $description "Reads from the input string until the next occurrence of " { $link POSTPONE: " } ", and appends the resulting string to the parse tree. String literals cannot span multiple lines. Strings containing the " { $link POSTPONE: " } " character and various other special characters can be read by inserting " { $link "escape" } "." }
+{ $description "Reads from the input string until the next occurrence of " { $snippet "\"" } " or " { $snippet "\"\"\"" } ", and appends the resulting string to the parse tree. String literals can span multiple lines. Various special characters can be read by inserting " { $link "escape" } ". For triple quoted strings, the double-quote character does not require escaping." }
{ $examples
- "A string with a newline in it:"
- { $example "USE: io" "\"Hello\\nworld\" print" "Hello\nworld" }
- "A string with a named Unicode code point:"
- { $example "USE: io" "\"\\u{greek-capital-letter-sigma}\" print" "\u{greek-capital-letter-sigma}" }
+ "A string with an escaped newline in it:"
+ { $example "USE: io" "\"Hello\\nworld\" print" "Hello\nworld" }
+ "A string with an actual newline in it:"
+ { $example "USE: io" "\"Hello\nworld\" print" "Hello\nworld" }
+ "A string with a named Unicode code point:"
+ { $example "USE: io" "\"\\u{greek-capital-letter-sigma}\" print" "\u{greek-capital-letter-sigma}" }
+ "A triple-quoted string:"
+ { $example "USE: io \"\"\"Teach a man to \"fish\"...\nand fish will go extinct\"\"\" print" """Teach a man to \"fish\"...
+and fish will go extinct""" }
} ;
HELP: SBUF"
{ $description "Discards all input until the end of the line." } ;
HELP: HEX:
-{ $syntax "HEX: integer" }
-{ $values { "integer" "hexadecimal digits (0-9, a-f, A-F)" } }
-{ $description "Adds an integer read from a hexadecimal literal to the parse tree." }
-{ $examples { $example "USE: prettyprint" "HEX: ff ." "255" } } ;
+{ $syntax "HEX: NNN" "HEX: NNN.NNNpEEE" }
+{ $values { "N" "hexadecimal digit (0-9, a-f, A-F)" } { "pEEE" "decimal exponent value" } }
+{ $description "Adds an integer or floating-point value read from a hexadecimal literal to the parse tree." }
+{ $examples
+ { $example "USE: prettyprint" "HEX: ff ." "255" }
+ { $example "USE: prettyprint" "HEX: 1.8p5 ." "48.0" }
+} ;
HELP: OCT:
{ $syntax "OCT: integer" }
} cond parsed
] define-core-syntax
- "\"" [ parse-string parsed ] define-core-syntax
+ "\"" [ parse-multiline-string parsed ] define-core-syntax
"SBUF\"" [
lexer get skip-blank parse-string >sbuf parsed
! Copyright (C) 2008 Jean-François Bigot.
! See http://factorcode.org/license.txt for BSD license.
-USING: help.markup help.syntax kernel quotations strings multiline ;
+USING: help.markup help.syntax kernel quotations strings ;
IN: 4DNav
$nl
"An example is:"
-{ $code <"
+{ $code """
<model>
<space>
<dimension>4</dimension>
</light>
<color>0.8,0.9,0.9</color>
</space>
-</model> "> } ;
+</model>""" } ;
ARTICLE: "TODO" "Todo"
{ $list
! Copyright (C) 2008 Jeff Bigot\r
! See http://factorcode.org/license.txt for BSD license.\r
-USING: help.markup help.syntax multiline ;\r
+USING: help.markup help.syntax ;\r
IN: adsoda\r
\r
! --------------------------------------------------------------\r
;\r
\r
ARTICLE: { "adsoda" "light" } "ADSODA : lights"\r
-{ $code <"\r
+{ $code """\r
! HELP: light position color\r
! <light> ( -- tuple ) light new ;\r
! light est un vecteur avec 3 variables pour les couleurs\n\r
if (cRed > 1.0) cRed = 1.0;\r
if (cGreen > 1.0) cGreen = 1.0;\r
if (cBlue > 1.0) cBlue = 1.0;\r
-"> }\r
+""" }\r
;\r
\r
\r
[ current-vocab name>> % "_" % % ] "" make ;
PRIVATE>
+: parse-arglist ( parameters return -- types effect )
+ [ 2 group unzip [ "," ?tail drop ] map ]
+ [ [ { } ] [ 1array ] if-void ]
+ bi* <effect> ;
+
: append-function-body ( prototype-str body -- str )
[ swap % " {\n" % % "\n}\n" % ] "" make ;
! Copyright (C) 2009 Jeremy Hughes.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.inline alien.inline.syntax io.directories io.files
-kernel namespaces tools.test alien.c-types alien.structs ;
+kernel namespaces tools.test alien.c-types alien.data alien.structs ;
IN: alien.inline.syntax.tests
DELETE-C-LIBRARY: test
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien.c-types assocs combinators.short-circuit
continuations effects fry kernel math memoize sequences
-splitting strings peg.ebnf make ;
+splitting strings peg.ebnf make words ;
IN: alien.inline.types
: cify-type ( str -- str' )
+ dup word? [ name>> ] when
{ { CHAR: - CHAR: space } } substitute ;
: factorize-type ( str -- str' )
! Copyright (C) 2009 Jeremy Hughes.
! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax kernel quotations sequences
-strings alien alien.c-types math byte-arrays ;
+strings alien alien.c-types alien.data math byte-arrays ;
IN: alien.marshall
<PRIVATE
USING: accessors alien alien.c-types alien.inline.types
alien.marshall.private alien.strings byte-arrays classes
combinators combinators.short-circuit destructors fry
-io.encodings.utf8 kernel libc sequences
+io.encodings.utf8 kernel libc sequences alien.data
specialized-arrays strings unix.utilities vocabs.parser
words libc.private locals generalizations math ;
+FROM: alien.c-types => float short ;
SPECIALIZED-ARRAY: bool
SPECIALIZED-ARRAY: char
SPECIALIZED-ARRAY: double
SPECIALIZED-ARRAY: void*
IN: alien.marshall
-<< primitive-types [ [ "void*" = ] [ "bool" = ] bi or not ]
+<< primitive-types [ [ void* = ] [ bool = ] bi or not ]
filter [ define-primitive-marshallers ] each >>
TUPLE: alien-wrapper { underlying alien } ;
USING: accessors alien alien.c-types alien.inline arrays
combinators fry functors kernel lexer libc macros math
sequences specialized-arrays libc.private
-combinators.short-circuit ;
+combinators.short-circuit alien.data ;
SPECIALIZED-ARRAY: void*
IN: alien.marshall.private
USING: accessors alien.c-types alien.marshall arrays assocs
classes.tuple combinators destructors generalizations generic
kernel libc locals parser quotations sequences slots words
-alien.structs lexer vocabs.parser fry effects ;
+alien.structs lexer vocabs.parser fry effects alien.data ;
IN: alien.marshall.structs
<PRIVATE
USING: alien.c-types alien.syntax audio combinators
combinators.short-circuit io io.binary io.encodings.binary
io.files io.streams.byte-array kernel locals math
-sequences ;
+sequences alien alien.data classes.struct accessors ;
IN: audio.wav
CONSTANT: RIFF-MAGIC "RIFF"
CONSTANT: FMT-MAGIC "fmt "
CONSTANT: DATA-MAGIC "data"
-C-STRUCT: riff-chunk-header
- { "char[4]" "id" }
- { "uchar[4]" "size" }
- ;
+STRUCT: riff-chunk-header
+ { id char[4] }
+ { size char[4] } ;
-C-STRUCT: riff-chunk
- { "riff-chunk-header" "header" }
- { "char[4]" "format" }
- ;
+STRUCT: riff-chunk
+ { header riff-chunk-header }
+ { format char[4] } ;
-C-STRUCT: wav-fmt-chunk
- { "riff-chunk-header" "header" }
- { "uchar[2]" "audio-format" }
- { "uchar[2]" "num-channels" }
- { "uchar[4]" "sample-rate" }
- { "uchar[4]" "byte-rate" }
- { "uchar[2]" "block-align" }
- { "uchar[2]" "bits-per-sample" }
- ;
+STRUCT: wav-fmt-chunk
+ { header riff-chunk-header }
+ { audio-format uchar[2] }
+ { num-channels uchar[2] }
+ { sample-rate uchar[4] }
+ { byte-rate uchar[4] }
+ { block-align uchar[2] }
+ { bits-per-sample uchar[2] } ;
-C-STRUCT: wav-data-chunk
- { "riff-chunk-header" "header" }
- { "uchar[0]" "body" }
- ;
+STRUCT: wav-data-chunk
+ { header riff-chunk-header }
+ { body uchar[0] } ;
ERROR: invalid-wav-file ;
: read-chunk ( -- byte-array/f )
4 ensured-read [ 4 ensured-read* dup le> ensured-read* 3append ] [ f ] if* ;
: read-riff-chunk ( -- byte-array/f )
- "riff-chunk" heap-size ensured-read* ;
+ riff-chunk heap-size ensured-read* ;
: id= ( chunk id -- ? )
- [ 4 head ] dip sequence= ;
+ [ 4 head ] dip sequence= ; inline
-: check-chunk ( chunk id min-size -- ? )
- [ id= ] [ [ length ] dip >= ] bi-curry* bi and ;
+: check-chunk ( chunk id class -- ? )
+ heap-size [ id= ] [ [ length ] dip >= ] bi-curry* bi and ;
:: read-wav-chunks ( -- fmt data )
f :> fmt! f :> data!
[ { [ fmt data and not ] [ read-chunk ] } 0&& dup ]
[ {
- { [ dup FMT-MAGIC "wav-fmt-chunk" heap-size check-chunk ] [ fmt! ] }
- { [ dup DATA-MAGIC "wav-data-chunk" heap-size check-chunk ] [ data! ] }
+ { [ dup FMT-MAGIC wav-fmt-chunk check-chunk ] [ wav-fmt-chunk memory>struct fmt! ] }
+ { [ dup DATA-MAGIC wav-data-chunk check-chunk ] [ wav-data-chunk memory>struct data! ] }
} cond ] while drop
fmt data 2dup and [ invalid-wav-file ] unless ;
: verify-wav ( chunk -- )
{
[ RIFF-MAGIC id= ]
- [ riff-chunk-format 4 memory>byte-array WAVE-MAGIC id= ]
+ [ riff-chunk memory>struct format>> 4 memory>byte-array WAVE-MAGIC id= ]
} 1&&
[ invalid-wav-file ] unless ;
: (read-wav) ( -- audio )
read-wav-chunks
[
- [ wav-fmt-chunk-num-channels 2 memory>byte-array le> ]
- [ wav-fmt-chunk-bits-per-sample 2 memory>byte-array le> ]
- [ wav-fmt-chunk-sample-rate 4 memory>byte-array le> ] tri
+ [ num-channels>> 2 memory>byte-array le> ]
+ [ bits-per-sample>> 2 memory>byte-array le> ]
+ [ sample-rate>> 4 memory>byte-array le> ] tri
] [
- [ riff-chunk-header-size 4 memory>byte-array le> dup ]
- [ wav-data-chunk-body ] bi swap memory>byte-array
+ [ header>> size>> 4 memory>byte-array le> dup ]
+ [ body>> >c-ptr ] bi swap memory>byte-array
] bi* <audio> ;
: read-wav ( filename -- audio )
math.functions math.vectors math.vectors.simd prettyprint
combinators.smart sequences hints classes.struct
specialized-arrays ;
+SIMD: double
IN: benchmark.nbody-simd
: solar-mass ( -- x ) 4 pi sq * ; inline
io.encodings.binary kernel math math.constants math.functions
math.vectors math.vectors.simd math.parser make sequences
sequences.private words hints classes.struct ;
+SIMD: double
IN: benchmark.raytracer-simd
! parameters
! See http://factorcode.org/license.txt for BSD license.
USING: kernel io math math.functions math.parser math.vectors
math.vectors.simd sequences specialized-arrays ;
+SIMD: float
SPECIALIZED-ARRAY: float-4
IN: benchmark.simd-1
] [
number-of-requests
[ read1 write1 flush ] times
- counter get count-down
] if
] with-stream
] curry "Client handler" spawn drop server-loop ;
: clients ( n -- )
dup pprint " clients: " write [
<promise> port-promise set
- dup 2 * <count-down> counter set
+ dup <count-down> counter set
[ simple-server ] "Simple server" spawn drop
yield yield
[ [ simple-client ] "Simple client" spawn drop ] times
! Factor port of
! http://shootout.alioth.debian.org/gp4/benchmark.php?test=spectralnorm&lang=all
USING: specialized-arrays kernel math math.functions
-math.vectors sequences sequences.private prettyprint words hints
-locals ;
+math.vectors sequences prettyprint words hints locals ;
SPECIALIZED-ARRAY: double
IN: benchmark.spectral-norm
+ 1 + recip ; inline
: (eval-A-times-u) ( u i j -- x )
- tuck [ swap nth-unsafe ] [ eval-A ] 2bi* * ; inline
+ [ swap nth ] [ eval-A ] bi-curry bi* * ; inline
: eval-A-times-u ( n u -- seq )
[ (eval-A-times-u) ] inner-loop ; inline
: (eval-At-times-u) ( u i j -- x )
- tuck [ swap nth-unsafe ] [ swap eval-A ] 2bi* * ; inline
+ [ swap nth ] [ swap eval-A ] bi-curry bi* * ; inline
: eval-At-times-u ( u n -- seq )
[ (eval-At-times-u) ] inner-loop ; inline
! See http://factorcode.org/license.txt for BSD license.
USING: alien.accessors alien.c-types alien.syntax byte-arrays
destructors generalizations hints kernel libc locals math math.order
-sequences sequences.private classes.struct accessors ;
+sequences sequences.private classes.struct accessors alien.data ;
IN: benchmark.yuv-to-rgb
STRUCT: yuv_buffer
! See http://factorcode.org/license.txt for BSD license
USING: brainfuck kernel io.streams.string math math.parser math.ranges
-multiline quotations sequences tools.test ;
+quotations sequences tools.test ;
+IN: brainfuck.tests
[ "+" run-brainfuck ] must-infer
! Hello World!
-[ "Hello World!\n" ] [ <" ++++++++++[>+++++++>++++++++++>+++>+<<<<-]
+[ "Hello World!\n" ] [ """++++++++++[>+++++++>++++++++++>+++>+<<<<-]
>++.>+.+++++++..+++.>++.<<+++++++++++++++.>.+++.
- ------.--------.>+.>. "> get-brainfuck ] unit-test
+ ------.--------.>+.>.""" get-brainfuck ] unit-test
! Addition (single-digit)
! Multiplication (single-digit)
-[ "8\0" ] [ "24" [ <" ,>,>++++++++[<------<------>>-]
+[ "8\0" ] [ "24" [ """,>,>++++++++[<------<------>>-]
<<[>[>+>+<<-]>>[<<+>>-]<<<-]
- >>>++++++[<++++++++>-],<.>. ">
+ >>>++++++[<++++++++>-],<.>."""
get-brainfuck ] with-string-reader ] unit-test
! Division (single-digit, integer)
-[ "3" ] [ "62" [ <" ,>,>++++++[-<--------<-------->>]
+[ "3" ] [ "62" [ """,>,>++++++[-<--------<-------->>]
<<[
>[->+>+<<]
>[-<<-
<<[-<<+>>]
<<<]
>[-]>>>>[-<<<<<+>>>>>]
- <<<<++++++[-<++++++++>]<. ">
+ <<<<++++++[-<++++++++>]<."""
get-brainfuck ] with-string-reader ] unit-test
! Uppercase
! Squares of numbers from 0 to 100
100 [0,b] [ dup * number>string ] map "\n" join "\n" append 1quotation
-[ <" ++++[>+++++<-]>[<+++++>-]+<+[
+[ """++++[>+++++<-]>[<+++++>-]+<+[
>[>+>+<<-]++>>[<<+>>-]>>>[-]++>[-]+
>>>+[[-]++++++>>>]<<<[[<++++++++<++>>-]+<.<[>----<-]<]
<<[>>>>>[>>>[-]+++++++++<[>-<-]+++++++++>
- [-[<->-]+[<<<]]<[>+<-]>]<<-]<<-] ">
+ [-[<->-]+[<<<]]<[>+<-]>]<<-]<<-]"""
get-brainfuck ] unit-test
math math.matrices math.parser math.vectors opengl
opengl.capabilities opengl.gl opengl.demo-support sequences
splitting vectors words specialized-arrays ;
-SPECIALIZED-ARRAY: float
-SPECIALIZED-ARRAY: uint
+QUALIFIED-WITH: alien.c-types c
+SPECIALIZED-ARRAY: c:float
+SPECIALIZED-ARRAY: c:uint
IN: bunny.model
: numbers ( str -- seq )
--- /dev/null
+IN: compiler.graphviz.tests
+USING: compiler.graphviz io.files kernel tools.test ;
+
+[ t ] [ [ [ 1 ] [ 2 ] if ] render-cfg exists? ] unit-test
+[ t ] [ [ [ 1 ] [ 2 ] if ] render-dom exists? ] unit-test
+[ t ] [ [ [ 1 ] [ 2 ] if ] render-call-graph exists? ] unit-test
"}" ,
] { } make , ; inline
-: render-graph ( quot -- )
+: render-graph ( quot -- name )
{ } make
"cfg" ".dot" make-unique-file
dup "Wrote " prepend print
[ [ concat ] dip ascii set-file-lines ]
[ { "dot" "-Tpng" "-O" } swap suffix try-process ]
- [ ".png" append "open" swap 2array try-process ]
+ [ ".png" append ]
tri ; inline
+: display-graph ( name -- )
+ "open" swap 2array try-process ;
+
: attrs>string ( seq -- str )
[ "" ] [ "," join "[" "]" surround ] if-empty ;
: optimized-cfg ( quot -- cfgs )
{
{ [ dup cfg? ] [ 1array ] }
- { [ dup quotation? ] [ test-cfg [ optimize-cfg ] map ] }
- { [ dup word? ] [ test-cfg [ optimize-cfg ] map ] }
+ { [ dup quotation? ] [ test-cfg [ dup cfg set optimize-cfg ] map ] }
+ { [ dup word? ] [ test-cfg [ dup cfg set optimize-cfg ] map ] }
[ ]
} cond ;
-: render-cfg ( cfg -- )
+: render-cfg ( cfg -- name )
optimized-cfg [ cfgs ] render-graph ;
: dom-trees ( cfgs -- )
] over cfg-title graph,
] each ;
-: render-dom ( cfg -- )
+: render-dom ( cfg -- name )
optimized-cfg [ dom-trees ] render-graph ;
SYMBOL: word-counts
H{ } clone vertex-names set
[ "ROOT" ] dip (call-graph-edges) ;
-: render-call-graph ( tree -- )
+: render-call-graph ( tree -- name )
dup quotation? [ build-tree ] when
analyze-recursive drop
[ [ call-graph get call-graph-edges ] "Call graph" graph, ]
USING: accessors alien.c-types alien.strings assocs byte-arrays
combinators continuations destructors fry io.encodings.8-bit
io io.encodings.string io.encodings.utf8 kernel math
-namespaces prettyprint sequences
+namespaces prettyprint sequences classes.struct
strings threads curses.ffi ;
IN: curses
: move-cursor ( window-name y x -- )
[
- window-ptr
+ window-ptr c-window memory>struct
{
[ ]
[ (curses-window-refresh) ]
- [ c-window-_curx ]
- [ c-window-_cury ]
+ [ _curx>> ]
+ [ _cury>> ]
} cleave
] 2dip mvcur curses-error (curses-window-refresh) ;
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien alien.syntax combinators kernel system
-alien.libraries ;
+alien.libraries classes.struct ;
IN: curses.ffi
<< "curses" {
CONSTANT: CCHARW_MAX 5
-C-STRUCT: cchar_t
- { "attr_t" "attr" }
- { { "wchar_t" CCHARW_MAX } "chars" } ;
+STRUCT: cchar_t
+ { attr attr_t }
+ { chars { wchar_t CCHARW_MAX } } ;
-C-STRUCT: pdat
- { "NCURSES_SIZE_T" "_pad_y" }
- { "NCURSES_SIZE_T" "_pad_x" }
- { "NCURSES_SIZE_T" "_pad_top" }
- { "NCURSES_SIZE_T" "_pad_left" }
- { "NCURSES_SIZE_T" "_pad_bottom" }
- { "NCURSES_SIZE_T" "_pad_right" } ;
+STRUCT: pdat
+ { _pad_y NCURSES_SIZE_T }
+ { _pad_x NCURSES_SIZE_T }
+ { _pad_top NCURSES_SIZE_T }
+ { _pad_left NCURSES_SIZE_T }
+ { _pad_bottom NCURSES_SIZE_T }
+ { _pad_right NCURSES_SIZE_T } ;
-C-STRUCT: c-window
- { "NCURSES_SIZE_T" "_cury" }
- { "NCURSES_SIZE_T" "_curx" }
+STRUCT: c-window
+ { _cury NCURSES_SIZE_T }
+ { _curx NCURSES_SIZE_T }
- { "NCURSES_SIZE_T" "_maxy" }
- { "NCURSES_SIZE_T" "_maxx" }
- { "NCURSES_SIZE_T" "_begy" }
- { "NCURSES_SIZE_T" "_begx" }
+ { _maxy NCURSES_SIZE_T }
+ { _maxx NCURSES_SIZE_T }
+ { _begy NCURSES_SIZE_T }
+ { _begx NCURSES_SIZE_T }
- { "short" " _flags" }
+ { _flags short }
- { "attr_t" "_attrs" }
- { "chtype" "_bkgd" }
+ { _attrs attr_t }
+ { _bkgd chtype }
- { "bool" "_notimeout" }
- { "bool" "_clear" }
- { "bool" "_leaveok" }
- { "bool" "_scroll" }
- { "bool" "_idlok" }
- { "bool" "_idcok" }
- { "bool" "_immed" }
- { "bool" "_sync" }
- { "bool" "_use_keypad" }
- { "int" "_delay" }
+ { _notimeout bool }
+ { _clear bool }
+ { _leaveok bool }
+ { _scroll bool }
+ { _idlok bool }
+ { _idcok bool }
+ { _immed bool }
+ { _sync bool }
+ { _use_keypad bool }
+ { _delay int }
- { "char*" "_line" }
- { "NCURSES_SIZE_T" "_regtop" }
- { "NCURSES_SIZE_T" "_regbottom" }
+ { _line char* }
+ { _regtop NCURSES_SIZE_T }
+ { _regbottom NCURSES_SIZE_T }
- { "int" "_parx" }
- { "int" "_pary" }
- { "WINDOW*" "_parent" }
+ { _parx int }
+ { _pary int }
+ { _parent WINDOW* }
- { "pdat" "_pad" }
+ { _pad pdat }
- { "NCURSES_SIZE_T" "_yoffset" }
+ { _yoffset NCURSES_SIZE_T }
- { "cchar_t" "_bkgrnd" } ;
+ { _bkgrnd cchar_t } ;
LIBRARY: curses
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: continuations decimals grouping kernel locals math
+math.functions math.order math.ratios prettyprint random
+sequences tools.test ;
+IN: decimals.tests
+
+[ t ] [
+ D: 12.34 D: 00012.34000 =
+] unit-test
+
+: random-test-int ( -- n )
+ 10 random 2 random 0 = [ neg ] when ;
+
+: random-test-decimal ( -- decimal )
+ random-test-int random-test-int <decimal> ;
+
+ERROR: decimal-test-failure D1 D2 quot ;
+
+:: (test-decimal-op) ( D1 D2 quot1 quot2 -- ? )
+ D1 D2
+ quot1 [ decimal>ratio >float ] compose
+ [ [ decimal>ratio ] bi@ quot2 call( obj obj -- obj ) >float ] 2bi -.1 ~
+ [ t ] [ D1 D2 quot1 decimal-test-failure ] if ; inline
+
+: test-decimal-op ( quot1 quot2 -- ? )
+ [ random-test-decimal random-test-decimal ] 2dip (test-decimal-op) ; inline
+
+[ t ] [ 1000 [ drop [ D+ ] [ + ] test-decimal-op ] all? ] unit-test
+[ t ] [ 1000 [ drop [ D- ] [ - ] test-decimal-op ] all? ] unit-test
+[ t ] [ 1000 [ drop [ D* ] [ * ] test-decimal-op ] all? ] unit-test
+[ t ] [
+ 1000 [
+ drop
+ [ [ 100 D/ ] [ /f ] test-decimal-op ]
+ [ { "kernel-error" 4 f f } = ] recover
+ ] all?
+] unit-test
+
+[ t ] [
+ { D: 0. D: .0 D: 0.0 D: 00.00 D: . } all-equal?
+] unit-test
+
+[ t ] [ T{ decimal f 90 0 } T{ decimal f 9 1 } = ] unit-test
+
+[ t ] [ D: 1 D: 2 before? ] unit-test
+[ f ] [ D: 2 D: 2 before? ] unit-test
+[ f ] [ D: 3 D: 2 before? ] unit-test
+[ f ] [ D: -1 D: -2 before? ] unit-test
+[ f ] [ D: -2 D: -2 before? ] unit-test
+[ t ] [ D: -3 D: -2 before? ] unit-test
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors combinators.short-circuit kernel lexer math
+math.functions math.parser parser sequences splitting
+locals math.order ;
+IN: decimals
+
+TUPLE: decimal { mantissa read-only } { exponent read-only } ;
+
+: <decimal> ( mantissa exponent -- decimal ) decimal boa ;
+
+: >decimal< ( decimal -- mantissa exponent )
+ [ mantissa>> ] [ exponent>> ] bi ; inline
+
+: string>decimal ( string -- decimal )
+ "." split1
+ [ [ CHAR: 0 = ] trim-head [ "0" ] when-empty ]
+ [ [ CHAR: 0 = ] trim-tail [ "" ] when-empty ] bi*
+ [ append string>number ] [ nip length neg ] 2bi <decimal> ;
+
+: parse-decimal ( -- decimal ) scan string>decimal ;
+
+SYNTAX: D: parse-decimal parsed ;
+
+: decimal>ratio ( decimal -- ratio ) >decimal< 10^ * ;
+: decimal>float ( decimal -- ratio ) decimal>ratio >float ;
+
+: scale-mantissas ( D1 D2 -- m1 m2 exp )
+ [ [ mantissa>> ] bi@ ]
+ [
+ [ exponent>> ] bi@
+ [
+ - dup 0 <
+ [ neg 10^ * t ]
+ [ 10^ [ * ] curry dip f ] if
+ ] [ ? ] 2bi
+ ] 2bi ;
+
+: scale-decimals ( D1 D2 -- D1' D2' )
+ [ drop ]
+ [ scale-mantissas <decimal> nip ] 2bi ;
+
+ERROR: decimal-types-expected d1 d2 ;
+
+: guard-decimals ( obj1 obj2 -- D1 D2 )
+ 2dup [ decimal? ] both?
+ [ decimal-types-expected ] unless ;
+
+M: decimal equal?
+ {
+ [ [ decimal? ] both? ]
+ [
+ scale-decimals
+ {
+ [ [ mantissa>> ] bi@ = ]
+ [ [ exponent>> ] bi@ = ]
+ } 2&&
+ ]
+ } 2&& ;
+
+M: decimal before?
+ guard-decimals scale-decimals
+ [ mantissa>> ] bi@ < ;
+
+: D-abs ( D -- D' )
+ [ mantissa>> abs ] [ exponent>> ] bi <decimal> ;
+
+: D+ ( D1 D2 -- D3 )
+ guard-decimals scale-mantissas [ + ] dip <decimal> ;
+
+: D- ( D1 D2 -- D3 )
+ guard-decimals scale-mantissas [ - ] dip <decimal> ;
+
+: D* ( D1 D2 -- D3 )
+ guard-decimals [ >decimal< ] bi@ swapd + [ * ] dip <decimal> ;
+
+:: D/ ( D1 D2 a -- D3 )
+ D1 D2 guard-decimals 2drop
+ D1 >decimal< :> e1 :> m1
+ D2 >decimal< :> e2 :> m2
+ m1 a 10^ *
+ m2 /i
+
+ e1
+ e2 a + - <decimal> ;
USING: kernel accessors sequences sequences.private destructors math namespaces
locals openssl openssl.libcrypto byte-arrays bit-arrays.private
- alien.c-types alien.destructors ;
+ alien.c-types alien.destructors alien.data ;
IN: ecdsa
! Copyright (C) 2005, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.syntax kernel system combinators
-alien.libraries ;
+alien.libraries classes.struct ;
IN: freetype
<< "freetype" {
TYPEDEF: long FT_Long
TYPEDEF: ulong FT_ULong
TYPEDEF: uchar FT_Bool
-TYPEDEF: cell FT_Offset
+TYPEDEF: ulong FT_Offset
TYPEDEF: int FT_PtrDist
TYPEDEF: char FT_String
TYPEDEF: int FT_Tag
TYPEDEF: void face
TYPEDEF: void glyph
-C-STRUCT: glyph
- { "void*" "library" }
- { "face*" "face" }
- { "glyph*" "next" }
- { "FT_UInt" "reserved" }
- { "void*" "generic" }
- { "void*" "generic" }
+STRUCT: glyph
+ { library void* }
+ { face face* }
+ { next glyph* }
+ { reserved FT_UInt }
+ { generic void* }
+ { generic2 void* }
- { "FT_Pos" "width" }
- { "FT_Pos" "height" }
+ { width FT_Pos }
+ { height FT_Pos }
- { "FT_Pos" "hori-bearing-x" }
- { "FT_Pos" "hori-bearing-y" }
- { "FT_Pos" "hori-advance" }
+ { hori-bearing-x FT_Pos }
+ { hori-bearing-y FT_Pos }
+ { hori-advance FT_Pos }
- { "FT_Pos" "vert-bearing-x" }
- { "FT_Pos" "vert-bearing-y" }
- { "FT_Pos" "vert-advance" }
+ { vert-bearing-x FT_Pos }
+ { vert-bearing-y FT_Pos }
+ { vert-advance FT_Pos }
- { "FT_Fixed" "linear-hori-advance" }
- { "FT_Fixed" "linear-vert-advance" }
- { "FT_Pos" "advance-x" }
- { "FT_Pos" "advance-y" }
+ { linear-hori-advance FT_Fixed }
+ { linear-vert-advance FT_Fixed }
+ { advance-x FT_Pos }
+ { advance-y FT_Pos }
- { "intptr_t" "format" }
+ { format intptr_t }
- { "int" "bitmap-rows" }
- { "int" "bitmap-width" }
- { "int" "bitmap-pitch" }
- { "void*" "bitmap-buffer" }
- { "short" "bitmap-num-grays" }
- { "char" "bitmap-pixel-mode" }
- { "char" "bitmap-palette-mode" }
- { "void*" "bitmap-palette" }
+ { bitmap-rows int }
+ { bitmap-width int }
+ { bitmap-pitch int }
+ { bitmap-buffer void* }
+ { bitmap-num-grays short }
+ { bitmap-pixel-mode char }
+ { bitmap-palette-mode char }
+ { bitmap-palette void* }
- { "FT_Int" "bitmap-left" }
- { "FT_Int" "bitmap-top" }
+ { bitmap-left FT_Int }
+ { bitmap-top FT_Int }
- { "short" "n-contours" }
- { "short" "n-points" }
+ { n-contours short }
+ { n-points short }
- { "void*" "points" }
- { "char*" "tags" }
- { "short*" "contours" }
+ { points void* }
+ { tags char* }
+ { contours short* }
- { "int" "outline-flags" }
+ { outline-flags int }
- { "FT_UInt" "num_subglyphs" }
- { "void*" "subglyphs" }
+ { num_subglyphs FT_UInt }
+ { subglyphs void* }
- { "void*" "control-data" }
- { "long" "control-len" }
+ { control-data void* }
+ { control-len long }
- { "FT_Pos" "lsb-delta" }
- { "FT_Pos" "rsb-delta" }
+ { lsb-delta FT_Pos }
+ { rsb-delta FT_Pos }
- { "void*" "other" } ;
+ { other void* } ;
-C-STRUCT: face-size
- { "face*" "face" }
- { "void*" "generic" }
- { "void*" "generic" }
+STRUCT: face-size
+ { face face* }
+ { generic void* }
+ { generic2 void* }
- { "FT_UShort" "x-ppem" }
- { "FT_UShort" "y-ppem" }
+ { x-ppem FT_UShort }
+ { y-ppem FT_UShort }
- { "FT_Fixed" "x-scale" }
- { "FT_Fixed" "y-scale" }
+ { x-scale FT_Fixed }
+ { y-scale FT_Fixed }
- { "FT_Pos" "ascender" }
- { "FT_Pos" "descender" }
- { "FT_Pos" "height" }
- { "FT_Pos" "max-advance" } ;
+ { ascender FT_Pos }
+ { descender FT_Pos }
+ { height FT_Pos }
+ { max-advance FT_Pos } ;
-C-STRUCT: face
- { "FT_Long" "num-faces" }
- { "FT_Long" "index" }
+STRUCT: face
+ { num-faces FT_Long }
+ { index FT_Long }
- { "FT_Long" "flags" }
- { "FT_Long" "style-flags" }
+ { flags FT_Long }
+ { style-flags FT_Long }
- { "FT_Long" "num-glyphs" }
+ { num-glyphs FT_Long }
- { "FT_Char*" "family-name" }
- { "FT_Char*" "style-name" }
+ { family-name FT_Char* }
+ { style-name FT_Char* }
- { "FT_Int" "num-fixed-sizes" }
- { "void*" "available-sizes" }
+ { num-fixed-sizes FT_Int }
+ { available-sizes void* }
- { "FT_Int" "num-charmaps" }
- { "void*" "charmaps" }
+ { num-charmaps FT_Int }
+ { charmaps void* }
- { "void*" "generic" }
- { "void*" "generic" }
+ { generic void* }
+ { generic2 void* }
- { "FT_Pos" "x-min" }
- { "FT_Pos" "y-min" }
- { "FT_Pos" "x-max" }
- { "FT_Pos" "y-max" }
+ { x-min FT_Pos }
+ { y-min FT_Pos }
+ { x-max FT_Pos }
+ { y-max FT_Pos }
- { "FT_UShort" "units-per-em" }
- { "FT_Short" "ascender" }
- { "FT_Short" "descender" }
- { "FT_Short" "height" }
+ { units-per-em FT_UShort }
+ { ascender FT_Short }
+ { descender FT_Short }
+ { height FT_Short }
- { "FT_Short" "max-advance-width" }
- { "FT_Short" "max-advance-height" }
+ { max-advance-width FT_Short }
+ { max-advance-height FT_Short }
- { "FT_Short" "underline-position" }
- { "FT_Short" "underline-thickness" }
+ { underline-position FT_Short }
+ { underline-thickness FT_Short }
- { "glyph*" "glyph" }
- { "face-size*" "size" }
- { "void*" "charmap" } ;
+ { glyph glyph* }
+ { size face-size* }
+ { charmap void* } ;
-C-STRUCT: FT_Bitmap
- { "int" "rows" }
- { "int" "width" }
- { "int" "pitch" }
- { "void*" "buffer" }
- { "short" "num_grays" }
- { "char" "pixel_mode" }
- { "char" "palette_mode" }
- { "void*" "palette" } ;
+STRUCT: FT_Bitmap
+ { rows int }
+ { width int }
+ { pitch int }
+ { buffer void* }
+ { num_grays short }
+ { pixel_mode char }
+ { palette_mode char }
+ { palette void* } ;
FUNCTION: FT_Error FT_New_Face ( void* library, FT_Char* font, FT_Long index, face* face ) ;
math.matrices math.parser math.vectors method-chains sequences
splitting threads ui ui.gadgets ui.gadgets.worlds
ui.pixel-formats specialized-arrays specialized-vectors ;
+FROM: alien.c-types => float ;
SPECIALIZED-ARRAY: float
SPECIALIZED-VECTOR: uint
IN: gpu.demos.bunny
! (c)2009 Joe Groff bsd license
USING: alien alien.syntax byte-arrays classes gpu.buffers
gpu.framebuffers gpu.shaders gpu.textures help.markup
-help.syntax images kernel math multiline sequences
+help.syntax images kernel math sequences
specialized-arrays strings ;
SPECIALIZED-ARRAY: float
SPECIALIZED-ARRAY: int
{ $description "Constructs a " { $link multi-index-range } " tuple." } ;
HELP: UNIFORM-TUPLE:
-{ $syntax <" UNIFORM-TUPLE: class-name
+{ $syntax """UNIFORM-TUPLE: class-name
{ "slot" uniform-type dimension }
{ "slot" uniform-type dimension }
...
- { "slot" uniform-type dimension } ; "> }
+ { "slot" uniform-type dimension } ;""" }
{ $description "Defines a new " { $link uniform-tuple } " class. Tuples of the new class can be used as the " { $snippet "uniforms" } " slot of a " { $link render-set } " in order to set the uniform parameters of the active shader program. The " { $link uniform-type } " of each slot defines the component type, and the " { $snippet "dimension" } " specifies an array length if not " { $link f } "."
$nl
"Uniform parameters are passed from Factor to the shader program through the uniform tuple as follows:"
! (c)2009 Joe Groff bsd license
-USING: accessors alien alien.c-types alien.structs arrays
+USING: accessors alien alien.c-types alien.data arrays
assocs classes classes.mixin classes.parser classes.singleton
classes.tuple classes.tuple.private combinators combinators.tuple destructors fry
generic generic.parser gpu gpu.buffers gpu.framebuffers
opengl.gl parser quotations sequences slots sorting
specialized-arrays strings ui.gadgets.worlds variants
vocabs.parser words ;
-SPECIALIZED-ARRAY: float
+FROM: math => float ;
+QUALIFIED-WITH: alien.c-types c
+SPECIALIZED-ARRAY: c:float
SPECIALIZED-ARRAY: int
SPECIALIZED-ARRAY: uint
SPECIALIZED-ARRAY: void*
{ $description "Defines a new " { $link shader } " of kind " { $link shader-kind } " named " { $snippet "shader-name" } ". The shader will read its source code from " { $snippet "filename" } " in the current Factor source file's directory." } ;
HELP: GLSL-SHADER:
-{ $syntax <" GLSL-SHADER-FILE: shader-name shader-kind
+{ $syntax """GLSL-SHADER-FILE: shader-name shader-kind
shader source
-; "> }
+;""" }
{ $description "Defines a new " { $link shader } " of kind " { $link shader-kind } " named " { $snippet "shader-name" } ". The shader will read its source code from the current Factor source file between the " { $snippet "GLSL-SHADER:" } " line and the first subsequent line with a single semicolon on it." } ;
HELP: VERTEX-FORMAT:
-{ $syntax <" VERTEX-FORMAT: format-name
+{ $syntax """VERTEX-FORMAT: format-name
{ "attribute"/f component-type dimension normalize? }
{ "attribute"/f component-type dimension normalize? }
...
- { "attribute"/f component-type dimension normalize? } ; "> }
+ { "attribute"/f component-type dimension normalize? } ;""" }
{ $description "Defines a new binary " { $link vertex-format } " for structuring vertex data stored in " { $link buffer } "s. Each " { $snippet "attribute" } " name either corresponds to an input parameter of a vertex shader, or is " { $link f } " to include padding in the vertex format. The " { $link component-type } " determines the format of the components, and the " { $snippet "dimension" } " determines the number of components. If the " { $snippet "component-type" } " is an integer type and " { $snippet "normalize?" } " is true, the component values will be scaled to the range 0.0 to 1.0 when fed to the vertex shader; otherwise, they will be cast to floats retaining their integral values." } ;
HELP: VERTEX-STRUCT:
-{ $syntax <" VERTEX-STRUCT: struct-name format-name "> }
+{ $syntax """VERTEX-STRUCT: struct-name format-name""" }
{ $description "Defines a struct class (like " { $link POSTPONE: STRUCT: } ") with the same binary format and component types as the given " { $link vertex-format } "." } ;
{ POSTPONE: GLSL-PROGRAM: POSTPONE: GLSL-SHADER-FILE: POSTPONE: GLSL-SHADER: } related-words
USING: multiline gpu.shaders gpu.shaders.private tools.test ;
IN: gpu.shaders.tests
-[ <" ERROR: foo.factor:20: Bad command or filename
+[ """ERROR: foo.factor:20: Bad command or filename
INFO: foo.factor:30: The operation completed successfully
-NOT:A:LOG:LINE "> ]
+NOT:A:LOG:LINE""" ]
[ T{ shader { filename "foo.factor" } { line 19 } }
-<" ERROR: 0:1: Bad command or filename
+"""ERROR: 0:1: Bad command or filename
INFO: 0:11: The operation completed successfully
-NOT:A:LOG:LINE "> replace-log-line-numbers ] unit-test
+NOT:A:LOG:LINE""" replace-log-line-numbers ] unit-test
! (c)2009 Joe Groff bsd license
-USING: accessors alien alien.c-types alien.strings arrays assocs
-byte-arrays classes.mixin classes.parser classes.singleton
-classes.struct combinators combinators.short-circuit definitions
-destructors generic.parser gpu gpu.buffers hashtables images
-io.encodings.ascii io.files io.pathnames kernel lexer literals
-locals math math.parser memoize multiline namespaces opengl
-opengl.gl opengl.shaders parser quotations sequences
+USING: accessors alien alien.c-types alien.data alien.strings
+arrays assocs byte-arrays classes.mixin classes.parser
+classes.singleton classes.struct combinators combinators.short-circuit
+definitions destructors generic.parser gpu gpu.buffers hashtables
+images io.encodings.ascii io.files io.pathnames kernel lexer
+literals locals math math.parser memoize multiline namespaces
+opengl opengl.gl opengl.shaders parser quotations sequences
specialized-arrays splitting strings tr ui.gadgets.worlds
variants vectors vocabs vocabs.loader vocabs.parser words
words.constant ;
! (c)2009 Joe Groff bsd license
-USING: help.markup help.syntax kernel math math.rectangles multiline sequences ;
+USING: help.markup help.syntax kernel math math.rectangles
+sequences ;
IN: gpu.state
HELP: <blend-mode>
{ { $link func-one-minus-constant-alpha } " returns one minus the alpha component of the current " { $link blend-state } "'s " { $snippet "constant-color" } " for every result component." }
}
"A typical transparency effect will use the values:"
-{ $code <" T{ blend-mode
+{ $code """T{ blend-mode
{ equation eq-add }
{ source-function func-source-alpha }
{ dest-function func-one-minus-source-alpha }
-} "> }
+}""" }
} } ;
HELP: blend-state
! (c)2009 Joe Groff bsd license
-USING: accessors alien.c-types arrays byte-arrays combinators gpu
-kernel literals math math.rectangles opengl opengl.gl sequences
-variants specialized-arrays ;
+USING: accessors alien.c-types alien.data arrays byte-arrays
+combinators gpu kernel literals math math.rectangles opengl
+opengl.gl sequences variants specialized-arrays ;
+QUALIFIED-WITH: alien.c-types c
+FROM: math => float ;
SPECIALIZED-ARRAY: int
-SPECIALIZED-ARRAY: float
+SPECIALIZED-ARRAY: c:float
IN: gpu.state
UNION: ?rect rect POSTPONE: f ;
destructors fry gpu gpu.buffers images kernel locals math
opengl opengl.gl opengl.textures sequences
specialized-arrays ui.gadgets.worlds variants ;
+FROM: alien.c-types => float ;
SPECIALIZED-ARRAY: float
IN: gpu.textures
-USING: alien.c-types alien.syntax half-floats kernel math tools.test
-specialized-arrays ;
+USING: accessors alien.c-types alien.syntax half-floats kernel
+math tools.test specialized-arrays alien.data classes.struct ;
SPECIALIZED-ARRAY: half
IN: half-floats.tests
[ HEX: be00 ] [ -1.5 half>bits ] unit-test
[ HEX: 7c00 ] [ 1/0. half>bits ] unit-test
[ HEX: fc00 ] [ -1/0. half>bits ] unit-test
-[ HEX: 7eaa ] [ HEX: aaaaaaaaaaaaa <fp-nan> half>bits ] unit-test
+[ HEX: 7eaa ] [ NAN: aaaaaaaaaaaaa half>bits ] unit-test
! too-big floats overflow to infinity
[ HEX: 7c00 ] [ 65536.0 half>bits ] unit-test
[ 3.0 ] [ HEX: 4200 bits>half ] unit-test
[ t ] [ HEX: 7e00 bits>half fp-nan? ] unit-test
-C-STRUCT: halves
- { "half" "tom" }
- { "half" "dick" }
- { "half" "harry" }
- { "half" "harry-jr" } ;
+STRUCT: halves
+ { tom half }
+ { dick half }
+ { harry half }
+ { harry-jr half } ;
-[ 8 ] [ "halves" heap-size ] unit-test
+[ 8 ] [ halves heap-size ] unit-test
[ 3.0 ] [
- "halves" <c-object>
- 3.0 over set-halves-dick
- halves-dick
+ halves <struct>
+ 3.0 >>dick
+ dick>>
] unit-test
[ half-array{ 1.0 2.0 3.0 1/0. -1/0. } ]
! (c)2009 Joe Groff bsd license
-USING: accessors alien.c-types alien.syntax kernel math math.order ;
+USING: accessors alien.accessors alien.c-types alien.data
+alien.syntax kernel math math.order ;
+FROM: math => float ;
IN: half-floats
: half>bits ( float -- bits )
] unless
] bi bitor bits>float ;
-C-STRUCT: half { "ushort" "(bits)" } ;
+SYMBOL: half
<<
-"half" c-type
- [ half>bits <ushort> ] >>unboxer-quot
- [ *ushort bits>half ] >>boxer-quot
- drop
+<c-type>
+ float >>class
+ float >>boxed-class
+ [ alien-unsigned-2 bits>half ] >>getter
+ [ [ >float half>bits ] 2dip set-alien-unsigned-2 ] >>setter
+ 2 >>size
+ 2 >>align
+ [ >float ] >>unboxer-quot
+\ half define-primitive-type
>>
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax kernel sequences system ;
+USING: alien.syntax classes.struct kernel sequences system ;
IN: io.serial.unix.termios
CONSTANT: NCCS 20
TYPEDEF: uchar cc_t
TYPEDEF: uint speed_t
-C-STRUCT: termios
- { "tcflag_t" "iflag" } ! input mode flags
- { "tcflag_t" "oflag" } ! output mode flags
- { "tcflag_t" "cflag" } ! control mode flags
- { "tcflag_t" "lflag" } ! local mode flags
- { { "cc_t" NCCS } "cc" } ! control characters
- { "speed_t" "ispeed" } ! input speed
- { "speed_t" "ospeed" } ; ! output speed
+STRUCT: termios
+ { iflag tcflag_t }
+ { oflag tcflag_t }
+ { cflag tcflag_t }
+ { lflag tcflag_t }
+ { cc { cc_t NCCS } }
+ { ispeed speed_t }
+ { ospeed speed_t } ;
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax kernel system unix ;
+USING: alien.syntax classes.struct kernel system unix ;
IN: io.serial.unix.termios
CONSTANT: NCCS 32
TYPEDEF: uint speed_t
TYPEDEF: uint tcflag_t
-C-STRUCT: termios
- { "tcflag_t" "iflag" } ! input mode flags
- { "tcflag_t" "oflag" } ! output mode flags
- { "tcflag_t" "cflag" } ! control mode flags
- { "tcflag_t" "lflag" } ! local mode flags
- { "cc_t" "line" } ! line discipline
- { { "cc_t" NCCS } "cc" } ! control characters
- { "speed_t" "ispeed" } ! input speed
- { "speed_t" "ospeed" } ; ! output speed
+STRUCT: termios
+ { iflag tcflag_t }
+ { oflag tcflag_t }
+ { cflag tcflag_t }
+ { lflag tcflag_t }
+ { line cc_t }
+ { cc { cc_t NCCS } }
+ { ispeed speed_t }
+ { ospeed speed_t } ;
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien.c-types alien.syntax combinators io.ports
-io.streams.duplex system kernel math math.bitwise
-vocabs.loader unix io.serial io.serial.unix.termios io.backend.unix ;
+USING: accessors alien.c-types alien.syntax alien.data
+classes.struct combinators io.ports io.streams.duplex
+system kernel math math.bitwise vocabs.loader unix io.serial
+io.serial.unix.termios io.backend.unix ;
IN: io.serial.unix
<< {
: get-termios ( serial -- termios )
serial-fd
- "termios" <c-object> [ tcgetattr io-error ] keep ;
+ termios <struct> [ tcgetattr io-error ] keep ;
: configure-termios ( serial -- )
dup termios>>
{
- [ [ iflag>> ] dip over [ set-termios-iflag ] [ 2drop ] if ]
- [ [ oflag>> ] dip over [ set-termios-oflag ] [ 2drop ] if ]
+ [ [ iflag>> ] dip over [ (>>iflag) ] [ 2drop ] if ]
+ [ [ oflag>> ] dip over [ (>>oflag) ] [ 2drop ] if ]
[
[
[ cflag>> 0 or ] [ baud>> lookup-baud ] bi bitor
- ] dip set-termios-cflag
+ ] dip (>>cflag)
]
- [ [ lflag>> ] dip over [ set-termios-lflag ] [ 2drop ] if ]
+ [ [ lflag>> ] dip over [ (>>lflag) ] [ 2drop ] if ]
} 2cleave ;
: tciflush ( serial -- )
[ (connect-irc) (do-login) spawn-irc ] with-irc ;
: attach-chat ( irc-chat irc-client -- ) [ (attach-chat) ] with-irc ;
-: detach-chat ( irc-chat -- ) dup [ client>> remove-chat ] with-irc ;
+: detach-chat ( irc-chat -- ) dup client>> [ remove-chat ] with-irc ;
: speak ( message irc-chat -- ) dup client>> [ (speak) ] with-irc ;
: hear ( irc-chat -- message ) in-messages>> mailbox-get ;
: terminate-irc ( irc-client -- ) [ (terminate-irc) ] with-irc ;
! Test join
[ { "JOIN #factortest" } [
- "#factortest" %join %pop-output-line
+ "#factortest" %join %pop-output-line
+ ] unit-test
+] spawning-irc
+
+[ { "PART #factortest" } [
+ "#factortest" %join %pop-output-line drop
+ "#factortest" chat> remove-chat %pop-output-line
] unit-test
] spawning-irc
M: irc-server-chat remove-chat drop +server-chat+ unregister-chat ;
M: irc-channel-chat remove-chat
- [ part new annotate-message irc-send ]
+ [ name>> "PART " prepend string>irc-message irc-send ]
[ name>> unregister-chat ] bi ;
: (speak) ( message irc-chat -- ) swap annotate-message irc-send ;
jamshred.player jamshred.tunnel kernel math math.constants
math.functions math.vectors opengl opengl.gl opengl.glu
opengl.demo-support sequences specialized-arrays ;
+FROM: alien.c-types => float ;
SPECIALIZED-ARRAY: float
IN: jamshred.gl
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: slides help.markup math math.private kernel sequences
+slots.private ;
+IN: jvm-summit-talk
+
+CONSTANT: jvm-summit-slides
+{
+ { $slide "Factor language implementation"
+ "Goals: expressiveness, metaprogramming, performance"
+ "We want a language for anything from scripting DSLs to high-performance numerics"
+ "I assume you know a bit about compiler implementation: parser -> frontend -> optimizer -> codegen"
+ { "This is " { $strong "not" } " a talk about the Factor language" }
+ { "Go to " { $url "http://factorcode.org" } " to learn the language" }
+ }
+ { $slide "Why are dynamic languages slow?"
+ "Branching and indirection!"
+ "Runtime type checks and dispatch"
+ "Integer overflow checks"
+ "Boxed integers and floats"
+ "Lots of allocation of temporary objects"
+ }
+ { $slide "Interactive development"
+ "Code can be reloaded at any time"
+ "Class hierarchy might change"
+ "Slots may be added and removed"
+ "Functions might be redefined"
+ }
+ { $slide "Factor's solution"
+ "Factor implements most of the library in Factor"
+ "Library contains very generic, high-level code"
+ "Always compiles to native code"
+ "Compiler removes unused generality from high-level code"
+ "Inlining, specialization, partial evaluation"
+ "And deoptimize when assumptions change"
+ }
+ { $slide "Introduction: SSA form"
+ "Every identifier only has one global definition"
+ {
+ "Not SSA:"
+ { $code
+ "x = 1"
+ "y = 2"
+ "x = x + y"
+ "if(z < 0)"
+ " t = x + y"
+ "else"
+ " t = x - y"
+ "print(t)"
+ }
+ }
+ }
+ { $slide "Introduction: SSA form"
+ "Rename re-definitions and subsequent usages"
+ {
+ "Still not SSA:"
+ { $code
+ "x = 1"
+ "y = 2"
+ "x1 = x + y"
+ "if(z < 0)"
+ " t = x1 + y"
+ "else"
+ " t = x1 - y"
+ "print(t)"
+ }
+ }
+ }
+ { $slide "Introduction: SSA form"
+ "Introduce “φ functions” at control-flow merge points"
+ {
+ "This is SSA:"
+ { $code
+ "x = 1"
+ "y = 2"
+ "x1 = x + y"
+ "if(z < 0)"
+ " t1 = x1 + y"
+ "else"
+ " t2 = x1 - y"
+ "t3 = φ(t1,t2)"
+ "print(t3)"
+ }
+ }
+ }
+ { $slide "Why SSA form?"
+ {
+ "Def-use chains:"
+ { $list
+ "Defs-of: instructions that define a value"
+ "Uses-of: instructions that use a value"
+ }
+ "With SSA, defs-of has exactly one element"
+ }
+ }
+ { $slide "Def-use chains"
+ "Simpler def-use makes analysis more accurate."
+ {
+ "Non-SSA example:"
+ { $code
+ "if(x < 0)"
+ " s = new Circle"
+ " a = area(s1)"
+ "else"
+ " s = new Rectangle"
+ " a = area(s2)"
+ }
+ }
+ }
+ { $slide "Def-use chains"
+ {
+ "SSA example:"
+ { $code
+ "if(x < 0)"
+ " s1 = new Circle"
+ " a1 = area(s1)"
+ "else"
+ " s2 = new Rectangle"
+ " a2 = area(s2)"
+ "a = φ(a1,a2)"
+ }
+
+ }
+ }
+ { $slide "Factor compiler overview"
+ "High-level SSA IR constructed from stack code"
+ "High level optimizer transforms high-level IR"
+ "Low-level SSA IR is constructed from high-level IR"
+ "Low level optimizer transforms low-level IR"
+ "Register allocator runs on low-level IR"
+ "Machine IR is constructed from low-level IR"
+ "Code generation"
+ }
+ { $slide "High-level optimizer"
+ "Frontend: expands macros, inline higher order functions"
+ "Propagation: inline methods, constant folding"
+ "Escape analysis: unbox tuples"
+ "Dead code elimination: clean up"
+ }
+ { $slide "Higher-order functions"
+ "Almost all control flow is done with higher-order functions"
+ { { $link if } ", " { $link times } ", " { $link each } }
+ "Calling a block is an indirect jump"
+ "Solution: inline higher order functions at the call site"
+ "Inline the block body at the higher order call site in the function"
+ "Record inlining in deoptimization database"
+ }
+ { $slide "Generic functions"
+ "A generic function contains multiple method bodies"
+ "Dispatches on the class of argument(s)"
+ "In Factor, generic functions are single dispatch"
+ "Almost equivalent to message passing"
+ }
+ { $slide "Tuple slot access"
+ "Slot readers and writers are generic functions"
+ "Generated automatically when you define a tuple class"
+ { "The generated methods call " { $link slot } ", " { $link set-slot } " primitives" }
+ "These primitives are not type safe; the generic dispatch performs the type checking for us"
+ "If class of dispatch value known statically, inline method"
+ "This may result in more methods inlining from additional specialization"
+ }
+ { $slide "Generic arithmetic"
+ { { $link + } ", " { $link * } ", etc perform a double dispatch on arguments" }
+ { "Fixed-precision integers (" { $link fixnum } "s) upgrade to " { $link bignum } "s automatically" }
+ "Floats and complex numbers are boxed, heap-allocated"
+ "Propagation of classes helps for floats"
+ "But not for fixnums, because of overflow checks"
+ "So we also propagate integer intervals"
+ "Interval arithmetic: etc, [a,b] + [c,d] = [a+c,b+d]"
+ }
+ { $slide "Slot value propagation"
+ "Complex numbers are even trickier"
+ "We can have a complex number with integer components, float components"
+ "Even if we inline complex arithmetic methods, still dispatching on components"
+ "Solution: propagate slot info"
+ }
+ { $slide "Constrant propagation"
+ "Contrieved example:"
+ { $code
+ "x = •"
+ "b = isa(x,array)"
+ "if(b)"
+ " a = length(x)"
+ "else"
+ " b = length(x)"
+ "c = φ(a,b)"
+ }
+ { "We should be able to inline the call to " { $snippet "length" } " in the true branch" }
+ }
+ { $slide "Constrant propagation"
+ "We build a table:"
+ { $code
+ "b true => x is array"
+ "b false => x is ~array"
+ }
+ { "In true branch, apply all " { $snippet "b true" } " constraints" }
+ { "In false branch, apply all " { $snippet "b false" } " constraints" }
+ }
+ { $slide "Going further"
+ "High-level optimizer eliminates some dispatch overhead and allocation"
+ {
+ { "Let's take a look at the " { $link float+ } " primitive" }
+ { $list
+ "No type checking anymore... but"
+ "Loads two tagged pointers from operand stack"
+ "Unboxes floats"
+ "Adds two floats"
+ "Boxes float result and perform a GC check"
+ }
+ }
+ }
+ { $slide "Low-level optimizer"
+ "Frontend: construct LL SSA IR from HL SSA IR"
+ "Alias analysis: remove redundant slot loads/stores"
+ "Value numbering: simplify arithmetic"
+ "Representation selection: eliminate boxing"
+ "Dead code elimination: clean up"
+ "Register allocation"
+ }
+ { $slide "Constructing low-level IR"
+ { "Low-level IR is a " { $emphasis "control flow graph" } " of " { $emphasis "basic blocks" } }
+ "A basic block is a list of instructions"
+ "Register-based IR; infinite, uniform register file"
+ { "Instructions:"
+ { $list
+ "Subroutine calls"
+ "Machine arithmetic"
+ "Load/store values on operand stack"
+ "Box/unbox values"
+ }
+ }
+ }
+ { $slide "Inline allocation and GC checks"
+ {
+ "Allocation of small objects can be done in a few instructions:"
+ { $list
+ "Bump allocation pointer"
+ "Write object header"
+ "Fill in payload"
+ }
+ }
+ "Multiple allocations in the same basic block only need a single GC check; saves on a conditional branch"
+ }
+ { $slide "Alias analysis"
+ "Factor constructors are just ordinary functions"
+ { "They call a primitive constructor: " { $link new } }
+ "When a new object is constructed, it has to be initialized"
+ "... but the user's constructor probably fills in all the slots again with actual values"
+ "Local alias analysis eliminates redundant slot loads and stores"
+ }
+ { $slide "Value numbering"
+ { "A form of " { $emphasis "redundancy elimination" } }
+ "Requires use of SSA form in order to work"
+ "Define an equivalence relation over SSA values"
+ "Assign a “value number” to each SSA value"
+ "If two values have the same number, they will always be equal at runtime"
+ }
+ { $slide "Types of value numbering"
+ "Many variations: algebraic simplifications, various rewrite rules can be tacked on"
+ "Local value numbering: in basic blocks"
+ "Global value numbering: entire procedure"
+ "Factor only does local value numbering"
+ }
+ { $slide "Value graph and expressions"
+ { $table
+ {
+ {
+ "Basic block:"
+ { $code
+ "x = •"
+ "y = •"
+ "a = x + 1"
+ "b = a + 1"
+ "c = x + 2"
+ "d = b - c"
+ "e = y + d"
+ }
+ }
+ {
+ "Value numbers:"
+ { $code
+ "V1: •"
+ "V2: •"
+ "V3: 1"
+ "V4: 2"
+ "V5: (V1 + V3)"
+ "V6: (V5 + V3)"
+ "V7: (V3 + V4)"
+ "V8: (V6 - V7)"
+ "V9: (V2 + V8)"
+ }
+ }
+ }
+ }
+ }
+ { $slide "Expression simplification"
+ {
+ "Constant folding: if V1 and V2 are constants "
+ { $snippet "(V1 op V2)" }
+ " can be evaluated at compile-time"
+ }
+ {
+ "Reassociation: if V2 and V3 are constants "
+ { $code "((V1 op V2) op V3) => (V1 op (V2 op V3))" }
+ }
+ {
+ "Algebraic identities: if V2 is constant 0, "
+ { $code "(V1 + V2) => V1" }
+ }
+ {
+ "Strength reduction: if V2 is a constant power of two, "
+ { $code "(V1 * V2) => (V1 << log2(V2))" }
+ }
+ "etc, etc, etc"
+ }
+ { $slide "Representation selection overview"
+ "Floats and SIMD vectors need to be boxed"
+ "Representation: tagged pointer, unboxed float, unboxed SIMD value..."
+ "When IR is built, no boxing or unboxing instructions inserted"
+ "Representation selection pass makes IR consistent"
+ }
+ { $slide "Representation selection algorithm"
+ {
+ "For each SSA value:"
+ { $list
+ "Compute possible representations"
+ "Compute cost of each representation"
+ "Pick representation with minimum cost"
+ }
+ }
+ {
+ "For each instruction:"
+ { $list
+ "If it expects a value to be in a different representation, insert box or unbox code"
+ }
+ }
+ }
+ { $slide "Register allocation"
+ "Linear scan algorithm used in Java HotSpot Client"
+ "Described in Christian Wimmer's masters thesis"
+ "Works fine on x86-64, not too great on x86-32"
+ "Good enough since basic blocks tend to be short, with lots of procedure calls"
+ "Might switch to graph coloring eventually"
+ }
+ { $slide "Compiler tools"
+ "Printing high level IR"
+ "Printing low level IR"
+ "Disassembly"
+ "Display call tree"
+ "Display control flow graph"
+ "Display dominator tree"
+ }
+}
+
+: jvm-summit-talk ( -- )
+ jvm-summit-slides slides-window ;
+
+MAIN: jvm-summit-talk
--- /dev/null
+Slides from Slava's talk at JVM Language Summit 2009
destructors fry io io.encodings.utf8 kernel managed-server
namespaces parser sequences sorting splitting strings.parser
unicode.case unicode.categories calendar calendar.format
-locals multiline io.encodings.binary io.encodings.string
-prettyprint ;
+locals io.encodings.binary io.encodings.string prettyprint ;
IN: managed-server.chat
TUPLE: chat-server < managed-server ;
docs key chat-docs get set-at ;
[ handle-help ]
-<" Syntax: /help [command]
-Displays the documentation for a command.">
+"""Syntax: /help [command]
+Displays the documentation for a command."""
"help" add-command
[ drop clients keys [ "``" "''" surround ] map ", " join send-line ]
-<" Syntax: /who
-Shows the list of connected users.">
+"""Syntax: /who
+Shows the list of connected users."""
"who" add-command
[ drop gmt timestamp>rfc822 send-line ]
-<" Syntax: /time
-Returns the current GMT time."> "time" add-command
+"""Syntax: /time
+Returns the current GMT time.""" "time" add-command
[ handle-nick ]
-<" Syntax: /nick nickname
-Changes your nickname.">
+"""Syntax: /nick nickname
+Changes your nickname."""
"nick" add-command
[ handle-me ]
-<" Syntax: /me action">
+"""Syntax: /me action"""
"me" add-command
[ handle-quit ]
-<" Syntax: /quit [message]
-Disconnects a user from the chat server."> "quit" add-command
+"""Syntax: /quit [message]
+Disconnects a user from the chat server.""" "quit" add-command
: handle-command ( string -- )
dup " " split1 swap >lower commands get at* [
] with-scope
] unit-test
-[ { "./factor.com" "-i=boot.x86.32.image" "-no-user-init" "-sse-version=30" } ] [
+[ { "./factor.com" "-i=boot.x86.32.image" "-no-user-init" } ] [
[
"winnt" target-os set
"x86.32" target-cpu set
factor-vm ,
"-i=" boot-image-name append ,
"-no-user-init" ,
- target-cpu get { "x86.32" "x86.64" } member? [ "-sse-version=30" , ] when
] { } make ;
: boot ( -- )
! (c)2009 Joe Groff bsd license
-USING: accessors alien alien.c-types destructors kernel libc math ;
+USING: accessors alien alien.c-types alien.data destructors kernel libc math ;
IN: memory.piles
TUPLE: pile
--- /dev/null
+USING: alien.syntax io io.encodings.utf16n io.encodings.utf8 io.files
+kernel namespaces sequences system threads unix.utilities ;
+IN: mttest
+
+FUNCTION: void* start_standalone_factor_in_new_thread ( int argc, char** argv ) ;
+
+HOOK: native-string-encoding os ( -- encoding )
+M: windows native-string-encoding utf16n ;
+M: unix native-string-encoding utf8 ;
+
+: start-vm-in-os-thread ( args -- threadhandle )
+ \ vm get-global prefix
+ [ length ] [ native-string-encoding strings>alien ] bi
+ start_standalone_factor_in_new_thread ;
+
+: start-tetris-in-os-thread ( -- )
+ { "-run=tetris" } start-vm-in-os-thread drop ;
+
+: start-testthread-in-os-thread ( -- )
+ { "-run=mttest" } start-vm-in-os-thread drop ;
+
+: testthread ( -- )
+ "/tmp/hello" utf8 [ "hello!\n" write ] with-file-appender 5000000 sleep ;
+
+MAIN: testthread
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors eval kernel lexer nested-comments tools.test ;
+IN: nested-comments.tests
+
+! Correct
+[ ] [
+ "USE: nested-comments (* comment *)" eval( -- )
+] unit-test
+
+[ ] [
+ "USE: nested-comments (* comment*)" eval( -- )
+] unit-test
+
+[ ] [
+ "USE: nested-comments (* comment
+*)" eval( -- )
+] unit-test
+
+[ ] [
+ "USE: nested-comments (* comment
+*)" eval( -- )
+] unit-test
+
+[ ] [
+ "USE: nested-comments (* comment
+*)" eval( -- )
+] unit-test
+
+[ ] [
+ "USE: nested-comments (* comment
+ (* *)
+
+*)" eval( -- )
+] unit-test
+
+! Malformed
+[
+ "USE: nested-comments (* comment
+ (* *)" eval( -- )
+] [
+ error>> T{ unexpected f "*)" f } =
+] must-fail-with
-! by blei on #concatenative\r
+! Copyright (C) 2009 blei, Doug Coleman.\r
+! See http://factorcode.org/license.txt for BSD license.\r
USING: kernel sequences math locals make multiline ;\r
IN: nested-comments\r
\r
-:: (subsequences-at) ( sseq seq n -- )\r
- sseq seq n start*\r
- [ dup , sseq length + [ sseq seq ] dip (subsequences-at) ]\r
- when* ;\r
+: (count-subsequences) ( count substring string n -- count' )\r
+ [ 2dup ] dip start* [\r
+ pick length +\r
+ [ 1 + ] 3dip (count-subsequences)\r
+ ] [\r
+ 2drop\r
+ ] if* ;\r
\r
-: subsequences-at ( sseq seq -- indices )\r
- [ 0 (subsequences-at) ] { } make ;\r
+: count-subsequences ( subseq seq -- n )\r
+ [ 0 ] 2dip 0 (count-subsequences) ;\r
\r
-: count-subsequences ( sseq seq -- i )\r
- subsequences-at length ;\r
+: parse-nestable-comment ( parsed-vector left-to-parse -- parsed-vector )\r
+ 1 - "*)" parse-multiline-string\r
+ [ "(*" ] dip\r
+ count-subsequences + dup 0 > [ parse-nestable-comment ] [ drop ] if ;\r
\r
-: parse-all-(* ( parsed-vector left-to-parse -- parsed-vector )\r
- 1 - "*)" parse-multiline-string [ "(*" ] dip\r
- count-subsequences + dup 0 > [ parse-all-(* ] [ drop ] if ;\r
-\r
-SYNTAX: (* 1 parse-all-(* ;
\ No newline at end of file
+SYNTAX: (* 1 parse-nestable-comment ;\r
alien.syntax namespaces alien.c-types sequences vocabs.loader
shuffle openal.backend alien.libraries generalizations
specialized-arrays ;
+FROM: alien.c-types => float short ;
SPECIALIZED-ARRAY: uint
IN: openal
{ $slide "Locals example"
"Area of a triangle using Heron's formula"
{ $code
- <" :: area ( a b c -- x )
+ """:: area ( a b c -- x )
a b c + + 2 / :> p
p
p a - *
p b - *
- p c - * sqrt ;">
+ p c - * sqrt ;"""
}
}
{ $slide "Previous example without locals"
"A bit unwieldy..."
{ $code
- <" : area ( a b c -- x )
+ """: area ( a b c -- x )
[ ] [ + + 2 / ] 3bi
[ '[ _ - ] tri@ ] [ neg ] bi
- * * * sqrt ;"> }
+ * * * sqrt ;""" }
}
{ $slide "More idiomatic version"
"But there's a trick: put the points in an array"
- { $code <" : v-n ( v n -- w ) '[ _ - ] map ;
+ { $code """: v-n ( v n -- w ) '[ _ - ] map ;
: area ( points -- x )
[ 0 suffix ] [ sum 2 / ] bi
- v-n product sqrt ;"> }
+ v-n product sqrt ;""" }
}
! { $slide "The parser"
! "All data types have a literal syntax"
}
{ $slide "This is hard with mainstream syntax!"
{ $code
- <" var customer = ...;
+ """var customer = ...;
var orders = (customer == null ? null : customer.orders);
var order = (orders == null ? null : orders[0]);
-var price = (order == null ? null : order.price);"> }
+var price = (order == null ? null : order.price);""" }
}
{ $slide "An ad-hoc solution"
"Something like..."
}
{ $slide "UI example"
{ $code
{ 5 5 } >>gap
1 >>fill
"Hello world!" <label> add-gadget
"Click me!" [ drop beep ]
<bevel-button> add-gadget
<editor> <scroller> add-gadget
-"UI test" open-window "> }
+"UI test" open-window""" }
}
{ $slide "Help system"
"Help markup is just literal data"
{ $syntax "a => b" }
{ $description "Constructs a two-element array from the objects immediately before and after the " { $snippet "=>" } ". This syntax can be used inside sequence and assoc literals." }
{ $examples
-{ $unchecked-example <" USING: pair-rocket prettyprint ;
+{ $unchecked-example """USING: pair-rocket prettyprint ;
-H{ "foo" => 1 "bar" => 2 } .
-"> <" H{ { "foo" 1 } { "bar" 2 } } "> }
+H{ "foo" => 1 "bar" => 2 } ."""
+"""H{ { "foo" 1 } { "bar" 2 } }""" }
}
;
! See http://factorcode.org/license.txt for BSD license.
!
USING: kernel tools.test peg peg.javascript.ast peg.javascript.parser
- accessors multiline sequences math peg.ebnf ;
+ accessors sequences math peg.ebnf ;
IN: peg.javascript.parser.tests
{
] unit-test
{ t } [
-<"
+"""
var x=5
var y=10
-"> main \ javascript rule (parse) remaining>> length zero?
+""" main \ javascript rule (parse) remaining>> length zero?
] unit-test
{ t } [
-<"
+"""
function foldl(f, initial, seq) {
for(var i=0; i< seq.length; ++i)
initial = f(initial, seq[i]);
return initial;
-}"> main \ javascript rule (parse) remaining>> length zero?
+}""" main \ javascript rule (parse) remaining>> length zero?
] unit-test
{ t } [
-<"
+"""
ParseState.prototype.from = function(index) {
var r = new ParseState(this.input, this.index + index);
r.cache = this.cache;
r.length = this.length - index;
return r;
-}"> main \ javascript rule (parse) remaining>> length zero?
+}""" main \ javascript rule (parse) remaining>> length zero?
] unit-test
! See http://factorcode.org/license.txt for BSD license.
!
USING: kernel tools.test peg peg.ebnf peg.pl0
- multiline sequences accessors ;
+ sequences accessors ;
IN: peg.pl0.tests
{ t } [
] unit-test
{ t } [
- <"
-VAR x, squ;
+"""VAR x, squ;
PROCEDURE square;
BEGIN
CALL square;
x := x + 1;
END
-END."> main \ pl0 rule (parse) remaining>> empty?
+END.""" main \ pl0 rule (parse) remaining>> empty?
] unit-test
{ f } [
- <"
+"""
CONST
m = 7,
n = 85;
y := 36;
CALL gcd;
END.
- "> main \ pl0 rule (parse) remaining>> empty?
-] unit-test
\ No newline at end of file
+""" main \ pl0 rule (parse) remaining>> empty?
+] unit-test
--- /dev/null
+USING: project-euler.072 tools.test ;
+IN: project-euler.072.tests
+
+[ 303963552391 ] [ euler072 ] unit-test
--- /dev/null
+! Copyright (c) 2009 Guillaume Nargeot.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel math math.primes.factors math.ranges
+project-euler.common sequences ;
+IN: project-euler.072
+
+! http://projecteuler.net/index.php?section=problems&id=072
+
+! DESCRIPTION
+! -----------
+
+! Consider the fraction, n/d, where n and d are positive integers.
+! If n<d and HCF(n,d)=1, it is called a reduced proper fraction.
+
+! If we list the set of reduced proper fractions for d ≤ 8 in ascending order
+! of size, we get:
+
+! 1/8, 1/7, 1/6, 1/5, 1/4, 2/7, 1/3, 3/8, 2/5, 3/7, 1/2, 4/7, 3/5, 5/8, 2/3,
+! 5/7, 3/4, 4/5, 5/6, 6/7, 7/8
+
+! It can be seen that there are 21 elements in this set.
+
+! How many elements would be contained in the set of reduced proper fractions
+! for d ≤ 1,000,000?
+
+
+! SOLUTION
+! --------
+
+! The answer can be found by adding totient(n) for 2 ≤ n ≤ 1e6
+
+: euler072 ( -- answer )
+ 2 1000000 [a,b] [ totient ] [ + ] map-reduce ;
+
+! [ euler072 ] 100 ave-time
+! 5274 ms ave run time - 102.7 SD (100 trials)
+
+SOLUTION: euler072
--- /dev/null
+USING: project-euler.074 tools.test ;
+IN: project-euler.074.tests
+
+[ 402 ] [ euler074 ] unit-test
--- /dev/null
+! Copyright (c) 2009 Guillaume Nargeot.
+! See http://factorcode.org/license.txt for BSD license.
+USING: assocs hashtables kernel math math.ranges
+project-euler.common sequences sets ;
+IN: project-euler.074
+
+! http://projecteuler.net/index.php?section=problems&id=074
+
+! DESCRIPTION
+! -----------
+
+! The number 145 is well known for the property that the sum of the factorial
+! of its digits is equal to 145:
+
+! 1! + 4! + 5! = 1 + 24 + 120 = 145
+
+! Perhaps less well known is 169, in that it produces the longest chain of
+! numbers that link back to 169; it turns out that there are only three such
+! loops that exist:
+
+! 169 → 363601 → 1454 → 169
+! 871 → 45361 → 871
+! 872 → 45362 → 872
+
+! It is not difficult to prove that EVERY starting number will eventually get
+! stuck in a loop. For example,
+
+! 69 → 363600 → 1454 → 169 → 363601 (→ 1454)
+! 78 → 45360 → 871 → 45361 (→ 871)
+! 540 → 145 (→ 145)
+
+! Starting with 69 produces a chain of five non-repeating terms, but the
+! longest non-repeating chain with a starting number below one million is sixty
+! terms.
+
+! How many chains, with a starting number below one million, contain exactly
+! sixty non-repeating terms?
+
+
+! SOLUTION
+! --------
+
+! Brute force
+
+<PRIVATE
+
+: digit-factorial ( n -- n! )
+ { 1 1 2 6 24 120 720 5040 40320 362880 } nth ;
+
+: digits-factorial-sum ( n -- n )
+ number>digits [ digit-factorial ] sigma ;
+
+: chain-length ( n -- n )
+ 61 <hashtable>
+ [ 2dup key? not ]
+ [ [ conjoin ] [ [ digits-factorial-sum ] dip ] 2bi ]
+ while nip assoc-size ;
+
+PRIVATE>
+
+: euler074 ( -- answer )
+ 1000000 [1,b] [ chain-length 60 = ] count ;
+
+! [ euler074 ] 10 ave-time
+! 25134 ms ave run time - 31.96 SD (10 trials)
+
+SOLUTION: euler074
+
! SOLUTION
! --------
-! A grid measuring x by y contains x * (x + 1) * y * (x + 1) rectangles.
+! A grid measuring x by y contains x * (x + 1) * y * (x + 1) / 4 rectangles.
<PRIVATE
area-of-nearest ;
! [ euler085 ] 100 ave-time
-! 2285 ms ave run time - 4.8 SD (100 trials)
+! 791 ms ave run time - 17.15 SD (100 trials)
SOLUTION: euler085
--- /dev/null
+USING: project-euler.124 tools.test ;
+IN: project-euler.124.tests
+
+[ 21417 ] [ euler124 ] unit-test
--- /dev/null
+! Copyright (c) 2009 Guillaume Nargeot.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays kernel math.primes.factors
+math.ranges project-euler.common sequences sorting ;
+IN: project-euler.124
+
+! http://projecteuler.net/index.php?section=problems&id=124
+
+! DESCRIPTION
+! -----------
+
+! The radical of n, rad(n), is the product of distinct prime factors of n.
+! For example, 504 = 2^3 × 3^2 × 7, so rad(504) = 2 × 3 × 7 = 42.
+
+! If we calculate rad(n) for 1 ≤ n ≤ 10, then sort them on rad(n),
+! and sorting on n if the radical values are equal, we get:
+
+! Unsorted Sorted
+! n rad(n) n rad(n) k
+! 1 1 1 1 1
+! 2 2 2 2 2
+! 3 3 4 2 3
+! 4 2 8 2 4
+! 5 5 3 3 5
+! 6 6 9 3 6
+! 7 7 5 5 7
+! 8 2 6 6 8
+! 9 3 7 7 9
+! 10 10 10 10 10
+
+! Let E(k) be the kth element in the sorted n column; for example,
+! E(4) = 8 and E(6) = 9.
+
+! If rad(n) is sorted for 1 ≤ n ≤ 100000, find E(10000).
+
+
+! SOLUTION
+! --------
+
+<PRIVATE
+
+: rad ( n -- n )
+ unique-factors product ; inline
+
+: rads-upto ( n -- seq )
+ [0,b] [ dup rad 2array ] map ;
+
+: (euler124) ( -- seq )
+ 100000 rads-upto sort-values ;
+
+PRIVATE>
+
+: euler124 ( -- answer )
+ 10000 (euler124) nth first ;
+
+! [ euler124 ] 100 ave-time
+! 373 ms ave run time - 17.61 SD (100 trials)
+
+! TODO: instead of the brute-force method, making the rad
+! array in the way of the sieve of eratosthene would scale
+! better on bigger values.
+
+SOLUTION: euler124
project-euler.049 project-euler.052 project-euler.053 project-euler.054
project-euler.055 project-euler.056 project-euler.057 project-euler.058
project-euler.059 project-euler.063 project-euler.067 project-euler.069
- project-euler.071 project-euler.073 project-euler.075 project-euler.076
- project-euler.079 project-euler.085 project-euler.092 project-euler.097
- project-euler.099 project-euler.100 project-euler.102 project-euler.112
- project-euler.116 project-euler.117 project-euler.134 project-euler.148
- project-euler.150 project-euler.151 project-euler.164 project-euler.169
- project-euler.173 project-euler.175 project-euler.186 project-euler.190
- project-euler.203 project-euler.215 ;
+ project-euler.071 project-euler.072 project-euler.073 project-euler.074
+ project-euler.075 project-euler.076 project-euler.079 project-euler.085
+ project-euler.092 project-euler.097 project-euler.099 project-euler.100
+ project-euler.102 project-euler.112 project-euler.116 project-euler.117
+ project-euler.124 project-euler.134 project-euler.148 project-euler.150
+ project-euler.151 project-euler.164 project-euler.169 project-euler.173
+ project-euler.175 project-euler.186 project-euler.190 project-euler.203
+ project-euler.215 ;
IN: project-euler
<PRIVATE
-USING: classes.struct cocoa core-foundation.strings ;
+USING: classes.struct cocoa cocoa.application cocoa.classes
+cocoa.enumeration cocoa.plists core-foundation.strings kernel ;
IN: qtkit
STRUCT: QTTime
IMPORT: QTSampleBuffer
IMPORT: QTTrack
+: <movie> ( filename -- movie )
+ QTMovie swap <NSString> f -> movieWithFile:error: -> retain ;
+
+: movie-attributes ( movie -- attributes )
+ -> movieAttributes plist> ;
+
+: play ( movie -- )
+ -> play ;
+: stop ( movie -- )
+ -> stop ;
+
+: movie-tracks ( movie -- tracks )
+ -> tracks NSFastEnumeration>vector ;
+
+: track-attributes ( track -- attributes )
+ -> trackAttributes plist> ;
{ $syntax "qw{ lorem ipsum }" }
{ $description "Marks the beginning of a literal array of strings. Component strings are delimited by whitespace." }
{ $examples
-{ $unchecked-example <" USING: prettyprint qw ;
-qw{ pop quiz my hive of big wild ex tranny jocks } . ">
-<" { "pop" "quiz" "my" "hive" "of" "big" "wild" "ex" "tranny" "jocks" } "> }
+{ $unchecked-example """USING: prettyprint qw ;
+qw{ pop quiz my hive of big wild ex tranny jocks } ."""
+"""{ "pop" "quiz" "my" "hive" "of" "big" "wild" "ex" "tranny" "jocks" }""" }
} ;
+
+ARTICLE: "qw" "Quoted words"
+"The " { $vocab-link "qw" } " vocabulary offers a shorthand syntax for arrays-of-strings literals." $nl
+"Construct an array of strings:"
+{ $subsection POSTPONE: qw{ } ;
+
+ABOUT: "qw"
IN: roles
HELP: ROLE:
-{ $syntax <" ROLE: name slots... ;
+{ $syntax """ROLE: name slots... ;
ROLE: name < role slots... ;
-ROLE: name <{ roles... } slots... ; "> }
+ROLE: name <{ roles... } slots... ;""" }
{ $description "Defines a new " { $link role } ". " { $link tuple } " classes which inherit this role will contain the specified " { $snippet "slots" } " as well as the slots associated with the optional inherited " { $snippet "roles" } "."
$nl
"Slot specifiers take one of the following three forms:"
"Slot attributes are lists of slot attribute specifiers followed by values; a slot attribute specifier is one of " { $link initial: } " or " { $link read-only } ". See " { $link "tuple-declarations" } " for details." } ;
HELP: TUPLE:
-{ $syntax <" TUPLE: name slots ;
+{ $syntax """TUPLE: name slots ;
TUPLE: name < estate slots ;
-TUPLE: name <{ estates... } slots... ; "> }
+TUPLE: name <{ estates... } slots... ;""" }
{ $description "Defines a new " { $link tuple } " class."
$nl
"The list of inherited " { $snippet "estates" } " is optional; a single tuple superclass and/or a set of " { $link role } "s can be specified. If no superclass is provided, it defaults to " { $link tuple } "."
--- /dev/null
+IN: rpn.tests
+USING: rpn lists tools.test ;
+
+[ { 2 } ] [ "4 2 -" rpn-parse rpn-eval list>array ] unit-test
\ No newline at end of file
GENERIC: eval-insn ( stack insn -- stack )
: binary-op ( stack quot: ( x y -- z ) -- stack )
- [ uncons uncons ] dip dip cons ; inline
+ [ uncons uncons [ swap ] dip ] dip dip cons ; inline
M: add-insn eval-insn drop [ + ] binary-op ;
M: sub-insn eval-insn drop [ - ] binary-op ;
: print-stack ( list -- )
[ number>string print ] leach ;
-: rpn-eval ( tokens -- )
- nil [ eval-insn ] foldl print-stack ;
+: rpn-eval ( tokens -- stack )
+ nil [ eval-insn ] foldl ;
: rpn ( -- )
"RPN> " write flush
- readln [ rpn-parse rpn-eval rpn ] when* ;
+ readln [ rpn-parse rpn-eval print-stack rpn ] when* ;
MAIN: rpn
! (c)2008 Joe Groff, see BSD license etc.
-USING: help.markup help.syntax kernel math multiline sequences ;
+USING: help.markup help.syntax kernel math sequences ;
IN: sequences.n-based
HELP: <n-based-assoc>
{ $values { "seq" sequence } { "base" integer } { "n-based-assoc" n-based-assoc } }
{ $description "Wraps " { $snippet "seq" } " in an " { $link n-based-assoc } " wrapper." }
{ $examples
-{ $example <"
+{ $example """
USING: assocs prettyprint kernel sequences.n-based ;
IN: scratchpad
} 1 <n-based-assoc> ;
10 months at .
-"> "\"October\"" } } ;
+""" "\"October\"" } } ;
HELP: n-based-assoc
{ $class-description "An adaptor class that allows a sequence to be treated as an assoc with non-zero-based keys." }
{ $examples
-{ $example <"
+{ $example """
USING: assocs prettyprint kernel sequences.n-based ;
IN: scratchpad
} 1 <n-based-assoc> ;
10 months at .
-"> "\"October\"" } } ;
+""" "\"October\"" } } ;
{ n-based-assoc <n-based-assoc> } related-words
! (c)2009 Joe Groff bsd license
-USING: help.markup help.syntax multiline quotations sequences ;
+USING: help.markup help.syntax quotations sequences ;
IN: sequences.product
HELP: product-sequence
{ $class-description "A class of virtual sequences that present the cartesian product of their underlying set of sequences. Product sequences are constructed with the " { $link <product-sequence> } " word." }
{ $examples
-{ $example <" USING: arrays prettyprint sequences.product ;
+{ $example """USING: arrays prettyprint sequences.product ;
{ { 1 2 3 } { "a" "b" "c" } } <product-sequence> >array .
-"> <" {
+""" """{
{ 1 "a" }
{ 2 "a" }
{ 3 "a" }
{ 1 "c" }
{ 2 "c" }
{ 3 "c" }
-}"> } } ;
+}""" } } ;
HELP: <product-sequence>
{ $values { "sequences" sequence } { "product-sequence" product-sequence } }
{ $description "Constructs a " { $link product-sequence } " over " { $snippet "sequences" } "." }
{ $examples
-{ $example <" USING: arrays prettyprint sequences.product ;
-{ { 1 2 3 } { "a" "b" "c" } } <product-sequence> >array .
-"> <" {
+{ $example """USING: arrays prettyprint sequences.product ;
+{ { 1 2 3 } { "a" "b" "c" } } <product-sequence> >array ."""
+"""{
{ 1 "a" }
{ 2 "a" }
{ 3 "a" }
{ 1 "c" }
{ 2 "c" }
{ 3 "c" }
-}"> } } ;
+}""" } } ;
{ product-sequence <product-sequence> } related-words
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: smtp namespaces accessors kernel arrays ;
+USING: smtp namespaces accessors kernel arrays site-watcher.db ;
IN: site-watcher.email
SYMBOL: site-watcher-from
pick [
[ <email> site-watcher-from get >>from ] 3dip
[ 1array >>to ] [ >>body ] [ >>subject ] tri* send-email
- ] [ 3drop ] if ;
\ No newline at end of file
+ ] [ 3drop ] if ;
{ wrap-margin 1100 }
}
}
- { code-style
+ { code-char-style
H{
{ font-name "monospace" }
{ font-size 36 }
+ }
+ }
+ { code-style
+ H{
{ page-color T{ rgba f 0.4 0.4 0.4 0.3 } }
}
}
{ T{ button-down } [ request-focus ] }
{ T{ key-down f f "DOWN" } [ next-page ] }
{ T{ key-down f f "UP" } [ prev-page ] }
+ { T{ key-down f f "f" } [ dup fullscreen? not set-fullscreen ] }
} set-gestures
: slides-window ( slides -- )
ARTICLE: "spider-tutorial" "Spider tutorial"
"To create a new spider, call the " { $link <spider> } " word with a link to the site you wish to spider."
-{ $code <" "http://concatenative.org" <spider> "> }
+{ $code """"http://concatenative.org" <spider>""" }
"The max-depth is initialized to 0, which retrieves just the initial page. Let's initialize it to something more fun:"
-{ $code <" 1 >>max-depth "> }
+{ $code """1 >>max-depth""" }
"Now the spider will retrieve the first page and all the pages it links to in the same domain." $nl
"But suppose the front page contains thousands of links. To avoid grabbing them all, we can set " { $slot "max-count" } " to a reasonable limit."
-{ $code <" 10 >>max-count "> }
+{ $code """10 >>max-count""" }
"A timeout might keep the spider from hitting the server too hard:"
-{ $code <" USE: calendar 1.5 seconds >>sleep "> }
+{ $code """USE: calendar 1.5 seconds >>sleep""" }
"Since we happen to know that not all pages of a wiki are suitable for spidering, we will spider only the wiki view pages, not the edit or revisions pages. To do this, we add a filter through which new links are tested; links that pass the filter are added to the todo queue, while links that do not are discarded. You can add several filters to the filter array, but we'll just add a single one for now."
-{ $code <" { [ path>> "/wiki/view" head? ] } >>filters "> }
+{ $code """{ [ path>> "/wiki/view" head? ] } >>filters""" }
"Finally, to start the spider, call the " { $link run-spider } " word."
{ $code "run-spider" }
"The full code from the tutorial."
-{ $code <" USING: spider calendar sequences accessors ;
+{ $code """USING: spider calendar sequences accessors ;
: spider-concatenative ( -- spider )
"http://concatenative.org" <spider>
1 >>max-depth
10 >>max-count
1.5 seconds >>sleep
{ [ path>> "/wiki/view" head? ] } >>filters
- run-spider ;"> } ;
+ run-spider ;""" } ;
ARTICLE: "spider" "Spider"
"The " { $vocab-link "spider" } " vocabulary implements a simple web spider for retrieving sets of webpages."
! (c)2009 Joe Groff, see BSD license
USING: accessors arrays literals math math.affine-transforms
-math.functions multiline sequences svg tools.test xml xml.traversal ;
+math.functions sequences svg tools.test xml xml.traversal multiline ;
IN: svg.tests
{ 1.0 2.25 } { -3.0 4.0 } { 5.5 0.5 } <affine-transform> 1array [
T{ elliptical-arc f { 5.0 6.0 } 7.0 t f { 8.0 9.0 } f }
} ] [
- <"
+ """
M 1.0,+1 3,-10e-1 l 2 2, 2 -2, 2 2 v -9 1 H 9 8 z
M 0 0 C -4.0 0.0 -8.0 4.0 -8.0 8.0 -8.0 4.0 -12.0 8.0 -16.0 8.0
s 0.0,2.0 2.0,0.0
Q -2 0 0 -2 -3. 0 0 3
t 1 2 3 4
A 5 6 7 1 0 8 9
- "> svg-path>array
+ """ svg-path>array
] unit-test
STRING: test-svg-string
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien.c-types combinators kernel locals math
math.ranges openal sequences sequences.merged specialized-arrays ;
+FROM: alien.c-types => short ;
SPECIALIZED-ARRAY: uchar
SPECIALIZED-ARRAY: short
IN: synth.buffers
+++ /dev/null
-Doug Coleman
+++ /dev/null
-Doug Coleman
+++ /dev/null
-! Copyright (C) 2008 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: system ;
-IN: system-info.backend
-
-HOOK: cpus os ( -- n )
-HOOK: cpu-mhz os ( -- n )
-HOOK: memory-load os ( -- n )
-HOOK: physical-mem os ( -- n )
-HOOK: available-mem os ( -- n )
-HOOK: total-page-file os ( -- n )
-HOOK: available-page-file os ( -- n )
-HOOK: total-virtual-mem os ( -- n )
-HOOK: available-virtual-mem os ( -- n )
-HOOK: available-virtual-extended-mem os ( -- n )
+++ /dev/null
-Doug Coleman
+++ /dev/null
-! Copyright (C) 2008 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: unix alien alien.c-types kernel math sequences strings
-io.backend.unix splitting io.encodings.utf8 io.encodings.string
-specialized-arrays ;
-SPECIALIZED-ARRAY: char
-IN: system-info.linux
-
-: (uname) ( buf -- int )
- "int" f "uname" { "char*" } alien-invoke ;
-
-: uname ( -- seq )
- 65536 <char-array> [ (uname) io-error ] keep
- "\0" split harvest [ utf8 decode ] map
- 6 "" pad-tail ;
-
-: sysname ( -- string ) uname first ;
-: nodename ( -- string ) uname second ;
-: release ( -- string ) uname third ;
-: version ( -- string ) uname fourth ;
-: machine ( -- string ) uname 4 swap nth ;
-: domainname ( -- string ) uname 5 swap nth ;
-
-: kernel-version ( -- seq )
- release ".-" split harvest 5 "" pad-tail ;
+++ /dev/null
-unportable
+++ /dev/null
-Doug Coleman
+++ /dev/null
-! Copyright (C) 2008 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.c-types alien.strings alien.syntax
-byte-arrays kernel namespaces sequences unix
-system-info.backend system io.encodings.utf8 ;
-IN: system-info.macosx
-
-! See /usr/include/sys/sysctl.h for constants
-
-LIBRARY: libc
-FUNCTION: int sysctl ( int* name, uint namelen, void* oldp, size_t* oldlenp, void* newp, size_t newlen ) ;
-
-: make-int-array ( seq -- byte-array )
- [ <int> ] map concat ;
-
-: (sysctl-query) ( name namelen oldp oldlenp -- oldp )
- over [ f 0 sysctl io-error ] dip ;
-
-: sysctl-query ( seq n -- byte-array )
- [ [ make-int-array ] [ length ] bi ] dip
- [ <byte-array> ] [ <uint> ] bi (sysctl-query) ;
-
-: sysctl-query-string ( seq -- n )
- 4096 sysctl-query utf8 alien>string ;
-
-: sysctl-query-uint ( seq -- n )
- 4 sysctl-query *uint ;
-
-: sysctl-query-ulonglong ( seq -- n )
- 8 sysctl-query *ulonglong ;
-
-: machine ( -- str ) { 6 1 } sysctl-query-string ;
-: model ( -- str ) { 6 2 } sysctl-query-string ;
-M: macosx cpus ( -- n ) { 6 3 } sysctl-query-uint ;
-: byte-order ( -- n ) { 6 4 } sysctl-query-uint ;
-M: macosx physical-mem ( -- n ) { 6 5 } sysctl-query-uint ;
-: user-mem ( -- n ) { 6 6 } sysctl-query-uint ;
-: page-size ( -- n ) { 6 7 } sysctl-query-uint ;
-: disknames ( -- n ) { 6 8 } 8 sysctl-query ;
-: diskstats ( -- n ) { 6 9 } 8 sysctl-query ;
-: epoch ( -- n ) { 6 10 } sysctl-query-uint ;
-: floating-point ( -- n ) { 6 11 } sysctl-query-uint ;
-: machine-arch ( -- n ) { 6 12 } sysctl-query-string ;
-: vector-unit ( -- n ) { 6 13 } sysctl-query-uint ;
-: bus-frequency ( -- n ) { 6 14 } sysctl-query-uint ;
-M: macosx cpu-mhz ( -- n ) { 6 15 } sysctl-query-uint ;
-: cacheline-size ( -- n ) { 6 16 } sysctl-query-uint ;
-: l1-icache-size ( -- n ) { 6 17 } sysctl-query-uint ;
-: l1-dcache-size ( -- n ) { 6 18 } sysctl-query-uint ;
-: l2-cache-settings ( -- n ) { 6 19 } sysctl-query-uint ;
-: l2-cache-size ( -- n ) { 6 20 } sysctl-query-uint ;
-: l3-cache-settings ( -- n ) { 6 21 } sysctl-query-uint ;
-: l3-cache-size ( -- n ) { 6 22 } sysctl-query-uint ;
-: tb-frequency ( -- n ) { 6 23 } sysctl-query-uint ;
-: mem-size ( -- n ) { 6 24 } sysctl-query-ulonglong ;
-: available-cpus ( -- n ) { 6 25 } sysctl-query-uint ;
+++ /dev/null
-unportable
+++ /dev/null
-Query the operating system for hardware information in a platform-independent way
+++ /dev/null
-! Copyright (C) 2008 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax kernel math prettyprint io math.parser
-combinators vocabs.loader system-info.backend system ;
-IN: system-info
-
-: write-unit ( x n str -- )
- [ 2^ /f number>string write bl ] [ write ] bi* ;
-
-: kb ( x -- ) 10 "kB" write-unit ;
-: megs ( x -- ) 20 "MB" write-unit ;
-: gigs ( x -- ) 30 "GB" write-unit ;
-: ghz ( x -- ) 1000000000 /f number>string write bl "GHz" write ;
-
-<< {
- { [ os windows? ] [ "system-info.windows" ] }
- { [ os linux? ] [ "system-info.linux" ] }
- { [ os macosx? ] [ "system-info.macosx" ] }
- [ f ]
-} cond [ require ] when* >>
-
-: system-report. ( -- )
- "CPUs: " write cpus number>string write nl
- "CPU Speed: " write cpu-mhz ghz nl
- "Physical RAM: " write physical-mem megs nl ;
+++ /dev/null
-Doug Coleman
+++ /dev/null
-Doug Coleman
+++ /dev/null
-! Copyright (C) 2008 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: alien.c-types system-info kernel math namespaces
-windows windows.kernel32 system-info.backend system ;
-IN: system-info.windows.ce
-
-: memory-status ( -- MEMORYSTATUS )
- "MEMORYSTATUS" <c-object>
- "MEMORYSTATUS" heap-size over set-MEMORYSTATUS-dwLength
- dup GlobalMemoryStatus ;
-
-M: wince cpus ( -- n ) 1 ;
-
-M: wince memory-load ( -- n )
- memory-status MEMORYSTATUS-dwMemoryLoad ;
-
-M: wince physical-mem ( -- n )
- memory-status MEMORYSTATUS-dwTotalPhys ;
-
-M: wince available-mem ( -- n )
- memory-status MEMORYSTATUS-dwAvailPhys ;
-
-M: wince total-page-file ( -- n )
- memory-status MEMORYSTATUS-dwTotalPageFile ;
-
-M: wince available-page-file ( -- n )
- memory-status MEMORYSTATUS-dwAvailPageFile ;
-
-M: wince total-virtual-mem ( -- n )
- memory-status MEMORYSTATUS-dwTotalVirtual ;
-
-M: wince available-virtual-mem ( -- n )
- memory-status MEMORYSTATUS-dwAvailVirtual ;
+++ /dev/null
-unportable
+++ /dev/null
-Doug Coleman
+++ /dev/null
-! Copyright (C) 2008 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.c-types alien.strings
-kernel libc math namespaces system-info.backend
-system-info.windows windows windows.advapi32
-windows.kernel32 system byte-arrays windows.errors
-classes classes.struct accessors ;
-IN: system-info.windows.nt
-
-M: winnt cpus ( -- n )
- system-info dwNumberOfProcessors>> ;
-
-: memory-status ( -- MEMORYSTATUSEX )
- "MEMORYSTATUSEX" <struct>
- dup class heap-size >>dwLength
- dup GlobalMemoryStatusEx win32-error=0/f ;
-
-M: winnt memory-load ( -- n )
- memory-status dwMemoryLoad>> ;
-
-M: winnt physical-mem ( -- n )
- memory-status ullTotalPhys>> ;
-
-M: winnt available-mem ( -- n )
- memory-status ullAvailPhys>> ;
-
-M: winnt total-page-file ( -- n )
- memory-status ullTotalPageFile>> ;
-
-M: winnt available-page-file ( -- n )
- memory-status ullAvailPageFile>> ;
-
-M: winnt total-virtual-mem ( -- n )
- memory-status ullTotalVirtual>> ;
-
-M: winnt available-virtual-mem ( -- n )
- memory-status ullAvailVirtual>> ;
-
-: computer-name ( -- string )
- MAX_COMPUTERNAME_LENGTH 1 +
- [ <byte-array> dup ] keep <uint>
- GetComputerName win32-error=0/f alien>native-string ;
-
-: username ( -- string )
- UNLEN 1 +
- [ <byte-array> dup ] keep <uint>
- GetUserName win32-error=0/f alien>native-string ;
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-! Copyright (C) 2008 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.c-types classes.struct accessors kernel
-math namespaces windows windows.kernel32 windows.advapi32 words
-combinators vocabs.loader system-info.backend system
-alien.strings windows.errors specialized-arrays ;
-SPECIALIZED-ARRAY: ushort
-IN: system-info.windows
-
-: system-info ( -- SYSTEM_INFO )
- SYSTEM_INFO <struct> [ GetSystemInfo ] keep ;
-
-: page-size ( -- n )
- system-info dwPageSize>> ;
-
-! 386, 486, 586, 2200 (IA64), 8664 (AMD_X8664)
-: processor-type ( -- n )
- system-info dwProcessorType>> ;
-
-! 0 = x86, 6 = Intel Itanium, 9 = x64 (AMD or Intel), 10 = WOW64, 0xffff = Unk
-: processor-architecture ( -- n )
- system-info dwOemId>> HEX: ffff0000 bitand ;
-
-: os-version ( -- os-version )
- OSVERSIONINFO <struct>
- OSVERSIONINFO heap-size >>dwOSVersionInfoSize
- dup GetVersionEx win32-error=0/f ;
-
-: windows-major ( -- n )
- os-version dwMajorVersion>> ;
-
-: windows-minor ( -- n )
- os-version dwMinorVersion>> ;
-
-: windows-build# ( -- n )
- os-version dwBuildNumber>> ;
-
-: windows-platform-id ( -- n )
- os-version dwPlatformId>> ;
-
-: windows-service-pack ( -- string )
- os-version szCSDVersion>> alien>native-string ;
-
-: feature-present? ( n -- ? )
- IsProcessorFeaturePresent zero? not ;
-
-: sse2? ( -- ? )
- PF_XMMI64_INSTRUCTIONS_AVAILABLE feature-present? ;
-
-: sse3? ( -- ? )
- PF_SSE3_INSTRUCTIONS_AVAILABLE feature-present? ;
-
-: get-directory ( word -- str )
- [ MAX_UNICODE_PATH [ <ushort-array> ] keep dupd ] dip
- execute win32-error=0/f alien>native-string ; inline
-
-: windows-directory ( -- str )
- \ GetWindowsDirectory get-directory ;
-
-: system-directory ( -- str )
- \ GetSystemDirectory get-directory ;
-
-: system-windows-directory ( -- str )
- \ GetSystemWindowsDirectory get-directory ;
-
-<<
-{
- { [ os wince? ] [ "system-info.windows.ce" ] }
- { [ os winnt? ] [ "system-info.windows.nt" ] }
-} cond require >>
{ $slide "First, some examples"
{ $code "3 weeks ago noon monday ." }
{ $code "USE: roman 2009 >roman ." }
- { $code <" : average ( seq -- x )
- [ sum ] [ length ] bi / ;"> }
+ { $code """: average ( seq -- x )
+ [ sum ] [ length ] bi / ;""" }
{ $code "1 miles [ km ] undo >float ." }
{ $code "[ readln eval>string print t ] loop" }
}
{ $slide "XML Literals"
{ $code
- <" USING: splitting xml.writer xml.syntax ;
+ """USING: splitting xml.writer xml.syntax ;
{ "one" "two" "three" }
[ [XML <item><-></item> XML] ] map
-<XML <doc><-></doc> XML> pprint-xml">
+<XML <doc><-></doc> XML> pprint-xml"""
}
}
{ $slide "Differences between Factor and Lisp"
}
{ $slide "Object system example: shape protocol"
"In ~/factor/work/shapes/shapes.factor"
- { $code <" IN: shapes
+ { $code """IN: shapes
GENERIC: area ( shape -- x )
-GENERIC: perimeter ( shape -- x )">
+GENERIC: perimeter ( shape -- x )"""
}
}
{ $slide "Implementing the shape protocol: circles"
"In ~/factor/work/shapes/circle/circle.factor"
- { $code <" USING: shapes constructors math
+ { $code """USING: shapes constructors math
math.constants ;
IN: shapes.circle
TUPLE: circle radius ;
CONSTRUCTOR: circle ( radius -- obj ) ;
M: circle area radius>> sq pi * ;
-M: circle perimeter radius>> pi * 2 * ;">
+M: circle perimeter radius>> pi * 2 * ;"""
}
}
{ $slide "Dynamic variables"
"Implemented as a stack of hashtables"
{ "Useful words are " { $link get } ", " { $link set } }
"Input, output, error streams are stored in dynamic variables"
- { $code <" "Today is the first day of the rest of your life."
+ { $code """"Today is the first day of the rest of your life."
[
readln print
-] with-string-reader">
+] with-string-reader"""
}
}
{ $slide "The global namespace"
"The global namespace is just the namespace at the bottom of the namespace stack"
{ "Useful words are " { $link get-global } ", " { $link set-global } }
"Factor idiom for changing a particular namespace"
- { $code <" SYMBOL: king
-global [ "Henry VIII" king set ] bind">
+ { $code """SYMBOL: king
+global [ "Henry VIII" king set ] bind"""
}
{ $code "with-scope" }
{ $code "namestack" }
}
{ $slide "Hooks"
"Dispatch on a dynamic variable"
- { $code <" HOOK: computer-name os ( -- string )
+ { $code """HOOK: computer-name os ( -- string )
M: macosx computer-name uname first ;
macosx \ os set-global
-computer-name">
+computer-name"""
}
}
{ $slide "Interpolate"
"Replaces variables in a string"
{ $code
-<" "Dawg" "name" set
+""""Dawg" "name" set
"rims" "noun" set
"bling" "verb1" set
"roll" "verb2" set
[
"Sup ${name}, we heard you liked ${noun}, so we put ${noun} on your car so you can ${verb1} while you ${verb2}."
interpolate
-] with-string-writer print ">
+] with-string-writer print """
}
}
{ $slide "Sequence protocol"
{ $slide "Specialized arrays code"
"One line per array/vector"
{ "In ~/factor/basis/specialized-arrays/float/float.factor"
- { $code <" << "float" define-array >>"> }
+ { $code """<< "float" define-array >>""" }
}
{ "In ~/factor/basis/specialized-vectors/float/float.factor"
- { $code <" << "float" define-vector >>"> }
+ { $code """<< "float" define-vector >>""" }
}
}
}
{ $slide "Functor for sorting"
{ $code
- <" FUNCTOR: define-sorting ( NAME QUOT -- )
+ """FUNCTOR: define-sorting ( NAME QUOT -- )
NAME<=> DEFINES ${NAME}<=>
NAME>=< DEFINES ${NAME}>=<
: NAME>=< ( obj1 obj2 -- >=< )
NAME<=> invert-comparison ;
-;FUNCTOR">
+;FUNCTOR"""
}
}
{ $slide "Example of sorting functor"
- { $code <" USING: sorting.functor ;
-<< "length" [ length ] define-sorting >>">
+ { $code """USING: sorting.functor ;
+<< "length" [ length ] define-sorting >>"""
}
{ $code
- <" { { 1 2 3 } { 1 2 } { 1 } }
-[ length<=> ] sort">
+ """{ { 1 2 3 } { 1 2 } { 1 } }
+[ length<=> ] sort"""
}
}
{ $slide "Combinators"
}
{ $slide "Control flow: if"
{ $link if }
- { $code <" 10 random dup even? [ 2 / ] [ 1 - ] if"> }
+ { $code """10 random dup even? [ 2 / ] [ 1 - ] if""" }
{ $link when }
- { $code <" 10 random dup even? [ 2 / ] when"> }
+ { $code """10 random dup even? [ 2 / ] when""" }
{ $link unless }
- { $code <" 10 random dup even? [ 1 - ] unless"> }
+ { $code """10 random dup even? [ 1 - ] unless""" }
}
{ $slide "Control flow: case"
{ $link case }
- { $code <" ERROR: not-possible obj ;
+ { $code """ERROR: not-possible obj ;
10 random 5 <=> {
{ +lt+ [ "Less" ] }
{ +gt+ [ "More" ] }
{ +eq+ [ "Equal" ] }
[ not-possible ]
-} case">
+} case"""
}
}
{ $slide "Fry"
{ $slide "Locals example"
"Area of a triangle using Heron's formula"
{ $code
- <" :: area ( a b c -- x )
+ """:: area ( a b c -- x )
a b c + + 2 / :> p
p
p a - *
p b - *
- p c - * sqrt ;">
+ p c - * sqrt ;"""
}
}
{ $slide "Previous example without locals"
"A bit unwieldy..."
{ $code
- <" : area ( a b c -- x )
+ """: area ( a b c -- x )
[ ] [ + + 2 / ] 3bi
[ '[ _ - ] tri@ ] [ neg ] bi
- * * * sqrt ;"> }
+ * * * sqrt ;""" }
}
{ $slide "More idiomatic version"
"But there's a trick: put the lengths in an array"
- { $code <" : v-n ( v n -- w ) '[ _ - ] map ;
+ { $code """: v-n ( v n -- w ) '[ _ - ] map ;
: area ( seq -- x )
[ 0 suffix ] [ sum 2 / ] bi
- v-n product sqrt ;"> }
+ v-n product sqrt ;""" }
}
{ $slide "Implementing an abstraction"
{ "Suppose we want to get the price of the customer's first order, but any one of the steps along the way could be a nil value (" { $link f } " in Factor):" }
}
{ $slide "This is hard with mainstream syntax!"
{ $code
- <" var customer = ...;
+ """var customer = ...;
var orders = (customer == null ? null : customer.orders);
var order = (orders == null ? null : orders[0]);
-var price = (order == null ? null : order.price);"> }
+var price = (order == null ? null : order.price);""" }
}
{ $slide "An ad-hoc solution"
"Something like..."
{ $slide "A macro solution"
"Returns a quotation to the compiler"
"Constructed using map, fry, and concat"
- { $code <" MACRO: plox ( seq -- quot )
+ { $code """MACRO: plox ( seq -- quot )
[
'[ dup _ when ]
- ] map [ ] concat-as ;">
+ ] map [ ] concat-as ;"""
}
}
{ $slide "Macro example"
"Return the caaar of a sequence"
{ "Return " { $snippet f } " on failure" }
- { $code <" : caaar ( seq/f -- x/f )
+ { $code """: caaar ( seq/f -- x/f )
{
[ first ]
[ first ]
[ first ]
- } plox ;">
+ } plox ;"""
}
- { $code <" { { f } } caaar"> }
- { $code <" { { { 1 2 3 } } } caaar"> }
+ { $code """{ { f } } caaar""" }
+ { $code """{ { { 1 2 3 } } } caaar""" }
}
{ $slide "Smart combinators"
"Use stack checker to infer inputs and outputs"
{ $slide "Fibonacci"
"Not tail recursive"
"Call tree is huge"
- { $code <" : fib ( n -- x )
+ { $code """: fib ( n -- x )
dup 1 <= [
[ 1 - fib ] [ 2 - fib ] bi +
- ] unless ;">
+ ] unless ;"""
}
{ $code "36 iota [ fib ] map ." }
}
{ $slide "Memoized Fibonacci"
"Change one word and it's efficient"
- { $code <" MEMO: fib ( n -- x )
+ { $code """MEMO: fib ( n -- x )
dup 1 <= [
[ 1 - fib ] [ 2 - fib ] bi +
- ] unless ;">
+ ] unless ;"""
}
{ $code "36 iota [ fib ] map ." }
}
{ $slide "Example in C"
{ $code
-<" void do_stuff()
+"""void do_stuff()
{
void *obj1, *obj2;
if(!(*obj1 = malloc(256))) goto end;
cleanup2: free(*obj2);
cleanup1: free(*obj1);
end: return;
-}">
+}"""
}
}
{ $slide "Example: allocating and disposing two buffers"
- { $code <" : do-stuff ( -- )
+ { $code """: do-stuff ( -- )
[
256 malloc &free
256 malloc &free
... work goes here ...
- ] with-destructors ;">
+ ] with-destructors ;"""
}
}
{ $slide "Example: allocating two buffers for later"
- { $code <" : do-stuff ( -- )
+ { $code """: do-stuff ( -- )
[
256 malloc |free
256 malloc |free
... work goes here ...
- ] with-destructors ;">
+ ] with-destructors ;"""
}
}
{ $slide "Example: disposing of an output port"
- { $code <" M: output-port dispose*
+ { $code """M: output-port dispose*
[
{
[ handle>> &dispose drop ]
[ port-flush ]
[ handle>> shutdown ]
} cleave
- ] with-destructors ;">
+ ] with-destructors ;"""
}
}
{ $slide "Rapid application development"
}
{ $slide "The essence of Factor"
"Nicely named words abstract away the stack, leaving readable code"
- { $code <" : surround ( seq left right -- seq' )
- swapd 3append ;">
+ { $code """: surround ( seq left right -- seq' )
+ swapd 3append ;"""
}
- { $code <" : glue ( left right middle -- seq' )
- swap 3append ;">
+ { $code """: glue ( left right middle -- seq' )
+ swap 3append ;"""
}
{ $code HEREDOC: xyz
"a" "b" "c" 3append
-"a" "<" ">" surround
+"a" """""""" surround
"a" "b" ", " glue
xyz
}
"Handles C structures, C types, callbacks"
"Used extensively in the Windows and Unix backends"
{ $code
- <" FUNCTION: double pow ( double x, double y ) ;
-2 5.0 pow .">
+ """FUNCTION: double pow ( double x, double y ) ;
+2 5.0 pow ."""
}
}
{ $slide "Windows win32 example"
{ $code
-<" M: windows gmt-offset
+"""M: windows gmt-offset
( -- hours minutes seconds )
"TIME_ZONE_INFORMATION" <c-object>
dup GetTimeZoneInformation {
{ TIME_ZONE_ID_STANDARD [
TIME_ZONE_INFORMATION-Bias
] }
- } case neg 60 /mod 0 ;">
+ } case neg 60 /mod 0 ;"""
}
}
{ $slide "Struct and function"
- { $code <" C-STRUCT: TIME_ZONE_INFORMATION
+ { $code """C-STRUCT: TIME_ZONE_INFORMATION
{ "LONG" "Bias" }
{ { "WCHAR" 32 } "StandardName" }
{ "SYSTEMTIME" "StandardDate" }
{ "LONG" "StandardBias" }
{ { "WCHAR" 32 } "DaylightName" }
{ "SYSTEMTIME" "DaylightDate" }
- { "LONG" "DaylightBias" } ;">
+ { "LONG" "DaylightBias" } ;"""
}
- { $code <" FUNCTION: DWORD GetTimeZoneInformation (
+ { $code """FUNCTION: DWORD GetTimeZoneInformation (
LPTIME_ZONE_INFORMATION
lpTimeZoneInformation
-) ;">
+) ;"""
}
}
{ $slide "Cocoa FFI"
- { $code <" IMPORT: NSAlert [
+ { $code """IMPORT: NSAlert [
NSAlert -> new
[ -> retain ] [
"Raptor" <CFString> &CFRelease
"Look out!" <CFString> &CFRelease
-> setInformativeText:
] tri -> runModal drop
-] with-destructors">
+] with-destructors"""
}
}
{ $slide "Deployment demo"
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types alien.libraries alien.syntax
combinators kernel system tokyo.alien.tchdb tokyo.alien.tcutil
-tokyo.alien.tctdb ;
+tokyo.alien.tctdb classes.struct ;
IN: tokyo.alien.tcrdb
<< "tokyotyrant" {
LIBRARY: tokyotyrant
TYPEDEF: void* TCRDB*
-! C-STRUCT: TCRDB
-! { "pthread_mutex_t" mmtx }
-! { "pthread_key_t" eckey }
-! { "char*" host }
-! { "int" port }
-! { "char*" expr }
-! { "int" fd }
-! { "TTSOCK*" sock }
-! { "double" timeout }
-! { "int" opts } ;
+! STRUCT: TCRDB
+! { mmtx pthread_mutex_t }
+! { eckey pthread_key_t }
+! { host char* }
+! { port int }
+! { expr char* }
+! { fd int }
+! { sock TTSOCK* }
+! { timeout double }
+! { opts int } ;
C-ENUM:
TTESUCCESS
CONSTANT: RDBITKEEP TDBITKEEP
TYPEDEF: void* RDBQRY*
-! C-STRUCT: RDBQRY
-! { "TCRDB*" rdb }
-! { "TCLIST*" args } ;
+! STRUCT: RDBQRY
+! { rdb TCRDB* }
+! { args TCLIST* } ;
CONSTANT: RDBQCSTREQ TDBQCSTREQ
CONSTANT: RDBQCSTRINC TDBQCSTRINC
IN: variants
HELP: VARIANT:
-{ $syntax <"
+{ $syntax """
VARIANT: class-name
singleton
singleton
.
.
.
- ; "> }
+ ; """ }
{ $description "Defines " { $snippet "class-name" } " as a union of the following " { $link singleton-class } " and " { $link tuple-class } " definitions. Each " { $snippet "singleton" } " word is defined as a " { $snippet "singleton-class" } ", and each " { $snippet "tuple" } " word is defined aas a " { $snippet "tuple-class" } " with the given set of " { $snippet "slot" } "s, using the same syntax for slot specifiers as " { $link POSTPONE: TUPLE: } ". Typed tuple slots can recursively reference the variant " { $snippet "class-name" } " being defined. For " { $snippet "tuple" } " types, a " { $link boa } " constructor word " { $snippet "<tuple>" } " is defined as well." }
-{ $examples { $code <"
+{ $examples { $code """
USING: kernel variants ;
IN: scratchpad
nil
cons: { { first object } { rest list } }
;
-"> } } ;
+""" } } ;
HELP: match
{ $values { "branches" array } }
{ $description "Dispatches on the type of the value on the top of the stack. If the type is a " { $link singleton-class } ", the corresponding quotation is called with the underlying stack unchanged. If the type is a " { $link tuple-class } ", the tuple slots are pushed onto the stack by order of arguments." }
-{ $examples { $example <"
+{ $examples { $example """
USING: kernel math prettyprint variants ;
IN: scratchpad
} match ;
1 2 3 4 nil <cons> <cons> <cons> <cons> list-length .
-"> "4" } } ;
+""" "4" } } ;
HELP: unboa
{ $values { "class" class } }
: init-production ( -- )
common-configuration
<vhost-dispatcher>
- <factor-website> <wiki> <login-config> <factor-boilerplate> "wiki" add-responder test-db <alloy> "concatenative.org" add-responder
+ <factor-website>
+ <wiki> "wiki" add-responder
+ <user-admin> "user-admin" add-responder
+ <login-config> <factor-boilerplate> test-db <alloy> "concatenative.org" add-responder
<pastebin> <login-config> <factor-boilerplate> test-db <alloy> "paste.factorcode.org" add-responder
<planet> <login-config> <factor-boilerplate> test-db <alloy> "planet.factorcode.org" add-responder
home "docs" append-path <help-webapp> test-db <alloy> "docs.factorcode.org" add-responder
nmap <silent> <Leader>fi :FactorVocabImpl<CR>
nmap <silent> <Leader>fd :FactorVocabDocs<CR>
nmap <silent> <Leader>ft :FactorVocabTests<CR>
+nmap <Leader>fv :FactorVocab<SPACE>
+nmap <Leader>fn :NewFactorVocab<SPACE>
if !exists("g:FactorRoot")
let g:FactorRoot = "~/factor"
/* gets the address of an object representing a C pointer, with the
intention of storing the pointer across code which may potentially GC. */
-char *pinned_alien_offset(cell obj)
+char *factorvm::pinned_alien_offset(cell obj)
{
switch(tagged<object>(obj).type())
{
}
/* make an alien */
-cell allot_alien(cell delegate_, cell displacement)
+cell factorvm::allot_alien(cell delegate_, cell displacement)
{
- gc_root<object> delegate(delegate_);
- gc_root<alien> new_alien(allot<alien>(sizeof(alien)));
+ gc_root<object> delegate(delegate_,this);
+ gc_root<alien> new_alien(allot<alien>(sizeof(alien)),this);
if(delegate.type_p(ALIEN_TYPE))
{
}
/* make an alien pointing at an offset of another alien */
-PRIMITIVE(displaced_alien)
+inline void factorvm::vmprim_displaced_alien()
{
cell alien = dpop();
cell displacement = to_cell(dpop());
}
}
+PRIMITIVE(displaced_alien)
+{
+ PRIMITIVE_GETVM()->vmprim_displaced_alien();
+}
+
/* address of an object representing a C pointer. Explicitly throw an error
if the object is a byte array, as a sanity check. */
-PRIMITIVE(alien_address)
+inline void factorvm::vmprim_alien_address()
{
box_unsigned_cell((cell)pinned_alien_offset(dpop()));
}
+PRIMITIVE(alien_address)
+{
+ PRIMITIVE_GETVM()->vmprim_alien_address();
+}
+
/* pop ( alien n ) from datastack, return alien's address plus n */
-static void *alien_pointer()
+void *factorvm::alien_pointer()
{
fixnum offset = to_fixnum(dpop());
return unbox_alien() + offset;
#define DEFINE_ALIEN_ACCESSOR(name,type,boxer,to) \
PRIMITIVE(alien_##name) \
{ \
- boxer(*(type*)alien_pointer()); \
+ PRIMITIVE_GETVM()->boxer(*(type*)PRIMITIVE_GETVM()->alien_pointer()); \
} \
PRIMITIVE(set_alien_##name) \
{ \
- type *ptr = (type *)alien_pointer(); \
- type value = to(dpop()); \
+ type *ptr = (type *)PRIMITIVE_GETVM()->alien_pointer(); \
+ type value = PRIMITIVE_GETVM()->to(dpop()); \
*ptr = value; \
}
DEFINE_ALIEN_ACCESSOR(cell,void *,box_alien,pinned_alien_offset)
/* open a native library and push a handle */
-PRIMITIVE(dlopen)
+inline void factorvm::vmprim_dlopen()
{
- gc_root<byte_array> path(dpop());
- path.untag_check();
- gc_root<dll> library(allot<dll>(sizeof(dll)));
+ gc_root<byte_array> path(dpop(),this);
+ path.untag_check(this);
+ gc_root<dll> library(allot<dll>(sizeof(dll)),this);
library->path = path.value();
ffi_dlopen(library.untagged());
dpush(library.value());
}
+PRIMITIVE(dlopen)
+{
+ PRIMITIVE_GETVM()->vmprim_dlopen();
+}
+
/* look up a symbol in a native library */
-PRIMITIVE(dlsym)
+inline void factorvm::vmprim_dlsym()
{
- gc_root<object> library(dpop());
- gc_root<byte_array> name(dpop());
- name.untag_check();
+ gc_root<object> library(dpop(),this);
+ gc_root<byte_array> name(dpop(),this);
+ name.untag_check(this);
symbol_char *sym = name->data<symbol_char>();
}
}
+PRIMITIVE(dlsym)
+{
+ PRIMITIVE_GETVM()->vmprim_dlsym();
+}
+
/* close a native library handle */
-PRIMITIVE(dlclose)
+inline void factorvm::vmprim_dlclose()
{
dll *d = untag_check<dll>(dpop());
if(d->dll != NULL)
ffi_dlclose(d);
}
-PRIMITIVE(dll_validp)
+PRIMITIVE(dlclose)
+{
+ PRIMITIVE_GETVM()->vmprim_dlclose();
+}
+
+inline void factorvm::vmprim_dll_validp()
{
cell library = dpop();
if(library == F)
dpush(untag_check<dll>(library)->dll == NULL ? F : T);
}
+PRIMITIVE(dll_validp)
+{
+ PRIMITIVE_GETVM()->vmprim_dll_validp();
+}
+
/* gets the address of an object representing a C pointer */
-VM_C_API char *alien_offset(cell obj)
+char *factorvm::alien_offset(cell obj)
{
switch(tagged<object>(obj).type())
{
}
}
+VM_C_API char *alien_offset(cell obj, factorvm *myvm)
+{
+ ASSERTVM();
+ return VM_PTR->alien_offset(obj);
+}
+
/* pop an object representing a C pointer */
-VM_C_API char *unbox_alien()
+char *factorvm::unbox_alien()
{
return alien_offset(dpop());
}
+VM_C_API char *unbox_alien(factorvm *myvm)
+{
+ ASSERTVM();
+ return VM_PTR->unbox_alien();
+}
+
/* make an alien and push */
-VM_C_API void box_alien(void *ptr)
+void factorvm::box_alien(void *ptr)
{
if(ptr == NULL)
dpush(F);
dpush(allot_alien(F,(cell)ptr));
}
+VM_C_API void box_alien(void *ptr, factorvm *myvm)
+{
+ ASSERTVM();
+ return VM_PTR->box_alien(ptr);
+}
+
/* for FFI calls passing structs by value */
-VM_C_API void to_value_struct(cell src, void *dest, cell size)
+void factorvm::to_value_struct(cell src, void *dest, cell size)
{
memcpy(dest,alien_offset(src),size);
}
+VM_C_API void to_value_struct(cell src, void *dest, cell size, factorvm *myvm)
+{
+ ASSERTVM();
+ return VM_PTR->to_value_struct(src,dest,size);
+}
+
/* for FFI callbacks receiving structs by value */
-VM_C_API void box_value_struct(void *src, cell size)
+void factorvm::box_value_struct(void *src, cell size)
{
byte_array *bytes = allot_byte_array(size);
memcpy(bytes->data<void>(),src,size);
dpush(tag<byte_array>(bytes));
}
+VM_C_API void box_value_struct(void *src, cell size,factorvm *myvm)
+{
+ ASSERTVM();
+ return VM_PTR->box_value_struct(src,size);
+}
+
/* On some x86 OSes, structs <= 8 bytes are returned in registers. */
-VM_C_API void box_small_struct(cell x, cell y, cell size)
+void factorvm::box_small_struct(cell x, cell y, cell size)
{
cell data[2];
data[0] = x;
box_value_struct(data,size);
}
+VM_C_API void box_small_struct(cell x, cell y, cell size, factorvm *myvm)
+{
+ ASSERTVM();
+ return VM_PTR->box_small_struct(x,y,size);
+}
+
/* On OS X/PPC, complex numbers are returned in registers. */
-VM_C_API void box_medium_struct(cell x1, cell x2, cell x3, cell x4, cell size)
+void factorvm::box_medium_struct(cell x1, cell x2, cell x3, cell x4, cell size)
{
cell data[4];
data[0] = x1;
box_value_struct(data,size);
}
+VM_C_API void box_medium_struct(cell x1, cell x2, cell x3, cell x4, cell size, factorvm *myvm)
+{
+ ASSERTVM();
+ return VM_PTR->box_medium_struct(x1, x2, x3, x4, size);
+}
+
+inline void factorvm::vmprim_vm_ptr()
+{
+ box_alien(this);
+}
+
+PRIMITIVE(vm_ptr)
+{
+ PRIMITIVE_GETVM()->vmprim_vm_ptr();
+}
+
}
namespace factor
{
-cell allot_alien(cell delegate, cell displacement);
-
PRIMITIVE(displaced_alien);
PRIMITIVE(alien_address);
PRIMITIVE(dlclose);
PRIMITIVE(dll_validp);
-VM_C_API char *alien_offset(cell object);
-VM_C_API char *unbox_alien();
-VM_C_API void box_alien(void *ptr);
-VM_C_API void to_value_struct(cell src, void *dest, cell size);
-VM_C_API void box_value_struct(void *src, cell size);
-VM_C_API void box_small_struct(cell x, cell y, cell size);
-VM_C_API void box_medium_struct(cell x1, cell x2, cell x3, cell x4, cell size);
+PRIMITIVE(vm_ptr);
+
+VM_C_API char *alien_offset(cell object, factorvm *vm);
+VM_C_API char *unbox_alien(factorvm *vm);
+VM_C_API void box_alien(void *ptr, factorvm *vm);
+VM_C_API void to_value_struct(cell src, void *dest, cell size, factorvm *vm);
+VM_C_API void box_value_struct(void *src, cell size,factorvm *vm);
+VM_C_API void box_small_struct(cell x, cell y, cell size,factorvm *vm);
+VM_C_API void box_medium_struct(cell x1, cell x2, cell x3, cell x4, cell size,factorvm *vm);
}
{
/* make a new array with an initial element */
-array *allot_array(cell capacity, cell fill_)
+array *factorvm::allot_array(cell capacity, cell fill_)
{
- gc_root<object> fill(fill_);
- gc_root<array> new_array(allot_array_internal<array>(capacity));
+ gc_root<object> fill(fill_,this);
+ gc_root<array> new_array(allot_array_internal<array>(capacity),this);
if(fill.value() == tag_fixnum(0))
memset(new_array->data(),'\0',capacity * sizeof(cell));
return new_array.untagged();
}
+
/* push a new array on the stack */
-PRIMITIVE(array)
+inline void factorvm::vmprim_array()
{
cell initial = dpop();
cell size = unbox_array_size();
dpush(tag<array>(allot_array(size,initial)));
}
-cell allot_array_1(cell obj_)
+PRIMITIVE(array)
{
- gc_root<object> obj(obj_);
- gc_root<array> a(allot_array_internal<array>(1));
+ PRIMITIVE_GETVM()->vmprim_array();
+}
+
+cell factorvm::allot_array_1(cell obj_)
+{
+ gc_root<object> obj(obj_,this);
+ gc_root<array> a(allot_array_internal<array>(1),this);
set_array_nth(a.untagged(),0,obj.value());
return a.value();
}
-cell allot_array_2(cell v1_, cell v2_)
+
+cell factorvm::allot_array_2(cell v1_, cell v2_)
{
- gc_root<object> v1(v1_);
- gc_root<object> v2(v2_);
- gc_root<array> a(allot_array_internal<array>(2));
+ gc_root<object> v1(v1_,this);
+ gc_root<object> v2(v2_,this);
+ gc_root<array> a(allot_array_internal<array>(2),this);
set_array_nth(a.untagged(),0,v1.value());
set_array_nth(a.untagged(),1,v2.value());
return a.value();
}
-cell allot_array_4(cell v1_, cell v2_, cell v3_, cell v4_)
+
+cell factorvm::allot_array_4(cell v1_, cell v2_, cell v3_, cell v4_)
{
- gc_root<object> v1(v1_);
- gc_root<object> v2(v2_);
- gc_root<object> v3(v3_);
- gc_root<object> v4(v4_);
- gc_root<array> a(allot_array_internal<array>(4));
+ gc_root<object> v1(v1_,this);
+ gc_root<object> v2(v2_,this);
+ gc_root<object> v3(v3_,this);
+ gc_root<object> v4(v4_,this);
+ gc_root<array> a(allot_array_internal<array>(4),this);
set_array_nth(a.untagged(),0,v1.value());
set_array_nth(a.untagged(),1,v2.value());
set_array_nth(a.untagged(),2,v3.value());
return a.value();
}
-PRIMITIVE(resize_array)
+
+inline void factorvm::vmprim_resize_array()
{
array* a = untag_check<array>(dpop());
cell capacity = unbox_array_size();
dpush(tag<array>(reallot_array(a,capacity)));
}
+PRIMITIVE(resize_array)
+{
+ PRIMITIVE_GETVM()->vmprim_resize_array();
+}
+
void growable_array::add(cell elt_)
{
- gc_root<object> elt(elt_);
+ factorvm* myvm = elements.myvm;
+ gc_root<object> elt(elt_,myvm);
if(count == array_capacity(elements.untagged()))
- elements = reallot_array(elements.untagged(),count * 2);
+ elements = myvm->reallot_array(elements.untagged(),count * 2);
- set_array_nth(elements.untagged(),count++,elt.value());
+ myvm->set_array_nth(elements.untagged(),count++,elt.value());
}
void growable_array::trim()
{
- elements = reallot_array(elements.untagged(),count);
+ factorvm *myvm = elements.myvm;
+ elements = myvm->reallot_array(elements.untagged(),count);
}
}
namespace factor
{
-inline static cell array_nth(array *array, cell slot)
+inline cell array_nth(array *array, cell slot)
{
#ifdef FACTOR_DEBUG
assert(slot < array_capacity(array));
return array->data()[slot];
}
-inline static void set_array_nth(array *array, cell slot, cell value)
-{
-#ifdef FACTOR_DEBUG
- assert(slot < array_capacity(array));
- assert(array->h.hi_tag() == ARRAY_TYPE);
- check_tagged_pointer(value);
-#endif
- array->data()[slot] = value;
- write_barrier(array);
-}
-
-array *allot_array(cell capacity, cell fill);
-
-cell allot_array_1(cell obj);
-cell allot_array_2(cell v1, cell v2);
-cell allot_array_4(cell v1, cell v2, cell v3, cell v4);
-
PRIMITIVE(array);
PRIMITIVE(resize_array);
-struct growable_array {
- cell count;
- gc_root<array> elements;
-
- growable_array(cell capacity = 10) : count(0), elements(allot_array(capacity,F)) {}
-
- void add(cell elt);
- void trim();
-};
}
/* :tabSize=2:indentSize=2:noTabs=true:
-Copyright (C) 1989-94 Massachusetts Institute of Technology
-Portions copyright (C) 2004-2008 Slava Pestov
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy and modify this software, to
-redistribute either the original software or a modified version, and
-to use this software for any purpose is granted, subject to the
-following restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. */
+ Copyright (C) 1989-94 Massachusetts Institute of Technology
+ Portions copyright (C) 2004-2008 Slava Pestov
+
+ This material was developed by the Scheme project at the Massachusetts
+ Institute of Technology, Department of Electrical Engineering and
+ Computer Science. Permission to copy and modify this software, to
+ redistribute either the original software or a modified version, and
+ to use this software for any purpose is granted, subject to the
+ following restrictions and understandings.
+
+ 1. Any copy made of this software must include this copyright notice
+ in full.
+
+ 2. Users of this software agree to make their best efforts (a) to
+ return to the MIT Scheme project any improvements or extensions that
+ they make, so that these may be included in future releases; and (b)
+ to inform MIT of noteworthy uses of this software.
+
+ 3. All materials developed as a consequence of the use of this
+ software shall duly acknowledge such use, in accordance with the usual
+ standards of acknowledging credit in academic research.
+
+ 4. MIT has made no warrantee or representation that the operation of
+ this software will be error-free, and MIT is under no obligation to
+ provide any services, by way of maintenance, update, or otherwise.
+
+ 5. In conjunction with products arising from the use of this material,
+ there shall be no use of the name of the Massachusetts Institute of
+ Technology nor of any adaptation thereof in any advertising,
+ promotional, or sales literature without prior written consent from
+ MIT in each case. */
/* Changes for Scheme 48:
* - Converted to ANSI.
/* Exports */
-int
-bignum_equal_p(bignum * x, bignum * y)
+int factorvm::bignum_equal_p(bignum * x, bignum * y)
{
- return
- ((BIGNUM_ZERO_P (x))
- ? (BIGNUM_ZERO_P (y))
- : ((! (BIGNUM_ZERO_P (y)))
- && ((BIGNUM_NEGATIVE_P (x))
- ? (BIGNUM_NEGATIVE_P (y))
- : (! (BIGNUM_NEGATIVE_P (y))))
- && (bignum_equal_p_unsigned (x, y))));
+ return
+ ((BIGNUM_ZERO_P (x))
+ ? (BIGNUM_ZERO_P (y))
+ : ((! (BIGNUM_ZERO_P (y)))
+ && ((BIGNUM_NEGATIVE_P (x))
+ ? (BIGNUM_NEGATIVE_P (y))
+ : (! (BIGNUM_NEGATIVE_P (y))))
+ && (bignum_equal_p_unsigned (x, y))));
}
-enum bignum_comparison
-bignum_compare(bignum * x, bignum * y)
+
+enum bignum_comparison factorvm::bignum_compare(bignum * x, bignum * y)
{
- return
- ((BIGNUM_ZERO_P (x))
- ? ((BIGNUM_ZERO_P (y))
- ? bignum_comparison_equal
- : (BIGNUM_NEGATIVE_P (y))
- ? bignum_comparison_greater
- : bignum_comparison_less)
- : (BIGNUM_ZERO_P (y))
- ? ((BIGNUM_NEGATIVE_P (x))
- ? bignum_comparison_less
- : bignum_comparison_greater)
- : (BIGNUM_NEGATIVE_P (x))
- ? ((BIGNUM_NEGATIVE_P (y))
- ? (bignum_compare_unsigned (y, x))
- : (bignum_comparison_less))
- : ((BIGNUM_NEGATIVE_P (y))
- ? (bignum_comparison_greater)
- : (bignum_compare_unsigned (x, y))));
+ return
+ ((BIGNUM_ZERO_P (x))
+ ? ((BIGNUM_ZERO_P (y))
+ ? bignum_comparison_equal
+ : (BIGNUM_NEGATIVE_P (y))
+ ? bignum_comparison_greater
+ : bignum_comparison_less)
+ : (BIGNUM_ZERO_P (y))
+ ? ((BIGNUM_NEGATIVE_P (x))
+ ? bignum_comparison_less
+ : bignum_comparison_greater)
+ : (BIGNUM_NEGATIVE_P (x))
+ ? ((BIGNUM_NEGATIVE_P (y))
+ ? (bignum_compare_unsigned (y, x))
+ : (bignum_comparison_less))
+ : ((BIGNUM_NEGATIVE_P (y))
+ ? (bignum_comparison_greater)
+ : (bignum_compare_unsigned (x, y))));
}
+
/* allocates memory */
-bignum *
-bignum_add(bignum * x, bignum * y)
+bignum *factorvm::bignum_add(bignum * x, bignum * y)
{
- return
- ((BIGNUM_ZERO_P (x))
- ? (y)
- : (BIGNUM_ZERO_P (y))
- ? (x)
- : ((BIGNUM_NEGATIVE_P (x))
- ? ((BIGNUM_NEGATIVE_P (y))
- ? (bignum_add_unsigned (x, y, 1))
- : (bignum_subtract_unsigned (y, x)))
- : ((BIGNUM_NEGATIVE_P (y))
- ? (bignum_subtract_unsigned (x, y))
- : (bignum_add_unsigned (x, y, 0)))));
+ return
+ ((BIGNUM_ZERO_P (x))
+ ? (y)
+ : (BIGNUM_ZERO_P (y))
+ ? (x)
+ : ((BIGNUM_NEGATIVE_P (x))
+ ? ((BIGNUM_NEGATIVE_P (y))
+ ? (bignum_add_unsigned (x, y, 1))
+ : (bignum_subtract_unsigned (y, x)))
+ : ((BIGNUM_NEGATIVE_P (y))
+ ? (bignum_subtract_unsigned (x, y))
+ : (bignum_add_unsigned (x, y, 0)))));
}
/* allocates memory */
-bignum *
-bignum_subtract(bignum * x, bignum * y)
+bignum *factorvm::bignum_subtract(bignum * x, bignum * y)
{
- return
- ((BIGNUM_ZERO_P (x))
- ? ((BIGNUM_ZERO_P (y))
- ? (y)
- : (bignum_new_sign (y, (! (BIGNUM_NEGATIVE_P (y))))))
- : ((BIGNUM_ZERO_P (y))
- ? (x)
- : ((BIGNUM_NEGATIVE_P (x))
- ? ((BIGNUM_NEGATIVE_P (y))
- ? (bignum_subtract_unsigned (y, x))
- : (bignum_add_unsigned (x, y, 1)))
- : ((BIGNUM_NEGATIVE_P (y))
- ? (bignum_add_unsigned (x, y, 0))
- : (bignum_subtract_unsigned (x, y))))));
+ return
+ ((BIGNUM_ZERO_P (x))
+ ? ((BIGNUM_ZERO_P (y))
+ ? (y)
+ : (bignum_new_sign (y, (! (BIGNUM_NEGATIVE_P (y))))))
+ : ((BIGNUM_ZERO_P (y))
+ ? (x)
+ : ((BIGNUM_NEGATIVE_P (x))
+ ? ((BIGNUM_NEGATIVE_P (y))
+ ? (bignum_subtract_unsigned (y, x))
+ : (bignum_add_unsigned (x, y, 1)))
+ : ((BIGNUM_NEGATIVE_P (y))
+ ? (bignum_add_unsigned (x, y, 0))
+ : (bignum_subtract_unsigned (x, y))))));
}
+
/* allocates memory */
-bignum *
-bignum_multiply(bignum * x, bignum * y)
+bignum *factorvm::bignum_multiply(bignum * x, bignum * y)
{
- bignum_length_type x_length = (BIGNUM_LENGTH (x));
- bignum_length_type y_length = (BIGNUM_LENGTH (y));
- int negative_p =
- ((BIGNUM_NEGATIVE_P (x))
- ? (! (BIGNUM_NEGATIVE_P (y)))
- : (BIGNUM_NEGATIVE_P (y)));
- if (BIGNUM_ZERO_P (x))
- return (x);
- if (BIGNUM_ZERO_P (y))
- return (y);
- if (x_length == 1)
- {
- bignum_digit_type digit = (BIGNUM_REF (x, 0));
- if (digit == 1)
- return (bignum_maybe_new_sign (y, negative_p));
- if (digit < BIGNUM_RADIX_ROOT)
- return (bignum_multiply_unsigned_small_factor (y, digit, negative_p));
- }
- if (y_length == 1)
- {
- bignum_digit_type digit = (BIGNUM_REF (y, 0));
- if (digit == 1)
- return (bignum_maybe_new_sign (x, negative_p));
- if (digit < BIGNUM_RADIX_ROOT)
- return (bignum_multiply_unsigned_small_factor (x, digit, negative_p));
- }
- return (bignum_multiply_unsigned (x, y, negative_p));
+ bignum_length_type x_length = (BIGNUM_LENGTH (x));
+ bignum_length_type y_length = (BIGNUM_LENGTH (y));
+ int negative_p =
+ ((BIGNUM_NEGATIVE_P (x))
+ ? (! (BIGNUM_NEGATIVE_P (y)))
+ : (BIGNUM_NEGATIVE_P (y)));
+ if (BIGNUM_ZERO_P (x))
+ return (x);
+ if (BIGNUM_ZERO_P (y))
+ return (y);
+ if (x_length == 1)
+ {
+ bignum_digit_type digit = (BIGNUM_REF (x, 0));
+ if (digit == 1)
+ return (bignum_maybe_new_sign (y, negative_p));
+ if (digit < BIGNUM_RADIX_ROOT)
+ return (bignum_multiply_unsigned_small_factor (y, digit, negative_p));
+ }
+ if (y_length == 1)
+ {
+ bignum_digit_type digit = (BIGNUM_REF (y, 0));
+ if (digit == 1)
+ return (bignum_maybe_new_sign (x, negative_p));
+ if (digit < BIGNUM_RADIX_ROOT)
+ return (bignum_multiply_unsigned_small_factor (x, digit, negative_p));
+ }
+ return (bignum_multiply_unsigned (x, y, negative_p));
}
+
/* allocates memory */
-void
-bignum_divide(bignum * numerator, bignum * denominator,
- bignum * * quotient, bignum * * remainder)
+void factorvm::bignum_divide(bignum * numerator, bignum * denominator, bignum * * quotient, bignum * * remainder)
{
- if (BIGNUM_ZERO_P (denominator))
- {
- divide_by_zero_error();
- return;
- }
- if (BIGNUM_ZERO_P (numerator))
- {
- (*quotient) = numerator;
- (*remainder) = numerator;
- }
- else
- {
- int r_negative_p = (BIGNUM_NEGATIVE_P (numerator));
- int q_negative_p =
- ((BIGNUM_NEGATIVE_P (denominator)) ? (! r_negative_p) : r_negative_p);
- switch (bignum_compare_unsigned (numerator, denominator))
- {
- case bignum_comparison_equal:
- {
- (*quotient) = (BIGNUM_ONE (q_negative_p));
- (*remainder) = (BIGNUM_ZERO ());
- break;
- }
- case bignum_comparison_less:
- {
- (*quotient) = (BIGNUM_ZERO ());
- (*remainder) = numerator;
- break;
- }
- case bignum_comparison_greater:
- {
- if ((BIGNUM_LENGTH (denominator)) == 1)
- {
- bignum_digit_type digit = (BIGNUM_REF (denominator, 0));
- if (digit == 1)
- {
- (*quotient) =
- (bignum_maybe_new_sign (numerator, q_negative_p));
- (*remainder) = (BIGNUM_ZERO ());
- break;
- }
- else if (digit < BIGNUM_RADIX_ROOT)
- {
- bignum_divide_unsigned_small_denominator
- (numerator, digit,
- quotient, remainder,
- q_negative_p, r_negative_p);
- break;
- }
- else
- {
- bignum_divide_unsigned_medium_denominator
- (numerator, digit,
- quotient, remainder,
- q_negative_p, r_negative_p);
- break;
- }
- }
- bignum_divide_unsigned_large_denominator
- (numerator, denominator,
- quotient, remainder,
- q_negative_p, r_negative_p);
- break;
- }
- }
- }
+ if (BIGNUM_ZERO_P (denominator))
+ {
+ divide_by_zero_error();
+ return;
+ }
+ if (BIGNUM_ZERO_P (numerator))
+ {
+ (*quotient) = numerator;
+ (*remainder) = numerator;
+ }
+ else
+ {
+ int r_negative_p = (BIGNUM_NEGATIVE_P (numerator));
+ int q_negative_p =
+ ((BIGNUM_NEGATIVE_P (denominator)) ? (! r_negative_p) : r_negative_p);
+ switch (bignum_compare_unsigned (numerator, denominator))
+ {
+ case bignum_comparison_equal:
+ {
+ (*quotient) = (BIGNUM_ONE (q_negative_p));
+ (*remainder) = (BIGNUM_ZERO ());
+ break;
+ }
+ case bignum_comparison_less:
+ {
+ (*quotient) = (BIGNUM_ZERO ());
+ (*remainder) = numerator;
+ break;
+ }
+ case bignum_comparison_greater:
+ {
+ if ((BIGNUM_LENGTH (denominator)) == 1)
+ {
+ bignum_digit_type digit = (BIGNUM_REF (denominator, 0));
+ if (digit == 1)
+ {
+ (*quotient) =
+ (bignum_maybe_new_sign (numerator, q_negative_p));
+ (*remainder) = (BIGNUM_ZERO ());
+ break;
+ }
+ else if (digit < BIGNUM_RADIX_ROOT)
+ {
+ bignum_divide_unsigned_small_denominator
+ (numerator, digit,
+ quotient, remainder,
+ q_negative_p, r_negative_p);
+ break;
+ }
+ else
+ {
+ bignum_divide_unsigned_medium_denominator
+ (numerator, digit,
+ quotient, remainder,
+ q_negative_p, r_negative_p);
+ break;
+ }
+ }
+ bignum_divide_unsigned_large_denominator
+ (numerator, denominator,
+ quotient, remainder,
+ q_negative_p, r_negative_p);
+ break;
+ }
+ }
+ }
}
+
/* allocates memory */
-bignum *
-bignum_quotient(bignum * numerator, bignum * denominator)
+bignum *factorvm::bignum_quotient(bignum * numerator, bignum * denominator)
{
- if (BIGNUM_ZERO_P (denominator))
- {
- divide_by_zero_error();
- return (BIGNUM_OUT_OF_BAND);
- }
- if (BIGNUM_ZERO_P (numerator))
- return numerator;
- {
- int q_negative_p =
- ((BIGNUM_NEGATIVE_P (denominator))
- ? (! (BIGNUM_NEGATIVE_P (numerator)))
- : (BIGNUM_NEGATIVE_P (numerator)));
- switch (bignum_compare_unsigned (numerator, denominator))
- {
- case bignum_comparison_equal:
- return (BIGNUM_ONE (q_negative_p));
- case bignum_comparison_less:
- return (BIGNUM_ZERO ());
- case bignum_comparison_greater:
- default: /* to appease gcc -Wall */
- {
- bignum * quotient;
- if ((BIGNUM_LENGTH (denominator)) == 1)
- {
- bignum_digit_type digit = (BIGNUM_REF (denominator, 0));
- if (digit == 1)
- return (bignum_maybe_new_sign (numerator, q_negative_p));
- if (digit < BIGNUM_RADIX_ROOT)
- bignum_divide_unsigned_small_denominator
- (numerator, digit,
- ("ient), ((bignum * *) 0),
- q_negative_p, 0);
- else
- bignum_divide_unsigned_medium_denominator
- (numerator, digit,
- ("ient), ((bignum * *) 0),
- q_negative_p, 0);
- }
- else
- bignum_divide_unsigned_large_denominator
- (numerator, denominator,
- ("ient), ((bignum * *) 0),
- q_negative_p, 0);
- return (quotient);
- }
- }
- }
+ if (BIGNUM_ZERO_P (denominator))
+ {
+ divide_by_zero_error();
+ return (BIGNUM_OUT_OF_BAND);
+ }
+ if (BIGNUM_ZERO_P (numerator))
+ return numerator;
+ {
+ int q_negative_p =
+ ((BIGNUM_NEGATIVE_P (denominator))
+ ? (! (BIGNUM_NEGATIVE_P (numerator)))
+ : (BIGNUM_NEGATIVE_P (numerator)));
+ switch (bignum_compare_unsigned (numerator, denominator))
+ {
+ case bignum_comparison_equal:
+ return (BIGNUM_ONE (q_negative_p));
+ case bignum_comparison_less:
+ return (BIGNUM_ZERO ());
+ case bignum_comparison_greater:
+ default: /* to appease gcc -Wall */
+ {
+ bignum * quotient;
+ if ((BIGNUM_LENGTH (denominator)) == 1)
+ {
+ bignum_digit_type digit = (BIGNUM_REF (denominator, 0));
+ if (digit == 1)
+ return (bignum_maybe_new_sign (numerator, q_negative_p));
+ if (digit < BIGNUM_RADIX_ROOT)
+ bignum_divide_unsigned_small_denominator
+ (numerator, digit,
+ ("ient), ((bignum * *) 0),
+ q_negative_p, 0);
+ else
+ bignum_divide_unsigned_medium_denominator
+ (numerator, digit,
+ ("ient), ((bignum * *) 0),
+ q_negative_p, 0);
+ }
+ else
+ bignum_divide_unsigned_large_denominator
+ (numerator, denominator,
+ ("ient), ((bignum * *) 0),
+ q_negative_p, 0);
+ return (quotient);
+ }
+ }
+ }
}
+
/* allocates memory */
-bignum *
-bignum_remainder(bignum * numerator, bignum * denominator)
+bignum *factorvm::bignum_remainder(bignum * numerator, bignum * denominator)
{
- if (BIGNUM_ZERO_P (denominator))
- {
- divide_by_zero_error();
- return (BIGNUM_OUT_OF_BAND);
- }
- if (BIGNUM_ZERO_P (numerator))
- return numerator;
- switch (bignum_compare_unsigned (numerator, denominator))
- {
- case bignum_comparison_equal:
- return (BIGNUM_ZERO ());
- case bignum_comparison_less:
- return numerator;
- case bignum_comparison_greater:
- default: /* to appease gcc -Wall */
- {
- bignum * remainder;
- if ((BIGNUM_LENGTH (denominator)) == 1)
- {
- bignum_digit_type digit = (BIGNUM_REF (denominator, 0));
- if (digit == 1)
- return (BIGNUM_ZERO ());
- if (digit < BIGNUM_RADIX_ROOT)
- return
- (bignum_remainder_unsigned_small_denominator
- (numerator, digit, (BIGNUM_NEGATIVE_P (numerator))));
- bignum_divide_unsigned_medium_denominator
- (numerator, digit,
- ((bignum * *) 0), (&remainder),
- 0, (BIGNUM_NEGATIVE_P (numerator)));
- }
- else
- bignum_divide_unsigned_large_denominator
- (numerator, denominator,
- ((bignum * *) 0), (&remainder),
- 0, (BIGNUM_NEGATIVE_P (numerator)));
- return (remainder);
- }
- }
+ if (BIGNUM_ZERO_P (denominator))
+ {
+ divide_by_zero_error();
+ return (BIGNUM_OUT_OF_BAND);
+ }
+ if (BIGNUM_ZERO_P (numerator))
+ return numerator;
+ switch (bignum_compare_unsigned (numerator, denominator))
+ {
+ case bignum_comparison_equal:
+ return (BIGNUM_ZERO ());
+ case bignum_comparison_less:
+ return numerator;
+ case bignum_comparison_greater:
+ default: /* to appease gcc -Wall */
+ {
+ bignum * remainder;
+ if ((BIGNUM_LENGTH (denominator)) == 1)
+ {
+ bignum_digit_type digit = (BIGNUM_REF (denominator, 0));
+ if (digit == 1)
+ return (BIGNUM_ZERO ());
+ if (digit < BIGNUM_RADIX_ROOT)
+ return
+ (bignum_remainder_unsigned_small_denominator
+ (numerator, digit, (BIGNUM_NEGATIVE_P (numerator))));
+ bignum_divide_unsigned_medium_denominator
+ (numerator, digit,
+ ((bignum * *) 0), (&remainder),
+ 0, (BIGNUM_NEGATIVE_P (numerator)));
+ }
+ else
+ bignum_divide_unsigned_large_denominator
+ (numerator, denominator,
+ ((bignum * *) 0), (&remainder),
+ 0, (BIGNUM_NEGATIVE_P (numerator)));
+ return (remainder);
+ }
+ }
}
-#define FOO_TO_BIGNUM(name,type,utype) \
- bignum * name##_to_bignum(type n) \
- { \
- int negative_p; \
- bignum_digit_type result_digits [BIGNUM_DIGITS_FOR(type)]; \
- bignum_digit_type * end_digits = result_digits; \
- /* Special cases win when these small constants are cached. */ \
- if (n == 0) return (BIGNUM_ZERO ()); \
- if (n == 1) return (BIGNUM_ONE (0)); \
- if (n < (type)0 && n == (type)-1) return (BIGNUM_ONE (1)); \
- { \
- utype accumulator = ((negative_p = (n < (type)0)) ? (-n) : n); \
- do \
- { \
- (*end_digits++) = (accumulator & BIGNUM_DIGIT_MASK); \
- accumulator >>= BIGNUM_DIGIT_LENGTH; \
- } \
- while (accumulator != 0); \
- } \
- { \
- bignum * result = \
- (allot_bignum ((end_digits - result_digits), negative_p)); \
- bignum_digit_type * scan_digits = result_digits; \
- bignum_digit_type * scan_result = (BIGNUM_START_PTR (result)); \
- while (scan_digits < end_digits) \
- (*scan_result++) = (*scan_digits++); \
- return (result); \
- } \
- }
+
+#define FOO_TO_BIGNUM(name,type,utype) \
+bignum * factorvm::name##_to_bignum(type n) \
+{ \
+ int negative_p; \
+ bignum_digit_type result_digits [BIGNUM_DIGITS_FOR(type)]; \
+ bignum_digit_type * end_digits = result_digits; \
+ /* Special cases win when these small constants are cached. */ \
+ if (n == 0) return (BIGNUM_ZERO ()); \
+ if (n == 1) return (BIGNUM_ONE (0)); \
+ if (n < (type)0 && n == (type)-1) return (BIGNUM_ONE (1)); \
+ { \
+ utype accumulator = ((negative_p = (n < (type)0)) ? (-n) : n); \
+ do \
+ { \
+ (*end_digits++) = (accumulator & BIGNUM_DIGIT_MASK); \
+ accumulator >>= BIGNUM_DIGIT_LENGTH; \
+ } \
+ while (accumulator != 0); \
+ } \
+ { \
+ bignum * result = \
+ (allot_bignum ((end_digits - result_digits), negative_p)); \
+ bignum_digit_type * scan_digits = result_digits; \
+ bignum_digit_type * scan_result = (BIGNUM_START_PTR (result)); \
+ while (scan_digits < end_digits) \
+ (*scan_result++) = (*scan_digits++); \
+ return (result); \
+ } \
+}
/* all below allocate memory */
FOO_TO_BIGNUM(cell,cell,cell)
FOO_TO_BIGNUM(long_long,s64,u64)
FOO_TO_BIGNUM(ulong_long,u64,u64)
-#define BIGNUM_TO_FOO(name,type,utype) \
- type bignum_to_##name(bignum * bignum) \
- { \
- if (BIGNUM_ZERO_P (bignum)) \
- return (0); \
- { \
- utype accumulator = 0; \
- bignum_digit_type * start = (BIGNUM_START_PTR (bignum)); \
- bignum_digit_type * scan = (start + (BIGNUM_LENGTH (bignum))); \
- while (start < scan) \
- accumulator = ((accumulator << BIGNUM_DIGIT_LENGTH) + (*--scan)); \
- return ((BIGNUM_NEGATIVE_P (bignum)) ? (-((type)accumulator)) : accumulator); \
- } \
- }
+#define BIGNUM_TO_FOO(name,type,utype) \
+ type factorvm::bignum_to_##name(bignum * bignum) \
+ { \
+ if (BIGNUM_ZERO_P (bignum)) \
+ return (0); \
+ { \
+ utype accumulator = 0; \
+ bignum_digit_type * start = (BIGNUM_START_PTR (bignum)); \
+ bignum_digit_type * scan = (start + (BIGNUM_LENGTH (bignum))); \
+ while (start < scan) \
+ accumulator = ((accumulator << BIGNUM_DIGIT_LENGTH) + (*--scan)); \
+ return ((BIGNUM_NEGATIVE_P (bignum)) ? (-((type)accumulator)) : accumulator); \
+ } \
+ }
/* all of the below allocate memory */
BIGNUM_TO_FOO(cell,cell,cell);
BIGNUM_TO_FOO(long_long,s64,u64)
BIGNUM_TO_FOO(ulong_long,u64,u64)
-double
-bignum_to_double(bignum * bignum)
+double factorvm::bignum_to_double(bignum * bignum)
{
- if (BIGNUM_ZERO_P (bignum))
- return (0);
- {
- double accumulator = 0;
- bignum_digit_type * start = (BIGNUM_START_PTR (bignum));
- bignum_digit_type * scan = (start + (BIGNUM_LENGTH (bignum)));
- while (start < scan)
- accumulator = ((accumulator * BIGNUM_RADIX) + (*--scan));
- return ((BIGNUM_NEGATIVE_P (bignum)) ? (-accumulator) : accumulator);
- }
+ if (BIGNUM_ZERO_P (bignum))
+ return (0);
+ {
+ double accumulator = 0;
+ bignum_digit_type * start = (BIGNUM_START_PTR (bignum));
+ bignum_digit_type * scan = (start + (BIGNUM_LENGTH (bignum)));
+ while (start < scan)
+ accumulator = ((accumulator * BIGNUM_RADIX) + (*--scan));
+ return ((BIGNUM_NEGATIVE_P (bignum)) ? (-accumulator) : accumulator);
+ }
}
-#define DTB_WRITE_DIGIT(factor) \
-{ \
- significand *= (factor); \
- digit = ((bignum_digit_type) significand); \
- (*--scan) = digit; \
- significand -= ((double) digit); \
+
+#define DTB_WRITE_DIGIT(factor) \
+{ \
+ significand *= (factor); \
+ digit = ((bignum_digit_type) significand); \
+ (*--scan) = digit; \
+ significand -= ((double) digit); \
}
/* allocates memory */
#define inf std::numeric_limits<double>::infinity()
-bignum *
-double_to_bignum(double x)
+bignum *factorvm::double_to_bignum(double x)
{
- if (x == inf || x == -inf || x != x) return (BIGNUM_ZERO ());
- int exponent;
- double significand = (frexp (x, (&exponent)));
- if (exponent <= 0) return (BIGNUM_ZERO ());
- if (exponent == 1) return (BIGNUM_ONE (x < 0));
- if (significand < 0) significand = (-significand);
- {
- bignum_length_type length = (BIGNUM_BITS_TO_DIGITS (exponent));
- bignum * result = (allot_bignum (length, (x < 0)));
- bignum_digit_type * start = (BIGNUM_START_PTR (result));
- bignum_digit_type * scan = (start + length);
- bignum_digit_type digit;
- int odd_bits = (exponent % BIGNUM_DIGIT_LENGTH);
- if (odd_bits > 0)
- DTB_WRITE_DIGIT ((fixnum)1 << odd_bits);
- while (start < scan)
- {
- if (significand == 0)
- {
- while (start < scan)
- (*--scan) = 0;
- break;
- }
- DTB_WRITE_DIGIT (BIGNUM_RADIX);
- }
- return (result);
- }
+ if (x == inf || x == -inf || x != x) return (BIGNUM_ZERO ());
+ int exponent;
+ double significand = (frexp (x, (&exponent)));
+ if (exponent <= 0) return (BIGNUM_ZERO ());
+ if (exponent == 1) return (BIGNUM_ONE (x < 0));
+ if (significand < 0) significand = (-significand);
+ {
+ bignum_length_type length = (BIGNUM_BITS_TO_DIGITS (exponent));
+ bignum * result = (allot_bignum (length, (x < 0)));
+ bignum_digit_type * start = (BIGNUM_START_PTR (result));
+ bignum_digit_type * scan = (start + length);
+ bignum_digit_type digit;
+ int odd_bits = (exponent % BIGNUM_DIGIT_LENGTH);
+ if (odd_bits > 0)
+ DTB_WRITE_DIGIT ((fixnum)1 << odd_bits);
+ while (start < scan)
+ {
+ if (significand == 0)
+ {
+ while (start < scan)
+ (*--scan) = 0;
+ break;
+ }
+ DTB_WRITE_DIGIT (BIGNUM_RADIX);
+ }
+ return (result);
+ }
}
+
#undef DTB_WRITE_DIGIT
/* Comparisons */
-int
-bignum_equal_p_unsigned(bignum * x, bignum * y)
+int factorvm::bignum_equal_p_unsigned(bignum * x, bignum * y)
{
- bignum_length_type length = (BIGNUM_LENGTH (x));
- if (length != (BIGNUM_LENGTH (y)))
- return (0);
- else
- {
- bignum_digit_type * scan_x = (BIGNUM_START_PTR (x));
- bignum_digit_type * scan_y = (BIGNUM_START_PTR (y));
- bignum_digit_type * end_x = (scan_x + length);
- while (scan_x < end_x)
- if ((*scan_x++) != (*scan_y++))
- return (0);
- return (1);
- }
+ bignum_length_type length = (BIGNUM_LENGTH (x));
+ if (length != (BIGNUM_LENGTH (y)))
+ return (0);
+ else
+ {
+ bignum_digit_type * scan_x = (BIGNUM_START_PTR (x));
+ bignum_digit_type * scan_y = (BIGNUM_START_PTR (y));
+ bignum_digit_type * end_x = (scan_x + length);
+ while (scan_x < end_x)
+ if ((*scan_x++) != (*scan_y++))
+ return (0);
+ return (1);
+ }
}
-enum bignum_comparison
-bignum_compare_unsigned(bignum * x, bignum * y)
+
+enum bignum_comparison factorvm::bignum_compare_unsigned(bignum * x, bignum * y)
{
- bignum_length_type x_length = (BIGNUM_LENGTH (x));
- bignum_length_type y_length = (BIGNUM_LENGTH (y));
- if (x_length < y_length)
- return (bignum_comparison_less);
- if (x_length > y_length)
- return (bignum_comparison_greater);
- {
- bignum_digit_type * start_x = (BIGNUM_START_PTR (x));
- bignum_digit_type * scan_x = (start_x + x_length);
- bignum_digit_type * scan_y = ((BIGNUM_START_PTR (y)) + y_length);
- while (start_x < scan_x)
- {
- bignum_digit_type digit_x = (*--scan_x);
- bignum_digit_type digit_y = (*--scan_y);
- if (digit_x < digit_y)
- return (bignum_comparison_less);
- if (digit_x > digit_y)
- return (bignum_comparison_greater);
- }
- }
- return (bignum_comparison_equal);
+ bignum_length_type x_length = (BIGNUM_LENGTH (x));
+ bignum_length_type y_length = (BIGNUM_LENGTH (y));
+ if (x_length < y_length)
+ return (bignum_comparison_less);
+ if (x_length > y_length)
+ return (bignum_comparison_greater);
+ {
+ bignum_digit_type * start_x = (BIGNUM_START_PTR (x));
+ bignum_digit_type * scan_x = (start_x + x_length);
+ bignum_digit_type * scan_y = ((BIGNUM_START_PTR (y)) + y_length);
+ while (start_x < scan_x)
+ {
+ bignum_digit_type digit_x = (*--scan_x);
+ bignum_digit_type digit_y = (*--scan_y);
+ if (digit_x < digit_y)
+ return (bignum_comparison_less);
+ if (digit_x > digit_y)
+ return (bignum_comparison_greater);
+ }
+ }
+ return (bignum_comparison_equal);
}
+
/* Addition */
/* allocates memory */
-bignum *
-bignum_add_unsigned(bignum * x, bignum * y, int negative_p)
+bignum *factorvm::bignum_add_unsigned(bignum * x, bignum * y, int negative_p)
{
- GC_BIGNUM(x); GC_BIGNUM(y);
-
- if ((BIGNUM_LENGTH (y)) > (BIGNUM_LENGTH (x)))
- {
- bignum * z = x;
- x = y;
- y = z;
- }
- {
- bignum_length_type x_length = (BIGNUM_LENGTH (x));
+ GC_BIGNUM(x,this); GC_BIGNUM(y,this);
+
+ if ((BIGNUM_LENGTH (y)) > (BIGNUM_LENGTH (x)))
+ {
+ bignum * z = x;
+ x = y;
+ y = z;
+ }
+ {
+ bignum_length_type x_length = (BIGNUM_LENGTH (x));
- bignum * r = (allot_bignum ((x_length + 1), negative_p));
-
- bignum_digit_type sum;
- bignum_digit_type carry = 0;
- bignum_digit_type * scan_x = (BIGNUM_START_PTR (x));
- bignum_digit_type * scan_r = (BIGNUM_START_PTR (r));
- {
- bignum_digit_type * scan_y = (BIGNUM_START_PTR (y));
- bignum_digit_type * end_y = (scan_y + (BIGNUM_LENGTH (y)));
- while (scan_y < end_y)
- {
- sum = ((*scan_x++) + (*scan_y++) + carry);
- if (sum < BIGNUM_RADIX)
- {
- (*scan_r++) = sum;
- carry = 0;
- }
- else
- {
- (*scan_r++) = (sum - BIGNUM_RADIX);
- carry = 1;
- }
- }
- }
- {
- bignum_digit_type * end_x = ((BIGNUM_START_PTR (x)) + x_length);
- if (carry != 0)
- while (scan_x < end_x)
- {
- sum = ((*scan_x++) + 1);
- if (sum < BIGNUM_RADIX)
- {
- (*scan_r++) = sum;
- carry = 0;
- break;
- }
- else
- (*scan_r++) = (sum - BIGNUM_RADIX);
- }
- while (scan_x < end_x)
- (*scan_r++) = (*scan_x++);
- }
- if (carry != 0)
- {
- (*scan_r) = 1;
- return (r);
- }
- return (bignum_shorten_length (r, x_length));
- }
+ bignum * r = (allot_bignum ((x_length + 1), negative_p));
+
+ bignum_digit_type sum;
+ bignum_digit_type carry = 0;
+ bignum_digit_type * scan_x = (BIGNUM_START_PTR (x));
+ bignum_digit_type * scan_r = (BIGNUM_START_PTR (r));
+ {
+ bignum_digit_type * scan_y = (BIGNUM_START_PTR (y));
+ bignum_digit_type * end_y = (scan_y + (BIGNUM_LENGTH (y)));
+ while (scan_y < end_y)
+ {
+ sum = ((*scan_x++) + (*scan_y++) + carry);
+ if (sum < BIGNUM_RADIX)
+ {
+ (*scan_r++) = sum;
+ carry = 0;
+ }
+ else
+ {
+ (*scan_r++) = (sum - BIGNUM_RADIX);
+ carry = 1;
+ }
+ }
+ }
+ {
+ bignum_digit_type * end_x = ((BIGNUM_START_PTR (x)) + x_length);
+ if (carry != 0)
+ while (scan_x < end_x)
+ {
+ sum = ((*scan_x++) + 1);
+ if (sum < BIGNUM_RADIX)
+ {
+ (*scan_r++) = sum;
+ carry = 0;
+ break;
+ }
+ else
+ (*scan_r++) = (sum - BIGNUM_RADIX);
+ }
+ while (scan_x < end_x)
+ (*scan_r++) = (*scan_x++);
+ }
+ if (carry != 0)
+ {
+ (*scan_r) = 1;
+ return (r);
+ }
+ return (bignum_shorten_length (r, x_length));
+ }
}
+
/* Subtraction */
/* allocates memory */
-bignum *
-bignum_subtract_unsigned(bignum * x, bignum * y)
+bignum *factorvm::bignum_subtract_unsigned(bignum * x, bignum * y)
{
- GC_BIGNUM(x); GC_BIGNUM(y);
+ GC_BIGNUM(x,this); GC_BIGNUM(y,this);
- int negative_p = 0;
- switch (bignum_compare_unsigned (x, y))
- {
- case bignum_comparison_equal:
- return (BIGNUM_ZERO ());
- case bignum_comparison_less:
- {
- bignum * z = x;
- x = y;
- y = z;
- }
- negative_p = 1;
- break;
- case bignum_comparison_greater:
- negative_p = 0;
- break;
- }
- {
- bignum_length_type x_length = (BIGNUM_LENGTH (x));
+ int negative_p = 0;
+ switch (bignum_compare_unsigned (x, y))
+ {
+ case bignum_comparison_equal:
+ return (BIGNUM_ZERO ());
+ case bignum_comparison_less:
+ {
+ bignum * z = x;
+ x = y;
+ y = z;
+ }
+ negative_p = 1;
+ break;
+ case bignum_comparison_greater:
+ negative_p = 0;
+ break;
+ }
+ {
+ bignum_length_type x_length = (BIGNUM_LENGTH (x));
- bignum * r = (allot_bignum (x_length, negative_p));
-
- bignum_digit_type difference;
- bignum_digit_type borrow = 0;
- bignum_digit_type * scan_x = (BIGNUM_START_PTR (x));
- bignum_digit_type * scan_r = (BIGNUM_START_PTR (r));
- {
- bignum_digit_type * scan_y = (BIGNUM_START_PTR (y));
- bignum_digit_type * end_y = (scan_y + (BIGNUM_LENGTH (y)));
- while (scan_y < end_y)
- {
- difference = (((*scan_x++) - (*scan_y++)) - borrow);
- if (difference < 0)
- {
- (*scan_r++) = (difference + BIGNUM_RADIX);
- borrow = 1;
- }
- else
- {
- (*scan_r++) = difference;
- borrow = 0;
- }
- }
- }
- {
- bignum_digit_type * end_x = ((BIGNUM_START_PTR (x)) + x_length);
- if (borrow != 0)
- while (scan_x < end_x)
- {
- difference = ((*scan_x++) - borrow);
- if (difference < 0)
- (*scan_r++) = (difference + BIGNUM_RADIX);
- else
- {
- (*scan_r++) = difference;
- borrow = 0;
- break;
- }
- }
- BIGNUM_ASSERT (borrow == 0);
- while (scan_x < end_x)
- (*scan_r++) = (*scan_x++);
- }
- return (bignum_trim (r));
- }
+ bignum * r = (allot_bignum (x_length, negative_p));
+
+ bignum_digit_type difference;
+ bignum_digit_type borrow = 0;
+ bignum_digit_type * scan_x = (BIGNUM_START_PTR (x));
+ bignum_digit_type * scan_r = (BIGNUM_START_PTR (r));
+ {
+ bignum_digit_type * scan_y = (BIGNUM_START_PTR (y));
+ bignum_digit_type * end_y = (scan_y + (BIGNUM_LENGTH (y)));
+ while (scan_y < end_y)
+ {
+ difference = (((*scan_x++) - (*scan_y++)) - borrow);
+ if (difference < 0)
+ {
+ (*scan_r++) = (difference + BIGNUM_RADIX);
+ borrow = 1;
+ }
+ else
+ {
+ (*scan_r++) = difference;
+ borrow = 0;
+ }
+ }
+ }
+ {
+ bignum_digit_type * end_x = ((BIGNUM_START_PTR (x)) + x_length);
+ if (borrow != 0)
+ while (scan_x < end_x)
+ {
+ difference = ((*scan_x++) - borrow);
+ if (difference < 0)
+ (*scan_r++) = (difference + BIGNUM_RADIX);
+ else
+ {
+ (*scan_r++) = difference;
+ borrow = 0;
+ break;
+ }
+ }
+ BIGNUM_ASSERT (borrow == 0);
+ while (scan_x < end_x)
+ (*scan_r++) = (*scan_x++);
+ }
+ return (bignum_trim (r));
+ }
}
+
/* Multiplication
Maximum value for product_low or product_high:
- ((R * R) + (R * (R - 2)) + (R - 1))
+ ((R * R) + (R * (R - 2)) + (R - 1))
Maximum value for carry: ((R * (R - 1)) + (R - 1))
- where R == BIGNUM_RADIX_ROOT */
+ where R == BIGNUM_RADIX_ROOT */
/* allocates memory */
-bignum *
-bignum_multiply_unsigned(bignum * x, bignum * y, int negative_p)
+bignum *factorvm::bignum_multiply_unsigned(bignum * x, bignum * y, int negative_p)
{
- GC_BIGNUM(x); GC_BIGNUM(y);
-
- if ((BIGNUM_LENGTH (y)) > (BIGNUM_LENGTH (x)))
- {
- bignum * z = x;
- x = y;
- y = z;
- }
- {
- bignum_digit_type carry;
- bignum_digit_type y_digit_low;
- bignum_digit_type y_digit_high;
- bignum_digit_type x_digit_low;
- bignum_digit_type x_digit_high;
- bignum_digit_type product_low;
- bignum_digit_type * scan_r;
- bignum_digit_type * scan_y;
- bignum_length_type x_length = (BIGNUM_LENGTH (x));
- bignum_length_type y_length = (BIGNUM_LENGTH (y));
-
- bignum * r =
- (allot_bignum_zeroed ((x_length + y_length), negative_p));
-
- bignum_digit_type * scan_x = (BIGNUM_START_PTR (x));
- bignum_digit_type * end_x = (scan_x + x_length);
- bignum_digit_type * start_y = (BIGNUM_START_PTR (y));
- bignum_digit_type * end_y = (start_y + y_length);
- bignum_digit_type * start_r = (BIGNUM_START_PTR (r));
+ GC_BIGNUM(x,this); GC_BIGNUM(y,this);
+
+ if ((BIGNUM_LENGTH (y)) > (BIGNUM_LENGTH (x)))
+ {
+ bignum * z = x;
+ x = y;
+ y = z;
+ }
+ {
+ bignum_digit_type carry;
+ bignum_digit_type y_digit_low;
+ bignum_digit_type y_digit_high;
+ bignum_digit_type x_digit_low;
+ bignum_digit_type x_digit_high;
+ bignum_digit_type product_low;
+ bignum_digit_type * scan_r;
+ bignum_digit_type * scan_y;
+ bignum_length_type x_length = (BIGNUM_LENGTH (x));
+ bignum_length_type y_length = (BIGNUM_LENGTH (y));
+
+ bignum * r =
+ (allot_bignum_zeroed ((x_length + y_length), negative_p));
+
+ bignum_digit_type * scan_x = (BIGNUM_START_PTR (x));
+ bignum_digit_type * end_x = (scan_x + x_length);
+ bignum_digit_type * start_y = (BIGNUM_START_PTR (y));
+ bignum_digit_type * end_y = (start_y + y_length);
+ bignum_digit_type * start_r = (BIGNUM_START_PTR (r));
#define x_digit x_digit_high
#define y_digit y_digit_high
#define product_high carry
- while (scan_x < end_x)
- {
- x_digit = (*scan_x++);
- x_digit_low = (HD_LOW (x_digit));
- x_digit_high = (HD_HIGH (x_digit));
- carry = 0;
- scan_y = start_y;
- scan_r = (start_r++);
- while (scan_y < end_y)
- {
- y_digit = (*scan_y++);
- y_digit_low = (HD_LOW (y_digit));
- y_digit_high = (HD_HIGH (y_digit));
- product_low =
- ((*scan_r) +
- (x_digit_low * y_digit_low) +
- (HD_LOW (carry)));
- product_high =
- ((x_digit_high * y_digit_low) +
- (x_digit_low * y_digit_high) +
- (HD_HIGH (product_low)) +
- (HD_HIGH (carry)));
- (*scan_r++) =
- (HD_CONS ((HD_LOW (product_high)), (HD_LOW (product_low))));
- carry =
- ((x_digit_high * y_digit_high) +
- (HD_HIGH (product_high)));
- }
- (*scan_r) += carry;
- }
- return (bignum_trim (r));
+ while (scan_x < end_x)
+ {
+ x_digit = (*scan_x++);
+ x_digit_low = (HD_LOW (x_digit));
+ x_digit_high = (HD_HIGH (x_digit));
+ carry = 0;
+ scan_y = start_y;
+ scan_r = (start_r++);
+ while (scan_y < end_y)
+ {
+ y_digit = (*scan_y++);
+ y_digit_low = (HD_LOW (y_digit));
+ y_digit_high = (HD_HIGH (y_digit));
+ product_low =
+ ((*scan_r) +
+ (x_digit_low * y_digit_low) +
+ (HD_LOW (carry)));
+ product_high =
+ ((x_digit_high * y_digit_low) +
+ (x_digit_low * y_digit_high) +
+ (HD_HIGH (product_low)) +
+ (HD_HIGH (carry)));
+ (*scan_r++) =
+ (HD_CONS ((HD_LOW (product_high)), (HD_LOW (product_low))));
+ carry =
+ ((x_digit_high * y_digit_high) +
+ (HD_HIGH (product_high)));
+ }
+ (*scan_r) += carry;
+ }
+ return (bignum_trim (r));
#undef x_digit
#undef y_digit
#undef product_high
- }
+ }
}
+
/* allocates memory */
-bignum *
-bignum_multiply_unsigned_small_factor(bignum * x, bignum_digit_type y,
- int negative_p)
+bignum *factorvm::bignum_multiply_unsigned_small_factor(bignum * x, bignum_digit_type y,int negative_p)
{
- GC_BIGNUM(x);
+ GC_BIGNUM(x,this);
- bignum_length_type length_x = (BIGNUM_LENGTH (x));
+ bignum_length_type length_x = (BIGNUM_LENGTH (x));
- bignum * p = (allot_bignum ((length_x + 1), negative_p));
+ bignum * p = (allot_bignum ((length_x + 1), negative_p));
- bignum_destructive_copy (x, p);
- (BIGNUM_REF (p, length_x)) = 0;
- bignum_destructive_scale_up (p, y);
- return (bignum_trim (p));
+ bignum_destructive_copy (x, p);
+ (BIGNUM_REF (p, length_x)) = 0;
+ bignum_destructive_scale_up (p, y);
+ return (bignum_trim (p));
}
-void
-bignum_destructive_add(bignum * bignum, bignum_digit_type n)
+
+void factorvm::bignum_destructive_add(bignum * bignum, bignum_digit_type n)
{
- bignum_digit_type * scan = (BIGNUM_START_PTR (bignum));
- bignum_digit_type digit;
- digit = ((*scan) + n);
- if (digit < BIGNUM_RADIX)
- {
- (*scan) = digit;
- return;
- }
- (*scan++) = (digit - BIGNUM_RADIX);
- while (1)
- {
- digit = ((*scan) + 1);
- if (digit < BIGNUM_RADIX)
- {
- (*scan) = digit;
- return;
- }
- (*scan++) = (digit - BIGNUM_RADIX);
- }
+ bignum_digit_type * scan = (BIGNUM_START_PTR (bignum));
+ bignum_digit_type digit;
+ digit = ((*scan) + n);
+ if (digit < BIGNUM_RADIX)
+ {
+ (*scan) = digit;
+ return;
+ }
+ (*scan++) = (digit - BIGNUM_RADIX);
+ while (1)
+ {
+ digit = ((*scan) + 1);
+ if (digit < BIGNUM_RADIX)
+ {
+ (*scan) = digit;
+ return;
+ }
+ (*scan++) = (digit - BIGNUM_RADIX);
+ }
}
-void
-bignum_destructive_scale_up(bignum * bignum, bignum_digit_type factor)
+
+void factorvm::bignum_destructive_scale_up(bignum * bignum, bignum_digit_type factor)
{
- bignum_digit_type carry = 0;
- bignum_digit_type * scan = (BIGNUM_START_PTR (bignum));
- bignum_digit_type two_digits;
- bignum_digit_type product_low;
+ bignum_digit_type carry = 0;
+ bignum_digit_type * scan = (BIGNUM_START_PTR (bignum));
+ bignum_digit_type two_digits;
+ bignum_digit_type product_low;
#define product_high carry
- bignum_digit_type * end = (scan + (BIGNUM_LENGTH (bignum)));
- BIGNUM_ASSERT ((factor > 1) && (factor < BIGNUM_RADIX_ROOT));
- while (scan < end)
- {
- two_digits = (*scan);
- product_low = ((factor * (HD_LOW (two_digits))) + (HD_LOW (carry)));
- product_high =
- ((factor * (HD_HIGH (two_digits))) +
- (HD_HIGH (product_low)) +
- (HD_HIGH (carry)));
- (*scan++) = (HD_CONS ((HD_LOW (product_high)), (HD_LOW (product_low))));
- carry = (HD_HIGH (product_high));
- }
- /* A carry here would be an overflow, i.e. it would not fit.
- Hopefully the callers allocate enough space that this will
- never happen.
- */
- BIGNUM_ASSERT (carry == 0);
- return;
+ bignum_digit_type * end = (scan + (BIGNUM_LENGTH (bignum)));
+ BIGNUM_ASSERT ((factor > 1) && (factor < BIGNUM_RADIX_ROOT));
+ while (scan < end)
+ {
+ two_digits = (*scan);
+ product_low = ((factor * (HD_LOW (two_digits))) + (HD_LOW (carry)));
+ product_high =
+ ((factor * (HD_HIGH (two_digits))) +
+ (HD_HIGH (product_low)) +
+ (HD_HIGH (carry)));
+ (*scan++) = (HD_CONS ((HD_LOW (product_high)), (HD_LOW (product_low))));
+ carry = (HD_HIGH (product_high));
+ }
+ /* A carry here would be an overflow, i.e. it would not fit.
+ Hopefully the callers allocate enough space that this will
+ never happen.
+ */
+ BIGNUM_ASSERT (carry == 0);
+ return;
#undef product_high
}
+
/* Division */
/* For help understanding this algorithm, see:
section 4.3.1, "Multiple-Precision Arithmetic". */
/* allocates memory */
-void
-bignum_divide_unsigned_large_denominator(bignum * numerator,
- bignum * denominator,
- bignum * * quotient,
- bignum * * remainder,
- int q_negative_p,
- int r_negative_p)
+void factorvm::bignum_divide_unsigned_large_denominator(bignum * numerator, bignum * denominator, bignum * * quotient, bignum * * remainder, int q_negative_p, int r_negative_p)
{
- GC_BIGNUM(numerator); GC_BIGNUM(denominator);
+ GC_BIGNUM(numerator,this); GC_BIGNUM(denominator,this);
- bignum_length_type length_n = ((BIGNUM_LENGTH (numerator)) + 1);
- bignum_length_type length_d = (BIGNUM_LENGTH (denominator));
-
- bignum * q =
- ((quotient != ((bignum * *) 0))
- ? (allot_bignum ((length_n - length_d), q_negative_p))
- : BIGNUM_OUT_OF_BAND);
- GC_BIGNUM(q);
+ bignum_length_type length_n = ((BIGNUM_LENGTH (numerator)) + 1);
+ bignum_length_type length_d = (BIGNUM_LENGTH (denominator));
+
+ bignum * q =
+ ((quotient != ((bignum * *) 0))
+ ? (allot_bignum ((length_n - length_d), q_negative_p))
+ : BIGNUM_OUT_OF_BAND);
+ GC_BIGNUM(q,this);
- bignum * u = (allot_bignum (length_n, r_negative_p));
- GC_BIGNUM(u);
+ bignum * u = (allot_bignum (length_n, r_negative_p));
+ GC_BIGNUM(u,this);
- int shift = 0;
- BIGNUM_ASSERT (length_d > 1);
- {
- bignum_digit_type v1 = (BIGNUM_REF ((denominator), (length_d - 1)));
- while (v1 < (BIGNUM_RADIX / 2))
- {
- v1 <<= 1;
- shift += 1;
- }
- }
- if (shift == 0)
- {
- bignum_destructive_copy (numerator, u);
- (BIGNUM_REF (u, (length_n - 1))) = 0;
- bignum_divide_unsigned_normalized (u, denominator, q);
- }
- else
- {
- bignum * v = (allot_bignum (length_d, 0));
-
- bignum_destructive_normalization (numerator, u, shift);
- bignum_destructive_normalization (denominator, v, shift);
- bignum_divide_unsigned_normalized (u, v, q);
- if (remainder != ((bignum * *) 0))
- bignum_destructive_unnormalization (u, shift);
- }
-
- if(q)
- q = bignum_trim (q);
-
- u = bignum_trim (u);
-
- if (quotient != ((bignum * *) 0))
- (*quotient) = q;
-
- if (remainder != ((bignum * *) 0))
- (*remainder) = u;
-
- return;
+ int shift = 0;
+ BIGNUM_ASSERT (length_d > 1);
+ {
+ bignum_digit_type v1 = (BIGNUM_REF ((denominator), (length_d - 1)));
+ while (v1 < (BIGNUM_RADIX / 2))
+ {
+ v1 <<= 1;
+ shift += 1;
+ }
+ }
+ if (shift == 0)
+ {
+ bignum_destructive_copy (numerator, u);
+ (BIGNUM_REF (u, (length_n - 1))) = 0;
+ bignum_divide_unsigned_normalized (u, denominator, q);
+ }
+ else
+ {
+ bignum * v = (allot_bignum (length_d, 0));
+
+ bignum_destructive_normalization (numerator, u, shift);
+ bignum_destructive_normalization (denominator, v, shift);
+ bignum_divide_unsigned_normalized (u, v, q);
+ if (remainder != ((bignum * *) 0))
+ bignum_destructive_unnormalization (u, shift);
+ }
+
+ if(q)
+ q = bignum_trim (q);
+
+ u = bignum_trim (u);
+
+ if (quotient != ((bignum * *) 0))
+ (*quotient) = q;
+
+ if (remainder != ((bignum * *) 0))
+ (*remainder) = u;
+
+ return;
}
-void
-bignum_divide_unsigned_normalized(bignum * u, bignum * v, bignum * q)
+
+void factorvm::bignum_divide_unsigned_normalized(bignum * u, bignum * v, bignum * q)
{
- bignum_length_type u_length = (BIGNUM_LENGTH (u));
- bignum_length_type v_length = (BIGNUM_LENGTH (v));
- bignum_digit_type * u_start = (BIGNUM_START_PTR (u));
- bignum_digit_type * u_scan = (u_start + u_length);
- bignum_digit_type * u_scan_limit = (u_start + v_length);
- bignum_digit_type * u_scan_start = (u_scan - v_length);
- bignum_digit_type * v_start = (BIGNUM_START_PTR (v));
- bignum_digit_type * v_end = (v_start + v_length);
- bignum_digit_type * q_scan = NULL;
- bignum_digit_type v1 = (v_end[-1]);
- bignum_digit_type v2 = (v_end[-2]);
- bignum_digit_type ph; /* high half of double-digit product */
- bignum_digit_type pl; /* low half of double-digit product */
- bignum_digit_type guess;
- bignum_digit_type gh; /* high half-digit of guess */
- bignum_digit_type ch; /* high half of double-digit comparand */
- bignum_digit_type v2l = (HD_LOW (v2));
- bignum_digit_type v2h = (HD_HIGH (v2));
- bignum_digit_type cl; /* low half of double-digit comparand */
+ bignum_length_type u_length = (BIGNUM_LENGTH (u));
+ bignum_length_type v_length = (BIGNUM_LENGTH (v));
+ bignum_digit_type * u_start = (BIGNUM_START_PTR (u));
+ bignum_digit_type * u_scan = (u_start + u_length);
+ bignum_digit_type * u_scan_limit = (u_start + v_length);
+ bignum_digit_type * u_scan_start = (u_scan - v_length);
+ bignum_digit_type * v_start = (BIGNUM_START_PTR (v));
+ bignum_digit_type * v_end = (v_start + v_length);
+ bignum_digit_type * q_scan = NULL;
+ bignum_digit_type v1 = (v_end[-1]);
+ bignum_digit_type v2 = (v_end[-2]);
+ bignum_digit_type ph; /* high half of double-digit product */
+ bignum_digit_type pl; /* low half of double-digit product */
+ bignum_digit_type guess;
+ bignum_digit_type gh; /* high half-digit of guess */
+ bignum_digit_type ch; /* high half of double-digit comparand */
+ bignum_digit_type v2l = (HD_LOW (v2));
+ bignum_digit_type v2h = (HD_HIGH (v2));
+ bignum_digit_type cl; /* low half of double-digit comparand */
#define gl ph /* low half-digit of guess */
#define uj pl
#define qj ph
- bignum_digit_type gm; /* memory loc for reference parameter */
- if (q != BIGNUM_OUT_OF_BAND)
- q_scan = ((BIGNUM_START_PTR (q)) + (BIGNUM_LENGTH (q)));
- while (u_scan_limit < u_scan)
- {
- uj = (*--u_scan);
- if (uj != v1)
- {
- /* comparand =
- (((((uj * BIGNUM_RADIX) + uj1) % v1) * BIGNUM_RADIX) + uj2);
- guess = (((uj * BIGNUM_RADIX) + uj1) / v1); */
- cl = (u_scan[-2]);
- ch = (bignum_digit_divide (uj, (u_scan[-1]), v1, (&gm)));
- guess = gm;
- }
- else
- {
- cl = (u_scan[-2]);
- ch = ((u_scan[-1]) + v1);
- guess = (BIGNUM_RADIX - 1);
- }
- while (1)
- {
- /* product = (guess * v2); */
- gl = (HD_LOW (guess));
- gh = (HD_HIGH (guess));
- pl = (v2l * gl);
- ph = ((v2l * gh) + (v2h * gl) + (HD_HIGH (pl)));
- pl = (HD_CONS ((HD_LOW (ph)), (HD_LOW (pl))));
- ph = ((v2h * gh) + (HD_HIGH (ph)));
- /* if (comparand >= product) */
- if ((ch > ph) || ((ch == ph) && (cl >= pl)))
- break;
- guess -= 1;
- /* comparand += (v1 << BIGNUM_DIGIT_LENGTH) */
- ch += v1;
- /* if (comparand >= (BIGNUM_RADIX * BIGNUM_RADIX)) */
- if (ch >= BIGNUM_RADIX)
- break;
- }
- qj = (bignum_divide_subtract (v_start, v_end, guess, (--u_scan_start)));
- if (q != BIGNUM_OUT_OF_BAND)
- (*--q_scan) = qj;
- }
- return;
+ bignum_digit_type gm; /* memory loc for reference parameter */
+ if (q != BIGNUM_OUT_OF_BAND)
+ q_scan = ((BIGNUM_START_PTR (q)) + (BIGNUM_LENGTH (q)));
+ while (u_scan_limit < u_scan)
+ {
+ uj = (*--u_scan);
+ if (uj != v1)
+ {
+ /* comparand =
+ (((((uj * BIGNUM_RADIX) + uj1) % v1) * BIGNUM_RADIX) + uj2);
+ guess = (((uj * BIGNUM_RADIX) + uj1) / v1); */
+ cl = (u_scan[-2]);
+ ch = (bignum_digit_divide (uj, (u_scan[-1]), v1, (&gm)));
+ guess = gm;
+ }
+ else
+ {
+ cl = (u_scan[-2]);
+ ch = ((u_scan[-1]) + v1);
+ guess = (BIGNUM_RADIX - 1);
+ }
+ while (1)
+ {
+ /* product = (guess * v2); */
+ gl = (HD_LOW (guess));
+ gh = (HD_HIGH (guess));
+ pl = (v2l * gl);
+ ph = ((v2l * gh) + (v2h * gl) + (HD_HIGH (pl)));
+ pl = (HD_CONS ((HD_LOW (ph)), (HD_LOW (pl))));
+ ph = ((v2h * gh) + (HD_HIGH (ph)));
+ /* if (comparand >= product) */
+ if ((ch > ph) || ((ch == ph) && (cl >= pl)))
+ break;
+ guess -= 1;
+ /* comparand += (v1 << BIGNUM_DIGIT_LENGTH) */
+ ch += v1;
+ /* if (comparand >= (BIGNUM_RADIX * BIGNUM_RADIX)) */
+ if (ch >= BIGNUM_RADIX)
+ break;
+ }
+ qj = (bignum_divide_subtract (v_start, v_end, guess, (--u_scan_start)));
+ if (q != BIGNUM_OUT_OF_BAND)
+ (*--q_scan) = qj;
+ }
+ return;
#undef gl
#undef uj
#undef qj
}
-bignum_digit_type
-bignum_divide_subtract(bignum_digit_type * v_start,
- bignum_digit_type * v_end,
- bignum_digit_type guess,
- bignum_digit_type * u_start)
+
+bignum_digit_type factorvm::bignum_divide_subtract(bignum_digit_type * v_start, bignum_digit_type * v_end, bignum_digit_type guess, bignum_digit_type * u_start)
{
- bignum_digit_type * v_scan = v_start;
- bignum_digit_type * u_scan = u_start;
- bignum_digit_type carry = 0;
- if (guess == 0) return (0);
- {
- bignum_digit_type gl = (HD_LOW (guess));
- bignum_digit_type gh = (HD_HIGH (guess));
- bignum_digit_type v;
- bignum_digit_type pl;
- bignum_digit_type vl;
+ bignum_digit_type * v_scan = v_start;
+ bignum_digit_type * u_scan = u_start;
+ bignum_digit_type carry = 0;
+ if (guess == 0) return (0);
+ {
+ bignum_digit_type gl = (HD_LOW (guess));
+ bignum_digit_type gh = (HD_HIGH (guess));
+ bignum_digit_type v;
+ bignum_digit_type pl;
+ bignum_digit_type vl;
#define vh v
#define ph carry
#define diff pl
- while (v_scan < v_end)
- {
- v = (*v_scan++);
- vl = (HD_LOW (v));
- vh = (HD_HIGH (v));
- pl = ((vl * gl) + (HD_LOW (carry)));
- ph = ((vl * gh) + (vh * gl) + (HD_HIGH (pl)) + (HD_HIGH (carry)));
- diff = ((*u_scan) - (HD_CONS ((HD_LOW (ph)), (HD_LOW (pl)))));
- if (diff < 0)
- {
- (*u_scan++) = (diff + BIGNUM_RADIX);
- carry = ((vh * gh) + (HD_HIGH (ph)) + 1);
- }
- else
- {
- (*u_scan++) = diff;
- carry = ((vh * gh) + (HD_HIGH (ph)));
- }
- }
- if (carry == 0)
- return (guess);
- diff = ((*u_scan) - carry);
- if (diff < 0)
- (*u_scan) = (diff + BIGNUM_RADIX);
- else
- {
- (*u_scan) = diff;
- return (guess);
- }
+ while (v_scan < v_end)
+ {
+ v = (*v_scan++);
+ vl = (HD_LOW (v));
+ vh = (HD_HIGH (v));
+ pl = ((vl * gl) + (HD_LOW (carry)));
+ ph = ((vl * gh) + (vh * gl) + (HD_HIGH (pl)) + (HD_HIGH (carry)));
+ diff = ((*u_scan) - (HD_CONS ((HD_LOW (ph)), (HD_LOW (pl)))));
+ if (diff < 0)
+ {
+ (*u_scan++) = (diff + BIGNUM_RADIX);
+ carry = ((vh * gh) + (HD_HIGH (ph)) + 1);
+ }
+ else
+ {
+ (*u_scan++) = diff;
+ carry = ((vh * gh) + (HD_HIGH (ph)));
+ }
+ }
+ if (carry == 0)
+ return (guess);
+ diff = ((*u_scan) - carry);
+ if (diff < 0)
+ (*u_scan) = (diff + BIGNUM_RADIX);
+ else
+ {
+ (*u_scan) = diff;
+ return (guess);
+ }
#undef vh
#undef ph
#undef diff
- }
- /* Subtraction generated carry, implying guess is one too large.
- Add v back in to bring it back down. */
- v_scan = v_start;
- u_scan = u_start;
- carry = 0;
- while (v_scan < v_end)
- {
- bignum_digit_type sum = ((*v_scan++) + (*u_scan) + carry);
- if (sum < BIGNUM_RADIX)
- {
- (*u_scan++) = sum;
- carry = 0;
- }
- else
- {
- (*u_scan++) = (sum - BIGNUM_RADIX);
- carry = 1;
- }
- }
- if (carry == 1)
- {
- bignum_digit_type sum = ((*u_scan) + carry);
- (*u_scan) = ((sum < BIGNUM_RADIX) ? sum : (sum - BIGNUM_RADIX));
- }
- return (guess - 1);
+ }
+ /* Subtraction generated carry, implying guess is one too large.
+ Add v back in to bring it back down. */
+ v_scan = v_start;
+ u_scan = u_start;
+ carry = 0;
+ while (v_scan < v_end)
+ {
+ bignum_digit_type sum = ((*v_scan++) + (*u_scan) + carry);
+ if (sum < BIGNUM_RADIX)
+ {
+ (*u_scan++) = sum;
+ carry = 0;
+ }
+ else
+ {
+ (*u_scan++) = (sum - BIGNUM_RADIX);
+ carry = 1;
+ }
+ }
+ if (carry == 1)
+ {
+ bignum_digit_type sum = ((*u_scan) + carry);
+ (*u_scan) = ((sum < BIGNUM_RADIX) ? sum : (sum - BIGNUM_RADIX));
+ }
+ return (guess - 1);
}
+
/* allocates memory */
-void
-bignum_divide_unsigned_medium_denominator(bignum * numerator,
- bignum_digit_type denominator,
- bignum * * quotient,
- bignum * * remainder,
- int q_negative_p,
- int r_negative_p)
+void factorvm::bignum_divide_unsigned_medium_denominator(bignum * numerator,bignum_digit_type denominator, bignum * * quotient, bignum * * remainder,int q_negative_p, int r_negative_p)
{
- GC_BIGNUM(numerator);
+ GC_BIGNUM(numerator,this);
- bignum_length_type length_n = (BIGNUM_LENGTH (numerator));
- bignum_length_type length_q;
- bignum * q = NULL;
- GC_BIGNUM(q);
+ bignum_length_type length_n = (BIGNUM_LENGTH (numerator));
+ bignum_length_type length_q;
+ bignum * q = NULL;
+ GC_BIGNUM(q,this);
- int shift = 0;
- /* Because `bignum_digit_divide' requires a normalized denominator. */
- while (denominator < (BIGNUM_RADIX / 2))
- {
- denominator <<= 1;
- shift += 1;
- }
- if (shift == 0)
- {
- length_q = length_n;
-
- q = (allot_bignum (length_q, q_negative_p));
- bignum_destructive_copy (numerator, q);
- }
- else
- {
- length_q = (length_n + 1);
-
- q = (allot_bignum (length_q, q_negative_p));
- bignum_destructive_normalization (numerator, q, shift);
- }
- {
- bignum_digit_type r = 0;
- bignum_digit_type * start = (BIGNUM_START_PTR (q));
- bignum_digit_type * scan = (start + length_q);
- bignum_digit_type qj;
-
- while (start < scan)
- {
- r = (bignum_digit_divide (r, (*--scan), denominator, (&qj)));
- (*scan) = qj;
- }
-
- q = bignum_trim (q);
-
- if (remainder != ((bignum * *) 0))
- {
- if (shift != 0)
- r >>= shift;
-
- (*remainder) = (bignum_digit_to_bignum (r, r_negative_p));
- }
-
- if (quotient != ((bignum * *) 0))
- (*quotient) = q;
- }
- return;
+ int shift = 0;
+ /* Because `bignum_digit_divide' requires a normalized denominator. */
+ while (denominator < (BIGNUM_RADIX / 2))
+ {
+ denominator <<= 1;
+ shift += 1;
+ }
+ if (shift == 0)
+ {
+ length_q = length_n;
+
+ q = (allot_bignum (length_q, q_negative_p));
+ bignum_destructive_copy (numerator, q);
+ }
+ else
+ {
+ length_q = (length_n + 1);
+
+ q = (allot_bignum (length_q, q_negative_p));
+ bignum_destructive_normalization (numerator, q, shift);
+ }
+ {
+ bignum_digit_type r = 0;
+ bignum_digit_type * start = (BIGNUM_START_PTR (q));
+ bignum_digit_type * scan = (start + length_q);
+ bignum_digit_type qj;
+
+ while (start < scan)
+ {
+ r = (bignum_digit_divide (r, (*--scan), denominator, (&qj)));
+ (*scan) = qj;
+ }
+
+ q = bignum_trim (q);
+
+ if (remainder != ((bignum * *) 0))
+ {
+ if (shift != 0)
+ r >>= shift;
+
+ (*remainder) = (bignum_digit_to_bignum (r, r_negative_p));
+ }
+
+ if (quotient != ((bignum * *) 0))
+ (*quotient) = q;
+ }
+ return;
}
-void
-bignum_destructive_normalization(bignum * source, bignum * target,
- int shift_left)
+
+void factorvm::bignum_destructive_normalization(bignum * source, bignum * target, int shift_left)
{
- bignum_digit_type digit;
- bignum_digit_type * scan_source = (BIGNUM_START_PTR (source));
- bignum_digit_type carry = 0;
- bignum_digit_type * scan_target = (BIGNUM_START_PTR (target));
- bignum_digit_type * end_source = (scan_source + (BIGNUM_LENGTH (source)));
- bignum_digit_type * end_target = (scan_target + (BIGNUM_LENGTH (target)));
- int shift_right = (BIGNUM_DIGIT_LENGTH - shift_left);
- bignum_digit_type mask = (((cell)1 << shift_right) - 1);
- while (scan_source < end_source)
- {
- digit = (*scan_source++);
- (*scan_target++) = (((digit & mask) << shift_left) | carry);
- carry = (digit >> shift_right);
- }
- if (scan_target < end_target)
- (*scan_target) = carry;
- else
- BIGNUM_ASSERT (carry == 0);
- return;
+ bignum_digit_type digit;
+ bignum_digit_type * scan_source = (BIGNUM_START_PTR (source));
+ bignum_digit_type carry = 0;
+ bignum_digit_type * scan_target = (BIGNUM_START_PTR (target));
+ bignum_digit_type * end_source = (scan_source + (BIGNUM_LENGTH (source)));
+ bignum_digit_type * end_target = (scan_target + (BIGNUM_LENGTH (target)));
+ int shift_right = (BIGNUM_DIGIT_LENGTH - shift_left);
+ bignum_digit_type mask = (((cell)1 << shift_right) - 1);
+ while (scan_source < end_source)
+ {
+ digit = (*scan_source++);
+ (*scan_target++) = (((digit & mask) << shift_left) | carry);
+ carry = (digit >> shift_right);
+ }
+ if (scan_target < end_target)
+ (*scan_target) = carry;
+ else
+ BIGNUM_ASSERT (carry == 0);
+ return;
}
-void
-bignum_destructive_unnormalization(bignum * bignum, int shift_right)
+
+void factorvm::bignum_destructive_unnormalization(bignum * bignum, int shift_right)
{
- bignum_digit_type * start = (BIGNUM_START_PTR (bignum));
- bignum_digit_type * scan = (start + (BIGNUM_LENGTH (bignum)));
- bignum_digit_type digit;
- bignum_digit_type carry = 0;
- int shift_left = (BIGNUM_DIGIT_LENGTH - shift_right);
- bignum_digit_type mask = (((fixnum)1 << shift_right) - 1);
- while (start < scan)
- {
- digit = (*--scan);
- (*scan) = ((digit >> shift_right) | carry);
- carry = ((digit & mask) << shift_left);
- }
- BIGNUM_ASSERT (carry == 0);
- return;
+ bignum_digit_type * start = (BIGNUM_START_PTR (bignum));
+ bignum_digit_type * scan = (start + (BIGNUM_LENGTH (bignum)));
+ bignum_digit_type digit;
+ bignum_digit_type carry = 0;
+ int shift_left = (BIGNUM_DIGIT_LENGTH - shift_right);
+ bignum_digit_type mask = (((fixnum)1 << shift_right) - 1);
+ while (start < scan)
+ {
+ digit = (*--scan);
+ (*scan) = ((digit >> shift_right) | carry);
+ carry = ((digit & mask) << shift_left);
+ }
+ BIGNUM_ASSERT (carry == 0);
+ return;
}
+
/* This is a reduced version of the division algorithm, applied to the
case of dividing two bignum digits by one bignum digit. It is
assumed that the numerator, denominator are normalized. */
-#define BDD_STEP(qn, j) \
-{ \
- uj = (u[j]); \
- if (uj != v1) \
- { \
- uj_uj1 = (HD_CONS (uj, (u[j + 1]))); \
- guess = (uj_uj1 / v1); \
- comparand = (HD_CONS ((uj_uj1 % v1), (u[j + 2]))); \
- } \
- else \
- { \
- guess = (BIGNUM_RADIX_ROOT - 1); \
- comparand = (HD_CONS (((u[j + 1]) + v1), (u[j + 2]))); \
- } \
- while ((guess * v2) > comparand) \
- { \
- guess -= 1; \
- comparand += (v1 << BIGNUM_HALF_DIGIT_LENGTH); \
- if (comparand >= BIGNUM_RADIX) \
- break; \
- } \
- qn = (bignum_digit_divide_subtract (v1, v2, guess, (&u[j]))); \
+#define BDD_STEP(qn, j) \
+{ \
+ uj = (u[j]); \
+ if (uj != v1) \
+ { \
+ uj_uj1 = (HD_CONS (uj, (u[j + 1]))); \
+ guess = (uj_uj1 / v1); \
+ comparand = (HD_CONS ((uj_uj1 % v1), (u[j + 2]))); \
+ } \
+ else \
+ { \
+ guess = (BIGNUM_RADIX_ROOT - 1); \
+ comparand = (HD_CONS (((u[j + 1]) + v1), (u[j + 2]))); \
+ } \
+ while ((guess * v2) > comparand) \
+ { \
+ guess -= 1; \
+ comparand += (v1 << BIGNUM_HALF_DIGIT_LENGTH); \
+ if (comparand >= BIGNUM_RADIX) \
+ break; \
+ } \
+ qn = (bignum_digit_divide_subtract (v1, v2, guess, (&u[j]))); \
}
-bignum_digit_type
-bignum_digit_divide(bignum_digit_type uh, bignum_digit_type ul,
- bignum_digit_type v,
- bignum_digit_type * q) /* return value */
+bignum_digit_type factorvm::bignum_digit_divide(bignum_digit_type uh, bignum_digit_type ul, bignum_digit_type v, bignum_digit_type * q) /* return value */
{
- bignum_digit_type guess;
- bignum_digit_type comparand;
- bignum_digit_type v1 = (HD_HIGH (v));
- bignum_digit_type v2 = (HD_LOW (v));
- bignum_digit_type uj;
- bignum_digit_type uj_uj1;
- bignum_digit_type q1;
- bignum_digit_type q2;
- bignum_digit_type u [4];
- if (uh == 0)
- {
- if (ul < v)
- {
- (*q) = 0;
- return (ul);
- }
- else if (ul == v)
- {
- (*q) = 1;
- return (0);
- }
- }
- (u[0]) = (HD_HIGH (uh));
- (u[1]) = (HD_LOW (uh));
- (u[2]) = (HD_HIGH (ul));
- (u[3]) = (HD_LOW (ul));
- v1 = (HD_HIGH (v));
- v2 = (HD_LOW (v));
- BDD_STEP (q1, 0);
- BDD_STEP (q2, 1);
- (*q) = (HD_CONS (q1, q2));
- return (HD_CONS ((u[2]), (u[3])));
+ bignum_digit_type guess;
+ bignum_digit_type comparand;
+ bignum_digit_type v1 = (HD_HIGH (v));
+ bignum_digit_type v2 = (HD_LOW (v));
+ bignum_digit_type uj;
+ bignum_digit_type uj_uj1;
+ bignum_digit_type q1;
+ bignum_digit_type q2;
+ bignum_digit_type u [4];
+ if (uh == 0)
+ {
+ if (ul < v)
+ {
+ (*q) = 0;
+ return (ul);
+ }
+ else if (ul == v)
+ {
+ (*q) = 1;
+ return (0);
+ }
+ }
+ (u[0]) = (HD_HIGH (uh));
+ (u[1]) = (HD_LOW (uh));
+ (u[2]) = (HD_HIGH (ul));
+ (u[3]) = (HD_LOW (ul));
+ v1 = (HD_HIGH (v));
+ v2 = (HD_LOW (v));
+ BDD_STEP (q1, 0);
+ BDD_STEP (q2, 1);
+ (*q) = (HD_CONS (q1, q2));
+ return (HD_CONS ((u[2]), (u[3])));
}
+
#undef BDD_STEP
-#define BDDS_MULSUB(vn, un, carry_in) \
-{ \
- product = ((vn * guess) + carry_in); \
- diff = (un - (HD_LOW (product))); \
- if (diff < 0) \
- { \
- un = (diff + BIGNUM_RADIX_ROOT); \
- carry = ((HD_HIGH (product)) + 1); \
- } \
- else \
- { \
- un = diff; \
- carry = (HD_HIGH (product)); \
- } \
+#define BDDS_MULSUB(vn, un, carry_in) \
+{ \
+ product = ((vn * guess) + carry_in); \
+ diff = (un - (HD_LOW (product))); \
+ if (diff < 0) \
+ { \
+ un = (diff + BIGNUM_RADIX_ROOT); \
+ carry = ((HD_HIGH (product)) + 1); \
+ } \
+ else \
+ { \
+ un = diff; \
+ carry = (HD_HIGH (product)); \
+ } \
}
-#define BDDS_ADD(vn, un, carry_in) \
-{ \
- sum = (vn + un + carry_in); \
- if (sum < BIGNUM_RADIX_ROOT) \
- { \
- un = sum; \
- carry = 0; \
- } \
- else \
- { \
- un = (sum - BIGNUM_RADIX_ROOT); \
- carry = 1; \
- } \
+#define BDDS_ADD(vn, un, carry_in) \
+{ \
+ sum = (vn + un + carry_in); \
+ if (sum < BIGNUM_RADIX_ROOT) \
+ { \
+ un = sum; \
+ carry = 0; \
+ } \
+ else \
+ { \
+ un = (sum - BIGNUM_RADIX_ROOT); \
+ carry = 1; \
+ } \
}
-bignum_digit_type
-bignum_digit_divide_subtract(bignum_digit_type v1, bignum_digit_type v2,
- bignum_digit_type guess, bignum_digit_type * u)
+bignum_digit_type factorvm::bignum_digit_divide_subtract(bignum_digit_type v1, bignum_digit_type v2, bignum_digit_type guess, bignum_digit_type * u)
{
- {
- bignum_digit_type product;
- bignum_digit_type diff;
- bignum_digit_type carry;
- BDDS_MULSUB (v2, (u[2]), 0);
- BDDS_MULSUB (v1, (u[1]), carry);
- if (carry == 0)
- return (guess);
- diff = ((u[0]) - carry);
- if (diff < 0)
- (u[0]) = (diff + BIGNUM_RADIX);
- else
- {
- (u[0]) = diff;
- return (guess);
- }
- }
- {
- bignum_digit_type sum;
- bignum_digit_type carry;
- BDDS_ADD(v2, (u[2]), 0);
- BDDS_ADD(v1, (u[1]), carry);
- if (carry == 1)
- (u[0]) += 1;
- }
- return (guess - 1);
+ {
+ bignum_digit_type product;
+ bignum_digit_type diff;
+ bignum_digit_type carry;
+ BDDS_MULSUB (v2, (u[2]), 0);
+ BDDS_MULSUB (v1, (u[1]), carry);
+ if (carry == 0)
+ return (guess);
+ diff = ((u[0]) - carry);
+ if (diff < 0)
+ (u[0]) = (diff + BIGNUM_RADIX);
+ else
+ {
+ (u[0]) = diff;
+ return (guess);
+ }
+ }
+ {
+ bignum_digit_type sum;
+ bignum_digit_type carry;
+ BDDS_ADD(v2, (u[2]), 0);
+ BDDS_ADD(v1, (u[1]), carry);
+ if (carry == 1)
+ (u[0]) += 1;
+ }
+ return (guess - 1);
}
+
#undef BDDS_MULSUB
#undef BDDS_ADD
/* allocates memory */
-void
-bignum_divide_unsigned_small_denominator(bignum * numerator,
- bignum_digit_type denominator,
- bignum * * quotient,
- bignum * * remainder,
- int q_negative_p,
- int r_negative_p)
+void factorvm::bignum_divide_unsigned_small_denominator(bignum * numerator, bignum_digit_type denominator, bignum * * quotient, bignum * * remainder,int q_negative_p, int r_negative_p)
{
- GC_BIGNUM(numerator);
+ GC_BIGNUM(numerator,this);
- bignum * q = (bignum_new_sign (numerator, q_negative_p));
- GC_BIGNUM(q);
+ bignum * q = (bignum_new_sign (numerator, q_negative_p));
+ GC_BIGNUM(q,this);
- bignum_digit_type r = (bignum_destructive_scale_down (q, denominator));
+ bignum_digit_type r = (bignum_destructive_scale_down (q, denominator));
- q = (bignum_trim (q));
+ q = (bignum_trim (q));
- if (remainder != ((bignum * *) 0))
- (*remainder) = (bignum_digit_to_bignum (r, r_negative_p));
+ if (remainder != ((bignum * *) 0))
+ (*remainder) = (bignum_digit_to_bignum (r, r_negative_p));
- (*quotient) = q;
+ (*quotient) = q;
- return;
+ return;
}
+
/* Given (denominator > 1), it is fairly easy to show that
(quotient_high < BIGNUM_RADIX_ROOT), after which it is easy to see
that all digits are < BIGNUM_RADIX. */
-bignum_digit_type
-bignum_destructive_scale_down(bignum * bignum, bignum_digit_type denominator)
+bignum_digit_type factorvm::bignum_destructive_scale_down(bignum * bignum, bignum_digit_type denominator)
{
- bignum_digit_type numerator;
- bignum_digit_type remainder = 0;
- bignum_digit_type two_digits;
+ bignum_digit_type numerator;
+ bignum_digit_type remainder = 0;
+ bignum_digit_type two_digits;
#define quotient_high remainder
- bignum_digit_type * start = (BIGNUM_START_PTR (bignum));
- bignum_digit_type * scan = (start + (BIGNUM_LENGTH (bignum)));
- BIGNUM_ASSERT ((denominator > 1) && (denominator < BIGNUM_RADIX_ROOT));
- while (start < scan)
- {
- two_digits = (*--scan);
- numerator = (HD_CONS (remainder, (HD_HIGH (two_digits))));
- quotient_high = (numerator / denominator);
- numerator = (HD_CONS ((numerator % denominator), (HD_LOW (two_digits))));
- (*scan) = (HD_CONS (quotient_high, (numerator / denominator)));
- remainder = (numerator % denominator);
- }
- return (remainder);
+ bignum_digit_type * start = (BIGNUM_START_PTR (bignum));
+ bignum_digit_type * scan = (start + (BIGNUM_LENGTH (bignum)));
+ BIGNUM_ASSERT ((denominator > 1) && (denominator < BIGNUM_RADIX_ROOT));
+ while (start < scan)
+ {
+ two_digits = (*--scan);
+ numerator = (HD_CONS (remainder, (HD_HIGH (two_digits))));
+ quotient_high = (numerator / denominator);
+ numerator = (HD_CONS ((numerator % denominator), (HD_LOW (two_digits))));
+ (*scan) = (HD_CONS (quotient_high, (numerator / denominator)));
+ remainder = (numerator % denominator);
+ }
+ return (remainder);
#undef quotient_high
}
+
/* allocates memory */
-bignum *
-bignum_remainder_unsigned_small_denominator(
- bignum * n, bignum_digit_type d, int negative_p)
+bignum * factorvm::bignum_remainder_unsigned_small_denominator(bignum * n, bignum_digit_type d, int negative_p)
{
- bignum_digit_type two_digits;
- bignum_digit_type * start = (BIGNUM_START_PTR (n));
- bignum_digit_type * scan = (start + (BIGNUM_LENGTH (n)));
- bignum_digit_type r = 0;
- BIGNUM_ASSERT ((d > 1) && (d < BIGNUM_RADIX_ROOT));
- while (start < scan)
- {
- two_digits = (*--scan);
- r =
- ((HD_CONS (((HD_CONS (r, (HD_HIGH (two_digits)))) % d),
- (HD_LOW (two_digits))))
- % d);
- }
- return (bignum_digit_to_bignum (r, negative_p));
+ bignum_digit_type two_digits;
+ bignum_digit_type * start = (BIGNUM_START_PTR (n));
+ bignum_digit_type * scan = (start + (BIGNUM_LENGTH (n)));
+ bignum_digit_type r = 0;
+ BIGNUM_ASSERT ((d > 1) && (d < BIGNUM_RADIX_ROOT));
+ while (start < scan)
+ {
+ two_digits = (*--scan);
+ r =
+ ((HD_CONS (((HD_CONS (r, (HD_HIGH (two_digits)))) % d),
+ (HD_LOW (two_digits))))
+ % d);
+ }
+ return (bignum_digit_to_bignum (r, negative_p));
}
+
/* allocates memory */
-bignum *
-bignum_digit_to_bignum(bignum_digit_type digit, int negative_p)
+bignum *factorvm::bignum_digit_to_bignum(bignum_digit_type digit, int negative_p)
{
- if (digit == 0)
- return (BIGNUM_ZERO ());
- else
- {
- bignum * result = (allot_bignum (1, negative_p));
- (BIGNUM_REF (result, 0)) = digit;
- return (result);
- }
+ if (digit == 0)
+ return (BIGNUM_ZERO ());
+ else
+ {
+ bignum * result = (allot_bignum (1, negative_p));
+ (BIGNUM_REF (result, 0)) = digit;
+ return (result);
+ }
}
+
/* allocates memory */
-bignum *
-allot_bignum(bignum_length_type length, int negative_p)
+bignum *factorvm::allot_bignum(bignum_length_type length, int negative_p)
{
- BIGNUM_ASSERT ((length >= 0) || (length < BIGNUM_RADIX));
- bignum * result = allot_array_internal<bignum>(length + 1);
- BIGNUM_SET_NEGATIVE_P (result, negative_p);
- return (result);
+ BIGNUM_ASSERT ((length >= 0) || (length < BIGNUM_RADIX));
+ bignum * result = allot_array_internal<bignum>(length + 1);
+ BIGNUM_SET_NEGATIVE_P (result, negative_p);
+ return (result);
}
+
/* allocates memory */
-bignum *
-allot_bignum_zeroed(bignum_length_type length, int negative_p)
+bignum * factorvm::allot_bignum_zeroed(bignum_length_type length, int negative_p)
{
- bignum * result = allot_bignum(length,negative_p);
- bignum_digit_type * scan = (BIGNUM_START_PTR (result));
- bignum_digit_type * end = (scan + length);
- while (scan < end)
- (*scan++) = 0;
- return (result);
+ bignum * result = allot_bignum(length,negative_p);
+ bignum_digit_type * scan = (BIGNUM_START_PTR (result));
+ bignum_digit_type * end = (scan + length);
+ while (scan < end)
+ (*scan++) = 0;
+ return (result);
}
-#define BIGNUM_REDUCE_LENGTH(source, length) \
- source = reallot_array(source,length + 1)
+
+#define BIGNUM_REDUCE_LENGTH(source, length) \
+source = reallot_array(source,length + 1)
/* allocates memory */
-bignum *
-bignum_shorten_length(bignum * bignum, bignum_length_type length)
+bignum *factorvm::bignum_shorten_length(bignum * bignum, bignum_length_type length)
{
- bignum_length_type current_length = (BIGNUM_LENGTH (bignum));
- BIGNUM_ASSERT ((length >= 0) || (length <= current_length));
- if (length < current_length)
- {
- BIGNUM_REDUCE_LENGTH (bignum, length);
- BIGNUM_SET_NEGATIVE_P (bignum, (length != 0) && (BIGNUM_NEGATIVE_P (bignum)));
- }
- return (bignum);
+ bignum_length_type current_length = (BIGNUM_LENGTH (bignum));
+ BIGNUM_ASSERT ((length >= 0) || (length <= current_length));
+ if (length < current_length)
+ {
+ BIGNUM_REDUCE_LENGTH (bignum, length);
+ BIGNUM_SET_NEGATIVE_P (bignum, (length != 0) && (BIGNUM_NEGATIVE_P (bignum)));
+ }
+ return (bignum);
}
+
/* allocates memory */
-bignum *
-bignum_trim(bignum * bignum)
+bignum *factorvm::bignum_trim(bignum * bignum)
{
- bignum_digit_type * start = (BIGNUM_START_PTR (bignum));
- bignum_digit_type * end = (start + (BIGNUM_LENGTH (bignum)));
- bignum_digit_type * scan = end;
- while ((start <= scan) && ((*--scan) == 0))
- ;
- scan += 1;
- if (scan < end)
- {
- bignum_length_type length = (scan - start);
- BIGNUM_REDUCE_LENGTH (bignum, length);
- BIGNUM_SET_NEGATIVE_P (bignum, (length != 0) && (BIGNUM_NEGATIVE_P (bignum)));
- }
- return (bignum);
+ bignum_digit_type * start = (BIGNUM_START_PTR (bignum));
+ bignum_digit_type * end = (start + (BIGNUM_LENGTH (bignum)));
+ bignum_digit_type * scan = end;
+ while ((start <= scan) && ((*--scan) == 0))
+ ;
+ scan += 1;
+ if (scan < end)
+ {
+ bignum_length_type length = (scan - start);
+ BIGNUM_REDUCE_LENGTH (bignum, length);
+ BIGNUM_SET_NEGATIVE_P (bignum, (length != 0) && (BIGNUM_NEGATIVE_P (bignum)));
+ }
+ return (bignum);
}
+
/* Copying */
/* allocates memory */
-bignum *
-bignum_new_sign(bignum * x, int negative_p)
+bignum *factorvm::bignum_new_sign(bignum * x, int negative_p)
{
- GC_BIGNUM(x);
- bignum * result = (allot_bignum ((BIGNUM_LENGTH (x)), negative_p));
+ GC_BIGNUM(x,this);
+ bignum * result = (allot_bignum ((BIGNUM_LENGTH (x)), negative_p));
- bignum_destructive_copy (x, result);
- return (result);
+ bignum_destructive_copy (x, result);
+ return (result);
}
+
/* allocates memory */
-bignum *
-bignum_maybe_new_sign(bignum * x, int negative_p)
+bignum *factorvm::bignum_maybe_new_sign(bignum * x, int negative_p)
{
- if ((BIGNUM_NEGATIVE_P (x)) ? negative_p : (! negative_p))
- return (x);
- else
- {
- bignum * result =
- (allot_bignum ((BIGNUM_LENGTH (x)), negative_p));
- bignum_destructive_copy (x, result);
- return (result);
- }
+ if ((BIGNUM_NEGATIVE_P (x)) ? negative_p : (! negative_p))
+ return (x);
+ else
+ {
+ bignum * result =
+ (allot_bignum ((BIGNUM_LENGTH (x)), negative_p));
+ bignum_destructive_copy (x, result);
+ return (result);
+ }
}
-void
-bignum_destructive_copy(bignum * source, bignum * target)
+
+void factorvm::bignum_destructive_copy(bignum * source, bignum * target)
{
- bignum_digit_type * scan_source = (BIGNUM_START_PTR (source));
- bignum_digit_type * end_source =
- (scan_source + (BIGNUM_LENGTH (source)));
- bignum_digit_type * scan_target = (BIGNUM_START_PTR (target));
- while (scan_source < end_source)
- (*scan_target++) = (*scan_source++);
- return;
+ bignum_digit_type * scan_source = (BIGNUM_START_PTR (source));
+ bignum_digit_type * end_source =
+ (scan_source + (BIGNUM_LENGTH (source)));
+ bignum_digit_type * scan_target = (BIGNUM_START_PTR (target));
+ while (scan_source < end_source)
+ (*scan_target++) = (*scan_source++);
+ return;
}
+
/*
* Added bitwise operations (and oddp).
*/
/* allocates memory */
-bignum *
-bignum_bitwise_not(bignum * x)
+bignum *factorvm::bignum_bitwise_not(bignum * x)
{
- return bignum_subtract(BIGNUM_ONE(1), x);
+ return bignum_subtract(BIGNUM_ONE(1), x);
}
+
/* allocates memory */
-bignum *
-bignum_arithmetic_shift(bignum * arg1, fixnum n)
+bignum *factorvm::bignum_arithmetic_shift(bignum * arg1, fixnum n)
{
- if (BIGNUM_NEGATIVE_P(arg1) && n < 0)
- return bignum_bitwise_not(bignum_magnitude_ash(bignum_bitwise_not(arg1), n));
- else
- return bignum_magnitude_ash(arg1, n);
+ if (BIGNUM_NEGATIVE_P(arg1) && n < 0)
+ return bignum_bitwise_not(bignum_magnitude_ash(bignum_bitwise_not(arg1), n));
+ else
+ return bignum_magnitude_ash(arg1, n);
}
+
#define AND_OP 0
#define IOR_OP 1
#define XOR_OP 2
/* allocates memory */
-bignum *
-bignum_bitwise_and(bignum * arg1, bignum * arg2)
+bignum *factorvm::bignum_bitwise_and(bignum * arg1, bignum * arg2)
{
- return(
- (BIGNUM_NEGATIVE_P (arg1))
- ? (BIGNUM_NEGATIVE_P (arg2))
+ return(
+ (BIGNUM_NEGATIVE_P (arg1))
+ ? (BIGNUM_NEGATIVE_P (arg2))
? bignum_negneg_bitwise_op(AND_OP, arg1, arg2)
: bignum_posneg_bitwise_op(AND_OP, arg2, arg1)
- : (BIGNUM_NEGATIVE_P (arg2))
+ : (BIGNUM_NEGATIVE_P (arg2))
? bignum_posneg_bitwise_op(AND_OP, arg1, arg2)
: bignum_pospos_bitwise_op(AND_OP, arg1, arg2)
- );
+ );
}
+
/* allocates memory */
-bignum *
-bignum_bitwise_ior(bignum * arg1, bignum * arg2)
+bignum *factorvm::bignum_bitwise_ior(bignum * arg1, bignum * arg2)
{
- return(
- (BIGNUM_NEGATIVE_P (arg1))
- ? (BIGNUM_NEGATIVE_P (arg2))
+ return(
+ (BIGNUM_NEGATIVE_P (arg1))
+ ? (BIGNUM_NEGATIVE_P (arg2))
? bignum_negneg_bitwise_op(IOR_OP, arg1, arg2)
: bignum_posneg_bitwise_op(IOR_OP, arg2, arg1)
- : (BIGNUM_NEGATIVE_P (arg2))
+ : (BIGNUM_NEGATIVE_P (arg2))
? bignum_posneg_bitwise_op(IOR_OP, arg1, arg2)
: bignum_pospos_bitwise_op(IOR_OP, arg1, arg2)
- );
+ );
}
+
/* allocates memory */
-bignum *
-bignum_bitwise_xor(bignum * arg1, bignum * arg2)
+bignum *factorvm::bignum_bitwise_xor(bignum * arg1, bignum * arg2)
{
- return(
- (BIGNUM_NEGATIVE_P (arg1))
- ? (BIGNUM_NEGATIVE_P (arg2))
+ return(
+ (BIGNUM_NEGATIVE_P (arg1))
+ ? (BIGNUM_NEGATIVE_P (arg2))
? bignum_negneg_bitwise_op(XOR_OP, arg1, arg2)
: bignum_posneg_bitwise_op(XOR_OP, arg2, arg1)
- : (BIGNUM_NEGATIVE_P (arg2))
+ : (BIGNUM_NEGATIVE_P (arg2))
? bignum_posneg_bitwise_op(XOR_OP, arg1, arg2)
: bignum_pospos_bitwise_op(XOR_OP, arg1, arg2)
- );
+ );
}
+
/* allocates memory */
/* ash for the magnitude */
/* assume arg1 is a big number, n is a long */
-bignum *
-bignum_magnitude_ash(bignum * arg1, fixnum n)
+bignum *factorvm::bignum_magnitude_ash(bignum * arg1, fixnum n)
{
- GC_BIGNUM(arg1);
+ GC_BIGNUM(arg1,this);
- bignum * result = NULL;
- bignum_digit_type *scan1;
- bignum_digit_type *scanr;
- bignum_digit_type *end;
+ bignum * result = NULL;
+ bignum_digit_type *scan1;
+ bignum_digit_type *scanr;
+ bignum_digit_type *end;
- fixnum digit_offset,bit_offset;
+ fixnum digit_offset,bit_offset;
- if (BIGNUM_ZERO_P (arg1)) return (arg1);
+ if (BIGNUM_ZERO_P (arg1)) return (arg1);
- if (n > 0) {
- digit_offset = n / BIGNUM_DIGIT_LENGTH;
- bit_offset = n % BIGNUM_DIGIT_LENGTH;
+ if (n > 0) {
+ digit_offset = n / BIGNUM_DIGIT_LENGTH;
+ bit_offset = n % BIGNUM_DIGIT_LENGTH;
- result = allot_bignum_zeroed (BIGNUM_LENGTH (arg1) + digit_offset + 1,
- BIGNUM_NEGATIVE_P(arg1));
+ result = allot_bignum_zeroed (BIGNUM_LENGTH (arg1) + digit_offset + 1,
+ BIGNUM_NEGATIVE_P(arg1));
- scanr = BIGNUM_START_PTR (result) + digit_offset;
- scan1 = BIGNUM_START_PTR (arg1);
- end = scan1 + BIGNUM_LENGTH (arg1);
+ scanr = BIGNUM_START_PTR (result) + digit_offset;
+ scan1 = BIGNUM_START_PTR (arg1);
+ end = scan1 + BIGNUM_LENGTH (arg1);
- while (scan1 < end) {
- *scanr = *scanr | (*scan1 & BIGNUM_DIGIT_MASK) << bit_offset;
- *scanr = *scanr & BIGNUM_DIGIT_MASK;
- scanr++;
- *scanr = *scan1++ >> (BIGNUM_DIGIT_LENGTH - bit_offset);
- *scanr = *scanr & BIGNUM_DIGIT_MASK;
- }
- }
- else if (n < 0
- && (-n >= (BIGNUM_LENGTH (arg1) * (bignum_length_type) BIGNUM_DIGIT_LENGTH)))
- result = BIGNUM_ZERO ();
-
- else if (n < 0) {
- digit_offset = -n / BIGNUM_DIGIT_LENGTH;
- bit_offset = -n % BIGNUM_DIGIT_LENGTH;
+ while (scan1 < end) {
+ *scanr = *scanr | (*scan1 & BIGNUM_DIGIT_MASK) << bit_offset;
+ *scanr = *scanr & BIGNUM_DIGIT_MASK;
+ scanr++;
+ *scanr = *scan1++ >> (BIGNUM_DIGIT_LENGTH - bit_offset);
+ *scanr = *scanr & BIGNUM_DIGIT_MASK;
+ }
+ }
+ else if (n < 0
+ && (-n >= (BIGNUM_LENGTH (arg1) * (bignum_length_type) BIGNUM_DIGIT_LENGTH)))
+ result = BIGNUM_ZERO ();
+
+ else if (n < 0) {
+ digit_offset = -n / BIGNUM_DIGIT_LENGTH;
+ bit_offset = -n % BIGNUM_DIGIT_LENGTH;
- result = allot_bignum_zeroed (BIGNUM_LENGTH (arg1) - digit_offset,
- BIGNUM_NEGATIVE_P(arg1));
+ result = allot_bignum_zeroed (BIGNUM_LENGTH (arg1) - digit_offset,
+ BIGNUM_NEGATIVE_P(arg1));
- scanr = BIGNUM_START_PTR (result);
- scan1 = BIGNUM_START_PTR (arg1) + digit_offset;
- end = scanr + BIGNUM_LENGTH (result) - 1;
+ scanr = BIGNUM_START_PTR (result);
+ scan1 = BIGNUM_START_PTR (arg1) + digit_offset;
+ end = scanr + BIGNUM_LENGTH (result) - 1;
- while (scanr < end) {
- *scanr = (*scan1++ & BIGNUM_DIGIT_MASK) >> bit_offset ;
- *scanr = (*scanr |
- *scan1 << (BIGNUM_DIGIT_LENGTH - bit_offset)) & BIGNUM_DIGIT_MASK;
- scanr++;
- }
- *scanr = (*scan1++ & BIGNUM_DIGIT_MASK) >> bit_offset ;
- }
- else if (n == 0) result = arg1;
+ while (scanr < end) {
+ *scanr = (*scan1++ & BIGNUM_DIGIT_MASK) >> bit_offset ;
+ *scanr = (*scanr |
+ *scan1 << (BIGNUM_DIGIT_LENGTH - bit_offset)) & BIGNUM_DIGIT_MASK;
+ scanr++;
+ }
+ *scanr = (*scan1++ & BIGNUM_DIGIT_MASK) >> bit_offset ;
+ }
+ else if (n == 0) result = arg1;
- return (bignum_trim (result));
+ return (bignum_trim (result));
}
+
/* allocates memory */
-bignum *
-bignum_pospos_bitwise_op(int op, bignum * arg1, bignum * arg2)
+bignum *factorvm::bignum_pospos_bitwise_op(int op, bignum * arg1, bignum * arg2)
{
- GC_BIGNUM(arg1); GC_BIGNUM(arg2);
+ GC_BIGNUM(arg1,this); GC_BIGNUM(arg2,this);
- bignum * result;
- bignum_length_type max_length;
-
- bignum_digit_type *scan1, *end1, digit1;
- bignum_digit_type *scan2, *end2, digit2;
- bignum_digit_type *scanr, *endr;
-
- max_length = (BIGNUM_LENGTH(arg1) > BIGNUM_LENGTH(arg2))
- ? BIGNUM_LENGTH(arg1) : BIGNUM_LENGTH(arg2);
-
- result = allot_bignum(max_length, 0);
-
- scanr = BIGNUM_START_PTR(result);
- scan1 = BIGNUM_START_PTR(arg1);
- scan2 = BIGNUM_START_PTR(arg2);
- endr = scanr + max_length;
- end1 = scan1 + BIGNUM_LENGTH(arg1);
- end2 = scan2 + BIGNUM_LENGTH(arg2);
-
- while (scanr < endr) {
- digit1 = (scan1 < end1) ? *scan1++ : 0;
- digit2 = (scan2 < end2) ? *scan2++ : 0;
- *scanr++ = (op == AND_OP) ? digit1 & digit2 :
- (op == IOR_OP) ? digit1 | digit2 :
- digit1 ^ digit2;
- }
- return bignum_trim(result);
+ bignum * result;
+ bignum_length_type max_length;
+
+ bignum_digit_type *scan1, *end1, digit1;
+ bignum_digit_type *scan2, *end2, digit2;
+ bignum_digit_type *scanr, *endr;
+
+ max_length = (BIGNUM_LENGTH(arg1) > BIGNUM_LENGTH(arg2))
+ ? BIGNUM_LENGTH(arg1) : BIGNUM_LENGTH(arg2);
+
+ result = allot_bignum(max_length, 0);
+
+ scanr = BIGNUM_START_PTR(result);
+ scan1 = BIGNUM_START_PTR(arg1);
+ scan2 = BIGNUM_START_PTR(arg2);
+ endr = scanr + max_length;
+ end1 = scan1 + BIGNUM_LENGTH(arg1);
+ end2 = scan2 + BIGNUM_LENGTH(arg2);
+
+ while (scanr < endr) {
+ digit1 = (scan1 < end1) ? *scan1++ : 0;
+ digit2 = (scan2 < end2) ? *scan2++ : 0;
+ *scanr++ = (op == AND_OP) ? digit1 & digit2 :
+ (op == IOR_OP) ? digit1 | digit2 :
+ digit1 ^ digit2;
+ }
+ return bignum_trim(result);
}
+
/* allocates memory */
-bignum *
-bignum_posneg_bitwise_op(int op, bignum * arg1, bignum * arg2)
+bignum *factorvm::bignum_posneg_bitwise_op(int op, bignum * arg1, bignum * arg2)
{
- GC_BIGNUM(arg1); GC_BIGNUM(arg2);
+ GC_BIGNUM(arg1,this); GC_BIGNUM(arg2,this);
- bignum * result;
- bignum_length_type max_length;
+ bignum * result;
+ bignum_length_type max_length;
- bignum_digit_type *scan1, *end1, digit1;
- bignum_digit_type *scan2, *end2, digit2, carry2;
- bignum_digit_type *scanr, *endr;
+ bignum_digit_type *scan1, *end1, digit1;
+ bignum_digit_type *scan2, *end2, digit2, carry2;
+ bignum_digit_type *scanr, *endr;
- char neg_p = op == IOR_OP || op == XOR_OP;
+ char neg_p = op == IOR_OP || op == XOR_OP;
- max_length = (BIGNUM_LENGTH(arg1) > BIGNUM_LENGTH(arg2) + 1)
- ? BIGNUM_LENGTH(arg1) : BIGNUM_LENGTH(arg2) + 1;
+ max_length = (BIGNUM_LENGTH(arg1) > BIGNUM_LENGTH(arg2) + 1)
+ ? BIGNUM_LENGTH(arg1) : BIGNUM_LENGTH(arg2) + 1;
- result = allot_bignum(max_length, neg_p);
+ result = allot_bignum(max_length, neg_p);
- scanr = BIGNUM_START_PTR(result);
- scan1 = BIGNUM_START_PTR(arg1);
- scan2 = BIGNUM_START_PTR(arg2);
- endr = scanr + max_length;
- end1 = scan1 + BIGNUM_LENGTH(arg1);
- end2 = scan2 + BIGNUM_LENGTH(arg2);
+ scanr = BIGNUM_START_PTR(result);
+ scan1 = BIGNUM_START_PTR(arg1);
+ scan2 = BIGNUM_START_PTR(arg2);
+ endr = scanr + max_length;
+ end1 = scan1 + BIGNUM_LENGTH(arg1);
+ end2 = scan2 + BIGNUM_LENGTH(arg2);
- carry2 = 1;
+ carry2 = 1;
- while (scanr < endr) {
- digit1 = (scan1 < end1) ? *scan1++ : 0;
- digit2 = (~((scan2 < end2) ? *scan2++ : 0) & BIGNUM_DIGIT_MASK)
- + carry2;
+ while (scanr < endr) {
+ digit1 = (scan1 < end1) ? *scan1++ : 0;
+ digit2 = (~((scan2 < end2) ? *scan2++ : 0) & BIGNUM_DIGIT_MASK)
+ + carry2;
- if (digit2 < BIGNUM_RADIX)
- carry2 = 0;
- else
- {
- digit2 = (digit2 - BIGNUM_RADIX);
- carry2 = 1;
- }
+ if (digit2 < BIGNUM_RADIX)
+ carry2 = 0;
+ else
+ {
+ digit2 = (digit2 - BIGNUM_RADIX);
+ carry2 = 1;
+ }
- *scanr++ = (op == AND_OP) ? digit1 & digit2 :
- (op == IOR_OP) ? digit1 | digit2 :
- digit1 ^ digit2;
- }
+ *scanr++ = (op == AND_OP) ? digit1 & digit2 :
+ (op == IOR_OP) ? digit1 | digit2 :
+ digit1 ^ digit2;
+ }
- if (neg_p)
- bignum_negate_magnitude(result);
+ if (neg_p)
+ bignum_negate_magnitude(result);
- return bignum_trim(result);
+ return bignum_trim(result);
}
+
/* allocates memory */
-bignum *
-bignum_negneg_bitwise_op(int op, bignum * arg1, bignum * arg2)
+bignum *factorvm::bignum_negneg_bitwise_op(int op, bignum * arg1, bignum * arg2)
{
- GC_BIGNUM(arg1); GC_BIGNUM(arg2);
+ GC_BIGNUM(arg1,this); GC_BIGNUM(arg2,this);
- bignum * result;
- bignum_length_type max_length;
+ bignum * result;
+ bignum_length_type max_length;
- bignum_digit_type *scan1, *end1, digit1, carry1;
- bignum_digit_type *scan2, *end2, digit2, carry2;
- bignum_digit_type *scanr, *endr;
+ bignum_digit_type *scan1, *end1, digit1, carry1;
+ bignum_digit_type *scan2, *end2, digit2, carry2;
+ bignum_digit_type *scanr, *endr;
- char neg_p = op == AND_OP || op == IOR_OP;
+ char neg_p = op == AND_OP || op == IOR_OP;
- max_length = (BIGNUM_LENGTH(arg1) > BIGNUM_LENGTH(arg2))
- ? BIGNUM_LENGTH(arg1) + 1 : BIGNUM_LENGTH(arg2) + 1;
+ max_length = (BIGNUM_LENGTH(arg1) > BIGNUM_LENGTH(arg2))
+ ? BIGNUM_LENGTH(arg1) + 1 : BIGNUM_LENGTH(arg2) + 1;
- result = allot_bignum(max_length, neg_p);
+ result = allot_bignum(max_length, neg_p);
- scanr = BIGNUM_START_PTR(result);
- scan1 = BIGNUM_START_PTR(arg1);
- scan2 = BIGNUM_START_PTR(arg2);
- endr = scanr + max_length;
- end1 = scan1 + BIGNUM_LENGTH(arg1);
- end2 = scan2 + BIGNUM_LENGTH(arg2);
+ scanr = BIGNUM_START_PTR(result);
+ scan1 = BIGNUM_START_PTR(arg1);
+ scan2 = BIGNUM_START_PTR(arg2);
+ endr = scanr + max_length;
+ end1 = scan1 + BIGNUM_LENGTH(arg1);
+ end2 = scan2 + BIGNUM_LENGTH(arg2);
- carry1 = 1;
- carry2 = 1;
+ carry1 = 1;
+ carry2 = 1;
- while (scanr < endr) {
- digit1 = (~((scan1 < end1) ? *scan1++ : 0) & BIGNUM_DIGIT_MASK) + carry1;
- digit2 = (~((scan2 < end2) ? *scan2++ : 0) & BIGNUM_DIGIT_MASK) + carry2;
+ while (scanr < endr) {
+ digit1 = (~((scan1 < end1) ? *scan1++ : 0) & BIGNUM_DIGIT_MASK) + carry1;
+ digit2 = (~((scan2 < end2) ? *scan2++ : 0) & BIGNUM_DIGIT_MASK) + carry2;
- if (digit1 < BIGNUM_RADIX)
- carry1 = 0;
- else
- {
- digit1 = (digit1 - BIGNUM_RADIX);
- carry1 = 1;
- }
+ if (digit1 < BIGNUM_RADIX)
+ carry1 = 0;
+ else
+ {
+ digit1 = (digit1 - BIGNUM_RADIX);
+ carry1 = 1;
+ }
- if (digit2 < BIGNUM_RADIX)
- carry2 = 0;
- else
- {
- digit2 = (digit2 - BIGNUM_RADIX);
- carry2 = 1;
- }
+ if (digit2 < BIGNUM_RADIX)
+ carry2 = 0;
+ else
+ {
+ digit2 = (digit2 - BIGNUM_RADIX);
+ carry2 = 1;
+ }
- *scanr++ = (op == AND_OP) ? digit1 & digit2 :
- (op == IOR_OP) ? digit1 | digit2 :
- digit1 ^ digit2;
- }
+ *scanr++ = (op == AND_OP) ? digit1 & digit2 :
+ (op == IOR_OP) ? digit1 | digit2 :
+ digit1 ^ digit2;
+ }
- if (neg_p)
- bignum_negate_magnitude(result);
+ if (neg_p)
+ bignum_negate_magnitude(result);
- return bignum_trim(result);
+ return bignum_trim(result);
}
-void
-bignum_negate_magnitude(bignum * arg)
+
+void factorvm::bignum_negate_magnitude(bignum * arg)
{
- bignum_digit_type *scan;
- bignum_digit_type *end;
- bignum_digit_type digit;
- bignum_digit_type carry;
-
- scan = BIGNUM_START_PTR(arg);
- end = scan + BIGNUM_LENGTH(arg);
-
- carry = 1;
-
- while (scan < end) {
- digit = (~*scan & BIGNUM_DIGIT_MASK) + carry;
-
- if (digit < BIGNUM_RADIX)
- carry = 0;
- else
- {
- digit = (digit - BIGNUM_RADIX);
- carry = 1;
- }
+ bignum_digit_type *scan;
+ bignum_digit_type *end;
+ bignum_digit_type digit;
+ bignum_digit_type carry;
+
+ scan = BIGNUM_START_PTR(arg);
+ end = scan + BIGNUM_LENGTH(arg);
+
+ carry = 1;
+
+ while (scan < end) {
+ digit = (~*scan & BIGNUM_DIGIT_MASK) + carry;
+
+ if (digit < BIGNUM_RADIX)
+ carry = 0;
+ else
+ {
+ digit = (digit - BIGNUM_RADIX);
+ carry = 1;
+ }
- *scan++ = digit;
- }
+ *scan++ = digit;
+ }
}
+
/* Allocates memory */
-bignum *
-bignum_integer_length(bignum * x)
+bignum *factorvm::bignum_integer_length(bignum * x)
{
- GC_BIGNUM(x);
+ GC_BIGNUM(x,this);
- bignum_length_type index = ((BIGNUM_LENGTH (x)) - 1);
- bignum_digit_type digit = (BIGNUM_REF (x, index));
+ bignum_length_type index = ((BIGNUM_LENGTH (x)) - 1);
+ bignum_digit_type digit = (BIGNUM_REF (x, index));
- bignum * result = (allot_bignum (2, 0));
+ bignum * result = (allot_bignum (2, 0));
- (BIGNUM_REF (result, 0)) = index;
- (BIGNUM_REF (result, 1)) = 0;
- bignum_destructive_scale_up (result, BIGNUM_DIGIT_LENGTH);
- while (digit > 1)
- {
- bignum_destructive_add (result, ((bignum_digit_type) 1));
- digit >>= 1;
- }
- return (bignum_trim (result));
+ (BIGNUM_REF (result, 0)) = index;
+ (BIGNUM_REF (result, 1)) = 0;
+ bignum_destructive_scale_up (result, BIGNUM_DIGIT_LENGTH);
+ while (digit > 1)
+ {
+ bignum_destructive_add (result, ((bignum_digit_type) 1));
+ digit >>= 1;
+ }
+ return (bignum_trim (result));
}
+
/* Allocates memory */
-int
-bignum_logbitp(int shift, bignum * arg)
+int factorvm::bignum_logbitp(int shift, bignum * arg)
{
- return((BIGNUM_NEGATIVE_P (arg))
- ? !bignum_unsigned_logbitp (shift, bignum_bitwise_not (arg))
- : bignum_unsigned_logbitp (shift,arg));
+ return((BIGNUM_NEGATIVE_P (arg))
+ ? !bignum_unsigned_logbitp (shift, bignum_bitwise_not (arg))
+ : bignum_unsigned_logbitp (shift,arg));
}
-int
-bignum_unsigned_logbitp(int shift, bignum * bignum)
+
+int factorvm::bignum_unsigned_logbitp(int shift, bignum * bignum)
{
- bignum_length_type len = (BIGNUM_LENGTH (bignum));
- int index = shift / BIGNUM_DIGIT_LENGTH;
- if (index >= len)
- return 0;
- bignum_digit_type digit = (BIGNUM_REF (bignum, index));
- int p = shift % BIGNUM_DIGIT_LENGTH;
- bignum_digit_type mask = ((fixnum)1) << p;
- return (digit & mask) ? 1 : 0;
+ bignum_length_type len = (BIGNUM_LENGTH (bignum));
+ int index = shift / BIGNUM_DIGIT_LENGTH;
+ if (index >= len)
+ return 0;
+ bignum_digit_type digit = (BIGNUM_REF (bignum, index));
+ int p = shift % BIGNUM_DIGIT_LENGTH;
+ bignum_digit_type mask = ((fixnum)1) << p;
+ return (digit & mask) ? 1 : 0;
}
+
/* Allocates memory */
-bignum *
-digit_stream_to_bignum(unsigned int n_digits,
- unsigned int (*producer)(unsigned int),
- unsigned int radix,
- int negative_p)
+bignum *factorvm::digit_stream_to_bignum(unsigned int n_digits, unsigned int (*producer)(unsigned int, factorvm*), unsigned int radix, int negative_p)
{
- BIGNUM_ASSERT ((radix > 1) && (radix <= BIGNUM_RADIX_ROOT));
- if (n_digits == 0)
- return (BIGNUM_ZERO ());
- if (n_digits == 1)
- {
- fixnum digit = ((fixnum) ((*producer) (0)));
- return (fixnum_to_bignum (negative_p ? (- digit) : digit));
- }
- {
- bignum_length_type length;
- {
- unsigned int radix_copy = radix;
- unsigned int log_radix = 0;
- while (radix_copy > 0)
- {
- radix_copy >>= 1;
- log_radix += 1;
- }
- /* This length will be at least as large as needed. */
- length = (BIGNUM_BITS_TO_DIGITS (n_digits * log_radix));
- }
- {
- bignum * result = (allot_bignum_zeroed (length, negative_p));
- while ((n_digits--) > 0)
- {
- bignum_destructive_scale_up (result, ((bignum_digit_type) radix));
- bignum_destructive_add
- (result, ((bignum_digit_type) ((*producer) (n_digits))));
- }
- return (bignum_trim (result));
- }
- }
+ BIGNUM_ASSERT ((radix > 1) && (radix <= BIGNUM_RADIX_ROOT));
+ if (n_digits == 0)
+ return (BIGNUM_ZERO ());
+ if (n_digits == 1)
+ {
+ fixnum digit = ((fixnum) ((*producer) (0,this)));
+ return (fixnum_to_bignum (negative_p ? (- digit) : digit));
+ }
+ {
+ bignum_length_type length;
+ {
+ unsigned int radix_copy = radix;
+ unsigned int log_radix = 0;
+ while (radix_copy > 0)
+ {
+ radix_copy >>= 1;
+ log_radix += 1;
+ }
+ /* This length will be at least as large as needed. */
+ length = (BIGNUM_BITS_TO_DIGITS (n_digits * log_radix));
+ }
+ {
+ bignum * result = (allot_bignum_zeroed (length, negative_p));
+ while ((n_digits--) > 0)
+ {
+ bignum_destructive_scale_up (result, ((bignum_digit_type) radix));
+ bignum_destructive_add
+ (result, ((bignum_digit_type) ((*producer) (n_digits,this))));
+ }
+ return (bignum_trim (result));
+ }
+ }
}
+
}
bignum_comparison_greater = 1
};
-int bignum_equal_p(bignum *, bignum *);
-enum bignum_comparison bignum_compare(bignum *, bignum *);
-bignum * bignum_add(bignum *, bignum *);
-bignum * bignum_subtract(bignum *, bignum *);
-bignum * bignum_negate(bignum *);
-bignum * bignum_multiply(bignum *, bignum *);
-void
-bignum_divide(bignum * numerator, bignum * denominator,
- bignum * * quotient, bignum * * remainder);
-bignum * bignum_quotient(bignum *, bignum *);
-bignum * bignum_remainder(bignum *, bignum *);
-bignum * fixnum_to_bignum(fixnum);
-bignum * cell_to_bignum(cell);
-bignum * long_long_to_bignum(s64 n);
-bignum * ulong_long_to_bignum(u64 n);
-fixnum bignum_to_fixnum(bignum *);
-cell bignum_to_cell(bignum *);
-s64 bignum_to_long_long(bignum *);
-u64 bignum_to_ulong_long(bignum *);
-bignum * double_to_bignum(double);
-double bignum_to_double(bignum *);
-
-/* Added bitwise operators. */
-
-bignum * bignum_bitwise_not(bignum *);
-bignum * bignum_arithmetic_shift(bignum *, fixnum);
-bignum * bignum_bitwise_and(bignum *, bignum *);
-bignum * bignum_bitwise_ior(bignum *, bignum *);
-bignum * bignum_bitwise_xor(bignum *, bignum *);
-
-/* Forward references */
-int bignum_equal_p_unsigned(bignum *, bignum *);
-enum bignum_comparison bignum_compare_unsigned(bignum *, bignum *);
-bignum * bignum_add_unsigned(bignum *, bignum *, int);
-bignum * bignum_subtract_unsigned(bignum *, bignum *);
-bignum * bignum_multiply_unsigned(bignum *, bignum *, int);
-bignum * bignum_multiply_unsigned_small_factor
- (bignum *, bignum_digit_type, int);
-void bignum_destructive_scale_up(bignum *, bignum_digit_type);
-void bignum_destructive_add(bignum *, bignum_digit_type);
-void bignum_divide_unsigned_large_denominator
- (bignum *, bignum *, bignum * *, bignum * *, int, int);
-void bignum_destructive_normalization(bignum *, bignum *, int);
-void bignum_destructive_unnormalization(bignum *, int);
-void bignum_divide_unsigned_normalized(bignum *, bignum *, bignum *);
-bignum_digit_type bignum_divide_subtract
- (bignum_digit_type *, bignum_digit_type *, bignum_digit_type,
- bignum_digit_type *);
-void bignum_divide_unsigned_medium_denominator
- (bignum *, bignum_digit_type, bignum * *, bignum * *, int, int);
-bignum_digit_type bignum_digit_divide
- (bignum_digit_type, bignum_digit_type, bignum_digit_type, bignum_digit_type *);
-bignum_digit_type bignum_digit_divide_subtract
- (bignum_digit_type, bignum_digit_type, bignum_digit_type, bignum_digit_type *);
-void bignum_divide_unsigned_small_denominator
- (bignum *, bignum_digit_type, bignum * *, bignum * *, int, int);
-bignum_digit_type bignum_destructive_scale_down
- (bignum *, bignum_digit_type);
-bignum * bignum_remainder_unsigned_small_denominator
- (bignum *, bignum_digit_type, int);
-bignum * bignum_digit_to_bignum(bignum_digit_type, int);
-bignum * allot_bignum(bignum_length_type, int);
-bignum * allot_bignum_zeroed(bignum_length_type, int);
-bignum * bignum_shorten_length(bignum *, bignum_length_type);
-bignum * bignum_trim(bignum *);
-bignum * bignum_new_sign(bignum *, int);
-bignum * bignum_maybe_new_sign(bignum *, int);
-void bignum_destructive_copy(bignum *, bignum *);
-
-/* Added for bitwise operations. */
-bignum * bignum_magnitude_ash(bignum * arg1, fixnum n);
-bignum * bignum_pospos_bitwise_op(int op, bignum *, bignum *);
-bignum * bignum_posneg_bitwise_op(int op, bignum *, bignum *);
-bignum * bignum_negneg_bitwise_op(int op, bignum *, bignum *);
-void bignum_negate_magnitude(bignum *);
-
-bignum * bignum_integer_length(bignum * arg1);
-int bignum_unsigned_logbitp(int shift, bignum * bignum);
-int bignum_logbitp(int shift, bignum * arg);
+struct factorvm;
bignum * digit_stream_to_bignum(unsigned int n_digits,
- unsigned int (*producer)(unsigned int),
+ unsigned int (*producer)(unsigned int,factorvm*),
unsigned int radix,
int negative_p);
namespace factor
{
-VM_C_API void box_boolean(bool value)
+void factorvm::box_boolean(bool value)
{
dpush(value ? T : F);
}
-VM_C_API bool to_boolean(cell value)
+VM_C_API void box_boolean(bool value, factorvm *myvm)
+{
+ ASSERTVM();
+ return VM_PTR->box_boolean(value);
+}
+
+bool factorvm::to_boolean(cell value)
{
return value != F;
}
+VM_C_API bool to_boolean(cell value, factorvm *myvm)
+{
+ ASSERTVM();
+ return VM_PTR->to_boolean(value);
+}
+
}
namespace factor
{
-inline static cell tag_boolean(cell untagged)
-{
- return (untagged ? T : F);
-}
-VM_C_API void box_boolean(bool value);
-VM_C_API bool to_boolean(cell value);
+VM_C_API void box_boolean(bool value, factorvm *vm);
+VM_C_API bool to_boolean(cell value, factorvm *vm);
}
namespace factor
{
-byte_array *allot_byte_array(cell size)
+byte_array *factorvm::allot_byte_array(cell size)
{
byte_array *array = allot_array_internal<byte_array>(size);
memset(array + 1,0,size);
return array;
}
-PRIMITIVE(byte_array)
+
+inline void factorvm::vmprim_byte_array()
{
cell size = unbox_array_size();
dpush(tag<byte_array>(allot_byte_array(size)));
}
-PRIMITIVE(uninitialized_byte_array)
+PRIMITIVE(byte_array)
+{
+ PRIMITIVE_GETVM()->vmprim_byte_array();
+}
+
+inline void factorvm::vmprim_uninitialized_byte_array()
{
cell size = unbox_array_size();
dpush(tag<byte_array>(allot_array_internal<byte_array>(size)));
}
-PRIMITIVE(resize_byte_array)
+PRIMITIVE(uninitialized_byte_array)
+{
+ PRIMITIVE_GETVM()->vmprim_uninitialized_byte_array();
+}
+
+inline void factorvm::vmprim_resize_byte_array()
{
byte_array *array = untag_check<byte_array>(dpop());
cell capacity = unbox_array_size();
dpush(tag<byte_array>(reallot_array(array,capacity)));
}
+PRIMITIVE(resize_byte_array)
+{
+ PRIMITIVE_GETVM()->vmprim_resize_byte_array();
+}
+
void growable_byte_array::append_bytes(void *elts, cell len)
{
cell new_size = count + len;
-
+ factorvm *myvm = elements.myvm;
if(new_size >= array_capacity(elements.untagged()))
- elements = reallot_array(elements.untagged(),new_size * 2);
+ elements = myvm->reallot_array(elements.untagged(),new_size * 2);
memcpy(&elements->data<u8>()[count],elts,len);
void growable_byte_array::append_byte_array(cell byte_array_)
{
- gc_root<byte_array> byte_array(byte_array_);
+ gc_root<byte_array> byte_array(byte_array_,elements.myvm);
cell len = array_capacity(byte_array.untagged());
cell new_size = count + len;
-
+ factorvm *myvm = elements.myvm;
if(new_size >= array_capacity(elements.untagged()))
- elements = reallot_array(elements.untagged(),new_size * 2);
+ elements = myvm->reallot_array(elements.untagged(),new_size * 2);
memcpy(&elements->data<u8>()[count],byte_array->data<u8>(),len);
void growable_byte_array::trim()
{
- elements = reallot_array(elements.untagged(),count);
+ factorvm *myvm = elements.myvm;
+ elements = myvm->reallot_array(elements.untagged(),count);
}
}
namespace factor
{
-byte_array *allot_byte_array(cell size);
-
PRIMITIVE(byte_array);
PRIMITIVE(uninitialized_byte_array);
PRIMITIVE(resize_byte_array);
-struct growable_byte_array {
- cell count;
- gc_root<byte_array> elements;
-
- growable_byte_array(cell capacity = 40) : count(0), elements(allot_byte_array(capacity)) { }
-
- void append_bytes(void *elts, cell len);
- void append_byte_array(cell elts);
-
- void trim();
-};
}
namespace factor
{
-static void check_frame(stack_frame *frame)
+void factorvm::check_frame(stack_frame *frame)
{
#ifdef FACTOR_DEBUG
check_code_pointer((cell)frame->xt);
#endif
}
-callstack *allot_callstack(cell size)
+callstack *factorvm::allot_callstack(cell size)
{
callstack *stack = allot<callstack>(callstack_size(size));
stack->length = tag_fixnum(size);
return stack;
}
-stack_frame *fix_callstack_top(stack_frame *top, stack_frame *bottom)
+stack_frame *factorvm::fix_callstack_top(stack_frame *top, stack_frame *bottom)
{
stack_frame *frame = bottom - 1;
will have popped a necessary frame... however this word is only
called by continuation implementation, and user code shouldn't
be calling it at all, so we leave it as it is for now. */
-stack_frame *capture_start()
+stack_frame *factorvm::capture_start()
{
stack_frame *frame = stack_chain->callstack_bottom - 1;
while(frame >= stack_chain->callstack_top
return frame + 1;
}
-PRIMITIVE(callstack)
+inline void factorvm::vmprim_callstack()
{
stack_frame *top = capture_start();
stack_frame *bottom = stack_chain->callstack_bottom;
dpush(tag<callstack>(stack));
}
-PRIMITIVE(set_callstack)
+PRIMITIVE(callstack)
+{
+ PRIMITIVE_GETVM()->vmprim_callstack();
+}
+
+inline void factorvm::vmprim_set_callstack()
{
callstack *stack = untag_check<callstack>(dpop());
critical_error("Bug in set_callstack()",0);
}
-code_block *frame_code(stack_frame *frame)
+PRIMITIVE(set_callstack)
+{
+ PRIMITIVE_GETVM()->vmprim_set_callstack();
+}
+
+code_block *factorvm::frame_code(stack_frame *frame)
{
check_frame(frame);
return (code_block *)frame->xt - 1;
}
-cell frame_type(stack_frame *frame)
+
+cell factorvm::frame_type(stack_frame *frame)
{
return frame_code(frame)->type;
}
-cell frame_executing(stack_frame *frame)
+cell factorvm::frame_executing(stack_frame *frame)
{
code_block *compiled = frame_code(frame);
if(compiled->literals == F || !stack_traces_p())
}
}
-stack_frame *frame_successor(stack_frame *frame)
+stack_frame *factorvm::frame_successor(stack_frame *frame)
{
check_frame(frame);
return (stack_frame *)((cell)frame - frame->size);
}
/* Allocates memory */
-cell frame_scan(stack_frame *frame)
+cell factorvm::frame_scan(stack_frame *frame)
{
switch(frame_type(frame))
{
struct stack_frame_accumulator {
growable_array frames;
- void operator()(stack_frame *frame)
+ stack_frame_accumulator(factorvm *vm) : frames(vm) {}
+
+ void operator()(stack_frame *frame, factorvm *myvm)
{
- gc_root<object> executing(frame_executing(frame));
- gc_root<object> scan(frame_scan(frame));
+ gc_root<object> executing(myvm->frame_executing(frame),myvm);
+ gc_root<object> scan(myvm->frame_scan(frame),myvm);
frames.add(executing.value());
frames.add(scan.value());
}
-PRIMITIVE(callstack_to_array)
+inline void factorvm::vmprim_callstack_to_array()
{
- gc_root<callstack> callstack(dpop());
+ gc_root<callstack> callstack(dpop(),this);
- stack_frame_accumulator accum;
+ stack_frame_accumulator accum(this);
iterate_callstack_object(callstack.untagged(),accum);
accum.frames.trim();
dpush(accum.frames.elements.value());
}
-stack_frame *innermost_stack_frame(callstack *stack)
+PRIMITIVE(callstack_to_array)
+{
+ PRIMITIVE_GETVM()->vmprim_callstack_to_array();
+}
+
+stack_frame *factorvm::innermost_stack_frame(callstack *stack)
{
stack_frame *top = stack->top();
stack_frame *bottom = stack->bottom();
return frame;
}
-stack_frame *innermost_stack_frame_quot(callstack *callstack)
+stack_frame *factorvm::innermost_stack_frame_quot(callstack *callstack)
{
stack_frame *inner = innermost_stack_frame(callstack);
- tagged<quotation>(frame_executing(inner)).untag_check();
+ tagged<quotation>(frame_executing(inner)).untag_check(this);
return inner;
}
/* Some primitives implementing a limited form of callstack mutation.
Used by the single stepper. */
-PRIMITIVE(innermost_stack_frame_executing)
+inline void factorvm::vmprim_innermost_stack_frame_executing()
{
dpush(frame_executing(innermost_stack_frame(untag_check<callstack>(dpop()))));
}
-PRIMITIVE(innermost_stack_frame_scan)
+PRIMITIVE(innermost_stack_frame_executing)
+{
+ PRIMITIVE_GETVM()->vmprim_innermost_stack_frame_executing();
+}
+
+inline void factorvm::vmprim_innermost_stack_frame_scan()
{
dpush(frame_scan(innermost_stack_frame_quot(untag_check<callstack>(dpop()))));
}
-PRIMITIVE(set_innermost_stack_frame_quot)
+PRIMITIVE(innermost_stack_frame_scan)
{
- gc_root<callstack> callstack(dpop());
- gc_root<quotation> quot(dpop());
+ PRIMITIVE_GETVM()->vmprim_innermost_stack_frame_scan();
+}
- callstack.untag_check();
- quot.untag_check();
+inline void factorvm::vmprim_set_innermost_stack_frame_quot()
+{
+ gc_root<callstack> callstack(dpop(),this);
+ gc_root<quotation> quot(dpop(),this);
+
+ callstack.untag_check(this);
+ quot.untag_check(this);
jit_compile(quot.value(),true);
FRAME_RETURN_ADDRESS(inner) = (char *)quot->xt + offset;
}
+PRIMITIVE(set_innermost_stack_frame_quot)
+{
+ PRIMITIVE_GETVM()->vmprim_set_innermost_stack_frame_quot();
+}
+
/* called before entry into Factor code. */
-VM_ASM_API void save_callstack_bottom(stack_frame *callstack_bottom)
+void factorvm::save_callstack_bottom(stack_frame *callstack_bottom)
{
stack_chain->callstack_bottom = callstack_bottom;
}
+VM_ASM_API void save_callstack_bottom(stack_frame *callstack_bottom, factorvm *myvm)
+{
+ ASSERTVM();
+ return VM_PTR->save_callstack_bottom(callstack_bottom);
+}
+
}
return sizeof(callstack) + size;
}
-stack_frame *fix_callstack_top(stack_frame *top, stack_frame *bottom);
-stack_frame *frame_successor(stack_frame *frame);
-code_block *frame_code(stack_frame *frame);
-cell frame_executing(stack_frame *frame);
-cell frame_scan(stack_frame *frame);
-cell frame_type(stack_frame *frame);
-
PRIMITIVE(callstack);
PRIMITIVE(set_callstack);
PRIMITIVE(callstack_to_array);
PRIMITIVE(innermost_stack_frame_scan);
PRIMITIVE(set_innermost_stack_frame_quot);
-VM_ASM_API void save_callstack_bottom(stack_frame *callstack_bottom);
-
-template<typename T> void iterate_callstack(cell top, cell bottom, T &iterator)
-{
- stack_frame *frame = (stack_frame *)bottom - 1;
+VM_ASM_API void save_callstack_bottom(stack_frame *callstack_bottom,factorvm *vm);
- while((cell)frame >= top)
- {
- iterator(frame);
- frame = frame_successor(frame);
- }
-}
-/* This is a little tricky. The iterator may allocate memory, so we
-keep the callstack in a GC root and use relative offsets */
-template<typename T> void iterate_callstack_object(callstack *stack_, T &iterator)
-{
- gc_root<callstack> stack(stack_);
- fixnum frame_offset = untag_fixnum(stack->length) - sizeof(stack_frame);
-
- while(frame_offset >= 0)
- {
- stack_frame *frame = stack->frame_at(frame_offset);
- frame_offset -= frame->size;
- iterator(frame);
- }
-}
}
namespace factor
{
-static relocation_type relocation_type_of(relocation_entry r)
+relocation_type factorvm::relocation_type_of(relocation_entry r)
{
return (relocation_type)((r & 0xf0000000) >> 28);
}
-static relocation_class relocation_class_of(relocation_entry r)
+
+relocation_class factorvm::relocation_class_of(relocation_entry r)
{
return (relocation_class)((r & 0x0f000000) >> 24);
}
-static cell relocation_offset_of(relocation_entry r)
+
+cell factorvm::relocation_offset_of(relocation_entry r)
{
return (r & 0x00ffffff);
}
-void flush_icache_for(code_block *block)
+
+void factorvm::flush_icache_for(code_block *block)
{
flush_icache((cell)block,block->size);
}
-static int number_of_parameters(relocation_type type)
+
+int factorvm::number_of_parameters(relocation_type type)
{
switch(type)
{
case RT_THIS:
case RT_STACK_CHAIN:
case RT_MEGAMORPHIC_CACHE_HITS:
+ case RT_VM:
return 0;
default:
critical_error("Bad rel type",type);
}
}
-void *object_xt(cell obj)
+
+void *factorvm::object_xt(cell obj)
{
switch(tagged<object>(obj).type())
{
}
}
-static void *xt_pic(word *w, cell tagged_quot)
+
+void *factorvm::xt_pic(word *w, cell tagged_quot)
{
if(tagged_quot == F || max_pic_size == 0)
return w->xt;
}
}
-void *word_xt_pic(word *w)
+
+void *factorvm::word_xt_pic(word *w)
{
return xt_pic(w,w->pic_def);
}
-void *word_xt_pic_tail(word *w)
+
+void *factorvm::word_xt_pic_tail(word *w)
{
return xt_pic(w,w->pic_tail_def);
}
+
/* References to undefined symbols are patched up to call this function on
image load */
-void undefined_symbol()
+void factorvm::undefined_symbol()
{
general_error(ERROR_UNDEFINED_SYMBOL,F,F,NULL);
}
+void undefined_symbol(factorvm *myvm)
+{
+ return myvm->undefined_symbol();
+}
+
/* Look up an external library symbol referenced by a compiled code block */
-void *get_rel_symbol(array *literals, cell index)
+void *factorvm::get_rel_symbol(array *literals, cell index)
{
cell symbol = array_nth(literals,index);
cell library = array_nth(literals,index + 1);
dll *d = (library == F ? NULL : untag<dll>(library));
if(d != NULL && !d->dll)
- return (void *)undefined_symbol;
+ return (void *)factor::undefined_symbol;
switch(tagged<object>(symbol).type())
{
return sym;
else
{
- return (void *)undefined_symbol;
+ return (void *)factor::undefined_symbol;
}
}
case ARRAY_TYPE:
if(sym)
return sym;
}
- return (void *)undefined_symbol;
+ return (void *)factor::undefined_symbol;
}
default:
critical_error("Bad symbol specifier",symbol);
- return (void *)undefined_symbol;
+ return (void *)factor::undefined_symbol;
}
}
-cell compute_relocation(relocation_entry rel, cell index, code_block *compiled)
+
+cell factorvm::compute_relocation(relocation_entry rel, cell index, code_block *compiled)
{
array *literals = untag<array>(compiled->literals);
cell offset = relocation_offset_of(rel) + (cell)compiled->xt();
return untag_fixnum(ARG);
case RT_MEGAMORPHIC_CACHE_HITS:
return (cell)&megamorphic_cache_hits;
+ case RT_VM:
+ return (cell)this;
default:
critical_error("Bad rel type",rel);
return 0; /* Can't happen */
#undef ARG
}
-void iterate_relocations(code_block *compiled, relocation_iterator iter)
+
+void factorvm::iterate_relocations(code_block *compiled, relocation_iterator iter)
{
if(compiled->relocation != F)
{
for(cell i = 0; i < length; i++)
{
relocation_entry rel = relocation->data<relocation_entry>()[i];
- iter(rel,index,compiled);
+ iter(rel,index,compiled,this);
index += number_of_parameters(relocation_type_of(rel));
}
}
}
+
/* Store a 32-bit value into a PowerPC LIS/ORI sequence */
-static void store_address_2_2(cell *ptr, cell value)
+void factorvm::store_address_2_2(cell *ptr, cell value)
{
ptr[-1] = ((ptr[-1] & ~0xffff) | ((value >> 16) & 0xffff));
ptr[ 0] = ((ptr[ 0] & ~0xffff) | (value & 0xffff));
}
+
/* Store a value into a bitfield of a PowerPC instruction */
-static void store_address_masked(cell *ptr, fixnum value, cell mask, fixnum shift)
+void factorvm::store_address_masked(cell *ptr, fixnum value, cell mask, fixnum shift)
{
/* This is unaccurate but good enough */
fixnum test = (fixnum)mask >> 1;
*ptr = ((*ptr & ~mask) | ((value >> shift) & mask));
}
+
/* Perform a fixup on a code block */
-void store_address_in_code_block(cell klass, cell offset, fixnum absolute_value)
+void factorvm::store_address_in_code_block(cell klass, cell offset, fixnum absolute_value)
{
fixnum relative_value = absolute_value - offset;
}
}
-void update_literal_references_step(relocation_entry rel, cell index, code_block *compiled)
+
+void factorvm::update_literal_references_step(relocation_entry rel, cell index, code_block *compiled)
{
if(relocation_type_of(rel) == RT_IMMEDIATE)
{
}
}
+void update_literal_references_step(relocation_entry rel, cell index, code_block *compiled, factorvm *myvm)
+{
+ return myvm->update_literal_references_step(rel,index,compiled);
+}
+
/* Update pointers to literals from compiled code. */
-void update_literal_references(code_block *compiled)
+void factorvm::update_literal_references(code_block *compiled)
{
if(!compiled->needs_fixup)
{
- iterate_relocations(compiled,update_literal_references_step);
+ iterate_relocations(compiled,factor::update_literal_references_step);
flush_icache_for(compiled);
}
}
+
/* Copy all literals referenced from a code block to newspace. Only for
aging and nursery collections */
-void copy_literal_references(code_block *compiled)
+void factorvm::copy_literal_references(code_block *compiled)
{
if(collecting_gen >= compiled->last_scan)
{
}
}
+void copy_literal_references(code_block *compiled, factorvm *myvm)
+{
+ return myvm->copy_literal_references(compiled);
+}
+
/* Compute an address to store at a relocation */
-void relocate_code_block_step(relocation_entry rel, cell index, code_block *compiled)
+void factorvm::relocate_code_block_step(relocation_entry rel, cell index, code_block *compiled)
{
#ifdef FACTOR_DEBUG
- tagged<array>(compiled->literals).untag_check();
- tagged<byte_array>(compiled->relocation).untag_check();
+ tagged<array>(compiled->literals).untag_check(this);
+ tagged<byte_array>(compiled->relocation).untag_check(this);
#endif
store_address_in_code_block(relocation_class_of(rel),
compute_relocation(rel,index,compiled));
}
-void update_word_references_step(relocation_entry rel, cell index, code_block *compiled)
+void relocate_code_block_step(relocation_entry rel, cell index, code_block *compiled, factorvm *myvm)
+{
+ return myvm->relocate_code_block_step(rel,index,compiled);
+}
+
+void factorvm::update_word_references_step(relocation_entry rel, cell index, code_block *compiled)
{
relocation_type type = relocation_type_of(rel);
if(type == RT_XT || type == RT_XT_PIC || type == RT_XT_PIC_TAIL)
relocate_code_block_step(rel,index,compiled);
}
+void update_word_references_step(relocation_entry rel, cell index, code_block *compiled, factorvm *myvm)
+{
+ return myvm->update_word_references_step(rel,index,compiled);
+}
+
/* Relocate new code blocks completely; updating references to literals,
dlsyms, and words. For all other words in the code heap, we only need
to update references to other words, without worrying about literals
or dlsyms. */
-void update_word_references(code_block *compiled)
+void factorvm::update_word_references(code_block *compiled)
{
if(compiled->needs_fixup)
relocate_code_block(compiled);
heap_free(&code,compiled);
else
{
- iterate_relocations(compiled,update_word_references_step);
+ iterate_relocations(compiled,factor::update_word_references_step);
flush_icache_for(compiled);
}
}
-void update_literal_and_word_references(code_block *compiled)
+void update_word_references(code_block *compiled, factorvm *myvm)
+{
+ return myvm->update_word_references(compiled);
+}
+
+void factorvm::update_literal_and_word_references(code_block *compiled)
{
update_literal_references(compiled);
update_word_references(compiled);
}
-static void check_code_address(cell address)
+void update_literal_and_word_references(code_block *compiled, factorvm *myvm)
+{
+ return myvm->update_literal_and_word_references(compiled);
+}
+
+void factorvm::check_code_address(cell address)
{
#ifdef FACTOR_DEBUG
assert(address >= code.seg->start && address < code.seg->end);
#endif
}
+
/* Update references to words. This is done after a new code block
is added to the heap. */
/* Mark all literals referenced from a word XT. Only for tenured
collections */
-void mark_code_block(code_block *compiled)
+void factorvm::mark_code_block(code_block *compiled)
{
check_code_address((cell)compiled);
copy_handle(&compiled->relocation);
}
-void mark_stack_frame_step(stack_frame *frame)
+
+void factorvm::mark_stack_frame_step(stack_frame *frame)
{
mark_code_block(frame_code(frame));
}
+void mark_stack_frame_step(stack_frame *frame, factorvm *myvm)
+{
+ return myvm->mark_stack_frame_step(frame);
+}
+
/* Mark code blocks executing in currently active stack frames. */
-void mark_active_blocks(context *stacks)
+void factorvm::mark_active_blocks(context *stacks)
{
if(collecting_gen == data->tenured())
{
cell top = (cell)stacks->callstack_top;
cell bottom = (cell)stacks->callstack_bottom;
- iterate_callstack(top,bottom,mark_stack_frame_step);
+ iterate_callstack(top,bottom,factor::mark_stack_frame_step);
}
}
-void mark_object_code_block(object *object)
+
+void factorvm::mark_object_code_block(object *object)
{
switch(object->h.hi_tag())
{
case CALLSTACK_TYPE:
{
callstack *stack = (callstack *)object;
- iterate_callstack_object(stack,mark_stack_frame_step);
+ iterate_callstack_object(stack,factor::mark_stack_frame_step);
break;
}
}
}
+
/* Perform all fixups on a code block */
-void relocate_code_block(code_block *compiled)
+void factorvm::relocate_code_block(code_block *compiled)
{
compiled->last_scan = data->nursery();
compiled->needs_fixup = false;
- iterate_relocations(compiled,relocate_code_block_step);
+ iterate_relocations(compiled,factor::relocate_code_block_step);
flush_icache_for(compiled);
}
+void relocate_code_block(code_block *compiled, factorvm *myvm)
+{
+ return myvm->relocate_code_block(compiled);
+}
+
/* Fixup labels. This is done at compile time, not image load time */
-void fixup_labels(array *labels, code_block *compiled)
+void factorvm::fixup_labels(array *labels, code_block *compiled)
{
cell i;
cell size = array_capacity(labels);
}
}
+
/* Might GC */
-code_block *allot_code_block(cell size)
+code_block *factorvm::allot_code_block(cell size)
{
heap_block *block = heap_allot(&code,size + sizeof(code_block));
return (code_block *)block;
}
+
/* Might GC */
-code_block *add_code_block(
- cell type,
- cell code_,
- cell labels_,
- cell relocation_,
- cell literals_)
-{
- gc_root<byte_array> code(code_);
- gc_root<object> labels(labels_);
- gc_root<byte_array> relocation(relocation_);
- gc_root<array> literals(literals_);
+code_block *factorvm::add_code_block(cell type,cell code_,cell labels_,cell relocation_,cell literals_)
+{
+ gc_root<byte_array> code(code_,this);
+ gc_root<object> labels(labels_,this);
+ gc_root<byte_array> relocation(relocation_,this);
+ gc_root<array> literals(literals_,this);
cell code_length = align8(array_capacity(code.untagged()));
code_block *compiled = allot_code_block(code_length);
return compiled;
}
+
}
RT_UNTAGGED,
/* address of megamorphic_cache_hits var */
RT_MEGAMORPHIC_CACHE_HITS,
+ /* address of vm object*/
+ RT_VM,
};
enum relocation_class {
/* code relocation table consists of a table of entries for each fixup */
typedef u32 relocation_entry;
-void flush_icache_for(code_block *compiled);
+struct factorvm;
-typedef void (*relocation_iterator)(relocation_entry rel, cell index, code_block *compiled);
+typedef void (*relocation_iterator)(relocation_entry rel, cell index, code_block *compiled, factorvm *vm);
-void iterate_relocations(code_block *compiled, relocation_iterator iter);
-
-void store_address_in_code_block(cell klass, cell offset, fixnum absolute_value);
-
-void relocate_code_block(code_block *compiled);
-
-void update_literal_references(code_block *compiled);
-
-void copy_literal_references(code_block *compiled);
-
-void update_word_references(code_block *compiled);
-
-void update_literal_and_word_references(code_block *compiled);
-
-void mark_code_block(code_block *compiled);
-
-void mark_active_blocks(context *stacks);
-
-void mark_object_code_block(object *scan);
-
-void relocate_code_block(code_block *relocating);
-
-inline static bool stack_traces_p()
-{
- return userenv[STACK_TRACES_ENV] != F;
-}
-
-code_block *add_code_block(cell type, cell code, cell labels, cell relocation, cell literals);
+// callback functions
+void relocate_code_block(code_block *compiled, factorvm *myvm);
+void copy_literal_references(code_block *compiled, factorvm *myvm);
+void update_word_references(code_block *compiled, factorvm *myvm);
+void update_literal_and_word_references(code_block *compiled, factorvm *myvm);
}
namespace factor
{
-static void clear_free_list(heap *heap)
+void factorvm::clear_free_list(heap *heap)
{
memset(&heap->free,0,sizeof(heap_free_list));
}
+
/* This malloc-style heap code is reasonably generic. Maybe in the future, it
will be used for the data heap too, if we ever get incremental
mark/sweep/compact GC. */
-void new_heap(heap *heap, cell size)
+void factorvm::new_heap(heap *heap, cell size)
{
heap->seg = alloc_segment(align_page(size));
if(!heap->seg)
clear_free_list(heap);
}
-static void add_to_free_list(heap *heap, free_heap_block *block)
+
+void factorvm::add_to_free_list(heap *heap, free_heap_block *block)
{
if(block->size < free_list_count * block_size_increment)
{
}
}
+
/* Called after reading the code heap from the image file, and after code GC.
In the former case, we must add a large free block from compiling.base + size to
compiling.limit. */
-void build_free_list(heap *heap, cell size)
+void factorvm::build_free_list(heap *heap, cell size)
{
heap_block *prev = NULL;
}
-static void assert_free_block(free_heap_block *block)
+
+void factorvm::assert_free_block(free_heap_block *block)
{
if(block->status != B_FREE)
critical_error("Invalid block in free list",(cell)block);
}
+
-static free_heap_block *find_free_block(heap *heap, cell size)
+free_heap_block *factorvm::find_free_block(heap *heap, cell size)
{
cell attempt = size;
return NULL;
}
-static free_heap_block *split_free_block(heap *heap, free_heap_block *block, cell size)
+
+free_heap_block *factorvm::split_free_block(heap *heap, free_heap_block *block, cell size)
{
if(block->size != size )
{
return block;
}
+
/* Allocate a block of memory from the mark and sweep GC heap */
-heap_block *heap_allot(heap *heap, cell size)
+heap_block *factorvm::heap_allot(heap *heap, cell size)
{
size = (size + block_size_increment - 1) & ~(block_size_increment - 1);
return NULL;
}
+
/* Deallocates a block manually */
-void heap_free(heap *heap, heap_block *block)
+void factorvm::heap_free(heap *heap, heap_block *block)
{
block->status = B_FREE;
add_to_free_list(heap,(free_heap_block *)block);
}
-void mark_block(heap_block *block)
+
+void factorvm::mark_block(heap_block *block)
{
/* If already marked, do nothing */
switch(block->status)
}
}
+
/* If in the middle of code GC, we have to grow the heap, data GC restarts from
scratch, so we have to unmark any marked blocks. */
-void unmark_marked(heap *heap)
+void factorvm::unmark_marked(heap *heap)
{
heap_block *scan = first_block(heap);
}
}
+
/* After code GC, all referenced code blocks have status set to B_MARKED, so any
which are allocated and not marked can be reclaimed. */
-void free_unmarked(heap *heap, heap_iterator iter)
+void factorvm::free_unmarked(heap *heap, heap_iterator iter)
{
clear_free_list(heap);
add_to_free_list(heap,(free_heap_block *)prev);
scan->status = B_ALLOCATED;
prev = scan;
- iter(scan);
+ iter(scan,this);
break;
default:
critical_error("Invalid scan->status",(cell)scan);
add_to_free_list(heap,(free_heap_block *)prev);
}
+
/* Compute total sum of sizes of free blocks, and size of largest free block */
-void heap_usage(heap *heap, cell *used, cell *total_free, cell *max_free)
+void factorvm::heap_usage(heap *heap, cell *used, cell *total_free, cell *max_free)
{
*used = 0;
*total_free = 0;
}
}
+
/* The size of the heap, not including the last block if it's free */
-cell heap_size(heap *heap)
+cell factorvm::heap_size(heap *heap)
{
heap_block *scan = first_block(heap);
return heap->seg->size;
}
+
/* Compute where each block is going to go, after compaction */
-cell compute_heap_forwarding(heap *heap, unordered_map<heap_block *,char *> &forwarding)
+cell factorvm::compute_heap_forwarding(heap *heap, unordered_map<heap_block *,char *> &forwarding)
{
heap_block *scan = first_block(heap);
char *address = (char *)first_block(heap);
return (cell)address - heap->seg->start;
}
-void compact_heap(heap *heap, unordered_map<heap_block *,char *> &forwarding)
+
+void factorvm::compact_heap(heap *heap, unordered_map<heap_block *,char *> &forwarding)
{
heap_block *scan = first_block(heap);
heap_free_list free;
};
-typedef void (*heap_iterator)(heap_block *compiled);
-
-void new_heap(heap *h, cell size);
-void build_free_list(heap *h, cell size);
-heap_block *heap_allot(heap *h, cell size);
-void heap_free(heap *h, heap_block *block);
-void mark_block(heap_block *block);
-void unmark_marked(heap *heap);
-void free_unmarked(heap *heap, heap_iterator iter);
-void heap_usage(heap *h, cell *used, cell *total_free, cell *max_free);
-cell heap_size(heap *h);
-cell compute_heap_forwarding(heap *h, unordered_map<heap_block *,char *> &forwarding);
-void compact_heap(heap *h, unordered_map<heap_block *,char *> &forwarding);
+typedef void (*heap_iterator)(heap_block *compiled,factorvm *vm);
inline static heap_block *next_block(heap *h, heap_block *block)
{
namespace factor
{
-heap code;
-
/* Allocate a code heap during startup */
-void init_code_heap(cell size)
+void factorvm::init_code_heap(cell size)
{
new_heap(&code,size);
}
-bool in_code_heap_p(cell ptr)
+bool factorvm::in_code_heap_p(cell ptr)
{
return (ptr >= code.seg->start && ptr <= code.seg->end);
}
/* Compile a word definition with the non-optimizing compiler. Allocates memory */
-void jit_compile_word(cell word_, cell def_, bool relocate)
+void factorvm::jit_compile_word(cell word_, cell def_, bool relocate)
{
- gc_root<word> word(word_);
- gc_root<quotation> def(def_);
+ gc_root<word> word(word_,this);
+ gc_root<quotation> def(def_,this);
jit_compile(def.value(),relocate);
if(word->pic_tail_def != F) jit_compile(word->pic_tail_def,relocate);
}
+
/* Apply a function to every code block */
-void iterate_code_heap(code_heap_iterator iter)
+void factorvm::iterate_code_heap(code_heap_iterator iter)
{
heap_block *scan = first_block(&code);
while(scan)
{
if(scan->status != B_FREE)
- iter((code_block *)scan);
+ iter((code_block *)scan,this);
scan = next_block(&code,scan);
}
}
+
/* Copy literals referenced from all code blocks to newspace. Only for
aging and nursery collections */
-void copy_code_heap_roots()
+void factorvm::copy_code_heap_roots()
{
- iterate_code_heap(copy_literal_references);
+ iterate_code_heap(factor::copy_literal_references);
}
+
/* Update pointers to words referenced from all code blocks. Only after
defining a new word. */
-void update_code_heap_words()
+void factorvm::update_code_heap_words()
{
- iterate_code_heap(update_word_references);
+ iterate_code_heap(factor::update_word_references);
}
-PRIMITIVE(modify_code_heap)
+
+inline void factorvm::vmprim_modify_code_heap()
{
- gc_root<array> alist(dpop());
+ gc_root<array> alist(dpop(),this);
cell count = array_capacity(alist.untagged());
cell i;
for(i = 0; i < count; i++)
{
- gc_root<array> pair(array_nth(alist.untagged(),i));
+ gc_root<array> pair(array_nth(alist.untagged(),i),this);
- gc_root<word> word(array_nth(pair.untagged(),0));
- gc_root<object> data(array_nth(pair.untagged(),1));
+ gc_root<word> word(array_nth(pair.untagged(),0),this);
+ gc_root<object> data(array_nth(pair.untagged(),1),this);
switch(data.type())
{
update_code_heap_words();
}
+PRIMITIVE(modify_code_heap)
+{
+ PRIMITIVE_GETVM()->vmprim_modify_code_heap();
+}
+
/* Push the free space and total size of the code heap */
-PRIMITIVE(code_room)
+inline void factorvm::vmprim_code_room()
{
cell used, total_free, max_free;
heap_usage(&code,&used,&total_free,&max_free);
dpush(tag_fixnum(max_free / 1024));
}
-static unordered_map<heap_block *,char *> forwarding;
+PRIMITIVE(code_room)
+{
+ PRIMITIVE_GETVM()->vmprim_code_room();
+}
-code_block *forward_xt(code_block *compiled)
+
+code_block *factorvm::forward_xt(code_block *compiled)
{
return (code_block *)forwarding[compiled];
}
-void forward_frame_xt(stack_frame *frame)
+
+void factorvm::forward_frame_xt(stack_frame *frame)
{
cell offset = (cell)FRAME_RETURN_ADDRESS(frame) - (cell)frame_code(frame);
code_block *forwarded = forward_xt(frame_code(frame));
FRAME_RETURN_ADDRESS(frame) = (void *)((cell)forwarded + offset);
}
-void forward_object_xts()
+void forward_frame_xt(stack_frame *frame,factorvm *myvm)
+{
+ return myvm->forward_frame_xt(frame);
+}
+
+void factorvm::forward_object_xts()
{
begin_scan();
case CALLSTACK_TYPE:
{
callstack *stack = untag<callstack>(obj);
- iterate_callstack_object(stack,forward_frame_xt);
+ iterate_callstack_object(stack,factor::forward_frame_xt);
}
break;
default:
end_scan();
}
+
/* Set the XT fields now that the heap has been compacted */
-void fixup_object_xts()
+void factorvm::fixup_object_xts()
{
begin_scan();
end_scan();
}
+
/* Move all free space to the end of the code heap. This is not very efficient,
since it makes several passes over the code and data heaps, but we only ever
do this before saving a deployed image and exiting, so performaance is not
critical here */
-void compact_code_heap()
+void factorvm::compact_code_heap()
{
/* Free all unreachable code blocks */
gc();
namespace factor
{
-
-/* compiled code */
-extern heap code;
-
-void init_code_heap(cell size);
-
-bool in_code_heap_p(cell ptr);
-
-void jit_compile_word(cell word, cell def, bool relocate);
-
-typedef void (*code_heap_iterator)(code_block *compiled);
-
-void iterate_code_heap(code_heap_iterator iter);
-
-void copy_code_heap_roots();
+struct factorvm;
+typedef void (*code_heap_iterator)(code_block *compiled,factorvm *myvm);
PRIMITIVE(modify_code_heap);
-
PRIMITIVE(code_room);
-void compact_code_heap();
-
-inline static void check_code_pointer(cell ptr)
-{
-#ifdef FACTOR_DEBUG
- assert(in_code_heap_p(ptr));
-#endif
-}
-
}
#include "master.hpp"
-factor::context *stack_chain;
-
namespace factor
{
-cell ds_size, rs_size;
-context *unused_contexts;
-void reset_datastack()
+void factorvm::reset_datastack()
{
ds = ds_bot - sizeof(cell);
}
-void reset_retainstack()
+void factorvm::reset_retainstack()
{
rs = rs_bot - sizeof(cell);
}
static const cell stack_reserved = (64 * sizeof(cell));
-void fix_stacks()
+void factorvm::fix_stacks()
{
if(ds + sizeof(cell) < ds_bot || ds + stack_reserved >= ds_top) reset_datastack();
if(rs + sizeof(cell) < rs_bot || rs + stack_reserved >= rs_top) reset_retainstack();
/* called before entry into foreign C code. Note that ds and rs might
be stored in registers, so callbacks must save and restore the correct values */
-void save_stacks()
+void factorvm::save_stacks()
{
if(stack_chain)
{
}
}
-context *alloc_context()
+context *factorvm::alloc_context()
{
context *new_context;
return new_context;
}
-void dealloc_context(context *old_context)
+void factorvm::dealloc_context(context *old_context)
{
old_context->next = unused_contexts;
unused_contexts = old_context;
}
/* called on entry into a compiled callback */
-void nest_stacks()
+void factorvm::nest_stacks()
{
context *new_context = alloc_context();
reset_retainstack();
}
+void nest_stacks(factorvm *myvm)
+{
+ ASSERTVM();
+ return VM_PTR->nest_stacks();
+}
+
/* called when leaving a compiled callback */
-void unnest_stacks()
+void factorvm::unnest_stacks()
{
ds = stack_chain->datastack_save;
rs = stack_chain->retainstack_save;
dealloc_context(old_stacks);
}
+void unnest_stacks(factorvm *myvm)
+{
+ ASSERTVM();
+ return VM_PTR->unnest_stacks();
+}
+
/* called on startup */
-void init_stacks(cell ds_size_, cell rs_size_)
+void factorvm::init_stacks(cell ds_size_, cell rs_size_)
{
ds_size = ds_size_;
rs_size = rs_size_;
unused_contexts = NULL;
}
-bool stack_to_array(cell bottom, cell top)
+bool factorvm::stack_to_array(cell bottom, cell top)
{
fixnum depth = (fixnum)(top - bottom + sizeof(cell));
}
}
-PRIMITIVE(datastack)
+inline void factorvm::vmprim_datastack()
{
if(!stack_to_array(ds_bot,ds))
general_error(ERROR_DS_UNDERFLOW,F,F,NULL);
}
-PRIMITIVE(retainstack)
+PRIMITIVE(datastack)
+{
+ PRIMITIVE_GETVM()->vmprim_datastack();
+}
+
+inline void factorvm::vmprim_retainstack()
{
if(!stack_to_array(rs_bot,rs))
general_error(ERROR_RS_UNDERFLOW,F,F,NULL);
}
+PRIMITIVE(retainstack)
+{
+ PRIMITIVE_GETVM()->vmprim_retainstack();
+}
+
/* returns pointer to top of stack */
-cell array_to_stack(array *array, cell bottom)
+cell factorvm::array_to_stack(array *array, cell bottom)
{
cell depth = array_capacity(array) * sizeof(cell);
memcpy((void*)bottom,array + 1,depth);
return bottom + depth - sizeof(cell);
}
-PRIMITIVE(set_datastack)
+inline void factorvm::vmprim_set_datastack()
{
ds = array_to_stack(untag_check<array>(dpop()),ds_bot);
}
-PRIMITIVE(set_retainstack)
+PRIMITIVE(set_datastack)
+{
+ PRIMITIVE_GETVM()->vmprim_set_datastack();
+}
+
+inline void factorvm::vmprim_set_retainstack()
{
rs = array_to_stack(untag_check<array>(dpop()),rs_bot);
}
+PRIMITIVE(set_retainstack)
+{
+ PRIMITIVE_GETVM()->vmprim_set_retainstack();
+}
+
/* Used to implement call( */
-PRIMITIVE(check_datastack)
+inline void factorvm::vmprim_check_datastack()
{
fixnum out = to_fixnum(dpop());
fixnum in = to_fixnum(dpop());
}
}
+PRIMITIVE(check_datastack)
+{
+ PRIMITIVE_GETVM()->vmprim_check_datastack();
+}
+
}
context *next;
};
-extern cell ds_size, rs_size;
-
#define ds_bot (stack_chain->datastack_region->start)
#define ds_top (stack_chain->datastack_region->end)
#define rs_bot (stack_chain->retainstack_region->start)
DEFPUSHPOP(d,ds)
DEFPUSHPOP(r,rs)
-void reset_datastack();
-void reset_retainstack();
-void fix_stacks();
-void init_stacks(cell ds_size, cell rs_size);
-
PRIMITIVE(datastack);
PRIMITIVE(retainstack);
PRIMITIVE(set_datastack);
PRIMITIVE(set_retainstack);
PRIMITIVE(check_datastack);
-VM_C_API void save_stacks();
-VM_C_API void nest_stacks();
-VM_C_API void unnest_stacks();
+struct factorvm;
+VM_C_API void nest_stacks(factorvm *vm);
+VM_C_API void unnest_stacks(factorvm *vm);
}
-VM_C_API factor::context *stack_chain;
#define FACTOR_CPU_STRING "ppc"
#define VM_ASM_API VM_C_API
+#define VM_ASM_API_OVERFLOW VM_C_API
register cell ds asm("r13");
register cell rs asm("r14");
}
/* Defined in assembly */
-VM_ASM_API void c_to_factor(cell quot);
-VM_ASM_API void throw_impl(cell quot, stack_frame *rewind);
-VM_ASM_API void lazy_jit_compile(cell quot);
+VM_ASM_API void c_to_factor(cell quot, void *vm);
+VM_ASM_API void throw_impl(cell quot, stack_frame *rewind, void *vm);
+VM_ASM_API void lazy_jit_compile(cell quot, void *vm);
VM_ASM_API void flush_icache(cell start, cell len);
VM_ASM_API void set_callstack(stack_frame *to,
#define ARG0 %eax
#define ARG1 %edx
+#define ARG2 %ecx
#define STACK_REG %esp
#define DS_REG %esi
#define RETURN_REG %eax
rdtsc
ret
-DEF(void,primitive_inline_cache_miss,(void)):
+DEF(void,primitive_inline_cache_miss,(void *vm)):
mov (%esp),%ebx
-DEF(void,primitive_inline_cache_miss_tail,(void)):
+DEF(void,primitive_inline_cache_miss_tail,(void *vm)):
sub $8,%esp
+ push ARG0 /* push vm ptr */
push %ebx
call MANGLE(inline_cache_miss)
- add $12,%esp
+ add $16,%esp
jmp *%eax
DEF(void,get_sse_env,(void*)):
fldcw 2(%eax)
ret
+DEF(F_FASTCALL void,throw_impl,(CELL quot, F_STACK_FRAME *rewind_to, void *vm)):
+ mov CELL_SIZE(STACK_REG),NV_TEMP_REG /* get vm ptr in case quot_xt = lazy_jit_compile */
+ /* clear x87 stack, but preserve rounding mode and exception flags */
+ sub $2,STACK_REG
+ fnstcw (STACK_REG)
+ fninit
+ fldcw (STACK_REG)
+ /* rewind_to */
+ mov ARG1,STACK_REG
+ mov NV_TEMP_REG,ARG1
+ jmp *QUOT_XT_OFFSET(ARG0)
+
+
+DEF(F_FASTCALL void,lazy_jit_compile,(CELL quot, void *vm)):
+ mov ARG1,NV_TEMP_REG /* stash vm ptr */
+ mov STACK_REG,ARG1 /* Save stack pointer */
+ sub $STACK_PADDING,STACK_REG
+ push NV_TEMP_REG /* push vm ptr as arg3 */
+ call MANGLE(lazy_jit_compile_impl)
+ pop NV_TEMP_REG
+ mov RETURN_REG,ARG0 /* No-op on 32-bit */
+ add $STACK_PADDING,STACK_REG
+ jmp *QUOT_XT_OFFSET(ARG0) /* Call the quotation */
+
+
#include "cpu-x86.S"
#ifdef WINDOWS
register cell rs asm("edi");
#define VM_ASM_API VM_C_API __attribute__ ((regparm (2)))
-
+#define VM_ASM_API_OVERFLOW VM_C_API __attribute__ ((regparm (3)))
}
or %rdx,%rax
ret
-DEF(void,primitive_inline_cache_miss,(void)):
+DEF(void,primitive_inline_cache_miss,(void *vm)):
mov (%rsp),%rbx
-DEF(void,primitive_inline_cache_miss_tail,(void)):
+DEF(void,primitive_inline_cache_miss_tail,(void *vm)):
sub $STACK_PADDING,%rsp
+ mov ARG0,ARG1
mov %rbx,ARG0
call MANGLE(inline_cache_miss)
add $STACK_PADDING,%rsp
jmp *%rax
+
DEF(void,get_sse_env,(void*)):
stmxcsr (%rdi)
ret
fldcw 2(%rdi)
ret
+DEF(F_FASTCALL void,throw_impl,(CELL quot, F_STACK_FRAME *rewind_to, void *vm)):
+ /* clear x87 stack, but preserve rounding mode and exception flags */
+ sub $2,STACK_REG
+ fnstcw (STACK_REG)
+ fninit
+ fldcw (STACK_REG)
+ /* rewind_to */
+ mov ARG1,STACK_REG
+ mov ARG2,ARG1 /* make vm ptr 2nd arg in case quot_xt = lazy_jit_compile */
+ jmp *QUOT_XT_OFFSET(ARG0)
+
+DEF(F_FASTCALL void,lazy_jit_compile,(CELL quot, void *vm)):
+ mov ARG1,ARG2 /* vm is 3rd arg */
+ mov STACK_REG,ARG1 /* Save stack pointer */
+ sub $STACK_PADDING,STACK_REG
+ call MANGLE(lazy_jit_compile_impl)
+ mov RETURN_REG,ARG0 /* No-op on 32-bit */
+ add $STACK_PADDING,STACK_REG
+ jmp *QUOT_XT_OFFSET(ARG0) /* Call the quotation */
+
+
#include "cpu-x86.S"
register cell rs asm("r15");
#define VM_ASM_API VM_C_API
-
+#define VM_ASM_API_OVERFLOW VM_C_API
}
-DEF(void,primitive_fixnum_add,(void)):
+DEF(void,primitive_fixnum_add,(void *myvm)):
+ mov ARG0, ARG2 /* save vm ptr for overflow */
mov (DS_REG),ARG0
mov -CELL_SIZE(DS_REG),ARG1
sub $CELL_SIZE,DS_REG
mov ARITH_TEMP_1,(DS_REG)
ret
-DEF(void,primitive_fixnum_subtract,(void)):
+DEF(void,primitive_fixnum_subtract,(void *myvm)):
+ mov ARG0, ARG2 /* save vm ptr for overflow */
mov (DS_REG),ARG1
mov -CELL_SIZE(DS_REG),ARG0
sub $CELL_SIZE,DS_REG
mov ARITH_TEMP_1,(DS_REG)
ret
-DEF(void,primitive_fixnum_multiply,(void)):
+DEF(void,primitive_fixnum_multiply,(void *myvm)):
+ push ARG0 /* save vm ptr for overflow */
mov (DS_REG),ARITH_TEMP_1
mov ARITH_TEMP_1,DIV_RESULT
mov -CELL_SIZE(DS_REG),ARITH_TEMP_2
imul ARITH_TEMP_2
jo multiply_overflow
mov DIV_RESULT,(DS_REG)
+ pop ARG2
ret
multiply_overflow:
sar $3,ARITH_TEMP_1
mov ARITH_TEMP_1,ARG0
mov ARITH_TEMP_2,ARG1
+ pop ARG2
jmp MANGLE(overflow_fixnum_multiply)
-DEF(F_FASTCALL void,c_to_factor,(CELL quot)):
+
+DEF(F_FASTCALL void,c_to_factor,(CELL quot, void *vm)):
PUSH_NONVOLATILE
mov ARG0,NV_TEMP_REG
-
/* Create register shadow area for Win64 */
sub $32,STACK_REG
/* Save stack pointer */
lea -CELL_SIZE(STACK_REG),ARG0
+ push ARG1 /* save vm ptr */
call MANGLE(save_callstack_bottom)
-
+ pop ARG1
+
/* Call quot-xt */
mov NV_TEMP_REG,ARG0
call *QUOT_XT_OFFSET(ARG0)
POP_NONVOLATILE
ret
-DEF(F_FASTCALL void,throw_impl,(CELL quot, F_STACK_FRAME *rewind_to)):
- /* clear x87 stack, but preserve rounding mode and exception flags */
- sub $2,STACK_REG
- fnstcw (STACK_REG)
- fninit
- fldcw (STACK_REG)
- /* rewind_to */
- mov ARG1,STACK_REG
- jmp *QUOT_XT_OFFSET(ARG0)
-
-DEF(F_FASTCALL void,lazy_jit_compile,(CELL quot)):
- mov STACK_REG,ARG1 /* Save stack pointer */
- sub $STACK_PADDING,STACK_REG
- call MANGLE(lazy_jit_compile_impl)
- mov RETURN_REG,ARG0 /* No-op on 32-bit */
- add $STACK_PADDING,STACK_REG
- jmp *QUOT_XT_OFFSET(ARG0) /* Call the quotation */
-
/* cpu.x86.features calls this */
DEF(bool,sse_version,(void)):
mov $0x1,RETURN_REG
cpuid
- /* test $0x100000,%ecx
+ test $0x100000,%ecx
jnz sse_42
test $0x80000,%ecx
jnz sse_41
test $0x200,%ecx
- jnz ssse_3 */
+ jnz ssse_3
test $0x1,%ecx
jnz sse_3
test $0x4000000,%edx
sse_1:
mov $10,RETURN_REG
ret
+
#ifdef WINDOWS
.section .drectve
.ascii " -export:sse_version"
}
/* Defined in assembly */
-VM_ASM_API void c_to_factor(cell quot);
-VM_ASM_API void throw_impl(cell quot, stack_frame *rewind_to);
-VM_ASM_API void lazy_jit_compile(cell quot);
+VM_ASM_API void c_to_factor(cell quot,void *vm);
+VM_ASM_API void throw_impl(cell quot, stack_frame *rewind_to, void *vm);
+VM_ASM_API void lazy_jit_compile(cell quot, void *vm);
VM_C_API void set_callstack(stack_frame *to,
stack_frame *from,
namespace factor
{
-/* used during garbage collection only */
-zone *newspace;
-bool performing_gc;
-bool performing_compaction;
-cell collecting_gen;
-
-/* if true, we are collecting aging space for the second time, so if it is still
-full, we go on to collect tenured */
-bool collecting_aging_again;
-
-/* in case a generation fills up in the middle of a gc, we jump back
-up to try collecting the next generation. */
-jmp_buf gc_jmp;
-
-gc_stats stats[max_gen_count];
-u64 cards_scanned;
-u64 decks_scanned;
-u64 card_scan_time;
-cell code_heap_scans;
-
-/* What generation was being collected when copy_code_heap_roots() was last
-called? Until the next call to add_code_block(), future
-collections of younger generations don't have to touch the code
-heap. */
-cell last_code_heap_scan;
-
-/* sometimes we grow the heap */
-bool growing_data_heap;
-data_heap *old_data_heap;
-
-void init_data_gc()
+void factorvm::init_data_gc()
{
performing_gc = false;
last_code_heap_scan = data->nursery();
collecting_aging_again = false;
}
+
/* Given a pointer to oldspace, copy it to newspace */
-static object *copy_untagged_object_impl(object *pointer, cell size)
+object *factorvm::copy_untagged_object_impl(object *pointer, cell size)
{
if(newspace->here + size >= newspace->end)
longjmp(gc_jmp,1);
return newpointer;
}
-static object *copy_object_impl(object *untagged)
+
+object *factorvm::copy_object_impl(object *untagged)
{
object *newpointer = copy_untagged_object_impl(untagged,untagged_object_size(untagged));
untagged->h.forward_to(newpointer);
return newpointer;
}
-static bool should_copy_p(object *untagged)
+
+bool factorvm::should_copy_p(object *untagged)
{
if(in_zone(newspace,untagged))
return false;
}
}
+
/* Follow a chain of forwarding pointers */
-static object *resolve_forwarding(object *untagged)
+object *factorvm::resolve_forwarding(object *untagged)
{
check_data_pointer(untagged);
}
}
-template <typename T> static T *copy_untagged_object(T *untagged)
+
+template <typename TYPE> TYPE *factorvm::copy_untagged_object(TYPE *untagged)
{
check_data_pointer(untagged);
if(untagged->h.forwarding_pointer_p())
- untagged = (T *)resolve_forwarding(untagged->h.forwarding_pointer());
+ untagged = (TYPE *)resolve_forwarding(untagged->h.forwarding_pointer());
else
{
untagged->h.check_header();
- untagged = (T *)copy_object_impl(untagged);
+ untagged = (TYPE *)copy_object_impl(untagged);
}
return untagged;
}
-static cell copy_object(cell pointer)
+
+cell factorvm::copy_object(cell pointer)
{
return RETAG(copy_untagged_object(untag<object>(pointer)),TAG(pointer));
}
-void copy_handle(cell *handle)
+
+void factorvm::copy_handle(cell *handle)
{
cell pointer = *handle;
}
}
+
/* Scan all the objects in the card */
-static void copy_card(card *ptr, cell gen, cell here)
+void factorvm::copy_card(card *ptr, cell gen, cell here)
{
cell card_scan = card_to_addr(ptr) + card_offset(ptr);
cell card_end = card_to_addr(ptr + 1);
cards_scanned++;
}
-static void copy_card_deck(card_deck *deck, cell gen, card mask, card unmask)
+
+void factorvm::copy_card_deck(card_deck *deck, cell gen, card mask, card unmask)
{
card *first_card = deck_to_card(deck);
card *last_card = deck_to_card(deck + 1);
decks_scanned++;
}
+
/* Copy all newspace objects referenced from marked cards to the destination */
-static void copy_gen_cards(cell gen)
+void factorvm::copy_gen_cards(cell gen)
{
card_deck *first_deck = addr_to_deck(data->generations[gen].start);
card_deck *last_deck = addr_to_deck(data->generations[gen].end);
}
}
+
/* Scan cards in all generations older than the one being collected, copying
old->new references */
-static void copy_cards()
+void factorvm::copy_cards()
{
u64 start = current_micros();
card_scan_time += (current_micros() - start);
}
+
/* Copy all tagged pointers in a range of memory */
-static void copy_stack_elements(segment *region, cell top)
+void factorvm::copy_stack_elements(segment *region, cell top)
{
cell ptr = region->start;
copy_handle((cell*)ptr);
}
-static void copy_registered_locals()
+
+void factorvm::copy_registered_locals()
{
std::vector<cell>::const_iterator iter = gc_locals.begin();
std::vector<cell>::const_iterator end = gc_locals.end();
copy_handle((cell *)(*iter));
}
-static void copy_registered_bignums()
+
+void factorvm::copy_registered_bignums()
{
std::vector<cell>::const_iterator iter = gc_bignums.begin();
std::vector<cell>::const_iterator end = gc_bignums.end();
}
}
+
/* Copy roots over at the start of GC, namely various constants, stacks,
the user environment and extra roots registered by local_roots.hpp */
-static void copy_roots()
+void factorvm::copy_roots()
{
copy_handle(&T);
copy_handle(&bignum_zero);
copy_handle(&userenv[i]);
}
-static cell copy_next_from_nursery(cell scan)
+
+cell factorvm::copy_next_from_nursery(cell scan)
{
cell *obj = (cell *)scan;
cell *end = (cell *)(scan + binary_payload_start((object *)scan));
return scan + untagged_object_size((object *)scan);
}
-static cell copy_next_from_aging(cell scan)
+
+cell factorvm::copy_next_from_aging(cell scan)
{
cell *obj = (cell *)scan;
cell *end = (cell *)(scan + binary_payload_start((object *)scan));
return scan + untagged_object_size((object *)scan);
}
-static cell copy_next_from_tenured(cell scan)
+
+cell factorvm::copy_next_from_tenured(cell scan)
{
cell *obj = (cell *)scan;
cell *end = (cell *)(scan + binary_payload_start((object *)scan));
return scan + untagged_object_size((object *)scan);
}
-void copy_reachable_objects(cell scan, cell *end)
+
+void factorvm::copy_reachable_objects(cell scan, cell *end)
{
if(collecting_gen == data->nursery())
{
}
}
+
/* Prepare to start copying reachable objects into an unused zone */
-static void begin_gc(cell requested_bytes)
+void factorvm::begin_gc(cell requested_bytes)
{
if(growing_data_heap)
{
}
}
-static void end_gc(cell gc_elapsed)
+
+void factorvm::end_gc(cell gc_elapsed)
{
gc_stats *s = &stats[collecting_gen];
collecting_aging_again = false;
}
+
/* Collect gen and all younger generations.
If growing_data_heap_ is true, we must grow the data heap to such a size that
an allocation of requested_bytes won't fail */
-void garbage_collection(cell gen,
- bool growing_data_heap_,
- cell requested_bytes)
+void factorvm::garbage_collection(cell gen,bool growing_data_heap_,cell requested_bytes)
{
if(gc_off)
{
code_heap_scans++;
if(collecting_gen == data->tenured())
- free_unmarked(&code,(heap_iterator)update_literal_and_word_references);
+ free_unmarked(&code,(heap_iterator)factor::update_literal_and_word_references);
else
copy_code_heap_roots();
performing_gc = false;
}
-void gc()
+
+void factorvm::gc()
{
garbage_collection(data->tenured(),false,0);
}
-PRIMITIVE(gc)
+
+inline void factorvm::vmprim_gc()
{
gc();
}
-PRIMITIVE(gc_stats)
+PRIMITIVE(gc)
+{
+ PRIMITIVE_GETVM()->vmprim_gc();
+}
+
+inline void factorvm::vmprim_gc_stats()
{
- growable_array result;
+ growable_array result(this);
cell i;
u64 total_gc_time = 0;
dpush(result.elements.value());
}
-void clear_gc_stats()
+PRIMITIVE(gc_stats)
+{
+ PRIMITIVE_GETVM()->vmprim_gc_stats();
+}
+
+void factorvm::clear_gc_stats()
{
for(cell i = 0; i < max_gen_count; i++)
memset(&stats[i],0,sizeof(gc_stats));
code_heap_scans = 0;
}
-PRIMITIVE(clear_gc_stats)
+inline void factorvm::vmprim_clear_gc_stats()
{
clear_gc_stats();
}
+PRIMITIVE(clear_gc_stats)
+{
+ PRIMITIVE_GETVM()->vmprim_clear_gc_stats();
+}
+
/* classes.tuple uses this to reshape tuples; tools.deploy.shaker uses this
to coalesce equal but distinct quotations and wrappers. */
-PRIMITIVE(become)
+inline void factorvm::vmprim_become()
{
array *new_objects = untag_check<array>(dpop());
array *old_objects = untag_check<array>(dpop());
compile_all_words();
}
-VM_ASM_API void inline_gc(cell *gc_roots_base, cell gc_roots_size)
+PRIMITIVE(become)
+{
+ PRIMITIVE_GETVM()->vmprim_become();
+}
+
+void factorvm::inline_gc(cell *gc_roots_base, cell gc_roots_size)
{
for(cell i = 0; i < gc_roots_size; i++)
gc_locals.push_back((cell)&gc_roots_base[i]);
gc_locals.pop_back();
}
+VM_ASM_API void inline_gc(cell *gc_roots_base, cell gc_roots_size, factorvm *myvm)
+{
+ ASSERTVM();
+ VM_PTR->inline_gc(gc_roots_base,gc_roots_size);
+}
+
}
u64 bytes_copied;
};
-extern zone *newspace;
-
-extern bool performing_compaction;
-extern cell collecting_gen;
-extern bool collecting_aging_again;
-
-extern cell last_code_heap_scan;
-
-void init_data_gc();
-
-void gc();
-
-inline static bool collecting_accumulation_gen_p()
-{
- return ((data->have_aging_p()
- && collecting_gen == data->aging()
- && !collecting_aging_again)
- || collecting_gen == data->tenured());
-}
-
-void copy_handle(cell *handle);
-
-void garbage_collection(volatile cell gen,
- bool growing_data_heap_,
- cell requested_bytes);
-
/* We leave this many bytes free at the top of the nursery so that inline
allocation (which does not call GC because of possible roots in volatile
registers) does not run out of memory */
static const cell allot_buffer_zone = 1024;
-inline static object *allot_zone(zone *z, cell a)
-{
- cell h = z->here;
- z->here = h + align8(a);
- object *obj = (object *)h;
- allot_barrier(obj);
- return obj;
-}
-
-/*
- * It is up to the caller to fill in the object's fields in a meaningful
- * fashion!
- */
-inline static object *allot_object(header header, cell size)
-{
-#ifdef GC_DEBUG
- if(!gc_off)
- gc();
-#endif
-
- object *obj;
-
- if(nursery.size - allot_buffer_zone > size)
- {
- /* If there is insufficient room, collect the nursery */
- if(nursery.here + allot_buffer_zone + size > nursery.end)
- garbage_collection(data->nursery(),false,0);
-
- cell h = nursery.here;
- nursery.here = h + align8(size);
- obj = (object *)h;
- }
- /* If the object is bigger than the nursery, allocate it in
- tenured space */
- else
- {
- zone *tenured = &data->generations[data->tenured()];
-
- /* If tenured space does not have enough room, collect */
- if(tenured->here + size > tenured->end)
- {
- gc();
- tenured = &data->generations[data->tenured()];
- }
-
- /* If it still won't fit, grow the heap */
- if(tenured->here + size > tenured->end)
- {
- garbage_collection(data->tenured(),true,size);
- tenured = &data->generations[data->tenured()];
- }
-
- obj = allot_zone(tenured,size);
-
- /* Allows initialization code to store old->new pointers
- without hitting the write barrier in the common case of
- a nursery allocation */
- write_barrier(obj);
- }
-
- obj->h = header;
- return obj;
-}
-
-template<typename T> T *allot(cell size)
-{
- return (T *)allot_object(header(T::type_number),size);
-}
-
-void copy_reachable_objects(cell scan, cell *end);
-
PRIMITIVE(gc);
PRIMITIVE(gc_stats);
-void clear_gc_stats();
PRIMITIVE(clear_gc_stats);
PRIMITIVE(become);
-
-extern bool growing_data_heap;
-
-inline static void check_data_pointer(object *pointer)
-{
-#ifdef FACTOR_DEBUG
- if(!growing_data_heap)
- {
- assert((cell)pointer >= data->seg->start
- && (cell)pointer < data->seg->end);
- }
-#endif
-}
-
-inline static void check_tagged_pointer(cell tagged)
-{
-#ifdef FACTOR_DEBUG
- if(!immediate_p(tagged))
- {
- object *obj = untag<object>(tagged);
- check_data_pointer(obj);
- obj->h.hi_tag();
- }
-#endif
-}
-
-VM_ASM_API void inline_gc(cell *gc_roots_base, cell gc_roots_size);
+struct factorvm;
+VM_ASM_API void inline_gc(cell *gc_roots_base, cell gc_roots_size, factorvm *myvm);
}
#include "master.hpp"
-factor::zone nursery;
-
namespace factor
{
-/* Set by the -securegc command line argument */
-bool secure_gc;
-
-/* new objects are allocated here */
-VM_C_API zone nursery;
-
-/* GC is off during heap walking */
-bool gc_off;
-
-data_heap *data;
-
-cell init_zone(zone *z, cell size, cell start)
+cell factorvm::init_zone(zone *z, cell size, cell start)
{
z->size = size;
z->start = z->here = start;
return z->end;
}
-void init_card_decks()
+
+void factorvm::init_card_decks()
{
cell start = align(data->seg->start,deck_size);
allot_markers_offset = (cell)data->allot_markers - (start >> card_bits);
decks_offset = (cell)data->decks - (start >> deck_bits);
}
-data_heap *alloc_data_heap(cell gens,
- cell young_size,
- cell aging_size,
- cell tenured_size)
+data_heap *factorvm::alloc_data_heap(cell gens, cell young_size,cell aging_size,cell tenured_size)
{
young_size = align(young_size,deck_size);
aging_size = align(aging_size,deck_size);
return data;
}
-data_heap *grow_data_heap(data_heap *data, cell requested_bytes)
+
+data_heap *factorvm::grow_data_heap(data_heap *data, cell requested_bytes)
{
cell new_tenured_size = (data->tenured_size * 2) + requested_bytes;
new_tenured_size);
}
-void dealloc_data_heap(data_heap *data)
+
+void factorvm::dealloc_data_heap(data_heap *data)
{
dealloc_segment(data->seg);
free(data->generations);
free(data);
}
-void clear_cards(cell from, cell to)
+
+void factorvm::clear_cards(cell from, cell to)
{
/* NOTE: reverse order due to heap layout. */
card *first_card = addr_to_card(data->generations[to].start);
memset(first_card,0,last_card - first_card);
}
-void clear_decks(cell from, cell to)
+
+void factorvm::clear_decks(cell from, cell to)
{
/* NOTE: reverse order due to heap layout. */
card_deck *first_deck = addr_to_deck(data->generations[to].start);
memset(first_deck,0,last_deck - first_deck);
}
-void clear_allot_markers(cell from, cell to)
+
+void factorvm::clear_allot_markers(cell from, cell to)
{
/* NOTE: reverse order due to heap layout. */
card *first_card = addr_to_allot_marker((object *)data->generations[to].start);
memset(first_card,invalid_allot_marker,last_card - first_card);
}
-void reset_generation(cell i)
+
+void factorvm::reset_generation(cell i)
{
zone *z = (i == data->nursery() ? &nursery : &data->generations[i]);
memset((void*)z->start,69,z->size);
}
+
/* After garbage collection, any generations which are now empty need to have
their allocation pointers and cards reset. */
-void reset_generations(cell from, cell to)
+void factorvm::reset_generations(cell from, cell to)
{
cell i;
for(i = from; i <= to; i++)
clear_allot_markers(from,to);
}
-void set_data_heap(data_heap *data_)
+
+void factorvm::set_data_heap(data_heap *data_)
{
data = data_;
nursery = data->generations[data->nursery()];
clear_allot_markers(data->nursery(),data->tenured());
}
-void init_data_heap(cell gens,
- cell young_size,
- cell aging_size,
- cell tenured_size,
- bool secure_gc_)
+
+void factorvm::init_data_heap(cell gens,cell young_size,cell aging_size,cell tenured_size,bool secure_gc_)
{
set_data_heap(alloc_data_heap(gens,young_size,aging_size,tenured_size));
secure_gc = secure_gc_;
init_data_gc();
}
+
/* Size of the object pointed to by a tagged pointer */
-cell object_size(cell tagged)
+cell factorvm::object_size(cell tagged)
{
if(immediate_p(tagged))
return 0;
return untagged_object_size(untag<object>(tagged));
}
+
/* Size of the object pointed to by an untagged pointer */
-cell untagged_object_size(object *pointer)
+cell factorvm::untagged_object_size(object *pointer)
{
return align8(unaligned_object_size(pointer));
}
+
/* Size of the data area of an object pointed to by an untagged pointer */
-cell unaligned_object_size(object *pointer)
+cell factorvm::unaligned_object_size(object *pointer)
{
switch(pointer->h.hi_tag())
{
}
}
-PRIMITIVE(size)
+
+inline void factorvm::vmprim_size()
{
box_unsigned_cell(object_size(dpop()));
}
+PRIMITIVE(size)
+{
+ PRIMITIVE_GETVM()->vmprim_size();
+}
+
/* The number of cells from the start of the object which should be scanned by
the GC. Some types have a binary payload at the end (string, word, DLL) which
we ignore. */
-cell binary_payload_start(object *pointer)
+cell factorvm::binary_payload_start(object *pointer)
{
switch(pointer->h.hi_tag())
{
}
}
+
/* Push memory usage statistics in data heap */
-PRIMITIVE(data_room)
+inline void factorvm::vmprim_data_room()
{
dpush(tag_fixnum((data->cards_end - data->cards) >> 10));
dpush(tag_fixnum((data->decks_end - data->decks) >> 10));
- growable_array a;
+ growable_array a(this);
cell gen;
for(gen = 0; gen < data->gen_count; gen++)
dpush(a.elements.value());
}
-/* A heap walk allows useful things to be done, like finding all
-references to an object for debugging purposes. */
-cell heap_scan_ptr;
+PRIMITIVE(data_room)
+{
+ PRIMITIVE_GETVM()->vmprim_data_room();
+}
/* Disables GC and activates next-object ( -- obj ) primitive */
-void begin_scan()
+void factorvm::begin_scan()
{
heap_scan_ptr = data->generations[data->tenured()].start;
gc_off = true;
}
-void end_scan()
+
+void factorvm::end_scan()
{
gc_off = false;
}
-PRIMITIVE(begin_scan)
+
+inline void factorvm::vmprim_begin_scan()
{
begin_scan();
}
-cell next_object()
+PRIMITIVE(begin_scan)
+{
+ PRIMITIVE_GETVM()->vmprim_begin_scan();
+}
+
+cell factorvm::next_object()
{
if(!gc_off)
general_error(ERROR_HEAP_SCAN,F,F,NULL);
return tag_dynamic(obj);
}
+
/* Push object at heap scan cursor and advance; pushes f when done */
-PRIMITIVE(next_object)
+inline void factorvm::vmprim_next_object()
{
dpush(next_object());
}
+PRIMITIVE(next_object)
+{
+ PRIMITIVE_GETVM()->vmprim_next_object();
+}
+
/* Re-enables GC */
-PRIMITIVE(end_scan)
+inline void factorvm::vmprim_end_scan()
{
gc_off = false;
}
-template<typename T> void each_object(T &functor)
+PRIMITIVE(end_scan)
+{
+ PRIMITIVE_GETVM()->vmprim_end_scan();
+}
+
+template<typename TYPE> void factorvm::each_object(TYPE &functor)
{
begin_scan();
cell obj;
end_scan();
}
+
namespace
{
struct word_accumulator {
growable_array words;
- word_accumulator(int count) : words(count) {}
+ word_accumulator(int count,factorvm *vm) : words(vm,count) {}
void operator()(tagged<object> obj) { if(obj.type_p(WORD_TYPE)) words.add(obj.value()); }
};
}
-cell find_all_words()
+cell factorvm::find_all_words()
{
word_counter counter;
each_object(counter);
- word_accumulator accum(counter.count);
+ word_accumulator accum(counter.count,this);
each_object(accum);
accum.words.trim();
return accum.words.elements.value();
}
+
}
namespace factor
{
-/* Set by the -securegc command line argument */
-extern bool secure_gc;
/* generational copying GC divides memory into zones */
struct zone {
bool have_aging_p() { return gen_count > 2; }
};
-extern data_heap *data;
static const cell max_gen_count = 3;
return (cell)pointer >= z->start && (cell)pointer < z->end;
}
-cell init_zone(zone *z, cell size, cell base);
-
-void init_card_decks();
-
-data_heap *grow_data_heap(data_heap *data, cell requested_bytes);
-
-void dealloc_data_heap(data_heap *data);
-
-void clear_cards(cell from, cell to);
-void clear_decks(cell from, cell to);
-void clear_allot_markers(cell from, cell to);
-void reset_generation(cell i);
-void reset_generations(cell from, cell to);
-
-void set_data_heap(data_heap *data_heap_);
-
-void init_data_heap(cell gens,
- cell young_size,
- cell aging_size,
- cell tenured_size,
- bool secure_gc_);
-
/* set up guard pages to check for under/overflow.
size must be a multiple of the page size */
-segment *alloc_segment(cell size);
+segment *alloc_segment(cell size); // defined in OS-*.cpp files PD
void dealloc_segment(segment *block);
-cell untagged_object_size(object *pointer);
-cell unaligned_object_size(object *pointer);
-cell binary_payload_start(object *pointer);
-cell object_size(cell tagged);
-
-void begin_scan();
-void end_scan();
-cell next_object();
-
PRIMITIVE(data_room);
PRIMITIVE(size);
PRIMITIVE(next_object);
PRIMITIVE(end_scan);
-/* GC is off during heap walking */
-extern bool gc_off;
-
-cell find_all_words();
-
-/* Every object has a regular representation in the runtime, which makes GC
-much simpler. Every slot of the object until binary_payload_start is a pointer
-to some other object. */
-inline static void do_slots(cell obj, void (* iter)(cell *))
-{
- cell scan = obj;
- cell payload_start = binary_payload_start((object *)obj);
- cell end = obj + payload_start;
-
- scan += sizeof(cell);
-
- while(scan < end)
- {
- iter((cell *)scan);
- scan += sizeof(cell);
- }
-}
-
}
-
-/* new objects are allocated here */
-VM_C_API factor::zone nursery;
namespace factor
{
-static bool fep_disabled;
-static bool full_output;
-void print_chars(string* str)
+void factorvm::print_chars(string* str)
{
cell i;
for(i = 0; i < string_capacity(str); i++)
putchar(string_nth(str,i));
}
-void print_word(word* word, cell nesting)
+
+void factorvm::print_word(word* word, cell nesting)
{
if(tagged<object>(word->vocabulary).type_p(STRING_TYPE))
{
}
}
-void print_factor_string(string* str)
+
+void factorvm::print_factor_string(string* str)
{
putchar('"');
print_chars(str);
putchar('"');
}
-void print_array(array* array, cell nesting)
+
+void factorvm::print_array(array* array, cell nesting)
{
cell length = array_capacity(array);
cell i;
print_string("...");
}
-void print_tuple(tuple *tuple, cell nesting)
+
+void factorvm::print_tuple(tuple *tuple, cell nesting)
{
tuple_layout *layout = untag<tuple_layout>(tuple->layout);
cell length = to_fixnum(layout->size);
print_string("...");
}
-void print_nested_obj(cell obj, fixnum nesting)
+
+void factorvm::print_nested_obj(cell obj, fixnum nesting)
{
if(nesting <= 0 && !full_output)
{
}
}
-void print_obj(cell obj)
+
+void factorvm::print_obj(cell obj)
{
print_nested_obj(obj,10);
}
-void print_objects(cell *start, cell *end)
+
+void factorvm::print_objects(cell *start, cell *end)
{
for(; start <= end; start++)
{
}
}
-void print_datastack()
+
+void factorvm::print_datastack()
{
print_string("==== DATA STACK:\n");
print_objects((cell *)ds_bot,(cell *)ds);
}
-void print_retainstack()
+
+void factorvm::print_retainstack()
{
print_string("==== RETAIN STACK:\n");
print_objects((cell *)rs_bot,(cell *)rs);
}
-void print_stack_frame(stack_frame *frame)
+
+void factorvm::print_stack_frame(stack_frame *frame)
{
print_obj(frame_executing(frame));
print_string("\n");
print_string("\n");
}
-void print_callstack()
+void print_stack_frame(stack_frame *frame, factorvm *myvm)
+{
+ return myvm->print_stack_frame(frame);
+}
+
+void factorvm::print_callstack()
{
print_string("==== CALL STACK:\n");
cell bottom = (cell)stack_chain->callstack_bottom;
cell top = (cell)stack_chain->callstack_top;
- iterate_callstack(top,bottom,print_stack_frame);
+ iterate_callstack(top,bottom,factor::print_stack_frame);
}
-void dump_cell(cell x)
+
+void factorvm::dump_cell(cell x)
{
print_cell_hex_pad(x); print_string(": ");
x = *(cell *)x;
nl();
}
-void dump_memory(cell from, cell to)
+
+void factorvm::dump_memory(cell from, cell to)
{
from = UNTAG(from);
dump_cell(from);
}
-void dump_zone(zone *z)
+
+void factorvm::dump_zone(zone *z)
{
print_string("Start="); print_cell(z->start);
print_string(", size="); print_cell(z->size);
print_string(", here="); print_cell(z->here - z->start); nl();
}
-void dump_generations()
+
+void factorvm::dump_generations()
{
cell i;
nl();
}
-void dump_objects(cell type)
+
+void factorvm::dump_objects(cell type)
{
gc();
begin_scan();
end_scan();
}
-cell look_for;
-cell obj;
-void find_data_references_step(cell *scan)
+
+void factorvm::find_data_references_step(cell *scan)
{
if(look_for == *scan)
{
}
}
-void find_data_references(cell look_for_)
+void find_data_references_step(cell *scan,factorvm *myvm)
+{
+ return myvm->find_data_references_step(scan);
+}
+
+void factorvm::find_data_references(cell look_for_)
{
look_for = look_for_;
begin_scan();
while((obj = next_object()) != F)
- do_slots(UNTAG(obj),find_data_references_step);
+ do_slots(UNTAG(obj),factor::find_data_references_step);
end_scan();
}
+
/* Dump all code blocks for debugging */
-void dump_code_heap()
+void factorvm::dump_code_heap()
{
cell reloc_size = 0, literal_size = 0;
print_cell(literal_size); print_string(" bytes of literal data\n");
}
-void factorbug()
+
+void factorvm::factorbug()
{
if(fep_disabled)
{
}
}
-PRIMITIVE(die)
+
+inline void factorvm::vmprim_die()
{
print_string("The die word was called by the library. Unless you called it yourself,\n");
print_string("you have triggered a bug in Factor. Please report.\n");
factorbug();
}
+PRIMITIVE(die)
+{
+ PRIMITIVE_GETVM()->vmprim_die();
+}
+
}
namespace factor
{
-void print_obj(cell obj);
-void print_nested_obj(cell obj, fixnum nesting);
-void dump_generations();
-void factorbug();
-void dump_zone(zone *z);
PRIMITIVE(die);
namespace factor
{
-cell megamorphic_cache_hits;
-cell megamorphic_cache_misses;
-
-static cell search_lookup_alist(cell table, cell klass)
+cell factorvm::search_lookup_alist(cell table, cell klass)
{
array *elements = untag<array>(table);
fixnum index = array_capacity(elements) - 2;
return F;
}
-static cell search_lookup_hash(cell table, cell klass, cell hashcode)
+cell factorvm::search_lookup_hash(cell table, cell klass, cell hashcode)
{
array *buckets = untag<array>(table);
cell bucket = array_nth(buckets,hashcode & (array_capacity(buckets) - 1));
return search_lookup_alist(bucket,klass);
}
-static cell nth_superclass(tuple_layout *layout, fixnum echelon)
+cell factorvm::nth_superclass(tuple_layout *layout, fixnum echelon)
{
cell *ptr = (cell *)(layout + 1);
return ptr[echelon * 2];
}
-static cell nth_hashcode(tuple_layout *layout, fixnum echelon)
+cell factorvm::nth_hashcode(tuple_layout *layout, fixnum echelon)
{
cell *ptr = (cell *)(layout + 1);
return ptr[echelon * 2 + 1];
}
-static cell lookup_tuple_method(cell obj, cell methods)
+cell factorvm::lookup_tuple_method(cell obj, cell methods)
{
tuple_layout *layout = untag<tuple_layout>(untag<tuple>(obj)->layout);
return F;
}
-static cell lookup_hi_tag_method(cell obj, cell methods)
+cell factorvm::lookup_hi_tag_method(cell obj, cell methods)
{
array *hi_tag_methods = untag<array>(methods);
cell tag = untag<object>(obj)->h.hi_tag() - HEADER_TYPE;
return array_nth(hi_tag_methods,tag);
}
-static cell lookup_hairy_method(cell obj, cell methods)
+cell factorvm::lookup_hairy_method(cell obj, cell methods)
{
cell method = array_nth(untag<array>(methods),TAG(obj));
if(tagged<object>(method).type_p(WORD_TYPE))
}
}
-cell lookup_method(cell obj, cell methods)
+cell factorvm::lookup_method(cell obj, cell methods)
{
cell tag = TAG(obj);
if(tag == TUPLE_TYPE || tag == OBJECT_TYPE)
return array_nth(untag<array>(methods),TAG(obj));
}
-PRIMITIVE(lookup_method)
+inline void factorvm::vmprim_lookup_method()
{
cell methods = dpop();
cell obj = dpop();
dpush(lookup_method(obj,methods));
}
-cell object_class(cell obj)
+PRIMITIVE(lookup_method)
+{
+ PRIMITIVE_GETVM()->vmprim_lookup_method();
+}
+
+cell factorvm::object_class(cell obj)
{
switch(TAG(obj))
{
}
}
-static cell method_cache_hashcode(cell klass, array *array)
+cell factorvm::method_cache_hashcode(cell klass, array *array)
{
cell capacity = (array_capacity(array) >> 1) - 1;
return ((klass >> TAG_BITS) & capacity) << 1;
}
-static void update_method_cache(cell cache, cell klass, cell method)
+void factorvm::update_method_cache(cell cache, cell klass, cell method)
{
array *cache_elements = untag<array>(cache);
cell hashcode = method_cache_hashcode(klass,cache_elements);
set_array_nth(cache_elements,hashcode + 1,method);
}
-PRIMITIVE(mega_cache_miss)
+inline void factorvm::vmprim_mega_cache_miss()
{
megamorphic_cache_misses++;
dpush(method);
}
-PRIMITIVE(reset_dispatch_stats)
+PRIMITIVE(mega_cache_miss)
+{
+ PRIMITIVE_GETVM()->vmprim_mega_cache_miss();
+}
+
+inline void factorvm::vmprim_reset_dispatch_stats()
{
megamorphic_cache_hits = megamorphic_cache_misses = 0;
}
-PRIMITIVE(dispatch_stats)
+PRIMITIVE(reset_dispatch_stats)
+{
+ PRIMITIVE_GETVM()->vmprim_reset_dispatch_stats();
+}
+
+inline void factorvm::vmprim_dispatch_stats()
{
- growable_array stats;
+ growable_array stats(this);
stats.add(allot_cell(megamorphic_cache_hits));
stats.add(allot_cell(megamorphic_cache_misses));
stats.trim();
dpush(stats.elements.value());
}
+PRIMITIVE(dispatch_stats)
+{
+ PRIMITIVE_GETVM()->vmprim_dispatch_stats();
+}
+
void quotation_jit::emit_mega_cache_lookup(cell methods_, fixnum index, cell cache_)
{
- gc_root<array> methods(methods_);
- gc_root<array> cache(cache_);
+ gc_root<array> methods(methods_,myvm);
+ gc_root<array> cache(cache_,myvm);
/* Generate machine code to determine the object's class. */
emit_class_lookup(index,PIC_HI_TAG_TUPLE);
/* Do a cache lookup. */
- emit_with(userenv[MEGA_LOOKUP],cache.value());
+ emit_with(myvm->userenv[MEGA_LOOKUP],cache.value());
/* If we end up here, the cache missed. */
- emit(userenv[JIT_PROLOG]);
+ emit(myvm->userenv[JIT_PROLOG]);
/* Push index, method table and cache on the stack. */
push(methods.value());
push(tag_fixnum(index));
push(cache.value());
- word_call(userenv[MEGA_MISS_WORD]);
+ word_call(myvm->userenv[MEGA_MISS_WORD]);
/* Now the new method has been stored into the cache, and its on
the stack. */
- emit(userenv[JIT_EPILOG]);
- emit(userenv[JIT_EXECUTE_JUMP]);
+ emit(myvm->userenv[JIT_EPILOG]);
+ emit(myvm->userenv[JIT_EXECUTE_JUMP]);
}
}
namespace factor
{
-extern cell megamorphic_cache_hits;
-extern cell megamorphic_cache_misses;
-
-cell lookup_method(cell object, cell methods);
PRIMITIVE(lookup_method);
-
-cell object_class(cell object);
-
PRIMITIVE(mega_cache_miss);
-
PRIMITIVE(reset_dispatch_stats);
PRIMITIVE(dispatch_stats);
-void jit_emit_class_lookup(jit *jit, fixnum index, cell type);
-
-void jit_emit_mega_cache_lookup(jit *jit, cell methods, fixnum index, cell cache);
-
}
namespace factor
{
-/* Global variables used to pass fault handler state from signal handler to
-user-space */
-cell signal_number;
-cell signal_fault_addr;
-unsigned int signal_fpu_status;
-stack_frame *signal_callstack_top;
-
-void out_of_memory()
+void factorvm::out_of_memory()
{
print_string("Out of memory\n\n");
dump_generations();
exit(1);
}
-void critical_error(const char* msg, cell tagged)
+void factorvm::critical_error(const char* msg, cell tagged)
{
print_string("You have triggered a bug in Factor. Please report.\n");
print_string("critical_error: "); print_string(msg);
factorbug();
}
-void throw_error(cell error, stack_frame *callstack_top)
+void factorvm::throw_error(cell error, stack_frame *callstack_top)
{
/* If the error handler is set, we rewind any C stack frames and
pass the error to user-space. */
else
callstack_top = stack_chain->callstack_top;
- throw_impl(userenv[BREAK_ENV],callstack_top);
+ throw_impl(userenv[BREAK_ENV],callstack_top,this);
}
/* Error was thrown in early startup before error handler is set, just
crash. */
}
}
-void general_error(vm_error_type error, cell arg1, cell arg2,
- stack_frame *callstack_top)
+void factorvm::general_error(vm_error_type error, cell arg1, cell arg2, stack_frame *callstack_top)
{
throw_error(allot_array_4(userenv[ERROR_ENV],
tag_fixnum(error),arg1,arg2),callstack_top);
}
-void type_error(cell type, cell tagged)
+
+void factorvm::type_error(cell type, cell tagged)
{
general_error(ERROR_TYPE,tag_fixnum(type),tagged,NULL);
}
-void not_implemented_error()
+void factorvm::not_implemented_error()
{
general_error(ERROR_NOT_IMPLEMENTED,F,F,NULL);
}
+
/* Test if 'fault' is in the guard page at the top or bottom (depending on
offset being 0 or -1) of area+area_size */
-bool in_page(cell fault, cell area, cell area_size, int offset)
+bool factorvm::in_page(cell fault, cell area, cell area_size, int offset)
{
int pagesize = getpagesize();
area += area_size;
return fault >= area && fault <= area + pagesize;
}
-void memory_protection_error(cell addr, stack_frame *native_stack)
+void factorvm::memory_protection_error(cell addr, stack_frame *native_stack)
{
if(in_page(addr, ds_bot, 0, -1))
general_error(ERROR_DS_UNDERFLOW,F,F,native_stack);
general_error(ERROR_MEMORY,allot_cell(addr),F,native_stack);
}
-void signal_error(int signal, stack_frame *native_stack)
+void factorvm::signal_error(int signal, stack_frame *native_stack)
{
general_error(ERROR_SIGNAL,tag_fixnum(signal),F,native_stack);
}
-void divide_by_zero_error()
+void factorvm::divide_by_zero_error()
{
general_error(ERROR_DIVIDE_BY_ZERO,F,F,NULL);
}
-void fp_trap_error(unsigned int fpu_status, stack_frame *signal_callstack_top)
+void factorvm::fp_trap_error(unsigned int fpu_status, stack_frame *signal_callstack_top)
{
general_error(ERROR_FP_TRAP,tag_fixnum(fpu_status),F,signal_callstack_top);
}
+inline void factorvm::vmprim_call_clear()
+{
+ throw_impl(dpop(),stack_chain->callstack_bottom,this);
+}
+
PRIMITIVE(call_clear)
{
- throw_impl(dpop(),stack_chain->callstack_bottom);
+ PRIMITIVE_GETVM()->vmprim_call_clear();
}
/* For testing purposes */
-PRIMITIVE(unimplemented)
+inline void factorvm::vmprim_unimplemented()
{
not_implemented_error();
}
-void memory_signal_handler_impl()
+PRIMITIVE(unimplemented)
+{
+ PRIMITIVE_GETVM()->vmprim_unimplemented();
+}
+
+void factorvm::memory_signal_handler_impl()
{
memory_protection_error(signal_fault_addr,signal_callstack_top);
}
-void misc_signal_handler_impl()
+void memory_signal_handler_impl()
+{
+ SIGNAL_VM_PTR()->memory_signal_handler_impl();
+}
+
+void factorvm::misc_signal_handler_impl()
{
signal_error(signal_number,signal_callstack_top);
}
-void fp_signal_handler_impl()
+void misc_signal_handler_impl()
+{
+ SIGNAL_VM_PTR()->misc_signal_handler_impl();
+}
+
+void factorvm::fp_signal_handler_impl()
{
fp_trap_error(signal_fpu_status,signal_callstack_top);
}
+void fp_signal_handler_impl()
+{
+ SIGNAL_VM_PTR()->fp_signal_handler_impl();
+}
+
}
ERROR_FP_TRAP,
};
-void out_of_memory();
-void fatal_error(const char* msg, cell tagged);
-void critical_error(const char* msg, cell tagged);
-
PRIMITIVE(die);
-
-void throw_error(cell error, stack_frame *native_stack);
-void general_error(vm_error_type error, cell arg1, cell arg2, stack_frame *native_stack);
-void divide_by_zero_error();
-void memory_protection_error(cell addr, stack_frame *native_stack);
-void signal_error(int signal, stack_frame *native_stack);
-void type_error(cell type, cell tagged);
-void not_implemented_error();
-void fp_trap_error(unsigned int fpu_status, stack_frame *signal_callstack_top);
-
PRIMITIVE(call_clear);
PRIMITIVE(unimplemented);
-/* Global variables used to pass fault handler state from signal handler to
-user-space */
-extern cell signal_number;
-extern cell signal_fault_addr;
-extern unsigned int signal_fpu_status;
-extern stack_frame *signal_callstack_top;
-
+void fatal_error(const char* msg, cell tagged);
void memory_signal_handler_impl();
void fp_signal_handler_impl();
void misc_signal_handler_impl();
namespace factor
{
-VM_C_API void default_parameters(vm_parameters *p)
+factorvm *vm;
+
+void init_globals()
+{
+ init_platform_globals();
+}
+
+void factorvm::default_parameters(vm_parameters *p)
{
p->image_path = NULL;
#ifdef WINDOWS
p->console = false;
#else
- p->console = true;
+ if (this == vm)
+ p->console = true;
+ else
+ p->console = false;
+
#endif
p->stack_traces = true;
}
-static bool factor_arg(const vm_char* str, const vm_char* arg, cell* value)
+bool factorvm::factor_arg(const vm_char* str, const vm_char* arg, cell* value)
{
int val;
if(SSCANF(str,arg,&val) > 0)
return false;
}
-VM_C_API void init_parameters_from_args(vm_parameters *p, int argc, vm_char **argv)
+void factorvm::init_parameters_from_args(vm_parameters *p, int argc, vm_char **argv)
{
default_parameters(p);
p->executable_path = argv[0];
}
/* Do some initialization that we do once only */
-static void do_stage1_init()
+void factorvm::do_stage1_init()
{
print_string("*** Stage 2 early init... ");
fflush(stdout);
fflush(stdout);
}
-VM_C_API void init_factor(vm_parameters *p)
+void factorvm::init_factor(vm_parameters *p)
{
/* Kilobytes */
p->ds_size = align_page(p->ds_size << 10);
}
/* May allocate memory */
-VM_C_API void pass_args_to_factor(int argc, vm_char **argv)
+void factorvm::pass_args_to_factor(int argc, vm_char **argv)
{
- growable_array args;
+ growable_array args(this);
int i;
- for(i = 1; i < argc; i++)
+ for(i = 1; i < argc; i++){
args.add(allot_alien(F,(cell)argv[i]));
+ }
args.trim();
userenv[ARGS_ENV] = args.elements.value();
}
-static void start_factor(vm_parameters *p)
+void factorvm::start_factor(vm_parameters *p)
{
if(p->fep) factorbug();
unnest_stacks();
}
-VM_C_API void start_embedded_factor(vm_parameters *p)
+
+char *factorvm::factor_eval_string(char *string)
+{
+ char *(*callback)(char *) = (char *(*)(char *))alien_offset(userenv[EVAL_CALLBACK_ENV]);
+ return callback(string);
+}
+
+void factorvm::factor_eval_free(char *result)
{
- userenv[EMBEDDED_ENV] = T;
- start_factor(p);
+ free(result);
}
-VM_C_API void start_standalone_factor(int argc, vm_char **argv)
+void factorvm::factor_yield()
+{
+ void (*callback)() = (void (*)())alien_offset(userenv[YIELD_CALLBACK_ENV]);
+ callback();
+}
+
+void factorvm::factor_sleep(long us)
+{
+ void (*callback)(long) = (void (*)(long))alien_offset(userenv[SLEEP_CALLBACK_ENV]);
+ callback(us);
+}
+
+void factorvm::start_standalone_factor(int argc, vm_char **argv)
{
vm_parameters p;
default_parameters(&p);
start_factor(&p);
}
-VM_C_API char *factor_eval_string(char *string)
-{
- char *(*callback)(char *) = (char *(*)(char *))alien_offset(userenv[EVAL_CALLBACK_ENV]);
- return callback(string);
-}
+struct startargs {
+ int argc;
+ vm_char **argv;
+};
-VM_C_API void factor_eval_free(char *result)
+void* start_standalone_factor_thread(void *arg)
{
- free(result);
+ factorvm *newvm = new factorvm;
+ register_vm_with_thread(newvm);
+ startargs *args = (startargs*) arg;
+ newvm->start_standalone_factor(args->argc, args->argv);
+ return 0;
}
-VM_C_API void factor_yield()
+
+VM_C_API void start_standalone_factor(int argc, vm_char **argv)
{
- void (*callback)() = (void (*)())alien_offset(userenv[YIELD_CALLBACK_ENV]);
- callback();
+ factorvm *newvm = new factorvm;
+ vm = newvm;
+ register_vm_with_thread(newvm);
+ return newvm->start_standalone_factor(argc,argv);
}
-VM_C_API void factor_sleep(long us)
+VM_C_API THREADHANDLE start_standalone_factor_in_new_thread(int argc, vm_char **argv)
{
- void (*callback)(long) = (void (*)(long))alien_offset(userenv[SLEEP_CALLBACK_ENV]);
- callback(us);
+ startargs *args = new startargs; // leaks startargs structure
+ args->argc = argc; args->argv = argv;
+ return start_thread(start_standalone_factor_thread,args);
}
}
namespace factor
{
-VM_C_API void default_parameters(vm_parameters *p);
-VM_C_API void init_parameters_from_args(vm_parameters *p, int argc, vm_char **argv);
-VM_C_API void init_factor(vm_parameters *p);
-VM_C_API void pass_args_to_factor(int argc, vm_char **argv);
-VM_C_API void start_embedded_factor(vm_parameters *p);
-VM_C_API void start_standalone_factor(int argc, vm_char **argv);
-
-VM_C_API char *factor_eval_string(char *string);
-VM_C_API void factor_eval_free(char *result);
-VM_C_API void factor_yield();
-VM_C_API void factor_sleep(long ms);
+VM_C_API void init_globals();
+VM_C_API void start_standalone_factor(int argc, vm_char **argv);
+VM_C_API THREADHANDLE start_standalone_factor_in_new_thread(int argc, vm_char **argv);
}
return array_size<T>(array_capacity(array));
}
-template <typename T> T *allot_array_internal(cell capacity)
-{
- T *array = allot<T>(array_size<T>(capacity));
- array->capacity = tag_fixnum(capacity);
- return array;
-}
-
-template <typename T> bool reallot_array_in_place_p(T *array, cell capacity)
-{
- return in_zone(&nursery,array) && capacity <= array_capacity(array);
-}
-
-template <typename T> T *reallot_array(T *array_, cell capacity)
-{
- gc_root<T> array(array_);
-
- if(reallot_array_in_place_p(array.untagged(),capacity))
- {
- array->capacity = tag_fixnum(capacity);
- return array.untagged();
- }
- else
- {
- cell to_copy = array_capacity(array.untagged());
- if(capacity < to_copy)
- to_copy = capacity;
-
- T *new_array = allot_array_internal<T>(capacity);
-
- memcpy(new_array + 1,array.untagged() + 1,to_copy * T::element_size);
- memset((char *)(new_array + 1) + to_copy * T::element_size,
- 0,(capacity - to_copy) * T::element_size);
-
- return new_array;
- }
-}
-
}
{
/* Certain special objects in the image are known to the runtime */
-static void init_objects(image_header *h)
+void factorvm::init_objects(image_header *h)
{
memcpy(userenv,h->userenv,sizeof(userenv));
bignum_neg_one = h->bignum_neg_one;
}
-cell data_relocation_base;
-static void load_data_heap(FILE *file, image_header *h, vm_parameters *p)
+
+void factorvm::load_data_heap(FILE *file, image_header *h, vm_parameters *p)
{
cell good_size = h->data_size + (1 << 20);
data_relocation_base = h->data_relocation_base;
}
-cell code_relocation_base;
-static void load_code_heap(FILE *file, image_header *h, vm_parameters *p)
+
+void factorvm::load_code_heap(FILE *file, image_header *h, vm_parameters *p)
{
if(h->code_size > p->code_size)
fatal_error("Code heap too small to fit image",h->code_size);
build_free_list(&code,h->code_size);
}
+
/* Save the current image to disk */
-bool save_image(const vm_char *filename)
+bool factorvm::save_image(const vm_char *filename)
{
FILE* file;
image_header h;
return ok;
}
-PRIMITIVE(save_image)
+
+inline void factorvm::vmprim_save_image()
{
/* do a full GC to push everything into tenured space */
gc();
- gc_root<byte_array> path(dpop());
- path.untag_check();
+ gc_root<byte_array> path(dpop(),this);
+ path.untag_check(this);
save_image((vm_char *)(path.untagged() + 1));
}
-PRIMITIVE(save_image_and_exit)
-{
+PRIMITIVE(save_image)
+{
+ PRIMITIVE_GETVM()->vmprim_save_image();
+}
+
+inline void factorvm::vmprim_save_image_and_exit()
+{
/* We unbox this before doing anything else. This is the only point
where we might throw an error, so we have to throw an error here since
later steps destroy the current image. */
- gc_root<byte_array> path(dpop());
- path.untag_check();
+ gc_root<byte_array> path(dpop(),this);
+ path.untag_check(this);
/* strip out userenv data which is set on startup anyway */
for(cell i = 0; i < USER_ENV; i++)
exit(1);
}
-static void data_fixup(cell *cell)
+PRIMITIVE(save_image_and_exit)
+{
+ PRIMITIVE_GETVM()->vmprim_save_image_and_exit();
+}
+
+void factorvm::data_fixup(cell *cell)
{
if(immediate_p(*cell))
return;
*cell += (tenured->start - data_relocation_base);
}
-template <typename T> void code_fixup(T **handle)
+void data_fixup(cell *cell, factorvm *myvm)
+{
+ return myvm->data_fixup(cell);
+}
+
+template <typename TYPE> void factorvm::code_fixup(TYPE **handle)
{
- T *ptr = *handle;
- T *new_ptr = (T *)(((cell)ptr) + (code.seg->start - code_relocation_base));
+ TYPE *ptr = *handle;
+ TYPE *new_ptr = (TYPE *)(((cell)ptr) + (code.seg->start - code_relocation_base));
*handle = new_ptr;
}
-static void fixup_word(word *word)
+
+void factorvm::fixup_word(word *word)
{
if(word->code)
code_fixup(&word->code);
code_fixup(&word->xt);
}
-static void fixup_quotation(quotation *quot)
+
+void factorvm::fixup_quotation(quotation *quot)
{
if(quot->code)
{
quot->xt = (void *)lazy_jit_compile;
}
-static void fixup_alien(alien *d)
+
+void factorvm::fixup_alien(alien *d)
{
d->expired = T;
}
-static void fixup_stack_frame(stack_frame *frame)
+
+void factorvm::fixup_stack_frame(stack_frame *frame)
{
code_fixup(&frame->xt);
code_fixup(&FRAME_RETURN_ADDRESS(frame));
}
-static void fixup_callstack_object(callstack *stack)
+void fixup_stack_frame(stack_frame *frame, factorvm *myvm)
+{
+ return myvm->fixup_stack_frame(frame);
+}
+
+void factorvm::fixup_callstack_object(callstack *stack)
{
- iterate_callstack_object(stack,fixup_stack_frame);
+ iterate_callstack_object(stack,factor::fixup_stack_frame);
}
+
/* Initialize an object in a newly-loaded image */
-static void relocate_object(object *object)
+void factorvm::relocate_object(object *object)
{
cell hi_tag = object->h.hi_tag();
}
else
{
- do_slots((cell)object,data_fixup);
+ do_slots((cell)object,factor::data_fixup);
switch(hi_tag)
{
}
}
+
/* Since the image might have been saved with a different base address than
where it is loaded, we need to fix up pointers in the image. */
-void relocate_data()
+void factorvm::relocate_data()
{
cell relocating;
}
}
-static void fixup_code_block(code_block *compiled)
+
+void factorvm::fixup_code_block(code_block *compiled)
{
/* relocate literal table data */
data_fixup(&compiled->relocation);
relocate_code_block(compiled);
}
-void relocate_code()
+void fixup_code_block(code_block *compiled,factorvm *myvm)
+{
+ return myvm->fixup_code_block(compiled);
+}
+
+void factorvm::relocate_code()
{
- iterate_code_heap(fixup_code_block);
+ iterate_code_heap(factor::fixup_code_block);
}
+
/* Read an image file from disk, only done once during startup */
/* This function also initializes the data and code heaps */
-void load_image(vm_parameters *p)
+void factorvm::load_image(vm_parameters *p)
{
FILE *file = OPEN_READ(p->image_path);
if(file == NULL)
userenv[IMAGE_ENV] = allot_alien(F,(cell)p->image_path);
}
+
}
cell max_pic_size;
};
-void load_image(vm_parameters *p);
-bool save_image(const vm_char *file);
-
PRIMITIVE(save_image);
PRIMITIVE(save_image_and_exit);
namespace factor
{
-cell max_pic_size;
-cell cold_call_to_ic_transitions;
-cell ic_to_pic_transitions;
-cell pic_to_mega_transitions;
-
-/* PIC_TAG, PIC_HI_TAG, PIC_TUPLE, PIC_HI_TAG_TUPLE */
-cell pic_counts[4];
-
-void init_inline_caching(int max_size)
+void factorvm::init_inline_caching(int max_size)
{
max_pic_size = max_size;
}
-void deallocate_inline_cache(cell return_address)
+void factorvm::deallocate_inline_cache(cell return_address)
{
/* Find the call target. */
void *old_xt = get_call_target(return_address);
/* Figure out what kind of type check the PIC needs based on the methods
it contains */
-static cell determine_inline_cache_type(array *cache_entries)
+cell factorvm::determine_inline_cache_type(array *cache_entries)
{
bool seen_hi_tag = false, seen_tuple = false;
return 0;
}
-static void update_pic_count(cell type)
+void factorvm::update_pic_count(cell type)
{
pic_counts[type - PIC_TAG]++;
}
struct inline_cache_jit : public jit {
fixnum index;
- inline_cache_jit(cell generic_word_) : jit(PIC_TYPE,generic_word_) {};
+ inline_cache_jit(cell generic_word_,factorvm *vm) : jit(PIC_TYPE,generic_word_,vm) {};
void emit_check(cell klass);
void compile_inline_cache(fixnum index,
{
cell code_template;
if(TAG(klass) == FIXNUM_TYPE && untag_fixnum(klass) < HEADER_TYPE)
- code_template = userenv[PIC_CHECK_TAG];
+ code_template = myvm->userenv[PIC_CHECK_TAG];
else
- code_template = userenv[PIC_CHECK];
+ code_template = myvm->userenv[PIC_CHECK];
emit_with(code_template,klass);
}
cell cache_entries_,
bool tail_call_p)
{
- gc_root<word> generic_word(generic_word_);
- gc_root<array> methods(methods_);
- gc_root<array> cache_entries(cache_entries_);
+ gc_root<word> generic_word(generic_word_,myvm);
+ gc_root<array> methods(methods_,myvm);
+ gc_root<array> cache_entries(cache_entries_,myvm);
- cell inline_cache_type = determine_inline_cache_type(cache_entries.untagged());
- update_pic_count(inline_cache_type);
+ cell inline_cache_type = myvm->determine_inline_cache_type(cache_entries.untagged());
+ myvm->update_pic_count(inline_cache_type);
/* Generate machine code to determine the object's class. */
emit_class_lookup(index,inline_cache_type);
/* Yes? Jump to method */
cell method = array_nth(cache_entries.untagged(),i + 1);
- emit_with(userenv[PIC_HIT],method);
+ emit_with(myvm->userenv[PIC_HIT],method);
}
/* Generate machine code to handle a cache miss, which ultimately results in
push(methods.value());
push(tag_fixnum(index));
push(cache_entries.value());
- word_special(userenv[tail_call_p ? PIC_MISS_TAIL_WORD : PIC_MISS_WORD]);
+ word_special(myvm->userenv[tail_call_p ? PIC_MISS_TAIL_WORD : PIC_MISS_WORD]);
}
-static code_block *compile_inline_cache(fixnum index,
- cell generic_word_,
- cell methods_,
- cell cache_entries_,
- bool tail_call_p)
+code_block *factorvm::compile_inline_cache(fixnum index,cell generic_word_,cell methods_,cell cache_entries_,bool tail_call_p)
{
- gc_root<word> generic_word(generic_word_);
- gc_root<array> methods(methods_);
- gc_root<array> cache_entries(cache_entries_);
+ gc_root<word> generic_word(generic_word_,this);
+ gc_root<array> methods(methods_,this);
+ gc_root<array> cache_entries(cache_entries_,this);
- inline_cache_jit jit(generic_word.value());
+ inline_cache_jit jit(generic_word.value(),this);
jit.compile_inline_cache(index,
generic_word.value(),
methods.value(),
}
/* A generic word's definition performs general method lookup. Allocates memory */
-static void *megamorphic_call_stub(cell generic_word)
+void *factorvm::megamorphic_call_stub(cell generic_word)
{
return untag<word>(generic_word)->xt;
}
-static cell inline_cache_size(cell cache_entries)
+cell factorvm::inline_cache_size(cell cache_entries)
{
return array_capacity(untag_check<array>(cache_entries)) / 2;
}
/* Allocates memory */
-static cell add_inline_cache_entry(cell cache_entries_, cell klass_, cell method_)
+cell factorvm::add_inline_cache_entry(cell cache_entries_, cell klass_, cell method_)
{
- gc_root<array> cache_entries(cache_entries_);
- gc_root<object> klass(klass_);
- gc_root<word> method(method_);
+ gc_root<array> cache_entries(cache_entries_,this);
+ gc_root<object> klass(klass_,this);
+ gc_root<word> method(method_,this);
cell pic_size = array_capacity(cache_entries.untagged());
- gc_root<array> new_cache_entries(reallot_array(cache_entries.untagged(),pic_size + 2));
+ gc_root<array> new_cache_entries(reallot_array(cache_entries.untagged(),pic_size + 2),this);
set_array_nth(new_cache_entries.untagged(),pic_size,klass.value());
set_array_nth(new_cache_entries.untagged(),pic_size + 1,method.value());
return new_cache_entries.value();
}
-static void update_pic_transitions(cell pic_size)
+void factorvm::update_pic_transitions(cell pic_size)
{
if(pic_size == max_pic_size)
pic_to_mega_transitions++;
/* The cache_entries parameter is either f (on cold call site) or an array (on cache miss).
Called from assembly with the actual return address */
-void *inline_cache_miss(cell return_address)
+void *factorvm::inline_cache_miss(cell return_address)
{
check_code_pointer(return_address);
instead of leaving dead PICs around until the next GC. */
deallocate_inline_cache(return_address);
- gc_root<array> cache_entries(dpop());
+ gc_root<array> cache_entries(dpop(),this);
fixnum index = untag_fixnum(dpop());
- gc_root<array> methods(dpop());
- gc_root<word> generic_word(dpop());
- gc_root<object> object(((cell *)ds)[-index]);
+ gc_root<array> methods(dpop(),this);
+ gc_root<word> generic_word(dpop(),this);
+ gc_root<object> object(((cell *)ds)[-index],this);
void *xt;
gc_root<array> new_cache_entries(add_inline_cache_entry(
cache_entries.value(),
klass,
- method));
+ method),this);
xt = compile_inline_cache(index,
generic_word.value(),
methods.value(),
return xt;
}
-PRIMITIVE(reset_inline_cache_stats)
+VM_C_API void *inline_cache_miss(cell return_address, factorvm *myvm)
+{
+ ASSERTVM();
+ return VM_PTR->inline_cache_miss(return_address);
+}
+
+
+inline void factorvm::vmprim_reset_inline_cache_stats()
{
cold_call_to_ic_transitions = ic_to_pic_transitions = pic_to_mega_transitions = 0;
cell i;
for(i = 0; i < 4; i++) pic_counts[i] = 0;
}
-PRIMITIVE(inline_cache_stats)
+PRIMITIVE(reset_inline_cache_stats)
+{
+ PRIMITIVE_GETVM()->vmprim_reset_inline_cache_stats();
+}
+
+inline void factorvm::vmprim_inline_cache_stats()
{
- growable_array stats;
+ growable_array stats(this);
stats.add(allot_cell(cold_call_to_ic_transitions));
stats.add(allot_cell(ic_to_pic_transitions));
stats.add(allot_cell(pic_to_mega_transitions));
dpush(stats.elements.value());
}
+PRIMITIVE(inline_cache_stats)
+{
+ PRIMITIVE_GETVM()->vmprim_inline_cache_stats();
+}
+
}
namespace factor
{
-
-extern cell max_pic_size;
-
-void init_inline_caching(int max_size);
-
PRIMITIVE(reset_inline_cache_stats);
PRIMITIVE(inline_cache_stats);
PRIMITIVE(inline_cache_miss);
PRIMITIVE(inline_cache_miss_tail);
-VM_C_API void *inline_cache_miss(cell return_address);
+VM_C_API void *inline_cache_miss(cell return_address, factorvm *vm);
}
--- /dev/null
+namespace factor
+{
+
+// I've had to copy inline implementations here to make dependencies work. Am hoping to move this code back into include files
+// once the rest of the reentrant changes are done. -PD
+
+// segments.hpp
+
+inline cell factorvm::align_page(cell a)
+{
+ return align(a,getpagesize());
+}
+
+// write_barrier.hpp
+
+inline card *factorvm::addr_to_card(cell a)
+{
+ return (card*)(((cell)(a) >> card_bits) + cards_offset);
+}
+
+
+inline cell factorvm::card_to_addr(card *c)
+{
+ return ((cell)c - cards_offset) << card_bits;
+}
+
+
+inline cell factorvm::card_offset(card *c)
+{
+ return *(c - (cell)data->cards + (cell)data->allot_markers);
+}
+
+inline card_deck *factorvm::addr_to_deck(cell a)
+{
+ return (card_deck *)(((cell)a >> deck_bits) + decks_offset);
+}
+
+inline cell factorvm::deck_to_addr(card_deck *c)
+{
+ return ((cell)c - decks_offset) << deck_bits;
+}
+
+inline card *factorvm::deck_to_card(card_deck *d)
+{
+ return (card *)((((cell)d - decks_offset) << (deck_bits - card_bits)) + cards_offset);
+}
+
+inline card *factorvm::addr_to_allot_marker(object *a)
+{
+ return (card *)(((cell)a >> card_bits) + allot_markers_offset);
+}
+
+/* the write barrier must be called any time we are potentially storing a
+pointer from an older generation to a younger one */
+inline void factorvm::write_barrier(object *obj)
+{
+ *addr_to_card((cell)obj) = card_mark_mask;
+ *addr_to_deck((cell)obj) = card_mark_mask;
+}
+
+/* we need to remember the first object allocated in the card */
+inline void factorvm::allot_barrier(object *address)
+{
+ card *ptr = addr_to_allot_marker(address);
+ if(*ptr == invalid_allot_marker)
+ *ptr = ((cell)address & addr_card_mask);
+}
+
+
+//data_gc.hpp
+inline bool factorvm::collecting_accumulation_gen_p()
+{
+ return ((data->have_aging_p()
+ && collecting_gen == data->aging()
+ && !collecting_aging_again)
+ || collecting_gen == data->tenured());
+}
+
+inline object *factorvm::allot_zone(zone *z, cell a)
+{
+ cell h = z->here;
+ z->here = h + align8(a);
+ object *obj = (object *)h;
+ allot_barrier(obj);
+ return obj;
+}
+
+/*
+ * It is up to the caller to fill in the object's fields in a meaningful
+ * fashion!
+ */
+inline object *factorvm::allot_object(header header, cell size)
+{
+#ifdef GC_DEBUG
+ if(!gc_off)
+ gc();
+#endif
+
+ object *obj;
+
+ if(nursery.size - allot_buffer_zone > size)
+ {
+ /* If there is insufficient room, collect the nursery */
+ if(nursery.here + allot_buffer_zone + size > nursery.end)
+ garbage_collection(data->nursery(),false,0);
+
+ cell h = nursery.here;
+ nursery.here = h + align8(size);
+ obj = (object *)h;
+ }
+ /* If the object is bigger than the nursery, allocate it in
+ tenured space */
+ else
+ {
+ zone *tenured = &data->generations[data->tenured()];
+
+ /* If tenured space does not have enough room, collect */
+ if(tenured->here + size > tenured->end)
+ {
+ gc();
+ tenured = &data->generations[data->tenured()];
+ }
+
+ /* If it still won't fit, grow the heap */
+ if(tenured->here + size > tenured->end)
+ {
+ garbage_collection(data->tenured(),true,size);
+ tenured = &data->generations[data->tenured()];
+ }
+
+ obj = allot_zone(tenured,size);
+
+ /* Allows initialization code to store old->new pointers
+ without hitting the write barrier in the common case of
+ a nursery allocation */
+ write_barrier(obj);
+ }
+
+ obj->h = header;
+ return obj;
+}
+
+template<typename TYPE> TYPE *factorvm::allot(cell size)
+{
+ return (TYPE *)allot_object(header(TYPE::type_number),size);
+}
+
+inline void factorvm::check_data_pointer(object *pointer)
+{
+#ifdef FACTOR_DEBUG
+ if(!growing_data_heap)
+ {
+ assert((cell)pointer >= data->seg->start
+ && (cell)pointer < data->seg->end);
+ }
+#endif
+}
+
+inline void factorvm::check_tagged_pointer(cell tagged)
+{
+#ifdef FACTOR_DEBUG
+ if(!immediate_p(tagged))
+ {
+ object *obj = untag<object>(tagged);
+ check_data_pointer(obj);
+ obj->h.hi_tag();
+ }
+#endif
+}
+
+//local_roots.hpp
+template <typename TYPE>
+struct gc_root : public tagged<TYPE>
+{
+ factorvm *myvm;
+
+ void push() { myvm->check_tagged_pointer(tagged<TYPE>::value()); myvm->gc_locals.push_back((cell)this); }
+
+ explicit gc_root(cell value_,factorvm *vm) : tagged<TYPE>(value_),myvm(vm) { push(); }
+ explicit gc_root(TYPE *value_, factorvm *vm) : tagged<TYPE>(value_),myvm(vm) { push(); }
+
+ const gc_root<TYPE>& operator=(const TYPE *x) { tagged<TYPE>::operator=(x); return *this; }
+ const gc_root<TYPE>& operator=(const cell &x) { tagged<TYPE>::operator=(x); return *this; }
+
+ ~gc_root() {
+#ifdef FACTOR_DEBUG
+ assert(myvm->gc_locals.back() == (cell)this);
+#endif
+ myvm->gc_locals.pop_back();
+ }
+};
+
+/* A similar hack for the bignum implementation */
+struct gc_bignum
+{
+ bignum **addr;
+ factorvm *myvm;
+ gc_bignum(bignum **addr_, factorvm *vm) : addr(addr_), myvm(vm) {
+ if(*addr_)
+ myvm->check_data_pointer(*addr_);
+ myvm->gc_bignums.push_back((cell)addr);
+ }
+
+ ~gc_bignum() {
+#ifdef FACTOR_DEBUG
+ assert(myvm->gc_bignums.back() == (cell)addr);
+#endif
+ myvm->gc_bignums.pop_back();
+ }
+};
+
+#define GC_BIGNUM(x,vm) gc_bignum x##__gc_root(&x,vm)
+
+//generic_arrays.hpp
+template <typename TYPE> TYPE *factorvm::allot_array_internal(cell capacity)
+{
+ TYPE *array = allot<TYPE>(array_size<TYPE>(capacity));
+ array->capacity = tag_fixnum(capacity);
+ return array;
+}
+
+template <typename TYPE> bool factorvm::reallot_array_in_place_p(TYPE *array, cell capacity)
+{
+ return in_zone(&nursery,array) && capacity <= array_capacity(array);
+}
+
+template <typename TYPE> TYPE *factorvm::reallot_array(TYPE *array_, cell capacity)
+{
+ gc_root<TYPE> array(array_,this);
+
+ if(reallot_array_in_place_p(array.untagged(),capacity))
+ {
+ array->capacity = tag_fixnum(capacity);
+ return array.untagged();
+ }
+ else
+ {
+ cell to_copy = array_capacity(array.untagged());
+ if(capacity < to_copy)
+ to_copy = capacity;
+
+ TYPE *new_array = allot_array_internal<TYPE>(capacity);
+
+ memcpy(new_array + 1,array.untagged() + 1,to_copy * TYPE::element_size);
+ memset((char *)(new_array + 1) + to_copy * TYPE::element_size,
+ 0,(capacity - to_copy) * TYPE::element_size);
+
+ return new_array;
+ }
+}
+
+//arrays.hpp
+inline void factorvm::set_array_nth(array *array, cell slot, cell value)
+{
+#ifdef FACTOR_DEBUG
+ assert(slot < array_capacity(array));
+ assert(array->h.hi_tag() == ARRAY_TYPE);
+ check_tagged_pointer(value);
+#endif
+ array->data()[slot] = value;
+ write_barrier(array);
+}
+
+struct growable_array {
+ cell count;
+ gc_root<array> elements;
+
+ growable_array(factorvm *myvm, cell capacity = 10) : count(0), elements(myvm->allot_array(capacity,F),myvm) {}
+
+ void add(cell elt);
+ void trim();
+};
+
+//byte_arrays.hpp
+struct growable_byte_array {
+ cell count;
+ gc_root<byte_array> elements;
+
+ growable_byte_array(factorvm *myvm,cell capacity = 40) : count(0), elements(myvm->allot_byte_array(capacity),myvm) { }
+
+ void append_bytes(void *elts, cell len);
+ void append_byte_array(cell elts);
+
+ void trim();
+};
+
+//math.hpp
+inline cell factorvm::allot_integer(fixnum x)
+{
+ if(x < fixnum_min || x > fixnum_max)
+ return tag<bignum>(fixnum_to_bignum(x));
+ else
+ return tag_fixnum(x);
+}
+
+inline cell factorvm::allot_cell(cell x)
+{
+ if(x > (cell)fixnum_max)
+ return tag<bignum>(cell_to_bignum(x));
+ else
+ return tag_fixnum(x);
+}
+
+inline cell factorvm::allot_float(double n)
+{
+ boxed_float *flo = allot<boxed_float>(sizeof(boxed_float));
+ flo->n = n;
+ return tag(flo);
+}
+
+inline bignum *factorvm::float_to_bignum(cell tagged)
+{
+ return double_to_bignum(untag_float(tagged));
+}
+
+inline double factorvm::bignum_to_float(cell tagged)
+{
+ return bignum_to_double(untag<bignum>(tagged));
+}
+
+inline double factorvm::untag_float(cell tagged)
+{
+ return untag<boxed_float>(tagged)->n;
+}
+
+inline double factorvm::untag_float_check(cell tagged)
+{
+ return untag_check<boxed_float>(tagged)->n;
+}
+
+inline fixnum factorvm::float_to_fixnum(cell tagged)
+{
+ return (fixnum)untag_float(tagged);
+}
+
+inline double factorvm::fixnum_to_float(cell tagged)
+{
+ return (double)untag_fixnum(tagged);
+}
+
+//callstack.hpp
+/* This is a little tricky. The iterator may allocate memory, so we
+keep the callstack in a GC root and use relative offsets */
+template<typename TYPE> void factorvm::iterate_callstack_object(callstack *stack_, TYPE &iterator)
+{
+ gc_root<callstack> stack(stack_,this);
+ fixnum frame_offset = untag_fixnum(stack->length) - sizeof(stack_frame);
+
+ while(frame_offset >= 0)
+ {
+ stack_frame *frame = stack->frame_at(frame_offset);
+ frame_offset -= frame->size;
+ iterator(frame,this);
+ }
+}
+
+//booleans.hpp
+inline cell factorvm::tag_boolean(cell untagged)
+{
+ return (untagged ? T : F);
+}
+
+// callstack.hpp
+template<typename TYPE> void factorvm::iterate_callstack(cell top, cell bottom, TYPE &iterator)
+{
+ stack_frame *frame = (stack_frame *)bottom - 1;
+
+ while((cell)frame >= top)
+ {
+ iterator(frame,this);
+ frame = frame_successor(frame);
+ }
+}
+
+
+// data_heap.hpp
+/* Every object has a regular representation in the runtime, which makes GC
+much simpler. Every slot of the object until binary_payload_start is a pointer
+to some other object. */
+struct factorvm;
+inline void factorvm::do_slots(cell obj, void (* iter)(cell *,factorvm*))
+{
+ cell scan = obj;
+ cell payload_start = binary_payload_start((object *)obj);
+ cell end = obj + payload_start;
+
+ scan += sizeof(cell);
+
+ while(scan < end)
+ {
+ iter((cell *)scan,this);
+ scan += sizeof(cell);
+ }
+}
+
+// code_heap.hpp
+
+inline void factorvm::check_code_pointer(cell ptr)
+{
+#ifdef FACTOR_DEBUG
+ assert(in_code_heap_p(ptr));
+#endif
+}
+
+}
with many more capabilities so these words are not usually used in
normal operation. */
-void init_c_io()
+void factorvm::init_c_io()
{
userenv[STDIN_ENV] = allot_alien(F,(cell)stdin);
userenv[STDOUT_ENV] = allot_alien(F,(cell)stdout);
userenv[STDERR_ENV] = allot_alien(F,(cell)stderr);
}
-void io_error()
+
+void factorvm::io_error()
{
#ifndef WINCE
if(errno == EINTR)
general_error(ERROR_IO,tag_fixnum(errno),F,NULL);
}
-PRIMITIVE(fopen)
+
+inline void factorvm::vmprim_fopen()
{
- gc_root<byte_array> mode(dpop());
- gc_root<byte_array> path(dpop());
- mode.untag_check();
- path.untag_check();
+ gc_root<byte_array> mode(dpop(),this);
+ gc_root<byte_array> path(dpop(),this);
+ mode.untag_check(this);
+ path.untag_check(this);
for(;;)
{
}
}
-PRIMITIVE(fgetc)
+PRIMITIVE(fopen)
+{
+ PRIMITIVE_GETVM()->vmprim_fopen();
+}
+
+inline void factorvm::vmprim_fgetc()
{
FILE *file = (FILE *)unbox_alien();
}
}
-PRIMITIVE(fread)
+PRIMITIVE(fgetc)
+{
+ PRIMITIVE_GETVM()->vmprim_fgetc();
+}
+
+inline void factorvm::vmprim_fread()
{
FILE *file = (FILE *)unbox_alien();
fixnum size = unbox_array_size();
return;
}
- gc_root<byte_array> buf(allot_array_internal<byte_array>(size));
+ gc_root<byte_array> buf(allot_array_internal<byte_array>(size),this);
for(;;)
{
}
}
-PRIMITIVE(fputc)
+PRIMITIVE(fread)
+{
+ PRIMITIVE_GETVM()->vmprim_fread();
+}
+
+inline void factorvm::vmprim_fputc()
{
FILE *file = (FILE *)unbox_alien();
fixnum ch = to_fixnum(dpop());
}
}
-PRIMITIVE(fwrite)
+PRIMITIVE(fputc)
+{
+ PRIMITIVE_GETVM()->vmprim_fputc();
+}
+
+inline void factorvm::vmprim_fwrite()
{
FILE *file = (FILE *)unbox_alien();
byte_array *text = untag_check<byte_array>(dpop());
}
}
-PRIMITIVE(fseek)
+PRIMITIVE(fwrite)
+{
+ PRIMITIVE_GETVM()->vmprim_fwrite();
+}
+
+inline void factorvm::vmprim_fseek()
{
int whence = to_fixnum(dpop());
FILE *file = (FILE *)unbox_alien();
}
}
-PRIMITIVE(fflush)
+PRIMITIVE(fseek)
+{
+ PRIMITIVE_GETVM()->vmprim_fseek();
+}
+
+inline void factorvm::vmprim_fflush()
{
FILE *file = (FILE *)unbox_alien();
for(;;)
}
}
-PRIMITIVE(fclose)
+PRIMITIVE(fflush)
+{
+ PRIMITIVE_GETVM()->vmprim_fflush();
+}
+
+inline void factorvm::vmprim_fclose()
{
FILE *file = (FILE *)unbox_alien();
for(;;)
}
}
+PRIMITIVE(fclose)
+{
+ PRIMITIVE_GETVM()->vmprim_fclose();
+}
+
/* This function is used by FFI I/O. Accessing the errno global directly is
not portable, since on some libc's errno is not a global but a funky macro that
reads thread-local storage. */
{
errno = 0;
}
-
}
namespace factor
{
-void init_c_io();
-void io_error();
-
PRIMITIVE(fopen);
PRIMITIVE(fgetc);
PRIMITIVE(fread);
- polymorphic inline caches (inline_cache.cpp) */
/* Allocates memory */
-jit::jit(cell type_, cell owner_)
+jit::jit(cell type_, cell owner_, factorvm *vm)
: type(type_),
- owner(owner_),
- code(),
- relocation(),
- literals(),
+ owner(owner_,vm),
+ code(vm),
+ relocation(vm),
+ literals(vm),
computing_offset_p(false),
position(0),
- offset(0)
+ offset(0),
+ myvm(vm)
{
- if(stack_traces_p()) literal(owner.value());
+ if(myvm->stack_traces_p()) literal(owner.value());
}
void jit::emit_relocation(cell code_template_)
{
- gc_root<array> code_template(code_template_);
+ gc_root<array> code_template(code_template_,myvm);
cell capacity = array_capacity(code_template.untagged());
for(cell i = 1; i < capacity; i += 3)
{
/* Allocates memory */
void jit::emit(cell code_template_)
{
- gc_root<array> code_template(code_template_);
+ gc_root<array> code_template(code_template_,myvm);
emit_relocation(code_template.value());
- gc_root<byte_array> insns(array_nth(code_template.untagged(),0));
+ gc_root<byte_array> insns(array_nth(code_template.untagged(),0),myvm);
if(computing_offset_p)
{
}
void jit::emit_with(cell code_template_, cell argument_) {
- gc_root<array> code_template(code_template_);
- gc_root<object> argument(argument_);
+ gc_root<array> code_template(code_template_,myvm);
+ gc_root<object> argument(argument_,myvm);
literal(argument.value());
emit(code_template.value());
}
void jit::emit_class_lookup(fixnum index, cell type)
{
- emit_with(userenv[PIC_LOAD],tag_fixnum(-index * sizeof(cell)));
- emit(userenv[type]);
+ emit_with(myvm->userenv[PIC_LOAD],tag_fixnum(-index * sizeof(cell)));
+ emit(myvm->userenv[type]);
}
/* Facility to convert compiled code offsets to quotation offsets.
relocation.trim();
literals.trim();
- return add_code_block(
+ return myvm->add_code_block(
type,
code.elements.value(),
F, /* no labels */
bool computing_offset_p;
fixnum position;
cell offset;
+ factorvm *myvm;
- jit(cell jit_type, cell owner);
+ jit(cell jit_type, cell owner, factorvm *vm);
void compute_position(cell offset);
void emit_relocation(cell code_template);
void emit_with(cell code_template_, cell literal_);
void push(cell literal) {
- emit_with(userenv[JIT_PUSH_IMMEDIATE],literal);
+ emit_with(myvm->userenv[JIT_PUSH_IMMEDIATE],literal);
}
void word_jump(cell word) {
literal(tag_fixnum(xt_tail_pic_offset));
literal(word);
- emit(userenv[JIT_WORD_JUMP]);
+ emit(myvm->userenv[JIT_WORD_JUMP]);
}
void word_call(cell word) {
- emit_with(userenv[JIT_WORD_CALL],word);
+ emit_with(myvm->userenv[JIT_WORD_CALL],word);
}
void word_special(cell word) {
- emit_with(userenv[JIT_WORD_SPECIAL],word);
+ emit_with(myvm->userenv[JIT_WORD_SPECIAL],word);
}
void emit_subprimitive(cell word_) {
- gc_root<word> word(word_);
- gc_root<array> code_template(word->subprimitive);
- if(array_capacity(code_template.untagged()) > 1) literal(T);
+ gc_root<word> word(word_,myvm);
+ gc_root<array> code_template(word->subprimitive,myvm);
+ if(array_capacity(code_template.untagged()) > 1) literal(myvm->T);
emit(code_template.value());
}
namespace factor
{
-
-std::vector<cell> gc_locals;
-
-std::vector<cell> gc_bignums;
-
}
namespace factor
{
-
-/* If a runtime function needs to call another function which potentially
-allocates memory, it must wrap any local variable references to Factor
-objects in gc_root instances */
-extern std::vector<cell> gc_locals;
-
-template <typename T>
-struct gc_root : public tagged<T>
-{
- void push() { check_tagged_pointer(tagged<T>::value()); gc_locals.push_back((cell)this); }
-
- explicit gc_root(cell value_) : tagged<T>(value_) { push(); }
- explicit gc_root(T *value_) : tagged<T>(value_) { push(); }
-
- const gc_root<T>& operator=(const T *x) { tagged<T>::operator=(x); return *this; }
- const gc_root<T>& operator=(const cell &x) { tagged<T>::operator=(x); return *this; }
-
- ~gc_root() {
-#ifdef FACTOR_DEBUG
- assert(gc_locals.back() == (cell)this);
-#endif
- gc_locals.pop_back();
- }
-};
-
-/* A similar hack for the bignum implementation */
-extern std::vector<cell> gc_bignums;
-
-struct gc_bignum
-{
- bignum **addr;
-
- gc_bignum(bignum **addr_) : addr(addr_) {
- if(*addr_)
- check_data_pointer(*addr_);
- gc_bignums.push_back((cell)addr);
- }
-
- ~gc_bignum() {
-#ifdef FACTOR_DEBUG
- assert(gc_bignums.back() == (cell)addr);
-#endif
- gc_bignums.pop_back();
- }
-};
-
-#define GC_BIGNUM(x) gc_bignum x##__gc_root(&x)
-
}
/* Modify a suspended thread's thread_state so that when the thread resumes
executing, the call frame of the current C primitive (if any) is rewound, and
the appropriate Factor error is thrown from the top-most Factor frame. */
-static void call_fault_handler(
+void factorvm::call_fault_handler(
exception_type_t exception,
exception_data_type_t code,
MACH_EXC_STATE_TYPE *exc_state,
if(exception == EXC_BAD_ACCESS)
{
signal_fault_addr = MACH_EXC_STATE_FAULT(exc_state);
- MACH_PROGRAM_COUNTER(thread_state) = (cell)memory_signal_handler_impl;
+ MACH_PROGRAM_COUNTER(thread_state) = (cell)factor::memory_signal_handler_impl;
}
else if(exception == EXC_ARITHMETIC && code != MACH_EXC_INTEGER_DIV)
{
- signal_fpu_status = fpu_status(mach_fpu_status(float_state));
- mach_clear_fpu_status(float_state);
- MACH_PROGRAM_COUNTER(thread_state) = (cell)fp_signal_handler_impl;
+ signal_fpu_status = fpu_status(mach_fpu_status(float_state));
+ mach_clear_fpu_status(float_state);
+ MACH_PROGRAM_COUNTER(thread_state) = (cell)factor::fp_signal_handler_impl;
}
else
{
signal_number = (exception == EXC_ARITHMETIC ? SIGFPE : SIGABRT);
- MACH_PROGRAM_COUNTER(thread_state) = (cell)misc_signal_handler_impl;
+ MACH_PROGRAM_COUNTER(thread_state) = (cell)factor::misc_signal_handler_impl;
}
}
+static void call_fault_handler(exception_type_t exception,
+ exception_data_type_t code,
+ MACH_EXC_STATE_TYPE *exc_state,
+ MACH_THREAD_STATE_TYPE *thread_state,
+ MACH_FLOAT_STATE_TYPE *float_state)
+{
+ SIGNAL_VM_PTR()->call_fault_handler(exception,code,exc_state,thread_state,float_state);
+}
+
/* Handle an exception by invoking the user's fault handler and/or forwarding
the duty to the previously installed handlers. */
extern "C"
mask = EXC_MASK_BAD_ACCESS | EXC_MASK_ARITHMETIC;
/* Create the thread listening on the exception port. */
- start_thread(mach_exception_thread);
+ start_thread(mach_exception_thread,NULL);
/* Replace the exception port info for these exceptions with our own.
Note that we replace the exception port for the entire task, not only
int main(int argc, char **argv)
{
+ factor::init_globals();
factor::start_standalone_factor(argc,argv);
return 0;
}
return 1;
}
+ factor::init_globals();
+ #ifdef FACTOR_MULTITHREADED
+ factor::THREADHANDLE thread = factor::start_standalone_factor_in_new_thread(nArgs,szArglist);
+ WaitForSingleObject(thread, INFINITE);
+ #else
factor::start_standalone_factor(nArgs,szArglist);
+ #endif
LocalFree(szArglist);
#ifndef __FACTOR_MASTER_H__
#define __FACTOR_MASTER_H__
+#define _THREAD_SAFE
+#define _REENTRANT
+
#ifndef WINCE
#include <errno.h>
#endif
#include "segments.hpp"
#include "contexts.hpp"
#include "run.hpp"
-#include "tagged.hpp"
#include "profiler.hpp"
#include "errors.hpp"
#include "bignumint.hpp"
#include "bignum.hpp"
+#include "code_block.hpp"
#include "data_heap.hpp"
#include "write_barrier.hpp"
#include "data_gc.hpp"
#include "float_bits.hpp"
#include "io.hpp"
#include "code_gc.hpp"
-#include "code_block.hpp"
#include "code_heap.hpp"
#include "image.hpp"
#include "callstack.hpp"
#include "alien.hpp"
+#include "vm.hpp"
+#include "tagged.hpp"
+#include "inlineimpls.hpp"
#include "jit.hpp"
#include "quotations.hpp"
#include "dispatch.hpp"
#include "factor.hpp"
#include "utilities.hpp"
+
+
#endif /* __FACTOR_MASTER_H__ */
namespace factor
{
-cell bignum_zero;
-cell bignum_pos_one;
-cell bignum_neg_one;
+inline void factorvm::vmprim_bignum_to_fixnum()
+{
+ drepl(tag_fixnum(bignum_to_fixnum(untag<bignum>(dpeek()))));
+}
PRIMITIVE(bignum_to_fixnum)
{
- drepl(tag_fixnum(bignum_to_fixnum(untag<bignum>(dpeek()))));
+ PRIMITIVE_GETVM()->vmprim_bignum_to_fixnum();
}
-PRIMITIVE(float_to_fixnum)
+inline void factorvm::vmprim_float_to_fixnum()
{
drepl(tag_fixnum(float_to_fixnum(dpeek())));
}
+PRIMITIVE(float_to_fixnum)
+{
+ PRIMITIVE_GETVM()->vmprim_float_to_fixnum();
+}
+
/* Division can only overflow when we are dividing the most negative fixnum
by -1. */
-PRIMITIVE(fixnum_divint)
+inline void factorvm::vmprim_fixnum_divint()
{
fixnum y = untag_fixnum(dpop()); \
fixnum x = untag_fixnum(dpeek());
drepl(tag_fixnum(result));
}
-PRIMITIVE(fixnum_divmod)
+PRIMITIVE(fixnum_divint)
+{
+ PRIMITIVE_GETVM()->vmprim_fixnum_divint();
+}
+
+inline void factorvm::vmprim_fixnum_divmod()
{
cell y = ((cell *)ds)[0];
cell x = ((cell *)ds)[-1];
}
}
+PRIMITIVE(fixnum_divmod)
+{
+ PRIMITIVE_GETVM()->vmprim_fixnum_divmod();
+}
+
/*
* If we're shifting right by n bits, we won't overflow as long as none of the
* high WORD_SIZE-TAG_BITS-n bits are set.
*/
-static inline fixnum sign_mask(fixnum x)
+inline fixnum factorvm::sign_mask(fixnum x)
{
return x >> (WORD_SIZE - 1);
}
-static inline fixnum branchless_max(fixnum x, fixnum y)
+
+inline fixnum factorvm::branchless_max(fixnum x, fixnum y)
{
return (x - ((x - y) & sign_mask(x - y)));
}
-static inline fixnum branchless_abs(fixnum x)
+
+inline fixnum factorvm::branchless_abs(fixnum x)
{
return (x ^ sign_mask(x)) - sign_mask(x);
}
-PRIMITIVE(fixnum_shift)
+
+inline void factorvm::vmprim_fixnum_shift()
{
fixnum y = untag_fixnum(dpop());
fixnum x = untag_fixnum(dpeek());
fixnum_to_bignum(x),y)));
}
-PRIMITIVE(fixnum_to_bignum)
+PRIMITIVE(fixnum_shift)
+{
+ PRIMITIVE_GETVM()->vmprim_fixnum_shift();
+}
+
+inline void factorvm::vmprim_fixnum_to_bignum()
{
drepl(tag<bignum>(fixnum_to_bignum(untag_fixnum(dpeek()))));
}
-PRIMITIVE(float_to_bignum)
+PRIMITIVE(fixnum_to_bignum)
+{
+ PRIMITIVE_GETVM()->vmprim_fixnum_to_bignum();
+}
+
+inline void factorvm::vmprim_float_to_bignum()
{
drepl(tag<bignum>(float_to_bignum(dpeek())));
}
+PRIMITIVE(float_to_bignum)
+{
+ PRIMITIVE_GETVM()->vmprim_float_to_bignum();
+}
+
#define POP_BIGNUMS(x,y) \
bignum * y = untag<bignum>(dpop()); \
bignum * x = untag<bignum>(dpop());
-PRIMITIVE(bignum_eq)
+inline void factorvm::vmprim_bignum_eq()
{
POP_BIGNUMS(x,y);
box_boolean(bignum_equal_p(x,y));
}
-PRIMITIVE(bignum_add)
+PRIMITIVE(bignum_eq)
+{
+ PRIMITIVE_GETVM()->vmprim_bignum_eq();
+}
+
+inline void factorvm::vmprim_bignum_add()
{
POP_BIGNUMS(x,y);
dpush(tag<bignum>(bignum_add(x,y)));
}
-PRIMITIVE(bignum_subtract)
+PRIMITIVE(bignum_add)
+{
+ PRIMITIVE_GETVM()->vmprim_bignum_add();
+}
+
+inline void factorvm::vmprim_bignum_subtract()
{
POP_BIGNUMS(x,y);
dpush(tag<bignum>(bignum_subtract(x,y)));
}
-PRIMITIVE(bignum_multiply)
+PRIMITIVE(bignum_subtract)
+{
+ PRIMITIVE_GETVM()->vmprim_bignum_subtract();
+}
+
+inline void factorvm::vmprim_bignum_multiply()
{
POP_BIGNUMS(x,y);
dpush(tag<bignum>(bignum_multiply(x,y)));
}
-PRIMITIVE(bignum_divint)
+PRIMITIVE(bignum_multiply)
+{
+ PRIMITIVE_GETVM()->vmprim_bignum_multiply();
+}
+
+inline void factorvm::vmprim_bignum_divint()
{
POP_BIGNUMS(x,y);
dpush(tag<bignum>(bignum_quotient(x,y)));
}
-PRIMITIVE(bignum_divmod)
+PRIMITIVE(bignum_divint)
+{
+ PRIMITIVE_GETVM()->vmprim_bignum_divint();
+}
+
+inline void factorvm::vmprim_bignum_divmod()
{
bignum *q, *r;
POP_BIGNUMS(x,y);
dpush(tag<bignum>(r));
}
-PRIMITIVE(bignum_mod)
+PRIMITIVE(bignum_divmod)
+{
+ PRIMITIVE_GETVM()->vmprim_bignum_divmod();
+}
+
+inline void factorvm::vmprim_bignum_mod()
{
POP_BIGNUMS(x,y);
dpush(tag<bignum>(bignum_remainder(x,y)));
}
-PRIMITIVE(bignum_and)
+PRIMITIVE(bignum_mod)
+{
+ PRIMITIVE_GETVM()->vmprim_bignum_mod();
+}
+
+inline void factorvm::vmprim_bignum_and()
{
POP_BIGNUMS(x,y);
dpush(tag<bignum>(bignum_bitwise_and(x,y)));
}
-PRIMITIVE(bignum_or)
+PRIMITIVE(bignum_and)
+{
+ PRIMITIVE_GETVM()->vmprim_bignum_and();
+}
+
+inline void factorvm::vmprim_bignum_or()
{
POP_BIGNUMS(x,y);
dpush(tag<bignum>(bignum_bitwise_ior(x,y)));
}
-PRIMITIVE(bignum_xor)
+PRIMITIVE(bignum_or)
+{
+ PRIMITIVE_GETVM()->vmprim_bignum_or();
+}
+
+inline void factorvm::vmprim_bignum_xor()
{
POP_BIGNUMS(x,y);
dpush(tag<bignum>(bignum_bitwise_xor(x,y)));
}
-PRIMITIVE(bignum_shift)
+PRIMITIVE(bignum_xor)
+{
+ PRIMITIVE_GETVM()->vmprim_bignum_xor();
+}
+
+inline void factorvm::vmprim_bignum_shift()
{
fixnum y = untag_fixnum(dpop());
bignum* x = untag<bignum>(dpop());
dpush(tag<bignum>(bignum_arithmetic_shift(x,y)));
}
-PRIMITIVE(bignum_less)
+PRIMITIVE(bignum_shift)
+{
+ PRIMITIVE_GETVM()->vmprim_bignum_shift();
+}
+
+inline void factorvm::vmprim_bignum_less()
{
POP_BIGNUMS(x,y);
box_boolean(bignum_compare(x,y) == bignum_comparison_less);
}
-PRIMITIVE(bignum_lesseq)
+PRIMITIVE(bignum_less)
+{
+ PRIMITIVE_GETVM()->vmprim_bignum_less();
+}
+
+inline void factorvm::vmprim_bignum_lesseq()
{
POP_BIGNUMS(x,y);
box_boolean(bignum_compare(x,y) != bignum_comparison_greater);
}
-PRIMITIVE(bignum_greater)
+PRIMITIVE(bignum_lesseq)
+{
+ PRIMITIVE_GETVM()->vmprim_bignum_lesseq();
+}
+
+inline void factorvm::vmprim_bignum_greater()
{
POP_BIGNUMS(x,y);
box_boolean(bignum_compare(x,y) == bignum_comparison_greater);
}
-PRIMITIVE(bignum_greatereq)
+PRIMITIVE(bignum_greater)
+{
+ PRIMITIVE_GETVM()->vmprim_bignum_greater();
+}
+
+inline void factorvm::vmprim_bignum_greatereq()
{
POP_BIGNUMS(x,y);
box_boolean(bignum_compare(x,y) != bignum_comparison_less);
}
-PRIMITIVE(bignum_not)
+PRIMITIVE(bignum_greatereq)
+{
+ PRIMITIVE_GETVM()->vmprim_bignum_greatereq();
+}
+
+inline void factorvm::vmprim_bignum_not()
{
drepl(tag<bignum>(bignum_bitwise_not(untag<bignum>(dpeek()))));
}
-PRIMITIVE(bignum_bitp)
+PRIMITIVE(bignum_not)
+{
+ PRIMITIVE_GETVM()->vmprim_bignum_not();
+}
+
+inline void factorvm::vmprim_bignum_bitp()
{
fixnum bit = to_fixnum(dpop());
bignum *x = untag<bignum>(dpop());
box_boolean(bignum_logbitp(bit,x));
}
-PRIMITIVE(bignum_log2)
+PRIMITIVE(bignum_bitp)
+{
+ PRIMITIVE_GETVM()->vmprim_bignum_bitp();
+}
+
+inline void factorvm::vmprim_bignum_log2()
{
drepl(tag<bignum>(bignum_integer_length(untag<bignum>(dpeek()))));
}
-unsigned int bignum_producer(unsigned int digit)
+PRIMITIVE(bignum_log2)
+{
+ PRIMITIVE_GETVM()->vmprim_bignum_log2();
+}
+
+unsigned int factorvm::bignum_producer(unsigned int digit)
{
unsigned char *ptr = (unsigned char *)alien_offset(dpeek());
return *(ptr + digit);
}
-PRIMITIVE(byte_array_to_bignum)
+unsigned int bignum_producer(unsigned int digit, factorvm *myvm)
+{
+ return myvm->bignum_producer(digit);
+}
+
+inline void factorvm::vmprim_byte_array_to_bignum()
{
cell n_digits = array_capacity(untag_check<byte_array>(dpeek()));
- bignum * result = digit_stream_to_bignum(n_digits,bignum_producer,0x100,0);
+ // bignum * result = factor::digit_stream_to_bignum(n_digits,factor::bignum_producer,0x100,0);
+ bignum * result = digit_stream_to_bignum(n_digits,factor::bignum_producer,0x100,0);
drepl(tag<bignum>(result));
}
-cell unbox_array_size()
+PRIMITIVE(byte_array_to_bignum)
+{
+ PRIMITIVE_GETVM()->vmprim_byte_array_to_bignum();
+}
+
+cell factorvm::unbox_array_size()
{
switch(tagged<object>(dpeek()).type())
{
return 0; /* can't happen */
}
-PRIMITIVE(fixnum_to_float)
+
+inline void factorvm::vmprim_fixnum_to_float()
{
drepl(allot_float(fixnum_to_float(dpeek())));
}
-PRIMITIVE(bignum_to_float)
+PRIMITIVE(fixnum_to_float)
+{
+ PRIMITIVE_GETVM()->vmprim_fixnum_to_float();
+}
+
+inline void factorvm::vmprim_bignum_to_float()
{
drepl(allot_float(bignum_to_float(dpeek())));
}
-PRIMITIVE(str_to_float)
+PRIMITIVE(bignum_to_float)
+{
+ PRIMITIVE_GETVM()->vmprim_bignum_to_float();
+}
+
+inline void factorvm::vmprim_str_to_float()
{
byte_array *bytes = untag_check<byte_array>(dpeek());
cell capacity = array_capacity(bytes);
drepl(F);
}
-PRIMITIVE(float_to_str)
+PRIMITIVE(str_to_float)
+{
+ PRIMITIVE_GETVM()->vmprim_str_to_float();
+}
+
+inline void factorvm::vmprim_float_to_str()
{
byte_array *array = allot_byte_array(33);
snprintf((char *)(array + 1),32,"%.16g",untag_float_check(dpop()));
dpush(tag<byte_array>(array));
}
+PRIMITIVE(float_to_str)
+{
+ PRIMITIVE_GETVM()->vmprim_float_to_str();
+}
+
#define POP_FLOATS(x,y) \
double y = untag_float(dpop()); \
double x = untag_float(dpop());
-PRIMITIVE(float_eq)
+inline void factorvm::vmprim_float_eq()
{
POP_FLOATS(x,y);
box_boolean(x == y);
}
-PRIMITIVE(float_add)
+PRIMITIVE(float_eq)
+{
+ PRIMITIVE_GETVM()->vmprim_float_eq();
+}
+
+inline void factorvm::vmprim_float_add()
{
POP_FLOATS(x,y);
box_double(x + y);
}
-PRIMITIVE(float_subtract)
+PRIMITIVE(float_add)
+{
+ PRIMITIVE_GETVM()->vmprim_float_add();
+}
+
+inline void factorvm::vmprim_float_subtract()
{
POP_FLOATS(x,y);
box_double(x - y);
}
-PRIMITIVE(float_multiply)
+PRIMITIVE(float_subtract)
+{
+ PRIMITIVE_GETVM()->vmprim_float_subtract();
+}
+
+inline void factorvm::vmprim_float_multiply()
{
POP_FLOATS(x,y);
box_double(x * y);
}
-PRIMITIVE(float_divfloat)
+PRIMITIVE(float_multiply)
+{
+ PRIMITIVE_GETVM()->vmprim_float_multiply();
+}
+
+inline void factorvm::vmprim_float_divfloat()
{
POP_FLOATS(x,y);
box_double(x / y);
}
-PRIMITIVE(float_mod)
+PRIMITIVE(float_divfloat)
+{
+ PRIMITIVE_GETVM()->vmprim_float_divfloat();
+}
+
+inline void factorvm::vmprim_float_mod()
{
POP_FLOATS(x,y);
box_double(fmod(x,y));
}
-PRIMITIVE(float_less)
+PRIMITIVE(float_mod)
+{
+ PRIMITIVE_GETVM()->vmprim_float_mod();
+}
+
+inline void factorvm::vmprim_float_less()
{
POP_FLOATS(x,y);
box_boolean(x < y);
}
-PRIMITIVE(float_lesseq)
+PRIMITIVE(float_less)
+{
+ PRIMITIVE_GETVM()->vmprim_float_less();
+}
+
+inline void factorvm::vmprim_float_lesseq()
{
POP_FLOATS(x,y);
box_boolean(x <= y);
}
-PRIMITIVE(float_greater)
+PRIMITIVE(float_lesseq)
+{
+ PRIMITIVE_GETVM()->vmprim_float_lesseq();
+}
+
+inline void factorvm::vmprim_float_greater()
{
POP_FLOATS(x,y);
box_boolean(x > y);
}
-PRIMITIVE(float_greatereq)
+PRIMITIVE(float_greater)
+{
+ PRIMITIVE_GETVM()->vmprim_float_greater();
+}
+
+inline void factorvm::vmprim_float_greatereq()
{
POP_FLOATS(x,y);
box_boolean(x >= y);
}
-PRIMITIVE(float_bits)
+PRIMITIVE(float_greatereq)
+{
+ PRIMITIVE_GETVM()->vmprim_float_greatereq();
+}
+
+inline void factorvm::vmprim_float_bits()
{
box_unsigned_4(float_bits(untag_float_check(dpop())));
}
-PRIMITIVE(bits_float)
+PRIMITIVE(float_bits)
+{
+ PRIMITIVE_GETVM()->vmprim_float_bits();
+}
+
+inline void factorvm::vmprim_bits_float()
{
box_float(bits_float(to_cell(dpop())));
}
-PRIMITIVE(double_bits)
+PRIMITIVE(bits_float)
+{
+ PRIMITIVE_GETVM()->vmprim_bits_float();
+}
+
+inline void factorvm::vmprim_double_bits()
{
box_unsigned_8(double_bits(untag_float_check(dpop())));
}
-PRIMITIVE(bits_double)
+PRIMITIVE(double_bits)
+{
+ PRIMITIVE_GETVM()->vmprim_double_bits();
+}
+
+inline void factorvm::vmprim_bits_double()
{
box_double(bits_double(to_unsigned_8(dpop())));
}
-VM_C_API fixnum to_fixnum(cell tagged)
+PRIMITIVE(bits_double)
+{
+ PRIMITIVE_GETVM()->vmprim_bits_double();
+}
+
+fixnum factorvm::to_fixnum(cell tagged)
{
switch(TAG(tagged))
{
}
}
-VM_C_API cell to_cell(cell tagged)
+VM_C_API fixnum to_fixnum(cell tagged,factorvm *myvm)
+{
+ ASSERTVM();
+ return VM_PTR->to_fixnum(tagged);
+}
+
+cell factorvm::to_cell(cell tagged)
{
return (cell)to_fixnum(tagged);
}
-VM_C_API void box_signed_1(s8 n)
+VM_C_API cell to_cell(cell tagged, factorvm *myvm)
+{
+ ASSERTVM();
+ return VM_PTR->to_cell(tagged);
+}
+
+void factorvm::box_signed_1(s8 n)
{
dpush(tag_fixnum(n));
}
-VM_C_API void box_unsigned_1(u8 n)
+VM_C_API void box_signed_1(s8 n,factorvm *myvm)
+{
+ ASSERTVM();
+ return VM_PTR->box_signed_1(n);
+}
+
+void factorvm::box_unsigned_1(u8 n)
{
dpush(tag_fixnum(n));
}
-VM_C_API void box_signed_2(s16 n)
+VM_C_API void box_unsigned_1(u8 n,factorvm *myvm)
+{
+ ASSERTVM();
+ return VM_PTR->box_unsigned_1(n);
+}
+
+void factorvm::box_signed_2(s16 n)
{
dpush(tag_fixnum(n));
}
-VM_C_API void box_unsigned_2(u16 n)
+VM_C_API void box_signed_2(s16 n,factorvm *myvm)
+{
+ ASSERTVM();
+ return VM_PTR->box_signed_2(n);
+}
+
+void factorvm::box_unsigned_2(u16 n)
{
dpush(tag_fixnum(n));
}
-VM_C_API void box_signed_4(s32 n)
+VM_C_API void box_unsigned_2(u16 n,factorvm *myvm)
+{
+ ASSERTVM();
+ return VM_PTR->box_unsigned_2(n);
+}
+
+void factorvm::box_signed_4(s32 n)
{
dpush(allot_integer(n));
}
-VM_C_API void box_unsigned_4(u32 n)
+VM_C_API void box_signed_4(s32 n,factorvm *myvm)
+{
+ ASSERTVM();
+ return VM_PTR->box_signed_4(n);
+}
+
+void factorvm::box_unsigned_4(u32 n)
{
dpush(allot_cell(n));
}
-VM_C_API void box_signed_cell(fixnum integer)
+VM_C_API void box_unsigned_4(u32 n,factorvm *myvm)
+{
+ ASSERTVM();
+ return VM_PTR->box_unsigned_4(n);
+}
+
+void factorvm::box_signed_cell(fixnum integer)
{
dpush(allot_integer(integer));
}
-VM_C_API void box_unsigned_cell(cell cell)
+VM_C_API void box_signed_cell(fixnum integer,factorvm *myvm)
+{
+ ASSERTVM();
+ return VM_PTR->box_signed_cell(integer);
+}
+
+void factorvm::box_unsigned_cell(cell cell)
{
dpush(allot_cell(cell));
}
-VM_C_API void box_signed_8(s64 n)
+VM_C_API void box_unsigned_cell(cell cell,factorvm *myvm)
+{
+ ASSERTVM();
+ return VM_PTR->box_unsigned_cell(cell);
+}
+
+void factorvm::box_signed_8(s64 n)
{
if(n < fixnum_min || n > fixnum_max)
dpush(tag<bignum>(long_long_to_bignum(n)));
dpush(tag_fixnum(n));
}
-VM_C_API s64 to_signed_8(cell obj)
+VM_C_API void box_signed_8(s64 n,factorvm *myvm)
+{
+ ASSERTVM();
+ return VM_PTR->box_signed_8(n);
+}
+
+s64 factorvm::to_signed_8(cell obj)
{
switch(tagged<object>(obj).type())
{
}
}
-VM_C_API void box_unsigned_8(u64 n)
+VM_C_API s64 to_signed_8(cell obj,factorvm *myvm)
+{
+ ASSERTVM();
+ return VM_PTR->to_signed_8(obj);
+}
+
+void factorvm::box_unsigned_8(u64 n)
{
if(n > (u64)fixnum_max)
dpush(tag<bignum>(ulong_long_to_bignum(n)));
dpush(tag_fixnum(n));
}
-VM_C_API u64 to_unsigned_8(cell obj)
+VM_C_API void box_unsigned_8(u64 n,factorvm *myvm)
+{
+ ASSERTVM();
+ return VM_PTR->box_unsigned_8(n);
+}
+
+u64 factorvm::to_unsigned_8(cell obj)
{
switch(tagged<object>(obj).type())
{
}
}
-VM_C_API void box_float(float flo)
+VM_C_API u64 to_unsigned_8(cell obj,factorvm *myvm)
+{
+ ASSERTVM();
+ return VM_PTR->to_unsigned_8(obj);
+}
+
+void factorvm::box_float(float flo)
{
dpush(allot_float(flo));
}
-VM_C_API float to_float(cell value)
+VM_C_API void box_float(float flo,factorvm *myvm) // not sure if this is ever called
+{
+ ASSERTVM();
+ return VM_PTR->box_float(flo);
+}
+
+float factorvm::to_float(cell value)
{
return untag_float_check(value);
}
-VM_C_API void box_double(double flo)
+VM_C_API float to_float(cell value,factorvm *myvm)
+{
+ ASSERTVM();
+ return VM_PTR->to_float(value);
+}
+
+void factorvm::box_double(double flo)
{
dpush(allot_float(flo));
}
-VM_C_API double to_double(cell value)
+VM_C_API void box_double(double flo,factorvm *myvm)
+{
+ ASSERTVM();
+ return VM_PTR->box_double(flo);
+}
+
+double factorvm::to_double(cell value)
{
return untag_float_check(value);
}
+VM_C_API double to_double(cell value,factorvm *myvm)
+{
+ ASSERTVM();
+ return VM_PTR->to_double(value);
+}
+
/* The fixnum+, fixnum- and fixnum* primitives are defined in cpu_*.S. On
overflow, they call these functions. */
-VM_ASM_API void overflow_fixnum_add(fixnum x, fixnum y)
+inline void factorvm::overflow_fixnum_add(fixnum x, fixnum y)
{
drepl(tag<bignum>(fixnum_to_bignum(
untag_fixnum(x) + untag_fixnum(y))));
}
-VM_ASM_API void overflow_fixnum_subtract(fixnum x, fixnum y)
+VM_ASM_API_OVERFLOW void overflow_fixnum_add(fixnum x, fixnum y, factorvm *myvm)
+{
+ PRIMITIVE_OVERFLOW_GETVM()->overflow_fixnum_add(x,y);
+}
+
+inline void factorvm::overflow_fixnum_subtract(fixnum x, fixnum y)
{
drepl(tag<bignum>(fixnum_to_bignum(
untag_fixnum(x) - untag_fixnum(y))));
}
-VM_ASM_API void overflow_fixnum_multiply(fixnum x, fixnum y)
+VM_ASM_API_OVERFLOW void overflow_fixnum_subtract(fixnum x, fixnum y, factorvm *myvm)
+{
+ PRIMITIVE_OVERFLOW_GETVM()->overflow_fixnum_subtract(x,y);
+}
+
+inline void factorvm::overflow_fixnum_multiply(fixnum x, fixnum y)
{
bignum *bx = fixnum_to_bignum(x);
- GC_BIGNUM(bx);
+ GC_BIGNUM(bx,this);
bignum *by = fixnum_to_bignum(y);
- GC_BIGNUM(by);
+ GC_BIGNUM(by,this);
drepl(tag<bignum>(bignum_multiply(bx,by)));
}
+VM_ASM_API_OVERFLOW void overflow_fixnum_multiply(fixnum x, fixnum y, factorvm *myvm)
+{
+ PRIMITIVE_OVERFLOW_GETVM()->overflow_fixnum_multiply(x,y);
+}
+
}
namespace factor
{
-extern cell bignum_zero;
-extern cell bignum_pos_one;
-extern cell bignum_neg_one;
-
static const fixnum fixnum_max = (((fixnum)1 << (WORD_SIZE - TAG_BITS - 1)) - 1);
static const fixnum fixnum_min = (-((fixnum)1 << (WORD_SIZE - TAG_BITS - 1)));
static const fixnum array_size_max = ((cell)1 << (WORD_SIZE - TAG_BITS - 2));
+// defined in assembler
PRIMITIVE(fixnum_add);
PRIMITIVE(fixnum_subtract);
PRIMITIVE(fixnum_multiply);
PRIMITIVE(bignum_log2);
PRIMITIVE(byte_array_to_bignum);
-inline static cell allot_integer(fixnum x)
-{
- if(x < fixnum_min || x > fixnum_max)
- return tag<bignum>(fixnum_to_bignum(x));
- else
- return tag_fixnum(x);
-}
-
-inline static cell allot_cell(cell x)
-{
- if(x > (cell)fixnum_max)
- return tag<bignum>(cell_to_bignum(x));
- else
- return tag_fixnum(x);
-}
-
-cell unbox_array_size();
-
-inline static double untag_float(cell tagged)
-{
- return untag<boxed_float>(tagged)->n;
-}
-
-inline static double untag_float_check(cell tagged)
-{
- return untag_check<boxed_float>(tagged)->n;
-}
-
-inline static cell allot_float(double n)
-{
- boxed_float *flo = allot<boxed_float>(sizeof(boxed_float));
- flo->n = n;
- return tag(flo);
-}
-
-inline static fixnum float_to_fixnum(cell tagged)
-{
- return (fixnum)untag_float(tagged);
-}
-
-inline static bignum *float_to_bignum(cell tagged)
-{
- return double_to_bignum(untag_float(tagged));
-}
-
-inline static double fixnum_to_float(cell tagged)
-{
- return (double)untag_fixnum(tagged);
-}
-
-inline static double bignum_to_float(cell tagged)
-{
- return bignum_to_double(untag<bignum>(tagged));
-}
-
PRIMITIVE(fixnum_to_float);
PRIMITIVE(bignum_to_float);
PRIMITIVE(str_to_float);
PRIMITIVE(double_bits);
PRIMITIVE(bits_double);
-VM_C_API void box_float(float flo);
-VM_C_API float to_float(cell value);
-VM_C_API void box_double(double flo);
-VM_C_API double to_double(cell value);
-
-VM_C_API void box_signed_1(s8 n);
-VM_C_API void box_unsigned_1(u8 n);
-VM_C_API void box_signed_2(s16 n);
-VM_C_API void box_unsigned_2(u16 n);
-VM_C_API void box_signed_4(s32 n);
-VM_C_API void box_unsigned_4(u32 n);
-VM_C_API void box_signed_cell(fixnum integer);
-VM_C_API void box_unsigned_cell(cell cell);
-VM_C_API void box_signed_8(s64 n);
-VM_C_API void box_unsigned_8(u64 n);
-
-VM_C_API s64 to_signed_8(cell obj);
-VM_C_API u64 to_unsigned_8(cell obj);
-
-VM_C_API fixnum to_fixnum(cell tagged);
-VM_C_API cell to_cell(cell tagged);
-
-VM_ASM_API void overflow_fixnum_add(fixnum x, fixnum y);
-VM_ASM_API void overflow_fixnum_subtract(fixnum x, fixnum y);
-VM_ASM_API void overflow_fixnum_multiply(fixnum x, fixnum y);
+VM_C_API void box_float(float flo, factorvm *vm);
+VM_C_API float to_float(cell value, factorvm *vm);
+VM_C_API void box_double(double flo, factorvm *vm);
+VM_C_API double to_double(cell value, factorvm *vm);
+
+VM_C_API void box_signed_1(s8 n, factorvm *vm);
+VM_C_API void box_unsigned_1(u8 n, factorvm *vm);
+VM_C_API void box_signed_2(s16 n, factorvm *vm);
+VM_C_API void box_unsigned_2(u16 n, factorvm *vm);
+VM_C_API void box_signed_4(s32 n, factorvm *vm);
+VM_C_API void box_unsigned_4(u32 n, factorvm *vm);
+VM_C_API void box_signed_cell(fixnum integer, factorvm *vm);
+VM_C_API void box_unsigned_cell(cell cell, factorvm *vm);
+VM_C_API void box_signed_8(s64 n, factorvm *vm);
+VM_C_API void box_unsigned_8(u64 n, factorvm *vm);
+
+VM_C_API s64 to_signed_8(cell obj, factorvm *vm);
+VM_C_API u64 to_unsigned_8(cell obj, factorvm *vm);
+
+VM_C_API fixnum to_fixnum(cell tagged, factorvm *vm);
+VM_C_API cell to_cell(cell tagged, factorvm *vm);
+
+VM_ASM_API_OVERFLOW void overflow_fixnum_add(fixnum x, fixnum y, factorvm *vm);
+VM_ASM_API_OVERFLOW void overflow_fixnum_subtract(fixnum x, fixnum y, factorvm *vm);
+VM_ASM_API_OVERFLOW void overflow_fixnum_multiply(fixnum x, fixnum y, factorvm *vm);
}
namespace factor
{
-void c_to_factor_toplevel(cell quot)
+void factorvm::c_to_factor_toplevel(cell quot)
{
- c_to_factor(quot);
+ c_to_factor(quot,this);
}
void init_signals()
: "r0","r1","r2");
if(result < 0)
- critical_error("flush_icache() failed",result);
+ SIGNAL_VM_PTR->critical_error("flush_icache() failed",result);
}
}
VM_C_API int inotify_init()
{
- not_implemented_error();
+ VM_PTR->not_implemented_error();
return -1;
}
VM_C_API int inotify_add_watch(int fd, const char *name, u32 mask)
{
- not_implemented_error();
+ VM_PTR->not_implemented_error();
return -1;
}
VM_C_API int inotify_rm_watch(int fd, u32 wd)
{
- not_implemented_error();
+ VM_PTR->not_implemented_error();
return -1;
}
namespace factor
{
-void c_to_factor_toplevel(cell quot)
+void factorvm::c_to_factor_toplevel(cell quot)
{
for(;;)
{
NS_DURING
- c_to_factor(quot);
+ c_to_factor(quot,this);
NS_VOIDRETURN;
NS_HANDLER
dpush(allot_alien(F,(cell)localException));
namespace factor
{
-void start_thread(void *(*start_routine)(void *))
+THREADHANDLE start_thread(void *(*start_routine)(void *),void *args)
{
pthread_attr_t attr;
pthread_t thread;
-
if (pthread_attr_init (&attr) != 0)
fatal_error("pthread_attr_init() failed",0);
- if (pthread_attr_setdetachstate (&attr, PTHREAD_CREATE_DETACHED) != 0)
+ if (pthread_attr_setdetachstate (&attr, PTHREAD_CREATE_JOINABLE) != 0)
fatal_error("pthread_attr_setdetachstate() failed",0);
- if (pthread_create (&thread, &attr, start_routine, NULL) != 0)
+ if (pthread_create (&thread, &attr, start_routine, args) != 0)
fatal_error("pthread_create() failed",0);
pthread_attr_destroy (&attr);
+ return thread;
+}
+
+
+pthread_key_t tlsKey = 0;
+
+void init_platform_globals()
+{
+ if (pthread_key_create(&tlsKey, NULL) != 0){
+ fatal_error("pthread_key_create() failed",0);
+ }
+
+}
+
+void register_vm_with_thread(factorvm *vm)
+{
+ pthread_setspecific(tlsKey,vm);
+}
+
+factorvm *tls_vm()
+{
+ return (factorvm*)pthread_getspecific(tlsKey);
}
static void *null_dll;
usleep(usec);
}
-void init_ffi()
+void factorvm::init_ffi()
{
/* NULL_DLL is "libfactor.dylib" for OS X and NULL for generic unix */
null_dll = dlopen(NULL_DLL,RTLD_LAZY);
}
-void ffi_dlopen(dll *dll)
+void factorvm::ffi_dlopen(dll *dll)
{
dll->dll = dlopen(alien_offset(dll->path), RTLD_LAZY);
}
-void *ffi_dlsym(dll *dll, symbol_char *symbol)
+void *factorvm::ffi_dlsym(dll *dll, symbol_char *symbol)
{
void *handle = (dll == NULL ? null_dll : dll->dll);
return dlsym(handle,symbol);
}
-void ffi_dlclose(dll *dll)
+void factorvm::ffi_dlclose(dll *dll)
{
if(dlclose(dll->dll))
general_error(ERROR_FFI,F,F,NULL);
dll->dll = NULL;
}
-PRIMITIVE(existsp)
+
+
+
+inline void factorvm::vmprim_existsp()
{
struct stat sb;
char *path = (char *)(untag_check<byte_array>(dpop()) + 1);
box_boolean(stat(path,&sb) >= 0);
}
-segment *alloc_segment(cell size)
+PRIMITIVE(existsp)
+{
+ PRIMITIVE_GETVM()->vmprim_existsp();
+}
+
+segment *factorvm::alloc_segment(cell size)
{
int pagesize = getpagesize();
free(block);
}
-static stack_frame *uap_stack_pointer(void *uap)
+stack_frame *factorvm::uap_stack_pointer(void *uap)
{
/* There is a race condition here, but in practice a signal
delivered during stack frame setup/teardown or while transitioning
return NULL;
}
-void memory_signal_handler(int signal, siginfo_t *siginfo, void *uap)
+
+
+void factorvm::memory_signal_handler(int signal, siginfo_t *siginfo, void *uap)
{
signal_fault_addr = (cell)siginfo->si_addr;
signal_callstack_top = uap_stack_pointer(uap);
- UAP_PROGRAM_COUNTER(uap) = (cell)memory_signal_handler_impl;
+ UAP_PROGRAM_COUNTER(uap) = (cell)factor::memory_signal_handler_impl;
}
-void misc_signal_handler(int signal, siginfo_t *siginfo, void *uap)
+void memory_signal_handler(int signal, siginfo_t *siginfo, void *uap)
+{
+ SIGNAL_VM_PTR()->memory_signal_handler(signal,siginfo,uap);
+}
+
+
+void factorvm::misc_signal_handler(int signal, siginfo_t *siginfo, void *uap)
{
signal_number = signal;
signal_callstack_top = uap_stack_pointer(uap);
- UAP_PROGRAM_COUNTER(uap) = (cell)misc_signal_handler_impl;
+ UAP_PROGRAM_COUNTER(uap) = (cell)factor::misc_signal_handler_impl;
}
-void fpe_signal_handler(int signal, siginfo_t *siginfo, void *uap)
+void misc_signal_handler(int signal, siginfo_t *siginfo, void *uap)
+{
+ SIGNAL_VM_PTR()->misc_signal_handler(signal,siginfo,uap);
+}
+
+void factorvm::fpe_signal_handler(int signal, siginfo_t *siginfo, void *uap)
{
signal_number = signal;
signal_callstack_top = uap_stack_pointer(uap);
- signal_fpu_status = fpu_status(uap_fpu_status(uap));
- uap_clear_fpu_status(uap);
+ signal_fpu_status = fpu_status(uap_fpu_status(uap));
+ uap_clear_fpu_status(uap);
UAP_PROGRAM_COUNTER(uap) =
- (siginfo->si_code == FPE_INTDIV || siginfo->si_code == FPE_INTOVF)
- ? (cell)misc_signal_handler_impl
- : (cell)fp_signal_handler_impl;
+ (siginfo->si_code == FPE_INTDIV || siginfo->si_code == FPE_INTOVF)
+ ? (cell)factor::misc_signal_handler_impl
+ : (cell)factor::fp_signal_handler_impl;
+}
+
+void fpe_signal_handler(int signal, siginfo_t *siginfo, void *uap)
+{
+ SIGNAL_VM_PTR()->fpe_signal_handler(signal, siginfo, uap);
}
static void sigaction_safe(int signum, const struct sigaction *act, struct sigaction *oldact)
stdin_read = filedes[0];
stdin_write = filedes[1];
- start_thread(stdin_loop);
+ start_thread(stdin_loop,NULL);
}
VM_C_API void wait_for_stdin()
#define print_native_string(string) print_string(string)
-void start_thread(void *(*start_routine)(void *));
+typedef pthread_t THREADHANDLE;
-void init_ffi();
-void ffi_dlopen(dll *dll);
-void *ffi_dlsym(dll *dll, symbol_char *symbol);
-void ffi_dlclose(dll *dll);
+THREADHANDLE start_thread(void *(*start_routine)(void *),void *args);
+pthread_t thread_id();
void unix_init_signals();
void signal_handler(int signal, siginfo_t* siginfo, void* uap);
s64 current_micros();
void sleep_micros(cell usec);
+void init_platform_globals();
+struct factorvm;
+void register_vm_with_thread(factorvm *vm);
+factorvm *tls_vm();
void open_console();
-
}
char *getenv(char *name)
{
- not_implemented_error();
+ vm->not_implemented_error();
return 0; /* unreachable */
}
PRIMITIVE(os_envs)
{
- not_implemented_error();
+ vm->not_implemented_error();
}
void c_to_factor_toplevel(cell quot)
{
- c_to_factor(quot);
+ c_to_factor(quot,vm);
}
void open_console() { }
namespace factor
{
+
+THREADHANDLE start_thread(void *(*start_routine)(void *),void *args){
+ return (void*) CreateThread(NULL, 0, (LPTHREAD_START_ROUTINE)start_routine, args, 0, 0);
+}
+
+
+DWORD dwTlsIndex;
+
+void init_platform_globals()
+{
+ if ((dwTlsIndex = TlsAlloc()) == TLS_OUT_OF_INDEXES) {
+ fatal_error("TlsAlloc failed - out of indexes",0);
+ }
+}
+
+void register_vm_with_thread(factorvm *vm)
+{
+ if (! TlsSetValue(dwTlsIndex, vm)) {
+ fatal_error("TlsSetValue failed",0);
+ }
+}
+
+factorvm *tls_vm()
+{
+ return (factorvm*)TlsGetValue(dwTlsIndex);
+}
+
+
s64 current_micros()
{
FILETIME t;
- EPOCH_OFFSET) / 10;
}
-FACTOR_STDCALL LONG exception_handler(PEXCEPTION_POINTERS pe)
+LONG factorvm::exception_handler(PEXCEPTION_POINTERS pe)
{
PEXCEPTION_RECORD e = (PEXCEPTION_RECORD)pe->ExceptionRecord;
CONTEXT *c = (CONTEXT*)pe->ContextRecord;
else
signal_callstack_top = NULL;
- switch (e->ExceptionCode)
- {
- case EXCEPTION_ACCESS_VIOLATION:
+ switch (e->ExceptionCode) {
+ case EXCEPTION_ACCESS_VIOLATION:
signal_fault_addr = e->ExceptionInformation[1];
- c->EIP = (cell)memory_signal_handler_impl;
+ c->EIP = (cell)factor::memory_signal_handler_impl;
break;
case STATUS_FLOAT_DENORMAL_OPERAND:
signal_fpu_status = fpu_status(X87SW(c) | MXCSR(c));
X87SW(c) = 0;
MXCSR(c) &= 0xffffffc0;
- c->EIP = (cell)fp_signal_handler_impl;
+ c->EIP = (cell)factor::fp_signal_handler_impl;
break;
case 0x40010006:
/* If the Widcomm bluetooth stack is installed, the BTTray.exe
break;
default:
signal_number = e->ExceptionCode;
- c->EIP = (cell)misc_signal_handler_impl;
+ c->EIP = (cell)factor::misc_signal_handler_impl;
break;
}
return EXCEPTION_CONTINUE_EXECUTION;
}
-void c_to_factor_toplevel(cell quot)
+
+FACTOR_STDCALL LONG exception_handler(PEXCEPTION_POINTERS pe)
+{
+ return SIGNAL_VM_PTR()->exception_handler(pe);
+}
+
+bool handler_added = 0;
+
+void factorvm::c_to_factor_toplevel(cell quot)
{
- if(!AddVectoredExceptionHandler(0, (PVECTORED_EXCEPTION_HANDLER)exception_handler))
- fatal_error("AddVectoredExceptionHandler failed", 0);
- c_to_factor(quot);
- RemoveVectoredExceptionHandler((void *)exception_handler);
+ if(!handler_added){
+ if(!AddVectoredExceptionHandler(0, (PVECTORED_EXCEPTION_HANDLER)factor::exception_handler))
+ fatal_error("AddVectoredExceptionHandler failed", 0);
+ handler_added = 1;
+ }
+ c_to_factor(quot,this);
+ RemoveVectoredExceptionHandler((void *)factor::exception_handler);
}
-void open_console()
+void factorvm::open_console()
{
}
#define FACTOR_STDCALL __attribute__((stdcall))
-void c_to_factor_toplevel(cell quot);
FACTOR_STDCALL LONG exception_handler(PEXCEPTION_POINTERS pe);
-void open_console();
// SSE traps raise these exception codes, which are defined in internal NT headers
// but not winbase.h
#define STATUS_FLOAT_MULTIPLE_FAULTS 0xC00002B4
#define STATUS_FLOAT_MULTIPLE_TRAPS 0xC00002B5
+typedef HANDLE THREADHANDLE;
+
+THREADHANDLE start_thread(void *(*start_routine)(void *),void *args);
+
+void init_platform_globals();
+struct factorvm;
+void register_vm_with_thread(factorvm *vm);
+factorvm *tls_vm();
+
}
HMODULE hFactorDll;
-void init_ffi()
+void factorvm::init_ffi()
{
hFactorDll = GetModuleHandle(FACTOR_DLL);
if(!hFactorDll)
fatal_error("GetModuleHandle(\"" FACTOR_DLL_NAME "\") failed", 0);
}
-void ffi_dlopen(dll *dll)
+void factorvm::ffi_dlopen(dll *dll)
{
dll->dll = LoadLibraryEx((WCHAR *)alien_offset(dll->path), NULL, 0);
}
-void *ffi_dlsym(dll *dll, symbol_char *symbol)
+void *factorvm::ffi_dlsym(dll *dll, symbol_char *symbol)
{
return (void *)GetProcAddress(dll ? (HMODULE)dll->dll : hFactorDll, symbol);
}
-void ffi_dlclose(dll *dll)
+void factorvm::ffi_dlclose(dll *dll)
{
FreeLibrary((HMODULE)dll->dll);
dll->dll = NULL;
}
-bool windows_stat(vm_char *path)
+bool factorvm::windows_stat(vm_char *path)
{
BY_HANDLE_FILE_INFORMATION bhfi;
HANDLE h = CreateFileW(path,
return ret;
}
-void windows_image_path(vm_char *full_path, vm_char *temp_path, unsigned int length)
+
+void factorvm::windows_image_path(vm_char *full_path, vm_char *temp_path, unsigned int length)
{
snwprintf(temp_path, length-1, L"%s.image", full_path);
- temp_path[sizeof(temp_path) - 1] = 0;
+ temp_path[length - 1] = 0;
}
/* You must free() this yourself. */
-const vm_char *default_image_path()
+const vm_char *factorvm::default_image_path()
{
vm_char full_path[MAX_UNICODE_PATH];
vm_char *ptr;
if((ptr = wcsrchr(full_path, '.')))
*ptr = 0;
- snwprintf(temp_path, sizeof(temp_path)-1, L"%s.image", full_path);
- temp_path[sizeof(temp_path) - 1] = 0;
+ snwprintf(temp_path, MAX_UNICODE_PATH-1, L"%s.image", full_path);
+ temp_path[MAX_UNICODE_PATH - 1] = 0;
return safe_strdup(temp_path);
}
/* You must free() this yourself. */
-const vm_char *vm_executable_path()
+const vm_char *factorvm::vm_executable_path()
{
vm_char full_path[MAX_UNICODE_PATH];
if(!GetModuleFileName(NULL, full_path, MAX_UNICODE_PATH))
}
-PRIMITIVE(existsp)
+inline void factorvm::vmprim_existsp()
{
vm_char *path = untag_check<byte_array>(dpop())->data<vm_char>();
box_boolean(windows_stat(path));
}
-segment *alloc_segment(cell size)
+PRIMITIVE(existsp)
+{
+ PRIMITIVE_GETVM()->vmprim_existsp();
+}
+
+segment *factorvm::alloc_segment(cell size)
{
char *mem;
DWORD ignore;
return block;
}
-void dealloc_segment(segment *block)
+void factorvm::dealloc_segment(segment *block)
{
SYSTEM_INFO si;
GetSystemInfo(&si);
free(block);
}
-long getpagesize()
+long factorvm::getpagesize()
{
static long g_pagesize = 0;
if (! g_pagesize)
return g_pagesize;
}
-void sleep_micros(u64 usec)
+void factorvm::sleep_micros(u64 usec)
{
Sleep((DWORD)(usec / 1000));
}
/* Difference between Jan 1 00:00:00 1601 and Jan 1 00:00:00 1970 */
#define EPOCH_OFFSET 0x019db1ded53e8000LL
-void init_ffi();
-void ffi_dlopen(dll *dll);
-void *ffi_dlsym(dll *dll, symbol_char *symbol);
-void ffi_dlclose(dll *dll);
-
-void sleep_micros(u64 msec);
inline static void init_signals() {}
inline static void early_init() {}
-const vm_char *vm_executable_path();
-const vm_char *default_image_path();
-long getpagesize ();
s64 current_micros();
primitive_inline_cache_stats,
primitive_optimized_p,
primitive_quot_compiled_p,
+ primitive_vm_ptr,
};
}
namespace factor
{
-extern "C" typedef void (*primitive_type)();
-extern const primitive_type primitives[];
-
-#define PRIMITIVE(name) extern "C" void primitive_##name()
+#if defined(FACTOR_X86)
+ extern "C" __attribute__ ((regparm (1))) typedef void (*primitive_type)(void *myvm);
+ #define PRIMITIVE(name) extern "C" __attribute__ ((regparm (1))) void primitive_##name(void *myvm)
+#else
+ extern "C" typedef void (*primitive_type)(void *myvm);
+ #define PRIMITIVE(name) extern "C" void primitive_##name(void *myvm)
+#endif
+extern const primitive_type primitives[];
}
namespace factor
{
-bool profiling_p;
-void init_profiler()
+void factorvm::init_profiler()
{
profiling_p = false;
}
+
/* Allocates memory */
-code_block *compile_profiling_stub(cell word_)
+code_block *factorvm::compile_profiling_stub(cell word_)
{
- gc_root<word> word(word_);
+ gc_root<word> word(word_,this);
- jit jit(WORD_TYPE,word.value());
+ jit jit(WORD_TYPE,word.value(),this);
jit.emit_with(userenv[JIT_PROFILING],word.value());
return jit.to_code_block();
}
+
/* Allocates memory */
-static void set_profiling(bool profiling)
+void factorvm::set_profiling(bool profiling)
{
if(profiling == profiling_p)
return;
and allocate profiling blocks if necessary */
gc();
- gc_root<array> words(find_all_words());
+ gc_root<array> words(find_all_words(),this);
cell i;
cell length = array_capacity(words.untagged());
}
/* Update XTs in code heap */
- iterate_code_heap(relocate_code_block);
+ iterate_code_heap(factor::relocate_code_block);
}
-PRIMITIVE(profiling)
+
+inline void factorvm::vmprim_profiling()
{
set_profiling(to_boolean(dpop()));
}
+PRIMITIVE(profiling)
+{
+ PRIMITIVE_GETVM()->vmprim_profiling();
+}
+
}
namespace factor
{
-extern bool profiling_p;
-void init_profiler();
-code_block *compile_profiling_stub(cell word);
PRIMITIVE(profiling);
}
{
return (i + 2) == array_capacity(elements.untagged())
&& tagged<object>(array_nth(elements.untagged(),i)).type_p(FIXNUM_TYPE)
- && array_nth(elements.untagged(),i + 1) == userenv[JIT_PRIMITIVE_WORD];
+ && array_nth(elements.untagged(),i + 1) == myvm->userenv[JIT_PRIMITIVE_WORD];
}
bool quotation_jit::fast_if_p(cell i)
return (i + 3) == array_capacity(elements.untagged())
&& tagged<object>(array_nth(elements.untagged(),i)).type_p(QUOTATION_TYPE)
&& tagged<object>(array_nth(elements.untagged(),i + 1)).type_p(QUOTATION_TYPE)
- && array_nth(elements.untagged(),i + 2) == userenv[JIT_IF_WORD];
+ && array_nth(elements.untagged(),i + 2) == myvm->userenv[JIT_IF_WORD];
}
bool quotation_jit::fast_dip_p(cell i)
{
return (i + 2) <= array_capacity(elements.untagged())
&& tagged<object>(array_nth(elements.untagged(),i)).type_p(QUOTATION_TYPE)
- && array_nth(elements.untagged(),i + 1) == userenv[JIT_DIP_WORD];
+ && array_nth(elements.untagged(),i + 1) == myvm->userenv[JIT_DIP_WORD];
}
bool quotation_jit::fast_2dip_p(cell i)
{
return (i + 2) <= array_capacity(elements.untagged())
&& tagged<object>(array_nth(elements.untagged(),i)).type_p(QUOTATION_TYPE)
- && array_nth(elements.untagged(),i + 1) == userenv[JIT_2DIP_WORD];
+ && array_nth(elements.untagged(),i + 1) == myvm->userenv[JIT_2DIP_WORD];
}
bool quotation_jit::fast_3dip_p(cell i)
{
return (i + 2) <= array_capacity(elements.untagged())
&& tagged<object>(array_nth(elements.untagged(),i)).type_p(QUOTATION_TYPE)
- && array_nth(elements.untagged(),i + 1) == userenv[JIT_3DIP_WORD];
+ && array_nth(elements.untagged(),i + 1) == myvm->userenv[JIT_3DIP_WORD];
}
bool quotation_jit::mega_lookup_p(cell i)
&& tagged<object>(array_nth(elements.untagged(),i)).type_p(ARRAY_TYPE)
&& tagged<object>(array_nth(elements.untagged(),i + 1)).type_p(FIXNUM_TYPE)
&& tagged<object>(array_nth(elements.untagged(),i + 2)).type_p(ARRAY_TYPE)
- && array_nth(elements.untagged(),i + 3) == userenv[MEGA_LOOKUP_WORD];
+ && array_nth(elements.untagged(),i + 3) == myvm->userenv[MEGA_LOOKUP_WORD];
}
bool quotation_jit::stack_frame_p()
switch(tagged<object>(obj).type())
{
case WORD_TYPE:
- if(untag<word>(obj)->subprimitive == F)
+ if(myvm->untag<word>(obj)->subprimitive == F)
return true;
break;
case QUOTATION_TYPE:
set_position(0);
if(stack_frame)
- emit(userenv[JIT_PROLOG]);
+ emit(myvm->userenv[JIT_PROLOG]);
cell i;
cell length = array_capacity(elements.untagged());
{
set_position(i);
- gc_root<object> obj(array_nth(elements.untagged(),i));
+ gc_root<object> obj(array_nth(elements.untagged(),i),myvm);
switch(obj.type())
{
if(obj.as<word>()->subprimitive != F)
emit_subprimitive(obj.value());
/* The (execute) primitive is special-cased */
- else if(obj.value() == userenv[JIT_EXECUTE_WORD])
+ else if(obj.value() == myvm->userenv[JIT_EXECUTE_WORD])
{
if(i == length - 1)
{
- if(stack_frame) emit(userenv[JIT_EPILOG]);
+ if(stack_frame) emit(myvm->userenv[JIT_EPILOG]);
tail_call = true;
- emit(userenv[JIT_EXECUTE_JUMP]);
+ emit(myvm->userenv[JIT_EXECUTE_JUMP]);
}
else
- emit(userenv[JIT_EXECUTE_CALL]);
+ emit(myvm->userenv[JIT_EXECUTE_CALL]);
}
/* Everything else */
else
{
if(i == length - 1)
{
- if(stack_frame) emit(userenv[JIT_EPILOG]);
+ if(stack_frame) emit(myvm->userenv[JIT_EPILOG]);
tail_call = true;
/* Inline cache misses are special-cased.
The calling convention for tail
the inline cache miss primitive, and
we don't want to clobber the saved
address. */
- if(obj.value() == userenv[PIC_MISS_WORD]
- || obj.value() == userenv[PIC_MISS_TAIL_WORD])
+ if(obj.value() == myvm->userenv[PIC_MISS_WORD]
+ || obj.value() == myvm->userenv[PIC_MISS_TAIL_WORD])
{
word_special(obj.value());
}
/* Primitive calls */
if(primitive_call_p(i))
{
- emit_with(userenv[JIT_PRIMITIVE],obj.value());
+ emit_with(myvm->userenv[JIT_PRIMITIVE],obj.value());
i++;
mutually recursive in the library, but both still work) */
if(fast_if_p(i))
{
- if(stack_frame) emit(userenv[JIT_EPILOG]);
+ if(stack_frame) emit(myvm->userenv[JIT_EPILOG]);
tail_call = true;
if(compiling)
{
- jit_compile(array_nth(elements.untagged(),i),relocate);
- jit_compile(array_nth(elements.untagged(),i + 1),relocate);
+ myvm->jit_compile(array_nth(elements.untagged(),i),relocate);
+ myvm->jit_compile(array_nth(elements.untagged(),i + 1),relocate);
}
literal(array_nth(elements.untagged(),i));
literal(array_nth(elements.untagged(),i + 1));
- emit(userenv[JIT_IF]);
+ emit(myvm->userenv[JIT_IF]);
i += 2;
else if(fast_dip_p(i))
{
if(compiling)
- jit_compile(obj.value(),relocate);
- emit_with(userenv[JIT_DIP],obj.value());
+ myvm->jit_compile(obj.value(),relocate);
+ emit_with(myvm->userenv[JIT_DIP],obj.value());
i++;
break;
}
else if(fast_2dip_p(i))
{
if(compiling)
- jit_compile(obj.value(),relocate);
- emit_with(userenv[JIT_2DIP],obj.value());
+ myvm->jit_compile(obj.value(),relocate);
+ emit_with(myvm->userenv[JIT_2DIP],obj.value());
i++;
break;
}
else if(fast_3dip_p(i))
{
if(compiling)
- jit_compile(obj.value(),relocate);
- emit_with(userenv[JIT_3DIP],obj.value());
+ myvm->jit_compile(obj.value(),relocate);
+ emit_with(myvm->userenv[JIT_3DIP],obj.value());
i++;
break;
}
set_position(length);
if(stack_frame)
- emit(userenv[JIT_EPILOG]);
- emit(userenv[JIT_RETURN]);
+ emit(myvm->userenv[JIT_EPILOG]);
+ emit(myvm->userenv[JIT_RETURN]);
}
}
-void set_quot_xt(quotation *quot, code_block *code)
+void factorvm::set_quot_xt(quotation *quot, code_block *code)
{
if(code->type != QUOTATION_TYPE)
critical_error("Bad param to set_quot_xt",(cell)code);
}
/* Allocates memory */
-void jit_compile(cell quot_, bool relocating)
+void factorvm::jit_compile(cell quot_, bool relocating)
{
- gc_root<quotation> quot(quot_);
+ gc_root<quotation> quot(quot_,this);
if(quot->code) return;
- quotation_jit compiler(quot.value(),true,relocating);
+ quotation_jit compiler(quot.value(),true,relocating,this);
compiler.iterate_quotation();
code_block *compiled = compiler.to_code_block();
if(relocating) relocate_code_block(compiled);
}
-PRIMITIVE(jit_compile)
+inline void factorvm::vmprim_jit_compile()
{
jit_compile(dpop(),true);
}
+PRIMITIVE(jit_compile)
+{
+ PRIMITIVE_GETVM()->vmprim_jit_compile();
+}
+
/* push a new quotation on the stack */
-PRIMITIVE(array_to_quotation)
+inline void factorvm::vmprim_array_to_quotation()
{
quotation *quot = allot<quotation>(sizeof(quotation));
quot->array = dpeek();
drepl(tag<quotation>(quot));
}
-PRIMITIVE(quotation_xt)
+PRIMITIVE(array_to_quotation)
+{
+ PRIMITIVE_GETVM()->vmprim_array_to_quotation();
+}
+
+inline void factorvm::vmprim_quotation_xt()
{
quotation *quot = untag_check<quotation>(dpeek());
drepl(allot_cell((cell)quot->xt));
}
-void compile_all_words()
+PRIMITIVE(quotation_xt)
{
- gc_root<array> words(find_all_words());
+ PRIMITIVE_GETVM()->vmprim_quotation_xt();
+}
+
+void factorvm::compile_all_words()
+{
+ gc_root<array> words(find_all_words(),this);
cell i;
cell length = array_capacity(words.untagged());
for(i = 0; i < length; i++)
{
- gc_root<word> word(array_nth(words.untagged(),i));
+ gc_root<word> word(array_nth(words.untagged(),i),this);
if(!word->code || !word_optimized_p(word.untagged()))
jit_compile_word(word.value(),word->def,false);
}
- iterate_code_heap(relocate_code_block);
+ iterate_code_heap(factor::relocate_code_block);
}
/* Allocates memory */
-fixnum quot_code_offset_to_scan(cell quot_, cell offset)
+fixnum factorvm::quot_code_offset_to_scan(cell quot_, cell offset)
{
- gc_root<quotation> quot(quot_);
- gc_root<array> array(quot->array);
+ gc_root<quotation> quot(quot_,this);
+ gc_root<array> array(quot->array,this);
- quotation_jit compiler(quot.value(),false,false);
+ quotation_jit compiler(quot.value(),false,false,this);
compiler.compute_position(offset);
compiler.iterate_quotation();
return compiler.get_position();
}
-VM_ASM_API cell lazy_jit_compile_impl(cell quot_, stack_frame *stack)
+cell factorvm::lazy_jit_compile_impl(cell quot_, stack_frame *stack)
{
- gc_root<quotation> quot(quot_);
+ gc_root<quotation> quot(quot_,this);
stack_chain->callstack_top = stack;
jit_compile(quot.value(),true);
return quot.value();
}
-PRIMITIVE(quot_compiled_p)
+VM_ASM_API cell lazy_jit_compile_impl(cell quot_, stack_frame *stack, factorvm *myvm)
+{
+ ASSERTVM();
+ return VM_PTR->lazy_jit_compile_impl(quot_,stack);
+}
+
+inline void factorvm::vmprim_quot_compiled_p()
{
tagged<quotation> quot(dpop());
- quot.untag_check();
+ quot.untag_check(this);
dpush(tag_boolean(quot->code != NULL));
}
+PRIMITIVE(quot_compiled_p)
+{
+ PRIMITIVE_GETVM()->vmprim_quot_compiled_p();
+}
+
}
gc_root<array> elements;
bool compiling, relocate;
- quotation_jit(cell quot, bool compiling_, bool relocate_)
- : jit(QUOTATION_TYPE,quot),
- elements(owner.as<quotation>().untagged()->array),
+ quotation_jit(cell quot, bool compiling_, bool relocate_, factorvm *vm)
+ : jit(QUOTATION_TYPE,quot,vm),
+ elements(owner.as<quotation>().untagged()->array,vm),
compiling(compiling_),
- relocate(relocate_) {};
+ relocate(relocate_){};
void emit_mega_cache_lookup(cell methods, fixnum index, cell cache);
bool primitive_call_p(cell i);
void iterate_quotation();
};
-void set_quot_xt(quotation *quot, code_block *code);
-void jit_compile(cell quot, bool relocate);
-fixnum quot_code_offset_to_scan(cell quot, cell offset);
-
PRIMITIVE(jit_compile);
-void compile_all_words();
-
PRIMITIVE(array_to_quotation);
PRIMITIVE(quotation_xt);
-VM_ASM_API cell lazy_jit_compile_impl(cell quot, stack_frame *stack);
+VM_ASM_API cell lazy_jit_compile_impl(cell quot, stack_frame *stack, factorvm *myvm);
PRIMITIVE(quot_compiled_p);
#include "master.hpp"
-factor::cell userenv[USER_ENV];
-
namespace factor
{
-cell T;
-PRIMITIVE(getenv)
+inline void factorvm::vmprim_getenv()
{
fixnum e = untag_fixnum(dpeek());
drepl(userenv[e]);
}
-PRIMITIVE(setenv)
+PRIMITIVE(getenv)
+{
+ PRIMITIVE_GETVM()->vmprim_getenv();
+}
+
+inline void factorvm::vmprim_setenv()
{
fixnum e = untag_fixnum(dpop());
cell value = dpop();
userenv[e] = value;
}
-PRIMITIVE(exit)
+PRIMITIVE(setenv)
+{
+ PRIMITIVE_GETVM()->vmprim_setenv();
+}
+
+inline void factorvm::vmprim_exit()
{
exit(to_fixnum(dpop()));
}
-PRIMITIVE(micros)
+PRIMITIVE(exit)
+{
+ PRIMITIVE_GETVM()->vmprim_exit();
+}
+
+inline void factorvm::vmprim_micros()
{
box_unsigned_8(current_micros());
}
-PRIMITIVE(sleep)
+PRIMITIVE(micros)
+{
+ PRIMITIVE_GETVM()->vmprim_micros();
+}
+
+inline void factorvm::vmprim_sleep()
{
sleep_micros(to_cell(dpop()));
}
-PRIMITIVE(set_slot)
+PRIMITIVE(sleep)
+{
+ PRIMITIVE_GETVM()->vmprim_sleep();
+}
+
+inline void factorvm::vmprim_set_slot()
{
fixnum slot = untag_fixnum(dpop());
object *obj = untag<object>(dpop());
write_barrier(obj);
}
-PRIMITIVE(load_locals)
+PRIMITIVE(set_slot)
+{
+ PRIMITIVE_GETVM()->vmprim_set_slot();
+}
+
+inline void factorvm::vmprim_load_locals()
{
fixnum count = untag_fixnum(dpop());
memcpy((cell *)(rs + sizeof(cell)),(cell *)(ds - sizeof(cell) * (count - 1)),sizeof(cell) * count);
rs += sizeof(cell) * count;
}
-static cell clone_object(cell obj_)
+PRIMITIVE(load_locals)
+{
+ PRIMITIVE_GETVM()->vmprim_load_locals();
+}
+
+cell factorvm::clone_object(cell obj_)
{
- gc_root<object> obj(obj_);
+ gc_root<object> obj(obj_,this);
if(immediate_p(obj.value()))
return obj.value();
}
}
-PRIMITIVE(clone)
+inline void factorvm::vmprim_clone()
{
drepl(clone_object(dpeek()));
}
+PRIMITIVE(clone)
+{
+ PRIMITIVE_GETVM()->vmprim_clone();
+}
+
}
return (i >= FIRST_SAVE_ENV && i <= LAST_SAVE_ENV) || i == STACK_TRACES_ENV;
}
-/* Canonical T object. It's just a word */
-extern cell T;
-
PRIMITIVE(getenv);
PRIMITIVE(setenv);
PRIMITIVE(exit);
}
-/* TAGGED user environment data; see getenv/setenv prims */
-VM_C_API factor::cell userenv[USER_ENV];
+
cell end;
};
-inline static cell align_page(cell a)
-{
- return align(a,getpagesize());
-}
-
}
{
#define DEFPUSHPOP(prefix,ptr) \
- inline static cell prefix##peek() { return *(cell *)ptr; } \
- inline static void prefix##repl(cell tagged) { *(cell *)ptr = tagged; } \
- inline static cell prefix##pop() \
+ inline cell prefix##peek() { return *(cell *)ptr; } \
+ inline void prefix##repl(cell tagged) { *(cell *)ptr = tagged; } \
+ inline cell prefix##pop() \
{ \
cell value = prefix##peek(); \
ptr -= sizeof(cell); \
return value; \
} \
- inline static void prefix##push(cell tagged) \
+ inline void prefix##push(cell tagged) \
{ \
ptr += sizeof(cell); \
prefix##repl(tagged); \
namespace factor
{
-cell string_nth(string* str, cell index)
+cell factorvm::string_nth(string* str, cell index)
{
/* If high bit is set, the most significant 16 bits of the char
come from the aux vector. The least significant bit of the
}
}
-void set_string_nth_fast(string *str, cell index, cell ch)
+
+void factorvm::set_string_nth_fast(string *str, cell index, cell ch)
{
str->data()[index] = ch;
}
-void set_string_nth_slow(string *str_, cell index, cell ch)
+
+void factorvm::set_string_nth_slow(string *str_, cell index, cell ch)
{
- gc_root<string> str(str_);
+ gc_root<string> str(str_,this);
byte_array *aux;
aux->data<u16>()[index] = ((ch >> 7) ^ 1);
}
+
/* allocates memory */
-void set_string_nth(string *str, cell index, cell ch)
+void factorvm::set_string_nth(string *str, cell index, cell ch)
{
if(ch <= 0x7f)
set_string_nth_fast(str,index,ch);
set_string_nth_slow(str,index,ch);
}
+
/* Allocates memory */
-string *allot_string_internal(cell capacity)
+string *factorvm::allot_string_internal(cell capacity)
{
string *str = allot<string>(string_size(capacity));
return str;
}
+
/* Allocates memory */
-void fill_string(string *str_, cell start, cell capacity, cell fill)
+void factorvm::fill_string(string *str_, cell start, cell capacity, cell fill)
{
- gc_root<string> str(str_);
+ gc_root<string> str(str_,this);
if(fill <= 0x7f)
memset(&str->data()[start],fill,capacity - start);
}
}
+
/* Allocates memory */
-string *allot_string(cell capacity, cell fill)
+string *factorvm::allot_string(cell capacity, cell fill)
{
- gc_root<string> str(allot_string_internal(capacity));
+ gc_root<string> str(allot_string_internal(capacity),this);
fill_string(str.untagged(),0,capacity,fill);
return str.untagged();
}
-PRIMITIVE(string)
+
+inline void factorvm::vmprim_string()
{
cell initial = to_cell(dpop());
cell length = unbox_array_size();
dpush(tag<string>(allot_string(length,initial)));
}
-static bool reallot_string_in_place_p(string *str, cell capacity)
+PRIMITIVE(string)
+{
+ PRIMITIVE_GETVM()->vmprim_string();
+}
+
+bool factorvm::reallot_string_in_place_p(string *str, cell capacity)
{
return in_zone(&nursery,str)
&& (str->aux == F || in_zone(&nursery,untag<byte_array>(str->aux)))
&& capacity <= string_capacity(str);
}
-string* reallot_string(string *str_, cell capacity)
+
+string* factorvm::reallot_string(string *str_, cell capacity)
{
- gc_root<string> str(str_);
+ gc_root<string> str(str_,this);
if(reallot_string_in_place_p(str.untagged(),capacity))
{
if(capacity < to_copy)
to_copy = capacity;
- gc_root<string> new_str(allot_string_internal(capacity));
+ gc_root<string> new_str(allot_string_internal(capacity),this);
memcpy(new_str->data(),str->data(),to_copy);
}
}
-PRIMITIVE(resize_string)
+
+inline void factorvm::vmprim_resize_string()
{
string* str = untag_check<string>(dpop());
cell capacity = unbox_array_size();
dpush(tag<string>(reallot_string(str,capacity)));
}
-PRIMITIVE(string_nth)
+PRIMITIVE(resize_string)
+{
+ PRIMITIVE_GETVM()->vmprim_resize_string();
+}
+
+inline void factorvm::vmprim_string_nth()
{
string *str = untag<string>(dpop());
cell index = untag_fixnum(dpop());
dpush(tag_fixnum(string_nth(str,index)));
}
-PRIMITIVE(set_string_nth_fast)
+PRIMITIVE(string_nth)
+{
+ PRIMITIVE_GETVM()->vmprim_string_nth();
+}
+
+inline void factorvm::vmprim_set_string_nth_fast()
{
string *str = untag<string>(dpop());
cell index = untag_fixnum(dpop());
set_string_nth_fast(str,index,value);
}
-PRIMITIVE(set_string_nth_slow)
+PRIMITIVE(set_string_nth_fast)
+{
+ PRIMITIVE_GETVM()->vmprim_set_string_nth_fast();
+}
+
+inline void factorvm::vmprim_set_string_nth_slow()
{
string *str = untag<string>(dpop());
cell index = untag_fixnum(dpop());
set_string_nth_slow(str,index,value);
}
+PRIMITIVE(set_string_nth_slow)
+{
+ PRIMITIVE_GETVM()->vmprim_set_string_nth_slow();
+}
+
}
return sizeof(string) + size;
}
-string* allot_string_internal(cell capacity);
-string* allot_string(cell capacity, cell fill);
PRIMITIVE(string);
-string *reallot_string(string *string, cell capacity);
PRIMITIVE(resize_string);
-/* String getters and setters */
-cell string_nth(string* string, cell index);
-void set_string_nth(string* string, cell index, cell value);
-
PRIMITIVE(string_nth);
PRIMITIVE(set_string_nth_slow);
PRIMITIVE(set_string_nth_fast);
namespace factor
{
-template <typename T> cell tag(T *value)
+template <typename TYPE> cell tag(TYPE *value)
{
- return RETAG(value,tag_for(T::type_number));
+ return RETAG(value,tag_for(TYPE::type_number));
}
inline static cell tag_dynamic(object *value)
return RETAG(value,tag_for(value->h.hi_tag()));
}
-template <typename T>
+template <typename TYPE>
struct tagged
{
cell value_;
cell value() const { return value_; }
- T *untagged() const { return (T *)(UNTAG(value_)); }
+ TYPE *untagged() const { return (TYPE *)(UNTAG(value_)); }
cell type() const {
cell tag = TAG(value_);
bool type_p(cell type_) const { return type() == type_; }
- T *untag_check() const {
- if(T::type_number != TYPE_COUNT && !type_p(T::type_number))
- type_error(T::type_number,value_);
+ TYPE *untag_check(factorvm *myvm) const {
+ if(TYPE::type_number != TYPE_COUNT && !type_p(TYPE::type_number))
+ myvm->type_error(TYPE::type_number,value_);
return untagged();
}
explicit tagged(cell tagged) : value_(tagged) {
#ifdef FACTOR_DEBUG
- untag_check();
+ untag_check(SIGNAL_VM_PTR());
#endif
}
- explicit tagged(T *untagged) : value_(factor::tag(untagged)) {
+ explicit tagged(TYPE *untagged) : value_(factor::tag(untagged)) {
#ifdef FACTOR_DEBUG
- untag_check();
+ untag_check(SIGNAL_VM_PTR());
#endif
}
- T *operator->() const { return untagged(); }
+ TYPE *operator->() const { return untagged(); }
cell *operator&() const { return &value_; }
- const tagged<T>& operator=(const T *x) { value_ = tag(x); return *this; }
- const tagged<T>& operator=(const cell &x) { value_ = x; return *this; }
+ const tagged<TYPE>& operator=(const TYPE *x) { value_ = tag(x); return *this; }
+ const tagged<TYPE>& operator=(const cell &x) { value_ = x; return *this; }
- bool operator==(const tagged<T> &x) { return value_ == x.value_; }
- bool operator!=(const tagged<T> &x) { return value_ != x.value_; }
+ bool operator==(const tagged<TYPE> &x) { return value_ == x.value_; }
+ bool operator!=(const tagged<TYPE> &x) { return value_ != x.value_; }
template<typename X> tagged<X> as() { return tagged<X>(value_); }
};
-template <typename T> T *untag_check(cell value)
+template <typename TYPE> TYPE *factorvm::untag_check(cell value)
{
- return tagged<T>(value).untag_check();
+ return tagged<TYPE>(value).untag_check(this);
}
-template <typename T> T *untag(cell value)
+template <typename TYPE> TYPE *factorvm::untag(cell value)
{
- return tagged<T>(value).untagged();
+ return tagged<TYPE>(value).untagged();
}
}
{
/* push a new tuple on the stack */
-tuple *allot_tuple(cell layout_)
+tuple *factorvm::allot_tuple(cell layout_)
{
- gc_root<tuple_layout> layout(layout_);
- gc_root<tuple> t(allot<tuple>(tuple_size(layout.untagged())));
+ gc_root<tuple_layout> layout(layout_,this);
+ gc_root<tuple> t(allot<tuple>(tuple_size(layout.untagged())),this);
t->layout = layout.value();
return t.untagged();
}
-PRIMITIVE(tuple)
+inline void factorvm::vmprim_tuple()
{
- gc_root<tuple_layout> layout(dpop());
+ gc_root<tuple_layout> layout(dpop(),this);
tuple *t = allot_tuple(layout.value());
fixnum i;
for(i = tuple_size(layout.untagged()) - 1; i >= 0; i--)
dpush(tag<tuple>(t));
}
+PRIMITIVE(tuple)
+{
+ PRIMITIVE_GETVM()->vmprim_tuple();
+}
+
/* push a new tuple on the stack, filling its slots from the stack */
-PRIMITIVE(tuple_boa)
+inline void factorvm::vmprim_tuple_boa()
{
- gc_root<tuple_layout> layout(dpop());
- gc_root<tuple> t(allot_tuple(layout.value()));
+ gc_root<tuple_layout> layout(dpop(),this);
+ gc_root<tuple> t(allot_tuple(layout.value()),this);
cell size = untag_fixnum(layout.untagged()->size) * sizeof(cell);
memcpy(t->data(),(cell *)(ds - (size - sizeof(cell))),size);
ds -= size;
dpush(t.value());
}
+PRIMITIVE(tuple_boa)
+{
+ PRIMITIVE_GETVM()->vmprim_tuple_boa();
+}
+
}
return ptr;
}
+
/* We don't use printf directly, because format directives are not portable.
Instead we define the common cases here. */
void nl()
fputs(str,stdout);
}
+
void print_cell(cell x)
{
printf(CELL_FORMAT,x);
cell cell;
if(scanf(CELL_HEX_FORMAT,&cell) < 0) exit(1);
return cell;
-};
+}
}
namespace factor
{
-
-void *safe_malloc(size_t size);
-vm_char *safe_strdup(const vm_char *str);
-
-void nl();
-void print_string(const char *str);
-void print_cell(cell x);
-void print_cell_hex(cell x);
-void print_cell_hex_pad(cell x);
-void print_fixnum(fixnum x);
-cell read_cell_hex();
-
+ void *safe_malloc(size_t size);
+ vm_char *safe_strdup(const vm_char *str);
+ void print_string(const char *str);
+ void nl();
+ void print_cell(cell x);
+ void print_cell_hex(cell x);
+ void print_cell_hex_pad(cell x);
+ void print_fixnum(fixnum x);
+ cell read_cell_hex();
}
--- /dev/null
+namespace factor
+{
+
+struct factorvmdata {
+ // if you change this struct, also change vm.factor k--------
+ context *stack_chain;
+ zone nursery; /* new objects are allocated here */
+ cell cards_offset;
+ cell decks_offset;
+ cell userenv[USER_ENV]; /* TAGGED user environment data; see getenv/setenv prims */
+
+ // -------------------------------
+
+ // contexts
+ cell ds_size, rs_size;
+ context *unused_contexts;
+
+ // run
+ cell T; /* Canonical T object. It's just a word */
+
+ // profiler
+ bool profiling_p;
+
+ // errors
+ /* Global variables used to pass fault handler state from signal handler to
+ user-space */
+ cell signal_number;
+ cell signal_fault_addr;
+ unsigned int signal_fpu_status;
+ stack_frame *signal_callstack_top;
+
+ //data_heap
+ bool secure_gc; /* Set by the -securegc command line argument */
+ bool gc_off; /* GC is off during heap walking */
+ data_heap *data;
+ /* A heap walk allows useful things to be done, like finding all
+ references to an object for debugging purposes. */
+ cell heap_scan_ptr;
+ //write barrier
+ cell allot_markers_offset;
+ //data_gc
+ /* used during garbage collection only */
+ zone *newspace;
+ bool performing_gc;
+ bool performing_compaction;
+ cell collecting_gen;
+ /* if true, we are collecting aging space for the second time, so if it is still
+ full, we go on to collect tenured */
+ bool collecting_aging_again;
+ /* in case a generation fills up in the middle of a gc, we jump back
+ up to try collecting the next generation. */
+ jmp_buf gc_jmp;
+ gc_stats stats[max_gen_count];
+ u64 cards_scanned;
+ u64 decks_scanned;
+ u64 card_scan_time;
+ cell code_heap_scans;
+ /* What generation was being collected when copy_code_heap_roots() was last
+ called? Until the next call to add_code_block(), future
+ collections of younger generations don't have to touch the code
+ heap. */
+ cell last_code_heap_scan;
+ /* sometimes we grow the heap */
+ bool growing_data_heap;
+ data_heap *old_data_heap;
+
+ // local roots
+ /* If a runtime function needs to call another function which potentially
+ allocates memory, it must wrap any local variable references to Factor
+ objects in gc_root instances */
+ std::vector<cell> gc_locals;
+ std::vector<cell> gc_bignums;
+
+ //debug
+ bool fep_disabled;
+ bool full_output;
+ cell look_for;
+ cell obj;
+
+ //math
+ cell bignum_zero;
+ cell bignum_pos_one;
+ cell bignum_neg_one;
+
+ //code_heap
+ heap code;
+ unordered_map<heap_block *,char *> forwarding;
+
+ //image
+ cell code_relocation_base;
+ cell data_relocation_base;
+
+ //dispatch
+ cell megamorphic_cache_hits;
+ cell megamorphic_cache_misses;
+
+ //inline cache
+ cell max_pic_size;
+ cell cold_call_to_ic_transitions;
+ cell ic_to_pic_transitions;
+ cell pic_to_mega_transitions;
+ cell pic_counts[4]; /* PIC_TAG, PIC_HI_TAG, PIC_TUPLE, PIC_HI_TAG_TUPLE */
+
+ factorvmdata()
+ : profiling_p(false),
+ secure_gc(false),
+ gc_off(false),
+ performing_gc(false),
+ performing_compaction(false),
+ collecting_aging_again(false),
+ growing_data_heap(false),
+ fep_disabled(false),
+ full_output(false),
+ max_pic_size(0)
+ {
+ memset(this,0,sizeof(this)); // just to make sure
+ }
+
+};
+
+}
--- /dev/null
+#include "vm-data.hpp"
+
+namespace factor
+{
+
+struct factorvm : factorvmdata {
+
+ // segments
+ inline cell align_page(cell a);
+
+ // contexts
+ void reset_datastack();
+ void reset_retainstack();
+ void fix_stacks();
+ void save_stacks();
+ context *alloc_context();
+ void dealloc_context(context *old_context);
+ void nest_stacks();
+ void unnest_stacks();
+ void init_stacks(cell ds_size_, cell rs_size_);
+ bool stack_to_array(cell bottom, cell top);
+ cell array_to_stack(array *array, cell bottom);
+ inline void vmprim_datastack();
+ inline void vmprim_retainstack();
+ inline void vmprim_set_datastack();
+ inline void vmprim_set_retainstack();
+ inline void vmprim_check_datastack();
+
+ // run
+ inline void vmprim_getenv();
+ inline void vmprim_setenv();
+ inline void vmprim_exit();
+ inline void vmprim_micros();
+ inline void vmprim_sleep();
+ inline void vmprim_set_slot();
+ inline void vmprim_load_locals();
+ cell clone_object(cell obj_);
+ inline void vmprim_clone();
+
+ // profiler
+ void init_profiler();
+ code_block *compile_profiling_stub(cell word_);
+ void set_profiling(bool profiling);
+ inline void vmprim_profiling();
+
+ // errors
+ void out_of_memory();
+ void critical_error(const char* msg, cell tagged);
+ void throw_error(cell error, stack_frame *callstack_top);
+ void not_implemented_error();
+ bool in_page(cell fault, cell area, cell area_size, int offset);
+ void memory_protection_error(cell addr, stack_frame *native_stack);
+ void signal_error(int signal, stack_frame *native_stack);
+ void divide_by_zero_error();
+ void fp_trap_error(unsigned int fpu_status, stack_frame *signal_callstack_top);
+ inline void vmprim_call_clear();
+ inline void vmprim_unimplemented();
+ void memory_signal_handler_impl();
+ void misc_signal_handler_impl();
+ void fp_signal_handler_impl();
+ void type_error(cell type, cell tagged);
+ void general_error(vm_error_type error, cell arg1, cell arg2, stack_frame *native_stack);
+
+ //callstack
+
+ // bignum
+ int bignum_equal_p(bignum * x, bignum * y);
+ enum bignum_comparison bignum_compare(bignum * x, bignum * y);
+ bignum *bignum_add(bignum * x, bignum * y);
+ bignum *bignum_subtract(bignum * x, bignum * y);
+ bignum *bignum_multiply(bignum * x, bignum * y);
+ void bignum_divide(bignum * numerator, bignum * denominator, bignum * * quotient, bignum * * remainder);
+ bignum *bignum_quotient(bignum * numerator, bignum * denominator);
+ bignum *bignum_remainder(bignum * numerator, bignum * denominator);
+ cell bignum_to_cell(bignum * bignum);
+ fixnum bignum_to_fixnum(bignum * bignum);
+ s64 bignum_to_long_long(bignum * bignum);
+ u64 bignum_to_ulong_long(bignum * bignum);
+ double bignum_to_double(bignum * bignum);
+ bignum *double_to_bignum(double x);
+ int bignum_equal_p_unsigned(bignum * x, bignum * y);
+ enum bignum_comparison bignum_compare_unsigned(bignum * x, bignum * y);
+ bignum *bignum_add_unsigned(bignum * x, bignum * y, int negative_p);
+ bignum *bignum_subtract_unsigned(bignum * x, bignum * y);
+ bignum *bignum_multiply_unsigned(bignum * x, bignum * y, int negative_p);
+ bignum *bignum_multiply_unsigned_small_factor(bignum * x, bignum_digit_type y,int negative_p);
+ void bignum_destructive_add(bignum * bignum, bignum_digit_type n);
+ void bignum_destructive_scale_up(bignum * bignum, bignum_digit_type factor);
+ void bignum_divide_unsigned_large_denominator(bignum * numerator, bignum * denominator,
+ bignum * * quotient, bignum * * remainder, int q_negative_p, int r_negative_p);
+ void bignum_divide_unsigned_normalized(bignum * u, bignum * v, bignum * q);
+ bignum_digit_type bignum_divide_subtract(bignum_digit_type * v_start, bignum_digit_type * v_end,
+ bignum_digit_type guess, bignum_digit_type * u_start);
+ void bignum_divide_unsigned_medium_denominator(bignum * numerator,bignum_digit_type denominator,
+ bignum * * quotient, bignum * * remainder,int q_negative_p, int r_negative_p);
+ void bignum_destructive_normalization(bignum * source, bignum * target, int shift_left);
+ void bignum_destructive_unnormalization(bignum * bignum, int shift_right);
+ bignum_digit_type bignum_digit_divide(bignum_digit_type uh, bignum_digit_type ul,
+ bignum_digit_type v, bignum_digit_type * q) /* return value */;
+ bignum_digit_type bignum_digit_divide_subtract(bignum_digit_type v1, bignum_digit_type v2,
+ bignum_digit_type guess, bignum_digit_type * u);
+ void bignum_divide_unsigned_small_denominator(bignum * numerator, bignum_digit_type denominator,
+ bignum * * quotient, bignum * * remainder,int q_negative_p, int r_negative_p);
+ bignum_digit_type bignum_destructive_scale_down(bignum * bignum, bignum_digit_type denominator);
+ bignum * bignum_remainder_unsigned_small_denominator(bignum * n, bignum_digit_type d, int negative_p);
+ bignum *bignum_digit_to_bignum(bignum_digit_type digit, int negative_p);
+ bignum *allot_bignum(bignum_length_type length, int negative_p);
+ bignum * allot_bignum_zeroed(bignum_length_type length, int negative_p);
+ bignum *bignum_shorten_length(bignum * bignum, bignum_length_type length);
+ bignum *bignum_trim(bignum * bignum);
+ bignum *bignum_new_sign(bignum * x, int negative_p);
+ bignum *bignum_maybe_new_sign(bignum * x, int negative_p);
+ void bignum_destructive_copy(bignum * source, bignum * target);
+ bignum *bignum_bitwise_not(bignum * x);
+ bignum *bignum_arithmetic_shift(bignum * arg1, fixnum n);
+ bignum *bignum_bitwise_and(bignum * arg1, bignum * arg2);
+ bignum *bignum_bitwise_ior(bignum * arg1, bignum * arg2);
+ bignum *bignum_bitwise_xor(bignum * arg1, bignum * arg2);
+ bignum *bignum_magnitude_ash(bignum * arg1, fixnum n);
+ bignum *bignum_pospos_bitwise_op(int op, bignum * arg1, bignum * arg2);
+ bignum *bignum_posneg_bitwise_op(int op, bignum * arg1, bignum * arg2);
+ bignum *bignum_negneg_bitwise_op(int op, bignum * arg1, bignum * arg2);
+ void bignum_negate_magnitude(bignum * arg);
+ bignum *bignum_integer_length(bignum * x);
+ int bignum_logbitp(int shift, bignum * arg);
+ int bignum_unsigned_logbitp(int shift, bignum * bignum);
+ bignum *digit_stream_to_bignum(unsigned int n_digits, unsigned int (*producer)(unsigned int, factorvm *), unsigned int radix, int negative_p);
+
+ //data_heap
+ cell init_zone(zone *z, cell size, cell start);
+ void init_card_decks();
+ data_heap *alloc_data_heap(cell gens, cell young_size,cell aging_size,cell tenured_size);
+ data_heap *grow_data_heap(data_heap *data, cell requested_bytes);
+ void dealloc_data_heap(data_heap *data);
+ void clear_cards(cell from, cell to);
+ void clear_decks(cell from, cell to);
+ void clear_allot_markers(cell from, cell to);
+ void reset_generation(cell i);
+ void reset_generations(cell from, cell to);
+ void set_data_heap(data_heap *data_);
+ void init_data_heap(cell gens,cell young_size,cell aging_size,cell tenured_size,bool secure_gc_);
+ cell untagged_object_size(object *pointer);
+ cell unaligned_object_size(object *pointer);
+ inline void vmprim_size();
+ cell binary_payload_start(object *pointer);
+ inline void vmprim_data_room();
+ void begin_scan();
+ void end_scan();
+ inline void vmprim_begin_scan();
+ cell next_object();
+ inline void vmprim_next_object();
+ inline void vmprim_end_scan();
+ template<typename T> void each_object(T &functor);
+ cell find_all_words();
+ cell object_size(cell tagged);
+
+
+ //write barrier
+ inline card *addr_to_card(cell a);
+ inline cell card_to_addr(card *c);
+ inline cell card_offset(card *c);
+ inline card_deck *addr_to_deck(cell a);
+ inline cell deck_to_addr(card_deck *c);
+ inline card *deck_to_card(card_deck *d);
+ inline card *addr_to_allot_marker(object *a);
+ inline void write_barrier(object *obj);
+ inline void allot_barrier(object *address);
+
+
+ //data_gc
+ void init_data_gc();
+ object *copy_untagged_object_impl(object *pointer, cell size);
+ object *copy_object_impl(object *untagged);
+ bool should_copy_p(object *untagged);
+ object *resolve_forwarding(object *untagged);
+ template <typename T> T *copy_untagged_object(T *untagged);
+ cell copy_object(cell pointer);
+ void copy_handle(cell *handle);
+ void copy_card(card *ptr, cell gen, cell here);
+ void copy_card_deck(card_deck *deck, cell gen, card mask, card unmask);
+ void copy_gen_cards(cell gen);
+ void copy_cards();
+ void copy_stack_elements(segment *region, cell top);
+ void copy_registered_locals();
+ void copy_registered_bignums();
+ void copy_roots();
+ cell copy_next_from_nursery(cell scan);
+ cell copy_next_from_aging(cell scan);
+ cell copy_next_from_tenured(cell scan);
+ void copy_reachable_objects(cell scan, cell *end);
+ void begin_gc(cell requested_bytes);
+ void end_gc(cell gc_elapsed);
+ void garbage_collection(cell gen,bool growing_data_heap_,cell requested_bytes);
+ void gc();
+ inline void vmprim_gc();
+ inline void vmprim_gc_stats();
+ void clear_gc_stats();
+ inline void vmprim_become();
+ void inline_gc(cell *gc_roots_base, cell gc_roots_size);
+ inline bool collecting_accumulation_gen_p();
+ inline object *allot_zone(zone *z, cell a);
+ inline object *allot_object(header header, cell size);
+ template <typename TYPE> TYPE *allot(cell size);
+ inline void check_data_pointer(object *pointer);
+ inline void check_tagged_pointer(cell tagged);
+ inline void vmprim_clear_gc_stats();
+
+ // generic arrays
+ template <typename T> T *allot_array_internal(cell capacity);
+ template <typename T> bool reallot_array_in_place_p(T *array, cell capacity);
+ template <typename TYPE> TYPE *reallot_array(TYPE *array_, cell capacity);
+
+ //debug
+ void print_chars(string* str);
+ void print_word(word* word, cell nesting);
+ void print_factor_string(string* str);
+ void print_array(array* array, cell nesting);
+ void print_tuple(tuple *tuple, cell nesting);
+ void print_nested_obj(cell obj, fixnum nesting);
+ void print_obj(cell obj);
+ void print_objects(cell *start, cell *end);
+ void print_datastack();
+ void print_retainstack();
+ void print_stack_frame(stack_frame *frame);
+ void print_callstack();
+ void dump_cell(cell x);
+ void dump_memory(cell from, cell to);
+ void dump_zone(zone *z);
+ void dump_generations();
+ void dump_objects(cell type);
+ void find_data_references_step(cell *scan);
+ void find_data_references(cell look_for_);
+ void dump_code_heap();
+ void factorbug();
+ inline void vmprim_die();
+
+ //arrays
+ array *allot_array(cell capacity, cell fill_);
+ inline void vmprim_array();
+ cell allot_array_1(cell obj_);
+ cell allot_array_2(cell v1_, cell v2_);
+ cell allot_array_4(cell v1_, cell v2_, cell v3_, cell v4_);
+ inline void vmprim_resize_array();
+ inline void set_array_nth(array *array, cell slot, cell value);
+
+ //strings
+ cell string_nth(string* str, cell index);
+ void set_string_nth_fast(string *str, cell index, cell ch);
+ void set_string_nth_slow(string *str_, cell index, cell ch);
+ void set_string_nth(string *str, cell index, cell ch);
+ string *allot_string_internal(cell capacity);
+ void fill_string(string *str_, cell start, cell capacity, cell fill);
+ string *allot_string(cell capacity, cell fill);
+ inline void vmprim_string();
+ bool reallot_string_in_place_p(string *str, cell capacity);
+ string* reallot_string(string *str_, cell capacity);
+ inline void vmprim_resize_string();
+ inline void vmprim_string_nth();
+ inline void vmprim_set_string_nth_fast();
+ inline void vmprim_set_string_nth_slow();
+
+ //booleans
+ void box_boolean(bool value);
+ bool to_boolean(cell value);
+ inline cell tag_boolean(cell untagged);
+
+ //byte arrays
+ byte_array *allot_byte_array(cell size);
+ inline void vmprim_byte_array();
+ inline void vmprim_uninitialized_byte_array();
+ inline void vmprim_resize_byte_array();
+
+ //tuples
+ tuple *allot_tuple(cell layout_);
+ inline void vmprim_tuple();
+ inline void vmprim_tuple_boa();
+
+ //words
+ word *allot_word(cell vocab_, cell name_);
+ inline void vmprim_word();
+ inline void vmprim_word_xt();
+ void update_word_xt(cell w_);
+ inline void vmprim_optimized_p();
+ inline void vmprim_wrapper();
+
+ //math
+ inline void vmprim_bignum_to_fixnum();
+ inline void vmprim_float_to_fixnum();
+ inline void vmprim_fixnum_divint();
+ inline void vmprim_fixnum_divmod();
+ bignum *fixnum_to_bignum(fixnum);
+ bignum *cell_to_bignum(cell);
+ bignum *long_long_to_bignum(s64 n);
+ bignum *ulong_long_to_bignum(u64 n);
+ inline fixnum sign_mask(fixnum x);
+ inline fixnum branchless_max(fixnum x, fixnum y);
+ inline fixnum branchless_abs(fixnum x);
+ inline void vmprim_fixnum_shift();
+ inline void vmprim_fixnum_to_bignum();
+ inline void vmprim_float_to_bignum();
+ inline void vmprim_bignum_eq();
+ inline void vmprim_bignum_add();
+ inline void vmprim_bignum_subtract();
+ inline void vmprim_bignum_multiply();
+ inline void vmprim_bignum_divint();
+ inline void vmprim_bignum_divmod();
+ inline void vmprim_bignum_mod();
+ inline void vmprim_bignum_and();
+ inline void vmprim_bignum_or();
+ inline void vmprim_bignum_xor();
+ inline void vmprim_bignum_shift();
+ inline void vmprim_bignum_less();
+ inline void vmprim_bignum_lesseq();
+ inline void vmprim_bignum_greater();
+ inline void vmprim_bignum_greatereq();
+ inline void vmprim_bignum_not();
+ inline void vmprim_bignum_bitp();
+ inline void vmprim_bignum_log2();
+ unsigned int bignum_producer(unsigned int digit);
+ inline void vmprim_byte_array_to_bignum();
+ cell unbox_array_size();
+ inline void vmprim_fixnum_to_float();
+ inline void vmprim_bignum_to_float();
+ inline void vmprim_str_to_float();
+ inline void vmprim_float_to_str();
+ inline void vmprim_float_eq();
+ inline void vmprim_float_add();
+ inline void vmprim_float_subtract();
+ inline void vmprim_float_multiply();
+ inline void vmprim_float_divfloat();
+ inline void vmprim_float_mod();
+ inline void vmprim_float_less();
+ inline void vmprim_float_lesseq();
+ inline void vmprim_float_greater();
+ inline void vmprim_float_greatereq();
+ inline void vmprim_float_bits();
+ inline void vmprim_bits_float();
+ inline void vmprim_double_bits();
+ inline void vmprim_bits_double();
+ fixnum to_fixnum(cell tagged);
+ cell to_cell(cell tagged);
+ void box_signed_1(s8 n);
+ void box_unsigned_1(u8 n);
+ void box_signed_2(s16 n);
+ void box_unsigned_2(u16 n);
+ void box_signed_4(s32 n);
+ void box_unsigned_4(u32 n);
+ void box_signed_cell(fixnum integer);
+ void box_unsigned_cell(cell cell);
+ void box_signed_8(s64 n);
+ s64 to_signed_8(cell obj);
+ void box_unsigned_8(u64 n);
+ u64 to_unsigned_8(cell obj);
+ void box_float(float flo);
+ float to_float(cell value);
+ void box_double(double flo);
+ double to_double(cell value);
+ inline void overflow_fixnum_add(fixnum x, fixnum y);
+ inline void overflow_fixnum_subtract(fixnum x, fixnum y);
+ inline void overflow_fixnum_multiply(fixnum x, fixnum y);
+ inline cell allot_integer(fixnum x);
+ inline cell allot_cell(cell x);
+ inline cell allot_float(double n);
+ inline bignum *float_to_bignum(cell tagged);
+ inline double bignum_to_float(cell tagged);
+ inline double untag_float(cell tagged);
+ inline double untag_float_check(cell tagged);
+ inline fixnum float_to_fixnum(cell tagged);
+ inline double fixnum_to_float(cell tagged);
+ template <typename T> T *untag_check(cell value);
+ template <typename T> T *untag(cell value);
+
+ //io
+ void init_c_io();
+ void io_error();
+ inline void vmprim_fopen();
+ inline void vmprim_fgetc();
+ inline void vmprim_fread();
+ inline void vmprim_fputc();
+ inline void vmprim_fwrite();
+ inline void vmprim_fseek();
+ inline void vmprim_fflush();
+ inline void vmprim_fclose();
+
+ //code_gc
+ void clear_free_list(heap *heap);
+ void new_heap(heap *heap, cell size);
+ void add_to_free_list(heap *heap, free_heap_block *block);
+ void build_free_list(heap *heap, cell size);
+ void assert_free_block(free_heap_block *block);
+ free_heap_block *find_free_block(heap *heap, cell size);
+ free_heap_block *split_free_block(heap *heap, free_heap_block *block, cell size);
+ heap_block *heap_allot(heap *heap, cell size);
+ void heap_free(heap *heap, heap_block *block);
+ void mark_block(heap_block *block);
+ void unmark_marked(heap *heap);
+ void free_unmarked(heap *heap, heap_iterator iter);
+ void heap_usage(heap *heap, cell *used, cell *total_free, cell *max_free);
+ cell heap_size(heap *heap);
+ cell compute_heap_forwarding(heap *heap, unordered_map<heap_block *,char *> &forwarding);
+ void compact_heap(heap *heap, unordered_map<heap_block *,char *> &forwarding);
+
+ //code_block
+ relocation_type relocation_type_of(relocation_entry r);
+ relocation_class relocation_class_of(relocation_entry r);
+ cell relocation_offset_of(relocation_entry r);
+ void flush_icache_for(code_block *block);
+ int number_of_parameters(relocation_type type);
+ void *object_xt(cell obj);
+ void *xt_pic(word *w, cell tagged_quot);
+ void *word_xt_pic(word *w);
+ void *word_xt_pic_tail(word *w);
+ void undefined_symbol();
+ void *get_rel_symbol(array *literals, cell index);
+ cell compute_relocation(relocation_entry rel, cell index, code_block *compiled);
+ void iterate_relocations(code_block *compiled, relocation_iterator iter);
+ void store_address_2_2(cell *ptr, cell value);
+ void store_address_masked(cell *ptr, fixnum value, cell mask, fixnum shift);
+ void store_address_in_code_block(cell klass, cell offset, fixnum absolute_value);
+ void update_literal_references_step(relocation_entry rel, cell index, code_block *compiled);
+ void update_literal_references(code_block *compiled);
+ void copy_literal_references(code_block *compiled);
+ void relocate_code_block_step(relocation_entry rel, cell index, code_block *compiled);
+ void update_word_references_step(relocation_entry rel, cell index, code_block *compiled);
+ void update_word_references(code_block *compiled);
+ void update_literal_and_word_references(code_block *compiled);
+ void check_code_address(cell address);
+ void mark_code_block(code_block *compiled);
+ void mark_stack_frame_step(stack_frame *frame);
+ void mark_active_blocks(context *stacks);
+ void mark_object_code_block(object *object);
+ void relocate_code_block(code_block *compiled);
+ void fixup_labels(array *labels, code_block *compiled);
+ code_block *allot_code_block(cell size);
+ code_block *add_code_block(cell type,cell code_,cell labels_,cell relocation_,cell literals_);
+ inline bool stack_traces_p()
+ {
+ return userenv[STACK_TRACES_ENV] != F;
+ }
+
+ //code_heap
+ void init_code_heap(cell size);
+ bool in_code_heap_p(cell ptr);
+ void jit_compile_word(cell word_, cell def_, bool relocate);
+ void iterate_code_heap(code_heap_iterator iter);
+ void copy_code_heap_roots();
+ void update_code_heap_words();
+ inline void vmprim_modify_code_heap();
+ inline void vmprim_code_room();
+ code_block *forward_xt(code_block *compiled);
+ void forward_frame_xt(stack_frame *frame);
+ void forward_object_xts();
+ void fixup_object_xts();
+ void compact_code_heap();
+ inline void check_code_pointer(cell ptr);
+
+
+ //image
+ void init_objects(image_header *h);
+ void load_data_heap(FILE *file, image_header *h, vm_parameters *p);
+ void load_code_heap(FILE *file, image_header *h, vm_parameters *p);
+ bool save_image(const vm_char *filename);
+ inline void vmprim_save_image();
+ inline void vmprim_save_image_and_exit();
+ void data_fixup(cell *cell);
+ template <typename T> void code_fixup(T **handle);
+ void fixup_word(word *word);
+ void fixup_quotation(quotation *quot);
+ void fixup_alien(alien *d);
+ void fixup_stack_frame(stack_frame *frame);
+ void fixup_callstack_object(callstack *stack);
+ void relocate_object(object *object);
+ void relocate_data();
+ void fixup_code_block(code_block *compiled);
+ void relocate_code();
+ void load_image(vm_parameters *p);
+
+ //callstack
+ template<typename T> void iterate_callstack_object(callstack *stack_, T &iterator);
+ void check_frame(stack_frame *frame);
+ callstack *allot_callstack(cell size);
+ stack_frame *fix_callstack_top(stack_frame *top, stack_frame *bottom);
+ stack_frame *capture_start();
+ inline void vmprim_callstack();
+ inline void vmprim_set_callstack();
+ code_block *frame_code(stack_frame *frame);
+ cell frame_type(stack_frame *frame);
+ cell frame_executing(stack_frame *frame);
+ stack_frame *frame_successor(stack_frame *frame);
+ cell frame_scan(stack_frame *frame);
+ inline void vmprim_callstack_to_array();
+ stack_frame *innermost_stack_frame(callstack *stack);
+ stack_frame *innermost_stack_frame_quot(callstack *callstack);
+ inline void vmprim_innermost_stack_frame_executing();
+ inline void vmprim_innermost_stack_frame_scan();
+ inline void vmprim_set_innermost_stack_frame_quot();
+ void save_callstack_bottom(stack_frame *callstack_bottom);
+ template<typename T> void iterate_callstack(cell top, cell bottom, T &iterator);
+ inline void do_slots(cell obj, void (* iter)(cell *,factorvm*));
+
+
+ //alien
+ char *pinned_alien_offset(cell obj);
+ cell allot_alien(cell delegate_, cell displacement);
+ inline void vmprim_displaced_alien();
+ inline void vmprim_alien_address();
+ void *alien_pointer();
+ inline void vmprim_dlopen();
+ inline void vmprim_dlsym();
+ inline void vmprim_dlclose();
+ inline void vmprim_dll_validp();
+ inline void vmprim_vm_ptr();
+ char *alien_offset(cell obj);
+ char *unbox_alien();
+ void box_alien(void *ptr);
+ void to_value_struct(cell src, void *dest, cell size);
+ void box_value_struct(void *src, cell size);
+ void box_small_struct(cell x, cell y, cell size);
+ void box_medium_struct(cell x1, cell x2, cell x3, cell x4, cell size);
+
+ //quotations
+ inline void vmprim_jit_compile();
+ inline void vmprim_array_to_quotation();
+ inline void vmprim_quotation_xt();
+ void set_quot_xt(quotation *quot, code_block *code);
+ void jit_compile(cell quot_, bool relocating);
+ void compile_all_words();
+ fixnum quot_code_offset_to_scan(cell quot_, cell offset);
+ cell lazy_jit_compile_impl(cell quot_, stack_frame *stack);
+ inline void vmprim_quot_compiled_p();
+
+ //dispatch
+ cell search_lookup_alist(cell table, cell klass);
+ cell search_lookup_hash(cell table, cell klass, cell hashcode);
+ cell nth_superclass(tuple_layout *layout, fixnum echelon);
+ cell nth_hashcode(tuple_layout *layout, fixnum echelon);
+ cell lookup_tuple_method(cell obj, cell methods);
+ cell lookup_hi_tag_method(cell obj, cell methods);
+ cell lookup_hairy_method(cell obj, cell methods);
+ cell lookup_method(cell obj, cell methods);
+ inline void vmprim_lookup_method();
+ cell object_class(cell obj);
+ cell method_cache_hashcode(cell klass, array *array);
+ void update_method_cache(cell cache, cell klass, cell method);
+ inline void vmprim_mega_cache_miss();
+ inline void vmprim_reset_dispatch_stats();
+ inline void vmprim_dispatch_stats();
+
+ //inline cache
+ void init_inline_caching(int max_size);
+ void deallocate_inline_cache(cell return_address);
+ cell determine_inline_cache_type(array *cache_entries);
+ void update_pic_count(cell type);
+ code_block *compile_inline_cache(fixnum index,cell generic_word_,cell methods_,cell cache_entries_,bool tail_call_p);
+ void *megamorphic_call_stub(cell generic_word);
+ cell inline_cache_size(cell cache_entries);
+ cell add_inline_cache_entry(cell cache_entries_, cell klass_, cell method_);
+ void update_pic_transitions(cell pic_size);
+ void *inline_cache_miss(cell return_address);
+ inline void vmprim_reset_inline_cache_stats();
+ inline void vmprim_inline_cache_stats();
+
+ //factor
+ void default_parameters(vm_parameters *p);
+ bool factor_arg(const vm_char* str, const vm_char* arg, cell* value);
+ void init_parameters_from_args(vm_parameters *p, int argc, vm_char **argv);
+ void do_stage1_init();
+ void init_factor(vm_parameters *p);
+ void pass_args_to_factor(int argc, vm_char **argv);
+ void start_factor(vm_parameters *p);
+ void start_embedded_factor(vm_parameters *p);
+ void start_standalone_factor(int argc, vm_char **argv);
+ char *factor_eval_string(char *string);
+ void factor_eval_free(char *result);
+ void factor_yield();
+ void factor_sleep(long us);
+
+ // os-*
+ inline void vmprim_existsp();
+ void init_ffi();
+ void ffi_dlopen(dll *dll);
+ void *ffi_dlsym(dll *dll, symbol_char *symbol);
+ void ffi_dlclose(dll *dll);
+ segment *alloc_segment(cell size);
+ void c_to_factor_toplevel(cell quot);
+
+ // os-windows
+ #if defined(WINDOWS)
+ void sleep_micros(u64 usec);
+ long getpagesize();
+ void dealloc_segment(segment *block);
+ const vm_char *vm_executable_path();
+ const vm_char *default_image_path();
+ void windows_image_path(vm_char *full_path, vm_char *temp_path, unsigned int length);
+ bool windows_stat(vm_char *path);
+
+ #if defined(WINNT)
+ void open_console();
+ LONG exception_handler(PEXCEPTION_POINTERS pe);
+ // next method here:
+ #endif
+ #else // UNIX
+ void memory_signal_handler(int signal, siginfo_t *siginfo, void *uap);
+ void misc_signal_handler(int signal, siginfo_t *siginfo, void *uap);
+ void fpe_signal_handler(int signal, siginfo_t *siginfo, void *uap);
+ stack_frame *uap_stack_pointer(void *uap);
+
+ #endif
+
+ #ifdef __APPLE__
+ void call_fault_handler(exception_type_t exception, exception_data_type_t code, MACH_EXC_STATE_TYPE *exc_state, MACH_THREAD_STATE_TYPE *thread_state, MACH_FLOAT_STATE_TYPE *float_state);
+ #endif
+
+ void print_vm_data();
+};
+
+
+#ifndef FACTOR_REENTRANT
+ #define FACTOR_SINGLE_THREADED_SINGLETON
+#endif
+
+#ifdef FACTOR_SINGLE_THREADED_SINGLETON
+/* calls are dispatched using the singleton vm ptr */
+ extern factorvm *vm;
+ #define PRIMITIVE_GETVM() vm
+ #define PRIMITIVE_OVERFLOW_GETVM() vm
+ #define VM_PTR vm
+ #define ASSERTVM()
+ #define SIGNAL_VM_PTR() vm
+#endif
+
+#ifdef FACTOR_SINGLE_THREADED_TESTING
+/* calls are dispatched as per multithreaded, but checked against singleton */
+ extern factorvm *vm;
+ #define ASSERTVM() assert(vm==myvm)
+ #define PRIMITIVE_GETVM() ((factorvm*)myvm)
+ #define PRIMITIVE_OVERFLOW_GETVM() ASSERTVM(); myvm
+ #define VM_PTR myvm
+ #define SIGNAL_VM_PTR() tls_vm()
+#endif
+
+#ifdef FACTOR_REENTRANT_TLS
+/* uses thread local storage to obtain vm ptr */
+ #define PRIMITIVE_GETVM() tls_vm()
+ #define PRIMITIVE_OVERFLOW_GETVM() tls_vm()
+ #define VM_PTR tls_vm()
+ #define ASSERTVM()
+ #define SIGNAL_VM_PTR() tls_vm()
+#endif
+
+#ifdef FACTOR_REENTRANT
+ #define PRIMITIVE_GETVM() ((factorvm*)myvm)
+ #define PRIMITIVE_OVERFLOW_GETVM() ((factorvm*)myvm)
+ #define VM_PTR myvm
+ #define ASSERTVM()
+ #define SIGNAL_VM_PTR() tls_vm()
+#endif
+
+}
namespace factor
{
-word *allot_word(cell vocab_, cell name_)
+word *factorvm::allot_word(cell vocab_, cell name_)
{
- gc_root<object> vocab(vocab_);
- gc_root<object> name(name_);
+ gc_root<object> vocab(vocab_,this);
+ gc_root<object> name(name_,this);
- gc_root<word> new_word(allot<word>(sizeof(word)));
+ gc_root<word> new_word(allot<word>(sizeof(word)),this);
new_word->hashcode = tag_fixnum((rand() << 16) ^ rand());
new_word->vocabulary = vocab.value();
}
/* <word> ( name vocabulary -- word ) */
-PRIMITIVE(word)
+inline void factorvm::vmprim_word()
{
cell vocab = dpop();
cell name = dpop();
dpush(tag<word>(allot_word(vocab,name)));
}
+PRIMITIVE(word)
+{
+ PRIMITIVE_GETVM()->vmprim_word();
+}
+
/* word-xt ( word -- start end ) */
-PRIMITIVE(word_xt)
+inline void factorvm::vmprim_word_xt()
{
word *w = untag_check<word>(dpop());
code_block *code = (profiling_p ? w->profiling : w->code);
dpush(allot_cell((cell)code + code->size));
}
+PRIMITIVE(word_xt)
+{
+ PRIMITIVE_GETVM()->vmprim_word_xt();
+}
+
/* Allocates memory */
-void update_word_xt(cell w_)
+void factorvm::update_word_xt(cell w_)
{
- gc_root<word> w(w_);
+ gc_root<word> w(w_,this);
if(profiling_p)
{
w->xt = w->code->xt();
}
-PRIMITIVE(optimized_p)
+inline void factorvm::vmprim_optimized_p()
{
drepl(tag_boolean(word_optimized_p(untag_check<word>(dpeek()))));
}
-PRIMITIVE(wrapper)
+PRIMITIVE(optimized_p)
+{
+ PRIMITIVE_GETVM()->vmprim_optimized_p();
+}
+
+inline void factorvm::vmprim_wrapper()
{
wrapper *new_wrapper = allot<wrapper>(sizeof(wrapper));
new_wrapper->object = dpeek();
drepl(tag<wrapper>(new_wrapper));
}
+PRIMITIVE(wrapper)
+{
+ PRIMITIVE_GETVM()->vmprim_wrapper();
+}
+
}
namespace factor
{
-word *allot_word(cell vocab, cell name);
-
PRIMITIVE(word);
PRIMITIVE(word_xt);
-void update_word_xt(cell word);
inline bool word_optimized_p(word *word)
{
}
PRIMITIVE(optimized_p);
-
PRIMITIVE(wrapper);
}
using namespace factor;
-cell cards_offset;
-cell decks_offset;
-namespace factor
-{
- cell allot_markers_offset;
-}
the offset of the first object is set by the allocator. */
-VM_C_API factor::cell cards_offset;
-VM_C_API factor::cell decks_offset;
-
namespace factor
{
static const cell card_size = (1<<card_bits);
static const cell addr_card_mask = (card_size-1);
-inline static card *addr_to_card(cell a)
-{
- return (card*)(((cell)(a) >> card_bits) + cards_offset);
-}
-
-inline static cell card_to_addr(card *c)
-{
- return ((cell)c - cards_offset) << card_bits;
-}
-
-inline static cell card_offset(card *c)
-{
- return *(c - (cell)data->cards + (cell)data->allot_markers);
-}
typedef u8 card_deck;
static const cell deck_bits = (card_bits + 10);
static const cell deck_size = (1<<deck_bits);
static const cell addr_deck_mask = (deck_size-1);
-
-inline static card_deck *addr_to_deck(cell a)
-{
- return (card_deck *)(((cell)a >> deck_bits) + decks_offset);
-}
-
-inline static cell deck_to_addr(card_deck *c)
-{
- return ((cell)c - decks_offset) << deck_bits;
-}
-
-inline static card *deck_to_card(card_deck *d)
-{
- return (card *)((((cell)d - decks_offset) << (deck_bits - card_bits)) + cards_offset);
-}
-
static const cell invalid_allot_marker = 0xff;
-extern cell allot_markers_offset;
-
-inline static card *addr_to_allot_marker(object *a)
-{
- return (card *)(((cell)a >> card_bits) + allot_markers_offset);
-}
-
-/* the write barrier must be called any time we are potentially storing a
-pointer from an older generation to a younger one */
-inline static void write_barrier(object *obj)
-{
- *addr_to_card((cell)obj) = card_mark_mask;
- *addr_to_deck((cell)obj) = card_mark_mask;
-}
-
-/* we need to remember the first object allocated in the card */
-inline static void allot_barrier(object *address)
-{
- card *ptr = addr_to_allot_marker(address);
- if(*ptr == invalid_allot_marker)
- *ptr = ((cell)address & addr_card_mask);
-}
-
}
projects / factor.git / commitdiff