[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))) |
---|
[14619] | 30 | (vs-area (%fixnum-ref tcr (- target::tcr.vs-area |
---|
| 31 | target::tcr-bias)))) |
---|
[3942] | 32 | (not (%ptr-in-area-p p vs-area)))))) |
---|
| 33 | |
---|
| 34 | |
---|
| 35 | (defun lisp-frame-p (p context) |
---|
[4450] | 36 | (declare (fixnum p)) |
---|
| 37 | (let ((next-frame (%frame-backlink p context))) |
---|
| 38 | (declare (fixnum next-frame)) |
---|
| 39 | (if (bottom-of-stack-p next-frame context) |
---|
| 40 | (values nil t) |
---|
| 41 | (values t nil)))) |
---|
[3942] | 42 | |
---|
| 43 | |
---|
| 44 | (defun catch-frame-sp (catch) |
---|
[10128] | 45 | (uvref catch |
---|
| 46 | #+x8632-target x8632::catch-frame.ebp-cell |
---|
| 47 | #+x8664-target x8664::catch-frame.rbp-cell)) |
---|
[3942] | 48 | |
---|
[4185] | 49 | ;;; Sure would be nice to have &optional in defppclapfunction arglists |
---|
| 50 | ;;; Sure would be nice not to do this at runtime. |
---|
[3942] | 51 | |
---|
[4185] | 52 | (let ((bits (lfun-bits #'(lambda (x &optional y) (declare (ignore x y)))))) |
---|
| 53 | (lfun-bits #'%fixnum-ref |
---|
| 54 | (dpb (ldb $lfbits-numreq bits) |
---|
| 55 | $lfbits-numreq |
---|
| 56 | (dpb (ldb $lfbits-numopt bits) |
---|
| 57 | $lfbits-numopt |
---|
| 58 | (lfun-bits #'%fixnum-ref))))) |
---|
[3942] | 59 | |
---|
[4185] | 60 | (let ((bits (lfun-bits #'(lambda (x &optional y) (declare (ignore x y)))))) |
---|
| 61 | (lfun-bits #'%fixnum-ref-natural |
---|
| 62 | (dpb (ldb $lfbits-numreq bits) |
---|
| 63 | $lfbits-numreq |
---|
| 64 | (dpb (ldb $lfbits-numopt bits) |
---|
| 65 | $lfbits-numopt |
---|
| 66 | (lfun-bits #'%fixnum-ref-natural))))) |
---|
| 67 | |
---|
| 68 | |
---|
| 69 | ;;; Sure would be nice to have &optional in defppclapfunction arglists |
---|
| 70 | ;;; Sure would be nice not to do this at runtime. |
---|
| 71 | |
---|
| 72 | (let ((bits (lfun-bits #'(lambda (x &optional y) (declare (ignore x y)))))) |
---|
| 73 | (lfun-bits #'%fixnum-ref |
---|
| 74 | (dpb (ldb $lfbits-numreq bits) |
---|
| 75 | $lfbits-numreq |
---|
| 76 | (dpb (ldb $lfbits-numopt bits) |
---|
| 77 | $lfbits-numopt |
---|
| 78 | (lfun-bits #'%fixnum-ref))))) |
---|
| 79 | |
---|
| 80 | (let ((bits (lfun-bits #'(lambda (x &optional y) (declare (ignore x y)))))) |
---|
| 81 | (lfun-bits #'%fixnum-ref-natural |
---|
| 82 | (dpb (ldb $lfbits-numreq bits) |
---|
| 83 | $lfbits-numreq |
---|
| 84 | (dpb (ldb $lfbits-numopt bits) |
---|
| 85 | $lfbits-numopt |
---|
| 86 | (lfun-bits #'%fixnum-ref-natural))))) |
---|
| 87 | |
---|
| 88 | (let ((bits (lfun-bits #'(lambda (x y &optional z) (declare (ignore x y z)))))) |
---|
| 89 | (lfun-bits #'%fixnum-set |
---|
| 90 | (dpb (ldb $lfbits-numreq bits) |
---|
| 91 | $lfbits-numreq |
---|
| 92 | (dpb (ldb $lfbits-numopt bits) |
---|
| 93 | $lfbits-numopt |
---|
| 94 | (lfun-bits #'%fixnum-set))))) |
---|
| 95 | |
---|
| 96 | (let ((bits (lfun-bits #'(lambda (x y &optional z) (declare (ignore x y z)))))) |
---|
| 97 | (lfun-bits #'%fixnum-set-natural |
---|
| 98 | (dpb (ldb $lfbits-numreq bits) |
---|
| 99 | $lfbits-numreq |
---|
| 100 | (dpb (ldb $lfbits-numopt bits) |
---|
| 101 | $lfbits-numopt |
---|
| 102 | (lfun-bits #'%fixnum-set-natural))))) |
---|
[4543] | 103 | |
---|
| 104 | |
---|
[10128] | 105 | #+x8632-target |
---|
| 106 | (defun valid-subtag-p (subtag) |
---|
| 107 | (declare (fixnum subtag)) |
---|
| 108 | (let* ((tagval (ldb (byte (- x8632::num-subtag-bits x8632::ntagbits) x8632::ntagbits) subtag))) |
---|
| 109 | (declare (fixnum tagval)) |
---|
| 110 | (case (logand subtag x8632::fulltagmask) |
---|
| 111 | (#. x8632::fulltag-immheader (not (eq (%svref *immheader-types* tagval) 'bogus))) |
---|
| 112 | (#. x8632::fulltag-nodeheader (not (eq (%svref *nodeheader-types* tagval) 'bogus))) |
---|
| 113 | (t nil)))) |
---|
[4543] | 114 | |
---|
[10128] | 115 | #+x8664-target |
---|
[4562] | 116 | (defun valid-subtag-p (subtag) |
---|
| 117 | (declare (fixnum subtag)) |
---|
| 118 | (let* ((tagval (logand x8664::fulltagmask subtag)) |
---|
| 119 | (high4 (ash subtag (- x8664::ntagbits)))) |
---|
| 120 | (declare (fixnum tagval high4)) |
---|
| 121 | (not (eq 'bogus |
---|
| 122 | (case tagval |
---|
| 123 | (#.x8664::fulltag-immheader-0 |
---|
| 124 | (%svref *immheader-0-types* high4)) |
---|
| 125 | (#.x8664::fulltag-immheader-1 |
---|
| 126 | (%svref *immheader-1-types* high4)) |
---|
| 127 | (#.x8664::fulltag-immheader-2 |
---|
| 128 | (%svref *immheader-2-types* high4)) |
---|
| 129 | (#.x8664::fulltag-nodeheader-0 |
---|
| 130 | (%svref *nodeheader-0-types* high4)) |
---|
| 131 | (#.x8664::fulltag-nodeheader-1 |
---|
| 132 | (%svref *nodeheader-1-types* high4)) |
---|
| 133 | (t 'bogus)))))) |
---|
[4543] | 134 | |
---|
[10128] | 135 | #+x8632-target |
---|
[4562] | 136 | (defun valid-header-p (thing) |
---|
| 137 | (let* ((fulltag (fulltag thing))) |
---|
| 138 | (declare (fixnum fulltag)) |
---|
| 139 | (case fulltag |
---|
[10128] | 140 | (#.x8632::fulltag-misc (valid-subtag-p (typecode thing))) |
---|
| 141 | ((#.x8632::fulltag-immheader #.x8632::fulltag-nodeheader) nil) |
---|
| 142 | (t t)))) |
---|
| 143 | |
---|
| 144 | #+x8664-target |
---|
| 145 | (defun valid-header-p (thing) |
---|
| 146 | (let* ((fulltag (fulltag thing))) |
---|
| 147 | (declare (fixnum fulltag)) |
---|
| 148 | (case fulltag |
---|
[4562] | 149 | ((#.x8664::fulltag-even-fixnum |
---|
| 150 | #.x8664::fulltag-odd-fixnum |
---|
| 151 | #.x8664::fulltag-imm-0 |
---|
| 152 | #.x8664::fulltag-imm-1) |
---|
| 153 | t) |
---|
| 154 | (#.x8664::fulltag-function |
---|
| 155 | (= x8664::subtag-function (typecode (%function-to-function-vector thing)))) |
---|
| 156 | (#.x8664::fulltag-symbol |
---|
| 157 | (= x8664::subtag-symbol (typecode (%symptr->symvector thing)))) |
---|
| 158 | (#.x8664::fulltag-misc |
---|
| 159 | (valid-subtag-p (typecode thing))) |
---|
| 160 | ((#.x8664::fulltag-tra-0 |
---|
| 161 | #.x8664::fulltag-tra-1) |
---|
| 162 | (let* ((disp (%return-address-offset thing))) |
---|
[11065] | 163 | (and disp |
---|
| 164 | (let* ((f (%return-address-function thing))) |
---|
| 165 | (and (typep f 'function) (valid-header-p f)))))) |
---|
[4562] | 166 | (#.x8664::fulltag-cons t) |
---|
| 167 | (#.x8664::fulltag-nil (null thing)) |
---|
| 168 | (t nil)))) |
---|
| 169 | |
---|
[10128] | 170 | #+x8632-target |
---|
| 171 | (defun bogus-thing-p (x) |
---|
| 172 | (when x |
---|
| 173 | (or (not (valid-header-p x)) |
---|
| 174 | (let ((tag (lisptag x)) |
---|
| 175 | (fulltag (fulltag x))) |
---|
| 176 | (unless (or (eql tag x8632::tag-fixnum) |
---|
| 177 | (eql tag x8632::tag-imm) |
---|
| 178 | (in-any-consing-area-p x) |
---|
| 179 | (temporary-cons-p x) |
---|
| 180 | (and (or (typep x 'function) |
---|
| 181 | (typep x 'gvector)) |
---|
| 182 | (on-any-tsp-stack x)) |
---|
| 183 | (and (eql fulltag x8632::fulltag-tra) |
---|
[11065] | 184 | (%return-address-offset x)) |
---|
[10128] | 185 | (and (typep x 'ivector) |
---|
| 186 | (on-any-csp-stack x)) |
---|
| 187 | (%heap-ivector-p x)) |
---|
| 188 | t))))) |
---|
[4562] | 189 | |
---|
[10128] | 190 | #+x8664-target |
---|
[4543] | 191 | (defun bogus-thing-p (x) |
---|
[4562] | 192 | (when x |
---|
| 193 | (or (not (valid-header-p x)) |
---|
| 194 | (let* ((tag (lisptag x))) |
---|
| 195 | (unless (or (eql tag x8664::tag-fixnum) |
---|
| 196 | (eql tag x8664::tag-imm-0) |
---|
| 197 | (eql tag x8664::tag-imm-1) |
---|
| 198 | (in-any-consing-area-p x) |
---|
| 199 | (temporary-cons-p x) |
---|
| 200 | (and (or (typep x 'function) |
---|
| 201 | (typep x 'gvector)) |
---|
| 202 | (on-any-tsp-stack x)) |
---|
| 203 | (and (eql tag x8664::tag-tra) |
---|
| 204 | (eql 0 (%return-address-offset x))) |
---|
| 205 | (and (typep x 'ivector) |
---|
[5067] | 206 | (on-any-csp-stack x)) |
---|
| 207 | (%heap-ivector-p x)) |
---|
[4562] | 208 | t))))) |
---|
| 209 | |
---|