0.pre7.127:

[sbcl.git] / src / compiler / alpha / arith.lisp

diff --git a/src/compiler/alpha/arith.lisp b/src/compiler/alpha/arith.lisp
index 82951bb..9c96308 100644 (file)
--- a/src/compiler/alpha/arith.lisp
+++ b/src/compiler/alpha/arith.lisp
@@ -1,27 +1,17 @@
-;;; -*- Package: ALPHA; Log: C.Log -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the CMU Common Lisp project at
-;;; Carnegie Mellon University, and has been placed in the public domain.
-;;;
+;;;; the VM definition arithmetic VOPs for the Alpha

 
 

-;;;
-;;; **********************************************************************
-;;;
-;;; $Header$
-;;;
-;;;    This file contains the VM definition arithmetic VOPs for the MIPS.
-;;;
-;;; Written by Rob MacLachlan
-;;; Converted by Sean Hallgren
-;;; 
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.

 
 (in-package "SB!VM")
 
 (in-package "SB!VM")

-
-
-

 \f
 \f

-;;;; Unary operations.
+;;;; unary operations

 
 (define-vop (fixnum-unop)
   (:args (x :scs (any-reg)))
 
 (define-vop (fixnum-unop)
   (:args (x :scs (any-reg)))

@@ -58,10 +48,8 @@
   (:translate lognot)
   (:generator 1
     (inst not x res)))
   (:translate lognot)
   (:generator 1
     (inst not x res)))

-
-

 \f
 \f

-;;;; Binary fixnum operations.
+;;;; binary fixnum operations

 
 ;;; Assume that any constant operand is the second arg...
 
 
 ;;; Assume that any constant operand is the second arg...
 

@@ -165,10 +153,8 @@
 (define-binop lognor 1 3 ornot (unsigned-byte 6) (unsigned-byte 8))
 (define-binop logand 1 3 and (unsigned-byte 6) (unsigned-byte 8))
 (define-binop logxor 1 3 xor (unsigned-byte 6) (unsigned-byte 8))
 (define-binop lognor 1 3 ornot (unsigned-byte 6) (unsigned-byte 8))
 (define-binop logand 1 3 and (unsigned-byte 6) (unsigned-byte 8))
 (define-binop logxor 1 3 xor (unsigned-byte 6) (unsigned-byte 8))

-
-
-;;; Shifting
-
+\f
+;;;; shifting

 
 (define-vop (fast-ash)
   (:note "inline ASH")
 
 (define-vop (fast-ash)
   (:note "inline ASH")

@@ -278,9 +264,8 @@
     (inst and num mask num)
     (inst and temp mask temp)
     (inst addq num temp res)))
     (inst and num mask num)
     (inst and temp mask temp)
     (inst addq num temp res)))

-
-
-;;; Multiply
+\f
+;;;; multiplying

 
 (define-vop (fast-*/fixnum=>fixnum fast-fixnum-binop)
   (:temporary (:scs (non-descriptor-reg)) temp)
 
 (define-vop (fast-*/fixnum=>fixnum fast-fixnum-binop)
   (:temporary (:scs (non-descriptor-reg)) temp)

@@ -298,10 +283,8 @@
   (:translate *)
   (:generator 3
     (inst mulq x y r)))
   (:translate *)
   (:generator 3
     (inst mulq x y r)))

-
-

 \f
 \f

-;;;; Binary conditional VOPs:
+;;;; binary conditional VOPs

 
 (define-vop (fast-conditional)
   (:conditional)
 
 (define-vop (fast-conditional)
   (:conditional)

@@ -355,20 +338,20 @@
 
 (defmacro define-conditional-vop (translate &rest generator)
   `(progn
 
 (defmacro define-conditional-vop (translate &rest generator)
   `(progn

-     ,@(mapcar #'(lambda (suffix cost signed)
-                  (unless (and (member suffix '(/fixnum -c/fixnum))
-                               (eq translate 'eql))
-                    `(define-vop (,(intern (format nil "~:@(FAST-IF-~A~A~)"
-                                                   translate suffix))
-                                  ,(intern
-                                    (format nil "~:@(FAST-CONDITIONAL~A~)"
-                                            suffix)))
-                       (:translate ,translate)
-                       (:generator ,cost
-                         (let* ((signed ,signed)
-                                (-c/fixnum ,(eq suffix '-c/fixnum))
-                                (y (if -c/fixnum (fixnumize y) y)))
-                           ,@generator)))))
+     ,@(mapcar (lambda (suffix cost signed)
+                (unless (and (member suffix '(/fixnum -c/fixnum))
+                             (eq translate 'eql))
+                  `(define-vop (,(intern (format nil "~:@(FAST-IF-~A~A~)"
+                                                 translate suffix))
+                                ,(intern
+                                  (format nil "~:@(FAST-CONDITIONAL~A~)"
+                                          suffix)))
+                     (:translate ,translate)
+                     (:generator ,cost
+                                 (let* ((signed ,signed)
+                                        (-c/fixnum ,(eq suffix '-c/fixnum))
+                                        (y (if -c/fixnum (fixnumize y) y)))
+                                   ,@generator)))))

               '(/fixnum -c/fixnum /signed -c/signed /unsigned -c/unsigned)
               '(3 2 5 4 5 4)
               '(t t t t nil nil))))
               '(/fixnum -c/fixnum /signed -c/signed /unsigned -c/unsigned)
               '(3 2 5 4 5 4)
               '(t t t t nil nil))))

@@ -407,8 +390,8 @@
             (inst beq temp target)
             (inst bne temp target)))))
 
             (inst beq temp target)
             (inst bne temp target)))))
 

-;;; EQL/FIXNUM is funny because the first arg can be of any type, not just a
-;;; known fixnum.
+;;; EQL/FIXNUM is funny because the first arg can be of any type, not
+;;; just a known fixnum.

 
 (define-conditional-vop eql
   (declare (ignore signed))
 
 (define-conditional-vop eql
   (declare (ignore signed))

@@ -420,12 +403,11 @@
       (inst beq temp target)
       (inst bne temp target)))
 
       (inst beq temp target)
       (inst bne temp target)))
 

