[3942] | 1 | ;;; x86-trap-support |
---|
| 2 | ;;; |
---|
[13067] | 3 | ;;; Copyright (C) 2005-2009 Clozure Associates and contributors |
---|
[13066] | 4 | ;;; This file is part of Clozure CL. |
---|
[3942] | 5 | ;;; |
---|
[13066] | 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 |
---|
[3942] | 8 | ;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, |
---|
[13066] | 9 | ;;; which is distributed with Clozure CL as the file "LGPL". Where these |
---|
[3942] | 10 | ;;; conflict, the preamble takes precedence. |
---|
| 11 | ;;; |
---|
[13066] | 12 | ;;; Clozure CL is referenced in the preamble as the "LIBRARY." |
---|
[3942] | 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) |
---|
[4450] | 22 | (declare (ignore context)) |
---|
| 23 | (cond ((fixnump p) (%%frame-backlink p)) |
---|
[3942] | 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) |
---|
[4450] | 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)))) |
---|
[3942] | 41 | |
---|
| 42 | |
---|
| 43 | (defun catch-frame-sp (catch) |
---|
[10128] | 44 | (uvref catch |
---|
| 45 | #+x8632-target x8632::catch-frame.ebp-cell |
---|
| 46 | #+x8664-target x8664::catch-frame.rbp-cell)) |
---|
[3942] | 47 | |
---|
[4185] | 48 | ;;; Sure would be nice to have &optional in defppclapfunction arglists |
---|
| 49 | ;;; Sure would be nice not to do this at runtime. |
---|
[3942] | 50 | |
---|
[4185] | 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))))) |
---|
[3942] | 58 | |
---|
[4185] | 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))))) |
---|
[4543] | 102 | |
---|
| 103 | |
---|
[10128] | 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)))) |
---|
[4543] | 113 | |
---|
[10128] | 114 | #+x8664-target |
---|
[4562] | 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)))))) |
---|
[4543] | 133 | |
---|
[10128] | 134 | #+x8632-target |
---|
[4562] | 135 | (defun valid-header-p (thing) |
---|
| 136 | (let* ((fulltag (fulltag thing))) |
---|
| 137 | (declare (fixnum fulltag)) |
---|
| 138 | (case fulltag |
---|
[10128] | 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 |
---|
[4562] | 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))) |
---|
[11065] | 162 | (and disp |
---|
| 163 | (let* ((f (%return-address-function thing))) |
---|
| 164 | (and (typep f 'function) (valid-header-p f)))))) |
---|
[4562] | 165 | (#.x8664::fulltag-cons t) |
---|
| 166 | (#.x8664::fulltag-nil (null thing)) |
---|
| 167 | (t nil)))) |
---|
| 168 | |
---|
[10128] | 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) |
---|
[11065] | 183 | (%return-address-offset x)) |
---|
[10128] | 184 | (and (typep x 'ivector) |
---|
| 185 | (on-any-csp-stack x)) |
---|
| 186 | (%heap-ivector-p x)) |
---|
| 187 | t))))) |
---|
[4562] | 188 | |
---|
[10128] | 189 | #+x8664-target |
---|
[4543] | 190 | (defun bogus-thing-p (x) |
---|
[4562] | 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) |
---|
[5067] | 205 | (on-any-csp-stack x)) |
---|
| 206 | (%heap-ivector-p x)) |
---|
[4562] | 207 | t))))) |
---|
| 208 | |
---|