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

Last change on this file since 15850 was 15850, checked in by gb, 6 years ago

Fix CATCH-FRAME-SP for ARM (can't use STRIP-TAG-TO-FIXNUM anymore.)

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