source: branches/qres/ccl/lib/ppc-backtrace.lisp @ 14172

Last change on this file since 14172 was 13070, checked in by gz, 10 years ago

r13066, r13067 from trunk: copyrights etc

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 34.8 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
19(in-package "CCL")
20
21(def-accessors (fake-stack-frame) %svref
22  nil                           ; 'fake-stack-frame
23  %fake-stack-frame.sp          ; fixnum. The stack pointer where this frame "should" be
24  %fake-stack-frame.next-sp     ; Either sp or another fake-stack-frame
25  %fake-stack-frame.fn          ; The current function
26  %fake-stack-frame.lr          ; fixnum offset from fn (nil if fn is not functionp)
27  %fake-stack-frame.vsp         ; The value stack pointer
28  %fake-stack-frame.xp          ; Exception frame.
29  %fake-stack-frame.link        ; next in *fake-stack-frames* list
30  )
31
32;;; Linked list of fake stack frames.
33;;; %frame-backlink looks here
34(def-standard-initial-binding *fake-stack-frames* nil)
35 
36
37(defun fake-stack-frame-p (x)
38  (istruct-typep x 'fake-stack-frame))
39
40(defun cfp-lfun (p)
41  (if (fake-stack-frame-p p)
42    (let* ((fn (%fake-stack-frame.fn p))
43           (lr (%fake-stack-frame.lr p)))
44      (if (and (typep fn 'function)
45               (typep lr 'fixnum))
46        (values fn lr)
47        (values nil nil)))
48    (%cfp-lfun p)))
49
50
51(defun %stack< (index1 index2 &optional context)
52  (cond ((fake-stack-frame-p index1)
53         (let ((sp1 (%fake-stack-frame.sp index1)))
54           (declare (fixnum sp1))
55           (if (fake-stack-frame-p index2)
56             (or (%stack< sp1 (%fake-stack-frame.sp index2) context)
57                 (eq index2 (%fake-stack-frame.next-sp index1)))
58             (%stack< sp1 (%i+ index2 1) context))))
59        ((fake-stack-frame-p index2)
60         (%stack< index1 (%fake-stack-frame.sp index2) context))
61        (t (let* ((tcr (if context (bt.tcr context) (%current-tcr)))
62                  (cs-area (%fixnum-ref tcr target::tcr.cs-area)))
63             (and (%ptr-in-area-p index1 cs-area)
64                  (%ptr-in-area-p index2 cs-area)
65                  (< (the fixnum index1) (the fixnum index2)))))))
66
67;;; Returns two values:
68;;;  [nil, nil] if it can be reliably determined that function uses no registers at PC
69;;;  [mask, savevsp]  if it can be reliably determined that the registers specified by "mask"
70;;;      were saved at "savevsp" in the function's stack frame
71;;;  [mask, nil] if registers in "mask" MAY have been saved, but we don't know how to restore them
72;;;      (perhaps because the "at-pc" argument wasn't specified.
73
74
75;;; If the last instruction in a code vector is an
76;;; LWZ instruction (of the form "(LWZ rx s16 ry)"),
77;;; then
78;;;   this function uses registers RX-R31.  Note that this leaves
79;;;    us 2 extra bits, since we're only encoding 3 bits worth of
80;;;    register info.
81;;;   RX is saved nearest the top of the vstack
82;;;   s16 is the offset from the saved-vsp to the address at which
83;;;    RX was saved; this is a negative value whose low two bits
84;;;    are ignored
85;;;   (logior (ash (logand s16 3) 5) rY) is the pc at which
86;;;   the registers were saved (a fullword code-vector index).
87;;; This scheme lets us encode any "simple" register usage, where
88;;; the registers were saved once, saved somewhere within the first
89;;; 128 instructions in the code vector, and nothing interesting (to
90;;; backtrace) happens after the registers have been restored.
91;;; If the compiler ever gets cleverer about this, we'll have to use
92;;; some other scheme (perhaps a STW instruction, preceded by branches).
93;;;
94;;; Note that the "last instruction" really means "last instruction
95;;; before any traceback table"; we should be able to truncate the code
96;;; vector (probably by copying it) to strip off the traceback table
97;;; without losing this information.
98;;; Note also that the disassembler would probably ordinarily want to
99;;; hide this last instruction ...
100;;;   
101
102#+ppc32-target
103(defun registers-used-by (lfun &optional at-pc)
104  (let* ((regs-used nil)
105         (where-saved nil))
106    (multiple-value-bind (op-high op-low) (%code-vector-last-instruction (uvref lfun 0))
107      (declare (fixnum op-high op-low))
108      (if (eql (ldb (byte 6 (- 26 16)) op-high) 32)       ; LWZ
109        (let* ((nregs (- 32 (ldb (byte 5 (- 21 16)) op-high)))
110               (pc (dpb (ldb (byte 2 0) op-low) (byte 2 5) (ldb (byte 5 (- 16 16)) op-high)))
111               (offset (%word-to-int (logand op-low (lognot 3)))))
112          (declare (fixnum nregs pc offset))
113          (setq regs-used (1- (ash 1 nregs)))
114          (if at-pc
115            (if (>= at-pc pc)
116              (setq where-saved (- (ash (- offset) -2) nregs))
117              (setq regs-used nil))))))
118    (values (and regs-used (bit-reverse-8 regs-used)) where-saved)))
119
120#+ppc64-target
121(defun registers-used-by (lfun &optional at-pc)
122  (let* ((regs-used nil)
123         (where-saved nil)
124         (instr (%code-vector-last-instruction (uvref lfun 0))))
125      (if (eql (ldb (byte 6 26) instr) 32)       ; LWZ
126        (let* ((nregs (- 32 (ldb (byte 5 21) instr)))
127               (pc (dpb (ldb (byte 2 0) instr) (byte 2 5) (ldb (byte 5 16) instr)))
128               (offset (%word-to-int (logand instr (lognot 7)))))
129          (declare (fixnum nregs pc offset))
130          (setq regs-used (1- (ash 1 nregs)))
131          (if at-pc
132            (if (>= at-pc pc)
133              (setq where-saved (- (ash (- offset) -3) nregs))
134              (setq regs-used nil)))))       
135      (values (and regs-used (bit-reverse-8 regs-used)) where-saved)))   
136 
137
138(defparameter *bit-reverse-8-table*
139  #.(let ((table (make-array 256 :element-type '(unsigned-byte 8))))
140      (dotimes (i 256)
141        (let ((j 0)
142              (out-mask (ash 1 7)))
143          (declare (fixnum j out-mask))
144          (dotimes (bit 8)
145            (when (logbitp bit i)
146              (setq j (logior j out-mask)))
147            (setq out-mask (ash out-mask -1)))
148          (setf (aref table i) j)))
149      table))
150
151(defun bit-reverse-8 (x)
152  (aref *bit-reverse-8-table* x))
153
154(defun %frame-savefn (p)
155  (if (fake-stack-frame-p p)
156    (%fake-stack-frame.fn p)
157    (%%frame-savefn p)))
158
159(defun %frame-savevsp (p)
160  (if (fake-stack-frame-p p)
161    (%fake-stack-frame.vsp p)
162    (%%frame-savevsp p)))
163
164(defun frame-vsp (frame)
165  (%frame-savevsp frame))
166
167;;; Return two values: the vsp of p and the vsp of p's "parent" frame.
168;;; The "parent" frame vsp might actually be the end of p's segment,
169;;; if the real "parent" frame vsp is in another segment.
170(defun vsp-limits (p context)
171  (let* ((vsp (%frame-savevsp p))
172         parent)
173    (when (eql vsp 0)
174      ; This frame is where the code continues after an unwind-protect cleanup form
175      (setq vsp (%frame-savevsp (child-frame p context))))
176    (flet ((grand-parent (frame)
177             (let ((parent (parent-frame frame context)))
178               (when (and parent (eq parent (%frame-backlink frame context)))
179                 (let ((grand-parent (parent-frame parent context)))
180                   (when (and grand-parent (eq grand-parent (%frame-backlink parent context)))
181                     grand-parent))))))
182      (declare (dynamic-extent #'grand-parent))
183      (let* ((frame p)
184             grand-parent)
185        (loop
186          (setq grand-parent (grand-parent frame))
187          (when (or (null grand-parent) (not (eql 0 (%frame-savevsp grand-parent))))
188            (return))
189          (setq frame grand-parent))
190        (setq parent (parent-frame frame context)))
191      (let* ((parent-vsp (if parent (%frame-savevsp parent) vsp))
192             (tcr (if context (bt.tcr context) (%current-tcr)))
193             (vsp-area (%fixnum-ref tcr target::tcr.vs-area)))
194        (if (eql 0 parent-vsp)
195          (values vsp vsp)              ; p is the kernel frame pushed by an unwind-protect cleanup form
196          (progn
197            (unless vsp-area
198              (error "~s is not a stack frame pointer for context ~s" p tcr))
199            (unless (%ptr-in-area-p parent-vsp vsp-area)
200              (setq parent-vsp (%fixnum-ref vsp-area target::area.high)))
201            (values vsp parent-vsp)))))))
202
203
204(defun catch-csp-p (p context)
205  (let ((catch (if context
206                 (bt.top-catch context)
207                 (%catch-top (%current-tcr)))))
208    (loop
209      (when (null catch) (return nil))
210      (let ((sp (catch-frame-sp catch)))
211        (when (eql sp p)
212          (return t)))
213      (setq catch (next-catch catch)))))
214
215(defun last-catch-since (sp context)
216  (let* ((tcr (if context (bt.tcr context) (%current-tcr)))
217         (catch (%catch-top tcr))
218         (last-catch nil))
219    (loop
220      (unless catch (return last-catch))
221      (let ((csp (uvref catch target::catch-frame.csp-cell)))
222        (when (%stack< sp csp context) (return last-catch))
223        (setq last-catch catch
224              catch (next-catch catch))))))
225
226(defun register-number->saved-register-index (regno)
227  (- regno ppc::save7))
228
229(defun %find-register-argument-value (context cfp regval bad)
230  (let* ((last-catch (last-catch-since cfp context))
231         (index (register-number->saved-register-index regval)))
232    (do* ((frame cfp
233                 (child-frame frame context))
234          (first t))
235         ((null frame))
236      (if (fake-stack-frame-p frame)
237        (return-from %find-register-argument-value
238          (xp-gpr-lisp (%fake-stack-frame.xp frame) regval))
239        (if first
240          (setq first nil)
241          (multiple-value-bind (lfun pc)
242              (cfp-lfun frame)
243            (when lfun
244              (multiple-value-bind (mask where)
245                  (registers-used-by lfun pc)
246                (when (if mask (logbitp index mask))
247                  (incf where (logcount (logandc2 mask (1- (ash 1 (1+ index))))))
248                  (return-from
249                   %find-register-argument-value
250                    (raw-frame-ref frame context where bad)))))))))
251    (get-register-value nil last-catch index)))
252
253(defun %set-register-argument-value (context cfp regval new)
254  (let* ((last-catch (last-catch-since cfp context))
255         (index (register-number->saved-register-index regval)))
256    (do* ((frame cfp
257                 (child-frame frame context))
258          (first t))
259         ((null frame))
260      (if (fake-stack-frame-p frame)
261        (return-from %set-register-argument-value
262          (setf (xp-gpr-lisp (%fake-stack-frame.xp frame) regval) new))
263        (if first
264          (setq first nil)
265          (multiple-value-bind (lfun pc)
266              (cfp-lfun frame)
267            (when lfun
268              (multiple-value-bind (mask where)
269                  (registers-used-by lfun pc)
270                (when (if mask (logbitp index mask))
271                  (incf where (logcount (logandc2 mask (1- (ash 1 (1+ index))))))
272                  (return-from
273                   %set-register-argument-value
274                    (raw-frame-set frame context where new)))))))))
275    (set-register-value new nil last-catch index)))
276
277(defun %raw-frame-ref (cfp context idx bad)
278  (declare (fixnum idx))
279  (multiple-value-bind (frame base)
280      (vsp-limits cfp context)
281    (let* ((raw-size (- base frame)))
282      (declare (fixnum frame base raw-size))
283      (if (and (>= idx 0)
284               (< idx raw-size))
285        (let* ((addr (- (the fixnum (1- base))
286                        idx)))
287          (multiple-value-bind (db-count first-db last-db)
288              (count-db-links-in-frame frame base context)
289            (let* ((is-db-link
290                    (unless (zerop db-count)
291                      (do* ((last last-db (previous-db-link last first-db)))
292                           ((null last))
293                        (when (= addr last)
294                          (return t))))))
295              (if is-db-link
296                (oldest-binding-frame-value context addr)
297                (%fixnum-ref addr)))))
298        bad))))
299
300(defun %raw-frame-set (cfp context idx new)
301  (declare (fixnum idx))
302  (multiple-value-bind (frame base)
303      (vsp-limits cfp context)
304    (let* ((raw-size (- base frame)))
305      (declare (fixnum frame base raw-size))
306      (if (and (>= idx 0)
307               (< idx raw-size))
308        (let* ((addr (- (the fixnum (1- base))
309                        idx)))
310          (multiple-value-bind (db-count first-db last-db)
311              (count-db-links-in-frame frame base context)
312            (let* ((is-db-link
313                    (unless (zerop db-count)
314                      (do* ((last last-db (previous-db-link last first-db)))
315                           ((null last))
316                        (when (= addr last)
317                          (return t))))))
318              (if is-db-link
319                (setf (oldest-binding-frame-value context addr) new)
320                (setf (%fixnum-ref addr) new))))
321          t)))))
322
323;;; Used for printing only.
324(defun index->address (p)
325  (when (fake-stack-frame-p p)
326    (setq p (%fake-stack-frame.sp p)))
327  (ldb (byte #+32-bit-target 32 #+64-bit-target 64 0)  (ash p target::fixnumshift)))
328
329
330(defun match-local-name (cellno info pc)
331  (when info
332    (let* ((syms (%car info))
333           (ptrs (%cdr info)))
334      (dotimes (i (length syms))
335        (let ((j (%i+ i (%i+ i i ))))
336          (and (eq (uvref ptrs j) (%ilogior (%ilsl (+ 6 target::word-shift) cellno) #o77))
337               (%i>= pc (uvref ptrs (%i+ j 1)))
338               (%i< pc (uvref ptrs (%i+ j 2)))
339               (return (aref syms i))))))))
340
341(defun get-register-value (address last-catch index)
342  (if address
343    (%fixnum-ref address)
344    (uvref last-catch (+ index target::catch-frame.save-save7-cell))))
345
346;;; Inverse of get-register-value
347
348(defun set-register-value (value address last-catch index)
349  (if address
350    (%fixnum-set address value)
351    (setf (uvref last-catch (+ index target::catch-frame.save-save7-cell))
352          value)))
353
354;;; I'm skeptical about a lot of this stuff on the PPC, but if anything it's
355;;; pretty PPC-specific
356
357;;; Act as if VSTACK-INDEX points somewhere where DATA could go & put it there.
358(defun set-lisp-data (vstack-index data)
359  (let* ((old (%access-lisp-data vstack-index)))
360    (if (closed-over-value-p old)
361      (set-closed-over-value old data)
362      (%store-lisp-data vstack-index data))))
363
364
365;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
366;;
367;;extensions to let user access and modify values
368
369
370
371
372
373;;; nth-frame-info, set-nth-frame-info, & frame-lfun are in "inspector;new-backtrace"
374
375
376
377
378
379
380(defparameter *saved-register-count+1*
381  (1+ *saved-register-count*))
382
383
384
385(defparameter *saved-register-numbers*
386  #+x8664-target #(wrong)
387  #+ppc-target #(31 30 29 28 27 26 25 24))
388
389;;; Don't do unbound checks in compiled code
390(declaim (type t *saved-register-count* *saved-register-count+1*
391               *saved-register-names* *saved-register-numbers*))
392
393(defmacro %cons-saved-register-vector ()
394  `(make-array (the fixnum *saved-register-count+1*) :initial-element nil))
395
396(defun copy-srv (from-srv &optional to-srv)
397  (if to-srv
398    (if (eq from-srv to-srv)
399      to-srv
400      (dotimes (i (uvsize from-srv) to-srv)
401        (setf (uvref to-srv i) (uvref from-srv i))))
402    (copy-uvector from-srv)))
403
404(defmacro srv.unresolved (saved-register-vector)
405  `(svref ,saved-register-vector 0))
406
407(defmacro srv.register-n (saved-register-vector n)
408  `(svref ,saved-register-vector (1+ ,n)))
409
410;;; This isn't quite right - has to look at all functions on stack,
411;;; not just those that saved VSPs.
412
413
414(defun frame-restartable-p (target &optional context)
415  (multiple-value-bind (frame last-catch srv) (last-catch-since-saved-vars target context)
416    (when frame
417      (loop
418        (when (null frame)
419          (return-from frame-restartable-p nil))
420        (when (eq frame target) (return))
421        (multiple-value-setq (frame last-catch srv)
422          (ccl::parent-frame-saved-vars context frame last-catch srv srv)))
423      (when (and srv (eql 0 (srv.unresolved srv)))
424        (setf (srv.unresolved srv) last-catch)
425        srv))))
426
427
428;;; get the saved register addresses for this frame
429;;; still need to worry about this unresolved business
430;;; could share some code with parent-frame-saved-vars
431(defun my-saved-vars (frame &optional (srv-out (%cons-saved-register-vector)))
432  (let ((unresolved 0))
433    (multiple-value-bind (lfun pc) (cfp-lfun frame)
434        (if lfun
435          (multiple-value-bind (mask where) (registers-used-by lfun pc)
436            (when mask
437              (if (not where) 
438                (setq unresolved (%ilogior unresolved mask))
439                (let ((vsp (- (frame-vsp frame) where (1- (logcount mask))))
440                      (j *saved-register-count*))
441                  (declare (fixnum j))
442                  (dotimes (i j)
443                    (declare (fixnum i))
444                    (when (%ilogbitp (decf j) mask)
445                      (setf (srv.register-n srv-out i) vsp
446                            vsp (1+ vsp)
447                            unresolved (%ilogand unresolved (%ilognot (%ilsl j 1))))))))))
448          (setq unresolved (1- (ash 1 *saved-register-count*)))))
449    (setf (srv.unresolved srv-out) unresolved)
450    srv-out))
451
452(defun parent-frame-saved-vars 
453       (context frame last-catch srv &optional (srv-out (%cons-saved-register-vector)))
454  (copy-srv srv srv-out)
455  (let* ((parent (and frame (parent-frame frame context)))
456         (grand-parent (and parent (parent-frame parent context))))
457    (when grand-parent
458      (loop (let ((next-catch (and last-catch (next-catch last-catch))))
459              ;(declare (ignore next-catch))
460              (if (and next-catch (%stack< (catch-frame-sp next-catch) grand-parent context))
461                (progn
462                  (setf last-catch next-catch
463                        (srv.unresolved srv-out) 0)
464                  (dotimes (i *saved-register-count*)
465                    (setf (srv.register-n srv i) nil)))
466                (return))))
467      (lookup-registers parent context grand-parent srv-out)
468      (values parent last-catch srv-out))))
469
470(defun lookup-registers (parent context grand-parent srv-out)
471  (unless (or (eql (frame-vsp grand-parent) 0)
472              (let ((gg-parent (parent-frame grand-parent context)))
473                (eql (frame-vsp gg-parent) 0)))
474    (multiple-value-bind (lfun pc) (cfp-lfun parent)
475      (when lfun
476        (multiple-value-bind (mask where) (registers-used-by lfun pc)
477          (when mask
478            (locally (declare (fixnum mask))
479              (if (not where) 
480                (setf (srv.unresolved srv-out) (%ilogior (srv.unresolved srv-out) mask))
481                (let* ((grand-parent-vsp (frame-vsp grand-parent)))
482
483                  (let ((vsp (- grand-parent-vsp where 1))
484                        (j *saved-register-count*))
485                    (declare (fixnum j))
486                    (dotimes (i j)
487                      (declare (fixnum i))
488                      (when (%ilogbitp (decf j) mask)
489                        (setf (srv.register-n srv-out i) vsp
490                              vsp (1- vsp)
491                              (srv.unresolved srv-out)
492                              (%ilogand (srv.unresolved srv-out) (%ilognot (%ilsl j 1))))))))))))))))
493
494;;; initialization for looping on parent-frame-saved-vars
495(defun last-catch-since-saved-vars (frame context)
496  (let* ((parent (parent-frame frame context))
497         (last-catch (and parent (last-catch-since parent context))))
498    (when last-catch
499      (let ((frame (catch-frame-sp last-catch))
500            (srv (%cons-saved-register-vector)))
501        (setf (srv.unresolved srv) 0)
502        (let* ((parent (parent-frame frame context))
503               (child (and parent (child-frame parent context))))
504          (when child
505            (lookup-registers child context parent srv))
506          (values child last-catch srv))))))
507
508;;; Returns 2 values:
509;;; mask srv
510;;; The mask says which registers are used at PC in LFUN.  srv is a
511;;; saved-register-vector whose register contents are the register
512;;; values registers whose bits are not set in MASK or set in
513;;; UNRESOLVED will be returned as NIL.
514
515(defun saved-register-values 
516       (lfun pc child last-catch srv &optional (srv-out (%cons-saved-register-vector)))
517  (declare (ignore child))
518  (cond ((null srv-out) (setq srv-out (copy-uvector srv)))
519        ((eq srv-out srv))
520        (t (dotimes (i (the fixnum (uvsize srv)))
521             (setf (uvref srv-out i) (uvref srv i)))))
522  (let ((mask (or (registers-used-by lfun pc) 0))
523        (unresolved (srv.unresolved srv))
524        (j *saved-register-count*))
525    (declare (fixnum j))
526    (dotimes (i j)
527      (declare (fixnum i))
528      (setf (srv.register-n srv-out i)
529            (and (%ilogbitp (setq j (%i- j 1)) mask)
530                 (not (%ilogbitp j unresolved))
531                 (safe-cell-value (get-register-value (srv.register-n srv i) last-catch j)))))
532    (setf (srv.unresolved srv-out) mask)
533    (values mask srv-out)))
534
535; Set the nth saved register to value.
536(defun set-saved-register (value n lfun pc child last-catch srv)
537  (declare (ignore lfun pc child) (dynamic-extent))
538  (let ((j (- target::node-size n))
539        (unresolved (srv.unresolved srv))
540        (addr (srv.register-n srv n)))
541    (when (logbitp j unresolved)
542      (error "Can't set register ~S to ~S" n value))
543    (set-register-value value addr last-catch j))
544  value)
545
546
547
548
549
550(defun return-from-nth-frame (n &rest values)
551  (apply-in-nth-frame n #'values values))
552
553(defun apply-in-nth-frame (n fn arglist)
554  (let* ((bt-info (car *backtrace-contexts*)))
555    (and bt-info
556         (let* ((frame (nth-frame nil (bt.youngest bt-info) n bt-info)))
557           (and frame (apply-in-frame frame fn arglist)))))
558  (format t "Can't return to frame ~d ." n))
559
560;;; This method is shadowed by one for the backtrace window.
561(defmethod nth-frame (w target n context)
562  (declare (ignore w))
563  (and target (dotimes (i n target)
564                (declare (fixnum i))
565                (unless (setq target (parent-frame target context)) (return nil)))))
566
567; If this returns at all, it's because the frame wasn't restartable.
568(defun apply-in-frame (frame fn arglist &optional context)
569  (let* ((srv (frame-restartable-p frame context))
570         (target-sp (and srv (srv.unresolved srv))))
571    (if target-sp
572      (apply-in-frame-internal context frame fn arglist srv))))
573
574(defun apply-in-frame-internal (context frame fn arglist srv)
575  (let* ((tcr (if context (bt.tcr context) (%current-tcr))))
576    (if (eq tcr (%current-tcr))
577      (%apply-in-frame frame fn arglist srv)
578      (let ((process (tcr->process tcr)))
579        (if process
580          (process-interrupt
581           process
582           #'%apply-in-frame
583           frame fn arglist srv)
584          (error "Can't find active process for ~s" tcr))))))
585
586
587(defun return-from-frame (frame &rest values)
588  (apply-in-frame frame #'values values nil))
589
590
591;;; (srv.unresolved srv) is the last catch frame, left there by
592;;; frame-restartable-p The registers in srv are locations of
593;;; variables saved between frame and that catch frame.
594(defun %apply-in-frame (frame fn arglist srv)
595  (declare (fixnum frame))
596  (let* ((catch (srv.unresolved srv))
597         (tsp-count 0)
598         (tcr (%current-tcr))
599         (parent (parent-frame frame tcr))
600         (vsp (frame-vsp parent))
601         (catch-top (%catch-top tcr))
602         (db-link (%svref catch target::catch-frame.db-link-cell))
603         (catch-count 0))
604    (declare (fixnum parent vsp db-link catch-count))
605    ;; Figure out how many catch frames to throw through
606    (loop
607      (unless catch-top
608        (error "Didn't find catch frame"))
609      (incf catch-count)
610      (when (eq catch-top catch)
611        (return))
612      (setq catch-top (next-catch catch-top)))
613    ;; Figure out where the db-link should be
614    (loop
615      (when (or (eql db-link 0) (>= db-link vsp))
616        (return))
617      (setq db-link (%fixnum-ref db-link)))
618    ;; Figure out how many TSP frames to pop after throwing.
619    (let ((sp (catch-frame-sp catch)))
620      (loop
621        (multiple-value-bind (f pc) (cfp-lfun sp)
622          (when f (incf tsp-count (active-tsp-count f pc))))
623        (setq sp (parent-frame sp tcr))
624        (when (eql sp parent) (return))
625        (unless sp (error "Didn't find frame: ~s" frame))))
626    #+debug
627    (cerror "Continue" "(apply-in-frame ~s ~s ~s ~s ~s ~s ~s)"
628            catch-count srv tsp-count db-link parent fn arglist)
629    (%%apply-in-frame catch-count srv tsp-count db-link parent fn arglist)))
630
631
632
633
634;;;;;;;;;;;;;;;;;;;;;;;
635;;;
636;;; Code to determine how many tsp frames to pop.
637;;; This is done by parsing the code.
638;;; active-tsp-count is the entry point below.
639;;;
640
641(defstruct (branch-tree (:print-function print-branch-tree))
642  first-instruction
643  last-instruction
644  branch-target     ; a branch-tree or nil
645  fall-through)     ; a branch-tree or nil
646
647(defun print-branch-tree (tree stream print-level)
648  (declare (ignore print-level))
649  (print-unreadable-object (tree stream :type t :identity t)
650    (format stream "~s-~s"
651            (branch-tree-first-pc tree)
652            (branch-tree-last-pc tree))))
653
654(defun branch-tree-first-pc (branch-tree)
655  (let ((first (branch-tree-first-instruction branch-tree)))
656    (and first (instruction-element-address first))))
657
658(defun branch-tree-last-pc (branch-tree)
659  (let ((last (branch-tree-last-instruction branch-tree)))
660    (if last
661      (instruction-element-address last)
662      (branch-tree-first-pc branch-tree))))
663
664(defun branch-tree-contains-pc-p (branch-tree pc)
665  (<= (branch-tree-first-pc branch-tree)
666      pc
667      (branch-tree-last-pc branch-tree)))
668
669(defvar *branch-tree-hash*
670  (make-hash-table :test 'eq :weak :value))
671
672(defun get-branch-tree (function)
673  (or (gethash function *branch-tree-hash*)
674      (let* ((dll (function-to-dll-header function))
675             (tree (dll-to-branch-tree dll)))
676        (setf (gethash function *branch-tree-hash*) tree))))         
677
678; Return the number of TSP frames that will be active after throwing out
679; of all the active catch frames in function at pc.
680; PC is a byte address, a multiple of 4.
681(defun active-tsp-count (function pc)
682  (setq function
683        (require-type
684         (if (symbolp function)
685           (symbol-function function)
686           function)
687         'compiled-function))
688  (let* ((tree (get-branch-tree function))
689         (visited nil))
690    (labels ((find-pc (branch path)
691               (unless (memq branch visited)
692                 (push branch path)
693                 (if (branch-tree-contains-pc-p branch pc)
694                   path
695                   (let ((target (branch-tree-branch-target branch))
696                         (fall-through (branch-tree-fall-through branch)))
697                     (push branch visited)
698                     (if fall-through
699                       (or (and target (find-pc target path))
700                           (find-pc fall-through path))
701                       (and target (find-pc target path))))))))
702      (let* ((path (nreverse (find-pc tree nil)))
703             (last-tree (car (last path)))
704             (catch-count 0)
705             (tsp-count 0))
706        (unless path
707          (error "Can't find path to pc: ~s in ~s" pc function))
708        (dolist (tree path)
709          (let ((next (branch-tree-first-instruction tree))
710                (last (branch-tree-last-instruction tree)))
711            (loop
712              (when (and (eq tree last-tree)
713                         (eql pc (instruction-element-address next)))
714                ; If the instruction before the current one is an ff-call,
715                ; then callback pushed a TSP frame.
716                #| ; Not any more
717                (when (ff-call-instruction-p (dll-node-pred next))
718                  (incf tsp-count))
719                |#
720                (return))
721              (multiple-value-bind (type target fall-through count) (categorize-instruction next)
722                (declare (ignore target fall-through))
723                (case type
724                  (:tsp-push
725                   (when (eql catch-count 0)
726                     (incf tsp-count count)))
727                  (:tsp-pop
728                   (when (eql catch-count 0)
729                     (decf tsp-count count)))
730                  ((:catch :unwind-protect)
731                   (incf catch-count))
732                  (:throw
733                   (decf catch-count count))))
734              (when (eq next last)
735                (return))
736              (setq next (dll-node-succ next)))))
737        tsp-count))))
738       
739
740(defun dll-to-branch-tree (dll)
741  (let* ((hash (make-hash-table :test 'eql))    ; start-pc -> branch-tree
742         (res (collect-branch-tree (dll-header-first dll) dll hash))
743         (did-something nil))
744    (loop
745      (setq did-something nil)
746      (let ((mapper #'(lambda (key value)
747                        (declare (ignore key))
748                        (flet ((maybe-collect (pc)
749                                 (when (integerp pc)
750                                   (let ((target-tree (gethash pc hash)))
751                                     (if target-tree
752                                       target-tree
753                                       (progn
754                                         (collect-branch-tree (dll-pc->instr dll pc) dll hash)
755                                         (setq did-something t)
756                                         nil))))))
757                          (declare (dynamic-extent #'maybe-collect))
758                          (let ((target-tree (maybe-collect (branch-tree-branch-target value))))
759                            (when target-tree (setf (branch-tree-branch-target value) target-tree)))
760                          (let ((target-tree (maybe-collect (branch-tree-fall-through value))))
761                            (when target-tree (setf (branch-tree-fall-through value) target-tree)))))))
762        (declare (dynamic-extent mapper))
763        (maphash mapper hash))
764      (unless did-something (return)))
765    ; To be totally correct, we should fix up the trees containing
766    ; the BLR instruction for unwind-protect cleanups, but none
767    ; of the users of this code yet care that it appears that the code
768    ; stops there.
769    res))
770
771(defun collect-branch-tree (instr dll hash)
772  (unless (eq instr dll)
773    (let ((tree (make-branch-tree :first-instruction instr))
774          (pred nil)
775          (next instr))
776      (setf (gethash (instruction-element-address instr) hash)
777            tree)
778      (loop
779        (when (eq next dll)
780          (setf (branch-tree-last-instruction tree) pred)
781          (return))
782        (multiple-value-bind (type target fall-through) (categorize-instruction next)
783          (case type
784            (:label
785             (when pred
786               (setf (branch-tree-last-instruction tree) pred
787                     (branch-tree-fall-through tree) (instruction-element-address next))
788               (return)))
789            ((:branch :catch :unwind-protect)
790             (setf (branch-tree-last-instruction tree) next
791                   (branch-tree-branch-target tree) target
792                   (branch-tree-fall-through tree) fall-through)
793             (return))))
794        (setq pred next
795              next (dll-node-succ next)))
796      tree)))
797
798;;; Returns 4 values:
799;;; 1) type: one of :regular, :label, :branch, :catch, :unwind-protect, :throw, :tsp-push, :tsp-pop
800;;; 2) branch target (or catch or unwind-protect cleanup)
801;;; 3) branch-fallthrough (or catch or unwind-protect body)
802;;; 4) Count for throw, tsp-push, tsp-pop
803(defun categorize-instruction (instr)
804  (etypecase instr
805    (lap-label :label)
806    (lap-instruction
807     (let* ((opcode (lap-instruction-opcode instr))
808            (opcode-p (typep opcode 'opcode))
809            (name (if opcode-p (opcode-name opcode) opcode))
810            (pc (lap-instruction-address instr))
811            (operands (lap-instruction-parsed-operands instr)))
812       (cond ((equalp name "bla")
813              (let ((subprim (car operands)))
814                (case subprim
815                  (.SPmkunwind
816                   (values :unwind-protect (+ pc 4) (+ pc 8)))
817                  ((.SPmkcatch1v .SPmkcatchmv)
818                   (values :catch (+ pc 4) (+ pc 8)))
819                  (.SPthrow
820                   (values :branch nil nil))
821                  ((.SPnthrowvalues .SPnthrow1value)
822                   (let* ((prev-instr (require-type (lap-instruction-pred instr)
823                                                    'lap-instruction))
824                          (prev-name (opcode-name (lap-instruction-opcode prev-instr)))
825                          (prev-operands (lap-instruction-parsed-operands prev-instr)))
826                     ; Maybe we should recognize the other possible outputs of ppc2-lwi, but I
827                     ; can't imagine we'll ever see them
828                     (unless (and (equalp prev-name "li")
829                                  (equalp (car prev-operands) "imm0"))
830                       (error "Can't determine throw count for ~s" instr))
831                     (values :throw nil (+ pc 4) (ash (cadr prev-operands) (- target::fixnum-shift)))))
832                  ((.SPprogvsave
833                    .SPstack-rest-arg .SPreq-stack-rest-arg .SPstack-cons-rest-arg
834                    .SPmakestackblock .SPmakestackblock0 .SPmakestacklist .SPstkgvector
835                    .SPstkconslist .SPstkconslist-star
836                    .SPmkstackv .SPstack-misc-alloc .SPstack-misc-alloc-init
837                    .SPstkvcell0 .SPstkvcellvsp
838                    .SPsave-values)
839                   (values :tsp-push nil nil 1))
840                  (.SPrecover-values
841                   (values :tsp-pop nil nil 1))
842                  (t :regular))))
843             ((or (equalp name "lwz") (equalp name "addi"))
844              (if (equalp (car operands) "tsp")
845                (values :tsp-pop nil nil 1)
846                :regular))
847             ((equalp name "stwu")
848              (if (equalp (car operands) "tsp")
849                (values :tsp-push nil nil 1)
850                :regular))
851             ((member name '("ba" "blr" "bctr") :test 'equalp)
852              (values :branch nil nil))
853             ; It would probably be faster to determine the branch address by adding the PC and the offset.
854             ((equalp name "b")
855              (values :branch (branch-label-address instr (car (last operands))) nil))
856             ((and opcode-p (eql (opcode-majorop opcode) 16))
857              (values :branch (branch-label-address instr (car (last operands))) (+ pc 4)))
858             (t :regular))))))
859
860(defun branch-label-address (instr label-name &aux (next instr))
861  (loop
862    (setq next (dll-node-succ next))
863    (when (eq next instr)
864      (error "Couldn't find label ~s" label-name))
865    (when (and (typep next 'lap-label)
866               (eq (lap-label-name next) label-name))
867      (return (instruction-element-address next)))))
868
869(defun dll-pc->instr (dll pc)
870  (let ((next (dll-node-succ dll)))
871    (loop
872      (when (eq next dll)
873        (error "Couldn't find pc: ~s in ~s" pc dll))
874      (when (eql (instruction-element-address next) pc)
875        (return next))
876      (setq next (dll-node-succ next)))))
877
878(defun exception-frame-p (frame)
879  (fake-stack-frame-p frame))
880
881(defun arg-check-call-arguments (frame function)
882  (declare (ignore function))
883  (xp-argument-list (%fake-stack-frame.xp frame)))
Note: See TracBrowser for help on using the repository browser.