Make FFI callabacks work properly on 64 bit Windows OSes.

sharplispers · Sep 26, 2016 · 2156983 · 2156983 · rgcorman · Dec 21, 2016
1 parent 24302d6
commit 2156983
Show file tree

Hide file tree

Showing 3 changed files with 40 additions and 2 deletions.
diff --git a/CormanLispServer/include/Lisp.h b/CormanLispServer/include/Lisp.h
@@ -883,6 +883,8 @@ LispDeclare(Get_Time_Units_Per_Second);
 LispDeclare(Probe_File);
 LispDeclare(Memory_Report);
 
+LispDeclare(Safecall);
+
 //
 //	QV pointers
 //

diff --git a/CormanLispServer/src/Lispfunc.cpp b/CormanLispServer/src/Lispfunc.cpp
@@ -4481,6 +4481,9 @@ FunctEntry functTable[] =
     { "consoleUnderflow",           (LispFunc)consoleUnderflow },
     { "garbageCollect",             (LispFunc)garbageCollect },
 
+	// We need this built-in function to support callback in FFI on 64-bit versions of Windows
+	// It seems one can not throw Access Violation Exceptions through the Windows API functions on 64 bit OSes.
+	{ "%SAFECALL",                  (LispFunc)Safecall      },
     // ----------------------------------------------------------
 };
 long sizeFunctTable = sizeof(functTable)/sizeof(FunctEntry);
@@ -4810,3 +4813,31 @@ LispFunction(Lisp_Shutdown)
 	ret = NIL;
 	LISP_FUNC_RETURN(ret);	
 }
+
+
+// We need this to implement %SAFECALL primitive to support callbacks on 64 bit versions of Windows.
+volatile static LispObj doSafecall(LispObj func)
+{
+	LispObj res = NIL;
+	__try
+	{
+		res = LispCall1(Funcall, func);
+	}
+	__except (handleStructuredException(GetExceptionCode(), GetExceptionInformation()))
+	{
+
+	}
+	return res;
+}
+
+LispFunction(Safecall)
+{
+	LISP_FUNC_BEGIN(1);
+	LispObj obj = LISP_ARG(0);
+	checkFunction(obj);
+
+	ret = doSafecall(obj);
+
+	LISP_FUNC_RETURN(ret);
+}
+
diff --git a/Sys/ffi.lisp b/Sys/ffi.lisp
@@ -1617,7 +1617,12 @@ Example:
             (declare (ignore doc))
             (when bad-decls (error "Declarations found in body of callback"))
             (setq lisp-func 
-                `(defun ,internal-name ,syms (let () ,@decls (block ,name ,@body))))
+				  `(defun ,internal-name ,syms
+					 (let ()
+					   (cl::%safecall #'(lambda ()
+										  ,@decls
+										  (block ,name
+											,@body))))))
             (setq docstring doc))
         (let ((param-offset 0))
 			(dolist (x arg-list)
@@ -2389,4 +2394,4 @@ Example:
 (in-package :cl)
 
 (setq cl::*compiler-warn-on-undefined-function* t)
-
+