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

Last change on this file since 13537 was 13067, checked in by rme, 10 years ago

Update copyright notices.

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