src/compiler/sparc/debug.lisp

   1 ;;;; Sparc compiler support for the new whizzy debugger
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   6 ;;;; This software is derived from the CMU CL system, which was
   7 ;;;; written at Carnegie Mellon University and released into the
   8 ;;;; public domain. The software is in the public domain and is
   9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  10 ;;;; files for more information.
  11
  12 (in-package "SB!VM")
  13
  14 ;;; (defknown di::current-sp () system-area-pointer (movable flushable))
  15 ;;; (defknown di::current-fp () system-area-pointer (movable flushable))
  16 ;;; (defknown di::stack-ref (system-area-pointer index) t (flushable))
  17 ;;; (defknown di::%set-stack-ref (system-area-pointer index t) t (unsafe))
  18 ;;; (defknown di::lra-code-header (t) t (movable flushable))
  19 ;;; (defknown di::function-code-header (t) t (movable flushable))
  20 ;;; (defknown di::make-lisp-obj ((unsigned-byte 32)) t (movable flushable))
  21 ;;; (defknown di::get-lisp-obj-address (t) (unsigned-byte 32) (movable flushable))
  22 ;;; (defknown di::function-word-offset (function) index (movable flushable))
  23
  24 (define-vop (debug-cur-sp)
  25   (:translate current-sp)
  26   (:policy :fast-safe)
  27   (:results (res :scs (sap-reg)))
  28   (:result-types system-area-pointer)
  29   (:generator 1
  30     (move res csp-tn)))
  31
  32 (define-vop (debug-cur-fp)
  33   (:translate current-fp)
  34   (:policy :fast-safe)
  35   (:results (res :scs (sap-reg)))
  36   (:result-types system-area-pointer)
  37   (:generator 1
  38     (move res cfp-tn)))
  39
  40 (define-vop (read-control-stack)
  41   (:translate sb!kernel:stack-ref)
  42   (:policy :fast-safe)
  43   (:args (sap :scs (sap-reg))
  44          (offset :scs (any-reg)))
  45   (:arg-types system-area-pointer positive-fixnum)
  46   (:results (result :scs (descriptor-reg)))
  47   (:result-types *)
  48   (:generator 5
  49     (inst ld result sap offset)))
  50
  51 (define-vop (write-control-stack)
  52   (:translate sb!kernel:%set-stack-ref)
  53   (:policy :fast-safe)
  54   (:args (sap :scs (sap-reg))
  55          (offset :scs (any-reg))
  56          (value :scs (descriptor-reg) :target result))
  57   (:arg-types system-area-pointer positive-fixnum *)
  58   (:results (result :scs (descriptor-reg)))
  59   (:result-types *)
  60   (:generator 5
  61     (inst st value sap offset)
  62     (move result value)))
  63
  64 (define-vop (code-from-mumble)
  65   (:policy :fast-safe)
  66   (:args (thing :scs (descriptor-reg)))
  67   (:results (code :scs (descriptor-reg)))
  68   (:temporary (:scs (non-descriptor-reg)) temp)
  69   (:variant-vars lowtag)
  70   (:generator 5
  71     (let ((bogus (gen-label))
  72           (done (gen-label)))
  73       (loadw temp thing 0 lowtag)
  74       (inst srl temp n-widetag-bits)
  75       (inst cmp temp)
  76       (inst b :eq bogus)
  77       (inst sll temp (1- (integer-length n-word-bytes)))
  78       (unless (= lowtag other-pointer-lowtag)
  79         (inst add temp (- lowtag other-pointer-lowtag)))
  80       (inst sub code thing temp)
  81       (emit-label done)
  82       (assemble (*elsewhere*)
  83         (emit-label bogus)
  84         (inst b done)
  85         (move code null-tn)))))
  86
  87 (define-vop (code-from-lra code-from-mumble)
  88   (:translate lra-code-header)
  89   (:variant other-pointer-lowtag))
  90
  91 (define-vop (code-from-function code-from-mumble)
  92   (:translate fun-code-header)
  93   (:variant fun-pointer-lowtag))
  94
  95 (define-vop (make-lisp-obj)
  96   (:policy :fast-safe)
  97   (:translate make-lisp-obj)
  98   (:args (value :scs (unsigned-reg) :target result))
  99   (:arg-types unsigned-num)
 100   (:results (result :scs (descriptor-reg)))
 101   (:generator 1
 102     (move result value)))
 103
 104 (define-vop (get-lisp-obj-address)
 105   (:policy :fast-safe)
 106   (:translate get-lisp-obj-address)
 107   (:args (thing :scs (descriptor-reg) :target result))
 108   (:results (result :scs (unsigned-reg)))
 109   (:result-types unsigned-num)
 110   (:generator 1
 111     (move result thing)))
 112
 113
 114 (define-vop (fun-word-offset)
 115   (:policy :fast-safe)
 116   (:translate fun-word-offset)
 117   (:args (fun :scs (descriptor-reg)))
 118   (:results (res :scs (unsigned-reg)))
 119   (:result-types positive-fixnum)
 120   (:generator 5
 121     (loadw res fun 0 fun-pointer-lowtag)
 122     (inst srl res n-widetag-bits)))