-;;; These versions specify a fixnum restriction on their first arg.  We have
-;;; also generic-eql/fixnum VOPs which are the same, but have no restriction on
-;;; the first arg and a higher cost.  The reason for doing this is to prevent
-;;; fixnum specific operations from being used on word integers, spuriously
-;;; consing the argument.
-;;;
+;;; These versions specify a fixnum restriction on their first arg. We
+;;; have also generic-eql/fixnum VOPs which are the same, but have no
+;;; restriction on the first arg and a higher cost. The reason for
+;;; doing this is to prevent fixnum specific operations from being
+;;; used on word integers, spuriously consing the argument.

 (define-vop (fast-eql/fixnum fast-conditional)
   (:args (x :scs (any-reg))
         (y :scs (any-reg)))
 (define-vop (fast-eql/fixnum fast-conditional)
   (:args (x :scs (any-reg))
         (y :scs (any-reg)))

@@ -575,10 +557,8 @@
   (:generator 1
     (inst and amount #x1f temp)
     (inst sll num temp r)))
   (:generator 1
     (inst and amount #x1f temp)
     (inst sll num temp r)))

-
-

 \f
 \f

-;;;; Bignum stuff.
+;;;; bignum stuff

 
 (define-vop (bignum-length get-header-data)
   (:translate sb!bignum::%bignum-length)
 
 (define-vop (bignum-length get-header-data)
   (:translate sb!bignum::%bignum-length)

@@ -588,10 +568,10 @@
   (:translate sb!bignum::%bignum-set-length)
   (:policy :fast-safe))
 
   (:translate sb!bignum::%bignum-set-length)
   (:policy :fast-safe))
 

-(define-full-reffer bignum-ref * bignum-digits-offset other-pointer-type
+(define-full-reffer bignum-ref * bignum-digits-offset other-pointer-lowtag

   (unsigned-reg) unsigned-num sb!bignum::%bignum-ref)
 
   (unsigned-reg) unsigned-num sb!bignum::%bignum-ref)
 

-(define-full-setter bignum-set * bignum-digits-offset other-pointer-type
+(define-full-setter bignum-set * bignum-digits-offset other-pointer-lowtag

   (unsigned-reg) unsigned-num sb!bignum::%bignum-set #+gengc nil)
 
 (define-vop (digit-0-or-plus)
   (unsigned-reg) unsigned-num sb!bignum::%bignum-set #+gengc nil)
 
 (define-vop (digit-0-or-plus)

@@ -781,27 +761,26 @@
   (:translate sb!bignum::%ashl)
   (:generator 1
     (inst sll digit count result)))
   (:translate sb!bignum::%ashl)
   (:generator 1
     (inst sll digit count result)))

-

 \f
 \f

-;;;; Static functions.
+;;;; static functions

 
 

-(define-static-function two-arg-gcd (x y) :translate gcd)
-(define-static-function two-arg-lcm (x y) :translate lcm)
+(define-static-fun two-arg-gcd (x y) :translate gcd)
+(define-static-fun two-arg-lcm (x y) :translate lcm)

 
 

-(define-static-function two-arg-+ (x y) :translate +)
-(define-static-function two-arg-- (x y) :translate -)
-(define-static-function two-arg-* (x y) :translate *)
-(define-static-function two-arg-/ (x y) :translate /)
+(define-static-fun two-arg-+ (x y) :translate +)
+(define-static-fun two-arg-- (x y) :translate -)
+(define-static-fun two-arg-* (x y) :translate *)
+(define-static-fun two-arg-/ (x y) :translate /)

 
 

-(define-static-function two-arg-< (x y) :translate <)
-(define-static-function two-arg-<= (x y) :translate <=)
-(define-static-function two-arg-> (x y) :translate >)
-(define-static-function two-arg->= (x y) :translate >=)
-(define-static-function two-arg-= (x y) :translate =)
-(define-static-function two-arg-/= (x y) :translate /=)
+(define-static-fun two-arg-< (x y) :translate <)
+(define-static-fun two-arg-<= (x y) :translate <=)
+(define-static-fun two-arg-> (x y) :translate >)
+(define-static-fun two-arg->= (x y) :translate >=)
+(define-static-fun two-arg-= (x y) :translate =)
+(define-static-fun two-arg-/= (x y) :translate /=)

 
 

-(define-static-function %negate (x) :translate %negate)
+(define-static-fun %negate (x) :translate %negate)

 
 

-(define-static-function two-arg-and (x y) :translate logand)
-(define-static-function two-arg-ior (x y) :translate logior)
-(define-static-function two-arg-xor (x y) :translate logxor)
+(define-static-fun two-arg-and (x y) :translate logand)
+(define-static-fun two-arg-ior (x y) :translate logior)
+(define-static-fun two-arg-xor (x y) :translate logxor)