CC = gcc
+CPP = g++
AR = ar
LD = ld
BUNDLE = Factor.app
LIBPATH = -L/usr/X11R6/lib
-CFLAGS = -Wall -Werror
+CFLAGS = -Wall
ifdef DEBUG
CFLAGS += -g -DFACTOR_DEBUG
vm/code_block.o \
vm/code_gc.o \
vm/code_heap.o \
+ vm/contexts.o \
vm/data_gc.o \
vm/data_heap.o \
vm/debug.o \
vm/inline_cache.o \
vm/io.o \
vm/jit.o \
+ vm/local_roots.o \
vm/math.o \
vm/primitives.o \
vm/profiler.o \
vm/strings.o \
vm/tuples.o \
vm/utilities.o \
- vm/words.o
+ vm/words.o \
+ vm/write_barrier.o
EXE_OBJS = $(PLAF_EXE_OBJS)
$(EXECUTABLE): $(DLL_OBJS) $(EXE_OBJS)
$(LINKER) $(ENGINE) $(DLL_OBJS)
- $(CC) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \
+ $(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)
- $(CC) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \
+ $(CPP) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \
$(CFLAGS) $(CFLAGS_CONSOLE) -o factor$(EXE_SUFFIX)$(CONSOLE_EXTENSION) $(EXE_OBJS)
$(TEST_LIBRARY): vm/ffi_test.o
clean:
rm -f vm/*.o
- rm -f factor*.dll libfactor.{a,so,dylib} libfactor-ffi-test.{a,so,dylib} Factor.app/Contents/Frameworks/libfactor.dylib
+ rm -f factor.dll
+ rm -f libfactor.*
+ rm -f libfactor-ffi-test.*
+ rm -f Factor.app/Contents/Frameworks/libfactor.dylib
+
+tags:
+ etags vm/*.{cpp,hpp,mm,S,c}
vm/resources.o:
$(WINDRES) vm/factor.rs vm/resources.o
.c.o:
$(CC) -c $(CFLAGS) -o $@ $<
+.cpp.o:
+ $(CPP) -c $(CFLAGS) -o $@ $<
+
.S.o:
$(CC) -x assembler-with-cpp -c $(CFLAGS) -o $@ $<
-.m.o:
- $(CC) -c $(CFLAGS) -o $@ $<
+.mm.o:
+ $(CPP) -c $(CFLAGS) -o $@ $<
+
+.PHONY: factor tags clean
-.PHONY: factor
+.SUFFIXES: .mm
* Compiling the Factor VM
-The Factor runtime is written in GNU C99, and is built with GNU make and
+The Factor runtime is written in GNU C++, and is built with GNU make and
gcc.
Factor supports various platforms. For an up-to-date list, see
The Factor source tree is organized as follows:
build-support/ - scripts used for compiling Factor
- vm/ - sources for the Factor VM, written in C
+ vm/ - sources for the Factor VM, written in C++
core/ - Factor core library
basis/ - Factor basis library, compiler, tools
extra/ - more libraries and applications
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien arrays alien.c-types alien.structs
-sequences math kernel namespaces fry libc cpu.architecture ;
+USING: alien alien.strings alien.c-types alien.accessors alien.structs
+arrays words sequences math kernel namespaces fry libc cpu.architecture
+io.encodings.utf8 io.encodings.utf16n ;
IN: alien.arrays
UNION: value-type array struct-type ;
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 ;
+
+M: string-type c-type ;
+
+M: string-type c-type-class
+ drop object ;
+
+M: string-type heap-size
+ drop "void*" heap-size ;
+
+M: string-type c-type-align
+ drop "void*" c-type-align ;
+
+M: string-type c-type-stack-align?
+ drop "void*" c-type-stack-align? ;
+
+M: string-type unbox-parameter
+ drop "void*" unbox-parameter ;
+
+M: string-type unbox-return
+ drop "void*" unbox-return ;
+
+M: string-type box-parameter
+ drop "void*" box-parameter ;
+
+M: string-type box-return
+ drop "void*" box-return ;
+
+M: string-type stack-size
+ drop "void*" stack-size ;
+
+M: string-type c-type-reg-class
+ drop int-regs ;
+
+M: string-type c-type-boxer
+ drop "void*" c-type-boxer ;
+
+M: string-type c-type-unboxer
+ drop "void*" c-type-unboxer ;
+
+M: string-type c-type-boxer-quot
+ second '[ _ alien>string ] ;
+
+M: string-type c-type-unboxer-quot
+ second '[ _ string>alien ] ;
+
+M: string-type c-type-getter
+ drop [ alien-cell ] ;
+
+M: string-type c-type-setter
+ drop [ set-alien-cell ] ;
+
+{ "char*" utf8 } "char*" typedef
+"char*" "uchar*" typedef
+{ "char*" utf16n } "wchar_t*" typedef
+
IN: alien.c-types
USING: alien help.syntax help.markup libc kernel.private
-byte-arrays math strings hashtables alien.syntax
-debugger destructors ;
+byte-arrays math strings hashtables alien.syntax alien.strings sequences
+io.encodings.string debugger destructors ;
HELP: <c-type>
{ $values { "type" hashtable } }
{ $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"
+ }
+} ;
+
+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."
$nl
! 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 assocs splitting
-math.parser cpu.architecture alien alien.accessors quotations
-layouts system compiler.units io.files io.encodings.binary
-accessors combinators effects continuations fry classes ;
+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 ;
IN: alien.c-types
DEFER: <int>
: 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 ;
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien assocs io.backend kernel namespaces ;
+USING: accessors alien alien.strings assocs io.backend kernel namespaces ;
IN: alien.libraries
+: dlopen ( path -- dll ) native-string>alien (dlopen) ;
+
+: dlsym ( name dll -- alien ) [ native-string>alien ] dip (dlsym) ;
+
SYMBOL: libraries
libraries [ H{ } clone ] initialize
library dup [ dll>> ] when ;
: add-library ( name path abi -- )
- <library> swap libraries get set-at ;
+ <library> swap libraries get set-at ;
\ No newline at end of file
+++ /dev/null
-USING: help.markup help.syntax strings byte-arrays alien libc
-debugger io.encodings.string sequences ;
-IN: alien.strings
-
-HELP: string>alien
-{ $values { "string" string } { "encoding" "an encoding descriptor" } { "byte-array" byte-array } }
-{ $description "Encodes a string together with a trailing null code point using the given encoding, and stores the resulting bytes in a freshly-allocated byte array." }
-{ $errors "Throws an error if the string contains null characters, or characters not representable in the given encoding." } ;
-
-{ string>alien alien>string malloc-string } related-words
-
-HELP: alien>string
-{ $values { "c-ptr" c-ptr } { "encoding" "an encoding descriptor" } { "string/f" "a string or " { $link f } } }
-{ $description "Reads a null-terminated C string from the specified address with the given encoding." } ;
-
-HELP: malloc-string
-{ $values { "string" string } { "encoding" "an encoding descriptor" } { "alien" c-ptr } }
-{ $description "Encodes a string together with a trailing null code point using the given encoding, and stores the resulting bytes in a freshly-allocated unmanaged memory block." }
-{ $warning "Don't forget to deallocate the memory with a call to " { $link free } "." }
-{ $errors "Throws an error if one of the following conditions occurs:"
- { $list
- "the string contains null code points"
- "the string contains characters not representable using the encoding specified"
- "memory allocation fails"
- }
-} ;
-
-HELP: string>symbol
-{ $values { "str" string } { "alien" alien } }
-{ $description "Converts the string to a format which is a valid symbol name for the Factor VM's compiled code linker. By performing this conversion ahead of time, the image loader can run without allocating memory."
-$nl
-"On Windows CE, symbols are represented as UCS2 strings, and on all other platforms they are ASCII strings." } ;
-
-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 } "." ;
-
-ABOUT: "c-strings"
+++ /dev/null
-USING: alien.strings 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
-
-[ "\u0000ff" ]
-[ "\u0000ff" latin1 string>alien latin1 alien>string ]
-unit-test
-
-[ "hello world" ]
-[ "hello world" latin1 string>alien latin1 alien>string ]
-unit-test
-
-[ "hello\u00abcdworld" ]
-[ "hello\u00abcdworld" utf16le string>alien utf16le alien>string ]
-unit-test
-
-[ t ] [ f expired? ] unit-test
-
-[ "hello world" ] [
- "hello world" ascii malloc-string
- dup ascii alien>string swap free
-] unit-test
-
-[ "hello world" ] [
- "hello world" utf16n malloc-string
- dup utf16n alien>string swap free
-] unit-test
-
-[ f ] [ f utf8 alien>string ] unit-test
-
-[ "hello" ] [ "hello" utf16 encode utf16 decode ] unit-test
-
-[ "hello" ] [ "hello" utf16 string>alien utf16 alien>string ] unit-test
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: arrays sequences kernel accessors math alien.accessors
-alien.c-types byte-arrays words io io.encodings
-io.encodings.utf8 io.streams.byte-array io.streams.memory system
-alien strings cpu.architecture fry vocabs.loader combinators ;
-IN: alien.strings
-
-GENERIC# alien>string 1 ( c-ptr encoding -- string/f )
-
-M: c-ptr alien>string
- [ <memory-stream> ] [ <decoder> ] bi*
- "\0" swap stream-read-until drop ;
-
-M: f alien>string
- drop ;
-
-ERROR: invalid-c-string string ;
-
-: check-string ( string -- )
- 0 over memq? [ invalid-c-string ] [ drop ] if ;
-
-GENERIC# string>alien 1 ( string encoding -- byte-array )
-
-M: c-ptr string>alien drop ;
-
-M: string string>alien
- over check-string
- <byte-writer>
- [ stream-write ]
- [ 0 swap stream-write1 ]
- [ stream>> >byte-array ]
- tri ;
-
-: malloc-string ( string encoding -- alien )
- string>alien malloc-byte-array ;
-
-PREDICATE: string-type < pair
- first2 [ "char*" = ] [ word? ] bi* and ;
-
-M: string-type c-type ;
-
-M: string-type c-type-class
- drop object ;
-
-M: string-type heap-size
- drop "void*" heap-size ;
-
-M: string-type c-type-align
- drop "void*" c-type-align ;
-
-M: string-type c-type-stack-align?
- drop "void*" c-type-stack-align? ;
-
-M: string-type unbox-parameter
- drop "void*" unbox-parameter ;
-
-M: string-type unbox-return
- drop "void*" unbox-return ;
-
-M: string-type box-parameter
- drop "void*" box-parameter ;
-
-M: string-type box-return
- drop "void*" box-return ;
-
-M: string-type stack-size
- drop "void*" stack-size ;
-
-M: string-type c-type-reg-class
- drop int-regs ;
-
-M: string-type c-type-boxer
- drop "void*" c-type-boxer ;
-
-M: string-type c-type-unboxer
- drop "void*" c-type-unboxer ;
-
-M: string-type c-type-boxer-quot
- second '[ _ alien>string ] ;
-
-M: string-type c-type-unboxer-quot
- second '[ _ string>alien ] ;
-
-M: string-type c-type-getter
- drop [ alien-cell ] ;
-
-M: string-type c-type-setter
- drop [ set-alien-cell ] ;
-
-HOOK: alien>native-string os ( alien -- string )
-
-HOOK: native-string>alien os ( string -- alien )
-
-: dll-path ( dll -- string )
- path>> alien>native-string ;
-
-: string>symbol ( str -- alien )
- dup string?
- [ native-string>alien ]
- [ [ native-string>alien ] map ] if ;
-
-{ "char*" utf8 } "char*" typedef
-"char*" "uchar*" typedef
-
-{
- { [ os windows? ] [ "alien.strings.windows" require ] }
- { [ os unix? ] [ "alien.strings.unix" require ] }
-} cond
+++ /dev/null
-Passing Factor strings as C strings and vice versa
+++ /dev/null
-Default string encoding on Unix
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: alien.strings io.encodings.utf8 system ;
-IN: alien.strings.unix
-
-M: unix alien>native-string utf8 alien>string ;
-
-M: unix native-string>alien utf8 string>alien ;
+++ /dev/null
-Default string encoding on Windows
+++ /dev/null
-unportable
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: alien.strings alien.c-types io.encodings.utf8
-io.encodings.utf16n system ;
-IN: alien.strings.windows
-
-M: windows alien>native-string utf16n alien>string ;
-
-M: wince native-string>alien utf16n string>alien ;
-
-M: winnt native-string>alien utf8 string>alien ;
-
-{ "char*" utf16n } "wchar_t*" typedef
"stage2: deployment mode" print
] [
"debugger" require
- "alien.prettyprint" require
"inspector" require
"tools.errors" require
"listener" require
+++ /dev/null
-USING: arrays byte-arrays help.markup help.syntax kernel combinators ;\r
-IN: byte-vectors\r
-\r
-ARTICLE: "byte-vectors" "Byte vectors"\r
-"The " { $vocab-link "byte-vectors" } " vocabulary implements resizable mutable sequence of unsigned bytes. Byte vectors implement the " { $link "sequence-protocol" } " and thus all " { $link "sequences" } " can be used with them."\r
-$nl\r
-"Byte vectors form a class:"\r
-{ $subsection byte-vector }\r
-{ $subsection byte-vector? }\r
-"Creating byte vectors:"\r
-{ $subsection >byte-vector }\r
-{ $subsection <byte-vector> }\r
-"Literal syntax:"\r
-{ $subsection POSTPONE: BV{ }\r
-"If you don't care about initial capacity, a more elegant way to create a new byte vector is to write:"\r
-{ $code "BV{ } clone" } ;\r
-\r
-ABOUT: "byte-vectors"\r
-\r
-HELP: byte-vector\r
-{ $description "The class of resizable byte vectors. See " { $link "byte-vectors" } " for information." } ;\r
-\r
-HELP: <byte-vector>\r
-{ $values { "n" "a positive integer specifying initial capacity" } { "byte-vector" byte-vector } }\r
-{ $description "Creates a new byte vector that can hold " { $snippet "n" } " bytes before resizing." } ;\r
-\r
-HELP: >byte-vector\r
-{ $values { "seq" "a sequence" } { "byte-vector" byte-vector } }\r
-{ $description "Outputs a freshly-allocated byte vector with the same elements as a given sequence." }\r
-{ $errors "Throws an error if the sequence contains elements other than integers." } ;\r
-\r
-HELP: BV{\r
-{ $syntax "BV{ elements... }" }\r
-{ $values { "elements" "a list of bytes" } }\r
-{ $description "Marks the beginning of a literal byte vector. Literal byte vectors are terminated by " { $link POSTPONE: } } "." } \r
-{ $examples { $code "BV{ 1 2 3 12 }" } } ;\r
+++ /dev/null
-IN: byte-vectors.tests\r
-USING: tools.test byte-vectors vectors sequences kernel\r
-prettyprint ;\r
-\r
-[ 0 ] [ 123 <byte-vector> length ] unit-test\r
-\r
-: do-it ( seq -- seq )\r
- 123 [ over push ] each ;\r
-\r
-[ t ] [\r
- 3 <byte-vector> do-it\r
- 3 <vector> do-it sequence=\r
-] unit-test\r
-\r
-[ t ] [ BV{ } byte-vector? ] unit-test\r
-\r
-[ "BV{ }" ] [ BV{ } unparse ] unit-test\r
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: arrays kernel kernel.private math sequences\r
-sequences.private growable byte-arrays accessors parser\r
-prettyprint.custom ;\r
-IN: byte-vectors\r
-\r
-TUPLE: byte-vector\r
-{ underlying byte-array }\r
-{ length array-capacity } ;\r
-\r
-: <byte-vector> ( n -- byte-vector )\r
- (byte-array) 0 byte-vector boa ; inline\r
-\r
-: >byte-vector ( seq -- byte-vector )\r
- T{ byte-vector f B{ } 0 } clone-like ;\r
-\r
-M: byte-vector like\r
- drop dup byte-vector? [\r
- dup byte-array?\r
- [ dup length byte-vector boa ] [ >byte-vector ] if\r
- ] unless ;\r
-\r
-M: byte-vector new-sequence\r
- drop [ (byte-array) ] [ >fixnum ] bi byte-vector boa ;\r
-\r
-M: byte-vector equal?\r
- over byte-vector? [ sequence= ] [ 2drop f ] if ;\r
-\r
-M: byte-array like\r
- #! If we have an byte-array, we're done.\r
- #! If we have a byte-vector, and it's at full capacity,\r
- #! we're done. Otherwise, call resize-byte-array, which is a\r
- #! relatively fast primitive.\r
- drop dup byte-array? [\r
- dup byte-vector? [\r
- [ length ] [ underlying>> ] bi\r
- 2dup length eq?\r
- [ nip ] [ resize-byte-array ] if\r
- ] [ >byte-array ] if\r
- ] unless ;\r
-\r
-M: byte-array new-resizable drop <byte-vector> ;\r
-\r
-SYNTAX: BV{ \ } [ >byte-vector ] parse-literal ;\r
-\r
-M: byte-vector pprint* pprint-object ;\r
-M: byte-vector pprint-delims drop \ BV{ \ } ;\r
-M: byte-vector >pprint-sequence ;\r
-\r
-INSTANCE: byte-vector growable\r
+++ /dev/null
-Growable byte arrays
+++ /dev/null
-collections
-! Copyright (C) 2003, 2008 Slava Pestov.
+! Copyright (C) 2003, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: init continuations hashtables io io.encodings.utf8
io.files io.pathnames kernel kernel.private namespaces parser
-sequences strings system splitting vocabs.loader ;
+sequences strings system splitting vocabs.loader alien.strings ;
IN: command-line
SYMBOL: script
SYMBOL: command-line
-: (command-line) ( -- args ) 10 getenv sift ;
+: (command-line) ( -- args ) 10 getenv sift [ alien>native-string ] map ;
: rc-path ( name -- path )
os windows? [ "." prepend ] unless
! Make sure error reporting works
-[ [ dup ] compile-call ] must-fail
-[ [ drop ] compile-call ] must-fail
+! [ [ dup ] compile-call ] must-fail
+! [ [ drop ] compile-call ] must-fail
! Regression
! Copyright (C) 2004, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: slots arrays definitions generic hashtables summary io
-kernel math namespaces make prettyprint prettyprint.config
-sequences assocs sequences.private strings io.styles
-io.pathnames vectors words system splitting math.parser
-classes.mixin classes.tuple continuations continuations.private
-combinators generic.math classes.builtin classes compiler.units
-generic.standard generic.single vocabs init kernel.private io.encodings
-accessors math.order destructors source-files parser
-classes.tuple.parser effects.parser lexer
+USING: slots arrays definitions generic hashtables summary io kernel
+math namespaces make prettyprint prettyprint.config sequences assocs
+sequences.private strings io.styles io.pathnames vectors words system
+splitting math.parser classes.mixin classes.tuple continuations
+continuations.private combinators generic.math classes.builtin classes
+compiler.units generic.standard generic.single vocabs init
+kernel.private io.encodings accessors math.order destructors
+source-files parser classes.tuple.parser effects.parser lexer
generic.parser strings.parser vocabs.loader vocabs.parser see
source-files.errors ;
IN: debugger
GENERIC: error-help ( error -- topic )
M: object error. . ;
+
M: object error-help drop f ;
M: tuple error-help class ;
"Object did not survive image save/load: " write third . ;
: io-error. ( error -- )
- "I/O error: " write third print ;
+ "I/O error #" write third . ;
: type-check-error. ( obj -- )
"Type check error" print
"Cannot convert to C string: " write third . ;
: ffi-error. ( obj -- )
- "FFI: " write
- dup third [ write ": " write ] when*
- fourth print ;
+ "FFI error" print drop ;
: heap-scan-error. ( obj -- )
"Cannot do next-object outside begin/end-scan" print drop ;
! See http://factorcode.org/license.txt for BSD license.
USING: kernel strings values io.files assocs
splitting sequences io namespaces sets
-io.encodings.ascii io.encodings.utf8 ;
+io.encodings.ascii io.encodings.utf8 io.encodings.utf16 ;
IN: io.encodings.iana
<PRIVATE
] [ swap e>n-table get-global set-at ] 2bi ;
ascii "ANSI_X3.4-1968" register-encoding
+utf16be "UTF-16BE" register-encoding
+utf16le "UTF-16LE" register-encoding
+utf16 "UTF-16" register-encoding
\ No newline at end of file
+++ /dev/null
-Daniel Ehrenberg
+++ /dev/null
-UTF16 encoding/decoding
+++ /dev/null
-! Copyright (C) 2008 Daniel Ehrenberg
-! See http://factorcode.org/license.txt for BSD license.
-USING: help.markup help.syntax io.encodings strings ;
-IN: io.encodings.utf16
-
-ARTICLE: "io.encodings.utf16" "UTF-16 encoding"
-"The UTF-16 encoding is a variable-width encoding. Unicode code points are encoded as 2 or 4 byte sequences. There are three encoding descriptor classes for working with UTF-16, depending on endianness or the presence of a BOM:"
-{ $subsection utf16 }
-{ $subsection utf16le }
-{ $subsection utf16be } ;
-
-ABOUT: "io.encodings.utf16"
-
-HELP: utf16le
-{ $class-description "The encoding descriptor for UTF-16LE, that is, UTF-16 in little endian, without a byte order mark. Streams can be made which read or write wth this encoding." }
-{ $see-also "encodings-introduction" } ;
-
-HELP: utf16be
-{ $class-description "The encoding descriptor for UTF-16BE, that is, UTF-16 in big endian, without a byte order mark. Streams can be made which read or write wth this encoding." }
-{ $see-also "encodings-introduction" } ;
-
-HELP: utf16
-{ $class-description "The encoding descriptor for UTF-16, that is, UTF-16 with a byte order mark. This is the most useful for general input and output in UTF-16. Streams can be made which read or write wth this encoding." }
-{ $see-also "encodings-introduction" } ;
-
-{ utf16 utf16le utf16be } related-words
+++ /dev/null
-! Copyright (C) 2008 Daniel Ehrenberg.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel tools.test io.encodings.utf16 arrays sbufs
-io.streams.byte-array sequences io.encodings io strings
-io.encodings.string alien.c-types alien.strings accessors classes ;
-IN: io.encodings.utf16.tests
-
-[ { CHAR: x } ] [ B{ 0 CHAR: x } utf16be decode >array ] unit-test
-[ { HEX: 1D11E } ] [ B{ HEX: D8 HEX: 34 HEX: DD HEX: 1E } utf16be decode >array ] unit-test
-[ { CHAR: replacement-character } ] [ B{ BIN: 11011111 CHAR: q } utf16be decode >array ] unit-test
-[ { CHAR: replacement-character } ] [ B{ BIN: 11011011 CHAR: x BIN: 11011011 CHAR: x } utf16be decode >array ] unit-test
-
-[ { 0 120 216 52 221 30 } ] [ { CHAR: x HEX: 1d11e } >string utf16be encode >array ] unit-test
-
-[ { CHAR: x } ] [ B{ CHAR: x 0 } utf16le decode >array ] unit-test
-[ { 119070 } ] [ B{ HEX: 34 HEX: D8 HEX: 1E HEX: DD } >string utf16le decode >array ] unit-test
-[ { CHAR: replacement-character } ] [ { 0 BIN: 11011111 } >string utf16le decode >array ] unit-test
-[ { CHAR: replacement-character } ] [ { 0 BIN: 11011011 0 0 } >string utf16le decode >array ] unit-test
-
-[ { 120 0 52 216 30 221 } ] [ { CHAR: x HEX: 1d11e } >string utf16le encode >array ] unit-test
-
-[ { CHAR: x } ] [ B{ HEX: ff HEX: fe CHAR: x 0 } utf16 decode >array ] unit-test
-[ { CHAR: x } ] [ B{ HEX: fe HEX: ff 0 CHAR: x } utf16 decode >array ] unit-test
-
-[ { HEX: ff HEX: fe 120 0 52 216 30 221 } ] [ { CHAR: x HEX: 1d11e } >string utf16 encode >array ] unit-test
+++ /dev/null
-! Copyright (C) 2006, 2009 Daniel Ehrenberg.
-! See http://factorcode.org/license.txt for BSD license.
-USING: math kernel sequences sbufs vectors namespaces io.binary
-io.encodings combinators splitting io byte-arrays io.encodings.iana ;
-IN: io.encodings.utf16
-
-SINGLETON: utf16be
-
-utf16be "UTF-16BE" register-encoding
-
-SINGLETON: utf16le
-
-utf16le "UTF-16LE" register-encoding
-
-SINGLETON: utf16
-
-utf16 "UTF-16" register-encoding
-
-ERROR: missing-bom ;
-
-<PRIVATE
-
-! UTF-16BE decoding
-
-: append-nums ( byte ch -- ch )
- over [ 8 shift bitor ] [ 2drop replacement-char ] if ;
-
-: double-be ( stream byte -- stream char )
- over stream-read1 swap append-nums ;
-
-: quad-be ( stream byte -- stream char )
- double-be over stream-read1 [
- dup -2 shift BIN: 110111 number= [
- [ 2 shift ] dip BIN: 11 bitand bitor
- over stream-read1 swap append-nums HEX: 10000 +
- ] [ 2drop dup stream-read1 drop replacement-char ] if
- ] when* ;
-
-: ignore ( stream -- stream char )
- dup stream-read1 drop replacement-char ;
-
-: begin-utf16be ( stream byte -- stream char )
- dup -3 shift BIN: 11011 number= [
- dup BIN: 00000100 bitand zero?
- [ BIN: 11 bitand quad-be ]
- [ drop ignore ] if
- ] [ double-be ] if ;
-
-M: utf16be decode-char
- drop dup stream-read1 dup [ begin-utf16be ] when nip ;
-
-! UTF-16LE decoding
-
-: quad-le ( stream ch -- stream char )
- over stream-read1 swap 10 shift bitor
- over stream-read1 dup -2 shift BIN: 110111 = [
- BIN: 11 bitand append-nums HEX: 10000 +
- ] [ 2drop replacement-char ] if ;
-
-: double-le ( stream byte1 byte2 -- stream char )
- dup -3 shift BIN: 11011 = [
- dup BIN: 100 bitand 0 number=
- [ BIN: 11 bitand 8 shift bitor quad-le ]
- [ 2drop replacement-char ] if
- ] [ append-nums ] if ;
-
-: begin-utf16le ( stream byte -- stream char )
- over stream-read1 [ double-le ] [ drop replacement-char ] if* ;
-
-M: utf16le decode-char
- drop dup stream-read1 dup [ begin-utf16le ] when nip ;
-
-! UTF-16LE/BE encoding
-
-: encode-first ( char -- byte1 byte2 )
- -10 shift
- dup -8 shift BIN: 11011000 bitor
- swap HEX: FF bitand ;
-
-: encode-second ( char -- byte3 byte4 )
- BIN: 1111111111 bitand
- dup -8 shift BIN: 11011100 bitor
- swap BIN: 11111111 bitand ;
-
-: stream-write2 ( stream char1 char2 -- )
- rot [ stream-write1 ] curry bi@ ;
-
-: char>utf16be ( stream char -- )
- dup HEX: FFFF > [
- HEX: 10000 -
- 2dup encode-first stream-write2
- encode-second stream-write2
- ] [ h>b/b swap stream-write2 ] if ;
-
-M: utf16be encode-char ( char stream encoding -- )
- drop swap char>utf16be ;
-
-: char>utf16le ( char stream -- )
- dup HEX: FFFF > [
- HEX: 10000 -
- 2dup encode-first swap stream-write2
- encode-second swap stream-write2
- ] [ h>b/b stream-write2 ] if ;
-
-M: utf16le encode-char ( char stream encoding -- )
- drop swap char>utf16le ;
-
-! UTF-16
-
-CONSTANT: bom-le B{ HEX: ff HEX: fe }
-
-CONSTANT: bom-be B{ HEX: fe HEX: ff }
-
-: bom>le/be ( bom -- le/be )
- dup bom-le sequence= [ drop utf16le ] [
- bom-be sequence= [ utf16be ] [ missing-bom ] if
- ] if ;
-
-M: utf16 <decoder> ( stream utf16 -- decoder )
- drop 2 over stream-read bom>le/be <decoder> ;
-
-M: utf16 <encoder> ( stream utf16 -- encoder )
- drop bom-le over stream-write utf16le <encoder> ;
-
-PRIVATE>
+++ /dev/null
-Daniel Ehrenberg
+++ /dev/null
-UTF16 encoding with native byte order
+++ /dev/null
-USING: help.markup help.syntax ;
-IN: io.encodings.utf16n
-
-HELP: utf16n
-{ $class-description "The encoding descriptor for UTF-16 without a byte order mark in native endian order. This is useful mostly for FFI calls which take input of strings of the type wchar_t*" }
-{ $see-also "encodings-introduction" } ;
+++ /dev/null
-USING: accessors alien.c-types kernel
-io.encodings.utf16 io.streams.byte-array tools.test ;
-IN: io.encodings.utf16n
-
-: correct-endian ( obj -- ? )
- code>> little-endian? [ utf16le = ] [ utf16be = ] if ;
-
-[ t ] [ B{ } utf16n <byte-reader> correct-endian ] unit-test
-[ t ] [ utf16n <byte-writer> correct-endian ] unit-test
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: alien.c-types io.encodings io.encodings.utf16 kernel ;
-IN: io.encodings.utf16n
-
-! Native-order UTF-16
-
-SINGLETON: utf16n
-
-: utf16n ( -- descriptor )
- little-endian? utf16le utf16be ? ; foldable
-
-M: utf16n <decoder> drop utf16n <decoder> ;
-
-M: utf16n <encoder> drop utf16n <encoder> ;
+++ /dev/null
-USING: help.syntax help.markup io byte-arrays quotations ;
-IN: io.streams.byte-array
-
-ABOUT: "io.streams.byte-array"
-
-ARTICLE: "io.streams.byte-array" "Byte-array streams"
-"Byte array streams:"
-{ $subsection <byte-reader> }
-{ $subsection <byte-writer> }
-"Utility combinators:"
-{ $subsection with-byte-reader }
-{ $subsection with-byte-writer } ;
-
-HELP: <byte-reader>
-{ $values { "byte-array" byte-array }
- { "encoding" "an encoding descriptor" }
- { "stream" "a new byte reader" } }
-{ $description "Creates an input stream reading from a byte array using an encoding." } ;
-
-HELP: <byte-writer>
-{ $values { "encoding" "an encoding descriptor" }
- { "stream" "a new byte writer" } }
-{ $description "Creates an output stream writing data to a byte array using an encoding." } ;
-
-HELP: with-byte-reader
-{ $values { "encoding" "an encoding descriptor" }
- { "quot" quotation } { "byte-array" byte-array } }
-{ $description "Calls the quotation in a new dynamic scope with " { $link input-stream } " rebound to an input stream for reading from a byte array using an encoding." } ;
-
-HELP: with-byte-writer
-{ $values { "encoding" "an encoding descriptor" }
- { "quot" quotation }
- { "byte-array" byte-array } }
-{ $description "Calls the quotation in a new dynamic scope with " { $link output-stream } " rebound to an output stream writing data to a byte array using an encoding." } ;
+++ /dev/null
-USING: tools.test io.streams.byte-array io.encodings.binary
-io.encodings.utf8 io kernel arrays strings namespaces ;
-
-[ B{ 1 2 3 } ] [ binary [ B{ 1 2 3 } write ] with-byte-writer ] unit-test
-[ B{ 1 2 3 } ] [ { 1 2 3 } binary [ 3 read ] with-byte-reader ] unit-test
-
-[ B{ BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 10111111 BIN: 11101111 BIN: 10000000 BIN: 10111111 BIN: 11011111 BIN: 10000000 CHAR: x } ]
-[ { BIN: 101111111000000111111 BIN: 1111000000111111 BIN: 11111000000 CHAR: x } >string utf8 [ write ] with-byte-writer ] unit-test
-[ { BIN: 101111111000000111111 } t ] [ { BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 10111111 } utf8 <byte-reader> stream-contents dup >array swap string? ] unit-test
-
-[ B{ 121 120 } 0 ] [
- B{ 0 121 120 0 0 0 0 0 0 } binary
- [ 1 read drop "\0" read-until ] with-byte-reader
-] unit-test
-
-[ 1 1 4 11 f ] [
- B{ 1 2 3 4 5 6 7 8 9 10 11 12 } binary
- [
- read1
- 0 seek-absolute input-stream get stream-seek
- read1
- 2 seek-relative input-stream get stream-seek
- read1
- -2 seek-end input-stream get stream-seek
- read1
- 0 seek-end input-stream get stream-seek
- read1
- ] with-byte-reader
-] unit-test
+++ /dev/null
-! Copyright (C) 2008, 2009 Daniel Ehrenberg
-! See http://factorcode.org/license.txt for BSD license.
-USING: byte-arrays byte-vectors kernel io.encodings io.streams.string
-sequences io namespaces io.encodings.private accessors sequences.private
-io.streams.sequence destructors math combinators ;
-IN: io.streams.byte-array
-
-M: byte-vector stream-element-type drop +byte+ ;
-
-: <byte-writer> ( encoding -- stream )
- 512 <byte-vector> swap <encoder> ;
-
-: with-byte-writer ( encoding quot -- byte-array )
- [ <byte-writer> ] dip [ output-stream get ] compose with-output-stream*
- dup encoder? [ stream>> ] when >byte-array ; inline
-
-TUPLE: byte-reader { underlying byte-array read-only } { i array-capacity } ;
-
-M: byte-reader stream-element-type drop +byte+ ;
-
-M: byte-reader stream-read-partial stream-read ;
-M: byte-reader stream-read sequence-read ;
-M: byte-reader stream-read1 sequence-read1 ;
-M: byte-reader stream-read-until sequence-read-until ;
-M: byte-reader dispose drop ;
-
-M: byte-reader stream-seek ( n seek-type stream -- )
- swap {
- { seek-absolute [ (>>i) ] }
- { seek-relative [ [ + ] change-i drop ] }
- { seek-end [ [ underlying>> length + ] keep (>>i) ] }
- [ bad-seek-type ]
- } case ;
-
-: <byte-reader> ( byte-array encoding -- stream )
- [ B{ } like 0 byte-reader boa ] dip <decoder> ;
-
-: with-byte-reader ( byte-array encoding quot -- )
- [ <byte-reader> ] dip with-input-stream* ; inline
+++ /dev/null
-Streams for reading and writing bytes in a byte array
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors alien alien.c-types alien.accessors math io ;
-IN: io.streams.memory
-
-TUPLE: memory-stream alien index ;
-
-: <memory-stream> ( alien -- stream )
- 0 memory-stream boa ;
-
-M: memory-stream stream-element-type drop +byte+ ;
-
-M: memory-stream stream-read1
- [ [ alien>> ] [ index>> ] bi alien-unsigned-1 ]
- [ [ 1+ ] change-index drop ] bi ;
-
-M: memory-stream stream-read
- [
- [ index>> ] [ alien>> ] bi <displaced-alien>
- swap memory>byte-array
- ] [ [ + ] change-index drop ] 2bi ;
+++ /dev/null
-Streams for reading data directly from memory
! Copyright (C) 2008 Peter Burns.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel peg peg.ebnf math.parser math.private strings math
+USING: kernel peg peg.ebnf math.parser math.parser.private strings math
math.functions sequences arrays vectors hashtables assocs
prettyprint json ;
IN: json.reader
-! Copyright (C) 2003, 2008 Slava Pestov.
+! Copyright (C) 2003, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays byte-arrays generic hashtables io assocs
-kernel math namespaces make sequences strings sbufs vectors
+USING: accessors arrays byte-arrays byte-vectors generic hashtables io
+assocs kernel math namespaces make sequences strings sbufs vectors
words prettyprint.config prettyprint.custom prettyprint.sections
-quotations io io.pathnames io.styles math.parser effects
-classes.tuple math.order classes.tuple.private classes
-combinators colors ;
+quotations io io.pathnames io.styles math.parser effects classes.tuple
+math.order classes.tuple.private classes combinators colors ;
IN: prettyprint.backend
M: effect pprint* effect>string "(" ")" surround text ;
M: compose pprint-delims drop \ [ \ ] ;
M: array pprint-delims drop \ { \ } ;
M: byte-array pprint-delims drop \ B{ \ } ;
+M: byte-vector pprint-delims drop \ BV{ \ } ;
M: vector pprint-delims drop \ V{ \ } ;
M: hashtable pprint-delims drop \ H{ \ } ;
M: tuple pprint-delims drop \ T{ \ } ;
M: object >pprint-sequence ;
M: vector >pprint-sequence ;
+M: byte-vector >pprint-sequence ;
M: curry >pprint-sequence ;
M: compose >pprint-sequence ;
M: hashtable >pprint-sequence >alist ;
M: object pprint* pprint-object ;
M: vector pprint* pprint-object ;
+M: byte-vector pprint* pprint-object ;
M: hashtable pprint* pprint-object ;
M: curry pprint* pprint-object ;
M: compose pprint* pprint-object ;
! Copyright (C) 2004, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: fry accessors alien alien.accessors arrays byte-arrays
-classes sequences.private continuations.private effects generic
-hashtables hashtables.private io io.backend io.files
-io.files.private io.streams.c kernel kernel.private math
-math.private memory namespaces namespaces.private parser
-quotations quotations.private sbufs sbufs.private
-sequences sequences.private slots.private strings
+USING: fry accessors alien alien.accessors arrays byte-arrays classes
+sequences.private continuations.private effects generic hashtables
+hashtables.private io io.backend io.files io.files.private
+io.streams.c kernel kernel.private math math.private
+math.parser.private memory memory.private namespaces
+namespaces.private parser quotations quotations.private sbufs
+sbufs.private sequences sequences.private slots.private strings
strings.private system threads.private classes.tuple
-classes.tuple.private vectors vectors.private words definitions
-assocs summary compiler.units system.private
-combinators combinators.short-circuit locals locals.backend locals.types
+classes.tuple.private vectors vectors.private words definitions assocs
+summary compiler.units system.private combinators
+combinators.short-circuit locals locals.backend locals.types
quotations.private combinators.private stack-checker.values
generic.single generic.single.private
alien.libraries
\ bignum>float { bignum } { float } define-primitive
\ bignum>float make-foldable
-\ string>float { string } { float } define-primitive
-\ string>float make-foldable
+\ (string>float) { byte-array } { float } define-primitive
+\ (string>float) make-foldable
-\ float>string { float } { string } define-primitive
-\ float>string make-foldable
+\ (float>string) { float } { byte-array } define-primitive
+\ (float>string) make-foldable
\ float>bits { real } { integer } define-primitive
\ float>bits make-foldable
\ gc-stats { } { array } define-primitive
-\ save-image { string } { } define-primitive
+\ (save-image) { byte-array } { } define-primitive
-\ save-image-and-exit { string } { } define-primitive
+\ (save-image-and-exit) { byte-array } { } define-primitive
\ data-room { } { integer integer array } define-primitive
\ data-room make-flushable
\ tag { object } { fixnum } define-primitive
\ tag make-foldable
-\ dlopen { string } { dll } define-primitive
+\ (dlopen) { byte-array } { dll } define-primitive
-\ dlsym { string object } { c-ptr } define-primitive
+\ (dlsym) { byte-array object } { c-ptr } define-primitive
\ dlclose { dll } { } define-primitive
\ die { } { } define-primitive
-\ fopen { string string } { alien } define-primitive
+\ (fopen) { byte-array byte-array } { alien } define-primitive
\ fgetc { alien } { object } define-primitive
--- /dev/null
+USING: help.markup help.syntax strings byte-arrays alien libc
+debugger io.encodings.string sequences ;
+IN: alien.strings
+
+HELP: string>alien
+{ $values { "string" string } { "encoding" "an encoding descriptor" } { "byte-array" byte-array } }
+{ $description "Encodes a string together with a trailing null code point using the given encoding, and stores the resulting bytes in a freshly-allocated byte array." }
+{ $errors "Throws an error if the string contains null characters, or characters not representable in the given encoding." } ;
+
+HELP: alien>string
+{ $values { "c-ptr" c-ptr } { "encoding" "an encoding descriptor" } { "string/f" "a string or " { $link f } } }
+{ $description "Reads a null-terminated C string from the specified address with the given encoding." } ;
+
+HELP: string>symbol
+{ $values { "str" string } { "alien" alien } }
+{ $description "Converts the string to a format which is a valid symbol name for the Factor VM's compiled code linker. By performing this conversion ahead of time, the image loader can run without allocating memory."
+$nl
+"On Windows CE, symbols are represented as UCS2 strings, and on all other platforms they are ASCII strings." } ;
+
+ABOUT: "c-strings"
--- /dev/null
+USING: alien.strings 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
+
+[ "\u0000ff" ]
+[ "\u0000ff" latin1 string>alien latin1 alien>string ]
+unit-test
+
+[ "hello world" ]
+[ "hello world" latin1 string>alien latin1 alien>string ]
+unit-test
+
+[ "hello\u00abcdworld" ]
+[ "hello\u00abcdworld" utf16le string>alien utf16le alien>string ]
+unit-test
+
+[ t ] [ f expired? ] unit-test
+
+[ "hello world" ] [
+ "hello world" ascii malloc-string
+ dup ascii alien>string swap free
+] unit-test
+
+[ "hello world" ] [
+ "hello world" utf16n malloc-string
+ dup utf16n alien>string swap free
+] unit-test
+
+[ f ] [ f utf8 alien>string ] unit-test
+
+[ "hello" ] [ "hello" utf16 encode utf16 decode ] unit-test
+
+[ "hello" ] [ "hello" utf16 string>alien utf16 alien>string ] unit-test
--- /dev/null
+! Copyright (C) 2008, 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays sequences kernel kernel.private accessors math
+alien.accessors byte-arrays io io.encodings io.encodings.utf8
+io.encodings.utf16n io.streams.byte-array io.streams.memory system
+system.private alien strings combinators namespaces init ;
+IN: alien.strings
+
+GENERIC# alien>string 1 ( c-ptr encoding -- string/f )
+
+M: c-ptr alien>string
+ [ <memory-stream> ] [ <decoder> ] bi*
+ "\0" swap stream-read-until drop ;
+
+M: f alien>string
+ drop ;
+
+ERROR: invalid-c-string string ;
+
+: check-string ( string -- )
+ 0 over memq? [ invalid-c-string ] [ drop ] if ;
+
+GENERIC# string>alien 1 ( string encoding -- byte-array )
+
+M: c-ptr string>alien drop ;
+
+M: string string>alien
+ over check-string
+ <byte-writer>
+ [ stream-write ]
+ [ 0 swap stream-write1 ]
+ [ stream>> >byte-array ]
+ tri ;
+
+HOOK: alien>native-string os ( alien -- string )
+
+HOOK: native-string>alien os ( string -- alien )
+
+M: windows alien>native-string utf16n alien>string ;
+
+M: wince native-string>alien utf16n string>alien ;
+
+M: winnt native-string>alien utf8 string>alien ;
+
+M: unix alien>native-string utf8 alien>string ;
+
+M: unix native-string>alien utf8 string>alien ;
+
+: dll-path ( dll -- string )
+ path>> alien>native-string ;
+
+: string>symbol ( str -- alien )
+ dup string?
+ [ native-string>alien ]
+ [ [ native-string>alien ] map ] if ;
+
+[
+ 8 getenv utf8 alien>string string>cpu \ cpu set-global
+ 9 getenv utf8 alien>string string>os \ os set-global
+] "alien.strings" add-init-hook
+
--- /dev/null
+Passing Factor strings as C strings and vice versa
"kernel"
"kernel.private"
"math"
+ "math.parser.private"
"math.private"
"memory"
+ "memory.private"
"quotations"
"quotations.private"
"sbufs"
{ "float>bignum" "math.private" (( x -- y )) }
{ "fixnum>float" "math.private" (( x -- y )) }
{ "bignum>float" "math.private" (( x -- y )) }
- { "string>float" "math.private" (( str -- n/f )) }
- { "float>string" "math.private" (( n -- str )) }
+ { "(string>float)" "math.parser.private" (( str -- n/f )) }
+ { "(float>string)" "math.parser.private" (( n -- str )) }
{ "float>bits" "math" (( x -- n )) }
{ "double>bits" "math" (( x -- n )) }
{ "bits>float" "math" (( n -- x )) }
{ "(exists?)" "io.files.private" (( path -- ? )) }
{ "gc" "memory" (( -- )) }
{ "gc-stats" "memory" f }
- { "save-image" "memory" (( path -- )) }
- { "save-image-and-exit" "memory" (( path -- )) }
+ { "(save-image)" "memory.private" (( path -- )) }
+ { "(save-image-and-exit)" "memory.private" (( path -- )) }
{ "datastack" "kernel" (( -- ds )) }
{ "retainstack" "kernel" (( -- rs )) }
{ "callstack" "kernel" (( -- cs )) }
{ "code-room" "memory" (( -- code-free code-total )) }
{ "micros" "system" (( -- us )) }
{ "modify-code-heap" "compiler.units" (( alist -- )) }
- { "dlopen" "alien.libraries" (( path -- dll )) }
- { "dlsym" "alien.libraries" (( name dll -- alien )) }
+ { "(dlopen)" "alien.libraries" (( path -- dll )) }
+ { "(dlsym)" "alien.libraries" (( name dll -- alien )) }
{ "dlclose" "alien.libraries" (( dll -- )) }
{ "<byte-array>" "byte-arrays" (( n -- byte-array )) }
{ "(byte-array)" "byte-arrays" (( n -- byte-array )) }
{ "<displaced-alien>" "alien" (( displacement c-ptr -- alien )) }
- { "alien-signed-cell" "alien.accessors" f }
- { "set-alien-signed-cell" "alien.accessors" f }
- { "alien-unsigned-cell" "alien.accessors" f }
- { "set-alien-unsigned-cell" "alien.accessors" f }
- { "alien-signed-8" "alien.accessors" f }
- { "set-alien-signed-8" "alien.accessors" f }
- { "alien-unsigned-8" "alien.accessors" f }
- { "set-alien-unsigned-8" "alien.accessors" f }
- { "alien-signed-4" "alien.accessors" f }
- { "set-alien-signed-4" "alien.accessors" f }
- { "alien-unsigned-4" "alien.accessors" f }
- { "set-alien-unsigned-4" "alien.accessors" f }
- { "alien-signed-2" "alien.accessors" f }
- { "set-alien-signed-2" "alien.accessors" f }
- { "alien-unsigned-2" "alien.accessors" f }
- { "set-alien-unsigned-2" "alien.accessors" f }
- { "alien-signed-1" "alien.accessors" f }
- { "set-alien-signed-1" "alien.accessors" f }
- { "alien-unsigned-1" "alien.accessors" f }
- { "set-alien-unsigned-1" "alien.accessors" f }
- { "alien-float" "alien.accessors" f }
- { "set-alien-float" "alien.accessors" f }
- { "alien-double" "alien.accessors" f }
- { "set-alien-double" "alien.accessors" f }
- { "alien-cell" "alien.accessors" f }
- { "set-alien-cell" "alien.accessors" f }
+ { "alien-signed-cell" "alien.accessors" (( c-ptr n -- value )) }
+ { "set-alien-signed-cell" "alien.accessors" (( value c-ptr n -- )) }
+ { "alien-unsigned-cell" "alien.accessors" (( c-ptr n -- value )) }
+ { "set-alien-unsigned-cell" "alien.accessors" (( value c-ptr n -- )) }
+ { "alien-signed-8" "alien.accessors" (( c-ptr n -- value )) }
+ { "set-alien-signed-8" "alien.accessors" (( value c-ptr n -- )) }
+ { "alien-unsigned-8" "alien.accessors" (( c-ptr n -- value )) }
+ { "set-alien-unsigned-8" "alien.accessors" (( value c-ptr n -- )) }
+ { "alien-signed-4" "alien.accessors" (( c-ptr n -- value )) }
+ { "set-alien-signed-4" "alien.accessors" (( value c-ptr n -- )) }
+ { "alien-unsigned-4" "alien.accessors" (( c-ptr n -- value )) }
+ { "set-alien-unsigned-4" "alien.accessors" (( value c-ptr n -- )) }
+ { "alien-signed-2" "alien.accessors" (( c-ptr n -- value )) }
+ { "set-alien-signed-2" "alien.accessors" (( value c-ptr n -- )) }
+ { "alien-unsigned-2" "alien.accessors" (( c-ptr n -- value )) }
+ { "set-alien-unsigned-2" "alien.accessors" (( value c-ptr n -- )) }
+ { "alien-signed-1" "alien.accessors" (( c-ptr n -- value )) }
+ { "set-alien-signed-1" "alien.accessors" (( value c-ptr n -- )) }
+ { "alien-unsigned-1" "alien.accessors" (( c-ptr n -- value )) }
+ { "set-alien-unsigned-1" "alien.accessors" (( value c-ptr n -- )) }
+ { "alien-float" "alien.accessors" (( c-ptr n -- value )) }
+ { "set-alien-float" "alien.accessors" (( value c-ptr n -- )) }
+ { "alien-double" "alien.accessors" (( c-ptr n -- value )) }
+ { "set-alien-double" "alien.accessors" (( value c-ptr n -- )) }
+ { "alien-cell" "alien.accessors" (( c-ptr n -- value )) }
+ { "set-alien-cell" "alien.accessors" (( value c-ptr n -- )) }
{ "alien-address" "alien" (( c-ptr -- addr )) }
{ "set-slot" "slots.private" (( value obj n -- )) }
{ "string-nth" "strings.private" (( n string -- ch )) }
{ "end-scan" "memory" (( -- )) }
{ "size" "memory" (( obj -- n )) }
{ "die" "kernel" (( -- )) }
- { "fopen" "io.streams.c" (( path mode -- alien )) }
+ { "(fopen)" "io.streams.c" (( path mode -- alien )) }
{ "fgetc" "io.streams.c" (( alien -- ch/f )) }
{ "fread" "io.streams.c" (( n alien -- str/f )) }
{ "fputc" "io.streams.c" (( ch alien -- )) }
"<PRIVATE"
"BIN:"
"B{"
+ "BV{"
"C:"
"CHAR:"
"DEFER:"
--- /dev/null
+USING: arrays byte-arrays help.markup help.syntax kernel combinators ;\r
+IN: byte-vectors\r
+\r
+ARTICLE: "byte-vectors" "Byte vectors"\r
+"The " { $vocab-link "byte-vectors" } " vocabulary implements resizable mutable sequence of unsigned bytes. Byte vectors implement the " { $link "sequence-protocol" } " and thus all " { $link "sequences" } " can be used with them."\r
+$nl\r
+"Byte vectors form a class:"\r
+{ $subsection byte-vector }\r
+{ $subsection byte-vector? }\r
+"Creating byte vectors:"\r
+{ $subsection >byte-vector }\r
+{ $subsection <byte-vector> }\r
+"Literal syntax:"\r
+{ $subsection POSTPONE: BV{ }\r
+"If you don't care about initial capacity, a more elegant way to create a new byte vector is to write:"\r
+{ $code "BV{ } clone" } ;\r
+\r
+ABOUT: "byte-vectors"\r
+\r
+HELP: byte-vector\r
+{ $description "The class of resizable byte vectors. See " { $link "byte-vectors" } " for information." } ;\r
+\r
+HELP: <byte-vector>\r
+{ $values { "n" "a positive integer specifying initial capacity" } { "byte-vector" byte-vector } }\r
+{ $description "Creates a new byte vector that can hold " { $snippet "n" } " bytes before resizing." } ;\r
+\r
+HELP: >byte-vector\r
+{ $values { "seq" "a sequence" } { "byte-vector" byte-vector } }\r
+{ $description "Outputs a freshly-allocated byte vector with the same elements as a given sequence." }\r
+{ $errors "Throws an error if the sequence contains elements other than integers." } ;\r
+\r
+HELP: BV{\r
+{ $syntax "BV{ elements... }" }\r
+{ $values { "elements" "a list of bytes" } }\r
+{ $description "Marks the beginning of a literal byte vector. Literal byte vectors are terminated by " { $link POSTPONE: } } "." } \r
+{ $examples { $code "BV{ 1 2 3 12 }" } } ;\r
--- /dev/null
+IN: byte-vectors.tests\r
+USING: tools.test byte-vectors vectors sequences kernel\r
+prettyprint ;\r
+\r
+[ 0 ] [ 123 <byte-vector> length ] unit-test\r
+\r
+: do-it ( seq -- seq )\r
+ 123 [ over push ] each ;\r
+\r
+[ t ] [\r
+ 3 <byte-vector> do-it\r
+ 3 <vector> do-it sequence=\r
+] unit-test\r
+\r
+[ t ] [ BV{ } byte-vector? ] unit-test\r
+\r
+[ "BV{ }" ] [ BV{ } unparse ] unit-test\r
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.\r
+! See http://factorcode.org/license.txt for BSD license.\r
+USING: arrays kernel kernel.private math sequences\r
+sequences.private growable byte-arrays accessors ;\r
+IN: byte-vectors\r
+\r
+TUPLE: byte-vector\r
+{ underlying byte-array }\r
+{ length array-capacity } ;\r
+\r
+: <byte-vector> ( n -- byte-vector )\r
+ (byte-array) 0 byte-vector boa ; inline\r
+\r
+: >byte-vector ( seq -- byte-vector )\r
+ T{ byte-vector f B{ } 0 } clone-like ;\r
+\r
+M: byte-vector like\r
+ drop dup byte-vector? [\r
+ dup byte-array?\r
+ [ dup length byte-vector boa ] [ >byte-vector ] if\r
+ ] unless ;\r
+\r
+M: byte-vector new-sequence\r
+ drop [ (byte-array) ] [ >fixnum ] bi byte-vector boa ;\r
+\r
+M: byte-vector equal?\r
+ over byte-vector? [ sequence= ] [ 2drop f ] if ;\r
+\r
+M: byte-array like\r
+ #! If we have an byte-array, we're done.\r
+ #! If we have a byte-vector, and it's at full capacity,\r
+ #! we're done. Otherwise, call resize-byte-array, which is a\r
+ #! relatively fast primitive.\r
+ drop dup byte-array? [\r
+ dup byte-vector? [\r
+ [ length ] [ underlying>> ] bi\r
+ 2dup length eq?\r
+ [ nip ] [ resize-byte-array ] if\r
+ ] [ >byte-array ] if\r
+ ] unless ;\r
+\r
+M: byte-array new-resizable drop <byte-vector> ;\r
+\r
+INSTANCE: byte-vector growable\r
--- /dev/null
+Growable byte arrays
--- /dev/null
+collections
\r
[ sa ] [ sa { sa sb sc } min-class ] unit-test\r
\r
+[ f ] [ sa sb classes-intersect? ] unit-test\r
+\r
[ +lt+ ] [ integer sequence class<=> ] unit-test\r
[ +lt+ ] [ sequence object class<=> ] unit-test\r
[ +gt+ ] [ object sequence class<=> ] unit-test\r
[ +eq+ ] [ integer integer class<=> ] unit-test\r
+\r
+! Limitations:\r
+\r
+! UNION: u1 sa sb ;\r
+! UNION: u2 sc ;\r
+\r
+! [ f ] [ u1 u2 classes-intersect? ] unit-test
\ No newline at end of file
#! Direct calls to the generic word (not tail calls or indirect calls)
#! will jump to the inline cache entry point instead of the megamorphic
#! dispatch entry point.
- combination get #>> [ f inline-cache-miss ] 3curry [ ] like ;
+ combination get #>> [ { } inline-cache-miss ] 3curry [ ] like ;
: make-empty-cache ( -- array )
mega-cache-size get f <array> ;
--- /dev/null
+Daniel Ehrenberg
--- /dev/null
+UTF16 encoding/decoding
--- /dev/null
+! Copyright (C) 2008 Daniel Ehrenberg
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax io.encodings strings ;
+IN: io.encodings.utf16
+
+ARTICLE: "io.encodings.utf16" "UTF-16 encoding"
+"The UTF-16 encoding is a variable-width encoding. Unicode code points are encoded as 2 or 4 byte sequences. There are three encoding descriptor classes for working with UTF-16, depending on endianness or the presence of a BOM:"
+{ $subsection utf16 }
+{ $subsection utf16le }
+{ $subsection utf16be } ;
+
+ABOUT: "io.encodings.utf16"
+
+HELP: utf16le
+{ $class-description "The encoding descriptor for UTF-16LE, that is, UTF-16 in little endian, without a byte order mark. Streams can be made which read or write wth this encoding." }
+{ $see-also "encodings-introduction" } ;
+
+HELP: utf16be
+{ $class-description "The encoding descriptor for UTF-16BE, that is, UTF-16 in big endian, without a byte order mark. Streams can be made which read or write wth this encoding." }
+{ $see-also "encodings-introduction" } ;
+
+HELP: utf16
+{ $class-description "The encoding descriptor for UTF-16, that is, UTF-16 with a byte order mark. This is the most useful for general input and output in UTF-16. Streams can be made which read or write wth this encoding." }
+{ $see-also "encodings-introduction" } ;
+
+{ utf16 utf16le utf16be } related-words
--- /dev/null
+! Copyright (C) 2008 Daniel Ehrenberg.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel tools.test io.encodings.utf16 arrays sbufs
+io.streams.byte-array sequences io.encodings io strings
+io.encodings.string alien.c-types alien.strings accessors classes ;
+IN: io.encodings.utf16.tests
+
+[ { CHAR: x } ] [ B{ 0 CHAR: x } utf16be decode >array ] unit-test
+[ { HEX: 1D11E } ] [ B{ HEX: D8 HEX: 34 HEX: DD HEX: 1E } utf16be decode >array ] unit-test
+[ { CHAR: replacement-character } ] [ B{ BIN: 11011111 CHAR: q } utf16be decode >array ] unit-test
+[ { CHAR: replacement-character } ] [ B{ BIN: 11011011 CHAR: x BIN: 11011011 CHAR: x } utf16be decode >array ] unit-test
+
+[ { 0 120 216 52 221 30 } ] [ { CHAR: x HEX: 1d11e } >string utf16be encode >array ] unit-test
+
+[ { CHAR: x } ] [ B{ CHAR: x 0 } utf16le decode >array ] unit-test
+[ { 119070 } ] [ B{ HEX: 34 HEX: D8 HEX: 1E HEX: DD } >string utf16le decode >array ] unit-test
+[ { CHAR: replacement-character } ] [ { 0 BIN: 11011111 } >string utf16le decode >array ] unit-test
+[ { CHAR: replacement-character } ] [ { 0 BIN: 11011011 0 0 } >string utf16le decode >array ] unit-test
+
+[ { 120 0 52 216 30 221 } ] [ { CHAR: x HEX: 1d11e } >string utf16le encode >array ] unit-test
+
+[ { CHAR: x } ] [ B{ HEX: ff HEX: fe CHAR: x 0 } utf16 decode >array ] unit-test
+[ { CHAR: x } ] [ B{ HEX: fe HEX: ff 0 CHAR: x } utf16 decode >array ] unit-test
+
+[ { HEX: ff HEX: fe 120 0 52 216 30 221 } ] [ { CHAR: x HEX: 1d11e } >string utf16 encode >array ] unit-test
--- /dev/null
+! Copyright (C) 2006, 2009 Daniel Ehrenberg.
+! See http://factorcode.org/license.txt for BSD license.
+USING: math kernel sequences sbufs vectors namespaces io.binary
+io.encodings combinators splitting io byte-arrays ;
+IN: io.encodings.utf16
+
+SINGLETON: utf16be
+
+SINGLETON: utf16le
+
+SINGLETON: utf16
+
+ERROR: missing-bom ;
+
+<PRIVATE
+
+! UTF-16BE decoding
+
+: append-nums ( byte ch -- ch )
+ over [ 8 shift bitor ] [ 2drop replacement-char ] if ;
+
+: double-be ( stream byte -- stream char )
+ over stream-read1 swap append-nums ;
+
+: quad-be ( stream byte -- stream char )
+ double-be over stream-read1 [
+ dup -2 shift BIN: 110111 number= [
+ [ 2 shift ] dip BIN: 11 bitand bitor
+ over stream-read1 swap append-nums HEX: 10000 +
+ ] [ 2drop dup stream-read1 drop replacement-char ] if
+ ] when* ;
+
+: ignore ( stream -- stream char )
+ dup stream-read1 drop replacement-char ;
+
+: begin-utf16be ( stream byte -- stream char )
+ dup -3 shift BIN: 11011 number= [
+ dup BIN: 00000100 bitand zero?
+ [ BIN: 11 bitand quad-be ]
+ [ drop ignore ] if
+ ] [ double-be ] if ;
+
+M: utf16be decode-char
+ drop dup stream-read1 dup [ begin-utf16be ] when nip ;
+
+! UTF-16LE decoding
+
+: quad-le ( stream ch -- stream char )
+ over stream-read1 swap 10 shift bitor
+ over stream-read1 dup -2 shift BIN: 110111 = [
+ BIN: 11 bitand append-nums HEX: 10000 +
+ ] [ 2drop replacement-char ] if ;
+
+: double-le ( stream byte1 byte2 -- stream char )
+ dup -3 shift BIN: 11011 = [
+ dup BIN: 100 bitand 0 number=
+ [ BIN: 11 bitand 8 shift bitor quad-le ]
+ [ 2drop replacement-char ] if
+ ] [ append-nums ] if ;
+
+: begin-utf16le ( stream byte -- stream char )
+ over stream-read1 [ double-le ] [ drop replacement-char ] if* ;
+
+M: utf16le decode-char
+ drop dup stream-read1 dup [ begin-utf16le ] when nip ;
+
+! UTF-16LE/BE encoding
+
+: encode-first ( char -- byte1 byte2 )
+ -10 shift
+ dup -8 shift BIN: 11011000 bitor
+ swap HEX: FF bitand ;
+
+: encode-second ( char -- byte3 byte4 )
+ BIN: 1111111111 bitand
+ dup -8 shift BIN: 11011100 bitor
+ swap BIN: 11111111 bitand ;
+
+: stream-write2 ( stream char1 char2 -- )
+ rot [ stream-write1 ] curry bi@ ;
+
+: char>utf16be ( stream char -- )
+ dup HEX: FFFF > [
+ HEX: 10000 -
+ 2dup encode-first stream-write2
+ encode-second stream-write2
+ ] [ h>b/b swap stream-write2 ] if ;
+
+M: utf16be encode-char ( char stream encoding -- )
+ drop swap char>utf16be ;
+
+: char>utf16le ( char stream -- )
+ dup HEX: FFFF > [
+ HEX: 10000 -
+ 2dup encode-first swap stream-write2
+ encode-second swap stream-write2
+ ] [ h>b/b stream-write2 ] if ;
+
+M: utf16le encode-char ( char stream encoding -- )
+ drop swap char>utf16le ;
+
+! UTF-16
+
+CONSTANT: bom-le B{ HEX: ff HEX: fe }
+
+CONSTANT: bom-be B{ HEX: fe HEX: ff }
+
+: bom>le/be ( bom -- le/be )
+ dup bom-le sequence= [ drop utf16le ] [
+ bom-be sequence= [ utf16be ] [ missing-bom ] if
+ ] if ;
+
+M: utf16 <decoder> ( stream utf16 -- decoder )
+ drop 2 over stream-read bom>le/be <decoder> ;
+
+M: utf16 <encoder> ( stream utf16 -- encoder )
+ drop bom-le over stream-write utf16le <encoder> ;
+
+PRIVATE>
--- /dev/null
+Daniel Ehrenberg
--- /dev/null
+UTF16 encoding with native byte order
--- /dev/null
+USING: help.markup help.syntax ;
+IN: io.encodings.utf16n
+
+HELP: utf16n
+{ $class-description "The encoding descriptor for UTF-16 without a byte order mark in native endian order. This is useful mostly for FFI calls which take input of strings of the type wchar_t*" }
+{ $see-also "encodings-introduction" } ;
--- /dev/null
+USING: accessors alien.c-types kernel
+io.encodings.utf16 io.streams.byte-array tools.test ;
+IN: io.encodings.utf16n
+
+: correct-endian ( obj -- ? )
+ code>> little-endian? [ utf16le = ] [ utf16be = ] if ;
+
+[ t ] [ B{ } utf16n <byte-reader> correct-endian ] unit-test
+[ t ] [ utf16n <byte-writer> correct-endian ] unit-test
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: io.encodings io.encodings.utf16 kernel alien.accessors ;
+IN: io.encodings.utf16n
+
+! Native-order UTF-16
+
+SINGLETON: utf16n
+
+: utf16n ( -- descriptor )
+ B{ 1 0 0 0 } 0 alien-unsigned-4 1 = utf16le utf16be ? ; foldable
+
+M: utf16n <decoder> drop utf16n <decoder> ;
+
+M: utf16n <encoder> drop utf16n <encoder> ;
-! Copyright (C) 2004, 2008 Slava Pestov, Daniel Ehrenberg.
+! Copyright (C) 2004, 2009 Slava Pestov, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel kernel.private sequences init namespaces system io
-io.backend io.pathnames io.encodings io.files.private ;
+io.backend io.pathnames io.encodings io.files.private
+alien.strings ;
IN: io.files
HOOK: (file-reader) io-backend ( path -- stream )
: with-file-appender ( path encoding quot -- )
[ <file-appender> ] dip with-output-stream ; inline
-: exists? ( path -- ? ) normalize-path (exists?) ;
+: exists? ( path -- ? )
+ normalize-path native-string>alien (exists?) ;
! Current directory
<PRIVATE
[
cwd current-directory set-global
- 13 getenv cwd prepend-path \ image set-global
- 14 getenv cwd prepend-path \ vm set-global
+ 13 getenv alien>native-string cwd prepend-path \ image set-global
+ 14 getenv alien>native-string cwd prepend-path \ vm set-global
image parent-directory "resource-path" set-global
] "io.files" add-init-hook
--- /dev/null
+USING: help.syntax help.markup io byte-arrays quotations ;
+IN: io.streams.byte-array
+
+ABOUT: "io.streams.byte-array"
+
+ARTICLE: "io.streams.byte-array" "Byte-array streams"
+"Byte array streams:"
+{ $subsection <byte-reader> }
+{ $subsection <byte-writer> }
+"Utility combinators:"
+{ $subsection with-byte-reader }
+{ $subsection with-byte-writer } ;
+
+HELP: <byte-reader>
+{ $values { "byte-array" byte-array }
+ { "encoding" "an encoding descriptor" }
+ { "stream" "a new byte reader" } }
+{ $description "Creates an input stream reading from a byte array using an encoding." } ;
+
+HELP: <byte-writer>
+{ $values { "encoding" "an encoding descriptor" }
+ { "stream" "a new byte writer" } }
+{ $description "Creates an output stream writing data to a byte array using an encoding." } ;
+
+HELP: with-byte-reader
+{ $values { "encoding" "an encoding descriptor" }
+ { "quot" quotation } { "byte-array" byte-array } }
+{ $description "Calls the quotation in a new dynamic scope with " { $link input-stream } " rebound to an input stream for reading from a byte array using an encoding." } ;
+
+HELP: with-byte-writer
+{ $values { "encoding" "an encoding descriptor" }
+ { "quot" quotation }
+ { "byte-array" byte-array } }
+{ $description "Calls the quotation in a new dynamic scope with " { $link output-stream } " rebound to an output stream writing data to a byte array using an encoding." } ;
--- /dev/null
+USING: tools.test io.streams.byte-array io.encodings.binary
+io.encodings.utf8 io kernel arrays strings namespaces ;
+
+[ B{ 1 2 3 } ] [ binary [ B{ 1 2 3 } write ] with-byte-writer ] unit-test
+[ B{ 1 2 3 } ] [ { 1 2 3 } binary [ 3 read ] with-byte-reader ] unit-test
+
+[ B{ BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 10111111 BIN: 11101111 BIN: 10000000 BIN: 10111111 BIN: 11011111 BIN: 10000000 CHAR: x } ]
+[ { BIN: 101111111000000111111 BIN: 1111000000111111 BIN: 11111000000 CHAR: x } >string utf8 [ write ] with-byte-writer ] unit-test
+[ { BIN: 101111111000000111111 } t ] [ { BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 10111111 } utf8 <byte-reader> stream-contents dup >array swap string? ] unit-test
+
+[ B{ 121 120 } 0 ] [
+ B{ 0 121 120 0 0 0 0 0 0 } binary
+ [ 1 read drop "\0" read-until ] with-byte-reader
+] unit-test
+
+[ 1 1 4 11 f ] [
+ B{ 1 2 3 4 5 6 7 8 9 10 11 12 } binary
+ [
+ read1
+ 0 seek-absolute input-stream get stream-seek
+ read1
+ 2 seek-relative input-stream get stream-seek
+ read1
+ -2 seek-end input-stream get stream-seek
+ read1
+ 0 seek-end input-stream get stream-seek
+ read1
+ ] with-byte-reader
+] unit-test
--- /dev/null
+! Copyright (C) 2008, 2009 Daniel Ehrenberg
+! See http://factorcode.org/license.txt for BSD license.
+USING: byte-arrays byte-vectors kernel io.encodings sequences io
+namespaces io.encodings.private accessors sequences.private
+io.streams.sequence destructors math combinators ;
+IN: io.streams.byte-array
+
+M: byte-vector stream-element-type drop +byte+ ;
+
+: <byte-writer> ( encoding -- stream )
+ 512 <byte-vector> swap <encoder> ;
+
+: with-byte-writer ( encoding quot -- byte-array )
+ [ <byte-writer> ] dip [ output-stream get ] compose with-output-stream*
+ dup encoder? [ stream>> ] when >byte-array ; inline
+
+TUPLE: byte-reader { underlying byte-array read-only } { i array-capacity } ;
+
+M: byte-reader stream-element-type drop +byte+ ;
+
+M: byte-reader stream-read-partial stream-read ;
+M: byte-reader stream-read sequence-read ;
+M: byte-reader stream-read1 sequence-read1 ;
+M: byte-reader stream-read-until sequence-read-until ;
+M: byte-reader dispose drop ;
+
+M: byte-reader stream-seek ( n seek-type stream -- )
+ swap {
+ { seek-absolute [ (>>i) ] }
+ { seek-relative [ [ + ] change-i drop ] }
+ { seek-end [ [ underlying>> length + ] keep (>>i) ] }
+ [ bad-seek-type ]
+ } case ;
+
+: <byte-reader> ( byte-array encoding -- stream )
+ [ B{ } like 0 byte-reader boa ] dip <decoder> ;
+
+: with-byte-reader ( byte-array encoding quot -- )
+ [ <byte-reader> ] dip with-input-stream* ; inline
--- /dev/null
+Streams for reading and writing bytes in a byte array
! Copyright (C) 2004, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel kernel.private namespaces make io io.encodings
-sequences math generic threads.private classes io.backend
-io.files continuations destructors byte-arrays accessors
-combinators ;
+USING: kernel kernel.private namespaces make io io.encodings sequences
+math generic threads.private classes io.backend io.files
+io.encodings.utf8 alien.strings continuations destructors byte-arrays
+accessors combinators ;
IN: io.streams.c
TUPLE: c-stream handle disposed ;
M: c-io-backend io-multiplex 60 60 * 1000 * 1000 * or (sleep) ;
+: fopen ( path mode -- handle )
+ [ utf8 string>alien ] bi@ (fopen) ;
+
M: c-io-backend (file-reader)
"rb" fopen <c-reader> ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors alien alien.accessors math io ;
+IN: io.streams.memory
+
+TUPLE: memory-stream alien index ;
+
+: <memory-stream> ( alien -- stream )
+ 0 memory-stream boa ;
+
+M: memory-stream stream-element-type drop +byte+ ;
+
+M: memory-stream stream-read1
+ [ [ alien>> ] [ index>> ] bi alien-unsigned-1 ]
+ [ [ 1+ ] change-index drop ] bi ;
--- /dev/null
+Streams for reading data directly from memory
-USING: help.markup help.syntax math math.private prettyprint
+USING: help.markup help.syntax math math.parser.private prettyprint
namespaces make strings ;
IN: math.parser
! Copyright (C) 2004, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math.private namespaces sequences sequences.private
-strings arrays combinators splitting math assocs make ;
+strings arrays combinators splitting math assocs byte-arrays make ;
IN: math.parser
: digit> ( ch -- n )
string>natural
] if ; inline
+: string>float ( str -- n/f )
+ >byte-array 0 suffix (string>float) ;
+
PRIVATE>
: base> ( str radix -- n/f )
[ ".0" append ]
} cond ;
+: float>string ( x -- str )
+ (float>string)
+ [ 0 = ] trim-tail >string
+ fix-float ;
+
M: float >base
drop {
{ [ dup fp-nan? ] [ drop "0/0." ] }
{ [ dup 1/0. = ] [ drop "1/0." ] }
{ [ dup -1/0. = ] [ drop "-1/0." ] }
{ [ dup double>bits HEX: 8000000000000000 = ] [ drop "-0.0" ] }
- [ float>string fix-float ]
+ [ float>string ]
} cond ;
: number>string ( n -- str ) 10 >base ;
-! Copyright (C) 2005, 2008 Slava Pestov.
+! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel continuations sequences vectors arrays system math ;
+USING: kernel continuations sequences vectors arrays system math
+io.backend alien.strings memory.private ;
IN: memory
: (each-object) ( quot: ( obj -- ) -- )
[ count-instances 100 + <vector> ] keep swap
[ [ push-if ] 2curry each-object ] keep >array ; inline
+: save-image ( path -- )
+ normalize-path native-string>alien (save-image) ;
+
+: save-image-and-exit ( path -- )
+ normalize-path native-string>alien (save-image) ;
+
: save ( -- ) image save-image ;
[
\ over ,
over reader-word 1quotation
- [ dip call ] curry [ dip swap ] curry %
+ [ dip call ] curry [ ] like [ dip swap ] curry %
swap setter-word ,
] [ ] make (( object quot -- object )) define-inline
] [ 2drop ] if ;
! Copyright (C) 2004, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien arrays byte-arrays definitions generic
+USING: accessors alien arrays byte-arrays byte-vectors definitions generic
hashtables kernel math namespaces parser lexer sequences strings
strings.parser sbufs vectors words words.symbol words.constant
words.alias quotations io assocs splitting classes.tuple
"{" [ \ } [ >array ] parse-literal ] define-core-syntax
"V{" [ \ } [ >vector ] parse-literal ] define-core-syntax
"B{" [ \ } [ >byte-array ] parse-literal ] define-core-syntax
+ "BV{" [ \ } [ >byte-vector ] parse-literal ] define-core-syntax
"H{" [ \ } [ >hashtable ] parse-literal ] define-core-syntax
"T{" [ parse-tuple-literal parsed ] define-core-syntax
"W{" [ \ } [ first <wrapper> ] parse-literal ] define-core-syntax
-! Copyright (C) 2007 Slava Pestov.
+! Copyright (C) 2007, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-IN: system
USING: kernel kernel.private sequences math namespaces
init splitting assocs system.private layouts words ;
+IN: system
-SINGLETON: x86.32
-SINGLETON: x86.64
-SINGLETON: arm
-SINGLETON: ppc
+SINGLETONS: x86.32 x86.64 arm ppc ;
UNION: x86 x86.32 x86.64 ;
: cpu ( -- class ) \ cpu get-global ; foldable
-SINGLETON: winnt
-SINGLETON: wince
+SINGLETONS: winnt wince ;
UNION: windows winnt wince ;
-SINGLETON: freebsd
-SINGLETON: netbsd
-SINGLETON: openbsd
-SINGLETON: solaris
-SINGLETON: macosx
-SINGLETON: linux
+SINGLETONS: freebsd netbsd openbsd solaris macosx linux ;
SINGLETON: haiku
: vm ( -- path ) \ vm get-global ;
-[
- 8 getenv string>cpu \ cpu set-global
- 9 getenv string>os \ os set-global
-] "system" add-init-hook
-
: embedded? ( -- ? ) 15 getenv ;
: millis ( -- ms ) micros 1000 /i ;
-PLAF_DLL_OBJS += vm/cpu-arm.o
+PLAF_DLL_OBJS += vmpp/cpu-arm.o
-include vm/Config.unix
-PLAF_DLL_OBJS += vm/os-genunix.o vm/os-freebsd.o
+include vmpp/Config.unix
+PLAF_DLL_OBJS += vmpp/os-genunix.o vmpp/os-freebsd.o
CFLAGS += -export-dynamic
LIBS = -L/usr/local/lib/ -lm $(X11_UI_LIBS)
LIBS = -lm -framework Cocoa -framework AppKit
endif
-LINKER = gcc $(CFLAGS) -dynamiclib -single_module -std=gnu99 \
+LINKER = $(CPP) $(CFLAGS) -dynamiclib -single_module -std=gnu99 \
-current_version $(VERSION) \
-compatibility_version $(VERSION) \
-fvisibility=hidden \
+++ /dev/null
-#include "master.h"
-
-/* gets the address of an object representing a C pointer */
-void *alien_offset(CELL object)
-{
- F_ALIEN *alien;
- F_BYTE_ARRAY *byte_array;
-
- switch(type_of(object))
- {
- case BYTE_ARRAY_TYPE:
- byte_array = untag_object(object);
- return byte_array + 1;
- case ALIEN_TYPE:
- alien = untag_object(object);
- if(alien->expired != F)
- general_error(ERROR_EXPIRED,object,F,NULL);
- return alien_offset(alien->alien) + alien->displacement;
- case F_TYPE:
- return NULL;
- default:
- type_error(ALIEN_TYPE,object);
- return NULL; /* can't happen */
- }
-}
-
-/* gets the address of an object representing a C pointer, with the
-intention of storing the pointer across code which may potentially GC. */
-void *pinned_alien_offset(CELL object)
-{
- F_ALIEN *alien;
-
- switch(type_of(object))
- {
- case ALIEN_TYPE:
- alien = untag_object(object);
- if(alien->expired != F)
- general_error(ERROR_EXPIRED,object,F,NULL);
- return pinned_alien_offset(alien->alien) + alien->displacement;
- case F_TYPE:
- return NULL;
- default:
- type_error(ALIEN_TYPE,object);
- return NULL; /* can't happen */
- }
-}
-
-/* pop an object representing a C pointer */
-void *unbox_alien(void)
-{
- return alien_offset(dpop());
-}
-
-/* make an alien */
-CELL allot_alien(CELL delegate, CELL displacement)
-{
- REGISTER_ROOT(delegate);
- F_ALIEN *alien = allot_object(ALIEN_TYPE,sizeof(F_ALIEN));
- UNREGISTER_ROOT(delegate);
-
- if(type_of(delegate) == ALIEN_TYPE)
- {
- F_ALIEN *delegate_alien = untag_object(delegate);
- displacement += delegate_alien->displacement;
- alien->alien = delegate_alien->alien;
- }
- else
- alien->alien = delegate;
-
- alien->displacement = displacement;
- alien->expired = F;
- return tag_object(alien);
-}
-
-/* make an alien and push */
-void box_alien(void *ptr)
-{
- if(ptr == NULL)
- dpush(F);
- else
- dpush(allot_alien(F,(CELL)ptr));
-}
-
-/* make an alien pointing at an offset of another alien */
-void primitive_displaced_alien(void)
-{
- CELL alien = dpop();
- CELL displacement = to_cell(dpop());
-
- if(alien == F && displacement == 0)
- dpush(F);
- else
- {
- switch(type_of(alien))
- {
- case BYTE_ARRAY_TYPE:
- case ALIEN_TYPE:
- case F_TYPE:
- dpush(allot_alien(alien,displacement));
- break;
- default:
- type_error(ALIEN_TYPE,alien);
- break;
- }
- }
-}
-
-/* address of an object representing a C pointer. Explicitly throw an error
-if the object is a byte array, as a sanity check. */
-void primitive_alien_address(void)
-{
- box_unsigned_cell((CELL)pinned_alien_offset(dpop()));
-}
-
-/* pop ( alien n ) from datastack, return alien's address plus n */
-INLINE void *alien_pointer(void)
-{
- F_FIXNUM offset = to_fixnum(dpop());
- return unbox_alien() + offset;
-}
-
-/* define words to read/write values at an alien address */
-#define DEFINE_ALIEN_ACCESSOR(name,type,boxer,to) \
- void primitive_alien_##name(void) \
- { \
- boxer(*(type*)alien_pointer()); \
- } \
- void primitive_set_alien_##name(void) \
- { \
- type* ptr = alien_pointer(); \
- type value = to(dpop()); \
- *ptr = value; \
- }
-
-DEFINE_ALIEN_ACCESSOR(signed_cell,F_FIXNUM,box_signed_cell,to_fixnum)
-DEFINE_ALIEN_ACCESSOR(unsigned_cell,CELL,box_unsigned_cell,to_cell)
-DEFINE_ALIEN_ACCESSOR(signed_8,s64,box_signed_8,to_signed_8)
-DEFINE_ALIEN_ACCESSOR(unsigned_8,u64,box_unsigned_8,to_unsigned_8)
-DEFINE_ALIEN_ACCESSOR(signed_4,s32,box_signed_4,to_fixnum)
-DEFINE_ALIEN_ACCESSOR(unsigned_4,u32,box_unsigned_4,to_cell)
-DEFINE_ALIEN_ACCESSOR(signed_2,s16,box_signed_2,to_fixnum)
-DEFINE_ALIEN_ACCESSOR(unsigned_2,u16,box_unsigned_2,to_cell)
-DEFINE_ALIEN_ACCESSOR(signed_1,s8,box_signed_1,to_fixnum)
-DEFINE_ALIEN_ACCESSOR(unsigned_1,u8,box_unsigned_1,to_cell)
-DEFINE_ALIEN_ACCESSOR(float,float,box_float,to_float)
-DEFINE_ALIEN_ACCESSOR(double,double,box_double,to_double)
-DEFINE_ALIEN_ACCESSOR(cell,void *,box_alien,pinned_alien_offset)
-
-/* for FFI calls passing structs by value */
-void to_value_struct(CELL src, void *dest, CELL size)
-{
- memcpy(dest,alien_offset(src),size);
-}
-
-/* for FFI callbacks receiving structs by value */
-void box_value_struct(void *src, CELL size)
-{
- F_BYTE_ARRAY *array = allot_byte_array(size);
- memcpy(array + 1,src,size);
- dpush(tag_object(array));
-}
-
-/* On some x86 OSes, structs <= 8 bytes are returned in registers. */
-void box_small_struct(CELL x, CELL y, CELL size)
-{
- CELL data[2];
- data[0] = x;
- data[1] = y;
- box_value_struct(data,size);
-}
-
-/* On OS X/PPC, complex numbers are returned in registers. */
-void box_medium_struct(CELL x1, CELL x2, CELL x3, CELL x4, CELL size)
-{
- CELL data[4];
- data[0] = x1;
- data[1] = x2;
- data[2] = x3;
- data[3] = x4;
- box_value_struct(data,size);
-}
-
-/* open a native library and push a handle */
-void primitive_dlopen(void)
-{
- CELL path = tag_object(string_to_native_alien(
- untag_string(dpop())));
- REGISTER_ROOT(path);
- F_DLL* dll = allot_object(DLL_TYPE,sizeof(F_DLL));
- UNREGISTER_ROOT(path);
- dll->path = path;
- ffi_dlopen(dll);
- dpush(tag_object(dll));
-}
-
-/* look up a symbol in a native library */
-void primitive_dlsym(void)
-{
- CELL dll = dpop();
- REGISTER_ROOT(dll);
- F_SYMBOL *sym = unbox_symbol_string();
- UNREGISTER_ROOT(dll);
-
- F_DLL *d;
-
- if(dll == F)
- box_alien(ffi_dlsym(NULL,sym));
- else
- {
- d = untag_dll(dll);
- if(d->dll == NULL)
- dpush(F);
- else
- box_alien(ffi_dlsym(d,sym));
- }
-}
-
-/* close a native library handle */
-void primitive_dlclose(void)
-{
- ffi_dlclose(untag_dll(dpop()));
-}
-
-void primitive_dll_validp(void)
-{
- CELL dll = dpop();
- if(dll == F)
- dpush(T);
- else
- {
- F_DLL *d = untag_dll(dll);
- dpush(d->dll == NULL ? F : T);
- }
-}
--- /dev/null
+#include "master.hpp"
+
+namespace 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)
+{
+ switch(tagged<object>(obj).type())
+ {
+ case ALIEN_TYPE:
+ alien *ptr = untag<alien>(obj);
+ if(ptr->expired != F)
+ general_error(ERROR_EXPIRED,obj,F,NULL);
+ return pinned_alien_offset(ptr->alien) + ptr->displacement;
+ case F_TYPE:
+ return NULL;
+ default:
+ type_error(ALIEN_TYPE,obj);
+ return NULL; /* can't happen */
+ }
+}
+
+/* make an alien */
+cell allot_alien(cell delegate_, cell displacement)
+{
+ gc_root<object> delegate(delegate_);
+ gc_root<alien> new_alien(allot<alien>(sizeof(alien)));
+
+ if(delegate.type_p(ALIEN_TYPE))
+ {
+ tagged<alien> delegate_alien = delegate.as<alien>();
+ displacement += delegate_alien->displacement;
+ new_alien->alien = delegate_alien->alien;
+ }
+ else
+ new_alien->alien = delegate.value();
+
+ new_alien->displacement = displacement;
+ new_alien->expired = F;
+
+ return new_alien.value();
+}
+
+/* make an alien pointing at an offset of another alien */
+PRIMITIVE(displaced_alien)
+{
+ cell alien = dpop();
+ cell displacement = to_cell(dpop());
+
+ if(alien == F && displacement == 0)
+ dpush(F);
+ else
+ {
+ switch(tagged<object>(alien).type())
+ {
+ case BYTE_ARRAY_TYPE:
+ case ALIEN_TYPE:
+ case F_TYPE:
+ dpush(allot_alien(alien,displacement));
+ break;
+ default:
+ type_error(ALIEN_TYPE,alien);
+ break;
+ }
+ }
+}
+
+/* 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)
+{
+ box_unsigned_cell((cell)pinned_alien_offset(dpop()));
+}
+
+/* pop ( alien n ) from datastack, return alien's address plus n */
+static void *alien_pointer(void)
+{
+ fixnum offset = to_fixnum(dpop());
+ return unbox_alien() + offset;
+}
+
+/* define words to read/write values at an alien address */
+#define DEFINE_ALIEN_ACCESSOR(name,type,boxer,to) \
+ PRIMITIVE(alien_##name) \
+ { \
+ boxer(*(type*)alien_pointer()); \
+ } \
+ PRIMITIVE(set_alien_##name) \
+ { \
+ type *ptr = (type *)alien_pointer(); \
+ type value = to(dpop()); \
+ *ptr = value; \
+ }
+
+DEFINE_ALIEN_ACCESSOR(signed_cell,fixnum,box_signed_cell,to_fixnum)
+DEFINE_ALIEN_ACCESSOR(unsigned_cell,cell,box_unsigned_cell,to_cell)
+DEFINE_ALIEN_ACCESSOR(signed_8,s64,box_signed_8,to_signed_8)
+DEFINE_ALIEN_ACCESSOR(unsigned_8,u64,box_unsigned_8,to_unsigned_8)
+DEFINE_ALIEN_ACCESSOR(signed_4,s32,box_signed_4,to_fixnum)
+DEFINE_ALIEN_ACCESSOR(unsigned_4,u32,box_unsigned_4,to_cell)
+DEFINE_ALIEN_ACCESSOR(signed_2,s16,box_signed_2,to_fixnum)
+DEFINE_ALIEN_ACCESSOR(unsigned_2,u16,box_unsigned_2,to_cell)
+DEFINE_ALIEN_ACCESSOR(signed_1,s8,box_signed_1,to_fixnum)
+DEFINE_ALIEN_ACCESSOR(unsigned_1,u8,box_unsigned_1,to_cell)
+DEFINE_ALIEN_ACCESSOR(float,float,box_float,to_float)
+DEFINE_ALIEN_ACCESSOR(double,double,box_double,to_double)
+DEFINE_ALIEN_ACCESSOR(cell,void *,box_alien,pinned_alien_offset)
+
+/* open a native library and push a handle */
+PRIMITIVE(dlopen)
+{
+ gc_root<byte_array> path(dpop());
+ path.untag_check();
+ gc_root<dll> dll(allot<dll>(sizeof(dll)));
+ dll->path = path.value();
+ ffi_dlopen(dll.untagged());
+ dpush(dll.value());
+}
+
+/* look up a symbol in a native library */
+PRIMITIVE(dlsym)
+{
+ gc_root<object> library(dpop());
+ gc_root<byte_array> name(dpop());
+ name.untag_check();
+
+ vm_char *sym = (vm_char *)(name.untagged() + 1);
+
+ if(library.value() == F)
+ box_alien(ffi_dlsym(NULL,sym));
+ else
+ {
+ tagged<dll> d = library.as<dll>();
+ d.untag_check();
+
+ if(d->dll == NULL)
+ dpush(F);
+ else
+ box_alien(ffi_dlsym(d.untagged(),sym));
+ }
+}
+
+/* close a native library handle */
+PRIMITIVE(dlclose)
+{
+ ffi_dlclose(untag_check<dll>(dpop()));
+}
+
+PRIMITIVE(dll_validp)
+{
+ cell library = dpop();
+ if(library == F)
+ dpush(T);
+ else
+ dpush(tagged<dll>(library)->dll == NULL ? F : T);
+}
+
+/* gets the address of an object representing a C pointer */
+VM_C_API char *alien_offset(cell obj)
+{
+ switch(tagged<object>(obj).type())
+ {
+ case BYTE_ARRAY_TYPE:
+ return untag<byte_array>(obj)->data<char>();
+ case ALIEN_TYPE:
+ alien *ptr = untag<alien>(obj);
+ if(ptr->expired != F)
+ general_error(ERROR_EXPIRED,obj,F,NULL);
+ return alien_offset(ptr->alien) + ptr->displacement;
+ case F_TYPE:
+ return NULL;
+ default:
+ type_error(ALIEN_TYPE,obj);
+ return NULL; /* can't happen */
+ }
+}
+
+/* pop an object representing a C pointer */
+VM_C_API char *unbox_alien(void)
+{
+ return alien_offset(dpop());
+}
+
+/* make an alien and push */
+VM_C_API void box_alien(void *ptr)
+{
+ if(ptr == NULL)
+ dpush(F);
+ else
+ dpush(allot_alien(F,(cell)ptr));
+}
+
+/* for FFI calls passing structs by value */
+VM_C_API void to_value_struct(cell src, void *dest, cell size)
+{
+ memcpy(dest,alien_offset(src),size);
+}
+
+/* for FFI callbacks receiving structs by value */
+VM_C_API void 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));
+}
+
+/* On some x86 OSes, structs <= 8 bytes are returned in registers. */
+VM_C_API void box_small_struct(cell x, cell y, cell size)
+{
+ cell data[2];
+ data[0] = x;
+ data[1] = y;
+ box_value_struct(data,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)
+{
+ cell data[4];
+ data[0] = x1;
+ data[1] = x2;
+ data[2] = x3;
+ data[3] = x4;
+ box_value_struct(data,size);
+}
+
+}
+++ /dev/null
-CELL allot_alien(CELL delegate, CELL displacement);
-
-void primitive_displaced_alien(void);
-void primitive_alien_address(void);
-
-DLLEXPORT void *alien_offset(CELL object);
-
-void fixup_alien(F_ALIEN* d);
-
-DLLEXPORT void *unbox_alien(void);
-DLLEXPORT void box_alien(void *ptr);
-
-void primitive_alien_signed_cell(void);
-void primitive_set_alien_signed_cell(void);
-void primitive_alien_unsigned_cell(void);
-void primitive_set_alien_unsigned_cell(void);
-void primitive_alien_signed_8(void);
-void primitive_set_alien_signed_8(void);
-void primitive_alien_unsigned_8(void);
-void primitive_set_alien_unsigned_8(void);
-void primitive_alien_signed_4(void);
-void primitive_set_alien_signed_4(void);
-void primitive_alien_unsigned_4(void);
-void primitive_set_alien_unsigned_4(void);
-void primitive_alien_signed_2(void);
-void primitive_set_alien_signed_2(void);
-void primitive_alien_unsigned_2(void);
-void primitive_set_alien_unsigned_2(void);
-void primitive_alien_signed_1(void);
-void primitive_set_alien_signed_1(void);
-void primitive_alien_unsigned_1(void);
-void primitive_set_alien_unsigned_1(void);
-void primitive_alien_float(void);
-void primitive_set_alien_float(void);
-void primitive_alien_double(void);
-void primitive_set_alien_double(void);
-void primitive_alien_cell(void);
-void primitive_set_alien_cell(void);
-
-DLLEXPORT void to_value_struct(CELL src, void *dest, CELL size);
-DLLEXPORT void box_value_struct(void *src, CELL size);
-DLLEXPORT void box_small_struct(CELL x, CELL y, CELL size);
-void box_medium_struct(CELL x1, CELL x2, CELL x3, CELL x4, CELL size);
-
-DEFINE_UNTAG(F_DLL,DLL_TYPE,dll)
-
-void primitive_dlopen(void);
-void primitive_dlsym(void);
-void primitive_dlclose(void);
-void primitive_dll_validp(void);
--- /dev/null
+namespace factor
+{
+
+cell allot_alien(cell delegate, cell displacement);
+
+PRIMITIVE(displaced_alien);
+PRIMITIVE(alien_address);
+
+PRIMITIVE(alien_signed_cell);
+PRIMITIVE(set_alien_signed_cell);
+PRIMITIVE(alien_unsigned_cell);
+PRIMITIVE(set_alien_unsigned_cell);
+PRIMITIVE(alien_signed_8);
+PRIMITIVE(set_alien_signed_8);
+PRIMITIVE(alien_unsigned_8);
+PRIMITIVE(set_alien_unsigned_8);
+PRIMITIVE(alien_signed_4);
+PRIMITIVE(set_alien_signed_4);
+PRIMITIVE(alien_unsigned_4);
+PRIMITIVE(set_alien_unsigned_4);
+PRIMITIVE(alien_signed_2);
+PRIMITIVE(set_alien_signed_2);
+PRIMITIVE(alien_unsigned_2);
+PRIMITIVE(set_alien_unsigned_2);
+PRIMITIVE(alien_signed_1);
+PRIMITIVE(set_alien_signed_1);
+PRIMITIVE(alien_unsigned_1);
+PRIMITIVE(set_alien_unsigned_1);
+PRIMITIVE(alien_float);
+PRIMITIVE(set_alien_float);
+PRIMITIVE(alien_double);
+PRIMITIVE(set_alien_double);
+PRIMITIVE(alien_cell);
+PRIMITIVE(set_alien_cell);
+
+PRIMITIVE(dlopen);
+PRIMITIVE(dlsym);
+PRIMITIVE(dlclose);
+PRIMITIVE(dll_validp);
+
+VM_C_API char *alien_offset(cell object);
+VM_C_API char *unbox_alien(void);
+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);
+
+}
+++ /dev/null
-#include "master.h"
-
-/* the array is full of undefined data, and must be correctly filled before the
-next GC. size is in cells */
-F_ARRAY *allot_array_internal(CELL type, CELL capacity)
-{
- F_ARRAY *array = allot_object(type,array_size(capacity));
- array->capacity = tag_fixnum(capacity);
- return array;
-}
-
-/* make a new array with an initial element */
-F_ARRAY *allot_array(CELL type, CELL capacity, CELL fill)
-{
- int i;
- REGISTER_ROOT(fill);
- F_ARRAY* array = allot_array_internal(type, capacity);
- UNREGISTER_ROOT(fill);
- if(fill == 0)
- memset((void*)AREF(array,0),'\0',capacity * CELLS);
- else
- {
- /* No need for write barrier here. Either the object is in
- the nursery, or it was allocated directly in tenured space
- and the write barrier is already hit for us in that case. */
- for(i = 0; i < capacity; i++)
- put(AREF(array,i),fill);
- }
- return array;
-}
-
-/* push a new array on the stack */
-void primitive_array(void)
-{
- CELL initial = dpop();
- CELL size = unbox_array_size();
- dpush(tag_array(allot_array(ARRAY_TYPE,size,initial)));
-}
-
-CELL allot_array_1(CELL obj)
-{
- REGISTER_ROOT(obj);
- F_ARRAY *a = allot_array_internal(ARRAY_TYPE,1);
- UNREGISTER_ROOT(obj);
- set_array_nth(a,0,obj);
- return tag_array(a);
-}
-
-CELL allot_array_2(CELL v1, CELL v2)
-{
- REGISTER_ROOT(v1);
- REGISTER_ROOT(v2);
- F_ARRAY *a = allot_array_internal(ARRAY_TYPE,2);
- UNREGISTER_ROOT(v2);
- UNREGISTER_ROOT(v1);
- set_array_nth(a,0,v1);
- set_array_nth(a,1,v2);
- return tag_array(a);
-}
-
-CELL allot_array_4(CELL v1, CELL v2, CELL v3, CELL v4)
-{
- REGISTER_ROOT(v1);
- REGISTER_ROOT(v2);
- REGISTER_ROOT(v3);
- REGISTER_ROOT(v4);
- F_ARRAY *a = allot_array_internal(ARRAY_TYPE,4);
- UNREGISTER_ROOT(v4);
- UNREGISTER_ROOT(v3);
- UNREGISTER_ROOT(v2);
- UNREGISTER_ROOT(v1);
- set_array_nth(a,0,v1);
- set_array_nth(a,1,v2);
- set_array_nth(a,2,v3);
- set_array_nth(a,3,v4);
- return tag_array(a);
-}
-
-static bool reallot_array_in_place_p(F_ARRAY *array, CELL capacity)
-{
- return in_zone(&nursery,(CELL)array) && capacity <= array_capacity(array);
-}
-
-F_ARRAY *reallot_array(F_ARRAY *array, CELL capacity)
-{
-#ifdef FACTOR_DEBUG
- CELL header = untag_header(array->header);
- assert(header == ARRAY_TYPE || header == BIGNUM_TYPE);
-#endif
-
- if(reallot_array_in_place_p(array,capacity))
- {
- array->capacity = tag_fixnum(capacity);
- return array;
- }
- else
- {
- CELL to_copy = array_capacity(array);
- if(capacity < to_copy)
- to_copy = capacity;
-
- REGISTER_UNTAGGED(array);
- F_ARRAY* new_array = allot_array_internal(untag_header(array->header),capacity);
- UNREGISTER_UNTAGGED(array);
-
- memcpy(new_array + 1,array + 1,to_copy * CELLS);
- memset((char *)AREF(new_array,to_copy),'\0',(capacity - to_copy) * CELLS);
-
- return new_array;
- }
-}
-
-void primitive_resize_array(void)
-{
- F_ARRAY* array = untag_array(dpop());
- CELL capacity = unbox_array_size();
- dpush(tag_array(reallot_array(array,capacity)));
-}
-
-void growable_array_add(F_GROWABLE_ARRAY *array, CELL elt)
-{
- F_ARRAY *underlying = untag_object(array->array);
- REGISTER_ROOT(elt);
-
- if(array->count == array_capacity(underlying))
- {
- underlying = reallot_array(underlying,array->count * 2);
- array->array = tag_array(underlying);
- }
-
- UNREGISTER_ROOT(elt);
- set_array_nth(underlying,array->count++,elt);
-}
-
-void growable_array_append(F_GROWABLE_ARRAY *array, F_ARRAY *elts)
-{
- REGISTER_UNTAGGED(elts);
-
- F_ARRAY *underlying = untag_object(array->array);
-
- CELL elts_size = array_capacity(elts);
- CELL new_size = array->count + elts_size;
-
- if(new_size >= array_capacity(underlying))
- {
- underlying = reallot_array(underlying,new_size * 2);
- array->array = tag_array(underlying);
- }
-
- UNREGISTER_UNTAGGED(elts);
-
- write_barrier(array->array);
-
- memcpy((void *)AREF(underlying,array->count),
- (void *)AREF(elts,0),
- elts_size * CELLS);
-
- array->count += elts_size;
-}
--- /dev/null
+#include "master.hpp"
+
+namespace factor
+{
+
+/* make a new array with an initial element */
+array *allot_array(cell capacity, cell fill_)
+{
+ gc_root<object> fill(fill_);
+ gc_root<array> new_array(allot_array_internal<array>(capacity));
+
+ if(fill.value() == tag_fixnum(0))
+ memset(new_array->data(),'\0',capacity * sizeof(cell));
+ else
+ {
+ /* No need for write barrier here. Either the object is in
+ the nursery, or it was allocated directly in tenured space
+ and the write barrier is already hit for us in that case. */
+ cell i;
+ for(i = 0; i < capacity; i++)
+ new_array->data()[i] = fill.value();
+ }
+ return new_array.untagged();
+}
+
+/* push a new array on the stack */
+PRIMITIVE(array)
+{
+ cell initial = dpop();
+ cell size = unbox_array_size();
+ dpush(tag<array>(allot_array(size,initial)));
+}
+
+cell allot_array_1(cell obj_)
+{
+ gc_root<object> obj(obj_);
+ gc_root<array> a(allot_array_internal<array>(1));
+ set_array_nth(a.untagged(),0,obj.value());
+ return a.value();
+}
+
+cell 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));
+ 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_)
+{
+ 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));
+ set_array_nth(a.untagged(),0,v1.value());
+ set_array_nth(a.untagged(),1,v2.value());
+ set_array_nth(a.untagged(),2,v3.value());
+ set_array_nth(a.untagged(),3,v4.value());
+ return a.value();
+}
+
+PRIMITIVE(resize_array)
+{
+ array* a = untag_check<array>(dpop());
+ cell capacity = unbox_array_size();
+ dpush(tag<array>(reallot_array(a,capacity)));
+}
+
+void growable_array::add(cell elt_)
+{
+ gc_root<object> elt(elt_);
+ if(count == array_capacity(elements.untagged()))
+ elements = reallot_array(elements.untagged(),count * 2);
+
+ set_array_nth(elements.untagged(),count++,elt.value());
+}
+
+void growable_array::trim()
+{
+ elements = reallot_array(elements.untagged(),count);
+}
+
+}
+++ /dev/null
-DEFINE_UNTAG(F_ARRAY,ARRAY_TYPE,array)
-
-INLINE CELL tag_array(F_ARRAY *array)
-{
- return RETAG(array,ARRAY_TYPE);
-}
-
-/* Inline functions */
-INLINE CELL array_size(CELL size)
-{
- return sizeof(F_ARRAY) + size * CELLS;
-}
-
-INLINE CELL array_capacity(F_ARRAY* array)
-{
-#ifdef FACTOR_DEBUG
- CELL header = untag_header(array->header);
- assert(header == ARRAY_TYPE || header == BIGNUM_TYPE || header == BYTE_ARRAY_TYPE);
-#endif
- return array->capacity >> TAG_BITS;
-}
-
-#define AREF(array,index) ((CELL)(array) + sizeof(F_ARRAY) + (index) * CELLS)
-#define UNAREF(array,ptr) (((CELL)(ptr)-(CELL)(array)-sizeof(F_ARRAY)) / CELLS)
-
-INLINE CELL array_nth(F_ARRAY *array, CELL slot)
-{
-#ifdef FACTOR_DEBUG
- assert(slot < array_capacity(array));
- assert(untag_header(array->header) == ARRAY_TYPE);
-#endif
- return get(AREF(array,slot));
-}
-
-INLINE void set_array_nth(F_ARRAY *array, CELL slot, CELL value)
-{
-#ifdef FACTOR_DEBUG
- assert(slot < array_capacity(array));
- assert(untag_header(array->header) == ARRAY_TYPE);
-#endif
- put(AREF(array,slot),value);
- write_barrier((CELL)array);
-}
-
-F_ARRAY *allot_array_internal(CELL type, CELL capacity);
-F_ARRAY *allot_array(CELL type, CELL capacity, CELL fill);
-F_BYTE_ARRAY *allot_byte_array(CELL size);
-
-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);
-
-void primitive_array(void);
-
-F_ARRAY *reallot_array(F_ARRAY* array, CELL capacity);
-void primitive_resize_array(void);
-
-/* Macros to simulate a vector in C */
-typedef struct {
- CELL count;
- CELL array;
-} F_GROWABLE_ARRAY;
-
-/* Allocates memory */
-INLINE F_GROWABLE_ARRAY make_growable_array(void)
-{
- F_GROWABLE_ARRAY result;
- result.count = 0;
- result.array = tag_array(allot_array(ARRAY_TYPE,100,F));
- return result;
-}
-
-#define GROWABLE_ARRAY(result) F_GROWABLE_ARRAY result##_g = make_growable_array(); \
- REGISTER_ROOT(result##_g.array)
-
-void growable_array_add(F_GROWABLE_ARRAY *result, CELL elt);
-
-#define GROWABLE_ARRAY_ADD(result,elt) \
- growable_array_add(&result##_g,elt)
-
-void growable_array_append(F_GROWABLE_ARRAY *result, F_ARRAY *elts);
-
-#define GROWABLE_ARRAY_APPEND(result,elts) \
- growable_array_append(&result##_g,elts)
-
-INLINE void growable_array_trim(F_GROWABLE_ARRAY *array)
-{
- array->array = tag_array(reallot_array(untag_object(array->array),array->count));
-}
-
-#define GROWABLE_ARRAY_TRIM(result) growable_array_trim(&result##_g)
-
-#define GROWABLE_ARRAY_DONE(result) \
- UNREGISTER_ROOT(result##_g.array); \
- CELL result = result##_g.array;
--- /dev/null
+namespace factor
+{
+
+inline static cell array_nth(array *array, cell slot)
+{
+#ifdef FACTOR_DEBUG
+ assert(slot < array_capacity(array));
+ assert(array->h.hi_tag() == ARRAY_TYPE);
+#endif
+ 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() : count(0), elements(allot_array(2,F)) {}
+
+ void add(cell elt);
+ void trim();
+};
+
+}
+++ /dev/null
-/* :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. */
-
-/* Changes for Scheme 48:
- * - Converted to ANSI.
- * - Added bitwise operations.
- * - Added s48 to the beginning of all externally visible names.
- * - Cached the bignum representations of -1, 0, and 1.
- */
-
-/* Changes for Factor:
- * - Adapt bignumint.h for Factor memory manager
- * - Add more bignum <-> C type conversions
- * - Remove unused functions
- * - Add local variable GC root recording
- * - Remove s48 prefix from function names
- * - Various fixes for Win64
- */
-
-#include "master.h"
-#include <limits.h>
-#include <stdio.h>
-#include <stdlib.h> /* abort */
-#include <math.h>
-
-/* Exports */
-
-int
-bignum_equal_p(bignum_type x, bignum_type 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_type x, bignum_type 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_type
-bignum_add(bignum_type x, bignum_type 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)))));
-}
-
-/* allocates memory */
-bignum_type
-bignum_subtract(bignum_type x, bignum_type 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_type
-bignum_multiply(bignum_type x, bignum_type 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));
-}
-
-/* allocates memory */
-void
-bignum_divide(bignum_type numerator, bignum_type denominator,
- bignum_type * quotient, bignum_type * 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;
- }
- }
- }
-}
-
-/* allocates memory */
-bignum_type
-bignum_quotient(bignum_type numerator, bignum_type 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_type 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_type *) 0),
- q_negative_p, 0);
- else
- bignum_divide_unsigned_medium_denominator
- (numerator, digit,
- ("ient), ((bignum_type *) 0),
- q_negative_p, 0);
- }
- else
- bignum_divide_unsigned_large_denominator
- (numerator, denominator,
- ("ient), ((bignum_type *) 0),
- q_negative_p, 0);
- return (quotient);
- }
- }
- }
-}
-
-/* allocates memory */
-bignum_type
-bignum_remainder(bignum_type numerator, bignum_type 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_type 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_type *) 0), (&remainder),
- 0, (BIGNUM_NEGATIVE_P (numerator)));
- }
- else
- bignum_divide_unsigned_large_denominator
- (numerator, denominator,
- ((bignum_type *) 0), (&remainder),
- 0, (BIGNUM_NEGATIVE_P (numerator)));
- return (remainder);
- }
- }
-}
-
-#define FOO_TO_BIGNUM(name,type,utype) \
- bignum_type 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 < 0 && n == -1) return (BIGNUM_ONE (1)); \
- { \
- utype accumulator = ((negative_p = (n < 0)) ? (-n) : n); \
- do \
- { \
- (*end_digits++) = (accumulator & BIGNUM_DIGIT_MASK); \
- accumulator >>= BIGNUM_DIGIT_LENGTH; \
- } \
- while (accumulator != 0); \
- } \
- { \
- bignum_type 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(fixnum,F_FIXNUM,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_type 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(fixnum,F_FIXNUM,CELL);
-BIGNUM_TO_FOO(long_long,s64,u64)
-BIGNUM_TO_FOO(ulong_long,u64,u64)
-
-double
-bignum_to_double(bignum_type 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);
- }
-}
-
-#define DTB_WRITE_DIGIT(factor) \
-{ \
- significand *= (factor); \
- digit = ((bignum_digit_type) significand); \
- (*--scan) = digit; \
- significand -= ((double) digit); \
-}
-
-/* allocates memory */
-bignum_type
-double_to_bignum(double x)
-{
- if (x == 1.0/0.0 || x == -1.0/0.0 || 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_type 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 ((F_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_type x, bignum_type 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);
- }
-}
-
-enum bignum_comparison
-bignum_compare_unsigned(bignum_type x, bignum_type 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);
-}
-
-/* Addition */
-
-/* allocates memory */
-bignum_type
-bignum_add_unsigned(bignum_type x, bignum_type y, int negative_p)
-{
- if ((BIGNUM_LENGTH (y)) > (BIGNUM_LENGTH (x)))
- {
- bignum_type z = x;
- x = y;
- y = z;
- }
- {
- bignum_length_type x_length = (BIGNUM_LENGTH (x));
-
- REGISTER_BIGNUM(x);
- REGISTER_BIGNUM(y);
- bignum_type r = (allot_bignum ((x_length + 1), negative_p));
- UNREGISTER_BIGNUM(y);
- UNREGISTER_BIGNUM(x);
-
- 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_type
-bignum_subtract_unsigned(bignum_type x, bignum_type y)
-{
- int negative_p = 0;
- switch (bignum_compare_unsigned (x, y))
- {
- case bignum_comparison_equal:
- return (BIGNUM_ZERO ());
- case bignum_comparison_less:
- {
- bignum_type 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));
-
- REGISTER_BIGNUM(x);
- REGISTER_BIGNUM(y);
- bignum_type r = (allot_bignum (x_length, negative_p));
- UNREGISTER_BIGNUM(y);
- UNREGISTER_BIGNUM(x);
-
- 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))
- Maximum value for carry: ((R * (R - 1)) + (R - 1))
- where R == BIGNUM_RADIX_ROOT */
-
-/* allocates memory */
-bignum_type
-bignum_multiply_unsigned(bignum_type x, bignum_type y, int negative_p)
-{
- if ((BIGNUM_LENGTH (y)) > (BIGNUM_LENGTH (x)))
- {
- bignum_type 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));
-
- REGISTER_BIGNUM(x);
- REGISTER_BIGNUM(y);
- bignum_type r =
- (allot_bignum_zeroed ((x_length + y_length), negative_p));
- UNREGISTER_BIGNUM(y);
- UNREGISTER_BIGNUM(x);
-
- 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));
-#undef x_digit
-#undef y_digit
-#undef product_high
- }
-}
-
-/* allocates memory */
-bignum_type
-bignum_multiply_unsigned_small_factor(bignum_type x, bignum_digit_type y,
- int negative_p)
-{
- bignum_length_type length_x = (BIGNUM_LENGTH (x));
-
- REGISTER_BIGNUM(x);
- bignum_type p = (allot_bignum ((length_x + 1), negative_p));
- UNREGISTER_BIGNUM(x);
-
- 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_type 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);
- }
-}
-
-void
-bignum_destructive_scale_up(bignum_type 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;
-#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;
-#undef product_high
-}
-
-/* Division */
-
-/* For help understanding this algorithm, see:
- Knuth, Donald E., "The Art of Computer Programming",
- volume 2, "Seminumerical Algorithms"
- section 4.3.1, "Multiple-Precision Arithmetic". */
-
-/* allocates memory */
-void
-bignum_divide_unsigned_large_denominator(bignum_type numerator,
- bignum_type denominator,
- bignum_type * quotient,
- bignum_type * remainder,
- int q_negative_p,
- int r_negative_p)
-{
- bignum_length_type length_n = ((BIGNUM_LENGTH (numerator)) + 1);
- bignum_length_type length_d = (BIGNUM_LENGTH (denominator));
-
- REGISTER_BIGNUM(numerator);
- REGISTER_BIGNUM(denominator);
-
- bignum_type q =
- ((quotient != ((bignum_type *) 0))
- ? (allot_bignum ((length_n - length_d), q_negative_p))
- : BIGNUM_OUT_OF_BAND);
-
- REGISTER_BIGNUM(q);
- bignum_type u = (allot_bignum (length_n, r_negative_p));
- UNREGISTER_BIGNUM(q);
-
- UNREGISTER_BIGNUM(denominator);
- UNREGISTER_BIGNUM(numerator);
-
- 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
- {
- REGISTER_BIGNUM(numerator);
- REGISTER_BIGNUM(denominator);
- REGISTER_BIGNUM(u);
- REGISTER_BIGNUM(q);
- bignum_type v = (allot_bignum (length_d, 0));
- UNREGISTER_BIGNUM(q);
- UNREGISTER_BIGNUM(u);
- UNREGISTER_BIGNUM(denominator);
- UNREGISTER_BIGNUM(numerator);
-
- bignum_destructive_normalization (numerator, u, shift);
- bignum_destructive_normalization (denominator, v, shift);
- bignum_divide_unsigned_normalized (u, v, q);
- if (remainder != ((bignum_type *) 0))
- bignum_destructive_unnormalization (u, shift);
- }
-
- REGISTER_BIGNUM(u);
- if(q)
- q = bignum_trim (q);
- UNREGISTER_BIGNUM(u);
-
- REGISTER_BIGNUM(q);
- u = bignum_trim (u);
- UNREGISTER_BIGNUM(q);
-
- if (quotient != ((bignum_type *) 0))
- (*quotient) = q;
-
- if (remainder != ((bignum_type *) 0))
- (*remainder) = u;
-
- return;
-}
-
-void
-bignum_divide_unsigned_normalized(bignum_type u, bignum_type v, bignum_type 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 */
-#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;
-#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 * 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);
- }
-#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);
-}
-
-/* allocates memory */
-void
-bignum_divide_unsigned_medium_denominator(bignum_type numerator,
- bignum_digit_type denominator,
- bignum_type * quotient,
- bignum_type * remainder,
- int q_negative_p,
- int r_negative_p)
-{
- bignum_length_type length_n = (BIGNUM_LENGTH (numerator));
- bignum_length_type length_q;
- bignum_type q;
- 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;
-
- REGISTER_BIGNUM(numerator);
- q = (allot_bignum (length_q, q_negative_p));
- UNREGISTER_BIGNUM(numerator);
-
- bignum_destructive_copy (numerator, q);
- }
- else
- {
- length_q = (length_n + 1);
-
- REGISTER_BIGNUM(numerator);
- q = (allot_bignum (length_q, q_negative_p));
- UNREGISTER_BIGNUM(numerator);
-
- 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_type *) 0))
- {
- if (shift != 0)
- r >>= shift;
-
- REGISTER_BIGNUM(q);
- (*remainder) = (bignum_digit_to_bignum (r, r_negative_p));
- UNREGISTER_BIGNUM(q);
- }
-
- if (quotient != ((bignum_type *) 0))
- (*quotient) = q;
- }
- return;
-}
-
-void
-bignum_destructive_normalization(bignum_type source, bignum_type 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;
-}
-
-void
-bignum_destructive_unnormalization(bignum_type 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 = (((F_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]))); \
-}
-
-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 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_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 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_type numerator,
- bignum_digit_type denominator,
- bignum_type * quotient,
- bignum_type * remainder,
- int q_negative_p,
- int r_negative_p)
-{
- REGISTER_BIGNUM(numerator);
- bignum_type q = (bignum_new_sign (numerator, q_negative_p));
- UNREGISTER_BIGNUM(numerator);
-
- bignum_digit_type r = (bignum_destructive_scale_down (q, denominator));
-
- q = (bignum_trim (q));
-
- if (remainder != ((bignum_type *) 0))
- {
- REGISTER_BIGNUM(q);
- (*remainder) = (bignum_digit_to_bignum (r, r_negative_p));
- UNREGISTER_BIGNUM(q);
- }
-
- (*quotient) = q;
-
- 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_type bignum, bignum_digit_type denominator)
-{
- 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);
-#undef quotient_high
-}
-
-/* allocates memory */
-bignum_type
-bignum_remainder_unsigned_small_denominator(
- bignum_type 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));
-}
-
-/* allocates memory */
-bignum_type
-bignum_digit_to_bignum(bignum_digit_type digit, int negative_p)
-{
- if (digit == 0)
- return (BIGNUM_ZERO ());
- else
- {
- bignum_type result = (allot_bignum (1, negative_p));
- (BIGNUM_REF (result, 0)) = digit;
- return (result);
- }
-}
-
-/* allocates memory */
-bignum_type
-allot_bignum(bignum_length_type length, int negative_p)
-{
- BIGNUM_ASSERT ((length >= 0) || (length < BIGNUM_RADIX));
- bignum_type result = allot_array_internal(BIGNUM_TYPE,length + 1);
- BIGNUM_SET_NEGATIVE_P (result, negative_p);
- return (result);
-}
-
-/* allocates memory */
-bignum_type
-allot_bignum_zeroed(bignum_length_type length, int negative_p)
-{
- bignum_type 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)
-
-/* allocates memory */
-bignum_type
-bignum_shorten_length(bignum_type 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);
-}
-
-/* allocates memory */
-bignum_type
-bignum_trim(bignum_type 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_type
-bignum_new_sign(bignum_type bignum, int negative_p)
-{
- REGISTER_BIGNUM(bignum);
- bignum_type result =
- (allot_bignum ((BIGNUM_LENGTH (bignum)), negative_p));
- UNREGISTER_BIGNUM(bignum);
-
- bignum_destructive_copy (bignum, result);
- return (result);
-}
-
-/* allocates memory */
-bignum_type
-bignum_maybe_new_sign(bignum_type bignum, int negative_p)
-{
- if ((BIGNUM_NEGATIVE_P (bignum)) ? negative_p : (! negative_p))
- return (bignum);
- else
- {
- bignum_type result =
- (allot_bignum ((BIGNUM_LENGTH (bignum)), negative_p));
- bignum_destructive_copy (bignum, result);
- return (result);
- }
-}
-
-void
-bignum_destructive_copy(bignum_type source, bignum_type 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;
-}
-
-/*
- * Added bitwise operations (and oddp).
- */
-
-/* allocates memory */
-bignum_type
-bignum_bitwise_not(bignum_type x)
-{
- return bignum_subtract(BIGNUM_ONE(1), x);
-}
-
-/* allocates memory */
-bignum_type
-bignum_arithmetic_shift(bignum_type arg1, F_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);
-}
-
-#define AND_OP 0
-#define IOR_OP 1
-#define XOR_OP 2
-
-/* allocates memory */
-bignum_type
-bignum_bitwise_and(bignum_type arg1, bignum_type 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_posneg_bitwise_op(AND_OP, arg1, arg2)
- : bignum_pospos_bitwise_op(AND_OP, arg1, arg2)
- );
-}
-
-/* allocates memory */
-bignum_type
-bignum_bitwise_ior(bignum_type arg1, bignum_type 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_posneg_bitwise_op(IOR_OP, arg1, arg2)
- : bignum_pospos_bitwise_op(IOR_OP, arg1, arg2)
- );
-}
-
-/* allocates memory */
-bignum_type
-bignum_bitwise_xor(bignum_type arg1, bignum_type 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_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_type
-bignum_magnitude_ash(bignum_type arg1, F_FIXNUM n)
-{
- bignum_type result = NULL;
- bignum_digit_type *scan1;
- bignum_digit_type *scanr;
- bignum_digit_type *end;
-
- F_FIXNUM digit_offset,bit_offset;
-
- if (BIGNUM_ZERO_P (arg1)) return (arg1);
-
- if (n > 0) {
- digit_offset = n / BIGNUM_DIGIT_LENGTH;
- bit_offset = n % BIGNUM_DIGIT_LENGTH;
-
- REGISTER_BIGNUM(arg1);
- result = allot_bignum_zeroed (BIGNUM_LENGTH (arg1) + digit_offset + 1,
- BIGNUM_NEGATIVE_P(arg1));
- UNREGISTER_BIGNUM(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;
-
- REGISTER_BIGNUM(arg1);
- result = allot_bignum_zeroed (BIGNUM_LENGTH (arg1) - digit_offset,
- BIGNUM_NEGATIVE_P(arg1));
- UNREGISTER_BIGNUM(arg1);
-
- 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;
-
- return (bignum_trim (result));
-}
-
-/* allocates memory */
-bignum_type
-bignum_pospos_bitwise_op(int op, bignum_type arg1, bignum_type arg2)
-{
- bignum_type 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);
-
- REGISTER_BIGNUM(arg1);
- REGISTER_BIGNUM(arg2);
- result = allot_bignum(max_length, 0);
- UNREGISTER_BIGNUM(arg2);
- UNREGISTER_BIGNUM(arg1);
-
- 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_type
-bignum_posneg_bitwise_op(int op, bignum_type arg1, bignum_type arg2)
-{
- bignum_type result;
- bignum_length_type max_length;
-
- 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;
-
- max_length = (BIGNUM_LENGTH(arg1) > BIGNUM_LENGTH(arg2) + 1)
- ? BIGNUM_LENGTH(arg1) : BIGNUM_LENGTH(arg2) + 1;
-
- REGISTER_BIGNUM(arg1);
- REGISTER_BIGNUM(arg2);
- result = allot_bignum(max_length, neg_p);
- UNREGISTER_BIGNUM(arg2);
- UNREGISTER_BIGNUM(arg1);
-
- 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;
-
- 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;
- }
-
- *scanr++ = (op == AND_OP) ? digit1 & digit2 :
- (op == IOR_OP) ? digit1 | digit2 :
- digit1 ^ digit2;
- }
-
- if (neg_p)
- bignum_negate_magnitude(result);
-
- return bignum_trim(result);
-}
-
-/* allocates memory */
-bignum_type
-bignum_negneg_bitwise_op(int op, bignum_type arg1, bignum_type arg2)
-{
- bignum_type 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;
-
- 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;
-
- REGISTER_BIGNUM(arg1);
- REGISTER_BIGNUM(arg2);
- result = allot_bignum(max_length, neg_p);
- UNREGISTER_BIGNUM(arg2);
- UNREGISTER_BIGNUM(arg1);
-
- 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;
-
- 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 (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;
- }
-
- if (neg_p)
- bignum_negate_magnitude(result);
-
- return bignum_trim(result);
-}
-
-void
-bignum_negate_magnitude(bignum_type 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;
- }
-
- *scan++ = digit;
- }
-}
-
-/* Allocates memory */
-bignum_type
-bignum_integer_length(bignum_type bignum)
-{
- bignum_length_type index = ((BIGNUM_LENGTH (bignum)) - 1);
- bignum_digit_type digit = (BIGNUM_REF (bignum, index));
-
- REGISTER_BIGNUM(bignum);
- bignum_type result = (allot_bignum (2, 0));
- UNREGISTER_BIGNUM(bignum);
-
- (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_type 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_type 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 = ((F_FIXNUM)1) << p;
- return (digit & mask) ? 1 : 0;
-}
-
-/* Allocates memory */
-bignum_type
-digit_stream_to_bignum(unsigned int n_digits,
- unsigned int (*producer)(unsigned int),
- 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)
- {
- F_FIXNUM digit = ((F_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_type 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));
- }
- }
-}
--- /dev/null
+/* :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. */
+
+/* Changes for Scheme 48:
+ * - Converted to ANSI.
+ * - Added bitwise operations.
+ * - Added s48 to the beginning of all externally visible names.
+ * - Cached the bignum representations of -1, 0, and 1.
+ */
+
+/* Changes for Factor:
+ * - Adapt bignumint.h for Factor memory manager
+ * - Add more bignum <-> C type conversions
+ * - Remove unused functions
+ * - Add local variable GC root recording
+ * - Remove s48 prefix from function names
+ * - Various fixes for Win64
+ * - Port to C++
+ */
+
+#include "master.hpp"
+
+#include <limits>
+
+#include <stdio.h>
+#include <math.h>
+
+namespace factor
+{
+
+/* Exports */
+
+int
+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))));
+}
+
+enum bignum_comparison
+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))));
+}
+
+/* allocates memory */
+bignum *
+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)))));
+}
+
+/* allocates memory */
+bignum *
+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))))));
+}
+
+/* allocates memory */
+bignum *
+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));
+}
+
+/* allocates memory */
+void
+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;
+ }
+ }
+ }
+}
+
+/* allocates memory */
+bignum *
+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);
+ }
+ }
+ }
+}
+
+/* allocates memory */
+bignum *
+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);
+ }
+ }
+}
+
+#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); \
+ } \
+ }
+
+/* all below allocate memory */
+FOO_TO_BIGNUM(cell,cell,cell)
+FOO_TO_BIGNUM(fixnum,fixnum,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); \
+ } \
+ }
+
+/* all of the below allocate memory */
+BIGNUM_TO_FOO(cell,cell,cell);
+BIGNUM_TO_FOO(fixnum,fixnum,cell);
+BIGNUM_TO_FOO(long_long,s64,u64)
+BIGNUM_TO_FOO(ulong_long,u64,u64)
+
+double
+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);
+ }
+}
+
+#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)
+{
+ 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)
+{
+ 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)
+{
+ 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)
+{
+ 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));
+
+ 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)
+{
+ GC_BIGNUM(x); GC_BIGNUM(y);
+
+ 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));
+ }
+}
+
+/* Multiplication
+ Maximum value for product_low or product_high:
+ ((R * R) + (R * (R - 2)) + (R - 1))
+ Maximum value for carry: ((R * (R - 1)) + (R - 1))
+ where R == BIGNUM_RADIX_ROOT */
+
+/* allocates memory */
+bignum *
+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));
+#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));
+#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)
+{
+ GC_BIGNUM(x);
+
+ bignum_length_type length_x = (BIGNUM_LENGTH (x));
+
+ 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));
+}
+
+void
+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);
+ }
+}
+
+void
+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;
+#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;
+#undef product_high
+}
+
+/* Division */
+
+/* For help understanding this algorithm, see:
+ Knuth, Donald E., "The Art of Computer Programming",
+ volume 2, "Seminumerical Algorithms"
+ 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)
+{
+ GC_BIGNUM(numerator); GC_BIGNUM(denominator);
+
+ 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 * u = (allot_bignum (length_n, r_negative_p));
+ GC_BIGNUM(u);
+
+ 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)
+{
+ 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;
+#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 * 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);
+ }
+#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);
+}
+
+/* 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)
+{
+ GC_BIGNUM(numerator);
+
+ bignum_length_type length_n = (BIGNUM_LENGTH (numerator));
+ bignum_length_type length_q;
+ bignum * q = NULL;
+ GC_BIGNUM(q);
+
+ 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)
+{
+ 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)
+{
+ 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]))); \
+}
+
+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 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_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 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)
+{
+ GC_BIGNUM(numerator);
+
+ bignum * q = (bignum_new_sign (numerator, q_negative_p));
+ GC_BIGNUM(q);
+
+ bignum_digit_type r = (bignum_destructive_scale_down (q, denominator));
+
+ q = (bignum_trim (q));
+
+ if (remainder != ((bignum * *) 0))
+ (*remainder) = (bignum_digit_to_bignum (r, r_negative_p));
+
+ (*quotient) = q;
+
+ 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 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);
+#undef quotient_high
+}
+
+/* allocates memory */
+bignum *
+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));
+}
+
+/* allocates memory */
+bignum *
+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);
+ }
+}
+
+/* allocates memory */
+bignum *
+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);
+}
+
+/* allocates memory */
+bignum *
+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);
+}
+
+#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_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_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)
+{
+ GC_BIGNUM(x);
+ bignum * result = (allot_bignum ((BIGNUM_LENGTH (x)), negative_p));
+
+ bignum_destructive_copy (x, result);
+ return (result);
+}
+
+/* allocates memory */
+bignum *
+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);
+ }
+}
+
+void
+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;
+}
+
+/*
+ * Added bitwise operations (and oddp).
+ */
+
+/* allocates memory */
+bignum *
+bignum_bitwise_not(bignum * x)
+{
+ return bignum_subtract(BIGNUM_ONE(1), x);
+}
+
+/* allocates memory */
+bignum *
+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);
+}
+
+#define AND_OP 0
+#define IOR_OP 1
+#define XOR_OP 2
+
+/* allocates memory */
+bignum *
+bignum_bitwise_and(bignum * arg1, bignum * 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_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)
+{
+ 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_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)
+{
+ 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_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)
+{
+ GC_BIGNUM(arg1);
+
+ bignum * result = NULL;
+ bignum_digit_type *scan1;
+ bignum_digit_type *scanr;
+ bignum_digit_type *end;
+
+ fixnum digit_offset,bit_offset;
+
+ if (BIGNUM_ZERO_P (arg1)) return (arg1);
+
+ 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));
+
+ 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;
+
+ 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;
+
+ 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));
+}
+
+/* allocates memory */
+bignum *
+bignum_pospos_bitwise_op(int op, bignum * arg1, bignum * arg2)
+{
+ GC_BIGNUM(arg1); GC_BIGNUM(arg2);
+
+ 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)
+{
+ GC_BIGNUM(arg1); GC_BIGNUM(arg2);
+
+ 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;
+
+ 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;
+
+ 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);
+
+ carry2 = 1;
+
+ 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;
+ }
+
+ *scanr++ = (op == AND_OP) ? digit1 & digit2 :
+ (op == IOR_OP) ? digit1 | digit2 :
+ digit1 ^ digit2;
+ }
+
+ if (neg_p)
+ bignum_negate_magnitude(result);
+
+ return bignum_trim(result);
+}
+
+/* allocates memory */
+bignum *
+bignum_negneg_bitwise_op(int op, bignum * arg1, bignum * arg2)
+{
+ GC_BIGNUM(arg1); GC_BIGNUM(arg2);
+
+ 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;
+
+ 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;
+
+ 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);
+
+ 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;
+
+ 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;
+ }
+
+ *scanr++ = (op == AND_OP) ? digit1 & digit2 :
+ (op == IOR_OP) ? digit1 | digit2 :
+ digit1 ^ digit2;
+ }
+
+ if (neg_p)
+ bignum_negate_magnitude(result);
+
+ return bignum_trim(result);
+}
+
+void
+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;
+ }
+
+ *scan++ = digit;
+ }
+}
+
+/* Allocates memory */
+bignum *
+bignum_integer_length(bignum * x)
+{
+ GC_BIGNUM(x);
+
+ bignum_length_type index = ((BIGNUM_LENGTH (x)) - 1);
+ bignum_digit_type digit = (BIGNUM_REF (x, index));
+
+ 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));
+}
+
+/* Allocates memory */
+int
+bignum_logbitp(int shift, bignum * 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)
+{
+ 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_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));
+ }
+ }
+}
+
+}
+++ /dev/null
-/* :tabSize=2:indentSize=2:noTabs=true:
-
-Copyright (C) 1989-1992 Massachusetts Institute of Technology
-Portions copyright (C) 2004-2007 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. */
-
-typedef F_ARRAY * bignum_type;
-#define BIGNUM_OUT_OF_BAND ((bignum_type) 0)
-
-enum bignum_comparison
-{
- bignum_comparison_equal = 0,
- bignum_comparison_less = -1,
- bignum_comparison_greater = 1
-};
-
-int bignum_equal_p(bignum_type, bignum_type);
-enum bignum_comparison bignum_compare(bignum_type, bignum_type);
-bignum_type bignum_add(bignum_type, bignum_type);
-bignum_type bignum_subtract(bignum_type, bignum_type);
-bignum_type bignum_negate(bignum_type);
-bignum_type bignum_multiply(bignum_type, bignum_type);
-void
-bignum_divide(bignum_type numerator, bignum_type denominator,
- bignum_type * quotient, bignum_type * remainder);
-bignum_type bignum_quotient(bignum_type, bignum_type);
-bignum_type bignum_remainder(bignum_type, bignum_type);
-DLLEXPORT bignum_type fixnum_to_bignum(F_FIXNUM);
-DLLEXPORT bignum_type cell_to_bignum(CELL);
-DLLEXPORT bignum_type long_long_to_bignum(s64 n);
-DLLEXPORT bignum_type ulong_long_to_bignum(u64 n);
-F_FIXNUM bignum_to_fixnum(bignum_type);
-CELL bignum_to_cell(bignum_type);
-s64 bignum_to_long_long(bignum_type);
-u64 bignum_to_ulong_long(bignum_type);
-bignum_type double_to_bignum(double);
-double bignum_to_double(bignum_type);
-
-/* Added bitwise operators. */
-
-DLLEXPORT bignum_type bignum_bitwise_not(bignum_type),
- bignum_arithmetic_shift(bignum_type, F_FIXNUM),
- bignum_bitwise_and(bignum_type, bignum_type),
- bignum_bitwise_ior(bignum_type, bignum_type),
- bignum_bitwise_xor(bignum_type, bignum_type);
-
-/* Forward references */
-int bignum_equal_p_unsigned(bignum_type, bignum_type);
-enum bignum_comparison bignum_compare_unsigned(bignum_type, bignum_type);
-bignum_type bignum_add_unsigned(bignum_type, bignum_type, int);
-bignum_type bignum_subtract_unsigned(bignum_type, bignum_type);
-bignum_type bignum_multiply_unsigned(bignum_type, bignum_type, int);
-bignum_type bignum_multiply_unsigned_small_factor
- (bignum_type, bignum_digit_type, int);
-void bignum_destructive_scale_up(bignum_type, bignum_digit_type);
-void bignum_destructive_add(bignum_type, bignum_digit_type);
-void bignum_divide_unsigned_large_denominator
- (bignum_type, bignum_type, bignum_type *, bignum_type *, int, int);
-void bignum_destructive_normalization(bignum_type, bignum_type, int);
-void bignum_destructive_unnormalization(bignum_type, int);
-void bignum_divide_unsigned_normalized(bignum_type, bignum_type, bignum_type);
-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_type, bignum_digit_type, bignum_type *, bignum_type *, 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_type, bignum_digit_type, bignum_type *, bignum_type *, int, int);
-bignum_digit_type bignum_destructive_scale_down
- (bignum_type, bignum_digit_type);
-bignum_type bignum_remainder_unsigned_small_denominator
- (bignum_type, bignum_digit_type, int);
-bignum_type bignum_digit_to_bignum(bignum_digit_type, int);
-bignum_type allot_bignum(bignum_length_type, int);
-bignum_type allot_bignum_zeroed(bignum_length_type, int);
-bignum_type bignum_shorten_length(bignum_type, bignum_length_type);
-bignum_type bignum_trim(bignum_type);
-bignum_type bignum_new_sign(bignum_type, int);
-bignum_type bignum_maybe_new_sign(bignum_type, int);
-void bignum_destructive_copy(bignum_type, bignum_type);
-
-/* Added for bitwise operations. */
-bignum_type bignum_magnitude_ash(bignum_type arg1, F_FIXNUM n);
-bignum_type bignum_pospos_bitwise_op(int op, bignum_type, bignum_type);
-bignum_type bignum_posneg_bitwise_op(int op, bignum_type, bignum_type);
-bignum_type bignum_negneg_bitwise_op(int op, bignum_type, bignum_type);
-void bignum_negate_magnitude(bignum_type);
-
-bignum_type bignum_integer_length(bignum_type arg1);
-int bignum_unsigned_logbitp(int shift, bignum_type bignum);
-int bignum_logbitp(int shift, bignum_type arg);
-bignum_type digit_stream_to_bignum(unsigned int n_digits,
- unsigned int (*producer)(unsigned int),
- unsigned int radix,
- int negative_p);
--- /dev/null
+namespace factor
+{
+
+/* :tabSize=2:indentSize=2:noTabs=true:
+
+Copyright (C) 1989-1992 Massachusetts Institute of Technology
+Portions copyright (C) 2004-2009 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. */
+
+#define BIGNUM_OUT_OF_BAND ((bignum *) 0)
+
+enum bignum_comparison
+{
+ bignum_comparison_equal = 0,
+ bignum_comparison_less = -1,
+ 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);
+bignum * digit_stream_to_bignum(unsigned int n_digits,
+ unsigned int (*producer)(unsigned int),
+ unsigned int radix,
+ int negative_p);
+
+}
+++ /dev/null
-/* -*-C-*-
-
-$Id: s48_bignumint.h,v 1.14 2005/12/21 02:36:52 spestov Exp $
-
-Copyright (c) 1989-1992 Massachusetts Institute of Technology
-
-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. */
-
-/* Internal Interface to Bignum Code */
-#undef BIGNUM_ZERO_P
-#undef BIGNUM_NEGATIVE_P
-
-/* The memory model is based on the following definitions, and on the
- definition of the type `bignum_type'. The only other special
- definition is `CHAR_BIT', which is defined in the Ansi C header
- file "limits.h". */
-
-typedef F_FIXNUM bignum_digit_type;
-typedef F_FIXNUM bignum_length_type;
-
-/* BIGNUM_TO_POINTER casts a bignum object to a digit array pointer. */
-#define BIGNUM_TO_POINTER(bignum) ((bignum_digit_type *)AREF(bignum,0))
-
-/* BIGNUM_EXCEPTION is invoked to handle assertion violations. */
-#define BIGNUM_EXCEPTION abort
-
-
-#define BIGNUM_DIGIT_LENGTH (((sizeof (bignum_digit_type)) * CHAR_BIT) - 2)
-#define BIGNUM_HALF_DIGIT_LENGTH (BIGNUM_DIGIT_LENGTH / 2)
-#define BIGNUM_RADIX (((CELL) 1) << BIGNUM_DIGIT_LENGTH)
-#define BIGNUM_RADIX_ROOT (((CELL) 1) << BIGNUM_HALF_DIGIT_LENGTH)
-#define BIGNUM_DIGIT_MASK (BIGNUM_RADIX - 1)
-#define BIGNUM_HALF_DIGIT_MASK (BIGNUM_RADIX_ROOT - 1)
-
-#define BIGNUM_START_PTR(bignum) \
- ((BIGNUM_TO_POINTER (bignum)) + 1)
-
-#define BIGNUM_LENGTH(bignum) (untag_fixnum_fast((bignum)->capacity) - 1)
-
-#define BIGNUM_NEGATIVE_P(bignum) (get(AREF(bignum,0)) != 0)
-#define BIGNUM_SET_NEGATIVE_P(bignum,neg) put(AREF(bignum,0),neg)
-
-#define BIGNUM_ZERO_P(bignum) \
- ((BIGNUM_LENGTH (bignum)) == 0)
-
-#define BIGNUM_REF(bignum, index) \
- (* ((BIGNUM_START_PTR (bignum)) + (index)))
-
-/* These definitions are here to facilitate caching of the constants
- 0, 1, and -1. */
-#define BIGNUM_ZERO() untag_object(bignum_zero)
-#define BIGNUM_ONE(neg_p) \
- untag_object(neg_p ? bignum_neg_one : bignum_pos_one)
-
-#define HD_LOW(digit) ((digit) & BIGNUM_HALF_DIGIT_MASK)
-#define HD_HIGH(digit) ((digit) >> BIGNUM_HALF_DIGIT_LENGTH)
-#define HD_CONS(high, low) (((high) << BIGNUM_HALF_DIGIT_LENGTH) | (low))
-
-#define BIGNUM_BITS_TO_DIGITS(n) \
- (((n) + (BIGNUM_DIGIT_LENGTH - 1)) / BIGNUM_DIGIT_LENGTH)
-
-#define BIGNUM_DIGITS_FOR(type) \
- (BIGNUM_BITS_TO_DIGITS ((sizeof (type)) * CHAR_BIT))
-
-#ifndef BIGNUM_DISABLE_ASSERTION_CHECKS
-
-#define BIGNUM_ASSERT(expression) \
-{ \
- if (! (expression)) \
- BIGNUM_EXCEPTION (); \
-}
-
-#endif /* not BIGNUM_DISABLE_ASSERTION_CHECKS */
--- /dev/null
+/* -*-C-*-
+
+$Id: s48_bignumint.h,v 1.14 2005/12/21 02:36:52 spestov Exp $
+
+Copyright (c) 1989-1992 Massachusetts Institute of Technology
+
+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. */
+
+namespace factor
+{
+
+/* Internal Interface to Bignum Code */
+#undef BIGNUM_ZERO_P
+#undef BIGNUM_NEGATIVE_P
+
+/* The memory model is based on the following definitions, and on the
+ definition of the type `bignum_type'. The only other special
+ definition is `CHAR_BIT', which is defined in the Ansi C header
+ file "limits.h". */
+
+typedef fixnum bignum_digit_type;
+typedef fixnum bignum_length_type;
+
+/* BIGNUM_TO_POINTER casts a bignum object to a digit array pointer. */
+#define BIGNUM_TO_POINTER(bignum) ((bignum_digit_type *)(bignum + 1))
+
+/* BIGNUM_EXCEPTION is invoked to handle assertion violations. */
+#define BIGNUM_EXCEPTION abort
+
+
+#define BIGNUM_DIGIT_LENGTH (((sizeof (bignum_digit_type)) * CHAR_BIT) - 2)
+#define BIGNUM_HALF_DIGIT_LENGTH (BIGNUM_DIGIT_LENGTH / 2)
+#define BIGNUM_RADIX (bignum_digit_type)(((cell) 1) << BIGNUM_DIGIT_LENGTH)
+#define BIGNUM_RADIX_ROOT (((bignum_digit_type) 1) << BIGNUM_HALF_DIGIT_LENGTH)
+#define BIGNUM_DIGIT_MASK (BIGNUM_RADIX - 1)
+#define BIGNUM_HALF_DIGIT_MASK (BIGNUM_RADIX_ROOT - 1)
+
+#define BIGNUM_START_PTR(bignum) \
+ ((BIGNUM_TO_POINTER (bignum)) + 1)
+
+#define BIGNUM_LENGTH(bignum) (untag_fixnum((bignum)->capacity) - 1)
+
+#define BIGNUM_NEGATIVE_P(bignum) (bignum->data()[0] != 0)
+#define BIGNUM_SET_NEGATIVE_P(bignum,neg) (bignum->data()[0] = neg)
+
+#define BIGNUM_ZERO_P(bignum) \
+ ((BIGNUM_LENGTH (bignum)) == 0)
+
+#define BIGNUM_REF(bignum, index) \
+ (* ((BIGNUM_START_PTR (bignum)) + (index)))
+
+/* These definitions are here to facilitate caching of the constants
+ 0, 1, and -1. */
+#define BIGNUM_ZERO() untag<bignum>(bignum_zero)
+#define BIGNUM_ONE(neg_p) \
+ untag<bignum>(neg_p ? bignum_neg_one : bignum_pos_one)
+
+#define HD_LOW(digit) ((digit) & BIGNUM_HALF_DIGIT_MASK)
+#define HD_HIGH(digit) ((digit) >> BIGNUM_HALF_DIGIT_LENGTH)
+#define HD_CONS(high, low) (((high) << BIGNUM_HALF_DIGIT_LENGTH) | (low))
+
+#define BIGNUM_BITS_TO_DIGITS(n) \
+ (((n) + (BIGNUM_DIGIT_LENGTH - 1)) / BIGNUM_DIGIT_LENGTH)
+
+#define BIGNUM_DIGITS_FOR(type) \
+ (BIGNUM_BITS_TO_DIGITS ((sizeof (type)) * CHAR_BIT))
+
+#ifndef BIGNUM_DISABLE_ASSERTION_CHECKS
+
+#define BIGNUM_ASSERT(expression) \
+{ \
+ if (! (expression)) \
+ BIGNUM_EXCEPTION (); \
+}
+
+#endif /* not BIGNUM_DISABLE_ASSERTION_CHECKS */
+
+}
+++ /dev/null
-#include "master.h"
-
-/* FFI calls this */
-void box_boolean(bool value)
-{
- dpush(value ? T : F);
-}
-
-/* FFI calls this */
-bool to_boolean(CELL value)
-{
- return value != F;
-}
--- /dev/null
+#include "master.hpp"
+
+namespace factor
+{
+
+VM_C_API void box_boolean(bool value)
+{
+ dpush(value ? T : F);
+}
+
+VM_C_API bool to_boolean(cell value)
+{
+ return value != F;
+}
+
+}
+++ /dev/null
-INLINE CELL tag_boolean(CELL untagged)
-{
- return (untagged == false ? F : T);
-}
-
-DLLEXPORT void box_boolean(bool value);
-DLLEXPORT bool to_boolean(CELL value);
--- /dev/null
+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);
+
+}
+++ /dev/null
-#include "master.h"
-
-/* must fill out array before next GC */
-F_BYTE_ARRAY *allot_byte_array_internal(CELL size)
-{
- F_BYTE_ARRAY *array = allot_object(BYTE_ARRAY_TYPE,
- byte_array_size(size));
- array->capacity = tag_fixnum(size);
- return array;
-}
-
-/* size is in bytes this time */
-F_BYTE_ARRAY *allot_byte_array(CELL size)
-{
- F_BYTE_ARRAY *array = allot_byte_array_internal(size);
- memset(array + 1,0,size);
- return array;
-}
-
-/* push a new byte array on the stack */
-void primitive_byte_array(void)
-{
- CELL size = unbox_array_size();
- dpush(tag_object(allot_byte_array(size)));
-}
-
-void primitive_uninitialized_byte_array(void)
-{
- CELL size = unbox_array_size();
- dpush(tag_object(allot_byte_array_internal(size)));
-}
-
-static bool reallot_byte_array_in_place_p(F_BYTE_ARRAY *array, CELL capacity)
-{
- return in_zone(&nursery,(CELL)array) && capacity <= array_capacity(array);
-}
-
-F_BYTE_ARRAY *reallot_byte_array(F_BYTE_ARRAY *array, CELL capacity)
-{
-#ifdef FACTOR_DEBUG
- assert(untag_header(array->header) == BYTE_ARRAY_TYPE);
-#endif
- if(reallot_byte_array_in_place_p(array,capacity))
- {
- array->capacity = tag_fixnum(capacity);
- return array;
- }
- else
- {
- CELL to_copy = array_capacity(array);
- if(capacity < to_copy)
- to_copy = capacity;
-
- REGISTER_UNTAGGED(array);
- F_BYTE_ARRAY *new_array = allot_byte_array_internal(capacity);
- UNREGISTER_UNTAGGED(array);
-
- memcpy(new_array + 1,array + 1,to_copy);
-
- return new_array;
- }
-}
-
-void primitive_resize_byte_array(void)
-{
- F_BYTE_ARRAY* array = untag_byte_array(dpop());
- CELL capacity = unbox_array_size();
- dpush(tag_object(reallot_byte_array(array,capacity)));
-}
-
-void growable_byte_array_append(F_GROWABLE_BYTE_ARRAY *array, void *elts, CELL len)
-{
- CELL new_size = array->count + len;
- F_BYTE_ARRAY *underlying = untag_object(array->array);
-
- if(new_size >= byte_array_capacity(underlying))
- {
- underlying = reallot_byte_array(underlying,new_size * 2);
- array->array = tag_object(underlying);
- }
-
- memcpy((void *)BREF(underlying,array->count),elts,len);
-
- array->count += len;
-}
--- /dev/null
+#include "master.hpp"
+
+namespace factor
+{
+
+byte_array *allot_byte_array(cell size)
+{
+ byte_array *array = allot_array_internal<byte_array>(size);
+ memset(array + 1,0,size);
+ return array;
+}
+
+PRIMITIVE(byte_array)
+{
+ cell size = unbox_array_size();
+ dpush(tag<byte_array>(allot_byte_array(size)));
+}
+
+PRIMITIVE(uninitialized_byte_array)
+{
+ cell size = unbox_array_size();
+ dpush(tag<byte_array>(allot_array_internal<byte_array>(size)));
+}
+
+PRIMITIVE(resize_byte_array)
+{
+ byte_array *array = untag_check<byte_array>(dpop());
+ cell capacity = unbox_array_size();
+ dpush(tag<byte_array>(reallot_array(array,capacity)));
+}
+
+void growable_byte_array::append_bytes(void *elts, cell len)
+{
+ cell new_size = count + len;
+
+ if(new_size >= array_capacity(elements.untagged()))
+ elements = reallot_array(elements.untagged(),new_size * 2);
+
+ memcpy(&elements->data<u8>()[count],elts,len);
+
+ count += len;
+}
+
+void growable_byte_array::append_byte_array(cell byte_array_)
+{
+ gc_root<byte_array> byte_array(byte_array_);
+
+ cell len = array_capacity(byte_array.untagged());
+ cell new_size = count + len;
+
+ if(new_size >= array_capacity(elements.untagged()))
+ elements = reallot_array(elements.untagged(),new_size * 2);
+
+ memcpy(&elements->data<u8>()[count],byte_array->data<u8>(),len);
+
+ count += len;
+}
+
+void growable_byte_array::trim()
+{
+ elements = reallot_array(elements.untagged(),count);
+}
+
+}
+++ /dev/null
-DEFINE_UNTAG(F_BYTE_ARRAY,BYTE_ARRAY_TYPE,byte_array)
-
-INLINE CELL byte_array_capacity(F_BYTE_ARRAY *array)
-{
- return untag_fixnum_fast(array->capacity);
-}
-
-INLINE CELL byte_array_size(CELL size)
-{
- return sizeof(F_BYTE_ARRAY) + size;
-}
-
-F_BYTE_ARRAY *allot_byte_array(CELL size);
-F_BYTE_ARRAY *allot_byte_array_internal(CELL size);
-F_BYTE_ARRAY *reallot_byte_array(F_BYTE_ARRAY *array, CELL capacity);
-
-void primitive_byte_array(void);
-void primitive_uninitialized_byte_array(void);
-void primitive_resize_byte_array(void);
-
-/* Macros to simulate a byte vector in C */
-typedef struct {
- CELL count;
- CELL array;
-} F_GROWABLE_BYTE_ARRAY;
-
-INLINE F_GROWABLE_BYTE_ARRAY make_growable_byte_array(void)
-{
- F_GROWABLE_BYTE_ARRAY result;
- result.count = 0;
- result.array = tag_object(allot_byte_array(100));
- return result;
-}
-
-void growable_byte_array_append(F_GROWABLE_BYTE_ARRAY *result, void *elts, CELL len);
-
-INLINE void growable_byte_array_trim(F_GROWABLE_BYTE_ARRAY *byte_array)
-{
- byte_array->array = tag_object(reallot_byte_array(untag_object(byte_array->array),byte_array->count));
-}
--- /dev/null
+namespace factor
+{
+
+byte_array *allot_byte_array(cell size);
+
+PRIMITIVE(byte_array);
+PRIMITIVE(uninitialized_byte_array);
+PRIMITIVE(resize_byte_array);
+
+/* Macros to simulate a byte vector in C */
+struct growable_byte_array {
+ cell count;
+ gc_root<byte_array> elements;
+
+ growable_byte_array() : count(0), elements(allot_byte_array(2)) { }
+
+ void append_bytes(void *elts, cell len);
+ void append_byte_array(cell elts);
+
+ void trim();
+};
+
+}
+++ /dev/null
-#include "master.h"
-
-/* called before entry into Factor code. */
-F_FASTCALL void save_callstack_bottom(F_STACK_FRAME *callstack_bottom)
-{
- stack_chain->callstack_bottom = callstack_bottom;
-}
-
-void iterate_callstack(CELL top, CELL bottom, CALLSTACK_ITER iterator)
-{
- F_STACK_FRAME *frame = (F_STACK_FRAME *)bottom - 1;
-
- while((CELL)frame >= top)
- {
- F_STACK_FRAME *next = frame_successor(frame);
- iterator(frame);
- frame = next;
- }
-}
-
-void iterate_callstack_object(F_CALLSTACK *stack, CALLSTACK_ITER iterator)
-{
- CELL top = (CELL)FIRST_STACK_FRAME(stack);
- CELL bottom = top + untag_fixnum_fast(stack->length);
-
- iterate_callstack(top,bottom,iterator);
-}
-
-F_CALLSTACK *allot_callstack(CELL size)
-{
- F_CALLSTACK *callstack = allot_object(
- CALLSTACK_TYPE,
- callstack_size(size));
- callstack->length = tag_fixnum(size);
- return callstack;
-}
-
-F_STACK_FRAME *fix_callstack_top(F_STACK_FRAME *top, F_STACK_FRAME *bottom)
-{
- F_STACK_FRAME *frame = bottom - 1;
-
- while(frame >= top)
- frame = frame_successor(frame);
-
- return frame + 1;
-}
-
-/* We ignore the topmost frame, the one calling 'callstack',
-so that set-callstack doesn't get stuck in an infinite loop.
-
-This means that if 'callstack' is called in tail position, we
-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. */
-F_STACK_FRAME *capture_start(void)
-{
- F_STACK_FRAME *frame = stack_chain->callstack_bottom - 1;
- while(frame >= stack_chain->callstack_top
- && frame_successor(frame) >= stack_chain->callstack_top)
- {
- frame = frame_successor(frame);
- }
- return frame + 1;
-}
-
-void primitive_callstack(void)
-{
- F_STACK_FRAME *top = capture_start();
- F_STACK_FRAME *bottom = stack_chain->callstack_bottom;
-
- F_FIXNUM size = (CELL)bottom - (CELL)top;
- if(size < 0)
- size = 0;
-
- F_CALLSTACK *callstack = allot_callstack(size);
- memcpy(FIRST_STACK_FRAME(callstack),top,size);
- dpush(tag_object(callstack));
-}
-
-void primitive_set_callstack(void)
-{
- F_CALLSTACK *stack = untag_callstack(dpop());
-
- set_callstack(stack_chain->callstack_bottom,
- FIRST_STACK_FRAME(stack),
- untag_fixnum_fast(stack->length),
- memcpy);
-
- /* We cannot return here ... */
- critical_error("Bug in set_callstack()",0);
-}
-
-F_CODE_BLOCK *frame_code(F_STACK_FRAME *frame)
-{
- return (F_CODE_BLOCK *)frame->xt - 1;
-}
-
-CELL frame_type(F_STACK_FRAME *frame)
-{
- return frame_code(frame)->block.type;
-}
-
-CELL frame_executing(F_STACK_FRAME *frame)
-{
- F_CODE_BLOCK *compiled = frame_code(frame);
- if(compiled->literals == F || !stack_traces_p())
- return F;
- else
- {
- F_ARRAY *array = untag_object(compiled->literals);
- return array_nth(array,0);
- }
-}
-
-F_STACK_FRAME *frame_successor(F_STACK_FRAME *frame)
-{
- if(frame->size == 0)
- critical_error("Stack frame has zero size",(CELL)frame);
- return (F_STACK_FRAME *)((CELL)frame - frame->size);
-}
-
-CELL frame_scan(F_STACK_FRAME *frame)
-{
- if(frame_type(frame) == QUOTATION_TYPE)
- {
- CELL quot = frame_executing(frame);
- if(quot == F)
- return F;
- else
- {
- XT return_addr = FRAME_RETURN_ADDRESS(frame);
- XT quot_xt = (XT)(frame_code(frame) + 1);
-
- return tag_fixnum(quot_code_offset_to_scan(
- quot,(CELL)(return_addr - quot_xt)));
- }
- }
- else
- return F;
-}
-
-/* C doesn't have closures... */
-static CELL frame_count;
-
-void count_stack_frame(F_STACK_FRAME *frame)
-{
- frame_count += 2;
-}
-
-static CELL frame_index;
-static F_ARRAY *array;
-
-void stack_frame_to_array(F_STACK_FRAME *frame)
-{
- set_array_nth(array,frame_index++,frame_executing(frame));
- set_array_nth(array,frame_index++,frame_scan(frame));
-}
-
-void primitive_callstack_to_array(void)
-{
- F_CALLSTACK *stack = untag_callstack(dpop());
-
- frame_count = 0;
- iterate_callstack_object(stack,count_stack_frame);
-
- REGISTER_UNTAGGED(stack);
- array = allot_array_internal(ARRAY_TYPE,frame_count);
- UNREGISTER_UNTAGGED(stack);
-
- frame_index = 0;
- iterate_callstack_object(stack,stack_frame_to_array);
-
- dpush(tag_array(array));
-}
-
-F_STACK_FRAME *innermost_stack_frame(F_CALLSTACK *callstack)
-{
- F_STACK_FRAME *top = FIRST_STACK_FRAME(callstack);
- CELL bottom = (CELL)top + untag_fixnum_fast(callstack->length);
-
- F_STACK_FRAME *frame = (F_STACK_FRAME *)bottom - 1;
-
- while(frame >= top && frame_successor(frame) >= top)
- frame = frame_successor(frame);
-
- return frame;
-}
-
-/* Some primitives implementing a limited form of callstack mutation.
-Used by the single stepper. */
-void primitive_innermost_stack_frame_quot(void)
-{
- F_STACK_FRAME *inner = innermost_stack_frame(
- untag_callstack(dpop()));
- type_check(QUOTATION_TYPE,frame_executing(inner));
-
- dpush(frame_executing(inner));
-}
-
-void primitive_innermost_stack_frame_scan(void)
-{
- F_STACK_FRAME *inner = innermost_stack_frame(
- untag_callstack(dpop()));
- type_check(QUOTATION_TYPE,frame_executing(inner));
-
- dpush(frame_scan(inner));
-}
-
-void primitive_set_innermost_stack_frame_quot(void)
-{
- F_CALLSTACK *callstack = untag_callstack(dpop());
- F_QUOTATION *quot = untag_quotation(dpop());
-
- REGISTER_UNTAGGED(callstack);
- REGISTER_UNTAGGED(quot);
-
- jit_compile(tag_quotation(quot),true);
-
- UNREGISTER_UNTAGGED(quot);
- UNREGISTER_UNTAGGED(callstack);
-
- F_STACK_FRAME *inner = innermost_stack_frame(callstack);
- type_check(QUOTATION_TYPE,frame_executing(inner));
-
- CELL offset = FRAME_RETURN_ADDRESS(inner) - inner->xt;
-
- inner->xt = quot->xt;
-
- FRAME_RETURN_ADDRESS(inner) = quot->xt + offset;
-}
--- /dev/null
+#include "master.hpp"
+
+namespace factor
+{
+
+static void check_frame(stack_frame *frame)
+{
+#ifdef FACTOR_DEBUG
+ check_code_pointer((cell)frame->xt);
+ assert(frame->size != 0);
+#endif
+}
+
+void iterate_callstack(cell top, cell bottom, CALLSTACK_ITER iterator)
+{
+ stack_frame *frame = (stack_frame *)bottom - 1;
+
+ while((cell)frame >= top)
+ {
+ iterator(frame);
+ frame = frame_successor(frame);
+ }
+}
+
+void iterate_callstack_object(callstack *stack, CALLSTACK_ITER iterator)
+{
+ cell top = (cell)FIRST_STACK_FRAME(stack);
+ cell bottom = top + untag_fixnum(stack->length);
+
+ iterate_callstack(top,bottom,iterator);
+}
+
+callstack *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 *frame = bottom - 1;
+
+ while(frame >= top)
+ frame = frame_successor(frame);
+
+ return frame + 1;
+}
+
+/* We ignore the topmost frame, the one calling 'callstack',
+so that set-callstack doesn't get stuck in an infinite loop.
+
+This means that if 'callstack' is called in tail position, we
+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(void)
+{
+ stack_frame *frame = stack_chain->callstack_bottom - 1;
+ while(frame >= stack_chain->callstack_top
+ && frame_successor(frame) >= stack_chain->callstack_top)
+ {
+ frame = frame_successor(frame);
+ }
+ return frame + 1;
+}
+
+PRIMITIVE(callstack)
+{
+ stack_frame *top = capture_start();
+ stack_frame *bottom = stack_chain->callstack_bottom;
+
+ fixnum size = (cell)bottom - (cell)top;
+ if(size < 0)
+ size = 0;
+
+ callstack *stack = allot_callstack(size);
+ memcpy(FIRST_STACK_FRAME(stack),top,size);
+ dpush(tag<callstack>(stack));
+}
+
+PRIMITIVE(set_callstack)
+{
+ callstack *stack = untag_check<callstack>(dpop());
+
+ set_callstack(stack_chain->callstack_bottom,
+ FIRST_STACK_FRAME(stack),
+ untag_fixnum(stack->length),
+ memcpy);
+
+ /* We cannot return here ... */
+ critical_error("Bug in set_callstack()",0);
+}
+
+code_block *frame_code(stack_frame *frame)
+{
+ check_frame(frame);
+ return (code_block *)frame->xt - 1;
+}
+
+cell frame_type(stack_frame *frame)
+{
+ return frame_code(frame)->block.type;
+}
+
+cell frame_executing(stack_frame *frame)
+{
+ code_block *compiled = frame_code(frame);
+ if(compiled->literals == F || !stack_traces_p())
+ return F;
+ else
+ {
+ array *literals = untag<array>(compiled->literals);
+ return array_nth(literals,0);
+ }
+}
+
+stack_frame *frame_successor(stack_frame *frame)
+{
+ check_frame(frame);
+ return (stack_frame *)((cell)frame - frame->size);
+}
+
+cell frame_scan(stack_frame *frame)
+{
+ if(frame_type(frame) == QUOTATION_TYPE)
+ {
+ cell quot = frame_executing(frame);
+ if(quot == F)
+ return F;
+ else
+ {
+ char *return_addr = (char *)FRAME_RETURN_ADDRESS(frame);
+ char *quot_xt = (char *)(frame_code(frame) + 1);
+
+ return tag_fixnum(quot_code_offset_to_scan(
+ quot,(cell)(return_addr - quot_xt)));
+ }
+ }
+ else
+ return F;
+}
+
+/* C doesn't have closures... */
+static cell frame_count;
+
+void count_stack_frame(stack_frame *frame)
+{
+ frame_count += 2;
+}
+
+static cell frame_index;
+static array *frames;
+
+void stack_frame_to_array(stack_frame *frame)
+{
+ set_array_nth(frames,frame_index++,frame_executing(frame));
+ set_array_nth(frames,frame_index++,frame_scan(frame));
+}
+
+PRIMITIVE(callstack_to_array)
+{
+ gc_root<callstack> callstack(dpop());
+
+ frame_count = 0;
+ iterate_callstack_object(callstack.untagged(),count_stack_frame);
+
+ frames = allot_array_internal<array>(frame_count);
+
+ frame_index = 0;
+ iterate_callstack_object(callstack.untagged(),stack_frame_to_array);
+
+ dpush(tag<array>(frames));
+}
+
+stack_frame *innermost_stack_frame(callstack *callstack)
+{
+ stack_frame *top = FIRST_STACK_FRAME(callstack);
+ cell bottom = (cell)top + untag_fixnum(callstack->length);
+
+ stack_frame *frame = (stack_frame *)bottom - 1;
+
+ while(frame >= top && frame_successor(frame) >= top)
+ frame = frame_successor(frame);
+
+ return frame;
+}
+
+stack_frame *innermost_stack_frame_quot(callstack *callstack)
+{
+ stack_frame *inner = innermost_stack_frame(callstack);
+ tagged<quotation>(frame_executing(inner)).untag_check();
+ return inner;
+}
+
+/* Some primitives implementing a limited form of callstack mutation.
+Used by the single stepper. */
+PRIMITIVE(innermost_stack_frame_quot)
+{
+ dpush(frame_executing(innermost_stack_frame_quot(untag_check<callstack>(dpop()))));
+}
+
+PRIMITIVE(innermost_stack_frame_scan)
+{
+ dpush(frame_scan(innermost_stack_frame_quot(untag_check<callstack>(dpop()))));
+}
+
+PRIMITIVE(set_innermost_stack_frame_quot)
+{
+ gc_root<callstack> callstack(dpop());
+ gc_root<quotation> quot(dpop());
+
+ callstack.untag_check();
+ quot.untag_check();
+
+ jit_compile(quot.value(),true);
+
+ stack_frame *inner = innermost_stack_frame_quot(callstack.untagged());
+ cell offset = (char *)FRAME_RETURN_ADDRESS(inner) - (char *)inner->xt;
+ inner->xt = quot->xt;
+ FRAME_RETURN_ADDRESS(inner) = (char *)quot->xt + offset;
+}
+
+/* called before entry into Factor code. */
+VM_ASM_API void save_callstack_bottom(stack_frame *callstack_bottom)
+{
+ stack_chain->callstack_bottom = callstack_bottom;
+}
+
+}
+++ /dev/null
-INLINE CELL callstack_size(CELL size)
-{
- return sizeof(F_CALLSTACK) + size;
-}
-
-DEFINE_UNTAG(F_CALLSTACK,CALLSTACK_TYPE,callstack)
-
-F_FASTCALL void save_callstack_bottom(F_STACK_FRAME *callstack_bottom);
-
-#define FIRST_STACK_FRAME(stack) (F_STACK_FRAME *)((stack) + 1)
-
-typedef void (*CALLSTACK_ITER)(F_STACK_FRAME *frame);
-
-F_STACK_FRAME *fix_callstack_top(F_STACK_FRAME *top, F_STACK_FRAME *bottom);
-void iterate_callstack(CELL top, CELL bottom, CALLSTACK_ITER iterator);
-void iterate_callstack_object(F_CALLSTACK *stack, CALLSTACK_ITER iterator);
-F_STACK_FRAME *frame_successor(F_STACK_FRAME *frame);
-F_CODE_BLOCK *frame_code(F_STACK_FRAME *frame);
-CELL frame_executing(F_STACK_FRAME *frame);
-CELL frame_scan(F_STACK_FRAME *frame);
-CELL frame_type(F_STACK_FRAME *frame);
-
-void primitive_callstack(void);
-void primitive_set_callstack(void);
-void primitive_callstack_to_array(void);
-void primitive_innermost_stack_frame_quot(void);
-void primitive_innermost_stack_frame_scan(void);
-void primitive_set_innermost_stack_frame_quot(void);
--- /dev/null
+namespace factor
+{
+
+inline static cell callstack_size(cell size)
+{
+ return sizeof(callstack) + size;
+}
+
+#define FIRST_STACK_FRAME(stack) (stack_frame *)((stack) + 1)
+
+typedef void (*CALLSTACK_ITER)(stack_frame *frame);
+
+stack_frame *fix_callstack_top(stack_frame *top, stack_frame *bottom);
+void iterate_callstack(cell top, cell bottom, CALLSTACK_ITER iterator);
+void iterate_callstack_object(callstack *stack, CALLSTACK_ITER iterator);
+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_quot);
+PRIMITIVE(innermost_stack_frame_scan);
+PRIMITIVE(set_innermost_stack_frame_quot);
+
+VM_ASM_API void save_callstack_bottom(stack_frame *callstack_bottom);
+
+}
+++ /dev/null
-#include "master.h"
-
-void flush_icache_for(F_CODE_BLOCK *block)
-{
- flush_icache((CELL)block,block->block.size);
-}
-
-void iterate_relocations(F_CODE_BLOCK *compiled, RELOCATION_ITERATOR iter)
-{
- if(compiled->relocation != F)
- {
- F_BYTE_ARRAY *relocation = untag_object(compiled->relocation);
-
- CELL index = stack_traces_p() ? 1 : 0;
-
- F_REL *rel = (F_REL *)(relocation + 1);
- F_REL *rel_end = (F_REL *)((char *)rel + byte_array_capacity(relocation));
-
- while(rel < rel_end)
- {
- iter(*rel,index,compiled);
-
- switch(REL_TYPE(*rel))
- {
- case RT_PRIMITIVE:
- case RT_XT:
- case RT_XT_DIRECT:
- case RT_IMMEDIATE:
- case RT_HERE:
- case RT_UNTAGGED:
- index++;
- break;
- case RT_DLSYM:
- index += 2;
- break;
- case RT_THIS:
- case RT_STACK_CHAIN:
- break;
- default:
- critical_error("Bad rel type",*rel);
- return; /* Can't happen */
- }
-
- rel++;
- }
- }
-}
-
-/* Store a 32-bit value into a PowerPC LIS/ORI sequence */
-INLINE void store_address_2_2(CELL cell, CELL value)
-{
- put(cell - CELLS,((get(cell - CELLS) & ~0xffff) | ((value >> 16) & 0xffff)));
- put(cell,((get(cell) & ~0xffff) | (value & 0xffff)));
-}
-
-/* Store a value into a bitfield of a PowerPC instruction */
-INLINE void store_address_masked(CELL cell, F_FIXNUM value, CELL mask, F_FIXNUM shift)
-{
- /* This is unaccurate but good enough */
- F_FIXNUM test = (F_FIXNUM)mask >> 1;
- if(value <= -test || value >= test)
- critical_error("Value does not fit inside relocation",0);
-
- u32 original = *(u32*)cell;
- original &= ~mask;
- *(u32*)cell = (original | ((value >> shift) & mask));
-}
-
-/* Perform a fixup on a code block */
-void store_address_in_code_block(CELL class, CELL offset, F_FIXNUM absolute_value)
-{
- F_FIXNUM relative_value = absolute_value - offset;
-
- switch(class)
- {
- case RC_ABSOLUTE_CELL:
- put(offset,absolute_value);
- break;
- case RC_ABSOLUTE:
- *(u32*)offset = absolute_value;
- break;
- case RC_RELATIVE:
- *(u32*)offset = relative_value - sizeof(u32);
- break;
- case RC_ABSOLUTE_PPC_2_2:
- store_address_2_2(offset,absolute_value);
- break;
- case RC_RELATIVE_PPC_2:
- store_address_masked(offset,relative_value,REL_RELATIVE_PPC_2_MASK,0);
- break;
- case RC_RELATIVE_PPC_3:
- store_address_masked(offset,relative_value,REL_RELATIVE_PPC_3_MASK,0);
- break;
- case RC_RELATIVE_ARM_3:
- store_address_masked(offset,relative_value - CELLS * 2,
- REL_RELATIVE_ARM_3_MASK,2);
- break;
- case RC_INDIRECT_ARM:
- store_address_masked(offset,relative_value - CELLS,
- REL_INDIRECT_ARM_MASK,0);
- break;
- case RC_INDIRECT_ARM_PC:
- store_address_masked(offset,relative_value - CELLS * 2,
- REL_INDIRECT_ARM_MASK,0);
- break;
- default:
- critical_error("Bad rel class",class);
- break;
- }
-}
-
-void update_literal_references_step(F_REL rel, CELL index, F_CODE_BLOCK *compiled)
-{
- if(REL_TYPE(rel) == RT_IMMEDIATE)
- {
- CELL offset = REL_OFFSET(rel) + (CELL)(compiled + 1);
- F_ARRAY *literals = untag_object(compiled->literals);
- F_FIXNUM absolute_value = array_nth(literals,index);
- store_address_in_code_block(REL_CLASS(rel),offset,absolute_value);
- }
-}
-
-/* Update pointers to literals from compiled code. */
-void update_literal_references(F_CODE_BLOCK *compiled)
-{
- iterate_relocations(compiled,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(F_CODE_BLOCK *compiled)
-{
- if(collecting_gen >= compiled->block.last_scan)
- {
- if(collecting_accumulation_gen_p())
- compiled->block.last_scan = collecting_gen;
- else
- compiled->block.last_scan = collecting_gen + 1;
-
- /* initialize chase pointer */
- CELL scan = newspace->here;
-
- copy_handle(&compiled->literals);
- copy_handle(&compiled->relocation);
-
- /* do some tracing so that all reachable literals are now
- at their final address */
- copy_reachable_objects(scan,&newspace->here);
-
- update_literal_references(compiled);
- }
-}
-
-CELL object_xt(CELL obj)
-{
- if(TAG(obj) == QUOTATION_TYPE)
- {
- F_QUOTATION *quot = untag_object(obj);
- return (CELL)quot->xt;
- }
- else
- {
- F_WORD *word = untag_object(obj);
- return (CELL)word->xt;
- }
-}
-
-CELL word_direct_xt(CELL obj)
-{
-#ifdef FACTOR_DEBUG
- type_check(WORD_TYPE,obj);
-#endif
- F_WORD *word = untag_object(obj);
- CELL quot = word->direct_entry_def;
- if(quot == F || max_pic_size == 0)
- return (CELL)word->xt;
- else
- {
- F_QUOTATION *untagged = untag_object(quot);
-#ifdef FACTOR_DEBUG
- type_check(QUOTATION_TYPE,quot);
-#endif
- if(untagged->compiledp == F)
- return (CELL)word->xt;
- else
- return (CELL)untagged->xt;
- }
-}
-
-void update_word_references_step(F_REL rel, CELL index, F_CODE_BLOCK *compiled)
-{
- F_RELTYPE type = REL_TYPE(rel);
- if(type == RT_XT || type == RT_XT_DIRECT)
- {
- CELL offset = REL_OFFSET(rel) + (CELL)(compiled + 1);
- F_ARRAY *literals = untag_object(compiled->literals);
- CELL obj = array_nth(literals,index);
-
- CELL xt;
- if(type == RT_XT)
- xt = object_xt(obj);
- else
- xt = word_direct_xt(obj);
-
- store_address_in_code_block(REL_CLASS(rel),offset,xt);
- }
-}
-
-/* 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(F_CODE_BLOCK *compiled)
-{
- if(compiled->block.needs_fixup)
- relocate_code_block(compiled);
- /* update_word_references() is always applied to every block in
- the code heap. Since it resets all call sites to point to
- their canonical XT (cold entry point for non-tail calls,
- standard entry point for tail calls), it means that no PICs
- are referenced after this is done. So instead of polluting
- the code heap with dead PICs that will be freed on the next
- GC, we add them to the free list immediately. */
- else if(compiled->block.type == PIC_TYPE)
- {
- fflush(stdout);
- heap_free(&code_heap,&compiled->block);
- }
- else
- {
- iterate_relocations(compiled,update_word_references_step);
- flush_icache_for(compiled);
- }
-}
-
-void update_literal_and_word_references(F_CODE_BLOCK *compiled)
-{
- update_literal_references(compiled);
- update_word_references(compiled);
-}
-
-INLINE void check_code_address(CELL address)
-{
-#ifdef FACTOR_DEBUG
- assert(address >= code_heap.segment->start && address < code_heap.segment->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(F_CODE_BLOCK *compiled)
-{
- check_code_address((CELL)compiled);
-
- mark_block(&compiled->block);
-
- copy_handle(&compiled->literals);
- copy_handle(&compiled->relocation);
-}
-
-void mark_stack_frame_step(F_STACK_FRAME *frame)
-{
- mark_code_block(frame_code(frame));
-}
-
-/* Mark code blocks executing in currently active stack frames. */
-void mark_active_blocks(F_CONTEXT *stacks)
-{
- if(collecting_gen == TENURED)
- {
- CELL top = (CELL)stacks->callstack_top;
- CELL bottom = (CELL)stacks->callstack_bottom;
-
- iterate_callstack(top,bottom,mark_stack_frame_step);
- }
-}
-
-void mark_object_code_block(CELL scan)
-{
- F_WORD *word;
- F_QUOTATION *quot;
- F_CALLSTACK *stack;
-
- switch(hi_tag(scan))
- {
- case WORD_TYPE:
- word = (F_WORD *)scan;
- if(word->code)
- mark_code_block(word->code);
- if(word->profiling)
- mark_code_block(word->profiling);
- break;
- case QUOTATION_TYPE:
- quot = (F_QUOTATION *)scan;
- if(quot->compiledp != F)
- mark_code_block(quot->code);
- break;
- case CALLSTACK_TYPE:
- stack = (F_CALLSTACK *)scan;
- iterate_callstack_object(stack,mark_stack_frame_step);
- break;
- }
-}
-
-/* References to undefined symbols are patched up to call this function on
-image load */
-void undefined_symbol(void)
-{
- general_error(ERROR_UNDEFINED_SYMBOL,F,F,NULL);
-}
-
-/* Look up an external library symbol referenced by a compiled code block */
-void *get_rel_symbol(F_ARRAY *literals, CELL index)
-{
- CELL symbol = array_nth(literals,index);
- CELL library = array_nth(literals,index + 1);
-
- F_DLL *dll = (library == F ? NULL : untag_dll(library));
-
- if(dll != NULL && !dll->dll)
- return undefined_symbol;
-
- if(type_of(symbol) == BYTE_ARRAY_TYPE)
- {
- F_SYMBOL *name = alien_offset(symbol);
- void *sym = ffi_dlsym(dll,name);
-
- if(sym)
- return sym;
- }
- else if(type_of(symbol) == ARRAY_TYPE)
- {
- CELL i;
- F_ARRAY *names = untag_object(symbol);
- for(i = 0; i < array_capacity(names); i++)
- {
- F_SYMBOL *name = alien_offset(array_nth(names,i));
- void *sym = ffi_dlsym(dll,name);
-
- if(sym)
- return sym;
- }
- }
-
- return undefined_symbol;
-}
-
-/* Compute an address to store at a relocation */
-void relocate_code_block_step(F_REL rel, CELL index, F_CODE_BLOCK *compiled)
-{
-#ifdef FACTOR_DEBUG
- type_check(ARRAY_TYPE,compiled->literals);
- type_check(BYTE_ARRAY_TYPE,compiled->relocation);
-#endif
-
- CELL offset = REL_OFFSET(rel) + (CELL)(compiled + 1);
- F_ARRAY *literals = untag_object(compiled->literals);
- F_FIXNUM absolute_value;
-
- switch(REL_TYPE(rel))
- {
- case RT_PRIMITIVE:
- absolute_value = (CELL)primitives[to_fixnum(array_nth(literals,index))];
- break;
- case RT_DLSYM:
- absolute_value = (CELL)get_rel_symbol(literals,index);
- break;
- case RT_IMMEDIATE:
- absolute_value = array_nth(literals,index);
- break;
- case RT_XT:
- absolute_value = object_xt(array_nth(literals,index));
- break;
- case RT_XT_DIRECT:
- absolute_value = word_direct_xt(array_nth(literals,index));
- break;
- case RT_HERE:
- absolute_value = offset + (short)to_fixnum(array_nth(literals,index));
- break;
- case RT_THIS:
- absolute_value = (CELL)(compiled + 1);
- break;
- case RT_STACK_CHAIN:
- absolute_value = (CELL)&stack_chain;
- break;
- case RT_UNTAGGED:
- absolute_value = to_fixnum(array_nth(literals,index));
- break;
- default:
- critical_error("Bad rel type",rel);
- return; /* Can't happen */
- }
-
- store_address_in_code_block(REL_CLASS(rel),offset,absolute_value);
-}
-
-/* Perform all fixups on a code block */
-void relocate_code_block(F_CODE_BLOCK *compiled)
-{
- compiled->block.last_scan = NURSERY;
- compiled->block.needs_fixup = false;
- iterate_relocations(compiled,relocate_code_block_step);
- flush_icache_for(compiled);
-}
-
-/* Fixup labels. This is done at compile time, not image load time */
-void fixup_labels(F_ARRAY *labels, F_CODE_BLOCK *compiled)
-{
- CELL i;
- CELL size = array_capacity(labels);
-
- for(i = 0; i < size; i += 3)
- {
- CELL class = to_fixnum(array_nth(labels,i));
- CELL offset = to_fixnum(array_nth(labels,i + 1));
- CELL target = to_fixnum(array_nth(labels,i + 2));
-
- store_address_in_code_block(class,
- offset + (CELL)(compiled + 1),
- target + (CELL)(compiled + 1));
- }
-}
-
-/* Might GC */
-F_CODE_BLOCK *allot_code_block(CELL size)
-{
- F_BLOCK *block = heap_allot(&code_heap,size + sizeof(F_CODE_BLOCK));
-
- /* If allocation failed, do a code GC */
- if(block == NULL)
- {
- gc();
- block = heap_allot(&code_heap,size + sizeof(F_CODE_BLOCK));
-
- /* Insufficient room even after code GC, give up */
- if(block == NULL)
- {
- CELL used, total_free, max_free;
- heap_usage(&code_heap,&used,&total_free,&max_free);
-
- print_string("Code heap stats:\n");
- print_string("Used: "); print_cell(used); nl();
- print_string("Total free space: "); print_cell(total_free); nl();
- print_string("Largest free block: "); print_cell(max_free); nl();
- fatal_error("Out of memory in add-compiled-block",0);
- }
- }
-
- return (F_CODE_BLOCK *)block;
-}
-
-/* Might GC */
-F_CODE_BLOCK *add_code_block(
- CELL type,
- F_BYTE_ARRAY *code,
- F_ARRAY *labels,
- CELL relocation,
- CELL literals)
-{
-#ifdef FACTOR_DEBUG
- type_check(ARRAY_TYPE,literals);
- type_check(BYTE_ARRAY_TYPE,relocation);
- assert(untag_header(code->header) == BYTE_ARRAY_TYPE);
-#endif
-
- CELL code_length = align8(array_capacity(code));
-
- REGISTER_ROOT(literals);
- REGISTER_ROOT(relocation);
- REGISTER_UNTAGGED(code);
- REGISTER_UNTAGGED(labels);
-
- F_CODE_BLOCK *compiled = allot_code_block(code_length);
-
- UNREGISTER_UNTAGGED(labels);
- UNREGISTER_UNTAGGED(code);
- UNREGISTER_ROOT(relocation);
- UNREGISTER_ROOT(literals);
-
- /* slight space optimization */
- if(type_of(literals) == ARRAY_TYPE && array_capacity(untag_object(literals)) == 0)
- literals = F;
-
- /* compiled header */
- compiled->block.type = type;
- compiled->block.last_scan = NURSERY;
- compiled->block.needs_fixup = true;
- compiled->literals = literals;
- compiled->relocation = relocation;
-
- /* code */
- memcpy(compiled + 1,code + 1,code_length);
-
- /* fixup labels */
- if(labels) fixup_labels(labels,compiled);
-
- /* next time we do a minor GC, we have to scan the code heap for
- literals */
- last_code_heap_scan = NURSERY;
-
- return compiled;
-}
--- /dev/null
+#include "master.hpp"
+
+namespace factor
+{
+
+void flush_icache_for(code_block *block)
+{
+ flush_icache((cell)block,block->block.size);
+}
+
+void iterate_relocations(code_block *compiled, relocation_iterator iter)
+{
+ if(compiled->relocation != F)
+ {
+ byte_array *relocation = untag<byte_array>(compiled->relocation);
+
+ cell index = stack_traces_p() ? 1 : 0;
+
+ cell length = array_capacity(relocation) / sizeof(relocation_entry);
+ for(cell i = 0; i < length; i++)
+ {
+ relocation_entry rel = relocation->data<relocation_entry>()[i];
+
+ iter(rel,index,compiled);
+
+ switch(REL_TYPE(rel))
+ {
+ case RT_PRIMITIVE:
+ case RT_XT:
+ case RT_XT_DIRECT:
+ case RT_IMMEDIATE:
+ case RT_HERE:
+ case RT_UNTAGGED:
+ index++;
+ break;
+ case RT_DLSYM:
+ index += 2;
+ break;
+ case RT_THIS:
+ case RT_STACK_CHAIN:
+ break;
+ default:
+ critical_error("Bad rel type",rel);
+ return; /* Can't happen */
+ }
+ }
+ }
+}
+
+/* Store a 32-bit value into a PowerPC LIS/ORI sequence */
+static void store_address_2_2(cell *cell, cell value)
+{
+ cell[-1] = ((cell[-1] & ~0xffff) | ((value >> 16) & 0xffff));
+ cell[ 0] = ((cell[ 0] & ~0xffff) | (value & 0xffff));
+}
+
+/* Store a value into a bitfield of a PowerPC instruction */
+static void store_address_masked(cell *cell, fixnum value, cell mask, fixnum shift)
+{
+ /* This is unaccurate but good enough */
+ fixnum test = (fixnum)mask >> 1;
+ if(value <= -test || value >= test)
+ critical_error("Value does not fit inside relocation",0);
+
+ *cell = ((*cell & ~mask) | ((value >> shift) & mask));
+}
+
+/* Perform a fixup on a code block */
+void store_address_in_code_block(cell klass, cell offset, fixnum absolute_value)
+{
+ fixnum relative_value = absolute_value - offset;
+
+ switch(klass)
+ {
+ case RC_ABSOLUTE_CELL:
+ *(cell *)offset = absolute_value;
+ break;
+ case RC_ABSOLUTE:
+ *(u32*)offset = absolute_value;
+ break;
+ case RC_RELATIVE:
+ *(u32*)offset = relative_value - sizeof(u32);
+ break;
+ case RC_ABSOLUTE_PPC_2_2:
+ store_address_2_2((cell *)offset,absolute_value);
+ break;
+ case RC_RELATIVE_PPC_2:
+ store_address_masked((cell *)offset,relative_value,REL_RELATIVE_PPC_2_MASK,0);
+ break;
+ case RC_RELATIVE_PPC_3:
+ store_address_masked((cell *)offset,relative_value,REL_RELATIVE_PPC_3_MASK,0);
+ break;
+ case RC_RELATIVE_ARM_3:
+ store_address_masked((cell *)offset,relative_value - sizeof(cell) * 2,
+ REL_RELATIVE_ARM_3_MASK,2);
+ break;
+ case RC_INDIRECT_ARM:
+ store_address_masked((cell *)offset,relative_value - sizeof(cell),
+ REL_INDIRECT_ARM_MASK,0);
+ break;
+ case RC_INDIRECT_ARM_PC:
+ store_address_masked((cell *)offset,relative_value - sizeof(cell) * 2,
+ REL_INDIRECT_ARM_MASK,0);
+ break;
+ default:
+ critical_error("Bad rel class",klass);
+ break;
+ }
+}
+
+void update_literal_references_step(relocation_entry rel, cell index, code_block *compiled)
+{
+ if(REL_TYPE(rel) == RT_IMMEDIATE)
+ {
+ cell offset = REL_OFFSET(rel) + (cell)(compiled + 1);
+ array *literals = untag<array>(compiled->literals);
+ fixnum absolute_value = array_nth(literals,index);
+ store_address_in_code_block(REL_CLASS(rel),offset,absolute_value);
+ }
+}
+
+/* Update pointers to literals from compiled code. */
+void update_literal_references(code_block *compiled)
+{
+ if(!compiled->block.needs_fixup)
+ {
+ iterate_relocations(compiled,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)
+{
+ if(collecting_gen >= compiled->block.last_scan)
+ {
+ if(collecting_accumulation_gen_p())
+ compiled->block.last_scan = collecting_gen;
+ else
+ compiled->block.last_scan = collecting_gen + 1;
+
+ /* initialize chase pointer */
+ cell scan = newspace->here;
+
+ copy_handle(&compiled->literals);
+ copy_handle(&compiled->relocation);
+
+ /* do some tracing so that all reachable literals are now
+ at their final address */
+ copy_reachable_objects(scan,&newspace->here);
+
+ update_literal_references(compiled);
+ }
+}
+
+void *object_xt(cell obj)
+{
+ switch(tagged<object>(obj).type())
+ {
+ case WORD_TYPE:
+ return untag<word>(obj)->xt;
+ case QUOTATION_TYPE:
+ return untag<quotation>(obj)->xt;
+ default:
+ critical_error("Expected word or quotation",obj);
+ return NULL;
+ }
+}
+
+void *word_direct_xt(word *w)
+{
+ cell tagged_quot = w->direct_entry_def;
+ if(tagged_quot == F || max_pic_size == 0)
+ return w->xt;
+ else
+ {
+ quotation *quot = untag<quotation>(tagged_quot);
+ if(quot->compiledp == F)
+ return w->xt;
+ else
+ return quot->xt;
+ }
+}
+
+void update_word_references_step(relocation_entry rel, cell index, code_block *compiled)
+{
+ relocation_type type = REL_TYPE(rel);
+ if(type == RT_XT || type == RT_XT_DIRECT)
+ {
+ cell offset = REL_OFFSET(rel) + (cell)(compiled + 1);
+ array *literals = untag<array>(compiled->literals);
+ cell obj = array_nth(literals,index);
+
+ void *xt;
+ if(type == RT_XT)
+ xt = object_xt(obj);
+ else
+ xt = word_direct_xt(untag<word>(obj));
+
+ store_address_in_code_block(REL_CLASS(rel),offset,(cell)xt);
+ }
+}
+
+/* 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)
+{
+ if(compiled->block.needs_fixup)
+ relocate_code_block(compiled);
+ /* update_word_references() is always applied to every block in
+ the code heap. Since it resets all call sites to point to
+ their canonical XT (cold entry point for non-tail calls,
+ standard entry point for tail calls), it means that no PICs
+ are referenced after this is done. So instead of polluting
+ the code heap with dead PICs that will be freed on the next
+ GC, we add them to the free list immediately. */
+ else if(compiled->block.type == PIC_TYPE)
+ {
+ fflush(stdout);
+ heap_free(&code,&compiled->block);
+ }
+ else
+ {
+ iterate_relocations(compiled,update_word_references_step);
+ flush_icache_for(compiled);
+ }
+}
+
+void update_literal_and_word_references(code_block *compiled)
+{
+ update_literal_references(compiled);
+ update_word_references(compiled);
+}
+
+static void 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)
+{
+ check_code_address((cell)compiled);
+
+ mark_block(&compiled->block);
+
+ copy_handle(&compiled->literals);
+ copy_handle(&compiled->relocation);
+}
+
+void mark_stack_frame_step(stack_frame *frame)
+{
+ mark_code_block(frame_code(frame));
+}
+
+/* Mark code blocks executing in currently active stack frames. */
+void mark_active_blocks(context *stacks)
+{
+ if(collecting_gen == TENURED)
+ {
+ cell top = (cell)stacks->callstack_top;
+ cell bottom = (cell)stacks->callstack_bottom;
+
+ iterate_callstack(top,bottom,mark_stack_frame_step);
+ }
+}
+
+void mark_object_code_block(object *object)
+{
+ switch(object->h.hi_tag())
+ {
+ case WORD_TYPE:
+ word *w = (word *)object;
+ if(w->code)
+ mark_code_block(w->code);
+ if(w->profiling)
+ mark_code_block(w->profiling);
+ break;
+ case QUOTATION_TYPE:
+ quotation *q = (quotation *)object;
+ if(q->compiledp != F)
+ mark_code_block(q->code);
+ break;
+ case CALLSTACK_TYPE:
+ callstack *stack = (callstack *)object;
+ iterate_callstack_object(stack,mark_stack_frame_step);
+ break;
+ }
+}
+
+/* References to undefined symbols are patched up to call this function on
+image load */
+void undefined_symbol(void)
+{
+ general_error(ERROR_UNDEFINED_SYMBOL,F,F,NULL);
+}
+
+/* Look up an external library symbol referenced by a compiled code block */
+void *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;
+
+ switch(tagged<object>(symbol).type())
+ {
+ case BYTE_ARRAY_TYPE:
+ symbol_char *name = alien_offset(symbol);
+ void *sym = ffi_dlsym(d,name);
+
+ if(sym)
+ return sym;
+ else
+ {
+ printf("%s\n",name);
+ return (void *)undefined_symbol;
+ }
+ case ARRAY_TYPE:
+ cell i;
+ array *names = untag<array>(symbol);
+ for(i = 0; i < array_capacity(names); i++)
+ {
+ symbol_char *name = alien_offset(array_nth(names,i));
+ void *sym = ffi_dlsym(d,name);
+
+ if(sym)
+ return sym;
+ }
+ return (void *)undefined_symbol;
+ default:
+ critical_error("Bad symbol specifier",symbol);
+ return (void *)undefined_symbol;
+ }
+}
+
+/* Compute an address to store at a relocation */
+void 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();
+#endif
+
+ cell offset = REL_OFFSET(rel) + (cell)(compiled + 1);
+ array *literals = untag<array>(compiled->literals);
+ fixnum absolute_value;
+
+ switch(REL_TYPE(rel))
+ {
+ case RT_PRIMITIVE:
+ absolute_value = (cell)primitives[untag_fixnum(array_nth(literals,index))];
+ break;
+ case RT_DLSYM:
+ absolute_value = (cell)get_rel_symbol(literals,index);
+ break;
+ case RT_IMMEDIATE:
+ absolute_value = array_nth(literals,index);
+ break;
+ case RT_XT:
+ absolute_value = (cell)object_xt(array_nth(literals,index));
+ break;
+ case RT_XT_DIRECT:
+ absolute_value = (cell)word_direct_xt(untag<word>(array_nth(literals,index)));
+ break;
+ case RT_HERE:
+ absolute_value = offset + (short)untag_fixnum(array_nth(literals,index));
+ break;
+ case RT_THIS:
+ absolute_value = (cell)(compiled + 1);
+ break;
+ case RT_STACK_CHAIN:
+ absolute_value = (cell)&stack_chain;
+ break;
+ case RT_UNTAGGED:
+ absolute_value = untag_fixnum(array_nth(literals,index));
+ break;
+ default:
+ critical_error("Bad rel type",rel);
+ return; /* Can't happen */
+ }
+
+ store_address_in_code_block(REL_CLASS(rel),offset,absolute_value);
+}
+
+/* Perform all fixups on a code block */
+void relocate_code_block(code_block *compiled)
+{
+ compiled->block.last_scan = NURSERY;
+ compiled->block.needs_fixup = false;
+ iterate_relocations(compiled,relocate_code_block_step);
+ flush_icache_for(compiled);
+}
+
+/* Fixup labels. This is done at compile time, not image load time */
+void fixup_labels(array *labels, code_block *compiled)
+{
+ cell i;
+ cell size = array_capacity(labels);
+
+ for(i = 0; i < size; i += 3)
+ {
+ cell klass = untag_fixnum(array_nth(labels,i));
+ cell offset = untag_fixnum(array_nth(labels,i + 1));
+ cell target = untag_fixnum(array_nth(labels,i + 2));
+
+ store_address_in_code_block(klass,
+ offset + (cell)(compiled + 1),
+ target + (cell)(compiled + 1));
+ }
+}
+
+/* Might GC */
+code_block *allot_code_block(cell size)
+{
+ heap_block *block = heap_allot(&code,size + sizeof(code_block));
+
+ /* If allocation failed, do a code GC */
+ if(block == NULL)
+ {
+ gc();
+ block = heap_allot(&code,size + sizeof(code_block));
+
+ /* Insufficient room even after code GC, give up */
+ if(block == NULL)
+ {
+ cell used, total_free, max_free;
+ heap_usage(&code,&used,&total_free,&max_free);
+
+ print_string("Code heap stats:\n");
+ print_string("Used: "); print_cell(used); nl();
+ print_string("Total free space: "); print_cell(total_free); nl();
+ print_string("Largest free block: "); print_cell(max_free); nl();
+ fatal_error("Out of memory in add-compiled-block",0);
+ }
+ }
+
+ 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_);
+
+ cell code_length = align8(array_capacity(code.untagged()));
+ code_block *compiled = allot_code_block(code_length);
+
+ /* compiled header */
+ compiled->block.type = type;
+ compiled->block.last_scan = NURSERY;
+ compiled->block.needs_fixup = true;
+ compiled->relocation = relocation.value();
+
+ /* slight space optimization */
+ if(literals.type() == ARRAY_TYPE && array_capacity(literals.untagged()) == 0)
+ compiled->literals = F;
+ else
+ compiled->literals = literals.value();
+
+ /* code */
+ memcpy(compiled + 1,code.untagged() + 1,code_length);
+
+ /* fixup labels */
+ if(labels.value() != F)
+ fixup_labels(labels.as<array>().untagged(),compiled);
+
+ /* next time we do a minor GC, we have to scan the code heap for
+ literals */
+ last_code_heap_scan = NURSERY;
+
+ return compiled;
+}
+
+}
+++ /dev/null
-typedef enum {
- /* arg is a primitive number */
- RT_PRIMITIVE,
- /* arg is a literal table index, holding an array pair (symbol/dll) */
- RT_DLSYM,
- /* a pointer to a compiled word reference */
- RT_DISPATCH,
- /* a word's general entry point XT */
- RT_XT,
- /* a word's direct entry point XT */
- RT_XT_DIRECT,
- /* current offset */
- RT_HERE,
- /* current code block */
- RT_THIS,
- /* immediate literal */
- RT_IMMEDIATE,
- /* address of stack_chain var */
- RT_STACK_CHAIN,
- /* untagged fixnum literal */
- RT_UNTAGGED,
-} F_RELTYPE;
-
-typedef enum {
- /* absolute address in a 64-bit location */
- RC_ABSOLUTE_CELL,
- /* absolute address in a 32-bit location */
- RC_ABSOLUTE,
- /* relative address in a 32-bit location */
- RC_RELATIVE,
- /* relative address in a PowerPC LIS/ORI sequence */
- RC_ABSOLUTE_PPC_2_2,
- /* relative address in a PowerPC LWZ/STW/BC instruction */
- RC_RELATIVE_PPC_2,
- /* relative address in a PowerPC B/BL instruction */
- RC_RELATIVE_PPC_3,
- /* relative address in an ARM B/BL instruction */
- RC_RELATIVE_ARM_3,
- /* pointer to address in an ARM LDR/STR instruction */
- RC_INDIRECT_ARM,
- /* pointer to address in an ARM LDR/STR instruction offset by 8 bytes */
- RC_INDIRECT_ARM_PC
-} F_RELCLASS;
-
-#define REL_RELATIVE_PPC_2_MASK 0xfffc
-#define REL_RELATIVE_PPC_3_MASK 0x3fffffc
-#define REL_INDIRECT_ARM_MASK 0xfff
-#define REL_RELATIVE_ARM_3_MASK 0xffffff
-
-/* code relocation table consists of a table of entries for each fixup */
-typedef u32 F_REL;
-#define REL_TYPE(r) (((r) & 0xf0000000) >> 28)
-#define REL_CLASS(r) (((r) & 0x0f000000) >> 24)
-#define REL_OFFSET(r) ((r) & 0x00ffffff)
-
-void flush_icache_for(F_CODE_BLOCK *compiled);
-
-typedef void (*RELOCATION_ITERATOR)(F_REL rel, CELL index, F_CODE_BLOCK *compiled);
-
-void iterate_relocations(F_CODE_BLOCK *compiled, RELOCATION_ITERATOR iter);
-
-void store_address_in_code_block(CELL class, CELL offset, F_FIXNUM absolute_value);
-
-void relocate_code_block(F_CODE_BLOCK *compiled);
-
-void update_literal_references(F_CODE_BLOCK *compiled);
-
-void copy_literal_references(F_CODE_BLOCK *compiled);
-
-void update_word_references(F_CODE_BLOCK *compiled);
-
-void update_literal_and_word_references(F_CODE_BLOCK *compiled);
-
-void mark_code_block(F_CODE_BLOCK *compiled);
-
-void mark_active_blocks(F_CONTEXT *stacks);
-
-void mark_object_code_block(CELL scan);
-
-void relocate_code_block(F_CODE_BLOCK *relocating);
-
-INLINE bool stack_traces_p(void)
-{
- return userenv[STACK_TRACES_ENV] != F;
-}
-
-F_CODE_BLOCK *add_code_block(
- CELL type,
- F_BYTE_ARRAY *code,
- F_ARRAY *labels,
- CELL relocation,
- CELL literals);
--- /dev/null
+namespace factor
+{
+
+enum relocation_type {
+ /* arg is a primitive number */
+ RT_PRIMITIVE,
+ /* arg is a literal table index, holding an array pair (symbol/dll) */
+ RT_DLSYM,
+ /* a pointer to a compiled word reference */
+ RT_DISPATCH,
+ /* a word's general entry point XT */
+ RT_XT,
+ /* a word's direct entry point XT */
+ RT_XT_DIRECT,
+ /* current offset */
+ RT_HERE,
+ /* current code block */
+ RT_THIS,
+ /* immediate literal */
+ RT_IMMEDIATE,
+ /* address of stack_chain var */
+ RT_STACK_CHAIN,
+ /* untagged fixnum literal */
+ RT_UNTAGGED,
+};
+
+enum relocation_class {
+ /* absolute address in a 64-bit location */
+ RC_ABSOLUTE_CELL,
+ /* absolute address in a 32-bit location */
+ RC_ABSOLUTE,
+ /* relative address in a 32-bit location */
+ RC_RELATIVE,
+ /* relative address in a PowerPC LIS/ORI sequence */
+ RC_ABSOLUTE_PPC_2_2,
+ /* relative address in a PowerPC LWZ/STW/BC instruction */
+ RC_RELATIVE_PPC_2,
+ /* relative address in a PowerPC B/BL instruction */
+ RC_RELATIVE_PPC_3,
+ /* relative address in an ARM B/BL instruction */
+ RC_RELATIVE_ARM_3,
+ /* pointer to address in an ARM LDR/STR instruction */
+ RC_INDIRECT_ARM,
+ /* pointer to address in an ARM LDR/STR instruction offset by 8 bytes */
+ RC_INDIRECT_ARM_PC
+};
+
+#define REL_RELATIVE_PPC_2_MASK 0xfffc
+#define REL_RELATIVE_PPC_3_MASK 0x3fffffc
+#define REL_INDIRECT_ARM_MASK 0xfff
+#define REL_RELATIVE_ARM_3_MASK 0xffffff
+
+/* code relocation table consists of a table of entries for each fixup */
+typedef u32 relocation_entry;
+#define REL_TYPE(r) (relocation_type)(((r) & 0xf0000000) >> 28)
+#define REL_CLASS(r) (relocation_class)(((r) & 0x0f000000) >> 24)
+#define REL_OFFSET(r) ((r) & 0x00ffffff)
+
+void flush_icache_for(code_block *compiled);
+
+typedef void (*relocation_iterator)(relocation_entry rel, cell index, code_block *compiled);
+
+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(void)
+{
+ return userenv[STACK_TRACES_ENV] != F;
+}
+
+code_block *add_code_block(cell type, cell code, cell labels, cell relocation, cell literals);
+
+}
+++ /dev/null
-#include "master.h"
-
-static void clear_free_list(F_HEAP *heap)
-{
- memset(&heap->free,0,sizeof(F_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(F_HEAP *heap, CELL size)
-{
- heap->segment = alloc_segment(align_page(size));
- if(!heap->segment)
- fatal_error("Out of memory in new_heap",size);
-
- clear_free_list(heap);
-}
-
-static void add_to_free_list(F_HEAP *heap, F_FREE_BLOCK *block)
-{
- if(block->block.size < FREE_LIST_COUNT * BLOCK_SIZE_INCREMENT)
- {
- int index = block->block.size / BLOCK_SIZE_INCREMENT;
- block->next_free = heap->free.small_blocks[index];
- heap->free.small_blocks[index] = block;
- }
- else
- {
- block->next_free = heap->free.large_blocks;
- heap->free.large_blocks = block;
- }
-}
-
-/* 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(F_HEAP *heap, CELL size)
-{
- F_BLOCK *prev = NULL;
-
- clear_free_list(heap);
-
- size = (size + BLOCK_SIZE_INCREMENT - 1) & ~(BLOCK_SIZE_INCREMENT - 1);
-
- F_BLOCK *scan = first_block(heap);
- F_FREE_BLOCK *end = (F_FREE_BLOCK *)(heap->segment->start + size);
-
- /* Add all free blocks to the free list */
- while(scan && scan < (F_BLOCK *)end)
- {
- switch(scan->status)
- {
- case B_FREE:
- add_to_free_list(heap,(F_FREE_BLOCK *)scan);
- break;
- case B_ALLOCATED:
- break;
- default:
- critical_error("Invalid scan->status",(CELL)scan);
- break;
- }
-
- prev = scan;
- scan = next_block(heap,scan);
- }
-
- /* If there is room at the end of the heap, add a free block. This
- branch is only taken after loading a new image, not after code GC */
- if((CELL)(end + 1) <= heap->segment->end)
- {
- end->block.status = B_FREE;
- end->block.size = heap->segment->end - (CELL)end;
-
- /* add final free block */
- add_to_free_list(heap,end);
- }
- /* This branch is taken if the newly loaded image fits exactly, or
- after code GC */
- else
- {
- /* even if there's no room at the end of the heap for a new
- free block, we might have to jigger it up by a few bytes in
- case prev + prev->size */
- if(prev) prev->size = heap->segment->end - (CELL)prev;
- }
-
-}
-
-static void assert_free_block(F_FREE_BLOCK *block)
-{
- if(block->block.status != B_FREE)
- critical_error("Invalid block in free list",(CELL)block);
-}
-
-static F_FREE_BLOCK *find_free_block(F_HEAP *heap, CELL size)
-{
- CELL attempt = size;
-
- while(attempt < FREE_LIST_COUNT * BLOCK_SIZE_INCREMENT)
- {
- int index = attempt / BLOCK_SIZE_INCREMENT;
- F_FREE_BLOCK *block = heap->free.small_blocks[index];
- if(block)
- {
- assert_free_block(block);
- heap->free.small_blocks[index] = block->next_free;
- return block;
- }
-
- attempt *= 2;
- }
-
- F_FREE_BLOCK *prev = NULL;
- F_FREE_BLOCK *block = heap->free.large_blocks;
-
- while(block)
- {
- assert_free_block(block);
- if(block->block.size >= size)
- {
- if(prev)
- prev->next_free = block->next_free;
- else
- heap->free.large_blocks = block->next_free;
- return block;
- }
-
- prev = block;
- block = block->next_free;
- }
-
- return NULL;
-}
-
-static F_FREE_BLOCK *split_free_block(F_HEAP *heap, F_FREE_BLOCK *block, CELL size)
-{
- if(block->block.size != size )
- {
- /* split the block in two */
- F_FREE_BLOCK *split = (F_FREE_BLOCK *)((CELL)block + size);
- split->block.status = B_FREE;
- split->block.size = block->block.size - size;
- split->next_free = block->next_free;
- block->block.size = size;
- add_to_free_list(heap,split);
- }
-
- return block;
-}
-
-/* Allocate a block of memory from the mark and sweep GC heap */
-F_BLOCK *heap_allot(F_HEAP *heap, CELL size)
-{
- size = (size + BLOCK_SIZE_INCREMENT - 1) & ~(BLOCK_SIZE_INCREMENT - 1);
-
- F_FREE_BLOCK *block = find_free_block(heap,size);
- if(block)
- {
- block = split_free_block(heap,block,size);
-
- block->block.status = B_ALLOCATED;
- return &block->block;
- }
- else
- return NULL;
-}
-
-/* Deallocates a block manually */
-void heap_free(F_HEAP *heap, F_BLOCK *block)
-{
- block->status = B_FREE;
- add_to_free_list(heap,(F_FREE_BLOCK *)block);
-}
-
-void mark_block(F_BLOCK *block)
-{
- /* If already marked, do nothing */
- switch(block->status)
- {
- case B_MARKED:
- return;
- case B_ALLOCATED:
- block->status = B_MARKED;
- break;
- default:
- critical_error("Marking the wrong block",(CELL)block);
- break;
- }
-}
-
-/* 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(F_HEAP *heap)
-{
- F_BLOCK *scan = first_block(heap);
-
- while(scan)
- {
- if(scan->status == B_MARKED)
- scan->status = B_ALLOCATED;
-
- scan = next_block(heap,scan);
- }
-}
-
-/* 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(F_HEAP *heap, HEAP_ITERATOR iter)
-{
- clear_free_list(heap);
-
- F_BLOCK *prev = NULL;
- F_BLOCK *scan = first_block(heap);
-
- while(scan)
- {
- switch(scan->status)
- {
- case B_ALLOCATED:
- if(secure_gc)
- memset(scan + 1,0,scan->size - sizeof(F_BLOCK));
-
- if(prev && prev->status == B_FREE)
- prev->size += scan->size;
- else
- {
- scan->status = B_FREE;
- prev = scan;
- }
- break;
- case B_FREE:
- if(prev && prev->status == B_FREE)
- prev->size += scan->size;
- else
- prev = scan;
- break;
- case B_MARKED:
- if(prev && prev->status == B_FREE)
- add_to_free_list(heap,(F_FREE_BLOCK *)prev);
- scan->status = B_ALLOCATED;
- prev = scan;
- iter(scan);
- break;
- default:
- critical_error("Invalid scan->status",(CELL)scan);
- }
-
- scan = next_block(heap,scan);
- }
-
- if(prev && prev->status == B_FREE)
- add_to_free_list(heap,(F_FREE_BLOCK *)prev);
-}
-
-/* Compute total sum of sizes of free blocks, and size of largest free block */
-void heap_usage(F_HEAP *heap, CELL *used, CELL *total_free, CELL *max_free)
-{
- *used = 0;
- *total_free = 0;
- *max_free = 0;
-
- F_BLOCK *scan = first_block(heap);
-
- while(scan)
- {
- switch(scan->status)
- {
- case B_ALLOCATED:
- *used += scan->size;
- break;
- case B_FREE:
- *total_free += scan->size;
- if(scan->size > *max_free)
- *max_free = scan->size;
- break;
- default:
- critical_error("Invalid scan->status",(CELL)scan);
- }
-
- scan = next_block(heap,scan);
- }
-}
-
-/* The size of the heap, not including the last block if it's free */
-CELL heap_size(F_HEAP *heap)
-{
- F_BLOCK *scan = first_block(heap);
-
- while(next_block(heap,scan) != NULL)
- scan = next_block(heap,scan);
-
- /* this is the last block in the heap, and it is free */
- if(scan->status == B_FREE)
- return (CELL)scan - heap->segment->start;
- /* otherwise the last block is allocated */
- else
- return heap->segment->size;
-}
-
-/* Compute where each block is going to go, after compaction */
-CELL compute_heap_forwarding(F_HEAP *heap)
-{
- F_BLOCK *scan = first_block(heap);
- CELL address = (CELL)first_block(heap);
-
- while(scan)
- {
- if(scan->status == B_ALLOCATED)
- {
- scan->forwarding = (F_BLOCK *)address;
- address += scan->size;
- }
- else if(scan->status == B_MARKED)
- critical_error("Why is the block marked?",0);
-
- scan = next_block(heap,scan);
- }
-
- return address - heap->segment->start;
-}
-
-void compact_heap(F_HEAP *heap)
-{
- F_BLOCK *scan = first_block(heap);
-
- while(scan)
- {
- F_BLOCK *next = next_block(heap,scan);
-
- if(scan->status == B_ALLOCATED && scan != scan->forwarding)
- memcpy(scan->forwarding,scan,scan->size);
- scan = next;
- }
-}
--- /dev/null
+#include "master.hpp"
+
+namespace factor
+{
+
+static void 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)
+{
+ heap->seg = alloc_segment(align_page(size));
+ if(!heap->seg)
+ fatal_error("Out of memory in new_heap",size);
+
+ clear_free_list(heap);
+}
+
+static void add_to_free_list(heap *heap, free_heap_block *block)
+{
+ if(block->block.size < FREE_LIST_COUNT * BLOCK_SIZE_INCREMENT)
+ {
+ int index = block->block.size / BLOCK_SIZE_INCREMENT;
+ block->next_free = heap->free.small_blocks[index];
+ heap->free.small_blocks[index] = block;
+ }
+ else
+ {
+ block->next_free = heap->free.large_blocks;
+ heap->free.large_blocks = block;
+ }
+}
+
+/* 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)
+{
+ heap_block *prev = NULL;
+
+ clear_free_list(heap);
+
+ size = (size + BLOCK_SIZE_INCREMENT - 1) & ~(BLOCK_SIZE_INCREMENT - 1);
+
+ heap_block *scan = first_block(heap);
+ free_heap_block *end = (free_heap_block *)(heap->seg->start + size);
+
+ /* Add all free blocks to the free list */
+ while(scan && scan < (heap_block *)end)
+ {
+ switch(scan->status)
+ {
+ case B_FREE:
+ add_to_free_list(heap,(free_heap_block *)scan);
+ break;
+ case B_ALLOCATED:
+ break;
+ default:
+ critical_error("Invalid scan->status",(cell)scan);
+ break;
+ }
+
+ prev = scan;
+ scan = next_block(heap,scan);
+ }
+
+ /* If there is room at the end of the heap, add a free block. This
+ branch is only taken after loading a new image, not after code GC */
+ if((cell)(end + 1) <= heap->seg->end)
+ {
+ end->block.status = B_FREE;
+ end->block.size = heap->seg->end - (cell)end;
+
+ /* add final free block */
+ add_to_free_list(heap,end);
+ }
+ /* This branch is taken if the newly loaded image fits exactly, or
+ after code GC */
+ else
+ {
+ /* even if there's no room at the end of the heap for a new
+ free block, we might have to jigger it up by a few bytes in
+ case prev + prev->size */
+ if(prev) prev->size = heap->seg->end - (cell)prev;
+ }
+
+}
+
+static void assert_free_block(free_heap_block *block)
+{
+ if(block->block.status != B_FREE)
+ critical_error("Invalid block in free list",(cell)block);
+}
+
+static free_heap_block *find_free_block(heap *heap, cell size)
+{
+ cell attempt = size;
+
+ while(attempt < FREE_LIST_COUNT * BLOCK_SIZE_INCREMENT)
+ {
+ int index = attempt / BLOCK_SIZE_INCREMENT;
+ free_heap_block *block = heap->free.small_blocks[index];
+ if(block)
+ {
+ assert_free_block(block);
+ heap->free.small_blocks[index] = block->next_free;
+ return block;
+ }
+
+ attempt *= 2;
+ }
+
+ free_heap_block *prev = NULL;
+ free_heap_block *block = heap->free.large_blocks;
+
+ while(block)
+ {
+ assert_free_block(block);
+ if(block->block.size >= size)
+ {
+ if(prev)
+ prev->next_free = block->next_free;
+ else
+ heap->free.large_blocks = block->next_free;
+ return block;
+ }
+
+ prev = block;
+ block = block->next_free;
+ }
+
+ return NULL;
+}
+
+static free_heap_block *split_free_block(heap *heap, free_heap_block *block, cell size)
+{
+ if(block->block.size != size )
+ {
+ /* split the block in two */
+ free_heap_block *split = (free_heap_block *)((cell)block + size);
+ split->block.status = B_FREE;
+ split->block.size = block->block.size - size;
+ split->next_free = block->next_free;
+ block->block.size = size;
+ add_to_free_list(heap,split);
+ }
+
+ return block;
+}
+
+/* Allocate a block of memory from the mark and sweep GC heap */
+heap_block *heap_allot(heap *heap, cell size)
+{
+ size = (size + BLOCK_SIZE_INCREMENT - 1) & ~(BLOCK_SIZE_INCREMENT - 1);
+
+ free_heap_block *block = find_free_block(heap,size);
+ if(block)
+ {
+ block = split_free_block(heap,block,size);
+
+ block->block.status = B_ALLOCATED;
+ return &block->block;
+ }
+ else
+ return NULL;
+}
+
+/* Deallocates a block manually */
+void 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)
+{
+ /* If already marked, do nothing */
+ switch(block->status)
+ {
+ case B_MARKED:
+ return;
+ case B_ALLOCATED:
+ block->status = B_MARKED;
+ break;
+ default:
+ critical_error("Marking the wrong block",(cell)block);
+ break;
+ }
+}
+
+/* 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)
+{
+ heap_block *scan = first_block(heap);
+
+ while(scan)
+ {
+ if(scan->status == B_MARKED)
+ scan->status = B_ALLOCATED;
+
+ scan = next_block(heap,scan);
+ }
+}
+
+/* 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)
+{
+ clear_free_list(heap);
+
+ heap_block *prev = NULL;
+ heap_block *scan = first_block(heap);
+
+ while(scan)
+ {
+ switch(scan->status)
+ {
+ case B_ALLOCATED:
+ if(secure_gc)
+ memset(scan + 1,0,scan->size - sizeof(heap_block));
+
+ if(prev && prev->status == B_FREE)
+ prev->size += scan->size;
+ else
+ {
+ scan->status = B_FREE;
+ prev = scan;
+ }
+ break;
+ case B_FREE:
+ if(prev && prev->status == B_FREE)
+ prev->size += scan->size;
+ else
+ prev = scan;
+ break;
+ case B_MARKED:
+ if(prev && prev->status == B_FREE)
+ add_to_free_list(heap,(free_heap_block *)prev);
+ scan->status = B_ALLOCATED;
+ prev = scan;
+ iter(scan);
+ break;
+ default:
+ critical_error("Invalid scan->status",(cell)scan);
+ }
+
+ scan = next_block(heap,scan);
+ }
+
+ if(prev && prev->status == B_FREE)
+ 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)
+{
+ *used = 0;
+ *total_free = 0;
+ *max_free = 0;
+
+ heap_block *scan = first_block(heap);
+
+ while(scan)
+ {
+ switch(scan->status)
+ {
+ case B_ALLOCATED:
+ *used += scan->size;
+ break;
+ case B_FREE:
+ *total_free += scan->size;
+ if(scan->size > *max_free)
+ *max_free = scan->size;
+ break;
+ default:
+ critical_error("Invalid scan->status",(cell)scan);
+ }
+
+ scan = next_block(heap,scan);
+ }
+}
+
+/* The size of the heap, not including the last block if it's free */
+cell heap_size(heap *heap)
+{
+ heap_block *scan = first_block(heap);
+
+ while(next_block(heap,scan) != NULL)
+ scan = next_block(heap,scan);
+
+ /* this is the last block in the heap, and it is free */
+ if(scan->status == B_FREE)
+ return (cell)scan - heap->seg->start;
+ /* otherwise the last block is allocated */
+ else
+ return heap->seg->size;
+}
+
+/* Compute where each block is going to go, after compaction */
+cell compute_heap_forwarding(heap *heap)
+{
+ heap_block *scan = first_block(heap);
+ cell address = (cell)first_block(heap);
+
+ while(scan)
+ {
+ if(scan->status == B_ALLOCATED)
+ {
+ scan->forwarding = (heap_block *)address;
+ address += scan->size;
+ }
+ else if(scan->status == B_MARKED)
+ critical_error("Why is the block marked?",0);
+
+ scan = next_block(heap,scan);
+ }
+
+ return address - heap->seg->start;
+}
+
+void compact_heap(heap *heap)
+{
+ heap_block *scan = first_block(heap);
+
+ while(scan)
+ {
+ heap_block *next = next_block(heap,scan);
+
+ if(scan->status == B_ALLOCATED && scan != scan->forwarding)
+ memcpy(scan->forwarding,scan,scan->size);
+ scan = next;
+ }
+}
+
+}
+++ /dev/null
-#define FREE_LIST_COUNT 16
-#define BLOCK_SIZE_INCREMENT 32
-
-typedef struct {
- F_FREE_BLOCK *small_blocks[FREE_LIST_COUNT];
- F_FREE_BLOCK *large_blocks;
-} F_HEAP_FREE_LIST;
-
-typedef struct {
- F_SEGMENT *segment;
- F_HEAP_FREE_LIST free;
-} F_HEAP;
-
-typedef void (*HEAP_ITERATOR)(F_BLOCK *compiled);
-
-void new_heap(F_HEAP *heap, CELL size);
-void build_free_list(F_HEAP *heap, CELL size);
-F_BLOCK *heap_allot(F_HEAP *heap, CELL size);
-void heap_free(F_HEAP *heap, F_BLOCK *block);
-void mark_block(F_BLOCK *block);
-void unmark_marked(F_HEAP *heap);
-void free_unmarked(F_HEAP *heap, HEAP_ITERATOR iter);
-void heap_usage(F_HEAP *heap, CELL *used, CELL *total_free, CELL *max_free);
-CELL heap_size(F_HEAP *heap);
-CELL compute_heap_forwarding(F_HEAP *heap);
-void compact_heap(F_HEAP *heap);
-
-INLINE F_BLOCK *next_block(F_HEAP *heap, F_BLOCK *block)
-{
- CELL next = ((CELL)block + block->size);
- if(next == heap->segment->end)
- return NULL;
- else
- return (F_BLOCK *)next;
-}
-
-INLINE F_BLOCK *first_block(F_HEAP *heap)
-{
- return (F_BLOCK *)heap->segment->start;
-}
-
-INLINE F_BLOCK *last_block(F_HEAP *heap)
-{
- return (F_BLOCK *)heap->segment->end;
-}
--- /dev/null
+namespace factor
+{
+
+#define FREE_LIST_COUNT 16
+#define BLOCK_SIZE_INCREMENT 32
+
+struct heap_free_list {
+ free_heap_block *small_blocks[FREE_LIST_COUNT];
+ free_heap_block *large_blocks;
+};
+
+struct heap {
+ segment *seg;
+ 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);
+void compact_heap(heap *h);
+
+inline static heap_block *next_block(heap *h, heap_block *block)
+{
+ cell next = ((cell)block + block->size);
+ if(next == h->seg->end)
+ return NULL;
+ else
+ return (heap_block *)next;
+}
+
+inline static heap_block *first_block(heap *h)
+{
+ return (heap_block *)h->seg->start;
+}
+
+inline static heap_block *last_block(heap *h)
+{
+ return (heap_block *)h->seg->end;
+}
+
+}
+++ /dev/null
-#include "master.h"
-
-/* Allocate a code heap during startup */
-void init_code_heap(CELL size)
-{
- new_heap(&code_heap,size);
-}
-
-bool in_code_heap_p(CELL ptr)
-{
- return (ptr >= code_heap.segment->start
- && ptr <= code_heap.segment->end);
-}
-
-/* Compile a word definition with the non-optimizing compiler. Allocates memory */
-void jit_compile_word(F_WORD *word, CELL def, bool relocate)
-{
- REGISTER_ROOT(def);
- REGISTER_UNTAGGED(word);
- jit_compile(def,relocate);
- UNREGISTER_UNTAGGED(word);
- UNREGISTER_ROOT(def);
-
- word->code = untag_quotation(def)->code;
-
- if(word->direct_entry_def != F)
- jit_compile(word->direct_entry_def,relocate);
-}
-
-/* Apply a function to every code block */
-void iterate_code_heap(CODE_HEAP_ITERATOR iter)
-{
- F_BLOCK *scan = first_block(&code_heap);
-
- while(scan)
- {
- if(scan->status != B_FREE)
- iter((F_CODE_BLOCK *)scan);
- scan = next_block(&code_heap,scan);
- }
-}
-
-/* Copy literals referenced from all code blocks to newspace. Only for
-aging and nursery collections */
-void copy_code_heap_roots(void)
-{
- iterate_code_heap(copy_literal_references);
-}
-
-/* Update pointers to words referenced from all code blocks. Only after
-defining a new word. */
-void update_code_heap_words(void)
-{
- iterate_code_heap(update_word_references);
-}
-
-void primitive_modify_code_heap(void)
-{
- F_ARRAY *alist = untag_array(dpop());
-
- CELL count = untag_fixnum_fast(alist->capacity);
- if(count == 0)
- return;
-
- CELL i;
- for(i = 0; i < count; i++)
- {
- F_ARRAY *pair = untag_array(array_nth(alist,i));
-
- F_WORD *word = untag_word(array_nth(pair,0));
-
- CELL data = array_nth(pair,1);
-
- if(type_of(data) == QUOTATION_TYPE)
- {
- REGISTER_UNTAGGED(alist);
- REGISTER_UNTAGGED(word);
- jit_compile_word(word,data,false);
- UNREGISTER_UNTAGGED(word);
- UNREGISTER_UNTAGGED(alist);
- }
- else if(type_of(data) == ARRAY_TYPE)
- {
- F_ARRAY *compiled_code = untag_array(data);
-
- CELL literals = array_nth(compiled_code,0);
- CELL relocation = array_nth(compiled_code,1);
- F_ARRAY *labels = untag_array(array_nth(compiled_code,2));
- F_BYTE_ARRAY *code = untag_byte_array(array_nth(compiled_code,3));
-
- REGISTER_UNTAGGED(alist);
- REGISTER_UNTAGGED(word);
-
- F_CODE_BLOCK *compiled = add_code_block(
- WORD_TYPE,
- code,
- labels,
- relocation,
- literals);
-
- UNREGISTER_UNTAGGED(word);
- UNREGISTER_UNTAGGED(alist);
-
- word->code = compiled;
- }
- else
- critical_error("Expected a quotation or an array",data);
-
- REGISTER_UNTAGGED(alist);
- update_word_xt(word);
- UNREGISTER_UNTAGGED(alist);
- }
-
- update_code_heap_words();
-}
-
-/* Push the free space and total size of the code heap */
-void primitive_code_room(void)
-{
- CELL used, total_free, max_free;
- heap_usage(&code_heap,&used,&total_free,&max_free);
- dpush(tag_fixnum((code_heap.segment->size) / 1024));
- dpush(tag_fixnum(used / 1024));
- dpush(tag_fixnum(total_free / 1024));
- dpush(tag_fixnum(max_free / 1024));
-}
-
-F_CODE_BLOCK *forward_xt(F_CODE_BLOCK *compiled)
-{
- return (F_CODE_BLOCK *)compiled->block.forwarding;
-}
-
-void forward_frame_xt(F_STACK_FRAME *frame)
-{
- CELL offset = (CELL)FRAME_RETURN_ADDRESS(frame) - (CELL)frame_code(frame);
- F_CODE_BLOCK *forwarded = forward_xt(frame_code(frame));
- frame->xt = (XT)(forwarded + 1);
- FRAME_RETURN_ADDRESS(frame) = (XT)((CELL)forwarded + offset);
-}
-
-void forward_object_xts(void)
-{
- begin_scan();
-
- CELL obj;
-
- while((obj = next_object()) != F)
- {
- if(type_of(obj) == WORD_TYPE)
- {
- F_WORD *word = untag_object(obj);
-
- word->code = forward_xt(word->code);
- if(word->profiling)
- word->profiling = forward_xt(word->profiling);
- }
- else if(type_of(obj) == QUOTATION_TYPE)
- {
- F_QUOTATION *quot = untag_object(obj);
-
- if(quot->compiledp != F)
- quot->code = forward_xt(quot->code);
- }
- else if(type_of(obj) == CALLSTACK_TYPE)
- {
- F_CALLSTACK *stack = untag_object(obj);
- iterate_callstack_object(stack,forward_frame_xt);
- }
- }
-
- /* End the heap scan */
- gc_off = false;
-}
-
-/* Set the XT fields now that the heap has been compacted */
-void fixup_object_xts(void)
-{
- begin_scan();
-
- CELL obj;
-
- while((obj = next_object()) != F)
- {
- if(type_of(obj) == WORD_TYPE)
- {
- F_WORD *word = untag_object(obj);
- update_word_xt(word);
- }
- else if(type_of(obj) == QUOTATION_TYPE)
- {
- F_QUOTATION *quot = untag_object(obj);
-
- if(quot->compiledp != F)
- set_quot_xt(quot,quot->code);
- }
- }
-
- /* End the heap scan */
- gc_off = false;
-}
-
-/* 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)
-{
- /* Free all unreachable code blocks */
- gc();
-
- /* Figure out where the code heap blocks are going to end up */
- CELL size = compute_heap_forwarding(&code_heap);
-
- /* Update word and quotation code pointers */
- forward_object_xts();
-
- /* Actually perform the compaction */
- compact_heap(&code_heap);
-
- /* Update word and quotation XTs */
- fixup_object_xts();
-
- /* Now update the free list; there will be a single free block at
- the end */
- build_free_list(&code_heap,size);
-}
--- /dev/null
+#include "master.hpp"
+
+namespace factor
+{
+
+heap code;
+
+/* Allocate a code heap during startup */
+void init_code_heap(cell size)
+{
+ new_heap(&code,size);
+}
+
+bool 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)
+{
+ gc_root<word> word(word_);
+ gc_root<quotation> def(def_);
+
+ jit_compile(def.value(),relocate);
+
+ word->code = def->code;
+
+ if(word->direct_entry_def != F)
+ jit_compile(word->direct_entry_def,relocate);
+}
+
+/* Apply a function to every code block */
+void iterate_code_heap(code_heap_iterator iter)
+{
+ heap_block *scan = first_block(&code);
+
+ while(scan)
+ {
+ if(scan->status != B_FREE)
+ iter((code_block *)scan);
+ 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)
+{
+ iterate_code_heap(copy_literal_references);
+}
+
+/* Update pointers to words referenced from all code blocks. Only after
+defining a new word. */
+void update_code_heap_words(void)
+{
+ iterate_code_heap(update_word_references);
+}
+
+PRIMITIVE(modify_code_heap)
+{
+ gc_root<array> alist(dpop());
+
+ cell count = array_capacity(alist.untagged());
+
+ if(count == 0)
+ return;
+
+ cell i;
+ for(i = 0; i < count; i++)
+ {
+ gc_root<array> pair(array_nth(alist.untagged(),i));
+
+ gc_root<word> word(array_nth(pair.untagged(),0));
+ gc_root<object> data(array_nth(pair.untagged(),1));
+
+ switch(data.type())
+ {
+ case QUOTATION_TYPE:
+ jit_compile_word(word.value(),data.value(),false);
+ break;
+ case ARRAY_TYPE:
+ array *compiled_data = data.as<array>().untagged();
+ cell literals = array_nth(compiled_data,0);
+ cell relocation = array_nth(compiled_data,1);
+ cell labels = array_nth(compiled_data,2);
+ cell code = array_nth(compiled_data,3);
+
+ code_block *compiled = add_code_block(
+ WORD_TYPE,
+ code,
+ labels,
+ relocation,
+ literals);
+
+ word->code = compiled;
+ break;
+ default:
+ critical_error("Expected a quotation or an array",data.value());
+ break;
+ }
+
+ update_word_xt(word.value());
+ }
+
+ update_code_heap_words();
+}
+
+/* Push the free space and total size of the code heap */
+PRIMITIVE(code_room)
+{
+ cell used, total_free, max_free;
+ heap_usage(&code,&used,&total_free,&max_free);
+ dpush(tag_fixnum(code.seg->size / 1024));
+ dpush(tag_fixnum(used / 1024));
+ dpush(tag_fixnum(total_free / 1024));
+ dpush(tag_fixnum(max_free / 1024));
+}
+
+code_block *forward_xt(code_block *compiled)
+{
+ return (code_block *)compiled->block.forwarding;
+}
+
+void 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->xt = forwarded->xt();
+ FRAME_RETURN_ADDRESS(frame) = (void *)((cell)forwarded + offset);
+}
+
+void forward_object_xts(void)
+{
+ begin_scan();
+
+ cell obj;
+
+ while((obj = next_object()) != F)
+ {
+ switch(tagged<object>(obj).type())
+ {
+ case WORD_TYPE:
+ word *w = untag<word>(obj);
+
+ if(w->code)
+ w->code = forward_xt(w->code);
+ if(w->profiling)
+ w->profiling = forward_xt(w->profiling);
+
+ break;
+ case QUOTATION_TYPE:
+ quotation *quot = untag<quotation>(obj);
+
+ if(quot->compiledp != F)
+ quot->code = forward_xt(quot->code);
+
+ break;
+ case CALLSTACK_TYPE:
+ callstack *stack = untag<callstack>(obj);
+ iterate_callstack_object(stack,forward_frame_xt);
+
+ break;
+ default:
+ break;
+ }
+ }
+
+ /* End the heap scan */
+ gc_off = false;
+}
+
+/* Set the XT fields now that the heap has been compacted */
+void fixup_object_xts(void)
+{
+ begin_scan();
+
+ cell obj;
+
+ while((obj = next_object()) != F)
+ {
+ switch(tagged<object>(obj).type())
+ {
+ case WORD_TYPE:
+ update_word_xt(obj);
+ break;
+ case QUOTATION_TYPE:
+ quotation *quot = untag<quotation>(obj);
+ if(quot->compiledp != F)
+ set_quot_xt(quot,quot->code);
+ break;
+ default:
+ break;
+ }
+ }
+
+ /* End the heap scan */
+ gc_off = false;
+}
+
+/* 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)
+{
+ /* Free all unreachable code blocks */
+ gc();
+
+ /* Figure out where the code heap blocks are going to end up */
+ cell size = compute_heap_forwarding(&code);
+
+ /* Update word and quotation code pointers */
+ forward_object_xts();
+
+ /* Actually perform the compaction */
+ compact_heap(&code);
+
+ /* Update word and quotation XTs */
+ fixup_object_xts();
+
+ /* Now update the free list; there will be a single free block at
+ the end */
+ build_free_list(&code,size);
+}
+
+}
+++ /dev/null
-/* compiled code */
-F_HEAP code_heap;
-
-void init_code_heap(CELL size);
-
-bool in_code_heap_p(CELL ptr);
-
-void jit_compile_word(F_WORD *word, CELL def, bool relocate);
-
-typedef void (*CODE_HEAP_ITERATOR)(F_CODE_BLOCK *compiled);
-
-void iterate_code_heap(CODE_HEAP_ITERATOR iter);
-
-void copy_code_heap_roots(void);
-
-void primitive_modify_code_heap(void);
-
-void primitive_code_room(void);
-
-void compact_code_heap(void);
-
-INLINE void check_code_pointer(CELL pointer)
-{
-#ifdef FACTOR_DEBUG
- assert(pointer >= code_heap.segment->start && pointer < code_heap.segment->end);
-#endif
-}
--- /dev/null
+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(void);
+
+PRIMITIVE(modify_code_heap);
+
+PRIMITIVE(code_room);
+
+void compact_code_heap(void);
+
+inline static void check_code_pointer(cell ptr)
+{
+#ifdef FACTOR_DEBUG
+ assert(in_code_heap_p(ptr));
+#endif
+}
+
+}
--- /dev/null
+#include "master.hpp"
+
+factor::context *stack_chain;
+
+namespace factor
+{
+
+cell ds_size, rs_size;
+context *unused_contexts;
+
+void reset_datastack(void)
+{
+ ds = ds_bot - sizeof(cell);
+}
+
+void reset_retainstack(void)
+{
+ rs = rs_bot - sizeof(cell);
+}
+
+#define RESERVED (64 * sizeof(cell))
+
+void fix_stacks(void)
+{
+ if(ds + sizeof(cell) < ds_bot || ds + RESERVED >= ds_top) reset_datastack();
+ if(rs + sizeof(cell) < rs_bot || rs + 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)
+{
+ if(stack_chain)
+ {
+ stack_chain->datastack = ds;
+ stack_chain->retainstack = rs;
+ }
+}
+
+context *alloc_context(void)
+{
+ context *new_context;
+
+ if(unused_contexts)
+ {
+ new_context = unused_contexts;
+ unused_contexts = unused_contexts->next;
+ }
+ else
+ {
+ new_context = (context *)safe_malloc(sizeof(context));
+ new_context->datastack_region = alloc_segment(ds_size);
+ new_context->retainstack_region = alloc_segment(rs_size);
+ }
+
+ return new_context;
+}
+
+void 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)
+{
+ context *new_context = alloc_context();
+
+ new_context->callstack_bottom = (stack_frame *)-1;
+ new_context->callstack_top = (stack_frame *)-1;
+
+ /* note that these register values are not necessarily valid stack
+ pointers. they are merely saved non-volatile registers, and are
+ restored in unnest_stacks(). consider this scenario:
+ - factor code calls C function
+ - C function saves ds/cs registers (since they're non-volatile)
+ - C function clobbers them
+ - C function calls Factor callback
+ - Factor callback returns
+ - C function restores registers
+ - C function returns to Factor code */
+ new_context->datastack_save = ds;
+ new_context->retainstack_save = rs;
+
+ /* save per-callback userenv */
+ new_context->current_callback_save = userenv[CURRENT_CALLBACK_ENV];
+ new_context->catchstack_save = userenv[CATCHSTACK_ENV];
+
+ new_context->next = stack_chain;
+ stack_chain = new_context;
+
+ reset_datastack();
+ reset_retainstack();
+}
+
+/* called when leaving a compiled callback */
+void unnest_stacks(void)
+{
+ ds = stack_chain->datastack_save;
+ rs = stack_chain->retainstack_save;
+
+ /* restore per-callback userenv */
+ userenv[CURRENT_CALLBACK_ENV] = stack_chain->current_callback_save;
+ userenv[CATCHSTACK_ENV] = stack_chain->catchstack_save;
+
+ context *old_stacks = stack_chain;
+ stack_chain = old_stacks->next;
+ dealloc_context(old_stacks);
+}
+
+/* called on startup */
+void init_stacks(cell ds_size_, cell rs_size_)
+{
+ ds_size = ds_size_;
+ rs_size = rs_size_;
+ stack_chain = NULL;
+ unused_contexts = NULL;
+}
+
+bool stack_to_array(cell bottom, cell top)
+{
+ fixnum depth = (fixnum)(top - bottom + sizeof(cell));
+
+ if(depth < 0)
+ return false;
+ else
+ {
+ array *a = allot_array_internal<array>(depth / sizeof(cell));
+ memcpy(a + 1,(void*)bottom,depth);
+ dpush(tag<array>(a));
+ return true;
+ }
+}
+
+PRIMITIVE(datastack)
+{
+ if(!stack_to_array(ds_bot,ds))
+ general_error(ERROR_DS_UNDERFLOW,F,F,NULL);
+}
+
+PRIMITIVE(retainstack)
+{
+ if(!stack_to_array(rs_bot,rs))
+ general_error(ERROR_RS_UNDERFLOW,F,F,NULL);
+}
+
+/* returns pointer to top of stack */
+cell 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)
+{
+ ds = array_to_stack(untag_check<array>(dpop()),ds_bot);
+}
+
+PRIMITIVE(set_retainstack)
+{
+ rs = array_to_stack(untag_check<array>(dpop()),rs_bot);
+}
+
+/* Used to implement call( */
+PRIMITIVE(check_datastack)
+{
+ fixnum out = to_fixnum(dpop());
+ fixnum in = to_fixnum(dpop());
+ fixnum height = out - in;
+ array *saved_datastack = untag_check<array>(dpop());
+ fixnum saved_height = array_capacity(saved_datastack);
+ fixnum current_height = (ds - ds_bot + sizeof(cell)) / sizeof(cell);
+ if(current_height - height != saved_height)
+ dpush(F);
+ else
+ {
+ fixnum i;
+ for(i = 0; i < saved_height - in; i++)
+ {
+ if(((cell *)ds_bot)[i] != array_nth(saved_datastack,i))
+ {
+ dpush(F);
+ return;
+ }
+ }
+ dpush(T);
+ }
+}
+
+}
--- /dev/null
+namespace factor
+{
+
+/* Assembly code makes assumptions about the layout of this struct:
+ - callstack_top field is 0
+ - callstack_bottom field is 1
+ - datastack field is 2
+ - retainstack field is 3 */
+struct context {
+ /* C stack pointer on entry */
+ stack_frame *callstack_top;
+ stack_frame *callstack_bottom;
+
+ /* current datastack top pointer */
+ cell datastack;
+
+ /* current retain stack top pointer */
+ cell retainstack;
+
+ /* saved contents of ds register on entry to callback */
+ cell datastack_save;
+
+ /* saved contents of rs register on entry to callback */
+ cell retainstack_save;
+
+ /* memory region holding current datastack */
+ segment *datastack_region;
+
+ /* memory region holding current retain stack */
+ segment *retainstack_region;
+
+ /* saved userenv slots on entry to callback */
+ cell catchstack_save;
+ cell current_callback_save;
+
+ 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)
+#define rs_top (stack_chain->retainstack_region->end)
+
+DEFPUSHPOP(d,ds)
+DEFPUSHPOP(r,rs)
+
+void reset_datastack(void);
+void reset_retainstack(void);
+void fix_stacks(void);
+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(void);
+VM_C_API void nest_stacks(void);
+VM_C_API void unnest_stacks(void);
+
+}
+
+VM_C_API factor::context *stack_chain;
+++ /dev/null
-#define FACTOR_CPU_STRING "arm"
-
-register CELL ds asm("r5");
-register CELL rs asm("r6");
-
-#define F_FASTCALL
-
-#define FRAME_RETURN_ADDRESS(frame) *(XT *)(frame_successor(frame) + 1)
-
-void c_to_factor(CELL quot);
-void set_callstack(F_STACK_FRAME *to, F_STACK_FRAME *from, CELL length, void *memcpy);
-void throw_impl(CELL quot, F_STACK_FRAME *rewind);
-void lazy_jit_compile(CELL quot);
--- /dev/null
+namespace factor
+{
+
+#define FACTOR_CPU_STRING "arm"
+
+register cell ds asm("r5");
+register cell rs asm("r6");
+
+#define FRAME_RETURN_ADDRESS(frame) *(XT *)(frame_successor(frame) + 1)
+
+void c_to_factor(cell quot);
+void set_callstack(stack_frame *to, stack_frame *from, cell length, void *memcpy);
+void throw_impl(cell quot, stack_frame *rewind);
+void lazy_jit_compile(cell quot);
+
+}
+++ /dev/null
-#define FACTOR_CPU_STRING "ppc"
-#define F_FASTCALL
-
-register CELL ds asm("r29");
-register CELL rs asm("r30");
-
-void c_to_factor(CELL quot);
-void undefined(CELL word);
-void set_callstack(F_STACK_FRAME *to, F_STACK_FRAME *from, CELL length, void *memcpy);
-void throw_impl(CELL quot, F_STACK_FRAME *rewind);
-void lazy_jit_compile(CELL quot);
-void flush_icache(CELL start, CELL len);
--- /dev/null
+namespace factor
+{
+
+#define FACTOR_CPU_STRING "ppc"
+#define VM_ASM_API
+
+register cell ds asm("r29");
+register cell rs asm("r30");
+
+void c_to_factor(cell quot);
+void undefined(cell word);
+void set_callstack(stack_frame *to, stack_frame *from, cell length, void *memcpy);
+void throw_impl(cell quot, stack_frame *rewind);
+void lazy_jit_compile(cell quot);
+void flush_icache(cell start, cell len);
+
+}
+++ /dev/null
-#define FACTOR_CPU_STRING "x86.32"
-
-register CELL ds asm("esi");
-register CELL rs asm("edi");
-
-#define F_FASTCALL __attribute__ ((regparm (2)))
--- /dev/null
+namespace factor
+{
+
+#define FACTOR_CPU_STRING "x86.32"
+
+register cell ds asm("esi");
+register cell rs asm("edi");
+
+#define VM_ASM_API extern "C" __attribute__ ((regparm (2)))
+
+}
+++ /dev/null
-#define FACTOR_CPU_STRING "x86.64"
-
-register CELL ds asm("r14");
-register CELL rs asm("r15");
-
-#define F_FASTCALL
--- /dev/null
+namespace factor
+{
+
+#define FACTOR_CPU_STRING "x86.64"
+
+register cell ds asm("r14");
+register cell rs asm("r15");
+
+#define VM_ASM_API extern "C"
+
+}
+++ /dev/null
-#include <assert.h>
-
-#define FRAME_RETURN_ADDRESS(frame) *(XT *)(frame_successor(frame) + 1)
-
-INLINE void flush_icache(CELL start, CELL len) {}
-
-F_FASTCALL void c_to_factor(CELL quot);
-F_FASTCALL void throw_impl(CELL quot, F_STACK_FRAME *rewind_to);
-F_FASTCALL void lazy_jit_compile(CELL quot);
-
-void set_callstack(F_STACK_FRAME *to, F_STACK_FRAME *from, CELL length, void *memcpy);
-
-INLINE void check_call_site(CELL return_address)
-{
- /* An x86 CALL instruction looks like so:
- |e8|..|..|..|..|
- where the ... are a PC-relative jump address.
- The return_address points to right after the
- instruction. */
-#ifdef FACTOR_DEBUG
- assert(*(unsigned char *)(return_address - 5) == 0xe8);
-#endif
-}
-
-INLINE CELL get_call_target(CELL return_address)
-{
- check_call_site(return_address);
- return *(int *)(return_address - 4) + return_address;
-}
-
-INLINE void set_call_target(CELL return_address, CELL target)
-{
- check_call_site(return_address);
- *(int *)(return_address - 4) = (target - return_address);
-}
--- /dev/null
+#include <assert.h>
+
+namespace factor
+{
+
+#define FRAME_RETURN_ADDRESS(frame) *(void **)(frame_successor(frame) + 1)
+
+inline static void flush_icache(cell start, cell len) {}
+
+inline static void check_call_site(cell return_address)
+{
+ /* An x86 CALL instruction looks like so:
+ |e8|..|..|..|..|
+ where the ... are a PC-relative jump address.
+ The return_address points to right after the
+ instruction. */
+#ifdef FACTOR_DEBUG
+ assert(*(unsigned char *)(return_address - 5) == 0xe8);
+#endif
+}
+
+inline static void *get_call_target(cell return_address)
+{
+ check_call_site(return_address);
+ return (void *)(*(int *)(return_address - 4) + return_address);
+}
+
+inline static void set_call_target(cell return_address, void *target)
+{
+ check_call_site(return_address);
+ *(int *)(return_address - 4) = ((cell)target - return_address);
+}
+
+/* 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_C_API void set_callstack(stack_frame *to,
+ stack_frame *from,
+ cell length,
+ void *(*memcpy)(void*,const void*, size_t));
+
+}
+++ /dev/null
-#include "master.h"
-
-/* Scan all the objects in the card */
-void copy_card(F_CARD *ptr, CELL gen, CELL here)
-{
- CELL card_scan = (CELL)CARD_TO_ADDR(ptr) + CARD_OFFSET(ptr);
- CELL card_end = (CELL)CARD_TO_ADDR(ptr + 1);
-
- if(here < card_end)
- card_end = here;
-
- copy_reachable_objects(card_scan,&card_end);
-
- cards_scanned++;
-}
-
-void copy_card_deck(F_DECK *deck, CELL gen, F_CARD mask, F_CARD unmask)
-{
- F_CARD *first_card = DECK_TO_CARD(deck);
- F_CARD *last_card = DECK_TO_CARD(deck + 1);
-
- CELL here = data_heap->generations[gen].here;
-
- u32 *quad_ptr;
- u32 quad_mask = mask | (mask << 8) | (mask << 16) | (mask << 24);
-
- for(quad_ptr = (u32 *)first_card; quad_ptr < (u32 *)last_card; quad_ptr++)
- {
- if(*quad_ptr & quad_mask)
- {
- F_CARD *ptr = (F_CARD *)quad_ptr;
-
- int card;
- for(card = 0; card < 4; card++)
- {
- if(ptr[card] & mask)
- {
- copy_card(&ptr[card],gen,here);
- ptr[card] &= ~unmask;
- }
- }
- }
- }
-
- decks_scanned++;
-}
-
-/* Copy all newspace objects referenced from marked cards to the destination */
-void copy_gen_cards(CELL gen)
-{
- F_DECK *first_deck = ADDR_TO_DECK(data_heap->generations[gen].start);
- F_DECK *last_deck = ADDR_TO_DECK(data_heap->generations[gen].end);
-
- F_CARD mask, unmask;
-
- /* if we are collecting the nursery, we care about old->nursery pointers
- but not old->aging pointers */
- if(collecting_gen == NURSERY)
- {
- mask = CARD_POINTS_TO_NURSERY;
-
- /* after the collection, no old->nursery pointers remain
- anywhere, but old->aging pointers might remain in tenured
- space */
- if(gen == TENURED)
- unmask = CARD_POINTS_TO_NURSERY;
- /* after the collection, all cards in aging space can be
- cleared */
- else if(HAVE_AGING_P && gen == AGING)
- unmask = CARD_MARK_MASK;
- else
- {
- critical_error("bug in copy_gen_cards",gen);
- return;
- }
- }
- /* if we are collecting aging space into tenured space, we care about
- all old->nursery and old->aging pointers. no old->aging pointers can
- remain */
- else if(HAVE_AGING_P && collecting_gen == AGING)
- {
- if(collecting_aging_again)
- {
- mask = CARD_POINTS_TO_AGING;
- unmask = CARD_MARK_MASK;
- }
- /* after we collect aging space into the aging semispace, no
- old->nursery pointers remain but tenured space might still have
- pointers to aging space. */
- else
- {
- mask = CARD_POINTS_TO_AGING;
- unmask = CARD_POINTS_TO_NURSERY;
- }
- }
- else
- {
- critical_error("bug in copy_gen_cards",gen);
- return;
- }
-
- F_DECK *ptr;
-
- for(ptr = first_deck; ptr < last_deck; ptr++)
- {
- if(*ptr & mask)
- {
- copy_card_deck(ptr,gen,mask,unmask);
- *ptr &= ~unmask;
- }
- }
-}
-
-/* Scan cards in all generations older than the one being collected, copying
-old->new references */
-void copy_cards(void)
-{
- u64 start = current_micros();
-
- int i;
- for(i = collecting_gen + 1; i < data_heap->gen_count; i++)
- copy_gen_cards(i);
-
- card_scan_time += (current_micros() - start);
-}
-
-/* Copy all tagged pointers in a range of memory */
-void copy_stack_elements(F_SEGMENT *region, CELL top)
-{
- CELL ptr = region->start;
-
- for(; ptr <= top; ptr += CELLS)
- copy_handle((CELL*)ptr);
-}
-
-void copy_registered_locals(void)
-{
- CELL ptr = gc_locals_region->start;
-
- for(; ptr <= gc_locals; ptr += CELLS)
- copy_handle(*(CELL **)ptr);
-}
-
-/* Copy roots over at the start of GC, namely various constants, stacks,
-the user environment and extra roots registered with REGISTER_ROOT */
-void copy_roots(void)
-{
- copy_handle(&T);
- copy_handle(&bignum_zero);
- copy_handle(&bignum_pos_one);
- copy_handle(&bignum_neg_one);
-
- copy_registered_locals();
- copy_stack_elements(extra_roots_region,extra_roots);
-
- if(!performing_compaction)
- {
- save_stacks();
- F_CONTEXT *stacks = stack_chain;
-
- while(stacks)
- {
- copy_stack_elements(stacks->datastack_region,stacks->datastack);
- copy_stack_elements(stacks->retainstack_region,stacks->retainstack);
-
- copy_handle(&stacks->catchstack_save);
- copy_handle(&stacks->current_callback_save);
-
- mark_active_blocks(stacks);
-
- stacks = stacks->next;
- }
- }
-
- int i;
- for(i = 0; i < USER_ENV; i++)
- copy_handle(&userenv[i]);
-}
-
-/* Given a pointer to oldspace, copy it to newspace */
-INLINE void *copy_untagged_object(void *pointer, CELL size)
-{
- if(newspace->here + size >= newspace->end)
- longjmp(gc_jmp,1);
- allot_barrier(newspace->here);
- void *newpointer = allot_zone(newspace,size);
-
- F_GC_STATS *s = &gc_stats[collecting_gen];
- s->object_count++;
- s->bytes_copied += size;
-
- memcpy(newpointer,pointer,size);
- return newpointer;
-}
-
-INLINE void forward_object(CELL pointer, CELL newpointer)
-{
- if(pointer != newpointer)
- put(UNTAG(pointer),RETAG(newpointer,GC_COLLECTED));
-}
-
-INLINE CELL copy_object_impl(CELL pointer)
-{
- CELL newpointer = (CELL)copy_untagged_object(
- (void*)UNTAG(pointer),
- object_size(pointer));
- forward_object(pointer,newpointer);
- return newpointer;
-}
-
-/* Follow a chain of forwarding pointers */
-CELL resolve_forwarding(CELL untagged, CELL tag)
-{
- check_data_pointer(untagged);
-
- CELL header = get(untagged);
- /* another forwarding pointer */
- if(TAG(header) == GC_COLLECTED)
- return resolve_forwarding(UNTAG(header),tag);
- /* we've found the destination */
- else
- {
- check_header(header);
- CELL pointer = RETAG(untagged,tag);
- if(should_copy(untagged))
- pointer = RETAG(copy_object_impl(pointer),tag);
- return pointer;
- }
-}
-
-/* Given a pointer to a tagged pointer to oldspace, copy it to newspace.
-If the object has already been copied, return the forwarding
-pointer address without copying anything; otherwise, install
-a new forwarding pointer. */
-INLINE CELL copy_object(CELL pointer)
-{
- check_data_pointer(pointer);
-
- CELL tag = TAG(pointer);
- CELL header = get(UNTAG(pointer));
-
- if(TAG(header) == GC_COLLECTED)
- return resolve_forwarding(UNTAG(header),tag);
- else
- {
- check_header(header);
- return RETAG(copy_object_impl(pointer),tag);
- }
-}
-
-void copy_handle(CELL *handle)
-{
- CELL pointer = *handle;
-
- if(!immediate_p(pointer))
- {
- check_data_pointer(pointer);
- if(should_copy(pointer))
- *handle = copy_object(pointer);
- }
-}
-
-CELL copy_next_from_nursery(CELL scan)
-{
- CELL *obj = (CELL *)scan;
- CELL *end = (CELL *)(scan + binary_payload_start(scan));
-
- if(obj != end)
- {
- obj++;
-
- CELL nursery_start = nursery.start;
- CELL nursery_end = nursery.end;
-
- for(; obj < end; obj++)
- {
- CELL pointer = *obj;
-
- if(!immediate_p(pointer))
- {
- check_data_pointer(pointer);
- if(pointer >= nursery_start && pointer < nursery_end)
- *obj = copy_object(pointer);
- }
- }
- }
-
- return scan + untagged_object_size(scan);
-}
-
-CELL copy_next_from_aging(CELL scan)
-{
- CELL *obj = (CELL *)scan;
- CELL *end = (CELL *)(scan + binary_payload_start(scan));
-
- if(obj != end)
- {
- obj++;
-
- CELL tenured_start = data_heap->generations[TENURED].start;
- CELL tenured_end = data_heap->generations[TENURED].end;
-
- CELL newspace_start = newspace->start;
- CELL newspace_end = newspace->end;
-
- for(; obj < end; obj++)
- {
- CELL pointer = *obj;
-
- if(!immediate_p(pointer))
- {
- check_data_pointer(pointer);
- if(!(pointer >= newspace_start && pointer < newspace_end)
- && !(pointer >= tenured_start && pointer < tenured_end))
- *obj = copy_object(pointer);
- }
- }
- }
-
- return scan + untagged_object_size(scan);
-}
-
-CELL copy_next_from_tenured(CELL scan)
-{
- CELL *obj = (CELL *)scan;
- CELL *end = (CELL *)(scan + binary_payload_start(scan));
-
- if(obj != end)
- {
- obj++;
-
- CELL newspace_start = newspace->start;
- CELL newspace_end = newspace->end;
-
- for(; obj < end; obj++)
- {
- CELL pointer = *obj;
-
- if(!immediate_p(pointer))
- {
- check_data_pointer(pointer);
- if(!(pointer >= newspace_start && pointer < newspace_end))
- *obj = copy_object(pointer);
- }
- }
- }
-
- mark_object_code_block(scan);
-
- return scan + untagged_object_size(scan);
-}
-
-void copy_reachable_objects(CELL scan, CELL *end)
-{
- if(collecting_gen == NURSERY)
- {
- while(scan < *end)
- scan = copy_next_from_nursery(scan);
- }
- else if(HAVE_AGING_P && collecting_gen == AGING)
- {
- while(scan < *end)
- scan = copy_next_from_aging(scan);
- }
- else if(collecting_gen == TENURED)
- {
- while(scan < *end)
- scan = copy_next_from_tenured(scan);
- }
-}
-
-/* Prepare to start copying reachable objects into an unused zone */
-void begin_gc(CELL requested_bytes)
-{
- if(growing_data_heap)
- {
- if(collecting_gen != TENURED)
- critical_error("Invalid parameters to begin_gc",0);
-
- old_data_heap = data_heap;
- set_data_heap(grow_data_heap(old_data_heap,requested_bytes));
- newspace = &data_heap->generations[TENURED];
- }
- else if(collecting_accumulation_gen_p())
- {
- /* when collecting one of these generations, rotate it
- with the semispace */
- F_ZONE z = data_heap->generations[collecting_gen];
- data_heap->generations[collecting_gen] = data_heap->semispaces[collecting_gen];
- data_heap->semispaces[collecting_gen] = z;
- reset_generation(collecting_gen);
- newspace = &data_heap->generations[collecting_gen];
- clear_cards(collecting_gen,collecting_gen);
- clear_decks(collecting_gen,collecting_gen);
- clear_allot_markers(collecting_gen,collecting_gen);
- }
- else
- {
- /* when collecting a younger generation, we copy
- reachable objects to the next oldest generation,
- so we set the newspace so the next generation. */
- newspace = &data_heap->generations[collecting_gen + 1];
- }
-}
-
-void end_gc(CELL gc_elapsed)
-{
- F_GC_STATS *s = &gc_stats[collecting_gen];
-
- s->collections++;
- s->gc_time += gc_elapsed;
- if(s->max_gc_time < gc_elapsed)
- s->max_gc_time = gc_elapsed;
-
- if(growing_data_heap)
- {
- dealloc_data_heap(old_data_heap);
- old_data_heap = NULL;
- growing_data_heap = false;
- }
-
- if(collecting_accumulation_gen_p())
- {
- /* all younger generations except are now empty.
- if collecting_gen == NURSERY here, we only have 1 generation;
- old-school Cheney collector */
- if(collecting_gen != NURSERY)
- reset_generations(NURSERY,collecting_gen - 1);
- }
- else if(collecting_gen == NURSERY)
- {
- nursery.here = nursery.start;
- }
- else
- {
- /* all generations up to and including the one
- collected are now empty */
- reset_generations(NURSERY,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)
-{
- if(gc_off)
- {
- critical_error("GC disabled",gen);
- return;
- }
-
- u64 start = current_micros();
-
- performing_gc = true;
- growing_data_heap = growing_data_heap_;
- collecting_gen = gen;
-
- /* we come back here if a generation is full */
- if(setjmp(gc_jmp))
- {
- /* We have no older generations we can try collecting, so we
- resort to growing the data heap */
- if(collecting_gen == TENURED)
- {
- growing_data_heap = true;
-
- /* see the comment in unmark_marked() */
- unmark_marked(&code_heap);
- }
- /* we try collecting AGING space twice before going on to
- collect TENURED */
- else if(HAVE_AGING_P
- && collecting_gen == AGING
- && !collecting_aging_again)
- {
- collecting_aging_again = true;
- }
- /* Collect the next oldest generation */
- else
- {
- collecting_gen++;
- }
- }
-
- begin_gc(requested_bytes);
-
- /* initialize chase pointer */
- CELL scan = newspace->here;
-
- /* collect objects referenced from stacks and environment */
- copy_roots();
- /* collect objects referenced from older generations */
- copy_cards();
-
- /* do some tracing */
- copy_reachable_objects(scan,&newspace->here);
-
- /* don't scan code heap unless it has pointers to this
- generation or younger */
- if(collecting_gen >= last_code_heap_scan)
- {
- code_heap_scans++;
-
- if(collecting_gen == TENURED)
- free_unmarked(&code_heap,(HEAP_ITERATOR)update_literal_and_word_references);
- else
- copy_code_heap_roots();
-
- if(collecting_accumulation_gen_p())
- last_code_heap_scan = collecting_gen;
- else
- last_code_heap_scan = collecting_gen + 1;
- }
-
- CELL gc_elapsed = (current_micros() - start);
-
- end_gc(gc_elapsed);
-
- performing_gc = false;
-}
-
-void gc(void)
-{
- garbage_collection(TENURED,false,0);
-}
-
-void minor_gc(void)
-{
- garbage_collection(NURSERY,false,0);
-}
-
-void primitive_gc(void)
-{
- gc();
-}
-
-void primitive_gc_stats(void)
-{
- GROWABLE_ARRAY(stats);
-
- CELL i;
- u64 total_gc_time = 0;
-
- for(i = 0; i < MAX_GEN_COUNT; i++)
- {
- F_GC_STATS *s = &gc_stats[i];
- GROWABLE_ARRAY_ADD(stats,allot_cell(s->collections));
- GROWABLE_ARRAY_ADD(stats,tag_bignum(long_long_to_bignum(s->gc_time)));
- GROWABLE_ARRAY_ADD(stats,tag_bignum(long_long_to_bignum(s->max_gc_time)));
- GROWABLE_ARRAY_ADD(stats,allot_cell(s->collections == 0 ? 0 : s->gc_time / s->collections));
- GROWABLE_ARRAY_ADD(stats,allot_cell(s->object_count));
- GROWABLE_ARRAY_ADD(stats,tag_bignum(long_long_to_bignum(s->bytes_copied)));
-
- total_gc_time += s->gc_time;
- }
-
- GROWABLE_ARRAY_ADD(stats,tag_bignum(ulong_long_to_bignum(total_gc_time)));
- GROWABLE_ARRAY_ADD(stats,tag_bignum(ulong_long_to_bignum(cards_scanned)));
- GROWABLE_ARRAY_ADD(stats,tag_bignum(ulong_long_to_bignum(decks_scanned)));
- GROWABLE_ARRAY_ADD(stats,tag_bignum(ulong_long_to_bignum(card_scan_time)));
- GROWABLE_ARRAY_ADD(stats,allot_cell(code_heap_scans));
-
- GROWABLE_ARRAY_TRIM(stats);
- GROWABLE_ARRAY_DONE(stats);
- dpush(stats);
-}
-
-void clear_gc_stats(void)
-{
- int i;
- for(i = 0; i < MAX_GEN_COUNT; i++)
- memset(&gc_stats[i],0,sizeof(F_GC_STATS));
-
- cards_scanned = 0;
- decks_scanned = 0;
- card_scan_time = 0;
- code_heap_scans = 0;
-}
-
-void primitive_clear_gc_stats(void)
-{
- clear_gc_stats();
-}
-
-/* classes.tuple uses this to reshape tuples; tools.deploy.shaker uses this
- to coalesce equal but distinct quotations and wrappers. */
-void primitive_become(void)
-{
- F_ARRAY *new_objects = untag_array(dpop());
- F_ARRAY *old_objects = untag_array(dpop());
-
- CELL capacity = array_capacity(new_objects);
- if(capacity != array_capacity(old_objects))
- critical_error("bad parameters to become",0);
-
- CELL i;
-
- for(i = 0; i < capacity; i++)
- {
- CELL old_obj = array_nth(old_objects,i);
- CELL new_obj = array_nth(new_objects,i);
-
- forward_object(old_obj,new_obj);
- }
-
- gc();
-
- /* If a word's definition quotation was in old_objects and the
- quotation in new_objects is not compiled, we might leak memory
- by referencing the old quotation unless we recompile all
- unoptimized words. */
- compile_all_words();
-}
--- /dev/null
+#include "master.hpp"
+
+namespace factor
+{
+
+/* used during garbage collection only */
+zone *newspace;
+bool performing_gc;
+bool performing_compaction;
+cell collecting_gen;
+
+/* if true, we 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)
+{
+ performing_gc = false;
+ last_code_heap_scan = NURSERY;
+ collecting_aging_again = false;
+}
+
+/* Given a pointer to oldspace, copy it to newspace */
+static object *copy_untagged_object_impl(object *pointer, cell size)
+{
+ if(newspace->here + size >= newspace->end)
+ longjmp(gc_jmp,1);
+ object *newpointer = allot_zone(newspace,size);
+
+ gc_stats *s = &stats[collecting_gen];
+ s->object_count++;
+ s->bytes_copied += size;
+
+ memcpy(newpointer,pointer,size);
+ return newpointer;
+}
+
+static object *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)
+{
+ if(in_zone(newspace,untagged))
+ return false;
+ if(collecting_gen == TENURED)
+ return true;
+ else if(HAVE_AGING_P && collecting_gen == AGING)
+ return !in_zone(&data->generations[TENURED],untagged);
+ else if(collecting_gen == NURSERY)
+ return in_zone(&nursery,untagged);
+ else
+ {
+ critical_error("Bug in should_copy_p",(cell)untagged);
+ return false;
+ }
+}
+
+/* Follow a chain of forwarding pointers */
+static object *resolve_forwarding(object *untagged)
+{
+ check_data_pointer(untagged);
+
+ /* is there another forwarding pointer? */
+ if(untagged->h.forwarding_pointer_p())
+ return resolve_forwarding(untagged->h.forwarding_pointer());
+ /* we've found the destination */
+ else
+ {
+ untagged->h.check_header();
+ if(should_copy_p(untagged))
+ return copy_object_impl(untagged);
+ else
+ return untagged;
+ }
+}
+
+template <typename T> static T *copy_untagged_object(T *untagged)
+{
+ check_data_pointer(untagged);
+
+ if(untagged->h.forwarding_pointer_p())
+ untagged = (T *)resolve_forwarding(untagged->h.forwarding_pointer());
+ else
+ {
+ untagged->h.check_header();
+ untagged = (T *)copy_object_impl(untagged);
+ }
+
+ return untagged;
+}
+
+static cell copy_object(cell pointer)
+{
+ return RETAG(copy_untagged_object(untag<object>(pointer)),TAG(pointer));
+}
+
+void copy_handle(cell *handle)
+{
+ cell pointer = *handle;
+
+ if(!immediate_p(pointer))
+ {
+ object *obj = untag<object>(pointer);
+ check_data_pointer(obj);
+ if(should_copy_p(obj))
+ *handle = copy_object(pointer);
+ }
+}
+
+/* Scan all the objects in the card */
+static void 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);
+
+ if(here < card_end)
+ card_end = here;
+
+ copy_reachable_objects(card_scan,&card_end);
+
+ cards_scanned++;
+}
+
+static void 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);
+
+ cell here = data->generations[gen].here;
+
+ u32 *quad_ptr;
+ u32 quad_mask = mask | (mask << 8) | (mask << 16) | (mask << 24);
+
+ for(quad_ptr = (u32 *)first_card; quad_ptr < (u32 *)last_card; quad_ptr++)
+ {
+ if(*quad_ptr & quad_mask)
+ {
+ card *ptr = (card *)quad_ptr;
+
+ int card;
+ for(card = 0; card < 4; card++)
+ {
+ if(ptr[card] & mask)
+ {
+ copy_card(&ptr[card],gen,here);
+ ptr[card] &= ~unmask;
+ }
+ }
+ }
+ }
+
+ decks_scanned++;
+}
+
+/* Copy all newspace objects referenced from marked cards to the destination */
+static void 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);
+
+ card mask, unmask;
+
+ /* if we are collecting the nursery, we care about old->nursery pointers
+ but not old->aging pointers */
+ if(collecting_gen == NURSERY)
+ {
+ mask = CARD_POINTS_TO_NURSERY;
+
+ /* after the collection, no old->nursery pointers remain
+ anywhere, but old->aging pointers might remain in tenured
+ space */
+ if(gen == TENURED)
+ unmask = CARD_POINTS_TO_NURSERY;
+ /* after the collection, all cards in aging space can be
+ cleared */
+ else if(HAVE_AGING_P && gen == AGING)
+ unmask = CARD_MARK_MASK;
+ else
+ {
+ critical_error("bug in copy_gen_cards",gen);
+ return;
+ }
+ }
+ /* if we are collecting aging space into tenured space, we care about
+ all old->nursery and old->aging pointers. no old->aging pointers can
+ remain */
+ else if(HAVE_AGING_P && collecting_gen == AGING)
+ {
+ if(collecting_aging_again)
+ {
+ mask = CARD_POINTS_TO_AGING;
+ unmask = CARD_MARK_MASK;
+ }
+ /* after we collect aging space into the aging semispace, no
+ old->nursery pointers remain but tenured space might still have
+ pointers to aging space. */
+ else
+ {
+ mask = CARD_POINTS_TO_AGING;
+ unmask = CARD_POINTS_TO_NURSERY;
+ }
+ }
+ else
+ {
+ critical_error("bug in copy_gen_cards",gen);
+ return;
+ }
+
+ card_deck *ptr;
+
+ for(ptr = first_deck; ptr < last_deck; ptr++)
+ {
+ if(*ptr & mask)
+ {
+ copy_card_deck(ptr,gen,mask,unmask);
+ *ptr &= ~unmask;
+ }
+ }
+}
+
+/* Scan cards in all generations older than the one being collected, copying
+old->new references */
+static void copy_cards(void)
+{
+ u64 start = current_micros();
+
+ cell i;
+ for(i = collecting_gen + 1; i < data->gen_count; i++)
+ copy_gen_cards(i);
+
+ card_scan_time += (current_micros() - start);
+}
+
+/* Copy all tagged pointers in a range of memory */
+static void copy_stack_elements(segment *region, cell top)
+{
+ cell ptr = region->start;
+
+ for(; ptr <= top; ptr += sizeof(cell))
+ copy_handle((cell*)ptr);
+}
+
+static void copy_registered_locals(void)
+{
+ cell scan = gc_locals_region->start;
+
+ for(; scan <= gc_locals; scan += sizeof(cell))
+ copy_handle(*(cell **)scan);
+}
+
+static void copy_registered_bignums(void)
+{
+ cell scan = gc_bignums_region->start;
+
+ for(; scan <= gc_bignums; scan += sizeof(cell))
+ {
+ bignum **handle = *(bignum ***)scan;
+ bignum *pointer = *handle;
+
+ if(pointer)
+ {
+ check_data_pointer(pointer);
+ if(should_copy_p(pointer))
+ *handle = copy_untagged_object(pointer);
+#ifdef FACTOR_DEBUG
+ assert((*handle)->h.hi_tag() == BIGNUM_TYPE);
+#endif
+ }
+ }
+}
+
+/* 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)
+{
+ copy_handle(&T);
+ copy_handle(&bignum_zero);
+ copy_handle(&bignum_pos_one);
+ copy_handle(&bignum_neg_one);
+
+ copy_registered_locals();
+ copy_registered_bignums();
+
+ if(!performing_compaction)
+ {
+ save_stacks();
+ context *stacks = stack_chain;
+
+ while(stacks)
+ {
+ copy_stack_elements(stacks->datastack_region,stacks->datastack);
+ copy_stack_elements(stacks->retainstack_region,stacks->retainstack);
+
+ copy_handle(&stacks->catchstack_save);
+ copy_handle(&stacks->current_callback_save);
+
+ mark_active_blocks(stacks);
+
+ stacks = stacks->next;
+ }
+ }
+
+ int i;
+ for(i = 0; i < USER_ENV; i++)
+ copy_handle(&userenv[i]);
+}
+
+static cell copy_next_from_nursery(cell scan)
+{
+ cell *obj = (cell *)scan;
+ cell *end = (cell *)(scan + binary_payload_start((object *)scan));
+
+ if(obj != end)
+ {
+ obj++;
+
+ cell nursery_start = nursery.start;
+ cell nursery_end = nursery.end;
+
+ for(; obj < end; obj++)
+ {
+ cell pointer = *obj;
+
+ if(!immediate_p(pointer))
+ {
+ check_data_pointer((object *)pointer);
+ if(pointer >= nursery_start && pointer < nursery_end)
+ *obj = copy_object(pointer);
+ }
+ }
+ }
+
+ return scan + untagged_object_size((object *)scan);
+}
+
+static cell copy_next_from_aging(cell scan)
+{
+ cell *obj = (cell *)scan;
+ cell *end = (cell *)(scan + binary_payload_start((object *)scan));
+
+ if(obj != end)
+ {
+ obj++;
+
+ cell tenured_start = data->generations[TENURED].start;
+ cell tenured_end = data->generations[TENURED].end;
+
+ cell newspace_start = newspace->start;
+ cell newspace_end = newspace->end;
+
+ for(; obj < end; obj++)
+ {
+ cell pointer = *obj;
+
+ if(!immediate_p(pointer))
+ {
+ check_data_pointer((object *)pointer);
+ if(!(pointer >= newspace_start && pointer < newspace_end)
+ && !(pointer >= tenured_start && pointer < tenured_end))
+ *obj = copy_object(pointer);
+ }
+ }
+ }
+
+ return scan + untagged_object_size((object *)scan);
+}
+
+static cell copy_next_from_tenured(cell scan)
+{
+ cell *obj = (cell *)scan;
+ cell *end = (cell *)(scan + binary_payload_start((object *)scan));
+
+ if(obj != end)
+ {
+ obj++;
+
+ cell newspace_start = newspace->start;
+ cell newspace_end = newspace->end;
+
+ for(; obj < end; obj++)
+ {
+ cell pointer = *obj;
+
+ if(!immediate_p(pointer))
+ {
+ check_data_pointer((object *)pointer);
+ if(!(pointer >= newspace_start && pointer < newspace_end))
+ *obj = copy_object(pointer);
+ }
+ }
+ }
+
+ mark_object_code_block((object *)scan);
+
+ return scan + untagged_object_size((object *)scan);
+}
+
+void copy_reachable_objects(cell scan, cell *end)
+{
+ if(collecting_gen == NURSERY)
+ {
+ while(scan < *end)
+ scan = copy_next_from_nursery(scan);
+ }
+ else if(HAVE_AGING_P && collecting_gen == AGING)
+ {
+ while(scan < *end)
+ scan = copy_next_from_aging(scan);
+ }
+ else if(collecting_gen == TENURED)
+ {
+ while(scan < *end)
+ scan = copy_next_from_tenured(scan);
+ }
+}
+
+/* Prepare to start copying reachable objects into an unused zone */
+static void begin_gc(cell requested_bytes)
+{
+ if(growing_data_heap)
+ {
+ if(collecting_gen != TENURED)
+ critical_error("Invalid parameters to begin_gc",0);
+
+ old_data_heap = data;
+ set_data_heap(grow_data_heap(old_data_heap,requested_bytes));
+ newspace = &data->generations[TENURED];
+ }
+ else if(collecting_accumulation_gen_p())
+ {
+ /* when collecting one of these generations, rotate it
+ with the semispace */
+ zone z = data->generations[collecting_gen];
+ data->generations[collecting_gen] = data->semispaces[collecting_gen];
+ data->semispaces[collecting_gen] = z;
+ reset_generation(collecting_gen);
+ newspace = &data->generations[collecting_gen];
+ clear_cards(collecting_gen,collecting_gen);
+ clear_decks(collecting_gen,collecting_gen);
+ clear_allot_markers(collecting_gen,collecting_gen);
+ }
+ else
+ {
+ /* when collecting a younger generation, we copy
+ reachable objects to the next oldest generation,
+ so we set the newspace so the next generation. */
+ newspace = &data->generations[collecting_gen + 1];
+ }
+}
+
+static void end_gc(cell gc_elapsed)
+{
+ gc_stats *s = &stats[collecting_gen];
+
+ s->collections++;
+ s->gc_time += gc_elapsed;
+ if(s->max_gc_time < gc_elapsed)
+ s->max_gc_time = gc_elapsed;
+
+ if(growing_data_heap)
+ {
+ dealloc_data_heap(old_data_heap);
+ old_data_heap = NULL;
+ growing_data_heap = false;
+ }
+
+ if(collecting_accumulation_gen_p())
+ {
+ /* all younger generations except are now empty.
+ if collecting_gen == NURSERY here, we only have 1 generation;
+ old-school Cheney collector */
+ if(collecting_gen != NURSERY)
+ reset_generations(NURSERY,collecting_gen - 1);
+ }
+ else if(collecting_gen == NURSERY)
+ {
+ nursery.here = nursery.start;
+ }
+ else
+ {
+ /* all generations up to and including the one
+ collected are now empty */
+ reset_generations(NURSERY,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)
+{
+ if(gc_off)
+ {
+ critical_error("GC disabled",gen);
+ return;
+ }
+
+ u64 start = current_micros();
+
+ performing_gc = true;
+ growing_data_heap = growing_data_heap_;
+ collecting_gen = gen;
+
+ /* we come back here if a generation is full */
+ if(setjmp(gc_jmp))
+ {
+ /* We have no older generations we can try collecting, so we
+ resort to growing the data heap */
+ if(collecting_gen == TENURED)
+ {
+ growing_data_heap = true;
+
+ /* see the comment in unmark_marked() */
+ unmark_marked(&code);
+ }
+ /* we try collecting AGING space twice before going on to
+ collect TENURED */
+ else if(HAVE_AGING_P
+ && collecting_gen == AGING
+ && !collecting_aging_again)
+ {
+ collecting_aging_again = true;
+ }
+ /* Collect the next oldest generation */
+ else
+ {
+ collecting_gen++;
+ }
+ }
+
+ begin_gc(requested_bytes);
+
+ /* initialize chase pointer */
+ cell scan = newspace->here;
+
+ /* collect objects referenced from stacks and environment */
+ copy_roots();
+ /* collect objects referenced from older generations */
+ copy_cards();
+
+ /* do some tracing */
+ copy_reachable_objects(scan,&newspace->here);
+
+ /* don't scan code heap unless it has pointers to this
+ generation or younger */
+ if(collecting_gen >= last_code_heap_scan)
+ {
+ code_heap_scans++;
+
+ if(collecting_gen == TENURED)
+ free_unmarked(&code,(heap_iterator)update_literal_and_word_references);
+ else
+ copy_code_heap_roots();
+
+ if(collecting_accumulation_gen_p())
+ last_code_heap_scan = collecting_gen;
+ else
+ last_code_heap_scan = collecting_gen + 1;
+ }
+
+ cell gc_elapsed = (current_micros() - start);
+
+ end_gc(gc_elapsed);
+
+ performing_gc = false;
+}
+
+void gc(void)
+{
+ garbage_collection(TENURED,false,0);
+}
+
+PRIMITIVE(gc)
+{
+ gc();
+}
+
+PRIMITIVE(gc_stats)
+{
+ growable_array result;
+
+ cell i;
+ u64 total_gc_time = 0;
+
+ for(i = 0; i < MAX_GEN_COUNT; i++)
+ {
+ gc_stats *s = &stats[i];
+ result.add(allot_cell(s->collections));
+ result.add(tag<bignum>(long_long_to_bignum(s->gc_time)));
+ result.add(tag<bignum>(long_long_to_bignum(s->max_gc_time)));
+ result.add(allot_cell(s->collections == 0 ? 0 : s->gc_time / s->collections));
+ result.add(allot_cell(s->object_count));
+ result.add(tag<bignum>(long_long_to_bignum(s->bytes_copied)));
+
+ total_gc_time += s->gc_time;
+ }
+
+ result.add(tag<bignum>(ulong_long_to_bignum(total_gc_time)));
+ result.add(tag<bignum>(ulong_long_to_bignum(cards_scanned)));
+ result.add(tag<bignum>(ulong_long_to_bignum(decks_scanned)));
+ result.add(tag<bignum>(ulong_long_to_bignum(card_scan_time)));
+ result.add(allot_cell(code_heap_scans));
+
+ result.trim();
+ dpush(result.elements.value());
+}
+
+void clear_gc_stats(void)
+{
+ int i;
+ for(i = 0; i < MAX_GEN_COUNT; i++)
+ memset(&stats[i],0,sizeof(stats));
+
+ cards_scanned = 0;
+ decks_scanned = 0;
+ card_scan_time = 0;
+ code_heap_scans = 0;
+}
+
+PRIMITIVE(clear_gc_stats)
+{
+ 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)
+{
+ array *new_objects = untag_check<array>(dpop());
+ array *old_objects = untag_check<array>(dpop());
+
+ cell capacity = array_capacity(new_objects);
+ if(capacity != array_capacity(old_objects))
+ critical_error("bad parameters to become",0);
+
+ cell i;
+
+ for(i = 0; i < capacity; i++)
+ {
+ tagged<object> old_obj(array_nth(old_objects,i));
+ tagged<object> new_obj(array_nth(new_objects,i));
+
+ if(old_obj != new_obj)
+ old_obj->h.forward_to(new_obj.untagged());
+ }
+
+ gc();
+
+ /* If a word's definition quotation was in old_objects and the
+ quotation in new_objects is not compiled, we might leak memory
+ by referencing the old quotation unless we recompile all
+ unoptimized words. */
+ compile_all_words();
+}
+
+VM_C_API void minor_gc(void)
+{
+ garbage_collection(NURSERY,false,0);
+}
+
+}
+++ /dev/null
-void gc(void);
-DLLEXPORT void minor_gc(void);
-
-/* used during garbage collection only */
-
-F_ZONE *newspace;
-bool performing_gc;
-bool performing_compaction;
-CELL collecting_gen;
-
-/* if true, we 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;
-
-/* statistics */
-typedef struct {
- CELL collections;
- u64 gc_time;
- u64 max_gc_time;
- CELL object_count;
- u64 bytes_copied;
-} F_GC_STATS;
-
-F_GC_STATS gc_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;
-F_DATA_HEAP *old_data_heap;
-
-INLINE bool collecting_accumulation_gen_p(void)
-{
- return ((HAVE_AGING_P
- && collecting_gen == AGING
- && !collecting_aging_again)
- || collecting_gen == TENURED);
-}
-
-/* test if the pointer is in generation being collected, or a younger one. */
-INLINE bool should_copy(CELL untagged)
-{
- if(in_zone(newspace,untagged))
- return false;
- if(collecting_gen == TENURED)
- return true;
- else if(HAVE_AGING_P && collecting_gen == AGING)
- return !in_zone(&data_heap->generations[TENURED],untagged);
- else if(collecting_gen == NURSERY)
- return in_zone(&nursery,untagged);
- else
- {
- critical_error("Bug in should_copy",untagged);
- return false;
- }
-}
-
-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 */
-#define ALLOT_BUFFER_ZONE 1024
-
-/* If this is defined, we GC every 100 allocations. This catches missing local roots */
-#ifdef GC_DEBUG
-int gc_count;
-#endif
-
-/*
- * It is up to the caller to fill in the object's fields in a meaningful
- * fashion!
- */
-int count;
-INLINE void *allot_object(CELL type, CELL a)
-{
-#ifdef GC_DEBUG
- if(!gc_off)
- {
- if(gc_count++ % 100 == 0)
- gc();
-
- }
-#endif
-
- CELL *object;
-
- if(nursery.size - ALLOT_BUFFER_ZONE > a)
- {
- /* If there is insufficient room, collect the nursery */
- if(nursery.here + ALLOT_BUFFER_ZONE + a > nursery.end)
- garbage_collection(NURSERY,false,0);
-
- CELL h = nursery.here;
- nursery.here = h + align8(a);
- object = (void*)h;
- }
- /* If the object is bigger than the nursery, allocate it in
- tenured space */
- else
- {
- F_ZONE *tenured = &data_heap->generations[TENURED];
-
- /* If tenured space does not have enough room, collect */
- if(tenured->here + a > tenured->end)
- {
- gc();
- tenured = &data_heap->generations[TENURED];
- }
-
- /* If it still won't fit, grow the heap */
- if(tenured->here + a > tenured->end)
- {
- garbage_collection(TENURED,true,a);
- tenured = &data_heap->generations[TENURED];
- }
-
- object = allot_zone(tenured,a);
-
- /* We have to do this */
- allot_barrier((CELL)object);
-
- /* Allows initialization code to store old->new pointers
- without hitting the write barrier in the common case of
- a nursery allocation */
- write_barrier((CELL)object);
- }
-
- *object = tag_header(type);
- return object;
-}
-
-void copy_reachable_objects(CELL scan, CELL *end);
-
-void primitive_gc(void);
-void primitive_gc_stats(void);
-void clear_gc_stats(void);
-void primitive_clear_gc_stats(void);
-void primitive_become(void);
-
-INLINE void check_data_pointer(CELL pointer)
-{
-#ifdef FACTOR_DEBUG
- if(!growing_data_heap)
- {
- assert(pointer >= data_heap->segment->start
- && pointer < data_heap->segment->end);
- }
-#endif
-}
--- /dev/null
+namespace factor
+{
+
+/* statistics */
+struct gc_stats {
+ cell collections;
+ u64 gc_time;
+ u64 max_gc_time;
+ cell object_count;
+ 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);
+
+void gc(void);
+
+inline static bool collecting_accumulation_gen_p(void)
+{
+ return ((HAVE_AGING_P
+ && collecting_gen == AGING
+ && !collecting_aging_again)
+ || collecting_gen == 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 */
+#define 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(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[TENURED];
+
+ /* If tenured space does not have enough room, collect */
+ if(tenured->here + size > tenured->end)
+ {
+ gc();
+ tenured = &data->generations[TENURED];
+ }
+
+ /* If it still won't fit, grow the heap */
+ if(tenured->here + size > tenured->end)
+ {
+ garbage_collection(TENURED,true,size);
+ tenured = &data->generations[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(void);
+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_C_API void minor_gc(void);
+
+}
+++ /dev/null
-#include "master.h"
-
-CELL init_zone(F_ZONE *z, CELL size, CELL start)
-{
- z->size = size;
- z->start = z->here = start;
- z->end = start + size;
- return z->end;
-}
-
-void init_card_decks(void)
-{
- CELL start = align(data_heap->segment->start,DECK_SIZE);
- allot_markers_offset = (CELL)data_heap->allot_markers - (start >> CARD_BITS);
- cards_offset = (CELL)data_heap->cards - (start >> CARD_BITS);
- decks_offset = (CELL)data_heap->decks - (start >> DECK_BITS);
-}
-
-F_DATA_HEAP *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);
- tenured_size = align(tenured_size,DECK_SIZE);
-
- F_DATA_HEAP *data_heap = safe_malloc(sizeof(F_DATA_HEAP));
- data_heap->young_size = young_size;
- data_heap->aging_size = aging_size;
- data_heap->tenured_size = tenured_size;
- data_heap->gen_count = gens;
-
- CELL total_size;
- if(data_heap->gen_count == 2)
- total_size = young_size + 2 * tenured_size;
- else if(data_heap->gen_count == 3)
- total_size = young_size + 2 * aging_size + 2 * tenured_size;
- else
- {
- fatal_error("Invalid number of generations",data_heap->gen_count);
- return NULL; /* can't happen */
- }
-
- total_size += DECK_SIZE;
-
- data_heap->segment = alloc_segment(total_size);
-
- data_heap->generations = safe_malloc(sizeof(F_ZONE) * data_heap->gen_count);
- data_heap->semispaces = safe_malloc(sizeof(F_ZONE) * data_heap->gen_count);
-
- CELL cards_size = total_size >> CARD_BITS;
- data_heap->allot_markers = safe_malloc(cards_size);
- data_heap->allot_markers_end = data_heap->allot_markers + cards_size;
-
- data_heap->cards = safe_malloc(cards_size);
- data_heap->cards_end = data_heap->cards + cards_size;
-
- CELL decks_size = total_size >> DECK_BITS;
- data_heap->decks = safe_malloc(decks_size);
- data_heap->decks_end = data_heap->decks + decks_size;
-
- CELL alloter = align(data_heap->segment->start,DECK_SIZE);
-
- alloter = init_zone(&data_heap->generations[TENURED],tenured_size,alloter);
- alloter = init_zone(&data_heap->semispaces[TENURED],tenured_size,alloter);
-
- if(data_heap->gen_count == 3)
- {
- alloter = init_zone(&data_heap->generations[AGING],aging_size,alloter);
- alloter = init_zone(&data_heap->semispaces[AGING],aging_size,alloter);
- }
-
- if(data_heap->gen_count >= 2)
- {
- alloter = init_zone(&data_heap->generations[NURSERY],young_size,alloter);
- alloter = init_zone(&data_heap->semispaces[NURSERY],0,alloter);
- }
-
- if(data_heap->segment->end - alloter > DECK_SIZE)
- critical_error("Bug in alloc_data_heap",alloter);
-
- return data_heap;
-}
-
-F_DATA_HEAP *grow_data_heap(F_DATA_HEAP *data_heap, CELL requested_bytes)
-{
- CELL new_tenured_size = (data_heap->tenured_size * 2) + requested_bytes;
-
- return alloc_data_heap(data_heap->gen_count,
- data_heap->young_size,
- data_heap->aging_size,
- new_tenured_size);
-}
-
-void dealloc_data_heap(F_DATA_HEAP *data_heap)
-{
- dealloc_segment(data_heap->segment);
- free(data_heap->generations);
- free(data_heap->semispaces);
- free(data_heap->allot_markers);
- free(data_heap->cards);
- free(data_heap->decks);
- free(data_heap);
-}
-
-void clear_cards(CELL from, CELL to)
-{
- /* NOTE: reverse order due to heap layout. */
- F_CARD *first_card = ADDR_TO_CARD(data_heap->generations[to].start);
- F_CARD *last_card = ADDR_TO_CARD(data_heap->generations[from].end);
- memset(first_card,0,last_card - first_card);
-}
-
-void clear_decks(CELL from, CELL to)
-{
- /* NOTE: reverse order due to heap layout. */
- F_DECK *first_deck = ADDR_TO_DECK(data_heap->generations[to].start);
- F_DECK *last_deck = ADDR_TO_DECK(data_heap->generations[from].end);
- memset(first_deck,0,last_deck - first_deck);
-}
-
-void clear_allot_markers(CELL from, CELL to)
-{
- /* NOTE: reverse order due to heap layout. */
- F_CARD *first_card = ADDR_TO_ALLOT_MARKER(data_heap->generations[to].start);
- F_CARD *last_card = ADDR_TO_ALLOT_MARKER(data_heap->generations[from].end);
- memset(first_card,INVALID_ALLOT_MARKER,last_card - first_card);
-}
-
-void reset_generation(CELL i)
-{
- F_ZONE *z = (i == NURSERY ? &nursery : &data_heap->generations[i]);
-
- z->here = z->start;
- if(secure_gc)
- 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)
-{
- CELL i;
- for(i = from; i <= to; i++)
- reset_generation(i);
-
- clear_cards(from,to);
- clear_decks(from,to);
- clear_allot_markers(from,to);
-}
-
-void set_data_heap(F_DATA_HEAP *data_heap_)
-{
- data_heap = data_heap_;
- nursery = data_heap->generations[NURSERY];
- init_card_decks();
- clear_cards(NURSERY,TENURED);
- clear_decks(NURSERY,TENURED);
- clear_allot_markers(NURSERY,TENURED);
-}
-
-void 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));
-
- gc_locals_region = alloc_segment(getpagesize());
- gc_locals = gc_locals_region->start - CELLS;
-
- extra_roots_region = alloc_segment(getpagesize());
- extra_roots = extra_roots_region->start - CELLS;
-
- secure_gc = secure_gc_;
-}
-
-/* Size of the object pointed to by a tagged pointer */
-CELL object_size(CELL tagged)
-{
- if(immediate_p(tagged))
- return 0;
- else
- return untagged_object_size(UNTAG(tagged));
-}
-
-/* Size of the object pointed to by an untagged pointer */
-CELL untagged_object_size(CELL 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(CELL pointer)
-{
- F_TUPLE *tuple;
- F_TUPLE_LAYOUT *layout;
-
- switch(untag_header(get(pointer)))
- {
- case ARRAY_TYPE:
- case BIGNUM_TYPE:
- return array_size(array_capacity((F_ARRAY*)pointer));
- case BYTE_ARRAY_TYPE:
- return byte_array_size(
- byte_array_capacity((F_BYTE_ARRAY*)pointer));
- case STRING_TYPE:
- return string_size(string_capacity((F_STRING*)pointer));
- case TUPLE_TYPE:
- tuple = untag_object(pointer);
- layout = untag_object(tuple->layout);
- return tuple_size(layout);
- case QUOTATION_TYPE:
- return sizeof(F_QUOTATION);
- case WORD_TYPE:
- return sizeof(F_WORD);
- case FLOAT_TYPE:
- return sizeof(F_FLOAT);
- case DLL_TYPE:
- return sizeof(F_DLL);
- case ALIEN_TYPE:
- return sizeof(F_ALIEN);
- case WRAPPER_TYPE:
- return sizeof(F_WRAPPER);
- case CALLSTACK_TYPE:
- return callstack_size(
- untag_fixnum_fast(((F_CALLSTACK *)pointer)->length));
- default:
- critical_error("Invalid header",pointer);
- return -1; /* can't happen */
- }
-}
-
-void primitive_size(void)
-{
- box_unsigned_cell(object_size(dpop()));
-}
-
-/* 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(CELL pointer)
-{
- F_TUPLE *tuple;
- F_TUPLE_LAYOUT *layout;
-
- switch(untag_header(get(pointer)))
- {
- /* these objects do not refer to other objects at all */
- case FLOAT_TYPE:
- case BYTE_ARRAY_TYPE:
- case BIGNUM_TYPE:
- case CALLSTACK_TYPE:
- return 0;
- /* these objects have some binary data at the end */
- case WORD_TYPE:
- return sizeof(F_WORD) - CELLS * 3;
- case ALIEN_TYPE:
- return CELLS * 3;
- case DLL_TYPE:
- return CELLS * 2;
- case QUOTATION_TYPE:
- return sizeof(F_QUOTATION) - CELLS * 2;
- case STRING_TYPE:
- return sizeof(F_STRING);
- /* everything else consists entirely of pointers */
- case ARRAY_TYPE:
- return array_size(array_capacity((F_ARRAY*)pointer));
- case TUPLE_TYPE:
- tuple = untag_object(pointer);
- layout = untag_object(tuple->layout);
- return tuple_size(layout);
- case WRAPPER_TYPE:
- return sizeof(F_WRAPPER);
- default:
- critical_error("Invalid header",pointer);
- return -1; /* can't happen */
- }
-}
-
-/* Push memory usage statistics in data heap */
-void primitive_data_room(void)
-{
- dpush(tag_fixnum((data_heap->cards_end - data_heap->cards) >> 10));
- dpush(tag_fixnum((data_heap->decks_end - data_heap->decks) >> 10));
-
- GROWABLE_ARRAY(a);
-
- int gen;
- for(gen = 0; gen < data_heap->gen_count; gen++)
- {
- F_ZONE *z = (gen == NURSERY ? &nursery : &data_heap->generations[gen]);
- GROWABLE_ARRAY_ADD(a,tag_fixnum((z->end - z->here) >> 10));
- GROWABLE_ARRAY_ADD(a,tag_fixnum((z->size) >> 10));
- }
-
- GROWABLE_ARRAY_TRIM(a);
- GROWABLE_ARRAY_DONE(a);
- dpush(a);
-}
-
-/* Disables GC and activates next-object ( -- obj ) primitive */
-void begin_scan(void)
-{
- heap_scan_ptr = data_heap->generations[TENURED].start;
- gc_off = true;
-}
-
-void primitive_begin_scan(void)
-{
- begin_scan();
-}
-
-CELL next_object(void)
-{
- if(!gc_off)
- general_error(ERROR_HEAP_SCAN,F,F,NULL);
-
- CELL value = get(heap_scan_ptr);
- CELL obj = heap_scan_ptr;
- CELL type;
-
- if(heap_scan_ptr >= data_heap->generations[TENURED].here)
- return F;
-
- type = untag_header(value);
- heap_scan_ptr += untagged_object_size(heap_scan_ptr);
-
- return RETAG(obj,type < HEADER_TYPE ? type : OBJECT_TYPE);
-}
-
-/* Push object at heap scan cursor and advance; pushes f when done */
-void primitive_next_object(void)
-{
- dpush(next_object());
-}
-
-/* Re-enables GC */
-void primitive_end_scan(void)
-{
- gc_off = false;
-}
-
-CELL find_all_words(void)
-{
- GROWABLE_ARRAY(words);
-
- begin_scan();
-
- CELL obj;
- while((obj = next_object()) != F)
- {
- if(type_of(obj) == WORD_TYPE)
- GROWABLE_ARRAY_ADD(words,obj);
- }
-
- /* End heap scan */
- gc_off = false;
-
- GROWABLE_ARRAY_TRIM(words);
- GROWABLE_ARRAY_DONE(words);
-
- return words;
-}
--- /dev/null
+#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)
+{
+ z->size = size;
+ z->start = z->here = start;
+ z->end = start + size;
+ return z->end;
+}
+
+void init_card_decks(void)
+{
+ cell start = align(data->seg->start,DECK_SIZE);
+ allot_markers_offset = (cell)data->allot_markers - (start >> CARD_BITS);
+ cards_offset = (cell)data->cards - (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)
+{
+ young_size = align(young_size,DECK_SIZE);
+ aging_size = align(aging_size,DECK_SIZE);
+ tenured_size = align(tenured_size,DECK_SIZE);
+
+ data_heap *data = (data_heap *)safe_malloc(sizeof(data_heap));
+ data->young_size = young_size;
+ data->aging_size = aging_size;
+ data->tenured_size = tenured_size;
+ data->gen_count = gens;
+
+ cell total_size;
+ if(data->gen_count == 2)
+ total_size = young_size + 2 * tenured_size;
+ else if(data->gen_count == 3)
+ total_size = young_size + 2 * aging_size + 2 * tenured_size;
+ else
+ {
+ fatal_error("Invalid number of generations",data->gen_count);
+ return NULL; /* can't happen */
+ }
+
+ total_size += DECK_SIZE;
+
+ data->seg = alloc_segment(total_size);
+
+ data->generations = (zone *)safe_malloc(sizeof(zone) * data->gen_count);
+ data->semispaces = (zone *)safe_malloc(sizeof(zone) * data->gen_count);
+
+ cell cards_size = total_size >> CARD_BITS;
+ data->allot_markers = (cell *)safe_malloc(cards_size);
+ data->allot_markers_end = data->allot_markers + cards_size;
+
+ data->cards = (cell *)safe_malloc(cards_size);
+ data->cards_end = data->cards + cards_size;
+
+ cell decks_size = total_size >> DECK_BITS;
+ data->decks = (cell *)safe_malloc(decks_size);
+ data->decks_end = data->decks + decks_size;
+
+ cell alloter = align(data->seg->start,DECK_SIZE);
+
+ alloter = init_zone(&data->generations[TENURED],tenured_size,alloter);
+ alloter = init_zone(&data->semispaces[TENURED],tenured_size,alloter);
+
+ if(data->gen_count == 3)
+ {
+ alloter = init_zone(&data->generations[AGING],aging_size,alloter);
+ alloter = init_zone(&data->semispaces[AGING],aging_size,alloter);
+ }
+
+ if(data->gen_count >= 2)
+ {
+ alloter = init_zone(&data->generations[NURSERY],young_size,alloter);
+ alloter = init_zone(&data->semispaces[NURSERY],0,alloter);
+ }
+
+ if(data->seg->end - alloter > DECK_SIZE)
+ critical_error("Bug in alloc_data_heap",alloter);
+
+ return data;
+}
+
+data_heap *grow_data_heap(data_heap *data, cell requested_bytes)
+{
+ cell new_tenured_size = (data->tenured_size * 2) + requested_bytes;
+
+ return alloc_data_heap(data->gen_count,
+ data->young_size,
+ data->aging_size,
+ new_tenured_size);
+}
+
+void dealloc_data_heap(data_heap *data)
+{
+ dealloc_segment(data->seg);
+ free(data->generations);
+ free(data->semispaces);
+ free(data->allot_markers);
+ free(data->cards);
+ free(data->decks);
+ free(data);
+}
+
+void clear_cards(cell from, cell to)
+{
+ /* NOTE: reverse order due to heap layout. */
+ card *first_card = addr_to_card(data->generations[to].start);
+ card *last_card = addr_to_card(data->generations[from].end);
+ memset(first_card,0,last_card - first_card);
+}
+
+void clear_decks(cell from, cell to)
+{
+ /* NOTE: reverse order due to heap layout. */
+ card_deck *first_deck = addr_to_deck(data->generations[to].start);
+ card_deck *last_deck = addr_to_deck(data->generations[from].end);
+ memset(first_deck,0,last_deck - first_deck);
+}
+
+void 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);
+ card *last_card = addr_to_allot_marker((object *)data->generations[from].end);
+ memset(first_card,INVALID_ALLOT_MARKER,last_card - first_card);
+}
+
+void reset_generation(cell i)
+{
+ zone *z = (i == NURSERY ? &nursery : &data->generations[i]);
+
+ z->here = z->start;
+ if(secure_gc)
+ 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)
+{
+ cell i;
+ for(i = from; i <= to; i++)
+ reset_generation(i);
+
+ clear_cards(from,to);
+ clear_decks(from,to);
+ clear_allot_markers(from,to);
+}
+
+void set_data_heap(data_heap *data_)
+{
+ data = data_;
+ nursery = data->generations[NURSERY];
+ init_card_decks();
+ clear_cards(NURSERY,TENURED);
+ clear_decks(NURSERY,TENURED);
+ clear_allot_markers(NURSERY,TENURED);
+}
+
+void 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));
+
+ gc_locals_region = alloc_segment(getpagesize());
+ gc_locals = gc_locals_region->start - sizeof(cell);
+
+ gc_bignums_region = alloc_segment(getpagesize());
+ gc_bignums = gc_bignums_region->start - sizeof(cell);
+
+ secure_gc = secure_gc_;
+
+ init_data_gc();
+}
+
+/* Size of the object pointed to by a tagged pointer */
+cell object_size(cell tagged)
+{
+ if(immediate_p(tagged))
+ return 0;
+ else
+ return untagged_object_size(untag<object>(tagged));
+}
+
+/* Size of the object pointed to by an untagged pointer */
+cell 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)
+{
+ switch(pointer->h.hi_tag())
+ {
+ case ARRAY_TYPE:
+ return array_size((array*)pointer);
+ case BIGNUM_TYPE:
+ return array_size((bignum*)pointer);
+ case BYTE_ARRAY_TYPE:
+ return array_size((byte_array*)pointer);
+ case STRING_TYPE:
+ return string_size(string_capacity((string*)pointer));
+ case TUPLE_TYPE:
+ return tuple_size(untag<tuple_layout>(((tuple *)pointer)->layout));
+ case QUOTATION_TYPE:
+ return sizeof(quotation);
+ case WORD_TYPE:
+ return sizeof(word);
+ case FLOAT_TYPE:
+ return sizeof(boxed_float);
+ case DLL_TYPE:
+ return sizeof(dll);
+ case ALIEN_TYPE:
+ return sizeof(alien);
+ case WRAPPER_TYPE:
+ return sizeof(wrapper);
+ case CALLSTACK_TYPE:
+ return callstack_size(untag_fixnum(((callstack *)pointer)->length));
+ default:
+ critical_error("Invalid header",(cell)pointer);
+ return -1; /* can't happen */
+ }
+}
+
+PRIMITIVE(size)
+{
+ box_unsigned_cell(object_size(dpop()));
+}
+
+/* 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)
+{
+ switch(pointer->h.hi_tag())
+ {
+ /* these objects do not refer to other objects at all */
+ case FLOAT_TYPE:
+ case BYTE_ARRAY_TYPE:
+ case BIGNUM_TYPE:
+ case CALLSTACK_TYPE:
+ return 0;
+ /* these objects have some binary data at the end */
+ case WORD_TYPE:
+ return sizeof(word) - sizeof(cell) * 3;
+ case ALIEN_TYPE:
+ return sizeof(cell) * 3;
+ case DLL_TYPE:
+ return sizeof(cell) * 2;
+ case QUOTATION_TYPE:
+ return sizeof(quotation) - sizeof(cell) * 2;
+ case STRING_TYPE:
+ return sizeof(string);
+ /* everything else consists entirely of pointers */
+ case ARRAY_TYPE:
+ return array_size<array>(array_capacity((array*)pointer));
+ case TUPLE_TYPE:
+ return tuple_size(untag<tuple_layout>(((tuple *)pointer)->layout));
+ case WRAPPER_TYPE:
+ return sizeof(wrapper);
+ default:
+ critical_error("Invalid header",(cell)pointer);
+ return -1; /* can't happen */
+ }
+}
+
+/* Push memory usage statistics in data heap */
+PRIMITIVE(data_room)
+{
+ dpush(tag_fixnum((data->cards_end - data->cards) >> 10));
+ dpush(tag_fixnum((data->decks_end - data->decks) >> 10));
+
+ growable_array a;
+
+ cell gen;
+ for(gen = 0; gen < data->gen_count; gen++)
+ {
+ zone *z = (gen == NURSERY ? &nursery : &data->generations[gen]);
+ a.add(tag_fixnum((z->end - z->here) >> 10));
+ a.add(tag_fixnum((z->size) >> 10));
+ }
+
+ a.trim();
+ 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;
+
+/* Disables GC and activates next-object ( -- obj ) primitive */
+void begin_scan(void)
+{
+ heap_scan_ptr = data->generations[TENURED].start;
+ gc_off = true;
+}
+
+PRIMITIVE(begin_scan)
+{
+ begin_scan();
+}
+
+cell next_object(void)
+{
+ if(!gc_off)
+ general_error(ERROR_HEAP_SCAN,F,F,NULL);
+
+ if(heap_scan_ptr >= data->generations[TENURED].here)
+ return F;
+
+ object *obj = (object *)heap_scan_ptr;
+ heap_scan_ptr += untagged_object_size(obj);
+ return tag_dynamic(obj);
+}
+
+/* Push object at heap scan cursor and advance; pushes f when done */
+PRIMITIVE(next_object)
+{
+ dpush(next_object());
+}
+
+/* Re-enables GC */
+PRIMITIVE(end_scan)
+{
+ gc_off = false;
+}
+
+cell find_all_words(void)
+{
+ growable_array words;
+
+ begin_scan();
+
+ cell obj;
+ while((obj = next_object()) != F)
+ {
+ if(tagged<object>(obj).type_p(WORD_TYPE))
+ words.add(obj);
+ }
+
+ /* End heap scan */
+ gc_off = false;
+
+ words.trim();
+ return words.elements.value();
+}
+
+}
+++ /dev/null
-/* Set by the -securegc command line argument */
-bool secure_gc;
-
-/* generational copying GC divides memory into zones */
-typedef struct {
- /* allocation pointer is 'here'; its offset is hardcoded in the
- compiler backends*/
- CELL start;
- CELL here;
- CELL size;
- CELL end;
-} F_ZONE;
-
-typedef struct {
- F_SEGMENT *segment;
-
- CELL young_size;
- CELL aging_size;
- CELL tenured_size;
-
- CELL gen_count;
-
- F_ZONE *generations;
- F_ZONE* semispaces;
-
- CELL *allot_markers;
- CELL *allot_markers_end;
-
- CELL *cards;
- CELL *cards_end;
-
- CELL *decks;
- CELL *decks_end;
-} F_DATA_HEAP;
-
-F_DATA_HEAP *data_heap;
-
-/* the 0th generation is where new objects are allocated. */
-#define NURSERY 0
-/* where objects hang around */
-#define AGING (data_heap->gen_count-2)
-#define HAVE_AGING_P (data_heap->gen_count>2)
-/* the oldest generation */
-#define TENURED (data_heap->gen_count-1)
-
-#define MIN_GEN_COUNT 1
-#define MAX_GEN_COUNT 3
-
-/* new objects are allocated here */
-DLLEXPORT F_ZONE nursery;
-
-INLINE bool in_zone(F_ZONE *z, CELL pointer)
-{
- return pointer >= z->start && pointer < z->end;
-}
-
-CELL init_zone(F_ZONE *z, CELL size, CELL base);
-
-void init_card_decks(void);
-
-F_DATA_HEAP *grow_data_heap(F_DATA_HEAP *data_heap, CELL requested_bytes);
-
-void dealloc_data_heap(F_DATA_HEAP *data_heap);
-
-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(F_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 */
-F_SEGMENT *alloc_segment(CELL size);
-void dealloc_segment(F_SEGMENT *block);
-
-CELL untagged_object_size(CELL pointer);
-CELL unaligned_object_size(CELL pointer);
-CELL object_size(CELL pointer);
-CELL binary_payload_start(CELL pointer);
-
-void begin_scan(void);
-CELL next_object(void);
-
-void primitive_data_room(void);
-void primitive_size(void);
-
-void primitive_begin_scan(void);
-void primitive_next_object(void);
-void primitive_end_scan(void);
-
-/* A heap walk allows useful things to be done, like finding all
-references to an object for debugging purposes. */
-CELL heap_scan_ptr;
-
-/* GC is off during heap walking */
-bool gc_off;
-
-INLINE bool in_data_heap_p(CELL ptr)
-{
- return (ptr >= data_heap->segment->start
- && ptr <= data_heap->segment->end);
-}
-
-INLINE void *allot_zone(F_ZONE *z, CELL a)
-{
- CELL h = z->here;
- z->here = h + align8(a);
- return (void*)h;
-}
-
-CELL find_all_words(void);
-
-/* 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 void do_slots(CELL obj, void (* iter)(CELL *))
-{
- CELL scan = obj;
- CELL payload_start = binary_payload_start(obj);
- CELL end = obj + payload_start;
-
- scan += CELLS;
-
- while(scan < end)
- {
- iter((CELL *)scan);
- scan += CELLS;
- }
-}
-
--- /dev/null
+namespace factor
+{
+
+/* Set by the -securegc command line argument */
+extern bool secure_gc;
+
+/* generational copying GC divides memory into zones */
+struct zone {
+ /* allocation pointer is 'here'; its offset is hardcoded in the
+ compiler backends */
+ cell start;
+ cell here;
+ cell size;
+ cell end;
+};
+
+struct data_heap {
+ segment *seg;
+
+ cell young_size;
+ cell aging_size;
+ cell tenured_size;
+
+ cell gen_count;
+
+ zone *generations;
+ zone *semispaces;
+
+ cell *allot_markers;
+ cell *allot_markers_end;
+
+ cell *cards;
+ cell *cards_end;
+
+ cell *decks;
+ cell *decks_end;
+};
+
+extern data_heap *data;
+
+/* the 0th generation is where new objects are allocated. */
+#define NURSERY 0
+/* where objects hang around */
+#define AGING (data->gen_count-2)
+#define HAVE_AGING_P (data->gen_count>2)
+/* the oldest generation */
+#define TENURED (data->gen_count-1)
+
+#define MIN_GEN_COUNT 1
+#define MAX_GEN_COUNT 3
+
+inline static bool in_zone(zone *z, object *pointer)
+{
+ return (cell)pointer >= z->start && (cell)pointer < z->end;
+}
+
+cell init_zone(zone *z, cell size, cell base);
+
+void init_card_decks(void);
+
+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);
+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);
+cell next_object(void);
+
+PRIMITIVE(data_room);
+PRIMITIVE(size);
+
+PRIMITIVE(begin_scan);
+PRIMITIVE(next_object);
+PRIMITIVE(end_scan);
+
+/* GC is off during heap walking */
+extern bool gc_off;
+
+cell find_all_words(void);
+
+/* 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;
+++ /dev/null
-#include "master.h"
-
-static bool full_output;
-
-void print_chars(F_STRING* str)
-{
- CELL i;
- for(i = 0; i < string_capacity(str); i++)
- putchar(string_nth(str,i));
-}
-
-void print_word(F_WORD* word, CELL nesting)
-{
-
- if(type_of(word->vocabulary) == STRING_TYPE)
- {
- print_chars(untag_string(word->vocabulary));
- print_string(":");
- }
-
- if(type_of(word->name) == STRING_TYPE)
- print_chars(untag_string(word->name));
- else
- {
- print_string("#<not a string: ");
- print_nested_obj(word->name,nesting);
- print_string(">");
- }
-}
-
-void print_factor_string(F_STRING* str)
-{
- putchar('"');
- print_chars(str);
- putchar('"');
-}
-
-void print_array(F_ARRAY* array, CELL nesting)
-{
- CELL length = array_capacity(array);
- CELL i;
- bool trimmed;
-
- if(length > 10 && !full_output)
- {
- trimmed = true;
- length = 10;
- }
- else
- trimmed = false;
-
- for(i = 0; i < length; i++)
- {
- print_string(" ");
- print_nested_obj(array_nth(array,i),nesting);
- }
-
- if(trimmed)
- print_string("...");
-}
-
-void print_tuple(F_TUPLE* tuple, CELL nesting)
-{
- F_TUPLE_LAYOUT *layout = untag_object(tuple->layout);
- CELL length = to_fixnum(layout->size);
-
- print_string(" ");
- print_nested_obj(layout->class,nesting);
-
- CELL i;
- bool trimmed;
-
- if(length > 10 && !full_output)
- {
- trimmed = true;
- length = 10;
- }
- else
- trimmed = false;
-
- for(i = 0; i < length; i++)
- {
- print_string(" ");
- print_nested_obj(tuple_nth(tuple,i),nesting);
- }
-
- if(trimmed)
- print_string("...");
-}
-
-void print_nested_obj(CELL obj, F_FIXNUM nesting)
-{
- if(nesting <= 0 && !full_output)
- {
- print_string(" ... ");
- return;
- }
-
- F_QUOTATION *quot;
-
- switch(type_of(obj))
- {
- case FIXNUM_TYPE:
- print_fixnum(untag_fixnum_fast(obj));
- break;
- case WORD_TYPE:
- print_word(untag_word(obj),nesting - 1);
- break;
- case STRING_TYPE:
- print_factor_string(untag_string(obj));
- break;
- case F_TYPE:
- print_string("f");
- break;
- case TUPLE_TYPE:
- print_string("T{");
- print_tuple(untag_object(obj),nesting - 1);
- print_string(" }");
- break;
- case ARRAY_TYPE:
- print_string("{");
- print_array(untag_object(obj),nesting - 1);
- print_string(" }");
- break;
- case QUOTATION_TYPE:
- print_string("[");
- quot = untag_object(obj);
- print_array(untag_object(quot->array),nesting - 1);
- print_string(" ]");
- break;
- default:
- print_string("#<type "); print_cell(type_of(obj)); print_string(" @ "); print_cell_hex(obj); print_string(">");
- break;
- }
-}
-
-void print_obj(CELL obj)
-{
- print_nested_obj(obj,10);
-}
-
-void print_objects(CELL start, CELL end)
-{
- for(; start <= end; start += CELLS)
- {
- print_obj(get(start));
- nl();
- }
-}
-
-void print_datastack(void)
-{
- print_string("==== DATA STACK:\n");
- print_objects(ds_bot,ds);
-}
-
-void print_retainstack(void)
-{
- print_string("==== RETAIN STACK:\n");
- print_objects(rs_bot,rs);
-}
-
-void print_stack_frame(F_STACK_FRAME *frame)
-{
- print_obj(frame_executing(frame));
- print_string("\n");
- print_obj(frame_scan(frame));
- print_string("\n");
- print_cell_hex((CELL)frame_executing(frame));
- print_string(" ");
- print_cell_hex((CELL)frame->xt);
- print_string("\n");
-}
-
-void print_callstack(void)
-{
- 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);
-}
-
-void dump_cell(CELL cell)
-{
- print_cell_hex_pad(cell); print_string(": ");
-
- cell = get(cell);
-
- print_cell_hex_pad(cell); print_string(" tag "); print_cell(TAG(cell));
-
- switch(TAG(cell))
- {
- case OBJECT_TYPE:
- case BIGNUM_TYPE:
- case FLOAT_TYPE:
- if(cell == F)
- print_string(" -- F");
- else if(cell < TYPE_COUNT<<TAG_BITS)
- {
- print_string(" -- possible header: ");
- print_cell(cell>>TAG_BITS);
- }
- else if(cell >= data_heap->segment->start
- && cell < data_heap->segment->end)
- {
- CELL header = get(UNTAG(cell));
- CELL type = header>>TAG_BITS;
- print_string(" -- object; ");
- if(TAG(header) == 0 && type < TYPE_COUNT)
- {
- print_string(" type "); print_cell(type);
- }
- else
- print_string(" header corrupt");
- }
- break;
- }
-
- nl();
-}
-
-void dump_memory(CELL from, CELL to)
-{
- from = UNTAG(from);
-
- for(; from <= to; from += CELLS)
- dump_cell(from);
-}
-
-void dump_zone(F_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)
-{
- CELL i;
-
- print_string("Nursery: ");
- dump_zone(&nursery);
-
- for(i = 1; i < data_heap->gen_count; i++)
- {
- print_string("Generation "); print_cell(i); print_string(": ");
- dump_zone(&data_heap->generations[i]);
- }
-
- for(i = 0; i < data_heap->gen_count; i++)
- {
- print_string("Semispace "); print_cell(i); print_string(": ");
- dump_zone(&data_heap->semispaces[i]);
- }
-
- print_string("Cards: base=");
- print_cell((CELL)data_heap->cards);
- print_string(", size=");
- print_cell((CELL)(data_heap->cards_end - data_heap->cards));
- nl();
-}
-
-void dump_objects(F_FIXNUM type)
-{
- gc();
- begin_scan();
-
- CELL obj;
- while((obj = next_object()) != F)
- {
- if(type == -1 || type_of(obj) == type)
- {
- print_cell_hex_pad(obj);
- print_string(" ");
- print_nested_obj(obj,2);
- nl();
- }
- }
-
- /* end scan */
- gc_off = false;
-}
-
-CELL look_for;
-CELL obj;
-
-void find_data_references_step(CELL *scan)
-{
- if(look_for == *scan)
- {
- print_cell_hex_pad(obj);
- print_string(" ");
- print_nested_obj(obj,2);
- nl();
- }
-}
-
-void 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);
-
- /* end scan */
- gc_off = false;
-}
-
-/* Dump all code blocks for debugging */
-void dump_code_heap(void)
-{
- CELL reloc_size = 0, literal_size = 0;
-
- F_BLOCK *scan = first_block(&code_heap);
-
- while(scan)
- {
- char *status;
- switch(scan->status)
- {
- case B_FREE:
- status = "free";
- break;
- case B_ALLOCATED:
- reloc_size += object_size(((F_CODE_BLOCK *)scan)->relocation);
- literal_size += object_size(((F_CODE_BLOCK *)scan)->literals);
- status = "allocated";
- break;
- case B_MARKED:
- reloc_size += object_size(((F_CODE_BLOCK *)scan)->relocation);
- literal_size += object_size(((F_CODE_BLOCK *)scan)->literals);
- status = "marked";
- break;
- default:
- status = "invalid";
- break;
- }
-
- print_cell_hex((CELL)scan); print_string(" ");
- print_cell_hex(scan->size); print_string(" ");
- print_string(status); print_string("\n");
-
- scan = next_block(&code_heap,scan);
- }
-
- print_cell(reloc_size); print_string(" bytes of relocation data\n");
- print_cell(literal_size); print_string(" bytes of literal data\n");
-}
-
-void factorbug(void)
-{
- if(fep_disabled)
- {
- print_string("Low level debugger disabled\n");
- exit(1);
- }
-
- /* open_console(); */
-
- print_string("Starting low level debugger...\n");
- print_string(" Basic commands:\n");
- print_string("q -- continue executing Factor - NOT SAFE\n");
- print_string("im -- save image to fep.image\n");
- print_string("x -- exit Factor\n");
- print_string(" Advanced commands:\n");
- print_string("d <addr> <count> -- dump memory\n");
- print_string("u <addr> -- dump object at tagged <addr>\n");
- print_string(". <addr> -- print object at tagged <addr>\n");
- print_string("t -- toggle output trimming\n");
- print_string("s r -- dump data, retain stacks\n");
- print_string(".s .r .c -- print data, retain, call stacks\n");
- print_string("e -- dump environment\n");
- print_string("g -- dump generations\n");
- print_string("card <addr> -- print card containing address\n");
- print_string("addr <card> -- print address containing card\n");
- print_string("data -- data heap dump\n");
- print_string("words -- words dump\n");
- print_string("tuples -- tuples dump\n");
- print_string("refs <addr> -- find data heap references to object\n");
- print_string("push <addr> -- push object on data stack - NOT SAFE\n");
- print_string("code -- code heap dump\n");
-
- bool seen_command = false;
-
- for(;;)
- {
- char cmd[1024];
-
- print_string("READY\n");
- fflush(stdout);
-
- if(scanf("%1000s",cmd) <= 0)
- {
- if(!seen_command)
- {
- /* If we exit with an EOF immediately, then
- dump stacks. This is useful for builder and
- other cases where Factor is run with stdin
- redirected to /dev/null */
- fep_disabled = true;
-
- print_datastack();
- print_retainstack();
- print_callstack();
- }
-
- exit(1);
- }
-
- seen_command = true;
-
- if(strcmp(cmd,"d") == 0)
- {
- CELL addr = read_cell_hex();
- if(scanf(" ") < 0) break;
- CELL count = read_cell_hex();
- dump_memory(addr,addr+count);
- }
- else if(strcmp(cmd,"u") == 0)
- {
- CELL addr = read_cell_hex();
- CELL count = object_size(addr);
- dump_memory(addr,addr+count);
- }
- else if(strcmp(cmd,".") == 0)
- {
- CELL addr = read_cell_hex();
- print_obj(addr);
- print_string("\n");
- }
- else if(strcmp(cmd,"t") == 0)
- full_output = !full_output;
- else if(strcmp(cmd,"s") == 0)
- dump_memory(ds_bot,ds);
- else if(strcmp(cmd,"r") == 0)
- dump_memory(rs_bot,rs);
- else if(strcmp(cmd,".s") == 0)
- print_datastack();
- else if(strcmp(cmd,".r") == 0)
- print_retainstack();
- else if(strcmp(cmd,".c") == 0)
- print_callstack();
- else if(strcmp(cmd,"e") == 0)
- {
- int i;
- for(i = 0; i < USER_ENV; i++)
- dump_cell((CELL)&userenv[i]);
- }
- else if(strcmp(cmd,"g") == 0)
- dump_generations();
- else if(strcmp(cmd,"card") == 0)
- {
- CELL addr = read_cell_hex();
- print_cell_hex((CELL)ADDR_TO_CARD(addr));
- nl();
- }
- else if(strcmp(cmd,"addr") == 0)
- {
- CELL card = read_cell_hex();
- print_cell_hex((CELL)CARD_TO_ADDR(card));
- nl();
- }
- else if(strcmp(cmd,"q") == 0)
- return;
- else if(strcmp(cmd,"x") == 0)
- exit(1);
- else if(strcmp(cmd,"im") == 0)
- save_image(STRING_LITERAL("fep.image"));
- else if(strcmp(cmd,"data") == 0)
- dump_objects(-1);
- else if(strcmp(cmd,"refs") == 0)
- {
- CELL addr = read_cell_hex();
- print_string("Data heap references:\n");
- find_data_references(addr);
- nl();
- }
- else if(strcmp(cmd,"words") == 0)
- dump_objects(WORD_TYPE);
- else if(strcmp(cmd,"tuples") == 0)
- dump_objects(TUPLE_TYPE);
- else if(strcmp(cmd,"push") == 0)
- {
- CELL addr = read_cell_hex();
- dpush(addr);
- }
- else if(strcmp(cmd,"code") == 0)
- dump_code_heap();
- else
- print_string("unknown command\n");
- }
-}
-
-void primitive_die(void)
-{
- 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();
-}
--- /dev/null
+#include "master.hpp"
+
+namespace factor
+{
+
+static bool fep_disabled;
+static bool full_output;
+
+void 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)
+{
+ if(tagged<object>(word->vocabulary).type_p(STRING_TYPE))
+ {
+ print_chars(untag<string>(word->vocabulary));
+ print_string(":");
+ }
+
+ if(tagged<object>(word->name).type_p(STRING_TYPE))
+ print_chars(untag<string>(word->name));
+ else
+ {
+ print_string("#<not a string: ");
+ print_nested_obj(word->name,nesting);
+ print_string(">");
+ }
+}
+
+void print_factor_string(string* str)
+{
+ putchar('"');
+ print_chars(str);
+ putchar('"');
+}
+
+void print_array(array* array, cell nesting)
+{
+ cell length = array_capacity(array);
+ cell i;
+ bool trimmed;
+
+ if(length > 10 && !full_output)
+ {
+ trimmed = true;
+ length = 10;
+ }
+ else
+ trimmed = false;
+
+ for(i = 0; i < length; i++)
+ {
+ print_string(" ");
+ print_nested_obj(array_nth(array,i),nesting);
+ }
+
+ if(trimmed)
+ print_string("...");
+}
+
+void print_tuple(tuple *tuple, cell nesting)
+{
+ tuple_layout *layout = untag<tuple_layout>(tuple->layout);
+ cell length = to_fixnum(layout->size);
+
+ print_string(" ");
+ print_nested_obj(layout->klass,nesting);
+
+ cell i;
+ bool trimmed;
+
+ if(length > 10 && !full_output)
+ {
+ trimmed = true;
+ length = 10;
+ }
+ else
+ trimmed = false;
+
+ for(i = 0; i < length; i++)
+ {
+ print_string(" ");
+ print_nested_obj(tuple->data()[i],nesting);
+ }
+
+ if(trimmed)
+ print_string("...");
+}
+
+void print_nested_obj(cell obj, fixnum nesting)
+{
+ if(nesting <= 0 && !full_output)
+ {
+ print_string(" ... ");
+ return;
+ }
+
+ quotation *quot;
+
+ switch(tagged<object>(obj).type())
+ {
+ case FIXNUM_TYPE:
+ print_fixnum(untag_fixnum(obj));
+ break;
+ case WORD_TYPE:
+ print_word(untag<word>(obj),nesting - 1);
+ break;
+ case STRING_TYPE:
+ print_factor_string(untag<string>(obj));
+ break;
+ case F_TYPE:
+ print_string("f");
+ break;
+ case TUPLE_TYPE:
+ print_string("T{");
+ print_tuple(untag<tuple>(obj),nesting - 1);
+ print_string(" }");
+ break;
+ case ARRAY_TYPE:
+ print_string("{");
+ print_array(untag<array>(obj),nesting - 1);
+ print_string(" }");
+ break;
+ case QUOTATION_TYPE:
+ print_string("[");
+ quot = untag<quotation>(obj);
+ print_array(untag<array>(quot->array),nesting - 1);
+ print_string(" ]");
+ break;
+ default:
+ print_string("#<type ");
+ print_cell(tagged<object>(obj).type());
+ print_string(" @ ");
+ print_cell_hex(obj);
+ print_string(">");
+ break;
+ }
+}
+
+void print_obj(cell obj)
+{
+ print_nested_obj(obj,10);
+}
+
+void print_objects(cell *start, cell *end)
+{
+ for(; start <= end; start++)
+ {
+ print_obj(*start);
+ nl();
+ }
+}
+
+void print_datastack(void)
+{
+ print_string("==== DATA STACK:\n");
+ print_objects((cell *)ds_bot,(cell *)ds);
+}
+
+void print_retainstack(void)
+{
+ print_string("==== RETAIN STACK:\n");
+ print_objects((cell *)rs_bot,(cell *)rs);
+}
+
+void print_stack_frame(stack_frame *frame)
+{
+ print_obj(frame_executing(frame));
+ print_string("\n");
+ print_obj(frame_scan(frame));
+ print_string("\n");
+ print_cell_hex((cell)frame_executing(frame));
+ print_string(" ");
+ print_cell_hex((cell)frame->xt);
+ print_string("\n");
+}
+
+void print_callstack(void)
+{
+ 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);
+}
+
+void dump_cell(cell x)
+{
+ print_cell_hex_pad(x); print_string(": ");
+ x = *(cell *)x;
+ print_cell_hex_pad(x); print_string(" tag "); print_cell(TAG(x));
+ nl();
+}
+
+void dump_memory(cell from, cell to)
+{
+ from = UNTAG(from);
+
+ for(; from <= to; from += sizeof(cell))
+ dump_cell(from);
+}
+
+void 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)
+{
+ cell i;
+
+ print_string("Nursery: ");
+ dump_zone(&nursery);
+
+ for(i = 1; i < data->gen_count; i++)
+ {
+ print_string("Generation "); print_cell(i); print_string(": ");
+ dump_zone(&data->generations[i]);
+ }
+
+ for(i = 0; i < data->gen_count; i++)
+ {
+ print_string("Semispace "); print_cell(i); print_string(": ");
+ dump_zone(&data->semispaces[i]);
+ }
+
+ print_string("Cards: base=");
+ print_cell((cell)data->cards);
+ print_string(", size=");
+ print_cell((cell)(data->cards_end - data->cards));
+ nl();
+}
+
+void dump_objects(cell type)
+{
+ gc();
+ begin_scan();
+
+ cell obj;
+ while((obj = next_object()) != F)
+ {
+ if(type == TYPE_COUNT || tagged<object>(obj).type_p(type))
+ {
+ print_cell_hex_pad(obj);
+ print_string(" ");
+ print_nested_obj(obj,2);
+ nl();
+ }
+ }
+
+ /* end scan */
+ gc_off = false;
+}
+
+cell look_for;
+cell obj;
+
+void find_data_references_step(cell *scan)
+{
+ if(look_for == *scan)
+ {
+ print_cell_hex_pad(obj);
+ print_string(" ");
+ print_nested_obj(obj,2);
+ nl();
+ }
+}
+
+void 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);
+
+ /* end scan */
+ gc_off = false;
+}
+
+/* Dump all code blocks for debugging */
+void dump_code_heap(void)
+{
+ cell reloc_size = 0, literal_size = 0;
+
+ heap_block *scan = first_block(&code);
+
+ while(scan)
+ {
+ char *status;
+ switch(scan->status)
+ {
+ case B_FREE:
+ status = "free";
+ break;
+ case B_ALLOCATED:
+ reloc_size += object_size(((code_block *)scan)->relocation);
+ literal_size += object_size(((code_block *)scan)->literals);
+ status = "allocated";
+ break;
+ case B_MARKED:
+ reloc_size += object_size(((code_block *)scan)->relocation);
+ literal_size += object_size(((code_block *)scan)->literals);
+ status = "marked";
+ break;
+ default:
+ status = "invalid";
+ break;
+ }
+
+ print_cell_hex((cell)scan); print_string(" ");
+ print_cell_hex(scan->size); print_string(" ");
+ print_string(status); print_string("\n");
+
+ scan = next_block(&code,scan);
+ }
+
+ print_cell(reloc_size); print_string(" bytes of relocation data\n");
+ print_cell(literal_size); print_string(" bytes of literal data\n");
+}
+
+void factorbug(void)
+{
+ if(fep_disabled)
+ {
+ print_string("Low level debugger disabled\n");
+ exit(1);
+ }
+
+ /* open_console(); */
+
+ print_string("Starting low level debugger...\n");
+ print_string(" Basic commands:\n");
+ print_string("q -- continue executing Factor - NOT SAFE\n");
+ print_string("im -- save image to fep.image\n");
+ print_string("x -- exit Factor\n");
+ print_string(" Advanced commands:\n");
+ print_string("d <addr> <count> -- dump memory\n");
+ print_string("u <addr> -- dump object at tagged <addr>\n");
+ print_string(". <addr> -- print object at tagged <addr>\n");
+ print_string("t -- toggle output trimming\n");
+ print_string("s r -- dump data, retain stacks\n");
+ print_string(".s .r .c -- print data, retain, call stacks\n");
+ print_string("e -- dump environment\n");
+ print_string("g -- dump generations\n");
+ print_string("card <addr> -- print card containing address\n");
+ print_string("addr <card> -- print address containing card\n");
+ print_string("data -- data heap dump\n");
+ print_string("words -- words dump\n");
+ print_string("tuples -- tuples dump\n");
+ print_string("refs <addr> -- find data heap references to object\n");
+ print_string("push <addr> -- push object on data stack - NOT SAFE\n");
+ print_string("code -- code heap dump\n");
+
+ bool seen_command = false;
+
+ for(;;)
+ {
+ char cmd[1024];
+
+ print_string("READY\n");
+ fflush(stdout);
+
+ if(scanf("%1000s",cmd) <= 0)
+ {
+ if(!seen_command)
+ {
+ /* If we exit with an EOF immediately, then
+ dump stacks. This is useful for builder and
+ other cases where Factor is run with stdin
+ redirected to /dev/null */
+ fep_disabled = true;
+
+ print_datastack();
+ print_retainstack();
+ print_callstack();
+ }
+
+ exit(1);
+ }
+
+ seen_command = true;
+
+ if(strcmp(cmd,"d") == 0)
+ {
+ cell addr = read_cell_hex();
+ if(scanf(" ") < 0) break;
+ cell count = read_cell_hex();
+ dump_memory(addr,addr+count);
+ }
+ else if(strcmp(cmd,"u") == 0)
+ {
+ cell addr = read_cell_hex();
+ cell count = object_size(addr);
+ dump_memory(addr,addr+count);
+ }
+ else if(strcmp(cmd,".") == 0)
+ {
+ cell addr = read_cell_hex();
+ print_obj(addr);
+ print_string("\n");
+ }
+ else if(strcmp(cmd,"t") == 0)
+ full_output = !full_output;
+ else if(strcmp(cmd,"s") == 0)
+ dump_memory(ds_bot,ds);
+ else if(strcmp(cmd,"r") == 0)
+ dump_memory(rs_bot,rs);
+ else if(strcmp(cmd,".s") == 0)
+ print_datastack();
+ else if(strcmp(cmd,".r") == 0)
+ print_retainstack();
+ else if(strcmp(cmd,".c") == 0)
+ print_callstack();
+ else if(strcmp(cmd,"e") == 0)
+ {
+ int i;
+ for(i = 0; i < USER_ENV; i++)
+ dump_cell((cell)&userenv[i]);
+ }
+ else if(strcmp(cmd,"g") == 0)
+ dump_generations();
+ else if(strcmp(cmd,"card") == 0)
+ {
+ cell addr = read_cell_hex();
+ print_cell_hex((cell)addr_to_card(addr));
+ nl();
+ }
+ else if(strcmp(cmd,"addr") == 0)
+ {
+ card *ptr = (card *)read_cell_hex();
+ print_cell_hex(card_to_addr(ptr));
+ nl();
+ }
+ else if(strcmp(cmd,"q") == 0)
+ return;
+ else if(strcmp(cmd,"x") == 0)
+ exit(1);
+ else if(strcmp(cmd,"im") == 0)
+ save_image(STRING_LITERAL("fep.image"));
+ else if(strcmp(cmd,"data") == 0)
+ dump_objects(TYPE_COUNT);
+ else if(strcmp(cmd,"refs") == 0)
+ {
+ cell addr = read_cell_hex();
+ print_string("Data heap references:\n");
+ find_data_references(addr);
+ nl();
+ }
+ else if(strcmp(cmd,"words") == 0)
+ dump_objects(WORD_TYPE);
+ else if(strcmp(cmd,"tuples") == 0)
+ dump_objects(TUPLE_TYPE);
+ else if(strcmp(cmd,"push") == 0)
+ {
+ cell addr = read_cell_hex();
+ dpush(addr);
+ }
+ else if(strcmp(cmd,"code") == 0)
+ dump_code_heap();
+ else
+ print_string("unknown command\n");
+ }
+}
+
+PRIMITIVE(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();
+}
+
+}
+++ /dev/null
-void print_obj(CELL obj);
-void print_nested_obj(CELL obj, F_FIXNUM nesting);
-void dump_generations(void);
-void factorbug(void);
-void dump_zone(F_ZONE *z);
-
-bool fep_disabled;
-
-void primitive_die(void);
--- /dev/null
+namespace factor
+{
+
+void print_obj(cell obj);
+void print_nested_obj(cell obj, fixnum nesting);
+void dump_generations(void);
+void factorbug(void);
+void dump_zone(zone *z);
+
+PRIMITIVE(die);
+
+}
+++ /dev/null
-#include "master.h"
-
-static CELL search_lookup_alist(CELL table, CELL class)
-{
- F_ARRAY *pairs = untag_object(table);
- F_FIXNUM index = array_capacity(pairs) - 1;
- while(index >= 0)
- {
- F_ARRAY *pair = untag_object(array_nth(pairs,index));
- if(array_nth(pair,0) == class)
- return array_nth(pair,1);
- else
- index--;
- }
-
- return F;
-}
-
-static CELL search_lookup_hash(CELL table, CELL class, CELL hashcode)
-{
- F_ARRAY *buckets = untag_object(table);
- CELL bucket = array_nth(buckets,hashcode & (array_capacity(buckets) - 1));
- if(type_of(bucket) == WORD_TYPE || bucket == F)
- return bucket;
- else
- return search_lookup_alist(bucket,class);
-}
-
-static CELL nth_superclass(F_TUPLE_LAYOUT *layout, F_FIXNUM echelon)
-{
- CELL *ptr = (CELL *)(layout + 1);
- return ptr[echelon * 2];
-}
-
-static CELL nth_hashcode(F_TUPLE_LAYOUT *layout, F_FIXNUM echelon)
-{
- CELL *ptr = (CELL *)(layout + 1);
- return ptr[echelon * 2 + 1];
-}
-
-static CELL lookup_tuple_method(CELL object, CELL methods)
-{
- F_TUPLE *tuple = untag_object(object);
- F_TUPLE_LAYOUT *layout = untag_object(tuple->layout);
-
- F_ARRAY *echelons = untag_object(methods);
-
- F_FIXNUM echelon = untag_fixnum_fast(layout->echelon);
- F_FIXNUM max_echelon = array_capacity(echelons) - 1;
- if(echelon > max_echelon) echelon = max_echelon;
-
- while(echelon >= 0)
- {
- CELL echelon_methods = array_nth(echelons,echelon);
-
- if(type_of(echelon_methods) == WORD_TYPE)
- return echelon_methods;
- else if(echelon_methods != F)
- {
- CELL class = nth_superclass(layout,echelon);
- CELL hashcode = untag_fixnum_fast(nth_hashcode(layout,echelon));
- CELL result = search_lookup_hash(echelon_methods,class,hashcode);
- if(result != F)
- return result;
- }
-
- echelon--;
- }
-
- critical_error("Cannot find tuple method",methods);
- return F;
-}
-
-static CELL lookup_hi_tag_method(CELL object, CELL methods)
-{
- F_ARRAY *hi_tag_methods = untag_object(methods);
- CELL tag = hi_tag(object) - HEADER_TYPE;
-#ifdef FACTOR_DEBUG
- assert(tag < TYPE_COUNT - HEADER_TYPE);
-#endif
- return array_nth(hi_tag_methods,tag);
-}
-
-static CELL lookup_hairy_method(CELL object, CELL methods)
-{
- CELL method = array_nth(untag_object(methods),TAG(object));
- if(type_of(method) == WORD_TYPE)
- return method;
- else
- {
- switch(TAG(object))
- {
- case TUPLE_TYPE:
- return lookup_tuple_method(object,method);
- break;
- case OBJECT_TYPE:
- return lookup_hi_tag_method(object,method);
- break;
- default:
- critical_error("Bad methods array",methods);
- return -1;
- }
- }
-}
-
-CELL lookup_method(CELL object, CELL methods)
-{
- if(!HI_TAG_OR_TUPLE_P(object))
- return array_nth(untag_object(methods),TAG(object));
- else
- return lookup_hairy_method(object,methods);
-}
-
-void primitive_lookup_method(void)
-{
- CELL methods = dpop();
- CELL object = dpop();
- dpush(lookup_method(object,methods));
-}
-
-CELL object_class(CELL object)
-{
- if(!HI_TAG_OR_TUPLE_P(object))
- return tag_fixnum(TAG(object));
- else
- return get(HI_TAG_HEADER(object));
-}
-
-static CELL method_cache_hashcode(CELL class, F_ARRAY *array)
-{
- CELL capacity = (array_capacity(array) >> 1) - 1;
- return ((class >> TAG_BITS) & capacity) << 1;
-}
-
-static void update_method_cache(CELL cache, CELL class, CELL method)
-{
- F_ARRAY *array = untag_object(cache);
- CELL hashcode = method_cache_hashcode(class,array);
- set_array_nth(array,hashcode,class);
- set_array_nth(array,hashcode + 1,method);
-}
-
-void primitive_mega_cache_miss(void)
-{
- megamorphic_cache_misses++;
-
- CELL cache = dpop();
- F_FIXNUM index = untag_fixnum_fast(dpop());
- CELL methods = dpop();
-
- CELL object = get(ds - index * CELLS);
- CELL class = object_class(object);
- CELL method = lookup_method(object,methods);
-
- update_method_cache(cache,class,method);
-
- dpush(method);
-}
-
-void primitive_reset_dispatch_stats(void)
-{
- megamorphic_cache_hits = megamorphic_cache_misses = 0;
-}
-
-void primitive_dispatch_stats(void)
-{
- GROWABLE_ARRAY(stats);
- GROWABLE_ARRAY_ADD(stats,allot_cell(megamorphic_cache_hits));
- GROWABLE_ARRAY_ADD(stats,allot_cell(megamorphic_cache_misses));
- GROWABLE_ARRAY_TRIM(stats);
- GROWABLE_ARRAY_DONE(stats);
- dpush(stats);
-}
-
-void jit_emit_class_lookup(F_JIT *jit, F_FIXNUM index, CELL type)
-{
- jit_emit_with(jit,userenv[PIC_LOAD],tag_fixnum(-index * CELLS));
- jit_emit(jit,userenv[type]);
-}
-
-void jit_emit_mega_cache_lookup(F_JIT *jit, CELL methods, F_FIXNUM index, CELL cache)
-{
- /* Generate machine code to determine the object's class. */
- jit_emit_class_lookup(jit,index,PIC_HI_TAG_TUPLE);
-
- /* Do a cache lookup. */
- jit_emit_with(jit,userenv[MEGA_LOOKUP],cache);
-
- /* If we end up here, the cache missed. */
- jit_emit(jit,userenv[JIT_PROLOG]);
-
- /* Push index, method table and cache on the stack. */
- jit_push(jit,methods);
- jit_push(jit,tag_fixnum(index));
- jit_push(jit,cache);
- jit_word_call(jit,userenv[MEGA_MISS_WORD]);
-
- /* Now the new method has been stored into the cache, and its on
- the stack. */
- jit_emit(jit,userenv[JIT_EPILOG]);
- jit_emit(jit,userenv[JIT_EXECUTE_JUMP]);
-}
--- /dev/null
+#include "master.hpp"
+
+namespace factor
+{
+
+cell megamorphic_cache_hits;
+cell megamorphic_cache_misses;
+
+static cell search_lookup_alist(cell table, cell klass)
+{
+ array *pairs = untag<array>(table);
+ fixnum index = array_capacity(pairs) - 1;
+ while(index >= 0)
+ {
+ array *pair = untag<array>(array_nth(pairs,index));
+ if(array_nth(pair,0) == klass)
+ return array_nth(pair,1);
+ else
+ index--;
+ }
+
+ return F;
+}
+
+static cell search_lookup_hash(cell table, cell klass, cell hashcode)
+{
+ array *buckets = untag<array>(table);
+ cell bucket = array_nth(buckets,hashcode & (array_capacity(buckets) - 1));
+ if(tagged<object>(bucket).type_p(WORD_TYPE) || bucket == F)
+ return bucket;
+ else
+ return search_lookup_alist(bucket,klass);
+}
+
+static cell 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 *ptr = (cell *)(layout + 1);
+ return ptr[echelon * 2 + 1];
+}
+
+static cell lookup_tuple_method(cell obj, cell methods)
+{
+ tuple_layout *layout = untag<tuple_layout>(untag<tuple>(obj)->layout);
+
+ array *echelons = untag<array>(methods);
+
+ fixnum echelon = untag_fixnum(layout->echelon);
+ fixnum max_echelon = array_capacity(echelons) - 1;
+ if(echelon > max_echelon) echelon = max_echelon;
+
+ while(echelon >= 0)
+ {
+ cell echelon_methods = array_nth(echelons,echelon);
+
+ if(tagged<object>(echelon_methods).type_p(WORD_TYPE))
+ return echelon_methods;
+ else if(echelon_methods != F)
+ {
+ cell klass = nth_superclass(layout,echelon);
+ cell hashcode = untag_fixnum(nth_hashcode(layout,echelon));
+ cell result = search_lookup_hash(echelon_methods,klass,hashcode);
+ if(result != F)
+ return result;
+ }
+
+ echelon--;
+ }
+
+ critical_error("Cannot find tuple method",methods);
+ return F;
+}
+
+static cell 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;
+#ifdef FACTOR_DEBUG
+ assert(tag < TYPE_COUNT - HEADER_TYPE);
+#endif
+ return array_nth(hi_tag_methods,tag);
+}
+
+static cell lookup_hairy_method(cell obj, cell methods)
+{
+ cell method = array_nth(untag<array>(methods),TAG(obj));
+ if(tagged<object>(method).type_p(WORD_TYPE))
+ return method;
+ else
+ {
+ switch(TAG(obj))
+ {
+ case TUPLE_TYPE:
+ return lookup_tuple_method(obj,method);
+ break;
+ case OBJECT_TYPE:
+ return lookup_hi_tag_method(obj,method);
+ break;
+ default:
+ critical_error("Bad methods array",methods);
+ return -1;
+ }
+ }
+}
+
+cell lookup_method(cell obj, cell methods)
+{
+ cell tag = TAG(obj);
+ if(tag == TUPLE_TYPE || tag == OBJECT_TYPE)
+ return lookup_hairy_method(obj,methods);
+ else
+ return array_nth(untag<array>(methods),TAG(obj));
+}
+
+PRIMITIVE(lookup_method)
+{
+ cell methods = dpop();
+ cell obj = dpop();
+ dpush(lookup_method(obj,methods));
+}
+
+cell object_class(cell obj)
+{
+ switch(TAG(obj))
+ {
+ case TUPLE_TYPE:
+ return untag<tuple>(obj)->layout;
+ case OBJECT_TYPE:
+ return untag<object>(obj)->h.value;
+ default:
+ return tag_fixnum(TAG(obj));
+ }
+}
+
+static cell 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)
+{
+ array *cache_elements = untag<array>(cache);
+ cell hashcode = method_cache_hashcode(klass,cache_elements);
+ set_array_nth(cache_elements,hashcode,klass);
+ set_array_nth(cache_elements,hashcode + 1,method);
+}
+
+PRIMITIVE(mega_cache_miss)
+{
+ megamorphic_cache_misses++;
+
+ cell cache = dpop();
+ fixnum index = untag_fixnum(dpop());
+ cell methods = dpop();
+
+ cell object = ((cell *)ds)[-index];
+ cell klass = object_class(object);
+ cell method = lookup_method(object,methods);
+
+ update_method_cache(cache,klass,method);
+
+ dpush(method);
+}
+
+PRIMITIVE(reset_dispatch_stats)
+{
+ megamorphic_cache_hits = megamorphic_cache_misses = 0;
+}
+
+PRIMITIVE(dispatch_stats)
+{
+ growable_array stats;
+ stats.add(allot_cell(megamorphic_cache_hits));
+ stats.add(allot_cell(megamorphic_cache_misses));
+ stats.trim();
+ dpush(stats.elements.value());
+}
+
+void quotation_jit::emit_mega_cache_lookup(cell methods_, fixnum index, cell cache_)
+{
+ gc_root<array> methods(methods_);
+ gc_root<array> cache(cache_);
+
+ /* 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());
+
+ /* If we end up here, the cache missed. */
+ emit(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]);
+
+ /* Now the new method has been stored into the cache, and its on
+ the stack. */
+ emit(userenv[JIT_EPILOG]);
+ emit(userenv[JIT_EXECUTE_JUMP]);
+}
+
+}
+++ /dev/null
-CELL megamorphic_cache_hits;
-CELL megamorphic_cache_misses;
-
-CELL lookup_method(CELL object, CELL methods);
-void primitive_lookup_method(void);
-
-CELL object_class(CELL object);
-
-void primitive_mega_cache_miss(void);
-
-void primitive_reset_dispatch_stats(void);
-void primitive_dispatch_stats(void);
-
-void jit_emit_class_lookup(F_JIT *jit, F_FIXNUM index, CELL type);
-
-void jit_emit_mega_cache_lookup(F_JIT *jit, CELL methods, F_FIXNUM index, CELL cache);
--- /dev/null
+namespace factor
+{
+
+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);
+
+}
+++ /dev/null
-#include "master.h"
-
-void out_of_memory(void)
-{
- print_string("Out of memory\n\n");
- dump_generations();
- exit(1);
-}
-
-void fatal_error(char* msg, CELL tagged)
-{
- print_string("fatal_error: "); print_string(msg);
- print_string(": "); print_cell_hex(tagged); nl();
- exit(1);
-}
-
-void critical_error(char* msg, CELL tagged)
-{
- print_string("You have triggered a bug in Factor. Please report.\n");
- print_string("critical_error: "); print_string(msg);
- print_string(": "); print_cell_hex(tagged); nl();
- factorbug();
-}
-
-void throw_error(CELL error, F_STACK_FRAME *callstack_top)
-{
- /* If the error handler is set, we rewind any C stack frames and
- pass the error to user-space. */
- if(userenv[BREAK_ENV] != F)
- {
- /* If error was thrown during heap scan, we re-enable the GC */
- gc_off = false;
-
- /* Reset local roots */
- gc_locals = gc_locals_region->start - CELLS;
- extra_roots = extra_roots_region->start - CELLS;
-
- /* If we had an underflow or overflow, stack pointers might be
- out of bounds */
- fix_stacks();
-
- dpush(error);
-
- /* Errors thrown from C code pass NULL for this parameter.
- Errors thrown from Factor code, or signal handlers, pass the
- actual stack pointer at the time, since the saved pointer is
- not necessarily up to date at that point. */
- if(callstack_top)
- {
- callstack_top = fix_callstack_top(callstack_top,
- stack_chain->callstack_bottom);
- }
- else
- callstack_top = stack_chain->callstack_top;
-
- throw_impl(userenv[BREAK_ENV],callstack_top);
- }
- /* Error was thrown in early startup before error handler is set, just
- crash. */
- else
- {
- print_string("You have triggered a bug in Factor. Please report.\n");
- print_string("early_error: ");
- print_obj(error);
- nl();
- factorbug();
- }
-}
-
-void general_error(F_ERRORTYPE error, CELL arg1, CELL arg2,
- F_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)
-{
- general_error(ERROR_TYPE,tag_fixnum(type),tagged,NULL);
-}
-
-void not_implemented_error(void)
-{
- 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)
-{
- int pagesize = getpagesize();
- area += area_size;
- area += offset * pagesize;
-
- return fault >= area && fault <= area + pagesize;
-}
-
-void memory_protection_error(CELL addr, F_STACK_FRAME *native_stack)
-{
- if(in_page(addr, ds_bot, 0, -1))
- general_error(ERROR_DS_UNDERFLOW,F,F,native_stack);
- else if(in_page(addr, ds_bot, ds_size, 0))
- general_error(ERROR_DS_OVERFLOW,F,F,native_stack);
- else if(in_page(addr, rs_bot, 0, -1))
- general_error(ERROR_RS_UNDERFLOW,F,F,native_stack);
- else if(in_page(addr, rs_bot, rs_size, 0))
- general_error(ERROR_RS_OVERFLOW,F,F,native_stack);
- else if(in_page(addr, nursery.end, 0, 0))
- critical_error("allot_object() missed GC check",0);
- else if(in_page(addr, gc_locals_region->start, 0, -1))
- critical_error("gc locals underflow",0);
- else if(in_page(addr, gc_locals_region->end, 0, 0))
- critical_error("gc locals overflow",0);
- else if(in_page(addr, extra_roots_region->start, 0, -1))
- critical_error("extra roots underflow",0);
- else if(in_page(addr, extra_roots_region->end, 0, 0))
- critical_error("extra roots overflow",0);
- else
- general_error(ERROR_MEMORY,allot_cell(addr),F,native_stack);
-}
-
-void signal_error(int signal, F_STACK_FRAME *native_stack)
-{
- general_error(ERROR_SIGNAL,tag_fixnum(signal),F,native_stack);
-}
-
-void divide_by_zero_error(void)
-{
- general_error(ERROR_DIVIDE_BY_ZERO,F,F,NULL);
-}
-
-void memory_signal_handler_impl(void)
-{
- memory_protection_error(signal_fault_addr,signal_callstack_top);
-}
-
-void misc_signal_handler_impl(void)
-{
- signal_error(signal_number,signal_callstack_top);
-}
-
-void primitive_call_clear(void)
-{
- throw_impl(dpop(),stack_chain->callstack_bottom);
-}
-
-/* For testing purposes */
-void primitive_unimplemented(void)
-{
- not_implemented_error();
-}
--- /dev/null
+#include "master.hpp"
+
+namespace factor
+{
+
+/* Global variables used to pass fault handler state from signal handler to
+user-space */
+cell signal_number;
+cell signal_fault_addr;
+stack_frame *signal_callstack_top;
+
+void out_of_memory(void)
+{
+ print_string("Out of memory\n\n");
+ dump_generations();
+ exit(1);
+}
+
+void fatal_error(char* msg, cell tagged)
+{
+ print_string("fatal_error: "); print_string(msg);
+ print_string(": "); print_cell_hex(tagged); nl();
+ exit(1);
+}
+
+void critical_error(char* msg, cell tagged)
+{
+ print_string("You have triggered a bug in Factor. Please report.\n");
+ print_string("critical_error: "); print_string(msg);
+ print_string(": "); print_cell_hex(tagged); nl();
+ factorbug();
+}
+
+void 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. */
+ if(userenv[BREAK_ENV] != F)
+ {
+ /* If error was thrown during heap scan, we re-enable the GC */
+ gc_off = false;
+
+ /* Reset local roots */
+ gc_locals = gc_locals_region->start - sizeof(cell);
+ gc_bignums = gc_bignums_region->start - sizeof(cell);
+
+ /* If we had an underflow or overflow, stack pointers might be
+ out of bounds */
+ fix_stacks();
+
+ dpush(error);
+
+ /* Errors thrown from C code pass NULL for this parameter.
+ Errors thrown from Factor code, or signal handlers, pass the
+ actual stack pointer at the time, since the saved pointer is
+ not necessarily up to date at that point. */
+ if(callstack_top)
+ {
+ callstack_top = fix_callstack_top(callstack_top,
+ stack_chain->callstack_bottom);
+ }
+ else
+ callstack_top = stack_chain->callstack_top;
+
+ throw_impl(userenv[BREAK_ENV],callstack_top);
+ }
+ /* Error was thrown in early startup before error handler is set, just
+ crash. */
+ else
+ {
+ print_string("You have triggered a bug in Factor. Please report.\n");
+ print_string("early_error: ");
+ print_obj(error);
+ nl();
+ factorbug();
+ }
+}
+
+void 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)
+{
+ general_error(ERROR_TYPE,tag_fixnum(type),tagged,NULL);
+}
+
+void not_implemented_error(void)
+{
+ 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)
+{
+ int pagesize = getpagesize();
+ area += area_size;
+ area += offset * pagesize;
+
+ return fault >= area && fault <= area + pagesize;
+}
+
+void 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);
+ else if(in_page(addr, ds_bot, ds_size, 0))
+ general_error(ERROR_DS_OVERFLOW,F,F,native_stack);
+ else if(in_page(addr, rs_bot, 0, -1))
+ general_error(ERROR_RS_UNDERFLOW,F,F,native_stack);
+ else if(in_page(addr, rs_bot, rs_size, 0))
+ general_error(ERROR_RS_OVERFLOW,F,F,native_stack);
+ else if(in_page(addr, nursery.end, 0, 0))
+ critical_error("allot_object() missed GC check",0);
+ else
+ general_error(ERROR_MEMORY,allot_cell(addr),F,native_stack);
+}
+
+void signal_error(int signal, stack_frame *native_stack)
+{
+ general_error(ERROR_SIGNAL,tag_fixnum(signal),F,native_stack);
+}
+
+void divide_by_zero_error(void)
+{
+ general_error(ERROR_DIVIDE_BY_ZERO,F,F,NULL);
+}
+
+PRIMITIVE(call_clear)
+{
+ throw_impl(dpop(),stack_chain->callstack_bottom);
+}
+
+/* For testing purposes */
+PRIMITIVE(unimplemented)
+{
+ not_implemented_error();
+}
+
+void memory_signal_handler_impl(void)
+{
+ memory_protection_error(signal_fault_addr,signal_callstack_top);
+}
+
+void misc_signal_handler_impl(void)
+{
+ signal_error(signal_number,signal_callstack_top);
+}
+
+}
+++ /dev/null
-/* Runtime errors */
-typedef enum
-{
- ERROR_EXPIRED = 0,
- ERROR_IO,
- ERROR_NOT_IMPLEMENTED,
- ERROR_TYPE,
- ERROR_DIVIDE_BY_ZERO,
- ERROR_SIGNAL,
- ERROR_ARRAY_SIZE,
- ERROR_C_STRING,
- ERROR_FFI,
- ERROR_HEAP_SCAN,
- ERROR_UNDEFINED_SYMBOL,
- ERROR_DS_UNDERFLOW,
- ERROR_DS_OVERFLOW,
- ERROR_RS_UNDERFLOW,
- ERROR_RS_OVERFLOW,
- ERROR_MEMORY,
-} F_ERRORTYPE;
-
-void out_of_memory(void);
-void fatal_error(char* msg, CELL tagged);
-void critical_error(char* msg, CELL tagged);
-void primitive_die(void);
-
-void throw_error(CELL error, F_STACK_FRAME *native_stack);
-void general_error(F_ERRORTYPE error, CELL arg1, CELL arg2, F_STACK_FRAME *native_stack);
-void divide_by_zero_error(void);
-void memory_protection_error(CELL addr, F_STACK_FRAME *native_stack);
-void signal_error(int signal, F_STACK_FRAME *native_stack);
-void type_error(CELL type, CELL tagged);
-void not_implemented_error(void);
-
-void primitive_call_clear(void);
-
-INLINE void type_check(CELL type, CELL tagged)
-{
- if(type_of(tagged) != type) type_error(type,tagged);
-}
-
-#define DEFINE_UNTAG(type,check,name) \
- INLINE type *untag_##name(CELL obj) \
- { \
- type_check(check,obj); \
- return untag_object(obj); \
- }
-
-/* Global variables used to pass fault handler state from signal handler to
-user-space */
-CELL signal_number;
-CELL signal_fault_addr;
-void *signal_callstack_top;
-
-void memory_signal_handler_impl(void);
-void misc_signal_handler_impl(void);
-
-void primitive_unimplemented(void);
--- /dev/null
+namespace factor
+{
+
+/* Runtime errors */
+enum vm_error_type
+{
+ ERROR_EXPIRED = 0,
+ ERROR_IO,
+ ERROR_NOT_IMPLEMENTED,
+ ERROR_TYPE,
+ ERROR_DIVIDE_BY_ZERO,
+ ERROR_SIGNAL,
+ ERROR_ARRAY_SIZE,
+ ERROR_C_STRING,
+ ERROR_FFI,
+ ERROR_HEAP_SCAN,
+ ERROR_UNDEFINED_SYMBOL,
+ ERROR_DS_UNDERFLOW,
+ ERROR_DS_OVERFLOW,
+ ERROR_RS_UNDERFLOW,
+ ERROR_RS_OVERFLOW,
+ ERROR_MEMORY,
+};
+
+void out_of_memory(void);
+void fatal_error(char* msg, cell tagged);
+void critical_error(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);
+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);
+
+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 stack_frame *signal_callstack_top;
+
+void memory_signal_handler_impl(void);
+void misc_signal_handler_impl(void);
+
+}
+++ /dev/null
-#include "master.h"
-
-void default_parameters(F_PARAMETERS *p)
-{
- p->image_path = NULL;
-
- /* We make a wild guess here that if we're running on ARM, we don't
- have a lot of memory. */
-#ifdef FACTOR_ARM
- p->ds_size = 8 * CELLS;
- p->rs_size = 8 * CELLS;
-
- p->gen_count = 2;
- p->code_size = 4;
- p->young_size = 1;
- p->aging_size = 1;
- p->tenured_size = 6;
-#else
- p->ds_size = 32 * CELLS;
- p->rs_size = 32 * CELLS;
-
- p->gen_count = 3;
- p->code_size = 8 * CELLS;
- p->young_size = CELLS / 4;
- p->aging_size = CELLS / 2;
- p->tenured_size = 4 * CELLS;
-#endif
-
- p->max_pic_size = 3;
-
- p->secure_gc = false;
- p->fep = false;
-
-#ifdef WINDOWS
- p->console = false;
-#else
- p->console = true;
-#endif
-
- p->stack_traces = true;
-}
-
-INLINE bool factor_arg(const F_CHAR* str, const F_CHAR* arg, CELL* value)
-{
- int val;
- if(SSCANF(str,arg,&val) > 0)
- {
- *value = val;
- return true;
- }
- else
- return false;
-}
-
-void init_parameters_from_args(F_PARAMETERS *p, int argc, F_CHAR **argv)
-{
- default_parameters(p);
- p->executable_path = argv[0];
-
- int i = 0;
-
- for(i = 1; i < argc; i++)
- {
- if(factor_arg(argv[i],STRING_LITERAL("-datastack=%d"),&p->ds_size));
- else if(factor_arg(argv[i],STRING_LITERAL("-retainstack=%d"),&p->rs_size));
- else if(factor_arg(argv[i],STRING_LITERAL("-generations=%d"),&p->gen_count));
- else if(factor_arg(argv[i],STRING_LITERAL("-young=%d"),&p->young_size));
- else if(factor_arg(argv[i],STRING_LITERAL("-aging=%d"),&p->aging_size));
- else if(factor_arg(argv[i],STRING_LITERAL("-tenured=%d"),&p->tenured_size));
- else if(factor_arg(argv[i],STRING_LITERAL("-codeheap=%d"),&p->code_size));
- else if(factor_arg(argv[i],STRING_LITERAL("-pic=%d"),&p->max_pic_size));
- else if(STRCMP(argv[i],STRING_LITERAL("-securegc")) == 0) p->secure_gc = true;
- else if(STRCMP(argv[i],STRING_LITERAL("-fep")) == 0) p->fep = true;
- else if(STRNCMP(argv[i],STRING_LITERAL("-i="),3) == 0) p->image_path = argv[i] + 3;
- else if(STRCMP(argv[i],STRING_LITERAL("-console")) == 0) p->console = true;
- else if(STRCMP(argv[i],STRING_LITERAL("-no-stack-traces")) == 0) p->stack_traces = false;
- }
-}
-
-/* Do some initialization that we do once only */
-void do_stage1_init(void)
-{
- print_string("*** Stage 2 early init... ");
- fflush(stdout);
-
- compile_all_words();
- userenv[STAGE2_ENV] = T;
-
- print_string("done\n");
- fflush(stdout);
-}
-
-void init_factor(F_PARAMETERS *p)
-{
- /* Kilobytes */
- p->ds_size = align_page(p->ds_size << 10);
- p->rs_size = align_page(p->rs_size << 10);
-
- /* Megabytes */
- p->young_size <<= 20;
- p->aging_size <<= 20;
- p->tenured_size <<= 20;
- p->code_size <<= 20;
-
- /* Disable GC during init as a sanity check */
- gc_off = true;
-
- /* OS-specific initialization */
- early_init();
-
- const F_CHAR *executable_path = vm_executable_path();
-
- if(executable_path)
- p->executable_path = executable_path;
-
- if(p->image_path == NULL)
- p->image_path = default_image_path();
-
- srand(current_micros());
- init_ffi();
- init_stacks(p->ds_size,p->rs_size);
- load_image(p);
- init_c_io();
- init_inline_caching(p->max_pic_size);
-
-#ifndef FACTOR_DEBUG
- init_signals();
-#endif
-
- if(p->console)
- open_console();
-
- stack_chain = NULL;
- profiling_p = false;
- performing_gc = false;
- last_code_heap_scan = NURSERY;
- collecting_aging_again = false;
-
- userenv[CPU_ENV] = tag_object(from_char_string(FACTOR_CPU_STRING));
- userenv[OS_ENV] = tag_object(from_char_string(FACTOR_OS_STRING));
- userenv[CELL_SIZE_ENV] = tag_fixnum(sizeof(CELL));
- userenv[EXECUTABLE_ENV] = (p->executable_path ? tag_object(from_native_string(p->executable_path)) : F);
- userenv[ARGS_ENV] = F;
- userenv[EMBEDDED_ENV] = F;
-
- /* We can GC now */
- gc_off = false;
-
- if(!stage2)
- {
- userenv[STACK_TRACES_ENV] = tag_boolean(p->stack_traces);
- do_stage1_init();
- }
-}
-
-/* May allocate memory */
-void pass_args_to_factor(int argc, F_CHAR **argv)
-{
- F_ARRAY *args = allot_array(ARRAY_TYPE,argc,F);
- int i;
-
- for(i = 1; i < argc; i++)
- {
- REGISTER_UNTAGGED(args);
- CELL arg = tag_object(from_native_string(argv[i]));
- UNREGISTER_UNTAGGED(args);
- set_array_nth(args,i,arg);
- }
-
- userenv[ARGS_ENV] = tag_array(args);
-}
-
-void start_factor(F_PARAMETERS *p)
-{
- if(p->fep) factorbug();
-
- nest_stacks();
- c_to_factor_toplevel(userenv[BOOT_ENV]);
- unnest_stacks();
-}
-
-void start_embedded_factor(F_PARAMETERS *p)
-{
- userenv[EMBEDDED_ENV] = T;
- start_factor(p);
-}
-
-void start_standalone_factor(int argc, F_CHAR **argv)
-{
- F_PARAMETERS p;
- default_parameters(&p);
- init_parameters_from_args(&p,argc,argv);
- init_factor(&p);
- pass_args_to_factor(argc,argv);
- start_factor(&p);
-}
-
-char *factor_eval_string(char *string)
-{
- char* (*callback)(char*) = alien_offset(userenv[EVAL_CALLBACK_ENV]);
- return callback(string);
-}
-
-void factor_eval_free(char *result)
-{
- free(result);
-}
-
-void factor_yield(void)
-{
- void (*callback)() = alien_offset(userenv[YIELD_CALLBACK_ENV]);
- callback();
-}
-
-void factor_sleep(long us)
-{
- void (*callback)() = alien_offset(userenv[SLEEP_CALLBACK_ENV]);
- callback(us);
-}
--- /dev/null
+#include "master.hpp"
+
+namespace factor
+{
+
+VM_C_API void default_parameters(vm_parameters *p)
+{
+ p->image_path = NULL;
+
+ /* We make a wild guess here that if we're running on ARM, we don't
+ have a lot of memory. */
+#ifdef FACTOR_ARM
+ p->ds_size = 8 * sizeof(cell);
+ p->rs_size = 8 * sizeof(cell);
+
+ p->gen_count = 2;
+ p->code_size = 4;
+ p->young_size = 1;
+ p->aging_size = 1;
+ p->tenured_size = 6;
+#else
+ p->ds_size = 32 * sizeof(cell);
+ p->rs_size = 32 * sizeof(cell);
+
+ p->gen_count = 3;
+ p->code_size = 8 * sizeof(cell);
+ p->young_size = sizeof(cell) / 4;
+ p->aging_size = sizeof(cell) / 2;
+ p->tenured_size = 4 * sizeof(cell);
+#endif
+
+ p->max_pic_size = 3;
+
+ p->secure_gc = false;
+ p->fep = false;
+
+#ifdef WINDOWS
+ p->console = false;
+#else
+ p->console = true;
+#endif
+
+ p->stack_traces = true;
+}
+
+static bool factor_arg(const vm_char* str, const vm_char* arg, cell* value)
+{
+ int val;
+ if(SSCANF(str,arg,&val) > 0)
+ {
+ *value = val;
+ return true;
+ }
+ else
+ return false;
+}
+
+VM_C_API void init_parameters_from_args(vm_parameters *p, int argc, vm_char **argv)
+{
+ default_parameters(p);
+ p->executable_path = argv[0];
+
+ int i = 0;
+
+ for(i = 1; i < argc; i++)
+ {
+ if(factor_arg(argv[i],STRING_LITERAL("-datastack=%d"),&p->ds_size));
+ else if(factor_arg(argv[i],STRING_LITERAL("-retainstack=%d"),&p->rs_size));
+ else if(factor_arg(argv[i],STRING_LITERAL("-generations=%d"),&p->gen_count));
+ else if(factor_arg(argv[i],STRING_LITERAL("-young=%d"),&p->young_size));
+ else if(factor_arg(argv[i],STRING_LITERAL("-aging=%d"),&p->aging_size));
+ else if(factor_arg(argv[i],STRING_LITERAL("-tenured=%d"),&p->tenured_size));
+ else if(factor_arg(argv[i],STRING_LITERAL("-codeheap=%d"),&p->code_size));
+ else if(factor_arg(argv[i],STRING_LITERAL("-pic=%d"),&p->max_pic_size));
+ else if(STRCMP(argv[i],STRING_LITERAL("-securegc")) == 0) p->secure_gc = true;
+ else if(STRCMP(argv[i],STRING_LITERAL("-fep")) == 0) p->fep = true;
+ else if(STRNCMP(argv[i],STRING_LITERAL("-i="),3) == 0) p->image_path = argv[i] + 3;
+ else if(STRCMP(argv[i],STRING_LITERAL("-console")) == 0) p->console = true;
+ else if(STRCMP(argv[i],STRING_LITERAL("-no-stack-traces")) == 0) p->stack_traces = false;
+ }
+}
+
+/* Do some initialization that we do once only */
+static void do_stage1_init(void)
+{
+ print_string("*** Stage 2 early init... ");
+ fflush(stdout);
+
+ compile_all_words();
+ userenv[STAGE2_ENV] = T;
+
+ print_string("done\n");
+ fflush(stdout);
+}
+
+VM_C_API void init_factor(vm_parameters *p)
+{
+ /* Kilobytes */
+ p->ds_size = align_page(p->ds_size << 10);
+ p->rs_size = align_page(p->rs_size << 10);
+
+ /* Megabytes */
+ p->young_size <<= 20;
+ p->aging_size <<= 20;
+ p->tenured_size <<= 20;
+ p->code_size <<= 20;
+
+ /* Disable GC during init as a sanity check */
+ gc_off = true;
+
+ /* OS-specific initialization */
+ early_init();
+
+ const vm_char *executable_path = vm_executable_path();
+
+ if(executable_path)
+ p->executable_path = executable_path;
+
+ if(p->image_path == NULL)
+ p->image_path = default_image_path();
+
+ srand(current_micros());
+ init_ffi();
+ init_stacks(p->ds_size,p->rs_size);
+ load_image(p);
+ init_c_io();
+ init_inline_caching(p->max_pic_size);
+ init_signals();
+
+ if(p->console)
+ open_console();
+
+ init_profiler();
+
+ userenv[CPU_ENV] = allot_alien(F,(cell)FACTOR_CPU_STRING);
+ userenv[OS_ENV] = allot_alien(F,(cell)FACTOR_OS_STRING);
+ userenv[cell_SIZE_ENV] = tag_fixnum(sizeof(cell));
+ userenv[EXECUTABLE_ENV] = allot_alien(F,(cell)p->executable_path);
+ userenv[ARGS_ENV] = F;
+ userenv[EMBEDDED_ENV] = F;
+
+ /* We can GC now */
+ gc_off = false;
+
+ if(userenv[STAGE2_ENV] == F)
+ {
+ userenv[STACK_TRACES_ENV] = tag_boolean(p->stack_traces);
+ do_stage1_init();
+ }
+}
+
+/* May allocate memory */
+VM_C_API void pass_args_to_factor(int argc, vm_char **argv)
+{
+ growable_array args;
+ int 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)
+{
+ if(p->fep) factorbug();
+
+ nest_stacks();
+ c_to_factor_toplevel(userenv[BOOT_ENV]);
+ unnest_stacks();
+}
+
+VM_C_API void start_embedded_factor(vm_parameters *p)
+{
+ userenv[EMBEDDED_ENV] = T;
+ start_factor(p);
+}
+
+VM_C_API void start_standalone_factor(int argc, vm_char **argv)
+{
+ vm_parameters p;
+ default_parameters(&p);
+ init_parameters_from_args(&p,argc,argv);
+ init_factor(&p);
+ pass_args_to_factor(argc,argv);
+ 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);
+}
+
+VM_C_API void factor_eval_free(char *result)
+{
+ free(result);
+}
+
+VM_C_API void factor_yield(void)
+{
+ void (*callback)(void) = (void (*)(void))alien_offset(userenv[YIELD_CALLBACK_ENV]);
+ callback();
+}
+
+VM_C_API void factor_sleep(long us)
+{
+ void (*callback)(long) = (void (*)(long))alien_offset(userenv[SLEEP_CALLBACK_ENV]);
+ callback(us);
+}
+
+}
+++ /dev/null
-DLLEXPORT void default_parameters(F_PARAMETERS *p);
-DLLEXPORT void init_parameters_from_args(F_PARAMETERS *p, int argc, F_CHAR **argv);
-DLLEXPORT void init_factor(F_PARAMETERS *p);
-DLLEXPORT void pass_args_to_factor(int argc, F_CHAR **argv);
-DLLEXPORT void start_embedded_factor(F_PARAMETERS *p);
-DLLEXPORT void start_standalone_factor(int argc, F_CHAR **argv);
-
-DLLEXPORT char *factor_eval_string(char *string);
-DLLEXPORT void factor_eval_free(char *result);
-DLLEXPORT void factor_yield(void);
-DLLEXPORT void factor_sleep(long ms);
--- /dev/null
+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(void);
+VM_C_API void factor_sleep(long ms);
+
+}
/* This file is linked into the runtime for the sole purpose
* of testing FFI code. */
-#include "master.h"
#include "ffi_test.h"
+#include <assert.h>
+#include <string.h>
+
void ffi_test_0(void)
{
}
int ffi_test_39(long a, long b, struct test_struct_13 s)
{
- if(a != b) abort();
+ assert(a == b);
return s.x1 + s.x2 + s.x3 + s.x4 + s.x5 + s.x6;
}
#define F_STDCALL
#endif
+#define DLLEXPORT
+
DLLEXPORT void ffi_test_0(void);
DLLEXPORT int ffi_test_1(void);
DLLEXPORT int ffi_test_2(int x, int y);
+++ /dev/null
-/* Some functions for converting floating point numbers to binary
-representations and vice versa */
-
-typedef union {
- double x;
- u64 y;
-} F_DOUBLE_BITS;
-
-INLINE u64 double_bits(double x)
-{
- F_DOUBLE_BITS b;
- b.x = x;
- return b.y;
-}
-
-INLINE double bits_double(u64 y)
-{
- F_DOUBLE_BITS b;
- b.y = y;
- return b.x;
-}
-
-typedef union {
- float x;
- u32 y;
-} F_FLOAT_BITS;
-
-INLINE u32 float_bits(float x)
-{
- F_FLOAT_BITS b;
- b.x = x;
- return b.y;
-}
-
-INLINE float bits_float(u32 y)
-{
- F_FLOAT_BITS b;
- b.y = y;
- return b.x;
-}
--- /dev/null
+namespace factor
+{
+
+/* Some functions for converting floating point numbers to binary
+representations and vice versa */
+
+union double_bits_pun {
+ double x;
+ u64 y;
+};
+
+inline static u64 double_bits(double x)
+{
+ double_bits_pun b;
+ b.x = x;
+ return b.y;
+}
+
+inline static double bits_double(u64 y)
+{
+ double_bits_pun b;
+ b.y = y;
+ return b.x;
+}
+
+union float_bits_pun {
+ float x;
+ u32 y;
+};
+
+inline static u32 float_bits(float x)
+{
+ float_bits_pun b;
+ b.x = x;
+ return b.y;
+}
+
+inline static float bits_float(u32 y)
+{
+ float_bits_pun b;
+ b.y = y;
+ return b.x;
+}
+
+}
--- /dev/null
+namespace factor
+{
+
+template<typename T> cell array_capacity(T *array)
+{
+#ifdef FACTOR_DEBUG
+ assert(array->h.hi_tag() == T::type_number);
+#endif
+ return array->capacity >> TAG_BITS;
+}
+
+template <typename T> cell array_size(cell capacity)
+{
+ return sizeof(T) + capacity * T::element_size;
+}
+
+template <typename T> cell array_size(T *array)
+{
+ 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;
+ }
+}
+
+}
+++ /dev/null
-#include "master.h"
-
-/* Certain special objects in the image are known to the runtime */
-void init_objects(F_HEADER *h)
-{
- memcpy(userenv,h->userenv,sizeof(userenv));
-
- T = h->t;
- bignum_zero = h->bignum_zero;
- bignum_pos_one = h->bignum_pos_one;
- bignum_neg_one = h->bignum_neg_one;
-
- stage2 = (userenv[STAGE2_ENV] != F);
-}
-
-INLINE void load_data_heap(FILE *file, F_HEADER *h, F_PARAMETERS *p)
-{
- CELL good_size = h->data_size + (1 << 20);
-
- if(good_size > p->tenured_size)
- p->tenured_size = good_size;
-
- init_data_heap(p->gen_count,
- p->young_size,
- p->aging_size,
- p->tenured_size,
- p->secure_gc);
-
- clear_gc_stats();
-
- F_ZONE *tenured = &data_heap->generations[TENURED];
-
- F_FIXNUM bytes_read = fread((void*)tenured->start,1,h->data_size,file);
-
- if(bytes_read != h->data_size)
- {
- print_string("truncated image: ");
- print_fixnum(bytes_read);
- print_string(" bytes read, ");
- print_cell(h->data_size);
- print_string(" bytes expected\n");
- fatal_error("load_data_heap failed",0);
- }
-
- tenured->here = tenured->start + h->data_size;
- data_relocation_base = h->data_relocation_base;
-}
-
-INLINE void load_code_heap(FILE *file, F_HEADER *h, F_PARAMETERS *p)
-{
- CELL good_size = h->code_size + (1 << 19);
-
- if(good_size > p->code_size)
- p->code_size = good_size;
-
- init_code_heap(p->code_size);
-
- if(h->code_size != 0)
- {
- F_FIXNUM bytes_read = fread(first_block(&code_heap),1,h->code_size,file);
- if(bytes_read != h->code_size)
- {
- print_string("truncated image: ");
- print_fixnum(bytes_read);
- print_string(" bytes read, ");
- print_cell(h->code_size);
- print_string(" bytes expected\n");
- fatal_error("load_code_heap failed",0);
- }
- }
-
- code_relocation_base = h->code_relocation_base;
- build_free_list(&code_heap,h->code_size);
-}
-
-/* Read an image file from disk, only done once during startup */
-/* This function also initializes the data and code heaps */
-void load_image(F_PARAMETERS *p)
-{
- FILE *file = OPEN_READ(p->image_path);
- if(file == NULL)
- {
- print_string("Cannot open image file: "); print_native_string(p->image_path); nl();
- print_string(strerror(errno)); nl();
- exit(1);
- }
-
- F_HEADER h;
- if(fread(&h,sizeof(F_HEADER),1,file) != 1)
- fatal_error("Cannot read image header",0);
-
- if(h.magic != IMAGE_MAGIC)
- fatal_error("Bad image: magic number check failed",h.magic);
-
- if(h.version != IMAGE_VERSION)
- fatal_error("Bad image: version number check failed",h.version);
-
- load_data_heap(file,&h,p);
- load_code_heap(file,&h,p);
-
- fclose(file);
-
- init_objects(&h);
-
- relocate_data();
- relocate_code();
-
- /* Store image path name */
- userenv[IMAGE_ENV] = tag_object(from_native_string(p->image_path));
-}
-
-/* Save the current image to disk */
-bool save_image(const F_CHAR *filename)
-{
- FILE* file;
- F_HEADER h;
-
- file = OPEN_WRITE(filename);
- if(file == NULL)
- {
- print_string("Cannot open image file: "); print_native_string(filename); nl();
- print_string(strerror(errno)); nl();
- return false;
- }
-
- F_ZONE *tenured = &data_heap->generations[TENURED];
-
- h.magic = IMAGE_MAGIC;
- h.version = IMAGE_VERSION;
- h.data_relocation_base = tenured->start;
- h.data_size = tenured->here - tenured->start;
- h.code_relocation_base = code_heap.segment->start;
- h.code_size = heap_size(&code_heap);
-
- h.t = T;
- h.bignum_zero = bignum_zero;
- h.bignum_pos_one = bignum_pos_one;
- h.bignum_neg_one = bignum_neg_one;
-
- CELL i;
- for(i = 0; i < USER_ENV; i++)
- {
- if(i < FIRST_SAVE_ENV)
- h.userenv[i] = F;
- else
- h.userenv[i] = userenv[i];
- }
-
- bool ok = true;
-
- if(fwrite(&h,sizeof(F_HEADER),1,file) != 1) ok = false;
- if(fwrite((void*)tenured->start,h.data_size,1,file) != 1) ok = false;
- if(fwrite(first_block(&code_heap),h.code_size,1,file) != 1) ok = false;
- if(fclose(file)) ok = false;
-
- if(!ok)
- {
- print_string("save-image failed: "); print_string(strerror(errno)); nl();
- }
-
- return ok;
-}
-
-void primitive_save_image(void)
-{
- /* do a full GC to push everything into tenured space */
- gc();
-
- save_image(unbox_native_string());
-}
-
-void primitive_save_image_and_exit(void)
-{
- /* 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. */
- F_CHAR *path = unbox_native_string();
-
- REGISTER_C_STRING(path);
-
- /* strip out userenv data which is set on startup anyway */
- CELL i;
- for(i = 0; i < FIRST_SAVE_ENV; i++)
- userenv[i] = F;
-
- for(i = LAST_SAVE_ENV + 1; i < STACK_TRACES_ENV; i++)
- userenv[i] = F;
-
- /* do a full GC + code heap compaction */
- performing_compaction = true;
- compact_code_heap();
- performing_compaction = false;
-
- UNREGISTER_C_STRING(path);
-
- /* Save the image */
- if(save_image(path))
- exit(0);
- else
- exit(1);
-}
-
-void fixup_word(F_WORD *word)
-{
- if(stage2)
- {
- code_fixup((CELL)&word->code);
- if(word->profiling) code_fixup((CELL)&word->profiling);
- code_fixup((CELL)&word->xt);
- }
-}
-
-void fixup_quotation(F_QUOTATION *quot)
-{
- if(quot->compiledp == F)
- quot->xt = lazy_jit_compile;
- else
- {
- code_fixup((CELL)"->xt);
- code_fixup((CELL)"->code);
- }
-}
-
-void fixup_alien(F_ALIEN *d)
-{
- d->expired = T;
-}
-
-void fixup_stack_frame(F_STACK_FRAME *frame)
-{
- code_fixup((CELL)&frame->xt);
- code_fixup((CELL)&FRAME_RETURN_ADDRESS(frame));
-}
-
-void fixup_callstack_object(F_CALLSTACK *stack)
-{
- iterate_callstack_object(stack,fixup_stack_frame);
-}
-
-/* Initialize an object in a newly-loaded image */
-void relocate_object(CELL relocating)
-{
- /* Tuple relocation is a bit trickier; we have to fix up the
- fixup object before we can get the tuple size, so do_slots is
- out of the question */
- if(untag_header(get(relocating)) == TUPLE_TYPE)
- {
- data_fixup((CELL *)relocating + 1);
-
- CELL scan = relocating + 2 * CELLS;
- CELL size = untagged_object_size(relocating);
- CELL end = relocating + size;
-
- while(scan < end)
- {
- data_fixup((CELL *)scan);
- scan += CELLS;
- }
- }
- else
- {
- do_slots(relocating,data_fixup);
-
- switch(untag_header(get(relocating)))
- {
- case WORD_TYPE:
- fixup_word((F_WORD *)relocating);
- break;
- case QUOTATION_TYPE:
- fixup_quotation((F_QUOTATION *)relocating);
- break;
- case DLL_TYPE:
- ffi_dlopen((F_DLL *)relocating);
- break;
- case ALIEN_TYPE:
- fixup_alien((F_ALIEN *)relocating);
- break;
- case CALLSTACK_TYPE:
- fixup_callstack_object((F_CALLSTACK *)relocating);
- break;
- }
- }
-}
-
-/* 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()
-{
- CELL relocating;
-
- CELL i;
- for(i = 0; i < USER_ENV; i++)
- data_fixup(&userenv[i]);
-
- data_fixup(&T);
- data_fixup(&bignum_zero);
- data_fixup(&bignum_pos_one);
- data_fixup(&bignum_neg_one);
-
- F_ZONE *tenured = &data_heap->generations[TENURED];
-
- for(relocating = tenured->start;
- relocating < tenured->here;
- relocating += untagged_object_size(relocating))
- {
- allot_barrier(relocating);
- relocate_object(relocating);
- }
-}
-
-void fixup_code_block(F_CODE_BLOCK *compiled)
-{
- /* relocate literal table data */
- data_fixup(&compiled->relocation);
- data_fixup(&compiled->literals);
-
- relocate_code_block(compiled);
-}
-
-void relocate_code()
-{
- iterate_code_heap(fixup_code_block);
-}
--- /dev/null
+#include "master.hpp"
+
+namespace factor
+{
+
+/* Certain special objects in the image are known to the runtime */
+static void init_objects(image_header *h)
+{
+ memcpy(userenv,h->userenv,sizeof(userenv));
+
+ T = h->t;
+ bignum_zero = h->bignum_zero;
+ bignum_pos_one = h->bignum_pos_one;
+ bignum_neg_one = h->bignum_neg_one;
+}
+
+cell data_relocation_base;
+
+static void load_data_heap(FILE *file, image_header *h, vm_parameters *p)
+{
+ cell good_size = h->data_size + (1 << 20);
+
+ if(good_size > p->tenured_size)
+ p->tenured_size = good_size;
+
+ init_data_heap(p->gen_count,
+ p->young_size,
+ p->aging_size,
+ p->tenured_size,
+ p->secure_gc);
+
+ clear_gc_stats();
+
+ zone *tenured = &data->generations[TENURED];
+
+ fixnum bytes_read = fread((void*)tenured->start,1,h->data_size,file);
+
+ if((cell)bytes_read != h->data_size)
+ {
+ print_string("truncated image: ");
+ print_fixnum(bytes_read);
+ print_string(" bytes read, ");
+ print_cell(h->data_size);
+ print_string(" bytes expected\n");
+ fatal_error("load_data_heap failed",0);
+ }
+
+ tenured->here = tenured->start + h->data_size;
+ data_relocation_base = h->data_relocation_base;
+}
+
+cell code_relocation_base;
+
+static void load_code_heap(FILE *file, image_header *h, vm_parameters *p)
+{
+ cell good_size = h->code_size + (1 << 19);
+
+ if(good_size > p->code_size)
+ p->code_size = good_size;
+
+ init_code_heap(p->code_size);
+
+ if(h->code_size != 0)
+ {
+ size_t bytes_read = fread(first_block(&code),1,h->code_size,file);
+ if(bytes_read != h->code_size)
+ {
+ print_string("truncated image: ");
+ print_fixnum(bytes_read);
+ print_string(" bytes read, ");
+ print_cell(h->code_size);
+ print_string(" bytes expected\n");
+ fatal_error("load_code_heap failed",0);
+ }
+ }
+
+ code_relocation_base = h->code_relocation_base;
+ build_free_list(&code,h->code_size);
+}
+
+/* Save the current image to disk */
+bool save_image(const vm_char *filename)
+{
+ FILE* file;
+ image_header h;
+
+ file = OPEN_WRITE(filename);
+ if(file == NULL)
+ {
+ print_string("Cannot open image file: "); print_native_string(filename); nl();
+ print_string(strerror(errno)); nl();
+ return false;
+ }
+
+ zone *tenured = &data->generations[TENURED];
+
+ h.magic = IMAGE_MAGIC;
+ h.version = IMAGE_VERSION;
+ h.data_relocation_base = tenured->start;
+ h.data_size = tenured->here - tenured->start;
+ h.code_relocation_base = code.seg->start;
+ h.code_size = heap_size(&code);
+
+ h.t = T;
+ h.bignum_zero = bignum_zero;
+ h.bignum_pos_one = bignum_pos_one;
+ h.bignum_neg_one = bignum_neg_one;
+
+ cell i;
+ for(i = 0; i < USER_ENV; i++)
+ {
+ if(i < FIRST_SAVE_ENV)
+ h.userenv[i] = F;
+ else
+ h.userenv[i] = userenv[i];
+ }
+
+ bool ok = true;
+
+ if(fwrite(&h,sizeof(image_header),1,file) != 1) ok = false;
+ if(fwrite((void*)tenured->start,h.data_size,1,file) != 1) ok = false;
+ if(fwrite(first_block(&code),h.code_size,1,file) != 1) ok = false;
+ if(fclose(file)) ok = false;
+
+ if(!ok)
+ {
+ print_string("save-image failed: "); print_string(strerror(errno)); nl();
+ }
+
+ return ok;
+}
+
+PRIMITIVE(save_image)
+{
+ /* do a full GC to push everything into tenured space */
+ gc();
+
+ gc_root<byte_array> path(dpop());
+ path.untag_check();
+ save_image((vm_char *)(path.untagged() + 1));
+}
+
+PRIMITIVE(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();
+
+ /* strip out userenv data which is set on startup anyway */
+ cell i;
+ for(i = 0; i < FIRST_SAVE_ENV; i++)
+ userenv[i] = F;
+
+ for(i = LAST_SAVE_ENV + 1; i < STACK_TRACES_ENV; i++)
+ userenv[i] = F;
+
+ /* do a full GC + code heap compaction */
+ performing_compaction = true;
+ compact_code_heap();
+ performing_compaction = false;
+
+ /* Save the image */
+ if(save_image((vm_char *)(path.untagged() + 1)))
+ exit(0);
+ else
+ exit(1);
+}
+
+static void data_fixup(cell *cell)
+{
+ if(immediate_p(*cell))
+ return;
+
+ zone *tenured = &data->generations[TENURED];
+ *cell += (tenured->start - data_relocation_base);
+}
+
+template <typename T> void code_fixup(T **handle)
+{
+ T *ptr = *handle;
+ T *new_ptr = (T *)(((cell)ptr) + (code.seg->start - code_relocation_base));
+ *handle = new_ptr;
+}
+
+static void fixup_word(word *word)
+{
+ if(word->code)
+ code_fixup(&word->code);
+ if(word->profiling)
+ code_fixup(&word->profiling);
+ code_fixup(&word->xt);
+}
+
+static void fixup_quotation(quotation *quot)
+{
+ if(quot->compiledp == F)
+ quot->xt = (void *)lazy_jit_compile;
+ else
+ {
+ code_fixup("->xt);
+ code_fixup("->code);
+ }
+}
+
+static void fixup_alien(alien *d)
+{
+ d->expired = T;
+}
+
+static void fixup_stack_frame(stack_frame *frame)
+{
+ code_fixup(&frame->xt);
+ code_fixup(&FRAME_RETURN_ADDRESS(frame));
+}
+
+static void fixup_callstack_object(callstack *stack)
+{
+ iterate_callstack_object(stack,fixup_stack_frame);
+}
+
+/* Initialize an object in a newly-loaded image */
+static void relocate_object(object *object)
+{
+ cell hi_tag = object->h.hi_tag();
+
+ /* Tuple relocation is a bit trickier; we have to fix up the
+ layout object before we can get the tuple size, so do_slots is
+ out of the question */
+ if(hi_tag == TUPLE_TYPE)
+ {
+ tuple *t = (tuple *)object;
+ data_fixup(&t->layout);
+
+ cell *scan = t->data();
+ cell *end = (cell *)((cell)object + untagged_object_size(object));
+
+ for(; scan < end; scan++)
+ data_fixup(scan);
+ }
+ else
+ {
+ do_slots((cell)object,data_fixup);
+
+ switch(hi_tag)
+ {
+ case WORD_TYPE:
+ fixup_word((word *)object);
+ break;
+ case QUOTATION_TYPE:
+ fixup_quotation((quotation *)object);
+ break;
+ case DLL_TYPE:
+ ffi_dlopen((dll *)object);
+ break;
+ case ALIEN_TYPE:
+ fixup_alien((alien *)object);
+ break;
+ case CALLSTACK_TYPE:
+ fixup_callstack_object((callstack *)object);
+ break;
+ }
+ }
+}
+
+/* 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()
+{
+ cell relocating;
+
+ cell i;
+ for(i = 0; i < USER_ENV; i++)
+ data_fixup(&userenv[i]);
+
+ data_fixup(&T);
+ data_fixup(&bignum_zero);
+ data_fixup(&bignum_pos_one);
+ data_fixup(&bignum_neg_one);
+
+ zone *tenured = &data->generations[TENURED];
+
+ for(relocating = tenured->start;
+ relocating < tenured->here;
+ relocating += untagged_object_size((object *)relocating))
+ {
+ object *obj = (object *)relocating;
+ allot_barrier(obj);
+ relocate_object(obj);
+ }
+}
+
+static void fixup_code_block(code_block *compiled)
+{
+ /* relocate literal table data */
+ data_fixup(&compiled->relocation);
+ data_fixup(&compiled->literals);
+
+ relocate_code_block(compiled);
+}
+
+void relocate_code()
+{
+ iterate_code_heap(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)
+{
+ FILE *file = OPEN_READ(p->image_path);
+ if(file == NULL)
+ {
+ print_string("Cannot open image file: "); print_native_string(p->image_path); nl();
+ print_string(strerror(errno)); nl();
+ exit(1);
+ }
+
+ image_header h;
+ if(fread(&h,sizeof(image_header),1,file) != 1)
+ fatal_error("Cannot read image header",0);
+
+ if(h.magic != IMAGE_MAGIC)
+ fatal_error("Bad image: magic number check failed",h.magic);
+
+ if(h.version != IMAGE_VERSION)
+ fatal_error("Bad image: version number check failed",h.version);
+
+ load_data_heap(file,&h,p);
+ load_code_heap(file,&h,p);
+
+ fclose(file);
+
+ init_objects(&h);
+
+ relocate_data();
+ relocate_code();
+
+ /* Store image path name */
+ userenv[IMAGE_ENV] = allot_alien(F,(cell)p->image_path);
+}
+
+}
+++ /dev/null
-#define IMAGE_MAGIC 0x0f0e0d0c
-#define IMAGE_VERSION 4
-
-typedef struct {
- CELL magic;
- CELL version;
- /* all pointers in the image file are relocated from
- relocation_base to here when the image is loaded */
- CELL data_relocation_base;
- /* size of heap */
- CELL data_size;
- /* code relocation base */
- CELL code_relocation_base;
- /* size of code heap */
- CELL code_size;
- /* tagged pointer to t singleton */
- CELL t;
- /* tagged pointer to bignum 0 */
- CELL bignum_zero;
- /* tagged pointer to bignum 1 */
- CELL bignum_pos_one;
- /* tagged pointer to bignum -1 */
- CELL bignum_neg_one;
- /* Initial user environment */
- CELL userenv[USER_ENV];
-} F_HEADER;
-
-typedef struct {
- const F_CHAR *image_path;
- const F_CHAR *executable_path;
- CELL ds_size, rs_size;
- CELL gen_count, young_size, aging_size, tenured_size;
- CELL code_size;
- bool secure_gc;
- bool fep;
- bool console;
- bool stack_traces;
- CELL max_pic_size;
-} F_PARAMETERS;
-
-void load_image(F_PARAMETERS *p);
-void init_objects(F_HEADER *h);
-bool save_image(const F_CHAR *file);
-
-void primitive_save_image(void);
-void primitive_save_image_and_exit(void);
-
-/* relocation base of currently loaded image's data heap */
-CELL data_relocation_base;
-
-INLINE void data_fixup(CELL *cell)
-{
- if(immediate_p(*cell))
- return;
-
- F_ZONE *tenured = &data_heap->generations[TENURED];
- *cell += (tenured->start - data_relocation_base);
-}
-
-CELL code_relocation_base;
-
-INLINE void code_fixup(CELL cell)
-{
- CELL value = get(cell);
- put(cell,value + (code_heap.segment->start - code_relocation_base));
-}
-
-void relocate_data();
-void relocate_code();
--- /dev/null
+namespace factor
+{
+
+#define IMAGE_MAGIC 0x0f0e0d0c
+#define IMAGE_VERSION 4
+
+struct image_header {
+ cell magic;
+ cell version;
+ /* all pointers in the image file are relocated from
+ relocation_base to here when the image is loaded */
+ cell data_relocation_base;
+ /* size of heap */
+ cell data_size;
+ /* code relocation base */
+ cell code_relocation_base;
+ /* size of code heap */
+ cell code_size;
+ /* tagged pointer to t singleton */
+ cell t;
+ /* tagged pointer to bignum 0 */
+ cell bignum_zero;
+ /* tagged pointer to bignum 1 */
+ cell bignum_pos_one;
+ /* tagged pointer to bignum -1 */
+ cell bignum_neg_one;
+ /* Initial user environment */
+ cell userenv[USER_ENV];
+};
+
+struct vm_parameters {
+ const vm_char *image_path;
+ const vm_char *executable_path;
+ cell ds_size, rs_size;
+ cell gen_count, young_size, aging_size, tenured_size;
+ cell code_size;
+ bool secure_gc;
+ bool fep;
+ bool console;
+ bool stack_traces;
+ 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);
+
+}
+++ /dev/null
-#include "master.h"
-
-void init_inline_caching(int max_size)
-{
- max_pic_size = max_size;
-}
-
-void deallocate_inline_cache(CELL return_address)
-{
- /* Find the call target. */
- XT old_xt = (XT)get_call_target(return_address);
- F_CODE_BLOCK *old_block = (F_CODE_BLOCK *)old_xt - 1;
- CELL old_type = old_block->block.type;
-
-#ifdef FACTOR_DEBUG
- /* The call target was either another PIC,
- or a compiled quotation (megamorphic stub) */
- assert(old_type == PIC_TYPE || old_type == QUOTATION_TYPE);
-#endif
-
- if(old_type == PIC_TYPE)
- heap_free(&code_heap,&old_block->block);
-}
-
-/* Figure out what kind of type check the PIC needs based on the methods
-it contains */
-static CELL determine_inline_cache_type(CELL cache_entries)
-{
- F_ARRAY *array = untag_object(cache_entries);
-
- bool seen_hi_tag = false, seen_tuple = false;
-
- CELL i;
- for(i = 0; i < array_capacity(array); i += 2)
- {
- CELL class = array_nth(array,i);
- F_FIXNUM type;
-
- /* Is it a tuple layout? */
- switch(type_of(class))
- {
- case FIXNUM_TYPE:
- type = untag_fixnum_fast(class);
- if(type >= HEADER_TYPE)
- seen_hi_tag = true;
- break;
- case ARRAY_TYPE:
- seen_tuple = true;
- break;
- default:
- critical_error("Expected a fixnum or array",class);
- break;
- }
- }
-
- if(seen_hi_tag && seen_tuple) return PIC_HI_TAG_TUPLE;
- if(seen_hi_tag && !seen_tuple) return PIC_HI_TAG;
- if(!seen_hi_tag && seen_tuple) return PIC_TUPLE;
- if(!seen_hi_tag && !seen_tuple) return PIC_TAG;
-
- critical_error("Oops",0);
- return -1;
-}
-
-static void update_pic_count(CELL type)
-{
- pic_counts[type - PIC_TAG]++;
-}
-
-static void jit_emit_check(F_JIT *jit, CELL class)
-{
- CELL template;
- if(TAG(class) == FIXNUM_TYPE && untag_fixnum_fast(class) < HEADER_TYPE)
- template = userenv[PIC_CHECK_TAG];
- else
- template = userenv[PIC_CHECK];
-
- jit_emit_with(jit,template,class);
-}
-
-/* index: 0 = top of stack, 1 = item underneath, etc
- cache_entries: array of class/method pairs */
-static F_CODE_BLOCK *compile_inline_cache(F_FIXNUM index, CELL generic_word, CELL methods, CELL cache_entries)
-{
-#ifdef FACTOR_DEBUG
- type_check(WORD_TYPE,generic_word);
- type_check(ARRAY_TYPE,cache_entries);
-#endif
-
- REGISTER_ROOT(generic_word);
- REGISTER_ROOT(methods);
- REGISTER_ROOT(cache_entries);
-
- CELL inline_cache_type = determine_inline_cache_type(cache_entries);
-
- update_pic_count(inline_cache_type);
-
- F_JIT jit;
- jit_init(&jit,PIC_TYPE,generic_word);
-
- /* Generate machine code to determine the object's class. */
- jit_emit_class_lookup(&jit,index,inline_cache_type);
-
- /* Generate machine code to check, in turn, if the class is one of the cached entries. */
- CELL i;
- for(i = 0; i < array_capacity(untag_object(cache_entries)); i += 2)
- {
- /* Class equal? */
- CELL class = array_nth(untag_object(cache_entries),i);
- jit_emit_check(&jit,class);
-
- /* Yes? Jump to method */
- CELL method = array_nth(untag_object(cache_entries),i + 1);
- jit_emit_with(&jit,userenv[PIC_HIT],method);
- }
-
- /* Generate machine code to handle a cache miss, which ultimately results in
- this function being called again.
-
- The inline-cache-miss primitive call receives enough information to
- reconstruct the PIC. */
- jit_push(&jit,generic_word);
- jit_push(&jit,methods);
- jit_push(&jit,tag_fixnum(index));
- jit_push(&jit,cache_entries);
- jit_word_jump(&jit,userenv[PIC_MISS_WORD]);
-
- F_CODE_BLOCK *code = jit_make_code_block(&jit);
- relocate_code_block(code);
-
- jit_dispose(&jit);
-
- UNREGISTER_ROOT(cache_entries);
- UNREGISTER_ROOT(methods);
- UNREGISTER_ROOT(generic_word);
-
- return code;
-}
-
-/* A generic word's definition performs general method lookup. Allocates memory */
-static XT megamorphic_call_stub(CELL generic_word)
-{
- return untag_word(generic_word)->xt;
-}
-
-static CELL inline_cache_size(CELL cache_entries)
-{
- return (cache_entries == F ? 0 : array_capacity(untag_array(cache_entries)) / 2);
-}
-
-/* Allocates memory */
-static CELL add_inline_cache_entry(CELL cache_entries, CELL class, CELL method)
-{
- if(cache_entries == F)
- return allot_array_2(class,method);
- else
- {
- F_ARRAY *cache_entries_array = untag_object(cache_entries);
- CELL pic_size = array_capacity(cache_entries_array);
- cache_entries_array = reallot_array(cache_entries_array,pic_size + 2);
- set_array_nth(cache_entries_array,pic_size,class);
- set_array_nth(cache_entries_array,pic_size + 1,method);
- return tag_array(cache_entries_array);
- }
-}
-
-static void update_pic_transitions(CELL pic_size)
-{
- if(pic_size == max_pic_size)
- pic_to_mega_transitions++;
- else if(pic_size == 0)
- cold_call_to_ic_transitions++;
- else if(pic_size == 1)
- ic_to_pic_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 */
-XT inline_cache_miss(CELL return_address)
-{
- check_code_pointer(return_address);
-
- /* Since each PIC is only referenced from a single call site,
- if the old call target was a PIC, we can deallocate it immediately,
- instead of leaving dead PICs around until the next GC. */
- deallocate_inline_cache(return_address);
-
- CELL cache_entries = dpop();
- F_FIXNUM index = untag_fixnum_fast(dpop());
- CELL methods = dpop();
- CELL generic_word = dpop();
- CELL object = get(ds - index * CELLS);
-
- XT xt;
-
- CELL pic_size = inline_cache_size(cache_entries);
-
- update_pic_transitions(pic_size);
-
- if(pic_size >= max_pic_size)
- xt = megamorphic_call_stub(generic_word);
- else
- {
- REGISTER_ROOT(generic_word);
- REGISTER_ROOT(cache_entries);
- REGISTER_ROOT(methods);
-
- CELL class = object_class(object);
- CELL method = lookup_method(object,methods);
-
- cache_entries = add_inline_cache_entry(cache_entries,class,method);
- xt = compile_inline_cache(index,generic_word,methods,cache_entries) + 1;
-
- UNREGISTER_ROOT(methods);
- UNREGISTER_ROOT(cache_entries);
- UNREGISTER_ROOT(generic_word);
- }
-
- /* Install the new stub. */
- set_call_target(return_address,(CELL)xt);
-
-#ifdef PIC_DEBUG
- printf("Updated call site 0x%lx with 0x%lx\n",return_address,(CELL)xt);
-#endif
-
- return xt;
-}
-
-void primitive_reset_inline_cache_stats(void)
-{
- 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;
-}
-
-void primitive_inline_cache_stats(void)
-{
- GROWABLE_ARRAY(stats);
- GROWABLE_ARRAY_ADD(stats,allot_cell(cold_call_to_ic_transitions));
- GROWABLE_ARRAY_ADD(stats,allot_cell(ic_to_pic_transitions));
- GROWABLE_ARRAY_ADD(stats,allot_cell(pic_to_mega_transitions));
- CELL i;
- for(i = 0; i < 4; i++)
- GROWABLE_ARRAY_ADD(stats,allot_cell(pic_counts[i]));
- GROWABLE_ARRAY_TRIM(stats);
- GROWABLE_ARRAY_DONE(stats);
- dpush(stats);
-}
--- /dev/null
+#include "master.hpp"
+
+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)
+{
+ max_pic_size = max_size;
+}
+
+void deallocate_inline_cache(cell return_address)
+{
+ /* Find the call target. */
+ void *old_xt = get_call_target(return_address);
+ code_block *old_block = (code_block *)old_xt - 1;
+ cell old_type = old_block->block.type;
+
+#ifdef FACTOR_DEBUG
+ /* The call target was either another PIC,
+ or a compiled quotation (megamorphic stub) */
+ assert(old_type == PIC_TYPE || old_type == QUOTATION_TYPE);
+#endif
+
+ if(old_type == PIC_TYPE)
+ heap_free(&code,&old_block->block);
+}
+
+/* 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)
+{
+ bool seen_hi_tag = false, seen_tuple = false;
+
+ cell i;
+ for(i = 0; i < array_capacity(cache_entries); i += 2)
+ {
+ cell klass = array_nth(cache_entries,i);
+
+ /* Is it a tuple layout? */
+ switch(TAG(klass))
+ {
+ case FIXNUM_TYPE:
+ fixnum type = untag_fixnum(klass);
+ if(type >= HEADER_TYPE)
+ seen_hi_tag = true;
+ break;
+ case ARRAY_TYPE:
+ seen_tuple = true;
+ break;
+ default:
+ critical_error("Expected a fixnum or array",klass);
+ break;
+ }
+ }
+
+ if(seen_hi_tag && seen_tuple) return PIC_HI_TAG_TUPLE;
+ if(seen_hi_tag && !seen_tuple) return PIC_HI_TAG;
+ if(!seen_hi_tag && seen_tuple) return PIC_TUPLE;
+ if(!seen_hi_tag && !seen_tuple) return PIC_TAG;
+
+ critical_error("Oops",0);
+ return -1;
+}
+
+static void 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_) {};
+
+ void emit_check(cell klass);
+ void compile_inline_cache(fixnum index, cell generic_word_, cell methods_, cell cache_entries_);
+};
+
+void inline_cache_jit::emit_check(cell klass)
+{
+ cell code_template;
+ if(TAG(klass) == FIXNUM_TYPE && untag_fixnum(klass) < HEADER_TYPE)
+ code_template = userenv[PIC_CHECK_TAG];
+ else
+ code_template = userenv[PIC_CHECK];
+
+ emit_with(code_template,klass);
+}
+
+/* index: 0 = top of stack, 1 = item underneath, etc
+ cache_entries: array of class/method pairs */
+void inline_cache_jit::compile_inline_cache(fixnum index, cell generic_word_, cell methods_, cell cache_entries_)
+{
+ gc_root<word> generic_word(generic_word_);
+ gc_root<array> methods(methods_);
+ gc_root<array> cache_entries(cache_entries_);
+
+ cell inline_cache_type = determine_inline_cache_type(cache_entries.untagged());
+ update_pic_count(inline_cache_type);
+
+ /* Generate machine code to determine the object's class. */
+ emit_class_lookup(index,inline_cache_type);
+
+ /* Generate machine code to check, in turn, if the class is one of the cached entries. */
+ cell i;
+ for(i = 0; i < array_capacity(cache_entries.untagged()); i += 2)
+ {
+ /* Class equal? */
+ cell klass = array_nth(cache_entries.untagged(),i);
+ emit_check(klass);
+
+ /* Yes? Jump to method */
+ cell method = array_nth(cache_entries.untagged(),i + 1);
+ emit_with(userenv[PIC_HIT],method);
+ }
+
+ /* Generate machine code to handle a cache miss, which ultimately results in
+ this function being called again.
+
+ The inline-cache-miss primitive call receives enough information to
+ reconstruct the PIC. */
+ push(generic_word.value());
+ push(methods.value());
+ push(tag_fixnum(index));
+ push(cache_entries.value());
+ word_jump(userenv[PIC_MISS_WORD]);
+}
+
+static code_block *compile_inline_cache(fixnum index,
+ cell generic_word_,
+ cell methods_,
+ cell cache_entries_)
+{
+ gc_root<word> generic_word(generic_word_);
+ gc_root<array> methods(methods_);
+ gc_root<array> cache_entries(cache_entries_);
+
+ inline_cache_jit jit(generic_word.value());
+ jit.compile_inline_cache(index,generic_word.value(),methods.value(),cache_entries.value());
+ code_block *code = jit.to_code_block();
+ relocate_code_block(code);
+ return code;
+}
+
+/* A generic word's definition performs general method lookup. Allocates memory */
+static void *megamorphic_call_stub(cell generic_word)
+{
+ return untag<word>(generic_word)->xt;
+}
+
+static cell 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_)
+{
+ gc_root<array> cache_entries(cache_entries_);
+ gc_root<object> klass(klass_);
+ gc_root<word> method(method_);
+
+ cell pic_size = array_capacity(cache_entries.untagged());
+ gc_root<array> new_cache_entries(reallot_array(cache_entries.untagged(),pic_size + 2));
+ 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)
+{
+ if(pic_size == max_pic_size)
+ pic_to_mega_transitions++;
+ else if(pic_size == 0)
+ cold_call_to_ic_transitions++;
+ else if(pic_size == 1)
+ ic_to_pic_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)
+{
+ check_code_pointer(return_address);
+
+ /* Since each PIC is only referenced from a single call site,
+ if the old call target was a PIC, we can deallocate it immediately,
+ instead of leaving dead PICs around until the next GC. */
+ deallocate_inline_cache(return_address);
+
+ gc_root<array> cache_entries(dpop());
+ fixnum index = untag_fixnum(dpop());
+ gc_root<array> methods(dpop());
+ gc_root<word> generic_word(dpop());
+ gc_root<object> object(((cell *)ds)[-index]);
+
+ void *xt;
+
+ cell pic_size = inline_cache_size(cache_entries.value());
+
+ update_pic_transitions(pic_size);
+
+ if(pic_size >= max_pic_size)
+ xt = megamorphic_call_stub(generic_word.value());
+ else
+ {
+ cell klass = object_class(object.value());
+ cell method = lookup_method(object.value(),methods.value());
+
+ gc_root<array> new_cache_entries(add_inline_cache_entry(
+ cache_entries.value(),
+ klass,
+ method));
+ xt = compile_inline_cache(index,
+ generic_word.value(),
+ methods.value(),
+ new_cache_entries.value()) + 1;
+ }
+
+ /* Install the new stub. */
+ set_call_target(return_address,xt);
+
+#ifdef PIC_DEBUG
+ printf("Updated call site 0x%lx with 0x%lx\n",return_address,(cell)xt);
+#endif
+
+ return xt;
+}
+
+PRIMITIVE(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)
+{
+ growable_array stats;
+ 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));
+ cell i;
+ for(i = 0; i < 4; i++)
+ stats.add(allot_cell(pic_counts[i]));
+ stats.trim();
+ dpush(stats.elements.value());
+}
+
+}
+++ /dev/null
-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 primitive_inline_cache_miss(void);
-
-XT inline_cache_miss(CELL return_address);
-
-void primitive_reset_inline_cache_stats(void);
-void primitive_inline_cache_stats(void);
--- /dev/null
+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);
+
+extern "C" void *inline_cache_miss(cell return_address);
+
+}
+++ /dev/null
-#include "master.h"
-
-/* Simple wrappers for ANSI C I/O functions, used for bootstrapping.
-
-Note the ugly loop logic in almost every function; we have to handle EINTR
-and restart the operation if the system call was interrupted. Naive
-applications don't do this, but then they quickly fail if one enables
-itimer()s or other signals.
-
-The Factor library provides platform-specific code for Unix and Windows
-with many more capabilities so these words are not usually used in
-normal operation. */
-
-void init_c_io(void)
-{
- 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)
-{
-#ifndef WINCE
- if(errno == EINTR)
- return;
-#endif
-
- CELL error = tag_object(from_char_string(strerror(errno)));
- general_error(ERROR_IO,error,F,NULL);
-}
-
-void primitive_fopen(void)
-{
- char *mode = unbox_char_string();
- REGISTER_C_STRING(mode);
- char *path = unbox_char_string();
- UNREGISTER_C_STRING(mode);
-
- for(;;)
- {
- FILE *file = fopen(path,mode);
- if(file == NULL)
- io_error();
- else
- {
- box_alien(file);
- break;
- }
- }
-}
-
-void primitive_fgetc(void)
-{
- FILE* file = unbox_alien();
-
- for(;;)
- {
- int c = fgetc(file);
- if(c == EOF)
- {
- if(feof(file))
- {
- dpush(F);
- break;
- }
- else
- io_error();
- }
- else
- {
- dpush(tag_fixnum(c));
- break;
- }
- }
-}
-
-void primitive_fread(void)
-{
- FILE* file = unbox_alien();
- CELL size = unbox_array_size();
-
- if(size == 0)
- {
- dpush(tag_object(allot_string(0,0)));
- return;
- }
-
- F_BYTE_ARRAY *buf = allot_byte_array(size);
-
- for(;;)
- {
- int c = fread(buf + 1,1,size,file);
- if(c <= 0)
- {
- if(feof(file))
- {
- dpush(F);
- break;
- }
- else
- io_error();
- }
- else
- {
- if(c != size)
- {
- REGISTER_UNTAGGED(buf);
- F_BYTE_ARRAY *new_buf = allot_byte_array(c);
- UNREGISTER_UNTAGGED(buf);
- memcpy(new_buf + 1, buf + 1,c);
- buf = new_buf;
- }
- dpush(tag_object(buf));
- break;
- }
- }
-}
-
-void primitive_fputc(void)
-{
- FILE *file = unbox_alien();
- F_FIXNUM ch = to_fixnum(dpop());
-
- for(;;)
- {
- if(fputc(ch,file) == EOF)
- {
- io_error();
-
- /* Still here? EINTR */
- }
- else
- break;
- }
-}
-
-void primitive_fwrite(void)
-{
- FILE *file = unbox_alien();
- F_BYTE_ARRAY *text = untag_byte_array(dpop());
- F_FIXNUM length = array_capacity(text);
- char *string = (char *)(text + 1);
-
- if(length == 0)
- return;
-
- for(;;)
- {
- size_t written = fwrite(string,1,length,file);
- if(written == length)
- break;
- else
- {
- if(feof(file))
- break;
- else
- io_error();
-
- /* Still here? EINTR */
- length -= written;
- string += written;
- }
- }
-}
-
-void primitive_fseek(void)
-{
- int whence = to_fixnum(dpop());
- FILE *file = unbox_alien();
- off_t offset = to_signed_8(dpop());
-
- switch(whence)
- {
- case 0: whence = SEEK_SET; break;
- case 1: whence = SEEK_CUR; break;
- case 2: whence = SEEK_END; break;
- default:
- critical_error("Bad value for whence",whence);
- break;
- }
-
- if(FSEEK(file,offset,whence) == -1)
- {
- io_error();
-
- /* Still here? EINTR */
- critical_error("Don't know what to do; EINTR from fseek()?",0);
- }
-}
-
-void primitive_fflush(void)
-{
- FILE *file = unbox_alien();
- for(;;)
- {
- if(fflush(file) == EOF)
- io_error();
- else
- break;
- }
-}
-
-void primitive_fclose(void)
-{
- FILE *file = unbox_alien();
- for(;;)
- {
- if(fclose(file) == EOF)
- io_error();
- else
- break;
- }
-}
-
-/* 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. */
-int err_no(void)
-{
- return errno;
-}
-
-void clear_err_no(void)
-{
- errno = 0;
-}
--- /dev/null
+#include "master.hpp"
+
+namespace factor
+{
+
+/* Simple wrappers for ANSI C I/O functions, used for bootstrapping.
+
+Note the ugly loop logic in almost every function; we have to handle EINTR
+and restart the operation if the system call was interrupted. Naive
+applications don't do this, but then they quickly fail if one enables
+itimer()s or other signals.
+
+The Factor library provides platform-specific code for Unix and Windows
+with many more capabilities so these words are not usually used in
+normal operation. */
+
+void init_c_io(void)
+{
+ 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)
+{
+#ifndef WINCE
+ if(errno == EINTR)
+ return;
+#endif
+
+ general_error(ERROR_IO,tag_fixnum(errno),F,NULL);
+}
+
+PRIMITIVE(fopen)
+{
+ gc_root<byte_array> mode(dpop());
+ gc_root<byte_array> path(dpop());
+ mode.untag_check();
+ path.untag_check();
+
+ for(;;)
+ {
+ FILE *file = fopen((char *)(path.untagged() + 1),
+ (char *)(mode.untagged() + 1));
+ if(file == NULL)
+ io_error();
+ else
+ {
+ box_alien(file);
+ break;
+ }
+ }
+}
+
+PRIMITIVE(fgetc)
+{
+ FILE *file = (FILE *)unbox_alien();
+
+ for(;;)
+ {
+ int c = fgetc(file);
+ if(c == EOF)
+ {
+ if(feof(file))
+ {
+ dpush(F);
+ break;
+ }
+ else
+ io_error();
+ }
+ else
+ {
+ dpush(tag_fixnum(c));
+ break;
+ }
+ }
+}
+
+PRIMITIVE(fread)
+{
+ FILE *file = (FILE *)unbox_alien();
+ fixnum size = unbox_array_size();
+
+ if(size == 0)
+ {
+ dpush(tag<string>(allot_string(0,0)));
+ return;
+ }
+
+ gc_root<byte_array> buf(allot_array_internal<byte_array>(size));
+
+ for(;;)
+ {
+ int c = fread(buf.untagged() + 1,1,size,file);
+ if(c <= 0)
+ {
+ if(feof(file))
+ {
+ dpush(F);
+ break;
+ }
+ else
+ io_error();
+ }
+ else
+ {
+ if(c != size)
+ {
+ byte_array *new_buf = allot_byte_array(c);
+ memcpy(new_buf + 1, buf.untagged() + 1,c);
+ buf = new_buf;
+ }
+ dpush(buf.value());
+ break;
+ }
+ }
+}
+
+PRIMITIVE(fputc)
+{
+ FILE *file = (FILE *)unbox_alien();
+ fixnum ch = to_fixnum(dpop());
+
+ for(;;)
+ {
+ if(fputc(ch,file) == EOF)
+ {
+ io_error();
+
+ /* Still here? EINTR */
+ }
+ else
+ break;
+ }
+}
+
+PRIMITIVE(fwrite)
+{
+ FILE *file = (FILE *)unbox_alien();
+ byte_array *text = untag_check<byte_array>(dpop());
+ cell length = array_capacity(text);
+ char *string = (char *)(text + 1);
+
+ if(length == 0)
+ return;
+
+ for(;;)
+ {
+ size_t written = fwrite(string,1,length,file);
+ if(written == length)
+ break;
+ else
+ {
+ if(feof(file))
+ break;
+ else
+ io_error();
+
+ /* Still here? EINTR */
+ length -= written;
+ string += written;
+ }
+ }
+}
+
+PRIMITIVE(fseek)
+{
+ int whence = to_fixnum(dpop());
+ FILE *file = (FILE *)unbox_alien();
+ off_t offset = to_signed_8(dpop());
+
+ switch(whence)
+ {
+ case 0: whence = SEEK_SET; break;
+ case 1: whence = SEEK_CUR; break;
+ case 2: whence = SEEK_END; break;
+ default:
+ critical_error("Bad value for whence",whence);
+ break;
+ }
+
+ if(FSEEK(file,offset,whence) == -1)
+ {
+ io_error();
+
+ /* Still here? EINTR */
+ critical_error("Don't know what to do; EINTR from fseek()?",0);
+ }
+}
+
+PRIMITIVE(fflush)
+{
+ FILE *file = (FILE *)unbox_alien();
+ for(;;)
+ {
+ if(fflush(file) == EOF)
+ io_error();
+ else
+ break;
+ }
+}
+
+PRIMITIVE(fclose)
+{
+ FILE *file = (FILE *)unbox_alien();
+ for(;;)
+ {
+ if(fclose(file) == EOF)
+ io_error();
+ else
+ break;
+ }
+}
+
+/* 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. */
+VM_C_API int err_no(void)
+{
+ return errno;
+}
+
+VM_C_API void clear_err_no(void)
+{
+ errno = 0;
+}
+
+}
+++ /dev/null
-void init_c_io(void);
-void io_error(void);
-DLLEXPORT int err_no(void);
-DLLEXPORT void clear_err_no(void);
-
-void primitive_fopen(void);
-void primitive_fgetc(void);
-void primitive_fread(void);
-void primitive_fputc(void);
-void primitive_fwrite(void);
-void primitive_fflush(void);
-void primitive_fseek(void);
-void primitive_fclose(void);
-
-/* Platform specific primitives */
-void primitive_open_file(void);
-void primitive_existsp(void);
-void primitive_read_dir(void);
--- /dev/null
+namespace factor
+{
+
+void init_c_io(void);
+void io_error(void);
+
+PRIMITIVE(fopen);
+PRIMITIVE(fgetc);
+PRIMITIVE(fread);
+PRIMITIVE(fputc);
+PRIMITIVE(fwrite);
+PRIMITIVE(fflush);
+PRIMITIVE(fseek);
+PRIMITIVE(fclose);
+
+/* Platform specific primitives */
+PRIMITIVE(open_file);
+PRIMITIVE(existsp);
+PRIMITIVE(read_dir);
+
+VM_C_API int err_no(void);
+VM_C_API void clear_err_no(void);
+
+}
+++ /dev/null
-#include "master.h"
-
-/* Simple code generator used by:
-- profiler (profiler.c),
-- quotation compiler (quotations.c),
-- megamorphic caches (dispatch.c),
-- polymorphic inline caches (inline_cache.c) */
-
-/* Allocates memory */
-void jit_init(F_JIT *jit, CELL jit_type, CELL owner)
-{
- jit->owner = owner;
- REGISTER_ROOT(jit->owner);
-
- jit->type = jit_type;
-
- jit->code = make_growable_byte_array();
- REGISTER_ROOT(jit->code.array);
- jit->relocation = make_growable_byte_array();
- REGISTER_ROOT(jit->relocation.array);
- jit->literals = make_growable_array();
- REGISTER_ROOT(jit->literals.array);
-
- if(stack_traces_p())
- growable_array_add(&jit->literals,jit->owner);
-
- jit->computing_offset_p = false;
-}
-
-/* Facility to convert compiled code offsets to quotation offsets.
-Call jit_compute_offset() with the compiled code offset, then emit
-code, and at the end jit->position is the quotation position. */
-void jit_compute_position(F_JIT *jit, CELL offset)
-{
- jit->computing_offset_p = true;
- jit->position = 0;
- jit->offset = offset;
-}
-
-/* Allocates memory */
-F_CODE_BLOCK *jit_make_code_block(F_JIT *jit)
-{
- growable_byte_array_trim(&jit->code);
- growable_byte_array_trim(&jit->relocation);
- growable_array_trim(&jit->literals);
-
- F_CODE_BLOCK *code = add_code_block(
- jit->type,
- untag_object(jit->code.array),
- NULL, /* no labels */
- jit->relocation.array,
- jit->literals.array);
-
- return code;
-}
-
-void jit_dispose(F_JIT *jit)
-{
- UNREGISTER_ROOT(jit->literals.array);
- UNREGISTER_ROOT(jit->relocation.array);
- UNREGISTER_ROOT(jit->code.array);
- UNREGISTER_ROOT(jit->owner);
-}
-
-static F_REL rel_to_emit(F_JIT *jit, CELL template, bool *rel_p)
-{
- F_ARRAY *quadruple = untag_object(template);
- CELL rel_class = array_nth(quadruple,1);
- CELL rel_type = array_nth(quadruple,2);
- CELL offset = array_nth(quadruple,3);
-
- if(rel_class == F)
- {
- *rel_p = false;
- return 0;
- }
- else
- {
- *rel_p = true;
- return (untag_fixnum_fast(rel_type) << 28)
- | (untag_fixnum_fast(rel_class) << 24)
- | ((jit->code.count + untag_fixnum_fast(offset)));
- }
-}
-
-/* Allocates memory */
-void jit_emit(F_JIT *jit, CELL template)
-{
- REGISTER_ROOT(template);
-
- bool rel_p;
- F_REL rel = rel_to_emit(jit,template,&rel_p);
- if(rel_p) growable_byte_array_append(&jit->relocation,&rel,sizeof(F_REL));
-
- F_BYTE_ARRAY *code = code_to_emit(template);
-
- if(jit->computing_offset_p)
- {
- CELL size = array_capacity(code);
-
- if(jit->offset == 0)
- {
- jit->position--;
- jit->computing_offset_p = false;
- }
- else if(jit->offset < size)
- {
- jit->position++;
- jit->computing_offset_p = false;
- }
- else
- jit->offset -= size;
- }
-
- growable_byte_array_append(&jit->code,code + 1,array_capacity(code));
-
- UNREGISTER_ROOT(template);
-}
-
--- /dev/null
+#include "master.hpp"
+
+namespace factor
+{
+
+/* Simple code generator used by:
+- profiler (profiler.cpp),
+- quotation compiler (quotations.cpp),
+- megamorphic caches (dispatch.cpp),
+- polymorphic inline caches (inline_cache.cpp) */
+
+/* Allocates memory */
+jit::jit(cell type_, cell owner_)
+ : type(type_),
+ owner(owner_),
+ code(),
+ relocation(),
+ literals(),
+ computing_offset_p(false),
+ position(0),
+ offset(0)
+{
+ if(stack_traces_p()) literal(owner.value());
+}
+
+relocation_entry jit::rel_to_emit(cell code_template, bool *rel_p)
+{
+ array *quadruple = untag<array>(code_template);
+ cell rel_class = array_nth(quadruple,1);
+ cell rel_type = array_nth(quadruple,2);
+ cell offset = array_nth(quadruple,3);
+
+ if(rel_class == F)
+ {
+ *rel_p = false;
+ return 0;
+ }
+ else
+ {
+ *rel_p = true;
+ return (untag_fixnum(rel_type) << 28)
+ | (untag_fixnum(rel_class) << 24)
+ | ((code.count + untag_fixnum(offset)));
+ }
+}
+
+/* Allocates memory */
+void jit::emit(cell code_template_)
+{
+ gc_root<array> code_template(code_template_);
+
+ bool rel_p;
+ relocation_entry rel = rel_to_emit(code_template.value(),&rel_p);
+ if(rel_p) relocation.append_bytes(&rel,sizeof(relocation_entry));
+
+ gc_root<byte_array> insns(array_nth(code_template.untagged(),0));
+
+ if(computing_offset_p)
+ {
+ cell size = array_capacity(insns.untagged());
+
+ if(offset == 0)
+ {
+ position--;
+ computing_offset_p = false;
+ }
+ else if(offset < size)
+ {
+ position++;
+ computing_offset_p = false;
+ }
+ else
+ offset -= size;
+ }
+
+ code.append_byte_array(insns.value());
+}
+
+void jit::emit_with(cell code_template_, cell argument_) {
+ gc_root<array> code_template(code_template_);
+ gc_root<object> argument(argument_);
+ 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]);
+}
+
+/* Facility to convert compiled code offsets to quotation offsets.
+Call jit_compute_offset() with the compiled code offset, then emit
+code, and at the end jit->position is the quotation position. */
+void jit::compute_position(cell offset_)
+{
+ computing_offset_p = true;
+ position = 0;
+ offset = offset_;
+}
+
+/* Allocates memory */
+code_block *jit::to_code_block()
+{
+ code.trim();
+ relocation.trim();
+ literals.trim();
+
+ return add_code_block(
+ type,
+ code.elements.value(),
+ F, /* no labels */
+ relocation.elements.value(),
+ literals.elements.value());
+}
+
+}
+++ /dev/null
-typedef struct {
- CELL type;
- CELL owner;
- F_GROWABLE_BYTE_ARRAY code;
- F_GROWABLE_BYTE_ARRAY relocation;
- F_GROWABLE_ARRAY literals;
- bool computing_offset_p;
- F_FIXNUM position;
- CELL offset;
-} F_JIT;
-
-void jit_init(F_JIT *jit, CELL jit_type, CELL owner);
-
-void jit_compute_position(F_JIT *jit, CELL offset);
-
-F_CODE_BLOCK *jit_make_code_block(F_JIT *jit);
-
-void jit_dispose(F_JIT *jit);
-
-INLINE F_BYTE_ARRAY *code_to_emit(CELL template)
-{
- return untag_object(array_nth(untag_object(template),0));
-}
-
-void jit_emit(F_JIT *jit, CELL template);
-
-/* Allocates memory */
-INLINE void jit_add_literal(F_JIT *jit, CELL literal)
-{
- growable_array_add(&jit->literals,literal);
-}
-
-/* Allocates memory */
-INLINE void jit_emit_with(F_JIT *jit, CELL template, CELL argument)
-{
- REGISTER_ROOT(template);
- jit_add_literal(jit,argument);
- UNREGISTER_ROOT(template);
- jit_emit(jit,template);
-}
-
-/* Allocates memory */
-INLINE void jit_push(F_JIT *jit, CELL literal)
-{
- jit_emit_with(jit,userenv[JIT_PUSH_IMMEDIATE],literal);
-}
-
-/* Allocates memory */
-INLINE void jit_word_jump(F_JIT *jit, CELL word)
-{
- jit_emit_with(jit,userenv[JIT_WORD_JUMP],word);
-}
-
-/* Allocates memory */
-INLINE void jit_word_call(F_JIT *jit, CELL word)
-{
- jit_emit_with(jit,userenv[JIT_WORD_CALL],word);
-}
-
-/* Allocates memory */
-INLINE void jit_emit_subprimitive(F_JIT *jit, F_WORD *word)
-{
- REGISTER_UNTAGGED(word);
- if(array_nth(untag_object(word->subprimitive),1) != F)
- jit_add_literal(jit,T);
- UNREGISTER_UNTAGGED(word);
-
- jit_emit(jit,word->subprimitive);
-}
-
-INLINE F_FIXNUM jit_get_position(F_JIT *jit)
-{
- if(jit->computing_offset_p)
- {
- /* If this is still on, jit_emit() didn't clear it,
- so the offset was out of bounds */
- return -1;
- }
- else
- return jit->position;
-}
-
-INLINE void jit_set_position(F_JIT *jit, F_FIXNUM position)
-{
- if(jit->computing_offset_p)
- jit->position = position;
-}
--- /dev/null
+namespace factor
+{
+
+struct jit {
+ cell type;
+ gc_root<object> owner;
+ growable_byte_array code;
+ growable_byte_array relocation;
+ growable_array literals;
+ bool computing_offset_p;
+ fixnum position;
+ cell offset;
+
+ jit(cell jit_type, cell owner);
+ void compute_position(cell offset);
+
+ relocation_entry rel_to_emit(cell code_template, bool *rel_p);
+ void emit(cell code_template);
+
+ void literal(cell literal) { literals.add(literal); }
+ void emit_with(cell code_template_, cell literal_);
+
+ void push(cell literal) {
+ emit_with(userenv[JIT_PUSH_IMMEDIATE],literal);
+ }
+
+ void word_jump(cell word) {
+ emit_with(userenv[JIT_WORD_JUMP],word);
+ }
+
+ void word_call(cell word) {
+ emit_with(userenv[JIT_WORD_CALL],word);
+ }
+
+ void emit_subprimitive(cell word_) {
+ gc_root<word> word(word_);
+ gc_root<array> code_template(word->subprimitive);
+ if(array_nth(code_template.untagged(),1) != F) literal(T);
+ emit(code_template.value());
+ }
+
+ void emit_class_lookup(fixnum index, cell type);
+
+ fixnum get_position() {
+ if(computing_offset_p)
+ {
+ /* If this is still on, emit() didn't clear it,
+ so the offset was out of bounds */
+ return -1;
+ }
+ else
+ return position;
+ }
+
+ void set_position(fixnum position_) {
+ if(computing_offset_p)
+ position = position_;
+ }
+
+
+ code_block *to_code_block();
+};
+
+}
+++ /dev/null
-#define INLINE inline static
-
-typedef unsigned char u8;
-typedef unsigned short u16;
-typedef unsigned int u32;
-typedef unsigned long long u64;
-typedef signed char s8;
-typedef signed short s16;
-typedef signed int s32;
-typedef signed long long s64;
-
-#ifdef _WIN64
- typedef long long F_FIXNUM;
- typedef unsigned long long CELL;
-#else
- typedef long F_FIXNUM;
- typedef unsigned long CELL;
-#endif
-
-#define CELLS ((signed)sizeof(CELL))
-
-#define WORD_SIZE (CELLS*8)
-#define HALF_WORD_SIZE (CELLS*4)
-#define HALF_WORD_MASK (((unsigned long)1<<HALF_WORD_SIZE)-1)
-
-#define TAG_MASK 7
-#define TAG_BITS 3
-#define TAG(cell) ((CELL)(cell) & TAG_MASK)
-#define UNTAG(cell) ((CELL)(cell) & ~TAG_MASK)
-#define RETAG(cell,tag) (UNTAG(cell) | (tag))
-
-/*** Tags ***/
-#define FIXNUM_TYPE 0
-#define BIGNUM_TYPE 1
-#define ARRAY_TYPE 2
-#define FLOAT_TYPE 3
-#define QUOTATION_TYPE 4
-#define F_TYPE 5
-#define OBJECT_TYPE 6
-#define TUPLE_TYPE 7
-
-#define HI_TAG_OR_TUPLE_P(cell) (((CELL)(cell) & 6) == 6)
-#define HI_TAG_HEADER(cell) (((CELL)(cell) & 1) * CELLS + UNTAG(cell))
-
-/* Canonical F object */
-#define F F_TYPE
-
-#define HEADER_TYPE 8 /* anything less than this is a tag */
-
-#define GC_COLLECTED 5 /* can be anything other than FIXNUM_TYPE */
-
-/*** Header types ***/
-#define WRAPPER_TYPE 8
-#define BYTE_ARRAY_TYPE 9
-#define CALLSTACK_TYPE 10
-#define STRING_TYPE 11
-#define WORD_TYPE 12
-#define DLL_TYPE 13
-#define ALIEN_TYPE 14
-
-#define TYPE_COUNT 15
-
-/* Not a real type, but F_CODE_BLOCK's type field can be set to this */
-#define PIC_TYPE 69
-
-INLINE bool immediate_p(CELL obj)
-{
- return (obj == F || TAG(obj) == FIXNUM_TYPE);
-}
-
-INLINE F_FIXNUM untag_fixnum_fast(CELL tagged)
-{
- return ((F_FIXNUM)tagged) >> TAG_BITS;
-}
-
-INLINE CELL tag_fixnum(F_FIXNUM untagged)
-{
- return RETAG(untagged << TAG_BITS,FIXNUM_TYPE);
-}
-
-INLINE void *untag_object(CELL tagged)
-{
- return (void *)UNTAG(tagged);
-}
-
-typedef void *XT;
-
-/* Assembly code makes assumptions about the layout of this struct */
-typedef struct {
- CELL header;
- /* tagged */
- CELL capacity;
-} F_ARRAY;
-
-typedef F_ARRAY F_BYTE_ARRAY;
-
-/* Assembly code makes assumptions about the layout of this struct */
-typedef struct {
- CELL header;
- /* tagged num of chars */
- CELL length;
- /* tagged */
- CELL aux;
- /* tagged */
- CELL hashcode;
-} F_STRING;
-
-/* The compiled code heap is structured into blocks. */
-typedef enum
-{
- B_FREE,
- B_ALLOCATED,
- B_MARKED
-} F_BLOCK_STATUS;
-
-typedef struct _F_BLOCK
-{
- char status; /* free or allocated? */
- char type; /* this is WORD_TYPE or QUOTATION_TYPE */
- char last_scan; /* the youngest generation in which this block's literals may live */
- char needs_fixup; /* is this a new block that needs full fixup? */
-
- /* In bytes, includes this header */
- CELL size;
-
- /* Used during compaction */
- struct _F_BLOCK *forwarding;
-} F_BLOCK;
-
-typedef struct _F_FREE_BLOCK
-{
- F_BLOCK block;
-
- /* Filled in on image load */
- struct _F_FREE_BLOCK *next_free;
-} F_FREE_BLOCK;
-
-typedef struct
-{
- F_BLOCK block;
- CELL literals; /* # bytes */
- CELL relocation; /* tagged pointer to byte-array or f */
-} F_CODE_BLOCK;
-
-/* Assembly code makes assumptions about the layout of this struct */
-typedef struct {
- /* TAGGED header */
- CELL header;
- /* TAGGED hashcode */
- CELL hashcode;
- /* TAGGED word name */
- CELL name;
- /* TAGGED word vocabulary */
- CELL vocabulary;
- /* TAGGED definition */
- CELL def;
- /* TAGGED property assoc for library code */
- CELL props;
- /* TAGGED alternative entry point for direct non-tail calls. Used for inline caching */
- CELL direct_entry_def;
- /* TAGGED call count for profiling */
- CELL counter;
- /* TAGGED machine code for sub-primitive */
- CELL subprimitive;
- /* UNTAGGED execution token: jump here to execute word */
- XT xt;
- /* UNTAGGED compiled code block */
- F_CODE_BLOCK *code;
- /* UNTAGGED profiler stub */
- F_CODE_BLOCK *profiling;
-} F_WORD;
-
-/* Assembly code makes assumptions about the layout of this struct */
-typedef struct {
- CELL header;
- CELL object;
-} F_WRAPPER;
-
-/* Assembly code makes assumptions about the layout of this struct */
-typedef struct {
-/* We use a union here to force the float value to be aligned on an
-8-byte boundary. */
- union {
- CELL header;
- long long padding;
- };
- double n;
-} F_FLOAT;
-
-/* Assembly code makes assumptions about the layout of this struct */
-typedef struct {
- CELL header;
- /* tagged */
- CELL array;
- /* tagged */
- CELL compiledp;
- /* tagged */
- CELL cached_effect;
- /* tagged */
- CELL cache_counter;
- /* UNTAGGED */
- XT xt;
- /* UNTAGGED compiled code block */
- F_CODE_BLOCK *code;
-} F_QUOTATION;
-
-/* Assembly code makes assumptions about the layout of this struct */
-typedef struct {
- CELL header;
- /* tagged */
- CELL alien;
- /* tagged */
- CELL expired;
- /* untagged */
- CELL displacement;
-} F_ALIEN;
-
-typedef struct {
- CELL header;
- /* tagged byte array holding a C string */
- CELL path;
- /* OS-specific handle */
- void *dll;
-} F_DLL;
-
-typedef struct {
- CELL header;
- /* tagged */
- CELL length;
-} F_CALLSTACK;
-
-typedef struct
-{
- XT xt;
- /* Frame size in bytes */
- CELL size;
-} F_STACK_FRAME;
-
-/* These are really just arrays, but certain elements have special
-significance */
-typedef struct
-{
- CELL header;
- /* tagged */
- CELL capacity;
- /* tagged */
- CELL class;
- /* tagged fixnum */
- CELL size;
- /* tagged fixnum */
- CELL echelon;
-} F_TUPLE_LAYOUT;
-
-typedef struct
-{
- CELL header;
- /* tagged layout */
- CELL layout;
-} F_TUPLE;
--- /dev/null
+namespace factor
+{
+
+typedef unsigned char u8;
+typedef unsigned short u16;
+typedef unsigned int u32;
+typedef unsigned long long u64;
+typedef signed char s8;
+typedef signed short s16;
+typedef signed int s32;
+typedef signed long long s64;
+
+#ifdef _WIN64
+ typedef long long fixnum;
+ typedef unsigned long long cell;
+#else
+ typedef long fixnum;
+ typedef unsigned long cell;
+#endif
+
+inline static cell align(cell a, cell b)
+{
+ return (a + (b-1)) & ~(b-1);
+}
+
+#define align8(a) align(a,8)
+#define align_page(a) align(a,getpagesize())
+
+#define WORD_SIZE (signed)(sizeof(cell)*8)
+
+#define TAG_MASK 7
+#define TAG_BITS 3
+#define TAG(x) ((cell)(x) & TAG_MASK)
+#define UNTAG(x) ((cell)(x) & ~TAG_MASK)
+#define RETAG(x,tag) (UNTAG(x) | (tag))
+
+/*** Tags ***/
+#define FIXNUM_TYPE 0
+#define BIGNUM_TYPE 1
+#define ARRAY_TYPE 2
+#define FLOAT_TYPE 3
+#define QUOTATION_TYPE 4
+#define F_TYPE 5
+#define OBJECT_TYPE 6
+#define TUPLE_TYPE 7
+
+/* Canonical F object */
+#define F F_TYPE
+
+#define HEADER_TYPE 8 /* anything less than this is a tag */
+
+#define GC_COLLECTED 5 /* can be anything other than FIXNUM_TYPE */
+
+/*** Header types ***/
+#define WRAPPER_TYPE 8
+#define BYTE_ARRAY_TYPE 9
+#define CALLSTACK_TYPE 10
+#define STRING_TYPE 11
+#define WORD_TYPE 12
+#define DLL_TYPE 13
+#define ALIEN_TYPE 14
+
+#define TYPE_COUNT 15
+
+/* Not a real type, but code_block's type field can be set to this */
+#define PIC_TYPE 69
+
+inline static bool immediate_p(cell obj)
+{
+ return (obj == F || TAG(obj) == FIXNUM_TYPE);
+}
+
+inline static fixnum untag_fixnum(cell tagged)
+{
+#ifdef FACTOR_DEBUG
+ assert(TAG(tagged) == FIXNUM_TYPE);
+#endif
+ return ((fixnum)tagged) >> TAG_BITS;
+}
+
+inline static cell tag_fixnum(fixnum untagged)
+{
+ return RETAG(untagged << TAG_BITS,FIXNUM_TYPE);
+}
+
+inline static cell tag_for(cell type)
+{
+ return type < HEADER_TYPE ? type : OBJECT_TYPE;
+}
+
+class object;
+
+struct header {
+ cell value;
+
+ header(cell value_) : value(value_ << TAG_BITS) {}
+
+ void check_header() {
+#ifdef FACTOR_DEBUG
+ assert(TAG(value) == FIXNUM_TYPE && untag_fixnum(value) < TYPE_COUNT);
+#endif
+ }
+
+ cell hi_tag() {
+ check_header();
+ return value >> TAG_BITS;
+ }
+
+ bool forwarding_pointer_p() {
+ return TAG(value) == GC_COLLECTED;
+ }
+
+ object *forwarding_pointer() {
+ return (object *)UNTAG(value);
+ }
+
+ void forward_to(object *pointer) {
+ value = RETAG(pointer,GC_COLLECTED);
+ }
+};
+
+#define NO_TYPE_CHECK static const cell type_number = TYPE_COUNT
+
+struct object {
+ NO_TYPE_CHECK;
+ header h;
+ cell *slots() { return (cell *)this; }
+};
+
+/* Assembly code makes assumptions about the layout of this struct */
+struct array : public object {
+ static const cell type_number = ARRAY_TYPE;
+ static const cell element_size = sizeof(cell);
+ /* tagged */
+ cell capacity;
+
+ cell *data() { return (cell *)(this + 1); }
+};
+
+/* These are really just arrays, but certain elements have special
+significance */
+struct tuple_layout : public array {
+ NO_TYPE_CHECK;
+ /* tagged */
+ cell klass;
+ /* tagged fixnum */
+ cell size;
+ /* tagged fixnum */
+ cell echelon;
+};
+
+struct bignum : public object {
+ static const cell type_number = BIGNUM_TYPE;
+ static const cell element_size = sizeof(cell);
+ /* tagged */
+ cell capacity;
+
+ cell *data() { return (cell *)(this + 1); }
+};
+
+struct byte_array : public object {
+ static const cell type_number = BYTE_ARRAY_TYPE;
+ static const cell element_size = 1;
+ /* tagged */
+ cell capacity;
+
+ template<typename T> T *data() { return (T *)(this + 1); }
+};
+
+/* Assembly code makes assumptions about the layout of this struct */
+struct string : public object {
+ static const cell type_number = STRING_TYPE;
+ /* tagged num of chars */
+ cell length;
+ /* tagged */
+ cell aux;
+ /* tagged */
+ cell hashcode;
+
+ u8 *data() { return (u8 *)(this + 1); }
+};
+
+/* The compiled code heap is structured into blocks. */
+enum block_status
+{
+ B_FREE,
+ B_ALLOCATED,
+ B_MARKED
+};
+
+struct heap_block
+{
+ unsigned char status; /* free or allocated? */
+ unsigned char type; /* this is WORD_TYPE or QUOTATION_TYPE */
+ unsigned char last_scan; /* the youngest generation in which this block's literals may live */
+ char needs_fixup; /* is this a new block that needs full fixup? */
+
+ /* In bytes, includes this header */
+ cell size;
+
+ /* Used during compaction */
+ heap_block *forwarding;
+};
+
+struct free_heap_block
+{
+ heap_block block;
+
+ /* Filled in on image load */
+ free_heap_block *next_free;
+};
+
+struct code_block
+{
+ heap_block block;
+ cell literals; /* # bytes */
+ cell relocation; /* tagged pointer to byte-array or f */
+
+ void *xt() { return (void *)(this + 1); }
+};
+
+/* Assembly code makes assumptions about the layout of this struct */
+struct word : public object {
+ static const cell type_number = WORD_TYPE;
+ /* TAGGED hashcode */
+ cell hashcode;
+ /* TAGGED word name */
+ cell name;
+ /* TAGGED word vocabulary */
+ cell vocabulary;
+ /* TAGGED definition */
+ cell def;
+ /* TAGGED property assoc for library code */
+ cell props;
+ /* TAGGED alternative entry point for direct non-tail calls. Used for inline caching */
+ cell direct_entry_def;
+ /* TAGGED call count for profiling */
+ cell counter;
+ /* TAGGED machine code for sub-primitive */
+ cell subprimitive;
+ /* UNTAGGED execution token: jump here to execute word */
+ void *xt;
+ /* UNTAGGED compiled code block */
+ code_block *code;
+ /* UNTAGGED profiler stub */
+ code_block *profiling;
+};
+
+/* Assembly code makes assumptions about the layout of this struct */
+struct wrapper : public object {
+ static const cell type_number = WRAPPER_TYPE;
+ cell object;
+};
+
+/* Assembly code makes assumptions about the layout of this struct */
+struct boxed_float : object {
+ static const cell type_number = FLOAT_TYPE;
+
+#ifndef FACTOR_64
+ cell padding;
+#endif
+
+ double n;
+};
+
+/* Assembly code makes assumptions about the layout of this struct */
+struct quotation : public object {
+ static const cell type_number = QUOTATION_TYPE;
+ /* tagged */
+ cell array;
+ /* tagged */
+ cell compiledp;
+ /* tagged */
+ cell cached_effect;
+ /* tagged */
+ cell cache_counter;
+ /* UNTAGGED */
+ void *xt;
+ /* UNTAGGED compiled code block */
+ code_block *code;
+};
+
+/* Assembly code makes assumptions about the layout of this struct */
+struct alien : public object {
+ static const cell type_number = ALIEN_TYPE;
+ /* tagged */
+ cell alien;
+ /* tagged */
+ cell expired;
+ /* untagged */
+ cell displacement;
+};
+
+struct dll : public object {
+ static const cell type_number = DLL_TYPE;
+ /* tagged byte array holding a C string */
+ cell path;
+ /* OS-specific handle */
+ void *dll;
+};
+
+struct callstack : public object {
+ static const cell type_number = CALLSTACK_TYPE;
+ /* tagged */
+ cell length;
+};
+
+struct stack_frame
+{
+ void *xt;
+ /* Frame size in bytes */
+ cell size;
+};
+
+struct tuple : public object {
+ static const cell type_number = TUPLE_TYPE;
+ /* tagged layout */
+ cell layout;
+
+ cell *data() { return (cell *)(this + 1); }
+};
+
+}
--- /dev/null
+#include "master.hpp"
+
+namespace factor
+{
+
+segment *gc_locals_region;
+cell gc_locals;
+
+segment *gc_bignums_region;
+cell gc_bignums;
+
+}
+++ /dev/null
-/* If a runtime function needs to call another function which potentially
-allocates memory, it must store any local variable references to Factor
-objects on the root stack */
-
-/* GC locals: stores addresses of pointers to objects. The GC updates these
-pointers, so you can do
-
-REGISTER_ROOT(some_local);
-
-... allocate memory ...
-
-foo(some_local);
-
-...
-
-UNREGISTER_ROOT(some_local); */
-F_SEGMENT *gc_locals_region;
-CELL gc_locals;
-
-DEFPUSHPOP(gc_local_,gc_locals)
-
-#define REGISTER_ROOT(obj) \
- { \
- if(!immediate_p(obj)) \
- check_data_pointer(obj); \
- gc_local_push((CELL)&(obj)); \
- }
-#define UNREGISTER_ROOT(obj) \
- { \
- if(gc_local_pop() != (CELL)&(obj)) \
- critical_error("Mismatched REGISTER_ROOT/UNREGISTER_ROOT",0); \
- }
-
-/* Extra roots: stores pointers to objects in the heap. Requires extra work
-(you have to unregister before accessing the object) but more flexible. */
-F_SEGMENT *extra_roots_region;
-CELL extra_roots;
-
-DEFPUSHPOP(root_,extra_roots)
-
-#define REGISTER_UNTAGGED(obj) root_push(obj ? RETAG(obj,OBJECT_TYPE) : 0)
-#define UNREGISTER_UNTAGGED(obj) obj = untag_object(root_pop())
-
-/* We ignore strings which point outside the data heap, but we might be given
-a char* which points inside the data heap, in which case it is a root, for
-example if we call unbox_char_string() the result is placed in a byte array */
-INLINE bool root_push_alien(const void *ptr)
-{
- if(in_data_heap_p((CELL)ptr))
- {
- F_BYTE_ARRAY *objptr = ((F_BYTE_ARRAY *)ptr) - 1;
- if(objptr->header == tag_header(BYTE_ARRAY_TYPE))
- {
- root_push(tag_object(objptr));
- return true;
- }
- }
-
- return false;
-}
-
-#define REGISTER_C_STRING(obj) \
- bool obj##_root = root_push_alien(obj)
-#define UNREGISTER_C_STRING(obj) \
- if(obj##_root) obj = alien_offset(root_pop())
-
-#define REGISTER_BIGNUM(obj) if(obj) root_push(tag_bignum(obj))
-#define UNREGISTER_BIGNUM(obj) if(obj) obj = (untag_object(root_pop()))
--- /dev/null
+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 segment *gc_locals_region;
+extern cell gc_locals;
+
+DEFPUSHPOP(gc_local_,gc_locals)
+
+template <typename T>
+struct gc_root : public tagged<T>
+{
+ void push() { gc_local_push((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
+ cell old = gc_local_pop();
+ assert(old == (cell)this);
+#else
+ gc_local_pop();
+#endif
+ }
+};
+
+/* A similar hack for the bignum implementation */
+extern segment *gc_bignums_region;
+extern cell gc_bignums;
+
+DEFPUSHPOP(gc_bignum_,gc_bignums)
+
+struct gc_bignum
+{
+ bignum **addr;
+
+ gc_bignum(bignum **addr_) : addr(addr_) {
+ if(*addr_)
+ check_data_pointer(*addr_);
+ gc_bignum_push((cell)addr);
+ }
+
+ ~gc_bignum() { assert((cell)addr == gc_bignum_pop()); }
+};
+
+#define GC_BIGNUM(x) gc_bignum x##__gc_root(&x)
+
+}
+++ /dev/null
-/* Fault handler information. MacOSX version.
-Copyright (C) 1993-1999, 2002-2003 Bruno Haible <clisp.org at bruno>
-Copyright (C) 2003 Paolo Bonzini <gnu.org at bonzini>
-
-Used under BSD license with permission from Paolo Bonzini and Bruno Haible,
-2005-03-10:
-
-http://sourceforge.net/mailarchive/message.php?msg_name=200503102200.32002.bruno%40clisp.org
-
-Modified for Factor by Slava Pestov */
-
-#include "master.h"
-
-/* The following sources were used as a *reference* for this exception handling
-code:
-1. Apple's mach/xnu documentation
-2. Timothy J. Wood's "Mach Exception Handlers 101" post to the
-omnigroup's macosx-dev list.
-http://www.wodeveloper.com/omniLists/macosx-dev/2000/June/msg00137.html */
-
-/* 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(exception_type_t exception,
- MACH_EXC_STATE_TYPE *exc_state,
- MACH_THREAD_STATE_TYPE *thread_state)
-{
- /* There is a race condition here, but in practice an exception
- delivered during stack frame setup/teardown or while transitioning
- from Factor to C is a sign of things seriously gone wrong, not just
- a divide by zero or stack underflow in the listener */
-
- /* Are we in compiled Factor code? Then use the current stack pointer */
- if(in_code_heap_p(MACH_PROGRAM_COUNTER(thread_state)))
- signal_callstack_top = (void *)MACH_STACK_POINTER(thread_state);
- /* Are we in C? Then use the saved callstack top */
- else
- signal_callstack_top = NULL;
-
- MACH_STACK_POINTER(thread_state) = fix_stack_pointer(MACH_STACK_POINTER(thread_state));
-
- /* Now we point the program counter at the right handler function. */
- if(exception == EXC_BAD_ACCESS)
- {
- signal_fault_addr = MACH_EXC_STATE_FAULT(exc_state);
- MACH_PROGRAM_COUNTER(thread_state) = (CELL)memory_signal_handler_impl;
- }
- else
- {
- if(exception == EXC_ARITHMETIC)
- signal_number = SIGFPE;
- else
- signal_number = SIGABRT;
- MACH_PROGRAM_COUNTER(thread_state) = (CELL)misc_signal_handler_impl;
- }
-}
-
-/* Handle an exception by invoking the user's fault handler and/or forwarding
-the duty to the previously installed handlers. */
-kern_return_t
-catch_exception_raise (mach_port_t exception_port,
- mach_port_t thread,
- mach_port_t task,
- exception_type_t exception,
- exception_data_t code,
- mach_msg_type_number_t code_count)
-{
- MACH_EXC_STATE_TYPE exc_state;
- MACH_THREAD_STATE_TYPE thread_state;
- mach_msg_type_number_t state_count;
-
- /* Get fault information and the faulting thread's register contents..
-
- See http://web.mit.edu/darwin/src/modules/xnu/osfmk/man/thread_get_state.html. */
- state_count = MACH_EXC_STATE_COUNT;
- if (thread_get_state (thread, MACH_EXC_STATE_FLAVOR,
- (void *) &exc_state, &state_count)
- != KERN_SUCCESS)
- {
- /* The thread is supposed to be suspended while the exception
- handler is called. This shouldn't fail. */
- return KERN_FAILURE;
- }
-
- state_count = MACH_THREAD_STATE_COUNT;
- if (thread_get_state (thread, MACH_THREAD_STATE_FLAVOR,
- (void *) &thread_state, &state_count)
- != KERN_SUCCESS)
- {
- /* The thread is supposed to be suspended while the exception
- handler is called. This shouldn't fail. */
- return KERN_FAILURE;
- }
-
- /* Modify registers so to have the thread resume executing the
- fault handler */
- call_fault_handler(exception,&exc_state,&thread_state);
-
- /* Set the faulting thread's register contents..
-
- See http://web.mit.edu/darwin/src/modules/xnu/osfmk/man/thread_set_state.html. */
- if (thread_set_state (thread, MACH_THREAD_STATE_FLAVOR,
- (void *) &thread_state, state_count)
- != KERN_SUCCESS)
- {
- return KERN_FAILURE;
- }
-
- return KERN_SUCCESS;
-}
-
-
-/* The main function of the thread listening for exceptions. */
-static void *
-mach_exception_thread (void *arg)
-{
- for (;;)
- {
- /* These two structures contain some private kernel data. We don't need
- to access any of it so we don't bother defining a proper struct. The
- correct definitions are in the xnu source code. */
- /* Buffer for a message to be received. */
- struct
- {
- mach_msg_header_t head;
- mach_msg_body_t msgh_body;
- char data[1024];
- }
- msg;
- /* Buffer for a reply message. */
- struct
- {
- mach_msg_header_t head;
- char data[1024];
- }
- reply;
-
- mach_msg_return_t retval;
-
- /* Wait for a message on the exception port. */
- retval = mach_msg (&msg.head, MACH_RCV_MSG | MACH_RCV_LARGE, 0,
- sizeof (msg), our_exception_port,
- MACH_MSG_TIMEOUT_NONE, MACH_PORT_NULL);
- if (retval != MACH_MSG_SUCCESS)
- {
- abort ();
- }
-
- /* Handle the message: Call exc_server, which will call
- catch_exception_raise and produce a reply message. */
- exc_server (&msg.head, &reply.head);
-
- /* Send the reply. */
- if (mach_msg (&reply.head, MACH_SEND_MSG, reply.head.msgh_size,
- 0, MACH_PORT_NULL, MACH_MSG_TIMEOUT_NONE, MACH_PORT_NULL)
- != MACH_MSG_SUCCESS)
- {
- abort ();
- }
- }
-}
-
-
-/* Initialize the Mach exception handler thread. */
-void mach_initialize (void)
-{
- mach_port_t self;
- exception_mask_t mask;
-
- self = mach_task_self ();
-
- /* Allocate a port on which the thread shall listen for exceptions. */
- if (mach_port_allocate (self, MACH_PORT_RIGHT_RECEIVE, &our_exception_port)
- != KERN_SUCCESS)
- fatal_error("mach_port_allocate() failed",0);
-
- /* See http://web.mit.edu/darwin/src/modules/xnu/osfmk/man/mach_port_insert_right.html. */
- if (mach_port_insert_right (self, our_exception_port, our_exception_port,
- MACH_MSG_TYPE_MAKE_SEND)
- != KERN_SUCCESS)
- fatal_error("mach_port_insert_right() failed",0);
-
- /* The exceptions we want to catch. */
- mask = EXC_MASK_BAD_ACCESS | EXC_MASK_ARITHMETIC;
-
- /* Create the thread listening on the exception port. */
- start_thread(mach_exception_thread);
-
- /* Replace the exception port info for these exceptions with our own.
- Note that we replace the exception port for the entire task, not only
- for a particular thread. This has the effect that when our exception
- port gets the message, the thread specific exception port has already
- been asked, and we don't need to bother about it.
- See http://web.mit.edu/darwin/src/modules/xnu/osfmk/man/task_set_exception_ports.html. */
- if (task_set_exception_ports (self, mask, our_exception_port,
- EXCEPTION_DEFAULT, MACHINE_THREAD_STATE)
- != KERN_SUCCESS)
- fatal_error("task_set_exception_ports() failed",0);
-}
--- /dev/null
+/* Fault handler information. MacOSX version.
+Copyright (C) 1993-1999, 2002-2003 Bruno Haible <clisp.org at bruno>
+
+Copyright (C) 2003 Paolo Bonzini <gnu.org at bonzini>
+
+Used under BSD license with permission from Paolo Bonzini and Bruno Haible,
+2005-03-10:
+
+http://sourceforge.net/mailarchive/message.php?msg_name=200503102200.32002.bruno%40clisp.org
+
+Modified for Factor by Slava Pestov */
+
+#include "master.hpp"
+
+namespace factor
+{
+
+/* The exception port on which our thread listens. */
+mach_port_t our_exception_port;
+
+/* The following sources were used as a *reference* for this exception handling
+code:
+1. Apple's mach/xnu documentation
+2. Timothy J. Wood's "Mach Exception Handlers 101" post to the
+omnigroup's macosx-dev list.
+http://www.wodeveloper.com/omniLists/macosx-dev/2000/June/msg00137.html */
+
+/* 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(exception_type_t exception,
+ MACH_EXC_STATE_TYPE *exc_state,
+ MACH_THREAD_STATE_TYPE *thread_state)
+{
+ /* There is a race condition here, but in practice an exception
+ delivered during stack frame setup/teardown or while transitioning
+ from Factor to C is a sign of things seriously gone wrong, not just
+ a divide by zero or stack underflow in the listener */
+
+ /* Are we in compiled Factor code? Then use the current stack pointer */
+ if(in_code_heap_p(MACH_PROGRAM_COUNTER(thread_state)))
+ signal_callstack_top = (stack_frame *)MACH_STACK_POINTER(thread_state);
+ /* Are we in C? Then use the saved callstack top */
+ else
+ signal_callstack_top = NULL;
+
+ MACH_STACK_POINTER(thread_state) = fix_stack_pointer(MACH_STACK_POINTER(thread_state));
+
+ /* Now we point the program counter at the right handler function. */
+ if(exception == EXC_BAD_ACCESS)
+ {
+ signal_fault_addr = MACH_EXC_STATE_FAULT(exc_state);
+ MACH_PROGRAM_COUNTER(thread_state) = (cell)memory_signal_handler_impl;
+ }
+ else
+ {
+ if(exception == EXC_ARITHMETIC)
+ signal_number = SIGFPE;
+ else
+ signal_number = SIGABRT;
+ MACH_PROGRAM_COUNTER(thread_state) = (cell)misc_signal_handler_impl;
+ }
+}
+
+/* Handle an exception by invoking the user's fault handler and/or forwarding
+the duty to the previously installed handlers. */
+extern "C"
+kern_return_t
+catch_exception_raise (mach_port_t exception_port,
+ mach_port_t thread,
+ mach_port_t task,
+ exception_type_t exception,
+ exception_data_t code,
+ mach_msg_type_number_t code_count)
+{
+ MACH_EXC_STATE_TYPE exc_state;
+ MACH_THREAD_STATE_TYPE thread_state;
+ mach_msg_type_number_t state_count;
+
+ /* Get fault information and the faulting thread's register contents..
+
+ See http://web.mit.edu/darwin/src/modules/xnu/osfmk/man/thread_get_state.html. */
+ state_count = MACH_EXC_STATE_COUNT;
+ if (thread_get_state (thread, MACH_EXC_STATE_FLAVOR,
+ (natural_t *)&exc_state, &state_count)
+ != KERN_SUCCESS)
+ {
+ /* The thread is supposed to be suspended while the exception
+ handler is called. This shouldn't fail. */
+ return KERN_FAILURE;
+ }
+
+ state_count = MACH_THREAD_STATE_COUNT;
+ if (thread_get_state (thread, MACH_THREAD_STATE_FLAVOR,
+ (natural_t *)&thread_state, &state_count)
+ != KERN_SUCCESS)
+ {
+ /* The thread is supposed to be suspended while the exception
+ handler is called. This shouldn't fail. */
+ return KERN_FAILURE;
+ }
+
+ /* Modify registers so to have the thread resume executing the
+ fault handler */
+ call_fault_handler(exception,&exc_state,&thread_state);
+
+ /* Set the faulting thread's register contents..
+
+ See http://web.mit.edu/darwin/src/modules/xnu/osfmk/man/thread_set_state.html. */
+ if (thread_set_state (thread, MACH_THREAD_STATE_FLAVOR,
+ (natural_t *)&thread_state, state_count)
+ != KERN_SUCCESS)
+ {
+ return KERN_FAILURE;
+ }
+
+ return KERN_SUCCESS;
+}
+
+
+/* The main function of the thread listening for exceptions. */
+static void *
+mach_exception_thread (void *arg)
+{
+ for (;;)
+ {
+ /* These two structures contain some private kernel data. We don't need
+ to access any of it so we don't bother defining a proper struct. The
+ correct definitions are in the xnu source code. */
+ /* Buffer for a message to be received. */
+ struct
+ {
+ mach_msg_header_t head;
+ mach_msg_body_t msgh_body;
+ char data[1024];
+ }
+ msg;
+ /* Buffer for a reply message. */
+ struct
+ {
+ mach_msg_header_t head;
+ char data[1024];
+ }
+ reply;
+
+ mach_msg_return_t retval;
+
+ /* Wait for a message on the exception port. */
+ retval = mach_msg (&msg.head, MACH_RCV_MSG | MACH_RCV_LARGE, 0,
+ sizeof (msg), our_exception_port,
+ MACH_MSG_TIMEOUT_NONE, MACH_PORT_NULL);
+ if (retval != MACH_MSG_SUCCESS)
+ {
+ abort ();
+ }
+
+ /* Handle the message: Call exc_server, which will call
+ catch_exception_raise and produce a reply message. */
+ exc_server (&msg.head, &reply.head);
+
+ /* Send the reply. */
+ if (mach_msg (&reply.head, MACH_SEND_MSG, reply.head.msgh_size,
+ 0, MACH_PORT_NULL, MACH_MSG_TIMEOUT_NONE, MACH_PORT_NULL)
+ != MACH_MSG_SUCCESS)
+ {
+ abort ();
+ }
+ }
+}
+
+/* Initialize the Mach exception handler thread. */
+void mach_initialize (void)
+{
+ mach_port_t self;
+ exception_mask_t mask;
+
+ self = mach_task_self ();
+
+ /* Allocate a port on which the thread shall listen for exceptions. */
+ if (mach_port_allocate (self, MACH_PORT_RIGHT_RECEIVE, &our_exception_port)
+ != KERN_SUCCESS)
+ fatal_error("mach_port_allocate() failed",0);
+
+ /* See http://web.mit.edu/darwin/src/modules/xnu/osfmk/man/mach_port_insert_right.html. */
+ if (mach_port_insert_right (self, our_exception_port, our_exception_port,
+ MACH_MSG_TYPE_MAKE_SEND)
+ != KERN_SUCCESS)
+ fatal_error("mach_port_insert_right() failed",0);
+
+ /* The exceptions we want to catch. */
+ mask = EXC_MASK_BAD_ACCESS | EXC_MASK_ARITHMETIC;
+
+ /* Create the thread listening on the exception port. */
+ start_thread(mach_exception_thread);
+
+ /* Replace the exception port info for these exceptions with our own.
+ Note that we replace the exception port for the entire task, not only
+ for a particular thread. This has the effect that when our exception
+ port gets the message, the thread specific exception port has already
+ been asked, and we don't need to bother about it.
+ See http://web.mit.edu/darwin/src/modules/xnu/osfmk/man/task_set_exception_ports.html. */
+ if (task_set_exception_ports (self, mask, our_exception_port,
+ EXCEPTION_DEFAULT, MACHINE_THREAD_STATE)
+ != KERN_SUCCESS)
+ fatal_error("task_set_exception_ports() failed",0);
+}
+
+}
+++ /dev/null
-/* Fault handler information. MacOSX version.
-Copyright (C) 1993-1999, 2002-2003 Bruno Haible <clisp.org at bruno>
-Copyright (C) 2003 Paolo Bonzini <gnu.org at bonzini>
-
-Used under BSD license with permission from Paolo Bonzini and Bruno Haible,
-2005-03-10:
-
-http://sourceforge.net/mailarchive/message.php?msg_name=200503102200.32002.bruno%40clisp.org
-
-Modified for Factor by Slava Pestov */
-#include <stdio.h>
-#include <stdlib.h>
-#include <errno.h>
-#include <signal.h>
-
-#include <mach/mach.h>
-#include <mach/mach_error.h>
-#include <mach/thread_status.h>
-#include <mach/exception.h>
-#include <mach/task.h>
-#include <pthread.h>
-
-/* The exception port on which our thread listens. */
-mach_port_t our_exception_port;
-
-/* This is not defined in any header, although documented. */
-
-/* http://web.mit.edu/darwin/src/modules/xnu/osfmk/man/exc_server.html says:
- The exc_server function is the MIG generated server handling function
- to handle messages from the kernel relating to the occurrence of an
- exception in a thread. Such messages are delivered to the exception port
- set via thread_set_exception_ports or task_set_exception_ports. When an
- exception occurs in a thread, the thread sends an exception message to its
- exception port, blocking in the kernel waiting for the receipt of a reply.
- The exc_server function performs all necessary argument handling for this
- kernel message and calls catch_exception_raise, catch_exception_raise_state
- or catch_exception_raise_state_identity, which should handle the exception.
- If the called routine returns KERN_SUCCESS, a reply message will be sent,
- allowing the thread to continue from the point of the exception; otherwise,
- no reply message is sent and the called routine must have dealt with the
- exception thread directly. */
-extern boolean_t
- exc_server (mach_msg_header_t *request_msg,
- mach_msg_header_t *reply_msg);
-
-
-/* http://web.mit.edu/darwin/src/modules/xnu/osfmk/man/catch_exception_raise.html
- These functions are defined in this file, and called by exc_server.
- FIXME: What needs to be done when this code is put into a shared library? */
-kern_return_t
-catch_exception_raise (mach_port_t exception_port,
- mach_port_t thread,
- mach_port_t task,
- exception_type_t exception,
- exception_data_t code,
- mach_msg_type_number_t code_count);
-kern_return_t
-catch_exception_raise_state (mach_port_t exception_port,
- exception_type_t exception,
- exception_data_t code,
- mach_msg_type_number_t code_count,
- thread_state_flavor_t *flavor,
- thread_state_t in_state,
- mach_msg_type_number_t in_state_count,
- thread_state_t out_state,
- mach_msg_type_number_t *out_state_count);
-kern_return_t
-catch_exception_raise_state_identity (mach_port_t exception_port,
- mach_port_t thread,
- mach_port_t task,
- exception_type_t exception,
- exception_data_t code,
- mach_msg_type_number_t codeCnt,
- thread_state_flavor_t *flavor,
- thread_state_t in_state,
- mach_msg_type_number_t in_state_count,
- thread_state_t out_state,
- mach_msg_type_number_t *out_state_count);
-
-void mach_initialize (void);
--- /dev/null
+/* Fault handler information. MacOSX version.
+Copyright (C) 1993-1999, 2002-2003 Bruno Haible <clisp.org at bruno>
+Copyright (C) 2003 Paolo Bonzini <gnu.org at bonzini>
+
+Used under BSD license with permission from Paolo Bonzini and Bruno Haible,
+2005-03-10:
+
+http://sourceforge.net/mailarchive/message.php?msg_name=200503102200.32002.bruno%40clisp.org
+
+Modified for Factor by Slava Pestov */
+#include <stdio.h>
+#include <stdlib.h>
+#include <errno.h>
+#include <signal.h>
+
+#include <mach/mach.h>
+#include <mach/mach_error.h>
+#include <mach/thread_status.h>
+#include <mach/exception.h>
+#include <mach/task.h>
+#include <pthread.h>
+
+/* This is not defined in any header, although documented. */
+
+/* http://web.mit.edu/darwin/src/modules/xnu/osfmk/man/exc_server.html says:
+ The exc_server function is the MIG generated server handling function
+ to handle messages from the kernel relating to the occurrence of an
+ exception in a thread. Such messages are delivered to the exception port
+ set via thread_set_exception_ports or task_set_exception_ports. When an
+ exception occurs in a thread, the thread sends an exception message to its
+ exception port, blocking in the kernel waiting for the receipt of a reply.
+ The exc_server function performs all necessary argument handling for this
+ kernel message and calls catch_exception_raise, catch_exception_raise_state
+ or catch_exception_raise_state_identity, which should handle the exception.
+ If the called routine returns KERN_SUCCESS, a reply message will be sent,
+ allowing the thread to continue from the point of the exception; otherwise,
+ no reply message is sent and the called routine must have dealt with the
+ exception thread directly. */
+extern "C" boolean_t exc_server (mach_msg_header_t *request_msg, mach_msg_header_t *reply_msg);
+
+
+/* http://web.mit.edu/darwin/src/modules/xnu/osfmk/man/catch_exception_raise.html
+ These functions are defined in this file, and called by exc_server.
+ FIXME: What needs to be done when this code is put into a shared library? */
+extern "C"
+kern_return_t
+catch_exception_raise (mach_port_t exception_port,
+ mach_port_t thread,
+ mach_port_t task,
+ exception_type_t exception,
+ exception_data_t code,
+ mach_msg_type_number_t code_count);
+extern "C"
+kern_return_t
+catch_exception_raise_state (mach_port_t exception_port,
+ exception_type_t exception,
+ exception_data_t code,
+ mach_msg_type_number_t code_count,
+ thread_state_flavor_t *flavor,
+ thread_state_t in_state,
+ mach_msg_type_number_t in_state_count,
+ thread_state_t out_state,
+ mach_msg_type_number_t *out_state_count);
+
+extern "C"
+kern_return_t
+catch_exception_raise_state_identity (mach_port_t exception_port,
+ mach_port_t thread,
+ mach_port_t task,
+ exception_type_t exception,
+ exception_data_t code,
+ mach_msg_type_number_t codeCnt,
+ thread_state_flavor_t *flavor,
+ thread_state_t in_state,
+ mach_msg_type_number_t in_state_count,
+ thread_state_t out_state,
+ mach_msg_type_number_t *out_state_count);
+
+namespace factor
+{
+
+void mach_initialize (void);
+
+}
+++ /dev/null
-#include "master.h"
-
-int main(int argc, char **argv)
-{
- start_standalone_factor(argc,argv);
- return 0;
-}
--- /dev/null
+#include "master.hpp"
+
+int main(int argc, char **argv)
+{
+ factor::start_standalone_factor(argc,argv);
+ return 0;
+}
+++ /dev/null
-#include "master.h"
-
-/*
- Windows CE argument parsing ported to work on
- int main(int argc, wchar_t **argv).
-
- This would not be necessary if Windows CE had CommandLineToArgvW.
-
- Based on MinGW's public domain char** version.
-
-*/
-
-int __argc;
-wchar_t **__argv;
-
-static int
-parse_tokens(wchar_t* string, wchar_t*** tokens, int length)
-{
- /* Extract whitespace- and quotes- delimited tokens from the given string
- and put them into the tokens array. Returns number of tokens
- extracted. Length specifies the current size of tokens[].
- THIS METHOD MODIFIES string. */
-
- const wchar_t* whitespace = L" \t\r\n";
- wchar_t* tokenEnd = 0;
- const wchar_t* quoteCharacters = L"\"\'";
- wchar_t *end = string + wcslen(string);
-
- if (string == NULL)
- return length;
-
- while (1)
- {
- const wchar_t* q;
- /* Skip over initial whitespace. */
- string += wcsspn(string, whitespace);
- if (*string == '\0')
- break;
-
- for (q = quoteCharacters; *q; ++q)
- {
- if (*string == *q)
- break;
- }
- if (*q)
- {
- /* Token is quoted. */
- wchar_t quote = *string++;
- tokenEnd = wcschr(string, quote);
- /* If there is no endquote, the token is the rest of the string. */
- if (!tokenEnd)
- tokenEnd = end;
- }
- else
- {
- tokenEnd = string + wcscspn(string, whitespace);
- }
-
- *tokenEnd = '\0';
-
- {
- wchar_t** new_tokens;
- int newlen = length + 1;
- new_tokens = realloc (*tokens, sizeof (wchar_t**) * newlen);
- if (!new_tokens)
- {
- /* Out of memory. */
- return -1;
- }
-
- *tokens = new_tokens;
- (*tokens)[length] = string;
- length = newlen;
- }
- if (tokenEnd == end)
- break;
- string = tokenEnd + 1;
- }
- return length;
-}
-
-static void
-parse_args(int *argc, wchar_t ***argv, wchar_t *cmdlinePtrW)
-{
- wchar_t cmdnameBufW[MAX_UNICODE_PATH];
- int cmdlineLen = 0;
- int modlen;
-
- /* argv[0] is the path of invoked program - get this from CE. */
- cmdnameBufW[0] = 0;
- modlen = GetModuleFileNameW(NULL, cmdnameBufW, sizeof (cmdnameBufW)/sizeof (cmdnameBufW[0]));
-
- if (!cmdlinePtrW)
- cmdlineLen = 0;
- else
- cmdlineLen = wcslen(cmdlinePtrW);
-
- /* gets realloc()'d later */
- *argv = malloc (sizeof (wchar_t**) * 1);
- if (!*argv)
- ExitProcess(-1);
-
- (*argv)[0] = wcsdup(cmdnameBufW);
- if(!(*argv[0]))
- ExitProcess(-1);
- /* Add one to account for argv[0] */
- (*argc)++;
-
- if (cmdlineLen > 0)
- {
- wchar_t* argv1 = (*argv)[0] + wcslen((*argv)[0]) + 1;
- argv1 = wcsdup(cmdlinePtrW);
- if(!argv1)
- ExitProcess(-1);
- *argc = parse_tokens(argv1, argv, 1);
- if (*argc < 0)
- ExitProcess(-1);
- }
- (*argv)[*argc] = 0;
- return;
-}
-
-int WINAPI
-WinMain(
- HINSTANCE hInstance,
- HINSTANCE hPrevInstance,
- LPWSTR lpCmdLine,
- int nCmdShow)
-{
- parse_args(&__argc, &__argv, lpCmdLine);
- start_standalone_factor(__argc,(LPWSTR*)__argv);
- // memory leak from malloc, wcsdup
- return 0;
-}
--- /dev/null
+#include "master.hpp"
+
+/*
+ Windows CE argument parsing ported to work on
+ int main(int argc, wchar_t **argv).
+
+ This would not be necessary if Windows CE had CommandLineToArgvW.
+
+ Based on MinGW's public domain char** version.
+
+*/
+
+int __argc;
+wchar_t **__argv;
+
+static int
+parse_tokens(wchar_t* string, wchar_t*** tokens, int length)
+{
+ /* Extract whitespace- and quotes- delimited tokens from the given string
+ and put them into the tokens array. Returns number of tokens
+ extracted. Length specifies the current size of tokens[].
+ THIS METHOD MODIFIES string. */
+
+ const wchar_t* whitespace = L" \t\r\n";
+ wchar_t* tokenEnd = 0;
+ const wchar_t* quoteCharacters = L"\"\'";
+ wchar_t *end = string + wcslen(string);
+
+ if (string == NULL)
+ return length;
+
+ while (1)
+ {
+ const wchar_t* q;
+ /* Skip over initial whitespace. */
+ string += wcsspn(string, whitespace);
+ if (*string == '\0')
+ break;
+
+ for (q = quoteCharacters; *q; ++q)
+ {
+ if (*string == *q)
+ break;
+ }
+ if (*q)
+ {
+ /* Token is quoted. */
+ wchar_t quote = *string++;
+ tokenEnd = wcschr(string, quote);
+ /* If there is no endquote, the token is the rest of the string. */
+ if (!tokenEnd)
+ tokenEnd = end;
+ }
+ else
+ {
+ tokenEnd = string + wcscspn(string, whitespace);
+ }
+
+ *tokenEnd = '\0';
+
+ {
+ wchar_t** new_tokens;
+ int newlen = length + 1;
+ new_tokens = realloc (*tokens, sizeof (wchar_t**) * newlen);
+ if (!new_tokens)
+ {
+ /* Out of memory. */
+ return -1;
+ }
+
+ *tokens = new_tokens;
+ (*tokens)[length] = string;
+ length = newlen;
+ }
+ if (tokenEnd == end)
+ break;
+ string = tokenEnd + 1;
+ }
+ return length;
+}
+
+static void
+parse_args(int *argc, wchar_t ***argv, wchar_t *cmdlinePtrW)
+{
+ wchar_t cmdnameBufW[MAX_UNICODE_PATH];
+ int cmdlineLen = 0;
+ int modlen;
+
+ /* argv[0] is the path of invoked program - get this from CE. */
+ cmdnameBufW[0] = 0;
+ modlen = GetModuleFileNameW(NULL, cmdnameBufW, sizeof (cmdnameBufW)/sizeof (cmdnameBufW[0]));
+
+ if (!cmdlinePtrW)
+ cmdlineLen = 0;
+ else
+ cmdlineLen = wcslen(cmdlinePtrW);
+
+ /* gets realloc()'d later */
+ *argv = malloc (sizeof (wchar_t**) * 1);
+ if (!*argv)
+ ExitProcess(-1);
+
+ (*argv)[0] = wcsdup(cmdnameBufW);
+ if(!(*argv[0]))
+ ExitProcess(-1);
+ /* Add one to account for argv[0] */
+ (*argc)++;
+
+ if (cmdlineLen > 0)
+ {
+ wchar_t* argv1 = (*argv)[0] + wcslen((*argv)[0]) + 1;
+ argv1 = wcsdup(cmdlinePtrW);
+ if(!argv1)
+ ExitProcess(-1);
+ *argc = parse_tokens(argv1, argv, 1);
+ if (*argc < 0)
+ ExitProcess(-1);
+ }
+ (*argv)[*argc] = 0;
+ return;
+}
+
+int WINAPI
+WinMain(
+ HINSTANCE hInstance,
+ HINSTANCE hPrevInstance,
+ LPWSTR lpCmdLine,
+ int nCmdShow)
+{
+ parse_args(&__argc, &__argv, lpCmdLine);
+ factor::start_standalone_factor(__argc,(LPWSTR*)__argv);
+ // memory leak from malloc, wcsdup
+ return 0;
+}
+++ /dev/null
-#include <windows.h>
-#include <stdio.h>
-#include <shellapi.h>
-#include "master.h"
-
-int WINAPI WinMain(
- HINSTANCE hInstance,
- HINSTANCE hPrevInstance,
- LPSTR lpCmdLine,
- int nCmdShow)
-{
- LPWSTR *szArglist;
- int nArgs;
-
- szArglist = CommandLineToArgvW(GetCommandLineW(), &nArgs);
- if(NULL == szArglist)
- {
- puts("CommandLineToArgvW failed");
- return 1;
- }
-
- start_standalone_factor(nArgs,szArglist);
-
- LocalFree(szArglist);
-
- return 0;
-}
--- /dev/null
+#include "master.hpp"
+
+int WINAPI WinMain(
+ HINSTANCE hInstance,
+ HINSTANCE hPrevInstance,
+ LPSTR lpCmdLine,
+ int nCmdShow)
+{
+ LPWSTR *szArglist;
+ int nArgs;
+
+ szArglist = CommandLineToArgvW(GetCommandLineW(), &nArgs);
+ if(NULL == szArglist)
+ {
+ puts("CommandLineToArgvW failed");
+ return 1;
+ }
+
+ factor::start_standalone_factor(nArgs,szArglist);
+
+ LocalFree(szArglist);
+
+ return 0;
+}
+++ /dev/null
-#ifndef __FACTOR_MASTER_H__
-#define __FACTOR_MASTER_H__
-
-#ifndef WINCE
-#include <errno.h>
-#endif
-
-#ifdef FACTOR_DEBUG
-#include <assert.h>
-#endif
-
-#include <fcntl.h>
-#include <limits.h>
-#include <math.h>
-#include <stdbool.h>
-#include <setjmp.h>
-
-#include <stdio.h>
-#include <stdlib.h>
-#include <string.h>
-#include <time.h>
-#include <sys/param.h>
-
-#include "layouts.h"
-#include "platform.h"
-#include "primitives.h"
-#include "run.h"
-#include "profiler.h"
-#include "errors.h"
-#include "bignumint.h"
-#include "bignum.h"
-#include "write_barrier.h"
-#include "data_heap.h"
-#include "data_gc.h"
-#include "local_roots.h"
-#include "debug.h"
-#include "arrays.h"
-#include "strings.h"
-#include "booleans.h"
-#include "byte_arrays.h"
-#include "tuples.h"
-#include "words.h"
-#include "math.h"
-#include "float_bits.h"
-#include "io.h"
-#include "code_gc.h"
-#include "code_block.h"
-#include "code_heap.h"
-#include "image.h"
-#include "callstack.h"
-#include "alien.h"
-#include "quotations.h"
-#include "jit.h"
-#include "dispatch.h"
-#include "inline_cache.h"
-#include "factor.h"
-#include "utilities.h"
-
-#endif /* __FACTOR_MASTER_H__ */
--- /dev/null
+#ifndef __FACTOR_MASTER_H__
+#define __FACTOR_MASTER_H__
+
+#ifndef WINCE
+#include <errno.h>
+#endif
+
+#ifdef FACTOR_DEBUG
+#include <assert.h>
+#endif
+
+#include <fcntl.h>
+#include <limits.h>
+#include <math.h>
+#include <stdbool.h>
+#include <setjmp.h>
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+#include <time.h>
+#include <sys/param.h>
+
+#include "layouts.hpp"
+#include "platform.hpp"
+#include "primitives.hpp"
+#include "stacks.hpp"
+#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 "data_heap.hpp"
+#include "write_barrier.hpp"
+#include "data_gc.hpp"
+#include "local_roots.hpp"
+#include "generic_arrays.hpp"
+#include "debug.hpp"
+#include "arrays.hpp"
+#include "strings.hpp"
+#include "booleans.hpp"
+#include "byte_arrays.hpp"
+#include "tuples.hpp"
+#include "words.hpp"
+#include "math.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 "jit.hpp"
+#include "quotations.hpp"
+#include "dispatch.hpp"
+#include "inline_cache.hpp"
+#include "factor.hpp"
+#include "utilities.hpp"
+
+#endif /* __FACTOR_MASTER_H__ */
+++ /dev/null
-#include "master.h"
-
-/* Fixnums */
-F_FIXNUM to_fixnum(CELL tagged)
-{
- switch(TAG(tagged))
- {
- case FIXNUM_TYPE:
- return untag_fixnum_fast(tagged);
- case BIGNUM_TYPE:
- return bignum_to_fixnum(untag_object(tagged));
- default:
- type_error(FIXNUM_TYPE,tagged);
- return -1; /* can't happen */
- }
-}
-
-CELL to_cell(CELL tagged)
-{
- return (CELL)to_fixnum(tagged);
-}
-
-void primitive_bignum_to_fixnum(void)
-{
- drepl(tag_fixnum(bignum_to_fixnum(untag_object(dpeek()))));
-}
-
-void primitive_float_to_fixnum(void)
-{
- drepl(tag_fixnum(float_to_fixnum(dpeek())));
-}
-
-/* The fixnum+, fixnum- and fixnum* primitives are defined in cpu_*.S. On
-overflow, they call these functions. */
-F_FASTCALL void overflow_fixnum_add(F_FIXNUM x, F_FIXNUM y)
-{
- drepl(tag_bignum(fixnum_to_bignum(
- untag_fixnum_fast(x) + untag_fixnum_fast(y))));
-}
-
-F_FASTCALL void overflow_fixnum_subtract(F_FIXNUM x, F_FIXNUM y)
-{
- drepl(tag_bignum(fixnum_to_bignum(
- untag_fixnum_fast(x) - untag_fixnum_fast(y))));
-}
-
-F_FASTCALL void overflow_fixnum_multiply(F_FIXNUM x, F_FIXNUM y)
-{
- F_ARRAY *bx = fixnum_to_bignum(x);
- REGISTER_BIGNUM(bx);
- F_ARRAY *by = fixnum_to_bignum(y);
- UNREGISTER_BIGNUM(bx);
- drepl(tag_bignum(bignum_multiply(bx,by)));
-}
-
-/* Division can only overflow when we are dividing the most negative fixnum
-by -1. */
-void primitive_fixnum_divint(void)
-{
- F_FIXNUM y = untag_fixnum_fast(dpop()); \
- F_FIXNUM x = untag_fixnum_fast(dpeek());
- F_FIXNUM result = x / y;
- if(result == -FIXNUM_MIN)
- drepl(allot_integer(-FIXNUM_MIN));
- else
- drepl(tag_fixnum(result));
-}
-
-void primitive_fixnum_divmod(void)
-{
- F_FIXNUM y = get(ds);
- F_FIXNUM x = get(ds - CELLS);
- if(y == tag_fixnum(-1) && x == tag_fixnum(FIXNUM_MIN))
- {
- put(ds - CELLS,allot_integer(-FIXNUM_MIN));
- put(ds,tag_fixnum(0));
- }
- else
- {
- put(ds - CELLS,tag_fixnum(x / y));
- put(ds,x % y);
- }
-}
-
-/*
- * 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.
- */
-#define SIGN_MASK(x) ((x) >> (WORD_SIZE - 1))
-#define BRANCHLESS_MAX(x,y) ((x) - (((x) - (y)) & SIGN_MASK((x) - (y))))
-#define BRANCHLESS_ABS(x) ((x ^ SIGN_MASK(x)) - SIGN_MASK(x))
-
-void primitive_fixnum_shift(void)
-{
- F_FIXNUM y = untag_fixnum_fast(dpop()); \
- F_FIXNUM x = untag_fixnum_fast(dpeek());
-
- if(x == 0)
- return;
- else if(y < 0)
- {
- y = BRANCHLESS_MAX(y,-WORD_SIZE + 1);
- drepl(tag_fixnum(x >> -y));
- return;
- }
- else if(y < WORD_SIZE - TAG_BITS)
- {
- F_FIXNUM mask = -((F_FIXNUM)1 << (WORD_SIZE - 1 - TAG_BITS - y));
- if(!(BRANCHLESS_ABS(x) & mask))
- {
- drepl(tag_fixnum(x << y));
- return;
- }
- }
-
- drepl(tag_bignum(bignum_arithmetic_shift(
- fixnum_to_bignum(x),y)));
-}
-
-/* Bignums */
-void primitive_fixnum_to_bignum(void)
-{
- drepl(tag_bignum(fixnum_to_bignum(untag_fixnum_fast(dpeek()))));
-}
-
-void primitive_float_to_bignum(void)
-{
- drepl(tag_bignum(float_to_bignum(dpeek())));
-}
-
-#define POP_BIGNUMS(x,y) \
- F_ARRAY *y = untag_object(dpop()); \
- F_ARRAY *x = untag_object(dpop());
-
-void primitive_bignum_eq(void)
-{
- POP_BIGNUMS(x,y);
- box_boolean(bignum_equal_p(x,y));
-}
-
-void primitive_bignum_add(void)
-{
- POP_BIGNUMS(x,y);
- dpush(tag_bignum(bignum_add(x,y)));
-}
-
-void primitive_bignum_subtract(void)
-{
- POP_BIGNUMS(x,y);
- dpush(tag_bignum(bignum_subtract(x,y)));
-}
-
-void primitive_bignum_multiply(void)
-{
- POP_BIGNUMS(x,y);
- dpush(tag_bignum(bignum_multiply(x,y)));
-}
-
-void primitive_bignum_divint(void)
-{
- POP_BIGNUMS(x,y);
- dpush(tag_bignum(bignum_quotient(x,y)));
-}
-
-void primitive_bignum_divmod(void)
-{
- F_ARRAY *q, *r;
- POP_BIGNUMS(x,y);
- bignum_divide(x,y,&q,&r);
- dpush(tag_bignum(q));
- dpush(tag_bignum(r));
-}
-
-void primitive_bignum_mod(void)
-{
- POP_BIGNUMS(x,y);
- dpush(tag_bignum(bignum_remainder(x,y)));
-}
-
-void primitive_bignum_and(void)
-{
- POP_BIGNUMS(x,y);
- dpush(tag_bignum(bignum_bitwise_and(x,y)));
-}
-
-void primitive_bignum_or(void)
-{
- POP_BIGNUMS(x,y);
- dpush(tag_bignum(bignum_bitwise_ior(x,y)));
-}
-
-void primitive_bignum_xor(void)
-{
- POP_BIGNUMS(x,y);
- dpush(tag_bignum(bignum_bitwise_xor(x,y)));
-}
-
-void primitive_bignum_shift(void)
-{
- F_FIXNUM y = untag_fixnum_fast(dpop());
- F_ARRAY* x = untag_object(dpop());
- dpush(tag_bignum(bignum_arithmetic_shift(x,y)));
-}
-
-void primitive_bignum_less(void)
-{
- POP_BIGNUMS(x,y);
- box_boolean(bignum_compare(x,y) == bignum_comparison_less);
-}
-
-void primitive_bignum_lesseq(void)
-{
- POP_BIGNUMS(x,y);
- box_boolean(bignum_compare(x,y) != bignum_comparison_greater);
-}
-
-void primitive_bignum_greater(void)
-{
- POP_BIGNUMS(x,y);
- box_boolean(bignum_compare(x,y) == bignum_comparison_greater);
-}
-
-void primitive_bignum_greatereq(void)
-{
- POP_BIGNUMS(x,y);
- box_boolean(bignum_compare(x,y) != bignum_comparison_less);
-}
-
-void primitive_bignum_not(void)
-{
- drepl(tag_bignum(bignum_bitwise_not(untag_object(dpeek()))));
-}
-
-void primitive_bignum_bitp(void)
-{
- F_FIXNUM bit = to_fixnum(dpop());
- F_ARRAY *x = untag_object(dpop());
- box_boolean(bignum_logbitp(bit,x));
-}
-
-void primitive_bignum_log2(void)
-{
- drepl(tag_bignum(bignum_integer_length(untag_object(dpeek()))));
-}
-
-unsigned int bignum_producer(unsigned int digit)
-{
- unsigned char *ptr = alien_offset(dpeek());
- return *(ptr + digit);
-}
-
-void primitive_byte_array_to_bignum(void)
-{
- type_check(BYTE_ARRAY_TYPE,dpeek());
- CELL n_digits = array_capacity(untag_object(dpeek()));
- bignum_type bignum = digit_stream_to_bignum(
- n_digits,bignum_producer,0x100,0);
- drepl(tag_bignum(bignum));
-}
-
-void box_signed_1(s8 n)
-{
- dpush(tag_fixnum(n));
-}
-
-void box_unsigned_1(u8 n)
-{
- dpush(tag_fixnum(n));
-}
-
-void box_signed_2(s16 n)
-{
- dpush(tag_fixnum(n));
-}
-
-void box_unsigned_2(u16 n)
-{
- dpush(tag_fixnum(n));
-}
-
-void box_signed_4(s32 n)
-{
- dpush(allot_integer(n));
-}
-
-void box_unsigned_4(u32 n)
-{
- dpush(allot_cell(n));
-}
-
-void box_signed_cell(F_FIXNUM integer)
-{
- dpush(allot_integer(integer));
-}
-
-void box_unsigned_cell(CELL cell)
-{
- dpush(allot_cell(cell));
-}
-
-void box_signed_8(s64 n)
-{
- if(n < FIXNUM_MIN || n > FIXNUM_MAX)
- dpush(tag_bignum(long_long_to_bignum(n)));
- else
- dpush(tag_fixnum(n));
-}
-
-s64 to_signed_8(CELL obj)
-{
- switch(type_of(obj))
- {
- case FIXNUM_TYPE:
- return untag_fixnum_fast(obj);
- case BIGNUM_TYPE:
- return bignum_to_long_long(untag_object(obj));
- default:
- type_error(BIGNUM_TYPE,obj);
- return -1;
- }
-}
-
-void box_unsigned_8(u64 n)
-{
- if(n > FIXNUM_MAX)
- dpush(tag_bignum(ulong_long_to_bignum(n)));
- else
- dpush(tag_fixnum(n));
-}
-
-u64 to_unsigned_8(CELL obj)
-{
- switch(type_of(obj))
- {
- case FIXNUM_TYPE:
- return untag_fixnum_fast(obj);
- case BIGNUM_TYPE:
- return bignum_to_ulong_long(untag_object(obj));
- default:
- type_error(BIGNUM_TYPE,obj);
- return -1;
- }
-}
-
-CELL unbox_array_size(void)
-{
- switch(type_of(dpeek()))
- {
- case FIXNUM_TYPE:
- {
- F_FIXNUM n = untag_fixnum_fast(dpeek());
- if(n >= 0 && n < ARRAY_SIZE_MAX)
- {
- dpop();
- return n;
- }
- break;
- }
- case BIGNUM_TYPE:
- {
- bignum_type zero = untag_object(bignum_zero);
- bignum_type max = cell_to_bignum(ARRAY_SIZE_MAX);
- bignum_type n = untag_object(dpeek());
- if(bignum_compare(n,zero) != bignum_comparison_less
- && bignum_compare(n,max) == bignum_comparison_less)
- {
- dpop();
- return bignum_to_cell(n);
- }
- break;
- }
- }
-
- general_error(ERROR_ARRAY_SIZE,dpop(),tag_fixnum(ARRAY_SIZE_MAX),NULL);
- return 0; /* can't happen */
-}
-
-/* Floats */
-void primitive_fixnum_to_float(void)
-{
- drepl(allot_float(fixnum_to_float(dpeek())));
-}
-
-void primitive_bignum_to_float(void)
-{
- drepl(allot_float(bignum_to_float(dpeek())));
-}
-
-void primitive_str_to_float(void)
-{
- char *c_str, *end;
- double f;
- F_STRING *str = untag_string(dpeek());
- CELL capacity = string_capacity(str);
-
- c_str = to_char_string(str,false);
- end = c_str;
- f = strtod(c_str,&end);
- if(end != c_str + capacity)
- drepl(F);
- else
- drepl(allot_float(f));
-}
-
-void primitive_float_to_str(void)
-{
- char tmp[33];
- snprintf(tmp,32,"%.16g",untag_float(dpop()));
- tmp[32] = '\0';
- box_char_string(tmp);
-}
-
-#define POP_FLOATS(x,y) \
- double y = untag_float_fast(dpop()); \
- double x = untag_float_fast(dpop());
-
-void primitive_float_eq(void)
-{
- POP_FLOATS(x,y);
- box_boolean(x == y);
-}
-
-void primitive_float_add(void)
-{
- POP_FLOATS(x,y);
- box_double(x + y);
-}
-
-void primitive_float_subtract(void)
-{
- POP_FLOATS(x,y);
- box_double(x - y);
-}
-
-void primitive_float_multiply(void)
-{
- POP_FLOATS(x,y);
- box_double(x * y);
-}
-
-void primitive_float_divfloat(void)
-{
- POP_FLOATS(x,y);
- box_double(x / y);
-}
-
-void primitive_float_mod(void)
-{
- POP_FLOATS(x,y);
- box_double(fmod(x,y));
-}
-
-void primitive_float_less(void)
-{
- POP_FLOATS(x,y);
- box_boolean(x < y);
-}
-
-void primitive_float_lesseq(void)
-{
- POP_FLOATS(x,y);
- box_boolean(x <= y);
-}
-
-void primitive_float_greater(void)
-{
- POP_FLOATS(x,y);
- box_boolean(x > y);
-}
-
-void primitive_float_greatereq(void)
-{
- POP_FLOATS(x,y);
- box_boolean(x >= y);
-}
-
-void primitive_float_bits(void)
-{
- box_unsigned_4(float_bits(untag_float(dpop())));
-}
-
-void primitive_bits_float(void)
-{
- box_float(bits_float(to_cell(dpop())));
-}
-
-void primitive_double_bits(void)
-{
- box_unsigned_8(double_bits(untag_float(dpop())));
-}
-
-void primitive_bits_double(void)
-{
- box_double(bits_double(to_unsigned_8(dpop())));
-}
-
-float to_float(CELL value)
-{
- return untag_float(value);
-}
-
-double to_double(CELL value)
-{
- return untag_float(value);
-}
-
-void box_float(float flo)
-{
- dpush(allot_float(flo));
-}
-
-void box_double(double flo)
-{
- dpush(allot_float(flo));
-}
--- /dev/null
+#include "master.hpp"
+
+namespace factor
+{
+
+cell bignum_zero;
+cell bignum_pos_one;
+cell bignum_neg_one;
+
+PRIMITIVE(bignum_to_fixnum)
+{
+ drepl(tag_fixnum(bignum_to_fixnum(untag<bignum>(dpeek()))));
+}
+
+PRIMITIVE(float_to_fixnum)
+{
+ drepl(tag_fixnum(float_to_fixnum(dpeek())));
+}
+
+/* Division can only overflow when we are dividing the most negative fixnum
+by -1. */
+PRIMITIVE(fixnum_divint)
+{
+ fixnum y = untag_fixnum(dpop()); \
+ fixnum x = untag_fixnum(dpeek());
+ fixnum result = x / y;
+ if(result == -FIXNUM_MIN)
+ drepl(allot_integer(-FIXNUM_MIN));
+ else
+ drepl(tag_fixnum(result));
+}
+
+PRIMITIVE(fixnum_divmod)
+{
+ cell y = ((cell *)ds)[0];
+ cell x = ((cell *)ds)[-1];
+ if(y == tag_fixnum(-1) && x == tag_fixnum(FIXNUM_MIN))
+ {
+ ((cell *)ds)[-1] = allot_integer(-FIXNUM_MIN);
+ ((cell *)ds)[0] = tag_fixnum(0);
+ }
+ else
+ {
+ ((cell *)ds)[-1] = tag_fixnum(untag_fixnum(x) / untag_fixnum(y));
+ ((cell *)ds)[0] = (fixnum)x % (fixnum)y;
+ }
+}
+
+/*
+ * 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.
+ */
+#define SIGN_MASK(x) ((x) >> (WORD_SIZE - 1))
+#define BRANCHLESS_MAX(x,y) ((x) - (((x) - (y)) & SIGN_MASK((x) - (y))))
+#define BRANCHLESS_ABS(x) ((x ^ SIGN_MASK(x)) - SIGN_MASK(x))
+
+PRIMITIVE(fixnum_shift)
+{
+ fixnum y = untag_fixnum(dpop()); \
+ fixnum x = untag_fixnum(dpeek());
+
+ if(x == 0)
+ return;
+ else if(y < 0)
+ {
+ y = BRANCHLESS_MAX(y,-WORD_SIZE + 1);
+ drepl(tag_fixnum(x >> -y));
+ return;
+ }
+ else if(y < WORD_SIZE - TAG_BITS)
+ {
+ fixnum mask = -((fixnum)1 << (WORD_SIZE - 1 - TAG_BITS - y));
+ if(!(BRANCHLESS_ABS(x) & mask))
+ {
+ drepl(tag_fixnum(x << y));
+ return;
+ }
+ }
+
+ drepl(tag<bignum>(bignum_arithmetic_shift(
+ fixnum_to_bignum(x),y)));
+}
+
+PRIMITIVE(fixnum_to_bignum)
+{
+ drepl(tag<bignum>(fixnum_to_bignum(untag_fixnum(dpeek()))));
+}
+
+PRIMITIVE(float_to_bignum)
+{
+ drepl(tag<bignum>(float_to_bignum(dpeek())));
+}
+
+#define POP_BIGNUMS(x,y) \
+ bignum * y = untag<bignum>(dpop()); \
+ bignum * x = untag<bignum>(dpop());
+
+PRIMITIVE(bignum_eq)
+{
+ POP_BIGNUMS(x,y);
+ box_boolean(bignum_equal_p(x,y));
+}
+
+PRIMITIVE(bignum_add)
+{
+ POP_BIGNUMS(x,y);
+ dpush(tag<bignum>(bignum_add(x,y)));
+}
+
+PRIMITIVE(bignum_subtract)
+{
+ POP_BIGNUMS(x,y);
+ dpush(tag<bignum>(bignum_subtract(x,y)));
+}
+
+PRIMITIVE(bignum_multiply)
+{
+ POP_BIGNUMS(x,y);
+ dpush(tag<bignum>(bignum_multiply(x,y)));
+}
+
+PRIMITIVE(bignum_divint)
+{
+ POP_BIGNUMS(x,y);
+ dpush(tag<bignum>(bignum_quotient(x,y)));
+}
+
+PRIMITIVE(bignum_divmod)
+{
+ bignum *q, *r;
+ POP_BIGNUMS(x,y);
+ bignum_divide(x,y,&q,&r);
+ dpush(tag<bignum>(q));
+ dpush(tag<bignum>(r));
+}
+
+PRIMITIVE(bignum_mod)
+{
+ POP_BIGNUMS(x,y);
+ dpush(tag<bignum>(bignum_remainder(x,y)));
+}
+
+PRIMITIVE(bignum_and)
+{
+ POP_BIGNUMS(x,y);
+ dpush(tag<bignum>(bignum_bitwise_and(x,y)));
+}
+
+PRIMITIVE(bignum_or)
+{
+ POP_BIGNUMS(x,y);
+ dpush(tag<bignum>(bignum_bitwise_ior(x,y)));
+}
+
+PRIMITIVE(bignum_xor)
+{
+ POP_BIGNUMS(x,y);
+ dpush(tag<bignum>(bignum_bitwise_xor(x,y)));
+}
+
+PRIMITIVE(bignum_shift)
+{
+ fixnum y = untag_fixnum(dpop());
+ bignum* x = untag<bignum>(dpop());
+ dpush(tag<bignum>(bignum_arithmetic_shift(x,y)));
+}
+
+PRIMITIVE(bignum_less)
+{
+ POP_BIGNUMS(x,y);
+ box_boolean(bignum_compare(x,y) == bignum_comparison_less);
+}
+
+PRIMITIVE(bignum_lesseq)
+{
+ POP_BIGNUMS(x,y);
+ box_boolean(bignum_compare(x,y) != bignum_comparison_greater);
+}
+
+PRIMITIVE(bignum_greater)
+{
+ POP_BIGNUMS(x,y);
+ box_boolean(bignum_compare(x,y) == bignum_comparison_greater);
+}
+
+PRIMITIVE(bignum_greatereq)
+{
+ POP_BIGNUMS(x,y);
+ box_boolean(bignum_compare(x,y) != bignum_comparison_less);
+}
+
+PRIMITIVE(bignum_not)
+{
+ drepl(tag<bignum>(bignum_bitwise_not(untag<bignum>(dpeek()))));
+}
+
+PRIMITIVE(bignum_bitp)
+{
+ fixnum bit = to_fixnum(dpop());
+ bignum *x = untag<bignum>(dpop());
+ box_boolean(bignum_logbitp(bit,x));
+}
+
+PRIMITIVE(bignum_log2)
+{
+ drepl(tag<bignum>(bignum_integer_length(untag<bignum>(dpeek()))));
+}
+
+unsigned int bignum_producer(unsigned int digit)
+{
+ unsigned char *ptr = (unsigned char *)alien_offset(dpeek());
+ return *(ptr + digit);
+}
+
+PRIMITIVE(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);
+ drepl(tag<bignum>(result));
+}
+
+cell unbox_array_size(void)
+{
+ switch(tagged<object>(dpeek()).type())
+ {
+ case FIXNUM_TYPE:
+ {
+ fixnum n = untag_fixnum(dpeek());
+ if(n >= 0 && n < (fixnum)ARRAY_SIZE_MAX)
+ {
+ dpop();
+ return n;
+ }
+ break;
+ }
+ case BIGNUM_TYPE:
+ {
+ bignum * zero = untag<bignum>(bignum_zero);
+ bignum * max = cell_to_bignum(ARRAY_SIZE_MAX);
+ bignum * n = untag<bignum>(dpeek());
+ if(bignum_compare(n,zero) != bignum_comparison_less
+ && bignum_compare(n,max) == bignum_comparison_less)
+ {
+ dpop();
+ return bignum_to_cell(n);
+ }
+ break;
+ }
+ }
+
+ general_error(ERROR_ARRAY_SIZE,dpop(),tag_fixnum(ARRAY_SIZE_MAX),NULL);
+ return 0; /* can't happen */
+}
+
+PRIMITIVE(fixnum_to_float)
+{
+ drepl(allot_float(fixnum_to_float(dpeek())));
+}
+
+PRIMITIVE(bignum_to_float)
+{
+ drepl(allot_float(bignum_to_float(dpeek())));
+}
+
+PRIMITIVE(str_to_float)
+{
+ byte_array *bytes = untag_check<byte_array>(dpeek());
+ cell capacity = array_capacity(bytes);
+
+ char *c_str = (char *)(bytes + 1);
+ char *end = c_str;
+ double f = strtod(c_str,&end);
+ if(end == c_str + capacity - 1)
+ drepl(allot_float(f));
+ else
+ drepl(F);
+}
+
+PRIMITIVE(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));
+}
+
+#define POP_FLOATS(x,y) \
+ double y = untag_float(dpop()); \
+ double x = untag_float(dpop());
+
+PRIMITIVE(float_eq)
+{
+ POP_FLOATS(x,y);
+ box_boolean(x == y);
+}
+
+PRIMITIVE(float_add)
+{
+ POP_FLOATS(x,y);
+ box_double(x + y);
+}
+
+PRIMITIVE(float_subtract)
+{
+ POP_FLOATS(x,y);
+ box_double(x - y);
+}
+
+PRIMITIVE(float_multiply)
+{
+ POP_FLOATS(x,y);
+ box_double(x * y);
+}
+
+PRIMITIVE(float_divfloat)
+{
+ POP_FLOATS(x,y);
+ box_double(x / y);
+}
+
+PRIMITIVE(float_mod)
+{
+ POP_FLOATS(x,y);
+ box_double(fmod(x,y));
+}
+
+PRIMITIVE(float_less)
+{
+ POP_FLOATS(x,y);
+ box_boolean(x < y);
+}
+
+PRIMITIVE(float_lesseq)
+{
+ POP_FLOATS(x,y);
+ box_boolean(x <= y);
+}
+
+PRIMITIVE(float_greater)
+{
+ POP_FLOATS(x,y);
+ box_boolean(x > y);
+}
+
+PRIMITIVE(float_greatereq)
+{
+ POP_FLOATS(x,y);
+ box_boolean(x >= y);
+}
+
+PRIMITIVE(float_bits)
+{
+ box_unsigned_4(float_bits(untag_float_check(dpop())));
+}
+
+PRIMITIVE(bits_float)
+{
+ box_float(bits_float(to_cell(dpop())));
+}
+
+PRIMITIVE(double_bits)
+{
+ box_unsigned_8(double_bits(untag_float_check(dpop())));
+}
+
+PRIMITIVE(bits_double)
+{
+ box_double(bits_double(to_unsigned_8(dpop())));
+}
+
+VM_C_API fixnum to_fixnum(cell tagged)
+{
+ switch(TAG(tagged))
+ {
+ case FIXNUM_TYPE:
+ return untag_fixnum(tagged);
+ case BIGNUM_TYPE:
+ return bignum_to_fixnum(untag<bignum>(tagged));
+ default:
+ type_error(FIXNUM_TYPE,tagged);
+ return -1; /* can't happen */
+ }
+}
+
+VM_C_API cell to_cell(cell tagged)
+{
+ return (cell)to_fixnum(tagged);
+}
+
+VM_C_API void box_signed_1(s8 n)
+{
+ dpush(tag_fixnum(n));
+}
+
+VM_C_API void box_unsigned_1(u8 n)
+{
+ dpush(tag_fixnum(n));
+}
+
+VM_C_API void box_signed_2(s16 n)
+{
+ dpush(tag_fixnum(n));
+}
+
+VM_C_API void box_unsigned_2(u16 n)
+{
+ dpush(tag_fixnum(n));
+}
+
+VM_C_API void box_signed_4(s32 n)
+{
+ dpush(allot_integer(n));
+}
+
+VM_C_API void box_unsigned_4(u32 n)
+{
+ dpush(allot_cell(n));
+}
+
+VM_C_API void box_signed_cell(fixnum integer)
+{
+ dpush(allot_integer(integer));
+}
+
+VM_C_API void box_unsigned_cell(cell cell)
+{
+ dpush(allot_cell(cell));
+}
+
+VM_C_API void box_signed_8(s64 n)
+{
+ if(n < FIXNUM_MIN || n > FIXNUM_MAX)
+ dpush(tag<bignum>(long_long_to_bignum(n)));
+ else
+ dpush(tag_fixnum(n));
+}
+
+VM_C_API s64 to_signed_8(cell obj)
+{
+ switch(tagged<object>(obj).type())
+ {
+ case FIXNUM_TYPE:
+ return untag_fixnum(obj);
+ case BIGNUM_TYPE:
+ return bignum_to_long_long(untag<bignum>(obj));
+ default:
+ type_error(BIGNUM_TYPE,obj);
+ return -1;
+ }
+}
+
+VM_C_API void box_unsigned_8(u64 n)
+{
+ if(n > FIXNUM_MAX)
+ dpush(tag<bignum>(ulong_long_to_bignum(n)));
+ else
+ dpush(tag_fixnum(n));
+}
+
+VM_C_API u64 to_unsigned_8(cell obj)
+{
+ switch(tagged<object>(obj).type())
+ {
+ case FIXNUM_TYPE:
+ return untag_fixnum(obj);
+ case BIGNUM_TYPE:
+ return bignum_to_ulong_long(untag<bignum>(obj));
+ default:
+ type_error(BIGNUM_TYPE,obj);
+ return -1;
+ }
+}
+
+VM_C_API void box_float(float flo)
+{
+ dpush(allot_float(flo));
+}
+
+VM_C_API float to_float(cell value)
+{
+ return untag_float_check(value);
+}
+
+VM_C_API void box_double(double flo)
+{
+ dpush(allot_float(flo));
+}
+
+VM_C_API double to_double(cell value)
+{
+ return untag_float_check(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)
+{
+ drepl(tag<bignum>(fixnum_to_bignum(
+ untag_fixnum(x) + untag_fixnum(y))));
+}
+
+VM_ASM_API void 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)
+{
+ bignum *bx = fixnum_to_bignum(x);
+ GC_BIGNUM(bx);
+ bignum *by = fixnum_to_bignum(y);
+ GC_BIGNUM(by);
+ drepl(tag<bignum>(bignum_multiply(bx,by)));
+}
+
+}
+++ /dev/null
-#define CELL_MAX (CELL)(-1)
-#define FIXNUM_MAX (((F_FIXNUM)1 << (WORD_SIZE - TAG_BITS - 1)) - 1)
-#define FIXNUM_MIN (-((F_FIXNUM)1 << (WORD_SIZE - TAG_BITS - 1)))
-#define ARRAY_SIZE_MAX ((CELL)1 << (WORD_SIZE - TAG_BITS - 2))
-
-DLLEXPORT F_FIXNUM to_fixnum(CELL tagged);
-DLLEXPORT CELL to_cell(CELL tagged);
-
-void primitive_bignum_to_fixnum(void);
-void primitive_float_to_fixnum(void);
-
-void primitive_fixnum_add(void);
-void primitive_fixnum_subtract(void);
-void primitive_fixnum_multiply(void);
-
-DLLEXPORT F_FASTCALL void overflow_fixnum_add(F_FIXNUM x, F_FIXNUM y);
-DLLEXPORT F_FASTCALL void overflow_fixnum_subtract(F_FIXNUM x, F_FIXNUM y);
-DLLEXPORT F_FASTCALL void overflow_fixnum_multiply(F_FIXNUM x, F_FIXNUM y);
-
-void primitive_fixnum_divint(void);
-void primitive_fixnum_divmod(void);
-void primitive_fixnum_shift(void);
-
-CELL bignum_zero;
-CELL bignum_pos_one;
-CELL bignum_neg_one;
-
-INLINE CELL tag_bignum(F_ARRAY* bignum)
-{
- return RETAG(bignum,BIGNUM_TYPE);
-}
-
-void primitive_fixnum_to_bignum(void);
-void primitive_float_to_bignum(void);
-void primitive_bignum_eq(void);
-void primitive_bignum_add(void);
-void primitive_bignum_subtract(void);
-void primitive_bignum_multiply(void);
-void primitive_bignum_divint(void);
-void primitive_bignum_divmod(void);
-void primitive_bignum_mod(void);
-void primitive_bignum_and(void);
-void primitive_bignum_or(void);
-void primitive_bignum_xor(void);
-void primitive_bignum_shift(void);
-void primitive_bignum_less(void);
-void primitive_bignum_lesseq(void);
-void primitive_bignum_greater(void);
-void primitive_bignum_greatereq(void);
-void primitive_bignum_not(void);
-void primitive_bignum_bitp(void);
-void primitive_bignum_log2(void);
-void primitive_byte_array_to_bignum(void);
-
-INLINE CELL allot_integer(F_FIXNUM x)
-{
- if(x < FIXNUM_MIN || x > FIXNUM_MAX)
- return tag_bignum(fixnum_to_bignum(x));
- else
- return tag_fixnum(x);
-}
-
-INLINE CELL allot_cell(CELL x)
-{
- if(x > (CELL)FIXNUM_MAX)
- return tag_bignum(cell_to_bignum(x));
- else
- return tag_fixnum(x);
-}
-
-/* FFI calls this */
-DLLEXPORT void box_signed_1(s8 n);
-DLLEXPORT void box_unsigned_1(u8 n);
-DLLEXPORT void box_signed_2(s16 n);
-DLLEXPORT void box_unsigned_2(u16 n);
-DLLEXPORT void box_signed_4(s32 n);
-DLLEXPORT void box_unsigned_4(u32 n);
-DLLEXPORT void box_signed_cell(F_FIXNUM integer);
-DLLEXPORT void box_unsigned_cell(CELL cell);
-DLLEXPORT void box_signed_8(s64 n);
-DLLEXPORT s64 to_signed_8(CELL obj);
-
-DLLEXPORT void box_unsigned_8(u64 n);
-DLLEXPORT u64 to_unsigned_8(CELL obj);
-
-CELL unbox_array_size(void);
-
-INLINE double untag_float_fast(CELL tagged)
-{
- return ((F_FLOAT*)UNTAG(tagged))->n;
-}
-
-INLINE double untag_float(CELL tagged)
-{
- type_check(FLOAT_TYPE,tagged);
- return untag_float_fast(tagged);
-}
-
-INLINE CELL allot_float(double n)
-{
- F_FLOAT* flo = allot_object(FLOAT_TYPE,sizeof(F_FLOAT));
- flo->n = n;
- return RETAG(flo,FLOAT_TYPE);
-}
-
-INLINE F_FIXNUM float_to_fixnum(CELL tagged)
-{
- return (F_FIXNUM)untag_float_fast(tagged);
-}
-
-INLINE F_ARRAY *float_to_bignum(CELL tagged)
-{
- return double_to_bignum(untag_float_fast(tagged));
-}
-
-INLINE double fixnum_to_float(CELL tagged)
-{
- return (double)untag_fixnum_fast(tagged);
-}
-
-INLINE double bignum_to_float(CELL tagged)
-{
- return bignum_to_double(untag_object(tagged));
-}
-
-DLLEXPORT void box_float(float flo);
-DLLEXPORT float to_float(CELL value);
-DLLEXPORT void box_double(double flo);
-DLLEXPORT double to_double(CELL value);
-
-void primitive_fixnum_to_float(void);
-void primitive_bignum_to_float(void);
-void primitive_str_to_float(void);
-void primitive_float_to_str(void);
-void primitive_float_to_bits(void);
-
-void primitive_float_eq(void);
-void primitive_float_add(void);
-void primitive_float_subtract(void);
-void primitive_float_multiply(void);
-void primitive_float_divfloat(void);
-void primitive_float_mod(void);
-void primitive_float_less(void);
-void primitive_float_lesseq(void);
-void primitive_float_greater(void);
-void primitive_float_greatereq(void);
-
-void primitive_float_bits(void);
-void primitive_bits_float(void);
-void primitive_double_bits(void);
-void primitive_bits_double(void);
--- /dev/null
+namespace factor
+{
+
+extern cell bignum_zero;
+extern cell bignum_pos_one;
+extern cell bignum_neg_one;
+
+#define cell_MAX (cell)(-1)
+#define FIXNUM_MAX (((fixnum)1 << (WORD_SIZE - TAG_BITS - 1)) - 1)
+#define FIXNUM_MIN (-((fixnum)1 << (WORD_SIZE - TAG_BITS - 1)))
+#define ARRAY_SIZE_MAX ((cell)1 << (WORD_SIZE - TAG_BITS - 2))
+
+PRIMITIVE(fixnum_add);
+PRIMITIVE(fixnum_subtract);
+PRIMITIVE(fixnum_multiply);
+
+PRIMITIVE(bignum_to_fixnum);
+PRIMITIVE(float_to_fixnum);
+
+PRIMITIVE(fixnum_divint);
+PRIMITIVE(fixnum_divmod);
+PRIMITIVE(fixnum_shift);
+
+PRIMITIVE(fixnum_to_bignum);
+PRIMITIVE(float_to_bignum);
+PRIMITIVE(bignum_eq);
+PRIMITIVE(bignum_add);
+PRIMITIVE(bignum_subtract);
+PRIMITIVE(bignum_multiply);
+PRIMITIVE(bignum_divint);
+PRIMITIVE(bignum_divmod);
+PRIMITIVE(bignum_mod);
+PRIMITIVE(bignum_and);
+PRIMITIVE(bignum_or);
+PRIMITIVE(bignum_xor);
+PRIMITIVE(bignum_shift);
+PRIMITIVE(bignum_less);
+PRIMITIVE(bignum_lesseq);
+PRIMITIVE(bignum_greater);
+PRIMITIVE(bignum_greatereq);
+PRIMITIVE(bignum_not);
+PRIMITIVE(bignum_bitp);
+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(void);
+
+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(float_to_str);
+PRIMITIVE(float_to_bits);
+
+PRIMITIVE(float_eq);
+PRIMITIVE(float_add);
+PRIMITIVE(float_subtract);
+PRIMITIVE(float_multiply);
+PRIMITIVE(float_divfloat);
+PRIMITIVE(float_mod);
+PRIMITIVE(float_less);
+PRIMITIVE(float_lesseq);
+PRIMITIVE(float_greater);
+PRIMITIVE(float_greatereq);
+
+PRIMITIVE(float_bits);
+PRIMITIVE(bits_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);
+
+}
+++ /dev/null
-#include <ucontext.h>
-
-INLINE void *ucontext_stack_pointer(void *uap)
-{
- ucontext_t *ucontext = (ucontext_t *)uap;
- return (void *)ucontext->uc_mcontext.mc_esp;
-}
-
-#define UAP_PROGRAM_COUNTER(ucontext) (((ucontext_t *)(ucontext))->uc_mcontext.mc_eip)
--- /dev/null
+#include <ucontext.h>
+
+namespace factor
+{
+
+inline static void *ucontext_stack_pointer(void *uap)
+{
+ ucontext_t *ucontext = (ucontext_t *)uap;
+ return (void *)ucontext->uc_mcontext.mc_esp;
+}
+
+#define UAP_PROGRAM_COUNTER(ucontext) (((ucontext_t *)(ucontext))->uc_mcontext.mc_eip)
+
+}
+++ /dev/null
-#include <ucontext.h>
-
-INLINE void *ucontext_stack_pointer(void *uap)
-{
- ucontext_t *ucontext = (ucontext_t *)uap;
- return (void *)ucontext->uc_mcontext.mc_rsp;
-}
-
-#define UAP_PROGRAM_COUNTER(ucontext) (((ucontext_t *)(ucontext))->uc_mcontext.mc_rip)
--- /dev/null
+#include <ucontext.h>
+
+namespace factor
+{
+
+inline static void *ucontext_stack_pointer(void *uap)
+{
+ ucontext_t *ucontext = (ucontext_t *)uap;
+ return (void *)ucontext->uc_mcontext.mc_rsp;
+}
+
+#define UAP_PROGRAM_COUNTER(ucontext) (((ucontext_t *)(ucontext))->uc_mcontext.mc_rip)
+
+}
+++ /dev/null
-#include "master.h"
-
-/* From SBCL */
-const char *vm_executable_path(void)
-{
- char path[PATH_MAX + 1];
-
- if (getosreldate() >= 600024)
- {
- /* KERN_PROC_PATHNAME is available */
- size_t len = PATH_MAX + 1;
- int mib[4];
-
- mib[0] = CTL_KERN;
- mib[1] = KERN_PROC;
- mib[2] = KERN_PROC_PATHNAME;
- mib[3] = -1;
- if (sysctl(mib, 4, &path, &len, NULL, 0) != 0)
- return NULL;
- }
- else
- {
- int size;
- size = readlink("/proc/curproc/file", path, sizeof(path) - 1);
- if (size < 0)
- return NULL;
- path[size] = '\0';
- }
-
- if(strcmp(path, "unknown") == 0)
- return NULL;
-
- return safe_strdup(path);
-}
--- /dev/null
+#include "master.hpp"
+
+namespace factor
+{
+
+/* From SBCL */
+const char *vm_executable_path(void)
+{
+ char path[PATH_MAX + 1];
+
+ if (getosreldate() >= 600024)
+ {
+ /* KERN_PROC_PATHNAME is available */
+ size_t len = PATH_MAX + 1;
+ int mib[4];
+
+ mib[0] = CTL_KERN;
+ mib[1] = KERN_PROC;
+ mib[2] = KERN_PROC_PATHNAME;
+ mib[3] = -1;
+ if (sysctl(mib, 4, &path, &len, NULL, 0) != 0)
+ return NULL;
+ }
+ else
+ {
+ int size;
+ size = readlink("/proc/curproc/file", path, sizeof(path) - 1);
+ if (size < 0)
+ return NULL;
+ path[size] = '\0';
+ }
+
+ if(strcmp(path, "unknown") == 0)
+ return NULL;
+
+ return safe_strdup(path);
+}
+
+}
+++ /dev/null
-#include <osreldate.h>
-
-extern int getosreldate(void);
-
-#include <sys/sysctl.h>
-
-#ifndef KERN_PROC_PATHNAME
-#define KERN_PROC_PATHNAME 12
-#endif
--- /dev/null
+#include <osreldate.h>
+#include <sys/sysctl.h>
+
+extern "C" int getosreldate(void);
+
+#ifndef KERN_PROC_PATHNAME
+#define KERN_PROC_PATHNAME 12
+#endif
+++ /dev/null
-#include "master.h"
-
-void c_to_factor_toplevel(CELL quot)
-{
- c_to_factor(quot);
-}
-
-void init_signals(void)
-{
- unix_init_signals();
-}
-
-void early_init(void) { }
-
-#define SUFFIX ".image"
-#define SUFFIX_LEN 6
-
-const char *default_image_path(void)
-{
- const char *path = vm_executable_path();
-
- if(!path)
- return "factor.image";
-
- /* We can't call strlen() here because with gcc 4.1.2 this
- causes an internal compiler error. */
- int len = 0;
- const char *iter = path;
- while(*iter) { len++; iter++; }
-
- char *new_path = safe_malloc(PATH_MAX + SUFFIX_LEN + 1);
- memcpy(new_path,path,len + 1);
- memcpy(new_path + len,SUFFIX,SUFFIX_LEN + 1);
- return new_path;
-}
--- /dev/null
+#include "master.hpp"
+
+namespace factor
+{
+
+void c_to_factor_toplevel(cell quot)
+{
+ c_to_factor(quot);
+}
+
+void init_signals(void)
+{
+ unix_init_signals();
+}
+
+void early_init(void) { }
+
+#define SUFFIX ".image"
+#define SUFFIX_LEN 6
+
+const char *default_image_path(void)
+{
+ const char *path = vm_executable_path();
+
+ if(!path)
+ return "factor.image";
+
+ /* We can't call strlen() here because with gcc 4.1.2 this
+ causes an internal compiler error. */
+ int len = 0;
+ const char *iter = path;
+ while(*iter) { len++; iter++; }
+
+ char *new_path = safe_malloc(PATH_MAX + SUFFIX_LEN + 1);
+ memcpy(new_path,path,len + 1);
+ memcpy(new_path + len,SUFFIX,SUFFIX_LEN + 1);
+ return new_path;
+}
+
+}
+++ /dev/null
-#define DLLEXPORT
-#define NULL_DLL NULL
-
-void c_to_factor_toplevel(CELL quot);
-void init_signals(void);
-void early_init(void);
-const char *vm_executable_path(void);
-const char *default_image_path(void);
--- /dev/null
+namespace factor
+{
+
+#define VM_C_API extern "C"
+#define NULL_DLL NULL
+
+void c_to_factor_toplevel(cell quot);
+void init_signals(void);
+void early_init(void);
+const char *vm_executable_path(void);
+const char *default_image_path(void);
+
+}
+++ /dev/null
-#include "master.h"
-
-void flush_icache(CELL start, CELL len)
-{
- int result;
-
- /* XXX: why doesn't this work on Nokia n800? It should behave
- identically to the below assembly. */
- /* result = syscall(__ARM_NR_cacheflush,start,start + len,0); */
-
- /* Assembly swiped from
- http://lists.arm.linux.org.uk/pipermail/linux-arm/2002-July/003931.html
- */
- __asm__ __volatile__ (
- "mov r0, %1\n"
- "sub r1, %2, #1\n"
- "mov r2, #0\n"
- "swi " __sys1(__ARM_NR_cacheflush) "\n"
- "mov %0, r0\n"
- : "=r" (result)
- : "r" (start), "r" (start + len)
- : "r0","r1","r2");
-
- if(result < 0)
- critical_error("flush_icache() failed",result);
-}
--- /dev/null
+#include "master.hpp"
+
+namespace factor
+{
+
+void flush_icache(cell start, cell len)
+{
+ int result;
+
+ /* XXX: why doesn't this work on Nokia n800? It should behave
+ identically to the below assembly. */
+ /* result = syscall(__ARM_NR_cacheflush,start,start + len,0); */
+
+ /* Assembly swiped from
+ http://lists.arm.linux.org.uk/pipermail/linux-arm/2002-July/003931.html
+ */
+ __asm__ __volatile__ (
+ "mov r0, %1\n"
+ "sub r1, %2, #1\n"
+ "mov r2, #0\n"
+ "swi " __sys1(__ARM_NR_cacheflush) "\n"
+ "mov %0, r0\n"
+ : "=r" (result)
+ : "r" (start), "r" (start + len)
+ : "r0","r1","r2");
+
+ if(result < 0)
+ critical_error("flush_icache() failed",result);
+}
+
+}
+++ /dev/null
-#include <ucontext.h>
-#include <asm/unistd.h>
-#include <sys/syscall.h>
-
-INLINE void *ucontext_stack_pointer(void *uap)
-{
- ucontext_t *ucontext = (ucontext_t *)uap;
- return (void *)ucontext->uc_mcontext.arm_sp;
-}
-
-#define UAP_PROGRAM_COUNTER(ucontext) \
- (((ucontext_t *)(ucontext))->uc_mcontext.arm_pc)
-
-void flush_icache(CELL start, CELL len);
--- /dev/null
+#include <ucontext.h>
+#include <asm/unistd.h>
+#include <sys/syscall.h>
+
+namespace factor
+{
+
+inline static void *ucontext_stack_pointer(void *uap)
+{
+ ucontext_t *ucontext = (ucontext_t *)uap;
+ return (void *)ucontext->uc_mcontext.arm_sp;
+}
+
+#define UAP_PROGRAM_COUNTER(ucontext) \
+ (((ucontext_t *)(ucontext))->uc_mcontext.arm_pc)
+
+void flush_icache(cell start, cell len);
+
+}
+++ /dev/null
-#include <ucontext.h>
-
-#define FRAME_RETURN_ADDRESS(frame) *((XT *)(frame_successor(frame) + 1) + 1)
-
-INLINE void *ucontext_stack_pointer(void *uap)
-{
- ucontext_t *ucontext = (ucontext_t *)uap;
- return (void *)ucontext->uc_mcontext.uc_regs->gregs[PT_R1];
-}
-
-#define UAP_PROGRAM_COUNTER(ucontext) \
- (((ucontext_t *)(ucontext))->uc_mcontext.uc_regs->gregs[PT_NIP])
--- /dev/null
+#include <ucontext.h>
+
+namespace factor
+{
+
+#define FRAME_RETURN_ADDRESS(frame) *((void **)(frame_successor(frame) + 1) + 1)
+
+inline static void *ucontext_stack_pointer(void *uap)
+{
+ ucontext_t *ucontext = (ucontext_t *)uap;
+ return (void *)ucontext->uc_mcontext.uc_regs->gregs[PT_R1];
+}
+
+#define UAP_PROGRAM_COUNTER(ucontext) \
+ (((ucontext_t *)(ucontext))->uc_mcontext.uc_regs->gregs[PT_NIP])
+
+}
+++ /dev/null
-#include <ucontext.h>
-
-INLINE void *ucontext_stack_pointer(void *uap)
-{
- ucontext_t *ucontext = (ucontext_t *)uap;
- return (void *)ucontext->uc_mcontext.gregs[7];
-}
-
-#define UAP_PROGRAM_COUNTER(ucontext) \
- (((ucontext_t *)(ucontext))->uc_mcontext.gregs[14])
--- /dev/null
+#include <ucontext.h>
+
+namespace factor
+{
+
+inline static void *ucontext_stack_pointer(void *uap)
+{
+ ucontext_t *ucontext = (ucontext_t *)uap;
+ return (void *)ucontext->uc_mcontext.gregs[7];
+}
+
+#define UAP_PROGRAM_COUNTER(ucontext) \
+ (((ucontext_t *)(ucontext))->uc_mcontext.gregs[14])
+
+}
+++ /dev/null
-#include <ucontext.h>
-
-INLINE void *ucontext_stack_pointer(void *uap)
-{
- ucontext_t *ucontext = (ucontext_t *)uap;
- return (void *)ucontext->uc_mcontext.gregs[15];
-}
-
-#define UAP_PROGRAM_COUNTER(ucontext) \
- (((ucontext_t *)(ucontext))->uc_mcontext.gregs[16])
--- /dev/null
+#include <ucontext.h>
+
+namespace factor
+{
+
+inline static void *ucontext_stack_pointer(void *uap)
+{
+ ucontext_t *ucontext = (ucontext_t *)uap;
+ return (void *)ucontext->uc_mcontext.gregs[15];
+}
+
+#define UAP_PROGRAM_COUNTER(ucontext) \
+ (((ucontext_t *)(ucontext))->uc_mcontext.gregs[16])
+
+}
+++ /dev/null
-#include "master.h"
-
-/* Snarfed from SBCL linux-so.c. You must free() this yourself. */
-const char *vm_executable_path(void)
-{
- char *path = safe_malloc(PATH_MAX + 1);
-
- int size = readlink("/proc/self/exe", path, PATH_MAX);
- if (size < 0)
- {
- fatal_error("Cannot read /proc/self/exe",0);
- return NULL;
- }
- else
- {
- path[size] = '\0';
- return safe_strdup(path);
- }
-}
-
-#ifdef SYS_inotify_init
-
-int inotify_init(void)
-{
- return syscall(SYS_inotify_init);
-}
-
-int inotify_add_watch(int fd, const char *name, u32 mask)
-{
- return syscall(SYS_inotify_add_watch, fd, name, mask);
-}
-
-int inotify_rm_watch(int fd, u32 wd)
-{
- return syscall(SYS_inotify_rm_watch, fd, wd);
-}
-
-#else
-
-int inotify_init(void)
-{
- not_implemented_error();
- return -1;
-}
-
-int inotify_add_watch(int fd, const char *name, u32 mask)
-{
- not_implemented_error();
- return -1;
-}
-
-int inotify_rm_watch(int fd, u32 wd)
-{
- not_implemented_error();
- return -1;
-}
-
-#endif
--- /dev/null
+#include "master.hpp"
+
+namespace factor
+{
+
+/* Snarfed from SBCL linux-so.c. You must free() this yourself. */
+const char *vm_executable_path(void)
+{
+ char *path = safe_malloc(PATH_MAX + 1);
+
+ int size = readlink("/proc/self/exe", path, PATH_MAX);
+ if (size < 0)
+ {
+ fatal_error("Cannot read /proc/self/exe",0);
+ return NULL;
+ }
+ else
+ {
+ path[size] = '\0';
+ return safe_strdup(path);
+ }
+}
+
+#ifdef SYS_inotify_init
+
+int inotify_init(void)
+{
+ return syscall(SYS_inotify_init);
+}
+
+int inotify_add_watch(int fd, const char *name, u32 mask)
+{
+ return syscall(SYS_inotify_add_watch, fd, name, mask);
+}
+
+int inotify_rm_watch(int fd, u32 wd)
+{
+ return syscall(SYS_inotify_rm_watch, fd, wd);
+}
+
+#else
+
+int inotify_init(void)
+{
+ not_implemented_error();
+ return -1;
+}
+
+int inotify_add_watch(int fd, const char *name, u32 mask)
+{
+ not_implemented_error();
+ return -1;
+}
+
+int inotify_rm_watch(int fd, u32 wd)
+{
+ not_implemented_error();
+ return -1;
+}
+
+#endif
+
+}
+++ /dev/null
-#include <sys/syscall.h>
-
-int inotify_init(void);
-int inotify_add_watch(int fd, const char *name, u32 mask);
-int inotify_rm_watch(int fd, u32 wd);
--- /dev/null
+#include <sys/syscall.h>
+
+namespace factor
+{
+
+int inotify_init(void);
+int inotify_add_watch(int fd, const char *name, u32 mask);
+int inotify_rm_watch(int fd, u32 wd);
+
+}
+++ /dev/null
-/* Fault handler information. MacOSX version.
-Copyright (C) 1993-1999, 2002-2003 Bruno Haible <clisp.org at bruno>
-Copyright (C) 2003 Paolo Bonzini <gnu.org at bonzini>
-
-Used under BSD license with permission from Paolo Bonzini and Bruno Haible,
-2005-03-10:
-
-http://sourceforge.net/mailarchive/message.php?msg_name=200503102200.32002.bruno%40clisp.org
-
-Modified for Factor by Slava Pestov */
-#include <ucontext.h>
-
-#define FRAME_RETURN_ADDRESS(frame) *((XT *)(frame_successor(frame) + 1) + 2)
-
-#define MACH_EXC_STATE_TYPE ppc_exception_state_t
-#define MACH_EXC_STATE_FLAVOR PPC_EXCEPTION_STATE
-#define MACH_EXC_STATE_COUNT PPC_EXCEPTION_STATE_COUNT
-#define MACH_THREAD_STATE_TYPE ppc_thread_state_t
-#define MACH_THREAD_STATE_FLAVOR PPC_THREAD_STATE
-#define MACH_THREAD_STATE_COUNT PPC_THREAD_STATE_COUNT
-
-#if __DARWIN_UNIX03
- #define MACH_EXC_STATE_FAULT(exc_state) (exc_state)->__dar
- #define MACH_STACK_POINTER(thr_state) (thr_state)->__r1
- #define MACH_PROGRAM_COUNTER(thr_state) (thr_state)->__srr0
- #define UAP_PROGRAM_COUNTER(ucontext) \
- MACH_PROGRAM_COUNTER(&(((ucontext_t *)(ucontext))->uc_mcontext->__ss))
-#else
- #define MACH_EXC_STATE_FAULT(exc_state) (exc_state)->dar
- #define MACH_STACK_POINTER(thr_state) (thr_state)->r1
- #define MACH_PROGRAM_COUNTER(thr_state) (thr_state)->srr0
- #define UAP_PROGRAM_COUNTER(ucontext) \
- MACH_PROGRAM_COUNTER(&(((ucontext_t *)(ucontext))->uc_mcontext->ss))
-#endif
-
-INLINE CELL fix_stack_pointer(CELL sp)
-{
- return sp;
-}
--- /dev/null
+#include <ucontext.h>
+
+namespace factor
+{
+
+/* Fault handler information. MacOSX version.
+Copyright (C) 1993-1999, 2002-2003 Bruno Haible <clisp.org at bruno>
+Copyright (C) 2003 Paolo Bonzini <gnu.org at bonzini>
+
+Used under BSD license with permission from Paolo Bonzini and Bruno Haible,
+2005-03-10:
+
+http://sourceforge.net/mailarchive/message.php?msg_name=200503102200.32002.bruno%40clisp.org
+
+Modified for Factor by Slava Pestov */
+#define FRAME_RETURN_ADDRESS(frame) *((void **)(frame_successor(frame) + 1) + 2)
+
+#define MACH_EXC_STATE_TYPE ppc_exception_state_t
+#define MACH_EXC_STATE_FLAVOR PPC_EXCEPTION_STATE
+#define MACH_EXC_STATE_COUNT PPC_EXCEPTION_STATE_COUNT
+#define MACH_THREAD_STATE_TYPE ppc_thread_state_t
+#define MACH_THREAD_STATE_FLAVOR PPC_THREAD_STATE
+#define MACH_THREAD_STATE_COUNT PPC_THREAD_STATE_COUNT
+
+#if __DARWIN_UNIX03
+ #define MACH_EXC_STATE_FAULT(exc_state) (exc_state)->__dar
+ #define MACH_STACK_POINTER(thr_state) (thr_state)->__r1
+ #define MACH_PROGRAM_COUNTER(thr_state) (thr_state)->__srr0
+ #define UAP_PROGRAM_COUNTER(ucontext) \
+ MACH_PROGRAM_COUNTER(&(((ucontext_t *)(ucontext))->uc_mcontext->__ss))
+#else
+ #define MACH_EXC_STATE_FAULT(exc_state) (exc_state)->dar
+ #define MACH_STACK_POINTER(thr_state) (thr_state)->r1
+ #define MACH_PROGRAM_COUNTER(thr_state) (thr_state)->srr0
+ #define UAP_PROGRAM_COUNTER(ucontext) \
+ MACH_PROGRAM_COUNTER(&(((ucontext_t *)(ucontext))->uc_mcontext->ss))
+#endif
+
+inline static cell fix_stack_pointer(cell sp)
+{
+ return sp;
+}
+
+}
+++ /dev/null
-/* Fault handler information. MacOSX version.
-Copyright (C) 1993-1999, 2002-2003 Bruno Haible <clisp.org at bruno>
-Copyright (C) 2003 Paolo Bonzini <gnu.org at bonzini>
-
-Used under BSD license with permission from Paolo Bonzini and Bruno Haible,
-2005-03-10:
-
-http://sourceforge.net/mailarchive/message.php?msg_name=200503102200.32002.bruno%40clisp.org
-
-Modified for Factor by Slava Pestov */
-#include <ucontext.h>
-
-#define MACH_EXC_STATE_TYPE i386_exception_state_t
-#define MACH_EXC_STATE_FLAVOR i386_EXCEPTION_STATE
-#define MACH_EXC_STATE_COUNT i386_EXCEPTION_STATE_COUNT
-#define MACH_THREAD_STATE_TYPE i386_thread_state_t
-#define MACH_THREAD_STATE_FLAVOR i386_THREAD_STATE
-#define MACH_THREAD_STATE_COUNT i386_THREAD_STATE_COUNT
-
-#if __DARWIN_UNIX03
- #define MACH_EXC_STATE_FAULT(exc_state) (exc_state)->__faultvaddr
- #define MACH_STACK_POINTER(thr_state) (thr_state)->__esp
- #define MACH_PROGRAM_COUNTER(thr_state) (thr_state)->__eip
- #define UAP_PROGRAM_COUNTER(ucontext) \
- MACH_PROGRAM_COUNTER(&(((ucontext_t *)(ucontext))->uc_mcontext->__ss))
-#else
- #define MACH_EXC_STATE_FAULT(exc_state) (exc_state)->faultvaddr
- #define MACH_STACK_POINTER(thr_state) (thr_state)->esp
- #define MACH_PROGRAM_COUNTER(thr_state) (thr_state)->eip
- #define UAP_PROGRAM_COUNTER(ucontext) \
- MACH_PROGRAM_COUNTER(&(((ucontext_t *)(ucontext))->uc_mcontext->ss))
-#endif
-
-INLINE CELL fix_stack_pointer(CELL sp)
-{
- return ((sp + 4) & ~15) - 4;
-}
--- /dev/null
+#include <ucontext.h>
+
+namespace factor
+{
+
+/* Fault handler information. MacOSX version.
+Copyright (C) 1993-1999, 2002-2003 Bruno Haible <clisp.org at bruno>
+Copyright (C) 2003 Paolo Bonzini <gnu.org at bonzini>
+
+Used under BSD license with permission from Paolo Bonzini and Bruno Haible,
+2005-03-10:
+
+http://sourceforge.net/mailarchive/message.php?msg_name=200503102200.32002.bruno%40clisp.org
+
+Modified for Factor by Slava Pestov */
+#define MACH_EXC_STATE_TYPE i386_exception_state_t
+#define MACH_EXC_STATE_FLAVOR i386_EXCEPTION_STATE
+#define MACH_EXC_STATE_COUNT i386_EXCEPTION_STATE_COUNT
+#define MACH_THREAD_STATE_TYPE i386_thread_state_t
+#define MACH_THREAD_STATE_FLAVOR i386_THREAD_STATE
+#define MACH_THREAD_STATE_COUNT i386_THREAD_STATE_COUNT
+
+#if __DARWIN_UNIX03
+ #define MACH_EXC_STATE_FAULT(exc_state) (exc_state)->__faultvaddr
+ #define MACH_STACK_POINTER(thr_state) (thr_state)->__esp
+ #define MACH_PROGRAM_COUNTER(thr_state) (thr_state)->__eip
+ #define UAP_PROGRAM_COUNTER(ucontext) \
+ MACH_PROGRAM_COUNTER(&(((ucontext_t *)(ucontext))->uc_mcontext->__ss))
+#else
+ #define MACH_EXC_STATE_FAULT(exc_state) (exc_state)->faultvaddr
+ #define MACH_STACK_POINTER(thr_state) (thr_state)->esp
+ #define MACH_PROGRAM_COUNTER(thr_state) (thr_state)->eip
+ #define UAP_PROGRAM_COUNTER(ucontext) \
+ MACH_PROGRAM_COUNTER(&(((ucontext_t *)(ucontext))->uc_mcontext->ss))
+#endif
+
+inline static cell fix_stack_pointer(cell sp)
+{
+ return ((sp + 4) & ~15) - 4;
+}
+
+}
+++ /dev/null
-/* Fault handler information. MacOSX version.
-Copyright (C) 1993-1999, 2002-2003 Bruno Haible <clisp.org at bruno>
-Copyright (C) 2003 Paolo Bonzini <gnu.org at bonzini>
-
-Used under BSD license with permission from Paolo Bonzini and Bruno Haible,
-2005-03-10:
-
-http://sourceforge.net/mailarchive/message.php?msg_name=200503102200.32002.bruno%40clisp.org
-
-Modified for Factor by Slava Pestov and Daniel Ehrenberg */
-#include <ucontext.h>
-
-#define MACH_EXC_STATE_TYPE x86_exception_state64_t
-#define MACH_EXC_STATE_FLAVOR x86_EXCEPTION_STATE64
-#define MACH_EXC_STATE_COUNT x86_EXCEPTION_STATE64_COUNT
-#define MACH_THREAD_STATE_TYPE x86_thread_state64_t
-#define MACH_THREAD_STATE_FLAVOR x86_THREAD_STATE64
-#define MACH_THREAD_STATE_COUNT MACHINE_THREAD_STATE_COUNT
-
-#if __DARWIN_UNIX03
- #define MACH_EXC_STATE_FAULT(exc_state) (exc_state)->__faultvaddr
- #define MACH_STACK_POINTER(thr_state) (thr_state)->__rsp
- #define MACH_PROGRAM_COUNTER(thr_state) (thr_state)->__rip
- #define UAP_PROGRAM_COUNTER(ucontext) \
- MACH_PROGRAM_COUNTER(&(((ucontext_t *)(ucontext))->uc_mcontext->__ss))
-#else
- #define MACH_EXC_STATE_FAULT(exc_state) (exc_state)->faultvaddr
- #define MACH_STACK_POINTER(thr_state) (thr_state)->rsp
- #define MACH_PROGRAM_COUNTER(thr_state) (thr_state)->rip
- #define UAP_PROGRAM_COUNTER(ucontext) \
- MACH_PROGRAM_COUNTER(&(((ucontext_t *)(ucontext))->uc_mcontext->ss))
-#endif
-
-INLINE CELL fix_stack_pointer(CELL sp)
-{
- return ((sp + 8) & ~15) - 8;
-}
--- /dev/null
+#include <ucontext.h>
+
+namespace factor
+{
+
+/* Fault handler information. MacOSX version.
+Copyright (C) 1993-1999, 2002-2003 Bruno Haible <clisp.org at bruno>
+Copyright (C) 2003 Paolo Bonzini <gnu.org at bonzini>
+
+Used under BSD license with permission from Paolo Bonzini and Bruno Haible,
+2005-03-10:
+
+http://sourceforge.net/mailarchive/message.php?msg_name=200503102200.32002.bruno%40clisp.org
+
+Modified for Factor by Slava Pestov and Daniel Ehrenberg */
+#define MACH_EXC_STATE_TYPE x86_exception_state64_t
+#define MACH_EXC_STATE_FLAVOR x86_EXCEPTION_STATE64
+#define MACH_EXC_STATE_COUNT x86_EXCEPTION_STATE64_COUNT
+#define MACH_THREAD_STATE_TYPE x86_thread_state64_t
+#define MACH_THREAD_STATE_FLAVOR x86_THREAD_STATE64
+#define MACH_THREAD_STATE_COUNT MACHINE_THREAD_STATE_COUNT
+
+#if __DARWIN_UNIX03
+ #define MACH_EXC_STATE_FAULT(exc_state) (exc_state)->__faultvaddr
+ #define MACH_STACK_POINTER(thr_state) (thr_state)->__rsp
+ #define MACH_PROGRAM_COUNTER(thr_state) (thr_state)->__rip
+ #define UAP_PROGRAM_COUNTER(ucontext) \
+ MACH_PROGRAM_COUNTER(&(((ucontext_t *)(ucontext))->uc_mcontext->__ss))
+#else
+ #define MACH_EXC_STATE_FAULT(exc_state) (exc_state)->faultvaddr
+ #define MACH_STACK_POINTER(thr_state) (thr_state)->rsp
+ #define MACH_PROGRAM_COUNTER(thr_state) (thr_state)->rip
+ #define UAP_PROGRAM_COUNTER(ucontext) \
+ MACH_PROGRAM_COUNTER(&(((ucontext_t *)(ucontext))->uc_mcontext->ss))
+#endif
+
+inline static cell fix_stack_pointer(cell sp)
+{
+ return ((sp + 8) & ~15) - 8;
+}
+
+}
+++ /dev/null
-#define DLLEXPORT __attribute__((visibility("default")))
-#define FACTOR_OS_STRING "macosx"
-#define NULL_DLL "libfactor.dylib"
-
-void init_signals(void);
-void early_init(void);
-
-const char *vm_executable_path(void);
-const char *default_image_path(void);
-
-DLLEXPORT void c_to_factor_toplevel(CELL quot);
-
-INLINE void *ucontext_stack_pointer(void *uap)
-{
- ucontext_t *ucontext = (ucontext_t *)uap;
- return ucontext->uc_stack.ss_sp;
-}
--- /dev/null
+namespace factor
+{
+
+#define VM_C_API extern "C" __attribute__((visibility("default")))
+#define FACTOR_OS_STRING "macosx"
+#define NULL_DLL "libfactor.dylib"
+
+void init_signals(void);
+void early_init(void);
+
+const char *vm_executable_path(void);
+const char *default_image_path(void);
+
+inline static void *ucontext_stack_pointer(void *uap)
+{
+ ucontext_t *ucontext = (ucontext_t *)uap;
+ return ucontext->uc_stack.ss_sp;
+}
+
+void c_to_factor_toplevel(cell quot);
+
+}
+++ /dev/null
-#import <Cocoa/Cocoa.h>
-
-#include "master.h"
-
-void c_to_factor_toplevel(CELL quot)
-{
- for(;;)
- {
-NS_DURING
- c_to_factor(quot);
- NS_VOIDRETURN;
-NS_HANDLER
- dpush(allot_alien(F,(CELL)localException));
- quot = userenv[COCOA_EXCEPTION_ENV];
- if(type_of(quot) != QUOTATION_TYPE)
- {
- /* No Cocoa exception handler was registered, so
- extra/cocoa/ is not loaded. So we pass the exception
- along. */
- [localException raise];
- }
-NS_ENDHANDLER
- }
-}
-
-void early_init(void)
-{
- SInt32 version;
- Gestalt(gestaltSystemVersion,&version);
- if(version <= 0x1050)
- {
- printf("Factor requires Mac OS X 10.5 or later.\n");
- exit(1);
- }
-
- [[NSAutoreleasePool alloc] init];
-}
-
-const char *vm_executable_path(void)
-{
- return [[[NSBundle mainBundle] executablePath] UTF8String];
-}
-
-const char *default_image_path(void)
-{
- NSBundle *bundle = [NSBundle mainBundle];
- NSString *path = [bundle bundlePath];
- NSString *executable = [[bundle executablePath] lastPathComponent];
- NSString *image = [executable stringByAppendingString:@".image"];
-
- NSString *returnVal;
-
- if([path hasSuffix:@".app"] || [path hasSuffix:@".app/"])
- {
- NSFileManager *mgr = [NSFileManager defaultManager];
-
- NSString *imageInBundle = [[path stringByAppendingPathComponent:@"Contents/Resources"] stringByAppendingPathComponent:image];
- NSString *imageAlongBundle = [[path stringByDeletingLastPathComponent] stringByAppendingPathComponent:image];
-
- returnVal = ([mgr fileExistsAtPath:imageInBundle]
- ? imageInBundle : imageAlongBundle);
- }
- else
- returnVal = [path stringByAppendingPathComponent:image];
-
- return [returnVal UTF8String];
-}
-
-void init_signals(void)
-{
- unix_init_signals();
- mach_initialize();
-}
-
-/* Amateurs at Apple: implement this function, properly! */
-Protocol *objc_getProtocol(char *name)
-{
- if(strcmp(name,"NSTextInput") == 0)
- return @protocol(NSTextInput);
- else
- return nil;
-}
--- /dev/null
+#import <Cocoa/Cocoa.h>
+
+#include "master.hpp"
+
+namespace factor
+{
+
+void c_to_factor_toplevel(cell quot)
+{
+ for(;;)
+ {
+NS_DURING
+ c_to_factor(quot);
+ NS_VOIDRETURN;
+NS_HANDLER
+ dpush(allot_alien(F,(cell)localException));
+ quot = userenv[COCOA_EXCEPTION_ENV];
+ if(!tagged<object>(quot).type_p(QUOTATION_TYPE))
+ {
+ /* No Cocoa exception handler was registered, so
+ extra/cocoa/ is not loaded. So we pass the exception
+ along. */
+ [localException raise];
+ }
+NS_ENDHANDLER
+ }
+}
+
+void early_init(void)
+{
+ SInt32 version;
+ Gestalt(gestaltSystemVersion,&version);
+ if(version <= 0x1050)
+ {
+ printf("Factor requires Mac OS X 10.5 or later.\n");
+ exit(1);
+ }
+
+ [[NSAutoreleasePool alloc] init];
+}
+
+const char *vm_executable_path(void)
+{
+ return [[[NSBundle mainBundle] executablePath] UTF8String];
+}
+
+const char *default_image_path(void)
+{
+ NSBundle *bundle = [NSBundle mainBundle];
+ NSString *path = [bundle bundlePath];
+ NSString *executable = [[bundle executablePath] lastPathComponent];
+ NSString *image = [executable stringByAppendingString:@".image"];
+
+ NSString *returnVal;
+
+ if([path hasSuffix:@".app"] || [path hasSuffix:@".app/"])
+ {
+ NSFileManager *mgr = [NSFileManager defaultManager];
+
+ NSString *imageInBundle = [[path stringByAppendingPathComponent:@"Contents/Resources"] stringByAppendingPathComponent:image];
+ NSString *imageAlongBundle = [[path stringByDeletingLastPathComponent] stringByAppendingPathComponent:image];
+
+ returnVal = ([mgr fileExistsAtPath:imageInBundle]
+ ? imageInBundle : imageAlongBundle);
+ }
+ else
+ returnVal = [path stringByAppendingPathComponent:image];
+
+ return [returnVal UTF8String];
+}
+
+void init_signals(void)
+{
+ unix_init_signals();
+ mach_initialize();
+}
+
+/* Amateurs at Apple: implement this function, properly! */
+Protocol *objc_getProtocol(char *name)
+{
+ if(strcmp(name,"NSTextInput") == 0)
+ return @protocol(NSTextInput);
+ else
+ return nil;
+}
+
+}
+++ /dev/null
-#include <ucontext.h>
-
-#define ucontext_stack_pointer(uap) ((void *)_UC_MACHINE_SP((ucontext_t *)uap))
--- /dev/null
+#include <ucontext.h>
+
+namespace factor
+{
+
+#define ucontext_stack_pointer(uap) ((void *)_UC_MACHINE_SP((ucontext_t *)uap))
+
+}
+++ /dev/null
-#include <ucontext.h>
-
-#define ucontext_stack_pointer(uap) \
- ((void *)(((ucontext_t *)(uap))->uc_mcontext.__gregs[_REG_URSP]))
--- /dev/null
+#include <ucontext.h>
+
+namespace factor
+{
+
+#define ucontext_stack_pointer(uap) \
+ ((void *)(((ucontext_t *)(uap))->uc_mcontext.__gregs[_REG_URSP]))
+
+}
+++ /dev/null
-#include "master.h"
-
-extern int main();
-
-const char *vm_executable_path(void)
-{
- static Dl_info info = {0};
- if (!info.dli_fname)
- dladdr(main, &info);
- return info.dli_fname;
-}
--- /dev/null
+#include "master.hpp"
+
+namespace factor
+{
+
+extern int main();
+
+const char *vm_executable_path(void)
+{
+ static Dl_info info = {0};
+ if (!info.dli_fname)
+ dladdr(main, &info);
+ return info.dli_fname;
+}
+
+}
+++ /dev/null
-#include <ucontext.h>
-
-#define UAP_PROGRAM_COUNTER(uap) _UC_MACHINE_PC((ucontext_t *)uap)
-
-#define DIRECTORY_P(file) ((file)->d_type == DT_DIR)
--- /dev/null
+#include <ucontext.h>
+
+namespace factor
+{
+
+#define UAP_PROGRAM_COUNTER(uap) _UC_MACHINE_PC((ucontext_t *)uap)
+
+#define DIRECTORY_P(file) ((file)->d_type == DT_DIR)
+
+}
+++ /dev/null
-#include <i386/signal.h>
-
-INLINE void *openbsd_stack_pointer(void *uap)
-{
- struct sigcontext *sc = (struct sigcontext*) uap;
- return (void *)sc->sc_esp;
-}
-
-#define ucontext_stack_pointer openbsd_stack_pointer
-#define UAP_PROGRAM_COUNTER(uap) (((struct sigcontext*)(uap))->sc_eip)
--- /dev/null
+#include <i386/signal.h>
+
+namespace factor
+{
+
+inline static void *openbsd_stack_pointer(void *uap)
+{
+ struct sigcontext *sc = (struct sigcontext*) uap;
+ return (void *)sc->sc_esp;
+}
+
+#define ucontext_stack_pointer openbsd_stack_pointer
+#define UAP_PROGRAM_COUNTER(uap) (((struct sigcontext*)(uap))->sc_eip)
+
+}
+++ /dev/null
-#include <amd64/signal.h>
-
-INLINE void *openbsd_stack_pointer(void *uap)
-{
- struct sigcontext *sc = (struct sigcontext*) uap;
- return (void *)sc->sc_rsp;
-}
-
-#define ucontext_stack_pointer openbsd_stack_pointer
-#define UAP_PROGRAM_COUNTER(uap) (((struct sigcontext*)(uap))->sc_rip)
--- /dev/null
+#include <amd64/signal.h>
+
+namespace factor
+{
+
+inline static void *openbsd_stack_pointer(void *uap)
+{
+ struct sigcontext *sc = (struct sigcontext*) uap;
+ return (void *)sc->sc_rsp;
+}
+
+#define ucontext_stack_pointer openbsd_stack_pointer
+#define UAP_PROGRAM_COUNTER(uap) (((struct sigcontext*)(uap))->sc_rip)
+
+}
+++ /dev/null
-#include "master.h"
-
-const char *vm_executable_path(void)
-{
- return NULL;
-}
--- /dev/null
+#include "master.hpp"
+
+namespace factor
+{
+
+const char *vm_executable_path(void)
+{
+ return NULL;
+}
+
+}
+++ /dev/null
-#include <ucontext.h>
-
-INLINE void *ucontext_stack_pointer(void *uap)
-{
- ucontext_t *ucontext = (ucontext_t *)uap;
- return (void *)ucontext->uc_mcontext.gregs[ESP];
-}
-
-#define UAP_PROGRAM_COUNTER(ucontext) \
- (((ucontext_t *)(ucontext))->uc_mcontext.gregs[EIP])
--- /dev/null
+#include <ucontext.h>
+
+namespace factor
+{
+
+inline static void *ucontext_stack_pointer(void *uap)
+{
+ ucontext_t *ucontext = (ucontext_t *)uap;
+ return (void *)ucontext->uc_mcontext.gregs[ESP];
+}
+
+#define UAP_PROGRAM_COUNTER(ucontext) \
+ (((ucontext_t *)(ucontext))->uc_mcontext.gregs[EIP])
+
+}
+++ /dev/null
-#include <ucontext.h>
-
-INLINE void *ucontext_stack_pointer(void *uap)
-{
- ucontext_t *ucontext = (ucontext_t *)uap;
- return (void *)ucontext->uc_mcontext.gregs[RSP];
-}
-
-#define UAP_PROGRAM_COUNTER(ucontext) \
- (((ucontext_t *)(ucontext))->uc_mcontext.gregs[RIP])
--- /dev/null
+#include <ucontext.h>
+
+namespace factor
+{
+
+inline static void *ucontext_stack_pointer(void *uap)
+{
+ ucontext_t *ucontext = (ucontext_t *)uap;
+ return (void *)ucontext->uc_mcontext.gregs[RSP];
+}
+
+#define UAP_PROGRAM_COUNTER(ucontext) \
+ (((ucontext_t *)(ucontext))->uc_mcontext.gregs[RIP])
+
+}
+++ /dev/null
-#include "master.h"
-
-const char *vm_executable_path(void)
-{
- return NULL;
-}
--- /dev/null
+#include "master.hpp"
+
+namespace factor
+{
+
+const char *vm_executable_path(void)
+{
+ return NULL;
+}
+
+}
+++ /dev/null
-#include "master.h"
-
-void start_thread(void *(*start_routine)(void *))
-{
- 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)
- fatal_error("pthread_attr_setdetachstate() failed",0);
- if (pthread_create (&thread, &attr, start_routine, NULL) != 0)
- fatal_error("pthread_create() failed",0);
- pthread_attr_destroy (&attr);
-}
-
-static void *null_dll;
-
-s64 current_micros(void)
-{
- struct timeval t;
- gettimeofday(&t,NULL);
- return (s64)t.tv_sec * 1000000 + t.tv_usec;
-}
-
-void sleep_micros(CELL usec)
-{
- usleep(usec);
-}
-
-void init_ffi(void)
-{
- /* NULL_DLL is "libfactor.dylib" for OS X and NULL for generic unix */
- null_dll = dlopen(NULL_DLL,RTLD_LAZY);
-}
-
-void ffi_dlopen(F_DLL *dll)
-{
- dll->dll = dlopen(alien_offset(dll->path), RTLD_LAZY);
-}
-
-void *ffi_dlsym(F_DLL *dll, F_SYMBOL *symbol)
-{
- void *handle = (dll == NULL ? null_dll : dll->dll);
- return dlsym(handle,symbol);
-}
-
-void ffi_dlclose(F_DLL *dll)
-{
- if(dlclose(dll->dll))
- {
- general_error(ERROR_FFI,tag_object(
- from_char_string(dlerror())),F,NULL);
- }
- dll->dll = NULL;
-}
-
-void primitive_existsp(void)
-{
- struct stat sb;
- box_boolean(stat(unbox_char_string(),&sb) >= 0);
-}
-
-F_SEGMENT *alloc_segment(CELL size)
-{
- int pagesize = getpagesize();
-
- char *array = mmap(NULL,pagesize + size + pagesize,
- PROT_READ | PROT_WRITE | PROT_EXEC,
- MAP_ANON | MAP_PRIVATE,-1,0);
-
- if(array == (char*)-1)
- out_of_memory();
-
- if(mprotect(array,pagesize,PROT_NONE) == -1)
- fatal_error("Cannot protect low guard page",(CELL)array);
-
- if(mprotect(array + pagesize + size,pagesize,PROT_NONE) == -1)
- fatal_error("Cannot protect high guard page",(CELL)array);
-
- F_SEGMENT *retval = safe_malloc(sizeof(F_SEGMENT));
-
- retval->start = (CELL)(array + pagesize);
- retval->size = size;
- retval->end = retval->start + size;
-
- return retval;
-}
-
-void dealloc_segment(F_SEGMENT *block)
-{
- int pagesize = getpagesize();
-
- int retval = munmap((void*)(block->start - pagesize),
- pagesize + block->size + pagesize);
-
- if(retval)
- fatal_error("dealloc_segment failed",0);
-
- free(block);
-}
-
-INLINE F_STACK_FRAME *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
- from Factor to C is a sign of things seriously gone wrong, not just
- a divide by zero or stack underflow in the listener */
- if(in_code_heap_p(UAP_PROGRAM_COUNTER(uap)))
- {
- F_STACK_FRAME *ptr = ucontext_stack_pointer(uap);
- if(!ptr)
- critical_error("Invalid uap",(CELL)uap);
- return ptr;
- }
- else
- return NULL;
-}
-
-void 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;
-}
-
-void 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;
-}
-
-static void sigaction_safe(int signum, const struct sigaction *act, struct sigaction *oldact)
-{
- int ret;
- do
- {
- ret = sigaction(signum, act, oldact);
- }
- while(ret == -1 && errno == EINTR);
-
- if(ret == -1)
- fatal_error("sigaction failed", 0);
-}
-
-void unix_init_signals(void)
-{
- struct sigaction memory_sigaction;
- struct sigaction misc_sigaction;
- struct sigaction ignore_sigaction;
-
- memset(&memory_sigaction,0,sizeof(struct sigaction));
- sigemptyset(&memory_sigaction.sa_mask);
- memory_sigaction.sa_sigaction = memory_signal_handler;
- memory_sigaction.sa_flags = SA_SIGINFO;
-
- sigaction_safe(SIGBUS,&memory_sigaction,NULL);
- sigaction_safe(SIGSEGV,&memory_sigaction,NULL);
-
- memset(&misc_sigaction,0,sizeof(struct sigaction));
- sigemptyset(&misc_sigaction.sa_mask);
- misc_sigaction.sa_sigaction = misc_signal_handler;
- misc_sigaction.sa_flags = SA_SIGINFO;
-
- sigaction_safe(SIGABRT,&misc_sigaction,NULL);
- sigaction_safe(SIGFPE,&misc_sigaction,NULL);
- sigaction_safe(SIGQUIT,&misc_sigaction,NULL);
- sigaction_safe(SIGILL,&misc_sigaction,NULL);
-
- memset(&ignore_sigaction,0,sizeof(struct sigaction));
- sigemptyset(&ignore_sigaction.sa_mask);
- ignore_sigaction.sa_handler = SIG_IGN;
- sigaction_safe(SIGPIPE,&ignore_sigaction,NULL);
-}
-
-/* On Unix, shared fds such as stdin cannot be set to non-blocking mode
-(http://homepages.tesco.net/J.deBoynePollard/FGA/dont-set-shared-file-descriptors-to-non-blocking-mode.html)
-so we kludge around this by spawning a thread, which waits on a control pipe
-for a signal, upon receiving this signal it reads one block of data from stdin
-and writes it to a data pipe. Upon completion, it writes a 4-byte integer to
-the size pipe, indicating how much data was written to the data pipe.
-
-The read end of the size pipe can be set to non-blocking. */
-__attribute__((visibility("default"))) int stdin_read;
-__attribute__((visibility("default"))) int stdin_write;
-
-__attribute__((visibility("default"))) int control_read;
-__attribute__((visibility("default"))) int control_write;
-
-__attribute__((visibility("default"))) int size_read;
-__attribute__((visibility("default"))) int size_write;
-
-void safe_close(int fd)
-{
- if(close(fd) < 0)
- fatal_error("error closing fd",errno);
-}
-
-bool check_write(int fd, void *data, size_t size)
-{
- if(write(fd,data,size) == size)
- return true;
- else
- {
- if(errno == EINTR)
- return check_write(fd,data,size);
- else
- return false;
- }
-}
-
-void safe_write(int fd, void *data, size_t size)
-{
- if(!check_write(fd,data,size))
- fatal_error("error writing fd",errno);
-}
-
-bool safe_read(int fd, void *data, size_t size)
-{
- ssize_t bytes = read(fd,data,size);
- if(bytes < 0)
- {
- if(errno == EINTR)
- return safe_read(fd,data,size);
- else
- {
- fatal_error("error reading fd",errno);
- return false;
- }
- }
- else
- return (bytes == size);
-}
-
-void *stdin_loop(void *arg)
-{
- unsigned char buf[4096];
- bool loop_running = true;
-
- while(loop_running)
- {
- if(!safe_read(control_read,buf,1))
- break;
-
- if(buf[0] != 'X')
- fatal_error("stdin_loop: bad data on control fd",buf[0]);
-
- for(;;)
- {
- ssize_t bytes = read(0,buf,sizeof(buf));
- if(bytes < 0)
- {
- if(errno == EINTR)
- continue;
- else
- {
- loop_running = false;
- break;
- }
- }
- else if(bytes >= 0)
- {
- safe_write(size_write,&bytes,sizeof(bytes));
-
- if(!check_write(stdin_write,buf,bytes))
- loop_running = false;
- break;
- }
- }
- }
-
- safe_close(stdin_write);
- safe_close(control_read);
-
- return NULL;
-}
-
-void open_console(void)
-{
- int filedes[2];
-
- if(pipe(filedes) < 0)
- fatal_error("Error opening control pipe",errno);
-
- control_read = filedes[0];
- control_write = filedes[1];
-
- if(pipe(filedes) < 0)
- fatal_error("Error opening size pipe",errno);
-
- size_read = filedes[0];
- size_write = filedes[1];
-
- if(pipe(filedes) < 0)
- fatal_error("Error opening stdin pipe",errno);
-
- stdin_read = filedes[0];
- stdin_write = filedes[1];
-
- start_thread(stdin_loop);
-}
-
-DLLEXPORT void wait_for_stdin(void)
-{
- if(write(control_write,"X",1) != 1)
- {
- if(errno == EINTR)
- wait_for_stdin();
- else
- fatal_error("Error writing control fd",errno);
- }
-}
--- /dev/null
+#include "master.hpp"
+
+namespace factor
+{
+
+void start_thread(void *(*start_routine)(void *))
+{
+ 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)
+ fatal_error("pthread_attr_setdetachstate() failed",0);
+ if (pthread_create (&thread, &attr, start_routine, NULL) != 0)
+ fatal_error("pthread_create() failed",0);
+ pthread_attr_destroy (&attr);
+}
+
+static void *null_dll;
+
+s64 current_micros(void)
+{
+ struct timeval t;
+ gettimeofday(&t,NULL);
+ return (s64)t.tv_sec * 1000000 + t.tv_usec;
+}
+
+void sleep_micros(cell usec)
+{
+ usleep(usec);
+}
+
+void init_ffi(void)
+{
+ /* 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)
+{
+ dll->dll = dlopen(alien_offset(dll->path), RTLD_LAZY);
+}
+
+void *ffi_dlsym(dll *dll, symbol_char *symbol)
+{
+ void *handle = (dll == NULL ? null_dll : dll->dll);
+ return dlsym(handle,symbol);
+}
+
+void ffi_dlclose(dll *dll)
+{
+ if(dlclose(dll->dll))
+ general_error(ERROR_FFI,F,F,NULL);
+ dll->dll = NULL;
+}
+
+PRIMITIVE(existsp)
+{
+ struct stat sb;
+ char *path = (char *)(untag_check<byte_array>(dpop()) + 1);
+ box_boolean(stat(path,&sb) >= 0);
+}
+
+segment *alloc_segment(cell size)
+{
+ int pagesize = getpagesize();
+
+ char *array = (char *)mmap(NULL,pagesize + size + pagesize,
+ PROT_READ | PROT_WRITE | PROT_EXEC,
+ MAP_ANON | MAP_PRIVATE,-1,0);
+
+ if(array == (char*)-1)
+ out_of_memory();
+
+ if(mprotect(array,pagesize,PROT_NONE) == -1)
+ fatal_error("Cannot protect low guard page",(cell)array);
+
+ if(mprotect(array + pagesize + size,pagesize,PROT_NONE) == -1)
+ fatal_error("Cannot protect high guard page",(cell)array);
+
+ segment *retval = (segment *)safe_malloc(sizeof(segment));
+
+ retval->start = (cell)(array + pagesize);
+ retval->size = size;
+ retval->end = retval->start + size;
+
+ return retval;
+}
+
+void dealloc_segment(segment *block)
+{
+ int pagesize = getpagesize();
+
+ int retval = munmap((void*)(block->start - pagesize),
+ pagesize + block->size + pagesize);
+
+ if(retval)
+ fatal_error("dealloc_segment failed",0);
+
+ free(block);
+}
+
+static stack_frame *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
+ from Factor to C is a sign of things seriously gone wrong, not just
+ a divide by zero or stack underflow in the listener */
+ if(in_code_heap_p(UAP_PROGRAM_COUNTER(uap)))
+ {
+ stack_frame *ptr = (stack_frame *)ucontext_stack_pointer(uap);
+ if(!ptr)
+ critical_error("Invalid uap",(cell)uap);
+ return ptr;
+ }
+ else
+ return NULL;
+}
+
+void 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;
+}
+
+void 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;
+}
+
+static void sigaction_safe(int signum, const struct sigaction *act, struct sigaction *oldact)
+{
+ int ret;
+ do
+ {
+ ret = sigaction(signum, act, oldact);
+ }
+ while(ret == -1 && errno == EINTR);
+
+ if(ret == -1)
+ fatal_error("sigaction failed", 0);
+}
+
+void unix_init_signals(void)
+{
+ struct sigaction memory_sigaction;
+ struct sigaction misc_sigaction;
+ struct sigaction ignore_sigaction;
+
+ memset(&memory_sigaction,0,sizeof(struct sigaction));
+ sigemptyset(&memory_sigaction.sa_mask);
+ memory_sigaction.sa_sigaction = memory_signal_handler;
+ memory_sigaction.sa_flags = SA_SIGINFO;
+
+ sigaction_safe(SIGBUS,&memory_sigaction,NULL);
+ sigaction_safe(SIGSEGV,&memory_sigaction,NULL);
+
+ memset(&misc_sigaction,0,sizeof(struct sigaction));
+ sigemptyset(&misc_sigaction.sa_mask);
+ misc_sigaction.sa_sigaction = misc_signal_handler;
+ misc_sigaction.sa_flags = SA_SIGINFO;
+
+ sigaction_safe(SIGABRT,&misc_sigaction,NULL);
+ sigaction_safe(SIGFPE,&misc_sigaction,NULL);
+ sigaction_safe(SIGQUIT,&misc_sigaction,NULL);
+ sigaction_safe(SIGILL,&misc_sigaction,NULL);
+
+ memset(&ignore_sigaction,0,sizeof(struct sigaction));
+ sigemptyset(&ignore_sigaction.sa_mask);
+ ignore_sigaction.sa_handler = SIG_IGN;
+ sigaction_safe(SIGPIPE,&ignore_sigaction,NULL);
+}
+
+/* On Unix, shared fds such as stdin cannot be set to non-blocking mode
+(http://homepages.tesco.net/J.deBoynePollard/FGA/dont-set-shared-file-descriptors-to-non-blocking-mode.html)
+so we kludge around this by spawning a thread, which waits on a control pipe
+for a signal, upon receiving this signal it reads one block of data from stdin
+and writes it to a data pipe. Upon completion, it writes a 4-byte integer to
+the size pipe, indicating how much data was written to the data pipe.
+
+The read end of the size pipe can be set to non-blocking. */
+extern "C" {
+ int stdin_read;
+ int stdin_write;
+
+ int control_read;
+ int control_write;
+
+ int size_read;
+ int size_write;
+}
+
+void safe_close(int fd)
+{
+ if(close(fd) < 0)
+ fatal_error("error closing fd",errno);
+}
+
+bool check_write(int fd, void *data, ssize_t size)
+{
+ if(write(fd,data,size) == size)
+ return true;
+ else
+ {
+ if(errno == EINTR)
+ return check_write(fd,data,size);
+ else
+ return false;
+ }
+}
+
+void safe_write(int fd, void *data, ssize_t size)
+{
+ if(!check_write(fd,data,size))
+ fatal_error("error writing fd",errno);
+}
+
+bool safe_read(int fd, void *data, ssize_t size)
+{
+ ssize_t bytes = read(fd,data,size);
+ if(bytes < 0)
+ {
+ if(errno == EINTR)
+ return safe_read(fd,data,size);
+ else
+ {
+ fatal_error("error reading fd",errno);
+ return false;
+ }
+ }
+ else
+ return (bytes == size);
+}
+
+void *stdin_loop(void *arg)
+{
+ unsigned char buf[4096];
+ bool loop_running = true;
+
+ while(loop_running)
+ {
+ if(!safe_read(control_read,buf,1))
+ break;
+
+ if(buf[0] != 'X')
+ fatal_error("stdin_loop: bad data on control fd",buf[0]);
+
+ for(;;)
+ {
+ ssize_t bytes = read(0,buf,sizeof(buf));
+ if(bytes < 0)
+ {
+ if(errno == EINTR)
+ continue;
+ else
+ {
+ loop_running = false;
+ break;
+ }
+ }
+ else if(bytes >= 0)
+ {
+ safe_write(size_write,&bytes,sizeof(bytes));
+
+ if(!check_write(stdin_write,buf,bytes))
+ loop_running = false;
+ break;
+ }
+ }
+ }
+
+ safe_close(stdin_write);
+ safe_close(control_read);
+
+ return NULL;
+}
+
+void open_console(void)
+{
+ int filedes[2];
+
+ if(pipe(filedes) < 0)
+ fatal_error("Error opening control pipe",errno);
+
+ control_read = filedes[0];
+ control_write = filedes[1];
+
+ if(pipe(filedes) < 0)
+ fatal_error("Error opening size pipe",errno);
+
+ size_read = filedes[0];
+ size_write = filedes[1];
+
+ if(pipe(filedes) < 0)
+ fatal_error("Error opening stdin pipe",errno);
+
+ stdin_read = filedes[0];
+ stdin_write = filedes[1];
+
+ start_thread(stdin_loop);
+}
+
+VM_C_API void wait_for_stdin(void)
+{
+ if(write(control_write,"X",1) != 1)
+ {
+ if(errno == EINTR)
+ wait_for_stdin();
+ else
+ fatal_error("Error writing control fd",errno);
+ }
+}
+
+}
+++ /dev/null
-#include <dirent.h>
-#include <sys/mman.h>
-#include <sys/types.h>
-#include <sys/stat.h>
-#include <unistd.h>
-#include <sys/time.h>
-#include <dlfcn.h>
-#include <signal.h>
-#include <pthread.h>
-
-typedef char F_CHAR;
-typedef char F_SYMBOL;
-
-#define from_native_string from_char_string
-#define unbox_native_string unbox_char_string
-#define string_to_native_alien(string) string_to_char_alien(string,true)
-#define unbox_symbol_string unbox_char_string
-
-#define STRING_LITERAL(string) string
-
-#define SSCANF sscanf
-#define STRCMP strcmp
-#define STRNCMP strncmp
-#define STRDUP strdup
-
-#define FSEEK fseeko
-
-#define FIXNUM_FORMAT "%ld"
-#define CELL_FORMAT "%lu"
-#define CELL_HEX_FORMAT "%lx"
-
-#ifdef FACTOR_64
- #define CELL_HEX_PAD_FORMAT "%016lx"
-#else
- #define CELL_HEX_PAD_FORMAT "%08lx"
-#endif
-
-#define FIXNUM_FORMAT "%ld"
-
-#define OPEN_READ(path) fopen(path,"rb")
-#define OPEN_WRITE(path) fopen(path,"wb")
-
-#define print_native_string(string) print_string(string)
-
-void start_thread(void *(*start_routine)(void *));
-
-void init_ffi(void);
-void ffi_dlopen(F_DLL *dll);
-void *ffi_dlsym(F_DLL *dll, F_SYMBOL *symbol);
-void ffi_dlclose(F_DLL *dll);
-
-void unix_init_signals(void);
-void signal_handler(int signal, siginfo_t* siginfo, void* uap);
-void dump_stack_signal(int signal, siginfo_t* siginfo, void* uap);
-
-s64 current_micros(void);
-void sleep_micros(CELL usec);
-
-void open_console(void);
--- /dev/null
+#include <dirent.h>
+#include <sys/mman.h>
+#include <sys/types.h>
+#include <sys/stat.h>
+#include <unistd.h>
+#include <sys/time.h>
+#include <dlfcn.h>
+#include <signal.h>
+#include <pthread.h>
+
+namespace factor
+{
+
+typedef char vm_char;
+typedef char symbol_char;
+
+#define STRING_LITERAL(string) string
+
+#define SSCANF sscanf
+#define STRCMP strcmp
+#define STRNCMP strncmp
+#define STRDUP strdup
+
+#define FSEEK fseeko
+
+#define FIXNUM_FORMAT "%ld"
+#define cell_FORMAT "%lu"
+#define cell_HEX_FORMAT "%lx"
+
+#ifdef FACTOR_64
+ #define cell_HEX_PAD_FORMAT "%016lx"
+#else
+ #define cell_HEX_PAD_FORMAT "%08lx"
+#endif
+
+#define FIXNUM_FORMAT "%ld"
+
+#define OPEN_READ(path) fopen(path,"rb")
+#define OPEN_WRITE(path) fopen(path,"wb")
+
+#define print_native_string(string) print_string(string)
+
+void start_thread(void *(*start_routine)(void *));
+
+void init_ffi(void);
+void ffi_dlopen(dll *dll);
+void *ffi_dlsym(dll *dll, symbol_char *symbol);
+void ffi_dlclose(dll *dll);
+
+void unix_init_signals(void);
+void signal_handler(int signal, siginfo_t* siginfo, void* uap);
+void dump_stack_signal(int signal, siginfo_t* siginfo, void* uap);
+
+s64 current_micros(void);
+void sleep_micros(cell usec);
+
+void open_console(void);
+
+}
+++ /dev/null
-#include "master.h"
-
-s64 current_micros(void)
-{
- SYSTEMTIME st;
- FILETIME ft;
- GetSystemTime(&st);
- SystemTimeToFileTime(&st, &ft);
- return (((s64)ft.dwLowDateTime
- | (s64)ft.dwHighDateTime<<32) - EPOCH_OFFSET) / 10;
-}
-
-char *strerror(int err)
-{
- /* strerror() is not defined on WinCE */
- return "strerror() is not defined on WinCE. Use native I/O.";
-}
-
-void flush_icache(CELL start, CELL end)
-{
- FlushInstructionCache(GetCurrentProcess(), 0, 0);
-}
-
-char *getenv(char *name)
-{
- not_implemented_error();
- return 0; /* unreachable */
-}
-
-void primitive_os_envs(void)
-{
- not_implemented_error();
-}
-
-void c_to_factor_toplevel(CELL quot)
-{
- c_to_factor(quot);
-}
-
-void open_console(void) { }
--- /dev/null
+#include "master.hpp"
+
+namespace factor
+{
+
+s64 current_micros(void)
+{
+ SYSTEMTIME st;
+ FILETIME ft;
+ GetSystemTime(&st);
+ SystemTimeToFileTime(&st, &ft);
+ return (((s64)ft.dwLowDateTime
+ | (s64)ft.dwHighDateTime<<32) - EPOCH_OFFSET) / 10;
+}
+
+char *strerror(int err)
+{
+ /* strerror() is not defined on WinCE */
+ return "strerror() is not defined on WinCE. Use native I/O.";
+}
+
+void flush_icache(cell start, cell end)
+{
+ FlushInstructionCache(GetCurrentProcess(), 0, 0);
+}
+
+char *getenv(char *name)
+{
+ not_implemented_error();
+ return 0; /* unreachable */
+}
+
+PRIMITIVE(os_envs)
+{
+ not_implemented_error();
+}
+
+void c_to_factor_toplevel(cell quot)
+{
+ c_to_factor(quot);
+}
+
+void open_console(void) { }
+
+}
+++ /dev/null
-#ifndef UNICODE
-#define UNICODE
-#endif
-
-#include <windows.h>
-#include <ctype.h>
-
-typedef wchar_t F_SYMBOL;
-
-#define unbox_symbol_string unbox_u16_string
-#define from_symbol_string from_u16_string
-
-#define FACTOR_OS_STRING "wince"
-#define FACTOR_DLL L"factor-ce.dll"
-#define FACTOR_DLL_NAME "factor-ce.dll"
-
-int errno;
-char *strerror(int err);
-void flush_icache(CELL start, CELL end);
-char *getenv(char *name);
-
-#define snprintf _snprintf
-#define snwprintf _snwprintf
-
-s64 current_micros(void);
-void c_to_factor_toplevel(CELL quot);
-void open_console(void);
--- /dev/null
+#ifndef UNICODE
+#define UNICODE
+#endif
+
+#include <windows.h>
+#include <ctype.h>
+
+namespace factor
+{
+
+typedef wchar_t symbol_char;
+
+#define FACTOR_OS_STRING "wince"
+#define FACTOR_DLL L"factor-ce.dll"
+#define FACTOR_DLL_NAME "factor-ce.dll"
+
+int errno;
+char *strerror(int err);
+void flush_icache(cell start, cell end);
+char *getenv(char *name);
+
+#define snprintf _snprintf
+#define snwprintf _snwprintf
+
+s64 current_micros(void);
+void c_to_factor_toplevel(cell quot);
+void open_console(void);
+
+}
+++ /dev/null
-#define ESP Esp
-#define EIP Eip
--- /dev/null
+namespace factor
+{
+
+#define ESP Esp
+#define EIP Eip
+
+}
+++ /dev/null
-#define ESP Rsp
-#define EIP Rip
--- /dev/null
+namespace factor
+{
+
+#define ESP Rsp
+#define EIP Rip
+
+}
+++ /dev/null
-#include "master.h"
-
-s64 current_micros(void)
-{
- FILETIME t;
- GetSystemTimeAsFileTime(&t);
- return (((s64)t.dwLowDateTime | (s64)t.dwHighDateTime<<32)
- - EPOCH_OFFSET) / 10;
-}
-
-long exception_handler(PEXCEPTION_POINTERS pe)
-{
- PEXCEPTION_RECORD e = (PEXCEPTION_RECORD)pe->ExceptionRecord;
- CONTEXT *c = (CONTEXT*)pe->ContextRecord;
-
- if(in_code_heap_p(c->EIP))
- signal_callstack_top = (void *)c->ESP;
- else
- signal_callstack_top = NULL;
-
- if(e->ExceptionCode == EXCEPTION_ACCESS_VIOLATION)
- {
- signal_fault_addr = e->ExceptionInformation[1];
- c->EIP = (CELL)memory_signal_handler_impl;
- }
- /* If the Widcomm bluetooth stack is installed, the BTTray.exe process
- injects code into running programs. For some reason this results in
- random SEH exceptions with this (undocumented) exception code being
- raised. The workaround seems to be ignoring this altogether, since that
- is what happens if SEH is not enabled. Don't really have any idea what
- this exception means. */
- else if(e->ExceptionCode != 0x40010006)
- {
- signal_number = e->ExceptionCode;
- c->EIP = (CELL)misc_signal_handler_impl;
- }
-
- return EXCEPTION_CONTINUE_EXECUTION;
-}
-
-void c_to_factor_toplevel(CELL quot)
-{
- if(!AddVectoredExceptionHandler(0, (void*)exception_handler))
- fatal_error("AddVectoredExceptionHandler failed", 0);
- c_to_factor(quot);
- RemoveVectoredExceptionHandler((void*)exception_handler);
-}
-
-void open_console(void)
-{
-}
--- /dev/null
+#include "master.hpp"
+
+namespace factor
+{
+
+s64 current_micros(void)
+{
+ FILETIME t;
+ GetSystemTimeAsFileTime(&t);
+ return (((s64)t.dwLowDateTime | (s64)t.dwHighDateTime<<32)
+ - EPOCH_OFFSET) / 10;
+}
+
+long exception_handler(PEXCEPTION_POINTERS pe)
+{
+ PEXCEPTION_RECORD e = (PEXCEPTION_RECORD)pe->ExceptionRecord;
+ CONTEXT *c = (CONTEXT*)pe->ContextRecord;
+
+ if(in_code_heap_p(c->EIP))
+ signal_callstack_top = (void *)c->ESP;
+ else
+ signal_callstack_top = NULL;
+
+ if(e->ExceptionCode == EXCEPTION_ACCESS_VIOLATION)
+ {
+ signal_fault_addr = e->ExceptionInformation[1];
+ c->EIP = (cell)memory_signal_handler_impl;
+ }
+ /* If the Widcomm bluetooth stack is installed, the BTTray.exe process
+ injects code into running programs. For some reason this results in
+ random SEH exceptions with this (undocumented) exception code being
+ raised. The workaround seems to be ignoring this altogether, since that
+ is what happens if SEH is not enabled. Don't really have any idea what
+ this exception means. */
+ else if(e->ExceptionCode != 0x40010006)
+ {
+ signal_number = e->ExceptionCode;
+ c->EIP = (cell)misc_signal_handler_impl;
+ }
+
+ return EXCEPTION_CONTINUE_EXECUTION;
+}
+
+void c_to_factor_toplevel(cell quot)
+{
+ if(!AddVectoredExceptionHandler(0, (void*)exception_handler))
+ fatal_error("AddVectoredExceptionHandler failed", 0);
+ c_to_factor(quot);
+ RemoveVectoredExceptionHandler((void*)exception_handler);
+}
+
+void open_console(void)
+{
+}
+
+}
+++ /dev/null
-#undef _WIN32_WINNT
-#define _WIN32_WINNT 0x0501 // For AddVectoredExceptionHandler
-
-#ifndef UNICODE
-#define UNICODE
-#endif
-
-#include <windows.h>
-
-typedef char F_SYMBOL;
-
-#define unbox_symbol_string unbox_char_string
-#define from_symbol_string from_char_string
-
-#define FACTOR_OS_STRING "winnt"
-#define FACTOR_DLL L"factor.dll"
-#define FACTOR_DLL_NAME "factor.dll"
-
-void c_to_factor_toplevel(CELL quot);
-long exception_handler(PEXCEPTION_POINTERS pe);
-void open_console(void);
--- /dev/null
+#undef _WIN32_WINNT
+#define _WIN32_WINNT 0x0501 // For AddVectoredExceptionHandler
+
+#ifndef UNICODE
+#define UNICODE
+#endif
+
+#include <shellapi.h>
+#include <windows.h>
+
+namespace factor
+{
+
+typedef char symbol_char;
+
+#define FACTOR_OS_STRING "winnt"
+#define FACTOR_DLL L"factor.dll"
+#define FACTOR_DLL_NAME "factor.dll"
+
+void c_to_factor_toplevel(cell quot);
+long exception_handler(PEXCEPTION_POINTERS pe);
+void open_console(void);
+
+}
+++ /dev/null
-#include "master.h"
-
-HMODULE hFactorDll;
-
-void init_ffi(void)
-{
- hFactorDll = GetModuleHandle(FACTOR_DLL);
- if(!hFactorDll)
- fatal_error("GetModuleHandle(\"" FACTOR_DLL_NAME "\") failed", 0);
-}
-
-void ffi_dlopen(F_DLL *dll)
-{
- dll->dll = LoadLibraryEx(alien_offset(dll->path), NULL, 0);
-}
-
-void *ffi_dlsym(F_DLL *dll, F_SYMBOL *symbol)
-{
- return GetProcAddress(dll ? (HMODULE)dll->dll : hFactorDll, symbol);
-}
-
-void ffi_dlclose(F_DLL *dll)
-{
- FreeLibrary((HMODULE)dll->dll);
- dll->dll = NULL;
-}
-
-bool windows_stat(F_CHAR *path)
-{
- BY_HANDLE_FILE_INFORMATION bhfi;
- HANDLE h = CreateFileW(path,
- GENERIC_READ,
- FILE_SHARE_READ,
- NULL,
- OPEN_EXISTING,
- FILE_FLAG_BACKUP_SEMANTICS,
- NULL);
-
- if(h == INVALID_HANDLE_VALUE)
- {
- // FindFirstFile is the only call that can stat c:\pagefile.sys
- WIN32_FIND_DATA st;
- HANDLE h;
-
- if(INVALID_HANDLE_VALUE == (h = FindFirstFile(path, &st)))
- return false;
- FindClose(h);
- return true;
- }
- bool ret;
- ret = GetFileInformationByHandle(h, &bhfi);
- CloseHandle(h);
- return ret;
-}
-
-void windows_image_path(F_CHAR *full_path, F_CHAR *temp_path, unsigned int length)
-{
- snwprintf(temp_path, length-1, L"%s.image", full_path);
- temp_path[sizeof(temp_path) - 1] = 0;
-}
-
-/* You must free() this yourself. */
-const F_CHAR *default_image_path(void)
-{
- F_CHAR full_path[MAX_UNICODE_PATH];
- F_CHAR *ptr;
- F_CHAR temp_path[MAX_UNICODE_PATH];
-
- if(!GetModuleFileName(NULL, full_path, MAX_UNICODE_PATH))
- fatal_error("GetModuleFileName() failed", 0);
-
- 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;
-
- return safe_strdup(temp_path);
-}
-
-/* You must free() this yourself. */
-const F_CHAR *vm_executable_path(void)
-{
- F_CHAR full_path[MAX_UNICODE_PATH];
- if(!GetModuleFileName(NULL, full_path, MAX_UNICODE_PATH))
- fatal_error("GetModuleFileName() failed", 0);
- return safe_strdup(full_path);
-}
-
-
-void primitive_existsp(void)
-{
-
- F_CHAR *path = unbox_u16_string();
- box_boolean(windows_stat(path));
-}
-
-F_SEGMENT *alloc_segment(CELL size)
-{
- char *mem;
- DWORD ignore;
-
- if((mem = (char *)VirtualAlloc(NULL, getpagesize() * 2 + size,
- MEM_COMMIT, PAGE_EXECUTE_READWRITE)) == 0)
- out_of_memory();
-
- if (!VirtualProtect(mem, getpagesize(), PAGE_NOACCESS, &ignore))
- fatal_error("Cannot allocate low guard page", (CELL)mem);
-
- if (!VirtualProtect(mem + size + getpagesize(),
- getpagesize(), PAGE_NOACCESS, &ignore))
- fatal_error("Cannot allocate high guard page", (CELL)mem);
-
- F_SEGMENT *block = safe_malloc(sizeof(F_SEGMENT));
-
- block->start = (CELL)mem + getpagesize();
- block->size = size;
- block->end = block->start + size;
-
- return block;
-}
-
-void dealloc_segment(F_SEGMENT *block)
-{
- SYSTEM_INFO si;
- GetSystemInfo(&si);
- if(!VirtualFree((void*)(block->start - si.dwPageSize), 0, MEM_RELEASE))
- fatal_error("dealloc_segment failed",0);
- free(block);
-}
-
-long getpagesize(void)
-{
- static long g_pagesize = 0;
- if (! g_pagesize)
- {
- SYSTEM_INFO system_info;
- GetSystemInfo (&system_info);
- g_pagesize = system_info.dwPageSize;
- }
- return g_pagesize;
-}
-
-void sleep_micros(u64 usec)
-{
- Sleep((DWORD)(usec / 1000));
-}
--- /dev/null
+#include "master.hpp"
+
+namespace factor
+{
+
+HMODULE hFactorDll;
+
+void init_ffi(void)
+{
+ hFactorDll = GetModuleHandle(FACTOR_DLL);
+ if(!hFactorDll)
+ fatal_error("GetModuleHandle(\"" FACTOR_DLL_NAME "\") failed", 0);
+}
+
+void ffi_dlopen(dll *dll)
+{
+ dll->dll = LoadLibraryEx(alien_offset(dll->path), NULL, 0);
+}
+
+void *ffi_dlsym(dll *dll, symbol_char *symbol)
+{
+ return GetProcAddress(dll ? (HMODULE)dll->dll : hFactorDll, symbol);
+}
+
+void ffi_dlclose(dll *dll)
+{
+ FreeLibrary((HMODULE)dll->dll);
+ dll->dll = NULL;
+}
+
+bool windows_stat(vm_char *path)
+{
+ BY_HANDLE_FILE_INFORMATION bhfi;
+ HANDLE h = CreateFileW(path,
+ GENERIC_READ,
+ FILE_SHARE_READ,
+ NULL,
+ OPEN_EXISTING,
+ FILE_FLAG_BACKUP_SEMANTICS,
+ NULL);
+
+ if(h == INVALID_HANDLE_VALUE)
+ {
+ // FindFirstFile is the only call that can stat c:\pagefile.sys
+ WIN32_FIND_DATA st;
+ HANDLE h;
+
+ if(INVALID_HANDLE_VALUE == (h = FindFirstFile(path, &st)))
+ return false;
+ FindClose(h);
+ return true;
+ }
+ bool ret;
+ ret = GetFileInformationByHandle(h, &bhfi);
+ CloseHandle(h);
+ return ret;
+}
+
+void 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;
+}
+
+/* You must free() this yourself. */
+const vm_char *default_image_path(void)
+{
+ vm_char full_path[MAX_UNICODE_PATH];
+ vm_char *ptr;
+ vm_char temp_path[MAX_UNICODE_PATH];
+
+ if(!GetModuleFileName(NULL, full_path, MAX_UNICODE_PATH))
+ fatal_error("GetModuleFileName() failed", 0);
+
+ 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;
+
+ return safe_strdup(temp_path);
+}
+
+/* You must free() this yourself. */
+const vm_char *vm_executable_path(void)
+{
+ vm_char full_path[MAX_UNICODE_PATH];
+ if(!GetModuleFileName(NULL, full_path, MAX_UNICODE_PATH))
+ fatal_error("GetModuleFileName() failed", 0);
+ return safe_strdup(full_path);
+}
+
+
+PRIMITIVE(existsp)
+{
+ vm_char *path = (vm_char *)(untag_check<byte_array>(dpop()) + 1);
+ box_boolean(windows_stat(path));
+}
+
+segment *alloc_segment(cell size)
+{
+ char *mem;
+ DWORD ignore;
+
+ if((mem = (char *)VirtualAlloc(NULL, getpagesize() * 2 + size,
+ MEM_COMMIT, PAGE_EXECUTE_READWRITE)) == 0)
+ out_of_memory();
+
+ if (!VirtualProtect(mem, getpagesize(), PAGE_NOACCESS, &ignore))
+ fatal_error("Cannot allocate low guard page", (cell)mem);
+
+ if (!VirtualProtect(mem + size + getpagesize(),
+ getpagesize(), PAGE_NOACCESS, &ignore))
+ fatal_error("Cannot allocate high guard page", (cell)mem);
+
+ segment *block = safe_malloc(sizeof(segment));
+
+ block->start = (cell)mem + getpagesize();
+ block->size = size;
+ block->end = block->start + size;
+
+ return block;
+}
+
+void dealloc_segment(segment *block)
+{
+ SYSTEM_INFO si;
+ GetSystemInfo(&si);
+ if(!VirtualFree((void*)(block->start - si.dwPageSize), 0, MEM_RELEASE))
+ fatal_error("dealloc_segment failed",0);
+ free(block);
+}
+
+long getpagesize(void)
+{
+ static long g_pagesize = 0;
+ if (! g_pagesize)
+ {
+ SYSTEM_INFO system_info;
+ GetSystemInfo (&system_info);
+ g_pagesize = system_info.dwPageSize;
+ }
+ return g_pagesize;
+}
+
+void sleep_micros(u64 usec)
+{
+ Sleep((DWORD)(usec / 1000));
+}
+
+}
+++ /dev/null
-#include <ctype.h>
-
-#ifndef wcslen
- /* for cygwin */
- #include <wchar.h>
-#endif
-
-typedef wchar_t F_CHAR;
-
-#define from_native_string from_u16_string
-#define unbox_native_string unbox_u16_string
-#define string_to_native_alien(string) string_to_u16_alien(string,true)
-
-#define STRING_LITERAL(string) L##string
-
-#define MAX_UNICODE_PATH 32768
-#define DLLEXPORT __declspec(dllexport)
-#define SSCANF swscanf
-#define STRCMP wcscmp
-#define STRNCMP wcsncmp
-#define STRDUP _wcsdup
-#define MIN(a,b) ((a)>(b)?(b):(a))
-#define FSEEK fseek
-
-#ifdef WIN64
- #define CELL_FORMAT "%Iu"
- #define CELL_HEX_FORMAT "%Ix"
- #define CELL_HEX_PAD_FORMAT "%016Ix"
- #define FIXNUM_FORMAT "%Id"
-#else
- #define CELL_FORMAT "%lu"
- #define CELL_HEX_FORMAT "%lx"
- #define CELL_HEX_PAD_FORMAT "%08lx"
- #define FIXNUM_FORMAT "%ld"
-#endif
-
-#define OPEN_READ(path) _wfopen(path,L"rb")
-#define OPEN_WRITE(path) _wfopen(path,L"wb")
-
-#define print_native_string(string) wprintf(L"%s",string)
-
-/* Difference between Jan 1 00:00:00 1601 and Jan 1 00:00:00 1970 */
-#define EPOCH_OFFSET 0x019db1ded53e8000LL
-
-void init_ffi(void);
-void ffi_dlopen(F_DLL *dll);
-void *ffi_dlsym(F_DLL *dll, F_SYMBOL *symbol);
-void ffi_dlclose(F_DLL *dll);
-
-void sleep_micros(u64 msec);
-
-INLINE void init_signals(void) {}
-INLINE void early_init(void) {}
-const F_CHAR *vm_executable_path(void);
-const F_CHAR *default_image_path(void);
-long getpagesize (void);
-
-s64 current_micros(void);
-
--- /dev/null
+#include <ctype.h>
+
+#ifndef wcslen
+ /* for cygwin */
+ #include <wchar.h>
+#endif
+
+namespace factor
+{
+
+typedef wchar_t vm_char;
+
+#define STRING_LITERAL(string) L##string
+
+#define MAX_UNICODE_PATH 32768
+#define VM_C_API extern "C" __declspec(dllexport)
+#define SSCANF swscanf
+#define STRCMP wcscmp
+#define STRNCMP wcsncmp
+#define STRDUP _wcsdup
+#define MIN(a,b) ((a)>(b)?(b):(a))
+#define FSEEK fseek
+
+#ifdef WIN64
+ #define cell_FORMAT "%Iu"
+ #define cell_HEX_FORMAT "%Ix"
+ #define cell_HEX_PAD_FORMAT "%016Ix"
+ #define FIXNUM_FORMAT "%Id"
+#else
+ #define cell_FORMAT "%lu"
+ #define cell_HEX_FORMAT "%lx"
+ #define cell_HEX_PAD_FORMAT "%08lx"
+ #define FIXNUM_FORMAT "%ld"
+#endif
+
+#define OPEN_READ(path) _wfopen(path,L"rb")
+#define OPEN_WRITE(path) _wfopen(path,L"wb")
+
+#define print_native_string(string) wprintf(L"%s",string)
+
+/* Difference between Jan 1 00:00:00 1601 and Jan 1 00:00:00 1970 */
+#define EPOCH_OFFSET 0x019db1ded53e8000LL
+
+void init_ffi(void);
+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(void) {}
+inline static void early_init(void) {}
+const vm_char *vm_executable_path(void);
+const vm_char *default_image_path(void);
+long getpagesize (void);
+
+s64 current_micros(void);
+
+}
+++ /dev/null
-#if defined(__arm__)
- #define FACTOR_ARM
-#elif defined(__amd64__) || defined(__x86_64__)
- #define FACTOR_AMD64
-#elif defined(i386) || defined(__i386) || defined(__i386__) || defined(WIN32)
- #define FACTOR_X86
-#elif defined(__POWERPC__) || defined(__ppc__) || defined(_ARCH_PPC)
- #define FACTOR_PPC
-#else
- #error "Unsupported architecture"
-#endif
-
-#if defined(WINDOWS)
- #if defined(WINCE)
- #include "os-windows-ce.h"
- #else
- #include "os-windows-nt.h"
- #endif
-
- #include "os-windows.h"
- #if defined(FACTOR_AMD64)
- #include "os-windows-nt.64.h"
- #elif defined(FACTOR_X86)
- #include "os-windows-nt.32.h"
- #endif
-#else
- #include "os-unix.h"
-
- #ifdef __APPLE__
- #include "os-macosx.h"
- #include "mach_signal.h"
-
- #ifdef FACTOR_X86
- #include "os-macosx-x86.32.h"
- #elif defined(FACTOR_PPC)
- #include "os-macosx-ppc.h"
- #elif defined(FACTOR_AMD64)
- #include "os-macosx-x86.64.h"
- #else
- #error "Unsupported Mac OS X flavor"
- #endif
- #else
- #include "os-genunix.h"
-
- #ifdef __FreeBSD__
- #define FACTOR_OS_STRING "freebsd"
- #include "os-freebsd.h"
-
- #if defined(FACTOR_X86)
- #include "os-freebsd-x86.32.h"
- #elif defined(FACTOR_AMD64)
- #include "os-freebsd-x86.64.h"
- #else
- #error "Unsupported FreeBSD flavor"
- #endif
- #elif defined(__OpenBSD__)
- #define FACTOR_OS_STRING "openbsd"
-
- #if defined(FACTOR_X86)
- #include "os-openbsd-x86.32.h"
- #elif defined(FACTOR_AMD64)
- #include "os-openbsd-x86.64.h"
- #else
- #error "Unsupported OpenBSD flavor"
- #endif
- #elif defined(__NetBSD__)
- #define FACTOR_OS_STRING "netbsd"
-
- #if defined(FACTOR_X86)
- #include "os-netbsd-x86.32.h"
- #elif defined(FACTOR_AMD64)
- #include "os-netbsd-x86.64.h"
- #else
- #error "Unsupported NetBSD flavor"
- #endif
-
- #include "os-netbsd.h"
- #elif defined(linux)
- #define FACTOR_OS_STRING "linux"
- #include "os-linux.h"
-
- #if defined(FACTOR_X86)
- #include "os-linux-x86.32.h"
- #elif defined(FACTOR_PPC)
- #include "os-linux-ppc.h"
- #elif defined(FACTOR_ARM)
- #include "os-linux-arm.h"
- #elif defined(FACTOR_AMD64)
- #include "os-linux-x86.64.h"
- #else
- #error "Unsupported Linux flavor"
- #endif
- #elif defined(__SVR4) && defined(sun)
- #define FACTOR_OS_STRING "solaris"
-
- #if defined(FACTOR_X86)
- #include "os-solaris-x86.32.h"
- #elif defined(FACTOR_AMD64)
- #include "os-solaris-x86.64.h"
- #else
- #error "Unsupported Solaris flavor"
- #endif
-
- #else
- #error "Unsupported OS"
- #endif
- #endif
-#endif
-
-#if defined(FACTOR_X86)
- #include "cpu-x86.32.h"
- #include "cpu-x86.h"
-#elif defined(FACTOR_AMD64)
- #include "cpu-x86.64.h"
- #include "cpu-x86.h"
-#elif defined(FACTOR_PPC)
- #include "cpu-ppc.h"
-#elif defined(FACTOR_ARM)
- #include "cpu-arm.h"
-#else
- #error "Unsupported CPU"
-#endif
--- /dev/null
+#if defined(__arm__)
+ #define FACTOR_ARM
+#elif defined(__amd64__) || defined(__x86_64__)
+ #define FACTOR_AMD64
+#elif defined(i386) || defined(__i386) || defined(__i386__) || defined(WIN32)
+ #define FACTOR_X86
+#elif defined(__POWERPC__) || defined(__ppc__) || defined(_ARCH_PPC)
+ #define FACTOR_PPC
+#else
+ #error "Unsupported architecture"
+#endif
+
+#if defined(WINDOWS)
+ #if defined(WINCE)
+ #include "os-windows-ce.hpp"
+ #else
+ #include "os-windows-nt.hpp"
+ #endif
+
+ #include "os-windows.hpp"
+ #if defined(FACTOR_AMD64)
+ #include "os-windows-nt.64.hpp"
+ #elif defined(FACTOR_X86)
+ #include "os-windows-nt.32.hpp"
+ #endif
+#else
+ #include "os-unix.hpp"
+
+ #ifdef __APPLE__
+ #include "os-macosx.hpp"
+ #include "mach_signal.hpp"
+
+ #ifdef FACTOR_X86
+ #include "os-macosx-x86.32.hpp"
+ #elif defined(FACTOR_PPC)
+ #include "os-macosx-ppc.hpp"
+ #elif defined(FACTOR_AMD64)
+ #include "os-macosx-x86.64.hpp"
+ #else
+ #error "Unsupported Mac OS X flavor"
+ #endif
+ #else
+ #include "os-genunix.hpp"
+
+ #ifdef __FreeBSD__
+ #define FACTOR_OS_STRING "freebsd"
+ #include "os-freebsd.hpp"
+
+ #if defined(FACTOR_X86)
+ #include "os-freebsd-x86.32.hpp"
+ #elif defined(FACTOR_AMD64)
+ #include "os-freebsd-x86.64.hpp"
+ #else
+ #error "Unsupported FreeBSD flavor"
+ #endif
+ #elif defined(__OpenBSD__)
+ #define FACTOR_OS_STRING "openbsd"
+
+ #if defined(FACTOR_X86)
+ #include "os-openbsd-x86.32.hpp"
+ #elif defined(FACTOR_AMD64)
+ #include "os-openbsd-x86.64.hpp"
+ #else
+ #error "Unsupported OpenBSD flavor"
+ #endif
+ #elif defined(__NetBSD__)
+ #define FACTOR_OS_STRING "netbsd"
+
+ #if defined(FACTOR_X86)
+ #include "os-netbsd-x86.32.hpp"
+ #elif defined(FACTOR_AMD64)
+ #include "os-netbsd-x86.64.hpp"
+ #else
+ #error "Unsupported NetBSD flavor"
+ #endif
+
+ #include "os-netbsd.hpp"
+ #elif defined(linux)
+ #define FACTOR_OS_STRING "linux"
+ #include "os-linux.hpp"
+
+ #if defined(FACTOR_X86)
+ #include "os-linux-x86.32.hpp"
+ #elif defined(FACTOR_PPC)
+ #include "os-linux-ppc.hpp"
+ #elif defined(FACTOR_ARM)
+ #include "os-linux-arm.hpp"
+ #elif defined(FACTOR_AMD64)
+ #include "os-linux-x86.64.hpp"
+ #else
+ #error "Unsupported Linux flavor"
+ #endif
+ #elif defined(__SVR4) && defined(sun)
+ #define FACTOR_OS_STRING "solaris"
+
+ #if defined(FACTOR_X86)
+ #include "os-solaris-x86.32.hpp"
+ #elif defined(FACTOR_AMD64)
+ #include "os-solaris-x86.64.hpp"
+ #else
+ #error "Unsupported Solaris flavor"
+ #endif
+
+ #else
+ #error "Unsupported OS"
+ #endif
+ #endif
+#endif
+
+#if defined(FACTOR_X86)
+ #include "cpu-x86.32.hpp"
+ #include "cpu-x86.hpp"
+#elif defined(FACTOR_AMD64)
+ #include "cpu-x86.64.hpp"
+ #include "cpu-x86.hpp"
+#elif defined(FACTOR_PPC)
+ #include "cpu-ppc.hpp"
+#elif defined(FACTOR_ARM)
+ #include "cpu-arm.hpp"
+#else
+ #error "Unsupported CPU"
+#endif
+++ /dev/null
-#include "master.h"
-
-void *primitives[] = {
- primitive_bignum_to_fixnum,
- primitive_float_to_fixnum,
- primitive_fixnum_to_bignum,
- primitive_float_to_bignum,
- primitive_fixnum_to_float,
- primitive_bignum_to_float,
- primitive_str_to_float,
- primitive_float_to_str,
- primitive_float_bits,
- primitive_double_bits,
- primitive_bits_float,
- primitive_bits_double,
- primitive_fixnum_add,
- primitive_fixnum_subtract,
- primitive_fixnum_multiply,
- primitive_fixnum_divint,
- primitive_fixnum_divmod,
- primitive_fixnum_shift,
- primitive_bignum_eq,
- primitive_bignum_add,
- primitive_bignum_subtract,
- primitive_bignum_multiply,
- primitive_bignum_divint,
- primitive_bignum_mod,
- primitive_bignum_divmod,
- primitive_bignum_and,
- primitive_bignum_or,
- primitive_bignum_xor,
- primitive_bignum_not,
- primitive_bignum_shift,
- primitive_bignum_less,
- primitive_bignum_lesseq,
- primitive_bignum_greater,
- primitive_bignum_greatereq,
- primitive_bignum_bitp,
- primitive_bignum_log2,
- primitive_byte_array_to_bignum,
- primitive_float_eq,
- primitive_float_add,
- primitive_float_subtract,
- primitive_float_multiply,
- primitive_float_divfloat,
- primitive_float_mod,
- primitive_float_less,
- primitive_float_lesseq,
- primitive_float_greater,
- primitive_float_greatereq,
- primitive_word,
- primitive_word_xt,
- primitive_getenv,
- primitive_setenv,
- primitive_existsp,
- primitive_gc,
- primitive_gc_stats,
- primitive_save_image,
- primitive_save_image_and_exit,
- primitive_datastack,
- primitive_retainstack,
- primitive_callstack,
- primitive_set_datastack,
- primitive_set_retainstack,
- primitive_set_callstack,
- primitive_exit,
- primitive_data_room,
- primitive_code_room,
- primitive_micros,
- primitive_modify_code_heap,
- primitive_dlopen,
- primitive_dlsym,
- primitive_dlclose,
- primitive_byte_array,
- primitive_uninitialized_byte_array,
- primitive_displaced_alien,
- primitive_alien_signed_cell,
- primitive_set_alien_signed_cell,
- primitive_alien_unsigned_cell,
- primitive_set_alien_unsigned_cell,
- primitive_alien_signed_8,
- primitive_set_alien_signed_8,
- primitive_alien_unsigned_8,
- primitive_set_alien_unsigned_8,
- primitive_alien_signed_4,
- primitive_set_alien_signed_4,
- primitive_alien_unsigned_4,
- primitive_set_alien_unsigned_4,
- primitive_alien_signed_2,
- primitive_set_alien_signed_2,
- primitive_alien_unsigned_2,
- primitive_set_alien_unsigned_2,
- primitive_alien_signed_1,
- primitive_set_alien_signed_1,
- primitive_alien_unsigned_1,
- primitive_set_alien_unsigned_1,
- primitive_alien_float,
- primitive_set_alien_float,
- primitive_alien_double,
- primitive_set_alien_double,
- primitive_alien_cell,
- primitive_set_alien_cell,
- primitive_alien_address,
- primitive_set_slot,
- primitive_string_nth,
- primitive_set_string_nth_fast,
- primitive_set_string_nth_slow,
- primitive_resize_array,
- primitive_resize_string,
- primitive_array,
- primitive_begin_scan,
- primitive_next_object,
- primitive_end_scan,
- primitive_size,
- primitive_die,
- primitive_fopen,
- primitive_fgetc,
- primitive_fread,
- primitive_fputc,
- primitive_fwrite,
- primitive_fflush,
- primitive_fseek,
- primitive_fclose,
- primitive_wrapper,
- primitive_clone,
- primitive_string,
- primitive_array_to_quotation,
- primitive_quotation_xt,
- primitive_tuple,
- primitive_profiling,
- primitive_become,
- primitive_sleep,
- primitive_tuple_boa,
- primitive_callstack_to_array,
- primitive_innermost_stack_frame_quot,
- primitive_innermost_stack_frame_scan,
- primitive_set_innermost_stack_frame_quot,
- primitive_call_clear,
- primitive_resize_byte_array,
- primitive_dll_validp,
- primitive_unimplemented,
- primitive_clear_gc_stats,
- primitive_jit_compile,
- primitive_load_locals,
- primitive_check_datastack,
- primitive_inline_cache_miss,
- primitive_mega_cache_miss,
- primitive_lookup_method,
- primitive_reset_dispatch_stats,
- primitive_dispatch_stats,
- primitive_reset_inline_cache_stats,
- primitive_inline_cache_stats,
- primitive_optimized_p,
-};
--- /dev/null
+#include "master.hpp"
+
+namespace factor
+{
+
+void *primitives[] = {
+ (void *)primitive_bignum_to_fixnum,
+ (void *)primitive_float_to_fixnum,
+ (void *)primitive_fixnum_to_bignum,
+ (void *)primitive_float_to_bignum,
+ (void *)primitive_fixnum_to_float,
+ (void *)primitive_bignum_to_float,
+ (void *)primitive_str_to_float,
+ (void *)primitive_float_to_str,
+ (void *)primitive_float_bits,
+ (void *)primitive_double_bits,
+ (void *)primitive_bits_float,
+ (void *)primitive_bits_double,
+ (void *)primitive_fixnum_add,
+ (void *)primitive_fixnum_subtract,
+ (void *)primitive_fixnum_multiply,
+ (void *)primitive_fixnum_divint,
+ (void *)primitive_fixnum_divmod,
+ (void *)primitive_fixnum_shift,
+ (void *)primitive_bignum_eq,
+ (void *)primitive_bignum_add,
+ (void *)primitive_bignum_subtract,
+ (void *)primitive_bignum_multiply,
+ (void *)primitive_bignum_divint,
+ (void *)primitive_bignum_mod,
+ (void *)primitive_bignum_divmod,
+ (void *)primitive_bignum_and,
+ (void *)primitive_bignum_or,
+ (void *)primitive_bignum_xor,
+ (void *)primitive_bignum_not,
+ (void *)primitive_bignum_shift,
+ (void *)primitive_bignum_less,
+ (void *)primitive_bignum_lesseq,
+ (void *)primitive_bignum_greater,
+ (void *)primitive_bignum_greatereq,
+ (void *)primitive_bignum_bitp,
+ (void *)primitive_bignum_log2,
+ (void *)primitive_byte_array_to_bignum,
+ (void *)primitive_float_eq,
+ (void *)primitive_float_add,
+ (void *)primitive_float_subtract,
+ (void *)primitive_float_multiply,
+ (void *)primitive_float_divfloat,
+ (void *)primitive_float_mod,
+ (void *)primitive_float_less,
+ (void *)primitive_float_lesseq,
+ (void *)primitive_float_greater,
+ (void *)primitive_float_greatereq,
+ (void *)primitive_word,
+ (void *)primitive_word_xt,
+ (void *)primitive_getenv,
+ (void *)primitive_setenv,
+ (void *)primitive_existsp,
+ (void *)primitive_gc,
+ (void *)primitive_gc_stats,
+ (void *)primitive_save_image,
+ (void *)primitive_save_image_and_exit,
+ (void *)primitive_datastack,
+ (void *)primitive_retainstack,
+ (void *)primitive_callstack,
+ (void *)primitive_set_datastack,
+ (void *)primitive_set_retainstack,
+ (void *)primitive_set_callstack,
+ (void *)primitive_exit,
+ (void *)primitive_data_room,
+ (void *)primitive_code_room,
+ (void *)primitive_micros,
+ (void *)primitive_modify_code_heap,
+ (void *)primitive_dlopen,
+ (void *)primitive_dlsym,
+ (void *)primitive_dlclose,
+ (void *)primitive_byte_array,
+ (void *)primitive_uninitialized_byte_array,
+ (void *)primitive_displaced_alien,
+ (void *)primitive_alien_signed_cell,
+ (void *)primitive_set_alien_signed_cell,
+ (void *)primitive_alien_unsigned_cell,
+ (void *)primitive_set_alien_unsigned_cell,
+ (void *)primitive_alien_signed_8,
+ (void *)primitive_set_alien_signed_8,
+ (void *)primitive_alien_unsigned_8,
+ (void *)primitive_set_alien_unsigned_8,
+ (void *)primitive_alien_signed_4,
+ (void *)primitive_set_alien_signed_4,
+ (void *)primitive_alien_unsigned_4,
+ (void *)primitive_set_alien_unsigned_4,
+ (void *)primitive_alien_signed_2,
+ (void *)primitive_set_alien_signed_2,
+ (void *)primitive_alien_unsigned_2,
+ (void *)primitive_set_alien_unsigned_2,
+ (void *)primitive_alien_signed_1,
+ (void *)primitive_set_alien_signed_1,
+ (void *)primitive_alien_unsigned_1,
+ (void *)primitive_set_alien_unsigned_1,
+ (void *)primitive_alien_float,
+ (void *)primitive_set_alien_float,
+ (void *)primitive_alien_double,
+ (void *)primitive_set_alien_double,
+ (void *)primitive_alien_cell,
+ (void *)primitive_set_alien_cell,
+ (void *)primitive_alien_address,
+ (void *)primitive_set_slot,
+ (void *)primitive_string_nth,
+ (void *)primitive_set_string_nth_fast,
+ (void *)primitive_set_string_nth_slow,
+ (void *)primitive_resize_array,
+ (void *)primitive_resize_string,
+ (void *)primitive_array,
+ (void *)primitive_begin_scan,
+ (void *)primitive_next_object,
+ (void *)primitive_end_scan,
+ (void *)primitive_size,
+ (void *)primitive_die,
+ (void *)primitive_fopen,
+ (void *)primitive_fgetc,
+ (void *)primitive_fread,
+ (void *)primitive_fputc,
+ (void *)primitive_fwrite,
+ (void *)primitive_fflush,
+ (void *)primitive_fseek,
+ (void *)primitive_fclose,
+ (void *)primitive_wrapper,
+ (void *)primitive_clone,
+ (void *)primitive_string,
+ (void *)primitive_array_to_quotation,
+ (void *)primitive_quotation_xt,
+ (void *)primitive_tuple,
+ (void *)primitive_profiling,
+ (void *)primitive_become,
+ (void *)primitive_sleep,
+ (void *)primitive_tuple_boa,
+ (void *)primitive_callstack_to_array,
+ (void *)primitive_innermost_stack_frame_quot,
+ (void *)primitive_innermost_stack_frame_scan,
+ (void *)primitive_set_innermost_stack_frame_quot,
+ (void *)primitive_call_clear,
+ (void *)primitive_resize_byte_array,
+ (void *)primitive_dll_validp,
+ (void *)primitive_unimplemented,
+ (void *)primitive_clear_gc_stats,
+ (void *)primitive_jit_compile,
+ (void *)primitive_load_locals,
+ (void *)primitive_check_datastack,
+ (void *)primitive_inline_cache_miss,
+ (void *)primitive_mega_cache_miss,
+ (void *)primitive_lookup_method,
+ (void *)primitive_reset_dispatch_stats,
+ (void *)primitive_dispatch_stats,
+ (void *)primitive_reset_inline_cache_stats,
+ (void *)primitive_inline_cache_stats,
+ (void *)primitive_optimized_p,
+};
+
+}
+++ /dev/null
-extern void *primitives[];
--- /dev/null
+namespace factor
+{
+
+extern void *primitives[];
+
+#define PRIMITIVE(name) extern "C" void primitive_##name()
+
+}
+++ /dev/null
-#include "master.h"
-
-/* Allocates memory */
-F_CODE_BLOCK *compile_profiling_stub(CELL word)
-{
- REGISTER_ROOT(word);
- F_JIT jit;
- jit_init(&jit,WORD_TYPE,word);
- jit_emit_with(&jit,userenv[JIT_PROFILING],word);
- F_CODE_BLOCK *block = jit_make_code_block(&jit);
- jit_dispose(&jit);
- UNREGISTER_ROOT(word);
- return block;
-}
-
-/* Allocates memory */
-static void set_profiling(bool profiling)
-{
- if(profiling == profiling_p)
- return;
-
- profiling_p = profiling;
-
- /* Push everything to tenured space so that we can heap scan
- and allocate profiling blocks if necessary */
- gc();
-
- CELL words = find_all_words();
-
- REGISTER_ROOT(words);
-
- CELL i;
- CELL length = array_capacity(untag_object(words));
- for(i = 0; i < length; i++)
- {
- F_WORD *word = untag_word(array_nth(untag_array(words),i));
- if(profiling)
- word->counter = tag_fixnum(0);
- update_word_xt(word);
- }
-
- UNREGISTER_ROOT(words);
-
- /* Update XTs in code heap */
- iterate_code_heap(relocate_code_block);
-}
-
-void primitive_profiling(void)
-{
- set_profiling(to_boolean(dpop()));
-}
--- /dev/null
+#include "master.hpp"
+
+namespace factor
+{
+
+bool profiling_p;
+
+void init_profiler(void)
+{
+ profiling_p = false;
+}
+
+/* Allocates memory */
+code_block *compile_profiling_stub(cell word_)
+{
+ gc_root<word> word(word_);
+
+ jit jit(WORD_TYPE,word.value());
+ jit.emit_with(userenv[JIT_PROFILING],word.value());
+
+ return jit.to_code_block();
+}
+
+/* Allocates memory */
+static void set_profiling(bool profiling)
+{
+ if(profiling == profiling_p)
+ return;
+
+ profiling_p = profiling;
+
+ /* Push everything to tenured space so that we can heap scan
+ and allocate profiling blocks if necessary */
+ gc();
+
+ gc_root<array> words(find_all_words());
+
+ cell i;
+ cell length = array_capacity(words.untagged());
+ for(i = 0; i < length; i++)
+ {
+ tagged<word> word(array_nth(words.untagged(),i));
+ if(profiling)
+ word->counter = tag_fixnum(0);
+ update_word_xt(word.value());
+ }
+
+ /* Update XTs in code heap */
+ iterate_code_heap(relocate_code_block);
+}
+
+PRIMITIVE(profiling)
+{
+ set_profiling(to_boolean(dpop()));
+}
+
+}
+++ /dev/null
-bool profiling_p;
-F_CODE_BLOCK *compile_profiling_stub(CELL word);
-void primitive_profiling(void);
--- /dev/null
+namespace factor
+{
+
+extern bool profiling_p;
+void init_profiler(void);
+code_block *compile_profiling_stub(cell word);
+PRIMITIVE(profiling);
+
+}
+++ /dev/null
-#include "master.h"
-
-/* Simple non-optimizing compiler.
-
-This is one of the two compilers implementing Factor; the second one is written
-in Factor and performs advanced optimizations. See core/compiler/compiler.factor.
-
-The non-optimizing compiler compiles a quotation at a time by concatenating
-machine code chunks; prolog, epilog, call word, jump to word, etc. These machine
-code chunks are generated from Factor code in core/cpu/.../bootstrap.factor.
-
-Calls to words and constant quotations (referenced by conditionals and dips)
-are direct jumps to machine code blocks. Literals are also referenced directly
-without going through the literal table.
-
-It actually does do a little bit of very simple optimization:
-
-1) Tail call optimization.
-
-2) If a quotation is determined to not call any other words (except for a few
-special words which are open-coded, see below), then no prolog/epilog is
-generated.
-
-3) When in tail position and immediately preceded by literal arguments, the
-'if' is generated inline, instead of as a call to the 'if' word.
-
-4) When preceded by a quotation, calls to 'dip', '2dip' and '3dip' are
-open-coded as retain stack manipulation surrounding a subroutine call.
-
-5) Sub-primitives are primitive words which are implemented in assembly and not
-in the VM. They are open-coded and no subroutine call is generated. This
-includes stack shufflers, some fixnum arithmetic words, and words such as tag,
-slot and eq?. A primitive call is relatively expensive (two subroutine calls)
-so this results in a big speedup for relatively little effort. */
-
-static bool jit_primitive_call_p(F_ARRAY *array, CELL i)
-{
- return (i + 2) == array_capacity(array)
- && type_of(array_nth(array,i)) == FIXNUM_TYPE
- && array_nth(array,i + 1) == userenv[JIT_PRIMITIVE_WORD];
-}
-
-static bool jit_fast_if_p(F_ARRAY *array, CELL i)
-{
- return (i + 3) == array_capacity(array)
- && type_of(array_nth(array,i)) == QUOTATION_TYPE
- && type_of(array_nth(array,i + 1)) == QUOTATION_TYPE
- && array_nth(array,i + 2) == userenv[JIT_IF_WORD];
-}
-
-static bool jit_fast_dip_p(F_ARRAY *array, CELL i)
-{
- return (i + 2) <= array_capacity(array)
- && type_of(array_nth(array,i)) == QUOTATION_TYPE
- && array_nth(array,i + 1) == userenv[JIT_DIP_WORD];
-}
-
-static bool jit_fast_2dip_p(F_ARRAY *array, CELL i)
-{
- return (i + 2) <= array_capacity(array)
- && type_of(array_nth(array,i)) == QUOTATION_TYPE
- && array_nth(array,i + 1) == userenv[JIT_2DIP_WORD];
-}
-
-static bool jit_fast_3dip_p(F_ARRAY *array, CELL i)
-{
- return (i + 2) <= array_capacity(array)
- && type_of(array_nth(array,i)) == QUOTATION_TYPE
- && array_nth(array,i + 1) == userenv[JIT_3DIP_WORD];
-}
-
-static bool jit_mega_lookup_p(F_ARRAY *array, CELL i)
-{
- return (i + 3) < array_capacity(array)
- && type_of(array_nth(array,i)) == ARRAY_TYPE
- && type_of(array_nth(array,i + 1)) == FIXNUM_TYPE
- && type_of(array_nth(array,i + 2)) == ARRAY_TYPE
- && array_nth(array,i + 3) == userenv[MEGA_LOOKUP_WORD];
-}
-
-static bool jit_stack_frame_p(F_ARRAY *array)
-{
- F_FIXNUM length = array_capacity(array);
- F_FIXNUM i;
-
- for(i = 0; i < length - 1; i++)
- {
- CELL obj = array_nth(array,i);
- if(type_of(obj) == WORD_TYPE)
- {
- F_WORD *word = untag_object(obj);
- if(word->subprimitive == F)
- return true;
- }
- else if(type_of(obj) == QUOTATION_TYPE)
- {
- if(jit_fast_dip_p(array,i)
- || jit_fast_2dip_p(array,i)
- || jit_fast_3dip_p(array,i))
- return true;
- }
- }
-
- return false;
-}
-
-#define TAIL_CALL { \
- if(stack_frame) jit_emit(jit,userenv[JIT_EPILOG]); \
- tail_call = true; \
- }
-
-/* Allocates memory */
-static void jit_iterate_quotation(F_JIT *jit, CELL array, CELL compiling, CELL relocate)
-{
- REGISTER_ROOT(array);
-
- bool stack_frame = jit_stack_frame_p(untag_object(array));
-
- jit_set_position(jit,0);
-
- if(stack_frame)
- jit_emit(jit,userenv[JIT_PROLOG]);
-
- CELL i;
- CELL length = array_capacity(untag_object(array));
- bool tail_call = false;
-
- for(i = 0; i < length; i++)
- {
- jit_set_position(jit,i);
-
- CELL obj = array_nth(untag_object(array),i);
- REGISTER_ROOT(obj);
-
- F_WORD *word;
- F_WRAPPER *wrapper;
-
- switch(type_of(obj))
- {
- case WORD_TYPE:
- word = untag_object(obj);
-
- /* Intrinsics */
- if(word->subprimitive != F)
- jit_emit_subprimitive(jit,word);
- /* The (execute) primitive is special-cased */
- else if(obj == userenv[JIT_EXECUTE_WORD])
- {
- if(i == length - 1)
- {
- TAIL_CALL;
- jit_emit(jit,userenv[JIT_EXECUTE_JUMP]);
- }
- else
- jit_emit(jit,userenv[JIT_EXECUTE_CALL]);
- }
- /* Everything else */
- else
- {
- if(i == length - 1)
- {
- TAIL_CALL;
- jit_word_jump(jit,obj);
- }
- else
- jit_word_call(jit,obj);
- }
- break;
- case WRAPPER_TYPE:
- wrapper = untag_object(obj);
- jit_push(jit,wrapper->object);
- break;
- case FIXNUM_TYPE:
- /* Primitive calls */
- if(jit_primitive_call_p(untag_object(array),i))
- {
- jit_emit(jit,userenv[JIT_SAVE_STACK]);
- jit_emit_with(jit,userenv[JIT_PRIMITIVE],obj);
-
- i++;
-
- tail_call = true;
- break;
- }
- case QUOTATION_TYPE:
- /* 'if' preceeded by two literal quotations (this is why if and ? are
- mutually recursive in the library, but both still work) */
- if(jit_fast_if_p(untag_object(array),i))
- {
- TAIL_CALL;
-
- if(compiling)
- {
- jit_compile(array_nth(untag_object(array),i),relocate);
- jit_compile(array_nth(untag_object(array),i + 1),relocate);
- }
-
- jit_emit_with(jit,userenv[JIT_IF_1],array_nth(untag_object(array),i));
- jit_emit_with(jit,userenv[JIT_IF_2],array_nth(untag_object(array),i + 1));
-
- i += 2;
-
- break;
- }
- /* dip */
- else if(jit_fast_dip_p(untag_object(array),i))
- {
- if(compiling)
- jit_compile(obj,relocate);
- jit_emit_with(jit,userenv[JIT_DIP],obj);
- i++;
- break;
- }
- /* 2dip */
- else if(jit_fast_2dip_p(untag_object(array),i))
- {
- if(compiling)
- jit_compile(obj,relocate);
- jit_emit_with(jit,userenv[JIT_2DIP],obj);
- i++;
- break;
- }
- /* 3dip */
- else if(jit_fast_3dip_p(untag_object(array),i))
- {
- if(compiling)
- jit_compile(obj,relocate);
- jit_emit_with(jit,userenv[JIT_3DIP],obj);
- i++;
- break;
- }
- case ARRAY_TYPE:
- /* Method dispatch */
- if(jit_mega_lookup_p(untag_object(array),i))
- {
- jit_emit_mega_cache_lookup(jit,
- array_nth(untag_object(array),i),
- untag_fixnum_fast(array_nth(untag_object(array),i + 1)),
- array_nth(untag_object(array),i + 2));
- i += 3;
- tail_call = true;
- break;
- }
- default:
- jit_push(jit,obj);
- break;
- }
-
- UNREGISTER_ROOT(obj);
- }
-
- if(!tail_call)
- {
- jit_set_position(jit,length);
-
- if(stack_frame)
- jit_emit(jit,userenv[JIT_EPILOG]);
- jit_emit(jit,userenv[JIT_RETURN]);
- }
-
- UNREGISTER_ROOT(array);
-}
-
-void set_quot_xt(F_QUOTATION *quot, F_CODE_BLOCK *code)
-{
- if(code->block.type != QUOTATION_TYPE)
- critical_error("Bad param to set_quot_xt",(CELL)code);
-
- quot->code = code;
- quot->xt = (XT)(code + 1);
- quot->compiledp = T;
-}
-
-/* Allocates memory */
-void jit_compile(CELL quot, bool relocate)
-{
- if(untag_quotation(quot)->compiledp != F)
- return;
-
- CELL array = untag_quotation(quot)->array;
-
- REGISTER_ROOT(quot);
- REGISTER_ROOT(array);
-
- F_JIT jit;
- jit_init(&jit,QUOTATION_TYPE,quot);
-
- jit_iterate_quotation(&jit,array,true,relocate);
-
- F_CODE_BLOCK *compiled = jit_make_code_block(&jit);
-
- set_quot_xt(untag_object(quot),compiled);
-
- if(relocate) relocate_code_block(compiled);
-
- jit_dispose(&jit);
-
- UNREGISTER_ROOT(array);
- UNREGISTER_ROOT(quot);
-}
-
-F_FIXNUM quot_code_offset_to_scan(CELL quot, CELL offset)
-{
- CELL array = untag_quotation(quot)->array;
- REGISTER_ROOT(array);
-
- F_JIT jit;
- jit_init(&jit,QUOTATION_TYPE,quot);
- jit_compute_position(&jit,offset);
- jit_iterate_quotation(&jit,array,false,false);
- jit_dispose(&jit);
-
- UNREGISTER_ROOT(array);
-
- return jit_get_position(&jit);
-}
-
-F_FASTCALL CELL lazy_jit_compile_impl(CELL quot, F_STACK_FRAME *stack)
-{
- stack_chain->callstack_top = stack;
- REGISTER_ROOT(quot);
- jit_compile(quot,true);
- UNREGISTER_ROOT(quot);
- return quot;
-}
-
-void primitive_jit_compile(void)
-{
- jit_compile(dpop(),true);
-}
-
-/* push a new quotation on the stack */
-void primitive_array_to_quotation(void)
-{
- F_QUOTATION *quot = allot_object(QUOTATION_TYPE,sizeof(F_QUOTATION));
- quot->array = dpeek();
- quot->xt = lazy_jit_compile;
- quot->compiledp = F;
- quot->cached_effect = F;
- quot->cache_counter = F;
- drepl(tag_quotation(quot));
-}
-
-void primitive_quotation_xt(void)
-{
- F_QUOTATION *quot = untag_quotation(dpeek());
- drepl(allot_cell((CELL)quot->xt));
-}
-
-void compile_all_words(void)
-{
- CELL words = find_all_words();
-
- REGISTER_ROOT(words);
-
- CELL i;
- CELL length = array_capacity(untag_object(words));
- for(i = 0; i < length; i++)
- {
- F_WORD *word = untag_word(array_nth(untag_array(words),i));
- REGISTER_UNTAGGED(word);
-
- if(!word->code || !word_optimized_p(word))
- jit_compile_word(word,word->def,false);
-
- UNREGISTER_UNTAGGED(word);
- update_word_xt(word);
-
- }
-
- UNREGISTER_ROOT(words);
-
- iterate_code_heap(relocate_code_block);
-}
--- /dev/null
+#include "master.hpp"
+
+namespace factor
+{
+
+/* Simple non-optimizing compiler.
+
+This is one of the two compilers implementing Factor; the second one is written
+in Factor and performs advanced optimizations. See core/compiler/compiler.factor.
+
+The non-optimizing compiler compiles a quotation at a time by concatenating
+machine code chunks; prolog, epilog, call word, jump to word, etc. These machine
+code chunks are generated from Factor code in core/cpu/.../bootstrap.factor.
+
+Calls to words and constant quotations (referenced by conditionals and dips)
+are direct jumps to machine code blocks. Literals are also referenced directly
+without going through the literal table.
+
+It actually does do a little bit of very simple optimization:
+
+1) Tail call optimization.
+
+2) If a quotation is determined to not call any other words (except for a few
+special words which are open-coded, see below), then no prolog/epilog is
+generated.
+
+3) When in tail position and immediately preceded by literal arguments, the
+'if' is generated inline, instead of as a call to the 'if' word.
+
+4) When preceded by a quotation, calls to 'dip', '2dip' and '3dip' are
+open-coded as retain stack manipulation surrounding a subroutine call.
+
+5) Sub-primitives are primitive words which are implemented in assembly and not
+in the VM. They are open-coded and no subroutine call is generated. This
+includes stack shufflers, some fixnum arithmetic words, and words such as tag,
+slot and eq?. A primitive call is relatively expensive (two subroutine calls)
+so this results in a big speedup for relatively little effort. */
+
+bool quotation_jit::primitive_call_p(cell i)
+{
+ 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];
+}
+
+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];
+}
+
+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];
+}
+
+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];
+}
+
+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];
+}
+
+bool quotation_jit::mega_lookup_p(cell i)
+{
+ return (i + 3) < array_capacity(elements.untagged())
+ && 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];
+}
+
+bool quotation_jit::stack_frame_p()
+{
+ fixnum length = array_capacity(elements.untagged());
+ fixnum i;
+
+ for(i = 0; i < length - 1; i++)
+ {
+ cell obj = array_nth(elements.untagged(),i);
+ switch(tagged<object>(obj).type())
+ {
+ case WORD_TYPE:
+ if(untag<word>(obj)->subprimitive == F)
+ return true;
+ break;
+ case QUOTATION_TYPE:
+ if(fast_dip_p(i) || fast_2dip_p(i) || fast_3dip_p(i))
+ return true;
+ break;
+ default:
+ break;
+ }
+ }
+
+ return false;
+}
+
+/* Allocates memory */
+void quotation_jit::iterate_quotation()
+{
+ bool stack_frame = stack_frame_p();
+
+ set_position(0);
+
+ if(stack_frame)
+ emit(userenv[JIT_PROLOG]);
+
+ cell i;
+ cell length = array_capacity(elements.untagged());
+ bool tail_call = false;
+
+ for(i = 0; i < length; i++)
+ {
+ set_position(i);
+
+ gc_root<object> obj(array_nth(elements.untagged(),i));
+
+ switch(obj.type())
+ {
+ case WORD_TYPE:
+ /* Intrinsics */
+ if(obj.as<word>()->subprimitive != F)
+ emit_subprimitive(obj.value());
+ /* The (execute) primitive is special-cased */
+ else if(obj.value() == userenv[JIT_EXECUTE_WORD])
+ {
+ if(i == length - 1)
+ {
+ if(stack_frame) emit(userenv[JIT_EPILOG]);
+ tail_call = true;
+ emit(userenv[JIT_EXECUTE_JUMP]);
+ }
+ else
+ emit(userenv[JIT_EXECUTE_CALL]);
+ }
+ /* Everything else */
+ else
+ {
+ if(i == length - 1)
+ {
+ if(stack_frame) emit(userenv[JIT_EPILOG]);
+ tail_call = true;
+ word_jump(obj.value());
+ }
+ else
+ word_call(obj.value());
+ }
+ break;
+ case WRAPPER_TYPE:
+ push(obj.as<wrapper>()->object);
+ break;
+ case FIXNUM_TYPE:
+ /* Primitive calls */
+ if(primitive_call_p(i))
+ {
+ emit(userenv[JIT_SAVE_STACK]);
+ emit_with(userenv[JIT_PRIMITIVE],obj.value());
+
+ i++;
+
+ tail_call = true;
+ break;
+ }
+ case QUOTATION_TYPE:
+ /* 'if' preceeded by two literal quotations (this is why if and ? are
+ mutually recursive in the library, but both still work) */
+ if(fast_if_p(i))
+ {
+ if(stack_frame) emit(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);
+ }
+
+ emit_with(userenv[JIT_IF_1],array_nth(elements.untagged(),i));
+ emit_with(userenv[JIT_IF_2],array_nth(elements.untagged(),i + 1));
+
+ i += 2;
+
+ break;
+ }
+ /* dip */
+ else if(fast_dip_p(i))
+ {
+ if(compiling)
+ jit_compile(obj.value(),relocate);
+ emit_with(userenv[JIT_DIP],obj.value());
+ i++;
+ break;
+ }
+ /* 2dip */
+ else if(fast_2dip_p(i))
+ {
+ if(compiling)
+ jit_compile(obj.value(),relocate);
+ emit_with(userenv[JIT_2DIP],obj.value());
+ i++;
+ break;
+ }
+ /* 3dip */
+ else if(fast_3dip_p(i))
+ {
+ if(compiling)
+ jit_compile(obj.value(),relocate);
+ emit_with(userenv[JIT_3DIP],obj.value());
+ i++;
+ break;
+ }
+ case ARRAY_TYPE:
+ /* Method dispatch */
+ if(mega_lookup_p(i))
+ {
+ emit_mega_cache_lookup(
+ array_nth(elements.untagged(),i),
+ untag_fixnum(array_nth(elements.untagged(),i + 1)),
+ array_nth(elements.untagged(),i + 2));
+ i += 3;
+ tail_call = true;
+ break;
+ }
+ default:
+ push(obj.value());
+ break;
+ }
+ }
+
+ if(!tail_call)
+ {
+ set_position(length);
+
+ if(stack_frame)
+ emit(userenv[JIT_EPILOG]);
+ emit(userenv[JIT_RETURN]);
+ }
+}
+
+void set_quot_xt(quotation *quot, code_block *code)
+{
+ if(code->block.type != QUOTATION_TYPE)
+ critical_error("Bad param to set_quot_xt",(cell)code);
+
+ quot->code = code;
+ quot->xt = code->xt();
+ quot->compiledp = T;
+}
+
+/* Allocates memory */
+void jit_compile(cell quot_, bool relocating)
+{
+ gc_root<quotation> quot(quot_);
+ if(quot->compiledp != F) return;
+
+ quotation_jit compiler(quot.value(),true,relocating);
+ compiler.iterate_quotation();
+
+ code_block *compiled = compiler.to_code_block();
+ set_quot_xt(quot.untagged(),compiled);
+
+ if(relocating) relocate_code_block(compiled);
+}
+
+PRIMITIVE(jit_compile)
+{
+ jit_compile(dpop(),true);
+}
+
+/* push a new quotation on the stack */
+PRIMITIVE(array_to_quotation)
+{
+ quotation *quot = allot<quotation>(sizeof(quotation));
+ quot->array = dpeek();
+ quot->xt = (void *)lazy_jit_compile;
+ quot->compiledp = F;
+ quot->cached_effect = F;
+ quot->cache_counter = F;
+ drepl(tag<quotation>(quot));
+}
+
+PRIMITIVE(quotation_xt)
+{
+ quotation *quot = untag_check<quotation>(dpeek());
+ drepl(allot_cell((cell)quot->xt));
+}
+
+void compile_all_words(void)
+{
+ gc_root<array> words(find_all_words());
+
+ cell i;
+ cell length = array_capacity(words.untagged());
+ for(i = 0; i < length; i++)
+ {
+ gc_root<word> word(array_nth(words.untagged(),i));
+
+ if(!word->code || !word_optimized_p(word.untagged()))
+ jit_compile_word(word.value(),word->def,false);
+
+ update_word_xt(word.value());
+
+ }
+
+ iterate_code_heap(relocate_code_block);
+}
+
+/* Allocates memory */
+fixnum quot_code_offset_to_scan(cell quot_, cell offset)
+{
+ gc_root<quotation> quot(quot_);
+ gc_root<array> array(quot->array);
+
+ quotation_jit compiler(quot.value(),false,false);
+ compiler.compute_position(offset);
+ compiler.iterate_quotation();
+
+ return compiler.get_position();
+}
+
+VM_ASM_API cell lazy_jit_compile_impl(cell quot_, stack_frame *stack)
+{
+ gc_root<quotation> quot(quot_);
+ stack_chain->callstack_top = stack;
+ jit_compile(quot.value(),true);
+ return quot.value();
+}
+
+}
+++ /dev/null
-DEFINE_UNTAG(F_QUOTATION,QUOTATION_TYPE,quotation)
-
-INLINE CELL tag_quotation(F_QUOTATION *quotation)
-{
- return RETAG(quotation,QUOTATION_TYPE);
-}
-
-void set_quot_xt(F_QUOTATION *quot, F_CODE_BLOCK *code);
-void jit_compile(CELL quot, bool relocate);
-F_FASTCALL CELL lazy_jit_compile_impl(CELL quot, F_STACK_FRAME *stack);
-F_FIXNUM quot_code_offset_to_scan(CELL quot, CELL offset);
-void primitive_array_to_quotation(void);
-void primitive_quotation_xt(void);
-void primitive_jit_compile(void);
-void compile_all_words(void);
--- /dev/null
+namespace factor
+{
+
+struct quotation_jit : public jit {
+ 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),
+ compiling(compiling_),
+ relocate(relocate_) {};
+
+ void emit_mega_cache_lookup(cell methods, fixnum index, cell cache);
+ bool primitive_call_p(cell i);
+ bool fast_if_p(cell i);
+ bool fast_dip_p(cell i);
+ bool fast_2dip_p(cell i);
+ bool fast_3dip_p(cell i);
+ bool mega_lookup_p(cell i);
+ bool stack_frame_p();
+ 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(void);
+
+PRIMITIVE(array_to_quotation);
+PRIMITIVE(quotation_xt);
+
+VM_ASM_API cell lazy_jit_compile_impl(cell quot, stack_frame *stack);
+
+}
+++ /dev/null
-#include "master.h"
-
-void reset_datastack(void)
-{
- ds = ds_bot - CELLS;
-}
-
-void reset_retainstack(void)
-{
- rs = rs_bot - CELLS;
-}
-
-#define RESERVED (64 * CELLS)
-
-void fix_stacks(void)
-{
- if(ds + CELLS < ds_bot || ds + RESERVED >= ds_top) reset_datastack();
- if(rs + CELLS < rs_bot || rs + 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)
-{
- if(stack_chain)
- {
- stack_chain->datastack = ds;
- stack_chain->retainstack = rs;
- }
-}
-
-F_CONTEXT *alloc_context(void)
-{
- F_CONTEXT *context;
-
- if(unused_contexts)
- {
- context = unused_contexts;
- unused_contexts = unused_contexts->next;
- }
- else
- {
- context = safe_malloc(sizeof(F_CONTEXT));
- context->datastack_region = alloc_segment(ds_size);
- context->retainstack_region = alloc_segment(rs_size);
- }
-
- return context;
-}
-
-void dealloc_context(F_CONTEXT *context)
-{
- context->next = unused_contexts;
- unused_contexts = context;
-}
-
-/* called on entry into a compiled callback */
-void nest_stacks(void)
-{
- F_CONTEXT *new_stacks = alloc_context();
-
- new_stacks->callstack_bottom = (F_STACK_FRAME *)-1;
- new_stacks->callstack_top = (F_STACK_FRAME *)-1;
-
- /* note that these register values are not necessarily valid stack
- pointers. they are merely saved non-volatile registers, and are
- restored in unnest_stacks(). consider this scenario:
- - factor code calls C function
- - C function saves ds/cs registers (since they're non-volatile)
- - C function clobbers them
- - C function calls Factor callback
- - Factor callback returns
- - C function restores registers
- - C function returns to Factor code */
- new_stacks->datastack_save = ds;
- new_stacks->retainstack_save = rs;
-
- /* save per-callback userenv */
- new_stacks->current_callback_save = userenv[CURRENT_CALLBACK_ENV];
- new_stacks->catchstack_save = userenv[CATCHSTACK_ENV];
-
- new_stacks->next = stack_chain;
- stack_chain = new_stacks;
-
- reset_datastack();
- reset_retainstack();
-}
-
-/* called when leaving a compiled callback */
-void unnest_stacks(void)
-{
- ds = stack_chain->datastack_save;
- rs = stack_chain->retainstack_save;
-
- /* restore per-callback userenv */
- userenv[CURRENT_CALLBACK_ENV] = stack_chain->current_callback_save;
- userenv[CATCHSTACK_ENV] = stack_chain->catchstack_save;
-
- F_CONTEXT *old_stacks = stack_chain;
- stack_chain = old_stacks->next;
- dealloc_context(old_stacks);
-}
-
-/* called on startup */
-void init_stacks(CELL ds_size_, CELL rs_size_)
-{
- ds_size = ds_size_;
- rs_size = rs_size_;
- stack_chain = NULL;
- unused_contexts = NULL;
-}
-
-bool stack_to_array(CELL bottom, CELL top)
-{
- F_FIXNUM depth = (F_FIXNUM)(top - bottom + CELLS);
-
- if(depth < 0)
- return false;
- else
- {
- F_ARRAY *a = allot_array_internal(ARRAY_TYPE,depth / CELLS);
- memcpy(a + 1,(void*)bottom,depth);
- dpush(tag_array(a));
- return true;
- }
-}
-
-void primitive_datastack(void)
-{
- if(!stack_to_array(ds_bot,ds))
- general_error(ERROR_DS_UNDERFLOW,F,F,NULL);
-}
-
-void primitive_retainstack(void)
-{
- if(!stack_to_array(rs_bot,rs))
- general_error(ERROR_RS_UNDERFLOW,F,F,NULL);
-}
-
-/* returns pointer to top of stack */
-CELL array_to_stack(F_ARRAY *array, CELL bottom)
-{
- CELL depth = array_capacity(array) * CELLS;
- memcpy((void*)bottom,array + 1,depth);
- return bottom + depth - CELLS;
-}
-
-void primitive_set_datastack(void)
-{
- ds = array_to_stack(untag_array(dpop()),ds_bot);
-}
-
-void primitive_set_retainstack(void)
-{
- rs = array_to_stack(untag_array(dpop()),rs_bot);
-}
-
-/* Used to implement call( */
-void primitive_check_datastack(void)
-{
- F_FIXNUM out = to_fixnum(dpop());
- F_FIXNUM in = to_fixnum(dpop());
- F_FIXNUM height = out - in;
- F_ARRAY *array = untag_array(dpop());
- F_FIXNUM length = array_capacity(array);
- F_FIXNUM depth = (ds - ds_bot + CELLS) / CELLS;
- if(depth - height != length)
- dpush(F);
- else
- {
- F_FIXNUM i;
- for(i = 0; i < length - in; i++)
- {
- if(get(ds_bot + i * CELLS) != array_nth(array,i))
- {
- dpush(F);
- return;
- }
- }
- dpush(T);
- }
-}
-
-void primitive_getenv(void)
-{
- F_FIXNUM e = untag_fixnum_fast(dpeek());
- drepl(userenv[e]);
-}
-
-void primitive_setenv(void)
-{
- F_FIXNUM e = untag_fixnum_fast(dpop());
- CELL value = dpop();
- userenv[e] = value;
-}
-
-void primitive_exit(void)
-{
- exit(to_fixnum(dpop()));
-}
-
-void primitive_micros(void)
-{
- box_unsigned_8(current_micros());
-}
-
-void primitive_sleep(void)
-{
- sleep_micros(to_cell(dpop()));
-}
-
-void primitive_set_slot(void)
-{
- F_FIXNUM slot = untag_fixnum_fast(dpop());
- CELL obj = dpop();
- CELL value = dpop();
- set_slot(obj,slot,value);
-}
-
-void primitive_load_locals(void)
-{
- F_FIXNUM count = untag_fixnum_fast(dpop());
- memcpy((CELL *)(rs + CELLS),(CELL *)(ds - CELLS * (count - 1)),CELLS * count);
- ds -= CELLS * count;
- rs += CELLS * count;
-}
-
-static CELL clone_object(CELL object)
-{
- CELL size = object_size(object);
- if(size == 0)
- return object;
- else
- {
- REGISTER_ROOT(object);
- void *new_obj = allot_object(type_of(object),size);
- UNREGISTER_ROOT(object);
-
- CELL tag = TAG(object);
- memcpy(new_obj,(void*)UNTAG(object),size);
- return RETAG(new_obj,tag);
- }
-}
-
-void primitive_clone(void)
-{
- drepl(clone_object(dpeek()));
-}
--- /dev/null
+#include "master.hpp"
+
+factor::cell userenv[USER_ENV];
+
+namespace factor
+{
+
+cell T;
+
+PRIMITIVE(getenv)
+{
+ fixnum e = untag_fixnum(dpeek());
+ drepl(userenv[e]);
+}
+
+PRIMITIVE(setenv)
+{
+ fixnum e = untag_fixnum(dpop());
+ cell value = dpop();
+ userenv[e] = value;
+}
+
+PRIMITIVE(exit)
+{
+ exit(to_fixnum(dpop()));
+}
+
+PRIMITIVE(micros)
+{
+ box_unsigned_8(current_micros());
+}
+
+PRIMITIVE(sleep)
+{
+ sleep_micros(to_cell(dpop()));
+}
+
+PRIMITIVE(set_slot)
+{
+ fixnum slot = untag_fixnum(dpop());
+ object *obj = untag<object>(dpop());
+ cell value = dpop();
+
+ obj->slots()[slot] = value;
+ write_barrier(obj);
+}
+
+PRIMITIVE(load_locals)
+{
+ fixnum count = untag_fixnum(dpop());
+ memcpy((cell *)(rs + sizeof(cell)),(cell *)(ds - sizeof(cell) * (count - 1)),sizeof(cell) * count);
+ ds -= sizeof(cell) * count;
+ rs += sizeof(cell) * count;
+}
+
+static cell clone_object(cell obj_)
+{
+ gc_root<object> obj(obj_);
+
+ if(immediate_p(obj.value()))
+ return obj.value();
+ else
+ {
+ cell size = object_size(obj.value());
+ object *new_obj = allot_object(obj.type(),size);
+ memcpy(new_obj,obj.untagged(),size);
+ return tag_dynamic(new_obj);
+ }
+}
+
+PRIMITIVE(clone)
+{
+ drepl(clone_object(dpeek()));
+}
+
+}
+++ /dev/null
-#define USER_ENV 70
-
-typedef enum {
- NAMESTACK_ENV, /* used by library only */
- CATCHSTACK_ENV, /* used by library only, per-callback */
-
- CURRENT_CALLBACK_ENV = 2, /* used by library only, per-callback */
- WALKER_HOOK_ENV, /* non-local exit hook, used by library only */
- CALLCC_1_ENV, /* used to pass the value in callcc1 */
-
- BREAK_ENV = 5, /* quotation called by throw primitive */
- ERROR_ENV, /* a marker consed onto kernel errors */
-
- CELL_SIZE_ENV = 7, /* sizeof(CELL) */
- CPU_ENV, /* CPU architecture */
- OS_ENV, /* operating system name */
-
- ARGS_ENV = 10, /* command line arguments */
- STDIN_ENV, /* stdin FILE* handle */
- STDOUT_ENV, /* stdout FILE* handle */
-
- IMAGE_ENV = 13, /* image path name */
- EXECUTABLE_ENV, /* runtime executable path name */
-
- EMBEDDED_ENV = 15, /* are we embedded in another app? */
- EVAL_CALLBACK_ENV, /* used when Factor is embedded in a C app */
- YIELD_CALLBACK_ENV, /* used when Factor is embedded in a C app */
- SLEEP_CALLBACK_ENV, /* used when Factor is embedded in a C app */
-
- COCOA_EXCEPTION_ENV = 19, /* Cocoa exception handler quotation */
-
- BOOT_ENV = 20, /* boot quotation */
- GLOBAL_ENV, /* global namespace */
-
- /* Quotation compilation in quotations.c */
- JIT_PROLOG = 23,
- JIT_PRIMITIVE_WORD,
- JIT_PRIMITIVE,
- JIT_WORD_JUMP,
- JIT_WORD_CALL,
- JIT_IF_WORD,
- JIT_IF_1,
- JIT_IF_2,
- JIT_EPILOG = 33,
- JIT_RETURN,
- JIT_PROFILING,
- JIT_PUSH_IMMEDIATE,
- JIT_SAVE_STACK = 38,
- JIT_DIP_WORD,
- JIT_DIP,
- JIT_2DIP_WORD,
- JIT_2DIP,
- JIT_3DIP_WORD,
- JIT_3DIP,
- JIT_EXECUTE_WORD,
- JIT_EXECUTE_JUMP,
- JIT_EXECUTE_CALL,
-
- /* Polymorphic inline cache generation in inline_cache.c */
- PIC_LOAD = 48,
- PIC_TAG,
- PIC_HI_TAG,
- PIC_TUPLE,
- PIC_HI_TAG_TUPLE,
- PIC_CHECK_TAG,
- PIC_CHECK,
- PIC_HIT,
- PIC_MISS_WORD,
-
- /* Megamorphic cache generation in dispatch.c */
- MEGA_LOOKUP = 57,
- MEGA_LOOKUP_WORD,
- MEGA_MISS_WORD,
-
- UNDEFINED_ENV = 60, /* default quotation for undefined words */
-
- STDERR_ENV = 61, /* stderr FILE* handle */
-
- STAGE2_ENV = 62, /* have we bootstrapped? */
-
- CURRENT_THREAD_ENV = 63,
-
- THREADS_ENV = 64,
- RUN_QUEUE_ENV = 65,
- SLEEP_QUEUE_ENV = 66,
-
- STACK_TRACES_ENV = 67,
-} F_ENVTYPE;
-
-#define FIRST_SAVE_ENV BOOT_ENV
-#define LAST_SAVE_ENV STAGE2_ENV
-
-/* TAGGED user environment data; see getenv/setenv prims */
-DLLEXPORT CELL userenv[USER_ENV];
-
-/* macros for reading/writing memory, useful when working around
-C's type system */
-INLINE CELL get(CELL where)
-{
- return *((CELL*)where);
-}
-
-INLINE void put(CELL where, CELL what)
-{
- *((CELL*)where) = what;
-}
-
-INLINE CELL cget(CELL where)
-{
- return *((u16 *)where);
-}
-
-INLINE void cput(CELL where, CELL what)
-{
- *((u16 *)where) = what;
-}
-
-INLINE CELL bget(CELL where)
-{
- return *((u8 *)where);
-}
-
-INLINE void bput(CELL where, CELL what)
-{
- *((u8 *)where) = what;
-}
-
-INLINE CELL align(CELL a, CELL b)
-{
- return (a + (b-1)) & ~(b-1);
-}
-
-#define align8(a) align(a,8)
-#define align_page(a) align(a,getpagesize())
-
-/* Canonical T object. It's just a word */
-CELL T;
-
-INLINE CELL tag_header(CELL cell)
-{
- return cell << TAG_BITS;
-}
-
-INLINE void check_header(CELL cell)
-{
-#ifdef FACTOR_DEBUG
- assert(TAG(cell) == FIXNUM_TYPE && untag_fixnum_fast(cell) < TYPE_COUNT);
-#endif
-}
-
-INLINE CELL untag_header(CELL cell)
-{
- check_header(cell);
- return cell >> TAG_BITS;
-}
-
-INLINE CELL hi_tag(CELL tagged)
-{
- return untag_header(get(UNTAG(tagged)));
-}
-
-INLINE CELL tag_object(void *cell)
-{
-#ifdef FACTOR_DEBUG
- assert(hi_tag((CELL)cell) >= HEADER_TYPE);
-#endif
- return RETAG(cell,OBJECT_TYPE);
-}
-
-INLINE CELL type_of(CELL tagged)
-{
- CELL tag = TAG(tagged);
- if(tag == OBJECT_TYPE)
- return hi_tag(tagged);
- else
- return tag;
-}
-
-#define DEFPUSHPOP(prefix,ptr) \
- INLINE CELL prefix##pop(void) \
- { \
- CELL value = get(ptr); \
- ptr -= CELLS; \
- return value; \
- } \
- INLINE void prefix##push(CELL tagged) \
- { \
- ptr += CELLS; \
- put(ptr,tagged); \
- } \
- INLINE void prefix##repl(CELL tagged) \
- { \
- put(ptr,tagged); \
- } \
- INLINE CELL prefix##peek() \
- { \
- return get(ptr); \
- }
-
-DEFPUSHPOP(d,ds)
-DEFPUSHPOP(r,rs)
-
-typedef struct {
- CELL start;
- CELL size;
- CELL end;
-} F_SEGMENT;
-
-/* Assembly code makes assumptions about the layout of this struct:
- - callstack_top field is 0
- - callstack_bottom field is 1
- - datastack field is 2
- - retainstack field is 3 */
-typedef struct _F_CONTEXT {
- /* C stack pointer on entry */
- F_STACK_FRAME *callstack_top;
- F_STACK_FRAME *callstack_bottom;
-
- /* current datastack top pointer */
- CELL datastack;
-
- /* current retain stack top pointer */
- CELL retainstack;
-
- /* saved contents of ds register on entry to callback */
- CELL datastack_save;
-
- /* saved contents of rs register on entry to callback */
- CELL retainstack_save;
-
- /* memory region holding current datastack */
- F_SEGMENT *datastack_region;
-
- /* memory region holding current retain stack */
- F_SEGMENT *retainstack_region;
-
- /* saved userenv slots on entry to callback */
- CELL catchstack_save;
- CELL current_callback_save;
-
- struct _F_CONTEXT *next;
-} F_CONTEXT;
-
-DLLEXPORT F_CONTEXT *stack_chain;
-
-F_CONTEXT *unused_contexts;
-
-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)
-#define rs_top (stack_chain->retainstack_region->end)
-
-void reset_datastack(void);
-void reset_retainstack(void);
-void fix_stacks(void);
-DLLEXPORT void save_stacks(void);
-DLLEXPORT void nest_stacks(void);
-DLLEXPORT void unnest_stacks(void);
-void init_stacks(CELL ds_size, CELL rs_size);
-
-void primitive_datastack(void);
-void primitive_retainstack(void);
-void primitive_set_datastack(void);
-void primitive_set_retainstack(void);
-void primitive_check_datastack(void);
-void primitive_getenv(void);
-void primitive_setenv(void);
-void primitive_exit(void);
-void primitive_micros(void);
-void primitive_sleep(void);
-void primitive_set_slot(void);
-void primitive_load_locals(void);
-void primitive_clone(void);
-
-bool stage2;
--- /dev/null
+namespace factor
+{
+
+#define USER_ENV 70
+
+enum special_object {
+ NAMESTACK_ENV, /* used by library only */
+ CATCHSTACK_ENV, /* used by library only, per-callback */
+
+ CURRENT_CALLBACK_ENV = 2, /* used by library only, per-callback */
+ WALKER_HOOK_ENV, /* non-local exit hook, used by library only */
+ CALLCC_1_ENV, /* used to pass the value in callcc1 */
+
+ BREAK_ENV = 5, /* quotation called by throw primitive */
+ ERROR_ENV, /* a marker consed onto kernel errors */
+
+ cell_SIZE_ENV = 7, /* sizeof(cell) */
+ CPU_ENV, /* CPU architecture */
+ OS_ENV, /* operating system name */
+
+ ARGS_ENV = 10, /* command line arguments */
+ STDIN_ENV, /* stdin FILE* handle */
+ STDOUT_ENV, /* stdout FILE* handle */
+
+ IMAGE_ENV = 13, /* image path name */
+ EXECUTABLE_ENV, /* runtime executable path name */
+
+ EMBEDDED_ENV = 15, /* are we embedded in another app? */
+ EVAL_CALLBACK_ENV, /* used when Factor is embedded in a C app */
+ YIELD_CALLBACK_ENV, /* used when Factor is embedded in a C app */
+ SLEEP_CALLBACK_ENV, /* used when Factor is embedded in a C app */
+
+ COCOA_EXCEPTION_ENV = 19, /* Cocoa exception handler quotation */
+
+ BOOT_ENV = 20, /* boot quotation */
+ GLOBAL_ENV, /* global namespace */
+
+ /* Quotation compilation in quotations.c */
+ JIT_PROLOG = 23,
+ JIT_PRIMITIVE_WORD,
+ JIT_PRIMITIVE,
+ JIT_WORD_JUMP,
+ JIT_WORD_CALL,
+ JIT_IF_WORD,
+ JIT_IF_1,
+ JIT_IF_2,
+ JIT_EPILOG = 33,
+ JIT_RETURN,
+ JIT_PROFILING,
+ JIT_PUSH_IMMEDIATE,
+ JIT_SAVE_STACK = 38,
+ JIT_DIP_WORD,
+ JIT_DIP,
+ JIT_2DIP_WORD,
+ JIT_2DIP,
+ JIT_3DIP_WORD,
+ JIT_3DIP,
+ JIT_EXECUTE_WORD,
+ JIT_EXECUTE_JUMP,
+ JIT_EXECUTE_CALL,
+
+ /* Polymorphic inline cache generation in inline_cache.c */
+ PIC_LOAD = 48,
+ PIC_TAG,
+ PIC_HI_TAG,
+ PIC_TUPLE,
+ PIC_HI_TAG_TUPLE,
+ PIC_CHECK_TAG,
+ PIC_CHECK,
+ PIC_HIT,
+ PIC_MISS_WORD,
+
+ /* Megamorphic cache generation in dispatch.c */
+ MEGA_LOOKUP = 57,
+ MEGA_LOOKUP_WORD,
+ MEGA_MISS_WORD,
+
+ UNDEFINED_ENV = 60, /* default quotation for undefined words */
+
+ STDERR_ENV = 61, /* stderr FILE* handle */
+
+ STAGE2_ENV = 62, /* have we bootstrapped? */
+
+ CURRENT_THREAD_ENV = 63,
+
+ THREADS_ENV = 64,
+ RUN_QUEUE_ENV = 65,
+ SLEEP_QUEUE_ENV = 66,
+
+ STACK_TRACES_ENV = 67,
+};
+
+#define FIRST_SAVE_ENV BOOT_ENV
+#define LAST_SAVE_ENV STAGE2_ENV
+
+/* Canonical T object. It's just a word */
+extern cell T;
+
+PRIMITIVE(getenv);
+PRIMITIVE(setenv);
+PRIMITIVE(exit);
+PRIMITIVE(micros);
+PRIMITIVE(sleep);
+PRIMITIVE(set_slot);
+PRIMITIVE(load_locals);
+PRIMITIVE(clone);
+
+}
+
+/* TAGGED user environment data; see getenv/setenv prims */
+VM_C_API factor::cell userenv[USER_ENV];
--- /dev/null
+namespace factor
+{
+
+struct segment {
+ cell start;
+ cell size;
+ cell end;
+};
+
+}
--- /dev/null
+namespace factor
+{
+
+#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(void) \
+ { \
+ cell value = prefix##peek(); \
+ ptr -= sizeof(cell); \
+ return value; \
+ } \
+ inline static void prefix##push(cell tagged) \
+ { \
+ ptr += sizeof(cell); \
+ prefix##repl(tagged); \
+ }
+
+}
+++ /dev/null
-#include "master.h"
-
-CELL string_nth(F_STRING* string, 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
- corresponding aux vector entry is negated, so that we can
- XOR the two components together and get the original code point
- back. */
- CELL ch = bget(SREF(string,index));
- if((ch & 0x80) == 0)
- return ch;
- else
- {
- F_BYTE_ARRAY *aux = untag_object(string->aux);
- return (cget(BREF(aux,index * sizeof(u16))) << 7) ^ ch;
- }
-}
-
-void set_string_nth_fast(F_STRING* string, CELL index, CELL ch)
-{
- bput(SREF(string,index),ch);
-}
-
-void set_string_nth_slow(F_STRING* string, CELL index, CELL ch)
-{
- F_BYTE_ARRAY *aux;
-
- bput(SREF(string,index),(ch & 0x7f) | 0x80);
-
- if(string->aux == F)
- {
- REGISTER_UNTAGGED(string);
- /* We don't need to pre-initialize the
- byte array with any data, since we
- only ever read from the aux vector
- if the most significant bit of a
- character is set. Initially all of
- the bits are clear. */
- aux = allot_byte_array_internal(
- untag_fixnum_fast(string->length)
- * sizeof(u16));
- UNREGISTER_UNTAGGED(string);
-
- write_barrier((CELL)string);
- string->aux = tag_object(aux);
- }
- else
- aux = untag_object(string->aux);
-
- cput(BREF(aux,index * sizeof(u16)),(ch >> 7) ^ 1);
-}
-
-/* allocates memory */
-void set_string_nth(F_STRING* string, CELL index, CELL ch)
-{
- if(ch <= 0x7f)
- set_string_nth_fast(string,index,ch);
- else
- set_string_nth_slow(string,index,ch);
-}
-
-/* untagged */
-F_STRING* allot_string_internal(CELL capacity)
-{
- F_STRING *string = allot_object(STRING_TYPE,string_size(capacity));
-
- string->length = tag_fixnum(capacity);
- string->hashcode = F;
- string->aux = F;
-
- return string;
-}
-
-/* allocates memory */
-void fill_string(F_STRING *string, CELL start, CELL capacity, CELL fill)
-{
- if(fill <= 0x7f)
- memset((void *)SREF(string,start),fill,capacity - start);
- else
- {
- CELL i;
-
- for(i = start; i < capacity; i++)
- {
- REGISTER_UNTAGGED(string);
- set_string_nth(string,i,fill);
- UNREGISTER_UNTAGGED(string);
- }
- }
-}
-
-/* untagged */
-F_STRING *allot_string(CELL capacity, CELL fill)
-{
- F_STRING* string = allot_string_internal(capacity);
- REGISTER_UNTAGGED(string);
- fill_string(string,0,capacity,fill);
- UNREGISTER_UNTAGGED(string);
- return string;
-}
-
-void primitive_string(void)
-{
- CELL initial = to_cell(dpop());
- CELL length = unbox_array_size();
- dpush(tag_object(allot_string(length,initial)));
-}
-
-static bool reallot_string_in_place_p(F_STRING *string, CELL capacity)
-{
- return in_zone(&nursery,(CELL)string) && capacity <= string_capacity(string);
-}
-
-F_STRING* reallot_string(F_STRING* string, CELL capacity)
-{
- if(reallot_string_in_place_p(string,capacity))
- {
- string->length = tag_fixnum(capacity);
-
- if(string->aux != F)
- {
- F_BYTE_ARRAY *aux = untag_object(string->aux);
- aux->capacity = tag_fixnum(capacity * 2);
- }
-
- return string;
- }
- else
- {
- CELL to_copy = string_capacity(string);
- if(capacity < to_copy)
- to_copy = capacity;
-
- REGISTER_UNTAGGED(string);
- F_STRING *new_string = allot_string_internal(capacity);
- UNREGISTER_UNTAGGED(string);
-
- memcpy(new_string + 1,string + 1,to_copy);
-
- if(string->aux != F)
- {
- REGISTER_UNTAGGED(string);
- REGISTER_UNTAGGED(new_string);
- F_BYTE_ARRAY *new_aux = allot_byte_array(capacity * sizeof(u16));
- UNREGISTER_UNTAGGED(new_string);
- UNREGISTER_UNTAGGED(string);
-
- write_barrier((CELL)new_string);
- new_string->aux = tag_object(new_aux);
-
- F_BYTE_ARRAY *aux = untag_object(string->aux);
- memcpy(new_aux + 1,aux + 1,to_copy * sizeof(u16));
- }
-
- REGISTER_UNTAGGED(string);
- REGISTER_UNTAGGED(new_string);
- fill_string(new_string,to_copy,capacity,'\0');
- UNREGISTER_UNTAGGED(new_string);
- UNREGISTER_UNTAGGED(string);
-
- return new_string;
- }
-}
-
-void primitive_resize_string(void)
-{
- F_STRING* string = untag_string(dpop());
- CELL capacity = unbox_array_size();
- dpush(tag_object(reallot_string(string,capacity)));
-}
-
-/* Some ugly macros to prevent a 2x code duplication */
-
-#define MEMORY_TO_STRING(type,utype) \
- F_STRING *memory_to_##type##_string(const type *string, CELL length) \
- { \
- REGISTER_C_STRING(string); \
- F_STRING* s = allot_string_internal(length); \
- UNREGISTER_C_STRING(string); \
- CELL i; \
- for(i = 0; i < length; i++) \
- { \
- REGISTER_UNTAGGED(s); \
- set_string_nth(s,i,(utype)*string); \
- UNREGISTER_UNTAGGED(s); \
- string++; \
- } \
- return s; \
- } \
- F_STRING *from_##type##_string(const type *str) \
- { \
- CELL length = 0; \
- const type *scan = str; \
- while(*scan++) length++; \
- return memory_to_##type##_string(str,length); \
- } \
- void box_##type##_string(const type *str) \
- { \
- dpush(str ? tag_object(from_##type##_string(str)) : F); \
- }
-
-MEMORY_TO_STRING(char,u8)
-MEMORY_TO_STRING(u16,u16)
-MEMORY_TO_STRING(u32,u32)
-
-bool check_string(F_STRING *s, CELL max)
-{
- CELL capacity = string_capacity(s);
- CELL i;
- for(i = 0; i < capacity; i++)
- {
- CELL ch = string_nth(s,i);
- if(ch == '\0' || ch >= (1 << (max * 8)))
- return false;
- }
- return true;
-}
-
-F_BYTE_ARRAY *allot_c_string(CELL capacity, CELL size)
-{
- return allot_byte_array((capacity + 1) * size);
-}
-
-#define STRING_TO_MEMORY(type) \
- void type##_string_to_memory(F_STRING *s, type *string) \
- { \
- CELL i; \
- CELL capacity = string_capacity(s); \
- for(i = 0; i < capacity; i++) \
- string[i] = string_nth(s,i); \
- } \
- void primitive_##type##_string_to_memory(void) \
- { \
- type *address = unbox_alien(); \
- F_STRING *str = untag_string(dpop()); \
- type##_string_to_memory(str,address); \
- } \
- F_BYTE_ARRAY *string_to_##type##_alien(F_STRING *s, bool check) \
- { \
- CELL capacity = string_capacity(s); \
- F_BYTE_ARRAY *_c_str; \
- if(check && !check_string(s,sizeof(type))) \
- general_error(ERROR_C_STRING,tag_object(s),F,NULL); \
- REGISTER_UNTAGGED(s); \
- _c_str = allot_c_string(capacity,sizeof(type)); \
- UNREGISTER_UNTAGGED(s); \
- type *c_str = (type*)(_c_str + 1); \
- type##_string_to_memory(s,c_str); \
- c_str[capacity] = 0; \
- return _c_str; \
- } \
- type *to_##type##_string(F_STRING *s, bool check) \
- { \
- return (type*)(string_to_##type##_alien(s,check) + 1); \
- } \
- type *unbox_##type##_string(void) \
- { \
- return to_##type##_string(untag_string(dpop()),true); \
- }
-
-STRING_TO_MEMORY(char);
-STRING_TO_MEMORY(u16);
-
-void primitive_string_nth(void)
-{
- F_STRING *string = untag_object(dpop());
- CELL index = untag_fixnum_fast(dpop());
- dpush(tag_fixnum(string_nth(string,index)));
-}
-
-void primitive_set_string_nth(void)
-{
- F_STRING *string = untag_object(dpop());
- CELL index = untag_fixnum_fast(dpop());
- CELL value = untag_fixnum_fast(dpop());
- set_string_nth(string,index,value);
-}
-
-void primitive_set_string_nth_fast(void)
-{
- F_STRING *string = untag_object(dpop());
- CELL index = untag_fixnum_fast(dpop());
- CELL value = untag_fixnum_fast(dpop());
- set_string_nth_fast(string,index,value);
-}
-
-void primitive_set_string_nth_slow(void)
-{
- F_STRING *string = untag_object(dpop());
- CELL index = untag_fixnum_fast(dpop());
- CELL value = untag_fixnum_fast(dpop());
- set_string_nth_slow(string,index,value);
-}
--- /dev/null
+#include "master.hpp"
+
+namespace factor
+{
+
+cell 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
+ corresponding aux vector entry is negated, so that we can
+ XOR the two components together and get the original code point
+ back. */
+ cell lo_bits = str->data()[index];
+
+ if((lo_bits & 0x80) == 0)
+ return lo_bits;
+ else
+ {
+ byte_array *aux = untag<byte_array>(str->aux);
+ cell hi_bits = aux->data<u16>()[index];
+ return (hi_bits << 7) ^ lo_bits;
+ }
+}
+
+void 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)
+{
+ gc_root<string> str(str_);
+
+ byte_array *aux;
+
+ str->data()[index] = ((ch & 0x7f) | 0x80);
+
+ if(str->aux == F)
+ {
+ /* We don't need to pre-initialize the
+ byte array with any data, since we
+ only ever read from the aux vector
+ if the most significant bit of a
+ character is set. Initially all of
+ the bits are clear. */
+ aux = allot_array_internal<byte_array>(untag_fixnum(str->length) * sizeof(u16));
+
+ write_barrier(str.untagged());
+ str->aux = tag<byte_array>(aux);
+ }
+ else
+ aux = untag<byte_array>(str->aux);
+
+ aux->data<u16>()[index] = ((ch >> 7) ^ 1);
+}
+
+/* allocates memory */
+void set_string_nth(string *str, cell index, cell ch)
+{
+ if(ch <= 0x7f)
+ set_string_nth_fast(str,index,ch);
+ else
+ set_string_nth_slow(str,index,ch);
+}
+
+/* Allocates memory */
+string *allot_string_internal(cell capacity)
+{
+ string *str = allot<string>(string_size(capacity));
+
+ str->length = tag_fixnum(capacity);
+ str->hashcode = F;
+ str->aux = F;
+
+ return str;
+}
+
+/* Allocates memory */
+void fill_string(string *str_, cell start, cell capacity, cell fill)
+{
+ gc_root<string> str(str_);
+
+ if(fill <= 0x7f)
+ memset(&str->data()[start],fill,capacity - start);
+ else
+ {
+ cell i;
+
+ for(i = start; i < capacity; i++)
+ set_string_nth(str.untagged(),i,fill);
+ }
+}
+
+/* Allocates memory */
+string *allot_string(cell capacity, cell fill)
+{
+ gc_root<string> str(allot_string_internal(capacity));
+ fill_string(str.untagged(),0,capacity,fill);
+ return str.untagged();
+}
+
+PRIMITIVE(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)
+{
+ return in_zone(&nursery,str) && capacity <= string_capacity(str);
+}
+
+string* reallot_string(string *str_, cell capacity)
+{
+ gc_root<string> str(str_);
+
+ if(reallot_string_in_place_p(str.untagged(),capacity))
+ {
+ str->length = tag_fixnum(capacity);
+
+ if(str->aux != F)
+ {
+ byte_array *aux = untag<byte_array>(str->aux);
+ aux->capacity = tag_fixnum(capacity * 2);
+ }
+
+ return str.untagged();
+ }
+ else
+ {
+ cell to_copy = string_capacity(str.untagged());
+ if(capacity < to_copy)
+ to_copy = capacity;
+
+ gc_root<string> new_str(allot_string_internal(capacity));
+
+ memcpy(new_str->data(),str->data(),to_copy);
+
+ if(str->aux != F)
+ {
+ byte_array *new_aux = allot_byte_array(capacity * sizeof(u16));
+
+ write_barrier(new_str.untagged());
+ new_str->aux = tag<byte_array>(new_aux);
+
+ byte_array *aux = untag<byte_array>(str->aux);
+ memcpy(new_aux->data<u16>(),aux->data<u16>(),to_copy * sizeof(u16));
+ }
+
+ fill_string(new_str.untagged(),to_copy,capacity,'\0');
+ return new_str.untagged();
+ }
+}
+
+PRIMITIVE(resize_string)
+{
+ string* str = untag_check<string>(dpop());
+ cell capacity = unbox_array_size();
+ dpush(tag<string>(reallot_string(str,capacity)));
+}
+
+PRIMITIVE(string_nth)
+{
+ string *str = untag<string>(dpop());
+ cell index = untag_fixnum(dpop());
+ dpush(tag_fixnum(string_nth(str,index)));
+}
+
+PRIMITIVE(set_string_nth_fast)
+{
+ string *str = untag<string>(dpop());
+ cell index = untag_fixnum(dpop());
+ cell value = untag_fixnum(dpop());
+ set_string_nth_fast(str,index,value);
+}
+
+PRIMITIVE(set_string_nth_slow)
+{
+ string *str = untag<string>(dpop());
+ cell index = untag_fixnum(dpop());
+ cell value = untag_fixnum(dpop());
+ set_string_nth_slow(str,index,value);
+}
+
+}
+++ /dev/null
-INLINE CELL string_capacity(F_STRING* str)
-{
- return untag_fixnum_fast(str->length);
-}
-
-INLINE CELL string_size(CELL size)
-{
- return sizeof(F_STRING) + size;
-}
-
-#define BREF(byte_array,index) ((CELL)byte_array + sizeof(F_BYTE_ARRAY) + (index))
-#define SREF(string,index) ((CELL)string + sizeof(F_STRING) + (index))
-
-INLINE F_STRING* untag_string(CELL tagged)
-{
- type_check(STRING_TYPE,tagged);
- return untag_object(tagged);
-}
-
-F_STRING* allot_string_internal(CELL capacity);
-F_STRING* allot_string(CELL capacity, CELL fill);
-void primitive_string(void);
-F_STRING *reallot_string(F_STRING *string, CELL capacity);
-void primitive_resize_string(void);
-
-F_STRING *memory_to_char_string(const char *string, CELL length);
-F_STRING *from_char_string(const char *c_string);
-DLLEXPORT void box_char_string(const char *c_string);
-
-F_STRING *memory_to_u16_string(const u16 *string, CELL length);
-F_STRING *from_u16_string(const u16 *c_string);
-DLLEXPORT void box_u16_string(const u16 *c_string);
-
-void char_string_to_memory(F_STRING *s, char *string);
-F_BYTE_ARRAY *string_to_char_alien(F_STRING *s, bool check);
-char* to_char_string(F_STRING *s, bool check);
-DLLEXPORT char *unbox_char_string(void);
-
-void u16_string_to_memory(F_STRING *s, u16 *string);
-F_BYTE_ARRAY *string_to_u16_alien(F_STRING *s, bool check);
-u16* to_u16_string(F_STRING *s, bool check);
-DLLEXPORT u16 *unbox_u16_string(void);
-
-/* String getters and setters */
-CELL string_nth(F_STRING* string, CELL index);
-void set_string_nth(F_STRING* string, CELL index, CELL value);
-
-void primitive_string_nth(void);
-void primitive_set_string_nth_slow(void);
-void primitive_set_string_nth_fast(void);
--- /dev/null
+namespace factor
+{
+
+inline static cell string_capacity(string *str)
+{
+ return untag_fixnum(str->length);
+}
+
+inline static cell string_size(cell size)
+{
+ 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);
+
+}
--- /dev/null
+namespace factor
+{
+
+template <typename T> cell tag(T *value)
+{
+ return RETAG(value,tag_for(T::type_number));
+}
+
+inline static cell tag_dynamic(object *value)
+{
+ return RETAG(value,tag_for(value->h.hi_tag()));
+}
+
+template <typename T>
+struct tagged
+{
+ cell value_;
+
+ cell value() const { return value_; }
+ T *untagged() const { return (T *)(UNTAG(value_)); }
+
+ cell type() const {
+ cell tag = TAG(value_);
+ if(tag == OBJECT_TYPE)
+ return untagged()->h.hi_tag();
+ else
+ return tag;
+ }
+
+ 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_);
+ return untagged();
+ }
+
+ explicit tagged(cell tagged) : value_(tagged) {
+#ifdef FACTOR_DEBUG
+ untag_check();
+#endif
+ }
+
+ explicit tagged(T *untagged) : value_(factor::tag(untagged)) {
+#ifdef FACTOR_DEBUG
+ untag_check();
+#endif
+ }
+
+ T *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; }
+
+ bool operator==(const tagged<T> &x) { return value_ == x.value_; }
+ bool operator!=(const tagged<T> &x) { return value_ != x.value_; }
+
+ template<typename X> tagged<X> as() { return tagged<X>(value_); }
+};
+
+template <typename T> T *untag_check(cell value)
+{
+ return tagged<T>(value).untag_check();
+}
+
+template <typename T> T *untag(cell value)
+{
+ return tagged<T>(value).untagged();
+}
+
+}
+++ /dev/null
-#include "master.h"
-
-/* push a new tuple on the stack */
-F_TUPLE *allot_tuple(F_TUPLE_LAYOUT *layout)
-{
- REGISTER_UNTAGGED(layout);
- F_TUPLE *tuple = allot_object(TUPLE_TYPE,tuple_size(layout));
- UNREGISTER_UNTAGGED(layout);
- tuple->layout = tag_array((F_ARRAY *)layout);
- return tuple;
-}
-
-void primitive_tuple(void)
-{
- F_TUPLE_LAYOUT *layout = untag_object(dpop());
- F_FIXNUM size = untag_fixnum_fast(layout->size);
-
- F_TUPLE *tuple = allot_tuple(layout);
- F_FIXNUM i;
- for(i = size - 1; i >= 0; i--)
- put(AREF(tuple,i),F);
-
- dpush(tag_tuple(tuple));
-}
-
-/* push a new tuple on the stack, filling its slots from the stack */
-void primitive_tuple_boa(void)
-{
- F_TUPLE_LAYOUT *layout = untag_object(dpop());
- F_FIXNUM size = untag_fixnum_fast(layout->size);
- F_TUPLE *tuple = allot_tuple(layout);
- memcpy(tuple + 1,(CELL *)(ds - CELLS * (size - 1)),CELLS * size);
- ds -= CELLS * size;
- dpush(tag_tuple(tuple));
-}
--- /dev/null
+#include "master.hpp"
+
+namespace factor
+{
+
+/* push a new tuple on the stack */
+tuple *allot_tuple(cell layout_)
+{
+ gc_root<tuple_layout> layout(layout_);
+ gc_root<tuple> t(allot<tuple>(tuple_size(layout.untagged())));
+ t->layout = layout.value();
+ return t.untagged();
+}
+
+PRIMITIVE(tuple)
+{
+ gc_root<tuple_layout> layout(dpop());
+ tuple *t = allot_tuple(layout.value());
+ fixnum i;
+ for(i = tuple_size(layout.untagged()) - 1; i >= 0; i--)
+ t->data()[i] = F;
+
+ dpush(tag<tuple>(t));
+}
+
+/* push a new tuple on the stack, filling its slots from the stack */
+PRIMITIVE(tuple_boa)
+{
+ gc_root<tuple_layout> layout(dpop());
+ gc_root<tuple> t(allot_tuple(layout.value()));
+ cell size = untag_fixnum(layout.untagged()->size) * sizeof(cell);
+ memcpy(t->data(),(cell *)(ds - (size - sizeof(cell))),size);
+ ds -= size;
+ dpush(t.value());
+}
+
+}
+++ /dev/null
-INLINE CELL tag_tuple(F_TUPLE *tuple)
-{
- return RETAG(tuple,TUPLE_TYPE);
-}
-
-INLINE CELL tuple_size(F_TUPLE_LAYOUT *layout)
-{
- CELL size = untag_fixnum_fast(layout->size);
- return sizeof(F_TUPLE) + size * CELLS;
-}
-
-INLINE CELL tuple_nth(F_TUPLE *tuple, CELL slot)
-{
- return get(AREF(tuple,slot));
-}
-
-INLINE void set_tuple_nth(F_TUPLE *tuple, CELL slot, CELL value)
-{
- put(AREF(tuple,slot),value);
- write_barrier((CELL)tuple);
-}
-
-void primitive_tuple(void);
-void primitive_tuple_boa(void);
-void primitive_tuple_layout(void);
--- /dev/null
+namespace factor
+{
+
+inline static cell tuple_size(tuple_layout *layout)
+{
+ cell size = untag_fixnum(layout->size);
+ return sizeof(tuple) + size * sizeof(cell);
+}
+
+PRIMITIVE(tuple);
+PRIMITIVE(tuple_boa);
+PRIMITIVE(tuple_layout);
+
+}
+++ /dev/null
-#include "master.h"
-
-/* If memory allocation fails, bail out */
-void *safe_malloc(size_t size)
-{
- void *ptr = malloc(size);
- if(!ptr) fatal_error("Out of memory in safe_malloc", 0);
- return ptr;
-}
-
-F_CHAR *safe_strdup(const F_CHAR *str)
-{
- F_CHAR *ptr = STRDUP(str);
- if(!ptr) fatal_error("Out of memory in safe_strdup", 0);
- return ptr;
-}
-
-/* We don't use printf directly, because format directives are not portable.
-Instead we define the common cases here. */
-void nl(void)
-{
- fputs("\n",stdout);
-}
-
-void print_string(const char *str)
-{
- fputs(str,stdout);
-}
-
-void print_cell(CELL x)
-{
- printf(CELL_FORMAT,x);
-}
-
-void print_cell_hex(CELL x)
-{
- printf(CELL_HEX_FORMAT,x);
-}
-
-void print_cell_hex_pad(CELL x)
-{
- printf(CELL_HEX_PAD_FORMAT,x);
-}
-
-void print_fixnum(F_FIXNUM x)
-{
- printf(FIXNUM_FORMAT,x);
-}
-
-CELL read_cell_hex(void)
-{
- CELL cell;
- if(scanf(CELL_HEX_FORMAT,&cell) < 0) exit(1);
- return cell;
-};
--- /dev/null
+#include "master.hpp"
+
+namespace factor
+{
+
+/* If memory allocation fails, bail out */
+void *safe_malloc(size_t size)
+{
+ void *ptr = malloc(size);
+ if(!ptr) fatal_error("Out of memory in safe_malloc", 0);
+ return ptr;
+}
+
+vm_char *safe_strdup(const vm_char *str)
+{
+ vm_char *ptr = STRDUP(str);
+ if(!ptr) fatal_error("Out of memory in safe_strdup", 0);
+ return ptr;
+}
+
+/* We don't use printf directly, because format directives are not portable.
+Instead we define the common cases here. */
+void nl(void)
+{
+ fputs("\n",stdout);
+}
+
+void print_string(const char *str)
+{
+ fputs(str,stdout);
+}
+
+void print_cell(cell x)
+{
+ printf(cell_FORMAT,x);
+}
+
+void print_cell_hex(cell x)
+{
+ printf(cell_HEX_FORMAT,x);
+}
+
+void print_cell_hex_pad(cell x)
+{
+ printf(cell_HEX_PAD_FORMAT,x);
+}
+
+void print_fixnum(fixnum x)
+{
+ printf(FIXNUM_FORMAT,x);
+}
+
+cell read_cell_hex(void)
+{
+ cell cell;
+ if(scanf(cell_HEX_FORMAT,&cell) < 0) exit(1);
+ return cell;
+};
+
+}
+++ /dev/null
-void *safe_malloc(size_t size);
-F_CHAR *safe_strdup(const F_CHAR *str);
-
-void nl(void);
-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(F_FIXNUM x);
-CELL read_cell_hex(void);
--- /dev/null
+namespace factor
+{
+
+void *safe_malloc(size_t size);
+vm_char *safe_strdup(const vm_char *str);
+
+void nl(void);
+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);
+
+}
+++ /dev/null
-#include "master.h"
-
-F_WORD *allot_word(CELL vocab, CELL name)
-{
- REGISTER_ROOT(vocab);
- REGISTER_ROOT(name);
- F_WORD *word = allot_object(WORD_TYPE,sizeof(F_WORD));
- UNREGISTER_ROOT(name);
- UNREGISTER_ROOT(vocab);
-
- word->hashcode = tag_fixnum((rand() << 16) ^ rand());
- word->vocabulary = vocab;
- word->name = name;
- word->def = userenv[UNDEFINED_ENV];
- word->props = F;
- word->counter = tag_fixnum(0);
- word->direct_entry_def = F;
- word->subprimitive = F;
- word->profiling = NULL;
- word->code = NULL;
-
- REGISTER_UNTAGGED(word);
- jit_compile_word(word,word->def,true);
- UNREGISTER_UNTAGGED(word);
-
- REGISTER_UNTAGGED(word);
- update_word_xt(word);
- UNREGISTER_UNTAGGED(word);
-
- if(profiling_p)
- relocate_code_block(word->profiling);
-
- return word;
-}
-
-/* <word> ( name vocabulary -- word ) */
-void primitive_word(void)
-{
- CELL vocab = dpop();
- CELL name = dpop();
- dpush(tag_object(allot_word(vocab,name)));
-}
-
-/* word-xt ( word -- start end ) */
-void primitive_word_xt(void)
-{
- F_WORD *word = untag_word(dpop());
- F_CODE_BLOCK *code = (profiling_p ? word->profiling : word->code);
- dpush(allot_cell((CELL)code + sizeof(F_CODE_BLOCK)));
- dpush(allot_cell((CELL)code + code->block.size));
-}
-
-/* Allocates memory */
-void update_word_xt(F_WORD *word)
-{
- if(profiling_p)
- {
- if(!word->profiling)
- {
- REGISTER_UNTAGGED(word);
- F_CODE_BLOCK *profiling = compile_profiling_stub(tag_object(word));
- UNREGISTER_UNTAGGED(word);
- word->profiling = profiling;
- }
-
- word->xt = (XT)(word->profiling + 1);
- }
- else
- word->xt = (XT)(word->code + 1);
-}
-
-void primitive_optimized_p(void)
-{
- drepl(tag_boolean(word_optimized_p(untag_word(dpeek()))));
-}
-
-void primitive_wrapper(void)
-{
- F_WRAPPER *wrapper = allot_object(WRAPPER_TYPE,sizeof(F_WRAPPER));
- wrapper->object = dpeek();
- drepl(tag_object(wrapper));
-}
--- /dev/null
+#include "master.hpp"
+
+namespace factor
+{
+
+word *allot_word(cell vocab_, cell name_)
+{
+ gc_root<object> vocab(vocab_);
+ gc_root<object> name(name_);
+
+ gc_root<word> new_word(allot<word>(sizeof(word)));
+
+ new_word->hashcode = tag_fixnum((rand() << 16) ^ rand());
+ new_word->vocabulary = vocab.value();
+ new_word->name = name.value();
+ new_word->def = userenv[UNDEFINED_ENV];
+ new_word->props = F;
+ new_word->counter = tag_fixnum(0);
+ new_word->direct_entry_def = F;
+ new_word->subprimitive = F;
+ new_word->profiling = NULL;
+ new_word->code = NULL;
+
+ jit_compile_word(new_word.value(),new_word->def,true);
+ update_word_xt(new_word.value());
+
+ if(profiling_p)
+ relocate_code_block(new_word->profiling);
+
+ return new_word.untagged();
+}
+
+/* <word> ( name vocabulary -- word ) */
+PRIMITIVE(word)
+{
+ cell vocab = dpop();
+ cell name = dpop();
+ dpush(tag<word>(allot_word(vocab,name)));
+}
+
+/* word-xt ( word -- start end ) */
+PRIMITIVE(word_xt)
+{
+ word *w = untag_check<word>(dpop());
+ code_block *code = (profiling_p ? w->profiling : w->code);
+ dpush(allot_cell((cell)code->xt()));
+ dpush(allot_cell((cell)code + code->block.size));
+}
+
+/* Allocates memory */
+void update_word_xt(cell w_)
+{
+ gc_root<word> w(w_);
+
+ if(profiling_p)
+ {
+ if(!w->profiling)
+ w->profiling = compile_profiling_stub(w.value());
+
+ w->xt = w->profiling->xt();
+ }
+ else
+ w->xt = w->code->xt();
+}
+
+PRIMITIVE(optimized_p)
+{
+ drepl(tag_boolean(word_optimized_p(untag_check<word>(dpeek()))));
+}
+
+PRIMITIVE(wrapper)
+{
+ wrapper *new_wrapper = allot<wrapper>(sizeof(wrapper));
+ new_wrapper->object = dpeek();
+ drepl(tag<wrapper>(new_wrapper));
+}
+
+}
+++ /dev/null
-DEFINE_UNTAG(F_WORD,WORD_TYPE,word)
-
-F_WORD *allot_word(CELL vocab, CELL name);
-
-void primitive_word(void);
-void primitive_word_xt(void);
-void update_word_xt(F_WORD *word);
-
-INLINE bool word_optimized_p(F_WORD *word)
-{
- return word->code->block.type == WORD_TYPE;
-}
-
-void primitive_optimized_p(void);
-
-void primitive_wrapper(void);
--- /dev/null
+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)
+{
+ return word->code->block.type == WORD_TYPE;
+}
+
+PRIMITIVE(optimized_p);
+
+PRIMITIVE(wrapper);
+
+}
--- /dev/null
+#include "master.hpp"
+
+using namespace factor;
+
+cell cards_offset;
+cell decks_offset;
+cell allot_markers_offset;
+++ /dev/null
-/* card marking write barrier. a card is a byte storing a mark flag,
-and the offset (in cells) of the first object in the card.
-
-the mark flag is set by the write barrier when an object in the
-card has a slot written to.
-
-the offset of the first object is set by the allocator. */
-
-/* if CARD_POINTS_TO_NURSERY is set, CARD_POINTS_TO_AGING must also be set. */
-#define CARD_POINTS_TO_NURSERY 0x80
-#define CARD_POINTS_TO_AGING 0x40
-#define CARD_MARK_MASK (CARD_POINTS_TO_NURSERY | CARD_POINTS_TO_AGING)
-typedef u8 F_CARD;
-
-#define CARD_BITS 8
-#define CARD_SIZE (1<<CARD_BITS)
-#define ADDR_CARD_MASK (CARD_SIZE-1)
-
-DLLEXPORT CELL cards_offset;
-
-#define ADDR_TO_CARD(a) (F_CARD*)(((CELL)(a) >> CARD_BITS) + cards_offset)
-#define CARD_TO_ADDR(c) (CELL*)(((CELL)(c) - cards_offset)<<CARD_BITS)
-
-typedef u8 F_DECK;
-
-#define DECK_BITS (CARD_BITS + 10)
-#define DECK_SIZE (1<<DECK_BITS)
-#define ADDR_DECK_MASK (DECK_SIZE-1)
-
-DLLEXPORT CELL decks_offset;
-
-#define ADDR_TO_DECK(a) (F_DECK*)(((CELL)(a) >> DECK_BITS) + decks_offset)
-#define DECK_TO_ADDR(c) (CELL*)(((CELL)(c) - decks_offset) << DECK_BITS)
-
-#define DECK_TO_CARD(d) (F_CARD*)((((CELL)(d) - decks_offset) << (DECK_BITS - CARD_BITS)) + cards_offset)
-
-#define ADDR_TO_ALLOT_MARKER(a) (F_CARD*)(((CELL)(a) >> CARD_BITS) + allot_markers_offset)
-#define CARD_OFFSET(c) (*((c) - (CELL)data_heap->cards + (CELL)data_heap->allot_markers))
-
-#define INVALID_ALLOT_MARKER 0xff
-
-DLLEXPORT CELL 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 write_barrier(CELL address)
-{
- *ADDR_TO_CARD(address) = CARD_MARK_MASK;
- *ADDR_TO_DECK(address) = CARD_MARK_MASK;
-}
-
-#define SLOT(obj,slot) (UNTAG(obj) + (slot) * CELLS)
-
-INLINE void set_slot(CELL obj, CELL slot, CELL value)
-{
- put(SLOT(obj,slot),value);
- write_barrier(obj);
-}
-
-/* we need to remember the first object allocated in the card */
-INLINE void allot_barrier(CELL address)
-{
- F_CARD *ptr = ADDR_TO_ALLOT_MARKER(address);
- if(*ptr == INVALID_ALLOT_MARKER)
- *ptr = (address & ADDR_CARD_MASK);
-}
--- /dev/null
+/* card marking write barrier. a card is a byte storing a mark flag,
+and the offset (in cells) of the first object in the card.
+
+the mark flag is set by the write barrier when an object in the
+card has a slot written to.
+
+the offset of the first object is set by the allocator. */
+
+namespace factor
+{
+
+/* if CARD_POINTS_TO_NURSERY is set, CARD_POINTS_TO_AGING must also be set. */
+#define CARD_POINTS_TO_NURSERY 0x80
+#define CARD_POINTS_TO_AGING 0x40
+#define CARD_MARK_MASK (CARD_POINTS_TO_NURSERY | CARD_POINTS_TO_AGING)
+typedef u8 card;
+
+#define CARD_BITS 8
+#define CARD_SIZE (1<<CARD_BITS)
+#define ADDR_CARD_MASK (CARD_SIZE-1)
+
+VM_C_API cell cards_offset;
+
+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;
+
+#define DECK_BITS (CARD_BITS + 10)
+#define DECK_SIZE (1<<DECK_BITS)
+#define ADDR_DECK_MASK (DECK_SIZE-1)
+
+VM_C_API cell decks_offset;
+
+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);
+}
+
+#define INVALID_ALLOT_MARKER 0xff
+
+VM_C_API 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