source: trunk/source/level-1/l1-callbacks.lisp @ 8177

Last change on this file since 8177 was 6934, checked in by gb, 13 years ago

Move the x86-64 callback trampoline allocation stuff (which uses
mmap to ensure that the callback is in executable memory) here,
since it'll be needed on ppc64 leopard, at least.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 6.4 KB
Line 
1;;;-*- Mode: Lisp; Package: CCL -*-
2;;;
3;;;   Copyright (C) 1994-2001 Digitool, Inc
4;;;   This file is part of OpenMCL. 
5;;;
6;;;   OpenMCL is licensed under the terms of the Lisp Lesser GNU Public
7;;;   License , known as the LLGPL and distributed with OpenMCL as the
8;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
9;;;   which is distributed with OpenMCL as the file "LGPL".  Where these
10;;;   conflict, the preamble takes precedence. 
11;;;
12;;;   OpenMCL is referenced in the preamble as the "LIBRARY."
13;;;
14;;;   The LLGPL is also available online at
15;;;   http://opensource.franz.com/preamble.html
16
17;;; l1-callbacks.lisp
18
19(in-package "CCL")
20
21(defstatic *callback-lock* (make-lock))
22
23
24;;; MacOS toolbox routines were once written mostly in Pascal, so some
25;;; code still refers to callbacks from foreign code as "pascal-callable
26;;; functions".
27
28; %Pascal-Functions% Entry
29(def-accessor-macros %svref
30  pfe.routine-descriptor
31  pfe.proc-info
32  pfe.lisp-function
33  pfe.sym
34  pfe.without-interrupts
35  pfe.trace-p)
36
37(defun %cons-pfe (routine-descriptor proc-info lisp-function sym without-interrupts)
38  (vector routine-descriptor proc-info lisp-function sym without-interrupts nil))
39
40;;; (defcallback ...) expands into a call to this function.
41(defun define-callback-function (lisp-function  &optional doc-string (without-interrupts t) monitor-exception-ports
42                                                   &aux name trampoline)
43  (unless (functionp lisp-function)
44    (setq lisp-function (require-type lisp-function 'function)))
45  (unless (and (symbolp (setq name (function-name lisp-function)))
46               ;;Might as well err out now before do any _Newptr's...
47               (not (constant-symbol-p name)))
48    (report-bad-arg name '(and symbol (not (satisfies constantp)))))
49  (with-lock-grabbed (*callback-lock*)
50    (let ((len (length %pascal-functions%)))
51      (declare (fixnum len))
52      (when (and name (boundp name))
53        (let ((old-tramp (symbol-value name)))
54          (dotimes (i len)
55            (let ((pfe (%svref %pascal-functions% i)))
56              (when (and (vectorp pfe)
57                         (eql old-tramp (pfe.routine-descriptor pfe)))
58               
59                (setf (pfe.without-interrupts pfe) without-interrupts)
60                (setf (pfe.lisp-function pfe) lisp-function)
61                (setq trampoline old-tramp))))))
62      (unless trampoline
63        (let ((index (dotimes (i (length %pascal-functions%)
64                               (let* ((new-len (if (zerop len) 32 (* len 2)))
65                                      (new-pf (make-array (the fixnum new-len))))
66                                 (declare (fixnum new-len))
67                                 (dotimes (i len)
68                                   (setf (%svref new-pf i) (%svref %pascal-functions% i)))
69                                 (do ((i len (1+ i)))
70                                     ((>= i new-len))
71                                   (declare (fixnum i))
72                                   (setf (%svref new-pf i) nil))
73                                 (setq %pascal-functions% new-pf)
74                                 len))
75                       (unless (%svref %pascal-functions% i)
76                         (return i)))))
77          (setq trampoline (make-callback-trampoline index))
78          (setf (%svref %pascal-functions% index)
79                (%cons-pfe trampoline monitor-exception-ports lisp-function name without-interrupts)))))
80    ;;(%proclaim-special name)          ;
81    ;; already done by defpascal expansion
82    (when name (set name trampoline))
83    (record-source-file name 'defcallback)
84    (when (and doc-string *save-doc-strings*)
85      (setf (documentation name 'variable) doc-string))
86    (when *fasload-print* (format t "~&~S~%" name))
87    (or name trampoline)))
88
89
90(defun %lookup-pascal-function (index)
91  (declare (optimize (speed 3) (safety 0)))
92  (with-lock-grabbed (*callback-lock*)
93    (let* ((pfe (svref %pascal-functions% index)))
94      (values (pfe.lisp-function pfe)
95              (pfe.without-interrupts pfe)
96              (pfe.trace-p pfe)))))
97
98
99(defun %callback-function (pointer)
100  (if (typep pointer 'symbol)
101    (setq pointer (symbol-value pointer)))
102  (with-lock-grabbed (*callback-lock*)
103    (let* ((index (dotimes (i (length %pascal-functions%))
104                    (when (eql (pfe.routine-descriptor (svref %pascal-functions% i)) pointer)
105                      (return i)))))
106      (when index
107        (let* ((entry (svref %pascal-functions% index)))
108          (pfe.lisp-function entry))))))
109
110 
111(defun %delete-pascal-function (pointer)
112  (with-lock-grabbed (*callback-lock*)
113    (let* ((index (dotimes (i (length %pascal-functions%))
114                    (when (eql (pfe.routine-descriptor (svref %pascal-functions% i)) pointer)
115                      (return i)))))
116      (when index
117        (let* ((entry (svref %pascal-functions% index))
118               (sym (pfe.sym entry)))
119          (setf (svref %pascal-functions% index) nil)
120          (when (and sym
121                     (boundp sym)
122                     (eql (symbol-value sym)
123                          (pfe.routine-descriptor entry)))
124            (set (symbol-value sym) nil))
125          (free (pfe.routine-descriptor entry))
126          t)))))
127
128
129;; The kernel only really knows how to call back to one function,
130;; and you're looking at it ...
131(defun %pascal-functions% (index args-ptr-fixnum)
132  (declare (optimize (speed 3) (safety 0)))
133  (multiple-value-bind (lisp-function without-interrupts *callback-trace-p*)
134      (%lookup-pascal-function index)
135    (declare (special *callback-trace-p*))
136    (if without-interrupts
137        (without-interrupts (funcall lisp-function args-ptr-fixnum))
138      (funcall lisp-function args-ptr-fixnum))))
139
140(defstatic *callback-alloc-lock* (make-lock))
141
142;;;
143(defun %make-executable-page ()
144  (#_mmap (%null-ptr)
145          (#_getpagesize)
146          (logior #$PROT_READ #$PROT_WRITE #$PROT_EXEC)
147          (logior #$MAP_PRIVATE #$MAP_ANON)
148          -1
149          0))
150
151(defstatic *available-bytes-for-callbacks* 0)
152(defstatic *current-callback-page* nil)
153
154(defun reset-callback-storage ()
155  (setq *available-bytes-for-callbacks* (#_getpagesize)
156        *current-callback-page* (%make-executable-page)))
157
158(defun %allocate-callback-pointer (n)
159  (with-lock-grabbed (*callback-alloc-lock*)
160    (when (< *available-bytes-for-callbacks* n)
161      (reset-callback-storage))
162    (decf *available-bytes-for-callbacks* n)
163    (values (%inc-ptr *current-callback-page* *available-bytes-for-callbacks*))))
164
Note: See TracBrowser for help on using the repository browser.