From 1e0ff599f0b4c48d701107fb14a92629115963be Mon Sep 17 00:00:00 2001
From: rtoy <rtoy>
Date: Fri, 9 Nov 2007 19:24:40 +0000
Subject: [PATCH] Lynn Quam noted that callbacks did not work on his system. 
 This happened because the callback trampoline used malloc'ed space which were
 not executable by default.  Change this so that the trampoline is executable.

code/unix.lisp, code/unix-glibc2.lisp:
o Add UNIX-MPROTECT

code/exports.lisp:
o Export UNIX-MPROTECT

code/alieneval.lisp:
o Make sure the malloc'ed trampoline area is executable.

general-info/release-19e.txt:
o Update
---
 code/alieneval.lisp          | 13 ++++++++++++-
 code/exports.lisp            |  4 ++--
 code/unix-glibc2.lisp        | 11 +++++++++--
 code/unix.lisp               | 10 +++++++++-
 general-info/release-19e.txt |  3 +++
 5 files changed, 35 insertions(+), 6 deletions(-)

diff --git a/code/alieneval.lisp b/code/alieneval.lisp
index 485d36d09..66b274616 100644
--- a/code/alieneval.lisp
+++ b/code/alieneval.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/alieneval.lisp,v 1.64 2005/11/11 22:30:38 rtoy Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/alieneval.lisp,v 1.65 2007/11/09 19:24:35 rtoy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -2218,6 +2218,17 @@ type and arg types, so we can detect incompatible redefinitions."
 		(extern-alien "malloc" (function system-area-pointer unsigned))
 		length))
 	 (fill-pointer code))
+    ;; Make sure the malloc'ed area is executable.  
+    (let* ((page-size (get-page-size))
+	   ;; mprotect wants address on a page boundary, so round down
+	   ;; the address and round up the length
+	   (code-base (sys:int-sap (* page-size
+				      (floor (sys:sap-int code) page-size))))
+	   (len (* page-size (ceiling length page-size))))
+      (unless (unix::unix-mprotect code-base len
+				   (logior unix:prot_exec unix:prot_read unix:prot_write))
+	(warn "Unable to mprotect ~S bytes (~S) at ~S (~S).  Callbacks may not work."
+	      len length code-base code)))
     (new-assem:segment-map-output segment
       (lambda (sap length)
 	(kernel:system-area-copy sap 0 fill-pointer 0
diff --git a/code/exports.lisp b/code/exports.lisp
index 6c6e73dca..6bec4299f 100644
--- a/code/exports.lisp
+++ b/code/exports.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/exports.lisp,v 1.262 2007/11/05 15:25:03 rtoy Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/exports.lisp,v 1.263 2007/11/09 19:24:36 rtoy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -211,7 +211,7 @@
 	   "PROT_READ" "PROT_WRITE" "PROT_EXEC" "PROT_NONE"
 	   "MAP_SHARED" "MAP_PRIVATE" "MAP_FIXED" "MAP_ANONYMOUS"
 	   "MS_ASYNC" "MS_SYNC" "MS_INVALIDATE"
-	   "UNIX-MMAP" "UNIX-MUNMAP" "UNIX-MSYNC"
+	   "UNIX-MMAP" "UNIX-MUNMAP" "UNIX-MSYNC" "UNIX-MPROTECT"
 	   "KBDCGET" "KBDCRESET" "KBDCRST" "KBDCSET"
 	   "KBDCSSTD" "KBDGCLICK" "KBDSCLICK" "KBDSGET" "L_INCR" "L_SET"
 	   "L_XTND" "OFF-T" "O_APPEND" "O_CREAT" "O_EXCL" "O_RDONLY" "O_RDWR"
diff --git a/code/unix-glibc2.lisp b/code/unix-glibc2.lisp
index 039e21e86..539ca9b85 100644
--- a/code/unix-glibc2.lisp
+++ b/code/unix-glibc2.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/unix-glibc2.lisp,v 1.40 2007/11/06 07:16:05 cshapiro Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/unix-glibc2.lisp,v 1.41 2007/11/09 19:24:36 rtoy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -81,7 +81,7 @@
 	  prot_read prot_write prot_exec prot_none
 	  map_shared map_private map_fixed map_anonymous
 	  ms_async ms_sync ms_invalidate
-	  unix-mmap unix-munmap unix-msync
+	  unix-mmap unix-munmap unix-msync unix-mprotect
 	  unix-pathname unix-file-mode unix-fd unix-pid unix-uid unix-gid
 	  unix-setitimer unix-getitimer
 	  unix-access r_ok w_ok x_ok f_ok unix-chdir unix-chmod setuidexec
@@ -278,6 +278,13 @@
 	   (type (signed-byte 32) flags))
   (syscall ("msync" system-area-pointer size-t int) t addr length flags))
 
+(defun unix-mprotect (addr length prot)
+  (declare (type system-area-pointer addr)
+	   (type (unsigned-byte 32) length)
+           (type (integer 1 7) prot))
+  (syscall ("mprotect" system-area-pointer size-t int)
+	   t addr length prot))
+  
 ;;;; Lisp types used by syscalls.
 
 (deftype unix-pathname () 'simple-string)
diff --git a/code/unix.lisp b/code/unix.lisp
index c53b11baf..42a8225a5 100644
--- a/code/unix.lisp
+++ b/code/unix.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/unix.lisp,v 1.115 2007/11/06 07:16:05 cshapiro Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/unix.lisp,v 1.116 2007/11/09 19:24:36 rtoy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -39,6 +39,7 @@
 	  map_shared map_private map_fixed map_anonymous
 	  ms_async ms_sync ms_invalidate
 	  unix-mmap unix-munmap unix-msync
+	  unix-mprotect
 
 	  unix-pathname unix-file-mode unix-fd unix-pid unix-uid unix-gid
 	  unix-setitimer unix-getitimer
@@ -1082,6 +1083,13 @@
 	   (type (unsigned-byte 32) length))
   (syscall ("munmap" system-area-pointer size-t) t addr length))
 
+(defun unix-mprotect (addr length prot)
+  (declare (type system-area-pointer addr)
+	   (type (unsigned-byte 32) length)
+           (type (integer 1 7) prot))
+  (syscall ("mprotect" system-area-pointer size-t int)
+	   t addr length prot))
+  
 (defun unix-setuid (uid)
   "Set the user ID of the calling process to UID.
    If the calling process is the super-user, set the real
diff --git a/general-info/release-19e.txt b/general-info/release-19e.txt
index 3d5c02c90..7c6179d99 100644
--- a/general-info/release-19e.txt
+++ b/general-info/release-19e.txt
@@ -43,6 +43,7 @@ New in this release:
     - Preliminary support for external formats.  Currently only
       iso8859-1 and utf-8 are supported.  Utf-8 support is limited
       since CMUCL only has 8-bit characters.
+    - UNIX-MPROTECT added to access mprotect.
 
   * ANSI compliance fixes:
     - BOA constructors with &AUX variables are handled better now.
@@ -131,6 +132,8 @@ New in this release:
       labels/flet functions.  Untracing should work.  Redefining a
       function should automatically retrace the local functions if
       they were traced previously.
+    - Callbacks should now work on systems where malloc'ed space does
+      not normally allow execution of code.
 
   * Trac Tickets:
     - #8 fixed so logs of bignums and ratios that won't fit into a
-- 
GitLab