Menu
▾
▴
[Sbcl-commits] master: Port to x86-64 versions of Windows
|
From: David L. <lic...@us...> - 2012-12-05 16:42:26
|
The branch "master" has been updated in SBCL:
via 26ac616b6783b8841ccda8b4f1caa7d898d91b86 (commit)
from f93e3064ca572904ee399b77642ba52f2edfce3e (commit)
- Log -----------------------------------------------------------------
commit 26ac616b6783b8841ccda8b4f1caa7d898d91b86
Author: David Lichteblau <da...@li...>
Date: Mon Nov 12 17:32:51 2012 +0100
Port to x86-64 versions of Windows
- Microsoft x86-64 calling convention differences compared to the
the System V ABI: Argument passing registers; shadow space.
- Inform gcc that we are using the System V ABI for a few functions.
- Define long, unsigned-long to be 32 bit. This change just falls
into place now, since incompatible code had been adjusted earlier.
- Use VEH, not SEH.
- No pseudo atomic needed around inline allocation, but tweak alloc().
- Use the gencgc space alignment that also works on win32 x86.
- Factor "function end breakpoint" handling out of the sigtrap handler.
Beware known bugs, manifested as hangs during threads.impure.lisp,
happening rather frequently with 64 bit builds and at least much
less frequently (or not at all) with 32 bit binaries on the same
version of Windows, tested on Server 2012. (All credit for features
goes to Anton, all bugs are my fault.)
Thanks to Anton Kovalenko.
---
src/code/irrat.lisp | 44 +++++-----
src/code/target-c-call.lisp | 7 ++
src/compiler/generic/genesis.lisp | 9 ++-
src/compiler/generic/objdef.lisp | 4 +-
src/compiler/x86-64/c-call.lisp | 39 ++++++---
src/compiler/x86-64/macros.lisp | 3 +
src/compiler/x86-64/parms.lisp | 9 ++-
src/compiler/x86-64/vm.lisp | 5 +-
src/runtime/Config.x86-64-win32 | 59 +++++++++++++
src/runtime/arch.h | 6 +-
src/runtime/funcall.c | 6 +-
src/runtime/gc.h | 4 +
src/runtime/gencgc.c | 23 ++++-
src/runtime/mswin64.def | 2 +
src/runtime/os.h | 5 +
src/runtime/pthreads_win32.h | 5 +-
src/runtime/run-program.c | 4 +-
src/runtime/runtime.h | 11 +++
src/runtime/thread.c | 6 +-
src/runtime/win32-os.c | 90 +++++++++++++++++--
src/runtime/x86-64-arch.c | 53 +++++++-----
src/runtime/x86-64-arch.h | 2 +
src/runtime/x86-64-assem.S | 8 +-
src/runtime/x86-64-win32-os.c | 172 +++++++++++++++++++++++++++++++++++++
src/runtime/x86-64-win32-os.h | 24 +++++
25 files changed, 516 insertions(+), 84 deletions(-)
diff --git a/src/code/irrat.lisp b/src/code/irrat.lisp
index 1c684ac..86940c3 100644
--- a/src/code/irrat.lisp
+++ b/src/code/irrat.lisp
@@ -75,33 +75,37 @@
#!-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)))
@@ -120,7 +124,7 @@
#!-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)
diff --git a/src/code/target-c-call.lisp b/src/code/target-c-call.lisp
index 7a83d10..c978ac8 100644
--- a/src/code/target-c-call.lisp
+++ b/src/code/target-c-call.lisp
@@ -22,13 +22,20 @@
(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)
diff --git a/src/compiler/generic/genesis.lisp b/src/compiler/generic/genesis.lisp
index 9cc373f..3bba5f8 100644
--- a/src/compiler/generic/genesis.lisp
+++ b/src/compiler/generic/genesis.lisp
@@ -2832,7 +2832,11 @@ core and return a descriptor to it."
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))
@@ -2873,7 +2877,8 @@ core and return a descriptor to it."
(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
diff --git a/src/compiler/generic/objdef.lisp b/src/compiler/generic/objdef.lisp
index b3cb447..d3bd635 100644
--- a/src/compiler/generic/objdef.lisp
+++ b/src/compiler/generic/objdef.lisp
@@ -297,8 +297,8 @@
(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"))
diff --git a/src/compiler/x86-64/c-call.lisp b/src/compiler/x86-64/c-call.lisp
index 65ad782..e093930 100644
--- a/src/compiler/x86-64/c-call.lisp
+++ b/src/compiler/x86-64/c-call.lisp
@@ -27,9 +27,13 @@
(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*)))
@@ -48,8 +52,9 @@
(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*)))
@@ -274,6 +279,8 @@
(: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)
@@ -288,6 +295,7 @@
(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
@@ -295,11 +303,13 @@
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
@@ -417,23 +427,24 @@
(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)))
@@ -456,6 +467,7 @@
(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
@@ -468,6 +480,7 @@
((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))
@@ -517,16 +530,18 @@
#!+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)
diff --git a/src/compiler/x86-64/macros.lisp b/src/compiler/x86-64/macros.lisp
index 98337e1..11a06fc 100644
--- a/src/compiler/x86-64/macros.lisp
+++ b/src/compiler/x86-64/macros.lisp
@@ -303,6 +303,9 @@
#!+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
diff --git a/src/compiler/x86-64/parms.lisp b/src/compiler/x86-64/parms.lisp
index bd405c7..f51e4ad 100644
--- a/src/compiler/x86-64/parms.lisp
+++ b/src/compiler/x86-64/parms.lisp
@@ -106,7 +106,14 @@
;;; 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)
diff --git a/src/compiler/x86-64/vm.lisp b/src/compiler/x86-64/vm.lisp
index a19f45c..9295e4e 100644
--- a/src/compiler/x86-64/vm.lisp
+++ b/src/compiler/x86-64/vm.lisp
@@ -170,7 +170,10 @@
(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))
;;;; SB definitions
diff --git a/src/runtime/Config.x86-64-win32 b/src/runtime/Config.x86-64-win32
new file mode 100644
index 0000000..9fe5ce2
--- /dev/null
+++ b/src/runtime/Config.x86-64-win32
@@ -0,0 +1,59 @@
+# 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:
diff --git a/src/runtime/arch.h b/src/runtime/arch.h
index 2e62266..1a8cf69 100644
--- a/src/runtime/arch.h
+++ b/src/runtime/arch.h
@@ -44,10 +44,10 @@ extern lispobj funcall3(lispobj function, lispobj arg0, lispobj arg1,
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
diff --git a/src/runtime/funcall.c b/src/runtime/funcall.c
index 9236a48..4eb1d72 100644
--- a/src/runtime/funcall.c
+++ b/src/runtime/funcall.c
@@ -22,7 +22,11 @@
#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)
diff --git a/src/runtime/gc.h b/src/runtime/gc.h
index 3b0aea0..a028466 100644
--- a/src/runtime/gc.h
+++ b/src/runtime/gc.h
@@ -22,7 +22,11 @@
#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;
diff --git a/src/runtime/gencgc.c b/src/runtime/gencgc.c
index f4cbcc7..5829b5a 100644
--- a/src/runtime/gencgc.c
+++ b/src/runtime/gencgc.c
@@ -597,7 +597,7 @@ report_heap_exhaustion(long available, long requested, struct thread *th)
}
-#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
@@ -4303,13 +4303,28 @@ general_alloc(sword_t nbytes, int page_type_flag)
}
}
-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;
}
/*
diff --git a/src/runtime/mswin64.def b/src/runtime/mswin64.def
new file mode 100644
index 0000000..b5626a9
--- /dev/null
+++ b/src/runtime/mswin64.def
@@ -0,0 +1,2 @@
+EXPORTS
+ log1p
diff --git a/src/runtime/os.h b/src/runtime/os.h
index d6d34bc..50ff643 100644
--- a/src/runtime/os.h
+++ b/src/runtime/os.h
@@ -189,9 +189,14 @@ extern char *os_get_runtime_executable_path(int external_path);
# 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
diff --git a/src/runtime/pthreads_win32.h b/src/runtime/pthreads_win32.h
index 2d4b066..b91c0f9 100644
--- a/src/runtime/pthread |