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

Last change on this file since 8177 was 5067, checked in by gb, 13 years ago

Things that're %HEAP-IVECTOR-P aren't bogus objects.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 6.0 KB
Line 
1;;; x86-trap-support
2;;;
3;;;   Copyright (C) 2005-2006 Clozure Associates and contributors
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
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 x8664::catch-frame.rbp-cell))
45
46;;; Sure would be nice to have &optional in defppclapfunction arglists
47;;; Sure would be nice not to do this at runtime.
48
49(let ((bits (lfun-bits #'(lambda (x &optional y) (declare (ignore x y))))))
50  (lfun-bits #'%fixnum-ref
51             (dpb (ldb $lfbits-numreq bits)
52                  $lfbits-numreq
53                  (dpb (ldb $lfbits-numopt bits)
54                       $lfbits-numopt
55                       (lfun-bits #'%fixnum-ref)))))
56
57(let ((bits (lfun-bits #'(lambda (x &optional y) (declare (ignore x y))))))
58  (lfun-bits #'%fixnum-ref-natural
59             (dpb (ldb $lfbits-numreq bits)
60                  $lfbits-numreq
61                  (dpb (ldb $lfbits-numopt bits)
62                       $lfbits-numopt
63                       (lfun-bits #'%fixnum-ref-natural)))))
64
65
66;;; Sure would be nice to have &optional in defppclapfunction arglists
67;;; Sure would be nice not to do this at runtime.
68
69(let ((bits (lfun-bits #'(lambda (x &optional y) (declare (ignore x y))))))
70  (lfun-bits #'%fixnum-ref
71             (dpb (ldb $lfbits-numreq bits)
72                  $lfbits-numreq
73                  (dpb (ldb $lfbits-numopt bits)
74                       $lfbits-numopt
75                       (lfun-bits #'%fixnum-ref)))))
76
77(let ((bits (lfun-bits #'(lambda (x &optional y) (declare (ignore x y))))))
78  (lfun-bits #'%fixnum-ref-natural
79             (dpb (ldb $lfbits-numreq bits)
80                  $lfbits-numreq
81                  (dpb (ldb $lfbits-numopt bits)
82                       $lfbits-numopt
83                       (lfun-bits #'%fixnum-ref-natural)))))
84
85(let ((bits (lfun-bits #'(lambda (x y &optional z) (declare (ignore x y z))))))
86  (lfun-bits #'%fixnum-set
87             (dpb (ldb $lfbits-numreq bits)
88                  $lfbits-numreq
89                  (dpb (ldb $lfbits-numopt bits)
90                       $lfbits-numopt
91                       (lfun-bits #'%fixnum-set)))))
92
93(let ((bits (lfun-bits #'(lambda (x y &optional z) (declare (ignore x y z))))))
94  (lfun-bits #'%fixnum-set-natural
95             (dpb (ldb $lfbits-numreq bits)
96                  $lfbits-numreq
97                  (dpb (ldb $lfbits-numopt bits)
98                       $lfbits-numopt
99                       (lfun-bits #'%fixnum-set-natural)))))
100
101
102
103(defun valid-subtag-p (subtag)
104  (declare (fixnum subtag))
105  (let* ((tagval (logand x8664::fulltagmask subtag))
106         (high4 (ash subtag (- x8664::ntagbits))))
107    (declare (fixnum tagval high4))
108    (not (eq 'bogus
109             (case tagval
110               (#.x8664::fulltag-immheader-0
111                (%svref *immheader-0-types* high4))
112               (#.x8664::fulltag-immheader-1
113                (%svref *immheader-1-types* high4))
114               (#.x8664::fulltag-immheader-2
115                (%svref *immheader-2-types* high4))
116               (#.x8664::fulltag-nodeheader-0
117                (%svref *nodeheader-0-types* high4))
118               (#.x8664::fulltag-nodeheader-1
119                (%svref *nodeheader-1-types* high4))
120               (t 'bogus))))))
121
122(defun valid-header-p (thing)
123  (let* ((fulltag (fulltag thing)))
124    (declare (fixnum fulltag))
125    (case fulltag
126      ((#.x8664::fulltag-even-fixnum
127        #.x8664::fulltag-odd-fixnum
128        #.x8664::fulltag-imm-0
129        #.x8664::fulltag-imm-1)
130       t)
131      (#.x8664::fulltag-function
132       (= x8664::subtag-function (typecode (%function-to-function-vector thing))))
133      (#.x8664::fulltag-symbol
134       (= x8664::subtag-symbol (typecode (%symptr->symvector thing))))
135      (#.x8664::fulltag-misc
136       (valid-subtag-p (typecode thing)))
137      ((#.x8664::fulltag-tra-0
138        #.x8664::fulltag-tra-1)
139       (let* ((disp (%return-address-offset thing)))
140         (or (eql 0 disp)
141             (let* ((f (%return-address-function thing)))
142               (and (typep f 'function) (valid-header-p f))))))
143      (#.x8664::fulltag-cons t)
144      (#.x8664::fulltag-nil (null thing))
145      (t nil))))
146             
147     
148                                     
149               
150
151
152(defun bogus-thing-p (x)
153  (when x
154    (or (not (valid-header-p x))
155        (let* ((tag (lisptag x)))
156          (unless (or (eql tag x8664::tag-fixnum)
157                      (eql tag x8664::tag-imm-0)
158                      (eql tag x8664::tag-imm-1)
159                      (in-any-consing-area-p x)
160                      (temporary-cons-p x)
161                      (and (or (typep x 'function)
162                               (typep x 'gvector))
163                           (on-any-tsp-stack x))
164                      (and (eql tag x8664::tag-tra)
165                           (eql 0 (%return-address-offset x)))
166                      (and (typep x 'ivector)
167                           (on-any-csp-stack x))
168                      (%heap-ivector-p x))
169            t)))))
170
Note: See TracBrowser for help on using the repository browser.