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

Last change on this file since 16685 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: 7.3 KB
Line 
1;;;
2;;; Copyright 2005-2009 Clozure Associates
3;;;
4;;; Licensed under the Apache License, Version 2.0 (the "License");
5;;; you may not use this file except in compliance with the License.
6;;; You may obtain a copy of the License at
7;;;
8;;;     http://www.apache.org/licenses/LICENSE-2.0
9;;;
10;;; Unless required by applicable law or agreed to in writing, software
11;;; distributed under the License is distributed on an "AS IS" BASIS,
12;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
13;;; See the License for the specific language governing permissions and
14;;; limitations under the License.
15
16
17(in-package "CCL")
18
19
20(defun %frame-backlink (p &optional context)
21  (declare (ignore context))
22  (cond ((fixnump p) (%%frame-backlink p))
23        (t (error "~s is not a valid stack frame" p))))
24
25(defun bottom-of-stack-p (p context)
26  (and (fixnump p)
27       (locally (declare (fixnum p))
28         (let* ((tcr (if context (bt.tcr context) (%current-tcr)))
29                (vs-area (%fixnum-ref tcr (- target::tcr.vs-area
30                                             target::tcr-bias))))
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.