Merge commit 'erg/master'
commit
bcd1d6b66e
|
@ -360,20 +360,25 @@ cell 8 = [
|
|||
[ 3 ] [ B{ 1 2 3 4 5 } 2 [ { simple-c-ptr fixnum } declare alien-unsigned-1 ] compile-1 ] unit-test
|
||||
|
||||
[ ] [ B{ 1 2 3 4 5 } malloc-byte-array "b" set ] unit-test
|
||||
[ t ] [ "b" get >boolean ] unit-test
|
||||
|
||||
[ 3 ] [ "b" get 2 [ alien-unsigned-1 ] compile-1 ] unit-test
|
||||
[ 3 ] [ "b" get [ { simple-alien } declare 2 alien-unsigned-1 ] compile-1 ] unit-test
|
||||
[ 3 ] [ "b" get 2 [ { simple-alien fixnum } declare alien-unsigned-1 ] compile-1 ] unit-test
|
||||
[ 3 ] [ "b" get 2 [ { simple-c-ptr fixnum } declare alien-unsigned-1 ] compile-1 ] unit-test
|
||||
"b" get [
|
||||
[ 3 ] [ "b" get 2 [ alien-unsigned-1 ] compile-1 ] unit-test
|
||||
[ 3 ] [ "b" get [ { simple-alien } declare 2 alien-unsigned-1 ] compile-1 ] unit-test
|
||||
[ 3 ] [ "b" get 2 [ { simple-alien fixnum } declare alien-unsigned-1 ] compile-1 ] unit-test
|
||||
[ 3 ] [ "b" get 2 [ { simple-c-ptr fixnum } declare alien-unsigned-1 ] compile-1 ] unit-test
|
||||
|
||||
[ ] [ "b" get free ] unit-test
|
||||
[ ] [ "b" get free ] unit-test
|
||||
] when
|
||||
|
||||
[ ] [ "hello world" malloc-char-string "s" set ] unit-test
|
||||
[ t ] [ "hello world" malloc-char-string "s" set ] unit-test
|
||||
|
||||
[ "hello world" ] [ "s" get <void*> [ { byte-array } declare *void* ] compile-1 alien>char-string ] unit-test
|
||||
[ "hello world" ] [ "s" get <void*> [ { simple-c-ptr } declare *void* ] compile-1 alien>char-string ] unit-test
|
||||
"s" get [
|
||||
[ "hello world" ] [ "s" get <void*> [ { byte-array } declare *void* ] compile-1 alien>char-string ] unit-test
|
||||
[ "hello world" ] [ "s" get <void*> [ { simple-c-ptr } declare *void* ] compile-1 alien>char-string ] unit-test
|
||||
|
||||
[ ] [ "s" get free ] unit-test
|
||||
[ ] [ "s" get free ] unit-test
|
||||
] when
|
||||
|
||||
[ ALIEN: 1234 ] [ ALIEN: 1234 [ { simple-alien } declare <void*> ] compile-1 *void* ] unit-test
|
||||
[ ALIEN: 1234 ] [ ALIEN: 1234 [ { simple-c-ptr } declare <void*> ] compile-1 *void* ] unit-test
|
||||
|
|
|
@ -1,6 +1,7 @@
|
|||
USING: alien alien.c-types destructors io.windows libc
|
||||
io.nonblocking io.streams.duplex windows.types math
|
||||
windows.kernel32 windows namespaces io.launcher kernel ;
|
||||
windows.kernel32 windows namespaces io.launcher kernel
|
||||
io.windows.nt.backend ;
|
||||
IN: io.windows.launcher
|
||||
|
||||
! From MSDN: "Handles in PROCESS_INFORMATION must be closed with CloseHandle when they are no longer needed."
|
||||
|
|
|
@ -1,9 +1,36 @@
|
|||
USING: alien alien.c-types arrays assocs combinators continuations
|
||||
destructors io io.backend io.nonblocking io.windows io.windows.nt libc
|
||||
destructors io io.backend io.nonblocking io.windows libc
|
||||
kernel math namespaces sequences threads tuples.lib windows
|
||||
windows.errors windows.kernel32 prettyprint ;
|
||||
windows.errors windows.kernel32 prettyprint strings splitting
|
||||
io.files windows.winsock ;
|
||||
IN: io.windows.nt.backend
|
||||
|
||||
: unicode-prefix ( -- seq )
|
||||
"\\\\?\\" ; inline
|
||||
|
||||
M: windows-nt-io normalize-pathname ( string -- string )
|
||||
dup string? [ "pathname must be a string" throw ] unless
|
||||
"/" split "\\" join
|
||||
{
|
||||
! empty
|
||||
{ [ dup empty? ] [ "empty path" throw ] }
|
||||
! .\\foo
|
||||
{ [ dup ".\\" head? ] [
|
||||
>r unicode-prefix cwd r> 1 tail 3append
|
||||
] }
|
||||
! c:\\
|
||||
{ [ dup 1 tail ":" head? ] [ >r unicode-prefix r> append ] }
|
||||
! \\\\?\\c:\\foo
|
||||
{ [ dup unicode-prefix head? ] [ ] }
|
||||
! foo.txt ..\\foo.txt
|
||||
{ [ t ] [
|
||||
[
|
||||
unicode-prefix % cwd %
|
||||
dup first CHAR: \\ = [ CHAR: \\ , ] unless %
|
||||
] "" make
|
||||
] }
|
||||
} cond [ "/\\." member? ] rtrim ;
|
||||
|
||||
SYMBOL: io-hash
|
||||
|
||||
TUPLE: io-callback port continuation ;
|
||||
|
@ -63,9 +90,9 @@ C: <GetQueuedCompletionStatusParams> GetQueuedCompletionStatusParams
|
|||
GetQueuedCompletionStatus
|
||||
] keep swap ;
|
||||
|
||||
: lookup-callback ( GetQueuedCompletion-args -- callback ? )
|
||||
: lookup-callback ( GetQueuedCompletion-args -- callback )
|
||||
GetQueuedCompletionStatusParams-lpOverlapped* *void*
|
||||
\ io-hash get-global delete-at* ;
|
||||
\ io-hash get-global delete-at drop ;
|
||||
|
||||
: wait-for-io ( timeout -- continuation/f )
|
||||
wait-for-overlapped
|
||||
|
@ -73,15 +100,18 @@ C: <GetQueuedCompletionStatusParams> GetQueuedCompletionStatusParams
|
|||
GetLastError dup (expected-io-error?) [
|
||||
2drop f
|
||||
] [
|
||||
(win32-error-string) swap lookup-callback [
|
||||
dup ERROR_HANDLE_EOF = [
|
||||
drop lookup-callback [
|
||||
io-callback-port t swap set-port-eof?
|
||||
] keep io-callback-continuation
|
||||
] [
|
||||
(win32-error-string) swap lookup-callback
|
||||
[ io-callback-port set-port-error ] keep
|
||||
io-callback-continuation
|
||||
] [
|
||||
drop "No callback found" 2array throw
|
||||
] if
|
||||
] if
|
||||
] [
|
||||
lookup-callback [ io-callback-continuation ] when
|
||||
lookup-callback io-callback-continuation
|
||||
] if ;
|
||||
|
||||
: maybe-expire ( io-callbck -- )
|
||||
|
@ -99,3 +129,12 @@ M: windows-nt-io io-multiplex ( ms -- )
|
|||
cancel-timedout
|
||||
[ wait-for-io ] [ global [ "error: " write . flush ] bind drop f ] recover
|
||||
[ schedule-thread ] when* ;
|
||||
|
||||
M: windows-nt-io init-io ( -- )
|
||||
#! Should only be called on startup. Calling this at any
|
||||
#! other time can have unintended consequences.
|
||||
global [
|
||||
master-completion-port \ master-completion-port set
|
||||
H{ } clone \ io-hash set
|
||||
init-winsock
|
||||
] bind ;
|
||||
|
|
|
@ -1,51 +1,10 @@
|
|||
! Copyright (C) 2004, 2007 Mackenzie Straight, Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien alien.c-types assocs byte-arrays combinators
|
||||
io.backend io.files io.nonblocking io.windows
|
||||
kernel libc math namespaces qualified sequences
|
||||
splitting strings threads windows windows.errors windows.winsock
|
||||
windows.kernel32 ;
|
||||
QUALIFIED: windows.winsock
|
||||
IN: io.windows.nt
|
||||
|
||||
: unicode-prefix ( -- seq )
|
||||
"\\\\?\\" ; inline
|
||||
|
||||
M: windows-nt-io normalize-pathname ( string -- string )
|
||||
dup string? [ "pathname must be a string" throw ] unless
|
||||
"/" split "\\" join
|
||||
{
|
||||
! empty
|
||||
{ [ dup empty? ] [ "empty path" throw ] }
|
||||
! .\\foo
|
||||
{ [ dup ".\\" head? ] [
|
||||
>r unicode-prefix cwd r> 1 tail 3append
|
||||
] }
|
||||
! c:\\
|
||||
{ [ dup 1 tail ":" head? ] [ >r unicode-prefix r> append ] }
|
||||
! \\\\?\\c:\\foo
|
||||
{ [ dup unicode-prefix head? ] [ ] }
|
||||
! foo.txt ..\\foo.txt
|
||||
{ [ t ] [
|
||||
[
|
||||
unicode-prefix % cwd %
|
||||
dup first CHAR: \\ = [ CHAR: \\ , ] unless %
|
||||
] "" make
|
||||
] }
|
||||
} cond [ "/\\." member? ] rtrim ;
|
||||
|
||||
USE: io.windows
|
||||
USE: io.windows.nt.backend
|
||||
USE: io.windows.nt.files
|
||||
USE: io.windows.nt.sockets
|
||||
USE: io.backend
|
||||
USE: namespaces
|
||||
|
||||
T{ windows-nt-io } io-backend set-global
|
||||
|
||||
M: windows-nt-io init-io ( -- )
|
||||
#! Should only be called on startup. Calling this at any
|
||||
#! other time can have unintended consequences.
|
||||
global [
|
||||
master-completion-port \ master-completion-port set
|
||||
H{ } clone \ io-hash set
|
||||
init-winsock
|
||||
] bind ;
|
||||
|
||||
|
|
|
@ -1,7 +1,8 @@
|
|||
! Copyright (C) 2005, 2006 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien alien.c-types alien.syntax parser namespaces kernel
|
||||
math windows.types windows.types init assocs sequences opengl.gl ;
|
||||
math windows.types windows.types init assocs sequences opengl.gl
|
||||
libc ;
|
||||
IN: windows.opengl32
|
||||
|
||||
! PIXELFORMATDESCRIPTOR flags
|
||||
|
|
|
@ -0,0 +1,110 @@
|
|||
#!/bin/bash -e
|
||||
|
||||
# Programs returning != 0 will not cause script to exit
|
||||
set +e
|
||||
|
||||
# Case insensitive string comparison
|
||||
shopt -s nocaseglob
|
||||
shopt -s nocasematch
|
||||
|
||||
ensure_program_installed() {
|
||||
echo -n "Checking for $1..."
|
||||
result=`type -p $1`
|
||||
if ! [[ -n $result ]] ; then
|
||||
echo "not found!"
|
||||
echo "Install $1 and try again."
|
||||
exit 1
|
||||
fi
|
||||
echo "found!"
|
||||
}
|
||||
|
||||
check_ret() {
|
||||
RET=$?
|
||||
if [[ $RET -ne 0 ]] ; then
|
||||
echo $1 failed
|
||||
exit 5
|
||||
fi
|
||||
}
|
||||
|
||||
ensure_program_installed uname
|
||||
ensure_program_installed git
|
||||
ensure_program_installed wget
|
||||
ensure_program_installed gcc
|
||||
ensure_program_installed make
|
||||
|
||||
GCC_VERSION=`gcc --version`
|
||||
if [[ $GCC_VERSION == *3.3.* ]] ; then
|
||||
echo "You have a known buggy version of gcc (3.3)"
|
||||
echo "Install gcc 3.4 or higher and try again."
|
||||
exit 1
|
||||
fi
|
||||
|
||||
# OS
|
||||
OS=
|
||||
uname_s=`uname -s`
|
||||
case $uname_s in
|
||||
CYGWIN_NT-5.2-WOW64) OS=windows-nt;;
|
||||
*CYGWIN_NT*) OS=windows-nt;;
|
||||
*CYGWIN*) OS=windows-nt;;
|
||||
*darwin*) OS=macosx;;
|
||||
*linux*) OS=linux;;
|
||||
esac
|
||||
|
||||
# Architecture
|
||||
ARCH=
|
||||
uname_m=`uname -m`
|
||||
case $uname_m in
|
||||
i386) ARCH=x86;;
|
||||
i686) ARCH=x86;;
|
||||
*86) ARCH=x86;;
|
||||
"Power Macintosh") ARCH=ppc;;
|
||||
esac
|
||||
|
||||
WORD=
|
||||
C_WORD=factor-word-size
|
||||
# Word size
|
||||
echo "#include <stdio.h>" > $C_WORD.c
|
||||
echo "int main() { printf(\"%d\", 8*sizeof(long)); return 0; }" >> $C_WORD.c
|
||||
gcc -o $C_WORD $C_WORD.c
|
||||
WORD=$(./$C_WORD)
|
||||
check_ret $C_WORD
|
||||
rm -f $C_WORD*
|
||||
|
||||
case $OS in
|
||||
windows-nt) FACTOR_BINARY=factor-nt;;
|
||||
macosx) FACTOR_BINARY=./Factor.app/Contents/MacOS/factor;;
|
||||
*) FACTOR_BINARY=factor;;
|
||||
esac
|
||||
|
||||
MAKE_TARGET=$OS-$ARCH-$WORD
|
||||
BOOT_IMAGE=boot.$ARCH.$WORD.image
|
||||
|
||||
echo OS=$OS
|
||||
echo ARCH=$ARCH
|
||||
echo WORD=$WORD
|
||||
echo FACTOR_BINARY=$FACTOR_BINARY
|
||||
echo MAKE_TARGET=$MAKE_TARGET
|
||||
echo BOOT_IMAGE=$BOOT_IMAGE
|
||||
|
||||
if ! [[ -n $OS && -n $ARCH && -n $WORD ]] ; then
|
||||
echo "OS, ARCH, or WORD is empty. Please report this"
|
||||
exit 4
|
||||
fi
|
||||
|
||||
echo "Downloading the git repository from factorcode.org..."
|
||||
git clone git://factorcode.org/git/factor.git
|
||||
check_ret git
|
||||
|
||||
cd factor
|
||||
check_ret cd
|
||||
|
||||
make $MAKE_TARGET
|
||||
check_ret make
|
||||
|
||||
echo "Deleting old images..."
|
||||
rm $BOOT_IMAGE > /dev/null 2>&1
|
||||
rm $BOOT_IMAGE.* > /dev/null 2>&1
|
||||
wget http://factorcode.org/images/latest/$BOOT_IMAGE
|
||||
check_ret wget
|
||||
|
||||
./$FACTOR_BINARY -i=$BOOT_IMAGE
|
|
@ -1,5 +1,5 @@
|
|||
#define FACTOR_CPU_STRING "ppc"
|
||||
#define FASTCALL
|
||||
#define F_FASTCALL
|
||||
|
||||
register CELL ds asm("r14");
|
||||
register CELL rs asm("r15");
|
||||
|
|
|
@ -3,4 +3,5 @@
|
|||
register CELL ds asm("esi");
|
||||
register CELL rs asm("edi");
|
||||
|
||||
#define FASTCALL __attribute__ ((regparm (2)))
|
||||
#define F_FASTCALL __attribute__ ((regparm (2)))
|
||||
|
||||
|
|
|
@ -3,4 +3,4 @@
|
|||
register CELL ds asm("r14");
|
||||
register CELL rs asm("r15");
|
||||
|
||||
#define FASTCALL
|
||||
#define F_FASTCALL
|
||||
|
|
16
vm/cpu-x86.S
16
vm/cpu-x86.S
|
@ -2,7 +2,7 @@
|
|||
mov QUOT_XT_OFFSET(ARG0),XT_REG ; /* Load quot-xt */ \
|
||||
jmp *XT_REG /* Jump to quot-xt */
|
||||
|
||||
DEF(FASTCALL void,c_to_factor,(CELL quot)):
|
||||
DEF(F_FASTCALL void,c_to_factor,(CELL quot)):
|
||||
PUSH_NONVOLATILE
|
||||
push ARG0 /* Save quot */
|
||||
|
||||
|
@ -17,38 +17,38 @@ DEF(FASTCALL void,c_to_factor,(CELL quot)):
|
|||
POP_NONVOLATILE
|
||||
ret
|
||||
|
||||
DEF(FASTCALL void,undefined,(CELL word)):
|
||||
DEF(F_FASTCALL void,undefined,(CELL word)):
|
||||
mov STACK_REG,ARG1 /* Pass callstack pointer */
|
||||
jmp MANGLE(undefined_error) /* This throws an error */
|
||||
|
||||
DEF(FASTCALL void,dosym,(CELL word)):
|
||||
DEF(F_FASTCALL void,dosym,(CELL word)):
|
||||
add $CELL_SIZE,DS_REG /* Increment stack pointer */
|
||||
mov ARG0,(DS_REG) /* Store word on stack */
|
||||
ret
|
||||
|
||||
/* Here we have two entry points. The first one is taken when profiling is
|
||||
enabled */
|
||||
DEF(FASTCALL void,docol_profiling,(CELL word)):
|
||||
DEF(F_FASTCALL void,docol_profiling,(CELL word)):
|
||||
add $CELL_SIZE,PROFILING_OFFSET(ARG0) /* Increment profile-count slot */
|
||||
DEF(FASTCALL void,docol,(CELL word)):
|
||||
DEF(F_FASTCALL void,docol,(CELL word)):
|
||||
mov WORD_DEF_OFFSET(ARG0),ARG0 /* Load word-def slot */
|
||||
JUMP_QUOT
|
||||
|
||||
/* We must pass the XT to the quotation in ECX. */
|
||||
DEF(FASTCALL void,primitive_call,(void)):
|
||||
DEF(F_FASTCALL void,primitive_call,(void)):
|
||||
mov (DS_REG),ARG0 /* Load quotation from data stack */
|
||||
sub $CELL_SIZE,DS_REG /* Pop data stack */
|
||||
JUMP_QUOT
|
||||
|
||||
/* We pass the word in EAX and the XT in ECX. Don't mess up EDX, it's the
|
||||
callstack top parameter to primitives. */
|
||||
DEF(FASTCALL void,primitive_execute,(void)):
|
||||
DEF(F_FASTCALL void,primitive_execute,(void)):
|
||||
mov (DS_REG),ARG0 /* Load word from data stack */
|
||||
sub $CELL_SIZE,DS_REG /* Pop data stack */
|
||||
mov WORD_XT_OFFSET(ARG0),XT_REG /* Load word-xt slot */
|
||||
jmp *XT_REG /* Go */
|
||||
|
||||
DEF(FASTCALL void,throw_impl,(CELL quot, F_STACK_FRAME *rewind_to)):
|
||||
DEF(F_FASTCALL void,throw_impl,(CELL quot, F_STACK_FRAME *rewind_to)):
|
||||
mov ARG1,STACK_REG /* rewind_to */
|
||||
JUMP_QUOT
|
||||
|
||||
|
|
14
vm/cpu-x86.h
14
vm/cpu-x86.h
|
@ -22,12 +22,12 @@ typedef struct _F_STACK_FRAME
|
|||
|
||||
INLINE void flush_icache(CELL start, CELL len) {}
|
||||
|
||||
FASTCALL void c_to_factor(CELL quot);
|
||||
FASTCALL void throw_impl(CELL quot, F_STACK_FRAME *rewind_to);
|
||||
FASTCALL void undefined(CELL word);
|
||||
FASTCALL void dosym(CELL word);
|
||||
FASTCALL void docol_profiling(CELL word);
|
||||
FASTCALL void docol(CELL word);
|
||||
FASTCALL void lazy_jit_compile(CELL quot);
|
||||
F_FASTCALL void c_to_factor(CELL quot);
|
||||
F_FASTCALL void throw_impl(CELL quot, F_STACK_FRAME *rewind_to);
|
||||
F_FASTCALL void undefined(CELL word);
|
||||
F_FASTCALL void dosym(CELL word);
|
||||
F_FASTCALL void docol_profiling(CELL word);
|
||||
F_FASTCALL void docol(CELL word);
|
||||
F_FASTCALL void lazy_jit_compile(CELL quot);
|
||||
|
||||
void set_callstack(F_STACK_FRAME *to, F_STACK_FRAME *from, CELL length, void *memcpy);
|
||||
|
|
2
vm/jit.c
2
vm/jit.c
|
@ -34,7 +34,7 @@ bool jit_stack_frame_p(F_ARRAY *array)
|
|||
return false;
|
||||
}
|
||||
|
||||
FASTCALL CELL jit_compile(CELL tagged, F_STACK_FRAME *stack)
|
||||
F_FASTCALL CELL jit_compile(CELL tagged, F_STACK_FRAME *stack)
|
||||
{
|
||||
stack_chain->callstack_top = stack;
|
||||
|
||||
|
|
2
vm/jit.h
2
vm/jit.h
|
@ -1,2 +1,2 @@
|
|||
DLLEXPORT FASTCALL CELL jit_compile(CELL tagged, F_STACK_FRAME *stack);
|
||||
DLLEXPORT F_FASTCALL CELL jit_compile(CELL tagged, F_STACK_FRAME *stack);
|
||||
XT quot_offset_to_pc(F_QUOTATION *quot, F_FIXNUM offset);
|
||||
|
|
10
vm/os-unix.c
10
vm/os-unix.c
|
@ -179,11 +179,6 @@ INLINE F_STACK_FRAME *uap_stack_pointer(void *uap)
|
|||
return NULL;
|
||||
}
|
||||
|
||||
void memory_signal_handler_impl(void)
|
||||
{
|
||||
memory_protection_error(signal_fault_addr,signal_callstack_top);
|
||||
}
|
||||
|
||||
void memory_signal_handler(int signal, siginfo_t *siginfo, void *uap)
|
||||
{
|
||||
signal_fault_addr = (CELL)siginfo->si_addr;
|
||||
|
@ -191,11 +186,6 @@ void memory_signal_handler(int signal, siginfo_t *siginfo, void *uap)
|
|||
UAP_PROGRAM_COUNTER(uap) = (CELL)memory_signal_handler_impl;
|
||||
}
|
||||
|
||||
void misc_signal_handler_impl(void)
|
||||
{
|
||||
signal_error(signal_number,signal_callstack_top);
|
||||
}
|
||||
|
||||
void misc_signal_handler(int signal, siginfo_t *siginfo, void *uap)
|
||||
{
|
||||
signal_number = signal;
|
||||
|
|
|
@ -23,31 +23,39 @@ DEFINE_PRIMITIVE(cd)
|
|||
SetCurrentDirectory(unbox_u16_string());
|
||||
}
|
||||
|
||||
void seh_call(void (*func)(), exception_handler_t *handler)
|
||||
long exception_handler(PEXCEPTION_POINTERS pe)
|
||||
{
|
||||
exception_record_t record;
|
||||
asm volatile("mov %%fs:0, %0" : "=r" (record.next_handler));
|
||||
asm volatile("mov %0, %%fs:0" : : "r" (&record));
|
||||
record.handler_func = handler;
|
||||
func();
|
||||
asm volatile("mov %0, %%fs:0" : "=r" (record.next_handler));
|
||||
}
|
||||
PEXCEPTION_RECORD e = (PEXCEPTION_RECORD)pe->ExceptionRecord;
|
||||
CONTEXT *c = (CONTEXT*)pe->ContextRecord;
|
||||
|
||||
long exception_handler(PEXCEPTION_RECORD rec, void *frame, void *ctx, void *dispatch)
|
||||
{
|
||||
if(rec->ExceptionCode == EXCEPTION_ACCESS_VIOLATION)
|
||||
memory_protection_error(
|
||||
rec->ExceptionInformation[1],
|
||||
native_stack_pointer());
|
||||
else if(rec->ExceptionCode == EXCEPTION_FLT_DIVIDE_BY_ZERO
|
||||
|| rec->ExceptionCode == EXCEPTION_INT_DIVIDE_BY_ZERO)
|
||||
general_error(ERROR_DIVIDE_BY_ZERO,F,F,false,(void*)rec->ExceptionInformation[1]);
|
||||
if(in_code_heap_p(c->Eip))
|
||||
signal_callstack_top = (void*)c->Esp;
|
||||
else
|
||||
signal_error(11,(void*)rec->ExceptionInformation[1]);
|
||||
return -1; /* unreachable */
|
||||
signal_callstack_top = NULL;
|
||||
|
||||
if(e->ExceptionCode == EXCEPTION_ACCESS_VIOLATION)
|
||||
{
|
||||
signal_fault_addr = e->ExceptionInformation[1];
|
||||
c->Eip = (CELL)memory_signal_handler_impl;
|
||||
}
|
||||
else if(e->ExceptionCode == EXCEPTION_FLT_DIVIDE_BY_ZERO
|
||||
|| e->ExceptionCode == EXCEPTION_INT_DIVIDE_BY_ZERO)
|
||||
{
|
||||
signal_number = ERROR_DIVIDE_BY_ZERO;
|
||||
c->Eip = (CELL)divide_by_zero_signal_handler_impl;
|
||||
}
|
||||
else
|
||||
{
|
||||
signal_number = 11;
|
||||
c->Eip = (CELL)misc_signal_handler_impl;
|
||||
}
|
||||
|
||||
return EXCEPTION_CONTINUE_EXECUTION;
|
||||
}
|
||||
|
||||
void run_toplevel(void)
|
||||
void c_to_factor_toplevel(CELL quot)
|
||||
{
|
||||
seh_call(run, exception_handler);
|
||||
AddVectoredExceptionHandler(0, (void*)exception_handler);
|
||||
c_to_factor(quot);
|
||||
RemoveVectoredExceptionHandler((void*)exception_handler);
|
||||
}
|
||||
|
|
|
@ -1,3 +1,6 @@
|
|||
#undef _WIN32_WINNT
|
||||
#define _WIN32_WINNT 0x0501 // For AddVectoredExceptionHandler
|
||||
|
||||
#ifndef UNICODE
|
||||
#define UNICODE
|
||||
#endif
|
||||
|
@ -10,3 +13,13 @@ typedef char F_SYMBOL;
|
|||
#define FACTOR_OS_STRING "windows"
|
||||
#define FACTOR_DLL L"factor-nt.dll"
|
||||
#define FACTOR_DLL_NAME "factor-nt.dll"
|
||||
|
||||
void c_to_factor_toplevel(CELL quot);
|
||||
|
||||
CELL signal_number;
|
||||
CELL signal_fault_addr;
|
||||
void *signal_callstack_top;
|
||||
|
||||
void memory_signal_handler_impl(void);
|
||||
void divide_by_zero_signal_handler_impl(void);
|
||||
void misc_signal_handler_impl(void);
|
||||
|
|
|
@ -51,8 +51,8 @@ void ffi_dlopen (F_DLL *dll, bool error)
|
|||
{
|
||||
dll->dll = NULL;
|
||||
if(error)
|
||||
general_error(ERROR_FFI,F,
|
||||
tag_object(get_error_message()));
|
||||
general_error(ERROR_FFI,F,F,
|
||||
(void*)tag_object(get_error_message()));
|
||||
else
|
||||
return;
|
||||
}
|
||||
|
@ -204,9 +204,3 @@ void sleep_millis(DWORD msec)
|
|||
{
|
||||
Sleep(msec);
|
||||
}
|
||||
|
||||
void run(void)
|
||||
{
|
||||
interpreter();
|
||||
}
|
||||
|
||||
|
|
|
@ -49,20 +49,5 @@ s64 current_millis(void);
|
|||
|
||||
INLINE void reset_stdio(void) {}
|
||||
|
||||
/* SEH support. Proceed with caution. */
|
||||
typedef long exception_handler_t(
|
||||
PEXCEPTION_RECORD rec, void *frame, void *context, void *dispatch);
|
||||
long exception_handler(PEXCEPTION_POINTERS pe);
|
||||
|
||||
typedef struct exception_record
|
||||
{
|
||||
struct exception_record *next_handler;
|
||||
void *handler_func;
|
||||
} exception_record_t;
|
||||
|
||||
long exception_handler(PEXCEPTION_RECORD rec, void *frame, void *ctx, void *dispatch);
|
||||
|
||||
DECLARE_PRIMITIVE(open_file);
|
||||
DECLARE_PRIMITIVE(stat);
|
||||
DECLARE_PRIMITIVE(read_dir);
|
||||
DECLARE_PRIMITIVE(cwd);
|
||||
DECLARE_PRIMITIVE(cd);
|
||||
|
|
|
@ -14,19 +14,19 @@ DEFINE_PRIMITIVE(name)
|
|||
|
||||
Becomes
|
||||
|
||||
FASTCALL void primitive_name(CELL word, F_STACK_FRAME *callstack_top)
|
||||
F_FASTCALL void primitive_name(CELL word, F_STACK_FRAME *callstack_top)
|
||||
{
|
||||
stack_chain->callstack_top = callstack_top;
|
||||
... CODE ...
|
||||
}
|
||||
|
||||
On x86, FASTCALL expands into a GCC declaration which forces the two parameters
|
||||
to be passed in registers. This simplifies the quotation compiler and support
|
||||
code in cpu-x86.S. */
|
||||
On x86, F_FASTCALL expands into a GCC declaration which forces the two
|
||||
parameters to be passed in registers. This simplifies the quotation compiler
|
||||
and support code in cpu-x86.S. */
|
||||
#define DEFINE_PRIMITIVE(name) \
|
||||
INLINE void primitive_##name##_impl(void); \
|
||||
\
|
||||
FASTCALL void primitive_##name(CELL word, F_STACK_FRAME *callstack_top) \
|
||||
F_FASTCALL void primitive_##name(CELL word, F_STACK_FRAME *callstack_top) \
|
||||
{ \
|
||||
stack_chain->callstack_top = callstack_top; \
|
||||
primitive_##name##_impl(); \
|
||||
|
@ -36,4 +36,4 @@ code in cpu-x86.S. */
|
|||
|
||||
/* Prototype for header files */
|
||||
#define DECLARE_PRIMITIVE(name) \
|
||||
FASTCALL void primitive_##name(CELL word, F_STACK_FRAME *callstack_top)
|
||||
F_FASTCALL void primitive_##name(CELL word, F_STACK_FRAME *callstack_top)
|
||||
|
|
17
vm/run.c
17
vm/run.c
|
@ -197,7 +197,7 @@ void not_implemented_error(void)
|
|||
}
|
||||
|
||||
/* This function is called from the undefined function in cpu_*.S */
|
||||
FASTCALL void undefined_error(CELL word, F_STACK_FRAME *callstack_top)
|
||||
F_FASTCALL void undefined_error(CELL word, F_STACK_FRAME *callstack_top)
|
||||
{
|
||||
stack_chain->callstack_top = callstack_top;
|
||||
general_error(ERROR_UNDEFINED_WORD,word,F,NULL);
|
||||
|
@ -244,6 +244,21 @@ void divide_by_zero_error(F_STACK_FRAME *native_stack)
|
|||
general_error(ERROR_DIVIDE_BY_ZERO,F,F,native_stack);
|
||||
}
|
||||
|
||||
void memory_signal_handler_impl(void)
|
||||
{
|
||||
memory_protection_error(signal_fault_addr,signal_callstack_top);
|
||||
}
|
||||
|
||||
void divide_by_zero_signal_handler_impl(void)
|
||||
{
|
||||
divide_by_zero_error(signal_callstack_top);
|
||||
}
|
||||
|
||||
void misc_signal_handler_impl(void)
|
||||
{
|
||||
signal_error(signal_number,signal_callstack_top);
|
||||
}
|
||||
|
||||
DEFINE_PRIMITIVE(throw)
|
||||
{
|
||||
uncurry(dpop());
|
||||
|
|
2
vm/run.h
2
vm/run.h
|
@ -197,7 +197,7 @@ void signal_error(int signal, F_STACK_FRAME *native_stack);
|
|||
void type_error(CELL type, CELL tagged);
|
||||
void not_implemented_error(void);
|
||||
|
||||
FASTCALL void undefined_error(CELL word, F_STACK_FRAME *callstack_top);
|
||||
F_FASTCALL void undefined_error(CELL word, F_STACK_FRAME *callstack_top);
|
||||
|
||||
DECLARE_PRIMITIVE(throw);
|
||||
|
||||
|
|
|
@ -19,7 +19,7 @@ void fix_stacks(void)
|
|||
}
|
||||
|
||||
/* called before entry into Factor code. */
|
||||
FASTCALL void save_callstack_bottom(F_STACK_FRAME *callstack_bottom)
|
||||
F_FASTCALL void save_callstack_bottom(F_STACK_FRAME *callstack_bottom)
|
||||
{
|
||||
stack_chain->callstack_bottom = callstack_bottom;
|
||||
}
|
||||
|
|
|
@ -48,7 +48,7 @@ CELL ds_size, rs_size;
|
|||
void reset_datastack(void);
|
||||
void reset_retainstack(void);
|
||||
void fix_stacks(void);
|
||||
FASTCALL void save_callstack_bottom(F_STACK_FRAME *callstack_bottom);
|
||||
F_FASTCALL void save_callstack_bottom(F_STACK_FRAME *callstack_bottom);
|
||||
DLLEXPORT void save_stacks(void);
|
||||
DLLEXPORT void nest_stacks(void);
|
||||
DLLEXPORT void unnest_stacks(void);
|
||||
|
|
Loading…
Reference in New Issue