1 | ;;; |
---|
2 | ;;; Copyright (C) 2005-2009 Clozure Associates and contributors |
---|
3 | ;;; This file is part of Clozure CL. |
---|
4 | ;;; |
---|
5 | ;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public |
---|
6 | ;;; License , known as the LLGPL and distributed with Clozure CL as the |
---|
7 | ;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, |
---|
8 | ;;; which is distributed with Clozure CL as the file "LGPL". Where these |
---|
9 | ;;; conflict, the preamble takes precedence. |
---|
10 | ;;; |
---|
11 | ;;; Clozure CL is referenced in the preamble as the "LIBRARY." |
---|
12 | ;;; |
---|
13 | ;;; The LLGPL is also available online at |
---|
14 | ;;; http://opensource.franz.com/preamble.html |
---|
15 | |
---|
16 | |
---|
17 | (in-package "CCL") |
---|
18 | |
---|
19 | |
---|
20 | #+x8664-target |
---|
21 | (defun make-callback-trampoline (index &optional info) |
---|
22 | (declare (ignore info)) |
---|
23 | (let* ((p (%allocate-callback-pointer 16)) |
---|
24 | (addr #.(subprim-name->offset '.SPcallback))) |
---|
25 | (setf (%get-unsigned-byte p 0) #x41 ; movl $n,%r11d |
---|
26 | (%get-unsigned-byte p 1) #xc7 |
---|
27 | (%get-unsigned-byte p 2) #xc3 |
---|
28 | (%get-unsigned-byte p 3) (ldb (byte 8 0) index) |
---|
29 | (%get-unsigned-byte p 4) (ldb (byte 8 8) index) |
---|
30 | (%get-unsigned-byte p 5) (ldb (byte 8 16) index) |
---|
31 | (%get-unsigned-byte p 6) (ldb (byte 8 24) index) |
---|
32 | (%get-unsigned-byte p 7) #xff ; jmp * |
---|
33 | (%get-unsigned-byte p 8) #x24 |
---|
34 | (%get-unsigned-byte p 9) #x25 |
---|
35 | (%get-unsigned-byte p 10) (ldb (byte 8 0) addr) |
---|
36 | (%get-unsigned-byte p 11) (ldb (byte 8 8) addr) |
---|
37 | (%get-unsigned-byte p 12) (ldb (byte 8 16) addr) |
---|
38 | (%get-unsigned-byte p 13) (ldb (byte 8 24) addr)) |
---|
39 | p)) |
---|
40 | |
---|
41 | #+x8632-target |
---|
42 | (defun make-callback-trampoline (index &optional info) |
---|
43 | (let* ((p (%allocate-callback-pointer 12)) |
---|
44 | (addr #.(subprim-name->offset '.SPcallback))) |
---|
45 | ;; If the optional info parameter is supplied, it will contain |
---|
46 | ;; some stuff in bits 23 through 31. |
---|
47 | ;; |
---|
48 | ;; If bit 23 is set, that indicates that the caller will pass a |
---|
49 | ;; "hidden" argument which is a pointer to appropriate storage for |
---|
50 | ;; holding a returned structure. .SPcallback will have to discard |
---|
51 | ;; this extra argument upon return. |
---|
52 | ;; |
---|
53 | ;; The high 8 bits denote the number of words that .SPcallback |
---|
54 | ;; will have to discard upon return (used for _stdcall on |
---|
55 | ;; Windows). Bit 23 won't be set in this case: we will have |
---|
56 | ;; already added in the extra word to discard if that's necessary. |
---|
57 | ;; |
---|
58 | ;; These bits are be packed into the value that .SPcallback |
---|
59 | ;; receives in %eax. Bits 0 through 22 are the callback index. |
---|
60 | (if info |
---|
61 | (setf (ldb (byte 23 0) info) index) |
---|
62 | (setq info index)) |
---|
63 | (setf (%get-unsigned-byte p 0) #xb8 ; movl $n,%eax |
---|
64 | (%get-unsigned-byte p 1) (ldb (byte 8 0) info) |
---|
65 | (%get-unsigned-byte p 2) (ldb (byte 8 8) info) |
---|
66 | (%get-unsigned-byte p 3) (ldb (byte 8 16) info) |
---|
67 | (%get-unsigned-byte p 4) (ldb (byte 8 24) info) |
---|
68 | (%get-unsigned-byte p 5) #xff ; jmp * |
---|
69 | (%get-unsigned-byte p 6) #x24 |
---|
70 | (%get-unsigned-byte p 7) #x25 |
---|
71 | (%get-unsigned-byte p 8) (ldb (byte 8 0) addr) |
---|
72 | (%get-unsigned-byte p 9) (ldb (byte 8 8) addr) |
---|
73 | (%get-unsigned-byte p 10) (ldb (byte 8 16) addr) |
---|
74 | (%get-unsigned-byte p 11) (ldb (byte 8 24) addr)) |
---|
75 | p)) |
---|
76 | |
---|