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

Last change on this file since 11887 was 11590, checked in by rme, 11 years ago

Additional x8632 FFI details involving structure return and callbacks.

DEFINE-CALLBACK: add hair to recognize when a hidden first argument
will need to be discarded on return. Try to deal with interactions
with the win32 _stdcall case, too. Pass info argument to
DEFINE-CALLBACK-FUNCTION that encodes the arg discard information.

DEFINE-CALLBACK-FUNCTION: pass said info argument to
MAKE-CALLBACK-TRAMPOLINE.

MAKE-CALLBACK-TRAMPOLINE: pack arg discarding information and the
callback index into the value that gets passed to .SPcallback via
the %eax register.

.SPcallback: decode this information, and handle discarding the
appropriate number of args on return.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 6.1 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;;; (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
Note: See TracBrowser for help on using the repository browser.