Support unwinding the stack past call_into_lisp on Windows

lib/CMakeLists.txt

@@ -1,12 +1,12 @@
 cmake_minimum_required(VERSION 3.12)
 
-project(libsbcl_librarian C)
+project(libsbcl_librarian C ASM)
 
 include(GNUInstallDirs)
 
 set(CMAKE_INCLUDE_CURRENT_DIR ON)
 
-add_library(sbcl_librarian SHARED sbcl_librarian.c sbcl_librarian.h sbcl_librarian_err.h entry_point.c)
+add_library(sbcl_librarian SHARED sbcl_librarian.c sbcl_librarian_thunks.S sbcl_librarian.h sbcl_librarian_err.h entry_point.c)
 if(WIN32)
 # DLLs go to the bin/ directory on Windows
 target_link_directories(sbcl_librarian PRIVATE $ENV{BUILD_PREFIX}/Library/bin)
@@ -28,7 +28,7 @@ endif()
 
 # Generate the core file and C bindings
 add_custom_command(
-  OUTPUT sbcl_librarian.c sbcl_librarian.h
+  OUTPUT sbcl_librarian.c sbcl_librarian.h sbcl_librarian_thunks.S
   COMMAND ${CMAKE_COMMAND} -E env CL_SOURCE_REGISTRY=${CMAKE_CURRENT_SOURCE_DIR}/..// ${SBCL} --script ${CMAKE_CURRENT_SOURCE_DIR}/generate-bindings.lisp
   WORKING_DIRECTORY ${CMAKE_CURRENT_BINARY_DIR}
 )

lib/entry_point.c

@@ -18,6 +18,9 @@ __thread intptr_t _fatal_lisp_error_handler[5];
 intptr_t *fatal_lisp_error_handler(void) {
     return _fatal_lisp_error_handler;
 }
+
+int lisp_calling_context_tls_index;
+__thread struct unwind_context lisp_calling_context;
 #else
 # include <dlfcn.h>
 
@@ -79,6 +82,10 @@ BOOL WINAPI DllMain(HINSTANCE hinstDLL, DWORD fdwReason, LPVOID lpvReserved)
 
         GetModuleFileNameA(hinstDLL, libsbcl_librarian_path, BUF_SIZE);
         do_initialize_lisp(libsbcl_librarian_path);
+        lisp_calling_context_tls_index = TlsAlloc();
+        TlsSetValue(lisp_calling_context_tls_index, &lisp_calling_context);
+    } else if (fdwReason == DLL_THREAD_ATTACH) {
+        TlsSetValue(lisp_calling_context_tls_index, &lisp_calling_context);
     }
 
     return TRUE;

lib/generate-bindings.lisp

@@ -19,12 +19,18 @@
 
 (in-package #:sbcl-librarian/lib)
 
+(define-api unwind-context (:function-prefix "")
+  (:literal "#include <Windows.h>")
+  (:literal "struct unwind_context { DWORD64 Rip, Rsp, Rbp; };"))
+
 (define-aggregate-library sbcl-librarian (:function-linkage "LIBSBCL_LIBRARIAN_API")
   diagnostics
   environment
   errors
   handles
-  loader)
+  loader
+  #+win32
+  unwind-context)
 
 ;;; BEGIN HACKS
 

lib/sbcl_librarian_err.h

@@ -74,6 +74,9 @@ extern __thread LIBSBCL_LIBRARIAN_ERR_API jmp_buf fatal_lisp_error_handler;
 
 extern int LIBSBCL_LIBRARIAN_ERR_API fatal_sbcl_error_occurred;
 extern int LIBSBCL_LIBRARIAN_ERR_API initialized;
+#ifdef _WIN32
+extern int LIBSBCL_LIBRARIAN_ERR_API lisp_calling_context_tls_index;
+#endif
 extern void ldb_monitor(void);
 
 typedef enum {

src/bindings.lisp

@@ -50,7 +50,9 @@
                                              :function-prefix (api-function-prefix api)
                                              :error-map (api-error-map api))))))))))
 
