;;; -*- Package: x86 -*- ;;; ;;; ********************************************************************** ;;; 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 "$Header$") ;;; ;;; ********************************************************************** ;;; ;;; Stuff to handle simple cases for generic arithmetic. ;;; ;;; Written by William Lott. ;;; (in-package :x86) (eval-when (compile eval) ;;;; Addition, Subtraction, and Multiplication (defmacro define-generic-arith-routine ((fun cost) &body body) `(define-assembly-routine (,(symbolicate "GENERIC-" fun) (:cost ,cost) (:return-style :full-call) (:translate ,fun) (:policy :safe) (:save-p t)) ((:arg x (descriptor-reg any-reg) edx-offset) (:arg y (descriptor-reg any-reg) esi-offset) (:res res (descriptor-reg any-reg) edx-offset) (:temp eax dword-reg eax-offset) (:temp ebx dword-reg ebx-offset) (:temp ecx dword-reg ecx-offset)) ebx ; ignorable (inst test x 3) (inst jmp :nz DO-STATIC-FUN) (inst test y 3) (inst jmp :z DO-BODY) DO-STATIC-FUN (inst pop eax) (inst push ebp-tn) (inst lea ebp-tn (make-ea :dword :base esp-tn :disp word-bytes)) (inst sub esp-tn (fixnum 2)) (inst push eax) (move ecx (fixnum 2)) (inst jmp (make-ea :byte :disp (+ nil-value (static-function-offset ',(symbolicate "TWO-ARG-" fun))))) DO-BODY ,@body)) ); eval-when (define-generic-arith-routine (+ 10) (move res x) (inst add res y) (inst jmp :no okay) (inst rcr res 1) (inst sar res 1) (move ecx res) (with-fixed-allocation (res ebx bignum-type (1+ bignum-digits-offset)) (storew ecx res bignum-digits-offset other-pointer-type)) OKAY) (define-generic-arith-routine (- 10) (move res x) (inst sub res x) (inst jmp :no okay) (inst rcr res 1) (inst sar res 1) (move ecx res) (with-fixed-allocation (res ebx bignum-type (1+ bignum-digits-offset)) (storew ecx res bignum-digits-offset other-pointer-type)) OKAY) (define-generic-arith-routine (* 30) (move eax x) (inst sar eax 2) (inst imul y) (inst jmp :no okay) (inst shrd eax edx 2) (inst sar edx 2) (move ecx edx) (inst cdq) (inst cmp edx ecx) (inst jmp :e SINGLE-WORD-BIGNUM) (with-fixed-allocation (res ebx bignum-type (+ bignum-digits-offset 2)) (storew eax res bignum-digits-offset other-pointer-type) (storew ecx res (1+ bignum-digits-offset) other-pointer-type)) (inst jmp DONE) SINGLE-WORD-BIGNUM (with-fixed-allocation (res ebx bignum-type (1+ bignum-digits-offset)) (storew eax res bignum-digits-offset other-pointer-type)) (inst jmp DONE) OKAY (move res eax) DONE) (define-assembly-routine (generic-negate (:cost 10) (:return-style :full-call) (:policy :safe) (:translate %negate) (:save-p t)) ((:arg x (descriptor-reg any-reg) edx-offset) (:res res (descriptor-reg any-reg) edx-offset) (:temp eax dword-reg eax-offset) (:temp ecx dword-reg ecx-offset)) (inst test x 3) (inst jmp :z FIXNUM) (inst pop eax) (inst push ebp-tn) (inst lea ebp-tn (make-ea :dword :base esp-tn :disp word-bytes)) (inst sub esp-tn (fixnum 2)) (inst push eax) (move ecx (fixnum 2)) (inst jmp (make-ea :byte :disp (+ nil-value (static-function-offset '%negate)))) FIXNUM (move res x) (inst neg res)) ;;;; Comparison routines. (eval-when (compile eval) (defmacro define-cond-assem-rtn (name translate static-fn test) `(define-assembly-routine (,name (:cost 10) (:return-style :full-call) (:policy :safe) (:translate ,translate) (:save-p t)) ((:arg x (descriptor-reg any-reg) edx-offset) (:arg y (descriptor-reg any-reg) esi-offset) (:res res descriptor-reg edx-offset) (:temp eax dword-reg eax-offset)) (inst test x 3) (inst jmp :nz DO-STATIC-FN) (inst test y 3) (inst jmp :z DO-COMPARE) DO-STATIC-FN (inst pop eax) (inst push ebp-tn) (inst lea ebp-tn (make-ea :dword :base esp-tn :disp word-bytes)) (inst sub esp-tn (fixnum 2)) (inst push eax) (move ecx (fixnum 2)) (inst jmp (make-ea :byte :disp (+ nil-value (static-function-offset ',static-fn)))) DO-COMPARE (inst cmp x y) (inst jmp ,test TRUE) (move res nil-value) (inst pop eax) (inst add eax 2) (inst jmp eax) TRUE (move res t-value))) ); eval-when (define-cond-assem-rtn generic-< < two-arg-< :l) (define-cond-assem-rtn generic-> > two-arg-> :g) (define-assembly-routine (generic-eql (:cost 10) (:return-style :full-call) (:policy :safe) (:translate eql) (:save-p t)) ((:arg x (descriptor-reg any-reg) edx-offset) (:arg y (descriptor-reg any-reg) esi-offset) (:res res descriptor-reg edx-offset) ) (inst cmp x y) (inst jmp :e RETURN-T) (inst test x 3) (inst jmp :z RETURN-NIL) (inst test y 3) (inst jmp :nz DO-STATIC-FN) RETURN-NIL (move res nil-value) (inst pop eax) (inst add eax 2) (inst jmp eax) DO-STATIC-FN (inst pop eax) (inst push ebp-tn) (inst lea ebp-tn (make-ea :dword :base esp-tn :disp word-bytes)) (inst sub esp-tn (fixnum 2)) (inst push eax) (move ecx (fixnum 2)) (inst jmp (make-ea :byte :disp (+ nil-value (static-function-offset 'two-arg-eql)))) RETURN-T (move res t-value)) (define-assembly-routine (generic-= (:cost 10) (:return-style :full-call) (:policy :safe) (:translate =) (:save-p t)) ((:arg x (descriptor-reg any-reg) edx-offset) (:arg y (descriptor-reg any-reg) esi-offset) (:res res descriptor-reg edx-offset) (:temp eax dword-reg eax-offset)) (inst cmp x y) (inst jmp :e RETURN-T) (inst test x 3) (inst jmp :nz DO-STATIC-FN) (inst test y 3) (inst jmp :jz DO-STATIC-FN) (move res nil-value) (inst pop eax) (inst add eax 2) (inst jmp eax) DO-STATIC-FN (inst pop eax) (inst push ebp-tn) (inst lea ebp-tn (make-ea :dword :base esp-tn :disp word-bytes)) (inst sub esp-tn (fixnum 2)) (inst push eax) (move ecx (fixnum 2)) (inst jmp (make-ea :byte :disp (+ nil-value (static-function-offset 'two-arg-=)))) RETURN-T (load-symbol res t))