source: trunk/source/level-1/ppc-threads-utils.lisp @ 11887

Last change on this file since 11887 was 6497, checked in by gb, 12 years ago

Move %FIXNUM-REF-MACPTR and %FIXNUM-SET-MACPTR elsewhere.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 7.5 KB
Line 
1;;;-*- Mode: Lisp; Package: CCL -*-
2;;;
3;;;   Copyright (C) 1994-2001 Digitool, Inc
4;;;   This file is part of OpenMCL. 
5;;;
6;;;   OpenMCL is licensed under the terms of the Lisp Lesser GNU Public
7;;;   License , known as the LLGPL and distributed with OpenMCL as the
8;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
9;;;   which is distributed with OpenMCL as the file "LGPL".  Where these
10;;;   conflict, the preamble takes precedence. 
11;;;
12;;;   OpenMCL 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; low-level support for PPC threads and stack-backtrace printing
18
19(in-package "CCL")
20
21
22;;; Sure would be nice to have &optional in defppclapfunction arglists
23;;; Sure would be nice not to do this at runtime.
24
25(let ((bits (lfun-bits #'(lambda (x &optional y) (declare (ignore x y))))))
26  (lfun-bits #'%fixnum-ref
27             (dpb (ldb $lfbits-numreq bits)
28                  $lfbits-numreq
29                  (dpb (ldb $lfbits-numopt bits)
30                       $lfbits-numopt
31                       (lfun-bits #'%fixnum-ref)))))
32
33(let ((bits (lfun-bits #'(lambda (x &optional y) (declare (ignore x y))))))
34  (lfun-bits #'%fixnum-ref-natural
35             (dpb (ldb $lfbits-numreq bits)
36                  $lfbits-numreq
37                  (dpb (ldb $lfbits-numopt bits)
38                       $lfbits-numopt
39                       (lfun-bits #'%fixnum-ref-natural)))))
40
41(let ((bits (lfun-bits #'(lambda (x y &optional z) (declare (ignore x y z))))))
42  (lfun-bits #'%fixnum-set
43             (dpb (ldb $lfbits-numreq bits)
44                  $lfbits-numreq
45                  (dpb (ldb $lfbits-numopt bits)
46                       $lfbits-numopt
47                       (lfun-bits #'%fixnum-set)))))
48
49(let ((bits (lfun-bits #'(lambda (x y &optional z) (declare (ignore x y z))))))
50  (lfun-bits #'%fixnum-set-natural
51             (dpb (ldb $lfbits-numreq bits)
52                  $lfbits-numreq
53                  (dpb (ldb $lfbits-numopt bits)
54                       $lfbits-numopt
55                       (lfun-bits #'%fixnum-set-natural)))))
56
57
58 
59                                 
60;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
61;;;
62
63
64
65   
66   
67(defun %frame-backlink (p &optional context)
68  (cond ((fake-stack-frame-p p)
69         (%fake-stack-frame.next-sp p))
70        ((fixnump p)
71         (let ((backlink (%%frame-backlink p))
72               (fake-frame
73                (if context (bt.fake-frames context) *fake-stack-frames*)))
74           (loop
75             (when (null fake-frame) (return backlink))
76             (when (eq backlink (%fake-stack-frame.sp fake-frame))
77               (return fake-frame))
78             (setq fake-frame (%fake-stack-frame.link fake-frame)))))
79        (t (error "~s is not a valid stack frame" p))))
80
81
82
83
84(defun catch-frame-sp (catch)
85  (uvref catch target::catch-frame.csp-cell))
86
87(defun bottom-of-stack-p (p context)
88  (and (fixnump p)
89       (locally (declare (fixnum p))
90         (let* ((tcr (if context (bt.tcr context) (%current-tcr)))
91                (cs-area (%fixnum-ref tcr target::tcr.cs-area)))
92           (not (%ptr-in-area-p p cs-area))))))
93
94(defun lisp-frame-p (p context)
95  (or (fake-stack-frame-p p)
96      (locally (declare (fixnum p))
97        (let ((next-frame (%frame-backlink p context)))
98          (when (fake-stack-frame-p next-frame)
99            (setq next-frame (%fake-stack-frame.sp next-frame)))
100          (locally (declare (fixnum next-frame))
101            (if (bottom-of-stack-p next-frame context)
102              (values nil t)
103              (and
104               (eql (ash target::lisp-frame.size (- target::fixnum-shift))
105                    (the fixnum (- next-frame p)))
106               ;; EABI C functions keep their saved LRs where we save FN or 0
107               ;; The saved LR of such a function would be fixnum-tagged and never 0.
108               (let* ((fn (%fixnum-ref p target::lisp-frame.savefn)))
109                 (or (eql fn 0) (typep fn 'function))))))))))
110
111
112
113
114
115#+ppc32-target
116(defun valid-subtag-p (subtag)
117  (declare (fixnum subtag))
118  (let* ((tagval (ldb (byte (- ppc32::num-subtag-bits ppc32::ntagbits) ppc32::ntagbits) subtag)))
119    (declare (fixnum tagval))
120    (case (logand subtag ppc32::fulltagmask)
121      (#. ppc32::fulltag-immheader (not (eq (%svref *immheader-types* tagval) 'bogus)))
122      (#. ppc32::fulltag-nodeheader (not (eq (%svref *nodeheader-types* tagval) 'bogus)))
123      (t nil))))
124
125#+ppc64-target
126(defun valid-subtag-p (subtag)
127  (declare (fixnum subtag))
128  (let* ((tagval (ash subtag (- ppc64::nlowtagbits))))
129    (declare (fixnum tagval))
130    (case (logand subtag ppc64::lowtagmask)
131      (#. ppc64::lowtag-immheader (not (eq (%svref *immheader-types* tagval) 'bogus)))
132      (#. ppc64::lowtag-nodeheader (not (eq (%svref *nodeheader-types* tagval) 'bogus)))
133      (t nil))))
134
135#+ppc32-target
136(defun valid-header-p (thing)
137  (let* ((fulltag (fulltag thing)))
138    (declare (fixnum fulltag))
139    (case fulltag
140      (#.ppc32::fulltag-misc (valid-subtag-p (typecode thing)))
141      ((#.ppc32::fulltag-immheader #.ppc32::fulltag-nodeheader) nil)
142      (t t))))
143
144
145
146#+ppc64-target
147(defun valid-header-p (thing)
148  (let* ((fulltag (fulltag thing)))
149    (declare (fixnum fulltag))
150    (case fulltag
151      (#.ppc64::fulltag-misc (valid-subtag-p (typecode thing)))
152      ((#.ppc64::fulltag-immheader-0
153        #.ppc64::fulltag-immheader-1
154        #.ppc64::fulltag-immheader-2
155        #.ppc64::fulltag-immheader-3
156        #.ppc64::fulltag-nodeheader-0
157        #.ppc64::fulltag-nodeheader-1
158        #.ppc64::fulltag-nodeheader-2
159        #.ppc64::fulltag-nodeheader-3) nil)
160      (t t))))
161
162
163
164
165#+ppc32-target
166(defun bogus-thing-p (x)
167  (when x
168    #+cross-compiling (return-from bogus-thing-p nil)
169    (or (not (valid-header-p x))
170        (let ((tag (lisptag x)))
171          (unless (or (eql tag ppc32::tag-fixnum)
172                      (eql tag ppc32::tag-imm)
173                      (in-any-consing-area-p x))
174            ;; This is terribly complicated, should probably write some LAP
175            (let ((typecode (typecode x)))
176                  (not (or (case typecode
177                             (#.ppc32::tag-list
178                              (temporary-cons-p x))
179                             ((#.ppc32::subtag-symbol #.ppc32::subtag-code-vector)
180                              t)              ; no stack-consed symbols or code vectors
181                             (#.ppc32::subtag-value-cell
182                              (on-any-vstack x))
183                             (t
184                              (on-any-tsp-stack x)))
185                           (%heap-ivector-p x)))))))))
186
187
188
189#+ppc64-target
190(defun bogus-thing-p (x)
191  (when x
192    (or (not (valid-header-p x))
193        (let ((tag (lisptag x)))
194          (unless (or (eql tag ppc64::tag-fixnum)
195                      (eql tag ppc64::tag-imm-0)
196                      (eql tag ppc64::tag-imm-2)
197                      (in-any-consing-area-p x))
198            ;; This is terribly complicated, should probably write some LAP
199            (let ((typecode (typecode x)))
200                  (not (or (case typecode
201                             (#.ppc64::fulltag-cons
202                              (temporary-cons-p x))
203                             ((#.ppc64::subtag-symbol #.ppc64::subtag-code-vector)
204                              t)              ; no stack-consed symbols or code vectors
205                             (#.ppc64::subtag-value-cell
206                              (on-any-vstack x))
207                             (t
208                              (on-any-tsp-stack x)))
209                           (%heap-ivector-p x)))))))))
Note: See TracBrowser for help on using the repository browser.