cf5db5f98ff7cfe6d8043d84bad0d3f480baf4ef
[sbcl.git] / src / compiler / ppc / debug.lisp
1 ;;;
2 ;;; Written by William Lott.
3 ;;; 
4 (in-package "SB!VM")
5
6 (define-vop (debug-cur-sp)
7   (:translate sb!di::current-sp)
8   (:policy :fast-safe)
9   (:results (res :scs (sap-reg)))
10   (:result-types system-area-pointer)
11   (:generator 1
12     (move res csp-tn)))
13
14 (define-vop (debug-cur-fp)
15   (:translate sb!di::current-fp)
16   (:policy :fast-safe)
17   (:results (res :scs (sap-reg)))
18   (:result-types system-area-pointer)
19   (:generator 1
20     (move res cfp-tn)))
21
22 (define-vop (read-control-stack)
23   (:translate sb!kernel:stack-ref)
24   (:policy :fast-safe)
25   (:args (sap :scs (sap-reg))
26          (offset :scs (any-reg)))
27   (:arg-types system-area-pointer positive-fixnum)
28   (:results (result :scs (descriptor-reg)))
29   (:result-types *)
30   (:generator 5
31     (inst lwzx result sap offset)))
32
33 (define-vop (write-control-stack)
34   (:translate sb!kernel:%set-stack-ref)
35   (:policy :fast-safe)
36   (:args (sap :scs (sap-reg))
37          (offset :scs (any-reg))
38          (value :scs (descriptor-reg) :target result))
39   (:arg-types system-area-pointer positive-fixnum *)
40   (:results (result :scs (descriptor-reg)))
41   (:result-types *)
42   (:generator 5
43     (inst stwx value sap offset)
44     (move result value)))
45
46 (define-vop (code-from-mumble)
47   (:policy :fast-safe)
48   (:args (thing :scs (descriptor-reg)))
49   (:results (code :scs (descriptor-reg)))
50   (:temporary (:scs (non-descriptor-reg)) temp)
51   (:variant-vars lowtag)
52   (:generator 5
53     (let ((bogus (gen-label))
54           (done (gen-label)))
55       (loadw temp thing 0 lowtag)
56       (inst srwi temp temp sb!vm:n-widetag-bits)
57       (inst cmpwi temp 0)
58       (inst slwi temp temp (1- (integer-length sb!vm:n-word-bytes)))
59       (inst beq bogus)
60       (unless (= lowtag sb!vm:other-pointer-lowtag)
61         (inst addi temp temp (- lowtag sb!vm:other-pointer-lowtag)))
62       (inst sub code thing temp)
63       (emit-label done)
64       (assemble (*elsewhere*)
65         (emit-label bogus)
66         (move code null-tn)
67         (inst b done)))))
68
69 (define-vop (code-from-lra code-from-mumble)
70   (:translate sb!di::lra-code-header)
71   (:variant sb!vm:other-pointer-lowtag))
72
73 (define-vop (code-from-fun code-from-mumble)
74   (:translate sb!di::fun-code-header)
75   (:variant sb!vm:fun-pointer-lowtag))
76
77 (define-vop (make-lisp-obj)
78   (:policy :fast-safe)
79   (:translate sb!di::make-lisp-obj)
80   (:args (value :scs (unsigned-reg) :target result))
81   (:arg-types unsigned-num)
82   (:results (result :scs (descriptor-reg)))
83   (:generator 1
84     (move result value)))
85
86 (define-vop (get-lisp-obj-address)
87   (:policy :fast-safe)
88   (:translate sb!di::get-lisp-obj-address)
89   (:args (thing :scs (descriptor-reg) :target result))
90   (:results (result :scs (unsigned-reg)))
91   (:result-types unsigned-num)
92   (:generator 1
93     (move result thing)))
94
95
96 (define-vop (fun-word-offset)
97   (:policy :fast-safe)
98   (:translate sb!di::fun-word-offset)
99   (:args (fun :scs (descriptor-reg)))
100   (:results (res :scs (unsigned-reg)))
101   (:result-types positive-fixnum)
102   (:generator 5
103     (loadw res fun 0 fun-pointer-lowtag)
104     (inst srwi res res sb!vm:n-widetag-bits)))