-(defun write-api-to-source (api linkage stream)
+(defun write-api-to-source (api linkage stream thunk-stream)
+  #-win32
+  (declare (ignore thunk-stream))
   (dolist (spec (api-specs api))
     (destructuring-bind (kind &rest things) spec
       (ecase kind
@@ -59,7 +61,14 @@
         (:function
          (dolist (spec things)
            (destructuring-bind (name result-type typed-lambda-list) spec
-             (format stream "~A;~%~A~%"
+             (format stream "~A;~%~A;~%~A~%"
+                     (c-function-declaration name result-type typed-lambda-list
+                                             :datap nil
+                                             :externp t
+                                             :linkage linkage
+                                             :function-prefix (api-function-prefix api)
+                                             :c-prefix "_unwind_thunk_"
+                                             :error-map (api-error-map api))
                      (c-function-declaration name result-type typed-lambda-list
                                              :datap t
                                              :externp nil
@@ -69,7 +78,12 @@
                                              :error-map (api-error-map api))
                      (c-function-definition name result-type typed-lambda-list
                                             :function-prefix (api-function-prefix api)
-                                            :error-map (api-error-map api))))))))))
+                                            :error-map (api-error-map api)))
+             #+win32
+             (format thunk-stream "~A~%"
+                     (unwind-thunk-definition
+                      (callable-name-with-c-prefix name (api-function-prefix api))
+                      (length typed-lambda-list))))))))))
 
 (defun write-init-function (name linkage stream &optional (initialize-lisp-args nil))
   (terpri stream)
@@ -92,6 +106,7 @@
   (let* ((c-name (library-c-name library))
          (header-name (concatenate 'string c-name ".h"))
          (source-name (concatenate 'string c-name ".c"))
+         (thunks-name (concatenate 'string c-name "_thunks.S"))
          (linkage (library-function-linkage library))
          (build-flag (and linkage
                           (concatenate 'string linkage "_BUILD"))))
@@ -121,7 +136,16 @@
       (format stream "#include ~s~%~%" header-name)
       (format stream "#include <signal.h>~%")
       (format stream "#ifndef _WIN32~%#include <pthread.h>~%#endif~%~%")
-      (dolist (api (library-apis library))
-        (write-api-to-source api linkage stream))
-      (unless omit-init-function
-        (write-init-function 'init linkage stream initialize-lisp-args)))))
+      (with-open-file (thunk-stream (merge-pathnames thunks-name directory)
+                                    :direction :output
+                                    :if-exists :supersede)
+        #+win32
+        (progn
+          (format thunk-stream ".intel_syntax noprefix~%")
+          (format thunk-stream ".text~%~%")
+          (format thunk-stream ".extern lisp_calling_context_tls_index~%")
+          (format thunk-stream ".extern TlsGetValue~%~%"))
+        (dolist (api (library-apis library))
+          (write-api-to-source api linkage stream thunk-stream))
+        (unless omit-init-function
+          (write-init-function 'init linkage stream initialize-lisp-args))))))

src/fasl-lib.lisp

@@ -137,12 +137,13 @@ directory, building the shared library, and installing the shared
 library and its header file."
   (let* ((c-name (library-c-name library))
          (bindings-filename (concatenate 'string c-name ".c"))
+         (thunks-filename (concatenate 'string c-name "_thunks.S"))
          (loadable-systems (remove-if-not #'system-loadable-from-fasl-p systems))
-         (source-filenames (append (list bindings-filename *incbin-filename* *fasl-loader-filename*)
+         (source-filenames (append (list bindings-filename thunks-filename *incbin-filename* *fasl-loader-filename*)
                                    (mapcar #'system-fasl-bundle-filename loadable-systems))))
     (with-open-file (stream (uiop:merge-pathnames* "CMakeLists.txt" directory) :direction :output :if-exists :supersede)
       (format stream "cmake_minimum_required(VERSION ~A)~%" *cmake-minimum-required*)
-      (format stream "project(~A)~%" c-name)
+      (format stream "project(~A C ASM)~%" c-name)
       (loop :for system :in loadable-systems
             :for fasl-filename := (system-fasl-bundle-filename system)
             :do (format stream "configure_file(${CMAKE_CURRENT_SOURCE_DIR}/~A ${CMAKE_CURRENT_BINARY_DIR}/~A COPYONLY)~%"

src/function.lisp

@@ -73,9 +73,9 @@ if (!setjmp(fatal_lisp_error_handler)) {
         (canonical-signature name result-type typed-lambda-list
                              :function-prefix function-prefix
                              :error-map error-map)
-      (declare (ignore return-type))
-      (let ((call-statement (format nil "return ~a(~{~a~^, ~});"
-                                    (concatenate 'string "_" (coerce-to-c-name callable-name))
+      (let ((call-statement (format nil "~a err_code = ~a(~{~a~^, ~});"
+                                    (c-type return-type)
+                                    (concatenate 'string #-win32 "_" #+win32 "_unwind_thunk_" (coerce-to-c-name callable-name))
                                     (append
                                      (mapcar (lambda (item)
                                                (lisp-to-c-name (first item)))
@@ -105,6 +105,7 @@ if (!setjmp(fatal_lisp_error_handler)) {
         pthread_sigmask(SIG_UNBLOCK, &mask2, 0);
 #endif
         signal(SIGINT, sigint_handler);
+        return err_code;
     } else {
         ~a
     }"
@@ -117,6 +118,31 @@ if (!setjmp(fatal_lisp_error_handler)) {
                             (format nil "return ~d;" (error-map-fatal-code error-map))
                             (format nil "ldb_monitor();"))))))))
 
+(defparameter *win32-argument-registers*
+  '("rcx" "rdx" "r8" "r9"))
+
+(defun unwind-thunk-definition (name num-args)
+  (let ((c-name (coerce-to-c-name name))
+        (arg-regs (subseq *win32-argument-registers* 0 num-args)))
+    (with-output-to-string (s)
+      (format s ".extern _~a
+
+    .globl _unwind_thunk_~a
+_unwind_thunk_~a:
+    mov r10, [rsp]
+    lea r11, [rsp + 8]
+~@[~%~{    push ~a~^~%~}~%~]
+    mov ecx, DWORD PTR [rip + lisp_calling_context_tls_index]
+    call TlsGetValue
+
+    mov [rax], r10
+    mov [rax + 8], r11
+    mov [rax + 16], rbp
+~@[~%~{    pop ~a~^~%~}~%~]
+    mov rax, QWORD PTR [rip + _~a]
+    jmp rax
+" c-name c-name c-name arg-regs arg-regs c-name))))
+
 (defun callable-definition (name result-type typed-lambda-list &key
                                                                  (function-prefix "")
                                                                  error-map)