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

Last change on this file since 14841 was 13067, checked in by rme, 10 years ago

Update copyright notices.

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