diff --git a/Makefile b/Makefile index 33d42217a2..18cb7d15c7 100755 --- a/Makefile +++ b/Makefile @@ -1,4 +1,5 @@ CC = gcc +CPP = g++ AR = ar LD = ld @@ -9,7 +10,7 @@ VERSION = 0.92 BUNDLE = Factor.app LIBPATH = -L/usr/X11R6/lib -CFLAGS = -Wall -Werror +CFLAGS = -Wall ifdef DEBUG CFLAGS += -g -DFACTOR_DEBUG @@ -35,6 +36,7 @@ DLL_OBJS = $(PLAF_DLL_OBJS) \ 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 \ @@ -45,6 +47,7 @@ DLL_OBJS = $(PLAF_DLL_OBJS) \ vm/inline_cache.o \ vm/io.o \ vm/jit.o \ + vm/local_roots.o \ vm/math.o \ vm/primitives.o \ vm/profiler.o \ @@ -53,7 +56,8 @@ DLL_OBJS = $(PLAF_DLL_OBJS) \ vm/strings.o \ vm/tuples.o \ vm/utilities.o \ - vm/words.o + vm/words.o \ + vm/write_barrier.o EXE_OBJS = $(PLAF_EXE_OBJS) @@ -161,12 +165,12 @@ macosx.app: factor $(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 @@ -174,7 +178,13 @@ $(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 @@ -185,10 +195,15 @@ vm/ffi_test.o: vm/ffi_test.c .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 +.PHONY: factor tags clean + +.SUFFIXES: .mm diff --git a/README.txt b/README.txt index c0d56dfa09..addbe38f0d 100755 --- a/README.txt +++ b/README.txt @@ -20,7 +20,7 @@ implementation. It is not an introduction to the language itself. * 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 @@ -138,7 +138,7 @@ usage documentation, enter the following in the UI listener: 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 diff --git a/basis/alien/arrays/arrays.factor b/basis/alien/arrays/arrays.factor index 6a182f8dbf..15e67bf0fe 100755 --- a/basis/alien/arrays/arrays.factor +++ b/basis/alien/arrays/arrays.factor @@ -1,7 +1,8 @@ -! 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 ; @@ -38,3 +39,61 @@ M: value-type c-type-getter 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 + diff --git a/basis/alien/c-types/c-types-docs.factor b/basis/alien/c-types/c-types-docs.factor index 46afc05e2d..c9c1ecd0e5 100644 --- a/basis/alien/c-types/c-types-docs.factor +++ b/basis/alien/c-types/c-types-docs.factor @@ -1,7 +1,7 @@ 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: { $values { "type" hashtable } } @@ -114,6 +114,38 @@ HELP: define-out { $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 diff --git a/basis/alien/c-types/c-types.factor b/basis/alien/c-types/c-types.factor index dc35f8bbb0..9cd57f61ab 100755 --- a/basis/alien/c-types/c-types.factor +++ b/basis/alien/c-types/c-types.factor @@ -2,9 +2,10 @@ ! 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: @@ -213,6 +214,15 @@ M: f byte-length drop 0 ; : 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 + swap memory>byte-array + ] [ [ + ] change-index drop ] 2bi ; + : byte-array>memory ( byte-array base -- ) swap dup byte-length memcpy ; diff --git a/basis/alien/libraries/libraries.factor b/basis/alien/libraries/libraries.factor index 3fcc15974c..6c18065ab6 100644 --- a/basis/alien/libraries/libraries.factor +++ b/basis/alien/libraries/libraries.factor @@ -1,8 +1,12 @@ ! 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 @@ -18,4 +22,4 @@ TUPLE: library path abi dll ; library dup [ dll>> ] when ; : add-library ( name path abi -- ) - swap libraries get set-at ; + swap libraries get set-at ; \ No newline at end of file diff --git a/basis/alien/strings/strings-docs.factor b/basis/alien/strings/strings-docs.factor deleted file mode 100644 index 19c29e613e..0000000000 --- a/basis/alien/strings/strings-docs.factor +++ /dev/null @@ -1,52 +0,0 @@ -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" diff --git a/basis/alien/strings/strings.factor b/basis/alien/strings/strings.factor deleted file mode 100644 index e9053cd5c1..0000000000 --- a/basis/alien/strings/strings.factor +++ /dev/null @@ -1,109 +0,0 @@ -! 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 - [ ] [ ] 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 - - [ 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 diff --git a/basis/alien/strings/unix/summary.txt b/basis/alien/strings/unix/summary.txt deleted file mode 100644 index 27e7f4cfb1..0000000000 --- a/basis/alien/strings/unix/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Default string encoding on Unix diff --git a/basis/alien/strings/unix/unix.factor b/basis/alien/strings/unix/unix.factor deleted file mode 100644 index a7b1467344..0000000000 --- a/basis/alien/strings/unix/unix.factor +++ /dev/null @@ -1,8 +0,0 @@ -! 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 ; diff --git a/basis/alien/strings/windows/summary.txt b/basis/alien/strings/windows/summary.txt deleted file mode 100644 index 42bffbb300..0000000000 --- a/basis/alien/strings/windows/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Default string encoding on Windows diff --git a/basis/alien/strings/windows/tags.txt b/basis/alien/strings/windows/tags.txt deleted file mode 100644 index 6bf68304bb..0000000000 --- a/basis/alien/strings/windows/tags.txt +++ /dev/null @@ -1 +0,0 @@ -unportable diff --git a/basis/alien/strings/windows/windows.factor b/basis/alien/strings/windows/windows.factor deleted file mode 100644 index 55c69246de..0000000000 --- a/basis/alien/strings/windows/windows.factor +++ /dev/null @@ -1,13 +0,0 @@ -! 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 diff --git a/basis/bootstrap/stage2.factor b/basis/bootstrap/stage2.factor index 14c08c070a..9d19e4a231 100644 --- a/basis/bootstrap/stage2.factor +++ b/basis/bootstrap/stage2.factor @@ -65,7 +65,6 @@ SYMBOL: bootstrap-time "stage2: deployment mode" print ] [ "debugger" require - "alien.prettyprint" require "inspector" require "tools.errors" require "listener" require diff --git a/basis/bootstrap/tools/tools.factor b/basis/bootstrap/tools/tools.factor index cb0792ee1e..6017469925 100644 --- a/basis/bootstrap/tools/tools.factor +++ b/basis/bootstrap/tools/tools.factor @@ -14,7 +14,8 @@ IN: bootstrap.tools "tools.test" "tools.time" "tools.threads" - "tools.vocabs" - "tools.vocabs.monitor" + "vocabs.hierarchy" + "vocabs.refresh" + "vocabs.refresh.monitor" "editors" } [ require ] each diff --git a/basis/command-line/command-line.factor b/basis/command-line/command-line.factor index 56d7fbd207..f2da4ebdf5 100644 --- a/basis/command-line/command-line.factor +++ b/basis/command-line/command-line.factor @@ -1,14 +1,14 @@ -! 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 diff --git a/basis/compiler/tests/simple.factor b/basis/compiler/tests/simple.factor index 88dc9a53b1..da021412fe 100644 --- a/basis/compiler/tests/simple.factor +++ b/basis/compiler/tests/simple.factor @@ -60,8 +60,8 @@ IN: compiler.tests.simple ! 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 diff --git a/basis/debugger/debugger.factor b/basis/debugger/debugger.factor index 2091a26133..bb0268f048 100644 --- a/basis/debugger/debugger.factor +++ b/basis/debugger/debugger.factor @@ -1,14 +1,13 @@ ! 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 @@ -17,6 +16,7 @@ GENERIC: error. ( error -- ) GENERIC: error-help ( error -- topic ) M: object error. . ; + M: object error-help drop f ; M: tuple error-help class ; @@ -77,7 +77,7 @@ M: string error. print ; "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 @@ -98,9 +98,7 @@ HOOK: signal-error. os ( obj -- ) "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 ; diff --git a/basis/editors/editors.factor b/basis/editors/editors.factor index 6088400bd8..d5b4b909e3 100644 --- a/basis/editors/editors.factor +++ b/basis/editors/editors.factor @@ -1,10 +1,10 @@ ! Copyright (C) 2005, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: parser lexer kernel namespaces sequences definitions io.files -io.backend io.pathnames io summary continuations tools.crossref -tools.vocabs prettyprint source-files source-files.errors assocs -vocabs vocabs.loader splitting accessors debugger prettyprint -help.topics ; +USING: parser lexer kernel namespaces sequences definitions +io.files io.backend io.pathnames io summary continuations +tools.crossref vocabs.hierarchy prettyprint source-files +source-files.errors assocs vocabs vocabs.loader splitting +accessors debugger prettyprint help.topics ; IN: editors TUPLE: no-edit-hook ; diff --git a/basis/formatting/formatting.factor b/basis/formatting/formatting.factor index ac0b0850b4..5a517e4ac4 100644 --- a/basis/formatting/formatting.factor +++ b/basis/formatting/formatting.factor @@ -4,7 +4,7 @@ USING: accessors arrays ascii assocs calendar combinators fry kernel generalizations io io.encodings.ascii io.files io.streams.string macros math math.functions math.parser peg.ebnf quotations -sequences splitting strings unicode.case vectors ; +sequences splitting strings unicode.case vectors combinators.smart ; IN: formatting @@ -113,7 +113,6 @@ MACRO: printf ( format-string -- ) : sprintf ( format-string -- result ) [ printf ] with-string-writer ; inline - string 2 CHAR: 0 pad-head ; inline @@ -129,12 +128,15 @@ MACRO: printf ( format-string -- ) [ pad-00 ] map "/" join ; inline : >datetime ( timestamp -- string ) - { [ day-of-week day-abbreviation3 ] - [ month>> month-abbreviation ] - [ day>> pad-00 ] - [ >time ] - [ year>> number>string ] - } cleave 5 narray " " join ; inline + [ + { + [ day-of-week day-abbreviation3 ] + [ month>> month-abbreviation ] + [ day>> pad-00 ] + [ >time ] + [ year>> number>string ] + } cleave + ] output>array " " join ; inline : (week-of-year) ( timestamp day -- n ) [ dup clone 1 >>month 1 >>day day-of-week dup ] dip > [ 7 swap - ] when @@ -187,5 +189,3 @@ PRIVATE> MACRO: strftime ( format-string -- ) parse-strftime [ length ] keep [ ] join '[ _ @ reverse concat nip ] ; - - diff --git a/basis/help/apropos/apropos.factor b/basis/help/apropos/apropos.factor index b241db4c0e..63cbcb3f1e 100644 --- a/basis/help/apropos/apropos.factor +++ b/basis/help/apropos/apropos.factor @@ -1,8 +1,8 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays assocs fry help.markup help.topics io kernel make math math.parser namespaces sequences sorting -summary tools.completion tools.vocabs help.vocabs +summary tools.completion vocabs.hierarchy help.vocabs vocabs words unicode.case help ; IN: help.apropos diff --git a/basis/help/handbook/handbook.factor b/basis/help/handbook/handbook.factor index 262c46bbc3..b83fb22ccf 100644 --- a/basis/help/handbook/handbook.factor +++ b/basis/help/handbook/handbook.factor @@ -281,7 +281,7 @@ ARTICLE: "handbook-tools-reference" "Developer tools" { $heading "Workflow" } { $subsection "listener" } { $subsection "editor" } -{ $subsection "tools.vocabs" } +{ $subsection "vocabs.refresh" } { $subsection "tools.test" } { $subsection "help" } { $heading "Debugging" } @@ -292,6 +292,7 @@ ARTICLE: "handbook-tools-reference" "Developer tools" { $heading "Browsing" } { $subsection "see" } { $subsection "tools.crossref" } +{ $subsection "vocabs.hierarchy" } { $heading "Performance" } { $subsection "timing" } { $subsection "profiling" } diff --git a/basis/help/html/html.factor b/basis/help/html/html.factor index f4a8742486..348fcbbbfb 100644 --- a/basis/help/html/html.factor +++ b/basis/help/html/html.factor @@ -3,7 +3,7 @@ USING: io.encodings.utf8 io.encodings.ascii io.encodings.binary io.files io.files.temp io.directories html.streams help kernel assocs sequences make words accessors arrays help.topics vocabs -tools.vocabs help.vocabs namespaces prettyprint io +vocabs.hierarchy help.vocabs namespaces prettyprint io vocabs.loader serialize fry memoize ascii unicode.case math.order sorting debugger html xml.syntax xml.writer math.parser ; IN: help.html diff --git a/basis/help/lint/lint.factor b/basis/help/lint/lint.factor index 42f29bc8b7..f25d5f0f93 100755 --- a/basis/help/lint/lint.factor +++ b/basis/help/lint/lint.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: assocs continuations fry help help.lint.checks help.topics io kernel namespaces parser sequences -source-files.errors tools.vocabs vocabs words classes +source-files.errors vocabs.hierarchy vocabs words classes locals tools.errors ; FROM: help.lint.checks => all-vocabs ; IN: help.lint diff --git a/basis/help/tutorial/tutorial.factor b/basis/help/tutorial/tutorial.factor index 2ed18b7cd5..7686022b70 100644 --- a/basis/help/tutorial/tutorial.factor +++ b/basis/help/tutorial/tutorial.factor @@ -1,6 +1,6 @@ USING: help.markup help.syntax ui.commands ui.operations editors vocabs.loader kernel sequences prettyprint tools.test -tools.vocabs strings unicode.categories unicode.case +vocabs.refresh strings unicode.categories unicode.case ui.tools.browser ui.tools.common ; IN: help.tutorial diff --git a/basis/help/vocabs/vocabs.factor b/basis/help/vocabs/vocabs.factor index a8c93feee4..b23143e572 100644 --- a/basis/help/vocabs/vocabs.factor +++ b/basis/help/vocabs/vocabs.factor @@ -6,7 +6,8 @@ classes.singleton classes.tuple classes.union combinators definitions effects fry generic help help.markup help.stylesheet help.topics io io.files io.pathnames io.styles kernel macros make namespaces prettyprint sequences sets sorting summary -tools.vocabs vocabs vocabs.loader words words.symbol definitions.icons ; +vocabs vocabs.files vocabs.hierarchy vocabs.loader +vocabs.metadata words words.symbol definitions.icons ; IN: help.vocabs : about ( vocab -- ) diff --git a/basis/http/server/server-docs.factor b/basis/http/server/server-docs.factor index 29f61416fa..daf0305972 100644 --- a/basis/http/server/server-docs.factor +++ b/basis/http/server/server-docs.factor @@ -1,4 +1,4 @@ -USING: help.markup help.syntax io.streams.string quotations strings urls http tools.vocabs math io.servers.connection ; +USING: help.markup help.syntax io.streams.string quotations strings urls http vocabs.refresh math io.servers.connection ; IN: http.server HELP: trivial-responder diff --git a/basis/http/server/server.factor b/basis/http/server/server.factor index 8b22b9a885..3beb730499 100755 --- a/basis/http/server/server.factor +++ b/basis/http/server/server.factor @@ -1,8 +1,8 @@ -! Copyright (C) 2003, 2008 Slava Pestov. +! Copyright (C) 2003, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel accessors sequences arrays namespaces splitting vocabs.loader destructors assocs debugger continuations -combinators tools.vocabs tools.time math math.parser present +combinators vocabs.refresh tools.time math math.parser present io vectors io.sockets io.sockets.secure diff --git a/basis/io/encodings/iana/iana.factor b/basis/io/encodings/iana/iana.factor index 899bedfbc6..594e245a9c 100644 --- a/basis/io/encodings/iana/iana.factor +++ b/basis/io/encodings/iana/iana.factor @@ -2,7 +2,7 @@ ! 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 n-table [ initial-e>n ] initialize ] [ 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 diff --git a/basis/json/reader/reader.factor b/basis/json/reader/reader.factor index 0014ba1eb1..887a7a50e5 100644 --- a/basis/json/reader/reader.factor +++ b/basis/json/reader/reader.factor @@ -1,6 +1,6 @@ ! 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 diff --git a/basis/literals/literals-tests.factor b/basis/literals/literals-tests.factor index 024c94e4f2..29072f1299 100644 --- a/basis/literals/literals-tests.factor +++ b/basis/literals/literals-tests.factor @@ -19,3 +19,9 @@ IN: literals.tests [ { 0.5 2.0 } ] [ { $[ 1.0 2.0 / ] 2.0 } ] unit-test [ { 1.0 { 0.5 1.5 } 4.0 } ] [ { 1.0 { $[ 1.0 2.0 / ] 1.5 } $[ 2.0 2.0 * ] } ] unit-test + +<< +CONSTANT: constant-a 3 +>> + +[ { 3 10 "ftw" } ] [ ${ constant-a 10 "ftw" } ] unit-test diff --git a/basis/literals/literals.factor b/basis/literals/literals.factor index e55d78ab6e..7c7592dda8 100644 --- a/basis/literals/literals.factor +++ b/basis/literals/literals.factor @@ -1,6 +1,8 @@ ! (c) Joe Groff, see license for details -USING: accessors continuations kernel parser words quotations vectors ; +USING: accessors continuations kernel parser words quotations +combinators.smart vectors sequences ; IN: literals SYNTAX: $ scan-word [ def>> call ] curry with-datastack >vector ; SYNTAX: $[ parse-quotation with-datastack >vector ; +SYNTAX: ${ \ } [ [ ?execute ] { } map-as ] parse-literal ; diff --git a/basis/present/present-tests.factor b/basis/present/present-tests.factor index 22d352cb5a..559b9ac01d 100644 --- a/basis/present/present-tests.factor +++ b/basis/present/present-tests.factor @@ -1,5 +1,5 @@ IN: present.tests -USING: tools.test present math vocabs tools.vocabs sequences kernel ; +USING: tools.test present math vocabs sequences kernel ; [ "3" ] [ 3 present ] unit-test [ "Hi" ] [ "Hi" present ] unit-test diff --git a/basis/prettyprint/backend/backend.factor b/basis/prettyprint/backend/backend.factor index 1976c84fd1..3dcd7fb0ed 100644 --- a/basis/prettyprint/backend/backend.factor +++ b/basis/prettyprint/backend/backend.factor @@ -1,11 +1,10 @@ -! 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 ; @@ -135,8 +134,8 @@ M: pathname pprint* [ text ] [ f ] bi* \ } pprint-word block> ; -M: tuple pprint* - boa-tuples? get [ call-next-method ] [ +: pprint-tuple ( tuple -- ) + boa-tuples? get [ pprint-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 ; @@ -202,6 +206,7 @@ M: object pprint-object ( obj -- ) 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 ; diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor index 4a9ff93179..f6f94bf20d 100644 --- a/basis/stack-checker/known-words/known-words.factor +++ b/basis/stack-checker/known-words/known-words.factor @@ -1,16 +1,16 @@ ! 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 @@ -290,11 +290,11 @@ M: object infer-call* \ 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 @@ -465,9 +465,9 @@ M: object infer-call* \ 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 @@ -481,9 +481,9 @@ M: object infer-call* \ 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 @@ -598,7 +598,7 @@ M: object infer-call* \ die { } { } define-primitive -\ fopen { string string } { alien } define-primitive +\ (fopen) { byte-array byte-array } { alien } define-primitive \ fgetc { alien } { object } define-primitive diff --git a/basis/tools/completion/completion.factor b/basis/tools/completion/completion.factor index 99def097a2..00d86a1608 100644 --- a/basis/tools/completion/completion.factor +++ b/basis/tools/completion/completion.factor @@ -1,9 +1,9 @@ ! Copyright (C) 2005, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors kernel arrays sequences math namespaces -strings io fry vectors words assocs combinators sorting -unicode.case unicode.categories math.order vocabs -tools.vocabs unicode.data locals ; +USING: accessors kernel arrays sequences math namespaces strings io +fry vectors words assocs combinators sorting unicode.case +unicode.categories math.order vocabs vocabs.hierarchy unicode.data +locals ; IN: tools.completion :: (fuzzy) ( accum i full ch -- accum i full ? ) diff --git a/basis/tools/deploy/config/editor/editor.factor b/basis/tools/deploy/config/editor/editor.factor index ac89e3290b..78d86a4707 100644 --- a/basis/tools/deploy/config/editor/editor.factor +++ b/basis/tools/deploy/config/editor/editor.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: assocs io.pathnames kernel parser prettyprint sequences -splitting tools.deploy.config tools.vocabs vocabs.loader ; +splitting tools.deploy.config vocabs.loader vocabs.metadata ; IN: tools.deploy.config.editor : deploy-config-path ( vocab -- string ) diff --git a/basis/tools/deploy/shaker/shaker.factor b/basis/tools/deploy/shaker/shaker.factor index 9b02d3208f..fd43d1ccc9 100755 --- a/basis/tools/deploy/shaker/shaker.factor +++ b/basis/tools/deploy/shaker/shaker.factor @@ -37,7 +37,7 @@ IN: tools.deploy.shaker ] when strip-dictionary? [ "compiler.units" init-hooks get delete-at - "tools.vocabs" init-hooks get delete-at + "vocabs.cache" init-hooks get delete-at ] when ; : strip-debugger ( -- ) diff --git a/basis/tools/test/test.factor b/basis/tools/test/test.factor index c0c2f1892d..3dc7b8740b 100644 --- a/basis/tools/test/test.factor +++ b/basis/tools/test/test.factor @@ -4,9 +4,9 @@ USING: accessors arrays assocs combinators compiler.units continuations debugger effects fry generalizations io io.files io.styles kernel lexer locals macros math.parser namespaces parser prettyprint quotations sequences source-files splitting -stack-checker summary unicode.case vectors vocabs vocabs.loader words -tools.vocabs tools.errors source-files.errors io.streams.string make -compiler.errors ; +stack-checker summary unicode.case vectors vocabs vocabs.loader +vocabs.files words tools.errors source-files.errors +io.streams.string make compiler.errors ; IN: tools.test TUPLE: test-failure < source-file-error continuation ; diff --git a/basis/tools/vocabs/summary.txt b/basis/tools/vocabs/summary.txt deleted file mode 100644 index 1ae5f43784..0000000000 --- a/basis/tools/vocabs/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Reloading vocabularies and cross-referencing vocabularies diff --git a/basis/tools/vocabs/vocabs-docs.factor b/basis/tools/vocabs/vocabs-docs.factor deleted file mode 100644 index 33f197d0ea..0000000000 --- a/basis/tools/vocabs/vocabs-docs.factor +++ /dev/null @@ -1,75 +0,0 @@ -USING: help.markup help.syntax strings ; -IN: tools.vocabs - -ARTICLE: "tools.vocabs" "Vocabulary tools" -"Reloading source files changed on disk:" -{ $subsection refresh } -{ $subsection refresh-all } -"Vocabulary summaries:" -{ $subsection vocab-summary } -{ $subsection set-vocab-summary } -"Vocabulary tags:" -{ $subsection vocab-tags } -{ $subsection set-vocab-tags } -{ $subsection add-vocab-tags } -"Getting and setting vocabulary meta-data:" -{ $subsection vocab-file-contents } -{ $subsection set-vocab-file-contents } -"Global meta-data:" -{ $subsection all-vocabs } -{ $subsection all-vocabs-seq } -{ $subsection all-tags } -{ $subsection all-authors } -"Because loading the above data is expensive, it is cached. The cache is flushed by the " { $vocab-link "tools.vocabs.monitor" } " vocabulary. It can also be flushed manually when file system change monitors are not available:" -{ $subsection reset-cache } ; - -ABOUT: "tools.vocabs" - -HELP: vocab-files -{ $values { "vocab" "a vocabulary specifier" } { "seq" "a sequence of pathname strings" } } -{ $description "Outputs a sequence of files comprising this vocabulary, or " { $link f } " if the vocabulary does not have a directory on disk." } ; - -HELP: vocab-tests -{ $values { "vocab" "a vocabulary specifier" } { "tests" "a sequence of pathname strings" } } -{ $description "Outputs a sequence of pathnames where the unit tests for " { $snippet "vocab" } " are located." } ; - -HELP: source-modified? -{ $values { "path" "a pathname string" } { "?" "a boolean" } } -{ $description "Tests if the source file has been modified since it was last loaded. This compares the file's CRC32 checksum of the file's contents against the previously-recorded value." } ; - -HELP: refresh -{ $values { "prefix" string } } -{ $description "Reloads source files and documentation belonging to loaded vocabularies whose names are prefixed by " { $snippet "prefix" } " which have been modified on disk." } ; - -HELP: refresh-all -{ $description "Reloads source files and documentation for all loaded vocabularies which have been modified on disk." } ; - -{ refresh refresh-all } related-words - -HELP: vocab-file-contents -{ $values { "vocab" "a vocabulary specifier" } { "name" string } { "seq" "a sequence of lines, or " { $link f } } } -{ $description "Outputs the contents of the file named " { $snippet "name" } " from the vocabulary's directory, or " { $link f } " if the file does not exist." } ; - -HELP: set-vocab-file-contents -{ $values { "seq" "a sequence of lines" } { "vocab" "a vocabulary specifier" } { "name" string } } -{ $description "Stores a sequence of lines to the file named " { $snippet "name" } " from the vocabulary's directory." } ; - -HELP: vocab-summary -{ $values { "vocab" "a vocabulary specifier" } { "summary" "a string or " { $link f } } } -{ $description "Outputs a one-line string description of the vocabulary's intended purpose from the " { $snippet "summary.txt" } " file in the vocabulary's directory. Outputs " { $link f } " if the file does not exist." } ; - -HELP: set-vocab-summary -{ $values { "string" "a string or " { $link f } } { "vocab" "a vocabulary specifier" } } -{ $description "Stores a one-line string description of the vocabulary to the " { $snippet "summary.txt" } " file in the vocabulary's directory." } ; - -HELP: vocab-tags -{ $values { "vocab" "a vocabulary specifier" } { "tags" "a sequence of strings" } } -{ $description "Outputs a list of short tags classifying the vocabulary from the " { $snippet "tags.txt" } " file in the vocabulary's directory. Outputs " { $link f } " if the file does not exist." } ; - -HELP: set-vocab-tags -{ $values { "tags" "a sequence of strings" } { "vocab" "a vocabulary specifier" } } -{ $description "Stores a list of short tags classifying the vocabulary to the " { $snippet "tags.txt" } " file in the vocabulary's directory." } ; - -HELP: all-vocabs -{ $values { "assoc" "an association list mapping vocabulary roots to sequences of vocabulary specifiers" } } -{ $description "Outputs an association list of all vocabularies which have been loaded or are available for loading." } ; diff --git a/basis/tools/vocabs/vocabs-tests.factor b/basis/tools/vocabs/vocabs-tests.factor deleted file mode 100644 index 04e628d080..0000000000 --- a/basis/tools/vocabs/vocabs-tests.factor +++ /dev/null @@ -1,9 +0,0 @@ -IN: tools.vocabs.tests -USING: tools.test tools.vocabs namespaces continuations ; - -[ ] [ - changed-vocabs get-global - f changed-vocabs set-global - [ t ] [ "kernel" changed-vocab? ] unit-test - [ "kernel" changed-vocab ] [ changed-vocabs set-global ] [ ] cleanup -] unit-test diff --git a/basis/tools/vocabs/vocabs.factor b/basis/tools/vocabs/vocabs.factor deleted file mode 100644 index 4b9a72a443..0000000000 --- a/basis/tools/vocabs/vocabs.factor +++ /dev/null @@ -1,296 +0,0 @@ -! Copyright (C) 2007, 2008 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: kernel io io.styles io.files io.files.info io.directories -io.pathnames io.encodings.utf8 vocabs.loader vocabs sequences -namespaces make math.parser arrays hashtables assocs memoize -summary sorting splitting combinators source-files debugger -continuations compiler.errors init checksums checksums.crc32 -sets accessors generic definitions words ; -IN: tools.vocabs - -: vocab-tests-file ( vocab -- path ) - dup "-tests.factor" vocab-dir+ vocab-append-path dup - [ dup exists? [ drop f ] unless ] [ drop f ] if ; - -: vocab-tests-dir ( vocab -- paths ) - dup vocab-dir "tests" append-path vocab-append-path dup [ - dup exists? [ - dup directory-files [ ".factor" tail? ] filter - [ append-path ] with map - ] [ drop f ] if - ] [ drop f ] if ; - -: vocab-tests ( vocab -- tests ) - [ - [ vocab-tests-file [ , ] when* ] - [ vocab-tests-dir [ % ] when* ] bi - ] { } make ; - -: vocab-files ( vocab -- seq ) - [ - [ vocab-source-path [ , ] when* ] - [ vocab-docs-path [ , ] when* ] - [ vocab-tests % ] tri - ] { } make ; - -: vocab-heading. ( vocab -- ) - nl - "==== " write - [ vocab-name ] [ vocab write-object ] bi ":" print - nl ; - -: load-error. ( triple -- ) - [ first vocab-heading. ] [ second print-error ] bi ; - -: load-failures. ( failures -- ) - [ load-error. nl ] each ; - -SYMBOL: failures - -: require-all ( vocabs -- failures ) - [ - V{ } clone blacklist set - V{ } clone failures set - [ - [ require ] - [ swap vocab-name failures get set-at ] - recover - ] each - failures get - ] with-scope ; - -: source-modified? ( path -- ? ) - dup source-files get at [ - dup path>> - dup exists? [ - utf8 file-lines crc32 checksum-lines - swap checksum>> = not - ] [ - 2drop f - ] if - ] [ - exists? - ] ?if ; - -SYMBOL: changed-vocabs - -: changed-vocab ( vocab -- ) - dup vocab changed-vocabs get and - [ dup changed-vocabs get set-at ] [ drop ] if ; - -: unchanged-vocab ( vocab -- ) - changed-vocabs get delete-at ; - -: unchanged-vocabs ( vocabs -- ) - [ unchanged-vocab ] each ; - -: changed-vocab? ( vocab -- ? ) - changed-vocabs get dup [ key? ] [ 2drop t ] if ; - -: filter-changed ( vocabs -- vocabs' ) - [ changed-vocab? ] filter ; - -SYMBOL: modified-sources -SYMBOL: modified-docs - -: (to-refresh) ( vocab variable loaded? path -- ) - dup [ - swap [ - pick changed-vocab? [ - source-modified? [ get push ] [ 2drop ] if - ] [ 3drop ] if - ] [ drop get push ] if - ] [ 2drop 2drop ] if ; - -: to-refresh ( prefix -- modified-sources modified-docs unchanged ) - [ - V{ } clone modified-sources set - V{ } clone modified-docs set - - child-vocabs [ - [ - [ - [ modified-sources ] - [ vocab source-loaded?>> ] - [ vocab-source-path ] - tri (to-refresh) - ] [ - [ modified-docs ] - [ vocab docs-loaded?>> ] - [ vocab-docs-path ] - tri (to-refresh) - ] bi - ] each - - modified-sources get - modified-docs get - ] - [ modified-docs get modified-sources get append diff ] bi - ] with-scope ; - -: do-refresh ( modified-sources modified-docs unchanged -- ) - unchanged-vocabs - [ - [ [ vocab f >>source-loaded? drop ] each ] - [ [ vocab f >>docs-loaded? drop ] each ] bi* - ] - [ - append prune - [ unchanged-vocabs ] - [ require-all load-failures. ] bi - ] 2bi ; - -: refresh ( prefix -- ) to-refresh do-refresh ; - -: refresh-all ( -- ) "" refresh ; - -MEMO: vocab-file-contents ( vocab name -- seq ) - vocab-append-path dup - [ dup exists? [ utf8 file-lines ] [ drop f ] if ] when ; - -: set-vocab-file-contents ( seq vocab name -- ) - dupd vocab-append-path [ - utf8 set-file-lines - \ vocab-file-contents reset-memoized - ] [ - "The " swap vocab-name - " vocabulary was not loaded from the file system" - 3append throw - ] ?if ; - -: vocab-summary-path ( vocab -- string ) - vocab-dir "summary.txt" append-path ; - -: vocab-summary ( vocab -- summary ) - dup dup vocab-summary-path vocab-file-contents - [ - vocab-name " vocabulary" append - ] [ - nip first - ] if-empty ; - -M: vocab summary - [ - dup vocab-summary % - " (" % - words>> assoc-size # - " words)" % - ] "" make ; - -M: vocab-link summary vocab-summary ; - -: set-vocab-summary ( string vocab -- ) - [ 1array ] dip - dup vocab-summary-path - set-vocab-file-contents ; - -: vocab-tags-path ( vocab -- string ) - vocab-dir "tags.txt" append-path ; - -: vocab-tags ( vocab -- tags ) - dup vocab-tags-path vocab-file-contents harvest ; - -: set-vocab-tags ( tags vocab -- ) - dup vocab-tags-path set-vocab-file-contents ; - -: add-vocab-tags ( tags vocab -- ) - [ vocab-tags append prune ] keep set-vocab-tags ; - -: vocab-authors-path ( vocab -- string ) - vocab-dir "authors.txt" append-path ; - -: vocab-authors ( vocab -- authors ) - dup vocab-authors-path vocab-file-contents harvest ; - -: set-vocab-authors ( authors vocab -- ) - dup vocab-authors-path set-vocab-file-contents ; - -: subdirs ( dir -- dirs ) - [ - [ link-info directory? ] filter - ] with-directory-files natural-sort ; - -: (all-child-vocabs) ( root name -- vocabs ) - [ - vocab-dir append-path dup exists? - [ subdirs ] [ drop { } ] if - ] keep [ - swap [ "." glue ] with map - ] unless-empty ; - -: vocab-dir? ( root name -- ? ) - over - [ ".factor" vocab-dir+ append-path exists? ] - [ 2drop f ] - if ; - -: vocabs-in-dir ( root name -- ) - dupd (all-child-vocabs) [ - 2dup vocab-dir? [ dup >vocab-link , ] when - vocabs-in-dir - ] with each ; - -: all-vocabs ( -- assoc ) - vocab-roots get [ - dup [ "" vocabs-in-dir ] { } make - ] { } map>assoc ; - -MEMO: all-vocabs-seq ( -- seq ) - all-vocabs values concat ; - -: unportable? ( name -- ? ) - vocab-tags "unportable" swap member? ; - -: filter-unportable ( seq -- seq' ) - [ vocab-name unportable? not ] filter ; - -: try-everything ( -- failures ) - all-vocabs-seq - filter-unportable - require-all ; - -: load-everything ( -- ) - try-everything load-failures. ; - -: unrooted-child-vocabs ( prefix -- seq ) - dup empty? [ CHAR: . suffix ] unless - vocabs - [ find-vocab-root not ] filter - [ - vocab-name swap ?head CHAR: . rot member? not and - ] with filter - [ vocab ] map ; - -: all-child-vocabs ( prefix -- assoc ) - vocab-roots get [ - dup pick (all-child-vocabs) [ >vocab-link ] map - ] { } map>assoc - swap unrooted-child-vocabs f swap 2array suffix ; - -: all-child-vocabs-seq ( prefix -- assoc ) - vocab-roots get swap [ - dupd (all-child-vocabs) - [ vocab-dir? ] with filter - ] curry map concat ; - -MEMO: all-tags ( -- seq ) - all-vocabs-seq [ vocab-tags ] gather natural-sort ; - -MEMO: all-authors ( -- seq ) - all-vocabs-seq [ vocab-authors ] gather natural-sort ; - -: reset-cache ( -- ) - root-cache get-global clear-assoc - \ vocab-file-contents reset-memoized - \ all-vocabs-seq reset-memoized - \ all-authors reset-memoized - \ all-tags reset-memoized ; - -SINGLETON: cache-observer - -M: cache-observer vocabs-changed drop reset-cache ; - -[ - f changed-vocabs set-global - cache-observer add-vocab-observer -] "tools.vocabs" add-init-hook \ No newline at end of file diff --git a/basis/ui/backend/cocoa/tools/tools.factor b/basis/ui/backend/cocoa/tools/tools.factor index eb8823b107..cf5493f33d 100644 --- a/basis/ui/backend/cocoa/tools/tools.factor +++ b/basis/ui/backend/cocoa/tools/tools.factor @@ -4,7 +4,8 @@ USING: alien.syntax cocoa cocoa.nibs cocoa.application cocoa.classes cocoa.dialogs cocoa.pasteboard cocoa.subclassing core-foundation core-foundation.strings help.topics kernel memory namespaces parser system ui ui.tools.browser -ui.tools.listener ui.backend.cocoa eval locals tools.vocabs ; +ui.tools.listener ui.backend.cocoa eval locals +vocabs.refresh ; IN: ui.backend.cocoa.tools : finder-run-files ( alien -- ) diff --git a/basis/ui/backend/cocoa/views/views.factor b/basis/ui/backend/cocoa/views/views.factor index 4a16e3bd37..aab851c783 100644 --- a/basis/ui/backend/cocoa/views/views.factor +++ b/basis/ui/backend/cocoa/views/views.factor @@ -9,7 +9,7 @@ threads combinators math.rectangles ; IN: ui.backend.cocoa.views : send-mouse-moved ( view event -- ) - [ mouse-location ] [ drop window ] 2bi move-hand fire-motion ; + [ mouse-location ] [ drop window ] 2bi move-hand fire-motion yield ; : button ( event -- n ) #! Cocoa -> Factor UI button mapping diff --git a/basis/ui/gadgets/gadgets.factor b/basis/ui/gadgets/gadgets.factor index 32d6c0c8a6..f9f397d46f 100644 --- a/basis/ui/gadgets/gadgets.factor +++ b/basis/ui/gadgets/gadgets.factor @@ -3,7 +3,8 @@ USING: accessors arrays hashtables kernel models math namespaces make sequences quotations math.vectors combinators sorting binary-search vectors dlists deques models threads -concurrency.flags math.order math.rectangles fry locals ; +concurrency.flags math.order math.rectangles fry locals +prettyprint.backend prettyprint.custom ; IN: ui.gadgets ! Values for orientation slot @@ -27,6 +28,9 @@ interior boundary model ; +! Don't print gadgets with RECT: syntax +M: gadget pprint* pprint-tuple ; + M: gadget equal? 2drop f ; M: gadget hashcode* nip [ [ \ gadget counter ] unless* ] change-id id>> ; diff --git a/basis/ui/gadgets/status-bar/status-bar-docs.factor b/basis/ui/gadgets/status-bar/status-bar-docs.factor index 57c69c2a66..7a68310e36 100644 --- a/basis/ui/gadgets/status-bar/status-bar-docs.factor +++ b/basis/ui/gadgets/status-bar/status-bar-docs.factor @@ -18,7 +18,7 @@ HELP: { $notes "If the " { $snippet "model" } " is " { $snippet "status" } ", this gadget will display mouse over help for " { $link "ui.gadgets.presentations" } "." } ; HELP: open-status-window -{ $values { "gadget" gadget } { "title" string } } +{ $values { "gadget" gadget } { "title/attributes" { "a " { $link string } " or a " { $link world-attributes } " tuple" } } } { $description "Like " { $link open-window } ", with the additional feature that the new window iwll have a status bar displaying the value stored in the world's " { $slot "status" } " slot." } { $see-also show-status hide-status } ; @@ -30,4 +30,4 @@ ARTICLE: "ui.gadgets.status-bar" "Status bars and mouse-over help" { $subsection hide-status } { $link "ui.gadgets.presentations" } " use the status bar to display object summary." ; -ABOUT: "ui.gadgets.status-bar" \ No newline at end of file +ABOUT: "ui.gadgets.status-bar" diff --git a/basis/ui/gadgets/status-bar/status-bar.factor b/basis/ui/gadgets/status-bar/status-bar.factor index a1c2dca23d..0d3015508e 100644 --- a/basis/ui/gadgets/status-bar/status-bar.factor +++ b/basis/ui/gadgets/status-bar/status-bar.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors models models.delay models.arrow sequences ui.gadgets.labels ui.gadgets.tracks -ui.gadgets.worlds ui.gadgets ui kernel calendar summary ; +ui.gadgets.worlds ui.gadgets ui ui.private kernel calendar summary ; IN: ui.gadgets.status-bar : ( model -- gadget ) @@ -10,9 +10,9 @@ IN: ui.gadgets.status-bar reverse-video-theme t >>root? ; -: open-status-window ( gadget title -- ) - f [ ] keep - f track-add +: open-status-window ( gadget title/attributes -- ) + ?attributes f >>status + dup status>> f track-add open-world-window ; : show-summary ( object gadget -- ) diff --git a/basis/ui/gadgets/worlds/worlds-docs.factor b/basis/ui/gadgets/worlds/worlds-docs.factor index 9d4df189f2..d4e9790d89 100755 --- a/basis/ui/gadgets/worlds/worlds-docs.factor +++ b/basis/ui/gadgets/worlds/worlds-docs.factor @@ -48,8 +48,8 @@ HELP: world } ; HELP: -{ $values { "gadget" gadget } { "title" string } { "status" model } { "world" "a new " { $link world } } } -{ $description "Creates a new " { $link world } " delegating to the given gadget." } ; +{ $values { "world-attributes" world-attributes } { "world" "a new " { $link world } } } +{ $description "Creates a new " { $link world } " or world subclass with the given attributes." } ; HELP: find-world { $values { "gadget" gadget } { "world/f" { $maybe world } } } @@ -65,6 +65,30 @@ HELP: find-gl-context { $description "Makes the OpenGL context of the gadget's containing native window the current OpenGL context." } { $notes "This word should be called from " { $link graft* } " and " { $link ungraft* } " methods which need to allocate and deallocate OpenGL resources, such as textures, display lists, and so on." } ; +HELP: begin-world +{ $values { "world" world } } +{ $description "Called immediately after " { $snippet "world" } "'s OpenGL context has been created. The world's OpenGL context is current when this method is called." } ; + +HELP: end-world +{ $values { "world" world } } +{ $description "Called immediately before " { $snippet "world" } "'s OpenGL context is destroyed. The world's OpenGL context is current when this method is called." } ; + +HELP: resize-world +{ $values { "world" world } } +{ $description "Called when the window containing " { $snippet "world" } " is resized. The " { $snippet "loc" } " and " { $snippet "dim" } " slots of " { $snippet "world" } " will be updated with the world's new position and size. The world's OpenGL context is current when this method is called." } ; + +HELP: draw-world* +{ $values { "world" world } } +{ $description "Called when " { $snippet "world" } " needs to be redrawn. The world's OpenGL context is current when this method is called." } ; + +ARTICLE: "ui.gadgets.worlds-subclassing" "Subclassing worlds" +"The " { $link world } " gadget can be subclassed, giving Factor code full control of the window's OpenGL context. The following generic words can be overridden to replace standard UI behavior:" +{ $subsection begin-world } +{ $subsection end-world } +{ $subsection resize-world } +{ $subsection draw-world* } +"See the " { $vocab-link "spheres" } " and " { $vocab-link "bunny" } " demos for examples." ; + ARTICLE: "ui-paint-custom" "Implementing custom drawing logic" "The UI uses OpenGL to render gadgets. Custom rendering logic can be plugged in with the " { $link "ui-pen-protocol" } ", or by implementing a generic word:" { $subsection draw-gadget* } @@ -72,7 +96,8 @@ ARTICLE: "ui-paint-custom" "Implementing custom drawing logic" $nl "Gadgets which need to allocate and deallocate OpenGL resources such as textures, display lists, and so on, should perform the allocation in the " { $link graft* } " method, and the deallocation in the " { $link ungraft* } " method. Since those words are not necessarily called with the gadget's OpenGL context active, a utility word can be used to find and make the correct OpenGL context current:" { $subsection find-gl-context } -"OpenGL state must not be altered as a result of drawing a gadget, so any flags which were enabled should be disabled, and vice versa." +"OpenGL state must not be altered as a result of drawing a gadget, so any flags which were enabled should be disabled, and vice versa. To take full control of the OpenGL context, see " { $link "ui.gadgets.worlds-subclassing" } "." { $subsection "ui-paint-coord" } +{ $subsection "ui.gadgets.worlds-subclassing" } { $subsection "gl-utilities" } { $subsection "text-rendering" } ; diff --git a/basis/ui/gadgets/worlds/worlds.factor b/basis/ui/gadgets/worlds/worlds.factor index 171272dfc1..31b5a137a3 100755 --- a/basis/ui/gadgets/worlds/worlds.factor +++ b/basis/ui/gadgets/worlds/worlds.factor @@ -4,15 +4,28 @@ USING: accessors arrays assocs continuations kernel math models namespaces opengl opengl.textures sequences io combinators combinators.short-circuit fry math.vectors math.rectangles cache ui.gadgets ui.gestures ui.render ui.backend ui.gadgets.tracks -ui.commands ui.pixel-formats destructors ; +ui.commands ui.pixel-formats destructors literals ; IN: ui.gadgets.worlds +CONSTANT: default-world-pixel-format-attributes + { windowed double-buffered T{ depth-bits { value 16 } } } + TUPLE: world < track -active? focused? -layers -title status status-owner -text-handle handle images -window-loc ; + active? focused? + layers + title status status-owner + text-handle handle images + window-loc + pixel-format-attributes ; + +TUPLE: world-attributes + { world-class initial: world } + title + status + gadgets + { pixel-format-attributes initial: $ default-world-pixel-format-attributes } ; + +C: world-attributes : find-world ( gadget -- world/f ) [ world? ] find-parent ; @@ -45,18 +58,23 @@ M: world request-focus-on ( child gadget -- ) 2dup eq? [ 2drop ] [ dup focused?>> (request-focus) ] if ; -: new-world ( gadget title status class -- world ) +: new-world ( class -- world ) vertical swap new-track t >>root? t >>active? - { 0 0 } >>window-loc - swap >>status - swap >>title - swap 1 track-add - dup request-focus ; + { 0 0 } >>window-loc ; -: ( gadget title status -- world ) - world new-world ; +: apply-world-attributes ( world attributes -- world ) + { + [ title>> >>title ] + [ status>> >>status ] + [ pixel-format-attributes>> >>pixel-format-attributes ] + [ gadgets>> [ 1 track-add ] each ] + } cleave ; + +: ( world-attributes -- world ) + [ world-class>> new-world ] keep apply-world-attributes + dup request-focus ; : as-big-as-possible ( world gadget -- ) dup [ { 0 0 } >>loc over dim>> >>dim ] when 2drop ; inline @@ -77,17 +95,36 @@ SYMBOL: flush-layout-cache-hook flush-layout-cache-hook [ [ ] ] initialize -: (draw-world) ( world -- ) - dup handle>> [ - check-extensions - { - [ init-gl ] - [ draw-gadget ] - [ text-handle>> [ purge-cache ] when* ] - [ images>> [ purge-cache ] when* ] - } cleave - ] with-gl-context - flush-layout-cache-hook get call( -- ) ; +GENERIC: begin-world ( world -- ) +GENERIC: end-world ( world -- ) + +GENERIC: resize-world ( world -- ) + +M: world begin-world + drop ; +M: world end-world + drop ; +M: world resize-world + drop ; + +M: world (>>dim) + [ call-next-method ] + [ + dup handle>> + [ select-gl-context resize-world ] + [ drop ] if* + ] bi ; + +GENERIC: draw-world* ( world -- ) + +M: world draw-world* + check-extensions + { + [ init-gl ] + [ draw-gadget ] + [ text-handle>> [ purge-cache ] when* ] + [ images>> [ purge-cache ] when* ] + } cleave ; : draw-world? ( world -- ? ) #! We don't draw deactivated worlds, or those with 0 size. @@ -108,7 +145,10 @@ ui-error-hook [ [ rethrow ] ] initialize : draw-world ( world -- ) dup draw-world? [ dup world [ - [ (draw-world) ] [ + [ + dup handle>> [ draw-world* ] with-gl-context + flush-layout-cache-hook get call( -- ) + ] [ over ui-error f >>active? drop ] recover @@ -151,8 +191,7 @@ M: world handle-gesture ( gesture gadget -- ? ) [ get-global find-world eq? ] keep '[ f _ set-global ] when ; M: world world-pixel-format-attributes - drop - { windowed double-buffered T{ depth-bits { value 16 } } } ; + pixel-format-attributes>> ; M: world check-world-pixel-format 2drop ; @@ -160,3 +199,4 @@ M: world check-world-pixel-format : with-world-pixel-format ( world quot -- ) [ dup dup world-pixel-format-attributes ] dip [ 2dup check-world-pixel-format ] prepose with-disposal ; inline + diff --git a/basis/ui/pixel-formats/pixel-formats-docs.factor b/basis/ui/pixel-formats/pixel-formats-docs.factor index 207b757908..003b205c3d 100644 --- a/basis/ui/pixel-formats/pixel-formats-docs.factor +++ b/basis/ui/pixel-formats/pixel-formats-docs.factor @@ -91,29 +91,29 @@ HELP: backing-store { double-buffered backing-store } related-words HELP: multisampled -{ $class-description "Requests a pixel format with multisampled antialiasing enabled. The " { $link sample-buffers } " and " { $link samples } " attributes must also be specified to specify the level of multisampling." } +{ $class-description "Requests a pixel format with multisampled antialiasing enabled. The " { $link sample-buffers } " and " { $link samples } " attributes must also be provided to specify the level of multisampling." } { $notes "On some window systems this is not distinct from " { $link supersampled } "." } ; HELP: supersampled -{ $class-description "Requests a pixel format with supersampled antialiasing enabled. The " { $link sample-buffers } " and " { $link samples } " attributes must also be specified to specify the level of supersampling." } +{ $class-description "Requests a pixel format with supersampled antialiasing enabled. The " { $link sample-buffers } " and " { $link samples } " attributes must also be provided to specify the level of supersampling." } { $notes "On some window systems this is not distinct from " { $link multisampled } "." } ; HELP: sample-alpha { $class-description "Used with " { $link multisampled } " or " { $link supersampled } " to request more accurate multisampling of alpha values." } ; HELP: color-float -{ $class-description "Requests a pixel format where the pixels are stored in floating-point format." } ; +{ $class-description "Requests a pixel format where the color buffer is stored in floating-point format." } ; HELP: color-bits -{ $class-description "Requests a pixel format of at least " { $snippet "value" } " bits per pixel." } ; +{ $class-description "Requests a pixel format with a color buffer of at least " { $snippet "value" } " bits per pixel." } ; HELP: red-bits -{ $class-description "Requests a pixel format with at least " { $snippet "value" } " red bits per pixel." } ; +{ $class-description "Requests a pixel format with a color buffer with at least " { $snippet "value" } " red bits per pixel." } ; HELP: green-bits -{ $class-description "Requests a pixel format with at least " { $snippet "value" } " green bits per pixel." } ; +{ $class-description "Requests a pixel format with a color buffer with at least " { $snippet "value" } " green bits per pixel." } ; HELP: blue-bits -{ $class-description "Requests a pixel format with at least " { $snippet "value" } " blue bits per pixel." } ; +{ $class-description "Requests a pixel format with a color buffer with at least " { $snippet "value" } " blue bits per pixel." } ; HELP: alpha-bits -{ $class-description "Requests a pixel format with at least " { $snippet "value" } " alpha bits per pixel." } ; +{ $class-description "Requests a pixel format with a color buffer with at least " { $snippet "value" } " alpha bits per pixel." } ; { color-float color-bits red-bits green-bits blue-bits alpha-bits } related-words diff --git a/basis/ui/tools/listener/listener-docs.factor b/basis/ui/tools/listener/listener-docs.factor index ec4fc80a4d..998020c9c4 100644 --- a/basis/ui/tools/listener/listener-docs.factor +++ b/basis/ui/tools/listener/listener-docs.factor @@ -1,7 +1,7 @@ USING: help.markup help.syntax ui.commands ui.operations ui.gadgets.editors ui.gadgets.panes listener io words ui.tools.listener.completion ui.tools.common help.tips -tools.vocabs vocabs ; +vocabs vocabs.refresh ; IN: ui.tools.listener HELP: interactor diff --git a/basis/ui/tools/listener/listener.factor b/basis/ui/tools/listener/listener.factor index eca16e7286..6ed3577a06 100644 --- a/basis/ui/tools/listener/listener.factor +++ b/basis/ui/tools/listener/listener.factor @@ -6,14 +6,15 @@ compiler.units help.tips concurrency.flags concurrency.mailboxes continuations destructors documents documents.elements fry hashtables help help.markup io io.styles kernel lexer listener math models sets models.delay models.arrow namespaces parser prettyprint quotations -sequences strings threads tools.vocabs vocabs vocabs.loader +sequences strings threads vocabs vocabs.refresh vocabs.loader vocabs.parser words debugger ui ui.commands ui.pens.solid ui.gadgets ui.gadgets.glass ui.gadgets.buttons ui.gadgets.editors ui.gadgets.labeled ui.gadgets.panes ui.gadgets.scrollers ui.gadgets.status-bar ui.gadgets.tracks ui.gadgets.borders ui.gestures ui.operations ui.tools.browser ui.tools.common ui.tools.debugger ui.tools.listener.completion ui.tools.listener.popups -ui.tools.listener.history ui.images ui.tools.error-list tools.errors.model ; +ui.tools.listener.history ui.images ui.tools.error-list +tools.errors.model ; FROM: source-files.errors => all-errors ; IN: ui.tools.listener diff --git a/basis/ui/tools/operations/operations.factor b/basis/ui/tools/operations/operations.factor index 3c16011897..650d751ee2 100644 --- a/basis/ui/tools/operations/operations.factor +++ b/basis/ui/tools/operations/operations.factor @@ -4,7 +4,7 @@ USING: continuations definitions generic help.topics threads stack-checker summary io.pathnames io.styles kernel namespaces parser prettyprint quotations tools.crossref tools.annotations editors tools.profiler tools.test tools.time tools.walker vocabs vocabs.loader -words sequences tools.vocabs classes compiler.errors compiler.units +words sequences classes compiler.errors compiler.units accessors vocabs.parser macros.expander ui ui.tools.browser ui.tools.listener ui.tools.listener.completion ui.tools.profiler ui.tools.inspector ui.tools.traceback ui.commands ui.gadgets.editors diff --git a/basis/ui/tools/tools.factor b/basis/ui/tools/tools.factor index c825c60dbb..7ea34e651f 100644 --- a/basis/ui/tools/tools.factor +++ b/basis/ui/tools/tools.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2006, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: memory system kernel tools.vocabs ui.tools.operations +USING: memory system kernel vocabs.refresh ui.tools.operations ui.tools.listener ui.tools.browser ui.tools.common ui.tools.error-list ui.tools.walker ui.commands ui.gestures ui ui.private ; IN: ui.tools diff --git a/basis/ui/ui-docs.factor b/basis/ui/ui-docs.factor index f2b6154745..397fc419fa 100644 --- a/basis/ui/ui-docs.factor +++ b/basis/ui/ui-docs.factor @@ -2,17 +2,28 @@ USING: help.markup help.syntax strings quotations debugger namespaces ui.backend ui.gadgets ui.gadgets.worlds ui.gadgets.tracks ui.gadgets.packs ui.gadgets.grids ui.gadgets.private math.rectangles colors ui.text fonts -kernel ui.private ; +kernel ui.private classes sequences ; IN: ui HELP: windows { $var-description "Global variable holding an association list mapping native window handles to " { $link world } " instances." } ; -{ windows open-window find-window } related-words +{ windows open-window find-window world-attributes } related-words HELP: open-window -{ $values { "gadget" gadget } { "title" string } } -{ $description "Opens a native window with the specified title." } ; +{ $values { "gadget" gadget } { "title/attributes" { "a " { $link string } " or a " { $link world-attributes } " tuple" } } } +{ $description "Opens a native window containing " { $snippet "gadget" } " with the specified attributes. If a string is provided, it is used as the window title; otherwise, the window attributes are specified in a " { $link world-attributes } " tuple." } ; + +HELP: world-attributes +{ $values { "world-class" class } { "title" string } { "status" gadget } { "gadgets" sequence } { "pixel-format-attributes" sequence } } +{ $class-description "Tuples of this class can be passed to " { $link open-window } " to control attributes of the window opened. The following attributes can be set:" } +{ $list + { { $snippet "world-class" } " specifies the class of world to construct. " { $link world } " is the default." } + { { $snippet "title" } " is the window title." } + { { $snippet "status" } ", if specified, is a gadget that will be used as the window's status bar." } + { { $snippet "gadgets" } " is a sequence of gadgets that will be placed inside the window." } + { { $snippet "pixel-format-attributes" } " is a sequence of " { $link "ui.pixel-formats-attributes" } " that the window will request for its OpenGL pixel format." } +} ; HELP: set-fullscreen? { $values { "?" "a boolean" } { "gadget" gadget } } diff --git a/basis/ui/ui.factor b/basis/ui/ui.factor index 09403cb2d2..d07403836a 100644 --- a/basis/ui/ui.factor +++ b/basis/ui/ui.factor @@ -4,7 +4,8 @@ USING: arrays assocs io kernel math models namespaces make dlists deques sequences threads sequences words continuations init combinators combinators.short-circuit hashtables concurrency.flags sets accessors calendar fry destructors ui.gadgets ui.gadgets.private -ui.gadgets.worlds ui.gadgets.tracks ui.gestures ui.backend ui.render ; +ui.gadgets.worlds ui.gadgets.tracks ui.gestures ui.backend ui.render +strings ; IN: ui >focused? focus-path f swap focus-gestures ; +: try-to-open-window ( world -- ) + { + [ (open-window) ] + [ handle>> select-gl-context ] + [ + [ begin-world ] + [ [ handle>> (close-window) ] [ ui-error ] bi* ] + recover + ] + [ resize-world ] + } cleave ; + M: world graft* - [ (open-window) ] + [ try-to-open-window ] [ [ title>> ] keep set-title ] [ request-focus ] tri ; @@ -66,6 +79,7 @@ M: world graft* [ images>> [ dispose ] when* ] [ hand-clicked close-global ] [ hand-gadget close-global ] + [ end-world ] } cleave ; M: world ungraft* @@ -166,13 +180,17 @@ PRIVATE> : restore-windows? ( -- ? ) windows get empty? not ; +: ?attributes ( gadget title/attributes -- attributes ) + dup string? [ world-attributes new swap >>title ] when + swap [ [ [ 1array ] [ f ] if* ] curry unless* ] curry change-gadgets ; + PRIVATE> : open-world-window ( world -- ) dup pref-dim >>dim dup relayout graft ; -: open-window ( gadget title -- ) - f open-world-window ; +: open-window ( gadget title/attributes -- ) + ?attributes open-world-window ; : set-fullscreen? ( ? gadget -- ) find-world set-fullscreen* ; diff --git a/basis/vocabs/cache/authors.txt b/basis/vocabs/cache/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/basis/vocabs/cache/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/basis/vocabs/cache/cache.factor b/basis/vocabs/cache/cache.factor new file mode 100644 index 0000000000..63a8d6d292 --- /dev/null +++ b/basis/vocabs/cache/cache.factor @@ -0,0 +1,21 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: assocs kernel namespaces memoize init vocabs +vocabs.hierarchy vocabs.loader vocabs.metadata vocabs.refresh ; +IN: vocabs.cache + +: reset-cache ( -- ) + root-cache get-global clear-assoc + \ vocab-file-contents reset-memoized + \ all-vocabs-seq reset-memoized + \ all-authors reset-memoized + \ all-tags reset-memoized ; + +SINGLETON: cache-observer + +M: cache-observer vocabs-changed drop reset-cache ; + +[ + f changed-vocabs set-global + cache-observer add-vocab-observer +] "vocabs.cache" add-init-hook \ No newline at end of file diff --git a/basis/vocabs/cache/summary.txt b/basis/vocabs/cache/summary.txt new file mode 100644 index 0000000000..92ab1fe8eb --- /dev/null +++ b/basis/vocabs/cache/summary.txt @@ -0,0 +1 @@ +Caching vocabulary data from disk diff --git a/basis/vocabs/errors/authors.txt b/basis/vocabs/errors/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/basis/vocabs/errors/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/basis/vocabs/errors/errors.factor b/basis/vocabs/errors/errors.factor new file mode 100644 index 0000000000..8f88eb3816 --- /dev/null +++ b/basis/vocabs/errors/errors.factor @@ -0,0 +1,35 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: assocs continuations debugger io io.styles kernel +namespaces sequences vocabs vocabs.loader ; +IN: vocabs.errors + + + +: load-failures. ( failures -- ) + [ load-error. nl ] each ; + +: require-all ( vocabs -- failures ) + [ + V{ } clone blacklist set + V{ } clone failures set + [ + [ require ] + [ swap vocab-name failures get set-at ] + recover + ] each + failures get + ] with-scope ; \ No newline at end of file diff --git a/basis/vocabs/errors/summary.txt b/basis/vocabs/errors/summary.txt new file mode 100644 index 0000000000..b7e7040366 --- /dev/null +++ b/basis/vocabs/errors/summary.txt @@ -0,0 +1 @@ +Loading vocabularies and batching errors diff --git a/basis/vocabs/files/authors.txt b/basis/vocabs/files/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/basis/vocabs/files/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/basis/vocabs/files/files-docs.factor b/basis/vocabs/files/files-docs.factor new file mode 100644 index 0000000000..e2c6a5f373 --- /dev/null +++ b/basis/vocabs/files/files-docs.factor @@ -0,0 +1,11 @@ +USING: help.markup help.syntax strings ; +IN: vocabs.files + +HELP: vocab-files +{ $values { "vocab" "a vocabulary specifier" } { "seq" "a sequence of pathname strings" } } +{ $description "Outputs a sequence of files comprising this vocabulary, or " { $link f } " if the vocabulary does not have a directory on disk." } ; + +HELP: vocab-tests +{ $values { "vocab" "a vocabulary specifier" } { "tests" "a sequence of pathname strings" } } +{ $description "Outputs a sequence of pathnames where the unit tests for " { $snippet "vocab" } " are located." } ; + diff --git a/basis/vocabs/files/files.factor b/basis/vocabs/files/files.factor new file mode 100644 index 0000000000..c1d7dcfd59 --- /dev/null +++ b/basis/vocabs/files/files.factor @@ -0,0 +1,34 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: io.directories io.files io.pathnames kernel make +sequences vocabs.loader ; +IN: vocabs.files + + + +: vocab-tests ( vocab -- tests ) + [ + [ vocab-tests-file [ , ] when* ] + [ vocab-tests-dir [ % ] when* ] bi + ] { } make ; + +: vocab-files ( vocab -- seq ) + [ + [ vocab-source-path [ , ] when* ] + [ vocab-docs-path [ , ] when* ] + [ vocab-tests % ] tri + ] { } make ; \ No newline at end of file diff --git a/basis/vocabs/files/summary.txt b/basis/vocabs/files/summary.txt new file mode 100644 index 0000000000..b1633e3782 --- /dev/null +++ b/basis/vocabs/files/summary.txt @@ -0,0 +1 @@ +Getting a list of files in a vocabulary diff --git a/basis/vocabs/hierarchy/hierarchy-docs.factor b/basis/vocabs/hierarchy/hierarchy-docs.factor new file mode 100644 index 0000000000..c5d8554635 --- /dev/null +++ b/basis/vocabs/hierarchy/hierarchy-docs.factor @@ -0,0 +1,33 @@ +USING: help.markup help.syntax strings vocabs.loader ; +IN: vocabs.hierarchy + +ARTICLE: "vocabs.hierarchy" "Vocabulary hierarchy tools" +"These tools operate on all vocabularies found in the current set of " { $link vocab-roots } ", loaded or not." +$nl +"Loading vocabulary hierarchies:" +{ $subsection load } +{ $subsection load-all } +"Getting all vocabularies on disk:" +{ $subsection all-vocabs } +{ $subsection all-vocabs-seq } +"Getting " { $link "vocabs.metadata" } " for all vocabularies on disk:" +{ $subsection all-tags } +{ $subsection all-authors } ; + +ABOUT: "vocabs.hierarchy" + +HELP: all-vocabs +{ $values { "assoc" "an association list mapping vocabulary roots to sequences of vocabulary specifiers" } } +{ $description "Outputs an association list of all vocabularies which have been loaded or are available for loading." } ; + +HELP: load +{ $values { "prefix" string } } +{ $description "Load all vocabularies that match the provided prefix." } +{ $notes "This word differs from " { $link require } " in that it loads all subvocabularies, not just the given one." } ; + +HELP: load-all +{ $description "Load all vocabularies in the source tree." } ; + +HELP: all-vocabs-under +{ $values { "prefix" string } } +{ $description "Return a sequence of vocab or vocab-links for each vocab matching the provided prefix. Unlike " { $link all-child-vocabs } " this word will return both loaded and unloaded vocabularies." } ; diff --git a/basis/vocabs/hierarchy/hierarchy-tests.factor b/basis/vocabs/hierarchy/hierarchy-tests.factor new file mode 100644 index 0000000000..acbae804d2 --- /dev/null +++ b/basis/vocabs/hierarchy/hierarchy-tests.factor @@ -0,0 +1,12 @@ +IN: vocabs.hierarchy.tests +USING: continuations namespaces tools.test vocabs.hierarchy vocabs.hierarchy.private ; + +[ ] [ + changed-vocabs get-global + f changed-vocabs set-global + [ t ] [ "kernel" changed-vocab? ] unit-test + [ "kernel" changed-vocab ] [ changed-vocabs set-global ] [ ] cleanup +] unit-test + +[ t ] [ "some-vocab" valid-vocab-dirname ] unit-test +[ f ] [ ".git" valid-vocab-dirname ] unit-test diff --git a/basis/vocabs/hierarchy/hierarchy.factor b/basis/vocabs/hierarchy/hierarchy.factor new file mode 100644 index 0000000000..046ccb8c2d --- /dev/null +++ b/basis/vocabs/hierarchy/hierarchy.factor @@ -0,0 +1,99 @@ +! Copyright (C) 2007, 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: arrays assocs combinators.short-circuit fry +io.directories io.files io.files.info io.pathnames kernel make +memoize namespaces sequences sorting splitting vocabs sets +vocabs.loader vocabs.metadata vocabs.errors ; +IN: vocabs.hierarchy + +vocab-link , ] when + vocabs-in-dir + ] with each ; + +PRIVATE> + +: all-vocabs ( -- assoc ) + vocab-roots get [ + dup [ "" vocabs-in-dir ] { } make + ] { } map>assoc ; + +: all-vocabs-under ( prefix -- vocabs ) + [ + [ vocab-roots get ] dip '[ _ vocabs-in-dir ] each + ] { } make ; + +MEMO: all-vocabs-seq ( -- seq ) + "" all-vocabs-under ; + + + +: all-child-vocabs ( prefix -- assoc ) + vocab-roots get [ + dup pick (all-child-vocabs) [ >vocab-link ] map + ] { } map>assoc + swap unrooted-child-vocabs f swap 2array suffix ; + +: all-child-vocabs-seq ( prefix -- assoc ) + vocab-roots get swap '[ + dup _ (all-child-vocabs) + [ vocab-dir? ] with filter + ] map concat ; + + + +: (load) ( prefix -- failures ) + all-vocabs-under + filter-unportable + require-all ; + +: load ( prefix -- ) + (load) load-failures. ; + +: load-all ( -- ) + "" load ; + +MEMO: all-tags ( -- seq ) + all-vocabs-seq [ vocab-tags ] gather natural-sort ; + +MEMO: all-authors ( -- seq ) + all-vocabs-seq [ vocab-authors ] gather natural-sort ; \ No newline at end of file diff --git a/basis/vocabs/hierarchy/summary.txt b/basis/vocabs/hierarchy/summary.txt new file mode 100644 index 0000000000..b8d931570e --- /dev/null +++ b/basis/vocabs/hierarchy/summary.txt @@ -0,0 +1 @@ +Searching for vocabularies on disk diff --git a/basis/vocabs/metadata/authors.txt b/basis/vocabs/metadata/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/basis/vocabs/metadata/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/basis/vocabs/metadata/metadata-docs.factor b/basis/vocabs/metadata/metadata-docs.factor new file mode 100644 index 0000000000..002f8534b4 --- /dev/null +++ b/basis/vocabs/metadata/metadata-docs.factor @@ -0,0 +1,44 @@ +USING: help.markup help.syntax strings ; +IN: vocabs.metadata + +ARTICLE: "vocabs.metadata" "Vocabulary metadata" +"Vocabulary summaries:" +{ $subsection vocab-summary } +{ $subsection set-vocab-summary } +"Vocabulary authors:" +{ $subsection vocab-authors } +{ $subsection set-vocab-authors } +"Vocabulary tags:" +{ $subsection vocab-tags } +{ $subsection set-vocab-tags } +{ $subsection add-vocab-tags } +"Getting and setting arbitrary vocabulary metadata:" +{ $subsection vocab-file-contents } +{ $subsection set-vocab-file-contents } ; + +ABOUT: "vocabs.metadata" + +HELP: vocab-file-contents +{ $values { "vocab" "a vocabulary specifier" } { "name" string } { "seq" "a sequence of lines, or " { $link f } } } +{ $description "Outputs the contents of the file named " { $snippet "name" } " from the vocabulary's directory, or " { $link f } " if the file does not exist." } ; + +HELP: set-vocab-file-contents +{ $values { "seq" "a sequence of lines" } { "vocab" "a vocabulary specifier" } { "name" string } } +{ $description "Stores a sequence of lines to the file named " { $snippet "name" } " from the vocabulary's directory." } ; + +HELP: vocab-summary +{ $values { "vocab" "a vocabulary specifier" } { "summary" "a string or " { $link f } } } +{ $description "Outputs a one-line string description of the vocabulary's intended purpose from the " { $snippet "summary.txt" } " file in the vocabulary's directory. Outputs " { $link f } " if the file does not exist." } ; + +HELP: set-vocab-summary +{ $values { "string" "a string or " { $link f } } { "vocab" "a vocabulary specifier" } } +{ $description "Stores a one-line string description of the vocabulary to the " { $snippet "summary.txt" } " file in the vocabulary's directory." } ; + +HELP: vocab-tags +{ $values { "vocab" "a vocabulary specifier" } { "tags" "a sequence of strings" } } +{ $description "Outputs a list of short tags classifying the vocabulary from the " { $snippet "tags.txt" } " file in the vocabulary's directory. Outputs " { $link f } " if the file does not exist." } ; + +HELP: set-vocab-tags +{ $values { "tags" "a sequence of strings" } { "vocab" "a vocabulary specifier" } } +{ $description "Stores a list of short tags classifying the vocabulary to the " { $snippet "tags.txt" } " file in the vocabulary's directory." } ; + diff --git a/basis/vocabs/metadata/metadata.factor b/basis/vocabs/metadata/metadata.factor new file mode 100644 index 0000000000..85a503c7f0 --- /dev/null +++ b/basis/vocabs/metadata/metadata.factor @@ -0,0 +1,70 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors arrays assocs io.encodings.utf8 io.files +io.pathnames kernel make math.parser memoize sequences sets +sorting summary vocabs vocabs.loader ; +IN: vocabs.metadata + +MEMO: vocab-file-contents ( vocab name -- seq ) + vocab-append-path dup + [ dup exists? [ utf8 file-lines ] [ drop f ] if ] when ; + +: set-vocab-file-contents ( seq vocab name -- ) + dupd vocab-append-path [ + utf8 set-file-lines + \ vocab-file-contents reset-memoized + ] [ + "The " swap vocab-name + " vocabulary was not loaded from the file system" + 3append throw + ] ?if ; + +: vocab-summary-path ( vocab -- string ) + vocab-dir "summary.txt" append-path ; + +: vocab-summary ( vocab -- summary ) + dup dup vocab-summary-path vocab-file-contents + [ + vocab-name " vocabulary" append + ] [ + nip first + ] if-empty ; + +M: vocab summary + [ + dup vocab-summary % + " (" % + words>> assoc-size # + " words)" % + ] "" make ; + +M: vocab-link summary vocab-summary ; + +: set-vocab-summary ( string vocab -- ) + [ 1array ] dip + dup vocab-summary-path + set-vocab-file-contents ; + +: vocab-tags-path ( vocab -- string ) + vocab-dir "tags.txt" append-path ; + +: vocab-tags ( vocab -- tags ) + dup vocab-tags-path vocab-file-contents harvest ; + +: set-vocab-tags ( tags vocab -- ) + dup vocab-tags-path set-vocab-file-contents ; + +: add-vocab-tags ( tags vocab -- ) + [ vocab-tags append prune ] keep set-vocab-tags ; + +: vocab-authors-path ( vocab -- string ) + vocab-dir "authors.txt" append-path ; + +: vocab-authors ( vocab -- authors ) + dup vocab-authors-path vocab-file-contents harvest ; + +: set-vocab-authors ( authors vocab -- ) + dup vocab-authors-path set-vocab-file-contents ; + +: unportable? ( vocab -- ? ) + vocab-tags "unportable" swap member? ; \ No newline at end of file diff --git a/basis/vocabs/metadata/summary.txt b/basis/vocabs/metadata/summary.txt new file mode 100644 index 0000000000..eec7fd52e9 --- /dev/null +++ b/basis/vocabs/metadata/summary.txt @@ -0,0 +1 @@ +Managing vocabulary author, tag and summary information diff --git a/basis/vocabs/refresh/authors.txt b/basis/vocabs/refresh/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/basis/vocabs/refresh/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/basis/tools/vocabs/monitor/authors.txt b/basis/vocabs/refresh/monitor/authors.txt similarity index 100% rename from basis/tools/vocabs/monitor/authors.txt rename to basis/vocabs/refresh/monitor/authors.txt diff --git a/basis/tools/vocabs/monitor/monitor-tests.factor b/basis/vocabs/refresh/monitor/monitor-tests.factor similarity index 67% rename from basis/tools/vocabs/monitor/monitor-tests.factor rename to basis/vocabs/refresh/monitor/monitor-tests.factor index 0e767a3d34..86091189a5 100644 --- a/basis/tools/vocabs/monitor/monitor-tests.factor +++ b/basis/vocabs/refresh/monitor/monitor-tests.factor @@ -1,5 +1,5 @@ -USING: tools.test tools.vocabs.monitor io.pathnames ; -IN: tools.vocabs.monitor.tests +USING: tools.test vocabs.refresh.monitor io.pathnames ; +IN: vocabs.refresh.monitor.tests [ "kernel" ] [ "core/kernel/kernel.factor" path>vocab ] unit-test [ "kernel" ] [ "core/kernel/" path>vocab ] unit-test diff --git a/basis/tools/vocabs/monitor/monitor.factor b/basis/vocabs/refresh/monitor/monitor.factor similarity index 80% rename from basis/tools/vocabs/monitor/monitor.factor rename to basis/vocabs/refresh/monitor/monitor.factor index 1914da78b2..1445b9f882 100644 --- a/basis/tools/vocabs/monitor/monitor.factor +++ b/basis/vocabs/refresh/monitor/monitor.factor @@ -1,10 +1,10 @@ ! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: threads io.files io.pathnames io.monitors init kernel -vocabs vocabs.loader tools.vocabs namespaces continuations -sequences splitting assocs command-line concurrency.messaging -io.backend sets tr accessors ; -IN: tools.vocabs.monitor +USING: accessors assocs command-line concurrency.messaging +continuations init io.backend io.files io.monitors io.pathnames +kernel namespaces sequences sets splitting threads +tr vocabs vocabs.loader vocabs.refresh vocabs.cache ; +IN: vocabs.refresh.monitor TR: convert-separators "/\\" ".." ; @@ -56,4 +56,4 @@ TR: convert-separators "/\\" ".." ; [ "-no-monitors" (command-line) member? [ start-monitor-thread ] unless -] "tools.vocabs.monitor" add-init-hook +] "vocabs.refresh.monitor" add-init-hook diff --git a/basis/tools/vocabs/monitor/summary.txt b/basis/vocabs/refresh/monitor/summary.txt similarity index 100% rename from basis/tools/vocabs/monitor/summary.txt rename to basis/vocabs/refresh/monitor/summary.txt diff --git a/basis/vocabs/refresh/refresh-docs.factor b/basis/vocabs/refresh/refresh-docs.factor new file mode 100644 index 0000000000..5652d2ac6a --- /dev/null +++ b/basis/vocabs/refresh/refresh-docs.factor @@ -0,0 +1,22 @@ +USING: help.markup help.syntax strings ; +IN: vocabs.refresh + +HELP: source-modified? +{ $values { "path" "a pathname string" } { "?" "a boolean" } } +{ $description "Tests if the source file has been modified since it was last loaded. This compares the file's CRC32 checksum of the file's contents against the previously-recorded value." } ; + +HELP: refresh +{ $values { "prefix" string } } +{ $description "Reloads source files and documentation belonging to loaded vocabularies whose names are prefixed by " { $snippet "prefix" } " which have been modified on disk." } ; + +HELP: refresh-all +{ $description "Reloads source files and documentation for all loaded vocabularies which have been modified on disk." } ; + +{ refresh refresh-all } related-words + +ARTICLE: "vocabs.refresh" "Runtime code reloading" +"Reloading source files changed on disk:" +{ $subsection refresh } +{ $subsection refresh-all } ; + +ABOUT: "vocabs.refresh" diff --git a/basis/vocabs/refresh/refresh.factor b/basis/vocabs/refresh/refresh.factor new file mode 100644 index 0000000000..9ec89e3102 --- /dev/null +++ b/basis/vocabs/refresh/refresh.factor @@ -0,0 +1,91 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors assocs checksums checksums.crc32 +io.encodings.utf8 io.files kernel namespaces sequences sets +source-files vocabs vocabs.errors vocabs.loader ; +IN: vocabs.refresh + +: source-modified? ( path -- ? ) + dup source-files get at [ + dup path>> + dup exists? [ + utf8 file-lines crc32 checksum-lines + swap checksum>> = not + ] [ + 2drop f + ] if + ] [ + exists? + ] ?if ; + +SYMBOL: changed-vocabs + +: changed-vocab ( vocab -- ) + dup vocab changed-vocabs get and + [ dup changed-vocabs get set-at ] [ drop ] if ; + +: unchanged-vocab ( vocab -- ) + changed-vocabs get delete-at ; + +: unchanged-vocabs ( vocabs -- ) + [ unchanged-vocab ] each ; + +: changed-vocab? ( vocab -- ? ) + changed-vocabs get dup [ key? ] [ 2drop t ] if ; + +: filter-changed ( vocabs -- vocabs' ) + [ changed-vocab? ] filter ; + +SYMBOL: modified-sources +SYMBOL: modified-docs + +: (to-refresh) ( vocab variable loaded? path -- ) + dup [ + swap [ + pick changed-vocab? [ + source-modified? [ get push ] [ 2drop ] if + ] [ 3drop ] if + ] [ drop get push ] if + ] [ 2drop 2drop ] if ; + +: to-refresh ( prefix -- modified-sources modified-docs unchanged ) + [ + V{ } clone modified-sources set + V{ } clone modified-docs set + + child-vocabs [ + [ + [ + [ modified-sources ] + [ vocab source-loaded?>> ] + [ vocab-source-path ] + tri (to-refresh) + ] [ + [ modified-docs ] + [ vocab docs-loaded?>> ] + [ vocab-docs-path ] + tri (to-refresh) + ] bi + ] each + + modified-sources get + modified-docs get + ] + [ modified-docs get modified-sources get append diff ] bi + ] with-scope ; + +: do-refresh ( modified-sources modified-docs unchanged -- ) + unchanged-vocabs + [ + [ [ vocab f >>source-loaded? drop ] each ] + [ [ vocab f >>docs-loaded? drop ] each ] bi* + ] + [ + append prune + [ unchanged-vocabs ] + [ require-all load-failures. ] bi + ] 2bi ; + +: refresh ( prefix -- ) to-refresh do-refresh ; + +: refresh-all ( -- ) "" refresh ; \ No newline at end of file diff --git a/basis/vocabs/refresh/summary.txt b/basis/vocabs/refresh/summary.txt new file mode 100644 index 0000000000..4f75199aa5 --- /dev/null +++ b/basis/vocabs/refresh/summary.txt @@ -0,0 +1 @@ +Reloading changed vocabularies from disk diff --git a/basis/windows/errors/errors.factor b/basis/windows/errors/errors.factor index e08704d469..d180cb20e7 100644 --- a/basis/windows/errors/errors.factor +++ b/basis/windows/errors/errors.factor @@ -1,7 +1,7 @@ USING: alien.c-types kernel locals math math.bitwise windows.kernel32 sequences byte-arrays unicode.categories io.encodings.string io.encodings.utf16n alien.strings -arrays ; +arrays literals ; IN: windows.errors CONSTANT: ERROR_SUCCESS 0 @@ -732,11 +732,13 @@ ERROR: error-message-failed id ; win32-error-string throw ] when ; -: expected-io-errors ( -- seq ) - ERROR_SUCCESS - ERROR_IO_INCOMPLETE - ERROR_IO_PENDING - WAIT_TIMEOUT 4array ; foldable +CONSTANT: expected-io-errors + ${ + ERROR_SUCCESS + ERROR_IO_INCOMPLETE + ERROR_IO_PENDING + WAIT_TIMEOUT + } : expected-io-error? ( error-code -- ? ) expected-io-errors member? ; diff --git a/core/alien/strings/strings-docs.factor b/core/alien/strings/strings-docs.factor new file mode 100644 index 0000000000..388b9842db --- /dev/null +++ b/core/alien/strings/strings-docs.factor @@ -0,0 +1,20 @@ +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" diff --git a/basis/alien/strings/strings-tests.factor b/core/alien/strings/strings-tests.factor similarity index 100% rename from basis/alien/strings/strings-tests.factor rename to core/alien/strings/strings-tests.factor diff --git a/core/alien/strings/strings.factor b/core/alien/strings/strings.factor new file mode 100644 index 0000000000..943530d4f2 --- /dev/null +++ b/core/alien/strings/strings.factor @@ -0,0 +1,61 @@ +! 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 + [ ] [ ] 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 + + [ 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 + diff --git a/basis/alien/strings/summary.txt b/core/alien/strings/summary.txt similarity index 100% rename from basis/alien/strings/summary.txt rename to core/alien/strings/summary.txt diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index ec79185754..75a6c3179a 100644 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -82,8 +82,10 @@ bootstrapping? on "kernel" "kernel.private" "math" + "math.parser.private" "math.private" "memory" + "memory.private" "quotations" "quotations.private" "sbufs" @@ -366,8 +368,8 @@ tuple { "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 )) } @@ -414,8 +416,8 @@ tuple { "(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 )) } @@ -427,38 +429,38 @@ tuple { "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-arrays" (( n -- byte-array )) } { "(byte-array)" "byte-arrays" (( n -- byte-array )) } { "" "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 )) } @@ -472,7 +474,7 @@ tuple { "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 -- )) } diff --git a/core/bootstrap/syntax.factor b/core/bootstrap/syntax.factor index a0b349be51..55b92df215 100644 --- a/core/bootstrap/syntax.factor +++ b/core/bootstrap/syntax.factor @@ -16,6 +16,7 @@ IN: bootstrap.syntax " ; -SYNTAX: BV{ \ } [ >byte-vector ] parse-literal ; - -M: byte-vector pprint* pprint-object ; -M: byte-vector pprint-delims drop \ BV{ \ } ; -M: byte-vector >pprint-sequence ; - INSTANCE: byte-vector growable diff --git a/basis/byte-vectors/summary.txt b/core/byte-vectors/summary.txt similarity index 100% rename from basis/byte-vectors/summary.txt rename to core/byte-vectors/summary.txt diff --git a/basis/byte-vectors/tags.txt b/core/byte-vectors/tags.txt similarity index 100% rename from basis/byte-vectors/tags.txt rename to core/byte-vectors/tags.txt diff --git a/core/classes/algebra/algebra-tests.factor b/core/classes/algebra/algebra-tests.factor index a6af5b8c29..3069c4b555 100644 --- a/core/classes/algebra/algebra-tests.factor +++ b/core/classes/algebra/algebra-tests.factor @@ -305,7 +305,16 @@ SINGLETON: sc [ sa ] [ sa { sa sb sc } min-class ] unit-test +[ f ] [ sa sb classes-intersect? ] unit-test + [ +lt+ ] [ integer sequence class<=> ] unit-test [ +lt+ ] [ sequence object class<=> ] unit-test [ +gt+ ] [ object sequence class<=> ] unit-test [ +eq+ ] [ integer integer class<=> ] unit-test + +! Limitations: + +! UNION: u1 sa sb ; +! UNION: u2 sc ; + +! [ f ] [ u1 u2 classes-intersect? ] unit-test \ No newline at end of file diff --git a/core/generic/standard/standard.factor b/core/generic/standard/standard.factor index c8d1acba8f..87611a76d0 100644 --- a/core/generic/standard/standard.factor +++ b/core/generic/standard/standard.factor @@ -44,7 +44,7 @@ M: standard-combination inline-cache-quot ( word methods -- ) #! 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 ; diff --git a/basis/io/encodings/utf16/authors.txt b/core/io/encodings/utf16/authors.txt similarity index 100% rename from basis/io/encodings/utf16/authors.txt rename to core/io/encodings/utf16/authors.txt diff --git a/basis/io/encodings/utf16/summary.txt b/core/io/encodings/utf16/summary.txt similarity index 100% rename from basis/io/encodings/utf16/summary.txt rename to core/io/encodings/utf16/summary.txt diff --git a/basis/io/encodings/utf16/utf16-docs.factor b/core/io/encodings/utf16/utf16-docs.factor similarity index 100% rename from basis/io/encodings/utf16/utf16-docs.factor rename to core/io/encodings/utf16/utf16-docs.factor diff --git a/basis/io/encodings/utf16/utf16-tests.factor b/core/io/encodings/utf16/utf16-tests.factor similarity index 100% rename from basis/io/encodings/utf16/utf16-tests.factor rename to core/io/encodings/utf16/utf16-tests.factor diff --git a/basis/io/encodings/utf16/utf16.factor b/core/io/encodings/utf16/utf16.factor similarity index 94% rename from basis/io/encodings/utf16/utf16.factor rename to core/io/encodings/utf16/utf16.factor index d61c07f806..a6ccc95bf5 100644 --- a/basis/io/encodings/utf16/utf16.factor +++ b/core/io/encodings/utf16/utf16.factor @@ -1,21 +1,15 @@ ! 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 ; +io.encodings combinators splitting io byte-arrays ; 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 ; drop utf16n ; diff --git a/core/io/files/files.factor b/core/io/files/files.factor index 0f3041e670..6779c6d094 100644 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -1,7 +1,8 @@ -! 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 ) @@ -40,7 +41,8 @@ HOOK: (file-appender) io-backend ( path -- stream ) : with-file-appender ( path encoding quot -- ) [ ] dip with-output-stream ; inline -: exists? ( path -- ? ) normalize-path (exists?) ; +: exists? ( path -- ? ) + normalize-path native-string>alien (exists?) ; ! Current directory [ 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 diff --git a/basis/io/streams/byte-array/byte-array-docs.factor b/core/io/streams/byte-array/byte-array-docs.factor similarity index 100% rename from basis/io/streams/byte-array/byte-array-docs.factor rename to core/io/streams/byte-array/byte-array-docs.factor diff --git a/basis/io/streams/byte-array/byte-array-tests.factor b/core/io/streams/byte-array/byte-array-tests.factor similarity index 100% rename from basis/io/streams/byte-array/byte-array-tests.factor rename to core/io/streams/byte-array/byte-array-tests.factor diff --git a/basis/io/streams/byte-array/byte-array.factor b/core/io/streams/byte-array/byte-array.factor similarity index 90% rename from basis/io/streams/byte-array/byte-array.factor rename to core/io/streams/byte-array/byte-array.factor index 2ffb9b9a63..4cb50dfbc1 100644 --- a/basis/io/streams/byte-array/byte-array.factor +++ b/core/io/streams/byte-array/byte-array.factor @@ -1,7 +1,7 @@ ! 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 +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 diff --git a/basis/io/streams/byte-array/summary.txt b/core/io/streams/byte-array/summary.txt similarity index 100% rename from basis/io/streams/byte-array/summary.txt rename to core/io/streams/byte-array/summary.txt diff --git a/core/io/streams/c/c.factor b/core/io/streams/c/c.factor index bec3bdc6bf..e25db47cdf 100755 --- a/core/io/streams/c/c.factor +++ b/core/io/streams/c/c.factor @@ -1,9 +1,9 @@ ! 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 ; @@ -69,6 +69,9 @@ M: c-io-backend (init-stdio) init-c-stdio t ; 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 ; diff --git a/basis/io/streams/memory/memory.factor b/core/io/streams/memory/memory.factor similarity index 62% rename from basis/io/streams/memory/memory.factor rename to core/io/streams/memory/memory.factor index 52169de6f8..ad5453af61 100644 --- a/basis/io/streams/memory/memory.factor +++ b/core/io/streams/memory/memory.factor @@ -1,6 +1,6 @@ ! 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 ; +USING: kernel accessors alien alien.accessors math io ; IN: io.streams.memory TUPLE: memory-stream alien index ; @@ -13,9 +13,3 @@ 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 - swap memory>byte-array - ] [ [ + ] change-index drop ] 2bi ; diff --git a/basis/io/streams/memory/summary.txt b/core/io/streams/memory/summary.txt similarity index 100% rename from basis/io/streams/memory/summary.txt rename to core/io/streams/memory/summary.txt diff --git a/core/math/parser/parser-docs.factor b/core/math/parser/parser-docs.factor index ba0df3e357..beb2312f2a 100644 --- a/core/math/parser/parser-docs.factor +++ b/core/math/parser/parser-docs.factor @@ -1,4 +1,4 @@ -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 diff --git a/core/math/parser/parser.factor b/core/math/parser/parser.factor index 3fd62e69a0..1736a00be4 100644 --- a/core/math/parser/parser.factor +++ b/core/math/parser/parser.factor @@ -1,7 +1,7 @@ ! 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 ) @@ -79,6 +79,9 @@ SYMBOL: negative? string>natural ] if ; inline +: string>float ( str -- n/f ) + >byte-array 0 suffix (string>float) ; + PRIVATE> : base> ( str radix -- n/f ) @@ -149,13 +152,18 @@ M: ratio >base [ ".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 ; diff --git a/core/memory/memory.factor b/core/memory/memory.factor index 4b873ef6ec..c748f71c8e 100644 --- a/core/memory/memory.factor +++ b/core/memory/memory.factor @@ -1,6 +1,7 @@ -! 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 -- ) -- ) @@ -21,4 +22,10 @@ IN: memory [ count-instances 100 + ] 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 ; diff --git a/core/parser/parser.factor b/core/parser/parser.factor index 7915dc69e0..01e0b18887 100644 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -198,9 +198,10 @@ SYMBOL: interactive-vocabs "tools.test" "tools.threads" "tools.time" - "tools.vocabs" "vocabs" "vocabs.loader" + "vocabs.refresh" + "vocabs.hierarchy" "words" "scratchpad" } interactive-vocabs set-global diff --git a/core/slots/slots.factor b/core/slots/slots.factor index 63c0319c1c..6bb854daf6 100755 --- a/core/slots/slots.factor +++ b/core/slots/slots.factor @@ -122,7 +122,7 @@ ERROR: bad-slot-value value class ; [ \ 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 ; diff --git a/core/source-files/source-files-docs.factor b/core/source-files/source-files-docs.factor index eb1284cd25..91c039dbae 100644 --- a/core/source-files/source-files-docs.factor +++ b/core/source-files/source-files-docs.factor @@ -3,7 +3,7 @@ definitions quotations compiler.units ; IN: source-files ARTICLE: "source-files" "Source files" -"Words in the " { $vocab-link "source-files" } " vocabulary are used to keep track of loaded source files. This is used to implement " { $link "tools.vocabs" } "." +"Words in the " { $vocab-link "source-files" } " vocabulary are used to keep track of loaded source files. This is used to implement " { $link "vocabs.refresh" } "." $nl "The source file database:" { $subsection source-files } @@ -41,7 +41,7 @@ HELP: record-checksum $low-level-note ; HELP: reset-checksums -{ $description "Resets recorded modification times and CRC32 checksums for all loaded source files, creating a checkpoint for " { $link "tools.vocabs" } "." } ; +{ $description "Resets recorded modification times and CRC32 checksums for all loaded source files, creating a checkpoint for " { $link "vocabs.refresh" } "." } ; HELP: forget-source { $values { "path" "a pathname string" } } diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor index 3512b92e4c..7d710717aa 100644 --- a/core/syntax/syntax.factor +++ b/core/syntax/syntax.factor @@ -1,6 +1,6 @@ ! 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 @@ -98,6 +98,7 @@ IN: bootstrap.syntax "{" [ \ } [ >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 ] parse-literal ] define-core-syntax diff --git a/core/system/system.factor b/core/system/system.factor index 8f587d28c2..38b4a5fd9b 100644 --- a/core/system/system.factor +++ b/core/system/system.factor @@ -1,29 +1,20 @@ -! 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 @@ -62,11 +53,6 @@ PRIVATE> : 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 ; diff --git a/core/vocabs/loader/loader-docs.factor b/core/vocabs/loader/loader-docs.factor index e0d6fd4493..03d234807d 100644 --- a/core/vocabs/loader/loader-docs.factor +++ b/core/vocabs/loader/loader-docs.factor @@ -106,7 +106,7 @@ HELP: reload HELP: require { $values { "vocab" "a vocabulary specifier" } } { $description "Loads a vocabulary if it has not already been loaded." } -{ $notes "To unconditionally reload a vocabulary, use " { $link reload } ". To reload changed source files only, use the words in " { $link "tools.vocabs" } "." } ; +{ $notes "To unconditionally reload a vocabulary, use " { $link reload } ". To reload changed source files only, use the words in " { $link "vocabs.refresh" } "." } ; HELP: run { $values { "vocab" "a vocabulary specifier" } } diff --git a/core/vocabs/loader/loader-tests.factor b/core/vocabs/loader/loader-tests.factor index f7c8a89e8c..88a37cb450 100644 --- a/core/vocabs/loader/loader-tests.factor +++ b/core/vocabs/loader/loader-tests.factor @@ -1,9 +1,9 @@ -IN: vocabs.loader.tests USING: vocabs.loader tools.test continuations vocabs math kernel arrays sequences namespaces io.streams.string parser source-files words assocs classes.tuple definitions -debugger compiler.units tools.vocabs accessors eval +debugger compiler.units accessors eval combinators vocabs.parser grouping ; +IN: vocabs.loader.tests ! This vocab should not exist, but just in case... [ ] [ diff --git a/extra/benchmark/benchmark.factor b/extra/benchmark/benchmark.factor index 220f16fad5..6c64e34835 100755 --- a/extra/benchmark/benchmark.factor +++ b/extra/benchmark/benchmark.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2007, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel vocabs vocabs.loader tools.time tools.vocabs +USING: kernel vocabs vocabs.loader tools.time vocabs.hierarchy arrays assocs io.styles io help.markup prettyprint sequences continuations debugger math namespaces memory ; IN: benchmark diff --git a/extra/benchmark/gc0/authors.txt b/extra/benchmark/gc0/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/extra/benchmark/gc0/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/extra/benchmark/gc0/gc0.factor b/extra/benchmark/gc0/gc0.factor new file mode 100644 index 0000000000..997e8df23f --- /dev/null +++ b/extra/benchmark/gc0/gc0.factor @@ -0,0 +1,9 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: arrays kernel math ; +IN: benchmark.gc0 + +: allocate ( -- obj ) 10 f ; +: gc0 ( -- ) f 60000000 [ allocate nip ] times drop ; + +MAIN: gc0 \ No newline at end of file diff --git a/extra/benchmark/gc2/authors.txt b/extra/benchmark/gc2/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/extra/benchmark/gc2/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/extra/benchmark/gc2/gc2.factor b/extra/benchmark/gc2/gc2.factor new file mode 100644 index 0000000000..58f645aa7f --- /dev/null +++ b/extra/benchmark/gc2/gc2.factor @@ -0,0 +1,24 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: arrays byte-arrays kernel namespaces sequences math memory ; +IN: benchmark.gc2 + +! Runs slowly if clean cards are not unmarked. +SYMBOL: oldies + +: make-old-objects ( -- ) + 1000000 [ 1 f ] replicate oldies set gc + oldies get [ "HI" swap set-first ] each ; + +: allocate ( -- x ) 20000 (byte-array) ; + +: age ( -- ) + 1000 [ allocate drop ] times ; + +: gc2 ( -- ) + [ + make-old-objects + 50000 [ age ] times + ] with-scope ; + +MAIN: gc2 \ No newline at end of file diff --git a/extra/bunny/bunny.factor b/extra/bunny/bunny.factor index d0625e464f..620f737fe3 100755 --- a/extra/bunny/bunny.factor +++ b/extra/bunny/bunny.factor @@ -1,58 +1,67 @@ USING: accessors arrays bunny.cel-shaded bunny.fixed-pipeline bunny.model bunny.outlined destructors kernel math opengl.demo-support opengl.gl sequences ui ui.gadgets ui.gadgets.worlds ui.gestures -ui.render words ; +ui.render words ui.pixel-formats ; IN: bunny -TUPLE: bunny-gadget < demo-gadget model-triangles geom draw-seq draw-n ; +TUPLE: bunny-world < demo-world model-triangles geom draw-seq draw-n ; -: ( -- bunny-gadget ) - 0.0 0.0 0.375 bunny-gadget new-demo-gadget - maybe-download read-model >>model-triangles ; - -: bunny-gadget-draw ( gadget -- draw ) +: get-draw ( gadget -- draw ) [ draw-n>> ] [ draw-seq>> ] bi nth ; -: bunny-gadget-next-draw ( gadget -- ) +: next-draw ( gadget -- ) dup [ draw-seq>> ] [ draw-n>> ] bi 1+ swap length mod >>draw-n relayout-1 ; -M: bunny-gadget graft* ( gadget -- ) - dup find-gl-context - GL_DEPTH_TEST glEnable - dup model-triangles>> >>geom - dup +: make-draws ( gadget -- draw-seq ) [ ] [ ] [ ] tri 3array - sift >>draw-seq + sift ; + +M: bunny-world begin-world + GL_DEPTH_TEST glEnable + 0.0 0.0 0.375 set-demo-orientation + maybe-download read-model + [ >>model-triangles ] [ >>geom ] bi + dup make-draws >>draw-seq 0 >>draw-n drop ; -M: bunny-gadget ungraft* ( gadget -- ) +M: bunny-world end-world dup find-gl-context [ geom>> [ dispose ] when* ] [ draw-seq>> [ [ dispose ] when* ] each ] bi ; -M: bunny-gadget draw-gadget* ( gadget -- ) +M: bunny-world draw-world* dup draw-seq>> empty? [ drop ] [ 0.15 0.15 0.15 1.0 glClearColor GL_DEPTH_BUFFER_BIT GL_COLOR_BUFFER_BIT bitor glClear - dup demo-gadget-set-matrices + dup demo-world-set-matrix GL_MODELVIEW glMatrixMode 0.02 -0.105 0.0 glTranslatef - [ geom>> ] [ bunny-gadget-draw ] bi draw-bunny + [ geom>> ] [ get-draw ] bi draw-bunny ] if ; -M: bunny-gadget pref-dim* ( gadget -- dim ) +M: bunny-world pref-dim* ( gadget -- dim ) drop { 640 480 } ; -bunny-gadget H{ - { T{ key-down f f "TAB" } [ bunny-gadget-next-draw ] } +bunny-world H{ + { T{ key-down f f "TAB" } [ next-draw ] } } set-gestures : bunny-window ( -- ) - [ "Bunny" open-window ] with-ui ; + [ + f T{ world-attributes + { world-class bunny-world } + { title "Bunny" } + { pixel-format-attributes { + windowed + double-buffered + T{ depth-bits { value 16 } } + } } + } open-window + ] with-ui ; MAIN: bunny-window diff --git a/extra/bunny/outlined/outlined.factor b/extra/bunny/outlined/outlined.factor index 7491ed8bcb..0ad2a72100 100755 --- a/extra/bunny/outlined/outlined.factor +++ b/extra/bunny/outlined/outlined.factor @@ -216,7 +216,11 @@ MACRO: (framebuffer-texture>>draw) ( iformat xformat setter -- ) ] with-framebuffer ; : (pass2) ( draw -- ) - init-matrices { + GL_PROJECTION glMatrixMode + glPushMatrix glLoadIdentity + GL_MODELVIEW glMatrixMode + glLoadIdentity + { [ color-texture>> GL_TEXTURE_2D GL_TEXTURE0 bind-texture-unit ] [ normal-texture>> GL_TEXTURE_2D GL_TEXTURE1 bind-texture-unit ] [ depth-texture>> GL_TEXTURE_2D GL_TEXTURE2 bind-texture-unit ] @@ -230,7 +234,9 @@ MACRO: (framebuffer-texture>>draw) ( iformat xformat setter -- ) } cleave { -1.0 -1.0 } { 1.0 1.0 } rect-vertices ] with-gl-program ] - } cleave ; + } cleave + GL_PROJECTION glMatrixMode + glPopMatrix ; M: bunny-outlined draw-bunny [ remake-framebuffer-if-needed ] diff --git a/extra/file-trees/file-trees.factor b/extra/file-trees/file-trees.factor index 788291c0a2..eadfccdc4c 100644 --- a/extra/file-trees/file-trees.factor +++ b/extra/file-trees/file-trees.factor @@ -1,10 +1,10 @@ -USING: accessors delegate delegate.protocols io.pathnames -kernel locals namespaces sequences vectors -tools.annotations prettyprint ; +USING: accessors arrays delegate delegate.protocols +io.pathnames kernel locals namespaces prettyprint sequences +ui.frp vectors ; IN: file-trees TUPLE: tree node children ; -CONSULT: sequence-protocol tree children>> [ node>> ] map ; +CONSULT: sequence-protocol tree children>> ; : ( start -- tree ) V{ } clone [ tree boa dup children>> ] [ ".." swap tree boa ] bi swap push ; @@ -20,4 +20,9 @@ DEFER: (tree-insert) path-rest [ path-head tree-insert ] unless-empty ] if* ; : create-tree ( file-list -- tree ) [ path-components ] map - t [ [ tree-insert ] curry each ] keep ; \ No newline at end of file + t [ [ tree-insert ] curry each ] keep ; + +: ( tree-model -- table ) + [ node>> 1array ] >>quot + [ selected-value>> ] + [ swap >>model ] bi ; \ No newline at end of file diff --git a/extra/fuel/help/help.factor b/extra/fuel/help/help.factor index 30d6845a9b..6c43e646df 100644 --- a/extra/fuel/help/help.factor +++ b/extra/fuel/help/help.factor @@ -3,8 +3,8 @@ USING: accessors arrays assocs combinators help help.crossref help.markup help.topics io io.streams.string kernel make namespaces -parser prettyprint sequences summary tools.vocabs help.vocabs -vocabs vocabs.loader words see ; +parser prettyprint sequences summary help.vocabs +vocabs vocabs.loader vocabs.hierarchy vocabs.metadata words see ; IN: fuel.help @@ -21,9 +21,9 @@ IN: fuel.help [ see ] with-string-writer ; inline : fuel-methods-str ( word -- str ) - methods dup empty? not [ + methods [ f ] [ [ [ see nl ] each ] with-string-writer - ] [ drop f ] if ; inline + ] if-empty ; inline : fuel-related-words ( word -- seq ) dup "related" word-prop remove ; inline diff --git a/extra/fuel/xref/xref.factor b/extra/fuel/xref/xref.factor index ec06b9892e..160b7212c4 100644 --- a/extra/fuel/xref/xref.factor +++ b/extra/fuel/xref/xref.factor @@ -3,7 +3,7 @@ USING: accessors arrays assocs definitions help.topics io.pathnames kernel math math.order memoize namespaces sequences sets sorting -tools.completion tools.crossref tools.vocabs vocabs vocabs.parser +tools.completion tools.crossref vocabs vocabs.parser vocabs.hierarchy words ; IN: fuel.xref diff --git a/extra/galois-talk/galois-talk.factor b/extra/galois-talk/galois-talk.factor index be713542ed..ba929867e9 100644 --- a/extra/galois-talk/galois-talk.factor +++ b/extra/galois-talk/galois-talk.factor @@ -3,7 +3,7 @@ USING: slides help.markup math arrays hashtables namespaces sequences kernel sequences parser memoize io.encodings.binary locals kernel.private help.vocabs assocs quotations -urls peg.ebnf tools.vocabs tools.annotations tools.crossref +urls peg.ebnf tools.annotations tools.crossref help.topics math.functions compiler.tree.optimizer compiler.cfg.optimizer fry ; IN: galois-talk diff --git a/extra/google-tech-talk/google-tech-talk.factor b/extra/google-tech-talk/google-tech-talk.factor index ab8e72fc76..8e2eeeb1a7 100644 --- a/extra/google-tech-talk/google-tech-talk.factor +++ b/extra/google-tech-talk/google-tech-talk.factor @@ -3,7 +3,7 @@ USING: slides help.markup math arrays hashtables namespaces sequences kernel sequences parser memoize io.encodings.binary locals kernel.private help.vocabs assocs quotations -urls peg.ebnf tools.vocabs tools.annotations tools.crossref +urls peg.ebnf tools.annotations tools.crossref help.topics math.functions compiler.tree.optimizer compiler.cfg.optimizer fry ; IN: google-tech-talk diff --git a/extra/mason/common/common.factor b/extra/mason/common/common.factor index b255b351f0..e4a9d9da13 100755 --- a/extra/mason/common/common.factor +++ b/extra/mason/common/common.factor @@ -90,8 +90,8 @@ SYMBOL: stamp : ?prepare-build-machine ( -- ) builds/factor exists? [ prepare-build-machine ] unless ; -CONSTANT: load-everything-vocabs-file "load-everything-vocabs" -CONSTANT: load-everything-errors-file "load-everything-errors" +CONSTANT: load-all-vocabs-file "load-everything-vocabs" +CONSTANT: load-all-errors-file "load-everything-errors" CONSTANT: test-all-vocabs-file "test-all-vocabs" CONSTANT: test-all-errors-file "test-all-errors" diff --git a/extra/mason/report/report.factor b/extra/mason/report/report.factor index 64d31b4368..7707d16299 100644 --- a/extra/mason/report/report.factor +++ b/extra/mason/report/report.factor @@ -89,8 +89,8 @@ IN: mason.report timings-table "Load failures" - load-everything-vocabs-file - load-everything-errors-file + load-all-vocabs-file + load-all-errors-file error-dump "Compiler errors" @@ -120,7 +120,7 @@ IN: mason.report : build-clean? ( -- ? ) { - [ load-everything-vocabs-file eval-file empty? ] + [ load-all-vocabs-file eval-file empty? ] [ test-all-vocabs-file eval-file empty? ] [ help-lint-vocabs-file eval-file empty? ] [ compiler-errors-file eval-file empty? ] diff --git a/extra/mason/test/test.factor b/extra/mason/test/test.factor index 22b932ac5b..d50c77f71b 100644 --- a/extra/mason/test/test.factor +++ b/extra/mason/test/test.factor @@ -3,14 +3,15 @@ USING: accessors assocs benchmark bootstrap.stage2 compiler.errors source-files.errors generic help.html help.lint io.directories io.encodings.utf8 io.files kernel mason.common math namespaces -prettyprint sequences sets sorting tools.test tools.time tools.vocabs -words system io tools.errors locals ; +prettyprint sequences sets sorting tools.test tools.time +words system io tools.errors vocabs.hierarchy vocabs.errors +vocabs.refresh locals ; IN: mason.test : do-load ( -- ) - try-everything - [ keys load-everything-vocabs-file to-file ] - [ load-everything-errors-file utf8 [ load-failures. ] with-file-writer ] + "" (load) + [ keys load-all-vocabs-file to-file ] + [ load-all-errors-file utf8 [ load-failures. ] with-file-writer ] bi ; GENERIC: word-vocabulary ( word -- vocabulary ) diff --git a/extra/mongodb/driver/driver.factor b/extra/mongodb/driver/driver.factor index a972d1c380..967d4f11c5 100644 --- a/extra/mongodb/driver/driver.factor +++ b/extra/mongodb/driver/driver.factor @@ -178,7 +178,7 @@ M: mdb-query-msg skip GENERIC# sort 1 ( mdb-query-msg sort-quot -- mdb-query-msg ) M: mdb-query-msg sort - output>array >>orderby ; inline + output>array [ 1array >hashtable ] map >>orderby ; inline : key-spec ( spec-quot -- spec-assoc ) output>array >hashtable ; inline diff --git a/extra/mongodb/mongodb-docs.factor b/extra/mongodb/mongodb-docs.factor index ff8a769993..afdb2777fd 100644 --- a/extra/mongodb/mongodb-docs.factor +++ b/extra/mongodb/mongodb-docs.factor @@ -15,9 +15,9 @@ ARTICLE: "mongodb" "MongoDB factor integration" { $heading "Highlevel tuple integration" } "The " { $vocab-link "mongodb.tuple" } " vocabulary lets you define persistent tuples that can be stored to and retrieved from a MongoDB database" { $unchecked-example - "USING: mongodb.driver mongodb.tuple fry ;" + "USING: mongodb.driver mongodb.tuple fry literals ;" "MDBTUPLE: person name age ; " - "person \"persons\" { { \"age\" +fieldindex+ } } define-persistent " + "person \"persons\" { } { $[ \"ageIdx\" [ \"age\" asc ] key-spec ] } define-persistent " "\"db\" \"127.0.0.1\" 27017 " "person new \"Alfred\" >>name 57 >>age" "'[ _ save-tuple person new 57 >>age select-tuple ] with-db" diff --git a/extra/mongodb/tuple/collection/collection.factor b/extra/mongodb/tuple/collection/collection.factor index a4f86cd6a3..1bd2d94e69 100644 --- a/extra/mongodb/tuple/collection/collection.factor +++ b/extra/mongodb/tuple/collection/collection.factor @@ -1,51 +1,96 @@ USING: accessors arrays assocs bson.constants classes classes.tuple combinators continuations fry kernel mongodb.driver sequences strings -vectors words combinators.smart literals ; +vectors words combinators.smart literals memoize slots constructors ; IN: mongodb.tuple -SINGLETONS: +transient+ +load+ ; +SINGLETONS: +transient+ +load+ +user-defined-key+ ; + +: ( name key -- index-spec ) + index-spec new swap >>key swap >>name ; IN: mongodb.tuple.collection -FROM: mongodb.tuple => +transient+ +load+ ; +TUPLE: toid key value ; + +CONSTRUCTOR: toid ( value key -- toid ) ; + +FROM: mongodb.tuple => +transient+ +load+ ; MIXIN: mdb-persistent +SLOT: id SLOT: _id SLOT: _mfd + + +: >toid ( object -- toid ) + [ id>> ] [ class id-slot ] bi ; + +M: mdb-persistent id>> ( object -- id ) + dup class id-slot reader-word execute( object -- id ) ; + +M: mdb-persistent (>>id) ( object value -- ) + over class id-slot writer-word execute( object value -- ) ; + + + TUPLE: mdb-tuple-collection < mdb-collection { classes } ; GENERIC: tuple-collection ( object -- mdb-collection ) -GENERIC: mdb-slot-map ( tuple -- string ) +GENERIC: mdb-slot-map ( tuple -- assoc ) + +GENERIC: mdb-index-map ( tuple -- sequence ) assoc ( seq -- assoc ) - [ dup assoc? - [ 1array { "" } append ] unless ] map ; - : optl>map ( seq -- map ) - H{ } clone tuck - '[ split-optl opt>assoc swap _ set-at ] each ; inline + [ H{ } clone ] dip over + '[ split-optl swap _ set-at ] each ; inline + +: index-list>map ( seq -- map ) + [ H{ } clone ] dip over + '[ dup name>> _ set-at ] each ; inline + +: user-defined-key ( map -- key value ? ) + [ nip [ +user-defined-key+ ] dip member? ] assoc-find ; inline + +: user-defined-key-index ( class -- assoc ) + mdb-slot-map user-defined-key + [ drop [ "user-defined-key-index" 1 ] dip + H{ } clone [ set-at ] keep unique-index + [ ] [ name>> ] bi H{ } clone [ set-at ] keep + ] [ 2drop H{ } clone ] if ; PRIVATE> @@ -65,9 +110,15 @@ PRIVATE> over all-slots [ name>> ] map [ MDB_OID_FIELD ] dip member? [ ] [ MDB_ADDON_SLOTS prepend ] if ; inline -: set-slot-map ( class options -- ) - optl>map MDB_SLOTDEF_LIST set-word-prop ; inline - +: set-slot-map ( class option-list -- ) + optl>map [ MDB_SLOTDEF_MAP set-word-prop ] 2keep + user-defined-key + [ drop MDB_USER_KEY set-word-prop ] [ 3drop ] if ; inline + +: set-index-map ( class index-list -- ) + [ [ dup user-defined-key-index ] dip index-list>map ] output>sequence + assoc-combine MDB_INDEX_MAP set-word-prop ; inline + M: tuple-class tuple-collection ( tuple -- mdb-collection ) (mdb-collection) ; @@ -83,6 +134,13 @@ M: tuple-class mdb-slot-map ( class -- assoc ) M: mdb-collection mdb-slot-map ( collection -- assoc ) classes>> [ mdb-slot-map ] map assoc-combine ; +M: mdb-persistent mdb-index-map + class (mdb-index-map) ; +M: tuple-class mdb-index-map + (mdb-index-map) ; +M: mdb-collection mdb-index-map + classes>> [ mdb-index-map ] map assoc-combine ; + GENERIC: ( name -- mdb-tuple-collection ) -M: string ( name -- mdb-tuple-collection ) +M: string collection-map [ ] [ key? ] 2bi [ at ] [ [ mdb-tuple-collection new dup ] 2dip [ [ >>name ] keep ] dip set-at ] if ; inline -M: mdb-tuple-collection ( mdb-tuple-collection -- mdb-tuple-collection ) ; -M: mdb-collection ( mdb-collection -- mdb-tuple-collection ) +M: mdb-tuple-collection ; +M: mdb-collection [ name>> ] keep { [ capped>> >>capped ] @@ -110,6 +168,9 @@ M: mdb-collection ( mdb-collection -- mdb-tuple-collectio [ max>> >>max ] } cleave ; +: user-defined-key? ( tuple slot -- ? ) + +user-defined-key+ slot-option? ; + : transient-slot? ( tuple slot -- ? ) +transient+ slot-option? ; diff --git a/extra/mongodb/tuple/index/authors.txt b/extra/mongodb/tuple/index/authors.txt deleted file mode 100644 index 5df962bfe0..0000000000 --- a/extra/mongodb/tuple/index/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Sascha Matzke diff --git a/extra/mongodb/tuple/index/index.factor b/extra/mongodb/tuple/index/index.factor deleted file mode 100644 index 1e7a679df3..0000000000 --- a/extra/mongodb/tuple/index/index.factor +++ /dev/null @@ -1,56 +0,0 @@ -USING: kernel fry accessors formatting linked-assocs assocs sequences sequences.deep -mongodb.tuple.collection combinators mongodb.tuple.collection ; - -IN: mongodb.tuple - -SINGLETONS: +fieldindex+ +compoundindex+ +deepindex+ ; - -IN: mongodb.tuple.index - -TUPLE: tuple-index name spec ; - - ] 2dip - [ rest ] keep first ! assoc slot options itype - { { +fieldindex+ [ drop [ 1 ] dip pick set-at ] } - { +deepindex+ [ first "%s.%s" sprintf [ 1 ] dip pick set-at ] } - { +compoundindex+ [ - 2over swap [ 1 ] 2dip set-at [ drop ] dip ! assoc options - over '[ _ [ 1 ] 2dip set-at ] each ] } - } case ; - -: build-index-seq ( slot optlist -- index-seq ) - [ V{ } clone ] 2dip pick ! v{} slot optl v{} - [ swap ] dip ! v{} optl slot v{ } - '[ _ tuple-index new ! element slot exemplar - 2over swap index-name >>name ! element slot clone - [ build-index ] dip swap >>spec _ push - ] each ; - -: is-index-declaration? ( entry -- ? ) - first - { { +fieldindex+ [ t ] } - { +compoundindex+ [ t ] } - { +deepindex+ [ t ] } - [ drop f ] } case ; - -PRIVATE> - -: tuple-index-list ( mdb-collection/class -- seq ) - mdb-slot-map V{ } clone tuck - '[ [ is-index-declaration? ] filter - build-index-seq _ push - ] assoc-each flatten ; - diff --git a/extra/mongodb/tuple/index/summary.txt b/extra/mongodb/tuple/index/summary.txt deleted file mode 100644 index e4a15492be..0000000000 --- a/extra/mongodb/tuple/index/summary.txt +++ /dev/null @@ -1 +0,0 @@ -tuple class index handling diff --git a/extra/mongodb/tuple/persistent/persistent.factor b/extra/mongodb/tuple/persistent/persistent.factor index 061b27dd1b..fc521eca3e 100644 --- a/extra/mongodb/tuple/persistent/persistent.factor +++ b/extra/mongodb/tuple/persistent/persistent.factor @@ -27,8 +27,7 @@ DEFER: assoc>tuple : make-tuple ( assoc -- tuple ) prepare-assoc>tuple - '[ dup _ at assoc>tuple swap _ set-at ] each - [ mark-persistent ] keep ; inline recursive + '[ dup _ at assoc>tuple swap _ set-at ] each ; inline recursive : at+ ( value key assoc -- value ) 2dup key? @@ -38,9 +37,9 @@ DEFER: assoc>tuple dup tuple? [ assoc? not ] [ drop f ] if ; inline -: add-storable ( assoc ns -- ) - [ H{ } clone ] dip object-map get at+ - [ dup [ MDB_OID_FIELD ] dip at ] dip set-at ; inline +: add-storable ( assoc ns toid -- ) + [ [ H{ } clone ] dip object-map get at+ ] dip + swap set-at ; inline : write-field? ( tuple key value -- ? ) pick mdb-persistent? [ @@ -52,10 +51,10 @@ TUPLE: cond-value value quot ; CONSTRUCTOR: cond-value ( value quot -- cond-value ) ; : write-mdb-persistent ( value quot: ( tuple -- assoc ) -- value' ) - over [ (( tuple -- assoc )) call-effect ] dip - [ tuple-collection name>> ] keep + over [ call( tuple -- assoc ) ] dip + [ [ tuple-collection name>> ] [ >toid ] bi ] keep [ add-storable ] dip - [ tuple-collection name>> ] [ _id>> ] bi ; inline + [ tuple-collection name>> ] [ id>> ] bi ; inline : write-field ( value quot: ( tuple -- assoc ) -- value' ) { @@ -80,8 +79,7 @@ CONSTRUCTOR: cond-value ( value quot -- cond-value ) ; H{ } clone swap [ ] keep pick ; inline : ensure-mdb-info ( tuple -- tuple ) - dup _id>> [ >>_id ] unless - [ mark-persistent ] keep ; inline + dup id>> [ >>id ] unless ; inline : with-object-map ( quot: ( -- ) -- store-assoc ) [ H{ } clone dup object-map ] dip with-variable ; inline @@ -107,9 +105,9 @@ M: tuple tuple>selector ( tuple -- assoc ) prepare-assoc [ tuple>selector ] write-tuple-fields ; : assoc>tuple ( assoc -- tuple ) - dup assoc? - [ [ dup tuple-info? - [ make-tuple ] - [ ] if ] [ drop ] recover - ] [ ] if ; inline recursive + dup assoc? + [ [ dup tuple-info? + [ make-tuple ] + [ ] if ] [ drop ] recover + ] [ ] if ; inline recursive diff --git a/extra/mongodb/tuple/state/state.factor b/extra/mongodb/tuple/state/state.factor index 21923637e5..ec1b8865ab 100644 --- a/extra/mongodb/tuple/state/state.factor +++ b/extra/mongodb/tuple/state/state.factor @@ -6,17 +6,9 @@ IN: mongodb.tuple.state -SYMBOL: mdb-dirty-handling? - -: advised-with? ( name word loc -- ? ) - word-prop key? ; inline - : ( tuple -- tuple-info ) class V{ } clone tuck [ [ name>> ] dip push ] @@ -31,22 +23,3 @@ SYMBOL: mdb-dirty-handling? : tuple-info? ( assoc -- ? ) [ MDB_TUPLE_INFO ] dip key? ; -: tuple-meta ( tuple -- assoc ) - dup _mfd>> [ ] [ H{ } clone [ >>_mfd ] keep ] if* nip ; inline - -: dirty? ( tuple -- ? ) - [ MDB_DIRTY_FLAG ] dip tuple-meta at ; - -: mark-dirty ( tuple -- ) - [ t MDB_DIRTY_FLAG ] dip tuple-meta set-at ; - -: persistent? ( tuple -- ? ) - [ MDB_PERSISTENT_FLAG ] dip tuple-meta at ; - -: mark-persistent ( tuple -- ) - [ t MDB_PERSISTENT_FLAG ] dip tuple-meta [ set-at ] keep - [ f MDB_DIRTY_FLAG ] dip set-at ; - -: needs-store? ( tuple -- ? ) - [ persistent? not ] [ dirty? ] bi or ; - diff --git a/extra/mongodb/tuple/tuple.factor b/extra/mongodb/tuple/tuple.factor index 19281b769a..9173957979 100644 --- a/extra/mongodb/tuple/tuple.factor +++ b/extra/mongodb/tuple/tuple.factor @@ -1,26 +1,28 @@ USING: accessors assocs classes.mixin classes.tuple classes.tuple.parser compiler.units fry kernel sequences mongodb.driver -mongodb.msg mongodb.tuple.collection mongodb.tuple.index +mongodb.msg mongodb.tuple.collection mongodb.tuple.persistent mongodb.tuple.state strings ; IN: mongodb.tuple +SINGLETONS: +fieldindex+ +compoundindex+ +deepindex+ +unique+ ; + SYNTAX: MDBTUPLE: parse-tuple-definition mdb-check-slots define-tuple-class ; -: define-persistent ( class collection options -- ) - [ [ dupd link-collection ] when* ] dip - [ dup '[ _ mdb-persistent add-mixin-instance ] with-compilation-unit ] dip - ! [ dup annotate-writers ] dip - set-slot-map ; +: define-persistent ( class collection slot-options index -- ) + [ [ dupd link-collection ] when* ] 2dip + [ dup '[ _ mdb-persistent add-mixin-instance ] with-compilation-unit ] 2dip + [ drop set-slot-map ] + [ nip set-index-map ] 3bi ; inline : ensure-table ( class -- ) tuple-collection [ create-collection ] - [ [ tuple-index-list ] keep - '[ _ name>> swap [ name>> ] [ spec>> ] bi ensure-index ] each + [ [ mdb-index-map values ] keep + '[ _ name>> >>ns ensure-index ] each ] bi ; : ensure-tables ( classes -- ) @@ -28,7 +30,7 @@ SYNTAX: MDBTUPLE: : drop-table ( class -- ) tuple-collection - [ [ tuple-index-list ] keep + [ [ mdb-index-map values ] keep '[ _ name>> swap name>> drop-index ] each ] [ name>> drop-collection ] bi ; @@ -40,11 +42,11 @@ SYNTAX: MDBTUPLE: GENERIC: id-selector ( object -- selector ) -M: string id-selector ( objid -- selector ) - "_id" H{ } clone [ set-at ] keep ; inline +M: toid id-selector + [ value>> ] [ key>> ] bi H{ } clone [ set-at ] keep ; inline -M: mdb-persistent id-selector ( mdb-persistent -- selector ) - _id>> id-selector ; +M: mdb-persistent id-selector + >toid id-selector ; : (save-tuples) ( collection assoc -- ) swap '[ [ _ ] 2dip @@ -62,9 +64,8 @@ PRIVATE> save-tuple ; : delete-tuple ( tuple -- ) - dup persistent? - [ [ tuple-collection name>> ] keep - id-selector delete ] [ drop ] if ; + [ tuple-collection name>> ] keep + id-selector delete ; : tuple>query ( tuple -- query ) [ tuple-collection name>> ] keep diff --git a/extra/opengl/demo-support/demo-support.factor b/extra/opengl/demo-support/demo-support.factor index 5973766c8e..35c64d4ad1 100755 --- a/extra/opengl/demo-support/demo-support.factor +++ b/extra/opengl/demo-support/demo-support.factor @@ -1,6 +1,6 @@ USING: arrays kernel math math.functions math.order math.vectors namespaces opengl opengl.gl sequences ui ui.gadgets ui.gestures -ui.render accessors combinators ; +ui.gadgets.worlds ui.render accessors combinators ; IN: opengl.demo-support : FOV ( -- x ) 2.0 sqrt 1+ ; inline @@ -9,62 +9,62 @@ CONSTANT: KEY-ROTATE-STEP 10.0 SYMBOL: last-drag-loc -TUPLE: demo-gadget < gadget yaw pitch distance ; +TUPLE: demo-world < world yaw pitch distance ; -: new-demo-gadget ( yaw pitch distance class -- gadget ) - new - swap >>distance - swap >>pitch - swap >>yaw ; inline +: set-demo-orientation ( world yaw pitch distance -- world ) + [ >>yaw ] [ >>pitch ] [ >>distance ] tri* ; GENERIC: far-plane ( gadget -- z ) GENERIC: near-plane ( gadget -- z ) GENERIC: distance-step ( gadget -- dz ) -M: demo-gadget far-plane ( gadget -- z ) +M: demo-world far-plane ( gadget -- z ) drop 4.0 ; -M: demo-gadget near-plane ( gadget -- z ) +M: demo-world near-plane ( gadget -- z ) drop 1.0 64.0 / ; -M: demo-gadget distance-step ( gadget -- dz ) +M: demo-world distance-step ( gadget -- dz ) drop 1.0 64.0 / ; : fov-ratio ( gadget -- fov ) dim>> dup first2 min v/n ; -: yaw-demo-gadget ( yaw gadget -- ) +: yaw-demo-world ( yaw gadget -- ) [ + ] with change-yaw relayout-1 ; -: pitch-demo-gadget ( pitch gadget -- ) +: pitch-demo-world ( pitch gadget -- ) [ + ] with change-pitch relayout-1 ; -: zoom-demo-gadget ( distance gadget -- ) +: zoom-demo-world ( distance gadget -- ) [ + ] with change-distance relayout-1 ; -M: demo-gadget pref-dim* ( gadget -- dim ) +M: demo-world focusable-child* ( world -- gadget ) + drop t ; + +M: demo-world pref-dim* ( gadget -- dim ) drop { 640 480 } ; : -+ ( x -- -x x ) [ neg ] keep ; -: demo-gadget-frustum ( gadget -- -x x -y y near far ) +: demo-world-frustum ( world -- -x x -y y near far ) [ near-plane ] [ far-plane ] [ fov-ratio ] tri [ nip swap FOV / v*n first2 [ -+ ] bi@ ] 3keep drop ; -: demo-gadget-set-matrices ( gadget -- ) +M: demo-world resize-world + GL_PROJECTION glMatrixMode + glLoadIdentity + [ [ 0 0 ] dip dim>> first2 glViewport ] + [ demo-world-frustum glFrustum ] bi ; + +: demo-world-set-matrix ( gadget -- ) GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT bitor glClear - [ - GL_PROJECTION glMatrixMode - glLoadIdentity - demo-gadget-frustum glFrustum - ] [ - GL_MODELVIEW glMatrixMode - glLoadIdentity - [ [ 0.0 0.0 ] dip distance>> neg glTranslatef ] - [ pitch>> 1.0 0.0 0.0 glRotatef ] - [ yaw>> 0.0 1.0 0.0 glRotatef ] - tri - ] bi ; + GL_MODELVIEW glMatrixMode + glLoadIdentity + [ [ 0.0 0.0 ] dip distance>> neg glTranslatef ] + [ pitch>> 1.0 0.0 0.0 glRotatef ] + [ yaw>> 0.0 1.0 0.0 glRotatef ] + tri ; : reset-last-drag-rel ( -- ) { 0 0 } last-drag-loc set-global ; @@ -94,16 +94,16 @@ M: demo-gadget pref-dim* ( gadget -- dim ) swap first swap second glVertex2d ] do-state ; -demo-gadget H{ - { T{ key-down f f "LEFT" } [ KEY-ROTATE-STEP neg swap yaw-demo-gadget ] } - { T{ key-down f f "RIGHT" } [ KEY-ROTATE-STEP swap yaw-demo-gadget ] } - { T{ key-down f f "DOWN" } [ KEY-ROTATE-STEP neg swap pitch-demo-gadget ] } - { T{ key-down f f "UP" } [ KEY-ROTATE-STEP swap pitch-demo-gadget ] } - { T{ key-down f f "=" } [ dup distance-step neg swap zoom-demo-gadget ] } - { T{ key-down f f "-" } [ dup distance-step swap zoom-demo-gadget ] } +demo-world H{ + { T{ key-down f f "LEFT" } [ KEY-ROTATE-STEP neg swap yaw-demo-world ] } + { T{ key-down f f "RIGHT" } [ KEY-ROTATE-STEP swap yaw-demo-world ] } + { T{ key-down f f "DOWN" } [ KEY-ROTATE-STEP neg swap pitch-demo-world ] } + { T{ key-down f f "UP" } [ KEY-ROTATE-STEP swap pitch-demo-world ] } + { T{ key-down f f "=" } [ dup distance-step neg swap zoom-demo-world ] } + { T{ key-down f f "-" } [ dup distance-step swap zoom-demo-world ] } { T{ button-down f f 1 } [ drop reset-last-drag-rel ] } - { T{ drag f 1 } [ drag-yaw-pitch rot [ pitch-demo-gadget ] keep yaw-demo-gadget ] } - { mouse-scroll [ scroll-direction get second over distance-step * swap zoom-demo-gadget ] } + { T{ drag f 1 } [ drag-yaw-pitch rot [ pitch-demo-world ] keep yaw-demo-world ] } + { mouse-scroll [ scroll-direction get second over distance-step * swap zoom-demo-world ] } } set-gestures diff --git a/extra/otug-talk/otug-talk.factor b/extra/otug-talk/otug-talk.factor index b7256246fe..35a83a63de 100644 --- a/extra/otug-talk/otug-talk.factor +++ b/extra/otug-talk/otug-talk.factor @@ -1,12 +1,12 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: slides help.markup math arrays hashtables namespaces sequences -kernel sequences parser memoize io.encodings.binary locals -kernel.private help.vocabs assocs quotations tools.vocabs +USING: slides help.markup math arrays hashtables namespaces +sequences kernel sequences parser memoize io.encodings.binary +locals kernel.private help.vocabs assocs quotations tools.annotations tools.crossref help.topics math.functions -compiler.tree.optimizer compiler.cfg.optimizer fry ui.gadgets.panes -tetris tetris.game combinators generalizations multiline -sequences.private ; +compiler.tree.optimizer compiler.cfg.optimizer fry +ui.gadgets.panes tetris tetris.game combinators generalizations +multiline sequences.private ; IN: otug-talk : $tetris ( element -- ) diff --git a/extra/spheres/spheres.factor b/extra/spheres/spheres.factor index fa666dd776..710c953ed1 100755 --- a/extra/spheres/spheres.factor +++ b/extra/spheres/spheres.factor @@ -1,7 +1,8 @@ USING: kernel opengl opengl.demo-support opengl.gl opengl.textures opengl.shaders opengl.framebuffers opengl.capabilities multiline ui.gadgets accessors sequences ui.render ui math locals arrays -generalizations combinators ui.gadgets.worlds ; +generalizations combinators ui.gadgets.worlds +literals ui.pixel-formats ; IN: spheres STRING: plane-vertex-shader @@ -110,19 +111,16 @@ main() } ; -TUPLE: spheres-gadget < demo-gadget +TUPLE: spheres-world < demo-world plane-program solid-sphere-program texture-sphere-program reflection-framebuffer reflection-depthbuffer - reflection-texture initialized? ; + reflection-texture ; -: ( -- gadget ) - 20.0 10.0 20.0 spheres-gadget new-demo-gadget ; - -M: spheres-gadget near-plane ( gadget -- z ) +M: spheres-world near-plane ( gadget -- z ) drop 1.0 ; -M: spheres-gadget far-plane ( gadget -- z ) +M: spheres-world far-plane ( gadget -- z ) drop 512.0 ; -M: spheres-gadget distance-step ( gadget -- dz ) +M: spheres-world distance-step ( gadget -- dz ) drop 0.5 ; : (reflection-dim) ( -- w h ) @@ -136,12 +134,14 @@ M: spheres-gadget distance-step ( gadget -- dz ) GL_TEXTURE_CUBE_MAP GL_TEXTURE_WRAP_S GL_CLAMP glTexParameteri GL_TEXTURE_CUBE_MAP GL_TEXTURE_WRAP_T GL_CLAMP glTexParameteri GL_TEXTURE_CUBE_MAP GL_TEXTURE_WRAP_R GL_CLAMP glTexParameteri - GL_TEXTURE_CUBE_MAP_POSITIVE_X - GL_TEXTURE_CUBE_MAP_POSITIVE_Y - GL_TEXTURE_CUBE_MAP_POSITIVE_Z - GL_TEXTURE_CUBE_MAP_NEGATIVE_X - GL_TEXTURE_CUBE_MAP_NEGATIVE_Y - GL_TEXTURE_CUBE_MAP_NEGATIVE_Z 6 narray + ${ + GL_TEXTURE_CUBE_MAP_POSITIVE_X + GL_TEXTURE_CUBE_MAP_POSITIVE_Y + GL_TEXTURE_CUBE_MAP_POSITIVE_Z + GL_TEXTURE_CUBE_MAP_NEGATIVE_X + GL_TEXTURE_CUBE_MAP_NEGATIVE_Y + GL_TEXTURE_CUBE_MAP_NEGATIVE_Z + } [ 0 GL_RGBA8 (reflection-dim) 0 GL_RGBA GL_UNSIGNED_BYTE f glTexImage2D ] each ] keep ; @@ -171,22 +171,19 @@ M: spheres-gadget distance-step ( gadget -- dz ) sphere-main-fragment-shader check-gl-shader 3array check-gl-program ; -M: spheres-gadget graft* ( gadget -- ) - dup find-gl-context +M: spheres-world begin-world "2.0" { "GL_ARB_shader_objects" } require-gl-version-or-extensions { "GL_EXT_framebuffer_object" } require-gl-extensions + 20.0 10.0 20.0 set-demo-orientation (plane-program) >>plane-program (solid-sphere-program) >>solid-sphere-program (texture-sphere-program) >>texture-sphere-program (make-reflection-texture) >>reflection-texture (make-reflection-depthbuffer) [ >>reflection-depthbuffer ] keep (make-reflection-framebuffer) >>reflection-framebuffer - t >>initialized? drop ; -M: spheres-gadget ungraft* ( gadget -- ) - f >>initialized? - dup find-gl-context +M: spheres-world end-world { [ reflection-framebuffer>> [ delete-framebuffer ] when* ] [ reflection-depthbuffer>> [ delete-renderbuffer ] when* ] @@ -196,7 +193,7 @@ M: spheres-gadget ungraft* ( gadget -- ) [ plane-program>> [ delete-gl-program ] when* ] } cleave ; -M: spheres-gadget pref-dim* ( gadget -- dim ) +M: spheres-world pref-dim* ( gadget -- dim ) drop { 640 480 } ; :: (draw-sphere) ( program center radius -- ) @@ -254,7 +251,7 @@ M: spheres-gadget pref-dim* ( gadget -- dim ) [ drop 0 0 (reflection-dim) glViewport ] [ GL_PROJECTION glMatrixMode - glLoadIdentity + glPushMatrix glLoadIdentity reflection-frustum glFrustum GL_MODELVIEW glMatrixMode glLoadIdentity @@ -277,15 +274,19 @@ M: spheres-gadget pref-dim* ( gadget -- dim ) [ GL_TEXTURE_CUBE_MAP_POSITIVE_Y (reflection-face) glPopMatrix 90.0 1.0 0.0 0.0 glRotatef ] [ sphere-scene ] - [ dim>> 0 0 rot first2 glViewport ] + [ + [ 0 0 ] dip dim>> first2 glViewport + GL_PROJECTION glMatrixMode + glPopMatrix + ] } cleave ] with-framebuffer ; -: (draw-gadget) ( gadget -- ) +M: spheres-world draw-world* GL_DEPTH_TEST glEnable GL_SCISSOR_TEST glDisable 0.15 0.15 1.0 1.0 glClearColor { [ (draw-reflection-texture) ] - [ demo-gadget-set-matrices ] + [ demo-world-set-matrix ] [ sphere-scene ] [ reflection-texture>> GL_TEXTURE_CUBE_MAP GL_TEXTURE0 bind-texture-unit ] [ @@ -297,10 +298,17 @@ M: spheres-gadget pref-dim* ( gadget -- dim ) ] } cleave ; -M: spheres-gadget draw-gadget* ( gadget -- ) - dup initialized?>> [ (draw-gadget) ] [ drop ] if ; - : spheres-window ( -- ) - [ "Spheres" open-window ] with-ui ; + [ + f T{ world-attributes + { world-class spheres-world } + { title "Spheres" } + { pixel-format-attributes { + windowed + double-buffered + T{ depth-bits { value 16 } } + } } + } open-window + ] with-ui ; MAIN: spheres-window diff --git a/extra/str-fry/str-fry.factor b/extra/str-fry/str-fry.factor index aafdaa95d9..bfe74f37eb 100644 --- a/extra/str-fry/str-fry.factor +++ b/extra/str-fry/str-fry.factor @@ -1,4 +1,7 @@ -USING: kernel sequences splitting strings.parser ; +USING: combinators effects kernel math sequences splitting +strings.parser ; IN: str-fry -: str-fry ( str -- quot ) "_" split unclip [ [ rot glue ] reduce ] 2curry ; +: str-fry ( str -- quot ) "_" split + [ unclip [ [ rot glue ] reduce ] 2curry ] + [ length 1 - 1 [ call-effect ] 2curry ] bi ; SYNTAX: I" parse-string rest str-fry over push-all ; \ No newline at end of file diff --git a/extra/ui/frp/frp-docs.factor b/extra/ui/frp/frp-docs.factor index af44567e46..479a56e513 100644 --- a/extra/ui/frp/frp-docs.factor +++ b/extra/ui/frp/frp-docs.factor @@ -36,7 +36,7 @@ HELP: { $values { "oldval" "starting value" } { "quot" "applied to update and previous values" } { "model" model } { "model'" model } } { $description "Similar to " { $link reduce } " but works on models, applying a quotation to the previous and new values at each update" } ; -HELP: switch +HELP: { $values { "signal1" model } { "signal2" model } { "signal'" model } } { $description "Creates a model that starts with the behavior of model1 and switches to the behavior of model2 on its update" } ; diff --git a/extra/ui/frp/frp.factor b/extra/ui/frp/frp.factor index aa7c44ee03..699d034c72 100644 --- a/extra/ui/frp/frp.factor +++ b/extra/ui/frp/frp.factor @@ -1,7 +1,7 @@ -USING: accessors arrays colors fonts fry kernel models +USING: accessors arrays colors fonts kernel models models.product monads sequences ui.gadgets ui.gadgets.buttons ui.gadgets.editors ui.gadgets.line-support ui.gadgets.tables -ui.gadgets.tracks ui.render ; +ui.gadgets.tracks ui.render ui.gadgets.scrollers ; QUALIFIED: make IN: ui.frp @@ -18,8 +18,11 @@ M: frp-table row-color color-quot>> [ call( a -- b ) ] [ drop f ] if* ; frp-table new-line-gadget dup >>renderer [ ] >>quot swap >>model f >>selected-value sans-serif-font >>font focus-border-color >>focus-border-color - transparent >>column-line-color ; + transparent >>column-line-color [ ] >>val-quot ; +: ( -- table ) f ; : ( model -- table ) [ 1array ] >>quot ; +: ( -- table ) f ; + : ( -- field ) f ; ! Layout utilities @@ -27,6 +30,8 @@ M: frp-table row-color color-quot>> [ call( a -- b ) ] [ drop f ] if* ; GENERIC: output-model ( gadget -- model ) M: gadget output-model model>> ; M: frp-table output-model selected-value>> ; +M: model-field output-model field-model>> ; +M: scroller output-model children>> first model>> ; GENERIC: , ( uiitem -- ) M: gadget , make:, ; @@ -41,13 +46,16 @@ M: table -> dup , selected-value>> ; [ { } make:make ] dip swap [ f track-add ] each ; inline : ( gadgets type -- track ) [ ] [ [ model>> ] map ] bi >>model ; inline : ( gadgets -- track ) horizontal ; inline +: ( gadgets -- track ) horizontal ; inline : ( gadgets -- track ) vertical ; inline +: ( gadgets -- track ) vertical ; inline -! Model utilities +! !!! Model utilities TUPLE: multi-model < model ; -! M: multi-model model-activated dup model-changed ; : ( models kind -- model ) f swap new-model [ [ add-dependency ] curry each ] keep ; +! Events- discrete model utilities + TUPLE: merge-model < multi-model ; M: merge-model model-changed [ value>> ] dip set-model ; : ( models -- model ) merge-model ; @@ -57,15 +65,21 @@ M: filter-model model-changed [ value>> ] dip [ quot>> call( val -- bool ) ] 2ke [ set-model ] [ 2drop ] if ; : ( model quot -- filter-model ) [ 1array filter-model ] dip >>quot ; +! Behaviors - continuous model utilities + TUPLE: fold-model < multi-model oldval quot ; M: fold-model model-changed [ [ value>> ] [ [ oldval>> ] [ quot>> ] bi ] bi* call( val oldval -- newval ) ] keep set-model ; -: ( oldval quot model -- model' ) 1array fold-model swap >>quot swap >>oldval ; +: ( oldval quot model -- model' ) 1array fold-model swap >>quot + swap [ >>oldval ] [ >>value ] bi ; -TUPLE: switch-model < multi-model switcher on ; -M: switch-model model-changed tuck [ switcher>> = ] 2keep - '[ on>> [ _ value>> _ set-model ] when ] [ t swap (>>on) ] if ; -: switch ( signal1 signal2 -- signal' ) [ 2array switch-model ] keep >>switcher ; +TUPLE: switch-model < multi-model original switcher on ; +M: switch-model model-changed 2dup switcher>> = + [ over value>> [ [ value>> ] [ t >>on ] bi* set-model ] [ 2drop ] if ] + [ dup on>> [ 2drop ] [ [ value>> ] dip set-model ] if ] if ; +M: switch-model model-activated [ original>> ] keep model-changed ; +: ( signal1 signal2 -- signal' ) [ 2array switch-model ] 2keep + [ >>original ] [ >>switcher ] bi* ; TUPLE: mapped < model model quot ; @@ -87,4 +101,4 @@ INSTANCE: gadget-monad monad INSTANCE: gadget monad M: gadget monad-of drop gadget-monad ; M: gadget-monad return drop swap >>model ; -M: gadget >>= model>> '[ _ swap call( x -- y ) ] ; \ No newline at end of file +M: gadget >>= output-model [ swap call( x -- y ) ] curry ; \ No newline at end of file diff --git a/extra/vpri-talk/vpri-talk.factor b/extra/vpri-talk/vpri-talk.factor index 1e5c9602b9..4ee499bf50 100644 --- a/extra/vpri-talk/vpri-talk.factor +++ b/extra/vpri-talk/vpri-talk.factor @@ -2,10 +2,10 @@ ! See http://factorcode.org/license.txt for BSD license. USING: slides help.markup math arrays hashtables namespaces sequences kernel sequences parser memoize io.encodings.binary -locals kernel.private help.vocabs assocs quotations -urls peg.ebnf tools.vocabs tools.annotations tools.crossref -help.topics math.functions compiler.tree.optimizer -compiler.cfg.optimizer fry ; +locals kernel.private help.vocabs assocs quotations urls +peg.ebnf tools.annotations tools.crossref help.topics +math.functions compiler.tree.optimizer compiler.cfg.optimizer +fry ; IN: vpri-talk CONSTANT: vpri-slides diff --git a/extra/ui/offscreen/authors.txt b/unmaintained/ui/offscreen/authors.txt similarity index 100% rename from extra/ui/offscreen/authors.txt rename to unmaintained/ui/offscreen/authors.txt diff --git a/extra/ui/offscreen/offscreen-docs.factor b/unmaintained/ui/offscreen/offscreen-docs.factor similarity index 100% rename from extra/ui/offscreen/offscreen-docs.factor rename to unmaintained/ui/offscreen/offscreen-docs.factor diff --git a/extra/ui/offscreen/offscreen.factor b/unmaintained/ui/offscreen/offscreen.factor similarity index 100% rename from extra/ui/offscreen/offscreen.factor rename to unmaintained/ui/offscreen/offscreen.factor diff --git a/extra/ui/offscreen/summary.txt b/unmaintained/ui/offscreen/summary.txt similarity index 100% rename from extra/ui/offscreen/summary.txt rename to unmaintained/ui/offscreen/summary.txt diff --git a/extra/ui/offscreen/tags.txt b/unmaintained/ui/offscreen/tags.txt similarity index 100% rename from extra/ui/offscreen/tags.txt rename to unmaintained/ui/offscreen/tags.txt diff --git a/vm/Config.arm b/vm/Config.arm index 2273d61caf..1d7e6f9cc6 100644 --- a/vm/Config.arm +++ b/vm/Config.arm @@ -1 +1 @@ -PLAF_DLL_OBJS += vm/cpu-arm.o +PLAF_DLL_OBJS += vmpp/cpu-arm.o diff --git a/vm/Config.macosx b/vm/Config.macosx index 98d14cfdf4..07629f72bb 100644 --- a/vm/Config.macosx +++ b/vm/Config.macosx @@ -14,7 +14,7 @@ else 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 \ diff --git a/vm/alien.c b/vm/alien.cpp similarity index 50% rename from vm/alien.c rename to vm/alien.cpp index 2681579c5d..6a8c334788 100755 --- a/vm/alien.c +++ b/vm/alien.cpp @@ -1,97 +1,61 @@ -#include "master.h" +#include "master.hpp" -/* gets the address of an object representing a C pointer */ -void *alien_offset(CELL object) +namespace factor { - 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) +char *pinned_alien_offset(cell obj) { - F_ALIEN *alien; - - switch(type_of(object)) + switch(tagged(obj).type()) { 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; + { + alien *ptr = untag(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,object); + type_error(ALIEN_TYPE,obj); 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) +cell allot_alien(cell delegate_, cell displacement) { - REGISTER_ROOT(delegate); - F_ALIEN *alien = allot_object(ALIEN_TYPE,sizeof(F_ALIEN)); - UNREGISTER_ROOT(delegate); + gc_root delegate(delegate_); + gc_root new_alien(allot(sizeof(alien))); - if(type_of(delegate) == ALIEN_TYPE) + if(delegate.type_p(ALIEN_TYPE)) { - F_ALIEN *delegate_alien = untag_object(delegate); + tagged delegate_alien = delegate.as(); displacement += delegate_alien->displacement; - alien->alien = delegate_alien->alien; + new_alien->alien = delegate_alien->alien; } else - alien->alien = delegate; + new_alien->alien = delegate.value(); - alien->displacement = displacement; - alien->expired = F; - return tag_object(alien); -} + new_alien->displacement = displacement; + new_alien->expired = F; -/* make an alien and push */ -void box_alien(void *ptr) -{ - if(ptr == NULL) - dpush(F); - else - dpush(allot_alien(F,(CELL)ptr)); + return new_alien.value(); } /* make an alien pointing at an offset of another alien */ -void primitive_displaced_alien(void) +PRIMITIVE(displaced_alien) { - CELL alien = dpop(); - CELL displacement = to_cell(dpop()); + cell alien = dpop(); + cell displacement = to_cell(dpop()); if(alien == F && displacement == 0) dpush(F); else { - switch(type_of(alien)) + switch(tagged(alien).type()) { case BYTE_ARRAY_TYPE: case ALIEN_TYPE: @@ -107,33 +71,33 @@ void primitive_displaced_alien(void) /* 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) +PRIMITIVE(alien_address) { - box_unsigned_cell((CELL)pinned_alien_offset(dpop())); + box_unsigned_cell((cell)pinned_alien_offset(dpop())); } /* pop ( alien n ) from datastack, return alien's address plus n */ -INLINE void *alien_pointer(void) +static void *alien_pointer(void) { - F_FIXNUM offset = to_fixnum(dpop()); + 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) \ + PRIMITIVE(alien_##name) \ { \ boxer(*(type*)alien_pointer()); \ } \ - void primitive_set_alien_##name(void) \ + PRIMITIVE(set_alien_##name) \ { \ - type* ptr = alien_pointer(); \ + type *ptr = (type *)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_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) @@ -146,33 +110,119 @@ 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 path(dpop()); + path.untag_check(); + gc_root dll(allot(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 library(dpop()); + gc_root 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 d = library.as(); + 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(dpop())); +} + +PRIMITIVE(dll_validp) +{ + cell library = dpop(); + if(library == F) + dpush(T); + else + dpush(tagged(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(obj).type()) + { + case BYTE_ARRAY_TYPE: + return untag(obj)->data(); + case ALIEN_TYPE: + { + alien *ptr = untag(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 */ -void to_value_struct(CELL src, void *dest, CELL size) +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 */ -void box_value_struct(void *src, CELL size) +VM_C_API 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)); + byte_array *bytes = allot_byte_array(size); + memcpy(bytes->data(),src,size); + dpush(tag(bytes)); } /* On some x86 OSes, structs <= 8 bytes are returned in registers. */ -void box_small_struct(CELL x, CELL y, CELL size) +VM_C_API void box_small_struct(cell x, cell y, cell size) { - CELL data[2]; + 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) +VM_C_API void box_medium_struct(cell x1, cell x2, cell x3, cell x4, cell size) { - CELL data[4]; + cell data[4]; data[0] = x1; data[1] = x2; data[2] = x3; @@ -180,55 +230,4 @@ void box_medium_struct(CELL x1, CELL x2, CELL x3, CELL x4, CELL size) 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); - } } diff --git a/vm/alien.h b/vm/alien.h deleted file mode 100755 index dc76d49810..0000000000 --- a/vm/alien.h +++ /dev/null @@ -1,50 +0,0 @@ -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); diff --git a/vm/alien.hpp b/vm/alien.hpp new file mode 100755 index 0000000000..a66135cf92 --- /dev/null +++ b/vm/alien.hpp @@ -0,0 +1,49 @@ +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); + +} diff --git a/vm/arrays.c b/vm/arrays.c deleted file mode 100644 index 4d5dc67818..0000000000 --- a/vm/arrays.c +++ /dev/null @@ -1,159 +0,0 @@ -#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; -} diff --git a/vm/arrays.cpp b/vm/arrays.cpp new file mode 100644 index 0000000000..f9a3f211d0 --- /dev/null +++ b/vm/arrays.cpp @@ -0,0 +1,87 @@ +#include "master.hpp" + +namespace factor +{ + +/* make a new array with an initial element */ +array *allot_array(cell capacity, cell fill_) +{ + gc_root fill(fill_); + gc_root new_array(allot_array_internal(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(allot_array(size,initial))); +} + +cell allot_array_1(cell obj_) +{ + gc_root obj(obj_); + gc_root a(allot_array_internal(1)); + set_array_nth(a.untagged(),0,obj.value()); + return a.value(); +} + +cell allot_array_2(cell v1_, cell v2_) +{ + gc_root v1(v1_); + gc_root v2(v2_); + gc_root a(allot_array_internal(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 v1(v1_); + gc_root v2(v2_); + gc_root v3(v3_); + gc_root v4(v4_); + gc_root a(allot_array_internal(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(dpop()); + cell capacity = unbox_array_size(); + dpush(tag(reallot_array(a,capacity))); +} + +void growable_array::add(cell elt_) +{ + gc_root 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); +} + +} diff --git a/vm/arrays.h b/vm/arrays.h deleted file mode 100644 index 3b2a065aba..0000000000 --- a/vm/arrays.h +++ /dev/null @@ -1,95 +0,0 @@ -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; diff --git a/vm/arrays.hpp b/vm/arrays.hpp new file mode 100644 index 0000000000..82da3bb71d --- /dev/null +++ b/vm/arrays.hpp @@ -0,0 +1,43 @@ +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 elements; + + growable_array() : count(0), elements(allot_array(2,F)) {} + + void add(cell elt); + void trim(); +}; + +} diff --git a/vm/bignum.c b/vm/bignum.cpp similarity index 84% rename from vm/bignum.c rename to vm/bignum.cpp index c799691f36..c487186da0 100755 --- a/vm/bignum.c +++ b/vm/bignum.cpp @@ -46,18 +46,23 @@ MIT in each case. */ * - Add local variable GC root recording * - Remove s48 prefix from function names * - Various fixes for Win64 + * - Port to C++ */ -#include "master.h" -#include +#include "master.hpp" + +#include + #include -#include /* abort */ #include +namespace factor +{ + /* Exports */ int -bignum_equal_p(bignum_type x, bignum_type y) +bignum_equal_p(bignum * x, bignum * y) { return ((BIGNUM_ZERO_P (x)) @@ -70,7 +75,7 @@ bignum_equal_p(bignum_type x, bignum_type y) } enum bignum_comparison -bignum_compare(bignum_type x, bignum_type y) +bignum_compare(bignum * x, bignum * y) { return ((BIGNUM_ZERO_P (x)) @@ -93,8 +98,8 @@ bignum_compare(bignum_type x, bignum_type y) } /* allocates memory */ -bignum_type -bignum_add(bignum_type x, bignum_type y) +bignum * +bignum_add(bignum * x, bignum * y) { return ((BIGNUM_ZERO_P (x)) @@ -111,8 +116,8 @@ bignum_add(bignum_type x, bignum_type y) } /* allocates memory */ -bignum_type -bignum_subtract(bignum_type x, bignum_type y) +bignum * +bignum_subtract(bignum * x, bignum * y) { return ((BIGNUM_ZERO_P (x)) @@ -131,8 +136,8 @@ bignum_subtract(bignum_type x, bignum_type y) } /* allocates memory */ -bignum_type -bignum_multiply(bignum_type x, bignum_type y) +bignum * +bignum_multiply(bignum * x, bignum * y) { bignum_length_type x_length = (BIGNUM_LENGTH (x)); bignum_length_type y_length = (BIGNUM_LENGTH (y)); @@ -165,8 +170,8 @@ bignum_multiply(bignum_type x, bignum_type y) /* allocates memory */ void -bignum_divide(bignum_type numerator, bignum_type denominator, - bignum_type * quotient, bignum_type * remainder) +bignum_divide(bignum * numerator, bignum * denominator, + bignum * * quotient, bignum * * remainder) { if (BIGNUM_ZERO_P (denominator)) { @@ -237,8 +242,8 @@ bignum_divide(bignum_type numerator, bignum_type denominator, } /* allocates memory */ -bignum_type -bignum_quotient(bignum_type numerator, bignum_type denominator) +bignum * +bignum_quotient(bignum * numerator, bignum * denominator) { if (BIGNUM_ZERO_P (denominator)) { @@ -261,7 +266,7 @@ bignum_quotient(bignum_type numerator, bignum_type denominator) case bignum_comparison_greater: default: /* to appease gcc -Wall */ { - bignum_type quotient; + bignum * quotient; if ((BIGNUM_LENGTH (denominator)) == 1) { bignum_digit_type digit = (BIGNUM_REF (denominator, 0)); @@ -270,18 +275,18 @@ bignum_quotient(bignum_type numerator, bignum_type denominator) if (digit < BIGNUM_RADIX_ROOT) bignum_divide_unsigned_small_denominator (numerator, digit, - ("ient), ((bignum_type *) 0), + ("ient), ((bignum * *) 0), q_negative_p, 0); else bignum_divide_unsigned_medium_denominator (numerator, digit, - ("ient), ((bignum_type *) 0), + ("ient), ((bignum * *) 0), q_negative_p, 0); } else bignum_divide_unsigned_large_denominator (numerator, denominator, - ("ient), ((bignum_type *) 0), + ("ient), ((bignum * *) 0), q_negative_p, 0); return (quotient); } @@ -290,8 +295,8 @@ bignum_quotient(bignum_type numerator, bignum_type denominator) } /* allocates memory */ -bignum_type -bignum_remainder(bignum_type numerator, bignum_type denominator) +bignum * +bignum_remainder(bignum * numerator, bignum * denominator) { if (BIGNUM_ZERO_P (denominator)) { @@ -309,7 +314,7 @@ bignum_remainder(bignum_type numerator, bignum_type denominator) case bignum_comparison_greater: default: /* to appease gcc -Wall */ { - bignum_type remainder; + bignum * remainder; if ((BIGNUM_LENGTH (denominator)) == 1) { bignum_digit_type digit = (BIGNUM_REF (denominator, 0)); @@ -321,13 +326,13 @@ bignum_remainder(bignum_type numerator, bignum_type denominator) (numerator, digit, (BIGNUM_NEGATIVE_P (numerator)))); bignum_divide_unsigned_medium_denominator (numerator, digit, - ((bignum_type *) 0), (&remainder), + ((bignum * *) 0), (&remainder), 0, (BIGNUM_NEGATIVE_P (numerator))); } else bignum_divide_unsigned_large_denominator (numerator, denominator, - ((bignum_type *) 0), (&remainder), + ((bignum * *) 0), (&remainder), 0, (BIGNUM_NEGATIVE_P (numerator))); return (remainder); } @@ -335,7 +340,7 @@ bignum_remainder(bignum_type numerator, bignum_type denominator) } #define FOO_TO_BIGNUM(name,type,utype) \ - bignum_type name##_to_bignum(type n) \ + bignum * name##_to_bignum(type n) \ { \ int negative_p; \ bignum_digit_type result_digits [BIGNUM_DIGITS_FOR(type)]; \ @@ -343,9 +348,9 @@ bignum_remainder(bignum_type numerator, bignum_type denominator) /* 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)); \ + if (n < (type)0 && n == (type)-1) return (BIGNUM_ONE (1)); \ { \ - utype accumulator = ((negative_p = (n < 0)) ? (-n) : n); \ + utype accumulator = ((negative_p = (n < (type)0)) ? (-n) : n); \ do \ { \ (*end_digits++) = (accumulator & BIGNUM_DIGIT_MASK); \ @@ -354,7 +359,7 @@ bignum_remainder(bignum_type numerator, bignum_type denominator) while (accumulator != 0); \ } \ { \ - bignum_type result = \ + 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)); \ @@ -365,13 +370,13 @@ bignum_remainder(bignum_type numerator, bignum_type denominator) } /* all below allocate memory */ -FOO_TO_BIGNUM(cell,CELL,CELL) -FOO_TO_BIGNUM(fixnum,F_FIXNUM,CELL) +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_type bignum) \ + type bignum_to_##name(bignum * bignum) \ { \ if (BIGNUM_ZERO_P (bignum)) \ return (0); \ @@ -386,13 +391,13 @@ FOO_TO_BIGNUM(ulong_long,u64,u64) } /* all of the below allocate memory */ -BIGNUM_TO_FOO(cell,CELL,CELL); -BIGNUM_TO_FOO(fixnum,F_FIXNUM,CELL); +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_type bignum) +bignum_to_double(bignum * bignum) { if (BIGNUM_ZERO_P (bignum)) return (0); @@ -415,10 +420,12 @@ bignum_to_double(bignum_type bignum) } /* allocates memory */ -bignum_type +#define inf std::numeric_limits::infinity() + +bignum * double_to_bignum(double x) { - if (x == 1.0/0.0 || x == -1.0/0.0 || x != x) return (BIGNUM_ZERO ()); + if (x == inf || x == -inf || x != x) return (BIGNUM_ZERO ()); int exponent; double significand = (frexp (x, (&exponent))); if (exponent <= 0) return (BIGNUM_ZERO ()); @@ -426,13 +433,13 @@ double_to_bignum(double x) if (significand < 0) significand = (-significand); { bignum_length_type length = (BIGNUM_BITS_TO_DIGITS (exponent)); - bignum_type result = (allot_bignum (length, (x < 0))); + 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 ((F_FIXNUM)1 << odd_bits); + DTB_WRITE_DIGIT ((fixnum)1 << odd_bits); while (start < scan) { if (significand == 0) @@ -452,7 +459,7 @@ double_to_bignum(double x) /* Comparisons */ int -bignum_equal_p_unsigned(bignum_type x, bignum_type y) +bignum_equal_p_unsigned(bignum * x, bignum * y) { bignum_length_type length = (BIGNUM_LENGTH (x)); if (length != (BIGNUM_LENGTH (y))) @@ -470,7 +477,7 @@ bignum_equal_p_unsigned(bignum_type x, bignum_type y) } enum bignum_comparison -bignum_compare_unsigned(bignum_type x, bignum_type y) +bignum_compare_unsigned(bignum * x, bignum * y) { bignum_length_type x_length = (BIGNUM_LENGTH (x)); bignum_length_type y_length = (BIGNUM_LENGTH (y)); @@ -498,23 +505,21 @@ bignum_compare_unsigned(bignum_type x, bignum_type y) /* Addition */ /* allocates memory */ -bignum_type -bignum_add_unsigned(bignum_type x, bignum_type y, int negative_p) +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_type z = x; + bignum * 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 * r = (allot_bignum ((x_length + 1), negative_p)); bignum_digit_type sum; bignum_digit_type carry = 0; @@ -568,9 +573,11 @@ bignum_add_unsigned(bignum_type x, bignum_type y, int negative_p) /* Subtraction */ /* allocates memory */ -bignum_type -bignum_subtract_unsigned(bignum_type x, bignum_type y) +bignum * +bignum_subtract_unsigned(bignum * x, bignum * y) { + GC_BIGNUM(x); GC_BIGNUM(y); + int negative_p = 0; switch (bignum_compare_unsigned (x, y)) { @@ -578,7 +585,7 @@ bignum_subtract_unsigned(bignum_type x, bignum_type y) return (BIGNUM_ZERO ()); case bignum_comparison_less: { - bignum_type z = x; + bignum * z = x; x = y; y = z; } @@ -591,11 +598,7 @@ bignum_subtract_unsigned(bignum_type x, bignum_type y) { 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 * r = (allot_bignum (x_length, negative_p)); bignum_digit_type difference; bignum_digit_type borrow = 0; @@ -649,12 +652,14 @@ bignum_subtract_unsigned(bignum_type x, bignum_type y) where R == BIGNUM_RADIX_ROOT */ /* allocates memory */ -bignum_type -bignum_multiply_unsigned(bignum_type x, bignum_type y, int negative_p) +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_type z = x; + bignum * z = x; x = y; y = z; } @@ -670,12 +675,8 @@ bignum_multiply_unsigned(bignum_type x, bignum_type y, int negative_p) 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 = + bignum * 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); @@ -723,15 +724,15 @@ bignum_multiply_unsigned(bignum_type x, bignum_type y, int negative_p) } /* allocates memory */ -bignum_type -bignum_multiply_unsigned_small_factor(bignum_type x, bignum_digit_type y, +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)); - REGISTER_BIGNUM(x); - bignum_type p = (allot_bignum ((length_x + 1), negative_p)); - UNREGISTER_BIGNUM(x); + bignum * p = (allot_bignum ((length_x + 1), negative_p)); bignum_destructive_copy (x, p); (BIGNUM_REF (p, length_x)) = 0; @@ -740,7 +741,7 @@ bignum_multiply_unsigned_small_factor(bignum_type x, bignum_digit_type y, } void -bignum_destructive_add(bignum_type bignum, bignum_digit_type n) +bignum_destructive_add(bignum * bignum, bignum_digit_type n) { bignum_digit_type * scan = (BIGNUM_START_PTR (bignum)); bignum_digit_type digit; @@ -764,7 +765,7 @@ bignum_destructive_add(bignum_type bignum, bignum_digit_type n) } void -bignum_destructive_scale_up(bignum_type bignum, bignum_digit_type factor) +bignum_destructive_scale_up(bignum * bignum, bignum_digit_type factor) { bignum_digit_type carry = 0; bignum_digit_type * scan = (BIGNUM_START_PTR (bignum)); @@ -802,31 +803,27 @@ bignum_destructive_scale_up(bignum_type bignum, bignum_digit_type factor) /* allocates memory */ void -bignum_divide_unsigned_large_denominator(bignum_type numerator, - bignum_type denominator, - bignum_type * quotient, - bignum_type * remainder, +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)); - REGISTER_BIGNUM(numerator); - REGISTER_BIGNUM(denominator); - - bignum_type q = - ((quotient != ((bignum_type *) 0)) + bignum * q = + ((quotient != ((bignum * *) 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); - + GC_BIGNUM(q); + + bignum * u = (allot_bignum (length_n, r_negative_p)); + GC_BIGNUM(u); + int shift = 0; BIGNUM_ASSERT (length_d > 1); { @@ -845,43 +842,31 @@ bignum_divide_unsigned_large_denominator(bignum_type numerator, } 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 * 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_type *) 0)) + if (remainder != ((bignum * *) 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)) + if (quotient != ((bignum * *) 0)) (*quotient) = q; - if (remainder != ((bignum_type *) 0)) + if (remainder != ((bignum * *) 0)) (*remainder) = u; return; } void -bignum_divide_unsigned_normalized(bignum_type u, bignum_type v, bignum_type q) +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)); @@ -1036,16 +1021,20 @@ bignum_divide_subtract(bignum_digit_type * v_start, /* allocates memory */ void -bignum_divide_unsigned_medium_denominator(bignum_type numerator, +bignum_divide_unsigned_medium_denominator(bignum * numerator, bignum_digit_type denominator, - bignum_type * quotient, - bignum_type * remainder, + 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_type q; + bignum * q = NULL; + GC_BIGNUM(q); + int shift = 0; /* Because `bignum_digit_divide' requires a normalized denominator. */ while (denominator < (BIGNUM_RADIX / 2)) @@ -1057,20 +1046,14 @@ bignum_divide_unsigned_medium_denominator(bignum_type numerator, { 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); } { @@ -1087,24 +1070,22 @@ bignum_divide_unsigned_medium_denominator(bignum_type numerator, q = bignum_trim (q); - if (remainder != ((bignum_type *) 0)) + if (remainder != ((bignum * *) 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)) + if (quotient != ((bignum * *) 0)) (*quotient) = q; } return; } void -bignum_destructive_normalization(bignum_type source, bignum_type target, +bignum_destructive_normalization(bignum * source, bignum * target, int shift_left) { bignum_digit_type digit; @@ -1114,7 +1095,7 @@ bignum_destructive_normalization(bignum_type source, bignum_type 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); + bignum_digit_type mask = (((cell)1 << shift_right) - 1); while (scan_source < end_source) { digit = (*scan_source++); @@ -1129,14 +1110,14 @@ bignum_destructive_normalization(bignum_type source, bignum_type target, } void -bignum_destructive_unnormalization(bignum_type bignum, int shift_right) +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 = (((F_FIXNUM)1 << shift_right) - 1); + bignum_digit_type mask = (((fixnum)1 << shift_right) - 1); while (start < scan) { digit = (*--scan); @@ -1284,27 +1265,24 @@ bignum_digit_divide_subtract(bignum_digit_type v1, bignum_digit_type v2, /* allocates memory */ void -bignum_divide_unsigned_small_denominator(bignum_type numerator, +bignum_divide_unsigned_small_denominator(bignum * numerator, bignum_digit_type denominator, - bignum_type * quotient, - bignum_type * remainder, + bignum * * quotient, + bignum * * 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); + 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_type *) 0)) - { - REGISTER_BIGNUM(q); + if (remainder != ((bignum * *) 0)) (*remainder) = (bignum_digit_to_bignum (r, r_negative_p)); - UNREGISTER_BIGNUM(q); - } (*quotient) = q; @@ -1316,7 +1294,7 @@ bignum_divide_unsigned_small_denominator(bignum_type numerator, that all digits are < BIGNUM_RADIX. */ bignum_digit_type -bignum_destructive_scale_down(bignum_type bignum, bignum_digit_type denominator) +bignum_destructive_scale_down(bignum * bignum, bignum_digit_type denominator) { bignum_digit_type numerator; bignum_digit_type remainder = 0; @@ -1339,9 +1317,9 @@ bignum_destructive_scale_down(bignum_type bignum, bignum_digit_type denominator) } /* allocates memory */ -bignum_type +bignum * bignum_remainder_unsigned_small_denominator( - bignum_type n, bignum_digit_type d, int negative_p) + bignum * n, bignum_digit_type d, int negative_p) { bignum_digit_type two_digits; bignum_digit_type * start = (BIGNUM_START_PTR (n)); @@ -1360,34 +1338,34 @@ bignum_remainder_unsigned_small_denominator( } /* allocates memory */ -bignum_type +bignum * 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 * result = (allot_bignum (1, negative_p)); (BIGNUM_REF (result, 0)) = digit; return (result); } } /* allocates memory */ -bignum_type +bignum * 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 * result = allot_array_internal(length + 1); BIGNUM_SET_NEGATIVE_P (result, negative_p); return (result); } /* allocates memory */ -bignum_type +bignum * allot_bignum_zeroed(bignum_length_type length, int negative_p) { - bignum_type result = allot_bignum(length,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) @@ -1396,11 +1374,11 @@ allot_bignum_zeroed(bignum_length_type length, int negative_p) } #define BIGNUM_REDUCE_LENGTH(source, length) \ - source = reallot_array(source,length + 1) + source = reallot_array(source,length + 1) /* allocates memory */ -bignum_type -bignum_shorten_length(bignum_type bignum, bignum_length_type length) +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)); @@ -1413,8 +1391,8 @@ bignum_shorten_length(bignum_type bignum, bignum_length_type length) } /* allocates memory */ -bignum_type -bignum_trim(bignum_type bignum) +bignum * +bignum_trim(bignum * bignum) { bignum_digit_type * start = (BIGNUM_START_PTR (bignum)); bignum_digit_type * end = (start + (BIGNUM_LENGTH (bignum))); @@ -1434,35 +1412,33 @@ bignum_trim(bignum_type bignum) /* Copying */ /* allocates memory */ -bignum_type -bignum_new_sign(bignum_type bignum, int negative_p) +bignum * +bignum_new_sign(bignum * x, int negative_p) { - REGISTER_BIGNUM(bignum); - bignum_type result = - (allot_bignum ((BIGNUM_LENGTH (bignum)), negative_p)); - UNREGISTER_BIGNUM(bignum); + GC_BIGNUM(x); + bignum * result = (allot_bignum ((BIGNUM_LENGTH (x)), negative_p)); - bignum_destructive_copy (bignum, result); + bignum_destructive_copy (x, result); return (result); } /* allocates memory */ -bignum_type -bignum_maybe_new_sign(bignum_type bignum, int negative_p) +bignum * +bignum_maybe_new_sign(bignum * x, int negative_p) { - if ((BIGNUM_NEGATIVE_P (bignum)) ? negative_p : (! negative_p)) - return (bignum); + if ((BIGNUM_NEGATIVE_P (x)) ? negative_p : (! negative_p)) + return (x); else { - bignum_type result = - (allot_bignum ((BIGNUM_LENGTH (bignum)), negative_p)); - bignum_destructive_copy (bignum, result); + bignum * result = + (allot_bignum ((BIGNUM_LENGTH (x)), negative_p)); + bignum_destructive_copy (x, result); return (result); } } void -bignum_destructive_copy(bignum_type source, bignum_type target) +bignum_destructive_copy(bignum * source, bignum * target) { bignum_digit_type * scan_source = (BIGNUM_START_PTR (source)); bignum_digit_type * end_source = @@ -1478,15 +1454,15 @@ bignum_destructive_copy(bignum_type source, bignum_type target) */ /* allocates memory */ -bignum_type -bignum_bitwise_not(bignum_type x) +bignum * +bignum_bitwise_not(bignum * x) { return bignum_subtract(BIGNUM_ONE(1), x); } /* allocates memory */ -bignum_type -bignum_arithmetic_shift(bignum_type arg1, F_FIXNUM n) +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)); @@ -1499,8 +1475,8 @@ bignum_arithmetic_shift(bignum_type arg1, F_FIXNUM n) #define XOR_OP 2 /* allocates memory */ -bignum_type -bignum_bitwise_and(bignum_type arg1, bignum_type arg2) +bignum * +bignum_bitwise_and(bignum * arg1, bignum * arg2) { return( (BIGNUM_NEGATIVE_P (arg1)) @@ -1514,8 +1490,8 @@ bignum_bitwise_and(bignum_type arg1, bignum_type arg2) } /* allocates memory */ -bignum_type -bignum_bitwise_ior(bignum_type arg1, bignum_type arg2) +bignum * +bignum_bitwise_ior(bignum * arg1, bignum * arg2) { return( (BIGNUM_NEGATIVE_P (arg1)) @@ -1529,8 +1505,8 @@ bignum_bitwise_ior(bignum_type arg1, bignum_type arg2) } /* allocates memory */ -bignum_type -bignum_bitwise_xor(bignum_type arg1, bignum_type arg2) +bignum * +bignum_bitwise_xor(bignum * arg1, bignum * arg2) { return( (BIGNUM_NEGATIVE_P (arg1)) @@ -1546,15 +1522,17 @@ bignum_bitwise_xor(bignum_type arg1, bignum_type 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 * +bignum_magnitude_ash(bignum * arg1, fixnum n) { - bignum_type result = NULL; + GC_BIGNUM(arg1); + + bignum * result = NULL; bignum_digit_type *scan1; bignum_digit_type *scanr; bignum_digit_type *end; - F_FIXNUM digit_offset,bit_offset; + fixnum digit_offset,bit_offset; if (BIGNUM_ZERO_P (arg1)) return (arg1); @@ -1562,10 +1540,8 @@ bignum_magnitude_ash(bignum_type arg1, F_FIXNUM n) 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); + BIGNUM_NEGATIVE_P(arg1)); scanr = BIGNUM_START_PTR (result) + digit_offset; scan1 = BIGNUM_START_PTR (arg1); @@ -1587,10 +1563,8 @@ bignum_magnitude_ash(bignum_type arg1, F_FIXNUM n) 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); + BIGNUM_NEGATIVE_P(arg1)); scanr = BIGNUM_START_PTR (result); scan1 = BIGNUM_START_PTR (arg1) + digit_offset; @@ -1610,10 +1584,12 @@ bignum_magnitude_ash(bignum_type arg1, F_FIXNUM n) } /* allocates memory */ -bignum_type -bignum_pospos_bitwise_op(int op, bignum_type arg1, bignum_type arg2) +bignum * +bignum_pospos_bitwise_op(int op, bignum * arg1, bignum * arg2) { - bignum_type result; + GC_BIGNUM(arg1); GC_BIGNUM(arg2); + + bignum * result; bignum_length_type max_length; bignum_digit_type *scan1, *end1, digit1; @@ -1623,11 +1599,7 @@ bignum_pospos_bitwise_op(int op, bignum_type arg1, bignum_type arg2) 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); @@ -1647,10 +1619,12 @@ bignum_pospos_bitwise_op(int op, bignum_type arg1, bignum_type arg2) } /* allocates memory */ -bignum_type -bignum_posneg_bitwise_op(int op, bignum_type arg1, bignum_type arg2) +bignum * +bignum_posneg_bitwise_op(int op, bignum * arg1, bignum * arg2) { - bignum_type result; + GC_BIGNUM(arg1); GC_BIGNUM(arg2); + + bignum * result; bignum_length_type max_length; bignum_digit_type *scan1, *end1, digit1; @@ -1662,11 +1636,7 @@ bignum_posneg_bitwise_op(int op, bignum_type arg1, bignum_type arg2) 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); @@ -1702,10 +1672,12 @@ bignum_posneg_bitwise_op(int op, bignum_type arg1, bignum_type arg2) } /* allocates memory */ -bignum_type -bignum_negneg_bitwise_op(int op, bignum_type arg1, bignum_type arg2) +bignum * +bignum_negneg_bitwise_op(int op, bignum * arg1, bignum * arg2) { - bignum_type result; + GC_BIGNUM(arg1); GC_BIGNUM(arg2); + + bignum * result; bignum_length_type max_length; bignum_digit_type *scan1, *end1, digit1, carry1; @@ -1717,11 +1689,7 @@ bignum_negneg_bitwise_op(int op, bignum_type arg1, bignum_type arg2) 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); @@ -1765,7 +1733,7 @@ bignum_negneg_bitwise_op(int op, bignum_type arg1, bignum_type arg2) } void -bignum_negate_magnitude(bignum_type arg) +bignum_negate_magnitude(bignum * arg) { bignum_digit_type *scan; bignum_digit_type *end; @@ -1793,15 +1761,15 @@ bignum_negate_magnitude(bignum_type arg) } /* Allocates memory */ -bignum_type -bignum_integer_length(bignum_type bignum) +bignum * +bignum_integer_length(bignum * x) { - bignum_length_type index = ((BIGNUM_LENGTH (bignum)) - 1); - bignum_digit_type digit = (BIGNUM_REF (bignum, index)); + GC_BIGNUM(x); - REGISTER_BIGNUM(bignum); - bignum_type result = (allot_bignum (2, 0)); - UNREGISTER_BIGNUM(bignum); + 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; @@ -1816,7 +1784,7 @@ bignum_integer_length(bignum_type bignum) /* Allocates memory */ int -bignum_logbitp(int shift, bignum_type arg) +bignum_logbitp(int shift, bignum * arg) { return((BIGNUM_NEGATIVE_P (arg)) ? !bignum_unsigned_logbitp (shift, bignum_bitwise_not (arg)) @@ -1824,7 +1792,7 @@ bignum_logbitp(int shift, bignum_type arg) } int -bignum_unsigned_logbitp(int shift, bignum_type bignum) +bignum_unsigned_logbitp(int shift, bignum * bignum) { bignum_length_type len = (BIGNUM_LENGTH (bignum)); int index = shift / BIGNUM_DIGIT_LENGTH; @@ -1832,12 +1800,12 @@ bignum_unsigned_logbitp(int shift, bignum_type bignum) return 0; bignum_digit_type digit = (BIGNUM_REF (bignum, index)); int p = shift % BIGNUM_DIGIT_LENGTH; - bignum_digit_type mask = ((F_FIXNUM)1) << p; + bignum_digit_type mask = ((fixnum)1) << p; return (digit & mask) ? 1 : 0; } /* Allocates memory */ -bignum_type +bignum * digit_stream_to_bignum(unsigned int n_digits, unsigned int (*producer)(unsigned int), unsigned int radix, @@ -1848,7 +1816,7 @@ digit_stream_to_bignum(unsigned int n_digits, return (BIGNUM_ZERO ()); if (n_digits == 1) { - F_FIXNUM digit = ((F_FIXNUM) ((*producer) (0))); + fixnum digit = ((fixnum) ((*producer) (0))); return (fixnum_to_bignum (negative_p ? (- digit) : digit)); } { @@ -1865,7 +1833,7 @@ digit_stream_to_bignum(unsigned int n_digits, length = (BIGNUM_BITS_TO_DIGITS (n_digits * log_radix)); } { - bignum_type result = (allot_bignum_zeroed (length, negative_p)); + bignum * result = (allot_bignum_zeroed (length, negative_p)); while ((n_digits--) > 0) { bignum_destructive_scale_up (result, ((bignum_digit_type) radix)); @@ -1876,3 +1844,5 @@ digit_stream_to_bignum(unsigned int n_digits, } } } + +} diff --git a/vm/bignum.h b/vm/bignum.h deleted file mode 100644 index 02309cad34..0000000000 --- a/vm/bignum.h +++ /dev/null @@ -1,127 +0,0 @@ -/* :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); diff --git a/vm/bignum.hpp b/vm/bignum.hpp new file mode 100644 index 0000000000..296f0dce4c --- /dev/null +++ b/vm/bignum.hpp @@ -0,0 +1,131 @@ +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); + +} diff --git a/vm/bignumint.h b/vm/bignumint.hpp similarity index 83% rename from vm/bignumint.h rename to vm/bignumint.hpp index 7c835686c2..0b743b35a4 100644 --- a/vm/bignumint.h +++ b/vm/bignumint.hpp @@ -33,6 +33,9 @@ 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 @@ -42,11 +45,11 @@ MIT in each case. */ 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; +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 *)AREF(bignum,0)) +#define BIGNUM_TO_POINTER(bignum) ((bignum_digit_type *)(bignum + 1)) /* BIGNUM_EXCEPTION is invoked to handle assertion violations. */ #define BIGNUM_EXCEPTION abort @@ -54,18 +57,18 @@ typedef F_FIXNUM bignum_length_type; #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_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_fast((bignum)->capacity) - 1) +#define BIGNUM_LENGTH(bignum) (untag_fixnum((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_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) @@ -75,9 +78,9 @@ typedef F_FIXNUM bignum_length_type; /* These definitions are here to facilitate caching of the constants 0, 1, and -1. */ -#define BIGNUM_ZERO() untag_object(bignum_zero) +#define BIGNUM_ZERO() untag(bignum_zero) #define BIGNUM_ONE(neg_p) \ - untag_object(neg_p ? bignum_neg_one : bignum_pos_one) + untag(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) @@ -98,3 +101,5 @@ typedef F_FIXNUM bignum_length_type; } #endif /* not BIGNUM_DISABLE_ASSERTION_CHECKS */ + +} diff --git a/vm/booleans.c b/vm/booleans.c deleted file mode 100644 index 113265873f..0000000000 --- a/vm/booleans.c +++ /dev/null @@ -1,13 +0,0 @@ -#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; -} diff --git a/vm/booleans.cpp b/vm/booleans.cpp new file mode 100644 index 0000000000..8407e10099 --- /dev/null +++ b/vm/booleans.cpp @@ -0,0 +1,16 @@ +#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; +} + +} diff --git a/vm/booleans.h b/vm/booleans.h deleted file mode 100644 index ae49652dd8..0000000000 --- a/vm/booleans.h +++ /dev/null @@ -1,7 +0,0 @@ -INLINE CELL tag_boolean(CELL untagged) -{ - return (untagged == false ? F : T); -} - -DLLEXPORT void box_boolean(bool value); -DLLEXPORT bool to_boolean(CELL value); diff --git a/vm/booleans.hpp b/vm/booleans.hpp new file mode 100644 index 0000000000..ea16e0536b --- /dev/null +++ b/vm/booleans.hpp @@ -0,0 +1,12 @@ +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); + +} diff --git a/vm/byte_arrays.c b/vm/byte_arrays.c deleted file mode 100644 index 480b4d7a9f..0000000000 --- a/vm/byte_arrays.c +++ /dev/null @@ -1,85 +0,0 @@ -#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; -} diff --git a/vm/byte_arrays.cpp b/vm/byte_arrays.cpp new file mode 100644 index 0000000000..2eda3f33c4 --- /dev/null +++ b/vm/byte_arrays.cpp @@ -0,0 +1,64 @@ +#include "master.hpp" + +namespace factor +{ + +byte_array *allot_byte_array(cell size) +{ + byte_array *array = allot_array_internal(size); + memset(array + 1,0,size); + return array; +} + +PRIMITIVE(byte_array) +{ + cell size = unbox_array_size(); + dpush(tag(allot_byte_array(size))); +} + +PRIMITIVE(uninitialized_byte_array) +{ + cell size = unbox_array_size(); + dpush(tag(allot_array_internal(size))); +} + +PRIMITIVE(resize_byte_array) +{ + byte_array *array = untag_check(dpop()); + cell capacity = unbox_array_size(); + dpush(tag(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()[count],elts,len); + + count += len; +} + +void growable_byte_array::append_byte_array(cell byte_array_) +{ + gc_root 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()[count],byte_array->data(),len); + + count += len; +} + +void growable_byte_array::trim() +{ + elements = reallot_array(elements.untagged(),count); +} + +} diff --git a/vm/byte_arrays.h b/vm/byte_arrays.h deleted file mode 100644 index 65c9731047..0000000000 --- a/vm/byte_arrays.h +++ /dev/null @@ -1,40 +0,0 @@ -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)); -} diff --git a/vm/byte_arrays.hpp b/vm/byte_arrays.hpp new file mode 100644 index 0000000000..ebdc6bead6 --- /dev/null +++ b/vm/byte_arrays.hpp @@ -0,0 +1,23 @@ +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 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(); +}; + +} diff --git a/vm/callstack.c b/vm/callstack.c deleted file mode 100755 index 26f8589c29..0000000000 --- a/vm/callstack.c +++ /dev/null @@ -1,230 +0,0 @@ -#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; -} diff --git a/vm/callstack.cpp b/vm/callstack.cpp new file mode 100755 index 0000000000..56056426dd --- /dev/null +++ b/vm/callstack.cpp @@ -0,0 +1,230 @@ +#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_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(stack)); +} + +PRIMITIVE(set_callstack) +{ + callstack *stack = untag_check(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(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(dpop()); + + frame_count = 0; + iterate_callstack_object(callstack.untagged(),count_stack_frame); + + frames = allot_array_internal(frame_count); + + frame_index = 0; + iterate_callstack_object(callstack.untagged(),stack_frame_to_array); + + dpush(tag(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(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(dpop())))); +} + +PRIMITIVE(innermost_stack_frame_scan) +{ + dpush(frame_scan(innermost_stack_frame_quot(untag_check(dpop())))); +} + +PRIMITIVE(set_innermost_stack_frame_quot) +{ + gc_root callstack(dpop()); + gc_root 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; +} + +} diff --git a/vm/callstack.h b/vm/callstack.h deleted file mode 100755 index 8b693c451c..0000000000 --- a/vm/callstack.h +++ /dev/null @@ -1,28 +0,0 @@ -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); diff --git a/vm/callstack.hpp b/vm/callstack.hpp new file mode 100755 index 0000000000..efdbc7ba05 --- /dev/null +++ b/vm/callstack.hpp @@ -0,0 +1,31 @@ +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); + +} diff --git a/vm/code_block.c b/vm/code_block.c deleted file mode 100644 index f2ddc717f7..0000000000 --- a/vm/code_block.c +++ /dev/null @@ -1,506 +0,0 @@ -#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; -} diff --git a/vm/code_block.cpp b/vm/code_block.cpp new file mode 100644 index 0000000000..5ebb162f7e --- /dev/null +++ b/vm/code_block.cpp @@ -0,0 +1,505 @@ +#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(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()[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 *ptr, cell value) +{ + ptr[-1] = ((ptr[-1] & ~0xffff) | ((value >> 16) & 0xffff)); + ptr[ 0] = ((ptr[ 0] & ~0xffff) | (value & 0xffff)); +} + +/* Store a value into a bitfield of a PowerPC instruction */ +static void store_address_masked(cell *ptr, fixnum value, cell mask, fixnum shift) +{ + /* 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); + + *ptr = ((*ptr & ~mask) | ((value >> shift) & mask)); +} + +/* Perform a fixup on a code block */ +void store_address_in_code_block(cell klass, cell offset, fixnum absolute_value) +{ + 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(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(obj).type()) + { + case WORD_TYPE: + return untag(obj)->xt; + case QUOTATION_TYPE: + return untag(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(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(compiled->literals); + cell obj = array_nth(literals,index); + + void *xt; + if(type == RT_XT) + xt = object_xt(obj); + else + xt = word_direct_xt(untag(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(library)); + + if(d != NULL && !d->dll) + return (void *)undefined_symbol; + + switch(tagged(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(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(compiled->literals).untag_check(); + tagged(compiled->relocation).untag_check(); +#endif + + cell offset = REL_OFFSET(rel) + (cell)(compiled + 1); + array *literals = untag(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(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 code(code_); + gc_root labels(labels_); + gc_root relocation(relocation_); + gc_root 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().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; +} + +} diff --git a/vm/code_block.h b/vm/code_block.hpp similarity index 55% rename from vm/code_block.h rename to vm/code_block.hpp index 385f414f88..9689ea5419 100644 --- a/vm/code_block.h +++ b/vm/code_block.hpp @@ -1,4 +1,7 @@ -typedef enum { +namespace factor +{ + +enum relocation_type { /* arg is a primitive number */ RT_PRIMITIVE, /* arg is a literal table index, holding an array pair (symbol/dll) */ @@ -19,9 +22,9 @@ typedef enum { RT_STACK_CHAIN, /* untagged fixnum literal */ RT_UNTAGGED, -} F_RELTYPE; +}; -typedef enum { +enum relocation_class { /* absolute address in a 64-bit location */ RC_ABSOLUTE_CELL, /* absolute address in a 32-bit location */ @@ -40,7 +43,7 @@ typedef enum { 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 @@ -48,45 +51,42 @@ typedef enum { #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) +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(F_CODE_BLOCK *compiled); +void flush_icache_for(code_block *compiled); -typedef void (*RELOCATION_ITERATOR)(F_REL rel, CELL index, F_CODE_BLOCK *compiled); +typedef void (*relocation_iterator)(relocation_entry rel, cell index, code_block *compiled); -void iterate_relocations(F_CODE_BLOCK *compiled, RELOCATION_ITERATOR iter); +void iterate_relocations(code_block *compiled, relocation_iterator iter); -void store_address_in_code_block(CELL class, CELL offset, F_FIXNUM absolute_value); +void store_address_in_code_block(cell klass, cell offset, fixnum absolute_value); -void relocate_code_block(F_CODE_BLOCK *compiled); +void relocate_code_block(code_block *compiled); -void update_literal_references(F_CODE_BLOCK *compiled); +void update_literal_references(code_block *compiled); -void copy_literal_references(F_CODE_BLOCK *compiled); +void copy_literal_references(code_block *compiled); -void update_word_references(F_CODE_BLOCK *compiled); +void update_word_references(code_block *compiled); -void update_literal_and_word_references(F_CODE_BLOCK *compiled); +void update_literal_and_word_references(code_block *compiled); -void mark_code_block(F_CODE_BLOCK *compiled); +void mark_code_block(code_block *compiled); -void mark_active_blocks(F_CONTEXT *stacks); +void mark_active_blocks(context *stacks); -void mark_object_code_block(CELL scan); +void mark_object_code_block(object *scan); -void relocate_code_block(F_CODE_BLOCK *relocating); +void relocate_code_block(code_block *relocating); -INLINE bool stack_traces_p(void) +inline static 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); +code_block *add_code_block(cell type, cell code, cell labels, cell relocation, cell literals); + +} diff --git a/vm/code_gc.c b/vm/code_gc.cpp similarity index 66% rename from vm/code_gc.c rename to vm/code_gc.cpp index c7ab02c6e6..b86d08cf52 100755 --- a/vm/code_gc.c +++ b/vm/code_gc.cpp @@ -1,23 +1,26 @@ -#include "master.h" +#include "master.hpp" -static void clear_free_list(F_HEAP *heap) +namespace factor { - memset(&heap->free,0,sizeof(F_HEAP_FREE_LIST)); + +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(F_HEAP *heap, CELL size) +void new_heap(heap *heap, cell size) { - heap->segment = alloc_segment(align_page(size)); - if(!heap->segment) + 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(F_HEAP *heap, F_FREE_BLOCK *block) +static void add_to_free_list(heap *heap, free_heap_block *block) { if(block->block.size < FREE_LIST_COUNT * BLOCK_SIZE_INCREMENT) { @@ -36,29 +39,29 @@ static void add_to_free_list(F_HEAP *heap, F_FREE_BLOCK *block) 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) +void build_free_list(heap *heap, cell size) { - F_BLOCK *prev = NULL; + heap_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); + 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 < (F_BLOCK *)end) + while(scan && scan < (heap_block *)end) { switch(scan->status) { case B_FREE: - add_to_free_list(heap,(F_FREE_BLOCK *)scan); + add_to_free_list(heap,(free_heap_block *)scan); break; case B_ALLOCATED: break; default: - critical_error("Invalid scan->status",(CELL)scan); + critical_error("Invalid scan->status",(cell)scan); break; } @@ -68,10 +71,10 @@ void build_free_list(F_HEAP *heap, CELL size) /* 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) + if((cell)(end + 1) <= heap->seg->end) { end->block.status = B_FREE; - end->block.size = heap->segment->end - (CELL)end; + end->block.size = heap->seg->end - (cell)end; /* add final free block */ add_to_free_list(heap,end); @@ -83,25 +86,25 @@ void build_free_list(F_HEAP *heap, CELL size) /* 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; + if(prev) prev->size = heap->seg->end - (cell)prev; } } -static void assert_free_block(F_FREE_BLOCK *block) +static void assert_free_block(free_heap_block *block) { if(block->block.status != B_FREE) - critical_error("Invalid block in free list",(CELL)block); + critical_error("Invalid block in free list",(cell)block); } -static F_FREE_BLOCK *find_free_block(F_HEAP *heap, CELL size) +static free_heap_block *find_free_block(heap *heap, cell size) { - CELL attempt = 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]; + free_heap_block *block = heap->free.small_blocks[index]; if(block) { assert_free_block(block); @@ -112,8 +115,8 @@ static F_FREE_BLOCK *find_free_block(F_HEAP *heap, CELL size) attempt *= 2; } - F_FREE_BLOCK *prev = NULL; - F_FREE_BLOCK *block = heap->free.large_blocks; + free_heap_block *prev = NULL; + free_heap_block *block = heap->free.large_blocks; while(block) { @@ -134,12 +137,12 @@ static F_FREE_BLOCK *find_free_block(F_HEAP *heap, CELL size) return NULL; } -static F_FREE_BLOCK *split_free_block(F_HEAP *heap, F_FREE_BLOCK *block, CELL size) +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 */ - F_FREE_BLOCK *split = (F_FREE_BLOCK *)((CELL)block + size); + 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; @@ -151,11 +154,11 @@ static F_FREE_BLOCK *split_free_block(F_HEAP *heap, F_FREE_BLOCK *block, CELL si } /* Allocate a block of memory from the mark and sweep GC heap */ -F_BLOCK *heap_allot(F_HEAP *heap, CELL size) +heap_block *heap_allot(heap *heap, cell size) { size = (size + BLOCK_SIZE_INCREMENT - 1) & ~(BLOCK_SIZE_INCREMENT - 1); - F_FREE_BLOCK *block = find_free_block(heap,size); + free_heap_block *block = find_free_block(heap,size); if(block) { block = split_free_block(heap,block,size); @@ -168,13 +171,13 @@ F_BLOCK *heap_allot(F_HEAP *heap, CELL size) } /* Deallocates a block manually */ -void heap_free(F_HEAP *heap, F_BLOCK *block) +void heap_free(heap *heap, heap_block *block) { block->status = B_FREE; - add_to_free_list(heap,(F_FREE_BLOCK *)block); + add_to_free_list(heap,(free_heap_block *)block); } -void mark_block(F_BLOCK *block) +void mark_block(heap_block *block) { /* If already marked, do nothing */ switch(block->status) @@ -185,16 +188,16 @@ void mark_block(F_BLOCK *block) block->status = B_MARKED; break; default: - critical_error("Marking the wrong block",(CELL)block); + 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) +void unmark_marked(heap *heap) { - F_BLOCK *scan = first_block(heap); + heap_block *scan = first_block(heap); while(scan) { @@ -207,12 +210,12 @@ void unmark_marked(F_HEAP *heap) /* After code GC, all referenced code blocks have status set to B_MARKED, so any which are allocated and not marked can be reclaimed. */ -void free_unmarked(F_HEAP *heap, HEAP_ITERATOR iter) +void free_unmarked(heap *heap, heap_iterator iter) { clear_free_list(heap); - F_BLOCK *prev = NULL; - F_BLOCK *scan = first_block(heap); + heap_block *prev = NULL; + heap_block *scan = first_block(heap); while(scan) { @@ -220,7 +223,7 @@ void free_unmarked(F_HEAP *heap, HEAP_ITERATOR iter) { case B_ALLOCATED: if(secure_gc) - memset(scan + 1,0,scan->size - sizeof(F_BLOCK)); + memset(scan + 1,0,scan->size - sizeof(heap_block)); if(prev && prev->status == B_FREE) prev->size += scan->size; @@ -238,30 +241,30 @@ void free_unmarked(F_HEAP *heap, HEAP_ITERATOR iter) break; case B_MARKED: if(prev && prev->status == B_FREE) - add_to_free_list(heap,(F_FREE_BLOCK *)prev); + 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); + 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); + 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(F_HEAP *heap, CELL *used, CELL *total_free, CELL *max_free) +void heap_usage(heap *heap, cell *used, cell *total_free, cell *max_free) { *used = 0; *total_free = 0; *max_free = 0; - F_BLOCK *scan = first_block(heap); + heap_block *scan = first_block(heap); while(scan) { @@ -276,7 +279,7 @@ void heap_usage(F_HEAP *heap, CELL *used, CELL *total_free, CELL *max_free) *max_free = scan->size; break; default: - critical_error("Invalid scan->status",(CELL)scan); + critical_error("Invalid scan->status",(cell)scan); } scan = next_block(heap,scan); @@ -284,32 +287,32 @@ void heap_usage(F_HEAP *heap, CELL *used, CELL *total_free, CELL *max_free) } /* The size of the heap, not including the last block if it's free */ -CELL heap_size(F_HEAP *heap) +cell heap_size(heap *heap) { - F_BLOCK *scan = first_block(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->segment->start; + return (cell)scan - heap->seg->start; /* otherwise the last block is allocated */ else - return heap->segment->size; + return heap->seg->size; } /* Compute where each block is going to go, after compaction */ -CELL compute_heap_forwarding(F_HEAP *heap) +cell compute_heap_forwarding(heap *heap) { - F_BLOCK *scan = first_block(heap); - CELL address = (CELL)first_block(heap); + heap_block *scan = first_block(heap); + cell address = (cell)first_block(heap); while(scan) { if(scan->status == B_ALLOCATED) { - scan->forwarding = (F_BLOCK *)address; + scan->forwarding = (heap_block *)address; address += scan->size; } else if(scan->status == B_MARKED) @@ -318,19 +321,21 @@ CELL compute_heap_forwarding(F_HEAP *heap) scan = next_block(heap,scan); } - return address - heap->segment->start; + return address - heap->seg->start; } -void compact_heap(F_HEAP *heap) +void compact_heap(heap *heap) { - F_BLOCK *scan = first_block(heap); + heap_block *scan = first_block(heap); while(scan) { - F_BLOCK *next = next_block(heap,scan); + heap_block *next = next_block(heap,scan); if(scan->status == B_ALLOCATED && scan != scan->forwarding) memcpy(scan->forwarding,scan,scan->size); scan = next; } } + +} diff --git a/vm/code_gc.h b/vm/code_gc.h deleted file mode 100755 index 35f8d66d90..0000000000 --- a/vm/code_gc.h +++ /dev/null @@ -1,45 +0,0 @@ -#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; -} diff --git a/vm/code_gc.hpp b/vm/code_gc.hpp new file mode 100755 index 0000000000..3879d3c8e8 --- /dev/null +++ b/vm/code_gc.hpp @@ -0,0 +1,50 @@ +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; +} + +} diff --git a/vm/code_heap.c b/vm/code_heap.c deleted file mode 100755 index 0a174903b6..0000000000 --- a/vm/code_heap.c +++ /dev/null @@ -1,226 +0,0 @@ -#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); -} diff --git a/vm/code_heap.cpp b/vm/code_heap.cpp new file mode 100755 index 0000000000..5dca29b420 --- /dev/null +++ b/vm/code_heap.cpp @@ -0,0 +1,234 @@ +#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_); + gc_root 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 alist(dpop()); + + cell count = array_capacity(alist.untagged()); + + if(count == 0) + return; + + cell i; + for(i = 0; i < count; i++) + { + gc_root pair(array_nth(alist.untagged(),i)); + + gc_root word(array_nth(pair.untagged(),0)); + gc_root 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().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(obj).type()) + { + case WORD_TYPE: + { + word *w = untag(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(obj); + + if(quot->compiledp != F) + quot->code = forward_xt(quot->code); + } + break; + case CALLSTACK_TYPE: + { + callstack *stack = untag(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(obj).type()) + { + case WORD_TYPE: + update_word_xt(obj); + break; + case QUOTATION_TYPE: + { + quotation *quot = untag(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); +} + +} diff --git a/vm/code_heap.h b/vm/code_heap.h deleted file mode 100755 index 01d282acfa..0000000000 --- a/vm/code_heap.h +++ /dev/null @@ -1,27 +0,0 @@ -/* 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 -} diff --git a/vm/code_heap.hpp b/vm/code_heap.hpp new file mode 100755 index 0000000000..056a6a88c6 --- /dev/null +++ b/vm/code_heap.hpp @@ -0,0 +1,32 @@ +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 +} + +} diff --git a/vm/contexts.cpp b/vm/contexts.cpp new file mode 100644 index 0000000000..66570abc31 --- /dev/null +++ b/vm/contexts.cpp @@ -0,0 +1,192 @@ +#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(depth / sizeof(cell)); + memcpy(a + 1,(void*)bottom,depth); + dpush(tag(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(dpop()),ds_bot); +} + +PRIMITIVE(set_retainstack) +{ + rs = array_to_stack(untag_check(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(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); + } +} + +} diff --git a/vm/contexts.hpp b/vm/contexts.hpp new file mode 100644 index 0000000000..13af17f2f0 --- /dev/null +++ b/vm/contexts.hpp @@ -0,0 +1,66 @@ +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; diff --git a/vm/cpu-arm.h b/vm/cpu-arm.h deleted file mode 100755 index e6ea0a1158..0000000000 --- a/vm/cpu-arm.h +++ /dev/null @@ -1,13 +0,0 @@ -#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); diff --git a/vm/cpu-arm.hpp b/vm/cpu-arm.hpp new file mode 100755 index 0000000000..235677b274 --- /dev/null +++ b/vm/cpu-arm.hpp @@ -0,0 +1,16 @@ +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); + +} diff --git a/vm/cpu-ppc.h b/vm/cpu-ppc.h deleted file mode 100755 index 298e21aa7d..0000000000 --- a/vm/cpu-ppc.h +++ /dev/null @@ -1,12 +0,0 @@ -#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); diff --git a/vm/cpu-ppc.hpp b/vm/cpu-ppc.hpp new file mode 100755 index 0000000000..7e8ae05fac --- /dev/null +++ b/vm/cpu-ppc.hpp @@ -0,0 +1,17 @@ +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); + +} diff --git a/vm/cpu-x86.32.h b/vm/cpu-x86.32.h deleted file mode 100755 index 21f07cf2b4..0000000000 --- a/vm/cpu-x86.32.h +++ /dev/null @@ -1,6 +0,0 @@ -#define FACTOR_CPU_STRING "x86.32" - -register CELL ds asm("esi"); -register CELL rs asm("edi"); - -#define F_FASTCALL __attribute__ ((regparm (2))) diff --git a/vm/cpu-x86.32.hpp b/vm/cpu-x86.32.hpp new file mode 100755 index 0000000000..6b6328aa4f --- /dev/null +++ b/vm/cpu-x86.32.hpp @@ -0,0 +1,11 @@ +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))) + +} diff --git a/vm/cpu-x86.64.h b/vm/cpu-x86.64.h deleted file mode 100644 index 6412355129..0000000000 --- a/vm/cpu-x86.64.h +++ /dev/null @@ -1,6 +0,0 @@ -#define FACTOR_CPU_STRING "x86.64" - -register CELL ds asm("r14"); -register CELL rs asm("r15"); - -#define F_FASTCALL diff --git a/vm/cpu-x86.64.hpp b/vm/cpu-x86.64.hpp new file mode 100644 index 0000000000..be71a78aa8 --- /dev/null +++ b/vm/cpu-x86.64.hpp @@ -0,0 +1,11 @@ +namespace factor +{ + +#define FACTOR_CPU_STRING "x86.64" + +register cell ds asm("r14"); +register cell rs asm("r15"); + +#define VM_ASM_API extern "C" + +} diff --git a/vm/cpu-x86.h b/vm/cpu-x86.h deleted file mode 100755 index 0888ec57fd..0000000000 --- a/vm/cpu-x86.h +++ /dev/null @@ -1,35 +0,0 @@ -#include - -#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); -} diff --git a/vm/cpu-x86.hpp b/vm/cpu-x86.hpp new file mode 100755 index 0000000000..c0b4651811 --- /dev/null +++ b/vm/cpu-x86.hpp @@ -0,0 +1,44 @@ +#include + +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)); + +} diff --git a/vm/data_gc.c b/vm/data_gc.cpp similarity index 53% rename from vm/data_gc.c rename to vm/data_gc.cpp index 1662fc9a4d..e26edc9721 100755 --- a/vm/data_gc.c +++ b/vm/data_gc.cpp @@ -1,10 +1,141 @@ -#include "master.h" +#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 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(pointer)),TAG(pointer)); +} + +void copy_handle(cell *handle) +{ + cell pointer = *handle; + + if(!immediate_p(pointer)) + { + object *obj = untag(pointer); + check_data_pointer(obj); + if(should_copy_p(obj)) + *handle = copy_object(pointer); + } +} /* Scan all the objects in the card */ -void copy_card(F_CARD *ptr, CELL gen, CELL here) +static void copy_card(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); + 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; @@ -14,12 +145,12 @@ void copy_card(F_CARD *ptr, CELL gen, CELL here) cards_scanned++; } -void copy_card_deck(F_DECK *deck, CELL gen, F_CARD mask, F_CARD unmask) +static void copy_card_deck(card_deck *deck, cell gen, card mask, card unmask) { - F_CARD *first_card = DECK_TO_CARD(deck); - F_CARD *last_card = DECK_TO_CARD(deck + 1); + card *first_card = deck_to_card(deck); + card *last_card = deck_to_card(deck + 1); - CELL here = data_heap->generations[gen].here; + cell here = data->generations[gen].here; u32 *quad_ptr; u32 quad_mask = mask | (mask << 8) | (mask << 16) | (mask << 24); @@ -28,7 +159,7 @@ void copy_card_deck(F_DECK *deck, CELL gen, F_CARD mask, F_CARD unmask) { if(*quad_ptr & quad_mask) { - F_CARD *ptr = (F_CARD *)quad_ptr; + card *ptr = (card *)quad_ptr; int card; for(card = 0; card < 4; card++) @@ -46,12 +177,12 @@ void copy_card_deck(F_DECK *deck, CELL gen, F_CARD mask, F_CARD unmask) } /* Copy all newspace objects referenced from marked cards to the destination */ -void copy_gen_cards(CELL gen) +static 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); + card_deck *first_deck = addr_to_deck(data->generations[gen].start); + card_deck *last_deck = addr_to_deck(data->generations[gen].end); - F_CARD mask, unmask; + card mask, unmask; /* if we are collecting the nursery, we care about old->nursery pointers but not old->aging pointers */ @@ -99,7 +230,7 @@ void copy_gen_cards(CELL gen) return; } - F_DECK *ptr; + card_deck *ptr; for(ptr = first_deck; ptr < last_deck; ptr++) { @@ -113,37 +244,58 @@ void copy_gen_cards(CELL gen) /* Scan cards in all generations older than the one being collected, copying old->new references */ -void copy_cards(void) +static void copy_cards(void) { u64 start = current_micros(); - int i; - for(i = collecting_gen + 1; i < data_heap->gen_count; i++) + 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 */ -void copy_stack_elements(F_SEGMENT *region, CELL top) +static void copy_stack_elements(segment *region, cell top) { - CELL ptr = region->start; + cell ptr = region->start; - for(; ptr <= top; ptr += CELLS) - copy_handle((CELL*)ptr); + for(; ptr <= top; ptr += sizeof(cell)) + copy_handle((cell*)ptr); } -void copy_registered_locals(void) +static void copy_registered_locals(void) { - CELL ptr = gc_locals_region->start; + cell scan = gc_locals_region->start; - for(; ptr <= gc_locals; ptr += CELLS) - copy_handle(*(CELL **)ptr); + 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 with REGISTER_ROOT */ -void copy_roots(void) +the user environment and extra roots registered by local_roots.hpp */ +static void copy_roots(void) { copy_handle(&T); copy_handle(&bignum_zero); @@ -151,12 +303,12 @@ void copy_roots(void) copy_handle(&bignum_neg_one); copy_registered_locals(); - copy_stack_elements(extra_roots_region,extra_roots); + copy_registered_bignums(); if(!performing_compaction) { save_stacks(); - F_CONTEXT *stacks = stack_chain; + context *stacks = stack_chain; while(stacks) { @@ -177,139 +329,56 @@ void copy_roots(void) copy_handle(&userenv[i]); } -/* Given a pointer to oldspace, copy it to newspace */ -INLINE void *copy_untagged_object(void *pointer, CELL size) +static cell copy_next_from_nursery(cell scan) { - 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)); + 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; + cell nursery_start = nursery.start; + cell nursery_end = nursery.end; for(; obj < end; obj++) { - CELL pointer = *obj; + cell pointer = *obj; if(!immediate_p(pointer)) { - check_data_pointer(pointer); + check_data_pointer((object *)pointer); if(pointer >= nursery_start && pointer < nursery_end) *obj = copy_object(pointer); } } } - return scan + untagged_object_size(scan); + return scan + untagged_object_size((object *)scan); } -CELL copy_next_from_aging(CELL scan) +static cell copy_next_from_aging(cell scan) { - CELL *obj = (CELL *)scan; - CELL *end = (CELL *)(scan + binary_payload_start(scan)); + cell *obj = (cell *)scan; + cell *end = (cell *)(scan + binary_payload_start((object *)scan)); if(obj != end) { obj++; - CELL tenured_start = data_heap->generations[TENURED].start; - CELL tenured_end = data_heap->generations[TENURED].end; + cell tenured_start = data->generations[TENURED].start; + cell tenured_end = data->generations[TENURED].end; - CELL newspace_start = newspace->start; - CELL newspace_end = newspace->end; + cell newspace_start = newspace->start; + cell newspace_end = newspace->end; for(; obj < end; obj++) { - CELL pointer = *obj; + cell pointer = *obj; if(!immediate_p(pointer)) { - check_data_pointer(pointer); + check_data_pointer((object *)pointer); if(!(pointer >= newspace_start && pointer < newspace_end) && !(pointer >= tenured_start && pointer < tenured_end)) *obj = copy_object(pointer); @@ -317,40 +386,40 @@ CELL copy_next_from_aging(CELL scan) } } - return scan + untagged_object_size(scan); + return scan + untagged_object_size((object *)scan); } -CELL copy_next_from_tenured(CELL scan) +static cell copy_next_from_tenured(cell scan) { - CELL *obj = (CELL *)scan; - CELL *end = (CELL *)(scan + binary_payload_start(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; + cell newspace_start = newspace->start; + cell newspace_end = newspace->end; for(; obj < end; obj++) { - CELL pointer = *obj; + cell pointer = *obj; if(!immediate_p(pointer)) { - check_data_pointer(pointer); + check_data_pointer((object *)pointer); if(!(pointer >= newspace_start && pointer < newspace_end)) *obj = copy_object(pointer); } } } - mark_object_code_block(scan); + mark_object_code_block((object *)scan); - return scan + untagged_object_size(scan); + return scan + untagged_object_size((object *)scan); } -void copy_reachable_objects(CELL scan, CELL *end) +void copy_reachable_objects(cell scan, cell *end) { if(collecting_gen == NURSERY) { @@ -370,26 +439,26 @@ void copy_reachable_objects(CELL scan, CELL *end) } /* Prepare to start copying reachable objects into an unused zone */ -void begin_gc(CELL requested_bytes) +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_heap; + old_data_heap = data; set_data_heap(grow_data_heap(old_data_heap,requested_bytes)); - newspace = &data_heap->generations[TENURED]; + newspace = &data->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; + 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_heap->generations[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); @@ -399,13 +468,13 @@ void begin_gc(CELL requested_bytes) /* 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]; + newspace = &data->generations[collecting_gen + 1]; } } -void end_gc(CELL gc_elapsed) +static void end_gc(cell gc_elapsed) { - F_GC_STATS *s = &gc_stats[collecting_gen]; + gc_stats *s = &stats[collecting_gen]; s->collections++; s->gc_time += gc_elapsed; @@ -444,9 +513,9 @@ void end_gc(CELL gc_elapsed) /* 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, +void garbage_collection(cell gen, bool growing_data_heap_, - CELL requested_bytes) + cell requested_bytes) { if(gc_off) { @@ -470,7 +539,7 @@ void garbage_collection(CELL gen, growing_data_heap = true; /* see the comment in unmark_marked() */ - unmark_marked(&code_heap); + unmark_marked(&code); } /* we try collecting AGING space twice before going on to collect TENURED */ @@ -490,7 +559,7 @@ void garbage_collection(CELL gen, begin_gc(requested_bytes); /* initialize chase pointer */ - CELL scan = newspace->here; + cell scan = newspace->here; /* collect objects referenced from stacks and environment */ copy_roots(); @@ -507,7 +576,7 @@ void garbage_collection(CELL gen, code_heap_scans++; if(collecting_gen == TENURED) - free_unmarked(&code_heap,(HEAP_ITERATOR)update_literal_and_word_references); + free_unmarked(&code,(heap_iterator)update_literal_and_word_references); else copy_code_heap_roots(); @@ -517,7 +586,7 @@ void garbage_collection(CELL gen, last_code_heap_scan = collecting_gen + 1; } - CELL gc_elapsed = (current_micros() - start); + cell gc_elapsed = (current_micros() - start); end_gc(gc_elapsed); @@ -529,52 +598,46 @@ void gc(void) garbage_collection(TENURED,false,0); } -void minor_gc(void) -{ - garbage_collection(NURSERY,false,0); -} - -void primitive_gc(void) +PRIMITIVE(gc) { gc(); } -void primitive_gc_stats(void) +PRIMITIVE(gc_stats) { - GROWABLE_ARRAY(stats); + growable_array result; - CELL i; + 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))); + gc_stats *s = &stats[i]; + result.add(allot_cell(s->collections)); + result.add(tag(long_long_to_bignum(s->gc_time))); + result.add(tag(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(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)); + result.add(tag(ulong_long_to_bignum(total_gc_time))); + result.add(tag(ulong_long_to_bignum(cards_scanned))); + result.add(tag(ulong_long_to_bignum(decks_scanned))); + result.add(tag(ulong_long_to_bignum(card_scan_time))); + result.add(allot_cell(code_heap_scans)); - GROWABLE_ARRAY_TRIM(stats); - GROWABLE_ARRAY_DONE(stats); - dpush(stats); + result.trim(); + dpush(result.elements.value()); } void clear_gc_stats(void) { int i; for(i = 0; i < MAX_GEN_COUNT; i++) - memset(&gc_stats[i],0,sizeof(F_GC_STATS)); + memset(&stats[i],0,sizeof(gc_stats)); cards_scanned = 0; decks_scanned = 0; @@ -582,30 +645,31 @@ void clear_gc_stats(void) code_heap_scans = 0; } -void primitive_clear_gc_stats(void) +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. */ -void primitive_become(void) +PRIMITIVE(become) { - F_ARRAY *new_objects = untag_array(dpop()); - F_ARRAY *old_objects = untag_array(dpop()); + array *new_objects = untag_check(dpop()); + array *old_objects = untag_check(dpop()); - CELL capacity = array_capacity(new_objects); + cell capacity = array_capacity(new_objects); if(capacity != array_capacity(old_objects)) critical_error("bad parameters to become",0); - CELL i; + cell i; for(i = 0; i < capacity; i++) { - CELL old_obj = array_nth(old_objects,i); - CELL new_obj = array_nth(new_objects,i); + tagged old_obj(array_nth(old_objects,i)); + tagged new_obj(array_nth(new_objects,i)); - forward_object(old_obj,new_obj); + if(old_obj != new_obj) + old_obj->h.forward_to(new_obj.untagged()); } gc(); @@ -616,3 +680,10 @@ void primitive_become(void) unoptimized words. */ compile_all_words(); } + +VM_C_API void minor_gc(void) +{ + garbage_collection(NURSERY,false,0); +} + +} diff --git a/vm/data_gc.h b/vm/data_gc.h deleted file mode 100755 index 50f87ce0be..0000000000 --- a/vm/data_gc.h +++ /dev/null @@ -1,166 +0,0 @@ -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 -} diff --git a/vm/data_gc.hpp b/vm/data_gc.hpp new file mode 100755 index 0000000000..2869179394 --- /dev/null +++ b/vm/data_gc.hpp @@ -0,0 +1,148 @@ +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 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(tagged); + check_data_pointer(obj); + obj->h.hi_tag(); + } +#endif +} + +VM_C_API void minor_gc(void); + +} diff --git a/vm/data_heap.c b/vm/data_heap.c deleted file mode 100644 index cab9114089..0000000000 --- a/vm/data_heap.c +++ /dev/null @@ -1,366 +0,0 @@ -#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; -} diff --git a/vm/data_heap.cpp b/vm/data_heap.cpp new file mode 100644 index 0000000000..d83773de9c --- /dev/null +++ b/vm/data_heap.cpp @@ -0,0 +1,371 @@ +#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(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 *)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_capacity((array*)pointer)); + case TUPLE_TYPE: + return tuple_size(untag(((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(obj).type_p(WORD_TYPE)) + words.add(obj); + } + + /* End heap scan */ + gc_off = false; + + words.trim(); + return words.elements.value(); +} + +} diff --git a/vm/data_heap.h b/vm/data_heap.h deleted file mode 100644 index 4a86367208..0000000000 --- a/vm/data_heap.h +++ /dev/null @@ -1,138 +0,0 @@ -/* 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; - } -} - diff --git a/vm/data_heap.hpp b/vm/data_heap.hpp new file mode 100644 index 0000000000..bb8b35341e --- /dev/null +++ b/vm/data_heap.hpp @@ -0,0 +1,125 @@ +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; diff --git a/vm/debug.c b/vm/debug.cpp similarity index 64% rename from vm/debug.c rename to vm/debug.cpp index a9afd2c3c0..3cd05711ad 100755 --- a/vm/debug.c +++ b/vm/debug.cpp @@ -1,25 +1,28 @@ -#include "master.h" +#include "master.hpp" +namespace factor +{ + +static bool fep_disabled; static bool full_output; -void print_chars(F_STRING* str) +void print_chars(string* str) { - CELL i; + cell i; for(i = 0; i < string_capacity(str); i++) putchar(string_nth(str,i)); } -void print_word(F_WORD* word, CELL nesting) +void print_word(word* word, cell nesting) { - - if(type_of(word->vocabulary) == STRING_TYPE) + if(tagged(word->vocabulary).type_p(STRING_TYPE)) { - print_chars(untag_string(word->vocabulary)); + print_chars(untag(word->vocabulary)); print_string(":"); } - - if(type_of(word->name) == STRING_TYPE) - print_chars(untag_string(word->name)); + + if(tagged(word->name).type_p(STRING_TYPE)) + print_chars(untag(word->name)); else { print_string("# 10 && !full_output) @@ -59,15 +62,15 @@ void print_array(F_ARRAY* array, CELL nesting) print_string("..."); } -void print_tuple(F_TUPLE* tuple, CELL nesting) +void print_tuple(tuple *tuple, cell nesting) { - F_TUPLE_LAYOUT *layout = untag_object(tuple->layout); - CELL length = to_fixnum(layout->size); + tuple_layout *layout = untag(tuple->layout); + cell length = to_fixnum(layout->size); print_string(" "); - print_nested_obj(layout->class,nesting); + print_nested_obj(layout->klass,nesting); - CELL i; + cell i; bool trimmed; if(length > 10 && !full_output) @@ -81,14 +84,14 @@ void print_tuple(F_TUPLE* tuple, CELL nesting) for(i = 0; i < length; i++) { print_string(" "); - print_nested_obj(tuple_nth(tuple,i),nesting); + print_nested_obj(tuple->data()[i],nesting); } if(trimmed) print_string("..."); } -void print_nested_obj(CELL obj, F_FIXNUM nesting) +void print_nested_obj(cell obj, fixnum nesting) { if(nesting <= 0 && !full_output) { @@ -96,54 +99,58 @@ void print_nested_obj(CELL obj, F_FIXNUM nesting) return; } - F_QUOTATION *quot; + quotation *quot; - switch(type_of(obj)) + switch(tagged(obj).type()) { case FIXNUM_TYPE: - print_fixnum(untag_fixnum_fast(obj)); + print_fixnum(untag_fixnum(obj)); break; case WORD_TYPE: - print_word(untag_word(obj),nesting - 1); + print_word(untag(obj),nesting - 1); break; case STRING_TYPE: - print_factor_string(untag_string(obj)); + print_factor_string(untag(obj)); break; case F_TYPE: print_string("f"); break; case TUPLE_TYPE: print_string("T{"); - print_tuple(untag_object(obj),nesting - 1); + print_tuple(untag(obj),nesting - 1); print_string(" }"); break; case ARRAY_TYPE: print_string("{"); - print_array(untag_object(obj),nesting - 1); + print_array(untag(obj),nesting - 1); print_string(" }"); break; case QUOTATION_TYPE: print_string("["); - quot = untag_object(obj); - print_array(untag_object(quot->array),nesting - 1); + quot = untag(obj); + print_array(untag(quot->array),nesting - 1); print_string(" ]"); break; default: - print_string("#"); + print_string("#(obj).type()); + print_string(" @ "); + print_cell_hex(obj); + print_string(">"); break; } } -void print_obj(CELL obj) +void print_obj(cell obj) { print_nested_obj(obj,10); } -void print_objects(CELL start, CELL end) +void print_objects(cell *start, cell *end) { - for(; start <= end; start += CELLS) + for(; start <= end; start++) { - print_obj(get(start)); + print_obj(*start); nl(); } } @@ -151,83 +158,52 @@ void print_objects(CELL start, CELL end) void print_datastack(void) { print_string("==== DATA STACK:\n"); - print_objects(ds_bot,ds); + print_objects((cell *)ds_bot,(cell *)ds); } void print_retainstack(void) { print_string("==== RETAIN STACK:\n"); - print_objects(rs_bot,rs); + print_objects((cell *)rs_bot,(cell *)rs); } -void print_stack_frame(F_STACK_FRAME *frame) +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_cell_hex((cell)frame_executing(frame)); print_string(" "); - print_cell_hex((CELL)frame->xt); + 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; + 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) +void dump_cell(cell x) { - 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); - } - 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; - } - + 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) +void dump_memory(cell from, cell to) { from = UNTAG(from); - for(; from <= to; from += CELLS) + for(; from <= to; from += sizeof(cell)) dump_cell(from); } -void dump_zone(F_ZONE *z) +void dump_zone(zone *z) { print_string("Start="); print_cell(z->start); print_string(", size="); print_cell(z->size); @@ -236,39 +212,39 @@ void dump_zone(F_ZONE *z) void dump_generations(void) { - CELL i; + cell i; print_string("Nursery: "); dump_zone(&nursery); - for(i = 1; i < data_heap->gen_count; i++) + for(i = 1; i < data->gen_count; i++) { print_string("Generation "); print_cell(i); print_string(": "); - dump_zone(&data_heap->generations[i]); + dump_zone(&data->generations[i]); } - for(i = 0; i < data_heap->gen_count; i++) + for(i = 0; i < data->gen_count; i++) { print_string("Semispace "); print_cell(i); print_string(": "); - dump_zone(&data_heap->semispaces[i]); + dump_zone(&data->semispaces[i]); } print_string("Cards: base="); - print_cell((CELL)data_heap->cards); + print_cell((cell)data->cards); print_string(", size="); - print_cell((CELL)(data_heap->cards_end - data_heap->cards)); + print_cell((cell)(data->cards_end - data->cards)); nl(); } -void dump_objects(F_FIXNUM type) +void dump_objects(cell type) { gc(); begin_scan(); - CELL obj; + cell obj; while((obj = next_object()) != F) { - if(type == -1 || type_of(obj) == type) + if(type == TYPE_COUNT || tagged(obj).type_p(type)) { print_cell_hex_pad(obj); print_string(" "); @@ -281,10 +257,10 @@ void dump_objects(F_FIXNUM type) gc_off = false; } -CELL look_for; -CELL obj; +cell look_for; +cell obj; -void find_data_references_step(CELL *scan) +void find_data_references_step(cell *scan) { if(look_for == *scan) { @@ -295,7 +271,7 @@ void find_data_references_step(CELL *scan) } } -void find_data_references(CELL look_for_) +void find_data_references(cell look_for_) { look_for = look_for_; @@ -311,26 +287,26 @@ void find_data_references(CELL look_for_) /* Dump all code blocks for debugging */ void dump_code_heap(void) { - CELL reloc_size = 0, literal_size = 0; + cell reloc_size = 0, literal_size = 0; - F_BLOCK *scan = first_block(&code_heap); + heap_block *scan = first_block(&code); while(scan) { - char *status; + const 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); + 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(((F_CODE_BLOCK *)scan)->relocation); - literal_size += object_size(((F_CODE_BLOCK *)scan)->literals); + reloc_size += object_size(((code_block *)scan)->relocation); + literal_size += object_size(((code_block *)scan)->literals); status = "marked"; break; default: @@ -338,11 +314,11 @@ void dump_code_heap(void) break; } - print_cell_hex((CELL)scan); print_string(" "); + 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); + scan = next_block(&code,scan); } print_cell(reloc_size); print_string(" bytes of relocation data\n"); @@ -413,20 +389,20 @@ void factorbug(void) if(strcmp(cmd,"d") == 0) { - CELL addr = read_cell_hex(); + cell addr = read_cell_hex(); if(scanf(" ") < 0) break; - CELL count = read_cell_hex(); + 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); + 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(); + cell addr = read_cell_hex(); print_obj(addr); print_string("\n"); } @@ -446,20 +422,20 @@ void factorbug(void) { int i; for(i = 0; i < USER_ENV; i++) - dump_cell((CELL)&userenv[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)); + 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)); + card *ptr = (card *)read_cell_hex(); + print_cell_hex(card_to_addr(ptr)); nl(); } else if(strcmp(cmd,"q") == 0) @@ -469,10 +445,10 @@ void factorbug(void) else if(strcmp(cmd,"im") == 0) save_image(STRING_LITERAL("fep.image")); else if(strcmp(cmd,"data") == 0) - dump_objects(-1); + dump_objects(TYPE_COUNT); else if(strcmp(cmd,"refs") == 0) { - CELL addr = read_cell_hex(); + cell addr = read_cell_hex(); print_string("Data heap references:\n"); find_data_references(addr); nl(); @@ -483,7 +459,7 @@ void factorbug(void) dump_objects(TUPLE_TYPE); else if(strcmp(cmd,"push") == 0) { - CELL addr = read_cell_hex(); + cell addr = read_cell_hex(); dpush(addr); } else if(strcmp(cmd,"code") == 0) @@ -493,9 +469,11 @@ void factorbug(void) } } -void primitive_die(void) +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(); } + +} diff --git a/vm/debug.h b/vm/debug.h deleted file mode 100755 index 594d8ec919..0000000000 --- a/vm/debug.h +++ /dev/null @@ -1,9 +0,0 @@ -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); diff --git a/vm/debug.hpp b/vm/debug.hpp new file mode 100755 index 0000000000..81874bf2ac --- /dev/null +++ b/vm/debug.hpp @@ -0,0 +1,12 @@ +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); + +} diff --git a/vm/dispatch.c b/vm/dispatch.c deleted file mode 100644 index 68ef192531..0000000000 --- a/vm/dispatch.c +++ /dev/null @@ -1,202 +0,0 @@ -#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]); -} diff --git a/vm/dispatch.cpp b/vm/dispatch.cpp new file mode 100644 index 0000000000..bbcf20c57b --- /dev/null +++ b/vm/dispatch.cpp @@ -0,0 +1,211 @@ +#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(table); + fixnum index = array_capacity(pairs) - 1; + while(index >= 0) + { + array *pair = untag(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(table); + cell bucket = array_nth(buckets,hashcode & (array_capacity(buckets) - 1)); + if(tagged(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(untag(obj)->layout); + + array *echelons = untag(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(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(methods); + cell tag = untag(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(methods),TAG(obj)); + if(tagged(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(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(obj)->layout; + case OBJECT_TYPE: + return untag(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(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 methods(methods_); + gc_root 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]); +} + +} diff --git a/vm/dispatch.h b/vm/dispatch.h deleted file mode 100644 index 1aac242293..0000000000 --- a/vm/dispatch.h +++ /dev/null @@ -1,16 +0,0 @@ -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); diff --git a/vm/dispatch.hpp b/vm/dispatch.hpp new file mode 100644 index 0000000000..f5648c7ebe --- /dev/null +++ b/vm/dispatch.hpp @@ -0,0 +1,18 @@ +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); + +} diff --git a/vm/errors.c b/vm/errors.cpp similarity index 74% rename from vm/errors.c rename to vm/errors.cpp index 8e7b4818bf..f2ba355293 100755 --- a/vm/errors.c +++ b/vm/errors.cpp @@ -1,4 +1,13 @@ -#include "master.h" +#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) { @@ -7,14 +16,14 @@ void out_of_memory(void) exit(1); } -void fatal_error(char* msg, CELL tagged) +void fatal_error(const 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) +void critical_error(const char* msg, cell tagged) { print_string("You have triggered a bug in Factor. Please report.\n"); print_string("critical_error: "); print_string(msg); @@ -22,7 +31,7 @@ void critical_error(char* msg, CELL tagged) factorbug(); } -void throw_error(CELL error, F_STACK_FRAME *callstack_top) +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. */ @@ -32,8 +41,8 @@ void throw_error(CELL error, F_STACK_FRAME *callstack_top) gc_off = false; /* Reset local roots */ - gc_locals = gc_locals_region->start - CELLS; - extra_roots = extra_roots_region->start - CELLS; + 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 */ @@ -67,14 +76,14 @@ void throw_error(CELL error, F_STACK_FRAME *callstack_top) } } -void general_error(F_ERRORTYPE error, CELL arg1, CELL arg2, - F_STACK_FRAME *callstack_top) +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) +void type_error(cell type, cell tagged) { general_error(ERROR_TYPE,tag_fixnum(type),tagged,NULL); } @@ -86,7 +95,7 @@ void not_implemented_error(void) /* Test if 'fault' is in the guard page at the top or bottom (depending on offset being 0 or -1) of area+area_size */ -bool in_page(CELL fault, CELL area, CELL area_size, int offset) +bool in_page(cell fault, cell area, cell area_size, int offset) { int pagesize = getpagesize(); area += area_size; @@ -95,7 +104,7 @@ bool in_page(CELL fault, CELL area, CELL area_size, int offset) return fault >= area && fault <= area + pagesize; } -void memory_protection_error(CELL addr, F_STACK_FRAME *native_stack) +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); @@ -107,19 +116,11 @@ void memory_protection_error(CELL addr, F_STACK_FRAME *native_stack) 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) +void signal_error(int signal, stack_frame *native_stack) { general_error(ERROR_SIGNAL,tag_fixnum(signal),F,native_stack); } @@ -129,6 +130,17 @@ 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); @@ -139,13 +151,4 @@ 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(); } diff --git a/vm/errors.h b/vm/errors.h deleted file mode 100755 index 56aaf60d54..0000000000 --- a/vm/errors.h +++ /dev/null @@ -1,58 +0,0 @@ -/* 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); diff --git a/vm/errors.hpp b/vm/errors.hpp new file mode 100755 index 0000000000..e5968468a5 --- /dev/null +++ b/vm/errors.hpp @@ -0,0 +1,51 @@ +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(const char* msg, cell tagged); +void critical_error(const char* msg, cell tagged); + +PRIMITIVE(die); + +void throw_error(cell error, stack_frame *native_stack); +void general_error(vm_error_type error, cell arg1, cell arg2, stack_frame *native_stack); +void divide_by_zero_error(void); +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); + +} diff --git a/vm/factor.c b/vm/factor.cpp similarity index 64% rename from vm/factor.c rename to vm/factor.cpp index 0a652f7aab..b607adba63 100755 --- a/vm/factor.c +++ b/vm/factor.cpp @@ -1,14 +1,17 @@ -#include "master.h" +#include "master.hpp" -void default_parameters(F_PARAMETERS *p) +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 * CELLS; - p->rs_size = 8 * CELLS; + p->ds_size = 8 * sizeof(cell); + p->rs_size = 8 * sizeof(cell); p->gen_count = 2; p->code_size = 4; @@ -16,14 +19,14 @@ void default_parameters(F_PARAMETERS *p) p->aging_size = 1; p->tenured_size = 6; #else - p->ds_size = 32 * CELLS; - p->rs_size = 32 * CELLS; + p->ds_size = 32 * sizeof(cell); + p->rs_size = 32 * sizeof(cell); p->gen_count = 3; - p->code_size = 8 * CELLS; - p->young_size = CELLS / 4; - p->aging_size = CELLS / 2; - p->tenured_size = 4 * CELLS; + 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; @@ -40,7 +43,7 @@ void default_parameters(F_PARAMETERS *p) p->stack_traces = true; } -INLINE bool factor_arg(const F_CHAR* str, const F_CHAR* arg, CELL* value) +static bool factor_arg(const vm_char* str, const vm_char* arg, cell* value) { int val; if(SSCANF(str,arg,&val) > 0) @@ -52,7 +55,7 @@ INLINE bool factor_arg(const F_CHAR* str, const F_CHAR* arg, CELL* value) return false; } -void init_parameters_from_args(F_PARAMETERS *p, int argc, F_CHAR **argv) +VM_C_API void init_parameters_from_args(vm_parameters *p, int argc, vm_char **argv) { default_parameters(p); p->executable_path = argv[0]; @@ -78,7 +81,7 @@ void init_parameters_from_args(F_PARAMETERS *p, int argc, F_CHAR **argv) } /* Do some initialization that we do once only */ -void do_stage1_init(void) +static void do_stage1_init(void) { print_string("*** Stage 2 early init... "); fflush(stdout); @@ -90,7 +93,7 @@ void do_stage1_init(void) fflush(stdout); } -void init_factor(F_PARAMETERS *p) +VM_C_API void init_factor(vm_parameters *p) { /* Kilobytes */ p->ds_size = align_page(p->ds_size << 10); @@ -108,7 +111,7 @@ void init_factor(F_PARAMETERS *p) /* OS-specific initialization */ early_init(); - const F_CHAR *executable_path = vm_executable_path(); + const vm_char *executable_path = vm_executable_path(); if(executable_path) p->executable_path = executable_path; @@ -122,31 +125,24 @@ void init_factor(F_PARAMETERS *p) 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; + init_profiler(); - 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[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(!stage2) + if(userenv[STAGE2_ENV] == F) { userenv[STACK_TRACES_ENV] = tag_boolean(p->stack_traces); do_stage1_init(); @@ -154,23 +150,19 @@ void init_factor(F_PARAMETERS *p) } /* May allocate memory */ -void pass_args_to_factor(int argc, F_CHAR **argv) +VM_C_API void pass_args_to_factor(int argc, vm_char **argv) { - F_ARRAY *args = allot_array(ARRAY_TYPE,argc,F); + growable_array args; 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); - } + args.add(allot_alien(F,(cell)argv[i])); - userenv[ARGS_ENV] = tag_array(args); + args.trim(); + userenv[ARGS_ENV] = args.elements.value(); } -void start_factor(F_PARAMETERS *p) +static void start_factor(vm_parameters *p) { if(p->fep) factorbug(); @@ -179,15 +171,15 @@ void start_factor(F_PARAMETERS *p) unnest_stacks(); } -void start_embedded_factor(F_PARAMETERS *p) +VM_C_API void start_embedded_factor(vm_parameters *p) { userenv[EMBEDDED_ENV] = T; start_factor(p); } -void start_standalone_factor(int argc, F_CHAR **argv) +VM_C_API void start_standalone_factor(int argc, vm_char **argv) { - F_PARAMETERS p; + vm_parameters p; default_parameters(&p); init_parameters_from_args(&p,argc,argv); init_factor(&p); @@ -195,25 +187,27 @@ void start_standalone_factor(int argc, F_CHAR **argv) start_factor(&p); } -char *factor_eval_string(char *string) +VM_C_API char *factor_eval_string(char *string) { - char* (*callback)(char*) = alien_offset(userenv[EVAL_CALLBACK_ENV]); + char *(*callback)(char *) = (char *(*)(char *))alien_offset(userenv[EVAL_CALLBACK_ENV]); return callback(string); } -void factor_eval_free(char *result) +VM_C_API void factor_eval_free(char *result) { free(result); } -void factor_yield(void) +VM_C_API void factor_yield(void) { - void (*callback)() = alien_offset(userenv[YIELD_CALLBACK_ENV]); + void (*callback)(void) = (void (*)(void))alien_offset(userenv[YIELD_CALLBACK_ENV]); callback(); } -void factor_sleep(long us) +VM_C_API void factor_sleep(long us) { - void (*callback)() = alien_offset(userenv[SLEEP_CALLBACK_ENV]); + void (*callback)(long) = (void (*)(long))alien_offset(userenv[SLEEP_CALLBACK_ENV]); callback(us); } + +} diff --git a/vm/factor.h b/vm/factor.h deleted file mode 100644 index a3de31a502..0000000000 --- a/vm/factor.h +++ /dev/null @@ -1,11 +0,0 @@ -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); diff --git a/vm/factor.hpp b/vm/factor.hpp new file mode 100644 index 0000000000..e9ba920e9f --- /dev/null +++ b/vm/factor.hpp @@ -0,0 +1,16 @@ +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); + +} diff --git a/vm/ffi_test.c b/vm/ffi_test.c index a5a43cf2ae..680b144140 100755 --- a/vm/ffi_test.c +++ b/vm/ffi_test.c @@ -1,8 +1,10 @@ /* This file is linked into the runtime for the sole purpose * of testing FFI code. */ -#include "master.h" #include "ffi_test.h" +#include +#include + void ffi_test_0(void) { } @@ -259,7 +261,7 @@ unsigned long long ffi_test_38(unsigned long long x, unsigned long long y) 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; } diff --git a/vm/ffi_test.h b/vm/ffi_test.h index f8634b304e..f16e52e091 100755 --- a/vm/ffi_test.h +++ b/vm/ffi_test.h @@ -4,6 +4,8 @@ #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); diff --git a/vm/float_bits.h b/vm/float_bits.h deleted file mode 100644 index a60d42f97c..0000000000 --- a/vm/float_bits.h +++ /dev/null @@ -1,40 +0,0 @@ -/* 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; -} diff --git a/vm/float_bits.hpp b/vm/float_bits.hpp new file mode 100644 index 0000000000..000bd49482 --- /dev/null +++ b/vm/float_bits.hpp @@ -0,0 +1,45 @@ +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; +} + +} diff --git a/vm/generic_arrays.hpp b/vm/generic_arrays.hpp new file mode 100644 index 0000000000..26c8149a10 --- /dev/null +++ b/vm/generic_arrays.hpp @@ -0,0 +1,59 @@ +namespace factor +{ + +template cell array_capacity(T *array) +{ +#ifdef FACTOR_DEBUG + assert(array->h.hi_tag() == T::type_number); +#endif + return array->capacity >> TAG_BITS; +} + +template cell array_size(cell capacity) +{ + return sizeof(T) + capacity * T::element_size; +} + +template cell array_size(T *array) +{ + return array_size(array_capacity(array)); +} + +template T *allot_array_internal(cell capacity) +{ + T *array = allot(array_size(capacity)); + array->capacity = tag_fixnum(capacity); + return array; +} + +template bool reallot_array_in_place_p(T *array, cell capacity) +{ + return in_zone(&nursery,array) && capacity <= array_capacity(array); +} + +template T *reallot_array(T *array_, cell capacity) +{ + gc_root 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(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; + } +} + +} diff --git a/vm/image.c b/vm/image.cpp similarity index 58% rename from vm/image.c rename to vm/image.cpp index d7bf035514..2aa7727136 100755 --- a/vm/image.c +++ b/vm/image.cpp @@ -1,7 +1,10 @@ -#include "master.h" +#include "master.hpp" + +namespace factor +{ /* Certain special objects in the image are known to the runtime */ -void init_objects(F_HEADER *h) +static void init_objects(image_header *h) { memcpy(userenv,h->userenv,sizeof(userenv)); @@ -9,13 +12,13 @@ void init_objects(F_HEADER *h) 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 data_relocation_base; + +static void load_data_heap(FILE *file, image_header *h, vm_parameters *p) { - CELL good_size = h->data_size + (1 << 20); + cell good_size = h->data_size + (1 << 20); if(good_size > p->tenured_size) p->tenured_size = good_size; @@ -28,11 +31,11 @@ INLINE void load_data_heap(FILE *file, F_HEADER *h, F_PARAMETERS *p) clear_gc_stats(); - F_ZONE *tenured = &data_heap->generations[TENURED]; + zone *tenured = &data->generations[TENURED]; - F_FIXNUM bytes_read = fread((void*)tenured->start,1,h->data_size,file); + fixnum bytes_read = fread((void*)tenured->start,1,h->data_size,file); - if(bytes_read != h->data_size) + if((cell)bytes_read != h->data_size) { print_string("truncated image: "); print_fixnum(bytes_read); @@ -46,9 +49,11 @@ INLINE void load_data_heap(FILE *file, F_HEADER *h, F_PARAMETERS *p) data_relocation_base = h->data_relocation_base; } -INLINE void load_code_heap(FILE *file, F_HEADER *h, F_PARAMETERS *p) +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); + cell good_size = h->code_size + (1 << 19); if(good_size > p->code_size) p->code_size = good_size; @@ -57,7 +62,7 @@ INLINE void load_code_heap(FILE *file, F_HEADER *h, F_PARAMETERS *p) if(h->code_size != 0) { - F_FIXNUM bytes_read = fread(first_block(&code_heap),1,h->code_size,file); + size_t bytes_read = fread(first_block(&code),1,h->code_size,file); if(bytes_read != h->code_size) { print_string("truncated image: "); @@ -70,12 +75,239 @@ INLINE void load_code_heap(FILE *file, F_HEADER *h, F_PARAMETERS *p) } code_relocation_base = h->code_relocation_base; - build_free_list(&code_heap,h->code_size); + 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 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 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 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(F_PARAMETERS *p) +void load_image(vm_parameters *p) { FILE *file = OPEN_READ(p->image_path); if(file == NULL) @@ -85,8 +317,8 @@ void load_image(F_PARAMETERS *p) exit(1); } - F_HEADER h; - if(fread(&h,sizeof(F_HEADER),1,file) != 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) @@ -106,218 +338,7 @@ void load_image(F_PARAMETERS *p) relocate_code(); /* Store image path name */ - userenv[IMAGE_ENV] = tag_object(from_native_string(p->image_path)); + userenv[IMAGE_ENV] = allot_alien(F,(cell)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); } diff --git a/vm/image.h b/vm/image.h deleted file mode 100755 index de5b55f0af..0000000000 --- a/vm/image.h +++ /dev/null @@ -1,69 +0,0 @@ -#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(); diff --git a/vm/image.hpp b/vm/image.hpp new file mode 100755 index 0000000000..c306f322de --- /dev/null +++ b/vm/image.hpp @@ -0,0 +1,50 @@ +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); + +} diff --git a/vm/inline_cache.c b/vm/inline_cache.c deleted file mode 100644 index 83981d2894..0000000000 --- a/vm/inline_cache.c +++ /dev/null @@ -1,248 +0,0 @@ -#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); -} diff --git a/vm/inline_cache.cpp b/vm/inline_cache.cpp new file mode 100644 index 0000000000..5d9fbf069e --- /dev/null +++ b/vm/inline_cache.cpp @@ -0,0 +1,261 @@ +#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 generic_word(generic_word_); + gc_root methods(methods_); + gc_root 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 generic_word(generic_word_); + gc_root methods(methods_); + gc_root 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(generic_word)->xt; +} + +static cell inline_cache_size(cell cache_entries) +{ + return array_capacity(untag_check(cache_entries)) / 2; +} + +/* Allocates memory */ +static cell add_inline_cache_entry(cell cache_entries_, cell klass_, cell method_) +{ + gc_root cache_entries(cache_entries_); + gc_root klass(klass_); + gc_root method(method_); + + cell pic_size = array_capacity(cache_entries.untagged()); + gc_root 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 cache_entries(dpop()); + fixnum index = untag_fixnum(dpop()); + gc_root methods(dpop()); + gc_root generic_word(dpop()); + gc_root 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 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()); +} + +} diff --git a/vm/inline_cache.h b/vm/inline_cache.h deleted file mode 100644 index 83f2644f5a..0000000000 --- a/vm/inline_cache.h +++ /dev/null @@ -1,17 +0,0 @@ -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); diff --git a/vm/inline_cache.hpp b/vm/inline_cache.hpp new file mode 100644 index 0000000000..84334efc78 --- /dev/null +++ b/vm/inline_cache.hpp @@ -0,0 +1,14 @@ +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); + +} diff --git a/vm/io.c b/vm/io.cpp similarity index 63% rename from vm/io.c rename to vm/io.cpp index d88f1bab50..2d6c94faf0 100755 --- a/vm/io.c +++ b/vm/io.cpp @@ -1,4 +1,7 @@ -#include "master.h" +#include "master.hpp" + +namespace factor +{ /* Simple wrappers for ANSI C I/O functions, used for bootstrapping. @@ -13,9 +16,9 @@ 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); + 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) @@ -25,20 +28,20 @@ void io_error(void) return; #endif - CELL error = tag_object(from_char_string(strerror(errno))); - general_error(ERROR_IO,error,F,NULL); + general_error(ERROR_IO,tag_fixnum(errno),F,NULL); } -void primitive_fopen(void) +PRIMITIVE(fopen) { - char *mode = unbox_char_string(); - REGISTER_C_STRING(mode); - char *path = unbox_char_string(); - UNREGISTER_C_STRING(mode); + gc_root mode(dpop()); + gc_root path(dpop()); + mode.untag_check(); + path.untag_check(); for(;;) { - FILE *file = fopen(path,mode); + FILE *file = fopen((char *)(path.untagged() + 1), + (char *)(mode.untagged() + 1)); if(file == NULL) io_error(); else @@ -49,9 +52,9 @@ void primitive_fopen(void) } } -void primitive_fgetc(void) +PRIMITIVE(fgetc) { - FILE* file = unbox_alien(); + FILE *file = (FILE *)unbox_alien(); for(;;) { @@ -74,22 +77,22 @@ void primitive_fgetc(void) } } -void primitive_fread(void) +PRIMITIVE(fread) { - FILE* file = unbox_alien(); - CELL size = unbox_array_size(); + FILE *file = (FILE *)unbox_alien(); + fixnum size = unbox_array_size(); if(size == 0) { - dpush(tag_object(allot_string(0,0))); + dpush(tag(allot_string(0,0))); return; } - F_BYTE_ARRAY *buf = allot_byte_array(size); + gc_root buf(allot_array_internal(size)); for(;;) { - int c = fread(buf + 1,1,size,file); + int c = fread(buf.untagged() + 1,1,size,file); if(c <= 0) { if(feof(file)) @@ -104,22 +107,20 @@ void primitive_fread(void) { 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); + byte_array *new_buf = allot_byte_array(c); + memcpy(new_buf + 1, buf.untagged() + 1,c); buf = new_buf; } - dpush(tag_object(buf)); + dpush(buf.value()); break; } } } -void primitive_fputc(void) +PRIMITIVE(fputc) { - FILE *file = unbox_alien(); - F_FIXNUM ch = to_fixnum(dpop()); + FILE *file = (FILE *)unbox_alien(); + fixnum ch = to_fixnum(dpop()); for(;;) { @@ -134,11 +135,11 @@ void primitive_fputc(void) } } -void primitive_fwrite(void) +PRIMITIVE(fwrite) { - FILE *file = unbox_alien(); - F_BYTE_ARRAY *text = untag_byte_array(dpop()); - F_FIXNUM length = array_capacity(text); + FILE *file = (FILE *)unbox_alien(); + byte_array *text = untag_check(dpop()); + cell length = array_capacity(text); char *string = (char *)(text + 1); if(length == 0) @@ -163,10 +164,10 @@ void primitive_fwrite(void) } } -void primitive_fseek(void) +PRIMITIVE(fseek) { int whence = to_fixnum(dpop()); - FILE *file = unbox_alien(); + FILE *file = (FILE *)unbox_alien(); off_t offset = to_signed_8(dpop()); switch(whence) @@ -188,9 +189,9 @@ void primitive_fseek(void) } } -void primitive_fflush(void) +PRIMITIVE(fflush) { - FILE *file = unbox_alien(); + FILE *file = (FILE *)unbox_alien(); for(;;) { if(fflush(file) == EOF) @@ -200,9 +201,9 @@ void primitive_fflush(void) } } -void primitive_fclose(void) +PRIMITIVE(fclose) { - FILE *file = unbox_alien(); + FILE *file = (FILE *)unbox_alien(); for(;;) { if(fclose(file) == EOF) @@ -215,12 +216,14 @@ void primitive_fclose(void) /* 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) +VM_C_API int err_no(void) { return errno; } -void clear_err_no(void) +VM_C_API void clear_err_no(void) { errno = 0; } + +} diff --git a/vm/io.h b/vm/io.h deleted file mode 100755 index 63a9c35490..0000000000 --- a/vm/io.h +++ /dev/null @@ -1,18 +0,0 @@ -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); diff --git a/vm/io.hpp b/vm/io.hpp new file mode 100755 index 0000000000..968e96f0b5 --- /dev/null +++ b/vm/io.hpp @@ -0,0 +1,24 @@ +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); + +} diff --git a/vm/jit.c b/vm/jit.c deleted file mode 100644 index 8d7dcd657a..0000000000 --- a/vm/jit.c +++ /dev/null @@ -1,119 +0,0 @@ -#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); -} - diff --git a/vm/jit.cpp b/vm/jit.cpp new file mode 100644 index 0000000000..bb86506058 --- /dev/null +++ b/vm/jit.cpp @@ -0,0 +1,117 @@ +#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(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 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 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 code_template(code_template_); + gc_root 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()); +} + +} diff --git a/vm/jit.h b/vm/jit.h deleted file mode 100644 index 4ea72ee9a4..0000000000 --- a/vm/jit.h +++ /dev/null @@ -1,87 +0,0 @@ -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; -} diff --git a/vm/jit.hpp b/vm/jit.hpp new file mode 100644 index 0000000000..30b5163b4a --- /dev/null +++ b/vm/jit.hpp @@ -0,0 +1,64 @@ +namespace factor +{ + +struct jit { + cell type; + gc_root 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_); + gc_root 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(); +}; + +} diff --git a/vm/layouts.h b/vm/layouts.h deleted file mode 100755 index f439b1f8a7..0000000000 --- a/vm/layouts.h +++ /dev/null @@ -1,259 +0,0 @@ -#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<> 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; diff --git a/vm/layouts.hpp b/vm/layouts.hpp new file mode 100755 index 0000000000..4928fda632 --- /dev/null +++ b/vm/layouts.hpp @@ -0,0 +1,323 @@ +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 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); } +}; + +} diff --git a/vm/local_roots.cpp b/vm/local_roots.cpp new file mode 100644 index 0000000000..717beb32c7 --- /dev/null +++ b/vm/local_roots.cpp @@ -0,0 +1,12 @@ +#include "master.hpp" + +namespace factor +{ + +segment *gc_locals_region; +cell gc_locals; + +segment *gc_bignums_region; +cell gc_bignums; + +} diff --git a/vm/local_roots.h b/vm/local_roots.h deleted file mode 100644 index bbedf46394..0000000000 --- a/vm/local_roots.h +++ /dev/null @@ -1,68 +0,0 @@ -/* 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())) diff --git a/vm/local_roots.hpp b/vm/local_roots.hpp new file mode 100644 index 0000000000..e074d999e7 --- /dev/null +++ b/vm/local_roots.hpp @@ -0,0 +1,54 @@ +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 +struct gc_root : public tagged +{ + void push() { gc_local_push((cell)this); } + + explicit gc_root(cell value_) : tagged(value_) { push(); } + explicit gc_root(T *value_) : tagged(value_) { push(); } + + const gc_root& operator=(const T *x) { tagged::operator=(x); return *this; } + const gc_root& operator=(const cell &x) { tagged::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) + +} diff --git a/vm/mach_signal.c b/vm/mach_signal.cpp similarity index 92% rename from vm/mach_signal.c rename to vm/mach_signal.cpp index 57fb91d662..f752c3cb8f 100644 --- a/vm/mach_signal.c +++ b/vm/mach_signal.cpp @@ -1,5 +1,6 @@ /* Fault handler information. MacOSX version. Copyright (C) 1993-1999, 2002-2003 Bruno Haible + Copyright (C) 2003 Paolo Bonzini Used under BSD license with permission from Paolo Bonzini and Bruno Haible, @@ -9,7 +10,13 @@ http://sourceforge.net/mailarchive/message.php?msg_name=200503102200.32002.bruno Modified for Factor by Slava Pestov */ -#include "master.h" +#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: @@ -32,7 +39,7 @@ static void call_fault_handler(exception_type_t exception, /* 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); + 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; @@ -43,7 +50,7 @@ static void call_fault_handler(exception_type_t exception, if(exception == EXC_BAD_ACCESS) { signal_fault_addr = MACH_EXC_STATE_FAULT(exc_state); - MACH_PROGRAM_COUNTER(thread_state) = (CELL)memory_signal_handler_impl; + MACH_PROGRAM_COUNTER(thread_state) = (cell)memory_signal_handler_impl; } else { @@ -51,12 +58,13 @@ static void call_fault_handler(exception_type_t exception, signal_number = SIGFPE; else signal_number = SIGABRT; - MACH_PROGRAM_COUNTER(thread_state) = (CELL)misc_signal_handler_impl; + 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, @@ -74,7 +82,7 @@ catch_exception_raise (mach_port_t exception_port, 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) + (natural_t *)&exc_state, &state_count) != KERN_SUCCESS) { /* The thread is supposed to be suspended while the exception @@ -84,7 +92,7 @@ catch_exception_raise (mach_port_t exception_port, state_count = MACH_THREAD_STATE_COUNT; if (thread_get_state (thread, MACH_THREAD_STATE_FLAVOR, - (void *) &thread_state, &state_count) + (natural_t *)&thread_state, &state_count) != KERN_SUCCESS) { /* The thread is supposed to be suspended while the exception @@ -100,7 +108,7 @@ catch_exception_raise (mach_port_t exception_port, 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) + (natural_t *)&thread_state, state_count) != KERN_SUCCESS) { return KERN_FAILURE; @@ -160,7 +168,6 @@ mach_exception_thread (void *arg) } } - /* Initialize the Mach exception handler thread. */ void mach_initialize (void) { @@ -197,3 +204,5 @@ void mach_initialize (void) != KERN_SUCCESS) fatal_error("task_set_exception_ports() failed",0); } + +} diff --git a/vm/mach_signal.h b/vm/mach_signal.hpp similarity index 94% rename from vm/mach_signal.h rename to vm/mach_signal.hpp index 863fd86dae..5dd344c080 100644 --- a/vm/mach_signal.h +++ b/vm/mach_signal.hpp @@ -20,9 +20,6 @@ Modified for Factor by Slava Pestov */ #include #include -/* 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: @@ -39,14 +36,13 @@ mach_port_t our_exception_port; 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); +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, @@ -54,6 +50,7 @@ catch_exception_raise (mach_port_t exception_port, 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, @@ -64,6 +61,8 @@ catch_exception_raise_state (mach_port_t exception_port, 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, @@ -77,4 +76,9 @@ catch_exception_raise_state_identity (mach_port_t exception_port, thread_state_t out_state, mach_msg_type_number_t *out_state_count); +namespace factor +{ + void mach_initialize (void); + +} diff --git a/vm/main-unix.c b/vm/main-unix.c deleted file mode 100644 index b177c58eb3..0000000000 --- a/vm/main-unix.c +++ /dev/null @@ -1,7 +0,0 @@ -#include "master.h" - -int main(int argc, char **argv) -{ - start_standalone_factor(argc,argv); - return 0; -} diff --git a/vm/main-unix.cpp b/vm/main-unix.cpp new file mode 100644 index 0000000000..bc605e3cfd --- /dev/null +++ b/vm/main-unix.cpp @@ -0,0 +1,7 @@ +#include "master.hpp" + +int main(int argc, char **argv) +{ + factor::start_standalone_factor(argc,argv); + return 0; +} diff --git a/vm/main-windows-ce.c b/vm/main-windows-ce.cpp similarity index 97% rename from vm/main-windows-ce.c rename to vm/main-windows-ce.cpp index fc04d455db..526f3b2c36 100644 --- a/vm/main-windows-ce.c +++ b/vm/main-windows-ce.cpp @@ -1,4 +1,4 @@ -#include "master.h" +#include "master.hpp" /* Windows CE argument parsing ported to work on @@ -128,7 +128,7 @@ WinMain( int nCmdShow) { parse_args(&__argc, &__argv, lpCmdLine); - start_standalone_factor(__argc,(LPWSTR*)__argv); + factor::start_standalone_factor(__argc,(LPWSTR*)__argv); // memory leak from malloc, wcsdup return 0; } diff --git a/vm/main-windows-nt.c b/vm/main-windows-nt.cpp similarity index 71% rename from vm/main-windows-nt.c rename to vm/main-windows-nt.cpp index 6552e88bed..eaaad0f55b 100755 --- a/vm/main-windows-nt.c +++ b/vm/main-windows-nt.cpp @@ -1,7 +1,4 @@ -#include -#include -#include -#include "master.h" +#include "master.hpp" int WINAPI WinMain( HINSTANCE hInstance, @@ -19,7 +16,7 @@ int WINAPI WinMain( return 1; } - start_standalone_factor(nArgs,szArglist); + factor::start_standalone_factor(nArgs,szArglist); LocalFree(szArglist); diff --git a/vm/master.h b/vm/master.h deleted file mode 100644 index 9866c4aafd..0000000000 --- a/vm/master.h +++ /dev/null @@ -1,59 +0,0 @@ -#ifndef __FACTOR_MASTER_H__ -#define __FACTOR_MASTER_H__ - -#ifndef WINCE -#include -#endif - -#ifdef FACTOR_DEBUG -#include -#endif - -#include -#include -#include -#include -#include - -#include -#include -#include -#include -#include - -#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__ */ diff --git a/vm/master.hpp b/vm/master.hpp new file mode 100644 index 0000000000..fa7d7fa1a4 --- /dev/null +++ b/vm/master.hpp @@ -0,0 +1,63 @@ +#ifndef __FACTOR_MASTER_H__ +#define __FACTOR_MASTER_H__ + +#ifndef WINCE +#include +#endif + +#ifdef FACTOR_DEBUG +#include +#endif + +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include + +#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__ */ diff --git a/vm/math.c b/vm/math.c deleted file mode 100644 index 25180abdd6..0000000000 --- a/vm/math.c +++ /dev/null @@ -1,515 +0,0 @@ -#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)); -} diff --git a/vm/math.cpp b/vm/math.cpp new file mode 100644 index 0000000000..57d5e4a517 --- /dev/null +++ b/vm/math.cpp @@ -0,0 +1,516 @@ +#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(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_arithmetic_shift( + fixnum_to_bignum(x),y))); +} + +PRIMITIVE(fixnum_to_bignum) +{ + drepl(tag(fixnum_to_bignum(untag_fixnum(dpeek())))); +} + +PRIMITIVE(float_to_bignum) +{ + drepl(tag(float_to_bignum(dpeek()))); +} + +#define POP_BIGNUMS(x,y) \ + bignum * y = untag(dpop()); \ + bignum * x = untag(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_add(x,y))); +} + +PRIMITIVE(bignum_subtract) +{ + POP_BIGNUMS(x,y); + dpush(tag(bignum_subtract(x,y))); +} + +PRIMITIVE(bignum_multiply) +{ + POP_BIGNUMS(x,y); + dpush(tag(bignum_multiply(x,y))); +} + +PRIMITIVE(bignum_divint) +{ + POP_BIGNUMS(x,y); + dpush(tag(bignum_quotient(x,y))); +} + +PRIMITIVE(bignum_divmod) +{ + bignum *q, *r; + POP_BIGNUMS(x,y); + bignum_divide(x,y,&q,&r); + dpush(tag(q)); + dpush(tag(r)); +} + +PRIMITIVE(bignum_mod) +{ + POP_BIGNUMS(x,y); + dpush(tag(bignum_remainder(x,y))); +} + +PRIMITIVE(bignum_and) +{ + POP_BIGNUMS(x,y); + dpush(tag(bignum_bitwise_and(x,y))); +} + +PRIMITIVE(bignum_or) +{ + POP_BIGNUMS(x,y); + dpush(tag(bignum_bitwise_ior(x,y))); +} + +PRIMITIVE(bignum_xor) +{ + POP_BIGNUMS(x,y); + dpush(tag(bignum_bitwise_xor(x,y))); +} + +PRIMITIVE(bignum_shift) +{ + fixnum y = untag_fixnum(dpop()); + bignum* x = untag(dpop()); + dpush(tag(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_bitwise_not(untag(dpeek())))); +} + +PRIMITIVE(bignum_bitp) +{ + fixnum bit = to_fixnum(dpop()); + bignum *x = untag(dpop()); + box_boolean(bignum_logbitp(bit,x)); +} + +PRIMITIVE(bignum_log2) +{ + drepl(tag(bignum_integer_length(untag(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(dpeek())); + bignum * result = digit_stream_to_bignum(n_digits,bignum_producer,0x100,0); + drepl(tag(result)); +} + +cell unbox_array_size(void) +{ + switch(tagged(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_zero); + bignum * max = cell_to_bignum(ARRAY_SIZE_MAX); + bignum * n = untag(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(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(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(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(long_long_to_bignum(n))); + else + dpush(tag_fixnum(n)); +} + +VM_C_API s64 to_signed_8(cell obj) +{ + switch(tagged(obj).type()) + { + case FIXNUM_TYPE: + return untag_fixnum(obj); + case BIGNUM_TYPE: + return bignum_to_long_long(untag(obj)); + default: + type_error(BIGNUM_TYPE,obj); + return -1; + } +} + +VM_C_API void box_unsigned_8(u64 n) +{ + if(n > FIXNUM_MAX) + dpush(tag(ulong_long_to_bignum(n))); + else + dpush(tag_fixnum(n)); +} + +VM_C_API u64 to_unsigned_8(cell obj) +{ + switch(tagged(obj).type()) + { + case FIXNUM_TYPE: + return untag_fixnum(obj); + case BIGNUM_TYPE: + return bignum_to_ulong_long(untag(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(fixnum_to_bignum( + untag_fixnum(x) + untag_fixnum(y)))); +} + +VM_ASM_API void overflow_fixnum_subtract(fixnum x, fixnum y) +{ + drepl(tag(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_multiply(bx,by))); +} + +} diff --git a/vm/math.h b/vm/math.h deleted file mode 100644 index 4a18888549..0000000000 --- a/vm/math.h +++ /dev/null @@ -1,151 +0,0 @@ -#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); diff --git a/vm/math.hpp b/vm/math.hpp new file mode 100644 index 0000000000..763ed55f9a --- /dev/null +++ b/vm/math.hpp @@ -0,0 +1,149 @@ +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(fixnum_to_bignum(x)); + else + return tag_fixnum(x); +} + +inline static cell allot_cell(cell x) +{ + if(x > (cell)FIXNUM_MAX) + return tag(cell_to_bignum(x)); + else + return tag_fixnum(x); +} + +cell unbox_array_size(void); + +inline static double untag_float(cell tagged) +{ + return untag(tagged)->n; +} + +inline static double untag_float_check(cell tagged) +{ + return untag_check(tagged)->n; +} + +inline static cell allot_float(double n) +{ + boxed_float *flo = allot(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(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); + +} diff --git a/vm/os-freebsd-x86.32.h b/vm/os-freebsd-x86.32.hpp similarity index 73% rename from vm/os-freebsd-x86.32.h rename to vm/os-freebsd-x86.32.hpp index a04755e9dd..c276ce6174 100644 --- a/vm/os-freebsd-x86.32.h +++ b/vm/os-freebsd-x86.32.hpp @@ -1,9 +1,14 @@ #include -INLINE void *ucontext_stack_pointer(void *uap) +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) + +} diff --git a/vm/os-freebsd-x86.64.h b/vm/os-freebsd-x86.64.hpp similarity index 73% rename from vm/os-freebsd-x86.64.h rename to vm/os-freebsd-x86.64.hpp index 23e1ff5733..6ee491f3ae 100644 --- a/vm/os-freebsd-x86.64.h +++ b/vm/os-freebsd-x86.64.hpp @@ -1,9 +1,14 @@ #include -INLINE void *ucontext_stack_pointer(void *uap) +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) + +} diff --git a/vm/os-freebsd.c b/vm/os-freebsd.cpp similarity index 92% rename from vm/os-freebsd.c rename to vm/os-freebsd.cpp index 1d43a13001..63313f61e0 100644 --- a/vm/os-freebsd.c +++ b/vm/os-freebsd.cpp @@ -1,4 +1,7 @@ -#include "master.h" +#include "master.hpp" + +namespace factor +{ /* From SBCL */ const char *vm_executable_path(void) @@ -32,3 +35,5 @@ const char *vm_executable_path(void) return safe_strdup(path); } + +} diff --git a/vm/os-freebsd.h b/vm/os-freebsd.hpp similarity index 76% rename from vm/os-freebsd.h rename to vm/os-freebsd.hpp index 617a6686c2..0acf537d45 100644 --- a/vm/os-freebsd.h +++ b/vm/os-freebsd.hpp @@ -1,9 +1,8 @@ #include - -extern int getosreldate(void); - #include +extern "C" int getosreldate(void); + #ifndef KERN_PROC_PATHNAME #define KERN_PROC_PATHNAME 12 #endif diff --git a/vm/os-genunix.c b/vm/os-genunix.cpp similarity index 78% rename from vm/os-genunix.c rename to vm/os-genunix.cpp index f582483ce7..731527d208 100755 --- a/vm/os-genunix.c +++ b/vm/os-genunix.cpp @@ -1,6 +1,9 @@ -#include "master.h" +#include "master.hpp" -void c_to_factor_toplevel(CELL quot) +namespace factor +{ + +void c_to_factor_toplevel(cell quot) { c_to_factor(quot); } @@ -28,8 +31,10 @@ const char *default_image_path(void) const char *iter = path; while(*iter) { len++; iter++; } - char *new_path = safe_malloc(PATH_MAX + SUFFIX_LEN + 1); + char *new_path = (char *)safe_malloc(PATH_MAX + SUFFIX_LEN + 1); memcpy(new_path,path,len + 1); memcpy(new_path + len,SUFFIX,SUFFIX_LEN + 1); return new_path; } + +} diff --git a/vm/os-genunix.h b/vm/os-genunix.hpp similarity index 62% rename from vm/os-genunix.h rename to vm/os-genunix.hpp index 7afc68998d..bc12f716cf 100644 --- a/vm/os-genunix.h +++ b/vm/os-genunix.hpp @@ -1,8 +1,13 @@ -#define DLLEXPORT +namespace factor +{ + +#define VM_C_API extern "C" #define NULL_DLL NULL -void c_to_factor_toplevel(CELL quot); +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); + +} diff --git a/vm/os-linux-arm.c b/vm/os-linux-arm.cpp similarity index 87% rename from vm/os-linux-arm.c rename to vm/os-linux-arm.cpp index 39a3da0b3f..8e131b9011 100644 --- a/vm/os-linux-arm.c +++ b/vm/os-linux-arm.cpp @@ -1,6 +1,9 @@ -#include "master.h" +#include "master.hpp" -void flush_icache(CELL start, CELL len) +namespace factor +{ + +void flush_icache(cell start, cell len) { int result; @@ -24,3 +27,5 @@ void flush_icache(CELL start, CELL len) if(result < 0) critical_error("flush_icache() failed",result); } + +} diff --git a/vm/os-linux-arm.h b/vm/os-linux-arm.hpp similarity index 68% rename from vm/os-linux-arm.h rename to vm/os-linux-arm.hpp index 6e078b014d..70c3eb3ff6 100644 --- a/vm/os-linux-arm.h +++ b/vm/os-linux-arm.hpp @@ -2,7 +2,10 @@ #include #include -INLINE void *ucontext_stack_pointer(void *uap) +namespace factor +{ + +inline static void *ucontext_stack_pointer(void *uap) { ucontext_t *ucontext = (ucontext_t *)uap; return (void *)ucontext->uc_mcontext.arm_sp; @@ -11,4 +14,6 @@ INLINE void *ucontext_stack_pointer(void *uap) #define UAP_PROGRAM_COUNTER(ucontext) \ (((ucontext_t *)(ucontext))->uc_mcontext.arm_pc) -void flush_icache(CELL start, CELL len); +void flush_icache(cell start, cell len); + +} diff --git a/vm/os-linux-ppc.h b/vm/os-linux-ppc.hpp similarity index 61% rename from vm/os-linux-ppc.h rename to vm/os-linux-ppc.hpp index eb28af53e4..c0d13e6f17 100644 --- a/vm/os-linux-ppc.h +++ b/vm/os-linux-ppc.hpp @@ -1,8 +1,11 @@ #include -#define FRAME_RETURN_ADDRESS(frame) *((XT *)(frame_successor(frame) + 1) + 1) +namespace factor +{ -INLINE void *ucontext_stack_pointer(void *uap) +#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]; @@ -10,3 +13,5 @@ INLINE void *ucontext_stack_pointer(void *uap) #define UAP_PROGRAM_COUNTER(ucontext) \ (((ucontext_t *)(ucontext))->uc_mcontext.uc_regs->gregs[PT_NIP]) + +} diff --git a/vm/os-linux-x86.32.h b/vm/os-linux-x86.32.hpp similarity index 74% rename from vm/os-linux-x86.32.h rename to vm/os-linux-x86.32.hpp index b458fcbe21..4ba7c77e4b 100644 --- a/vm/os-linux-x86.32.h +++ b/vm/os-linux-x86.32.hpp @@ -1,6 +1,9 @@ #include -INLINE void *ucontext_stack_pointer(void *uap) +namespace factor +{ + +inline static void *ucontext_stack_pointer(void *uap) { ucontext_t *ucontext = (ucontext_t *)uap; return (void *)ucontext->uc_mcontext.gregs[7]; @@ -8,3 +11,5 @@ INLINE void *ucontext_stack_pointer(void *uap) #define UAP_PROGRAM_COUNTER(ucontext) \ (((ucontext_t *)(ucontext))->uc_mcontext.gregs[14]) + +} diff --git a/vm/os-linux-x86.64.h b/vm/os-linux-x86.64.hpp similarity index 74% rename from vm/os-linux-x86.64.h rename to vm/os-linux-x86.64.hpp index 911c2f1749..477e21708c 100644 --- a/vm/os-linux-x86.64.h +++ b/vm/os-linux-x86.64.hpp @@ -1,6 +1,9 @@ #include -INLINE void *ucontext_stack_pointer(void *uap) +namespace factor +{ + +inline static void *ucontext_stack_pointer(void *uap) { ucontext_t *ucontext = (ucontext_t *)uap; return (void *)ucontext->uc_mcontext.gregs[15]; @@ -8,3 +11,5 @@ INLINE void *ucontext_stack_pointer(void *uap) #define UAP_PROGRAM_COUNTER(ucontext) \ (((ucontext_t *)(ucontext))->uc_mcontext.gregs[16]) + +} diff --git a/vm/os-linux.c b/vm/os-linux.cpp similarity index 90% rename from vm/os-linux.c rename to vm/os-linux.cpp index 91017fc3f8..ecc8973ebe 100644 --- a/vm/os-linux.c +++ b/vm/os-linux.cpp @@ -1,9 +1,12 @@ -#include "master.h" +#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); + char *path = (char *)safe_malloc(PATH_MAX + 1); int size = readlink("/proc/self/exe", path, PATH_MAX); if (size < 0) @@ -56,3 +59,5 @@ int inotify_rm_watch(int fd, u32 wd) } #endif + +} diff --git a/vm/os-linux.h b/vm/os-linux.hpp similarity index 86% rename from vm/os-linux.h rename to vm/os-linux.hpp index 8e78595687..4e2f22b95f 100644 --- a/vm/os-linux.h +++ b/vm/os-linux.hpp @@ -1,5 +1,10 @@ #include +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); + +} diff --git a/vm/os-macosx-ppc.h b/vm/os-macosx-ppc.hpp similarity index 90% rename from vm/os-macosx-ppc.h rename to vm/os-macosx-ppc.hpp index 13213acbbc..d80959eaec 100644 --- a/vm/os-macosx-ppc.h +++ b/vm/os-macosx-ppc.hpp @@ -1,3 +1,8 @@ +#include + +namespace factor +{ + /* Fault handler information. MacOSX version. Copyright (C) 1993-1999, 2002-2003 Bruno Haible Copyright (C) 2003 Paolo Bonzini @@ -8,9 +13,7 @@ Used under BSD license with permission from Paolo Bonzini and Bruno Haible, http://sourceforge.net/mailarchive/message.php?msg_name=200503102200.32002.bruno%40clisp.org Modified for Factor by Slava Pestov */ -#include - -#define FRAME_RETURN_ADDRESS(frame) *((XT *)(frame_successor(frame) + 1) + 2) +#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 @@ -33,7 +36,9 @@ Modified for Factor by Slava Pestov */ MACH_PROGRAM_COUNTER(&(((ucontext_t *)(ucontext))->uc_mcontext->ss)) #endif -INLINE CELL fix_stack_pointer(CELL sp) +inline static cell fix_stack_pointer(cell sp) { return sp; } + +} diff --git a/vm/os-macosx-x86.32.h b/vm/os-macosx-x86.32.hpp similarity index 95% rename from vm/os-macosx-x86.32.h rename to vm/os-macosx-x86.32.hpp index 7c830c775d..e6454fd039 100644 --- a/vm/os-macosx-x86.32.h +++ b/vm/os-macosx-x86.32.hpp @@ -1,3 +1,8 @@ +#include + +namespace factor +{ + /* Fault handler information. MacOSX version. Copyright (C) 1993-1999, 2002-2003 Bruno Haible Copyright (C) 2003 Paolo Bonzini @@ -8,8 +13,6 @@ Used under BSD license with permission from Paolo Bonzini and Bruno Haible, http://sourceforge.net/mailarchive/message.php?msg_name=200503102200.32002.bruno%40clisp.org Modified for Factor by Slava Pestov */ -#include - #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 @@ -31,7 +34,9 @@ Modified for Factor by Slava Pestov */ MACH_PROGRAM_COUNTER(&(((ucontext_t *)(ucontext))->uc_mcontext->ss)) #endif -INLINE CELL fix_stack_pointer(CELL sp) +inline static cell fix_stack_pointer(cell sp) { return ((sp + 4) & ~15) - 4; } + +} diff --git a/vm/os-macosx-x86.64.h b/vm/os-macosx-x86.64.hpp similarity index 95% rename from vm/os-macosx-x86.64.h rename to vm/os-macosx-x86.64.hpp index b11aa80ce8..4d8976991e 100644 --- a/vm/os-macosx-x86.64.h +++ b/vm/os-macosx-x86.64.hpp @@ -1,3 +1,8 @@ +#include + +namespace factor +{ + /* Fault handler information. MacOSX version. Copyright (C) 1993-1999, 2002-2003 Bruno Haible Copyright (C) 2003 Paolo Bonzini @@ -8,8 +13,6 @@ Used under BSD license with permission from Paolo Bonzini and Bruno Haible, http://sourceforge.net/mailarchive/message.php?msg_name=200503102200.32002.bruno%40clisp.org Modified for Factor by Slava Pestov and Daniel Ehrenberg */ -#include - #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 @@ -31,7 +34,9 @@ Modified for Factor by Slava Pestov and Daniel Ehrenberg */ MACH_PROGRAM_COUNTER(&(((ucontext_t *)(ucontext))->uc_mcontext->ss)) #endif -INLINE CELL fix_stack_pointer(CELL sp) +inline static cell fix_stack_pointer(cell sp) { return ((sp + 8) & ~15) - 8; } + +} diff --git a/vm/os-macosx.h b/vm/os-macosx.hpp similarity index 60% rename from vm/os-macosx.h rename to vm/os-macosx.hpp index 216212e973..aa166910f5 100644 --- a/vm/os-macosx.h +++ b/vm/os-macosx.hpp @@ -1,4 +1,7 @@ -#define DLLEXPORT __attribute__((visibility("default"))) +namespace factor +{ + +#define VM_C_API extern "C" __attribute__((visibility("default"))) #define FACTOR_OS_STRING "macosx" #define NULL_DLL "libfactor.dylib" @@ -8,10 +11,12 @@ 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) +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); + +} diff --git a/vm/os-macosx.m b/vm/os-macosx.mm similarity index 90% rename from vm/os-macosx.m rename to vm/os-macosx.mm index 9b0366ff75..792ba0d541 100644 --- a/vm/os-macosx.m +++ b/vm/os-macosx.mm @@ -1,8 +1,11 @@ #import -#include "master.h" +#include "master.hpp" -void c_to_factor_toplevel(CELL quot) +namespace factor +{ + +void c_to_factor_toplevel(cell quot) { for(;;) { @@ -10,9 +13,9 @@ NS_DURING c_to_factor(quot); NS_VOIDRETURN; NS_HANDLER - dpush(allot_alien(F,(CELL)localException)); + dpush(allot_alien(F,(cell)localException)); quot = userenv[COCOA_EXCEPTION_ENV]; - if(type_of(quot) != QUOTATION_TYPE) + if(!tagged(quot).type_p(QUOTATION_TYPE)) { /* No Cocoa exception handler was registered, so extra/cocoa/ is not loaded. So we pass the exception @@ -80,3 +83,5 @@ Protocol *objc_getProtocol(char *name) else return nil; } + +} diff --git a/vm/os-netbsd-x86.32.h b/vm/os-netbsd-x86.32.hpp similarity index 81% rename from vm/os-netbsd-x86.32.h rename to vm/os-netbsd-x86.32.hpp index ca4a9f88f5..ebba4f356d 100644 --- a/vm/os-netbsd-x86.32.h +++ b/vm/os-netbsd-x86.32.hpp @@ -1,3 +1,8 @@ #include +namespace factor +{ + #define ucontext_stack_pointer(uap) ((void *)_UC_MACHINE_SP((ucontext_t *)uap)) + +} diff --git a/vm/os-netbsd-x86.64.h b/vm/os-netbsd-x86.64.hpp similarity index 84% rename from vm/os-netbsd-x86.64.h rename to vm/os-netbsd-x86.64.hpp index 587dc85ec7..1a062cc6ef 100644 --- a/vm/os-netbsd-x86.64.h +++ b/vm/os-netbsd-x86.64.hpp @@ -1,4 +1,9 @@ #include +namespace factor +{ + #define ucontext_stack_pointer(uap) \ ((void *)(((ucontext_t *)(uap))->uc_mcontext.__gregs[_REG_URSP])) + +} diff --git a/vm/os-netbsd.c b/vm/os-netbsd.cpp similarity index 54% rename from vm/os-netbsd.c rename to vm/os-netbsd.cpp index c33b4ad69c..7a3cb30652 100755 --- a/vm/os-netbsd.c +++ b/vm/os-netbsd.cpp @@ -1,11 +1,16 @@ -#include "master.h" +#include "master.hpp" -extern int main(); +namespace factor +{ + +extern "C" int main(); const char *vm_executable_path(void) { static Dl_info info = {0}; if (!info.dli_fname) - dladdr(main, &info); + dladdr((void *)main, &info); return info.dli_fname; } + +} diff --git a/vm/os-netbsd.h b/vm/os-netbsd.hpp similarity index 86% rename from vm/os-netbsd.h rename to vm/os-netbsd.hpp index 6486acda4a..635361e3e4 100644 --- a/vm/os-netbsd.h +++ b/vm/os-netbsd.hpp @@ -1,5 +1,10 @@ #include +namespace factor +{ + #define UAP_PROGRAM_COUNTER(uap) _UC_MACHINE_PC((ucontext_t *)uap) #define DIRECTORY_P(file) ((file)->d_type == DT_DIR) + +} diff --git a/vm/os-openbsd-x86.32.h b/vm/os-openbsd-x86.32.hpp similarity index 75% rename from vm/os-openbsd-x86.32.h rename to vm/os-openbsd-x86.32.hpp index 0617e62c0d..6065d96a5f 100644 --- a/vm/os-openbsd-x86.32.h +++ b/vm/os-openbsd-x86.32.hpp @@ -1,6 +1,9 @@ #include -INLINE void *openbsd_stack_pointer(void *uap) +namespace factor +{ + +inline static void *openbsd_stack_pointer(void *uap) { struct sigcontext *sc = (struct sigcontext*) uap; return (void *)sc->sc_esp; @@ -8,3 +11,5 @@ INLINE void *openbsd_stack_pointer(void *uap) #define ucontext_stack_pointer openbsd_stack_pointer #define UAP_PROGRAM_COUNTER(uap) (((struct sigcontext*)(uap))->sc_eip) + +} diff --git a/vm/os-openbsd-x86.64.h b/vm/os-openbsd-x86.64.hpp similarity index 75% rename from vm/os-openbsd-x86.64.h rename to vm/os-openbsd-x86.64.hpp index 3386e80a4b..7338b04e6f 100644 --- a/vm/os-openbsd-x86.64.h +++ b/vm/os-openbsd-x86.64.hpp @@ -1,6 +1,9 @@ #include -INLINE void *openbsd_stack_pointer(void *uap) +namespace factor +{ + +inline static void *openbsd_stack_pointer(void *uap) { struct sigcontext *sc = (struct sigcontext*) uap; return (void *)sc->sc_rsp; @@ -8,3 +11,5 @@ INLINE void *openbsd_stack_pointer(void *uap) #define ucontext_stack_pointer openbsd_stack_pointer #define UAP_PROGRAM_COUNTER(uap) (((struct sigcontext*)(uap))->sc_rip) + +} diff --git a/vm/os-openbsd.c b/vm/os-openbsd.cpp similarity index 55% rename from vm/os-openbsd.c rename to vm/os-openbsd.cpp index b9238b7877..fc8aac8cf7 100644 --- a/vm/os-openbsd.c +++ b/vm/os-openbsd.cpp @@ -1,6 +1,11 @@ -#include "master.h" +#include "master.hpp" + +namespace factor +{ const char *vm_executable_path(void) { return NULL; } + +} diff --git a/vm/os-solaris-x86.32.h b/vm/os-solaris-x86.32.hpp similarity index 74% rename from vm/os-solaris-x86.32.h rename to vm/os-solaris-x86.32.hpp index 1f4ec74e17..b89b8d541b 100644 --- a/vm/os-solaris-x86.32.h +++ b/vm/os-solaris-x86.32.hpp @@ -1,6 +1,9 @@ #include -INLINE void *ucontext_stack_pointer(void *uap) +namespace factor +{ + +inline static void *ucontext_stack_pointer(void *uap) { ucontext_t *ucontext = (ucontext_t *)uap; return (void *)ucontext->uc_mcontext.gregs[ESP]; @@ -8,3 +11,5 @@ INLINE void *ucontext_stack_pointer(void *uap) #define UAP_PROGRAM_COUNTER(ucontext) \ (((ucontext_t *)(ucontext))->uc_mcontext.gregs[EIP]) + +} diff --git a/vm/os-solaris-x86.64.h b/vm/os-solaris-x86.64.hpp similarity index 74% rename from vm/os-solaris-x86.64.h rename to vm/os-solaris-x86.64.hpp index 54d1866d50..0d3a74e11d 100644 --- a/vm/os-solaris-x86.64.h +++ b/vm/os-solaris-x86.64.hpp @@ -1,6 +1,9 @@ #include -INLINE void *ucontext_stack_pointer(void *uap) +namespace factor +{ + +inline static void *ucontext_stack_pointer(void *uap) { ucontext_t *ucontext = (ucontext_t *)uap; return (void *)ucontext->uc_mcontext.gregs[RSP]; @@ -8,3 +11,5 @@ INLINE void *ucontext_stack_pointer(void *uap) #define UAP_PROGRAM_COUNTER(ucontext) \ (((ucontext_t *)(ucontext))->uc_mcontext.gregs[RIP]) + +} diff --git a/vm/os-solaris.c b/vm/os-solaris.cpp similarity index 55% rename from vm/os-solaris.c rename to vm/os-solaris.cpp index b9238b7877..fc8aac8cf7 100644 --- a/vm/os-solaris.c +++ b/vm/os-solaris.cpp @@ -1,6 +1,11 @@ -#include "master.h" +#include "master.hpp" + +namespace factor +{ const char *vm_executable_path(void) { return NULL; } + +} diff --git a/vm/os-unix.c b/vm/os-unix.cpp similarity index 79% rename from vm/os-unix.c rename to vm/os-unix.cpp index 97c29d8c6e..c0a268018e 100755 --- a/vm/os-unix.c +++ b/vm/os-unix.cpp @@ -1,4 +1,7 @@ -#include "master.h" +#include "master.hpp" + +namespace factor +{ void start_thread(void *(*start_routine)(void *)) { @@ -23,7 +26,7 @@ s64 current_micros(void) return (s64)t.tv_sec * 1000000 + t.tv_usec; } -void sleep_micros(CELL usec) +void sleep_micros(cell usec) { usleep(usec); } @@ -34,38 +37,36 @@ void init_ffi(void) null_dll = dlopen(NULL_DLL,RTLD_LAZY); } -void ffi_dlopen(F_DLL *dll) +void ffi_dlopen(dll *dll) { dll->dll = dlopen(alien_offset(dll->path), RTLD_LAZY); } -void *ffi_dlsym(F_DLL *dll, F_SYMBOL *symbol) +void *ffi_dlsym(dll *dll, symbol_char *symbol) { void *handle = (dll == NULL ? null_dll : dll->dll); return dlsym(handle,symbol); } -void ffi_dlclose(F_DLL *dll) +void ffi_dlclose(dll *dll) { if(dlclose(dll->dll)) - { - general_error(ERROR_FFI,tag_object( - from_char_string(dlerror())),F,NULL); - } + general_error(ERROR_FFI,F,F,NULL); dll->dll = NULL; } -void primitive_existsp(void) +PRIMITIVE(existsp) { struct stat sb; - box_boolean(stat(unbox_char_string(),&sb) >= 0); + char *path = (char *)(untag_check(dpop()) + 1); + box_boolean(stat(path,&sb) >= 0); } -F_SEGMENT *alloc_segment(CELL size) +segment *alloc_segment(cell size) { int pagesize = getpagesize(); - char *array = mmap(NULL,pagesize + size + pagesize, + char *array = (char *)mmap(NULL,pagesize + size + pagesize, PROT_READ | PROT_WRITE | PROT_EXEC, MAP_ANON | MAP_PRIVATE,-1,0); @@ -73,21 +74,21 @@ F_SEGMENT *alloc_segment(CELL size) out_of_memory(); if(mprotect(array,pagesize,PROT_NONE) == -1) - fatal_error("Cannot protect low guard page",(CELL)array); + 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); + fatal_error("Cannot protect high guard page",(cell)array); - F_SEGMENT *retval = safe_malloc(sizeof(F_SEGMENT)); + segment *retval = (segment *)safe_malloc(sizeof(segment)); - retval->start = (CELL)(array + pagesize); + retval->start = (cell)(array + pagesize); retval->size = size; retval->end = retval->start + size; return retval; } -void dealloc_segment(F_SEGMENT *block) +void dealloc_segment(segment *block) { int pagesize = getpagesize(); @@ -100,7 +101,7 @@ void dealloc_segment(F_SEGMENT *block) free(block); } -INLINE F_STACK_FRAME *uap_stack_pointer(void *uap) +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 @@ -108,9 +109,9 @@ INLINE F_STACK_FRAME *uap_stack_pointer(void *uap) 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); + stack_frame *ptr = (stack_frame *)ucontext_stack_pointer(uap); if(!ptr) - critical_error("Invalid uap",(CELL)uap); + critical_error("Invalid uap",(cell)uap); return ptr; } else @@ -119,16 +120,16 @@ INLINE F_STACK_FRAME *uap_stack_pointer(void *uap) void memory_signal_handler(int signal, siginfo_t *siginfo, void *uap) { - signal_fault_addr = (CELL)siginfo->si_addr; + signal_fault_addr = (cell)siginfo->si_addr; signal_callstack_top = uap_stack_pointer(uap); - UAP_PROGRAM_COUNTER(uap) = (CELL)memory_signal_handler_impl; + UAP_PROGRAM_COUNTER(uap) = (cell)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; + UAP_PROGRAM_COUNTER(uap) = (cell)misc_signal_handler_impl; } static void sigaction_safe(int signum, const struct sigaction *act, struct sigaction *oldact) @@ -182,14 +183,16 @@ 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; +extern "C" { + int stdin_read; + int stdin_write; -__attribute__((visibility("default"))) int control_read; -__attribute__((visibility("default"))) int control_write; + int control_read; + int control_write; -__attribute__((visibility("default"))) int size_read; -__attribute__((visibility("default"))) int size_write; + int size_read; + int size_write; +} void safe_close(int fd) { @@ -197,7 +200,7 @@ void safe_close(int fd) fatal_error("error closing fd",errno); } -bool check_write(int fd, void *data, size_t size) +bool check_write(int fd, void *data, ssize_t size) { if(write(fd,data,size) == size) return true; @@ -210,13 +213,13 @@ bool check_write(int fd, void *data, size_t size) } } -void safe_write(int fd, void *data, size_t size) +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, size_t size) +bool safe_read(int fd, void *data, ssize_t size) { ssize_t bytes = read(fd,data,size); if(bytes < 0) @@ -301,7 +304,7 @@ void open_console(void) start_thread(stdin_loop); } -DLLEXPORT void wait_for_stdin(void) +VM_C_API void wait_for_stdin(void) { if(write(control_write,"X",1) != 1) { @@ -311,3 +314,5 @@ DLLEXPORT void wait_for_stdin(void) fatal_error("Error writing control fd",errno); } } + +} diff --git a/vm/os-unix.h b/vm/os-unix.hpp similarity index 62% rename from vm/os-unix.h rename to vm/os-unix.hpp index 35abfee41c..24e8016db4 100755 --- a/vm/os-unix.h +++ b/vm/os-unix.hpp @@ -8,13 +8,11 @@ #include #include -typedef char F_CHAR; -typedef char F_SYMBOL; +namespace factor +{ -#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 +typedef char vm_char; +typedef char symbol_char; #define STRING_LITERAL(string) string @@ -26,13 +24,13 @@ typedef char F_SYMBOL; #define FSEEK fseeko #define FIXNUM_FORMAT "%ld" -#define CELL_FORMAT "%lu" -#define CELL_HEX_FORMAT "%lx" +#define cell_FORMAT "%lu" +#define cell_HEX_FORMAT "%lx" #ifdef FACTOR_64 - #define CELL_HEX_PAD_FORMAT "%016lx" + #define cell_HEX_PAD_FORMAT "%016lx" #else - #define CELL_HEX_PAD_FORMAT "%08lx" + #define cell_HEX_PAD_FORMAT "%08lx" #endif #define FIXNUM_FORMAT "%ld" @@ -45,15 +43,17 @@ typedef char F_SYMBOL; 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 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 sleep_micros(cell usec); void open_console(void); + +} diff --git a/vm/os-windows-ce.c b/vm/os-windows-ce.cpp similarity index 79% rename from vm/os-windows-ce.c rename to vm/os-windows-ce.cpp index 621198ff7d..71c72e55f8 100755 --- a/vm/os-windows-ce.c +++ b/vm/os-windows-ce.cpp @@ -1,4 +1,7 @@ -#include "master.h" +#include "master.hpp" + +namespace factor +{ s64 current_micros(void) { @@ -16,7 +19,7 @@ char *strerror(int err) return "strerror() is not defined on WinCE. Use native I/O."; } -void flush_icache(CELL start, CELL end) +void flush_icache(cell start, cell end) { FlushInstructionCache(GetCurrentProcess(), 0, 0); } @@ -27,14 +30,16 @@ char *getenv(char *name) return 0; /* unreachable */ } -void primitive_os_envs(void) +PRIMITIVE(os_envs) { not_implemented_error(); } -void c_to_factor_toplevel(CELL quot) +void c_to_factor_toplevel(cell quot) { c_to_factor(quot); } void open_console(void) { } + +} diff --git a/vm/os-windows-ce.h b/vm/os-windows-ce.hpp similarity index 65% rename from vm/os-windows-ce.h rename to vm/os-windows-ce.hpp index a2be5fe475..49450f91c7 100755 --- a/vm/os-windows-ce.h +++ b/vm/os-windows-ce.hpp @@ -5,10 +5,10 @@ #include #include -typedef wchar_t F_SYMBOL; +namespace factor +{ -#define unbox_symbol_string unbox_u16_string -#define from_symbol_string from_u16_string +typedef wchar_t symbol_char; #define FACTOR_OS_STRING "wince" #define FACTOR_DLL L"factor-ce.dll" @@ -16,12 +16,14 @@ typedef wchar_t F_SYMBOL; int errno; char *strerror(int err); -void flush_icache(CELL start, CELL end); +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 c_to_factor_toplevel(cell quot); void open_console(void); + +} diff --git a/vm/os-windows-nt.32.h b/vm/os-windows-nt.32.hpp similarity index 58% rename from vm/os-windows-nt.32.h rename to vm/os-windows-nt.32.hpp index 9b10671ba0..ed67e28b8b 100644 --- a/vm/os-windows-nt.32.h +++ b/vm/os-windows-nt.32.hpp @@ -1,2 +1,7 @@ +namespace factor +{ + #define ESP Esp #define EIP Eip + +} diff --git a/vm/os-windows-nt.64.h b/vm/os-windows-nt.64.hpp similarity index 58% rename from vm/os-windows-nt.64.h rename to vm/os-windows-nt.64.hpp index 1f61c2335f..30ce150754 100644 --- a/vm/os-windows-nt.64.h +++ b/vm/os-windows-nt.64.hpp @@ -1,2 +1,7 @@ +namespace factor +{ + #define ESP Rsp #define EIP Rip + +} diff --git a/vm/os-windows-nt.c b/vm/os-windows-nt.cpp similarity index 88% rename from vm/os-windows-nt.c rename to vm/os-windows-nt.cpp index 501463378a..0a63dce513 100755 --- a/vm/os-windows-nt.c +++ b/vm/os-windows-nt.cpp @@ -1,4 +1,7 @@ -#include "master.h" +#include "master.hpp" + +namespace factor +{ s64 current_micros(void) { @@ -21,7 +24,7 @@ long exception_handler(PEXCEPTION_POINTERS pe) if(e->ExceptionCode == EXCEPTION_ACCESS_VIOLATION) { signal_fault_addr = e->ExceptionInformation[1]; - c->EIP = (CELL)memory_signal_handler_impl; + 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 @@ -32,13 +35,13 @@ long exception_handler(PEXCEPTION_POINTERS pe) else if(e->ExceptionCode != 0x40010006) { signal_number = e->ExceptionCode; - c->EIP = (CELL)misc_signal_handler_impl; + c->EIP = (cell)misc_signal_handler_impl; } return EXCEPTION_CONTINUE_EXECUTION; } -void c_to_factor_toplevel(CELL quot) +void c_to_factor_toplevel(cell quot) { if(!AddVectoredExceptionHandler(0, (void*)exception_handler)) fatal_error("AddVectoredExceptionHandler failed", 0); @@ -49,3 +52,5 @@ void c_to_factor_toplevel(CELL quot) void open_console(void) { } + +} diff --git a/vm/os-windows-nt.h b/vm/os-windows-nt.hpp similarity index 68% rename from vm/os-windows-nt.h rename to vm/os-windows-nt.hpp index 4e047b497c..107e42ea2e 100755 --- a/vm/os-windows-nt.h +++ b/vm/os-windows-nt.hpp @@ -5,17 +5,20 @@ #define UNICODE #endif +#include #include -typedef char F_SYMBOL; +namespace factor +{ -#define unbox_symbol_string unbox_char_string -#define from_symbol_string from_char_string +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); +void c_to_factor_toplevel(cell quot); long exception_handler(PEXCEPTION_POINTERS pe); void open_console(void); + +} diff --git a/vm/os-windows.c b/vm/os-windows.cpp similarity index 73% rename from vm/os-windows.c rename to vm/os-windows.cpp index c917cd804d..796a1c7184 100755 --- a/vm/os-windows.c +++ b/vm/os-windows.cpp @@ -1,4 +1,7 @@ -#include "master.h" +#include "master.hpp" + +namespace factor +{ HMODULE hFactorDll; @@ -9,23 +12,23 @@ void init_ffi(void) fatal_error("GetModuleHandle(\"" FACTOR_DLL_NAME "\") failed", 0); } -void ffi_dlopen(F_DLL *dll) +void ffi_dlopen(dll *dll) { dll->dll = LoadLibraryEx(alien_offset(dll->path), NULL, 0); } -void *ffi_dlsym(F_DLL *dll, F_SYMBOL *symbol) +void *ffi_dlsym(dll *dll, symbol_char *symbol) { return GetProcAddress(dll ? (HMODULE)dll->dll : hFactorDll, symbol); } -void ffi_dlclose(F_DLL *dll) +void ffi_dlclose(dll *dll) { FreeLibrary((HMODULE)dll->dll); dll->dll = NULL; } -bool windows_stat(F_CHAR *path) +bool windows_stat(vm_char *path) { BY_HANDLE_FILE_INFORMATION bhfi; HANDLE h = CreateFileW(path, @@ -53,18 +56,18 @@ bool windows_stat(F_CHAR *path) return ret; } -void windows_image_path(F_CHAR *full_path, F_CHAR *temp_path, unsigned int length) +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 F_CHAR *default_image_path(void) +const vm_char *default_image_path(void) { - F_CHAR full_path[MAX_UNICODE_PATH]; - F_CHAR *ptr; - F_CHAR temp_path[MAX_UNICODE_PATH]; + 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); @@ -79,23 +82,22 @@ const F_CHAR *default_image_path(void) } /* You must free() this yourself. */ -const F_CHAR *vm_executable_path(void) +const vm_char *vm_executable_path(void) { - F_CHAR full_path[MAX_UNICODE_PATH]; + 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); } -void primitive_existsp(void) +PRIMITIVE(existsp) { - - F_CHAR *path = unbox_u16_string(); + vm_char *path = (vm_char *)(untag_check(dpop()) + 1); box_boolean(windows_stat(path)); } -F_SEGMENT *alloc_segment(CELL size) +segment *alloc_segment(cell size) { char *mem; DWORD ignore; @@ -105,22 +107,22 @@ F_SEGMENT *alloc_segment(CELL size) out_of_memory(); if (!VirtualProtect(mem, getpagesize(), PAGE_NOACCESS, &ignore)) - fatal_error("Cannot allocate low guard page", (CELL)mem); + 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); + fatal_error("Cannot allocate high guard page", (cell)mem); - F_SEGMENT *block = safe_malloc(sizeof(F_SEGMENT)); + segment *block = safe_malloc(sizeof(segment)); - block->start = (CELL)mem + getpagesize(); + block->start = (cell)mem + getpagesize(); block->size = size; block->end = block->start + size; return block; } -void dealloc_segment(F_SEGMENT *block) +void dealloc_segment(segment *block) { SYSTEM_INFO si; GetSystemInfo(&si); @@ -145,3 +147,5 @@ void sleep_micros(u64 usec) { Sleep((DWORD)(usec / 1000)); } + +} diff --git a/vm/os-windows.h b/vm/os-windows.hpp similarity index 53% rename from vm/os-windows.h rename to vm/os-windows.hpp index 95d41ca9a2..2926ea50a8 100755 --- a/vm/os-windows.h +++ b/vm/os-windows.hpp @@ -5,16 +5,15 @@ #include #endif -typedef wchar_t F_CHAR; +namespace factor +{ -#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) +typedef wchar_t vm_char; #define STRING_LITERAL(string) L##string #define MAX_UNICODE_PATH 32768 -#define DLLEXPORT __declspec(dllexport) +#define VM_C_API extern "C" __declspec(dllexport) #define SSCANF swscanf #define STRCMP wcscmp #define STRNCMP wcsncmp @@ -23,14 +22,14 @@ typedef wchar_t F_CHAR; #define FSEEK fseek #ifdef WIN64 - #define CELL_FORMAT "%Iu" - #define CELL_HEX_FORMAT "%Ix" - #define CELL_HEX_PAD_FORMAT "%016Ix" + #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 cell_FORMAT "%lu" + #define cell_HEX_FORMAT "%lx" + #define cell_HEX_PAD_FORMAT "%08lx" #define FIXNUM_FORMAT "%ld" #endif @@ -43,17 +42,18 @@ typedef wchar_t F_CHAR; #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 ffi_dlopen(dll *dll); +void *ffi_dlsym(dll *dll, symbol_char *symbol); +void ffi_dlclose(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); +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); +} diff --git a/vm/platform.h b/vm/platform.hpp similarity index 63% rename from vm/platform.h rename to vm/platform.hpp index 70804542b4..7b4356af56 100644 --- a/vm/platform.h +++ b/vm/platform.hpp @@ -12,44 +12,44 @@ #if defined(WINDOWS) #if defined(WINCE) - #include "os-windows-ce.h" + #include "os-windows-ce.hpp" #else - #include "os-windows-nt.h" + #include "os-windows-nt.hpp" #endif - #include "os-windows.h" + #include "os-windows.hpp" #if defined(FACTOR_AMD64) - #include "os-windows-nt.64.h" + #include "os-windows-nt.64.hpp" #elif defined(FACTOR_X86) - #include "os-windows-nt.32.h" + #include "os-windows-nt.32.hpp" #endif #else - #include "os-unix.h" + #include "os-unix.hpp" #ifdef __APPLE__ - #include "os-macosx.h" - #include "mach_signal.h" + #include "os-macosx.hpp" + #include "mach_signal.hpp" #ifdef FACTOR_X86 - #include "os-macosx-x86.32.h" + #include "os-macosx-x86.32.hpp" #elif defined(FACTOR_PPC) - #include "os-macosx-ppc.h" + #include "os-macosx-ppc.hpp" #elif defined(FACTOR_AMD64) - #include "os-macosx-x86.64.h" + #include "os-macosx-x86.64.hpp" #else #error "Unsupported Mac OS X flavor" #endif #else - #include "os-genunix.h" + #include "os-genunix.hpp" #ifdef __FreeBSD__ #define FACTOR_OS_STRING "freebsd" - #include "os-freebsd.h" + #include "os-freebsd.hpp" #if defined(FACTOR_X86) - #include "os-freebsd-x86.32.h" + #include "os-freebsd-x86.32.hpp" #elif defined(FACTOR_AMD64) - #include "os-freebsd-x86.64.h" + #include "os-freebsd-x86.64.hpp" #else #error "Unsupported FreeBSD flavor" #endif @@ -57,9 +57,9 @@ #define FACTOR_OS_STRING "openbsd" #if defined(FACTOR_X86) - #include "os-openbsd-x86.32.h" + #include "os-openbsd-x86.32.hpp" #elif defined(FACTOR_AMD64) - #include "os-openbsd-x86.64.h" + #include "os-openbsd-x86.64.hpp" #else #error "Unsupported OpenBSD flavor" #endif @@ -67,26 +67,26 @@ #define FACTOR_OS_STRING "netbsd" #if defined(FACTOR_X86) - #include "os-netbsd-x86.32.h" + #include "os-netbsd-x86.32.hpp" #elif defined(FACTOR_AMD64) - #include "os-netbsd-x86.64.h" + #include "os-netbsd-x86.64.hpp" #else #error "Unsupported NetBSD flavor" #endif - #include "os-netbsd.h" + #include "os-netbsd.hpp" #elif defined(linux) #define FACTOR_OS_STRING "linux" - #include "os-linux.h" + #include "os-linux.hpp" #if defined(FACTOR_X86) - #include "os-linux-x86.32.h" + #include "os-linux-x86.32.hpp" #elif defined(FACTOR_PPC) - #include "os-linux-ppc.h" + #include "os-linux-ppc.hpp" #elif defined(FACTOR_ARM) - #include "os-linux-arm.h" + #include "os-linux-arm.hpp" #elif defined(FACTOR_AMD64) - #include "os-linux-x86.64.h" + #include "os-linux-x86.64.hpp" #else #error "Unsupported Linux flavor" #endif @@ -94,9 +94,9 @@ #define FACTOR_OS_STRING "solaris" #if defined(FACTOR_X86) - #include "os-solaris-x86.32.h" + #include "os-solaris-x86.32.hpp" #elif defined(FACTOR_AMD64) - #include "os-solaris-x86.64.h" + #include "os-solaris-x86.64.hpp" #else #error "Unsupported Solaris flavor" #endif @@ -108,15 +108,15 @@ #endif #if defined(FACTOR_X86) - #include "cpu-x86.32.h" - #include "cpu-x86.h" + #include "cpu-x86.32.hpp" + #include "cpu-x86.hpp" #elif defined(FACTOR_AMD64) - #include "cpu-x86.64.h" - #include "cpu-x86.h" + #include "cpu-x86.64.hpp" + #include "cpu-x86.hpp" #elif defined(FACTOR_PPC) - #include "cpu-ppc.h" + #include "cpu-ppc.hpp" #elif defined(FACTOR_ARM) - #include "cpu-arm.h" + #include "cpu-arm.hpp" #else #error "Unsupported CPU" #endif diff --git a/vm/primitives.c b/vm/primitives.c deleted file mode 100755 index cb5161693a..0000000000 --- a/vm/primitives.c +++ /dev/null @@ -1,154 +0,0 @@ -#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, -}; diff --git a/vm/primitives.cpp b/vm/primitives.cpp new file mode 100755 index 0000000000..0c9fc32dff --- /dev/null +++ b/vm/primitives.cpp @@ -0,0 +1,159 @@ +#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, +}; + +} diff --git a/vm/primitives.h b/vm/primitives.h deleted file mode 100644 index 30e0a4af96..0000000000 --- a/vm/primitives.h +++ /dev/null @@ -1 +0,0 @@ -extern void *primitives[]; diff --git a/vm/primitives.hpp b/vm/primitives.hpp new file mode 100644 index 0000000000..f53fcff17f --- /dev/null +++ b/vm/primitives.hpp @@ -0,0 +1,8 @@ +namespace factor +{ + +extern void *primitives[]; + +#define PRIMITIVE(name) extern "C" void primitive_##name() + +} diff --git a/vm/profiler.c b/vm/profiler.c deleted file mode 100755 index 5578854d6d..0000000000 --- a/vm/profiler.c +++ /dev/null @@ -1,51 +0,0 @@ -#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())); -} diff --git a/vm/profiler.cpp b/vm/profiler.cpp new file mode 100755 index 0000000000..9651e4a27e --- /dev/null +++ b/vm/profiler.cpp @@ -0,0 +1,57 @@ +#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_); + + 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 words(find_all_words()); + + cell i; + cell length = array_capacity(words.untagged()); + for(i = 0; i < length; i++) + { + tagged 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())); +} + +} diff --git a/vm/profiler.h b/vm/profiler.h deleted file mode 100755 index 40daab429c..0000000000 --- a/vm/profiler.h +++ /dev/null @@ -1,3 +0,0 @@ -bool profiling_p; -F_CODE_BLOCK *compile_profiling_stub(CELL word); -void primitive_profiling(void); diff --git a/vm/profiler.hpp b/vm/profiler.hpp new file mode 100755 index 0000000000..00f3e8067b --- /dev/null +++ b/vm/profiler.hpp @@ -0,0 +1,9 @@ +namespace factor +{ + +extern bool profiling_p; +void init_profiler(void); +code_block *compile_profiling_stub(cell word); +PRIMITIVE(profiling); + +} diff --git a/vm/quotations.c b/vm/quotations.c deleted file mode 100755 index 29ab8537d1..0000000000 --- a/vm/quotations.c +++ /dev/null @@ -1,374 +0,0 @@ -#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); -} diff --git a/vm/quotations.cpp b/vm/quotations.cpp new file mode 100755 index 0000000000..c87cf8dc82 --- /dev/null +++ b/vm/quotations.cpp @@ -0,0 +1,341 @@ +#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(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(array_nth(elements.untagged(),i)).type_p(QUOTATION_TYPE) + && tagged(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(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(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(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(array_nth(elements.untagged(),i)).type_p(ARRAY_TYPE) + && tagged(array_nth(elements.untagged(),i + 1)).type_p(FIXNUM_TYPE) + && tagged(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(obj).type()) + { + case WORD_TYPE: + if(untag(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 obj(array_nth(elements.untagged(),i)); + + switch(obj.type()) + { + case WORD_TYPE: + /* Intrinsics */ + if(obj.as()->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()->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 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(sizeof(quotation)); + quot->array = dpeek(); + quot->xt = (void *)lazy_jit_compile; + quot->compiledp = F; + quot->cached_effect = F; + quot->cache_counter = F; + drepl(tag(quot)); +} + +PRIMITIVE(quotation_xt) +{ + quotation *quot = untag_check(dpeek()); + drepl(allot_cell((cell)quot->xt)); +} + +void compile_all_words(void) +{ + gc_root words(find_all_words()); + + cell i; + cell length = array_capacity(words.untagged()); + for(i = 0; i < length; i++) + { + gc_root 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 quot(quot_); + gc_root 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 quot(quot_); + stack_chain->callstack_top = stack; + jit_compile(quot.value(),true); + return quot.value(); +} + +} diff --git a/vm/quotations.h b/vm/quotations.h deleted file mode 100755 index 6509dfe5ed..0000000000 --- a/vm/quotations.h +++ /dev/null @@ -1,15 +0,0 @@ -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); diff --git a/vm/quotations.hpp b/vm/quotations.hpp new file mode 100755 index 0000000000..a4545f3956 --- /dev/null +++ b/vm/quotations.hpp @@ -0,0 +1,38 @@ +namespace factor +{ + +struct quotation_jit : public jit { + gc_root elements; + bool compiling, relocate; + + quotation_jit(cell quot, bool compiling_, bool relocate_) + : jit(QUOTATION_TYPE,quot), + elements(owner.as().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); + +} diff --git a/vm/run.c b/vm/run.c deleted file mode 100755 index f5e45c2d5a..0000000000 --- a/vm/run.c +++ /dev/null @@ -1,248 +0,0 @@ -#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())); -} diff --git a/vm/run.cpp b/vm/run.cpp new file mode 100755 index 0000000000..c6a4bad695 --- /dev/null +++ b/vm/run.cpp @@ -0,0 +1,76 @@ +#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(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 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())); +} + +} diff --git a/vm/run.h b/vm/run.h deleted file mode 100755 index b31fc3a2e1..0000000000 --- a/vm/run.h +++ /dev/null @@ -1,277 +0,0 @@ -#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; diff --git a/vm/run.hpp b/vm/run.hpp new file mode 100755 index 0000000000..2204585fe5 --- /dev/null +++ b/vm/run.hpp @@ -0,0 +1,111 @@ +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]; diff --git a/vm/segments.hpp b/vm/segments.hpp new file mode 100644 index 0000000000..a715b4dabc --- /dev/null +++ b/vm/segments.hpp @@ -0,0 +1,10 @@ +namespace factor +{ + +struct segment { + cell start; + cell size; + cell end; +}; + +} diff --git a/vm/stacks.hpp b/vm/stacks.hpp new file mode 100644 index 0000000000..4af31e17d9 --- /dev/null +++ b/vm/stacks.hpp @@ -0,0 +1,19 @@ +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); \ + } + +} diff --git a/vm/strings.c b/vm/strings.c deleted file mode 100644 index f08a2e8866..0000000000 --- a/vm/strings.c +++ /dev/null @@ -1,294 +0,0 @@ -#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); -} diff --git a/vm/strings.cpp b/vm/strings.cpp new file mode 100644 index 0000000000..c00c17bc45 --- /dev/null +++ b/vm/strings.cpp @@ -0,0 +1,186 @@ +#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(str->aux); + cell hi_bits = aux->data()[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 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(untag_fixnum(str->length) * sizeof(u16)); + + write_barrier(str.untagged()); + str->aux = tag(aux); + } + else + aux = untag(str->aux); + + aux->data()[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_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 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 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(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 str(str_); + + if(reallot_string_in_place_p(str.untagged(),capacity)) + { + str->length = tag_fixnum(capacity); + + if(str->aux != F) + { + byte_array *aux = untag(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 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(new_aux); + + byte_array *aux = untag(str->aux); + memcpy(new_aux->data(),aux->data(),to_copy * sizeof(u16)); + } + + fill_string(new_str.untagged(),to_copy,capacity,'\0'); + return new_str.untagged(); + } +} + +PRIMITIVE(resize_string) +{ + string* str = untag_check(dpop()); + cell capacity = unbox_array_size(); + dpush(tag(reallot_string(str,capacity))); +} + +PRIMITIVE(string_nth) +{ + string *str = untag(dpop()); + cell index = untag_fixnum(dpop()); + dpush(tag_fixnum(string_nth(str,index))); +} + +PRIMITIVE(set_string_nth_fast) +{ + string *str = untag(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(dpop()); + cell index = untag_fixnum(dpop()); + cell value = untag_fixnum(dpop()); + set_string_nth_slow(str,index,value); +} + +} diff --git a/vm/strings.h b/vm/strings.h deleted file mode 100644 index d16a85ebea..0000000000 --- a/vm/strings.h +++ /dev/null @@ -1,50 +0,0 @@ -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); diff --git a/vm/strings.hpp b/vm/strings.hpp new file mode 100644 index 0000000000..9a082b0b83 --- /dev/null +++ b/vm/strings.hpp @@ -0,0 +1,28 @@ +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); + +} diff --git a/vm/tagged.hpp b/vm/tagged.hpp new file mode 100644 index 0000000000..ea1942e10c --- /dev/null +++ b/vm/tagged.hpp @@ -0,0 +1,72 @@ +namespace factor +{ + +template 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 +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& operator=(const T *x) { value_ = tag(x); return *this; } + const tagged& operator=(const cell &x) { value_ = x; return *this; } + + bool operator==(const tagged &x) { return value_ == x.value_; } + bool operator!=(const tagged &x) { return value_ != x.value_; } + + template tagged as() { return tagged(value_); } +}; + +template T *untag_check(cell value) +{ + return tagged(value).untag_check(); +} + +template T *untag(cell value) +{ + return tagged(value).untagged(); +} + +} diff --git a/vm/tuples.c b/vm/tuples.c deleted file mode 100644 index c93bdf4669..0000000000 --- a/vm/tuples.c +++ /dev/null @@ -1,35 +0,0 @@ -#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)); -} diff --git a/vm/tuples.cpp b/vm/tuples.cpp new file mode 100644 index 0000000000..d7e22bb807 --- /dev/null +++ b/vm/tuples.cpp @@ -0,0 +1,37 @@ +#include "master.hpp" + +namespace factor +{ + +/* push a new tuple on the stack */ +tuple *allot_tuple(cell layout_) +{ + gc_root layout(layout_); + gc_root t(allot(tuple_size(layout.untagged()))); + t->layout = layout.value(); + return t.untagged(); +} + +PRIMITIVE(tuple) +{ + gc_root 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(t)); +} + +/* push a new tuple on the stack, filling its slots from the stack */ +PRIMITIVE(tuple_boa) +{ + gc_root layout(dpop()); + gc_root 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()); +} + +} diff --git a/vm/tuples.h b/vm/tuples.h deleted file mode 100644 index 64b62e2539..0000000000 --- a/vm/tuples.h +++ /dev/null @@ -1,25 +0,0 @@ -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); diff --git a/vm/tuples.hpp b/vm/tuples.hpp new file mode 100644 index 0000000000..831bb3bbac --- /dev/null +++ b/vm/tuples.hpp @@ -0,0 +1,14 @@ +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); + +} diff --git a/vm/utilities.c b/vm/utilities.cpp similarity index 57% rename from vm/utilities.c rename to vm/utilities.cpp index ac52772b4e..532de80ed1 100755 --- a/vm/utilities.c +++ b/vm/utilities.cpp @@ -1,4 +1,7 @@ -#include "master.h" +#include "master.hpp" + +namespace factor +{ /* If memory allocation fails, bail out */ void *safe_malloc(size_t size) @@ -8,9 +11,9 @@ void *safe_malloc(size_t size) return ptr; } -F_CHAR *safe_strdup(const F_CHAR *str) +vm_char *safe_strdup(const vm_char *str) { - F_CHAR *ptr = STRDUP(str); + vm_char *ptr = STRDUP(str); if(!ptr) fatal_error("Out of memory in safe_strdup", 0); return ptr; } @@ -27,29 +30,31 @@ void print_string(const char *str) fputs(str,stdout); } -void print_cell(CELL x) +void print_cell(cell x) { - printf(CELL_FORMAT,x); + printf(cell_FORMAT,x); } -void print_cell_hex(CELL x) +void print_cell_hex(cell x) { - printf(CELL_HEX_FORMAT,x); + printf(cell_HEX_FORMAT,x); } -void print_cell_hex_pad(CELL x) +void print_cell_hex_pad(cell x) { - printf(CELL_HEX_PAD_FORMAT,x); + printf(cell_HEX_PAD_FORMAT,x); } -void print_fixnum(F_FIXNUM x) +void print_fixnum(fixnum x) { printf(FIXNUM_FORMAT,x); } -CELL read_cell_hex(void) +cell read_cell_hex(void) { - CELL cell; - if(scanf(CELL_HEX_FORMAT,&cell) < 0) exit(1); + cell cell; + if(scanf(cell_HEX_FORMAT,&cell) < 0) exit(1); return cell; }; + +} diff --git a/vm/utilities.h b/vm/utilities.h deleted file mode 100755 index d2b3223ce4..0000000000 --- a/vm/utilities.h +++ /dev/null @@ -1,10 +0,0 @@ -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); diff --git a/vm/utilities.hpp b/vm/utilities.hpp new file mode 100755 index 0000000000..d311b954ed --- /dev/null +++ b/vm/utilities.hpp @@ -0,0 +1,15 @@ +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); + +} diff --git a/vm/words.c b/vm/words.c deleted file mode 100644 index 615c11e5af..0000000000 --- a/vm/words.c +++ /dev/null @@ -1,82 +0,0 @@ -#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; -} - -/* ( 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)); -} diff --git a/vm/words.cpp b/vm/words.cpp new file mode 100644 index 0000000000..cb2fdf0dd6 --- /dev/null +++ b/vm/words.cpp @@ -0,0 +1,78 @@ +#include "master.hpp" + +namespace factor +{ + +word *allot_word(cell vocab_, cell name_) +{ + gc_root vocab(vocab_); + gc_root name(name_); + + gc_root new_word(allot(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(); +} + +/* ( name vocabulary -- word ) */ +PRIMITIVE(word) +{ + cell vocab = dpop(); + cell name = dpop(); + dpush(tag(allot_word(vocab,name))); +} + +/* word-xt ( word -- start end ) */ +PRIMITIVE(word_xt) +{ + word *w = untag_check(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 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(dpeek())))); +} + +PRIMITIVE(wrapper) +{ + wrapper *new_wrapper = allot(sizeof(wrapper)); + new_wrapper->object = dpeek(); + drepl(tag(new_wrapper)); +} + +} diff --git a/vm/words.h b/vm/words.h deleted file mode 100644 index aa86c87ae1..0000000000 --- a/vm/words.h +++ /dev/null @@ -1,16 +0,0 @@ -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); diff --git a/vm/words.hpp b/vm/words.hpp new file mode 100644 index 0000000000..9c8e7ad57a --- /dev/null +++ b/vm/words.hpp @@ -0,0 +1,19 @@ +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); + +} diff --git a/vm/write_barrier.cpp b/vm/write_barrier.cpp new file mode 100644 index 0000000000..4137b0a6eb --- /dev/null +++ b/vm/write_barrier.cpp @@ -0,0 +1,7 @@ +#include "master.hpp" + +using namespace factor; + +cell cards_offset; +cell decks_offset; +cell allot_markers_offset; diff --git a/vm/write_barrier.h b/vm/write_barrier.h deleted file mode 100644 index be75d189de..0000000000 --- a/vm/write_barrier.h +++ /dev/null @@ -1,66 +0,0 @@ -/* 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) + cards_offset) -#define CARD_TO_ADDR(c) (CELL*)(((CELL)(c) - cards_offset)<> 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); -} diff --git a/vm/write_barrier.hpp b/vm/write_barrier.hpp new file mode 100644 index 0000000000..ae7fbb25dd --- /dev/null +++ b/vm/write_barrier.hpp @@ -0,0 +1,87 @@ +/* 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) + 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) + 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); +} + +}