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

Last change on this file was 16685, checked in by rme, 4 years ago

Update copyright/license headers in files.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 6.3 KB
Line 
1;;;-*- Mode: Lisp; Package: CCL -*-
2;;;
3;;; Copyright 1994-2009 Clozure Associates
4;;;
5;;; Licensed under the Apache License, Version 2.0 (the "License");
6;;; you may not use this file except in compliance with the License.
7;;; You may obtain a copy of the License at
8;;;
9;;;     http://www.apache.org/licenses/LICENSE-2.0
10;;;
11;;; Unless required by applicable law or agreed to in writing, software
12;;; distributed under the License is distributed on an "AS IS" BASIS,
13;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
14;;; See the License for the specific language governing permissions and
15;;; limitations under the License.
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          #-android-target (#_getpagesize) #+android-target (#_sysconf #$_SC_PAGE_SIZE)
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 #-android-target (#_getpagesize) #+android-target (#_sysconf #$_SC_PAGE_SIZE) #+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
Note: See TracBrowser for help on using the repository browser.