Add WITH-CYCLE-COUNTER for x86, sparc, and ppc. Sparc and ppc
[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))
278
279 (defmacro with-cycle-counter (&body body)
280   "Returns the primary value of BODY as the primary value, and the
281  number of tick cycles elapsed as secondary value.  To get the number
282  of cycles, multiply by *cycles-per-tick*"
283   (let ((hi0 (gensym))
284         (hi1 (gensym))
285         (lo0 (gensym))
286         (lo1 (gensym)))
287     `(multiple-value-bind (,lo0 ,hi0)
288          (read-cycle-counter)
289        (values (locally ,@body)
290                (multiple-value-bind (,lo1 ,hi1)
291                    (read-cycle-counter)
292                  ;; Can't do anything about the notes about generic
293                  ;; arithmetic, so silence the notes..
294                  (declare (optimize (inhibit-warnings 3))
295                  (+ (ash (- ,hi1 ,hi0) 32)
296                     (- ,lo1 ,lo0)))))))