arith.lisp 9.86 KB
Newer Older
1
;;; -*- Package: MIPS -*-
wlott's avatar
wlott committed
2 3
;;;
;;; **********************************************************************
wlott's avatar
wlott committed
4 5 6 7
;;; This code was written as part of the CMU Common Lisp project at
;;; Carnegie Mellon University, and has been placed in the public domain.
;;;
(ext:file-comment
8
  "$Header: src/assembly/mips/arith.lisp $")
wlott's avatar
wlott committed
9
;;;
wlott's avatar
wlott committed
10
;;; **********************************************************************
wlott's avatar
wlott committed
11 12 13 14 15 16
;;;
;;; Stuff to handle simple cases for generic arithmetic.
;;;
;;; Written by William Lott.
;;;

17
(in-package "MIPS")
wlott's avatar
wlott committed
18 19 20 21 22 23 24 25


(define-assembly-routine (generic-+
			  (:cost 10)
			  (:return-style :full-call)
			  (:translate +)
			  (:policy :safe)
			  (:save-p t))
26 27
			 ((:arg x (descriptor-reg any-reg) a0-offset)
			  (:arg y (descriptor-reg any-reg) a1-offset)
wlott's avatar
wlott committed
28

29
			  (:res res (descriptor-reg any-reg) a0-offset)
wlott's avatar
wlott committed
30 31 32

			  (:temp temp non-descriptor-reg nl0-offset)
			  (:temp lip interior-reg lip-offset)
wlott's avatar
wlott committed
33 34
			  #-gengc (:temp lra descriptor-reg lra-offset)
			  #+gengc (:temp ra any-reg ra-offset)
35
			  (:temp nargs any-reg nargs-offset)
36
			  (:temp ocfp any-reg ocfp-offset))
wlott's avatar
wlott committed
37 38 39 40 41 42
  (inst and temp x 3)
  (inst bne temp DO-STATIC-FUN)
  (inst and temp y 3)
  (inst bne temp DO-STATIC-FUN)
  (inst nop)
  (inst add res x y)
wlott's avatar
wlott committed
43 44 45 46 47 48
  #+gengc
  (progn
    (inst addu lip ra (* 2 word-bytes))
    (inst j lip)
    (inst nop))
  #-gengc
wlott's avatar
wlott committed
49 50 51
  (lisp-return lra lip :offset 2)

  DO-STATIC-FUN
52
  (inst lw lip null-tn (static-function-offset 'two-arg-+))
53
  (inst li nargs (fixnumize 2))
54
  (inst move ocfp cfp-tn)
wlott's avatar
wlott committed
55
  (inst j lip)
56
  (inst move cfp-tn csp-tn))
wlott's avatar
wlott committed
57 58 59 60 61 62 63 64


(define-assembly-routine (generic--
			  (:cost 10)
			  (:return-style :full-call)
			  (:translate -)
			  (:policy :safe)
			  (:save-p t))
65 66
			 ((:arg x (descriptor-reg any-reg) a0-offset)
			  (:arg y (descriptor-reg any-reg) a1-offset)
wlott's avatar
wlott committed
67

68
			  (:res res (descriptor-reg any-reg) a0-offset)
wlott's avatar
wlott committed
69 70 71

			  (:temp temp non-descriptor-reg nl0-offset)
			  (:temp lip interior-reg lip-offset)
wlott's avatar
wlott committed
72 73
			  #-gengc (:temp lra descriptor-reg lra-offset)
			  #+gengc (:temp ra any-reg ra-offset)
74
			  (:temp nargs any-reg nargs-offset)
75
			  (:temp ocfp any-reg ocfp-offset))
wlott's avatar
wlott committed
76 77 78 79 80 81
  (inst and temp x 3)
  (inst bne temp DO-STATIC-FUN)
  (inst and temp y 3)
  (inst bne temp DO-STATIC-FUN)
  (inst nop)
  (inst sub res x y)
wlott's avatar
wlott committed
82 83 84 85 86 87
  #+gengc
  (progn
    (inst addu lip ra (* 2 word-bytes))
    (inst j lip)
    (inst nop))
  #-gengc
wlott's avatar
wlott committed
88 89 90
  (lisp-return lra lip :offset 2)

  DO-STATIC-FUN
91
  (inst lw lip null-tn (static-function-offset 'two-arg--))
92
  (inst li nargs (fixnumize 2))
93
  (inst move ocfp cfp-tn)
wlott's avatar
wlott committed
94
  (inst j lip)
95
  (inst move cfp-tn csp-tn))
wlott's avatar
wlott committed
96 97 98 99 100 101 102 103


(define-assembly-routine (generic-*
			  (:cost 25)
			  (:return-style :full-call)
			  (:translate *)
			  (:policy :safe)
			  (:save-p t))
104 105
			 ((:arg x (descriptor-reg any-reg) a0-offset)
			  (:arg y (descriptor-reg any-reg) a1-offset)
wlott's avatar
wlott committed
106

107
			  (:res res (descriptor-reg any-reg) a0-offset)
wlott's avatar
wlott committed
108 109 110 111

			  (:temp temp non-descriptor-reg nl0-offset)
			  (:temp lo non-descriptor-reg nl1-offset)
			  (:temp hi non-descriptor-reg nl2-offset)
wlott's avatar
wlott committed
112
			  #-gengc (:temp pa-flag non-descriptor-reg nl4-offset)
wlott's avatar
wlott committed
113
			  (:temp lip interior-reg lip-offset)
wlott's avatar
wlott committed
114 115
			  #-gengc (:temp lra descriptor-reg lra-offset)
			  #+gengc (:temp ra any-reg ra-offset)
116
			  (:temp nargs any-reg nargs-offset)
117
			  (:temp ocfp any-reg ocfp-offset))
wlott's avatar
wlott committed
118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141
  ;; If either arg is not a fixnum, call the static function.
  (inst and temp x 3)
  (inst bne temp DO-STATIC-FUN)
  (inst and temp y 3)
  (inst bne temp DO-STATIC-FUN)
  (inst nop)

  ;; Remove the tag from one arg so that the result will have the correct
  ;; fixnum tag.
  (inst sra temp x 2)
  (inst mult temp y)
  (inst mflo res)
  (inst mfhi hi)
  ;; Check to see if the result will fit in a fixnum.  (I.e. the high word
  ;; is just 32 copies of the sign bit of the low word).
  (inst sra temp res 31)
  (inst xor temp hi)
  (inst beq temp DONE)
  ;; Shift the double word hi:res down two bits into hi:low to get rid of the
  ;; fixnum tag.
  (inst srl lo res 2)
  (inst sll temp hi 30)
  (inst or lo temp)
  (inst sra hi 2)
wlott's avatar
wlott committed
142 143 144 145 146

  ;; Do we need one word or two?  Assume two.
  (inst sra temp lo 31)
  (inst xor temp hi)
  (inst bne temp two-words)
147
  ;; Assume a two word header.
wlott's avatar
wlott committed
148 149
  (inst li temp (logior (ash 2 type-bits) bignum-type))

150
  ;; Only need one word, fix the header.
wlott's avatar
wlott committed
151
  (inst li temp (logior (ash 1 type-bits) bignum-type))
152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173

  #-gengc
  (pseudo-atomic (pa-flag :extra (pad-data-block (+ 1 bignum-digits-offset)))
    (inst or res alloc-tn other-pointer-type)
    (storew temp res 0 other-pointer-type))
  #+gengc
  (without-scheduling ()
    (inst or res alloc-tn other-pointer-type)
    (storew temp alloc-tn)
    (inst addu alloc-tn (pad-data-block (+ 1 bignum-digits-offset))))

  (storew lo res bignum-digits-offset other-pointer-type)

  ;; Out of here
  #+gengc
  (progn
    (inst addu lip ra (* 2 word-bytes))
    (inst j lip)
    (inst nop))
  #-gengc
  (lisp-return lra lip :offset 2)

wlott's avatar
wlott committed
174 175 176

  TWO-WORDS
  #-gengc
wlott's avatar
wlott committed
177
  (pseudo-atomic (pa-flag :extra (pad-data-block (+ 2 bignum-digits-offset)))
wlott's avatar
wlott committed
178 179 180 181 182 183 184 185 186 187 188
    (inst or res alloc-tn other-pointer-type)
    (storew temp res 0 other-pointer-type))
  #+gengc
  (without-scheduling ()
    (inst or res alloc-tn other-pointer-type)
    (storew temp alloc-tn)
    (inst addu alloc-tn (pad-data-block (+ 2 bignum-digits-offset))))

  (storew lo res bignum-digits-offset other-pointer-type)
  (storew hi res (1+ bignum-digits-offset) other-pointer-type)

wlott's avatar
wlott committed
189
  ;; Out of here
wlott's avatar
wlott committed
190 191 192 193 194 195
  #+gengc
  (progn
    (inst addu lip ra (* 2 word-bytes))
    (inst j lip)
    (inst nop))
  #-gengc
wlott's avatar
wlott committed
196 197
  (lisp-return lra lip :offset 2)

198

wlott's avatar
wlott committed
199
  DO-STATIC-FUN
200
  (inst lw lip null-tn (static-function-offset 'two-arg-*))
201
  (inst li nargs (fixnumize 2))
202
  (inst move ocfp cfp-tn)
wlott's avatar
wlott committed
203
  (inst j lip)
204
  (inst move cfp-tn csp-tn)
wlott's avatar
wlott committed
205 206

  DONE)
207 208 209 210 211 212 213 214 215 216 217 218



;;;; Comparison routines.

(macrolet
    ((define-cond-assem-rtn (name translate static-fn cmp not-p)
       `(define-assembly-routine (,name
				  (:cost 10)
				  (:return-style :full-call)
				  (:policy :safe)
				  (:translate ,translate)
219
				  (:save-p t))
220 221 222 223 224 225 226 227
				 ((:arg x (descriptor-reg any-reg) a0-offset)
				  (:arg y (descriptor-reg any-reg) a1-offset)
				  
				  (:res res descriptor-reg a0-offset)
				  
				  (:temp temp non-descriptor-reg nl0-offset)
				  (:temp lip interior-reg lip-offset)
				  (:temp nargs any-reg nargs-offset)
228
				  (:temp ocfp any-reg ocfp-offset))
229 230 231 232 233 234 235
	  (inst and temp x 3)
	  (inst bne temp DO-STATIC-FN)
	  (inst and temp y 3)
	  (inst beq temp DO-COMPARE)
	  ,cmp
	  
	  DO-STATIC-FN
236
	  (inst lw lip null-tn (static-function-offset ',static-fn))
237
	  (inst li nargs (fixnumize 2))
238
	  (inst move ocfp cfp-tn)
239
	  (inst j lip)
240
	  (inst move cfp-tn csp-tn)
241 242
	  
	  DO-COMPARE
wlott's avatar
typo  
wlott committed
243
	  (inst ,(if not-p 'bne 'beq) temp done)
244 245 246 247 248
	  (inst move res null-tn)
	  (load-symbol res t)
	  DONE)))

  (define-cond-assem-rtn generic-< < two-arg-< (inst slt temp x y) nil)
249
  (define-cond-assem-rtn generic-> > two-arg-> (inst slt temp y x) nil))
250 251 252 253 254 255 256


(define-assembly-routine (generic-eql
			  (:cost 10)
			  (:return-style :full-call)
			  (:policy :safe)
			  (:translate eql)
257
			  (:save-p t))
258 259 260 261 262 263 264
			 ((:arg x (descriptor-reg any-reg) a0-offset)
			  (:arg y (descriptor-reg any-reg) a1-offset)
			  
			  (:res res descriptor-reg a0-offset)
			  
			  (:temp temp non-descriptor-reg nl0-offset)
			  (:temp lip interior-reg lip-offset)
wlott's avatar
wlott committed
265 266
			  #-gengc (:temp lra descriptor-reg lra-offset)
			  #+gengc (:temp ra any-reg ra-offset)
267
			  (:temp nargs any-reg nargs-offset)
268
			  (:temp ocfp any-reg ocfp-offset))
269 270 271 272 273 274 275 276 277
  (inst beq x y RETURN-T)
  (inst and temp x 3)
  (inst beq temp RETURN-NIL)
  (inst and temp y 3)
  (inst bne temp DO-STATIC-FN)
  (inst nop)

  RETURN-NIL
  (inst move res null-tn)
wlott's avatar
wlott committed
278 279 280 281 282 283
  #+gengc
  (progn
    (inst addu lip ra (* 2 word-bytes))
    (inst j lip)
    (inst nop))
  #-gengc
284 285 286
  (lisp-return lra lip :offset 2)

  DO-STATIC-FN
287
  (inst lw lip null-tn (static-function-offset 'eql))
288
  (inst li nargs (fixnumize 2))
289
  (inst move ocfp cfp-tn)
290
  (inst j lip)
291
  (inst move cfp-tn csp-tn)
292 293 294 295 296 297 298 299 300

  RETURN-T
  (load-symbol res t))

(define-assembly-routine (generic-=
			  (:cost 10)
			  (:return-style :full-call)
			  (:policy :safe)
			  (:translate =)
301
			  (:save-p t))
302 303 304 305 306 307 308
			 ((:arg x (descriptor-reg any-reg) a0-offset)
			  (:arg y (descriptor-reg any-reg) a1-offset)
			  
			  (:res res descriptor-reg a0-offset)
			  
			  (:temp temp non-descriptor-reg nl0-offset)
			  (:temp lip interior-reg lip-offset)
wlott's avatar
wlott committed
309 310
			  #-gengc (:temp lra descriptor-reg lra-offset)
			  #+gengc (:temp ra any-reg ra-offset)
311
			  (:temp nargs any-reg nargs-offset)
312
			  (:temp ocfp any-reg ocfp-offset))
313 314 315 316
  (inst and temp x 3)
  (inst bne temp DO-STATIC-FN)
  (inst and temp y 3)
  (inst bne temp DO-STATIC-FN)
pw's avatar
pw committed
317
  (inst nop)
318
  (inst beq x y RETURN-T)
319 320

  (inst move res null-tn)
wlott's avatar
wlott committed
321 322 323 324 325 326
  #+gengc
  (progn
    (inst addu lip ra (* 2 word-bytes))
    (inst j lip)
    (inst nop))
  #-gengc
327 328 329
  (lisp-return lra lip :offset 2)

  DO-STATIC-FN
330
  (inst lw lip null-tn (static-function-offset 'two-arg-=))
331
  (inst li nargs (fixnumize 2))
332
  (inst move ocfp cfp-tn)
333
  (inst j lip)
334
  (inst move cfp-tn csp-tn)
335 336 337 338 339 340 341 342 343

  RETURN-T
  (load-symbol res t))

(define-assembly-routine (generic-/=
			  (:cost 10)
			  (:return-style :full-call)
			  (:policy :safe)
			  (:translate /=)
344
			  (:save-p t))
345 346 347 348 349 350 351
			 ((:arg x (descriptor-reg any-reg) a0-offset)
			  (:arg y (descriptor-reg any-reg) a1-offset)
			  
			  (:res res descriptor-reg a0-offset)
			  
			  (:temp temp non-descriptor-reg nl0-offset)
			  (:temp lip interior-reg lip-offset)
wlott's avatar
wlott committed
352 353
			  #-gengc (:temp lra descriptor-reg lra-offset)
			  #+gengc (:temp ra any-reg ra-offset)
354
			  (:temp nargs any-reg nargs-offset)
355
			  (:temp ocfp any-reg ocfp-offset))
356 357 358 359
  (inst and temp x 3)
  (inst bne temp DO-STATIC-FN)
  (inst and temp y 3)
  (inst bne temp DO-STATIC-FN)
pw's avatar
pw committed
360
  (inst nop)
361
  (inst beq x y RETURN-NIL)
362 363

  (load-symbol res t)
wlott's avatar
wlott committed
364 365 366 367 368 369
  #+gengc
  (progn
    (inst addu lip ra (* 2 word-bytes))
    (inst j lip)
    (inst nop))
  #-gengc
370 371 372
  (lisp-return lra lip :offset 2)

  DO-STATIC-FN
373
  (inst lw lip null-tn (static-function-offset 'two-arg-=))
374
  (inst li nargs (fixnumize 2))
375
  (inst move ocfp cfp-tn)
376
  (inst j lip)
377
  (inst move cfp-tn csp-tn)
378 379 380

  RETURN-NIL
  (inst move res null-tn))