source: trunk/source/level-1/arm-threads-utils.lisp @ 15232

Last change on this file since 15232 was 14542, checked in by gb, 9 years ago

In CURRENT-FAKE-STACK-FRAME, return NIL when we hit the bottom
of the stack or a bad header.

File size: 3.7 KB
Line 
1;;;-*-Mode: LISP; Package: CCL -*-
2;;;
3;;;   Copyright (C) 2010 Clozure Associates
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(in-package "CCL")
18
19(defun %frame-backlink (p &optional context)
20  (declare (ignore context))
21  (cond ((fake-stack-frame-p p)
22         (%fixnum-ref p arm::fake-stack-frame.next-sp))
23        ((fixnump p) (%%frame-backlink p))
24        (t (error "~s is not a valid stack frame" p))))
25
26
27
28
29(defun catch-frame-sp (catch)
30  (+ (strip-tag-to-fixnum catch)        ;catch frame is stack-consed
31     arm::catch-frame.element-count))
32
33(defun fake-stack-frame-p (x)
34  (and (typep x 'fixnum)
35       (evenp x)
36       (eql (%fixnum-ref-natural x)
37            (logior (ash (ash (- arm::fake-stack-frame.size arm::node-size)
38                              (- arm::word-shift))
39                         arm::num-subtag-bits)
40                    arm::subtag-istruct))
41       (let* ((type (%fixnum-ref x arm::node-size)))
42         (and (consp type)
43              (eq (car type) 'arm::fake-stack-frame)))))
44
45(defun current-fake-stack-frame ()
46  (do* ((p (%get-frame-ptr) (%%frame-backlink p)))
47       ((or (zerop p) (bottom-of-stack-p p nil)))
48    (when (fake-stack-frame-p p) (return p))))
49
50
51
52(defun bottom-of-stack-p (p context)
53  (and (fixnump p)
54       (locally (declare (fixnum p))
55         (let* ((tcr (if context (bt.tcr context) (%current-tcr)))
56                (cs-area (%fixnum-ref tcr target::tcr.cs-area)))
57           (not (%ptr-in-area-p p cs-area))))))
58
59(defun lisp-frame-p (p context)
60  (if (bottom-of-stack-p p context)
61    (values nil t)
62    (values (or (fake-stack-frame-p p)
63                (eql (%fixnum-ref-natural p) arm::lisp-frame-marker)) nil)))
64
65
66
67
68
69(defun valid-subtag-p (subtag)
70  (declare (fixnum subtag))
71  (let* ((tagval (ldb (byte (- arm::num-subtag-bits arm::ntagbits) arm::ntagbits) subtag)))
72    (declare (fixnum tagval))
73    (case (logand subtag arm::fulltagmask)
74      (#. arm::fulltag-immheader (not (eq (%svref *immheader-types* tagval) 'bogus)))
75      (#. arm::fulltag-nodeheader (not (eq (%svref *nodeheader-types* tagval) 'bogus)))
76      (t nil))))
77
78
79
80(defun valid-header-p (thing)
81  (let* ((fulltag (fulltag thing)))
82    (declare (fixnum fulltag))
83    (case fulltag
84      (#.arm::fulltag-misc (valid-subtag-p (typecode thing)))
85      ((#.arm::fulltag-immheader #.arm::fulltag-nodeheader) nil)
86      (t t))))
87
88
89
90
91
92
93(defun bogus-thing-p (x)
94  (when x
95    #+cross-compiling (return-from bogus-thing-p nil)
96    (or (not (valid-header-p x))
97        (let ((tag (lisptag x)))
98          (unless (or (eql tag arm::tag-fixnum)
99                      (eql tag arm::tag-imm)
100                      (in-any-consing-area-p x))
101            ;; This is terribly complicated, should probably write some LAP
102            (let ((typecode (typecode x)))
103                  (not (or (case typecode
104                             (#.arm::tag-list
105                              (temporary-cons-p x))
106                             ((#.arm::subtag-symbol #.arm::subtag-code-vector)
107                              t)              ; no stack-consed symbols or code vectors
108                             (#.arm::subtag-value-cell
109                              (on-any-vstack x))
110                             (t
111                              (on-any-csp-stack x)))
112                           (%heap-ivector-p x)))))))))
113
114
115
116
117
Note: See TracBrowser for help on using the repository browser.