[projects/cmucl/cmucl.git] / src / compiler / ppc / system.lisp

;;; -*- Package: PPC -*-
;;;
;;; **********************************************************************
;;; This code was written as part of the CMU Common Lisp project at
;;; Carnegie Mellon University, and has been placed in the public domain.
;;; If you want to use this code or any part of CMU Common Lisp, please contact
;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;;
(ext:file-comment
  "$Header: src/compiler/ppc/system.lisp $")
;;;
;;; **********************************************************************
;;;
;;;    PPC VM definitions of various system hacking operations.
;;;
;;; Written by Rob MacLachlan
;;;
;;; Mips conversion by William Lott and Christopher Hoover.
;;;
(in-package "PPC")


\f
;;;; Type frobbing VOPs

(define-vop (get-lowtag)
  (:translate get-lowtag)
  (:policy :fast-safe)
  (:args (object :scs (any-reg descriptor-reg)))
  (:results (result :scs (unsigned-reg)))
  (:result-types positive-fixnum)
  (:generator 1
    (inst andi. result object vm:lowtag-mask)))

(define-vop (get-type)
  (:translate get-type)
  (:policy :fast-safe)
  (:args (object :scs (descriptor-reg) :to (:eval 1)))
  (:results (result :scs (unsigned-reg) :from (:eval 0)))
  (:result-types positive-fixnum)
  (:generator 6
    ;; Grab the lowtag.
    (inst andi. result object lowtag-mask)
    ;; Check for various pointer types.
    (inst cmpwi result list-pointer-type)
    (inst beq done)
    (inst cmpwi result other-pointer-type)
    (inst beq other-pointer)
    (inst cmpwi result function-pointer-type)
    (inst beq function-pointer)
    (inst cmpwi result instance-pointer-type)
    (inst beq done)
    ;; Okay, it is an immediate.  If fixnum, we want zero.  Otherwise,
    ;; we want the low 8 bits.
    (inst andi. result object #b11)
    (inst beq done)
    ;; It wasn't a fixnum, so get the low 8 bits.
    (inst andi. result object type-mask)
    (inst b done)
    
    FUNCTION-POINTER
    (load-type result object (- function-pointer-type))
    (inst b done)

    OTHER-POINTER
    (load-type result object (- other-pointer-type))

    DONE))


(define-vop (function-subtype)
  (:translate function-subtype)
  (:policy :fast-safe)
  (:args (function :scs (descriptor-reg)))
  (:results (result :scs (unsigned-reg)))
  (:result-types positive-fixnum)
  (:generator 6
    (load-type result function (- vm:function-pointer-type))))

(define-vop (set-function-subtype)
  (:translate (setf function-subtype))
  (:policy :fast-safe)
  (:args (type :scs (unsigned-reg) :target result)
	 (function :scs (descriptor-reg)))
  (:arg-types positive-fixnum *)
  (:results (result :scs (unsigned-reg)))
  (:result-types positive-fixnum)
  (:generator 6
    (inst stb type function (- 3 function-pointer-type))
    (move result type)))

(define-vop (get-header-data)
  (:translate get-header-data)
  (:policy :fast-safe)
  (:args (x :scs (descriptor-reg)))
  (:results (res :scs (unsigned-reg)))
  (:result-types positive-fixnum)
  (:generator 6
    (loadw res x 0 vm:other-pointer-type)
    (inst srwi res res vm:type-bits)))

(define-vop (get-closure-length)
  (:translate get-closure-length)
  (:policy :fast-safe)
  (:args (x :scs (descriptor-reg)))
  (:results (res :scs (unsigned-reg)))
  (:result-types positive-fixnum)
  (:generator 6
    (loadw res x 0 vm:function-pointer-type)
    (inst srwi res res vm:type-bits)))

(define-vop (set-header-data)
  (:translate set-header-data)
  (:policy :fast-safe)
  (:args (x :scs (descriptor-reg) :target res)
	 (data :scs (any-reg immediate zero)))
  (:arg-types * positive-fixnum)
  (:results (res :scs (descriptor-reg)))
  (:temporary (:scs (non-descriptor-reg)) t1 t2)
  (:generator 6
    (loadw t1 x 0 vm:other-pointer-type)
    (inst andi. t1 t1 vm:type-mask)
    (sc-case data
      (any-reg
       (inst slwi t2 data (- vm:type-bits 2))
       (inst or t1 t1 t2))
      (immediate
       (inst ori t1 t1 (ash (tn-value data) vm:type-bits)))
      (zero))
    (storew t1 x 0 vm:other-pointer-type)
    (move res x)))


(define-vop (make-fixnum)
  (:args (ptr :scs (any-reg descriptor-reg)))
  (:results (res :scs (any-reg descriptor-reg)))
  (:generator 1
    ;;
    ;; Some code (the hash table code) depends on this returning a
    ;; positive number so make sure it does.
    (inst slwi res ptr 3)
    (inst srwi res res 1)))

(define-vop (make-other-immediate-type)
  (:args (val :scs (any-reg descriptor-reg))
	 (type :scs (any-reg descriptor-reg immediate)
	       :target temp))
  (:results (res :scs (any-reg descriptor-reg)))
  (:temporary (:scs (non-descriptor-reg)) temp)
  (:generator 2
    (sc-case type
      (immediate
       (inst slwi temp val vm:type-bits)
       (inst ori res temp (tn-value type)))
      (t
       (inst srawi temp type 2)
       (inst slwi res val (- vm:type-bits 2))
       (inst or res res temp)))))

\f
;;;; Allocation

(define-vop (dynamic-space-free-pointer)
  (:results (int :scs (sap-reg)))
  (:result-types system-area-pointer)
  (:translate dynamic-space-free-pointer)
  (:policy :fast-safe)
  (:generator 1
    (move int alloc-tn)))

(define-vop (binding-stack-pointer-sap)
  (:results (int :scs (sap-reg)))
  (:result-types system-area-pointer)
  (:translate binding-stack-pointer-sap)
  (:policy :fast-safe)
  (:generator 1
    (move int bsp-tn)))

(define-vop (control-stack-pointer-sap)
  (:results (int :scs (sap-reg)))
  (:result-types system-area-pointer)
  (:translate control-stack-pointer-sap)
  (:policy :fast-safe)
  (:generator 1
    (move int csp-tn)))

\f
;;;; Code object frobbing.

(define-vop (code-instructions)
  (:translate code-instructions)
  (:policy :fast-safe)
  (:args (code :scs (descriptor-reg)))
  (:temporary (:scs (non-descriptor-reg)) ndescr)
  (:results (sap :scs (sap-reg)))
  (:result-types system-area-pointer)
  (:generator 10
    (loadw ndescr code 0 vm:other-pointer-type)
    (inst srwi ndescr ndescr vm:type-bits)
    (inst slwi ndescr ndescr vm:word-shift)
    (inst subi ndescr ndescr vm:other-pointer-type)
    (inst add sap code ndescr)))

(define-vop (compute-function)
  (:args (code :scs (descriptor-reg))
	 (offset :scs (signed-reg unsigned-reg)))
  (:arg-types * positive-fixnum)
  (:results (func :scs (descriptor-reg)))
  (:temporary (:scs (non-descriptor-reg)) ndescr)
  (:generator 10
    (loadw ndescr code 0 vm:other-pointer-type)
    (inst srwi ndescr ndescr vm:type-bits)
    (inst slwi ndescr ndescr vm:word-shift)
    (inst add ndescr ndescr offset)
    (inst addi ndescr ndescr (- vm:function-pointer-type vm:other-pointer-type))
    (inst add func code ndescr)))


\f
;;;; Other random VOPs.


(defknown unix::do-pending-interrupt () (values))
(define-vop (unix::do-pending-interrupt)
  (:policy :fast-safe)
  (:translate unix::do-pending-interrupt)
  (:generator 1
    (inst unimp pending-interrupt-trap)))


(define-vop (halt)
  (:generator 1
    (inst unimp halt-trap)))


\f
;;;; Dynamic vop count collection support

(define-vop (count-me)
  (:args (count-vector :scs (descriptor-reg)))
  (:info index)
  (:temporary (:scs (non-descriptor-reg)) count)
  (:generator 1
    (let ((offset
	   (- (* (+ index vector-data-offset) word-bytes) other-pointer-type)))
      (assert (typep offset '(signed-byte 16)))
      (inst lwz count count-vector offset)
      (inst addi count count 1)
      (inst stw count count-vector offset))))
\f
(defknown read-time-base ()
  (values (unsigned-byte 32) (unsigned-byte 32)))

(define-vop (read-time-base)
  (:translate read-time-base)
  (:args)
  (:policy :fast-safe)
  (:results (lo :scs (unsigned-reg))
	    (hi :scs (unsigned-reg)))
  (:result-types unsigned-num unsigned-num)
  (:temporary (:sc unsigned-reg) temp)
  (:temporary (:sc unsigned-reg :target hi) temp-hi)
  (:temporary (:sc unsigned-reg :target lo) temp-lo)
  (:generator 7
    ;; From 2.2.1
    (let ((loop (gen-label)))
      (emit-label loop)
      (inst mftbu temp-hi)
      (inst mftb temp-lo)
      (inst mftbu temp)
      (inst cmpw temp temp-hi)
      (inst bne loop)
      (move hi temp-hi)
      (move lo temp-lo))))

(defun read-cycle-counter ()
  (read-time-base))

(defmacro with-cycle-counter (&body body)
  "Returns the primary value of BODY as the primary value, and the
 number of tick cycles elapsed as secondary value.  To get the number
 of cycles, multiply by *cycles-per-tick*"
  (let ((hi0 (gensym))
	(hi1 (gensym))
	(lo0 (gensym))
	(lo1 (gensym)))
    `(multiple-value-bind (,lo0 ,hi0)
	 (read-cycle-counter)
       (values (locally ,@body)
               (multiple-value-bind (,lo1 ,hi1)
		   (read-cycle-counter)
		 ;; Can't do anything about the notes about generic
		 ;; arithmetic, so silence the notes..
		 (declare (optimize (inhibit-warnings 3)))
                 (+ (ash (- ,hi1 ,hi0) 32)
                    (- ,lo1 ,lo0)))))))
Commit	Line	Data
58aa93ec	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
99a5797f	10	"$Header: src/compiler/ppc/system.lisp $")
58aa93ec	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))))
484fcd5b	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 ()
68ac9a3e	277	(read-time-base))
8d75583b RT	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..
8391b8b0	294	(declare (optimize (inhibit-warnings 3)))
8d75583b RT	295	(+ (ash (- ,hi1 ,hi0) 32)
8d75583b RT	296	(- ,lo1 ,lo0)))))))