1 ;;;; Alpha compiler support for the new whizzy 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 current-sp
)
17 (:results
(res :scs
(sap-reg)))
18 (:result-types system-area-pointer
)
22 (define-vop (debug-cur-fp)
23 (:translate current-fp
)
25 (:results
(res :scs
(sap-reg)))
26 (:result-types system-area-pointer
)
30 (define-vop (read-control-stack)
31 (:translate stack-ref
)
33 (:args
(object :scs
(sap-reg) :target sap
)
34 (offset :scs
(any-reg)))
35 (:arg-types system-area-pointer positive-fixnum
)
36 (:temporary
(:scs
(sap-reg) :from
:eval
) sap
)
37 (:results
(result :scs
(descriptor-reg)))
40 (inst addq object offset sap
)
41 (inst ldl result
0 sap
)))
43 (define-vop (read-control-stack-c)
44 (:translate stack-ref
)
46 (:args
(object :scs
(sap-reg)))
48 (:arg-types system-area-pointer
(:constant
(signed-byte 14)))
49 (:results
(result :scs
(descriptor-reg)))
52 (inst ldl result
(* offset n-word-bytes
) object
)))
54 (define-vop (write-control-stack)
55 (:translate %set-stack-ref
)
57 (:args
(object :scs
(sap-reg) :target sap
)
58 (offset :scs
(any-reg))
59 (value :scs
(descriptor-reg) :target result
))
60 (:arg-types system-area-pointer positive-fixnum
*)
61 (:results
(result :scs
(descriptor-reg)))
63 (:temporary
(:scs
(sap-reg) :from
(:argument
1)) sap
)
65 (inst addq object offset sap
)
66 (inst stl value
0 sap
)
69 (define-vop (write-control-stack-c)
70 (:translate %set-stack-ref
)
72 (:args
(sap :scs
(sap-reg))
73 (value :scs
(descriptor-reg) :target result
))
75 (:arg-types system-area-pointer
(:constant
(signed-byte 14)) *)
76 (:results
(result :scs
(descriptor-reg)))
79 (inst stl value
(* offset n-word-bytes
) sap
)
83 (define-vop (code-from-mumble)
85 (:args
(thing :scs
(descriptor-reg)))
86 (:results
(code :scs
(descriptor-reg)))
87 (:temporary
(:scs
(non-descriptor-reg)) temp
)
88 (:variant-vars lowtag
)
90 (let ((bogus (gen-label))
92 (loadw temp thing
0 lowtag
)
93 (inst srl temp n-widetag-bits temp
)
95 (inst sll temp
(1- (integer-length n-word-bytes
)) temp
)
96 (unless (= lowtag other-pointer-lowtag
)
97 (inst subq temp
(- other-pointer-lowtag lowtag
) temp
))
98 (inst subq thing temp code
)
100 (assemble (*elsewhere
*)
103 (inst br zero-tn done
)))))
105 (define-vop (code-from-lra code-from-mumble
)
106 (:translate lra-code-header
)
107 (:variant other-pointer-lowtag
))
109 (define-vop (code-from-function code-from-mumble
)
110 (:translate fun-code-header
)
111 (:variant fun-pointer-lowtag
))
113 (define-vop (%make-lisp-obj
)
115 (:translate %make-lisp-obj
)
116 (:args
(value :scs
(unsigned-reg) :target result
))
117 (:arg-types unsigned-num
)
118 (:results
(result :scs
(descriptor-reg)))
120 (move value result
)))
122 (define-vop (get-lisp-obj-address)
124 (:translate get-lisp-obj-address
)
125 (:args
(thing :scs
(descriptor-reg) :target result
))
126 (:results
(result :scs
(unsigned-reg)))
127 (:result-types unsigned-num
)
129 (move thing result
)))
131 (define-vop (fun-word-offset)
133 (:translate fun-word-offset
)
134 (:args
(fun :scs
(descriptor-reg)))
135 (:results
(res :scs
(unsigned-reg)))
136 (:result-types positive-fixnum
)
138 (loadw res fun
0 fun-pointer-lowtag
)
139 (inst srl res n-widetag-bits res
)))
141 (defknown make-number-stack-pointer
((unsigned-byte 32)) system-area-pointer
142 (movable foldable flushable
))
144 (define-vop (make-number-stack-pointer)
146 (:translate make-number-stack-pointer
)
147 (:args
(arg :scs
(unsigned-reg) :to
(:argument
1)))
148 (:arg-types unsigned-num
)
149 (:results
(res :scs
(sap-reg) :from
(:argument
0)))
150 (:result-types system-area-pointer
)
152 (inst mskll nsp-tn
0 res
)
153 (inst bis res arg res
)))