1 ;;;; PPC compiler support for the debugger
3 ;;;; This software is part of the SBCL system. See the README file for
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.
14 (define-vop (debug-cur-sp)
15 (:translate sb
!di
::current-sp
)
17 (:results
(res :scs
(sap-reg)))
18 (:result-types system-area-pointer
)
22 (define-vop (debug-cur-fp)
23 (:translate sb
!di
::current-fp
)
25 (:results
(res :scs
(sap-reg)))
26 (:result-types system-area-pointer
)
30 (define-vop (read-control-stack)
31 (:translate sb
!kernel
:stack-ref
)
33 (:args
(sap :scs
(sap-reg))
34 (offset :scs
(any-reg)))
35 (:arg-types system-area-pointer positive-fixnum
)
36 (:results
(result :scs
(descriptor-reg)))
39 (inst lwzx result sap offset
)))
41 (define-vop (write-control-stack)
42 (:translate sb
!kernel
:%set-stack-ref
)
44 (:args
(sap :scs
(sap-reg))
45 (offset :scs
(any-reg))
46 (value :scs
(descriptor-reg) :target result
))
47 (:arg-types system-area-pointer positive-fixnum
*)
48 (:results
(result :scs
(descriptor-reg)))
51 (inst stwx value sap offset
)
54 (define-vop (code-from-mumble)
56 (:args
(thing :scs
(descriptor-reg)))
57 (:results
(code :scs
(descriptor-reg)))
58 (:temporary
(:scs
(non-descriptor-reg)) temp
)
59 (:variant-vars lowtag
)
61 (let ((bogus (gen-label))
63 (loadw temp thing
0 lowtag
)
64 (inst srwi temp temp n-widetag-bits
)
66 (inst slwi temp temp
(1- (integer-length n-word-bytes
)))
68 (unless (= lowtag other-pointer-lowtag
)
69 (inst addi temp temp
(- lowtag other-pointer-lowtag
)))
70 (inst sub code thing temp
)
72 (assemble (*elsewhere
*)
77 (define-vop (code-from-lra code-from-mumble
)
78 (:translate sb
!di
::lra-code-header
)
79 (:variant other-pointer-lowtag
))
81 (define-vop (code-from-fun code-from-mumble
)
82 (:translate sb
!di
::fun-code-header
)
83 (:variant fun-pointer-lowtag
))
85 (define-vop (make-lisp-obj)
87 (:translate sb
!di
::make-lisp-obj
)
88 (:args
(value :scs
(unsigned-reg) :target result
))
89 (:arg-types unsigned-num
)
90 (:results
(result :scs
(descriptor-reg)))
94 (define-vop (get-lisp-obj-address)
96 (:translate sb
!di
::get-lisp-obj-address
)
97 (:args
(thing :scs
(descriptor-reg) :target result
))
98 (:results
(result :scs
(unsigned-reg)))
99 (:result-types unsigned-num
)
101 (move result thing
)))
104 (define-vop (fun-word-offset)
106 (:translate sb
!di
::fun-word-offset
)
107 (:args
(fun :scs
(descriptor-reg)))
108 (:results
(res :scs
(unsigned-reg)))
109 (:result-types positive-fixnum
)
111 (loadw res fun
0 fun-pointer-lowtag
)
112 (inst srwi res res n-widetag-bits
)))