#!-x86 (def-math-rtn "tan" 1)
#!-x86 (def-math-rtn "atan" 1)
#!-x86 (def-math-rtn "atan2" 2)
-#!-win32
+#!-(and win32 x86)
(progn
(def-math-rtn "acos" 1)
(def-math-rtn "asin" 1)
(def-math-rtn "cosh" 1)
(def-math-rtn "sinh" 1)
(def-math-rtn "tanh" 1)
- (def-math-rtn "asinh" 1)
- (def-math-rtn "acosh" 1)
- (def-math-rtn "atanh" 1))
+ #!-win32
+ (progn
+ (def-math-rtn "asinh" 1)
+ (def-math-rtn "acosh" 1)
+ (def-math-rtn "atanh" 1)))
#!+win32
(progn
- (declaim (inline %asin))
- (defun %asin (number)
- (%atan (/ number (sqrt (- 1 (* number number))))))
- (declaim (inline %acos))
- (defun %acos (number)
- (- (/ pi 2) (%asin number)))
- (declaim (inline %cosh))
- (defun %cosh (number)
- (/ (+ (exp number) (exp (- number))) 2))
- (declaim (inline %sinh))
- (defun %sinh (number)
- (/ (- (exp number) (exp (- number))) 2))
- (declaim (inline %tanh))
- (defun %tanh (number)
- (/ (%sinh number) (%cosh number)))
+ #!-x86-64
+ (progn
+ (declaim (inline %asin))
+ (defun %asin (number)
+ (%atan (/ number (sqrt (- 1 (* number number))))))
+ (declaim (inline %acos))
+ (defun %acos (number)
+ (- (/ pi 2) (%asin number)))
+ (declaim (inline %cosh))
+ (defun %cosh (number)
+ (/ (+ (exp number) (exp (- number))) 2))
+ (declaim (inline %sinh))
+ (defun %sinh (number)
+ (/ (- (exp number) (exp (- number))) 2))
+ (declaim (inline %tanh))
+ (defun %tanh (number)
+ (/ (%sinh number) (%cosh number))))
(declaim (inline %asinh))
(defun %asinh (number)
(log (+ number (sqrt (+ (* number number) 1.0d0))) #.(exp 1.0d0)))
#!-x86 (def-math-rtn "exp" 1)
#!-x86 (def-math-rtn "log" 1)
#!-x86 (def-math-rtn "log10" 1)
-#!-win32(def-math-rtn "pow" 2)
+#!-(and win32 x86) (def-math-rtn "pow" 2)
#!-(or x86 x86-64) (def-math-rtn "sqrt" 1)
#!-win32 (def-math-rtn "hypot" 2)
#!-x86 (def-math-rtn "log1p" 1)
(define-alien-type char (integer 8))
(define-alien-type short (integer 16))
(define-alien-type int (integer 32))
+#!-(and win32 x86-64)
(define-alien-type long (integer #.sb!vm::n-machine-word-bits))
+#!+(and win32 x86-64)
+(define-alien-type long (integer 32))
+
(define-alien-type long-long (integer 64))
(define-alien-type unsigned-char (unsigned 8))
(define-alien-type unsigned-short (unsigned 16))
(define-alien-type unsigned-int (unsigned 32))
+#!-(and win32 x86-64)
(define-alien-type unsigned-long (unsigned #.sb!vm::n-machine-word-bits))
+#!+(and win32 x86-64)
+(define-alien-type unsigned-long (unsigned 32))
(define-alien-type unsigned-long-long (unsigned 64))
(define-alien-type float single-float)
priority)))
;; machinery for new-style SBCL Lisp-to-C naming
(record-with-translated-name (priority large)
- (record (c-name name) priority (if large "LU" "")))
+ (record (c-name name) priority
+ (if large
+ #!+(and win32 x86-64) "LLU"
+ #!-(and win32 x86-64) "LU"
+ "")))
(maybe-record-with-translated-name (suffixes priority &key large)
(when (some (lambda (suffix)
(tailwise-equal name suffix))
(push (list (c-symbol-name c)
9
(symbol-value c)
- "LU"
+ #!+(and win32 x86-64) "LLU"
+ #!-(and win32 x86-64) "LU"
nil)
constants))
(setf constants
(current-cont :c-type #!-alpha "lispobj *" #!+alpha "u32")
#!-(or x86 x86-64) current-code
entry-pc
- #!+win32 next-seh-frame
- #!+win32 seh-frame-handler
+ #!+(and win32 x86) next-seh-frame
+ #!+(and win32 x86) seh-frame-handler
tag
(previous-catch :c-type #!-alpha "struct catch_block *" #!+alpha "u32"))
(xmm-args 0)
(stack-frame-size 0))
+(defconstant max-int-args #.(length *c-call-register-arg-offsets*))
+(defconstant max-xmm-args #!+win32 4 #!-win32 8)
+
(defun int-arg (state prim-type reg-sc stack-sc)
- (let ((reg-args (arg-state-register-args state)))
- (cond ((< reg-args 6)
+ (let ((reg-args (max (arg-state-register-args state)
+ #!+win32 (arg-state-xmm-args state))))
+ (cond ((< reg-args max-int-args)
(setf (arg-state-register-args state) (1+ reg-args))
(my-make-wired-tn prim-type reg-sc
(nth reg-args *c-call-register-arg-offsets*)))
(int-arg state 'system-area-pointer 'sap-reg 'sap-stack))
(defun float-arg (state prim-type reg-sc stack-sc)
- (let ((xmm-args (arg-state-xmm-args state)))
- (cond ((< xmm-args 8)
+ (let ((xmm-args (max (arg-state-xmm-args state)
+ #!+win32 (arg-state-register-args state))))
+ (cond ((< xmm-args max-xmm-args)
(setf (arg-state-xmm-args state) (1+ xmm-args))
(my-make-wired-tn prim-type reg-sc
(nth xmm-args *float-regs*)))
(:ignore results
#!+(and sb-safepoint win32) rdi
#!+(and sb-safepoint win32) rsi
+ #!+win32 args
+ #!+win32 rax
#!+sb-safepoint r15
#!+sb-safepoint r13)
(:vop-var vop)
(let ((label (gen-label)))
(inst lea r14 (make-fixup nil :code-object label))
(emit-label label)))
+ #!-win32
;; ABI: AL contains amount of arguments passed in XMM registers
;; for vararg calls.
(move-immediate rax
while tn-ref
count (eq (sb-name (sc-sb (tn-sc (tn-ref-tn tn-ref))))
'float-registers)))
+ #!+win32 (inst sub rsp-tn #x20) ;MS_ABI: shadow zone
#!+sb-safepoint
(progn ;Store SP and PC in thread struct
(storew rsp-tn thread-base-tn thread-saved-csp-offset)
(storew r14 thread-base-tn thread-pc-around-foreign-call-slot))
(inst call function)
+ #!+win32 (inst add rsp-tn #x20) ;MS_ABI: remove shadow space
#!+sb-safepoint
(progn
;; Zeroing out
(error "Too many arguments in callback")))
(let* ((segment (make-segment))
(rax rax-tn)
- #!+(not sb-safepoint) (rcx rcx-tn)
- (rdi rdi-tn)
- (rsi rsi-tn)
+ #!+(or win32 (not sb-safepoint)) (rcx rcx-tn)
+ #!-win32 (rdi rdi-tn)
+ #!-win32 (rsi rsi-tn)
(rdx rdx-tn)
(rbp rbp-tn)
(rsp rsp-tn)
+ #!+win32 (r8 r8-tn)
(xmm0 float0-tn)
([rsp] (make-ea :qword :base rsp :disp 0))
;; How many arguments have been copied
(arg-count 0)
;; How many arguments have been copied from the stack
- (stack-argument-count 0)
+ (stack-argument-count #!-win32 0 #!+win32 4)
(gprs (mapcar (make-tn-maker 'any-reg) *c-call-register-arg-offsets*))
(fprs (mapcar (make-tn-maker 'double-reg)
;; Only 8 first XMM registers are used for
;; passing arguments
- (subseq *float-regs* 0 8))))
+ (subseq *float-regs* 0 #!-win32 8 #!+win32 4))))
(assemble (segment)
;; Make room on the stack for arguments.
(inst sub rsp (* n-word-bytes (length argument-types)))
(incf arg-count)
(cond (integerp
(let ((gpr (pop gprs)))
+ #!+win32 (pop fprs)
;; Argument not in register, copy it from the old
;; stack location to a temporary register.
(unless gpr
((or (alien-single-float-type-p type)
(alien-double-float-type-p type))
(let ((fpr (pop fprs)))
+ #!+win32 (pop gprs)
(cond (fpr
;; Copy from float register to target location.
(inst movq target-tn fpr))
#!+sb-safepoint
(progn
;; arg0 to ENTER-ALIEN-CALLBACK (trampoline index)
- (inst mov rdi (fixnumize index))
+ (inst mov #!-win32 rdi #!+win32 rcx (fixnumize index))
;; arg1 to ENTER-ALIEN-CALLBACK (pointer to argument vector)
- (inst mov rsi rsp)
+ (inst mov #!-win32 rsi #!+win32 rdx rsp)
;; add room on stack for return value
(inst sub rsp 8)
;; arg2 to ENTER-ALIEN-CALLBACK (pointer to return value)
- (inst mov rdx rsp)
+ (inst mov #!-win32 rdx #!+win32 r8 rsp)
;; Make new frame
(inst push rbp)
(inst mov rbp rsp)
+ #!+win32 (inst sub rsp #x20)
+ #!+win32 (inst and rsp #x-20)
;; Call
(inst mov rax (foreign-symbol-address "callback_wrapper_trampoline"))
(inst call rax)
#!+sb-thread
(defmacro pseudo-atomic (&rest forms)
+ #!+win32
+ `(progn ,@forms (emit-safepoint))
+ #!-win32
(with-unique-names (label)
`(let ((,label (gen-label)))
(inst mov (make-ea :qword
;;; The default dynamic space size is lower on OpenBSD to allow SBCL to
;;; run under the default 512M data size limit.
-(!gencgc-space-setup #x20000000 #x1000000000 #!+openbsd #x1bcf0000)
+(!gencgc-space-setup #x20000000
+ #x1000000000
+
+ ;; :default-dynamic-space-size
+ #!+openbsd #x1bcf0000
+
+ ;; :alignment
+ #!+win32 #!+win32 nil #x10000)
(def!constant linkage-table-entry-size 16)
(eval-when (:compile-toplevel :load-toplevel :execute)
(defparameter *register-arg-names* '(rdx rdi rsi)))
(defregset *register-arg-offsets* rdx rdi rsi)
- (defregset *c-call-register-arg-offsets* rdi rsi rdx rcx r8 r9))
+ #!-win32
+ (defregset *c-call-register-arg-offsets* rdi rsi rdx rcx r8 r9)
+ #!+win32
+ (defregset *c-call-register-arg-offsets* rcx rdx r8 r9))
\f
;;;; SB definitions
--- /dev/null
+# This software is part of the SBCL system. See the README file for
+# more information.
+#
+# This software is derived from the CMU CL system, which was
+# written at Carnegie Mellon University and released into the
+# public domain. The software is in the public domain and is
+# provided with absolutely no warranty. See the COPYING and CREDITS
+# files for more information.
+
+TARGET=sbcl.exe
+
+ASSEM_SRC = x86-64-assem.S
+ARCH_SRC = x86-64-arch.c
+
+OS_SRC = win32-os.c x86-64-win32-os.c os-common.c pthreads_win32.c
+OS_OBJS = # sbcl-win.res.o
+
+# The "--Wl,--export-dynamic" flags are here to help people
+# experimenting with callbacks from C to SBCL, by allowing linkage to
+# SBCL src/runtime/*.c symbols from C. Work on this is good, but it's
+# definitely bleeding edge and not particularly stable. In particular,
+# not only are the workarounds for the GC relocating Lisp code and
+# data unstable, but even the basic calling convention might end up
+# being unstable. Unless you want to do some masochistic maintenance
+# work when new releases of SBCL come out, please don't try to build
+# real code on this until a coherent stable interface has been added.
+# (You *are* encouraged to design and implement a coherent stable
+# interface, though.:-| As far as I (WHN 2002-05-19) know, no one is
+# working on one and it would be a nice thing to have.)
+LINKFLAGS = -Wl,-export-all-symbols -Wl,mswin64.def -Wl,mswin.def
+
+
+OS_LIBS = -l ws2_32
+ifdef LISP_FEATURE_SB_CORE_COMPRESSION
+ OS_LIBS += -lz
+endif
+
+GC_SRC = gencgc.c
+
+CFLAGS = -g -W -Wall \
+ -Wno-unused-function \
+ -fno-omit-frame-pointer \
+ -O5 -m64 -DWINVER=0x0501 \
+ -D__W32API_USE_DLLIMPORT__
+
+ASFLAGS = $(CFLAGS)
+
+CPP = cpp
+CC = gcc
+LD = ld
+NM = nm
+RC = windres
+
+%.res.o: %.rc
+ $(RC) -o "$@" "$<"
+
+# Nothing to do for after-grovel-headers.
+.PHONY: after-grovel-headers
+after-grovel-headers:
lispobj arg2);
extern lispobj *component_ptr_from_pc(lispobj *pc);
-extern void fpu_save(void *);
-extern void fpu_restore(void *);
+extern void AMD64_SYSV_ABI fpu_save(void *);
+extern void AMD64_SYSV_ABI fpu_restore(void *);
-#ifdef LISP_FEATURE_X86
+#if defined(LISP_FEATURE_X86)||defined(LISP_FEATURE_X86_64)
extern unsigned int * single_stepping;
extern void restore_breakpoint_from_single_step(os_context_t * context);
#endif
#include "interrupt.h"
/* This is implemented in assembly language and called from C: */
-extern lispobj call_into_lisp(lispobj fun, lispobj *args, int nargs);
+extern lispobj call_into_lisp(lispobj fun, lispobj *args, int nargs)
+#ifdef LISP_FEATURE_X86_64
+ __attribute__((sysv_abi))
+#endif
+ ;
static inline lispobj
safe_call_into_lisp(lispobj fun, lispobj *args, int nargs)
#define PAGE_BYTES BACKEND_PAGE_BYTES
typedef intptr_t page_index_t;
+#ifdef LISP_FEATURE_WIN32
+#define PAGE_INDEX_FMT "Id"
+#else
#define PAGE_INDEX_FMT "ld"
+#endif
typedef signed char generation_index_t;
}
\f
-#if defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64)
+#if defined(LISP_FEATURE_X86)
void fast_bzero(void*, size_t); /* in <arch>-assem.S */
#endif
}
}
-lispobj *
+lispobj AMD64_SYSV_ABI *
alloc(long nbytes)
{
-#if !(defined(LISP_FEATURE_WIN32) && defined(LISP_FEATURE_SB_THREAD))
+#ifdef LISP_FEATURE_WIN32
+ /* WIN32 is currently the only platform where inline allocation is
+ * not pseudo atomic. */
+ struct thread *self = arch_os_get_current_thread();
+ int was_pseudo_atomic = get_pseudo_atomic_atomic(self);
+ if (!was_pseudo_atomic)
+ set_pseudo_atomic_atomic(self);
+#else
gc_assert(get_pseudo_atomic_atomic(arch_os_get_current_thread()));
#endif
- return general_alloc(nbytes, BOXED_PAGE_FLAG);
+
+ lispobj *result = general_alloc(nbytes, BOXED_PAGE_FLAG);
+
+#ifdef LISP_FEATURE_WIN32
+ if (!was_pseudo_atomic)
+ clear_pseudo_atomic_atomic(self);
+#endif
+
+ return result;
}
\f
/*
--- /dev/null
+EXPORTS
+ log1p
# define OS_VM_SIZE_FMT "u"
# define OS_VM_SIZE_FMTX "x"
#else
+#if defined(LISP_FEATURE_SB_WIN32)
+# define OS_VM_SIZE_FMT "Iu"
+# define OS_VM_SIZE_FMTX "Ix"
+#else
# define OS_VM_SIZE_FMT "lu"
# define OS_VM_SIZE_FMTX "lx"
#endif
+#endif
/* FIXME: this is not the right place for this, but here we have
* a convenient base type to hand. If it turns out we can just use
int pthread_cond_timedwait(pthread_cond_t * cond, pthread_mutex_t * mutex, const struct timespec * abstime);
int pthread_cond_wait(pthread_cond_t * cond, pthread_mutex_t * mutex);
-#define ETIMEDOUT 123 //Something
+/* some MinGWs seem to include it, others not: */
+#ifndef ETIMEDOUT
+# define ETIMEDOUT 123 //Something
+#endif
int sched_yield();
/* Spawn process given on the command line*/
if (search)
- hProcess = (HANDLE) spawnvp ( wait_mode, program, argv );
+ hProcess = (HANDLE) spawnvp ( wait_mode, program, (char* const* )argv );
else
- hProcess = (HANDLE) spawnv ( wait_mode, program, argv );
+ hProcess = (HANDLE) spawnv ( wait_mode, program, (char* const* )argv );
/* Now that the process is launched, replace the original
* in/out/err handles and close the backups. */
/* even on alpha, int happens to be 4 bytes. long is longer. */
/* FIXME: these names really shouldn't reflect their length and this
is not quite right for some of the FFI stuff */
+#if defined(LISP_FEATURE_WIN32)&&defined(LISP_FEATURE_X86_64)
+typedef unsigned long long u64;
+typedef signed long long s64;
+#else
typedef unsigned long u64;
typedef signed long s64;
+#endif
typedef unsigned int u32;
typedef signed int s32;
/* this is an integral type the same length as a machine pointer */
typedef uintptr_t pointer_sized_uint_t;
+#ifdef _WIN64
+#define AMD64_SYSV_ABI __attribute__((sysv_abi))
+#else
+#define AMD64_SYSV_ABI
+#endif
+
#include <sys/types.h>
#if defined(LISP_FEATURE_SB_THREAD)
#endif
#if defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64)
-extern lispobj call_into_lisp_first_time(lispobj fun, lispobj *args, int nargs);
+extern lispobj call_into_lisp_first_time(lispobj fun, lispobj *args, int nargs)
+# ifdef LISP_FEATURE_X86_64
+ __attribute__((sysv_abi))
+# endif
+ ;
#endif
static void
}
#endif /* LISP_FEATURE_SB_THREAD */
+
+#ifdef LISP_FEATURE_X86_64
+/* Windows has 32-bit 'longs', so printf...%lX (and other %l patterns) doesn't
+ * work well with address-sized values, like it's done all over the place in
+ * SBCL. And msvcrt uses I64, not LL, for printing long longs.
+ *
+ * I've already had enough search/replace with longs/words/intptr_t for today,
+ * so I prefer to solve this problem with a format string translator. */
+
+/* There is (will be) defines for printf and friends. */
+
+static int translating_vfprintf(FILE*stream, const char *fmt, va_list args)
+{
+ char translated[1024];
+ int i=0, delta = 0;
+
+ while (fmt[i-delta] && i<sizeof(translated)-1) {
+ if((fmt[i-delta]=='%')&&
+ (fmt[i-delta+1]=='l')) {
+ translated[i++]='%';
+ translated[i++]='I';
+ translated[i++]='6';
+ translated[i++]='4';
+ delta += 2;
+ } else {
+ translated[i]=fmt[i-delta];
+ ++i;
+ }
+ }
+ translated[i++]=0;
+ return vfprintf(stream,translated,args);
+}
+
+int printf(const char*fmt,...)
+{
+ va_list args;
+ va_start(args,fmt);
+ return translating_vfprintf(stdout,fmt,args);
+}
+int fprintf(FILE*stream,const char*fmt,...)
+{
+ va_list args;
+ va_start(args,fmt);
+ return translating_vfprintf(stream,fmt,args);
+}
+
+#endif
+
int os_number_of_processors = 1;
BOOL WINAPI CancelIoEx(HANDLE handle, LPOVERLAPPED overlapped);
#endif
-#if defined(LISP_FEATURE_X86)
static int
handle_single_step(os_context_t *ctx)
{
/* We are doing a displaced instruction. At least function
* end breakpoints use this. */
- WITH_GC_AT_SAFEPOINTS_ONLY () /* Todo: Is it really gc-unsafe? */
- restore_breakpoint_from_single_step(ctx);
+ restore_breakpoint_from_single_step(ctx);
return 0;
}
-#endif
#ifdef LISP_FEATURE_UD2_BREAKPOINTS
#define SBCL_EXCEPTION_BREAKPOINT EXCEPTION_ILLEGAL_INSTRUCTION
handle_breakpoint_trap(os_context_t *ctx, struct thread* self)
{
#ifdef LISP_FEATURE_UD2_BREAKPOINTS
- if (((unsigned short *)((ctx->win32_context)->Eip))[0] != 0x0b0f)
+ if (((unsigned short *)*os_context_pc_addr(ctx))[0] != 0x0b0f)
return -1;
#endif
rc = handle_breakpoint_trap(ctx, self);
break;
-#if defined(LISP_FEATURE_X86)
case EXCEPTION_SINGLE_STEP:
rc = handle_single_step(ctx);
break;
-#endif
default:
rc = -1;
return ExceptionContinueExecution;
}
+#ifdef LISP_FEATURE_X86_64
+
+#define RESTORING_ERRNO() \
+ int sbcl__lastErrno = errno; \
+ RUN_BODY_ONCE(restoring_errno, errno = sbcl__lastErrno)
+
+LONG
+veh(EXCEPTION_POINTERS *ep)
+{
+ EXCEPTION_DISPOSITION disp;
+
+ RESTORING_ERRNO() {
+ if (!pthread_self())
+ return EXCEPTION_CONTINUE_SEARCH;
+ }
+
+ disp = handle_exception(ep->ExceptionRecord,0,ep->ContextRecord,0);
+
+ switch (disp)
+ {
+ case ExceptionContinueExecution:
+ return EXCEPTION_CONTINUE_EXECUTION;
+ case ExceptionContinueSearch:
+ return EXCEPTION_CONTINUE_SEARCH;
+ default:
+ fprintf(stderr,"Exception handler is mad\n");
+ ExitProcess(0);
+ }
+}
+#endif
+
void
wos_install_interrupt_handlers(struct lisp_exception_frame *handler)
{
return read_bytes;
}
-void __stdcall RtlUnwind(void *, void *, void *, void *); /* I don't have winternl.h */
-
/* We used to have a scratch() function listing all symbols needed by
* Lisp. Much rejoicing commenced upon its removal. However, I would
* like cold init to fail aggressively when encountering unused symbols.
void arch_init(void)
{}
+#ifndef _WIN64
os_vm_address_t
arch_get_bad_addr(int sig, siginfo_t *code, os_context_t *context)
{
return (os_vm_address_t)code->si_addr;
}
+#endif
\f
/*
return &context->sc_rflags;
#elif defined __NetBSD__
return CONTEXT_ADDR_FROM_STEM(RFLAGS);
+#elif defined _WIN64
+ return (os_context_register_t*)&context->win32_context->EFlags;
#else
#error unsupported OS
#endif
\f
void
-sigtrap_handler(int signal, siginfo_t *info, os_context_t *context)
+restore_breakpoint_from_single_step(os_context_t * context)
{
- unsigned int trap;
-
- if (single_stepping) {
#ifdef CANNOT_GET_TO_SINGLE_STEP_FLAG
- /* Un-install single step helper instructions. */
- *(single_stepping-3) = single_step_save1;
- *(single_stepping-2) = single_step_save2;
- *(single_stepping-1) = single_step_save3;
+ /* Un-install single step helper instructions. */
+ *(single_stepping-3) = single_step_save1;
+ *(single_stepping-2) = single_step_save2;
+ *(single_stepping-1) = single_step_save3;
#else
- *context_eflags_addr(context) ^= 0x100;
+ *context_eflags_addr(context) &= ~0x100;
#endif
- /* Re-install the breakpoint if possible. */
- if (((char *)*os_context_pc_addr(context) >
- (char *)single_stepping) &&
- ((char *)*os_context_pc_addr(context) <=
- (char *)single_stepping + BREAKPOINT_WIDTH)) {
- fprintf(stderr, "warning: couldn't reinstall breakpoint\n");
- } else {
- arch_install_breakpoint(single_stepping);
- }
+ /* Re-install the breakpoint if possible. */
+ if (((char *)*os_context_pc_addr(context) >
+ (char *)single_stepping) &&
+ ((char *)*os_context_pc_addr(context) <=
+ (char *)single_stepping + BREAKPOINT_WIDTH)) {
+ fprintf(stderr, "warning: couldn't reinstall breakpoint\n");
+ } else {
+ arch_install_breakpoint(single_stepping);
+ }
+
+ single_stepping = NULL;
+ return;
+}
+
+void
+sigtrap_handler(int signal, siginfo_t *info, os_context_t *context)
+{
+ unsigned int trap;
- single_stepping = NULL;
+ if (single_stepping) {
+ restore_breakpoint_from_single_step(context);
return;
}
* OS I haven't tested on?) and we have to go back to the old CMU
* CL way, I hope there will at least be a comment to explain
* why.. -- WHN 2001-06-07 */
-#if !defined(LISP_FEATURE_MACH_EXCEPTION_HANDLER)
+#if !defined(LISP_FEATURE_MACH_EXCEPTION_HANDLER) && !defined(LISP_FEATURE_WIN32)
undoably_install_low_level_interrupt_handler(SIGILL , sigill_handler);
undoably_install_low_level_interrupt_handler(SIGTRAP, sigtrap_handler);
#endif
-#ifdef X86_64_SIGFPE_FIXUP
+#if defined(X86_64_SIGFPE_FIXUP) && !defined(LISP_FEATURE_WIN32)
undoably_install_low_level_interrupt_handler(SIGFPE, sigfpe_handler);
#endif
return old_value;
}
+extern void AMD64_SYSV_ABI fast_bzero(void *, size_t);
+
#endif /* _X86_64_ARCH_H */
#include "genesis/thread.h"
/* Minimize conditionalization for different OS naming schemes. */
-#if defined __linux__ || defined __FreeBSD__ || defined __OpenBSD__ || defined __NetBSD__ || defined __sun
+#if defined __linux__ || defined __FreeBSD__ || defined __OpenBSD__ || defined __NetBSD__ || defined __sun || defined _WIN64
#define GNAME(var) var
#else
#define GNAME(var) _##var
/* Get the right type of alignment. Linux, FreeBSD and OpenBSD
* want alignment in bytes. */
-#if defined(__linux__) || defined(__FreeBSD__) || defined(__OpenBSD__) || defined __NetBSD__ || defined(__sun)
+#if defined(__linux__) || defined(__FreeBSD__) || defined(__OpenBSD__) || defined __NetBSD__ || defined(__sun) || defined _WIN64
#define align_4byte 4
#define align_8byte 8
#define align_16byte 16
.align align_16byte,0x90
.globl GNAME(funcallable_instance_tramp)
#if !defined(LISP_FEATURE_DARWIN)
- .type GNAME(funcallable_instance_tramp),@function
+ TYPE(GNAME(funcallable_instance_tramp))
#endif
GNAME(funcallable_instance_tramp):
mov FUNCALLABLE_INSTANCE_FUNCTION_OFFSET(%rax),%rax
* now, the first word of it contains the address to jump to. */
jmp *CLOSURE_FUN_OFFSET(%rax)
#if !defined(LISP_FEATURE_DARWIN)
- .size GNAME(funcallable_instance_tramp), .-GNAME(funcallable_instance_tramp)
+ SIZE(GNAME(funcallable_instance_tramp))
#endif
/*
* fun-end breakpoint magic
--- /dev/null
+/*
+ * The x86 Win32 incarnation of arch-dependent OS-dependent routines.
+ * See also "win32-os.c".
+ */
+
+/*
+ * This software is part of the SBCL system. See the README file for
+ * more information.
+ *
+ * This software is derived from the CMU CL system, which was
+ * written at Carnegie Mellon University and released into the
+ * public domain. The software is in the public domain and is
+ * provided with absolutely no warranty. See the COPYING and CREDITS
+ * files for more information.
+ */
+
+#include <stdio.h>
+#include <stddef.h>
+#include <sys/param.h>
+#include <sys/file.h>
+#include <sys/types.h>
+#include <unistd.h>
+#include <errno.h>
+
+#include "os.h"
+#include "arch.h"
+#include "globals.h"
+#include "interrupt.h"
+#include "interr.h"
+#include "lispregs.h"
+#include "sbcl.h"
+
+#include <sys/types.h>
+#include "runtime.h"
+#include <sys/time.h>
+#include <sys/stat.h>
+#include <unistd.h>
+#include "thread.h" /* dynamic_values_bytes */
+#include "cpputil.h"
+
+#include "validate.h"
+size_t os_vm_page_size;
+
+int arch_os_thread_init(struct thread *thread)
+{
+ {
+ void *top_exception_frame;
+ void *cur_stack_end;
+ void *cur_stack_start;
+ MEMORY_BASIC_INFORMATION stack_memory;
+
+ asm volatile ("mov %%gs:0,%0": "=r" (top_exception_frame));
+ asm volatile ("mov %%gs:8,%0": "=r" (cur_stack_end));
+
+ /* Can't pull stack start from fs:4 or fs:8 or whatever,
+ * because that's only what currently has memory behind
+ * it from being used, so do a quick VirtualQuery() and
+ * grab the AllocationBase. -AB 2006/11/25
+ */
+
+ if (!VirtualQuery(&stack_memory, &stack_memory, sizeof(stack_memory))) {
+ fprintf(stderr, "VirtualQuery: 0x%lx.\n", GetLastError());
+ lose("Could not query stack memory information.");
+ }
+
+ cur_stack_start = stack_memory.AllocationBase
+ /* OS provides its own guard page at the stack start,
+ and we have ours. Do you really want to see how they interact? */
+ + os_vm_page_size;
+
+ /* We use top_exception_frame rather than cur_stack_end to
+ * elide the last few (boring) stack entries at the bottom of
+ * the backtrace.
+ */
+ thread->control_stack_start = cur_stack_start;
+ thread->control_stack_end = cur_stack_end;
+
+#ifndef LISP_FEATURE_SB_THREAD
+ /*
+ * Theoretically, threaded SBCL binds directly against
+ * the thread structure for these values. We don't do
+ * threads yet, but we'll probably do the same. We do
+ * need to reset these, though, because they were
+ * initialized based on the wrong stack space.
+ */
+ SetSymbolValue(CONTROL_STACK_START,(lispobj)thread->control_stack_start,thread);
+ SetSymbolValue(CONTROL_STACK_END,(lispobj)thread->control_stack_end,thread);
+#endif
+ }
+
+#ifdef LISP_FEATURE_SB_THREAD
+ pthread_setspecific(specials,thread);
+#endif
+ return 1;
+}
+
+/* free any arch/os-specific resources used by thread, which is now
+ * defunct. Not called on live threads
+ */
+
+int arch_os_thread_cleanup(struct thread *thread) {
+ return 0;
+}
+
+#if defined(LISP_FEATURE_SB_THREAD)
+sigset_t *os_context_sigmask_addr(os_context_t *context)
+{
+ return &context->sigmask;
+}
+#endif
+
+os_context_register_t *
+os_context_register_addr(os_context_t *context, int offset)
+{
+ static const size_t offsets[16] = {
+ offsetof(CONTEXT,Rax),
+ offsetof(CONTEXT,Rcx),
+ offsetof(CONTEXT,Rdx),
+ offsetof(CONTEXT,Rbx),
+ offsetof(CONTEXT,Rsp),
+ offsetof(CONTEXT,Rbp),
+ offsetof(CONTEXT,Rsi),
+ offsetof(CONTEXT,Rdi),
+ offsetof(CONTEXT,R8),
+ offsetof(CONTEXT,R9),
+ offsetof(CONTEXT,R10),
+ offsetof(CONTEXT,R11),
+ offsetof(CONTEXT,R12),
+ offsetof(CONTEXT,R13),
+ offsetof(CONTEXT,R14),
+ offsetof(CONTEXT,R15),
+ };
+ return
+ (offset >= 0 && offset < 32) ?
+ ((void*)(context->win32_context)) + offsets[offset>>1] : 0;
+}
+
+os_context_register_t *
+os_context_pc_addr(os_context_t *context)
+{
+ return (void*)&context->win32_context->Rip; /* REG_EIP */
+}
+
+os_context_register_t *
+os_context_sp_addr(os_context_t *context)
+{
+ return (void*)&context->win32_context->Rsp; /* REG_UESP */
+}
+
+os_context_register_t *
+os_context_fp_addr(os_context_t *context)
+{
+ return (void*)&context->win32_context->Rbp; /* REG_EBP */
+}
+
+unsigned long
+os_context_fp_control(os_context_t *context)
+{
+ return ((((context->win32_context->FloatSave.ControlWord) & 0xffff) ^ 0x3f) |
+ (((context->win32_context->FloatSave.StatusWord) & 0xffff) << 16));
+}
+
+void
+os_restore_fp_control(os_context_t *context)
+{
+ asm ("fldcw %0" : : "m" (context->win32_context->FloatSave.ControlWord));
+}
+
+void
+os_flush_icache(os_vm_address_t address, os_vm_size_t length)
+{
+}
--- /dev/null
+#ifndef _X86_64_WIN32_OS_H
+#define _X86_64_WIN32_OS_H
+
+typedef struct os_context_t {
+ CONTEXT* win32_context;
+ sigset_t sigmask;
+} os_context_t;
+
+typedef intptr_t os_context_register_t;
+
+static inline os_context_t *arch_os_get_context(void **void_context)
+{
+ return (os_context_t *) *void_context;
+}
+
+static inline DWORD NT_GetLastError() {
+ return GetLastError();
+}
+
+unsigned long os_context_fp_control(os_context_t *context);
+void os_restore_fp_control(os_context_t *context);
+os_context_register_t * os_context_fp_addr(os_context_t *context);
+
+#endif /* _X86_64_WIN32_OS_H */
projects / sbcl.git / commitdiff