source: trunk/ccl/lib/backtrace-lds.lisp @ 4535

Last change on this file since 4535 was 4535, checked in by gb, 14 years ago

Move GET/SET-REGISTER-VALUE to TARGET-backtrace.lisp.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 26.9 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;;; backtrace-lds.lisp
18;;; low-level support for stack-backtrace dialog (Lisp Development System)
19
20(in-package "CCL")
21
22
23(defparameter *saved-register-count*
24  #+x8664-target 4
25  #+ppc-target 8)
26
27(defparameter *saved-register-names*
28  #+x8664-target #(save3 save2 save1 save0)
29  #+ppc-target #(save7 save6 save5 save4 save3 save2 save1 save0))
30
31
32;;; Returns five values: (ARGS TYPES NAMES COUNT NCLOSED)
33;;; ARGS is a list of the args supplied to the function
34;;; TYPES is a list of the types of the args.
35;;; NAMES is a list of the names of the args.
36;;; TYPES & NAMES will hae entries only for closed-over,
37;;;       required, & optional args.
38;;; COUNT is the number of known-correct elements of ARGS, or T if
39;;;       they're all correct.
40;;; ARGS will be filled with NIL up to the number of required args to lfun
41;;; NCLOSED is the number of closed-over values that are in the prefix of ARGS
42;;;       If COUNT < NCLOSED, it is not safe to restart the function.
43(defun frame-supplied-args (frame lfun pc child context)
44  (declare (ignore child))
45  (multiple-value-bind (req opt restp keys allow-other-keys optinit lexprp ncells nclosed)
46      (function-args lfun)
47    (declare (ignore allow-other-keys lexprp ncells))
48    (multiple-value-bind (child-vsp vsp) (vsp-limits frame context)
49      (decf vsp)
50      (let* ((frame-size (- vsp child-vsp))
51             (res nil)
52             (types nil)
53             (names nil))
54        (flet ((push-type&name (cellno)
55                 (multiple-value-bind (type name) (find-local-name cellno lfun pc)
56                   (push type types)
57                   (push name names))))
58          (declare (dynamic-extent #'push-type&name))
59          (if (or
60               (<= frame-size 0))
61            ;; Can't parse the frame, but all but the last 3 args are on the stack
62            (let* ((nargs (+ nclosed req))
63                   (vstack-args (max 0 (min frame-size (- nargs 3)))))
64              (dotimes (i vstack-args)
65                (declare (fixnum i))
66                (push (access-lisp-data vsp) res)
67                (push-type&name i)
68                (decf vsp))
69              (values (nreconc res (make-list (- nargs vstack-args)))
70                      (nreverse types)
71                      (nreverse names)
72                      vstack-args
73                      nclosed))
74            ;; All args were vpushed.
75            (let* ((might-be-rest (> frame-size (+ req opt)))
76                   (rest (and restp might-be-rest (access-lisp-data (- vsp req opt))))
77                   (cellno -1))
78              (declare (fixnum cellno))
79              (when (and keys might-be-rest (null rest))
80                (let ((vsp (- vsp req opt))
81                      (keyvect (lfun-keyvect lfun))
82                      (res nil))
83                  (dotimes (i keys)
84                    (declare (fixnum i))
85                    (when (access-lisp-data (1- vsp)) ; key-supplied-p
86                      (push (aref keyvect i) res)
87                      (push (access-lisp-data vsp) res))
88                    (decf vsp 2))
89                  (setq rest (nreverse res))))
90              (dotimes (i nclosed)
91                (declare (fixnum i))
92                (when (<= vsp child-vsp) (return))
93                (push (access-lisp-data vsp) res)
94                (push-type&name (incf cellno))
95                (decf vsp))
96              (dotimes (i req)
97                (declare (fixnum i))
98                (when (<= vsp child-vsp) (return))
99                (push (access-lisp-data vsp) res)
100                (push-type&name (incf cellno))
101                (decf vsp))
102              (if rest
103                (dotimes (i opt)        ; all optionals were specified
104                  (declare (fixnum i))
105                  (when (<= vsp child-vsp) (return))
106                  (push (access-lisp-data vsp) res)
107                  (push-type&name (incf cellno))
108                  (decf vsp))
109                (let ((offset (+ opt (if restp 1 0) (if keys (+ keys keys) 0)))
110                      (optionals nil))
111                  (dotimes (i opt)      ; some optionals may have been omitted
112                    (declare (fixnum i))
113                    (when (<= vsp child-vsp) (return))
114                    (let ((value (access-lisp-data vsp)))
115                      (if optinit
116                        (if (access-lisp-data (- vsp offset))
117                          (progn
118                            (push value optionals)
119                            (push-type&name (incf cellno))
120                            (return)))
121                        (progn (push value optionals)
122                               (push-type&name (incf cellno))))
123                      (decf vsp)))
124                  (unless optinit
125                    ;; assume that null optionals were not passed.
126                    (while (and optionals (null (car optionals)))
127                      (pop optionals)
128                      (pop types)
129                      (pop names)))
130                  (setq rest (nreconc optionals rest))))
131              (values (nreconc res rest) (nreverse types) (nreverse names)
132                      t nclosed))))))))
133
134;;; I'm skeptical about a lot of this stuff on the PPC, but if anything it's
135;;; pretty PPC-specific
136#+ppc-target
137(progn
138;;; Act as if VSTACK-INDEX points somewhere where DATA could go & put it there.
139(defun set-lisp-data (vstack-index data)
140  (let* ((old (%access-lisp-data vstack-index)))
141    (if (closed-over-value-p old)
142      (set-closed-over-value old data)
143      (%store-lisp-data vstack-index data))))
144
145
146;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
147;;
148;;extensions to let user access and modify values
149
150
151
152
153
154;;; nth-frame-info, set-nth-frame-info, & frame-lfun are in "inspector;new-backtrace"
155
156
157
158
159
160
161(defparameter *saved-register-count+1*
162  (1+ *saved-register-count*))
163
164
165
166(defparameter *saved-register-numbers*
167  #+x8664-target #(wrong)
168  #+ppc-target #(31 30 29 28 27 26 25 24))
169
170;;; Don't do unbound checks in compiled code
171(declaim (type t *saved-register-count* *saved-register-count+1*
172               *saved-register-names* *saved-register-numbers*))
173
174(defmacro %cons-saved-register-vector ()
175  `(make-array (the fixnum *saved-register-count+1*) :initial-element nil))
176
177(defun copy-srv (from-srv &optional to-srv)
178  (if to-srv
179    (if (eq from-srv to-srv)
180      to-srv
181      (dotimes (i (uvsize from-srv) to-srv)
182        (setf (uvref to-srv i) (uvref from-srv i))))
183    (copy-uvector from-srv)))
184
185(defmacro srv.unresolved (saved-register-vector)
186  `(svref ,saved-register-vector 0))
187
188(defmacro srv.register-n (saved-register-vector n)
189  `(svref ,saved-register-vector (1+ ,n)))
190
191;;; This isn't quite right - has to look at all functions on stack,
192;;; not just those that saved VSPs.
193
194
195(defun frame-restartable-p (target &optional context)
196  (multiple-value-bind (frame last-catch srv) (last-catch-since-saved-vars target context)
197    (when frame
198      (loop
199        (when (null frame)
200          (return-from frame-restartable-p nil))
201        (when (eq frame target) (return))
202        (multiple-value-setq (frame last-catch srv)
203          (ccl::parent-frame-saved-vars context frame last-catch srv srv)))
204      (when (and srv (eql 0 (srv.unresolved srv)))
205        (setf (srv.unresolved srv) last-catch)
206        srv))))
207
208
209;;; get the saved register addresses for this frame
210;;; still need to worry about this unresolved business
211;;; could share some code with parent-frame-saved-vars
212(defun my-saved-vars (frame &optional (srv-out (%cons-saved-register-vector)))
213  (let ((unresolved 0))
214    (multiple-value-bind (lfun pc) (cfp-lfun frame)
215        (if lfun
216          (multiple-value-bind (mask where) (registers-used-by lfun pc)
217            (when mask
218              (if (not where) 
219                (setq unresolved (%ilogior unresolved mask))
220                (let ((vsp (- (frame-vsp frame) where (1- (logcount mask))))
221                      (j *saved-register-count*))
222                  (declare (fixnum j))
223                  (dotimes (i j)
224                    (declare (fixnum i))
225                    (when (%ilogbitp (decf j) mask)
226                      (setf (srv.register-n srv-out i) vsp
227                            vsp (1+ vsp)
228                            unresolved (%ilogand unresolved (%ilognot (%ilsl j 1))))))))))
229          (setq unresolved (1- (ash 1 *saved-register-count*)))))
230    (setf (srv.unresolved srv-out) unresolved)
231    srv-out))
232
233(defun parent-frame-saved-vars 
234       (context frame last-catch srv &optional (srv-out (%cons-saved-register-vector)))
235  (copy-srv srv srv-out)
236  (let* ((parent (and frame (parent-frame frame context)))
237         (grand-parent (and parent (parent-frame parent context))))
238    (when grand-parent
239      (loop (let ((next-catch (and last-catch (next-catch last-catch))))
240              ;(declare (ignore next-catch))
241              (if (and next-catch (%stack< (catch-frame-sp next-catch) grand-parent context))
242                (progn
243                  (setf last-catch next-catch
244                        (srv.unresolved srv-out) 0)
245                  (dotimes (i *saved-register-count*)
246                    (setf (srv.register-n srv i) nil)))
247                (return))))
248      (lookup-registers parent context grand-parent srv-out)
249      (values parent last-catch srv-out))))
250
251(defun lookup-registers (parent context grand-parent srv-out)
252  (unless (or (eql (frame-vsp grand-parent) 0)
253              (let ((gg-parent (parent-frame grand-parent context)))
254                (eql (frame-vsp gg-parent) 0)))
255    (multiple-value-bind (lfun pc) (cfp-lfun parent)
256      (when lfun
257        (multiple-value-bind (mask where) (registers-used-by lfun pc)
258          (when mask
259            (locally (declare (fixnum mask))
260              (if (not where) 
261                (setf (srv.unresolved srv-out) (%ilogior (srv.unresolved srv-out) mask))
262                (let* ((grand-parent-vsp (frame-vsp grand-parent)))
263
264                  (let ((vsp (- grand-parent-vsp where 1))
265                        (j *saved-register-count*))
266                    (declare (fixnum j))
267                    (dotimes (i j)
268                      (declare (fixnum i))
269                      (when (%ilogbitp (decf j) mask)
270                        (setf (srv.register-n srv-out i) vsp
271                              vsp (1- vsp)
272                              (srv.unresolved srv-out)
273                              (%ilogand (srv.unresolved srv-out) (%ilognot (%ilsl j 1))))))))))))))))
274
275;;; initialization for looping on parent-frame-saved-vars
276(defun last-catch-since-saved-vars (frame context)
277  (let* ((parent (parent-frame frame context))
278         (last-catch (and parent (last-catch-since parent context))))
279    (when last-catch
280      (let ((frame (catch-frame-sp last-catch))
281            (srv (%cons-saved-register-vector)))
282        (setf (srv.unresolved srv) 0)
283        (let* ((parent (parent-frame frame context))
284               (child (and parent (child-frame parent context))))
285          (when child
286            (lookup-registers child context parent srv))
287          (values child last-catch srv))))))
288
289;;; Returns 2 values:
290;;; mask srv
291;;; The mask says which registers are used at PC in LFUN.  srv is a
292;;; saved-register-vector whose register contents are the register
293;;; values registers whose bits are not set in MASK or set in
294;;; UNRESOLVED will be returned as NIL.
295
296(defun saved-register-values 
297       (lfun pc child last-catch srv &optional (srv-out (%cons-saved-register-vector)))
298  (declare (ignore child))
299  (cond ((null srv-out) (setq srv-out (copy-uvector srv)))
300        ((eq srv-out srv))
301        (t (dotimes (i (the fixnum (uvsize srv)))
302             (setf (uvref srv-out i) (uvref srv i)))))
303  (let ((mask (or (registers-used-by lfun pc) 0))
304        (unresolved (srv.unresolved srv))
305        (j *saved-register-count*))
306    (declare (fixnum j))
307    (dotimes (i j)
308      (declare (fixnum i))
309      (setf (srv.register-n srv-out i)
310            (and (%ilogbitp (setq j (%i- j 1)) mask)
311                 (not (%ilogbitp j unresolved))
312                 (safe-cell-value (get-register-value (srv.register-n srv i) last-catch j)))))
313    (setf (srv.unresolved srv-out) mask)
314    (values mask srv-out)))
315
316; Set the nth saved register to value.
317(defun set-saved-register (value n lfun pc child last-catch srv)
318  (declare (ignore lfun pc child) (dynamic-extent saved-register-values))
319  (let ((j (- target::node-size n))
320        (unresolved (srv.unresolved srv))
321        (addr (srv.register-n srv n)))
322    (when (logbitp j unresolved)
323      (error "Can't set register ~S to ~S" n value))
324    (set-register-value value addr last-catch j))
325  value)
326
327
328
329
330
331(defun return-from-nth-frame (n &rest values)
332  (apply-in-nth-frame n #'values values))
333
334(defun apply-in-nth-frame (n fn arglist)
335  (let* ((bt-info (car *backtrace-contexts*)))
336    (and bt-info
337         (let* ((frame (nth-frame nil (bt.youngest bt-info) n bt-info)))
338           (and frame (apply-in-frame frame fn arglist)))))
339  (format t "Can't return to frame ~d ." n))
340
341;;; This method is shadowed by one for the backtrace window.
342(defmethod nth-frame (w target n context)
343  (declare (ignore w))
344  (and target (dotimes (i n target)
345                (declare (fixnum i))
346                (unless (setq target (parent-frame target context)) (return nil)))))
347
348; If this returns at all, it's because the frame wasn't restartable.
349(defun apply-in-frame (frame fn arglist &optional context)
350  (let* ((srv (frame-restartable-p frame context))
351         (target-sp (and srv (srv.unresolved srv))))
352    (if target-sp
353      (apply-in-frame-internal context frame fn arglist srv))))
354
355(defun apply-in-frame-internal (context frame fn arglist srv)
356  (let* ((tcr (if context (bt.tcr context) (%current-tcr))))
357    (if (eq tcr (%current-tcr))
358      (%apply-in-frame frame fn arglist srv)
359      (let ((process (tcr->process tcr)))
360        (if process
361          (process-interrupt
362           process
363           #'%apply-in-frame
364           frame fn arglist srv)
365          (error "Can't find active process for ~s" tcr))))))
366
367
368
369
370;;; (srv.unresolved srv) is the last catch frame, left there by
371;;; frame-restartable-p The registers in srv are locations of
372;;; variables saved between frame and that catch frame.
373(defun %apply-in-frame (frame fn arglist srv)
374  (declare (fixnum frame))
375  (let* ((catch (srv.unresolved srv))
376         (tsp-count 0)
377         (tcr (%current-tcr))
378         (parent (parent-frame frame tcr))
379         (vsp (frame-vsp parent))
380         (catch-top (%catch-top tcr))
381         (db-link (%svref catch target::catch-frame.db-link-cell))
382         (catch-count 0))
383    (declare (fixnum parent vsp db-link catch-count))
384    ;; Figure out how many catch frames to throw through
385    (loop
386      (unless catch-top
387        (error "Didn't find catch frame"))
388      (incf catch-count)
389      (when (eq catch-top catch)
390        (return))
391      (setq catch-top (next-catch catch-top)))
392    ;; Figure out where the db-link should be
393    (loop
394      (when (or (eql db-link 0) (>= db-link vsp))
395        (return))
396      (setq db-link (%fixnum-ref db-link)))
397    ;; Figure out how many TSP frames to pop after throwing.
398    (let ((sp (catch-frame-sp catch)))
399      (loop
400        (multiple-value-bind (f pc) (cfp-lfun sp)
401          (when f (incf tsp-count (active-tsp-count f pc))))
402        (setq sp (parent-frame sp tcr))
403        (when (eql sp parent) (return))
404        (unless sp (error "Didn't find frame: ~s" frame))))
405    #+debug
406    (cerror "Continue" "(apply-in-frame ~s ~s ~s ~s ~s ~s ~s)"
407            catch-count srv tsp-count db-link parent fn arglist)
408    (%%apply-in-frame catch-count srv tsp-count db-link parent fn arglist)))
409
410
411
412
413;;;;;;;;;;;;;;;;;;;;;;;
414;;;
415;;; Code to determine how many tsp frames to pop.
416;;; This is done by parsing the code.
417;;; active-tsp-count is the entry point below.
418;;;
419
420#+ppc-target
421(progn
422
423(defstruct (branch-tree (:print-function print-branch-tree))
424  first-instruction
425  last-instruction
426  branch-target     ; a branch-tree or nil
427  fall-through)     ; a branch-tree or nil
428
429(defun print-branch-tree (tree stream print-level)
430  (declare (ignore print-level))
431  (print-unreadable-object (tree stream :type t :identity t)
432    (format stream "~s-~s"
433            (branch-tree-first-pc tree)
434            (branch-tree-last-pc tree))))
435
436(defun branch-tree-first-pc (branch-tree)
437  (let ((first (branch-tree-first-instruction branch-tree)))
438    (and first (instruction-element-address first))))
439
440(defun branch-tree-last-pc (branch-tree)
441  (let ((last (branch-tree-last-instruction branch-tree)))
442    (if last
443      (instruction-element-address last)
444      (branch-tree-first-pc branch-tree))))
445
446(defun branch-tree-contains-pc-p (branch-tree pc)
447  (<= (branch-tree-first-pc branch-tree)
448      pc
449      (branch-tree-last-pc branch-tree)))
450
451(defvar *branch-tree-hash*
452  (make-hash-table :test 'eq :weak :value))
453
454(defun get-branch-tree (function)
455  (or (gethash function *branch-tree-hash*)
456      (let* ((dll (function-to-dll-header function))
457             (tree (dll-to-branch-tree dll)))
458        (setf (gethash function *branch-tree-hash*) tree))))         
459
460; Return the number of TSP frames that will be active after throwing out
461; of all the active catch frames in function at pc.
462; PC is a byte address, a multiple of 4.
463(defun active-tsp-count (function pc)
464  (setq function
465        (require-type
466         (if (symbolp function)
467           (symbol-function function)
468           function)
469         'compiled-function))
470  (let* ((tree (get-branch-tree function))
471         (visited nil))
472    (labels ((find-pc (branch path)
473               (unless (memq branch visited)
474                 (push branch path)
475                 (if (branch-tree-contains-pc-p branch pc)
476                   path
477                   (let ((target (branch-tree-branch-target branch))
478                         (fall-through (branch-tree-fall-through branch)))
479                     (push branch visited)
480                     (if fall-through
481                       (or (and target (find-pc target path))
482                           (find-pc fall-through path))
483                       (and target (find-pc target path))))))))
484      (let* ((path (nreverse (find-pc tree nil)))
485             (last-tree (car (last path)))
486             (catch-count 0)
487             (tsp-count 0))
488        (unless path
489          (error "Can't find path to pc: ~s in ~s" pc function))
490        (dolist (tree path)
491          (let ((next (branch-tree-first-instruction tree))
492                (last (branch-tree-last-instruction tree)))
493            (loop
494              (when (and (eq tree last-tree)
495                         (eql pc (instruction-element-address next)))
496                ; If the instruction before the current one is an ff-call,
497                ; then callback pushed a TSP frame.
498                #| ; Not any more
499                (when (ff-call-instruction-p (dll-node-pred next))
500                  (incf tsp-count))
501                |#
502                (return))
503              (multiple-value-bind (type target fall-through count) (categorize-instruction next)
504                (declare (ignore target fall-through))
505                (case type
506                  (:tsp-push
507                   (when (eql catch-count 0)
508                     (incf tsp-count count)))
509                  (:tsp-pop
510                   (when (eql catch-count 0)
511                     (decf tsp-count count)))
512                  ((:catch :unwind-protect)
513                   (incf catch-count))
514                  (:throw
515                   (decf catch-count count))))
516              (when (eq next last)
517                (return))
518              (setq next (dll-node-succ next)))))
519        tsp-count))))
520       
521
522(defun dll-to-branch-tree (dll)
523  (let* ((hash (make-hash-table :test 'eql))    ; start-pc -> branch-tree
524         (res (collect-branch-tree (dll-header-first dll) dll hash))
525         (did-something nil))
526    (loop
527      (setq did-something nil)
528      (let ((mapper #'(lambda (key value)
529                        (declare (ignore key))
530                        (flet ((maybe-collect (pc)
531                                 (when (integerp pc)
532                                   (let ((target-tree (gethash pc hash)))
533                                     (if target-tree
534                                       target-tree
535                                       (progn
536                                         (collect-branch-tree (dll-pc->instr dll pc) dll hash)
537                                         (setq did-something t)
538                                         nil))))))
539                          (declare (dynamic-extent #'maybe-collect))
540                          (let ((target-tree (maybe-collect (branch-tree-branch-target value))))
541                            (when target-tree (setf (branch-tree-branch-target value) target-tree)))
542                          (let ((target-tree (maybe-collect (branch-tree-fall-through value))))
543                            (when target-tree (setf (branch-tree-fall-through value) target-tree)))))))
544        (declare (dynamic-extent mapper))
545        (maphash mapper hash))
546      (unless did-something (return)))
547    ; To be totally correct, we should fix up the trees containing
548    ; the BLR instruction for unwind-protect cleanups, but none
549    ; of the users of this code yet care that it appears that the code
550    ; stops there.
551    res))
552
553(defun collect-branch-tree (instr dll hash)
554  (unless (eq instr dll)
555    (let ((tree (make-branch-tree :first-instruction instr))
556          (pred nil)
557          (next instr))
558      (setf (gethash (instruction-element-address instr) hash)
559            tree)
560      (loop
561        (when (eq next dll)
562          (setf (branch-tree-last-instruction tree) pred)
563          (return))
564        (multiple-value-bind (type target fall-through) (categorize-instruction next)
565          (case type
566            (:label
567             (when pred
568               (setf (branch-tree-last-instruction tree) pred
569                     (branch-tree-fall-through tree) (instruction-element-address next))
570               (return)))
571            ((:branch :catch :unwind-protect)
572             (setf (branch-tree-last-instruction tree) next
573                   (branch-tree-branch-target tree) target
574                   (branch-tree-fall-through tree) fall-through)
575             (return))))
576        (setq pred next
577              next (dll-node-succ next)))
578      tree)))
579
580;;; Returns 4 values:
581;;; 1) type: one of :regular, :label, :branch, :catch, :unwind-protect, :throw, :tsp-push, :tsp-pop
582;;; 2) branch target (or catch or unwind-protect cleanup)
583;;; 3) branch-fallthrough (or catch or unwind-protect body)
584;;; 4) Count for throw, tsp-push, tsp-pop
585#+ppc-target
586(defun categorize-instruction (instr)
587  (etypecase instr
588    (lap-label :label)
589    (lap-instruction
590     (let* ((opcode (lap-instruction-opcode instr))
591            (opcode-p (typep opcode 'opcode))
592            (name (if opcode-p (opcode-name opcode) opcode))
593            (pc (lap-instruction-address instr))
594            (operands (lap-instruction-parsed-operands instr)))
595       (cond ((equalp name "bla")
596              (let ((subprim (car operands)))
597                (case subprim
598                  (.SPmkunwind
599                   (values :unwind-protect (+ pc 4) (+ pc 8)))
600                  ((.SPmkcatch1v .SPmkcatchmv)
601                   (values :catch (+ pc 4) (+ pc 8)))
602                  (.SPthrow
603                   (values :branch nil nil))
604                  ((.SPnthrowvalues .SPnthrow1value)
605                   (let* ((prev-instr (require-type (lap-instruction-pred instr)
606                                                    'lap-instruction))
607                          (prev-name (opcode-name (lap-instruction-opcode prev-instr)))
608                          (prev-operands (lap-instruction-parsed-operands prev-instr)))
609                     ; Maybe we should recognize the other possible outputs of ppc2-lwi, but I
610                     ; can't imagine we'll ever see them
611                     (unless (and (equalp prev-name "li")
612                                  (equalp (car prev-operands) "imm0"))
613                       (error "Can't determine throw count for ~s" instr))
614                     (values :throw nil (+ pc 4) (ash (cadr prev-operands) (- target::fixnum-shift)))))
615                  ((.SPprogvsave
616                    .SPstack-rest-arg .SPreq-stack-rest-arg .SPstack-cons-rest-arg
617                    .SPmakestackblock .SPmakestackblock0 .SPmakestacklist .SPstkgvector
618                    .SPstkconslist .SPstkconslist-star
619                    .SPmkstackv .SPstack-misc-alloc .SPstack-misc-alloc-init
620                    .SPstkvcell0 .SPstkvcellvsp
621                    .SPsave-values)
622                   (values :tsp-push nil nil 1))
623                  (.SPrecover-values
624                   (values :tsp-pop nil nil 1))
625                  (t :regular))))
626             ((or (equalp name "lwz") (equalp name "addi"))
627              (if (equalp (car operands) "tsp")
628                (values :tsp-pop nil nil 1)
629                :regular))
630             ((equalp name "stwu")
631              (if (equalp (car operands) "tsp")
632                (values :tsp-push nil nil 1)
633                :regular))
634             ((member name '("ba" "blr" "bctr") :test 'equalp)
635              (values :branch nil nil))
636             ; It would probably be faster to determine the branch address by adding the PC and the offset.
637             ((equalp name "b")
638              (values :branch (branch-label-address instr (car (last operands))) nil))
639             ((and opcode-p (eql (opcode-majorop opcode) 16))
640              (values :branch (branch-label-address instr (car (last operands))) (+ pc 4)))
641             (t :regular))))))
642
643(defun branch-label-address (instr label-name &aux (next instr))
644  (loop
645    (setq next (dll-node-succ next))
646    (when (eq next instr)
647      (error "Couldn't find label ~s" label-name))
648    (when (and (typep next 'lap-label)
649               (eq (lap-label-name next) label-name))
650      (return (instruction-element-address next)))))
651
652(defun dll-pc->instr (dll pc)
653  (let ((next (dll-node-succ dll)))
654    (loop
655      (when (eq next dll)
656        (error "Couldn't find pc: ~s in ~s" pc dll))
657      (when (eql (instruction-element-address next) pc)
658        (return next))
659      (setq next (dll-node-succ next)))))
660
661)  ; end of #+ppc-target progn
662) ; end of another #+ppc-target progn
663#|
664(setq *save-local-symbols* t)
665
666(defun test (flip flop &optional bar)
667  (let ((another-one t)
668        (bar 'quux))
669    (break)))
670
671(test '(a b c d) #\a)
672
673(defun closure-test (flim flam)
674  (labels ((inner (x)
675              (let ((ret (list x flam)))
676                (break))))
677    (inner flim)
678    (break)))
679
680(closure-test '(a b c) 'quux)
681
682(defun set-test (a b)
683  (break)
684  (+ a b))
685
686(set-test 1 'a)
687
688||#
689
690
691(provide 'backtrace-lds)
692
693; End of backtrace-lds.lisp
Note: See TracBrowser for help on using the repository browser.