source: branches/arm/level-1/arm-threads-utils.lisp @ 13968

Last change on this file since 13968 was 13968, checked in by gb, 10 years ago

Fix bogosity in _SPcall_closure.
Start checking for FP exceptions (need to do this in software); compiler
generates checks unless unsafe. (Should maybe use a new policy hook for
this.)
Adapt PPC fake-stack-frame code to make backtrace/error reporting better.

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