25a37072b1502e1f4794ee74a3969142fca48582
[sbcl.git] / src / compiler / alpha / debug.lisp
1 ;;;; Alpha 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 (define-vop (debug-cur-sp)
15   (:translate current-sp)
16   (:policy :fast-safe)
17   (:results (res :scs (sap-reg)))
18   (:result-types system-area-pointer)
19   (:generator 1
20     (move csp-tn res)))
21
22 (define-vop (debug-cur-fp)
23   (:translate current-fp)
24   (:policy :fast-safe)
25   (:results (res :scs (sap-reg)))
26   (:result-types system-area-pointer)
27   (:generator 1
28     (move cfp-tn res)))
29
30 (define-vop (read-control-stack)
31   (:translate stack-ref)
32   (:policy :fast-safe)
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)))
38   (:result-types *)
39   (:generator 5
40     (inst addq object offset sap)
41     (inst ldl result 0 sap)))
42
43 (define-vop (read-control-stack-c)
44   (:translate stack-ref)
45   (:policy :fast-safe)
46   (:args (object :scs (sap-reg)))
47   (:info offset)
48   (:arg-types system-area-pointer (:constant (signed-byte 14)))
49   (:results (result :scs (descriptor-reg)))
50   (:result-types *)
51   (:generator 4
52     (inst ldl result (* offset word-bytes) object)))
53
54 (define-vop (write-control-stack)
55   (:translate %set-stack-ref)
56   (:policy :fast-safe)
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)))
62   (:result-types *)
63   (:temporary (:scs (sap-reg) :from (:argument 1)) sap)
64   (:generator 2
65     (inst addq object offset sap)
66     (inst stl value 0 sap)
67     (move value result)))
68
69 (define-vop (write-control-stack-c)
70   (:translate %set-stack-ref)
71   (:policy :fast-safe)
72   (:args (sap :scs (sap-reg))
73          (value :scs (descriptor-reg) :target result))
74   (:info offset)
75   (:arg-types system-area-pointer (:constant (signed-byte 14)) *)
76   (:results (result :scs (descriptor-reg)))
77   (:result-types *)
78   (:generator 1
79     (inst stl value (* offset word-bytes) sap)
80     (move value result)))
81
82
83 (define-vop (code-from-mumble)
84   (:policy :fast-safe)
85   (:args (thing :scs (descriptor-reg)))
86   (:results (code :scs (descriptor-reg)))
87   (:temporary (:scs (non-descriptor-reg)) temp)
88   (:variant-vars lowtag)
89   (:generator 5
90     (let ((bogus (gen-label))
91           (done (gen-label)))
92       (loadw temp thing 0 lowtag)
93       (inst srl temp sb!vm:n-widetag-bits temp)
94       (inst beq temp bogus)
95       (inst sll temp (1- (integer-length sb!vm:word-bytes)) temp)
96       (unless (= lowtag sb!vm:other-pointer-lowtag)
97         (inst subq temp (- sb!vm:other-pointer-lowtag lowtag) temp))
98       (inst subq thing temp code)
99       (emit-label done)
100       (assemble (*elsewhere*)
101         (emit-label bogus)
102         (move null-tn code)
103         (inst br zero-tn done)))))
104
105 (define-vop (code-from-lra code-from-mumble)
106   (:translate lra-code-header)
107   (:variant sb!vm:other-pointer-lowtag))
108
109 (define-vop (code-from-function code-from-mumble)
110   (:translate fun-code-header)
111   (:variant sb!vm:fun-pointer-lowtag))
112
113 (define-vop (make-lisp-obj)
114   (:policy :fast-safe)
115   (:translate make-lisp-obj)
116   (:args (value :scs (unsigned-reg) :target result))
117   (:arg-types unsigned-num)
118   (:results (result :scs (descriptor-reg)))
119   (:generator 1
120     (move value result)))
121
122 (define-vop (get-lisp-obj-address)
123   (:policy :fast-safe)
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)
128   (:generator 1
129     (move thing result)))
130
131 (define-vop (fun-word-offset)
132   (:policy :fast-safe)
133   (:translate fun-word-offset)
134   (:args (fun :scs (descriptor-reg)))
135   (:results (res :scs (unsigned-reg)))
136   (:result-types positive-fixnum)
137   (:generator 5
138     (loadw res fun 0 fun-pointer-lowtag)
139     (inst srl res sb!vm:n-widetag-bits res)))
140
141 (defknown make-number-stack-pointer ((unsigned-byte 32)) system-area-pointer
142   (movable foldable flushable))
143
144 (define-vop (make-number-stack-pointer)
145   (:policy :fast-safe)
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)
151   (:generator 5
152     (inst mskll nsp-tn 0 res)
153     (inst bis res arg res)))