;;;-*-Mode: LISP; Package: CCL -*-
;;;
;;; Copyright 1994-2009 Clozure Associates
;;;
;;; Licensed under the Apache License, Version 2.0 (the "License");
;;; you may not use this file except in compliance with the License.
;;; You may obtain a copy of the License at
;;;
;;;     http://www.apache.org/licenses/LICENSE-2.0
;;;
;;; Unless required by applicable law or agreed to in writing, software
;;; distributed under the License is distributed on an "AS IS" BASIS,
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
;;; See the License for the specific language governing permissions and
;;; limitations under the License.


(in-package "CCL")

(def-accessors (fake-stack-frame) %svref
  nil                           ; 'fake-stack-frame
  %fake-stack-frame.sp          ; fixnum. The stack pointer where this frame "should" be
  %fake-stack-frame.next-sp     ; Either sp or another fake-stack-frame
  %fake-stack-frame.fn          ; The current function
  %fake-stack-frame.lr          ; fixnum offset from fn (nil if fn is not functionp)
  %fake-stack-frame.vsp         ; The value stack pointer
  %fake-stack-frame.xp          ; Exception frame.
  %fake-stack-frame.link        ; next in *fake-stack-frames* list
  )

;;; Linked list of fake stack frames.
;;; %frame-backlink looks here
(def-standard-initial-binding *fake-stack-frames* nil)
  

