c3fe76a797496ab3443cc7688f873ecc12d3f354
[projects/cmucl/cmucl.git] / src / compiler / ppc / system.lisp
1 ;;; -*- Package: PPC -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; This code was written as part of the CMU Common Lisp project at
5 ;;; Carnegie Mellon University, and has been placed in the public domain.
6 ;;; If you want to use this code or any part of CMU Common Lisp, please contact
7 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
8 ;;;
9 (ext:file-comment
10   "$Header: src/compiler/ppc/system.lisp $")
11 ;;;
12 ;;; **********************************************************************
13 ;;;
14 ;;;    PPC VM definitions of various system hacking operations.
15 ;;;
16 ;;; Written by Rob MacLachlan
17 ;;;
18 ;;; Mips conversion by William Lott and Christopher Hoover.
19 ;;;
20 (in-package "PPC")
21
22
23 \f
24 ;;;; Type frobbing VOPs
25
26 (define-vop (get-lowtag)
27   (:translate get-lowtag)
28   (:policy :fast-safe)
29   (:args (object :scs (any-reg descriptor-reg)))
30   (:results (result :scs (unsigned-reg)))
31   (:result-types positive-fixnum)
32   (:generator 1
33     (inst andi. result object vm:lowtag-mask)))
34
35 (define-vop (get-type)
36   (:translate get-type)
37   (:policy :fast-safe)
38   (:args (object :scs (descriptor-reg) :to (:eval 1)))
39   (:results (result :scs (unsigned-reg) :from (:eval 0)))
40   (:result-types positive-fixnum)
41   (:generator 6
42     ;; Grab the lowtag.
43     (inst andi. result object lowtag-mask)
44     ;; Check for various pointer types.
45     (inst cmpwi result list-pointer-type)
46     (inst beq done)
47     (inst cmpwi result other-pointer-type)
48     (inst beq other-pointer)
49     (inst cmpwi result function-pointer-type)
50     (inst beq function-pointer)
51     (inst cmpwi result instance-pointer-type)
52     (inst beq done)
53     ;; Okay, it is an immediate.  If fixnum, we want zero.  Otherwise,
54     ;; we want the low 8 bits.
55     (inst andi. result object #b11)
56     (inst beq done)
57     ;; It wasn't a fixnum, so get the low 8 bits.
58     (inst andi. result object type-mask)
59     (inst b done)
60     
61     FUNCTION-POINTER
62     (load-type result object (- function-pointer-type))
63     (inst b done)
64
65     OTHER-POINTER
66     (load-type result object (- other-pointer-type))
67
68     DONE))
69
70
71 (define-vop (function-subtype)
72   (:translate function-subtype)
73   (:policy :fast-safe)
74   (:args (function :scs (descriptor-reg)))
75   (:results (result :scs (unsigned-reg)))
76   (:result-types positive-fixnum)
77   (:generator 6
78     (load-type result function (- vm:function-pointer-type))))
79
80 (define-vop (set-function-subtype)
81   (:translate (setf function-subtype))
82   (:policy :fast-safe)
83   (:args (type :scs (unsigned-reg) :target result)
84          (function :scs (descriptor-reg)))
85   (:arg-types positive-fixnum *)
86   (:results (result :scs (unsigned-reg)))
87   (:result-types positive-fixnum)
88   (:generator 6
89     (inst stb type function (- 3 function-pointer-type))
90     (move result type)))
91
92 (define-vop (get-header-data)
93   (:translate get-header-data)
94   (:policy :fast-safe)
95   (:args (x :scs (descriptor-reg)))
96   (:results (res :scs (unsigned-reg)))
97   (:result-types positive-fixnum)
98   (:generator 6
99     (loadw res x 0 vm:other-pointer-type)
100     (inst srwi res res vm:type-bits)))
101
102 (define-vop (get-closure-length)
103   (:translate get-closure-length)
104   (:policy :fast-safe)
105   (:args (x :scs (descriptor-reg)))
106   (:results (res :scs (unsigned-reg)))
107   (:result-types positive-fixnum)
108   (:generator 6
109     (loadw res x 0 vm:function-pointer-type)
110     (inst srwi res res vm:type-bits)))
111
112 (define-vop (set-header-data)
113   (:translate set-header-data)
114   (:policy :fast-safe)
115   (:args (x :scs (descriptor-reg) :target res)
116          (data :scs (any-reg immediate zero)))
117   (:arg-types * positive-fixnum)
118   (:results (res :scs (descriptor-reg)))
119   (:temporary (:scs (non-descriptor-reg)) t1 t2)
120   (:generator 6
121     (loadw t1 x 0 vm:other-pointer-type)
122     (inst andi. t1 t1 vm:type-mask)
123     (sc-case data
124       (any-reg
125        (inst slwi t2 data (- vm:type-bits 2))
126        (inst or t1 t1 t2))
127       (immediate
128        (inst ori t1 t1 (ash (tn-value data) vm:type-bits)))
129       (zero))
130     (storew t1 x 0 vm:other-pointer-type)
131     (move res x)))
132
133
134 (define-vop (make-fixnum)
135   (:args (ptr :scs (any-reg descriptor-reg)))
136   (:results (res :scs (any-reg descriptor-reg)))
137   (:generator 1
138     ;;
139     ;; Some code (the hash table code) depends on this returning a
140     ;; positive number so make sure it does.
141     (inst slwi res ptr 3)
142     (inst srwi res res 1)))
143
144 (define-vop (make-other-immediate-type)
145   (:args (val :scs (any-reg descriptor-reg))
146          (type :scs (any-reg descriptor-reg immediate)
147                :target temp))
148   (:results (res :scs (any-reg descriptor-reg)))
149   (:temporary (:scs (non-descriptor-reg)) temp)
150   (:generator 2
151     (sc-case type
152       (immediate
153        (inst slwi temp val vm:type-bits)
154        (inst ori res temp (tn-value type)))
155       (t
156        (inst srawi temp type 2)
157        (inst slwi res val (- vm:type-bits 2))
158        (inst or res res temp)))))
159
160 \f
161 ;;;; Allocation
162
163 (define-vop (dynamic-space-free-pointer)
164   (:results (int :scs (sap-reg)))
165   (:result-types system-area-pointer)
166   (:translate dynamic-space-free-pointer)
167   (:policy :fast-safe)
168   (:generator 1
169     (move int alloc-tn)))
170
171 (define-vop (binding-stack-pointer-sap)
172   (:results (int :scs (sap-reg)))
173   (:result-types system-area-pointer)
174   (:translate binding-stack-pointer-sap)
175   (:policy :fast-safe)
176   (:generator 1
177     (move int bsp-tn)))
178
179 (define-vop (control-stack-pointer-sap)
180   (:results (int :scs (sap-reg)))
181   (:result-types system-area-pointer)
182   (:translate control-stack-pointer-sap)
183   (:policy :fast-safe)
184   (:generator 1
185     (move int csp-tn)))
186
187 \f
188 ;;;; Code object frobbing.
189
190 (define-vop (code-instructions)
191   (:translate code-instructions)
192   (:policy :fast-safe)
193   (:args (code :scs (descriptor-reg)))
194   (:temporary (:scs (non-descriptor-reg)) ndescr)
195   (:results (sap :scs (sap-reg)))
196   (:result-types system-area-pointer)
197   (:generator 10
198     (loadw ndescr code 0 vm:other-pointer-type)
199     (inst srwi ndescr ndescr vm:type-bits)
200     (inst slwi ndescr ndescr vm:word-shift)
201     (inst subi ndescr ndescr vm:other-pointer-type)
202     (inst add sap code ndescr)))
203
204 (define-vop (compute-function)
205   (:args (code :scs (descriptor-reg))
206          (offset :scs (signed-reg unsigned-reg)))
207   (:arg-types * positive-fixnum)
208   (:results (func :scs (descriptor-reg)))
209   (:temporary (:scs (non-descriptor-reg)) ndescr)
210   (:generator 10
211     (loadw ndescr code 0 vm:other-pointer-type)
212     (inst srwi ndescr ndescr vm:type-bits)
213     (inst slwi ndescr ndescr vm:word-shift)
214     (inst add ndescr ndescr offset)
215     (inst addi ndescr ndescr (- vm:function-pointer-type vm:other-pointer-type))
216     (inst add func code ndescr)))
217
218
219 \f
220 ;;;; Other random VOPs.
221
222
223 (defknown unix::do-pending-interrupt () (values))
224 (define-vop (unix::do-pending-interrupt)
225   (:policy :fast-safe)
226   (:translate unix::do-pending-interrupt)
227   (:generator 1
228     (inst unimp pending-interrupt-trap)))
229
230
231 (define-vop (halt)
232   (:generator 1
233     (inst unimp halt-trap)))
234
235
236 \f
237 ;;;; Dynamic vop count collection support
238
239 (define-vop (count-me)
240   (:args (count-vector :scs (descriptor-reg)))
241   (:info index)
242   (:temporary (:scs (non-descriptor-reg)) count)
243   (:generator 1
244     (let ((offset
245            (- (* (+ index vector-data-offset) word-bytes) other-pointer-type)))
246       (assert (typep offset '(signed-byte 16)))
247       (inst lwz count count-vector offset)
248       (inst addi count count 1)
249       (inst stw count count-vector offset))))
250 \f
251 (defknown read-time-base ()
252   (values (unsigned-byte 32) (unsigned-byte 32)))
253
254 (define-vop (read-time-base)
255   (:translate read-time-base)
256   (:args)
257   (:policy :fast-safe)
258   (:results (lo :scs (unsigned-reg))
259             (hi :scs (unsigned-reg)))
260   (:result-types unsigned-num unsigned-num)
261   (:temporary (:sc unsigned-reg) temp)
262   (:temporary (:sc unsigned-reg :target hi) temp-hi)
263   (:temporary (:sc unsigned-reg :target lo) temp-lo)
264   (:generator 7
265     ;; From 2.2.1
266     (let ((loop (gen-label)))
267       (emit-label loop)
268       (inst mftbu temp-hi)
269       (inst mftb temp-lo)
270       (inst mftbu temp)
271       (inst cmpw temp temp-hi)
272       (inst bne loop)
273       (move hi temp-hi)
274       (move lo temp-lo))))
275
276 (defun read-cycle-counter ()
277   (read-time-base))