New keyword argument for SB-C:DEFKNOWN: :overwrite-fndb-silently
[sbcl.git] / src / compiler / mips / debug.lisp
1 ;;;; MIPS compiler support for the 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
15 (define-vop (debug-cur-sp)
16   (:translate sb!di::current-sp)
17   (:policy :fast-safe)
18   (:results (res :scs (sap-reg)))
19   (:result-types system-area-pointer)
20   (:generator 1
21     (move res csp-tn)))
22
23 (define-vop (debug-cur-fp)
24   (:translate sb!di::current-fp)
25   (:policy :fast-safe)
26   (:results (res :scs (sap-reg)))
27   (:result-types system-area-pointer)
28   (:generator 1
29     (move res cfp-tn)))
30
31 (define-vop (read-control-stack)
32   (:translate sb!kernel:stack-ref)
33   (:policy :fast-safe)
34   (:args (object :scs (sap-reg) :target sap)
35          (offset :scs (any-reg)))
36   (:arg-types system-area-pointer positive-fixnum)
37   (:temporary (:scs (sap-reg) :from :eval) sap)
38   (:results (result :scs (descriptor-reg)))
39   (:result-types *)
40   (:generator 5
41     (inst addu sap object offset)
42     (inst lw result sap 0)
43     (inst nop)))
44
45 (define-vop (read-control-stack-c)
46   (:translate sb!kernel:stack-ref)
47   (:policy :fast-safe)
48   (:args (object :scs (sap-reg)))
49   (:info offset)
50   (:arg-types system-area-pointer (:constant (signed-byte 14)))
51   (:results (result :scs (descriptor-reg)))
52   (:result-types *)
53   (:generator 4
54     (inst lw result object (* offset n-word-bytes))
55     (inst nop)))
56
57 (define-vop (write-control-stack)
58   (:translate sb!kernel:%set-stack-ref)
59   (:policy :fast-safe)
60   (:args (object :scs (sap-reg) :target sap)
61          (offset :scs (any-reg))
62          (value :scs (descriptor-reg) :target result))
63   (:arg-types system-area-pointer positive-fixnum *)
64   (:results (result :scs (descriptor-reg)))
65   (:result-types *)
66   (:temporary (:scs (sap-reg) :from (:argument 1)) sap)
67   (:generator 2
68     (inst addu sap object offset)
69     (inst sw value sap 0)
70     (move result value)))
71
72 (define-vop (write-control-stack-c)
73   (:translate %set-stack-ref)
74   (:policy :fast-safe)
75   (:args (sap :scs (sap-reg))
76          (value :scs (descriptor-reg) :target result))
77   (:info offset)
78   (:arg-types system-area-pointer (:constant (signed-byte 14)) *)
79   (:results (result :scs (descriptor-reg)))
80   (:result-types *)
81   (:generator 1
82     (inst sw value sap (* offset n-word-bytes))
83     (move result value)))
84
85
86 (define-vop (code-from-mumble)
87   (:policy :fast-safe)
88   (:args (thing :scs (descriptor-reg)))
89   (:results (code :scs (descriptor-reg)))
90   (:temporary (:scs (non-descriptor-reg)) temp)
91   (:variant-vars lowtag)
92   (:generator 5
93     (let ((bogus (gen-label))
94           (done (gen-label)))
95       (loadw temp thing 0 lowtag)
96       (inst srl temp n-widetag-bits)
97       (inst beq temp bogus)
98       (inst sll temp (1- (integer-length n-word-bytes)))
99       (unless (= lowtag other-pointer-lowtag)
100         (inst addu temp (- lowtag other-pointer-lowtag)))
101       (inst subu code thing temp)
102       (emit-label done)
103       (assemble (*elsewhere*)
104         (emit-label bogus)
105         (inst b done)
106         (move code null-tn t)))))
107
108 (define-vop (code-from-lra code-from-mumble)
109   (:translate sb!di::lra-code-header)
110   (:variant other-pointer-lowtag))
111
112 (define-vop (code-from-fun code-from-mumble)
113   (:translate sb!di::fun-code-header)
114   (:variant fun-pointer-lowtag))
115
116 (define-vop (%make-lisp-obj)
117   (:policy :fast-safe)
118   (:translate %make-lisp-obj)
119   (:args (value :scs (unsigned-reg) :target result))
120   (:arg-types unsigned-num)
121   (:results (result :scs (descriptor-reg)))
122   (:generator 1
123     (move result value)))
124
125 (define-vop (get-lisp-obj-address)
126   (:policy :fast-safe)
127   (:translate sb!di::get-lisp-obj-address)
128   (:args (thing :scs (descriptor-reg) :target result))
129   (:results (result :scs (unsigned-reg)))
130   (:result-types unsigned-num)
131   (:generator 1
132     (move result thing)))
133
134 (define-vop (fun-word-offset)
135   (:policy :fast-safe)
136   (:translate sb!di::fun-word-offset)
137   (:args (fun :scs (descriptor-reg)))
138   (:results (res :scs (unsigned-reg)))
139   (:result-types positive-fixnum)
140   (:generator 5
141     (loadw res fun 0 fun-pointer-lowtag)
142     (inst srl res n-widetag-bits)))