(defun fake-stack-frame-p (x)
  (istruct-typep x 'fake-stack-frame))

(defun cfp-lfun (p)
  (if (fake-stack-frame-p p)
    (let* ((fn (%fake-stack-frame.fn p))
           (lr (%fake-stack-frame.lr p)))
      (if (and (typep fn 'function)
               (typep lr 'fixnum))
        (values fn lr)
        (values nil nil)))
    (%cfp-lfun p)))


(defun %stack< (index1 index2 &optional context)
  (cond ((fake-stack-frame-p index1)
         (let ((sp1 (%fake-stack-frame.sp index1)))
           (declare (fixnum sp1))
           (if (fake-stack-frame-p index2)
             (or (%stack< sp1 (%fake-stack-frame.sp index2) context)
                 (eq index2 (%fake-stack-frame.next-sp index1)))
             (%stack< sp1 (%i+ index2 1) context))))
        ((fake-stack-frame-p index2)
         (%stack< index1 (%fake-stack-frame.sp index2) context))
        (t (let* ((tcr (if context (bt.tcr context) (%current-tcr)))
                  (cs-area (%fixnum-ref tcr target::tcr.cs-area)))
             (and (%ptr-in-area-p index1 cs-area)
                  (%ptr-in-area-p index2 cs-area)
                  (< (the fixnum index1) (the fixnum index2)))))))

;;; Returns two values:
;;;  [nil, nil] if it can be reliably determined that function uses no registers at PC
;;;  [mask, savevsp]  if it can be reliably determined that the registers specified by "mask"
;;;      were saved at "savevsp" in the function's stack frame
;;;  [mask, nil] if registers in "mask" MAY have been saved, but we don't know how to restore them
;;;      (perhaps because the "at-pc" argument wasn't specified.


;;; If the last instruction in a code vector is an
;;; LWZ instruction (of the form "(LWZ rx s16 ry)"),
;;; then 
;;;   this function uses registers RX-R31.  Note that this leaves
;;;    us 2 extra bits, since we're only encoding 3 bits worth of
;;;    register info.
;;;   RX is saved nearest the top of the vstack
;;;   s16 is the offset from the saved-vsp to the address at which
;;;    RX was saved; this is a negative value whose low two bits
;;;    are ignored
;;;   (logior (ash (logand s16 3) 5) rY) is the pc at which
;;;   the registers were saved (a fullword code-vector index).
;;; This scheme lets us encode any "simple" register usage, where
;;; the registers were saved once, saved somewhere within the first 
;;; 128 instructions in the code vector, and nothing interesting (to
;;; backtrace) happens after the registers have been restored.
;;; If the compiler ever gets cleverer about this, we'll have to use
;;; some other scheme (perhaps a STW instruction, preceded by branches).
;;;
;;; Note that the "last instruction" really means "last instruction
;;; before any traceback table"; we should be able to truncate the code
;;; vector (probably by copying it) to strip off the traceback table
;;; without losing this information.
;;; Note also that the disassembler would probably ordinarily want to
;;; hide this last instruction ...
;;;   

#+ppc32-target
(defun registers-used-by (lfun &optional at-pc)
  (let* ((regs-used nil)
         (where-saved nil))
    (multiple-value-bind (op-high op-low) (%code-vector-last-instruction (uvref lfun 0))
      (declare (fixnum op-high op-low))
      (if (eql (ldb (byte 6 (- 26 16)) op-high) 32)       ; LWZ
        (let* ((nregs (- 32 (ldb (byte 5 (- 21 16)) op-high)))
               (pc (dpb (ldb (byte 2 0) op-low) (byte 2 5) (ldb (byte 5 (- 16 16)) op-high)))
               (offset (%word-to-int (logand op-low (lognot 3)))))
          (declare (fixnum nregs pc offset))
          (setq regs-used (1- (ash 1 nregs)))
          (if at-pc
            (if (>= at-pc pc)
              (setq where-saved (- (ash (- offset) -2) nregs))
              (setq regs-used nil))))))
    (values (and regs-used (bit-reverse-8 regs-used)) where-saved)))

#+ppc64-target
(defun registers-used-by (lfun &optional at-pc)
  (let* ((regs-used nil)
         (where-saved nil)
         (instr (%code-vector-last-instruction (uvref lfun 0))))
      (if (eql (ldb (byte 6 26) instr) 32)       ; LWZ
        (let* ((nregs (- 32 (ldb (byte 5 21) instr)))
               (pc (dpb (ldb (byte 2 0) instr) (byte 2 5) (ldb (byte 5 16) instr)))
               (offset (%word-to-int (logand instr (lognot 7)))))
          (declare (fixnum nregs pc offset))
          (setq regs-used (1- (ash 1 nregs)))
          (if at-pc
            (if (>= at-pc pc)
              (setq where-saved (- (ash (- offset) -3) nregs))
              (setq regs-used nil)))))        
      (values (and regs-used (bit-reverse-8 regs-used)) where-saved)))    
  

(defparameter *bit-reverse-8-table*
  #.(let ((table (make-array 256 :element-type '(unsigned-byte 8))))
      (dotimes (i 256)
        (let ((j 0)
              (out-mask (ash 1 7)))
          (declare (fixnum j out-mask))
          (dotimes (bit 8)
            (when (logbitp bit i)
              (setq j (logior j out-mask)))
            (setq out-mask (ash out-mask -1)))
          (setf (aref table i) j)))
      table))

(defun bit-reverse-8 (x)
  (aref *bit-reverse-8-table* x))

(defun %frame-savefn (p)
  (if (fake-stack-frame-p p)
    (%fake-stack-frame.fn p)
    (%%frame-savefn p)))

(defun %frame-savevsp (p)
  (if (fake-stack-frame-p p)
    (%fake-stack-frame.vsp p)
    (%%frame-savevsp p)))

(defun frame-vsp (frame)
  (%frame-savevsp frame))

;;; Return two values: the vsp of p and the vsp of p's "parent" frame.
;;; The "parent" frame vsp might actually be the end of p's segment,
;;; if the real "parent" frame vsp is in another segment.
(defun vsp-limits (p context)
  (let* ((vsp (%frame-savevsp p))
         parent)
    (when (eql vsp 0)
      ; This frame is where the code continues after an unwind-protect cleanup form
      (setq vsp (%frame-savevsp (child-frame p context))))
    (flet ((grand-parent (frame)
             (let ((parent (parent-frame frame context)))
               (when (and parent (eq parent (%frame-backlink frame context)))
                 (let ((grand-parent (parent-frame parent context)))
                   (when (and grand-parent (eq grand-parent (%frame-backlink parent context)))
                     grand-parent))))))
      (declare (dynamic-extent #'grand-parent))
      (let* ((frame p)
             grand-parent)
        (loop
          (setq grand-parent (grand-parent frame))
          (when (or (null grand-parent) (not (eql 0 (%frame-savevsp grand-parent))))
            (return))
          (setq frame grand-parent))
        (setq parent (parent-frame frame context)))
      (let* ((parent-vsp (if parent (%frame-savevsp parent) vsp))
             (tcr (if context (bt.tcr context) (%current-tcr)))
             (vsp-area (%fixnum-ref tcr target::tcr.vs-area)))
        (if (eql 0 parent-vsp)
          (values vsp vsp)              ; p is the kernel frame pushed by an unwind-protect cleanup form
          (progn
            (unless vsp-area
              (error "~s is not a stack frame pointer for context ~s" p tcr))
            (unless (%ptr-in-area-p parent-vsp vsp-area)
              (setq parent-vsp (%fixnum-ref vsp-area target::area.high)))
            (values vsp parent-vsp)))))))


(defun catch-csp-p (p context)
  (let ((catch (if context
                 (bt.top-catch context)
                 (%catch-top (%current-tcr)))))
    (loop
      (when (null catch) (return nil))
      (let ((sp (catch-frame-sp catch)))
        (when (eql sp p)
          (return t)))
      (setq catch (next-catch catch)))))

(defun last-catch-since (sp context)
  (let* ((tcr (if context (bt.tcr context) (%current-tcr)))
         (catch (%catch-top tcr))
         (last-catch nil))
    (loop
      (unless catch (return last-catch))
      (let ((csp (uvref catch target::catch-frame.csp-cell)))
        (when (%stack< sp csp context) (return last-catch))
        (setq last-catch catch
              catch (next-catch catch))))))

(defun register-number->saved-register-index (regno)
  (- regno ppc::save7))

(defun %find-register-argument-value (context cfp regval bad)
  (let* ((last-catch (last-catch-since cfp context))
         (index (register-number->saved-register-index regval)))
    (do* ((frame cfp
                 (child-frame frame context))
          (first t))
         ((null frame))
      (if (fake-stack-frame-p frame)
        (return-from %find-register-argument-value
          (xp-gpr-lisp (%fake-stack-frame.xp frame) regval))
        (if first
          (setq first nil)
          (multiple-value-bind (lfun pc)
              (cfp-lfun frame)
            (when lfun
              (multiple-value-bind (mask where)
                  (registers-used-by lfun pc)
                (when (if mask (logbitp index mask))
                  (incf where (logcount (logandc2 mask (1- (ash 1 (1+ index))))))
                  (return-from
                   %find-register-argument-value
                    (raw-frame-ref frame context where bad)))))))))
    (get-register-value nil last-catch index)))

(defun %set-register-argument-value (context cfp regval new)
  (let* ((last-catch (last-catch-since cfp context))
         (index (register-number->saved-register-index regval)))
    (do* ((frame cfp
                 (child-frame frame context))
          (first t))
         ((null frame))
      (if (fake-stack-frame-p frame)
        (return-from %set-register-argument-value
          (setf (xp-gpr-lisp (%fake-stack-frame.xp frame) regval) new))
        (if first
          (setq first nil)
          (multiple-value-bind (lfun pc)
              (cfp-lfun frame)
            (when lfun
              (multiple-value-bind (mask where)
                  (registers-used-by lfun pc)
                (when (if mask (logbitp index mask))
                  (incf where (logcount (logandc2 mask (1- (ash 1 (1+ index))))))
                  (return-from
                   %set-register-argument-value
                    (raw-frame-set frame context where new)))))))))
    (set-register-value new nil last-catch index)))

(defun %raw-frame-ref (cfp context idx bad)
  (declare (fixnum idx))
  (multiple-value-bind (frame base)
      (vsp-limits cfp context)
    (let* ((raw-size (- base frame)))
      (declare (fixnum frame base raw-size))
      (if (and (>= idx 0)
               (< idx raw-size))
        (let* ((addr (- (the fixnum (1- base))
                        idx)))
          (multiple-value-bind (db-count first-db last-db)
              (count-db-links-in-frame frame base context)
            (let* ((is-db-link
                    (unless (zerop db-count)
                      (do* ((last last-db (previous-db-link last first-db)))
                           ((null last))
                        (when (= addr last)
                          (return t))))))
              (if is-db-link
                (oldest-binding-frame-value context addr)
                (%fixnum-ref addr)))))
        bad))))

(defun %raw-frame-set (cfp context idx new)
  (declare (fixnum idx))
  (multiple-value-bind (frame base)
      (vsp-limits cfp context)
    (let* ((raw-size (- base frame)))
      (declare (fixnum frame base raw-size))
      (if (and (>= idx 0)
               (< idx raw-size))
        (let* ((addr (- (the fixnum (1- base))
                        idx)))
          (multiple-value-bind (db-count first-db last-db)
              (count-db-links-in-frame frame base context)
            (let* ((is-db-link
                    (unless (zerop db-count)
                      (do* ((last last-db (previous-db-link last first-db)))
                           ((null last))
                        (when (= addr last)
                          (return t))))))
              (if is-db-link
                (setf (oldest-binding-frame-value context addr) new)
                (setf (%fixnum-ref addr) new))))
          t)))))

;;; Used for printing only.
(defun index->address (p)
  (when (fake-stack-frame-p p)
    (setq p (%fake-stack-frame.sp p)))
  (ldb (byte #+32-bit-target 32 #+64-bit-target 64 0)  (ash p target::fixnumshift)))


(defun match-local-name (cellno info pc)
  (when info
    (let* ((syms (%car info))
           (ptrs (%cdr info)))
      (dotimes (i (length syms))
        (let ((j (%i+ i (%i+ i i ))))
          (and (eq (uvref ptrs j) (%ilogior (%ilsl (+ 6 target::word-shift) cellno) #o77))
               (%i>= pc (uvref ptrs (%i+ j 1)))
               (%i< pc (uvref ptrs (%i+ j 2)))
               (return (aref syms i))))))))

(defun get-register-value (address last-catch index)
  (if address
    (%fixnum-ref address)
    (uvref last-catch (+ index target::catch-frame.save-save7-cell))))

;;; Inverse of get-register-value

(defun set-register-value (value address last-catch index)
  (if address
    (%fixnum-set address value)
    (setf (uvref last-catch (+ index target::catch-frame.save-save7-cell))
          value)))

;;; I'm skeptical about a lot of this stuff on the PPC, but if anything it's
;;; pretty PPC-specific

;;; Act as if VSTACK-INDEX points somewhere where DATA could go & put it there.
(defun set-lisp-data (vstack-index data)
  (let* ((old (%access-lisp-data vstack-index)))
    (if (closed-over-value-p old)
      (set-closed-over-value old data)
      (%store-lisp-data vstack-index data))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;extensions to let user access and modify values





;;; nth-frame-info, set-nth-frame-info, & frame-lfun are in "inspector;new-backtrace"






(defparameter *saved-register-count+1*
  (1+ *saved-register-count*))



(defparameter *saved-register-numbers*
  #+x8664-target #(wrong)
  #+ppc-target #(31 30 29 28 27 26 25 24))

;;; Don't do unbound checks in compiled code
(declaim (type t *saved-register-count* *saved-register-count+1*
               *saved-register-names* *saved-register-numbers*))

(defmacro %cons-saved-register-vector ()
  `(make-array (the fixnum *saved-register-count+1*) :initial-element nil))

(defun copy-srv (from-srv &optional to-srv)
  (if to-srv
    (if (eq from-srv to-srv)
      to-srv
      (dotimes (i (uvsize from-srv) to-srv)
        (setf (uvref to-srv i) (uvref from-srv i))))
    (copy-uvector from-srv)))

(defmacro srv.unresolved (saved-register-vector)
  `(svref ,saved-register-vector 0))

(defmacro srv.register-n (saved-register-vector n)
  `(svref ,saved-register-vector (1+ ,n)))

;;; This isn't quite right - has to look at all functions on stack,
;;; not just those that saved VSPs.


(defun frame-restartable-p (target &optional context)
  (multiple-value-bind (frame last-catch srv) (last-catch-since-saved-vars target context)
    (when frame
      (loop
        (when (null frame)
          (return-from frame-restartable-p nil))
        (when (eq frame target) (return))
        (multiple-value-setq (frame last-catch srv)
          (ccl::parent-frame-saved-vars context frame last-catch srv srv)))
      (when (and srv (eql 0 (srv.unresolved srv)))
        (setf (srv.unresolved srv) last-catch)
        srv))))


;;; get the saved register addresses for this frame
;;; still need to worry about this unresolved business
;;; could share some code with parent-frame-saved-vars
(defun my-saved-vars (frame &optional (srv-out (%cons-saved-register-vector)))
  (let ((unresolved 0))
    (multiple-value-bind (lfun pc) (cfp-lfun frame)
        (if lfun
          (multiple-value-bind (mask where) (registers-used-by lfun pc)
            (when mask
              (if (not where) 
                (setq unresolved (%ilogior unresolved mask))
                (let ((vsp (- (frame-vsp frame) where (1- (logcount mask))))
                      (j *saved-register-count*))
                  (declare (fixnum j))
                  (dotimes (i j)
                    (declare (fixnum i))
                    (when (%ilogbitp (decf j) mask)
                      (setf (srv.register-n srv-out i) vsp
                            vsp (1+ vsp)
                            unresolved (%ilogand unresolved (%ilognot (%ilsl j 1))))))))))
          (setq unresolved (1- (ash 1 *saved-register-count*)))))
    (setf (srv.unresolved srv-out) unresolved)
    srv-out))

(defun parent-frame-saved-vars 
       (context frame last-catch srv &optional (srv-out (%cons-saved-register-vector)))
  (copy-srv srv srv-out)
  (let* ((parent (and frame (parent-frame frame context)))
         (grand-parent (and parent (parent-frame parent context))))
    (when grand-parent
      (loop (let ((next-catch (and last-catch (next-catch last-catch))))
              ;(declare (ignore next-catch))
              (if (and next-catch (%stack< (catch-frame-sp next-catch) grand-parent context))
                (progn
                  (setf last-catch next-catch
                        (srv.unresolved srv-out) 0)
                  (dotimes (i *saved-register-count*)
                    (setf (srv.register-n srv i) nil)))
                (return))))
      (lookup-registers parent context grand-parent srv-out)
      (values parent last-catch srv-out))))

(defun lookup-registers (parent context grand-parent srv-out)
  (unless (or (eql (frame-vsp grand-parent) 0)
              (let ((gg-parent (parent-frame grand-parent context)))
                (eql (frame-vsp gg-parent) 0)))
    (multiple-value-bind (lfun pc) (cfp-lfun parent)
      (when lfun
        (multiple-value-bind (mask where) (registers-used-by lfun pc)
          (when mask
            (locally (declare (fixnum mask))
              (if (not where) 
                (setf (srv.unresolved srv-out) (%ilogior (srv.unresolved srv-out) mask))
                (let* ((grand-parent-vsp (frame-vsp grand-parent)))

                  (let ((vsp (- grand-parent-vsp where 1))
                        (j *saved-register-count*))
                    (declare (fixnum j))
                    (dotimes (i j)
                      (declare (fixnum i))
                      (when (%ilogbitp (decf j) mask)
                        (setf (srv.register-n srv-out i) vsp
                              vsp (1- vsp)
                              (srv.unresolved srv-out)
                              (%ilogand (srv.unresolved srv-out) (%ilognot (%ilsl j 1))))))))))))))))

;;; initialization for looping on parent-frame-saved-vars
(defun last-catch-since-saved-vars (frame context)
  (let* ((parent (parent-frame frame context))
         (last-catch (and parent (last-catch-since parent context))))
    (when last-catch
      (let ((frame (catch-frame-sp last-catch))
            (srv (%cons-saved-register-vector)))
        (setf (srv.unresolved srv) 0)
        (let* ((parent (parent-frame frame context))
               (child (and parent (child-frame parent context))))
          (when child
            (lookup-registers child context parent srv))
          (values child last-catch srv))))))

;;; Returns 2 values:
;;; mask srv
;;; The mask says which registers are used at PC in LFUN.  srv is a
;;; saved-register-vector whose register contents are the register
;;; values registers whose bits are not set in MASK or set in
;;; UNRESOLVED will be returned as NIL.

(defun saved-register-values 
       (lfun pc child last-catch srv &optional (srv-out (%cons-saved-register-vector)))
  (declare (ignore child))
  (cond ((null srv-out) (setq srv-out (copy-uvector srv)))
        ((eq srv-out srv))
        (t (dotimes (i (the fixnum (uvsize srv)))
             (setf (uvref srv-out i) (uvref srv i)))))
  (let ((mask (or (registers-used-by lfun pc) 0))
        (unresolved (srv.unresolved srv))
        (j *saved-register-count*))
    (declare (fixnum j))
    (dotimes (i j)
      (declare (fixnum i))
      (setf (srv.register-n srv-out i)
            (and (%ilogbitp (setq j (%i- j 1)) mask)
                 (not (%ilogbitp j unresolved))
                 (safe-cell-value (get-register-value (srv.register-n srv i) last-catch j)))))
    (setf (srv.unresolved srv-out) mask)
    (values mask srv-out)))

; Set the nth saved register to value.
(defun set-saved-register (value n lfun pc child last-catch srv)
  (declare (ignore lfun pc child) (dynamic-extent))
  (let ((j (- target::node-size n))
        (unresolved (srv.unresolved srv))
        (addr (srv.register-n srv n)))
    (when (logbitp j unresolved)
      (error "Can't set register ~S to ~S" n value))
    (set-register-value value addr last-catch j))
  value)





(defun return-from-nth-frame (n &rest values)
  (apply-in-nth-frame n #'values values))

(defun apply-in-nth-frame (n fn arglist)
  (let* ((bt-info (car *backtrace-contexts*)))
    (and bt-info
         (let* ((frame (nth-frame nil (bt.youngest bt-info) n bt-info)))
           (and frame (apply-in-frame frame fn arglist)))))
  (format t "Can't return to frame ~d ." n))

;;; This method is shadowed by one for the backtrace window.
(defmethod nth-frame (w target n context)
  (declare (ignore w))
  (and target (dotimes (i n target)
                (declare (fixnum i))
                (unless (setq target (parent-frame target context)) (return nil)))))

; If this returns at all, it's because the frame wasn't restartable.
(defun apply-in-frame (frame fn arglist &optional context)
  (let* ((srv (frame-restartable-p frame context))
         (target-sp (and srv (srv.unresolved srv))))
    (if target-sp
      (apply-in-frame-internal context frame fn arglist srv))))

(defun apply-in-frame-internal (context frame fn arglist srv)
  (let* ((tcr (if context (bt.tcr context) (%current-tcr))))
    (if (eq tcr (%current-tcr))
      (%apply-in-frame frame fn arglist srv)
      (let ((process (tcr->process tcr)))
        (if process
          (process-interrupt
           process
           #'%apply-in-frame
           frame fn arglist srv)
          (error "Can't find active process for ~s" tcr))))))


(defun return-from-frame (frame &rest values)
  (apply-in-frame frame #'values values nil))


;;; (srv.unresolved srv) is the last catch frame, left there by
;;; frame-restartable-p The registers in srv are locations of
;;; variables saved between frame and that catch frame.
(defun %apply-in-frame (frame fn arglist srv)
  (declare (fixnum frame))
  (let* ((catch (srv.unresolved srv))
         (tsp-count 0)
         (tcr (%current-tcr))
         (parent (parent-frame frame tcr))
         (vsp (frame-vsp parent))
         (catch-top (%catch-top tcr))
         (db-link (%svref catch target::catch-frame.db-link-cell))
         (catch-count 0))
    (declare (fixnum parent vsp db-link catch-count))
    ;; Figure out how many catch frames to throw through
    (loop
      (unless catch-top
        (error "Didn't find catch frame"))
      (incf catch-count)
      (when (eq catch-top catch)
        (return))
      (setq catch-top (next-catch catch-top)))
    ;; Figure out where the db-link should be
    (loop
      (when (or (eql db-link 0) (>= db-link vsp))
        (return))
      (setq db-link (%fixnum-ref db-link)))
    ;; Figure out how many TSP frames to pop after throwing.
    (let ((sp (catch-frame-sp catch)))
      (loop
        (multiple-value-bind (f pc) (cfp-lfun sp)
          (when f (incf tsp-count (active-tsp-count f pc))))
        (setq sp (parent-frame sp tcr))
        (when (eql sp parent) (return))
        (unless sp (error "Didn't find frame: ~s" frame))))
    #+debug
    (cerror "Continue" "(apply-in-frame ~s ~s ~s ~s ~s ~s ~s)"
            catch-count srv tsp-count db-link parent fn arglist)
    (%%apply-in-frame catch-count srv tsp-count db-link parent fn arglist)))




;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Code to determine how many tsp frames to pop.
;;; This is done by parsing the code.
;;; active-tsp-count is the entry point below.
;;;

(defstruct (branch-tree (:print-function print-branch-tree))
  first-instruction
  last-instruction
  branch-target     ; a branch-tree or nil
  fall-through)     ; a branch-tree or nil

(defun print-branch-tree (tree stream print-level)
  (declare (ignore print-level))
  (print-unreadable-object (tree stream :type t :identity t)
    (format stream "~s-~s"
            (branch-tree-first-pc tree)
            (branch-tree-last-pc tree))))

(defun branch-tree-first-pc (branch-tree)
  (let ((first (branch-tree-first-instruction branch-tree)))
    (and first (instruction-element-address first))))

(defun branch-tree-last-pc (branch-tree)
  (let ((last (branch-tree-last-instruction branch-tree)))
    (if last
      (instruction-element-address last)
      (branch-tree-first-pc branch-tree))))

(defun branch-tree-contains-pc-p (branch-tree pc)
  (<= (branch-tree-first-pc branch-tree)
      pc
      (branch-tree-last-pc branch-tree)))

(defvar *branch-tree-hash*
  (make-hash-table :test 'eq :weak :value))

(defun get-branch-tree (function)
  (or (gethash function *branch-tree-hash*)
      (let* ((dll (function-to-dll-header function))
             (tree (dll-to-branch-tree dll)))
        (setf (gethash function *branch-tree-hash*) tree))))         

; Return the number of TSP frames that will be active after throwing out
; of all the active catch frames in function at pc.
; PC is a byte address, a multiple of 4.
(defun active-tsp-count (function pc)
  (setq function
        (require-type
         (if (symbolp function)
           (symbol-function function)
           function)
         'compiled-function))
  (let* ((tree (get-branch-tree function))
         (visited nil))
    (labels ((find-pc (branch path)
               (unless (memq branch visited)
                 (push branch path)
                 (if (branch-tree-contains-pc-p branch pc)
                   path
                   (let ((target (branch-tree-branch-target branch))
                         (fall-through (branch-tree-fall-through branch)))
                     (push branch visited)
                     (if fall-through
                       (or (and target (find-pc target path))
                           (find-pc fall-through path))
                       (and target (find-pc target path))))))))
      (let* ((path (nreverse (find-pc tree nil)))
             (last-tree (car (last path)))
             (catch-count 0)
             (tsp-count 0))
        (unless path
          (error "Can't find path to pc: ~s in ~s" pc function))
        (dolist (tree path)
          (let ((next (branch-tree-first-instruction tree))
                (last (branch-tree-last-instruction tree)))
            (loop
              (when (and (eq tree last-tree)
                         (eql pc (instruction-element-address next)))
                ; If the instruction before the current one is an ff-call,
                ; then callback pushed a TSP frame.
                #| ; Not any more
                (when (ff-call-instruction-p (dll-node-pred next))
                  (incf tsp-count))
                |#
                (return))
              (multiple-value-bind (type target fall-through count) (categorize-instruction next)
                (declare (ignore target fall-through))
                (case type
                  (:tsp-push
                   (when (eql catch-count 0)
                     (incf tsp-count count)))
                  (:tsp-pop
                   (when (eql catch-count 0)
                     (decf tsp-count count)))
                  ((:catch :unwind-protect)
                   (incf catch-count))
                  (:throw
                   (decf catch-count count))))
              (when (eq next last)
                (return))
              (setq next (dll-node-succ next)))))
        tsp-count))))
        

(defun dll-to-branch-tree (dll)
  (let* ((hash (make-hash-table :test 'eql))    ; start-pc -> branch-tree
         (res (collect-branch-tree (dll-header-first dll) dll hash))
         (did-something nil))
    (loop
      (setq did-something nil)
      (let ((mapper #'(lambda (key value)
                        (declare (ignore key))
                        (flet ((maybe-collect (pc)
                                 (when (integerp pc)
                                   (let ((target-tree (gethash pc hash)))
                                     (if target-tree
                                       target-tree
                                       (progn
                                         (collect-branch-tree (dll-pc->instr dll pc) dll hash)
                                         (setq did-something t)
                                         nil))))))
                          (declare (dynamic-extent #'maybe-collect))
                          (let ((target-tree (maybe-collect (branch-tree-branch-target value))))
                            (when target-tree (setf (branch-tree-branch-target value) target-tree)))
                          (let ((target-tree (maybe-collect (branch-tree-fall-through value))))
                            (when target-tree (setf (branch-tree-fall-through value) target-tree)))))))
        (declare (dynamic-extent mapper))
        (maphash mapper hash))
      (unless did-something (return)))
    ; To be totally correct, we should fix up the trees containing
    ; the BLR instruction for unwind-protect cleanups, but none
    ; of the users of this code yet care that it appears that the code
    ; stops there.
    res))

(defun collect-branch-tree (instr dll hash)
  (unless (eq instr dll)
    (let ((tree (make-branch-tree :first-instruction instr))
          (pred nil)
          (next instr))
      (setf (gethash (instruction-element-address instr) hash)
            tree)
      (loop
        (when (eq next dll)
          (setf (branch-tree-last-instruction tree) pred)
          (return))
        (multiple-value-bind (type target fall-through) (categorize-instruction next)
          (case type
            (:label
             (when pred
               (setf (branch-tree-last-instruction tree) pred
                     (branch-tree-fall-through tree) (instruction-element-address next))
               (return)))
            ((:branch :catch :unwind-protect)
             (setf (branch-tree-last-instruction tree) next
                   (branch-tree-branch-target tree) target
                   (branch-tree-fall-through tree) fall-through)
             (return))))
        (setq pred next
              next (dll-node-succ next)))
      tree)))

;;; Returns 4 values:
;;; 1) type: one of :regular, :label, :branch, :catch, :unwind-protect, :throw, :tsp-push, :tsp-pop
;;; 2) branch target (or catch or unwind-protect cleanup)
;;; 3) branch-fallthrough (or catch or unwind-protect body)
;;; 4) Count for throw, tsp-push, tsp-pop
(defun categorize-instruction (instr)
  (etypecase instr
    (lap-label :label)
    (lap-instruction
     (let* ((opcode (lap-instruction-opcode instr))
            (opcode-p (typep opcode 'opcode))
            (name (if opcode-p (opcode-name opcode) opcode))
            (pc (lap-instruction-address instr))
            (operands (lap-instruction-parsed-operands instr)))
       (cond ((equalp name "bla")
              (let ((subprim (car operands)))
                (case subprim
                  (.SPmkunwind
                   (values :unwind-protect (+ pc 4) (+ pc 8)))
                  ((.SPmkcatch1v .SPmkcatchmv)
                   (values :catch (+ pc 4) (+ pc 8)))
                  (.SPthrow
                   (values :branch nil nil))
                  ((.SPnthrowvalues .SPnthrow1value)
                   (let* ((prev-instr (require-type (lap-instruction-pred instr)
                                                    'lap-instruction))
                          (prev-name (opcode-name (lap-instruction-opcode prev-instr)))
                          (prev-operands (lap-instruction-parsed-operands prev-instr)))
                     ; Maybe we should recognize the other possible outputs of ppc2-lwi, but I
                     ; can't imagine we'll ever see them
                     (unless (and (equalp prev-name "li")
                                  (equalp (car prev-operands) "imm0"))
                       (error "Can't determine throw count for ~s" instr))
                     (values :throw nil (+ pc 4) (ash (cadr prev-operands) (- target::fixnum-shift)))))
                  ((.SPprogvsave
                    .SPstack-rest-arg .SPreq-stack-rest-arg .SPstack-cons-rest-arg
                    .SPmakestackblock .SPmakestackblock0 .SPmakestacklist .SPstkgvector
                    .SPstkconslist .SPstkconslist-star
                    .SPmkstackv .SPstack-misc-alloc .SPstack-misc-alloc-init
                    .SPstkvcell0 .SPstkvcellvsp
                    .SPsave-values)
                   (values :tsp-push nil nil 1))
                  (.SPrecover-values
                   (values :tsp-pop nil nil 1))
                  (t :regular))))
             ((or (equalp name "lwz") (equalp name "addi"))
              (if (equalp (car operands) "tsp")
                (values :tsp-pop nil nil 1)
                :regular))
             ((equalp name "stwu")
              (if (equalp (car operands) "tsp")
                (values :tsp-push nil nil 1)
                :regular))
             ((member name '("ba" "blr" "bctr") :test 'equalp)
              (values :branch nil nil))
             ; It would probably be faster to determine the branch address by adding the PC and the offset.
             ((equalp name "b")
              (values :branch (branch-label-address instr (car (last operands))) nil))
             ((and opcode-p (eql (opcode-majorop opcode) 16))
              (values :branch (branch-label-address instr (car (last operands))) (+ pc 4)))
             (t :regular))))))

(defun branch-label-address (instr label-name &aux (next instr))
  (loop
    (setq next (dll-node-succ next))
    (when (eq next instr)
      (error "Couldn't find label ~s" label-name))
    (when (and (typep next 'lap-label)
               (eq (lap-label-name next) label-name))
      (return (instruction-element-address next)))))

(defun dll-pc->instr (dll pc)
  (let ((next (dll-node-succ dll)))
    (loop
      (when (eq next dll)
        (error "Couldn't find pc: ~s in ~s" pc dll))
      (when (eql (instruction-element-address next) pc)
        (return next))
      (setq next (dll-node-succ next)))))

(defun exception-frame-p (frame)
  (fake-stack-frame-p frame))

(defun arg-check-call-arguments (frame function)
  (declare (ignore function))
  (xp-argument-list (%fake-stack-frame.xp frame)))
