arith.lisp 12.2 KB
Newer Older
1 2 3 4 5 6 7 8 9
;;; -*- 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
10
  "$Header: src/assembly/ppc/arith.lisp $")
11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41
;;;
;;; **********************************************************************
;;;
;;; Stuff to handle simple cases for generic arithmetic.
;;;
;;; Written by William Lott.
;;;

(in-package "PPC")



;;;; Addition and subtraction.

(define-assembly-routine 
  (generic-+
   (:cost 10)
   (:return-style :full-call)
   (:translate +)
   (:policy :safe)
   (:save-p t))
  ((:arg x (descriptor-reg any-reg) a0-offset)
   (:arg y (descriptor-reg any-reg) a1-offset)
   
   (:res res (descriptor-reg any-reg) a0-offset)
   
   (:temp temp non-descriptor-reg nl0-offset)
   (:temp temp2 non-descriptor-reg nl1-offset)
   (:temp flag non-descriptor-reg nl3-offset)
   (:temp lra descriptor-reg lra-offset)
   (:temp nargs any-reg nargs-offset)
42
   (:temp lip interior-reg lip-offset)
43 44 45
   (:temp ocfp any-reg ocfp-offset))
  
  ; Clear the damned "sticky overflow" bit in :cr0 and :xer
46
  (inst mtxer zero-tn)
47 48 49 50 51 52 53 54 55 56 57
  (inst or temp x y)
  (inst andi. temp temp 3)
  (inst bne DO-STATIC-FUN)
  (inst addo. temp x y)
  (inst bns done)
 
  (inst srawi temp x 2)
  (inst srawi temp2 y 2)
  (inst add temp2 temp2 temp)
  (with-fixed-allocation (res flag temp bignum-type (1+ bignum-digits-offset))
    (storew temp2 res bignum-digits-offset other-pointer-type))
58
  (lisp-return lra lip :offset 2)
59 60

  DO-STATIC-FUN
61
  (inst lwz code-tn null-tn (static-function-offset 'two-arg-+))
62
  (inst li nargs (fixnumize 2))
63 64
  (inst mr ocfp cfp-tn)
  (inst mr cfp-tn csp-tn)
65 66
  (inst j code-tn
	(- (* function-code-offset word-bytes) function-pointer-type))
67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88

  DONE
  (move res temp))


(define-assembly-routine 
  (generic--
   (:cost 10)
   (:return-style :full-call)
   (:translate -)
   (:policy :safe)
   (:save-p t))
  ((:arg x (descriptor-reg any-reg) a0-offset)
   (:arg y (descriptor-reg any-reg) a1-offset)
   
   (:res res (descriptor-reg any-reg) a0-offset)
   
   (:temp temp non-descriptor-reg nl0-offset)
   (:temp temp2 non-descriptor-reg nl1-offset)
   (:temp flag non-descriptor-reg nl3-offset)
   (:temp lra descriptor-reg lra-offset)
   (:temp nargs any-reg nargs-offset)
89
   (:temp lip interior-reg lip-offset)
90 91 92
   (:temp ocfp any-reg ocfp-offset))

  ; Clear the damned "sticky overflow" bit in :cr0
93
  (inst mtxer zero-tn)
94 95 96 97 98 99 100 101 102 103 104 105 106

  (inst or temp x y)
  (inst andi. temp temp 3)
  (inst bne DO-STATIC-FUN)

  (inst subo. temp x y)
  (inst bns done)

  (inst srawi temp x 2)
  (inst srawi temp2 y 2)
  (inst sub temp2 temp temp2)
  (with-fixed-allocation (res flag temp bignum-type (1+ bignum-digits-offset))
    (storew temp2 res bignum-digits-offset other-pointer-type))
107
  (lisp-return lra lip :offset 2)
108 109

  DO-STATIC-FUN
110
  (inst lwz code-tn null-tn (static-function-offset 'two-arg--))
111
  (inst li nargs (fixnumize 2))
112 113
  (inst mr ocfp cfp-tn)
  (inst mr cfp-tn csp-tn)
114 115
  (inst j code-tn
	(- (* function-code-offset word-bytes) function-pointer-type))
116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140

  DONE
  (move res temp))



;;;; Multiplication


(define-assembly-routine 
  (generic-*
   (:cost 50)
   (:return-style :full-call)
   (:translate *)
   (:policy :safe)
   (:save-p t))
  ((:arg x (descriptor-reg any-reg) a0-offset)
   (:arg y (descriptor-reg any-reg) a1-offset)
   
   (:res res (descriptor-reg any-reg) a0-offset)
   
   (:temp temp non-descriptor-reg nl0-offset)
   (:temp lo non-descriptor-reg nl1-offset)
   (:temp hi non-descriptor-reg nl2-offset)
   (:temp pa-flag non-descriptor-reg nl3-offset)
141
   (:temp lip interior-reg lip-offset)
142 143 144 145 146
   (:temp lra descriptor-reg lra-offset)
   (:temp nargs any-reg nargs-offset)
   (:temp ocfp any-reg ocfp-offset))

  ;; If either arg is not a fixnum, call the static function.  But first ...
147
  (inst mtxer zero-tn)
148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169

  (inst or temp x y)
  (inst andi. temp temp 3)
  ;; Remove the tag from both args, so I don't get so confused.
  (inst srawi temp x 2)
  (inst srawi nargs y 2)
  (inst bne DO-STATIC-FUN)


  (inst mullwo. lo nargs temp)
  (inst srawi hi lo 31)                 ; hi = 32 copies of lo's sign bit
  (inst bns ONE-WORD-ANSWER)
  (inst mulhw hi nargs temp)
  (inst b CONS-BIGNUM)
  
  ONE-WORD-ANSWER                       ; We know that all of the overflow bits are clear.
  (inst addo temp lo lo)
  (inst addo. res temp temp)
  (inst bns GO-HOME)

  CONS-BIGNUM
  ;; Allocate a BIGNUM for the result.
170
  (with-fixed-allocation (res pa-flag temp bignum-type (+ 2 bignum-digits-offset))
171 172 173 174 175 176 177 178 179 180 181 182 183 184
    (let ((one-word (gen-label)))
      ;; We start out assuming that we need one word.  Is that correct?
      (inst srawi temp lo 31)
      (inst xor. temp temp hi)
      (inst li temp (logior (ash 1 type-bits) bignum-type))
      (inst beq one-word)
      ;; Nope, we need two, so allocate the additional space.
      (inst li temp (logior (ash 2 type-bits) bignum-type))
      (storew hi res (1+ bignum-digits-offset) other-pointer-type)
      (emit-label one-word)
      (storew temp res 0 other-pointer-type)
      (storew lo res bignum-digits-offset other-pointer-type)))
  ;; Out of here
  GO-HOME
185
  (lisp-return lra lip :offset 2)
186 187

  DO-STATIC-FUN
188
  (inst lwz code-tn null-tn (static-function-offset 'two-arg-*))
189
  (inst li nargs (fixnumize 2))
190 191
  (inst mr ocfp cfp-tn)
  (inst mr cfp-tn csp-tn)
192 193
  (inst j code-tn
	(- (* function-code-offset word-bytes) function-pointer-type))
194
  
195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310
  LOW-FITS-IN-FIXNUM
  (move res lo))

(macrolet
    ((frob (name note cost type sc)
       `(define-assembly-routine (,name
				  (:note ,note)
				  (:cost ,cost)
				  (:translate *)
				  (:policy :fast-safe)
				  (:arg-types ,type ,type)
				  (:result-types ,type))
				 ((:arg x ,sc nl0-offset)
				  (:arg y ,sc nl1-offset)
				  (:res res ,sc nl0-offset))
	  ,@(when (eq type 'tagged-num)
	      `((inst srawi x x 2)))
          (inst mullw res x y))))
  (frob unsigned-* "unsigned *" 40 unsigned-num unsigned-reg)
  (frob signed-* "unsigned *" 41 signed-num signed-reg)
  (frob fixnum-* "fixnum *" 30 tagged-num any-reg))



;;;; Division.


(define-assembly-routine (positive-fixnum-truncate
			  (:note "unsigned fixnum truncate")
			  (:cost 45)
			  (:translate truncate)
			  (:policy :fast-safe)
			  (:arg-types positive-fixnum positive-fixnum)
			  (:result-types positive-fixnum positive-fixnum))
			 ((:arg dividend any-reg nl0-offset)
			  (:arg divisor any-reg nl1-offset)

			  (:res quo any-reg nl2-offset)
			  (:res rem any-reg nl0-offset))
  (assert (location= rem dividend))
  (let ((error (generate-error-code nil division-by-zero-error
				    dividend divisor)))
    (inst cmpwi divisor 0)
    (inst beq error))
    (inst divwu quo dividend divisor)
    (inst mullw divisor quo divisor)
    (inst sub rem dividend divisor)
    (inst slwi quo quo 2))



(define-assembly-routine (fixnum-truncate
			  (:note "fixnum truncate")
			  (:cost 50)
			  (:policy :fast-safe)
			  (:translate truncate)
			  (:arg-types tagged-num tagged-num)
			  (:result-types tagged-num tagged-num))
			 ((:arg dividend any-reg nl0-offset)
			  (:arg divisor any-reg nl1-offset)

			  (:res quo any-reg nl2-offset)
			  (:res rem any-reg nl0-offset))
  
  (assert (location= rem dividend))
  (let ((error (generate-error-code nil division-by-zero-error
				    dividend divisor)))
    (inst cmpwi divisor 0)
    (inst beq error))

    (inst divw quo dividend divisor)
    (inst mullw divisor quo divisor)
    (inst subf rem divisor dividend)
    (inst slwi quo quo 2))


(define-assembly-routine (signed-truncate
			  (:note "(signed-byte 32) truncate")
			  (:cost 60)
			  (:policy :fast-safe)
			  (:translate truncate)
			  (:arg-types signed-num signed-num)
			  (:result-types signed-num signed-num))

			 ((:arg dividend signed-reg nl0-offset)
			  (:arg divisor signed-reg nl1-offset)

			  (:res quo signed-reg nl2-offset)
			  (:res rem signed-reg nl0-offset))
  
  (let ((error (generate-error-code nil division-by-zero-error
				    dividend divisor)))
    (inst cmpwi divisor 0)
    (inst beq error))

    (inst divw quo dividend divisor)
    (inst mullw divisor quo divisor)
    (inst subf rem divisor dividend))


;;;; Comparison

(macrolet
    ((define-cond-assem-rtn (name translate static-fn cmp)
       `(define-assembly-routine 
          (,name
           (:cost 10)
           (:return-style :full-call)
           (:policy :safe)
           (:translate ,translate)
           (:save-p t))
          ((:arg x (descriptor-reg any-reg) a0-offset)
           (:arg y (descriptor-reg any-reg) a1-offset)
           
           (:res res descriptor-reg a0-offset)
           
311
	   (:temp lip interior-reg lip-offset)
312 313 314 315 316 317 318 319 320
           (:temp nargs any-reg nargs-offset)
           (:temp ocfp any-reg ocfp-offset))
                          
          (inst or nargs x y)
          (inst andi. nargs nargs 3)
          (inst cmpw :cr1 x y)
          (inst beq DO-COMPARE)
	  
	  DO-STATIC-FN
321
	  (inst lwz code-tn null-tn (static-function-offset ',static-fn))
322
	  (inst li nargs (fixnumize 2))
323 324
	  (inst mr ocfp cfp-tn)
	  (inst mr cfp-tn csp-tn)
325
	  (inst j code-tn
326
	        (- (* function-code-offset word-bytes) function-pointer-type)) 
327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351
	  
	  DO-COMPARE
	  (load-symbol res t)
	  (inst b? :cr1 ,cmp done)
	  (inst mr res null-tn)
	  DONE)))

  (define-cond-assem-rtn generic-< < two-arg-< :lt)
  (define-cond-assem-rtn generic-<= <= two-arg-<= :le)
  (define-cond-assem-rtn generic-> > two-arg-> :gt)
  (define-cond-assem-rtn generic->= >= two-arg->= :ge))


(define-assembly-routine (generic-eql
			  (:cost 10)
			  (:return-style :full-call)
			  (:policy :safe)
			  (:translate eql)
			  (:save-p t))
			 ((:arg x (descriptor-reg any-reg) a0-offset)
			  (:arg y (descriptor-reg any-reg) a1-offset)
			  
			  (:res res descriptor-reg a0-offset)

			  (:temp lra descriptor-reg lra-offset)
352
			  (:temp lip interior-reg lip-offset)
353 354 355 356 357 358 359 360 361 362 363
			  (:temp nargs any-reg nargs-offset)
			  (:temp ocfp any-reg ocfp-offset))
  (inst cmpw :cr1 x y)
  (inst andi. nargs x 3)
  (inst beq :cr1 RETURN-T)
  (inst beq RETURN-NIL)                 ; x was fixnum, not eq y
  (inst andi. nargs y 3)
  (inst bne DO-STATIC-FN)

  RETURN-NIL
  (inst mr res null-tn)
364
  (lisp-return lra lip :offset 2)
365 366

  DO-STATIC-FN
367
  (inst lwz code-tn null-tn (static-function-offset 'eql))
368
  (inst li nargs (fixnumize 2))
369 370
  (inst mr ocfp cfp-tn)
  (inst mr cfp-tn csp-tn)
371
  (inst j code-tn (- (* function-code-offset word-bytes) function-pointer-type))
372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388

  RETURN-T
  (load-symbol res t))

(define-assembly-routine 
  (generic-=
   (:cost 10)
   (:return-style :full-call)
   (:policy :safe)
   (:translate =)
   (:save-p t))
  ((:arg x (descriptor-reg any-reg) a0-offset)
   (:arg y (descriptor-reg any-reg) a1-offset)
   
   (:res res descriptor-reg a0-offset)
   
   (:temp lra descriptor-reg lra-offset)
389
   (:temp lip interior-reg lip-offset)
390 391 392 393 394 395 396 397 398 399
   (:temp nargs any-reg nargs-offset)
   (:temp ocfp any-reg ocfp-offset))

  (inst or nargs x y)
  (inst andi. nargs nargs 3)
  (inst cmpw :cr1 x y)
  (inst bne DO-STATIC-FN)
  (inst beq :cr1 RETURN-T)

  (inst mr res null-tn)
400
  (lisp-return lra lip :offset 2)
401 402

  DO-STATIC-FN
403
  (inst lwz code-tn null-tn (static-function-offset 'two-arg-=))
404
  (inst li nargs (fixnumize 2))
405 406
  (inst mr ocfp cfp-tn)
  (inst mr cfp-tn csp-tn)
407 408
  (inst j code-tn
	(- (* function-code-offset word-bytes) function-pointer-type))
409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424

  RETURN-T
  (load-symbol res t))

(define-assembly-routine (generic-/=
			  (:cost 10)
			  (:return-style :full-call)
			  (:policy :safe)
			  (:translate /=)
			  (:save-p t))
			 ((:arg x (descriptor-reg any-reg) a0-offset)
			  (:arg y (descriptor-reg any-reg) a1-offset)

			  (:res res descriptor-reg a0-offset)

			  (:temp lra descriptor-reg lra-offset)
425
			  (:temp lip interior-reg lip-offset)
426 427 428 429 430 431 432 433 434
			  (:temp nargs any-reg nargs-offset)
			  (:temp ocfp any-reg ocfp-offset))
  (inst or nargs x y)
  (inst andi. nargs nargs 3)
  (inst cmpw :cr1 x y)
  (inst bne DO-STATIC-FN)
  (inst beq :cr1 RETURN-NIL)

  (load-symbol res t)
435
  (lisp-return lra lip :offset 2)
436 437

  DO-STATIC-FN
438
  (inst lwz code-tn null-tn (static-function-offset 'two-arg-=))
439
  (inst li nargs (fixnumize 2))
440 441
  (inst mr ocfp cfp-tn)
  (inst mr cfp-tn csp-tn)
442 443
  (inst j code-tn
	(- (* function-code-offset word-bytes) function-pointer-type))
444 445 446

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