src/assembly/hppa/arith.lisp

   1 (in-package "SB!VM")
   2
   3 \f
   4 ;;;; Multiplication and Division helping routines.
   5
   6 ;;; ?? FIXME: Where are generic-* and generic-/?
   7 #+sb-assembling
   8 (define-assembly-routine
   9     multiply
  10     ((:arg x (signed-reg) nl0-offset)
  11      (:arg y (signed-reg) nl1-offset)
  12
  13      (:res res (signed-reg) nl2-offset)
  14
  15      (:temp tmp (unsigned-reg) nl3-offset)
  16      (:temp sign (unsigned-reg) nl4-offset))
  17
  18   ;; Determine the sign of the result.
  19   (inst extrs x 0 1 sign :=)
  20   (inst sub zero-tn x x)
  21   (inst extrs y 0 1 tmp :=)
  22   (inst sub zero-tn y y)
  23   (inst xor sign tmp sign)
  24
  25   ;; Make sure X is less then Y.
  26   (inst comclr x y tmp :<<)
  27   (inst xor x y tmp)
  28   (inst xor x tmp x)
  29   (inst xor y tmp y)
  30   ;; Blow out of here if the result is zero.
  31   (inst comb := x zero-tn done)
  32   (inst li 0 res)
  33
  34   LOOP
  35   (inst extru x 31 1 zero-tn :ev)
  36   (inst add y res res)
  37   (inst extru x 30 1 zero-tn :ev)
  38   (inst sh1add y res res)
  39   (inst extru x 29 1 zero-tn :ev)
  40   (inst sh2add y res res)
  41   (inst extru x 28 1 zero-tn :ev)
  42   (inst sh3add y res res)
  43
  44   (inst srl x 4 x)
  45   (inst comb :<> x zero-tn loop)
  46   (inst sll y 4 y)
  47
  48   DONE
  49   (inst xor res sign res)
  50   (inst add res sign res))
  51
  52 (define-assembly-routine
  53     (truncate)
  54     ((:arg dividend signed-reg nl0-offset)
  55      (:arg divisor signed-reg nl1-offset)
  56
  57      (:res quo signed-reg nl2-offset)
  58      (:res rem signed-reg nl3-offset))
  59   ;; Move abs(divident) into quo.
  60   (inst move dividend quo :>=)
  61   (inst sub zero-tn quo quo)
  62   ;; Do one divive-step with -divisor to prime V  (use rem as a temp)
  63   (inst sub zero-tn divisor rem)
  64   (inst ds zero-tn rem zero-tn)
  65   ;; Shift the divident/quotient one bit, setting the carry flag.
  66   (inst add quo quo quo)
  67   ;; The first real divive-step.
  68   (inst ds zero-tn divisor rem)
  69   (inst addc quo quo quo)
  70   ;; And 31 more of them.
  71   (dotimes (i 31)
  72     (inst ds rem divisor rem)
  73     (inst addc quo quo quo))
  74   ;; If the remainder is negative, we need to add the absolute value of the
  75   ;; divisor.
  76   (inst comb :>= rem zero-tn remainder-positive)
  77   (inst comclr divisor zero-tn zero-tn :<)
  78   (inst add rem divisor rem :tr)
  79   (inst sub rem divisor rem)
  80   REMAINDER-POSITIVE
  81   ;; Now we have to fix the signs of quo and rem.
  82   (inst xor divisor dividend zero-tn :>=)
  83   (inst sub zero-tn quo quo)
  84   (inst move dividend zero-tn :>=)
  85   (inst sub zero-tn rem rem))
  86
  87 \f
  88 ;;;; Generic arithmetic.
  89
  90 (define-assembly-routine (generic-+
  91                           (:cost 10)
  92                           (:return-style :full-call)
  93                           (:translate +)
  94                           (:policy :safe)
  95                           (:save-p t))
  96                          ((:arg x (descriptor-reg any-reg) a0-offset)
  97                           (:arg y (descriptor-reg any-reg) a1-offset)
  98                           (:res res (descriptor-reg any-reg) a0-offset)
  99                           (:temp temp non-descriptor-reg nl0-offset)
 100                           (:temp temp1 non-descriptor-reg nl1-offset)
 101                           (:temp temp2 non-descriptor-reg nl2-offset)
 102                           (:temp lra descriptor-reg lra-offset)
 103                           (:temp lip interior-reg lip-offset)
 104                           (:temp nargs any-reg nargs-offset)
 105                           (:temp ocfp any-reg ocfp-offset))
 106   ;; If either arg is not fixnum, use two-arg-+ to summarize
 107   (inst or x y temp)
 108   (inst extru temp 31 3 zero-tn :=)
 109   (inst b DO-STATIC-FUN :nullify t)
 110   ;; check for overflow
 111   (inst add x y temp)
 112   (inst xor temp x temp1)
 113   (inst xor temp y temp2)
 114   (inst and temp1 temp2 temp1)
 115   (inst bc :< nil temp1 zero-tn DO-OVERFLOW)
 116   (inst move temp res)
 117   (lisp-return lra :offset 1)
 118
 119   DO-OVERFLOW
 120   ;; We did overflow, so do the bignum version
 121   (inst sra x n-fixnum-tag-bits temp1)
 122   (inst sra y n-fixnum-tag-bits temp2)
 123   (inst add temp1 temp2 temp)
 124   (with-fixed-allocation (res nil temp2 bignum-widetag
 125                           (1+ bignum-digits-offset) nil)
 126     (storew temp res bignum-digits-offset other-pointer-lowtag))
 127   (lisp-return lra :offset 1)
 128
 129   DO-STATIC-FUN
 130   (inst ldw (static-fun-offset 'two-arg-+) null-tn lip)
 131   (inst li (fixnumize 2) nargs)
 132   (move cfp-tn ocfp)
 133   (inst bv lip)
 134   (move csp-tn cfp-tn t))
 135
 136 (define-assembly-routine (generic--
 137                           (:cost 10)
 138                           (:return-style :full-call)
 139                           (:translate -)
 140                           (:policy :safe)
 141                           (:save-p t))
 142                          ((:arg x (descriptor-reg any-reg) a0-offset)
 143                           (:arg y (descriptor-reg any-reg) a1-offset)
 144
 145                           (:res res (descriptor-reg any-reg) a0-offset)
 146
 147                           (:temp temp non-descriptor-reg nl0-offset)
 148                           (:temp temp1 non-descriptor-reg nl1-offset)
 149                           (:temp temp2 non-descriptor-reg nl2-offset)
 150                           (:temp lra descriptor-reg lra-offset)
 151                           (:temp lip interior-reg lip-offset)
 152                           (:temp nargs any-reg nargs-offset)
 153                           (:temp ocfp any-reg ocfp-offset))
 154   ;; If either arg is not fixnum, use two-arg-+ to summarize
 155   (inst or x y temp)
 156   (inst extru temp 31 3 zero-tn :=)
 157   (inst b DO-STATIC-FUN :nullify t)
 158   (inst sub x y temp)
 159   ;; check for overflow
 160   (inst xor x y temp1)
 161   (inst xor x temp temp2)
 162   (inst and temp2 temp1 temp1)
 163   (inst bc :< nil temp1 zero-tn DO-OVERFLOW)
 164   (inst move temp res)
 165   (lisp-return lra :offset 1)
 166
 167   DO-OVERFLOW
 168   ;; We did overflow, so do the bignum version
 169   (inst sra x n-fixnum-tag-bits temp1)
 170   (inst sra y n-fixnum-tag-bits temp2)
 171   (inst sub temp1 temp2 temp)
 172   (with-fixed-allocation (res nil temp2 bignum-widetag
 173                           (1+ bignum-digits-offset) nil)
 174     (storew temp res bignum-digits-offset other-pointer-lowtag))
 175   (lisp-return lra :offset 1)
 176
 177   DO-STATIC-FUN
 178   (inst ldw (static-fun-offset 'two-arg--) null-tn lip)
 179   (inst li (fixnumize 2) nargs)
 180   (move cfp-tn ocfp)
 181   (inst bv lip)
 182   (move csp-tn cfp-tn t))
 183
 184 \f
 185 ;;;; Comparison routines.
 186
 187 (macrolet
 188     ((define-cond-assem-rtn (name translate static-fn cond)
 189        `(define-assembly-routine (,name
 190                                   (:cost 10)
 191                                   (:return-style :full-call)
 192                                   (:policy :safe)
 193                                   (:translate ,translate)
 194                                   (:save-p t))
 195                                  ((:arg x (descriptor-reg any-reg) a0-offset)
 196                                   (:arg y (descriptor-reg any-reg) a1-offset)
 197
 198                                   (:res res descriptor-reg a0-offset)
 199
 200                                   (:temp lip interior-reg lip-offset)
 201                                   (:temp lra descriptor-reg lra-offset)
 202                                   (:temp nargs any-reg nargs-offset)
 203                                   (:temp ocfp any-reg ocfp-offset))
 204           (inst extru x 31 2 zero-tn :=)
 205           (inst b do-static-fn :nullify t)
 206           (inst extru y 31 2 zero-tn :=)
 207           (inst b do-static-fn :nullify t)
 208
 209           (inst comclr x y zero-tn ,cond)
 210           (inst move null-tn res :tr)
 211           (load-symbol res t)
 212           (lisp-return lra :offset 1)
 213
 214           DO-STATIC-FN
 215           (inst ldw (static-fun-offset ',static-fn) null-tn lip)
 216           (inst li (fixnumize 2) nargs)
 217           (inst move cfp-tn ocfp)
 218           (inst bv lip)
 219           (inst move csp-tn cfp-tn))))
 220
 221   (define-cond-assem-rtn generic-< < two-arg-< :<)
 222   (define-cond-assem-rtn generic-> > two-arg-> :>))
 223
 224
 225 (define-assembly-routine
 226     (generic-eql
 227      (:cost 10)
 228      (:return-style :full-call)
 229      (:policy :safe)
 230      (:translate eql)
 231      (:save-p t))
 232     ((:arg x (descriptor-reg any-reg) a0-offset)
 233      (:arg y (descriptor-reg any-reg) a1-offset)
 234
 235      (:res res descriptor-reg a0-offset)
 236
 237      (:temp lip interior-reg lip-offset)
 238      (:temp lra descriptor-reg lra-offset)
 239      (:temp nargs any-reg nargs-offset)
 240      (:temp ocfp any-reg ocfp-offset))
 241
 242   (inst comb := x y return-t :nullify t)
 243   (inst extru x 31 2 zero-tn :<>)
 244   (inst b return-nil :nullify t)
 245   (inst extru y 31 2 zero-tn :=)
 246   (inst b do-static-fn :nullify t)
 247
 248   RETURN-NIL
 249   (inst move null-tn res)
 250   (lisp-return lra :offset 1)
 251
 252   DO-STATIC-FN
 253   (inst ldw (static-fun-offset 'eql) null-tn lip)
 254   (inst li (fixnumize 2) nargs)
 255   (inst move cfp-tn ocfp)
 256   (inst bv lip)
 257   (inst move csp-tn cfp-tn)
 258
 259   RETURN-T
 260   (load-symbol res t))
 261
 262 (define-assembly-routine
 263     (generic-=
 264      (:cost 10)
 265      (:return-style :full-call)
 266      (:policy :safe)
 267      (:translate =)
 268      (:save-p t))
 269     ((:arg x (descriptor-reg any-reg) a0-offset)
 270      (:arg y (descriptor-reg any-reg) a1-offset)
 271
 272      (:res res descriptor-reg a0-offset)
 273
 274      (:temp lip interior-reg lip-offset)
 275      (:temp lra descriptor-reg lra-offset)
 276      (:temp nargs any-reg nargs-offset)
 277      (:temp ocfp any-reg ocfp-offset))
 278
 279   (inst comb := x y return-t :nullify t)
 280   (inst extru x 31 2 zero-tn :=)
 281   (inst b do-static-fn :nullify t)
 282   (inst extru y 31 2 zero-tn :=)
 283   (inst b do-static-fn :nullify t)
 284
 285   (inst move null-tn res)
 286   (lisp-return lra :offset 1)
 287
 288   DO-STATIC-FN
 289   (inst ldw (static-fun-offset 'two-arg-=) null-tn lip)
 290   (inst li (fixnumize 2) nargs)
 291   (inst move cfp-tn ocfp)
 292   (inst bv lip)
 293   (inst move csp-tn cfp-tn)
 294
 295   RETURN-T
 296   (load-symbol res t))