* Compiling the Factor VM
-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
<http://factorcode.org>.
-Factor requires gcc 3.4 or later.
-
-On x86, Factor /will not/ build using gcc 3.3 or earlier.
-
-If you are using gcc 4.3, you might get an unusable Factor binary unless
-you add 'SITE_CFLAGS=-fno-forward-propagate' to the command-line
-arguments for make.
+The Factor VM is written in C++ and uses GNU extensions. When compiling
+with GCC 3.x, boost::unordered_map must be installed. On GCC 4.x, Factor
+uses std::tr1::unordered_map which is shipped as part of GCC.
Run 'make' ('gmake' on *BSD) with no parameters to build the Factor VM.
* Bootstrapping the Factor image
-Once you have compiled the Factor runtime, you must bootstrap the Factor
+Once you have compiled the Factor VM, you must bootstrap the Factor
system using the image that corresponds to your CPU architecture.
Boot images can be obtained from <http://factorcode.org/images/latest/>.
Then bootstrap with the following switches:
- ./factor -i=boot.<cpu>.image -ui-backend=x11 -ui-text-backend=pango
+ ./factor -i=boot.<cpu>.image -ui-backend=x11
Now if $DISPLAY is set, running ./factor will start the UI.
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/ - Factor VM
core/ - Factor core library
basis/ - Factor basis library, compiler, tools
extra/ - more libraries and applications
: dlopen ( path -- dll ) native-string>alien (dlopen) ;
-: dlsym ( name dll -- alien ) [ native-string>alien ] dip (dlsym) ;
+: dlsym ( name dll -- alien ) [ string>symbol ] dip (dlsym) ;
SYMBOL: libraries
! which are also quick to compile are replaced by
! compiled definitions as soon as possible.
{
- roll -roll declare not
+ not
array? hashtable? vector?
tuple? sbuf? tombstone?
-! Copyright (C) 2006 Slava Pestov
+! Copyright (C) 2006, 2009 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: compiler io kernel cocoa.runtime cocoa.subclassing
cocoa.messages cocoa.types sequences words vocabs parser
frameworks [ V{ } clone ] initialize
-[ frameworks get [ load-framework ] each ] "cocoa.messages" add-init-hook
+[ frameworks get [ load-framework ] each ] "cocoa" add-init-hook
SYNTAX: FRAMEWORK: scan [ load-framework ] [ frameworks get push ] bi ;
SYNTAX: IMPORT: scan [ ] import-objc-class ;
-"Compiling Objective C bridge..." print
+"Importing Cocoa classes..." print
"cocoa.classes" create-vocab drop
-{
- "cocoa" "cocoa.runtime" "cocoa.messages" "cocoa.subclassing"
-} [ words ] map concat compile
-
-"Importing Cocoa classes..." print
-
[
{
"NSApplication"
} cond ;
: optimize? ( word -- ? )
- {
- [ predicate-engine-word? ]
- [ contains-breakpoints? ]
- [ single-generic? ]
- } 1|| not ;
+ { [ predicate-engine-word? ] [ single-generic? ] } 1|| not ;
+
+: contains-breakpoints? ( -- ? )
+ dependencies get keys [ "break?" word-prop ] any? ;
: frontend ( word -- nodes )
#! If the word contains breakpoints, don't optimize it, since
#! the walker does not support this.
- dup optimize?
- [ [ build-tree ] [ deoptimize ] recover optimize-tree ]
- [ dup def>> deoptimize-with ]
- if ;
+ dup optimize? [
+ [ [ build-tree ] [ deoptimize ] recover optimize-tree ] keep
+ contains-breakpoints? [ nip dup def>> deoptimize-with ] [ drop ] if
+ ] [ dup def>> deoptimize-with ] if ;
: compile-dependency ( word -- )
#! If a word calls an unoptimized word, try to compile the callee.
: quot-xt-offset ( -- n ) 5 bootstrap-cells quotation tag-number - ; inline
: word-code-offset ( -- n ) 10 bootstrap-cells \ word tag-number - ; inline
: array-start-offset ( -- n ) 2 bootstrap-cells array tag-number - ; inline
-: compiled-header-size ( -- n ) 5 bootstrap-cells ; inline
+: compiled-header-size ( -- n ) 4 bootstrap-cells ; inline
! Relocation classes
CONSTANT: rc-absolute-cell 0
] [ dup inference-error? [ drop f ] [ rethrow ] if ] recover
] with-variable ;
-: contains-breakpoints? ( word -- ? )
- def>> [ word? ] filter [ "break?" word-prop ] any? ;
] sum-outputs ;
: should-inline? ( #call word -- ? )
- {
- { [ dup contains-breakpoints? ] [ 2drop f ] }
- { [ dup "inline" word-prop ] [ 2drop t ] }
- [ inlining-rank 5 >= ]
- } cond ;
+ dup inline? [ 2drop t ] [ inlining-rank 5 >= ] if ;
SYMBOL: history
[ { 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
+
+: sixty-nine ( -- a b ) 6 9 ;
+
+[ { 6 9 } ] [ ${ sixty-nine } ] unit-test
! (c) Joe Groff, see license for details
USING: accessors continuations kernel parser words quotations
-combinators.smart vectors sequences ;
+combinators.smart vectors sequences fry ;
IN: literals
-SYNTAX: $ scan-word [ def>> call ] curry with-datastack >vector ;
+<PRIVATE
+
+! Use def>> call so that CONSTANT:s defined in the same file can
+! be called
+
+: expand-literal ( seq obj -- seq' )
+ '[ _ dup word? [ def>> call ] when ] with-datastack ;
+
+: expand-literals ( seq -- seq' )
+ [ [ { } ] dip expand-literal ] map concat ;
+
+PRIVATE>
+
+SYNTAX: $ scan-word expand-literal >vector ;
SYNTAX: $[ parse-quotation with-datastack >vector ;
-SYNTAX: ${ \ } [ [ ?execute ] { } map-as ] parse-literal ;
+SYNTAX: ${ \ } [ expand-literals ] parse-literal ;
\ become { array array } { } define-primitive
-\ innermost-frame-quot { callstack } { quotation } define-primitive
+\ innermost-frame-executing { callstack } { object } define-primitive
\ innermost-frame-scan { callstack } { fixnum } define-primitive
sequences math namespaces.private continuations.private
concurrency.messaging quotations kernel.private words
sequences.private assocs models models.arrow arrays accessors
-generic generic.single definitions make sbufs tools.crossref ;
+generic generic.single definitions make sbufs tools.crossref fry ;
IN: tools.continuations
<PRIVATE
(step-into-call-next-method)
} [ t "no-compile" set-word-prop ] each >>
+: >innermost-frame< ( callstack -- n quot )
+ [ innermost-frame-scan 1 + ] [ innermost-frame-executing ] bi ;
+
+: (change-frame) ( callstack quot -- callstack' )
+ [ dup innermost-frame-executing quotation? ] dip '[
+ clone [ >innermost-frame< @ ] [ set-innermost-frame-quot ] [ ] tri
+ ] when ; inline
+
: change-frame ( continuation quot -- continuation' )
#! Applies quot to innermost call frame of the
#! continuation.
- [ clone ] dip [
- [ clone ] dip
- [
- [
- [ innermost-frame-scan 1+ ]
- [ innermost-frame-quot ] bi
- ] dip call
- ]
- [ drop set-innermost-frame-quot ]
- [ drop ]
- 2tri
- ] curry change-call ; inline
+ [ clone ] dip '[ _ (change-frame) ] change-call ; inline
PRIVATE>
[
2dup length = [ nip [ break ] append ] [
2dup nth \ break = [ nip ] [
- swap 1+ cut [ break ] glue
+ swap 1 + cut [ break ] glue
] if
] if
] change-frame ;
: continuation-step-out ( continuation -- continuation' )
[ nip \ break suffix ] change-frame ;
-
{
{ call [ (step-into-quot) ] }
{ dip [ (step-into-dip) ] }
! Never step into these words
: don't-step-into ( word -- )
- dup [ execute break ] curry "step-into" set-word-prop ;
+ dup '[ _ execute break ] "step-into" set-word-prop ;
{
>n ndrop >c c>
] change-frame ;
: continuation-current ( continuation -- obj )
- call>>
- [ innermost-frame-scan 1+ ]
- [ innermost-frame-quot ] bi ?nth ;
+ call>> >innermost-frame< ?nth ;
: compress-wrappers ( -- )
[ wrapper? ] [ ] "wrappers" compress ;
-: finish-deploy ( final-image -- )
- "Finishing up" show
- V{ } set-namestack
- V{ } set-catchstack
- "Saving final image" show
- save-image-and-exit ;
-
SYMBOL: deploy-vocab
: [:c] ( -- word ) ":c" "debugger" lookup ;
"Vocabulary has no MAIN: word." print flush 1 exit
] unless
strip
- finish-deploy
+ "Saving final image" show
+ save-image-and-exit
] deploy-error-handler
] bind ;
--- /dev/null
+IN: tools.disassembler.udis.tests
+USING: tools.disassembler.udis tools.test alien.c-types system combinators kernel ;
+
+{
+ { [ os linux? cpu x86.64? and ] [ [ 656 ] [ "ud" heap-size ] unit-test ] }
+ { [ os macosx? cpu x86.32? and ] [ [ 592 ] [ "ud" heap-size ] unit-test ] }
+ { [ os macosx? cpu x86.64? and ] [ [ 656 ] [ "ud" heap-size ] unit-test ] }
+ [ ]
+} cond
\ No newline at end of file
LIBRARY: libudis86
-TYPEDEF: char[592] ud
+C-STRUCT: ud_operand
+ { "int" "type" }
+ { "uchar" "size" }
+ { "ulonglong" "lval" }
+ { "int" "base" }
+ { "int" "index" }
+ { "uchar" "offset" }
+ { "uchar" "scale" } ;
+
+C-STRUCT: ud
+ { "void*" "inp_hook" }
+ { "uchar" "inp_curr" }
+ { "uchar" "inp_fill" }
+ { "FILE*" "inp_file" }
+ { "uchar" "inp_ctr" }
+ { "uchar*" "inp_buff" }
+ { "uchar*" "inp_buff_end" }
+ { "uchar" "inp_end" }
+ { "void*" "translator" }
+ { "ulonglong" "insn_offset" }
+ { "char[32]" "insn_hexcode" }
+ { "char[64]" "insn_buffer" }
+ { "uint" "insn_fill" }
+ { "uchar" "dis_mode" }
+ { "ulonglong" "pc" }
+ { "uchar" "vendor" }
+ { "struct map_entry*" "mapen" }
+ { "int" "mnemonic" }
+ { "ud_operand[3]" "operand" }
+ { "uchar" "error" }
+ { "uchar" "pfx_rex" }
+ { "uchar" "pfx_seg" }
+ { "uchar" "pfx_opr" }
+ { "uchar" "pfx_adr" }
+ { "uchar" "pfx_lock" }
+ { "uchar" "pfx_rep" }
+ { "uchar" "pfx_repe" }
+ { "uchar" "pfx_repne" }
+ { "uchar" "pfx_insn" }
+ { "uchar" "default64" }
+ { "uchar" "opr_mode" }
+ { "uchar" "adr_mode" }
+ { "uchar" "br_far" }
+ { "uchar" "br_near" }
+ { "uchar" "implicit_addr" }
+ { "uchar" "c1" }
+ { "uchar" "c2" }
+ { "uchar" "c3" }
+ { "uchar[256]" "inp_cache" }
+ { "uchar[64]" "inp_sess" }
+ { "ud_itab_entry*" "itab_entry" } ;
FUNCTION: void ud_translate_intel ( ud* u ) ;
FUNCTION: void ud_translate_att ( ud* u ) ;
math.private namespaces prettyprint sequences tools.test
continuations math.parser threads arrays tools.walker.debug
generic.single sequences.private kernel.private
-tools.continuations accessors words ;
+tools.continuations accessors words combinators ;
IN: tools.walker.tests
[ { } ] [
\ method-breakpoint-test don't-step-into
[ { 3 } ]
-[ [ T{ method-breakpoint-tuple } method-breakpoint-test ] test-walker ] unit-test
\ No newline at end of file
+[ [ T{ method-breakpoint-tuple } method-breakpoint-test ] test-walker ] unit-test
+
+: case-breakpoint-test ( -- x )
+ 5 { [ break 1 + ] } case ;
+
+\ case-breakpoint-test don't-step-into
+
+[ { 6 } ] [ [ case-breakpoint-test ] test-walker ] unit-test
+
+: call(-breakpoint-test ( -- x )
+ [ break 1 ] call( -- x ) 2 + ;
+
+\ call(-breakpoint-test don't-step-into
+
+[ { 3 } ] [ [ call(-breakpoint-test ] test-walker ] unit-test
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: unix alien>native-string utf8 alien>string ;
-M: winnt native-string>alien utf8 string>alien ;
+HOOK: native-string>alien os ( string -- alien )
-M: unix alien>native-string utf8 alien>string ;
+M: windows native-string>alien utf16n string>alien ;
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 ;
+HOOK: string>symbol* os ( str/seq -- alien )
+
+M: winnt string>symbol* utf8 string>alien ;
+
+M: wince string>symbol* utf16n string>alien ;
+
+M: unix string>symbol* utf8 string>alien ;
+
+GENERIC: string>symbol ( str -- alien )
+
+M: string string>symbol string>symbol* ;
+
+M: sequence string>symbol [ string>symbol* ] map ;
[
8 getenv utf8 alien>string string>cpu \ cpu set-global
{ "(sleep)" "threads.private" (( us -- )) }
{ "<tuple-boa>" "classes.tuple.private" (( ... layout -- tuple )) }
{ "callstack>array" "kernel" (( callstack -- array )) }
- { "innermost-frame-quot" "kernel.private" (( callstack -- quot )) }
+ { "innermost-frame-executing" "kernel.private" (( callstack -- obj )) }
{ "innermost-frame-scan" "kernel.private" (( callstack -- n )) }
{ "set-innermost-frame-quot" "kernel.private" (( n callstack -- )) }
{ "call-clear" "kernel" (( quot -- )) }
256 iota [
8 [
[ 2/ ] [ even? ] bi [ crc32-polynomial bitxor ] unless
- ] times >bignum
+ ] times
] map 0 crc32-table copy
: (crc32) ( crc ch -- crc )
- >bignum dupd bitxor
- mask-byte crc32-table nth-unsafe >bignum
+ dupd bitxor
+ mask-byte crc32-table nth-unsafe
swap -8 shift bitxor ; inline
SINGLETON: crc32
[ 1 2 ] [ bar ] unit-test
-[ t ] [ \ bar def>> "c" get innermost-frame-quot = ] unit-test
+[ t ] [ \ bar def>> "c" get innermost-frame-executing = ] unit-test
[ 1 ] [ "c" get innermost-frame-scan ] unit-test
TUPLE: standard-combination < single-combination # ;
-: <standard-combination> ( n -- standard-combination )
- dup 0 2 between? [ "Bad dispatch position" throw ] unless
- standard-combination boa ;
+C: <standard-combination> standard-combination
PREDICATE: standard-generic < generic
"combination" word-prop standard-combination? ;
normalize-path native-string>alien (save-image) ;
: save-image-and-exit ( path -- )
- normalize-path native-string>alien (save-image) ;
+ normalize-path native-string>alien (save-image-and-exit) ;
: save ( -- ) image save-image ;
ui.gadgets.panes ui.render ui.images ;
IN: images.viewer
-TUPLE: image-gadget < gadget image-name ;
+TUPLE: image-gadget < gadget image texture ;
-M: image-gadget pref-dim*
- image-name>> image-dim ;
+M: image-gadget pref-dim* image>> dim>> ;
+
+: image-gadget-texture ( gadget -- texture )
+ dup texture>> [ ] [ dup image>> { 0 0 } <texture> >>texture texture>> ] ?if ;
M: image-gadget draw-gadget* ( gadget -- )
- image-name>> draw-image ;
+ [ dim>> ] [ image-gadget-texture ] bi draw-scaled-texture ;
+
+! Todo: delete texture on ungraft
+
+GENERIC: <image-gadget> ( object -- gadget )
-: <image-gadget> ( image-name -- gadget )
+M: image <image-gadget>
\ image-gadget new
- swap >>image-name ;
+ swap >>image ;
-: image-window ( path -- gadget )
- [ <image-name> <image-gadget> dup ] [ open-window ] bi ;
+M: string <image-gadget> load-image <image-gadget> ;
-GENERIC: image. ( object -- )
+M: pathname <image-gadget> load-image <image-gadget> ;
-M: string image. ( image -- ) <image-name> <image-gadget> gadget. ;
+: image-window ( object -- ) <image-gadget> "Image" open-window ;
-M: pathname image. ( image -- ) <image-name> <image-gadget> gadget. ;
+: image. ( object -- ) <image-gadget> gadget. ;
CONSOLE_EXTENSION=.com
DLL_EXTENSION=.dll
SHARED_DLL_EXTENSION=.dll
-LINKER = $(CC) -shared -mno-cygwin -o
+LINKER = $(CPP) -shared -mno-cygwin -o
LINK_WITH_ENGINE = -l$(DLL_PREFIX)factor$(DLL_SUFFIX)
}
/* pop ( alien n ) from datastack, return alien's address plus n */
-static void *alien_pointer(void)
+static void *alien_pointer()
{
fixnum offset = to_fixnum(dpop());
return unbox_alien() + offset;
gc_root<byte_array> name(dpop());
name.untag_check();
- vm_char *sym = (vm_char *)(name.untagged() + 1);
+ symbol_char *sym = name->data<symbol_char>();
if(library.value() == F)
box_alien(ffi_dlsym(NULL,sym));
}
/* pop an object representing a C pointer */
-VM_C_API char *unbox_alien(void)
+VM_C_API char *unbox_alien()
{
return alien_offset(dpop());
}
PRIMITIVE(dll_validp);
VM_C_API char *alien_offset(cell object);
-VM_C_API char *unbox_alien(void);
+VM_C_API char *unbox_alien();
VM_C_API void box_alien(void *ptr);
VM_C_API void to_value_struct(cell src, void *dest, cell size);
VM_C_API void box_value_struct(void *src, cell size);
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 *capture_start()
{
stack_frame *frame = stack_chain->callstack_bottom - 1;
while(frame >= stack_chain->callstack_top
cell frame_type(stack_frame *frame)
{
- return frame_code(frame)->block.type;
+ return frame_code(frame)->type;
}
cell frame_executing(stack_frame *frame)
/* Some primitives implementing a limited form of callstack mutation.
Used by the single stepper. */
-PRIMITIVE(innermost_stack_frame_quot)
+PRIMITIVE(innermost_stack_frame_executing)
{
- dpush(frame_executing(innermost_stack_frame_quot(untag_check<callstack>(dpop()))));
+ dpush(frame_executing(innermost_stack_frame(untag_check<callstack>(dpop()))));
}
PRIMITIVE(innermost_stack_frame_scan)
PRIMITIVE(callstack);
PRIMITIVE(set_callstack);
PRIMITIVE(callstack_to_array);
-PRIMITIVE(innermost_stack_frame_quot);
+PRIMITIVE(innermost_stack_frame_executing);
PRIMITIVE(innermost_stack_frame_scan);
PRIMITIVE(set_innermost_stack_frame_quot);
void flush_icache_for(code_block *block)
{
- flush_icache((cell)block,block->block.size);
+ flush_icache((cell)block,block->size);
}
void iterate_relocations(code_block *compiled, relocation_iterator iter)
/* Update pointers to literals from compiled code. */
void update_literal_references(code_block *compiled)
{
- if(!compiled->block.needs_fixup)
+ if(!compiled->needs_fixup)
{
iterate_relocations(compiled,update_literal_references_step);
flush_icache_for(compiled);
aging and nursery collections */
void copy_literal_references(code_block *compiled)
{
- if(collecting_gen >= compiled->block.last_scan)
+ if(collecting_gen >= compiled->last_scan)
{
if(collecting_accumulation_gen_p())
- compiled->block.last_scan = collecting_gen;
+ compiled->last_scan = collecting_gen;
else
- compiled->block.last_scan = collecting_gen + 1;
+ compiled->last_scan = collecting_gen + 1;
/* initialize chase pointer */
cell scan = newspace->here;
or dlsyms. */
void update_word_references(code_block *compiled)
{
- if(compiled->block.needs_fixup)
+ if(compiled->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
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)
- heap_free(&code,&compiled->block);
+ else if(compiled->type == PIC_TYPE)
+ heap_free(&code,compiled);
else
{
iterate_relocations(compiled,update_word_references_step);
{
check_code_address((cell)compiled);
- mark_block(&compiled->block);
+ mark_block(compiled);
copy_handle(&compiled->literals);
copy_handle(&compiled->relocation);
/* References to undefined symbols are patched up to call this function on
image load */
-void undefined_symbol(void)
+void undefined_symbol()
{
general_error(ERROR_UNDEFINED_SYMBOL,F,F,NULL);
}
return sym;
else
{
- printf("%s\n",name);
return (void *)undefined_symbol;
}
}
/* Perform all fixups on a code block */
void relocate_code_block(code_block *compiled)
{
- compiled->block.last_scan = NURSERY;
- compiled->block.needs_fixup = false;
+ compiled->last_scan = NURSERY;
+ compiled->needs_fixup = false;
iterate_relocations(compiled,relocate_code_block_step);
flush_icache_for(compiled);
}
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->type = type;
+ compiled->last_scan = NURSERY;
+ compiled->needs_fixup = true;
compiled->relocation = relocation.value();
/* slight space optimization */
void relocate_code_block(code_block *relocating);
-inline static bool stack_traces_p(void)
+inline static bool stack_traces_p()
{
return userenv[STACK_TRACES_ENV] != F;
}
static void add_to_free_list(heap *heap, free_heap_block *block)
{
- if(block->block.size < FREE_LIST_COUNT * BLOCK_SIZE_INCREMENT)
+ if(block->size < FREE_LIST_COUNT * BLOCK_SIZE_INCREMENT)
{
- int index = block->block.size / BLOCK_SIZE_INCREMENT;
+ int index = block->size / BLOCK_SIZE_INCREMENT;
block->next_free = heap->free.small_blocks[index];
heap->free.small_blocks[index] = block;
}
branch is only taken after loading a new image, not after code GC */
if((cell)(end + 1) <= heap->seg->end)
{
- end->block.status = B_FREE;
- end->block.size = heap->seg->end - (cell)end;
+ end->status = B_FREE;
+ end->size = heap->seg->end - (cell)end;
/* add final free block */
add_to_free_list(heap,end);
static void assert_free_block(free_heap_block *block)
{
- if(block->block.status != B_FREE)
+ if(block->status != B_FREE)
critical_error("Invalid block in free list",(cell)block);
}
while(block)
{
assert_free_block(block);
- if(block->block.size >= size)
+ if(block->size >= size)
{
if(prev)
prev->next_free = block->next_free;
static free_heap_block *split_free_block(heap *heap, free_heap_block *block, cell size)
{
- if(block->block.size != size )
+ if(block->size != size )
{
/* split the block in two */
free_heap_block *split = (free_heap_block *)((cell)block + size);
- split->block.status = B_FREE;
- split->block.size = block->block.size - size;
+ split->status = B_FREE;
+ split->size = block->size - size;
split->next_free = block->next_free;
- block->block.size = size;
+ block->size = size;
add_to_free_list(heap,split);
}
{
block = split_free_block(heap,block,size);
- block->block.status = B_ALLOCATED;
- return &block->block;
+ block->status = B_ALLOCATED;
+ return block;
}
else
return NULL;
}
/* Compute where each block is going to go, after compaction */
-cell compute_heap_forwarding(heap *heap)
+ cell compute_heap_forwarding(heap *heap, unordered_map<heap_block *,char *> &forwarding)
{
heap_block *scan = first_block(heap);
- cell address = (cell)first_block(heap);
+ char *address = (char *)first_block(heap);
while(scan)
{
if(scan->status == B_ALLOCATED)
{
- scan->forwarding = (heap_block *)address;
+ forwarding[scan] = address;
address += scan->size;
}
else if(scan->status == B_MARKED)
scan = next_block(heap,scan);
}
- return address - heap->seg->start;
+ return (cell)address - heap->seg->start;
}
-void compact_heap(heap *heap)
+ void compact_heap(heap *heap, unordered_map<heap_block *,char *> &forwarding)
{
heap_block *scan = first_block(heap);
{
heap_block *next = next_block(heap,scan);
- if(scan->status == B_ALLOCATED && scan != scan->forwarding)
- memcpy(scan->forwarding,scan,scan->size);
+ if(scan->status == B_ALLOCATED)
+ memmove(forwarding[scan],scan,scan->size);
scan = next;
}
}
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);
+cell compute_heap_forwarding(heap *h, unordered_map<heap_block *,char *> &forwarding);
+void compact_heap(heap *h, unordered_map<heap_block *,char *> &forwarding);
inline static heap_block *next_block(heap *h, heap_block *block)
{
/* Copy literals referenced from all code blocks to newspace. Only for
aging and nursery collections */
-void copy_code_heap_roots(void)
+void copy_code_heap_roots()
{
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)
+void update_code_heap_words()
{
iterate_code_heap(update_word_references);
}
dpush(tag_fixnum(max_free / 1024));
}
+static unordered_map<heap_block *,char *> forwarding;
+
code_block *forward_xt(code_block *compiled)
{
- return (code_block *)compiled->block.forwarding;
+ return (code_block *)forwarding[compiled];
}
void forward_frame_xt(stack_frame *frame)
FRAME_RETURN_ADDRESS(frame) = (void *)((cell)forwarded + offset);
}
-void forward_object_xts(void)
+void forward_object_xts()
{
begin_scan();
}
/* Set the XT fields now that the heap has been compacted */
-void fixup_object_xts(void)
+void fixup_object_xts()
{
begin_scan();
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)
+void compact_code_heap()
{
/* Free all unreachable code blocks */
gc();
/* Figure out where the code heap blocks are going to end up */
- cell size = compute_heap_forwarding(&code);
+ cell size = compute_heap_forwarding(&code, forwarding);
/* Update word and quotation code pointers */
forward_object_xts();
/* Actually perform the compaction */
- compact_heap(&code);
+ compact_heap(&code,forwarding);
/* Update word and quotation XTs */
fixup_object_xts();
void iterate_code_heap(code_heap_iterator iter);
-void copy_code_heap_roots(void);
+void copy_code_heap_roots();
PRIMITIVE(modify_code_heap);
PRIMITIVE(code_room);
-void compact_code_heap(void);
+void compact_code_heap();
inline static void check_code_pointer(cell ptr)
{
cell ds_size, rs_size;
context *unused_contexts;
-void reset_datastack(void)
+void reset_datastack()
{
ds = ds_bot - sizeof(cell);
}
-void reset_retainstack(void)
+void reset_retainstack()
{
rs = rs_bot - sizeof(cell);
}
#define RESERVED (64 * sizeof(cell))
-void fix_stacks(void)
+void fix_stacks()
{
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)
+void save_stacks()
{
if(stack_chain)
{
}
}
-context *alloc_context(void)
+context *alloc_context()
{
context *new_context;
}
/* called on entry into a compiled callback */
-void nest_stacks(void)
+void nest_stacks()
{
context *new_context = alloc_context();
}
/* called when leaving a compiled callback */
-void unnest_stacks(void)
+void unnest_stacks()
{
ds = stack_chain->datastack_save;
rs = stack_chain->retainstack_save;
DEFPUSHPOP(d,ds)
DEFPUSHPOP(r,rs)
-void reset_datastack(void);
-void reset_retainstack(void);
-void fix_stacks(void);
+void reset_datastack();
+void reset_retainstack();
+void fix_stacks();
void init_stacks(cell ds_size, cell rs_size);
PRIMITIVE(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 void save_stacks();
+VM_C_API void nest_stacks();
+VM_C_API void unnest_stacks();
}
register cell ds asm("esi");
register cell rs asm("edi");
-#define VM_ASM_API extern "C" __attribute__ ((regparm (2)))
+#define VM_ASM_API VM_C_API __attribute__ ((regparm (2)))
}
register cell ds asm("r14");
register cell rs asm("r15");
-#define VM_ASM_API extern "C"
+#define VM_ASM_API VM_C_API
}
bool growing_data_heap;
data_heap *old_data_heap;
-void init_data_gc(void)
+void init_data_gc()
{
performing_gc = false;
last_code_heap_scan = NURSERY;
/* Scan cards in all generations older than the one being collected, copying
old->new references */
-static void copy_cards(void)
+static void copy_cards()
{
u64 start = current_micros();
copy_handle((cell*)ptr);
}
-static void copy_registered_locals(void)
+static void copy_registered_locals()
{
cell scan = gc_locals_region->start;
copy_handle(*(cell **)scan);
}
-static void copy_registered_bignums(void)
+static void copy_registered_bignums()
{
cell scan = gc_bignums_region->start;
/* Copy roots over at the start of GC, namely various constants, stacks,
the user environment and extra roots registered by local_roots.hpp */
-static void copy_roots(void)
+static void copy_roots()
{
copy_handle(&T);
copy_handle(&bignum_zero);
performing_gc = false;
}
-void gc(void)
+void gc()
{
garbage_collection(TENURED,false,0);
}
dpush(result.elements.value());
}
-void clear_gc_stats(void)
+void clear_gc_stats()
{
int i;
for(i = 0; i < MAX_GEN_COUNT; i++)
compile_all_words();
}
-VM_C_API void minor_gc(void)
+VM_C_API void minor_gc()
{
garbage_collection(NURSERY,false,0);
}
extern cell last_code_heap_scan;
-void init_data_gc(void);
+void init_data_gc();
-void gc(void);
+void gc();
-inline static bool collecting_accumulation_gen_p(void)
+inline static bool collecting_accumulation_gen_p()
{
return ((HAVE_AGING_P
&& collecting_gen == AGING
PRIMITIVE(gc);
PRIMITIVE(gc_stats);
-void clear_gc_stats(void);
+void clear_gc_stats();
PRIMITIVE(clear_gc_stats);
PRIMITIVE(become);
#endif
}
-VM_C_API void minor_gc(void);
+VM_C_API void minor_gc();
}
return z->end;
}
-void init_card_decks(void)
+void init_card_decks()
{
cell start = align(data->seg->start,DECK_SIZE);
allot_markers_offset = (cell)data->allot_markers - (start >> CARD_BITS);
return callstack_size(untag_fixnum(((callstack *)pointer)->length));
default:
critical_error("Invalid header",(cell)pointer);
- return -1; /* can't happen */
+ return 0; /* can't happen */
}
}
return sizeof(wrapper);
default:
critical_error("Invalid header",(cell)pointer);
- return -1; /* can't happen */
+ return 0; /* can't happen */
}
}
cell heap_scan_ptr;
/* Disables GC and activates next-object ( -- obj ) primitive */
-void begin_scan(void)
+void begin_scan()
{
heap_scan_ptr = data->generations[TENURED].start;
gc_off = true;
begin_scan();
}
-cell next_object(void)
+cell next_object()
{
if(!gc_off)
general_error(ERROR_HEAP_SCAN,F,F,NULL);
gc_off = false;
}
-cell find_all_words(void)
+cell find_all_words()
{
growable_array words;
cell init_zone(zone *z, cell size, cell base);
-void init_card_decks(void);
+void init_card_decks();
data_heap *grow_data_heap(data_heap *data, cell requested_bytes);
cell binary_payload_start(object *pointer);
cell object_size(cell tagged);
-void begin_scan(void);
-cell next_object(void);
+void begin_scan();
+cell next_object();
PRIMITIVE(data_room);
PRIMITIVE(size);
/* GC is off during heap walking */
extern bool gc_off;
-cell find_all_words(void);
+cell find_all_words();
/* Every object has a regular representation in the runtime, which makes GC
much simpler. Every slot of the object until binary_payload_start is a pointer
}
}
-void print_datastack(void)
+void print_datastack()
{
print_string("==== DATA STACK:\n");
print_objects((cell *)ds_bot,(cell *)ds);
}
-void print_retainstack(void)
+void print_retainstack()
{
print_string("==== RETAIN STACK:\n");
print_objects((cell *)rs_bot,(cell *)rs);
print_string("\n");
}
-void print_callstack(void)
+void print_callstack()
{
print_string("==== CALL STACK:\n");
cell bottom = (cell)stack_chain->callstack_bottom;
print_string(", here="); print_cell(z->here - z->start); nl();
}
-void dump_generations(void)
+void dump_generations()
{
cell i;
}
/* Dump all code blocks for debugging */
-void dump_code_heap(void)
+void dump_code_heap()
{
cell reloc_size = 0, literal_size = 0;
print_cell(literal_size); print_string(" bytes of literal data\n");
}
-void factorbug(void)
+void factorbug()
{
if(fep_disabled)
{
void print_obj(cell obj);
void print_nested_obj(cell obj, fixnum nesting);
-void dump_generations(void);
-void factorbug(void);
+void dump_generations();
+void factorbug();
void dump_zone(zone *z);
PRIMITIVE(die);
break;
default:
critical_error("Bad methods array",methods);
- return -1;
+ return 0;
}
}
}
cell signal_fault_addr;
stack_frame *signal_callstack_top;
-void out_of_memory(void)
+void out_of_memory()
{
print_string("Out of memory\n\n");
dump_generations();
general_error(ERROR_TYPE,tag_fixnum(type),tagged,NULL);
}
-void not_implemented_error(void)
+void not_implemented_error()
{
general_error(ERROR_NOT_IMPLEMENTED,F,F,NULL);
}
general_error(ERROR_SIGNAL,tag_fixnum(signal),F,native_stack);
}
-void divide_by_zero_error(void)
+void divide_by_zero_error()
{
general_error(ERROR_DIVIDE_BY_ZERO,F,F,NULL);
}
not_implemented_error();
}
-void memory_signal_handler_impl(void)
+void memory_signal_handler_impl()
{
memory_protection_error(signal_fault_addr,signal_callstack_top);
}
-void misc_signal_handler_impl(void)
+void misc_signal_handler_impl()
{
signal_error(signal_number,signal_callstack_top);
}
ERROR_MEMORY,
};
-void out_of_memory(void);
+void out_of_memory();
void fatal_error(const char* msg, cell tagged);
void critical_error(const char* msg, cell tagged);
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 divide_by_zero_error();
void memory_protection_error(cell addr, stack_frame *native_stack);
void signal_error(int signal, stack_frame *native_stack);
void type_error(cell type, cell tagged);
-void not_implemented_error(void);
+void not_implemented_error();
PRIMITIVE(call_clear);
PRIMITIVE(unimplemented);
extern cell signal_fault_addr;
extern stack_frame *signal_callstack_top;
-void memory_signal_handler_impl(void);
-void misc_signal_handler_impl(void);
+void memory_signal_handler_impl();
+void misc_signal_handler_impl();
}
}
/* Do some initialization that we do once only */
-static void do_stage1_init(void)
+static void do_stage1_init()
{
print_string("*** Stage 2 early init... ");
fflush(stdout);
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[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;
free(result);
}
-VM_C_API void factor_yield(void)
+VM_C_API void factor_yield()
{
- void (*callback)(void) = (void (*)(void))alien_offset(userenv[YIELD_CALLBACK_ENV]);
+ void (*callback)() = (void (*)())alien_offset(userenv[YIELD_CALLBACK_ENV]);
callback();
}
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_yield();
VM_C_API void factor_sleep(long ms);
}
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];
- }
+ for(cell i = 0; i < USER_ENV; i++)
+ h.userenv[i] = (save_env_p(i) ? userenv[i] : F);
bool ok = true;
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;
+ for(cell i = 0; i < USER_ENV; i++)
+ {
+ if(!save_env_p(i)) userenv[i] = F;
+ }
/* do a full GC + code heap compaction */
performing_compaction = true;
/* 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;
+ cell old_type = old_block->type;
#ifdef FACTOR_DEBUG
/* The call target was either another PIC,
#endif
if(old_type == PIC_TYPE)
- heap_free(&code,&old_block->block);
+ heap_free(&code,old_block);
}
/* Figure out what kind of type check the PIC needs based on the methods
if(!seen_hi_tag && !seen_tuple) return PIC_TAG;
critical_error("Oops",0);
- return -1;
+ return 0;
}
static void update_pic_count(cell type)
with many more capabilities so these words are not usually used in
normal operation. */
-void init_c_io(void)
+void init_c_io()
{
userenv[STDIN_ENV] = allot_alien(F,(cell)stdin);
userenv[STDOUT_ENV] = allot_alien(F,(cell)stdout);
userenv[STDERR_ENV] = allot_alien(F,(cell)stderr);
}
-void io_error(void)
+void io_error()
{
#ifndef WINCE
if(errno == EINTR)
/* This function is used by FFI I/O. Accessing the errno global directly is
not portable, since on some libc's errno is not a global but a funky macro that
reads thread-local storage. */
-VM_C_API int err_no(void)
+VM_C_API int err_no()
{
return errno;
}
-VM_C_API void clear_err_no(void)
+VM_C_API void clear_err_no()
{
errno = 0;
}
namespace factor
{
-void init_c_io(void);
-void io_error(void);
+void init_c_io();
+void io_error();
PRIMITIVE(fopen);
PRIMITIVE(fgetc);
PRIMITIVE(existsp);
PRIMITIVE(read_dir);
-VM_C_API int err_no(void);
-VM_C_API void clear_err_no(void);
+VM_C_API int err_no();
+VM_C_API void clear_err_no();
}
struct header {
cell value;
+ /* Default ctor to make gcc 3.x happy */
+ header() { abort(); }
+
header(cell value_) : value(value_ << TAG_BITS) {}
void check_header() {
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? */
+ unsigned 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
+struct free_heap_block : public heap_block
{
- heap_block block;
-
- /* Filled in on image load */
free_heap_block *next_free;
};
-struct code_block
+struct code_block : public heap_block
{
- heap_block block;
cell literals; /* # bytes */
cell relocation; /* tagged pointer to byte-array or f */
}
/* Initialize the Mach exception handler thread. */
-void mach_initialize (void)
+void mach_initialize ()
{
mach_port_t self;
exception_mask_t mask;
namespace factor
{
-void mach_initialize (void);
+void mach_initialize ();
}
#include <assert.h>
#endif
+/* C headers */
#include <fcntl.h>
#include <limits.h>
#include <math.h>
#include <time.h>
#include <sys/param.h>
+/* C++ headers */
+#if __GNUC__ == 4
+ #include <tr1/unordered_map>
+ #define unordered_map std::tr1::unordered_map
+#elif __GNUC__ == 3
+ #include <boost/unordered_map.hpp>
+ #define unordered_map boost::unordered_map
+#else
+ #error Factor requires GCC 3.x or later
+#endif
+
+/* Factor headers */
#include "layouts.hpp"
#include "platform.hpp"
#include "primitives.hpp"
drepl(tag<bignum>(result));
}
-cell unbox_array_size(void)
+cell unbox_array_size()
{
switch(tagged<object>(dpeek()).type())
{
return bignum_to_fixnum(untag<bignum>(tagged));
default:
type_error(FIXNUM_TYPE,tagged);
- return -1; /* can't happen */
+ return 0; /* can't happen */
}
}
return bignum_to_long_long(untag<bignum>(obj));
default:
type_error(BIGNUM_TYPE,obj);
- return -1;
+ return 0;
}
}
return bignum_to_ulong_long(untag<bignum>(obj));
default:
type_error(BIGNUM_TYPE,obj);
- return -1;
+ return 0;
}
}
return tag_fixnum(x);
}
-cell unbox_array_size(void);
+cell unbox_array_size();
inline static double untag_float(cell tagged)
{
{
/* From SBCL */
-const char *vm_executable_path(void)
+const char *vm_executable_path()
{
char path[PATH_MAX + 1];
#include <osreldate.h>
#include <sys/sysctl.h>
-extern "C" int getosreldate(void);
+extern "C" int getosreldate();
#ifndef KERN_PROC_PATHNAME
#define KERN_PROC_PATHNAME 12
c_to_factor(quot);
}
-void init_signals(void)
+void init_signals()
{
unix_init_signals();
}
-void early_init(void) { }
+void early_init() { }
#define SUFFIX ".image"
#define SUFFIX_LEN 6
-const char *default_image_path(void)
+const char *default_image_path()
{
const char *path = vm_executable_path();
#define NULL_DLL NULL
void c_to_factor_toplevel(cell quot);
-void init_signals(void);
-void early_init(void);
-const char *vm_executable_path(void);
-const char *default_image_path(void);
+void init_signals();
+void early_init();
+const char *vm_executable_path();
+const char *default_image_path();
}
{
/* Snarfed from SBCL linux-so.c. You must free() this yourself. */
-const char *vm_executable_path(void)
+const char *vm_executable_path()
{
char *path = (char *)safe_malloc(PATH_MAX + 1);
#ifdef SYS_inotify_init
-int inotify_init(void)
+int inotify_init()
{
return syscall(SYS_inotify_init);
}
#else
-int inotify_init(void)
+int inotify_init()
{
not_implemented_error();
return -1;
namespace factor
{
-int inotify_init(void);
+int inotify_init();
int inotify_add_watch(int fd, const char *name, u32 mask);
int inotify_rm_watch(int fd, u32 wd);
#define FACTOR_OS_STRING "macosx"
#define NULL_DLL "libfactor.dylib"
-void init_signals(void);
-void early_init(void);
+void init_signals();
+void early_init();
-const char *vm_executable_path(void);
-const char *default_image_path(void);
+const char *vm_executable_path();
+const char *default_image_path();
inline static void *ucontext_stack_pointer(void *uap)
{
extern "C" int main();
-const char *vm_executable_path(void)
+const char *vm_executable_path()
{
static Dl_info info = {0};
if (!info.dli_fname)
namespace factor
{
-const char *vm_executable_path(void)
+const char *vm_executable_path()
{
return NULL;
}
namespace factor
{
-const char *vm_executable_path(void)
+const char *vm_executable_path()
{
return NULL;
}
static void *null_dll;
-s64 current_micros(void)
+s64 current_micros()
{
struct timeval t;
gettimeofday(&t,NULL);
usleep(usec);
}
-void init_ffi(void)
+void init_ffi()
{
/* NULL_DLL is "libfactor.dylib" for OS X and NULL for generic unix */
null_dll = dlopen(NULL_DLL,RTLD_LAZY);
fatal_error("sigaction failed", 0);
}
-void unix_init_signals(void)
+void unix_init_signals()
{
struct sigaction memory_sigaction;
struct sigaction misc_sigaction;
return NULL;
}
-void open_console(void)
+void open_console()
{
int filedes[2];
start_thread(stdin_loop);
}
-VM_C_API void wait_for_stdin(void)
+VM_C_API void wait_for_stdin()
{
if(write(control_write,"X",1) != 1)
{
void start_thread(void *(*start_routine)(void *));
-void init_ffi(void);
+void init_ffi();
void ffi_dlopen(dll *dll);
void *ffi_dlsym(dll *dll, symbol_char *symbol);
void ffi_dlclose(dll *dll);
-void unix_init_signals(void);
+void unix_init_signals();
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);
+s64 current_micros();
void sleep_micros(cell usec);
-void open_console(void);
+void open_console();
}
namespace factor
{
-s64 current_micros(void)
+s64 current_micros()
{
SYSTEMTIME st;
FILETIME ft;
c_to_factor(quot);
}
-void open_console(void) { }
+void open_console() { }
}
#define snprintf _snprintf
#define snwprintf _snwprintf
-s64 current_micros(void);
+s64 current_micros();
void c_to_factor_toplevel(cell quot);
-void open_console(void);
+void open_console();
}
namespace factor
{
-s64 current_micros(void)
+s64 current_micros()
{
FILETIME t;
GetSystemTimeAsFileTime(&t);
- EPOCH_OFFSET) / 10;
}
-long exception_handler(PEXCEPTION_POINTERS pe)
+FACTOR_STDCALL LONG exception_handler(PEXCEPTION_POINTERS pe)
{
PEXCEPTION_RECORD e = (PEXCEPTION_RECORD)pe->ExceptionRecord;
CONTEXT *c = (CONTEXT*)pe->ContextRecord;
if(in_code_heap_p(c->EIP))
- signal_callstack_top = (void *)c->ESP;
+ signal_callstack_top = (stack_frame *)c->ESP;
else
signal_callstack_top = NULL;
void c_to_factor_toplevel(cell quot)
{
- if(!AddVectoredExceptionHandler(0, (void*)exception_handler))
+ if(!AddVectoredExceptionHandler(0, (PVECTORED_EXCEPTION_HANDLER)exception_handler))
fatal_error("AddVectoredExceptionHandler failed", 0);
c_to_factor(quot);
- RemoveVectoredExceptionHandler((void*)exception_handler);
+ RemoveVectoredExceptionHandler((void *)exception_handler);
}
-void open_console(void)
+void open_console()
{
}
#define UNICODE
#endif
-#include <shellapi.h>
#include <windows.h>
+#include <shellapi.h>
namespace factor
{
#define FACTOR_DLL L"factor.dll"
#define FACTOR_DLL_NAME "factor.dll"
+#define FACTOR_STDCALL __attribute__((stdcall))
+
void c_to_factor_toplevel(cell quot);
-long exception_handler(PEXCEPTION_POINTERS pe);
-void open_console(void);
+FACTOR_STDCALL LONG exception_handler(PEXCEPTION_POINTERS pe);
+void open_console();
}
HMODULE hFactorDll;
-void init_ffi(void)
+void init_ffi()
{
hFactorDll = GetModuleHandle(FACTOR_DLL);
if(!hFactorDll)
void ffi_dlopen(dll *dll)
{
- dll->dll = LoadLibraryEx(alien_offset(dll->path), NULL, 0);
+ dll->dll = LoadLibraryEx((WCHAR *)alien_offset(dll->path), NULL, 0);
}
void *ffi_dlsym(dll *dll, symbol_char *symbol)
{
- return GetProcAddress(dll ? (HMODULE)dll->dll : hFactorDll, symbol);
+ return (void *)GetProcAddress(dll ? (HMODULE)dll->dll : hFactorDll, symbol);
}
void ffi_dlclose(dll *dll)
}
/* You must free() this yourself. */
-const vm_char *default_image_path(void)
+const vm_char *default_image_path()
{
vm_char full_path[MAX_UNICODE_PATH];
vm_char *ptr;
}
/* You must free() this yourself. */
-const vm_char *vm_executable_path(void)
+const vm_char *vm_executable_path()
{
vm_char full_path[MAX_UNICODE_PATH];
if(!GetModuleFileName(NULL, full_path, MAX_UNICODE_PATH))
PRIMITIVE(existsp)
{
- vm_char *path = (vm_char *)(untag_check<byte_array>(dpop()) + 1);
+ vm_char *path = untag_check<byte_array>(dpop())->data<vm_char>();
box_boolean(windows_stat(path));
}
getpagesize(), PAGE_NOACCESS, &ignore))
fatal_error("Cannot allocate high guard page", (cell)mem);
- segment *block = safe_malloc(sizeof(segment));
+ segment *block = (segment *)safe_malloc(sizeof(segment));
block->start = (cell)mem + getpagesize();
block->size = size;
free(block);
}
-long getpagesize(void)
+long getpagesize()
{
static long g_pagesize = 0;
if (! g_pagesize)
/* Difference between Jan 1 00:00:00 1601 and Jan 1 00:00:00 1970 */
#define EPOCH_OFFSET 0x019db1ded53e8000LL
-void init_ffi(void);
+void init_ffi();
void ffi_dlopen(dll *dll);
void *ffi_dlsym(dll *dll, symbol_char *symbol);
void ffi_dlclose(dll *dll);
void sleep_micros(u64 msec);
-inline static void init_signals(void) {}
-inline static void early_init(void) {}
-const vm_char *vm_executable_path(void);
-const vm_char *default_image_path(void);
-long getpagesize (void);
+inline static void init_signals() {}
+inline static void early_init() {}
+const vm_char *vm_executable_path();
+const vm_char *default_image_path();
+long getpagesize ();
-s64 current_micros(void);
+s64 current_micros();
}
primitive_sleep,
primitive_tuple_boa,
primitive_callstack_to_array,
- primitive_innermost_stack_frame_quot,
+ primitive_innermost_stack_frame_executing,
primitive_innermost_stack_frame_scan,
primitive_set_innermost_stack_frame_quot,
primitive_call_clear,
bool profiling_p;
-void init_profiler(void)
+void init_profiler()
{
profiling_p = false;
}
{
extern bool profiling_p;
-void init_profiler(void);
+void init_profiler();
code_block *compile_profiling_stub(cell word);
PRIMITIVE(profiling);
void set_quot_xt(quotation *quot, code_block *code)
{
- if(code->block.type != QUOTATION_TYPE)
+ if(code->type != QUOTATION_TYPE)
critical_error("Bad param to set_quot_xt",(cell)code);
quot->code = code;
drepl(allot_cell((cell)quot->xt));
}
-void compile_all_words(void)
+void compile_all_words()
{
gc_root<array> words(find_all_words());
PRIMITIVE(jit_compile);
-void compile_all_words(void);
+void compile_all_words();
PRIMITIVE(array_to_quotation);
PRIMITIVE(quotation_xt);
BREAK_ENV = 5, /* quotation called by throw primitive */
ERROR_ENV, /* a marker consed onto kernel errors */
- cell_SIZE_ENV = 7, /* sizeof(cell) */
+ CELL_SIZE_ENV = 7, /* sizeof(cell) */
CPU_ENV, /* CPU architecture */
OS_ENV, /* operating system name */
#define FIRST_SAVE_ENV BOOT_ENV
#define LAST_SAVE_ENV STAGE2_ENV
+inline static bool save_env_p(cell i)
+{
+ return (i >= FIRST_SAVE_ENV && i <= LAST_SAVE_ENV) || i == STACK_TRACES_ENV;
+}
+
/* Canonical T object. It's just a word */
extern cell T;
#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) \
+ inline static cell prefix##pop() \
{ \
cell value = prefix##peek(); \
ptr -= sizeof(cell); \
/* We don't use printf directly, because format directives are not portable.
Instead we define the common cases here. */
-void nl(void)
+void nl()
{
fputs("\n",stdout);
}
printf(FIXNUM_FORMAT,x);
}
-cell read_cell_hex(void)
+cell read_cell_hex()
{
cell cell;
if(scanf(cell_HEX_FORMAT,&cell) < 0) exit(1);
void *safe_malloc(size_t size);
vm_char *safe_strdup(const vm_char *str);
-void nl(void);
+void nl();
void print_string(const char *str);
void print_cell(cell x);
void print_cell_hex(cell x);
void print_cell_hex_pad(cell x);
void print_fixnum(fixnum x);
-cell read_cell_hex(void);
+cell read_cell_hex();
}
word *w = untag_check<word>(dpop());
code_block *code = (profiling_p ? w->profiling : w->code);
dpush(allot_cell((cell)code->xt()));
- dpush(allot_cell((cell)code + code->block.size));
+ dpush(allot_cell((cell)code + code->size));
}
/* Allocates memory */
inline bool word_optimized_p(word *word)
{
- return word->code->block.type == WORD_TYPE;
+ return word->code->type == WORD_TYPE;
}
PRIMITIVE(optimized_p);
cell cards_offset;
cell decks_offset;
-cell allot_markers_offset;
+
+namespace factor
+{
+ cell allot_markers_offset;
+}
the offset of the first object is set by the allocator. */
+VM_C_API factor::cell cards_offset;
+VM_C_API factor::cell decks_offset;
+
namespace factor
{
#define CARD_SIZE (1<<CARD_BITS)
#define ADDR_CARD_MASK (CARD_SIZE-1)
-VM_C_API cell cards_offset;
-
inline static card *addr_to_card(cell a)
{
return (card*)(((cell)(a) >> CARD_BITS) + cards_offset);
#define DECK_SIZE (1<<DECK_BITS)
#define ADDR_DECK_MASK (DECK_SIZE-1)
-VM_C_API cell decks_offset;
-
inline static card_deck *addr_to_deck(cell a)
{
return (card_deck *)(((cell)a >> DECK_BITS) + decks_offset);
#define INVALID_ALLOT_MARKER 0xff
-VM_C_API cell allot_markers_offset;
+extern cell allot_markers_offset;
inline static card *addr_to_allot_marker(object *a)
{
projects / factor.git / commitdiff