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
  53 #+sb-assembling
  54 (define-assembly-routine
  55     (truncate)
  56     ((:arg dividend signed-reg nl0-offset)
  57      (:arg divisor signed-reg nl1-offset)
  58
  59      (:res quo signed-reg nl2-offset)
  60      (:res rem signed-reg nl3-offset))
  61
  62   ;; Move abs(divident) into quo.
  63   (inst move dividend quo :>=)
  64   (inst sub zero-tn quo quo)
  65   ;; Do one divive-step with -divisor to prime V  (use rem as a temp)
  66   (inst sub zero-tn divisor rem)
  67   (inst ds zero-tn rem zero-tn)
  68   ;; Shift the divident/quotient one bit, setting the carry flag.
  69   (inst add quo quo quo)
  70   ;; The first real divive-step.
  71   (inst ds zero-tn divisor rem)
  72   (inst addc quo quo quo)
  73   ;; And 31 more of them.
  74   (dotimes (i 31)
  75     (inst ds rem divisor rem)
  76     (inst addc quo quo quo))
  77   ;; If the remainder is negative, we need to add the absolute value of the
  78   ;; divisor.
  79   (inst comb :>= rem zero-tn remainder-positive)
  80   (inst comclr divisor zero-tn zero-tn :<)
  81   (inst add rem divisor rem :tr)
  82   (inst sub rem divisor rem)
  83   REMAINDER-POSITIVE
  84   ;; Now we have to fix the signs of quo and rem.
  85   (inst xor divisor dividend zero-tn :>=)
  86   (inst sub zero-tn quo quo)
  87   (inst move dividend zero-tn :>=)
  88   (inst sub zero-tn rem rem))
  89
  90
  91 \f
  92 ;;;; Generic arithmetic.
  93
  94 (define-assembly-routine (generic-+
  95                           (:cost 10)
  96                           (:return-style :full-call)
  97                           (:translate +)
  98                           (:policy :safe)
  99                           (:save-p t))
 100                          ((:arg x (descriptor-reg any-reg) a0-offset)
 101                           (:arg y (descriptor-reg any-reg) a1-offset)
 102
 103                           (:res res (descriptor-reg any-reg) a0-offset)
 104
 105                           (:temp lip interior-reg lip-offset)
 106                           (:temp lra descriptor-reg lra-offset)
 107                           (:temp nargs any-reg nargs-offset)
 108                           (:temp ocfp any-reg ocfp-offset))
 109   (inst extru x 31 2 zero-tn :=)
 110   (inst b do-static-fun :nullify t)
 111   (inst extru y 31 2 zero-tn :=)
 112   (inst b do-static-fun :nullify t)
 113   (inst addo x y res)
 114   (lisp-return lra :offset 1)
 115
 116   DO-STATIC-FUN
 117   (inst ldw (static-fun-offset 'two-arg-+) null-tn lip)
 118   (inst li (fixnumize 2) nargs)
 119   (inst move cfp-tn ocfp)
 120   (inst bv lip)
 121   (inst move csp-tn cfp-tn))
 122
 123 (define-assembly-routine (generic--
 124                           (:cost 10)
 125                           (:return-style :full-call)
 126                           (:translate -)
 127                           (:policy :safe)
 128                           (:save-p t))
 129                          ((:arg x (descriptor-reg any-reg) a0-offset)
 130                           (:arg y (descriptor-reg any-reg) a1-offset)
 131
 132                           (:res res (descriptor-reg any-reg) a0-offset)
 133
 134                           (:temp lip interior-reg lip-offset)
 135                           (:temp lra descriptor-reg lra-offset)
 136                           (:temp nargs any-reg nargs-offset)
 137                           (:temp ocfp any-reg ocfp-offset))
 138   (inst extru x 31 2 zero-tn :=)
 139   (inst b do-static-fun :nullify t)
 140   (inst extru y 31 2 zero-tn :=)
 141   (inst b do-static-fun :nullify t)
 142   (inst subo x y res)
 143   (lisp-return lra :offset 1)
 144
 145   DO-STATIC-FUN
 146   (inst ldw (static-fun-offset 'two-arg--) null-tn lip)
 147   (inst li (fixnumize 2) nargs)
 148   (inst move cfp-tn ocfp)
 149   (inst bv lip)
 150   (inst move csp-tn cfp-tn))
 151
 152
 153 \f
 154 ;;;; Comparison routines.
 155
 156 (macrolet
 157     ((define-cond-assem-rtn (name translate static-fn cond)
 158        `(define-assembly-routine (,name
 159                                   (:cost 10)
 160                                   (:return-style :full-call)
 161                                   (:policy :safe)
 162                                   (:translate ,translate)
 163                                   (:save-p t))
 164                                  ((:arg x (descriptor-reg any-reg) a0-offset)
 165                                   (:arg y (descriptor-reg any-reg) a1-offset)
 166
 167                                   (:res res descriptor-reg a0-offset)
 168
 169                                   (:temp lip interior-reg lip-offset)
 170                                   (:temp lra descriptor-reg lra-offset)
 171                                   (:temp nargs any-reg nargs-offset)
 172                                   (:temp ocfp any-reg ocfp-offset))
 173           (inst extru x 31 2 zero-tn :=)
 174           (inst b do-static-fn :nullify t)
 175           (inst extru y 31 2 zero-tn :=)
 176           (inst b do-static-fn :nullify t)
 177
 178           (inst comclr x y zero-tn ,cond)
 179           (inst move null-tn res :tr)
 180           (load-symbol res t)
 181           (lisp-return lra :offset 1)
 182
 183           DO-STATIC-FN
 184           (inst ldw (static-fun-offset ',static-fn) null-tn lip)
 185           (inst li (fixnumize 2) nargs)
 186           (inst move cfp-tn ocfp)
 187           (inst bv lip)
 188           (inst move csp-tn cfp-tn))))
 189
 190   (define-cond-assem-rtn generic-< < two-arg-< :<)
 191   (define-cond-assem-rtn generic-> > two-arg-> :>))
 192
 193
 194 (define-assembly-routine
 195     (generic-eql
 196      (:cost 10)
 197      (:return-style :full-call)
 198      (:policy :safe)
 199      (:translate eql)
 200      (:save-p t))
 201     ((:arg x (descriptor-reg any-reg) a0-offset)
 202      (:arg y (descriptor-reg any-reg) a1-offset)
 203
 204      (:res res descriptor-reg a0-offset)
 205
 206      (:temp lip interior-reg lip-offset)
 207      (:temp lra descriptor-reg lra-offset)
 208      (:temp nargs any-reg nargs-offset)
 209      (:temp ocfp any-reg ocfp-offset))
 210
 211   (inst comb := x y return-t :nullify t)
 212   (inst extru x 31 2 zero-tn :<>)
 213   (inst b return-nil :nullify t)
 214   (inst extru y 31 2 zero-tn :=)
 215   (inst b do-static-fn :nullify t)
 216
 217   RETURN-NIL
 218   (inst move null-tn res)
 219   (lisp-return lra :offset 1)
 220
 221   DO-STATIC-FN
 222   (inst ldw (static-fun-offset 'eql) null-tn lip)
 223   (inst li (fixnumize 2) nargs)
 224   (inst move cfp-tn ocfp)
 225   (inst bv lip)
 226   (inst move csp-tn cfp-tn)
 227
 228   RETURN-T
 229   (load-symbol res t))
 230
 231 (define-assembly-routine
 232     (generic-=
 233      (:cost 10)
 234      (:return-style :full-call)
 235      (:policy :safe)
 236      (:translate =)
 237      (:save-p t))
 238     ((:arg x (descriptor-reg any-reg) a0-offset)
 239      (:arg y (descriptor-reg any-reg) a1-offset)
 240
 241      (:res res descriptor-reg a0-offset)
 242
 243      (:temp lip interior-reg lip-offset)
 244      (:temp lra descriptor-reg lra-offset)
 245      (:temp nargs any-reg nargs-offset)
 246      (:temp ocfp any-reg ocfp-offset))
 247
 248   (inst comb := x y return-t :nullify t)
 249   (inst extru x 31 2 zero-tn :=)
 250   (inst b do-static-fn :nullify t)
 251   (inst extru y 31 2 zero-tn :=)
 252   (inst b do-static-fn :nullify t)
 253
 254   (inst move null-tn res)
 255   (lisp-return lra :offset 1)
 256
 257   DO-STATIC-FN
 258   (inst ldw (static-fun-offset 'two-arg-=) null-tn lip)
 259   (inst li (fixnumize 2) nargs)
 260   (inst move cfp-tn ocfp)
 261   (inst bv lip)
 262   (inst move csp-tn cfp-tn)
 263
 264   RETURN-T
 265   (load-symbol res t))