source: trunk/source/level-1/x86-threads-utils.lisp @ 14376

Last change on this file since 14376 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: 7.3 KB
Line 
1;;; x86-trap-support
2;;;
3;;;   Copyright (C) 2005-2009 Clozure Associates and contributors
4;;;   This file is part of Clozure CL. 
5;;;
6;;;   Clozure CL is licensed under the terms of the Lisp Lesser GNU Public
7;;;   License , known as the LLGPL and distributed with Clozure CL as the
8;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
9;;;   which is distributed with Clozure CL as the file "LGPL".  Where these
10;;;   conflict, the preamble takes precedence. 
11;;;
12;;;   Clozure CL 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
18(in-package "CCL")
19
20
21(defun %frame-backlink (p &optional context)
22  (declare (ignore context))
23  (cond ((fixnump p) (%%frame-backlink p))
24        (t (error "~s is not a valid stack frame" p))))
25
26(defun bottom-of-stack-p (p context)
27  (and (fixnump p)
28       (locally (declare (fixnum p))
29         (let* ((tcr (if context (bt.tcr context) (%current-tcr)))
30                (vs-area (%fixnum-ref tcr target::tcr.vs-area)))
31           (not (%ptr-in-area-p p vs-area))))))
32
33
34(defun lisp-frame-p (p context)
35  (declare (fixnum p))
36  (let ((next-frame (%frame-backlink p context)))
37    (declare (fixnum next-frame))
38    (if (bottom-of-stack-p next-frame context)
39        (values nil t)
40        (values t nil))))
41
42
43(defun catch-frame-sp (catch)
44  (uvref catch
45         #+x8632-target x8632::catch-frame.ebp-cell
46         #+x8664-target x8664::catch-frame.rbp-cell))
47
48;;; Sure would be nice to have &optional in defppclapfunction arglists
49;;; Sure would be nice not to do this at runtime.
50
51(let ((bits (lfun-bits #'(lambda (x &optional y) (declare (ignore x y))))))
52  (lfun-bits #'%fixnum-ref
53             (dpb (ldb $lfbits-numreq bits)
54                  $lfbits-numreq
55                  (dpb (ldb $lfbits-numopt bits)
56                       $lfbits-numopt
57                       (lfun-bits #'%fixnum-ref)))))
58
59(let ((bits (lfun-bits #'(lambda (x &optional y) (declare (ignore x y))))))
60  (lfun-bits #'%fixnum-ref-natural
61             (dpb (ldb $lfbits-numreq bits)
62                  $lfbits-numreq
63                  (dpb (ldb $lfbits-numopt bits)
64                       $lfbits-numopt
65                       (lfun-bits #'%fixnum-ref-natural)))))
66
67
68;;; Sure would be nice to have &optional in defppclapfunction arglists
69;;; Sure would be nice not to do this at runtime.
70
71(let ((bits (lfun-bits #'(lambda (x &optional y) (declare (ignore x y))))))
72  (lfun-bits #'%fixnum-ref
73             (dpb (ldb $lfbits-numreq bits)
74                  $lfbits-numreq
75                  (dpb (ldb $lfbits-numopt bits)
76                       $lfbits-numopt
77                       (lfun-bits #'%fixnum-ref)))))
78
79(let ((bits (lfun-bits #'(lambda (x &optional y) (declare (ignore x y))))))
80  (lfun-bits #'%fixnum-ref-natural
81             (dpb (ldb $lfbits-numreq bits)
82                  $lfbits-numreq
83                  (dpb (ldb $lfbits-numopt bits)
84                       $lfbits-numopt
85                       (lfun-bits #'%fixnum-ref-natural)))))
86
87(let ((bits (lfun-bits #'(lambda (x y &optional z) (declare (ignore x y z))))))
88  (lfun-bits #'%fixnum-set
89             (dpb (ldb $lfbits-numreq bits)
90                  $lfbits-numreq
91                  (dpb (ldb $lfbits-numopt bits)
92                       $lfbits-numopt
93                       (lfun-bits #'%fixnum-set)))))
94
95(let ((bits (lfun-bits #'(lambda (x y &optional z) (declare (ignore x y z))))))
96  (lfun-bits #'%fixnum-set-natural
97             (dpb (ldb $lfbits-numreq bits)
98                  $lfbits-numreq
99                  (dpb (ldb $lfbits-numopt bits)
100                       $lfbits-numopt
101                       (lfun-bits #'%fixnum-set-natural)))))
102
103
104#+x8632-target
105(defun valid-subtag-p (subtag)
106  (declare (fixnum subtag))
107  (let* ((tagval (ldb (byte (- x8632::num-subtag-bits x8632::ntagbits) x8632::ntagbits) subtag)))
108    (declare (fixnum tagval))
109    (case (logand subtag x8632::fulltagmask)
110      (#. x8632::fulltag-immheader (not (eq (%svref *immheader-types* tagval) 'bogus)))
111      (#. x8632::fulltag-nodeheader (not (eq (%svref *nodeheader-types* tagval) 'bogus)))
112      (t nil))))
113
114#+x8664-target
115(defun valid-subtag-p (subtag)
116  (declare (fixnum subtag))
117  (let* ((tagval (logand x8664::fulltagmask subtag))
118         (high4 (ash subtag (- x8664::ntagbits))))
119    (declare (fixnum tagval high4))
120    (not (eq 'bogus
121             (case tagval
122               (#.x8664::fulltag-immheader-0
123                (%svref *immheader-0-types* high4))
124               (#.x8664::fulltag-immheader-1
125                (%svref *immheader-1-types* high4))
126               (#.x8664::fulltag-immheader-2
127                (%svref *immheader-2-types* high4))
128               (#.x8664::fulltag-nodeheader-0
129                (%svref *nodeheader-0-types* high4))
130               (#.x8664::fulltag-nodeheader-1
131                (%svref *nodeheader-1-types* high4))
132               (t 'bogus))))))
133
134#+x8632-target
135(defun valid-header-p (thing)
136  (let* ((fulltag (fulltag thing)))
137    (declare (fixnum fulltag))
138    (case fulltag
139      (#.x8632::fulltag-misc (valid-subtag-p (typecode thing)))
140      ((#.x8632::fulltag-immheader #.x8632::fulltag-nodeheader) nil)
141      (t t))))
142
143#+x8664-target
144(defun valid-header-p (thing)
145  (let* ((fulltag (fulltag thing)))
146    (declare (fixnum fulltag))
147    (case fulltag
148      ((#.x8664::fulltag-even-fixnum
149        #.x8664::fulltag-odd-fixnum
150        #.x8664::fulltag-imm-0
151        #.x8664::fulltag-imm-1)
152       t)
153      (#.x8664::fulltag-function
154       (= x8664::subtag-function (typecode (%function-to-function-vector thing))))
155      (#.x8664::fulltag-symbol
156       (= x8664::subtag-symbol (typecode (%symptr->symvector thing))))
157      (#.x8664::fulltag-misc
158       (valid-subtag-p (typecode thing)))
159      ((#.x8664::fulltag-tra-0
160        #.x8664::fulltag-tra-1)
161       (let* ((disp (%return-address-offset thing)))
162         (and disp
163              (let* ((f (%return-address-function thing)))
164                (and (typep f 'function) (valid-header-p f))))))
165      (#.x8664::fulltag-cons t)
166      (#.x8664::fulltag-nil (null thing))
167      (t nil))))
168             
169#+x8632-target
170(defun bogus-thing-p (x)
171  (when x
172    (or (not (valid-header-p x))
173        (let ((tag (lisptag x))
174              (fulltag (fulltag x)))
175          (unless (or (eql tag x8632::tag-fixnum)
176                      (eql tag x8632::tag-imm)
177                      (in-any-consing-area-p x)
178                      (temporary-cons-p x)
179                      (and (or (typep x 'function)
180                               (typep x 'gvector))
181                           (on-any-tsp-stack x))
182                      (and (eql fulltag x8632::fulltag-tra)
183                           (%return-address-offset x))
184                      (and (typep x 'ivector)
185                           (on-any-csp-stack x))
186                      (%heap-ivector-p x))
187            t)))))
188
189#+x8664-target
190(defun bogus-thing-p (x)
191  (when x
192    (or (not (valid-header-p x))
193        (let* ((tag (lisptag x)))
194          (unless (or (eql tag x8664::tag-fixnum)
195                      (eql tag x8664::tag-imm-0)
196                      (eql tag x8664::tag-imm-1)
197                      (in-any-consing-area-p x)
198                      (temporary-cons-p x)
199                      (and (or (typep x 'function)
200                               (typep x 'gvector))
201                           (on-any-tsp-stack x))
202                      (and (eql tag x8664::tag-tra)
203                           (eql 0 (%return-address-offset x)))
204                      (and (typep x 'ivector)
205                           (on-any-csp-stack x))
206                      (%heap-ivector-p x))
207            t)))))
208
Note: See TracBrowser for help on using the repository browser.