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 | ;;; (defcallback ...) expands into a call to this function. |
---|
25 | (defun define-callback-function (lisp-function &optional doc-string (without-interrupts t) info &aux name trampoline) |
---|
26 | (unless (functionp lisp-function) |
---|
27 | (setq lisp-function (require-type lisp-function 'function))) |
---|
28 | (unless (and (symbolp (setq name (function-name lisp-function))) |
---|
29 | ;;Might as well err out now before do any _Newptr's... |
---|
30 | (not (constant-symbol-p name))) |
---|
31 | (report-bad-arg name '(and symbol (not (satisfies constantp))))) |
---|
32 | (with-lock-grabbed (*callback-lock*) |
---|
33 | (let ((len (length %pascal-functions%))) |
---|
34 | (declare (fixnum len)) |
---|
35 | (when (and name (boundp name)) |
---|
36 | (let ((old-tramp (symbol-value name))) |
---|
37 | (dotimes (i len) |
---|
38 | (let ((pfe (%svref %pascal-functions% i))) |
---|
39 | (when (and (vectorp pfe) |
---|
40 | (eql old-tramp (pfe.routine-descriptor pfe))) |
---|
41 | |
---|
42 | (setf (pfe.without-interrupts pfe) without-interrupts) |
---|
43 | (setf (pfe.lisp-function pfe) lisp-function) |
---|
44 | (setq trampoline old-tramp)))))) |
---|
45 | (unless trampoline |
---|
46 | (let ((index (dotimes (i (length %pascal-functions%) |
---|
47 | (let* ((new-len (if (zerop len) 32 (* len 2))) |
---|
48 | (new-pf (make-array (the fixnum new-len)))) |
---|
49 | (declare (fixnum new-len)) |
---|
50 | (dotimes (i len) |
---|
51 | (setf (%svref new-pf i) (%svref %pascal-functions% i))) |
---|
52 | (do ((i len (1+ i))) |
---|
53 | ((>= i new-len)) |
---|
54 | (declare (fixnum i)) |
---|
55 | (setf (%svref new-pf i) nil)) |
---|
56 | (setq %pascal-functions% new-pf) |
---|
57 | len)) |
---|
58 | (unless (%svref %pascal-functions% i) |
---|
59 | (return i))))) |
---|
60 | (setq trampoline (make-callback-trampoline index info)) |
---|
61 | (setf (%svref %pascal-functions% index) |
---|
62 | (%cons-pfe trampoline info lisp-function name without-interrupts))))) |
---|
63 | ;;(%proclaim-special name) ; |
---|
64 | ;; already done by defpascal expansion |
---|
65 | (when name (set name trampoline)) |
---|
66 | (record-source-file name 'callback) |
---|
67 | (when (and doc-string *save-doc-strings*) |
---|
68 | (setf (documentation name 'variable) doc-string)) |
---|
69 | (when *fasload-print* (format t "~&~S~%" name)) |
---|
70 | (or name trampoline))) |
---|
71 | |
---|
72 | (defun %lookup-pascal-function (index) |
---|
73 | (declare (optimize (speed 3) (safety 0))) |
---|
74 | (with-lock-grabbed (*callback-lock*) |
---|
75 | (let* ((pfe (svref %pascal-functions% index))) |
---|
76 | (values (pfe.lisp-function pfe) |
---|
77 | (pfe.without-interrupts pfe) |
---|
78 | (pfe.trace-p pfe))))) |
---|
79 | |
---|
80 | |
---|
81 | (defun %callback-function (pointer) |
---|
82 | (if (typep pointer 'symbol) |
---|
83 | (setq pointer (symbol-value pointer))) |
---|
84 | (with-lock-grabbed (*callback-lock*) |
---|
85 | (let* ((index (dotimes (i (length %pascal-functions%)) |
---|
86 | (when (eql (pfe.routine-descriptor (svref %pascal-functions% i)) pointer) |
---|
87 | (return i))))) |
---|
88 | (when index |
---|
89 | (let* ((entry (svref %pascal-functions% index))) |
---|
90 | (pfe.lisp-function entry)))))) |
---|
91 | |
---|
92 | |
---|
93 | (defun %delete-pascal-function (pointer) |
---|
94 | (with-lock-grabbed (*callback-lock*) |
---|
95 | (let* ((index (dotimes (i (length %pascal-functions%)) |
---|
96 | (when (eql (pfe.routine-descriptor (svref %pascal-functions% i)) pointer) |
---|
97 | (return i))))) |
---|
98 | (when index |
---|
99 | (let* ((entry (svref %pascal-functions% index)) |
---|
100 | (sym (pfe.sym entry))) |
---|
101 | (setf (svref %pascal-functions% index) nil) |
---|
102 | (when (and sym |
---|
103 | (boundp sym) |
---|
104 | (eql (symbol-value sym) |
---|
105 | (pfe.routine-descriptor entry))) |
---|
106 | (set (symbol-value sym) nil)) |
---|
107 | (free (pfe.routine-descriptor entry)) |
---|
108 | t))))) |
---|
109 | |
---|
110 | |
---|
111 | ;; The kernel only really knows how to call back to one function, |
---|
112 | ;; and you're looking at it ... |
---|
113 | (defun %pascal-functions% (index args-ptr-fixnum) |
---|
114 | (declare (optimize (speed 3) (safety 0))) |
---|
115 | (multiple-value-bind (lisp-function without-interrupts *callback-trace-p*) |
---|
116 | (%lookup-pascal-function index) |
---|
117 | (declare (special *callback-trace-p*)) |
---|
118 | (if without-interrupts |
---|
119 | (without-interrupts (funcall lisp-function args-ptr-fixnum)) |
---|
120 | (funcall lisp-function args-ptr-fixnum)))) |
---|
121 | |
---|
122 | (defstatic *callback-alloc-lock* (make-lock)) |
---|
123 | |
---|
124 | ;;; |
---|
125 | (defun %make-executable-page () |
---|
126 | #-windows-target |
---|
127 | (#_mmap (%null-ptr) |
---|
128 | (#_getpagesize) |
---|
129 | (logior #$PROT_READ #$PROT_WRITE #$PROT_EXEC) |
---|
130 | (logior #$MAP_PRIVATE #$MAP_ANON) |
---|
131 | -1 |
---|
132 | 0) |
---|
133 | #+windows-target |
---|
134 | (#_VirtualAlloc (%null-ptr) |
---|
135 | (ash 1 16) ; should use GetSystemInfo |
---|
136 | (logior #$MEM_RESERVE #$MEM_COMMIT) |
---|
137 | #$PAGE_EXECUTE_READWRITE) |
---|
138 | ) |
---|
139 | |
---|
140 | (defstatic *available-bytes-for-callbacks* 0) |
---|
141 | (defstatic *current-callback-page* nil) |
---|
142 | |
---|
143 | (defun reset-callback-storage () |
---|
144 | (setq *available-bytes-for-callbacks* #-windows-target (#_getpagesize) #+windows-target (ash 1 16) |
---|
145 | *current-callback-page* (%make-executable-page))) |
---|
146 | |
---|
147 | (defun %allocate-callback-pointer (n) |
---|
148 | (with-lock-grabbed (*callback-alloc-lock*) |
---|
149 | (when (< *available-bytes-for-callbacks* n) |
---|
150 | (reset-callback-storage)) |
---|
151 | (decf *available-bytes-for-callbacks* n) |
---|
152 | (values (%inc-ptr *current-callback-page* *available-bytes-for-callbacks*)))) |
---|
153 | |
---|