diff --git a/compiler/amd64/alloc.lisp b/compiler/amd64/alloc.lisp new file mode 100644 index 0000000000000000000000000000000000000000..e437cf45c0812eefa3bec973552ec8eaa198b3d5 --- /dev/null +++ b/compiler/amd64/alloc.lisp @@ -0,0 +1,291 @@ +;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; 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: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/amd64/alloc.lisp,v 1.1 2004/05/24 22:34:59 cwang Exp $") +;;; +;;; ********************************************************************** +;;; +;;; Allocation VOPs for the amd64 port. +;;; +;;; Written by William Lott. +;;; +;;; Debugged by Paul F. Werkowski Spring/Summer 1995. +;;; Enhancements/debugging by Douglas T. Crosher 1996,1996. +;;; + +(in-package :amd64) + + +;;;; Dynamic-Extent + +;;; +;;; Take an arg where to move the stack pointer instead of returning +;;; it via :results, because the former generates a single move. +;;; +(define-vop (%dynamic-extent-start) + (:args (saved-stack-pointer :scs (any-reg control-stack))) + (:results) + (:policy :safe) + (:generator 0 (inst mov saved-stack-pointer rsp-tn))) + +(define-vop (%dynamic-extent-end) + (:args (saved-stack-pointer :scs (any-reg control-stack))) + (:results) + (:policy :safe) + (:generator 0 (inst mov rsp-tn saved-stack-pointer))) + + +;;;; LIST and LIST* + +(define-vop (list-or-list*) + (:args (things :more t)) + (:temporary (:sc unsigned-reg) ptr temp) + (:temporary (:sc unsigned-reg :to (:result 0) :target result) res) + (:info num dynamic-extent) + (:results (result :scs (descriptor-reg))) + (:variant-vars star) + (:policy :safe) + (:node-var node) + (:generator 0 + (cond ((zerop num) + ;; (move result nil-value) + (inst mov result nil-value)) + ((and star (= num 1)) + (move result (tn-ref-tn things))) + (t + (macrolet + ((store-car (tn list &optional (slot vm:cons-car-slot)) + `(let ((reg + (sc-case ,tn + ((any-reg descriptor-reg) ,tn) + ((control-stack) + (move temp ,tn) + temp)))) + (storew reg ,list ,slot vm:list-pointer-type)))) + (let ((cons-cells (if star (1- num) num)) + (*enable-pseudo-atomic* (unless dynamic-extent + *enable-pseudo-atomic*))) + (pseudo-atomic + (allocation res (* (pad-data-block cons-size) cons-cells) temp node + dynamic-extent) + (inst lea res + (make-ea :byte :base res :disp list-pointer-type)) + (move ptr res) + (dotimes (i (1- cons-cells)) + (store-car (tn-ref-tn things) ptr) + (setf things (tn-ref-across things)) + (inst add ptr (pad-data-block cons-size)) + (storew ptr ptr (- cons-cdr-slot cons-size) + list-pointer-type)) + (store-car (tn-ref-tn things) ptr) + (cond (star + (setf things (tn-ref-across things)) + (store-car (tn-ref-tn things) ptr cons-cdr-slot)) + (t + (storew nil-value ptr cons-cdr-slot + list-pointer-type))) + (assert (null (tn-ref-across things))))) + (move result res)))))) + +(define-vop (list list-or-list*) + (:variant nil)) + +(define-vop (list* list-or-list*) + (:variant t)) + + +;;;; Special purpose inline allocators. + +(define-vop (allocate-code-object) + (:args (boxed-arg :scs (any-reg) :target boxed) + (unboxed-arg :scs (any-reg) :target unboxed)) + (:results (result :scs (descriptor-reg))) + (:temporary (:sc unsigned-reg :from :eval) temp) + (:temporary (:sc unsigned-reg :from (:argument 0)) boxed) + (:temporary (:sc unsigned-reg :from (:argument 1)) unboxed) + (:generator 100 + (move boxed boxed-arg) + (inst add boxed (fixnumize (1+ code-trace-table-offset-slot))) + (inst and boxed (lognot lowtag-mask)) + (move unboxed unboxed-arg) + (inst shr unboxed word-shift) + (inst add unboxed lowtag-mask) + (inst and unboxed (lognot lowtag-mask)) + (pseudo-atomic + ;; now loading code into static space cause it can't move + (load-symbol-value temp lisp::*static-space-free-pointer*) + (inst lea result (make-ea :byte :base temp :disp other-pointer-type)) + (inst add temp boxed) + (inst add temp unboxed) + (store-symbol-value temp lisp::*static-space-free-pointer*) + (inst shl boxed (- type-bits word-shift)) + (inst or boxed code-header-type) + (storew boxed result 0 other-pointer-type) + (storew unboxed result code-code-size-slot other-pointer-type) + (inst mov temp nil-value) + (storew temp result code-entry-points-slot other-pointer-type)) + (storew temp result code-debug-info-slot other-pointer-type))) + + +(define-vop (allocate-dynamic-code-object) + (:args (boxed-arg :scs (any-reg) :target boxed) ; fixnum, number of words + (unboxed-arg :scs (any-reg) :target unboxed)) ; fixnum, number of bytes + (:results (result :scs (descriptor-reg) :from :eval)) + (:temporary (:sc unsigned-reg :from (:argument 0)) boxed) + (:temporary (:sc unsigned-reg :from (:argument 1)) unboxed) + (:temporary (:sc any-reg) temp) + (:node-var node) + (:generator 100 + (move boxed boxed-arg) + ;; the compiled code assumes it's dual word aligned + (inst lea boxed (make-ea :byte :base boxed :index boxed + :disp (* 8 (1+ code-trace-table-offset-slot)))) + (inst and boxed (lognot 15)) + (move unboxed unboxed-arg) + (inst shr unboxed 2) + (inst add unboxed 15) + (inst and unboxed (lognot 15)) ; alignment + (inst mov result boxed) + (inst add result unboxed) ; total number of bytes + (pseudo-atomic + (allocation result result temp node) + (inst lea result (make-ea :byte :base result :disp other-pointer-type)) + (inst shl boxed (- type-bits word-shift)) + (inst or boxed code-header-type) + (storew boxed result 0 other-pointer-type) + (inst shr unboxed 1) ; number of code words (fixnum tag) + (storew unboxed result code-code-size-slot other-pointer-type) + (storew nil-value result code-entry-points-slot other-pointer-type)) + (storew nil-value result code-debug-info-slot other-pointer-type))) + + +(define-vop (make-fdefn) + (:policy :fast-safe) + (:translate make-fdefn) + (:args (name :scs (descriptor-reg) :to :eval)) + (:results (result :scs (descriptor-reg) :from :argument)) + (:temporary (:sc any-reg) temp) + (:node-var node) + (:generator 37 + (with-fixed-allocation (result fdefn-type fdefn-size temp node) + (storew name result fdefn-name-slot other-pointer-type) + (storew nil-value result fdefn-function-slot other-pointer-type) + (storew (make-fixup (extern-alien-name "undefined_tramp") :foreign) + result fdefn-raw-addr-slot other-pointer-type)))) + + +(define-vop (make-closure) + (:args (function :to :save :scs (descriptor-reg))) + (:info length dynamic-extent) + (:temporary (:sc any-reg) temp) + (:results (result :scs (descriptor-reg))) + (:node-var node) + (:generator 10 + (let ((*enable-pseudo-atomic* (unless dynamic-extent + *enable-pseudo-atomic*))) + (pseudo-atomic + (let ((size (+ length closure-info-offset))) + (allocation result (pad-data-block size) temp node dynamic-extent) + (inst lea result + (make-ea :byte :base result :disp function-pointer-type)) + (storew (logior (ash (1- size) type-bits) closure-header-type) + result 0 function-pointer-type)) + (loadw temp function closure-function-slot function-pointer-type) + (storew temp result closure-function-slot function-pointer-type))))) + +;;; The compiler likes to be able to directly make value cells. +;;; +(define-vop (make-value-cell) + (:args (value :scs (descriptor-reg any-reg) :to :result)) + (:results (result :scs (descriptor-reg) :from :eval)) + (:temporary (:sc any-reg) temp) + (:node-var node) + (:generator 10 + (with-fixed-allocation + (result value-cell-header-type value-cell-size temp node)) + (storew value result value-cell-value-slot other-pointer-type))) + + + +;;;; Automatic allocators for primitive objects. + +(define-vop (make-unbound-marker) + (:args) + (:results (result :scs (any-reg))) + (:generator 1 + (inst mov result unbound-marker-type))) + +(define-vop (fixed-alloc) + (:args) + (:info name words type lowtag dynamic-extent) + (:ignore name) + (:results (result :scs (descriptor-reg))) + (:temporary (:sc any-reg) temp) + (:node-var node) + (:generator 50 + (let ((*enable-pseudo-atomic* (unless dynamic-extent + *enable-pseudo-atomic*))) + (pseudo-atomic + (allocation result (pad-data-block words) temp node dynamic-extent) + (inst lea result (make-ea :byte :base result :disp lowtag)) + (when type + (storew (logior (ash (1- words) type-bits) type) result 0 lowtag)))))) + +(define-vop (var-alloc) + (:args (extra :scs (any-reg))) + (:arg-types positive-fixnum) + (:info name words type lowtag) + (:ignore name) + (:results (result :scs (descriptor-reg) :from (:eval 1))) + (:temporary (:sc any-reg :from :eval :to (:eval 1)) bytes) + (:temporary (:sc any-reg :from :eval :to :result) header) + (:temporary (:sc any-reg) temp) + (:node-var node) + (:generator 50 + (inst lea bytes + (make-ea :qword :index extra :scale 2 :disp (* (1+ words) word-bytes))) + (inst mov header bytes) + (inst shl header (- type-bits 3)) ; w+1 to length field + + (inst lea header ; (w-1 << 8) | type + (make-ea :qword :base header :disp (+ (ash -2 type-bits) type))) + (inst and bytes (lognot 15)) ; alignment + (pseudo-atomic + (allocation result bytes temp node) + (inst lea result (make-ea :byte :base result :disp lowtag)) + (storew header result 0 lowtag)))) + + + +(define-vop (make-symbol) + (:policy :fast-safe) + (:translate make-symbol) + (:args (name :scs (descriptor-reg) :to :eval)) + (:temporary (:sc unsigned-reg) temp) ; this cannot be the same register as name + (:temporary (:sc unsigned-reg :from :eval) state-addr) + (:results (result :scs (descriptor-reg) :from :argument)) + (:node-var node) + (:generator 37 + (with-fixed-allocation (result symbol-header-type symbol-size temp node) + (storew name result symbol-name-slot other-pointer-type) + (storew unbound-marker-type result symbol-value-slot other-pointer-type) + ;; Setup a random hash value for the symbol. Perhaps the object + ;; address could be used for even faster and smaller code! + (load-foreign-data-symbol2 state-addr "fast_random_state" temp) + (inst imul temp + (make-ea :qword :base state-addr) + 1103515245) + (inst add temp 12345) + (inst mov (make-ea :qword :base state-addr) temp) + ;; Want a positive fixnum for the hash value, discard the LS bits. + (inst shr temp 1) + (inst and temp #xfffffffc) + (storew temp result symbol-hash-slot other-pointer-type) + (storew nil-value result symbol-plist-slot other-pointer-type) + (storew nil-value result symbol-package-slot other-pointer-type)))) diff --git a/compiler/amd64/arith.lisp b/compiler/amd64/arith.lisp new file mode 100644 index 0000000000000000000000000000000000000000..fa979d62ea8cb22ae036edbd2a97aa27b6d8c206 --- /dev/null +++ b/compiler/amd64/arith.lisp @@ -0,0 +1,1475 @@ +;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; 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: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/amd64/arith.lisp,v 1.1 2004/05/24 22:34:59 cwang Exp $") +;;; +;;; ********************************************************************** +;;; +;;; This file contains the VM definition arithmetic VOPs for the x86. +;;; +;;; Written by William Lott. +;;; +;;; Debugged by Paul F. Werkowski Spring/Summer 1995. +;;; Enhancements/debugging by Douglas T. Crosher 1996,1997,2000. +;;; + +(in-package :amd64) + + + +;;;; Unary operations. + +(define-vop (fast-safe-arith-op) + (:policy :fast-safe) + (:effects) + (:affected)) + + +(define-vop (fixnum-unop fast-safe-arith-op) + (:args (x :scs (any-reg) :target res)) + (:results (res :scs (any-reg))) + (:note "inline fixnum arithmetic") + (:arg-types tagged-num) + (:result-types tagged-num)) + +(define-vop (signed-unop fast-safe-arith-op) + (:args (x :scs (signed-reg) :target res)) + (:results (res :scs (signed-reg))) + (:note "inline (signed-byte 32) arithmetic") + (:arg-types signed-num) + (:result-types signed-num)) + +(define-vop (fast-negate/fixnum fixnum-unop) + (:translate %negate) + (:generator 1 + (move res x) + (inst neg res))) + +(define-vop (fast-negate/signed signed-unop) + (:translate %negate) + (:generator 2 + (move res x) + (inst neg res))) + +(define-vop (fast-lognot/fixnum fixnum-unop) + (:translate lognot) + (:generator 2 + (move res x) + (inst xor res (fixnumize -1)))) + +(define-vop (fast-lognot/signed signed-unop) + (:translate lognot) + (:generator 1 + (move res x) + (inst not res))) + + + +;;;; Binary fixnum operations. + +;;; Assume that any constant operand is the second arg... + +(define-vop (fast-fixnum-binop fast-safe-arith-op) + (:args (x :target r :scs (any-reg) + :load-if (not (and (sc-is x control-stack) + (sc-is y any-reg) + (sc-is r control-stack) + (location= x r)))) + (y :scs (any-reg control-stack))) + (:arg-types tagged-num tagged-num) + (:results (r :scs (any-reg) :from (:argument 0) + :load-if (not (and (sc-is x control-stack) + (sc-is y any-reg) + (sc-is r control-stack) + (location= x r))))) + (:result-types tagged-num) + (:note "inline fixnum arithmetic")) + +(define-vop (fast-unsigned-binop fast-safe-arith-op) + (:args (x :target r :scs (unsigned-reg) + :load-if (not (and (sc-is x unsigned-stack) + (sc-is y unsigned-reg) + (sc-is r unsigned-stack) + (location= x r)))) + (y :scs (unsigned-reg unsigned-stack))) + (:arg-types unsigned-num unsigned-num) + (:results (r :scs (unsigned-reg) :from (:argument 0) + :load-if (not (and (sc-is x unsigned-stack) + (sc-is y unsigned-reg) + (sc-is r unsigned-stack) + (location= x r))))) + (:result-types unsigned-num) + (:note "inline (unsigned-byte 32) arithmetic")) + +(define-vop (fast-signed-binop fast-safe-arith-op) + (:args (x :target r :scs (signed-reg) + :load-if (not (and (sc-is x signed-stack) + (sc-is y signed-reg) + (sc-is r signed-stack) + (location= x r)))) + (y :scs (signed-reg signed-stack))) + (:arg-types signed-num signed-num) + (:results (r :scs (signed-reg) :from (:argument 0) + :load-if (not (and (sc-is x signed-stack) + (sc-is y signed-reg) + (sc-is r signed-stack) + (location= x r))))) + (:result-types signed-num) + (:note "inline (signed-byte 32) arithmetic")) + +(define-vop (fast-fixnum-binop-c fast-safe-arith-op) + (:args (x :target r :scs (any-reg control-stack))) + (:info y) + (:arg-types tagged-num (:constant (signed-byte 30))) + (:results (r :scs (any-reg) + :load-if (not (location= x r)))) + (:result-types tagged-num) + (:note "inline fixnum arithmetic")) + +(define-vop (fast-unsigned-binop-c fast-safe-arith-op) + (:args (x :target r :scs (unsigned-reg unsigned-stack))) + (:info y) + (:arg-types unsigned-num (:constant (unsigned-byte 32))) + (:results (r :scs (unsigned-reg) + :load-if (not (location= x r)))) + (:result-types unsigned-num) + (:note "inline (unsigned-byte 32) arithmetic")) + +(define-vop (fast-signed-binop-c fast-safe-arith-op) + (:args (x :target r :scs (signed-reg signed-stack))) + (:info y) + (:arg-types signed-num (:constant (signed-byte 32))) + (:results (r :scs (signed-reg) + :load-if (not (location= x r)))) + (:result-types signed-num) + (:note "inline (signed-byte 32) arithmetic")) + + +(eval-when (compile load eval) + +(defmacro define-binop (translate untagged-penalty op) + `(progn + (define-vop (,(symbolicate "FAST-" translate "/FIXNUM=>FIXNUM") + fast-fixnum-binop) + (:translate ,translate) + (:generator 2 + (move r x) + (inst ,op r y))) + (define-vop (,(symbolicate 'fast- translate '-c/fixnum=>fixnum) + fast-fixnum-binop-c) + (:translate ,translate) + (:generator 1 + (move r x) + (inst ,op r (fixnumize y)))) + (define-vop (,(symbolicate "FAST-" translate "/SIGNED=>SIGNED") + fast-signed-binop) + (:translate ,translate) + (:generator ,(1+ untagged-penalty) + (move r x) + (inst ,op r y))) + (define-vop (,(symbolicate 'fast- translate '-c/signed=>signed) + fast-signed-binop-c) + (:translate ,translate) + (:generator ,untagged-penalty + (move r x) + (inst ,op r y))) + (define-vop (,(symbolicate "FAST-" translate "/UNSIGNED=>UNSIGNED") + fast-unsigned-binop) + (:translate ,translate) + (:generator ,(1+ untagged-penalty) + (move r x) + (inst ,op r y))) + (define-vop (,(symbolicate 'fast- translate '-c/unsigned=>unsigned) + fast-unsigned-binop-c) + (:translate ,translate) + (:generator ,untagged-penalty + (move r x) + (inst ,op r y))))) + +); eval-when + + + +;(define-binop + 4 add) +(define-binop - 4 sub) +(define-binop logand 2 and) +(define-binop logior 2 or) +(define-binop logxor 2 xor) + + +;;; Special handling of add on the x86; can use lea to avoid a +;;; register load, otherwise it uses add. +(define-vop (fast-+/fixnum=>fixnum fast-safe-arith-op) + (:translate +) + (:args (x :scs (any-reg) :target r + :load-if (not (and (sc-is x control-stack) + (sc-is y any-reg) + (sc-is r control-stack) + (location= x r)))) + (y :scs (any-reg control-stack))) + (:arg-types tagged-num tagged-num) + (:results (r :scs (any-reg) :from (:argument 0) + :load-if (not (and (sc-is x control-stack) + (sc-is y any-reg) + (sc-is r control-stack) + (location= x r))))) + (:result-types tagged-num) + (:note "inline fixnum arithmetic") + (:generator 2 + (cond ((and (sc-is x any-reg) (sc-is y any-reg) (sc-is r any-reg) + (not (location= x r))) + (inst lea r (make-ea :qword :base x :index y :scale 1))) + (t + (move r x) + (inst add r y))))) + +(define-vop (fast-+-c/fixnum=>fixnum fast-safe-arith-op) + (:translate +) + (:args (x :target r :scs (any-reg control-stack))) + (:info y) + (:arg-types tagged-num (:constant (signed-byte 30))) + (:results (r :scs (any-reg) + :load-if (not (location= x r)))) + (:result-types tagged-num) + (:note "inline fixnum arithmetic") + (:generator 1 + (cond ((and (sc-is x any-reg) (sc-is r any-reg) (not (location= x r))) + (inst lea r (make-ea :qword :base x :disp (fixnumize y)))) + (t + (move r x) + (inst add r (fixnumize y)))))) + +(define-vop (fast-+/signed=>signed fast-safe-arith-op) + (:translate +) + (:args (x :scs (signed-reg) :target r + :load-if (not (and (sc-is x signed-stack) + (sc-is y signed-reg) + (sc-is r signed-stack) + (location= x r)))) + (y :scs (signed-reg signed-stack))) + (:arg-types signed-num signed-num) + (:results (r :scs (signed-reg) :from (:argument 0) + :load-if (not (and (sc-is x signed-stack) + (sc-is y signed-reg) + (location= x r))))) + (:result-types signed-num) + (:note "inline (signed-byte 32) arithmetic") + (:generator 5 + (cond ((and (sc-is x signed-reg) (sc-is y signed-reg) (sc-is r signed-reg) + (not (location= x r))) + (inst lea r (make-ea :qword :base x :index y :scale 1))) + (t + (move r x) + (inst add r y))))) + +(define-vop (fast-+-c/signed=>signed fast-safe-arith-op) + (:translate +) + (:args (x :target r :scs (signed-reg signed-stack))) + (:info y) + (:arg-types signed-num (:constant (signed-byte 32))) + (:results (r :scs (signed-reg) + :load-if (not (location= x r)))) + (:result-types signed-num) + (:note "inline (signed-byte 32) arithmetic") + (:generator 4 + (cond ((and (sc-is x signed-reg) (sc-is r signed-reg) + (not (location= x r))) + (inst lea r (make-ea :qword :base x :disp y))) + (t + (move r x) + (if (= y 1) + (inst inc r) + (inst add r y)))))) + +(define-vop (fast-+/unsigned=>unsigned fast-safe-arith-op) + (:translate +) + (:args (x :scs (unsigned-reg) :target r + :load-if (not (and (sc-is x unsigned-stack) + (sc-is y unsigned-reg) + (sc-is r unsigned-stack) + (location= x r)))) + (y :scs (unsigned-reg unsigned-stack))) + (:arg-types unsigned-num unsigned-num) + (:results (r :scs (unsigned-reg) :from (:argument 0) + :load-if (not (and (sc-is x unsigned-stack) + (sc-is y unsigned-reg) + (sc-is r unsigned-stack) + (location= x r))))) + (:result-types unsigned-num) + (:note "inline (unsigned-byte 32) arithmetic") + (:generator 5 + (cond ((and (sc-is x unsigned-reg) (sc-is y unsigned-reg) + (sc-is r unsigned-reg) (not (location= x r))) + (inst lea r (make-ea :qword :base x :index y :scale 1))) + (t + (move r x) + (inst add r y))))) + +(define-vop (fast-+-c/unsigned=>unsigned fast-safe-arith-op) + (:translate +) + (:args (x :target r :scs (unsigned-reg unsigned-stack))) + (:info y) + (:arg-types unsigned-num (:constant (unsigned-byte 32))) + (:results (r :scs (unsigned-reg) + :load-if (not (location= x r)))) + (:result-types unsigned-num) + (:note "inline (unsigned-byte 32) arithmetic") + (:generator 4 + (cond ((and (sc-is x unsigned-reg) + (sc-is r unsigned-reg) + (not (location= x r)) + (valid-displacement-p y)) + (inst lea r (make-ea :qword :base x :disp y))) + (t + (move r x) + (if (= y 1) + (inst inc r) + (inst add r y)))))) + + +;;;; Special logand cases: (logand signed unsigned) => unsigned + +(define-vop (fast-logand/signed-unsigned=>unsigned + fast-logand/unsigned=>unsigned) + (:args (x :target r :scs (signed-reg) + :load-if (not (and (sc-is x signed-stack) + (sc-is y unsigned-reg) + (sc-is r unsigned-stack) + (location= x r)))) + (y :scs (unsigned-reg unsigned-stack))) + (:arg-types signed-num unsigned-num)) + +(define-vop (fast-logand-c/signed-unsigned=>unsigned + fast-logand-c/unsigned=>unsigned) + (:args (x :target r :scs (signed-reg signed-stack))) + (:arg-types signed-num (:constant (unsigned-byte 32)))) + +(define-vop (fast-logand/unsigned-signed=>unsigned + fast-logand/unsigned=>unsigned) + (:args (x :target r :scs (unsigned-reg) + :load-if (not (and (sc-is x unsigned-stack) + (sc-is y signed-reg) + (sc-is r unsigned-stack) + (location= x r)))) + (y :scs (signed-reg signed-stack))) + (:arg-types unsigned-num signed-num)) + + +;;;; Multiplication and division. + +(define-vop (fast-*/fixnum=>fixnum fast-safe-arith-op) + (:translate *) + ;; We need different loading characteristics. + (:args (x :scs (any-reg) :target r) + (y :scs (any-reg control-stack))) + (:arg-types tagged-num tagged-num) + (:results (r :scs (any-reg) :from (:argument 0))) + (:result-types tagged-num) + (:note "inline fixnum arithmetic") + (:generator 4 + (move r x) + (inst sar r 2) + (inst imul r y))) + +(define-vop (fast-*-c/fixnum=>fixnum fast-safe-arith-op) + (:translate *) + ;; We need different loading characteristics. + (:args (x :scs (any-reg control-stack))) + (:info y) + (:arg-types tagged-num (:constant (signed-byte 30))) + (:results (r :scs (any-reg))) + (:result-types tagged-num) + (:note "inline fixnum arithmetic") + (:generator 3 + (inst imul r x y))) + +(define-vop (fast-*/signed=>signed fast-safe-arith-op) + (:translate *) + ;; We need different loading characteristics. + (:args (x :scs (signed-reg) :target r) + (y :scs (signed-reg signed-stack))) + (:arg-types signed-num signed-num) + (:results (r :scs (signed-reg) :from (:argument 0))) + (:result-types signed-num) + (:note "inline (signed-byte 32) arithmetic") + (:generator 5 + (move r x) + (inst imul r y))) + +(define-vop (fast-*-c/signed=>signed fast-safe-arith-op) + (:translate *) + ;; We need different loading characteristics. + (:args (x :scs (signed-reg signed-stack))) + (:info y) + (:arg-types signed-num (:constant (signed-byte 32))) + (:results (r :scs (signed-reg))) + (:result-types signed-num) + (:note "inline (signed-byte 32) arithmetic") + (:generator 4 + (inst imul r x y))) + +(define-vop (fast-*/unsigned=>unsigned fast-safe-arith-op) + (:translate *) + (:args (x :scs (unsigned-reg) :target rax) + (y :scs (unsigned-reg unsigned-stack))) + (:arg-types unsigned-num unsigned-num) + (:temporary (:sc unsigned-reg :offset rax-offset :target result + :from (:argument 0) :to :result) rax) + (:temporary (:sc unsigned-reg :offset rdx-offset + :from :eval :to :result) rdx) + (:ignore rdx) + (:results (result :scs (unsigned-reg))) + (:result-types unsigned-num) + (:note "inline (unsigned-byte 32) arithmetic") + (:vop-var vop) + (:save-p :compute-only) + (:generator 6 + (move rax x) + (inst mul rax y) + (move result rax))) + + +(define-vop (fast-truncate/fixnum=>fixnum fast-safe-arith-op) + (:translate truncate) + (:args (x :scs (any-reg) :target rax) + (y :scs (any-reg control-stack))) + (:arg-types tagged-num tagged-num) + (:temporary (:sc signed-reg :offset rax-offset :target quo + :from (:argument 0) :to (:result 0)) rax) + (:temporary (:sc unsigned-reg :offset rdx-offset :target rem + :from (:argument 0) :to (:result 1)) rdx) + (:results (quo :scs (any-reg)) + (rem :scs (any-reg))) + (:result-types tagged-num tagged-num) + (:note "inline fixnum arithmetic") + (:vop-var vop) + (:save-p :compute-only) + (:generator 31 + (let ((zero (generate-error-code vop division-by-zero-error x y))) + (if (sc-is y any-reg) + (inst test y y) ; Smaller instruction + (inst cmp y 0)) + (inst jmp :eq zero)) + (move rax x) + (inst cdo) + (inst idiv rax y) + (if (location= quo rax) + (inst shl rax 2) + (inst lea quo (make-ea :qword :index rax :scale 4))) + (move rem rdx))) + +(define-vop (fast-truncate-c/fixnum=>fixnum fast-safe-arith-op) + (:translate truncate) + (:args (x :scs (any-reg) :target rax)) + (:info y) + (:arg-types tagged-num (:constant (signed-byte 30))) + (:temporary (:sc signed-reg :offset rax-offset :target quo + :from :argument :to (:result 0)) rax) + (:temporary (:sc any-reg :offset rdx-offset :target rem + :from :eval :to (:result 1)) rdx) + (:temporary (:sc any-reg :from :eval :to :result) y-arg) + (:results (quo :scs (any-reg)) + (rem :scs (any-reg))) + (:result-types tagged-num tagged-num) + (:note "inline fixnum arithmetic") + (:vop-var vop) + (:save-p :compute-only) + (:generator 30 + (move rax x) + (inst cdq) + (inst mov y-arg (fixnumize y)) + (inst idiv rax y-arg) + (if (location= quo rax) + (inst shl rax 2) + (inst lea quo (make-ea :qword :index rax :scale 4))) + (move rem rdx))) + +(define-vop (fast-truncate/unsigned=>unsigned fast-safe-arith-op) + (:translate truncate) + (:args (x :scs (unsigned-reg) :target rax) + (y :scs (unsigned-reg signed-stack))) + (:arg-types unsigned-num unsigned-num) + (:temporary (:sc unsigned-reg :offset rax-offset :target quo + :from (:argument 0) :to (:result 0)) rax) + (:temporary (:sc unsigned-reg :offset rdx-offset :target rem + :from (:argument 0) :to (:result 1)) rdx) + (:results (quo :scs (unsigned-reg)) + (rem :scs (unsigned-reg))) + (:result-types unsigned-num unsigned-num) + (:note "inline (unsigned-byte 32) arithmetic") + (:vop-var vop) + (:save-p :compute-only) + (:generator 33 + (let ((zero (generate-error-code vop division-by-zero-error x y))) + (if (sc-is y unsigned-reg) + (inst test y y) ; Smaller instruction + (inst cmp y 0)) + (inst jmp :eq zero)) + (move rax x) + (inst xor rdx rdx) + (inst div rax y) + (move quo rax) + (move rem rdx))) + +(define-vop (fast-truncate-c/unsigned=>unsigned fast-safe-arith-op) + (:translate truncate) + (:args (x :scs (unsigned-reg) :target rax)) + (:info y) + (:arg-types unsigned-num (:constant (unsigned-byte 32))) + (:temporary (:sc unsigned-reg :offset rax-offset :target quo + :from :argument :to (:result 0)) rax) + (:temporary (:sc unsigned-reg :offset rdx-offset :target rem + :from :eval :to (:result 1)) rdx) + (:temporary (:sc unsigned-reg :from :eval :to :result) y-arg) + (:results (quo :scs (unsigned-reg)) + (rem :scs (unsigned-reg))) + (:result-types unsigned-num unsigned-num) + (:note "inline (unsigned-byte 32) arithmetic") + (:vop-var vop) + (:save-p :compute-only) + (:generator 32 + (move rax x) + (inst xor rdx rdx) + (inst mov y-arg y) + (inst div rax y-arg) + (move quo rax) + (move rem rdx))) + +(define-vop (fast-truncate/signed=>signed fast-safe-arith-op) + (:translate truncate) + (:args (x :scs (signed-reg) :target rax) + (y :scs (signed-reg signed-stack))) + (:arg-types signed-num signed-num) + (:temporary (:sc signed-reg :offset rax-offset :target quo + :from (:argument 0) :to (:result 0)) rax) + (:temporary (:sc signed-reg :offset rdx-offset :target rem + :from (:argument 0) :to (:result 1)) rdx) + (:results (quo :scs (signed-reg)) + (rem :scs (signed-reg))) + (:result-types signed-num signed-num) + (:note "inline (signed-byte 32) arithmetic") + (:vop-var vop) + (:save-p :compute-only) + (:generator 33 + (let ((zero (generate-error-code vop division-by-zero-error x y))) + (if (sc-is y signed-reg) + (inst test y y) ; Smaller instruction + (inst cmp y 0)) + (inst jmp :eq zero)) + (move rax x) + (inst cdq) + (inst idiv rax y) + (move quo rax) + (move rem rdx))) + +(define-vop (fast-truncate-c/signed=>signed fast-safe-arith-op) + (:translate truncate) + (:args (x :scs (signed-reg) :target rax)) + (:info y) + (:arg-types signed-num (:constant (signed-byte 32))) + (:temporary (:sc signed-reg :offset rax-offset :target quo + :from :argument :to (:result 0)) rax) + (:temporary (:sc signed-reg :offset rdx-offset :target rem + :from :eval :to (:result 1)) rdx) + (:temporary (:sc signed-reg :from :eval :to :result) y-arg) + (:results (quo :scs (signed-reg)) + (rem :scs (signed-reg))) + (:result-types signed-num signed-num) + (:note "inline (signed-byte 32) arithmetic") + (:vop-var vop) + (:save-p :compute-only) + (:generator 32 + (move rax x) + (inst cdq) + (inst mov y-arg y) + (inst idiv rax y-arg) + (move quo rax) + (move rem rdx))) + + + +;;;; Shifting +(define-vop (fast-ash-c/fixnum=>fixnum) + (:translate ash) + (:policy :fast-safe) + (:args (number :scs (any-reg) :target result + :load-if (not (and (sc-is number any-reg control-stack) + (sc-is result any-reg control-stack) + (location= number result))))) + (:info amount) + (:arg-types tagged-num (:constant integer)) + (:results (result :scs (any-reg) + :load-if (not (and (sc-is number control-stack) + (sc-is result control-stack) + (location= number result))))) + (:result-types tagged-num) + (:note "inline ASH") + (:generator 2 + (cond ((and (= amount 1) (not (location= number result))) + (inst lea result (make-ea :qword :index number :scale 2))) + ((and (= amount 2) (not (location= number result))) + (inst lea result (make-ea :qword :index number :scale 4))) + ((and (= amount 3) (not (location= number result))) + (inst lea result (make-ea :qword :index number :scale 8))) + (t + (move result number) + (cond ((plusp amount) + ;; We don't have to worry about overflow because of the + ;; result type restriction. + (inst shl result amount)) + (t + ;; If the amount is greater than 31, only shift by 31. We + ;; have to do this because the shift instructions only look + ;; at the low five bits of the result. + (inst sar result (min 31 (- amount))) + ;; Fixnum correction. + (inst and result #xfffffffc))))))) + +(define-vop (fast-ash-left/fixnum=>fixnum) + (:translate ash) + (:args (number :scs (any-reg) :target result + :load-if (not (and (sc-is number control-stack) + (sc-is result control-stack) + (location= number result)))) + (amount :scs (unsigned-reg) :target rcx)) + (:arg-types tagged-num positive-fixnum) + (:temporary (:sc unsigned-reg :offset rcx-offset :from (:argument 1)) rcx) + (:results (result :scs (any-reg) :from (:argument 0) + :load-if (not (and (sc-is number control-stack) + (sc-is result control-stack) + (location= number result))))) + (:result-types tagged-num) + (:policy :fast-safe) + (:note "inline ASH") + (:generator 3 + (move result number) + (move rcx amount) + ;; The result-type assures us that this shift will not overflow. + (inst shl result :cl))) + +(define-vop (fast-ash-c/unsigned=>unsigned) + (:translate ash) + (:policy :fast-safe) + (:args (number :scs (unsigned-reg) :target result + :load-if (not (and (sc-is number unsigned-stack) + (sc-is result unsigned-stack) + (location= number result))))) + (:info amount) + (:arg-types unsigned-num (:constant integer)) + (:results (result :scs (unsigned-reg) + :load-if (not (and (sc-is number unsigned-stack) + (sc-is result unsigned-stack) + (location= number result))))) + (:result-types unsigned-num) + (:note "inline ASH") + (:generator 3 + (cond ((and (= amount 1) (not (location= number result))) + (inst lea result (make-ea :qword :index number :scale 2))) + ((and (= amount 2) (not (location= number result))) + (inst lea result (make-ea :qword :index number :scale 4))) + ((and (= amount 3) (not (location= number result))) + (inst lea result (make-ea :qword :index number :scale 8))) + (t + (move result number) + (cond ((plusp amount) + ;; We don't have to worry about overflow because of the + ;; result type restriction. + (inst shl result amount)) + ((< amount -31) + (inst mov result 0)) + (t + (inst shr result (- amount)))))))) + +(define-vop (fast-ash-c/signed=>signed) + (:translate ash) + (:policy :fast-safe) + (:args (number :scs (signed-reg) :target result + :load-if (not (and (sc-is number signed-stack) + (sc-is result signed-stack) + (location= number result))))) + (:info amount) + (:arg-types signed-num (:constant integer)) + (:results (result :scs (signed-reg) + :load-if (not (and (sc-is number signed-stack) + (sc-is result signed-stack) + (location= number result))))) + (:result-types signed-num) + (:note "inline ASH") + (:generator 3 + (cond ((and (= amount 1) (not (location= number result))) + (inst lea result (make-ea :qword :index number :scale 2))) + ((and (= amount 2) (not (location= number result))) + (inst lea result (make-ea :qword :index number :scale 4))) + ((and (= amount 3) (not (location= number result))) + (inst lea result (make-ea :qword :index number :scale 8))) + (t + (move result number) + (cond ((plusp amount) + ;; We don't have to worry about overflow because of the + ;; result type restriction. + (inst shl result amount)) + (t + ;; If the amount is greater than 31, only shift by 31. We + ;; have to do this because the shift instructions only look + ;; at the low five bits of the result. + (inst sar result (min 31 (- amount))))))))) + +(define-vop (fast-ash-left/unsigned=>unsigned) + (:translate ash) + (:args (number :scs (unsigned-reg) :target result + :load-if (not (and (sc-is number unsigned-stack) + (sc-is result unsigned-stack) + (location= number result)))) + (amount :scs (unsigned-reg) :target rcx)) + (:arg-types unsigned-num positive-fixnum) + (:temporary (:sc unsigned-reg :offset rcx-offset :from (:argument 1)) rcx) + (:results (result :scs (unsigned-reg) :from (:argument 0) + :load-if (not (and (sc-is number unsigned-stack) + (sc-is result unsigned-stack) + (location= number result))))) + (:result-types unsigned-num) + (:policy :fast-safe) + (:note "inline ASH") + (:generator 4 + (move result number) + (move rcx amount) + ;; The result-type assures us that this shift will not overflow. + (inst shl result :cl))) + +(define-vop (fast-ash-left/signed=>signed) + (:translate ash) + (:args (number :scs (signed-reg) :target result + :load-if (not (and (sc-is number signed-stack) + (sc-is result signed-stack) + (location= number result)))) + (amount :scs (unsigned-reg) :target rcx)) + (:arg-types signed-num positive-fixnum) + (:temporary (:sc unsigned-reg :offset rcx-offset :from (:argument 1)) rcx) + (:results (result :scs (signed-reg) :from (:argument 0) + :load-if (not (and (sc-is number signed-stack) + (sc-is result signed-stack) + (location= number result))))) + (:result-types signed-num) + (:policy :fast-safe) + (:note "inline ASH") + (:generator 4 + (move result number) + (move rcx amount) + ;; The result-type assures us that this shift will not overflow. + (inst shl result :cl))) + +(define-vop (fast-ash/unsigned=>unsigned) + (:translate ash) + (:policy :fast-safe) + (:args (number :scs (unsigned-reg) :target result) + (amount :scs (signed-reg) :target rcx)) + (:arg-types unsigned-num signed-num) + (:results (result :scs (unsigned-reg) :from (:argument 0))) + (:result-types unsigned-num) + (:temporary (:sc signed-reg :offset rcx-offset :from (:argument 1)) rcx) + (:note "inline ASH") + (:generator 5 + (move result number) + (move rcx amount) + (inst or rcx rcx) + (inst jmp :ns POSITIVE) + (inst neg rcx) + (inst cmp rcx 31) + (inst jmp :be OKAY) + (inst xor result result) + (inst jmp DONE) + OKAY + (inst shr result :cl) + (inst jmp DONE) + + POSITIVE + ;; The result-type assures us that this shift will not overflow. + (inst shl result :cl) + + DONE)) + +(define-vop (fast-ash/signed=>signed) + (:translate ash) + (:policy :fast-safe) + (:args (number :scs (signed-reg) :target result) + (amount :scs (signed-reg) :target rcx)) + (:arg-types signed-num signed-num) + (:results (result :scs (signed-reg) :from (:argument 0))) + (:result-types signed-num) + (:temporary (:sc signed-reg :offset rcx-offset :from (:argument 1)) rcx) + (:note "inline ASH") + (:generator 5 + (move result number) + (move rcx amount) + (inst or rcx rcx) + (inst jmp :ns positive) + (inst neg rcx) + (inst cmp rcx 31) + (inst jmp :be okay) + (inst mov rcx 31) + OKAY + (inst sar result :cl) + (inst jmp done) + + POSITIVE + ;; The result-type assures us that this shift will not overflow. + (inst shl result :cl) + + DONE)) + + +;;; note documentation for this function is wrong - rtfm +(define-vop (signed-byte-32-len) + (:translate integer-length) + (:note "inline (signed-byte 32) integer-length") + (:policy :fast-safe) + (:args (arg :scs (signed-reg) :target res)) + (:arg-types signed-num) + (:results (res :scs (any-reg))) + (:result-types positive-fixnum) + (:generator 30 + (move res arg) + (inst cmp res 0) + (inst jmp :ge POS) + (inst not res) + POS + (inst bsr res res) + (inst jmp :z zero) + (inst inc res) + (inst shl res 2) + (inst jmp done) + ZERO + (inst xor res res) + DONE)) + +(define-vop (unsigned-byte-32-count) + (:translate logcount) + (:note "inline (unsigned-byte 32) logcount") + (:policy :fast-safe) + (:args (arg :scs (unsigned-reg))) + (:arg-types unsigned-num) + (:results (result :scs (unsigned-reg))) + (:result-types positive-fixnum) + (:temporary (:sc unsigned-reg :from (:argument 0)) temp) + (:generator 30 + (move result arg) + + (inst mov temp result) + (inst shr temp 1) + (inst and result #x55555555) + (inst and temp #x55555555) + (inst add result temp) + + (inst mov temp result) + (inst shr temp 2) + (inst and result #x33333333) + (inst and temp #x33333333) + (inst add result temp) + + (inst mov temp result) + (inst shr temp 4) + (inst and result #x0f0f0f0f) + (inst and temp #x0f0f0f0f) + (inst add result temp) + + (inst mov temp result) + (inst shr temp 8) + (inst and result #x00ff00ff) + (inst and temp #x00ff00ff) + (inst add result temp) + + (inst mov temp result) + (inst shr temp 16) + (inst and result #x0000ffff) + (inst and temp #x0000ffff) + (inst add result temp))) + + + +;;;; Binary conditional VOPs: + +(define-vop (fast-conditional) + (:conditional) + (:info target not-p) + (:effects) + (:affected) + (:policy :fast-safe)) + +(define-vop (fast-conditional/fixnum fast-conditional) + (:args (x :scs (any-reg) + :load-if (not (and (sc-is x control-stack) + (sc-is y any-reg)))) + (y :scs (any-reg control-stack))) + (:arg-types tagged-num tagged-num) + (:note "inline fixnum comparison")) + +(define-vop (fast-conditional-c/fixnum fast-conditional/fixnum) + (:args (x :scs (any-reg control-stack))) + (:arg-types tagged-num (:constant (signed-byte 30))) + (:info target not-p y)) + +(define-vop (fast-conditional/signed fast-conditional) + (:args (x :scs (signed-reg) + :load-if (not (and (sc-is x signed-stack) + (sc-is y signed-reg)))) + (y :scs (signed-reg signed-stack))) + (:arg-types signed-num signed-num) + (:note "inline (signed-byte 32) comparison")) + +(define-vop (fast-conditional-c/signed fast-conditional/signed) + (:args (x :scs (signed-reg signed-stack))) + (:arg-types signed-num (:constant (signed-byte 32))) + (:info target not-p y)) + +(define-vop (fast-conditional/unsigned fast-conditional) + (:args (x :scs (unsigned-reg) + :load-if (not (and (sc-is x unsigned-stack) + (sc-is y unsigned-reg)))) + (y :scs (unsigned-reg unsigned-stack))) + (:arg-types unsigned-num unsigned-num) + (:note "inline (unsigned-byte 32) comparison")) + +(define-vop (fast-conditional-c/unsigned fast-conditional/unsigned) + (:args (x :scs (unsigned-reg unsigned-stack))) + (:arg-types unsigned-num (:constant (unsigned-byte 32))) + (:info target not-p y)) + + +(defmacro define-conditional-vop (tran cond unsigned not-cond not-unsigned) + `(progn + ,@(mapcar + #'(lambda (suffix cost signed) + `(define-vop (,(intern (format nil "~:@(FAST-IF-~A~A~)" + tran suffix)) + ,(intern + (format nil "~:@(FAST-CONDITIONAL~A~)" + suffix))) + (:translate ,tran) + (:generator ,cost + (inst cmp x + ,(if (eq suffix '-c/fixnum) '(fixnumize y) 'y)) + (inst jmp (if not-p + ,(if signed not-cond not-unsigned) + ,(if signed cond unsigned)) + target)))) + '(/fixnum -c/fixnum /signed -c/signed /unsigned -c/unsigned) + '(4 3 6 5 6 5) + '(t t t t nil nil)))) + +(define-conditional-vop < :l :b :ge :ae) + +(define-conditional-vop > :g :a :le :be) + +(define-vop (fast-if-eql/signed fast-conditional/signed) + (:translate eql) + (:generator 6 + (inst cmp x y) + (inst jmp (if not-p :ne :e) target))) + +(define-vop (fast-if-eql-c/signed fast-conditional-c/signed) + (:translate eql) + (:generator 5 + (cond ((and (sc-is x signed-reg) (zerop y)) + (inst test x x)) ; Smaller instruction + (t + (inst cmp x y))) + (inst jmp (if not-p :ne :e) target))) + +(define-vop (fast-if-eql/unsigned fast-conditional/unsigned) + (:translate eql) + (:generator 6 + (inst cmp x y) + (inst jmp (if not-p :ne :e) target))) + +(define-vop (fast-if-eql-c/unsigned fast-conditional-c/unsigned) + (:translate eql) + (:generator 5 + (cond ((and (sc-is x unsigned-reg) (zerop y)) + (inst test x x)) ; Smaller instruction + (t + (inst cmp x y))) + (inst jmp (if not-p :ne :e) target))) + +;;; EQL/FIXNUM is funny because the first arg can be of any type, not just a +;;; known fixnum. + +;;; 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) + :load-if (not (and (sc-is x control-stack) + (sc-is y any-reg)))) + (y :scs (any-reg control-stack))) + (:arg-types tagged-num tagged-num) + (:note "inline fixnum comparison") + (:translate eql) + (:generator 4 + (inst cmp x y) + (inst jmp (if not-p :ne :e) target))) +;;; +(define-vop (generic-eql/fixnum fast-eql/fixnum) + (:args (x :scs (any-reg descriptor-reg) + :load-if (not (and (sc-is x control-stack) + (sc-is y any-reg)))) + (y :scs (any-reg control-stack))) + (:arg-types * tagged-num) + (:variant-cost 7)) + +(define-vop (fast-eql-c/fixnum fast-conditional/fixnum) + (:args (x :scs (any-reg control-stack))) + (:arg-types tagged-num (:constant (signed-byte 30))) + (:info target not-p y) + (:translate eql) + (:generator 2 + (cond ((and (sc-is x any-reg descriptor-reg) (zerop y)) + (inst test x x)) ; Smaller instruction + (t + (inst cmp x (fixnumize y)))) + (inst jmp (if not-p :ne :e) target))) +;;; +(define-vop (generic-eql-c/fixnum fast-eql-c/fixnum) + (:args (x :scs (any-reg descriptor-reg control-stack))) + (:arg-types * (:constant (signed-byte 30))) + (:variant-cost 6)) + + +;;;; 32-bit logical operations + +(define-vop (merge-bits) + (:translate merge-bits) + (:args (shift :scs (signed-reg unsigned-reg) :target rcx) + (prev :scs (unsigned-reg) :target result) + (next :scs (unsigned-reg))) + (:arg-types tagged-num unsigned-num unsigned-num) + (:temporary (:sc signed-reg :offset rcx-offset :from (:argument 0)) rcx) + (:results (result :scs (unsigned-reg) :from (:argument 1))) + (:result-types unsigned-num) + (:policy :fast-safe) + (:generator 4 + (move rcx shift) + (move result prev) + (inst shrd result next :cl))) + +(define-vop (32bit-logical) + (:args (x :scs (unsigned-reg) :target r + :load-if (not (and (sc-is x unsigned-stack) + (sc-is r unsigned-stack) + (location= x r)))) + (y :scs (unsigned-reg) + :load-if (or (not (sc-is y unsigned-stack)) + (and (sc-is x unsigned-stack) + (sc-is y unsigned-stack) + (location= x r))))) + (:arg-types unsigned-num unsigned-num) + (:results (r :scs (unsigned-reg) :from (:argument 0) + :load-if (not (and (sc-is x unsigned-stack) + (sc-is r unsigned-stack) + (location= x r))))) + (:result-types unsigned-num) + (:policy :fast-safe)) + +(define-vop (32bit-logical-not) + (:translate 32bit-logical-not) + (:args (x :scs (unsigned-reg) :target r + :load-if (not (and (sc-is x unsigned-stack) + (sc-is r unsigned-stack) + (location= x r))))) + (:arg-types unsigned-num) + (:results (r :scs (unsigned-reg) + :load-if (not (and (sc-is x unsigned-stack) + (sc-is r unsigned-stack) + (location= x r))))) + (:result-types unsigned-num) + (:policy :fast-safe) + (:generator 1 + (move r x) + (inst not r))) + +(define-vop (32bit-logical-and 32bit-logical) + (:translate 32bit-logical-and) + (:generator 1 + (move r x) + (inst and r y))) + +(def-source-transform 32bit-logical-nand (x y) + `(32bit-logical-not (32bit-logical-and ,x ,y))) + +(define-vop (32bit-logical-or 32bit-logical) + (:translate 32bit-logical-or) + (:generator 1 + (move r x) + (inst or r y))) + +(def-source-transform 32bit-logical-nor (x y) + `(32bit-logical-not (32bit-logical-or ,x ,y))) + +(define-vop (32bit-logical-xor 32bit-logical) + (:translate 32bit-logical-xor) + (:generator 1 + (move r x) + (inst xor r y))) + +(def-source-transform 32bit-logical-eqv (x y) + `(32bit-logical-not (32bit-logical-xor ,x ,y))) + +(def-source-transform 32bit-logical-orc1 (x y) + `(32bit-logical-or (32bit-logical-not ,x) ,y)) + +(def-source-transform 32bit-logical-orc2 (x y) + `(32bit-logical-or ,x (32bit-logical-not ,y))) + +(def-source-transform 32bit-logical-andc1 (x y) + `(32bit-logical-and (32bit-logical-not ,x) ,y)) + +(def-source-transform 32bit-logical-andc2 (x y) + `(32bit-logical-and ,x (32bit-logical-not ,y))) + +;;; Only the lower 5 bits of the shift amount are significant. +(define-vop (shift-towards-someplace) + (:policy :fast-safe) + (:args (num :scs (unsigned-reg) :target r) + (amount :scs (signed-reg) :target rcx)) + (:arg-types unsigned-num tagged-num) + (:temporary (:sc signed-reg :offset rcx-offset :from (:argument 1)) rcx) + (:results (r :scs (unsigned-reg) :from (:argument 0))) + (:result-types unsigned-num)) + +(define-vop (shift-towards-start shift-towards-someplace) + (:translate shift-towards-start) + (:note "SHIFT-TOWARDS-START") + (:generator 1 + (move r num) + (move rcx amount) + (inst shr r :cl))) + +(define-vop (shift-towards-end shift-towards-someplace) + (:translate shift-towards-end) + (:note "SHIFT-TOWARDS-END") + (:generator 1 + (move r num) + (move rcx amount) + (inst shl r :cl))) + + + +;;;; Bignum stuff. + +(define-vop (bignum-length get-header-data) + (:translate bignum::%bignum-length) + (:policy :fast-safe)) + +(define-vop (bignum-set-length set-header-data) + (:translate bignum::%bignum-set-length) + (:policy :fast-safe)) + +(define-full-reffer bignum-ref * bignum-digits-offset other-pointer-type + (unsigned-reg) unsigned-num bignum::%bignum-ref) + +(define-full-setter bignum-set * bignum-digits-offset other-pointer-type + (unsigned-reg) unsigned-num bignum::%bignum-set) + +(define-vop (digit-0-or-plus) + (:translate bignum::%digit-0-or-plusp) + (:policy :fast-safe) + (:args (digit :scs (unsigned-reg))) + (:arg-types unsigned-num) + (:conditional) + (:info target not-p) + (:generator 3 + (inst or digit digit) + (inst jmp (if not-p :s :ns) target))) + + +;;; For add and sub with carry the sc of carry argument is any-reg so +;;; the it may be passed as a fixnum or word and thus may be 0, 1, or +;;; 4. This is easy to deal with and may save a fixnum-word +;;; conversion. +;;; +(define-vop (add-w/carry) + (:translate bignum::%add-with-carry) + (:policy :fast-safe) + (:args (a :scs (unsigned-reg) :target result) + (b :scs (unsigned-reg unsigned-stack) :to :eval) + (c :scs (any-reg) :target temp)) + (:arg-types unsigned-num unsigned-num positive-fixnum) + (:temporary (:sc any-reg :from (:argument 2) :to :eval) temp) + (:results (result :scs (unsigned-reg) :from (:argument 0)) + (carry :scs (unsigned-reg))) + (:result-types unsigned-num positive-fixnum) + (:generator 4 + (move result a) + (move temp c) + (inst neg temp) ; Set the carry flag to 0 if c=0 else to 1 + (inst adc result b) + (inst mov carry 0) + (inst adc carry carry))) + +;;; Note: the borrow is the oppostite of the x86 convention - 1 for no +;;; borrow and 0 for a borrow. +(define-vop (sub-w/borrow) + (:translate bignum::%subtract-with-borrow) + (:policy :fast-safe) + (:args (a :scs (unsigned-reg) :to :eval :target result) + (b :scs (unsigned-reg unsigned-stack) :to :result) + (c :scs (any-reg control-stack))) + (:arg-types unsigned-num unsigned-num positive-fixnum) + (:results (result :scs (unsigned-reg) :from :eval) + (borrow :scs (unsigned-reg))) + (:result-types unsigned-num positive-fixnum) + (:generator 5 + (inst cmp c 1) ; Set the carry flag to 1 if c=0 else to 0 + (move result a) + (inst sbb result b) + (inst mov borrow 0) + (inst adc borrow borrow) + (inst xor borrow 1))) + + +(define-vop (bignum-mult-and-add-3-arg) + (:translate bignum::%multiply-and-add) + (:policy :fast-safe) + (:args (x :scs (unsigned-reg) :target rax) + (y :scs (unsigned-reg unsigned-stack)) + (carry-in :scs (unsigned-reg unsigned-stack))) + (:arg-types unsigned-num unsigned-num unsigned-num) + (:temporary (:sc unsigned-reg :offset rax-offset :from (:argument 0) + :to (:result 1) :target lo) rax) + (:temporary (:sc unsigned-reg :offset rdx-offset :from (:argument 1) + :to (:result 0) :target hi) rdx) + (:results (hi :scs (unsigned-reg)) + (lo :scs (unsigned-reg))) + (:result-types unsigned-num unsigned-num) + (:generator 20 + (move rax x) + (inst mul rax y) + (inst add rax carry-in) + (inst adc rdx 0) + (move hi rdx) + (move lo rax))) + +(define-vop (bignum-mult-and-add-4-arg) + (:translate bignum::%multiply-and-add) + (:policy :fast-safe) + (:args (x :scs (unsigned-reg) :target rax) + (y :scs (unsigned-reg unsigned-stack)) + (prev :scs (unsigned-reg unsigned-stack)) + (carry-in :scs (unsigned-reg unsigned-stack))) + (:arg-types unsigned-num unsigned-num unsigned-num unsigned-num) + (:temporary (:sc unsigned-reg :offset rax-offset :from (:argument 0) + :to (:result 1) :target lo) rax) + (:temporary (:sc unsigned-reg :offset rdx-offset :from (:argument 1) + :to (:result 0) :target hi) rdx) + (:results (hi :scs (unsigned-reg)) + (lo :scs (unsigned-reg))) + (:result-types unsigned-num unsigned-num) + (:generator 20 + (move rax x) + (inst mul rax y) + (inst add rax prev) + (inst adc rdx 0) + (inst add rax carry-in) + (inst adc rdx 0) + (move hi rdx) + (move lo rax))) + + +(define-vop (bignum-mult) + (:translate bignum::%multiply) + (:policy :fast-safe) + (:args (x :scs (unsigned-reg) :target rax) + (y :scs (unsigned-reg unsigned-stack))) + (:arg-types unsigned-num unsigned-num) + (:temporary (:sc unsigned-reg :offset rax-offset :from (:argument 0) + :to (:result 1) :target lo) rax) + (:temporary (:sc unsigned-reg :offset rdx-offset :from (:argument 1) + :to (:result 0) :target hi) rdx) + (:results (hi :scs (unsigned-reg)) + (lo :scs (unsigned-reg))) + (:result-types unsigned-num unsigned-num) + (:generator 20 + (move rax x) + (inst mul rax y) + (move hi rdx) + (move lo rax))) + +(define-vop (bignum-lognot) + (:translate bignum::%lognot) + (:policy :fast-safe) + (:args (x :scs (unsigned-reg unsigned-stack) :target r)) + (:arg-types unsigned-num) + (:results (r :scs (unsigned-reg) + :load-if (not (location= x r)))) + (:result-types unsigned-num) + (:generator 1 + (move r x) + (inst not r))) + +(define-vop (fixnum-to-digit) + (:translate bignum::%fixnum-to-digit) + (:policy :fast-safe) + (:args (fixnum :scs (any-reg control-stack) :target digit)) + (:arg-types tagged-num) + (:results (digit :scs (unsigned-reg) + :load-if (not (and (sc-is fixnum control-stack) + (sc-is digit unsigned-stack) + (location= fixnum digit))))) + (:result-types unsigned-num) + (:generator 1 + (move digit fixnum) + (inst sar digit 2))) + +(define-vop (bignum-floor) + (:translate bignum::%floor) + (:policy :fast-safe) + (:args (div-high :scs (unsigned-reg) :target rdx) + (div-low :scs (unsigned-reg) :target rax) + (divisor :scs (unsigned-reg unsigned-stack))) + (:arg-types unsigned-num unsigned-num unsigned-num) + (:temporary (:sc unsigned-reg :offset rax-offset :from (:argument 1) + :to (:result 0) :target quo) rax) + (:temporary (:sc unsigned-reg :offset rdx-offset :from (:argument 0) + :to (:result 1) :target rem) rdx) + (:results (quo :scs (unsigned-reg)) + (rem :scs (unsigned-reg))) + (:result-types unsigned-num unsigned-num) + (:generator 300 + (move rdx div-high) + (move rax div-low) + (inst div rax divisor) + (move quo rax) + (move rem rdx))) + +(define-vop (signify-digit) + (:translate bignum::%fixnum-digit-with-correct-sign) + (:policy :fast-safe) + (:args (digit :scs (unsigned-reg unsigned-stack) :target res)) + (:arg-types unsigned-num) + (:results (res :scs (any-reg signed-reg) + :load-if (not (and (sc-is digit unsigned-stack) + (sc-is res control-stack signed-stack) + (location= digit res))))) + (:result-types signed-num) + (:generator 1 + (move res digit) + (when (sc-is res any-reg control-stack) + (inst shl res 2)))) + +(define-vop (digit-ashr) + (:translate bignum::%ashr) + (:policy :fast-safe) + (:args (digit :scs (unsigned-reg unsigned-stack) :target result) + (count :scs (unsigned-reg) :target rcx)) + (:arg-types unsigned-num positive-fixnum) + (:temporary (:sc unsigned-reg :offset rcx-offset :from (:argument 1)) rcx) + (:results (result :scs (unsigned-reg) :from (:argument 0) + :load-if (not (and (sc-is result unsigned-stack) + (location= digit result))))) + (:result-types unsigned-num) + (:generator 1 + (move result digit) + (move rcx count) + (inst sar result :cl))) + +(define-vop (digit-lshr digit-ashr) + (:translate bignum::%digit-logical-shift-right) + (:generator 1 + (move result digit) + (move rcx count) + (inst shr result :cl))) + +(define-vop (digit-ashl digit-ashr) + (:translate bignum::%ashl) + (:generator 1 + (move result digit) + (move rcx count) + (inst shl result :cl))) + + +;;;; Static functions. + +(define-static-function two-arg-/ (x y) :translate /) + +(define-static-function two-arg-gcd (x y) :translate gcd) +(define-static-function two-arg-lcm (x y) :translate lcm) + +(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) + + +;;; Support for the Mersenne Twister, MT19937, random number generator +;;; due to Matsumoto and Nishimura. +;;; +;;; Makoto Matsumoto and T. Nishimura, "Mersenne twister: A +;;; 623-dimensionally equidistributed uniform pseudorandom number +;;; generator.", ACM Transactions on Modeling and Computer Simulation, +;;; 1997, to appear. +;;; +;;; State: +;;; 0-1: Constant matrix A. [0, #x9908b0df] (not used here) +;;; 2: Index; init. to 1. +;;; 3-626: State. +;;; +(defknown random-mt19937 ((simple-array (unsigned-byte 32) (*))) + (unsigned-byte 32) ()) +;;; +(define-vop (random-mt19937) + (:policy :fast-safe) + (:translate random-mt19937) + (:args (state :scs (descriptor-reg) :to :result)) + (:arg-types simple-array-unsigned-byte-32) + (:temporary (:sc unsigned-reg :from (:eval 0) :to :result) k) + (:temporary (:sc unsigned-reg :offset rax-offset + :from (:eval 0) :to :result) tmp) + (:results (y :scs (unsigned-reg) :from (:eval 0))) + (:result-types unsigned-num) + (:generator 50 + (inst mov k (make-ea :qword :base state + :disp (- (* (+ 2 vm:vector-data-offset) vm:word-bytes) + vm:other-pointer-type))) + (inst cmp k 624) + (inst jmp :ne no-update) + (inst mov tmp state) ; The state is passed in rAX. + (inst call (make-fixup 'random-mt19937-update :assembly-routine)) + ;; Restore k, and set to 0. + (inst xor k k) + NO-UPDATE + ;; y = ptgfsr[k++]; + (inst mov y (make-ea :qword :base state :index k :scale 4 + :disp (- (* (+ 3 vm:vector-data-offset) vm:word-bytes) + vm:other-pointer-type))) + ;; y ^= (y >> 11); + (inst shr y 11) + (inst xor y (make-ea :qword :base state :index k :scale 4 + :disp (- (* (+ 3 vm:vector-data-offset) vm:word-bytes) + vm:other-pointer-type))) + ;; y ^= (y << 7) & #x9d2c5680 + (inst mov tmp y) + (inst inc k) + (inst shl tmp 7) + (inst mov (make-ea :qword :base state + :disp (- (* (+ 2 vm:vector-data-offset) vm:word-bytes) + vm:other-pointer-type)) + k) + (inst and tmp #x9d2c5680) + (inst xor y tmp) + ;; y ^= (y << 15) & #xefc60000 + (inst mov tmp y) + (inst shl tmp 15) + (inst and tmp #xefc60000) + (inst xor y tmp) + ;; y ^= (y >> 18); + (inst mov tmp y) + (inst shr tmp 18) + (inst xor y tmp))) diff --git a/compiler/amd64/array.lisp b/compiler/amd64/array.lisp new file mode 100644 index 0000000000000000000000000000000000000000..0bd2ccb182509a26aebb83366307e8838950dfb9 --- /dev/null +++ b/compiler/amd64/array.lisp @@ -0,0 +1,1595 @@ +;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; 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: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/amd64/array.lisp,v 1.1 2004/05/24 22:34:59 cwang Exp $") +;;; +;;; ********************************************************************** +;;; +;;; This file contains the x86 definitions for array operations. +;;; +;;; Written by William Lott +;;; +;;; Debugged by Paul F. Werkowski Spring/Summer 1995. +;;; Enhancements/debugging by Douglas T. Crosher 1996,1997,1998,1999. +;;; +(in-package :amd64) + + +;;;; Allocator for the array header. + + +(define-vop (make-array-header) + (:translate make-array-header) + (:policy :fast-safe) + (:args (type :scs (any-reg)) + (rank :scs (any-reg))) + (:arg-types positive-fixnum positive-fixnum) + (:temporary (:sc any-reg :to :eval) bytes) + (:temporary (:sc any-reg :to :result) header) + (:temporary (:sc any-reg) temp) + (:results (result :scs (descriptor-reg) :from :eval)) + (:node-var node) + (:generator 13 + (inst lea bytes + (make-ea :qword :base rank + :disp (+ (* (1+ array-dimensions-offset) word-bytes) + lowtag-mask))) + (inst and bytes (lognot lowtag-mask)) + (inst lea header (make-ea :qword :base rank + :disp (fixnumize (1- array-dimensions-offset)))) + (inst shl header type-bits) + (inst or header type) + (inst shr header 2) + (pseudo-atomic + (allocation result bytes temp node) + (inst lea result (make-ea :qword :base result :disp other-pointer-type)) + (storew header result 0 other-pointer-type)))) + + +;;;; Additional accessors and setters for the array header. + +(defknown lisp::%array-dimension (t index) index + (flushable)) +(defknown lisp::%set-array-dimension (t index index) index + ()) + +(define-full-reffer %array-dimension * + array-dimensions-offset other-pointer-type + (any-reg) positive-fixnum lisp::%array-dimension) + +(define-full-setter %set-array-dimension * + array-dimensions-offset other-pointer-type + (any-reg) positive-fixnum lisp::%set-array-dimension) + + +(defknown lisp::%array-rank (t) index (flushable)) + +(define-vop (array-rank-vop) + (:translate lisp::%array-rank) + (:policy :fast-safe) + (:args (x :scs (descriptor-reg))) + (:results (res :scs (unsigned-reg))) + (:result-types positive-fixnum) + (:generator 6 + (loadw res x 0 other-pointer-type) + (inst shr res type-bits) + (inst sub res (1- array-dimensions-offset)))) + + + +;;;; Bounds checking routine. + +;;; Note that the immediate SC for the index argument is disabled +;;; because it is not possible to generate a valid error code SC for +;;; an immediate value. +(define-vop (check-bound) + (:translate %check-bound) + (:policy :fast-safe) + (:args (array :scs (descriptor-reg)) + (bound :scs (any-reg descriptor-reg)) + (index :scs (any-reg descriptor-reg #+nil immediate) :target result)) + (:arg-types * positive-fixnum tagged-num) + (:results (result :scs (any-reg descriptor-reg))) + (:result-types positive-fixnum) + (:vop-var vop) + (:save-p :compute-only) + (:generator 5 + (let ((error (generate-error-code vop invalid-array-index-error + array bound index)) + (index (if (sc-is index immediate) (fixnumize (tn-value index)) index))) + (inst cmp bound index) + ;; We use below-or-equal even though it's an unsigned test, because + ;; negative indexes appear as real large unsigned numbers. Therefore, + ;; we get the < 0 and >= bound test all rolled into one. + (inst jmp :be error) + (unless (and (tn-p index) (location= result index)) + (inst mov result index))))) + + +;;;; Accessors/Setters + +;;; Variants built on top of word-index-ref, etc. I.e. those vectors whos +;;; elements are represented in integer registers and are built out of +;;; 8, 16, or 32 bit elements. + +(eval-when (compile eval) + +(defmacro def-full-data-vector-frobs (type element-type &rest scs) + `(progn + (define-full-reffer ,(symbolicate "DATA-VECTOR-REF/" type) ,type + vector-data-offset other-pointer-type ,scs ,element-type + data-vector-ref) + (define-full-setter ,(symbolicate "DATA-VECTOR-SET/" type) ,type + vector-data-offset other-pointer-type ,scs ,element-type + data-vector-set))) + +); eval-when (compile eval) + +(def-full-data-vector-frobs simple-vector * descriptor-reg any-reg) + +(eval-when (compile eval) + +(defmacro def-half-data-vector-frobs (type element-type &rest scs) + `(progn + (define-half-reffer ,(symbolicate "DATA-VECTOR-REF/" type) ,type + vector-data-offset other-pointer-type ,scs ,element-type + data-vector-ref) + (define-half-setter ,(symbolicate "DATA-VECTOR-SET/" type) ,type + vector-data-offset other-pointer-type ,scs ,element-type + data-vector-set))) + +); eval-when (compile eval) + +(def-half-data-vector-frobs simple-array-unsigned-byte-32 unsigned-num + unsigned-reg) +(def-half-data-vector-frobs simple-array-signed-byte-30 tagged-num any-reg) +(def-half-data-vector-frobs simple-array-signed-byte-32 signed-num signed-reg) + +;;; Integer vectors whos elements are smaller than a byte. I.e. bit, 2-bit, +;;; and 4-bit vectors. +;;; + +(eval-when (compile eval) + +(defmacro def-small-data-vector-frobs (type bits) + (let* ((elements-per-word (floor vm:word-bits bits)) + (bit-shift (1- (integer-length elements-per-word)))) + `(progn + (define-vop (,(symbolicate 'data-vector-ref/ type)) + (:note "inline array access") + (:translate data-vector-ref) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (unsigned-reg))) + (:arg-types ,type positive-fixnum) + (:results (result :scs (unsigned-reg) :from (:argument 0))) + (:result-types positive-fixnum) + (:temporary (:sc unsigned-reg :offset rcx-offset) rcx) + (:generator 20 + (move rcx index) + (inst shr rcx ,bit-shift) + (inst mov result + (make-ea :qword :base object :index rcx :scale 4 + :disp (- (* vector-data-offset word-bytes) + other-pointer-type))) + (move rcx index) + (inst and rcx ,(1- elements-per-word)) + ,@(unless (= bits 1) + `((inst shl rcx ,(1- (integer-length bits))))) + (inst shr result :cl) + (inst and result ,(1- (ash 1 bits))))) + (define-vop (,(symbolicate 'data-vector-ref-c/ type)) + (:translate data-vector-ref) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg))) + (:arg-types ,type (:constant index)) + (:info index) + (:results (result :scs (unsigned-reg))) + (:result-types positive-fixnum) + (:generator 15 + (multiple-value-bind (word extra) (floor index ,elements-per-word) + (loadw result object (+ word vector-data-offset) + other-pointer-type) + (unless (zerop extra) + (inst shr result (* extra ,bits))) + (unless (= extra ,(1- elements-per-word)) + (inst and result ,(1- (ash 1 bits))))))) + (define-vop (,(symbolicate 'data-vector-set/ type)) + (:note "inline array store") + (:translate data-vector-set) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg) :target ptr) + (index :scs (unsigned-reg) :target rcx) + (value :scs (unsigned-reg immediate) :target result)) + (:arg-types ,type positive-fixnum positive-fixnum) + (:results (result :scs (unsigned-reg))) + (:result-types positive-fixnum) + (:temporary (:sc unsigned-reg) word-index) + (:temporary (:sc unsigned-reg :from (:argument 0)) ptr old) + (:temporary (:sc unsigned-reg :offset rcx-offset :from (:argument 1)) + rcx) + (:generator 25 + (move word-index index) + (inst shr word-index ,bit-shift) + (inst lea ptr + (make-ea :qword :base object :index word-index :scale 4 + :disp (- (* vector-data-offset word-bytes) + other-pointer-type))) + (loadw old ptr) + (move rcx index) + (inst and rcx ,(1- elements-per-word)) + ,@(unless (= bits 1) + `((inst shl rcx ,(1- (integer-length bits))))) + (inst ror old :cl) + (unless (and (sc-is value immediate) + (= (tn-value value) ,(1- (ash 1 bits)))) + (inst and old ,(lognot (1- (ash 1 bits))))) + (sc-case value + (immediate + (unless (zerop (tn-value value)) + (inst or old (logand (tn-value value) ,(1- (ash 1 bits)))))) + (unsigned-reg + (inst or old value))) + (inst rol old :cl) + (storew old ptr) + (sc-case value + (immediate + (inst mov result (tn-value value))) + (unsigned-reg + (move result value))))) + (define-vop (,(symbolicate 'data-vector-set-c/ type)) + (:translate data-vector-set) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (value :scs (unsigned-reg immediate) :target result)) + (:arg-types ,type (:constant index) positive-fixnum) + (:info index) + (:results (result :scs (unsigned-reg))) + (:result-types positive-fixnum) + (:temporary (:sc unsigned-reg :to (:result 0)) old) + (:generator 20 + (multiple-value-bind (word extra) (floor index ,elements-per-word) + (inst mov old + (make-ea :qword :base object + :disp (- (* (+ word vector-data-offset) word-bytes) + other-pointer-type))) + (sc-case value + (immediate + (let* ((value (tn-value value)) + (mask ,(1- (ash 1 bits))) + (shift (* extra ,bits))) + (unless (= value mask) + (inst and old (lognot (ash mask shift)))) + (unless (zerop value) + (inst or old (ash value shift))))) + (unsigned-reg + (let ((shift (* extra ,bits))) + (unless (zerop shift) + (inst ror old shift) + (inst and old (lognot ,(1- (ash 1 bits)))) + (inst or old value) + (inst rol old shift))))) + (inst mov (make-ea :qword :base object + :disp (- (* (+ word vector-data-offset) word-bytes) + other-pointer-type)) + old) + (sc-case value + (immediate + (inst mov result (tn-value value))) + (unsigned-reg + (move result value))))))))) + + +); eval-when (compile eval) + +(def-small-data-vector-frobs simple-bit-vector 1) +(def-small-data-vector-frobs simple-array-unsigned-byte-2 2) +(def-small-data-vector-frobs simple-array-unsigned-byte-4 4) + +;;; And the float variants. +;;; + +(define-vop (data-vector-ref/simple-array-single-float) + (:note "inline array access") + (:translate data-vector-ref) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg))) + (:arg-types simple-array-single-float positive-fixnum) + (:results (value :scs (single-reg))) + (:result-types single-float) + (:generator 5 + (with-empty-tn@fp-top(value) + (inst fld (make-ea :qword :base object :index index :scale 1 + :disp (- (* vm:vector-data-offset vm:word-bytes) + vm:other-pointer-type)))))) + +(define-vop (data-vector-ref-c/simple-array-single-float) + (:note "inline array access") + (:translate data-vector-ref) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg))) + (:info index) + (:arg-types simple-array-single-float (:constant (signed-byte 30))) + (:results (value :scs (single-reg))) + (:result-types single-float) + (:generator 4 + (with-empty-tn@fp-top(value) + (inst fld (make-ea :qword :base object + :disp (- (+ (* vm:vector-data-offset vm:word-bytes) + (* 4 index)) + vm:other-pointer-type)))))) + +(define-vop (data-vector-set/simple-array-single-float) + (:note "inline array store") + (:translate data-vector-set) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg)) + (value :scs (single-reg) :target result)) + (:arg-types simple-array-single-float positive-fixnum single-float) + (:results (result :scs (single-reg))) + (:result-types single-float) + (:generator 5 + (cond ((zerop (tn-offset value)) + ;; Value is in ST0 + (inst fst (make-ea :qword :base object :index index :scale 1 + :disp (- (* vm:vector-data-offset vm:word-bytes) + vm:other-pointer-type))) + (unless (zerop (tn-offset result)) + ;; Value is in ST0 but not result. + (inst fst result))) + (t + ;; Value is not in ST0. + (inst fxch value) + (inst fst (make-ea :qword :base object :index index :scale 1 + :disp (- (* vm:vector-data-offset vm:word-bytes) + vm:other-pointer-type))) + (cond ((zerop (tn-offset result)) + ;; The result is in ST0. + (inst fst value)) + (t + ;; Neither value or result are in ST0 + (unless (location= value result) + (inst fst result)) + (inst fxch value))))))) + +(define-vop (data-vector-set-c/simple-array-single-float) + (:note "inline array store") + (:translate data-vector-set) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (value :scs (single-reg) :target result)) + (:info index) + (:arg-types simple-array-single-float (:constant (signed-byte 30)) + single-float) + (:results (result :scs (single-reg))) + (:result-types single-float) + (:generator 4 + (cond ((zerop (tn-offset value)) + ;; Value is in ST0 + (inst fst (make-ea :qword :base object + :disp (- (+ (* vm:vector-data-offset + vm:word-bytes) + (* 4 index)) + vm:other-pointer-type))) + (unless (zerop (tn-offset result)) + ;; Value is in ST0 but not result. + (inst fst result))) + (t + ;; Value is not in ST0. + (inst fxch value) + (inst fst (make-ea :qword :base object + :disp (- (+ (* vm:vector-data-offset + vm:word-bytes) + (* 4 index)) + vm:other-pointer-type))) + (cond ((zerop (tn-offset result)) + ;; The result is in ST0. + (inst fst value)) + (t + ;; Neither value or result are in ST0 + (unless (location= value result) + (inst fst result)) + (inst fxch value))))))) + +(define-vop (data-vector-ref/simple-array-double-float) + (:note "inline array access") + (:translate data-vector-ref) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg))) + (:arg-types simple-array-double-float positive-fixnum) + (:results (value :scs (double-reg))) + (:result-types double-float) + (:generator 7 + (with-empty-tn@fp-top(value) + (inst fldd (make-ea :qword :base object :index index :scale 2 + :disp (- (* vm:vector-data-offset vm:word-bytes) + vm:other-pointer-type)))))) + +(define-vop (data-vector-ref-c/simple-array-double-float) + (:note "inline array access") + (:translate data-vector-ref) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg))) + (:info index) + (:arg-types simple-array-double-float (:constant (signed-byte 30))) + (:results (value :scs (double-reg))) + (:result-types double-float) + (:generator 6 + (with-empty-tn@fp-top(value) + (inst fldd (make-ea :qword :base object + :disp (- (+ (* vm:vector-data-offset vm:word-bytes) + (* 8 index)) + vm:other-pointer-type)))))) + +(define-vop (data-vector-set/simple-array-double-float) + (:note "inline array store") + (:translate data-vector-set) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg)) + (value :scs (double-reg) :target result)) + (:arg-types simple-array-double-float positive-fixnum double-float) + (:results (result :scs (double-reg))) + (:result-types double-float) + (:generator 20 + (cond ((zerop (tn-offset value)) + ;; Value is in ST0 + (inst fstd (make-ea :qword :base object :index index :scale 2 + :disp (- (* vm:vector-data-offset vm:word-bytes) + vm:other-pointer-type))) + (unless (zerop (tn-offset result)) + ;; Value is in ST0 but not result. + (inst fstd result))) + (t + ;; Value is not in ST0. + (inst fxch value) + (inst fstd (make-ea :qword :base object :index index :scale 2 + :disp (- (* vm:vector-data-offset vm:word-bytes) + vm:other-pointer-type))) + (cond ((zerop (tn-offset result)) + ;; The result is in ST0. + (inst fstd value)) + (t + ;; Neither value or result are in ST0 + (unless (location= value result) + (inst fstd result)) + (inst fxch value))))))) + + +(define-vop (data-vector-set-c/simple-array-double-float) + (:note "inline array store") + (:translate data-vector-set) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (value :scs (double-reg) :target result)) + (:info index) + (:arg-types simple-array-double-float (:constant (signed-byte 30)) + double-float) + (:results (result :scs (double-reg))) + (:result-types double-float) + (:generator 19 + (cond ((zerop (tn-offset value)) + ;; Value is in ST0 + (inst fstd (make-ea :qword :base object + :disp (- (+ (* vm:vector-data-offset + vm:word-bytes) + (* 8 index)) + vm:other-pointer-type))) + (unless (zerop (tn-offset result)) + ;; Value is in ST0 but not result. + (inst fstd result))) + (t + ;; Value is not in ST0. + (inst fxch value) + (inst fstd (make-ea :qword :base object + :disp (- (+ (* vm:vector-data-offset + vm:word-bytes) + (* 8 index)) + vm:other-pointer-type))) + (cond ((zerop (tn-offset result)) + ;; The result is in ST0. + (inst fstd value)) + (t + ;; Neither value or result are in ST0 + (unless (location= value result) + (inst fstd result)) + (inst fxch value))))))) + + +#+long-float +(define-vop (data-vector-ref/simple-array-long-float) + (:note "inline array access") + (:translate data-vector-ref) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg) :to :result) + (index :scs (any-reg))) + (:arg-types simple-array-long-float positive-fixnum) + (:temporary (:sc any-reg :from :eval :to :result) temp) + (:results (value :scs (long-reg))) + (:result-types long-float) + (:generator 7 + ;; temp = 3 * index + (inst lea temp (make-ea :qword :base index :index index :scale 2)) + (with-empty-tn@fp-top(value) + (inst fldl (make-ea :qword :base object :index temp :scale 1 + :disp (- (* vm:vector-data-offset vm:word-bytes) + vm:other-pointer-type)))))) + +#+long-float +(define-vop (data-vector-ref-c/simple-array-long-float) + (:note "inline array access") + (:translate data-vector-ref) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg))) + (:info index) + (:arg-types simple-array-long-float (:constant (signed-byte 30))) + (:results (value :scs (long-reg))) + (:result-types long-float) + (:generator 6 + (with-empty-tn@fp-top(value) + (inst fldl (make-ea :qword :base object + :disp (- (+ (* vm:vector-data-offset vm:word-bytes) + (* 12 index)) + vm:other-pointer-type)))))) + +#+long-float +(define-vop (data-vector-set/simple-array-long-float) + (:note "inline array store") + (:translate data-vector-set) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg) :to :result) + (index :scs (any-reg)) + (value :scs (long-reg) :target result)) + (:arg-types simple-array-long-float positive-fixnum long-float) + (:temporary (:sc any-reg :from (:argument 1) :to :result) temp) + (:results (result :scs (long-reg))) + (:result-types long-float) + (:generator 20 + ;; temp = 3 * index + (inst lea temp (make-ea :qword :base index :index index :scale 2)) + (cond ((zerop (tn-offset value)) + ;; Value is in ST0 + (store-long-float + (make-ea :qword :base object :index temp :scale 1 + :disp (- (* vm:vector-data-offset vm:word-bytes) + vm:other-pointer-type))) + (unless (zerop (tn-offset result)) + ;; Value is in ST0 but not result. + (inst fstd result))) + (t + ;; Value is not in ST0. + (inst fxch value) + (store-long-float + (make-ea :qword :base object :index temp :scale 1 + :disp (- (* vm:vector-data-offset vm:word-bytes) + vm:other-pointer-type))) + (cond ((zerop (tn-offset result)) + ;; The result is in ST0. + (inst fstd value)) + (t + ;; Neither value or result are in ST0 + (unless (location= value result) + (inst fstd result)) + (inst fxch value))))))) + +#+long-float +(define-vop (data-vector-set-c/simple-array-long-float) + (:note "inline array store") + (:translate data-vector-set) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (value :scs (long-reg) :target result)) + (:info index) + (:arg-types simple-array-long-float (:constant (signed-byte 30)) long-float) + (:results (result :scs (long-reg))) + (:result-types long-float) + (:generator 19 + (cond ((zerop (tn-offset value)) + ;; Value is in ST0 + (store-long-float (make-ea :qword :base object + :disp (- (+ (* vm:vector-data-offset + vm:word-bytes) + (* 12 index)) + vm:other-pointer-type))) + (unless (zerop (tn-offset result)) + ;; Value is in ST0 but not result. + (inst fstd result))) + (t + ;; Value is not in ST0. + (inst fxch value) + (store-long-float (make-ea :qword :base object + :disp (- (+ (* vm:vector-data-offset + vm:word-bytes) + (* 12 index)) + vm:other-pointer-type))) + (cond ((zerop (tn-offset result)) + ;; The result is in ST0. + (inst fstd value)) + (t + ;; Neither value or result are in ST0 + (unless (location= value result) + (inst fstd result)) + (inst fxch value))))))) + +;;; Complex float variants. +(define-vop (data-vector-ref/simple-array-complex-single-float) + (:note "inline array access") + (:translate data-vector-ref) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg))) + (:arg-types simple-array-complex-single-float positive-fixnum) + (:results (value :scs (complex-single-reg))) + (:result-types complex-single-float) + (:generator 5 + (let ((real-tn (complex-single-reg-real-tn value))) + (with-empty-tn@fp-top (real-tn) + (inst fld (make-ea :qword :base object :index index :scale 2 + :disp (- (* vm:vector-data-offset vm:word-bytes) + vm:other-pointer-type))))) + (let ((imag-tn (complex-single-reg-imag-tn value))) + (with-empty-tn@fp-top (imag-tn) + (inst fld (make-ea :qword :base object :index index :scale 2 + :disp (- (* (1+ vm:vector-data-offset) + vm:word-bytes) + vm:other-pointer-type))))))) + +(define-vop (data-vector-ref-c/simple-array-complex-single-float) + (:note "inline array access") + (:translate data-vector-ref) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg))) + (:info index) + (:arg-types simple-array-complex-single-float (:constant (signed-byte 30))) + (:results (value :scs (complex-single-reg))) + (:result-types complex-single-float) + (:generator 4 + (let ((real-tn (complex-single-reg-real-tn value))) + (with-empty-tn@fp-top (real-tn) + (inst fld (make-ea :qword :base object + :disp (- (+ (* vm:vector-data-offset vm:word-bytes) + (* 8 index)) + vm:other-pointer-type))))) + (let ((imag-tn (complex-single-reg-imag-tn value))) + (with-empty-tn@fp-top (imag-tn) + (inst fld (make-ea :qword :base object + :disp (- (+ (* vm:vector-data-offset vm:word-bytes) + (* 8 index) 4) + vm:other-pointer-type))))))) + +(define-vop (data-vector-set/simple-array-complex-single-float) + (:note "inline array store") + (:translate data-vector-set) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg)) + (value :scs (complex-single-reg) :target result)) + (:arg-types simple-array-complex-single-float positive-fixnum + complex-single-float) + (:results (result :scs (complex-single-reg))) + (:result-types complex-single-float) + (:generator 5 + (let ((value-real (complex-single-reg-real-tn value)) + (result-real (complex-single-reg-real-tn result))) + (cond ((zerop (tn-offset value-real)) + ;; Value is in ST0 + (inst fst (make-ea :qword :base object :index index :scale 2 + :disp (- (* vm:vector-data-offset + vm:word-bytes) + vm:other-pointer-type))) + (unless (zerop (tn-offset result-real)) + ;; Value is in ST0 but not result. + (inst fst result-real))) + (t + ;; Value is not in ST0. + (inst fxch value-real) + (inst fst (make-ea :qword :base object :index index :scale 2 + :disp (- (* vm:vector-data-offset + vm:word-bytes) + vm:other-pointer-type))) + (cond ((zerop (tn-offset result-real)) + ;; The result is in ST0. + (inst fst value-real)) + (t + ;; Neither value or result are in ST0 + (unless (location= value-real result-real) + (inst fst result-real)) + (inst fxch value-real)))))) + (let ((value-imag (complex-single-reg-imag-tn value)) + (result-imag (complex-single-reg-imag-tn result))) + (inst fxch value-imag) + (inst fst (make-ea :qword :base object :index index :scale 2 + :disp (- (+ (* vm:vector-data-offset vm:word-bytes) + 4) + vm:other-pointer-type))) + (unless (location= value-imag result-imag) + (inst fst result-imag)) + (inst fxch value-imag)))) + +(define-vop (data-vector-set-c/simple-array-complex-single-float) + (:note "inline array store") + (:translate data-vector-set) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (value :scs (complex-single-reg) :target result)) + (:info index) + (:arg-types simple-array-complex-single-float (:constant (signed-byte 30)) + complex-single-float) + (:results (result :scs (complex-single-reg))) + (:result-types complex-single-float) + (:generator 4 + (let ((value-real (complex-single-reg-real-tn value)) + (result-real (complex-single-reg-real-tn result))) + (cond ((zerop (tn-offset value-real)) + ;; Value is in ST0 + (inst fst (make-ea :qword :base object + :disp (- (+ (* vm:vector-data-offset + vm:word-bytes) + (* 8 index)) + vm:other-pointer-type))) + (unless (zerop (tn-offset result-real)) + ;; Value is in ST0 but not result. + (inst fst result-real))) + (t + ;; Value is not in ST0. + (inst fxch value-real) + (inst fst (make-ea :qword :base object + :disp (- (+ (* vm:vector-data-offset + vm:word-bytes) + (* 8 index)) + vm:other-pointer-type))) + (cond ((zerop (tn-offset result-real)) + ;; The result is in ST0. + (inst fst value-real)) + (t + ;; Neither value or result are in ST0 + (unless (location= value-real result-real) + (inst fst result-real)) + (inst fxch value-real)))))) + (let ((value-imag (complex-single-reg-imag-tn value)) + (result-imag (complex-single-reg-imag-tn result))) + (inst fxch value-imag) + (inst fst (make-ea :qword :base object + :disp (- (+ (* vm:vector-data-offset vm:word-bytes) + (* 8 index) 4) + vm:other-pointer-type))) + (unless (location= value-imag result-imag) + (inst fst result-imag)) + (inst fxch value-imag)))) + + +(define-vop (data-vector-ref/simple-array-complex-double-float) + (:note "inline array access") + (:translate data-vector-ref) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg))) + (:arg-types simple-array-complex-double-float positive-fixnum) + (:results (value :scs (complex-double-reg))) + (:result-types complex-double-float) + (:generator 7 + (let ((real-tn (complex-double-reg-real-tn value))) + (with-empty-tn@fp-top (real-tn) + (inst fldd (make-ea :qword :base object :index index :scale 4 + :disp (- (* vm:vector-data-offset vm:word-bytes) + vm:other-pointer-type))))) + (let ((imag-tn (complex-double-reg-imag-tn value))) + (with-empty-tn@fp-top (imag-tn) + (inst fldd (make-ea :qword :base object :index index :scale 4 + :disp (- (+ (* vm:vector-data-offset vm:word-bytes) + 8) + vm:other-pointer-type))))))) + +(define-vop (data-vector-ref-c/simple-array-complex-double-float) + (:note "inline array access") + (:translate data-vector-ref) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg))) + (:info index) + (:arg-types simple-array-complex-double-float (:constant (signed-byte 30))) + (:results (value :scs (complex-double-reg))) + (:result-types complex-double-float) + (:generator 6 + (let ((real-tn (complex-double-reg-real-tn value))) + (with-empty-tn@fp-top (real-tn) + (inst fldd (make-ea :qword :base object + :disp (- (+ (* vm:vector-data-offset vm:word-bytes) + (* 16 index)) + vm:other-pointer-type))))) + (let ((imag-tn (complex-double-reg-imag-tn value))) + (with-empty-tn@fp-top (imag-tn) + (inst fldd (make-ea :qword :base object + :disp (- (+ (* vm:vector-data-offset vm:word-bytes) + (* 16 index) 8) + vm:other-pointer-type))))))) + +(define-vop (data-vector-set/simple-array-complex-double-float) + (:note "inline array store") + (:translate data-vector-set) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg)) + (value :scs (complex-double-reg) :target result)) + (:arg-types simple-array-complex-double-float positive-fixnum + complex-double-float) + (:results (result :scs (complex-double-reg))) + (:result-types complex-double-float) + (:generator 20 + (let ((value-real (complex-double-reg-real-tn value)) + (result-real (complex-double-reg-real-tn result))) + (cond ((zerop (tn-offset value-real)) + ;; Value is in ST0 + (inst fstd (make-ea :qword :base object :index index :scale 4 + :disp (- (* vm:vector-data-offset + vm:word-bytes) + vm:other-pointer-type))) + (unless (zerop (tn-offset result-real)) + ;; Value is in ST0 but not result. + (inst fstd result-real))) + (t + ;; Value is not in ST0. + (inst fxch value-real) + (inst fstd (make-ea :qword :base object :index index :scale 4 + :disp (- (* vm:vector-data-offset + vm:word-bytes) + vm:other-pointer-type))) + (cond ((zerop (tn-offset result-real)) + ;; The result is in ST0. + (inst fstd value-real)) + (t + ;; Neither value or result are in ST0 + (unless (location= value-real result-real) + (inst fstd result-real)) + (inst fxch value-real)))))) + (let ((value-imag (complex-double-reg-imag-tn value)) + (result-imag (complex-double-reg-imag-tn result))) + (inst fxch value-imag) + (inst fstd (make-ea :qword :base object :index index :scale 4 + :disp (- (+ (* vm:vector-data-offset vm:word-bytes) + 8) + vm:other-pointer-type))) + (unless (location= value-imag result-imag) + (inst fstd result-imag)) + (inst fxch value-imag)))) + +(define-vop (data-vector-set-c/simple-array-complex-double-float) + (:note "inline array store") + (:translate data-vector-set) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (value :scs (complex-double-reg) :target result)) + (:info index) + (:arg-types simple-array-complex-double-float (:constant (signed-byte 30)) + complex-double-float) + (:results (result :scs (complex-double-reg))) + (:result-types complex-double-float) + (:generator 19 + (let ((value-real (complex-double-reg-real-tn value)) + (result-real (complex-double-reg-real-tn result))) + (cond ((zerop (tn-offset value-real)) + ;; Value is in ST0 + (inst fstd (make-ea :qword :base object + :disp (- (+ (* vm:vector-data-offset + vm:word-bytes) + (* 16 index)) + vm:other-pointer-type))) + (unless (zerop (tn-offset result-real)) + ;; Value is in ST0 but not result. + (inst fstd result-real))) + (t + ;; Value is not in ST0. + (inst fxch value-real) + (inst fstd (make-ea :qword :base object + :disp (- (+ (* vm:vector-data-offset + vm:word-bytes) + (* 16 index)) + vm:other-pointer-type))) + (cond ((zerop (tn-offset result-real)) + ;; The result is in ST0. + (inst fstd value-real)) + (t + ;; Neither value or result are in ST0 + (unless (location= value-real result-real) + (inst fstd result-real)) + (inst fxch value-real)))))) + (let ((value-imag (complex-double-reg-imag-tn value)) + (result-imag (complex-double-reg-imag-tn result))) + (inst fxch value-imag) + (inst fstd (make-ea :qword :base object + :disp (- (+ (* vm:vector-data-offset vm:word-bytes) + (* 16 index) 8) + vm:other-pointer-type))) + (unless (location= value-imag result-imag) + (inst fstd result-imag)) + (inst fxch value-imag)))) + + +#+long-float +(define-vop (data-vector-ref/simple-array-complex-long-float) + (:note "inline array access") + (:translate data-vector-ref) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg) :to :result) + (index :scs (any-reg))) + (:arg-types simple-array-complex-long-float positive-fixnum) + (:temporary (:sc any-reg :from :eval :to :result) temp) + (:results (value :scs (complex-long-reg))) + (:result-types complex-long-float) + (:generator 7 + ;; temp = 3 * index + (inst lea temp (make-ea :qword :base index :index index :scale 2)) + (let ((real-tn (complex-long-reg-real-tn value))) + (with-empty-tn@fp-top (real-tn) + (inst fldl (make-ea :qword :base object :index temp :scale 2 + :disp (- (* vm:vector-data-offset vm:word-bytes) + vm:other-pointer-type))))) + (let ((imag-tn (complex-long-reg-imag-tn value))) + (with-empty-tn@fp-top (imag-tn) + (inst fldl (make-ea :qword :base object :index temp :scale 2 + :disp (- (+ (* vm:vector-data-offset vm:word-bytes) + 12) + vm:other-pointer-type))))))) + +#+long-float +(define-vop (data-vector-ref-c/simple-array-complex-long-float) + (:note "inline array access") + (:translate data-vector-ref) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg))) + (:info index) + (:arg-types simple-array-complex-long-float (:constant (signed-byte 30))) + (:results (value :scs (complex-long-reg))) + (:result-types complex-long-float) + (:generator 6 + (let ((real-tn (complex-long-reg-real-tn value))) + (with-empty-tn@fp-top (real-tn) + (inst fldl (make-ea :qword :base object + :disp (- (+ (* vm:vector-data-offset vm:word-bytes) + (* 24 index)) + vm:other-pointer-type))))) + (let ((imag-tn (complex-long-reg-imag-tn value))) + (with-empty-tn@fp-top (imag-tn) + (inst fldl (make-ea :qword :base object + :disp (- (+ (* vm:vector-data-offset vm:word-bytes) + (* 24 index) 12) + vm:other-pointer-type))))))) + +#+long-float +(define-vop (data-vector-set/simple-array-complex-long-float) + (:note "inline array store") + (:translate data-vector-set) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg) :to :result) + (index :scs (any-reg)) + (value :scs (complex-long-reg) :target result)) + (:arg-types simple-array-complex-long-float positive-fixnum + complex-long-float) + (:temporary (:sc any-reg :from (:argument 1) :to :result) temp) + (:results (result :scs (complex-long-reg))) + (:result-types complex-long-float) + (:generator 20 + ;; temp = 3 * index + (inst lea temp (make-ea :qword :base index :index index :scale 2)) + (let ((value-real (complex-long-reg-real-tn value)) + (result-real (complex-long-reg-real-tn result))) + (cond ((zerop (tn-offset value-real)) + ;; Value is in ST0 + (store-long-float + (make-ea :qword :base object :index temp :scale 2 + :disp (- (* vm:vector-data-offset vm:word-bytes) + vm:other-pointer-type))) + (unless (zerop (tn-offset result-real)) + ;; Value is in ST0 but not result. + (inst fstd result-real))) + (t + ;; Value is not in ST0. + (inst fxch value-real) + (store-long-float + (make-ea :qword :base object :index temp :scale 2 + :disp (- (* vm:vector-data-offset vm:word-bytes) + vm:other-pointer-type))) + (cond ((zerop (tn-offset result-real)) + ;; The result is in ST0. + (inst fstd value-real)) + (t + ;; Neither value or result are in ST0 + (unless (location= value-real result-real) + (inst fstd result-real)) + (inst fxch value-real)))))) + (let ((value-imag (complex-long-reg-imag-tn value)) + (result-imag (complex-long-reg-imag-tn result))) + (inst fxch value-imag) + (store-long-float + (make-ea :qword :base object :index temp :scale 2 + :disp (- (+ (* vm:vector-data-offset vm:word-bytes) 12) + vm:other-pointer-type))) + (unless (location= value-imag result-imag) + (inst fstd result-imag)) + (inst fxch value-imag)))) + +#+long-float +(define-vop (data-vector-set-c/simple-array-complex-long-float) + (:note "inline array store") + (:translate data-vector-set) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (value :scs (complex-long-reg) :target result)) + (:info index) + (:arg-types simple-array-complex-long-float (:constant (signed-byte 30)) + complex-long-float) + (:results (result :scs (complex-long-reg))) + (:result-types complex-long-float) + (:generator 19 + (let ((value-real (complex-long-reg-real-tn value)) + (result-real (complex-long-reg-real-tn result))) + (cond ((zerop (tn-offset value-real)) + ;; Value is in ST0 + (store-long-float + (make-ea :qword :base object + :disp (- (+ (* vm:vector-data-offset vm:word-bytes) + (* 24 index)) + vm:other-pointer-type))) + (unless (zerop (tn-offset result-real)) + ;; Value is in ST0 but not result. + (inst fstd result-real))) + (t + ;; Value is not in ST0. + (inst fxch value-real) + (store-long-float + (make-ea :qword :base object + :disp (- (+ (* vm:vector-data-offset vm:word-bytes) + (* 24 index)) + vm:other-pointer-type))) + (cond ((zerop (tn-offset result-real)) + ;; The result is in ST0. + (inst fstd value-real)) + (t + ;; Neither value or result are in ST0 + (unless (location= value-real result-real) + (inst fstd result-real)) + (inst fxch value-real)))))) + (let ((value-imag (complex-long-reg-imag-tn value)) + (result-imag (complex-long-reg-imag-tn result))) + (inst fxch value-imag) + (store-long-float + (make-ea :qword :base object + :disp (- (+ (* vm:vector-data-offset vm:word-bytes) + (* 24 index) 12) + vm:other-pointer-type))) + (unless (location= value-imag result-imag) + (inst fstd result-imag)) + (inst fxch value-imag)))) + + +;;;; +;;;; dtc expanded and fixed the following: + + + +;;; unsigned-byte-8 + +(define-vop (data-vector-ref/simple-array-unsigned-byte-8) + (:translate data-vector-ref) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (unsigned-reg))) + (:arg-types simple-array-unsigned-byte-8 positive-fixnum) + (:results (value :scs (unsigned-reg signed-reg))) + (:result-types positive-fixnum) + (:generator 5 + (inst movzx value + (make-ea :byte :base object :index index :scale 1 + :disp (- (* vector-data-offset word-bytes) + other-pointer-type))))) + + +(define-vop (data-vector-ref-c/simple-array-unsigned-byte-8) + (:translate data-vector-ref) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg))) + (:info index) + (:arg-types simple-array-unsigned-byte-8 (:constant (signed-byte 30))) + (:results (value :scs (unsigned-reg signed-reg))) + (:result-types positive-fixnum) + (:generator 4 + (inst movzx value + (make-ea :byte :base object + :disp (- (+ (* vector-data-offset word-bytes) index) + other-pointer-type))))) + + +(define-vop (data-vector-set/simple-array-unsigned-byte-8) + (:translate data-vector-set) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg) :to (:eval 0)) + (index :scs (unsigned-reg) :to (:eval 0)) + (value :scs (unsigned-reg signed-reg) :target rax)) + (:arg-types simple-array-unsigned-byte-8 positive-fixnum positive-fixnum) + (:temporary (:sc unsigned-reg :offset rax-offset :target result + :from (:argument 2) :to (:result 0)) + rax) + (:results (result :scs (unsigned-reg signed-reg))) + (:result-types positive-fixnum) + (:generator 5 + (move rax value) + (inst mov (make-ea :byte :base object :index index :scale 1 + :disp (- (* vector-data-offset word-bytes) + other-pointer-type)) + al-tn) + (move result rax))) + + +(define-vop (data-vector-set-c/simple-array-unsigned-byte-8) + (:translate data-vector-set) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg) :to (:eval 0)) + (value :scs (unsigned-reg signed-reg) :target rax)) + (:info index) + (:arg-types simple-array-unsigned-byte-8 (:constant (signed-byte 30)) + positive-fixnum) + (:temporary (:sc unsigned-reg :offset rax-offset :target result + :from (:argument 1) :to (:result 0)) + rax) + (:results (result :scs (unsigned-reg signed-reg))) + (:result-types positive-fixnum) + (:generator 4 + (move rax value) + (inst mov (make-ea :byte :base object + :disp (- (+ (* vector-data-offset word-bytes) index) + other-pointer-type)) + al-tn) + (move result rax))) + + +;;; unsigned-byte-16 + +(define-vop (data-vector-ref/simple-array-unsigned-byte-16) + (:translate data-vector-ref) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (unsigned-reg))) + (:arg-types simple-array-unsigned-byte-16 positive-fixnum) + (:results (value :scs (unsigned-reg signed-reg))) + (:result-types positive-fixnum) + (:generator 5 + (inst movzx value + (make-ea :word :base object :index index :scale 2 + :disp (- (* vector-data-offset word-bytes) + other-pointer-type))))) + + +(define-vop (data-vector-ref-c/simple-array-unsigned-byte-16) + (:translate data-vector-ref) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg))) + (:info index) + (:arg-types simple-array-unsigned-byte-16 (:constant (signed-byte 30))) + (:results (value :scs (unsigned-reg signed-reg))) + (:result-types positive-fixnum) + (:generator 4 + (inst movzx value + (make-ea :word :base object + :disp (- (+ (* vector-data-offset word-bytes) (* 2 index)) + other-pointer-type))))) + + +(define-vop (data-vector-set/simple-array-unsigned-byte-16) + (:translate data-vector-set) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg) :to (:eval 0)) + (index :scs (unsigned-reg) :to (:eval 0)) + (value :scs (unsigned-reg signed-reg) :target rax)) + (:arg-types simple-array-unsigned-byte-16 positive-fixnum positive-fixnum) + (:temporary (:sc unsigned-reg :offset rax-offset :target result + :from (:argument 2) :to (:result 0)) + rax) + (:results (result :scs (unsigned-reg signed-reg))) + (:result-types positive-fixnum) + (:generator 5 + (move rax value) + (inst mov (make-ea :word :base object :index index :scale 2 + :disp (- (* vector-data-offset word-bytes) + other-pointer-type)) + ax-tn) + (move result rax))) + + +(define-vop (data-vector-set-c/simple-array-unsigned-byte-16) + (:translate data-vector-set) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg) :to (:eval 0)) + (value :scs (unsigned-reg signed-reg) :target rax)) + (:info index) + (:arg-types simple-array-unsigned-byte-16 (:constant (signed-byte 30)) + positive-fixnum) + (:temporary (:sc unsigned-reg :offset rax-offset :target result + :from (:argument 1) :to (:result 0)) + rax) + (:results (result :scs (unsigned-reg signed-reg))) + (:result-types positive-fixnum) + (:generator 4 + (move rax value) + (inst mov (make-ea :word :base object + :disp (- (+ (* vector-data-offset word-bytes) + (* 2 index)) + other-pointer-type)) + ax-tn) + (move result rax))) + + +;;; simple-string + +(define-vop (data-vector-ref/simple-string) + (:translate data-vector-ref) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (unsigned-reg))) + (:arg-types simple-string positive-fixnum) + (:temporary (:sc unsigned-reg ; byte-reg + :offset rax-offset ; al-offset + :target value + :from (:eval 0) :to (:result 0)) + rax) + (:ignore rax) + (:results (value :scs (base-char-reg))) + (:result-types base-char) + (:generator 5 + (inst mov al-tn + (make-ea :byte :base object :index index :scale 1 + :disp (- (* vector-data-offset word-bytes) + other-pointer-type))) + (move value al-tn))) + +(define-vop (data-vector-ref-c/simple-string) + (:translate data-vector-ref) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg))) + (:info index) + (:arg-types simple-string (:constant (signed-byte 30))) + (:temporary (:sc unsigned-reg :offset rax-offset :target value + :from (:eval 0) :to (:result 0)) + rax) + (:ignore rax) + (:results (value :scs (base-char-reg))) + (:result-types base-char) + (:generator 4 + (inst mov al-tn + (make-ea :byte :base object + :disp (- (+ (* vector-data-offset word-bytes) index) + other-pointer-type))) + (move value al-tn))) + + +(define-vop (data-vector-set/simple-string) + (:translate data-vector-set) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg) :to (:eval 0)) + (index :scs (unsigned-reg) :to (:eval 0)) + (value :scs (base-char-reg))) + (:arg-types simple-string positive-fixnum base-char) + (:results (result :scs (base-char-reg))) + (:result-types base-char) + (:generator 5 + (inst mov (make-ea :byte :base object :index index :scale 1 + :disp (- (* vector-data-offset word-bytes) + other-pointer-type)) + value) + (move result value))) + + +(define-vop (data-vector-set/simple-string-c) + (:translate data-vector-set) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg) :to (:eval 0)) + (value :scs (base-char-reg))) + (:info index) + (:arg-types simple-string (:constant (signed-byte 30)) base-char) + (:results (result :scs (base-char-reg))) + (:result-types base-char) + (:generator 4 + (inst mov (make-ea :byte :base object + :disp (- (+ (* vector-data-offset word-bytes) index) + other-pointer-type)) + value) + (move result value))) + + +;;; signed-byte-8 + +(define-vop (data-vector-ref/simple-array-signed-byte-8) + (:translate data-vector-ref) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (unsigned-reg))) + (:arg-types simple-array-signed-byte-8 positive-fixnum) + (:results (value :scs (signed-reg))) + (:result-types tagged-num) + (:generator 5 + (inst movsx value + (make-ea :byte :base object :index index :scale 1 + :disp (- (* vector-data-offset word-bytes) + other-pointer-type))))) + +(define-vop (data-vector-ref-c/simple-array-signed-byte-8) + (:translate data-vector-ref) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg))) + (:info index) + (:arg-types simple-array-signed-byte-8 (:constant (signed-byte 30))) + (:results (value :scs (signed-reg))) + (:result-types tagged-num) + (:generator 4 + (inst movsx value + (make-ea :byte :base object + :disp (- (+ (* vector-data-offset word-bytes) index) + other-pointer-type))))) + +(define-vop (data-vector-set/simple-array-signed-byte-8) + (:translate data-vector-set) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg) :to (:eval 0)) + (index :scs (unsigned-reg) :to (:eval 0)) + (value :scs (signed-reg) :target rax)) + (:arg-types simple-array-signed-byte-8 positive-fixnum tagged-num) + (:temporary (:sc unsigned-reg :offset rax-offset :target result + :from (:argument 2) :to (:result 0)) + rax) + (:results (result :scs (signed-reg))) + (:result-types tagged-num) + (:generator 5 + (move rax value) + (inst mov (make-ea :byte :base object :index index :scale 1 + :disp (- (* vector-data-offset word-bytes) + other-pointer-type)) + al-tn) + (move result rax))) + +(define-vop (data-vector-set-c/simple-array-signed-byte-8) + (:translate data-vector-set) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg) :to (:eval 0)) + (value :scs (signed-reg) :target rax)) + (:info index) + (:arg-types simple-array-signed-byte-8 (:constant (signed-byte 30)) + tagged-num) + (:temporary (:sc unsigned-reg :offset rax-offset :target result + :from (:argument 1) :to (:result 0)) + rax) + (:results (result :scs (signed-reg))) + (:result-types tagged-num) + (:generator 4 + (move rax value) + (inst mov (make-ea :byte :base object + :disp (- (+ (* vector-data-offset word-bytes) index) + other-pointer-type)) + al-tn) + (move result rax))) + +;;; signed-byte-16 + +(define-vop (data-vector-ref/simple-array-signed-byte-16) + (:translate data-vector-ref) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (unsigned-reg))) + (:arg-types simple-array-signed-byte-16 positive-fixnum) + (:results (value :scs (signed-reg))) + (:result-types tagged-num) + (:generator 5 + (inst movsx value + (make-ea :word :base object :index index :scale 2 + :disp (- (* vector-data-offset word-bytes) + other-pointer-type))))) + +(define-vop (data-vector-ref-c/simple-array-signed-byte-16) + (:translate data-vector-ref) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg))) + (:info index) + (:arg-types simple-array-signed-byte-16 (:constant (signed-byte 30))) + (:results (value :scs (signed-reg))) + (:result-types tagged-num) + (:generator 4 + (inst movsx value + (make-ea :word :base object + :disp (- (+ (* vector-data-offset word-bytes) + (* 2 index)) + other-pointer-type))))) + +(define-vop (data-vector-set/simple-array-signed-byte-16) + (:translate data-vector-set) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg) :to (:eval 0)) + (index :scs (unsigned-reg) :to (:eval 0)) + (value :scs (signed-reg) :target rax)) + (:arg-types simple-array-signed-byte-16 positive-fixnum tagged-num) + (:temporary (:sc signed-reg :offset rax-offset :target result + :from (:argument 2) :to (:result 0)) + rax) + (:results (result :scs (signed-reg))) + (:result-types tagged-num) + (:generator 5 + (move rax value) + (inst mov (make-ea :word :base object :index index :scale 2 + :disp (- (* vector-data-offset word-bytes) + other-pointer-type)) + ax-tn) + (move result rax))) + +(define-vop (data-vector-set-c/simple-array-signed-byte-16) + (:translate data-vector-set) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg) :to (:eval 0)) + (value :scs (signed-reg) :target rax)) + (:info index) + (:arg-types simple-array-signed-byte-16 (:constant (signed-byte 30)) tagged-num) + (:temporary (:sc signed-reg :offset rax-offset :target result + :from (:argument 1) :to (:result 0)) + rax) + (:results (result :scs (signed-reg))) + (:result-types tagged-num) + (:generator 4 + (move rax value) + (inst mov + (make-ea :word :base object + :disp (- (+ (* vector-data-offset word-bytes) + (* 2 index)) + other-pointer-type)) + ax-tn) + (move result rax))) + + + +;;; These VOPs are used for implementing float slots in structures (whose raw +;;; data is an unsigned-32 vector. +;;; +(define-vop (raw-ref-single data-vector-ref/simple-array-single-float) + (:translate %raw-ref-single) + (:arg-types simple-array-unsigned-byte-32 positive-fixnum)) +(define-vop (raw-ref-single-c data-vector-ref-c/simple-array-single-float) + (:translate %raw-ref-single) + (:arg-types simple-array-unsigned-byte-32 (:constant (signed-byte 30)))) +;;; +(define-vop (raw-set-single data-vector-set/simple-array-single-float) + (:translate %raw-set-single) + (:arg-types simple-array-unsigned-byte-32 positive-fixnum single-float)) +(define-vop (raw-set-single-c data-vector-set-c/simple-array-single-float) + (:translate %raw-set-single) + (:arg-types simple-array-unsigned-byte-32 (:constant (signed-byte 30)) + single-float)) +;;; +(define-vop (raw-ref-double data-vector-ref/simple-array-double-float) + (:translate %raw-ref-double) + (:arg-types simple-array-unsigned-byte-32 positive-fixnum)) +(define-vop (raw-ref-double-c data-vector-ref-c/simple-array-double-float) + (:translate %raw-ref-double) + (:arg-types simple-array-unsigned-byte-32 (:constant (signed-byte 30)))) +;;; +(define-vop (raw-set-double data-vector-set/simple-array-double-float) + (:translate %raw-set-double) + (:arg-types simple-array-unsigned-byte-32 positive-fixnum double-float)) +(define-vop (raw-set-double-c data-vector-set-c/simple-array-double-float) + (:translate %raw-set-double) + (:arg-types simple-array-unsigned-byte-32 (:constant (signed-byte 30)) + double-float)) +;;; +#+long-float +(define-vop (raw-ref-long data-vector-ref/simple-array-long-float) + (:translate %raw-ref-long) + (:arg-types simple-array-unsigned-byte-32 positive-fixnum)) +#+long-float +(define-vop (raw-ref-long-c data-vector-ref-c/simple-array-long-float) + (:translate %raw-ref-long) + (:arg-types simple-array-unsigned-byte-32 (:constant (signed-byte 30)))) +;;; +#+long-float +(define-vop (raw-set-double data-vector-set/simple-array-long-float) + (:translate %raw-set-long) + (:arg-types simple-array-unsigned-byte-32 positive-fixnum long-float)) +#+long-float +(define-vop (raw-set-long-c data-vector-set-c/simple-array-long-float) + (:translate %raw-set-long) + (:arg-types simple-array-unsigned-byte-32 (:constant (signed-byte 30)) + long-float)) + +;;;; Complex-float raw structure slot accessors. + +(define-vop (raw-ref-complex-single + data-vector-ref/simple-array-complex-single-float) + (:translate %raw-ref-complex-single) + (:arg-types simple-array-unsigned-byte-32 positive-fixnum)) +(define-vop (raw-ref-complex-single-c + data-vector-ref-c/simple-array-complex-single-float) + (:translate %raw-ref-complex-single) + (:arg-types simple-array-unsigned-byte-32 (:constant (signed-byte 30)))) +;;; +(define-vop (raw-set-complex-single + data-vector-set/simple-array-complex-single-float) + (:translate %raw-set-complex-single) + (:arg-types simple-array-unsigned-byte-32 positive-fixnum complex-single-float)) +(define-vop (raw-set-complex-single-c + data-vector-set-c/simple-array-complex-single-float) + (:translate %raw-set-complex-single) + (:arg-types simple-array-unsigned-byte-32 (:constant (signed-byte 30)) + complex-single-float)) +;;; +(define-vop (raw-ref-complex-double + data-vector-ref/simple-array-complex-double-float) + (:translate %raw-ref-complex-double) + (:arg-types simple-array-unsigned-byte-32 positive-fixnum)) +(define-vop (raw-ref-complex-double-c + data-vector-ref-c/simple-array-complex-double-float) + (:translate %raw-ref-complex-double) + (:arg-types simple-array-unsigned-byte-32 (:constant (signed-byte 30)))) +;;; +(define-vop (raw-set-complex-double + data-vector-set/simple-array-complex-double-float) + (:translate %raw-set-complex-double) + (:arg-types simple-array-unsigned-byte-32 positive-fixnum + complex-double-float)) +(define-vop (raw-set-complex-double-c + data-vector-set-c/simple-array-complex-double-float) + (:translate %raw-set-complex-double) + (:arg-types simple-array-unsigned-byte-32 (:constant (signed-byte 30)) + complex-double-float)) +;;; +#+long-float +(define-vop (raw-ref-complex-long + data-vector-ref/simple-array-complex-long-float) + (:translate %raw-ref-complex-long) + (:arg-types simple-array-unsigned-byte-32 positive-fixnum)) +#+long-float +(define-vop (raw-ref-complex-long-c + data-vector-ref-c/simple-array-complex-long-float) + (:translate %raw-ref-complex-long) + (:arg-types simple-array-unsigned-byte-32 (:constant (signed-byte 30)))) +;;; +#+long-float +(define-vop (raw-set-complex-long + data-vector-set/simple-array-complex-long-float) + (:translate %raw-set-complex-long) + (:arg-types simple-array-unsigned-byte-32 positive-fixnum + complex-long-float)) +#+long-float +(define-vop (raw-set-complex-long-c + data-vector-set-c/simple-array-complex-long-float) + (:translate %raw-set-complex-long) + (:arg-types simple-array-unsigned-byte-32 (:constant (signed-byte 30)) + complex-long-float)) + + +;;; These vops are useful for accessing the bits of a vector irrespective of +;;; what type of vector it is. +;;; +(define-full-reffer raw-bits * 0 other-pointer-type (unsigned-reg) + unsigned-num %raw-bits) +(define-full-setter set-raw-bits * 0 other-pointer-type (unsigned-reg) + unsigned-num %set-raw-bits) + + +;;;; Conditional setters. + +(export 'kernel::data-vector-set-conditional "KERNEL") +(defknown data-vector-set-conditional (array index t t) t + (unsafe c::explicit-check)) + +(define-full-conditional-setter data-vector-set-conditional/simple-vector + simple-vector vector-data-offset other-pointer-type + (descriptor-reg any-reg) * + data-vector-set-conditional) + + +;;;; Misc. Array VOPs. + +(define-vop (get-vector-subtype get-header-data)) +(define-vop (set-vector-subtype set-header-data)) + diff --git a/compiler/amd64/c-call.lisp b/compiler/amd64/c-call.lisp new file mode 100644 index 0000000000000000000000000000000000000000..416d75123426172531c78b2646bd809005c4a32a --- /dev/null +++ b/compiler/amd64/c-call.lisp @@ -0,0 +1,367 @@ +;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; 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: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/amd64/c-call.lisp,v 1.1 2004/05/24 22:34:59 cwang Exp $") +;;; +;;; ********************************************************************** +;;; +;;; This file contains the VOPs and other necessary machine specific support +;;; routines for call-out to C. +;;; +;;; Written by William Lott. +;;; +;;; Debugged by Paul F. Werkowski Spring/Summer 1995. +;;; Debugging and Enhancements by Douglas Crosher 1996,1997,1998,1999. +;;; + +(in-package :amd64) +(use-package :alien) +(use-package :alien-internals) + +;; The move-argument vop is going to store args on the stack for +;; call-out. These tn's will be used for that. move-arg is normally +;; used for things going down the stack but C wants to have args +;; indexed in the positive direction. + +(defun my-make-wired-tn (prim-type-name sc-name offset) + (make-wired-tn (primitive-type-or-lose prim-type-name *backend*) + (sc-number-or-lose sc-name *backend*) + offset)) + +(defstruct arg-state + (register-args 0) + (stack-frame-size 0)) + +(defun int-arg (state prim-type reg-sc stack-sc) + (let ((reg-args (arg-state-register-args state))) + (cond ((< reg-args 4) ; Should be 6 (r8 and r9) + (setf (arg-state-register-args state) (1+ reg-args)) + (my-make-wired-tn prim-type reg-sc (ecase reg-args + (0 #.rdi-offset) + (1 #.rsi-offset) + (2 #.rdx-offset) + (3 #.rcx-offset)))) + (t + (let ((frame-size (arg-state-stack-frame-size state))) + (setf (arg-state-stack-frame-size state) (1+ frame-size)) + (my-make-wired-tn prim-type stack-sc frame-size)))))) + +(def-alien-type-method (integer :arg-tn) (type state) + (if (alien-integer-type-signed type) + (int-arg state 'signed-byte-64 'signed-reg 'signed-stack) + (int-arg state 'unsigned-byte-64 'unsigned-reg 'unsigned-stack))) + +(def-alien-type-method (system-area-pointer :arg-tn) (type state) + (declare (ignore type)) + (int-arg state 'system-area-pointer 'sap-reg 'sap-stack)) + +#+long-float +(def-alien-type-method (long-float :arg-tn) (type state) + (declare (ignore type)) + (let ((stack-frame-size (arg-state-stack-frame-size state))) + (setf (arg-state-stack-frame-size state) (+ stack-frame-size 3)) + (my-make-wired-tn 'long-float 'long-stack stack-frame-size))) + +(def-alien-type-method (double-float :arg-tn) (type state) + (declare (ignore type)) + (let ((stack-frame-size (arg-state-stack-frame-size state))) + (setf (arg-state-stack-frame-size state) (+ stack-frame-size 2)) + (my-make-wired-tn 'double-float 'double-stack stack-frame-size))) + +(def-alien-type-method (single-float :arg-tn) (type state) + (declare (ignore type)) + (let ((stack-frame-size (arg-state-stack-frame-size state))) + (setf (arg-state-stack-frame-size state) (1+ stack-frame-size)) + (my-make-wired-tn 'single-float 'single-stack stack-frame-size))) + +(defstruct result-state + (num-results 0)) + +(defun result-reg-offset (slot) + (ecase slot + (0 rax-offset) + (1 rdx-offset))) + +(def-alien-type-method (integer :result-tn) (type state) + (let ((num-results (result-state-num-results state))) + (setf (result-state-num-results state) (1+ num-results)) + (multiple-value-bind + (ptype reg-sc) + (if (alien-integer-type-signed type) + (values 'signed-byte-64 'signed-reg) + (values 'unsigned-byte-64 'unsigned-reg)) + (my-make-wired-tn ptype reg-sc (result-reg-offset num-results))))) + +(def-alien-type-method (system-area-pointer :result-tn) (type state) + (declare (ignore type)) + (let ((num-results (result-state-num-results state))) + (setf (result-state-num-results state) (1+ num-results)) + (my-make-wired-tn 'system-area-pointer 'sap-reg + (result-reg-offset num-results)))) + +#+long-float +(def-alien-type-method (long-float :result-tn) (type state) + (declare (ignore type)) + (let ((num-results (result-state-num-results state))) + (setf (result-state-num-results state) (1+ num-results)) + (my-make-wired-tn 'long-float 'long-reg (* num-results 2)))) + +(def-alien-type-method (double-float :result-tn) (type state) + (declare (ignore type)) + (let ((num-results (result-state-num-results state))) + (setf (result-state-num-results state) (1+ num-results)) + (my-make-wired-tn 'double-float 'double-reg (* num-results 2)))) + +(def-alien-type-method (single-float :result-tn) (type state) + (declare (ignore type)) + (let ((num-results (result-state-num-results state))) + (setf (result-state-num-results state) (1+ num-results)) + (my-make-wired-tn 'single-float 'single-reg (* num-results 2)))) + +(def-alien-type-method (values :result-tn) (type state) + (let ((values (alien-values-type-values type))) + (when (> (length values) 2) + (error "Too many result values from c-call.")) + (mapcar #'(lambda (type) + (invoke-alien-type-method :result-tn type state)) + (alien-values-type-values type)))) + +(def-vm-support-routine make-call-out-tns (type) + (let ((arg-state (make-arg-state))) + (collect ((arg-tns)) + (dolist (arg-type (alien-function-type-arg-types type)) + (arg-tns (invoke-alien-type-method :arg-tn arg-type arg-state))) + (values (my-make-wired-tn 'positive-fixnum 'any-reg rsp-offset) + (* (arg-state-stack-frame-size arg-state) word-bytes) + (arg-tns) + (invoke-alien-type-method :result-tn + (alien-function-type-result-type type) + (make-result-state)))))) + +(deftransform %alien-funcall ((function type &rest args)) + (assert (c::constant-continuation-p type)) + (let* ((type (c::continuation-value type)) + (arg-types (alien-function-type-arg-types type)) + (result-type (alien-function-type-result-type type))) + (assert (= (length arg-types) (length args))) + (if (or (some #'(lambda (type) + (and (alien-integer-type-p type) + (> (alien::alien-integer-type-bits type) 32))) + arg-types) + (and (alien-integer-type-p result-type) + (> (alien::alien-integer-type-bits result-type) 32))) + (collect ((new-args) (lambda-vars) (new-arg-types)) + (dolist (type arg-types) + (let ((arg (gensym))) + (lambda-vars arg) + (cond ((and (alien-integer-type-p type) + (> (alien::alien-integer-type-bits type) 32)) + (new-args `(logand ,arg #xffffffff)) + (new-args `(ash ,arg -32)) + (new-arg-types (parse-alien-type '(unsigned 32))) + (if (alien-integer-type-signed type) + (new-arg-types (parse-alien-type '(signed 32))) + (new-arg-types (parse-alien-type '(unsigned 32))))) + (t + (new-args arg) + (new-arg-types type))))) + (cond ((and (alien-integer-type-p result-type) + (> (alien::alien-integer-type-bits result-type) 32)) + (let ((new-result-type + (let ((alien::*values-type-okay* t)) + (parse-alien-type + (if (alien-integer-type-signed result-type) + '(values (unsigned 32) (signed 32)) + '(values (unsigned 32) (unsigned 32))))))) + `(lambda (function type ,@(lambda-vars)) + (declare (ignore type)) + (multiple-value-bind (low high) + (%alien-funcall function + ',(make-alien-function-type + :arg-types (new-arg-types) + :result-type new-result-type) + ,@(new-args)) + (logior low (ash high 32)))))) + (t + `(lambda (function type ,@(lambda-vars)) + (declare (ignore type)) + (%alien-funcall function + ',(make-alien-function-type + :arg-types (new-arg-types) + :result-type result-type) + ,@(new-args)))))) + (c::give-up)))) + +(define-vop (foreign-symbol-code-address) + (:translate #+linkage-table foreign-symbol-code-address + #-linkage-table foreign-symbol-address) + (:policy :fast-safe) + (:args) + (:arg-types (:constant simple-string)) + (:info foreign-symbol) + (:results (res :scs (sap-reg))) + (:result-types system-area-pointer) + (:generator 2 + (inst mov-imm res (make-fixup (extern-alien-name foreign-symbol) + :foreign)))) + +(define-vop (foreign-symbol-data-address) + (:translate foreign-symbol-data-address) + (:policy :fast-safe) + (:args) + (:arg-types (:constant simple-string)) + (:info foreign-symbol) + (:results (res :scs (sap-reg))) + (:result-types system-area-pointer) + (:generator 2 + (inst mov res (make-fixup (extern-alien-name foreign-symbol) + :foreign-data)))) + +(define-vop (call-out) + (:args (function :scs (sap-reg)) + (args :more t)) + (:results (results :more t)) + (:temporary (:sc unsigned-reg :offset rax-offset + :from :eval :to :result) rax) + (:temporary (:sc unsigned-reg :offset rbx-offset + :from :eval :to :result) rbx) + (:temporary (:sc unsigned-reg :offset rcx-offset + :from :eval :to :result) rcx) + (:temporary (:sc unsigned-reg :offset rdx-offset + :from :eval :to :result) rdx) + (:node-var node) + (:vop-var vop) + (:save-p t) + (:ignore args rcx rdx) + (:generator 0 + (cond ((policy node (> space speed)) + (move rax function) + (inst call (make-fixup (extern-alien-name "call_into_c") :foreign))) + (t + (move rbx function) + ;; With variable arguments, rax passes information about the number of + ;; SSE register used. This is unnecessary for normal functions, but + ;; I don't know how to distinguish them. + (inst xor rax rax) + + ;; Setup the NPX for C; all the FP registers need to be + ;; empty; pop them all. + (dotimes (i 8) + (fp-pop)) + + (inst call rbx) + ;; To give the debugger a clue. XX not really internal-error? + (note-this-location vop :internal-error) + + ;; Restore the NPX for lisp; insure no regs are empty. + (dotimes (i 7) + (inst fldz)) + + (if (and results + (location= (tn-ref-tn results) fr0-tn)) + ;; The return result is in fr0. + (inst fxch fr7-tn) ; move the result back to fr0 + (inst fldz)) ; insure no regs are empty + )))) + +(define-vop (alloc-number-stack-space) + (:info amount) + (:results (result :scs (sap-reg any-reg))) + (:generator 0 + (assert (location= result rsp-tn)) + (unless (zerop amount) + (let ((delta (logandc2 (+ amount 3) 3))) + (inst sub rsp-tn delta))) + (move result rsp-tn))) + +(define-vop (dealloc-number-stack-space) + (:info amount) + (:generator 0 + (unless (zerop amount) + (let ((delta (logandc2 (+ amount 3) 3))) + (inst add rsp-tn delta))))) + +(define-vop (alloc-alien-stack-space) + (:info amount) + (:results (result :scs (sap-reg any-reg))) + (:generator 0 + (assert (not (location= result rsp-tn))) + (unless (zerop amount) + (let ((delta (logandc2 (+ amount 3) 3))) + (inst mov result (+ nil-value + (static-symbol-offset '*alien-stack*) + (ash symbol-value-slot word-shift) + (- other-pointer-type))) + (inst sub (make-ea :qword :base result) + delta))) + (load-symbol-value result *alien-stack*))) + +(define-vop (dealloc-alien-stack-space) + (:temporary (:sc any-reg) temp-tn) ; from/to? + (:info amount) + (:generator 0 + (unless (zerop amount) + (let ((delta (logandc2 (+ amount 3) 3))) + (inst mov temp-tn (+ nil-value + (static-symbol-offset '*alien-stack*) + (ash symbol-value-slot word-shift) + (- other-pointer-type))) + (inst add (make-ea :qword :base temp-tn) + delta))))) + +;;; Support for callbacks to Lisp. +(export '(make-callback-trampoline callback-accessor-form)) + +(defun callback-accessor-form (type sp offset) + `(alien:deref (sap-alien + (sys:sap+ ,sp ,offset) + (* ,type)))) + +(defun make-callback-trampoline (index return-type) + "Cons up a piece of code which calls call-callback with INDEX and a +pointer to the arguments." + (let* ((segment (make-segment)) + (rax amd64::rax-tn) + (rdx amd64::rdx-tn) + (rbp amd64::rbp-tn) + (rsp amd64::rsp-tn) + ([rbp-8] (amd64::make-ea :qword :base rbp :disp -8)) + ([rbp-4] (amd64::make-ea :qword :base rbp :disp -4))) + (assemble (segment) + (inst push rbp) ; save old frame pointer + (inst mov rbp rsp) ; establish new frame + (inst mov rax rsp) ; + (inst sub rax 8) ; place for result + (inst push rax) ; arg2 + (inst add rax 16) ; arguments + (inst push rax) ; arg1 + (inst push (ash index 2)) ; arg0 + (inst push (alien::address-of-call-callback)) ; function + (inst mov rax (alien::address-of-funcall3)) + (inst call rax) + ;; now put the result into the right register + (etypecase return-type + (alien::integer-64$ + (inst mov rax [rbp-8]) + (inst mov rdx [rbp-4])) + ((or alien::integer$ alien::pointer$ alien::sap$) + (inst mov rax [rbp-8])) + (alien::single$ + (inst fld [rbp-8])) + (alien::double$ + (inst fldd [rbp-8])) + (alien::void$ )) + (inst mov rsp rbp) ; discard frame + (inst pop rbp) ; restore frame pointer + (inst ret)) + (let* ((length (finalize-segment segment))) + (prog1 (alien::segment-to-trampoline segment length) + (release-segment segment))))) + + diff --git a/compiler/amd64/call.lisp b/compiler/amd64/call.lisp new file mode 100644 index 0000000000000000000000000000000000000000..afbf04f252d92df51fba65478efcb3d240c69383 --- /dev/null +++ b/compiler/amd64/call.lisp @@ -0,0 +1,1483 @@ +;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; 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: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/amd64/call.lisp,v 1.1 2004/05/24 22:34:59 cwang Exp $") +;;; +;;; ********************************************************************** +;;; +;;; This file contains the VM definition of function call for the AMD64. +;;; +;;; Written by William Lott. +;;; +;;; Debugged by Paul F. Werkowski Spring/Summer 1995. +;;; Enhancements/debugging by Douglas T. Crosher 1996,1997. +;;; +(in-package :amd64) + +;;; + + +;;;; Interfaces to IR2 conversion: + +;;; Standard-Argument-Location -- Interface +;;; +;;; Return a wired TN describing the N'th full call argument passing +;;; location. +;;; +(def-vm-support-routine standard-argument-location (n) + (declare (type unsigned-byte n)) + (if (< n register-arg-count) + (make-wired-tn *any-primitive-type* descriptor-reg-sc-number + (nth n register-arg-offsets)) + (make-wired-tn *any-primitive-type* control-stack-sc-number n))) + + +;;; Make-Return-PC-Passing-Location -- Interface +;;; +;;; Make a passing location TN for a local call return PC. +;;; +;;; Always wire the return PC location to the stack in its standard +;;; location. +;;; +;;; No problems. +;#+nil +(def-vm-support-routine make-return-pc-passing-location (standard) + (declare (ignore standard)) + (make-wired-tn (primitive-type-or-lose 'system-area-pointer *backend*) + sap-stack-sc-number return-pc-save-offset)) +;;; +;;; If standard is true, then use the standard (full call) location, +;;; otherwise use any legal location. +;;; +;;; No problems. +#+nil +(def-vm-support-routine make-return-pc-passing-location (standard) + (let ((ptype (primitive-type-or-lose 'system-area-pointer *backend*))) + (if standard + (make-wired-tn ptype sap-stack-sc-number return-pc-save-offset) + (make-normal-tn ptype)))) + +;;; Make-Old-FP-Passing-Location -- Interface +;;; +;;; Similar to Make-Return-PC-Passing-Location, but makes a location to pass +;;; Old-FP in. +;;; +;;; This is wired in both the standard and the local-call +;;; conventions, because we want to be able to assume it's always there. +;;; Besides, the x86 doesn't have enough registers to really make it +;;; profitable to pass it in a register. +;;; +;;; No problems +;#+nil +(def-vm-support-routine make-old-fp-passing-location (standard) + (declare (ignore standard)) + (make-wired-tn *fixnum-primitive-type* control-stack-sc-number + ocfp-save-offset)) +;;; +;;; If standard is true, then use the standard (full call) location, +;;; otherwise use any legal location. +;;; +;;; No problems. +#+nil +(def-vm-support-routine make-old-fp-passing-location (standard) + (if standard + (make-wired-tn *fixnum-primitive-type* control-stack-sc-number + ocfp-save-offset) + (make-normal-tn *fixnum-primitive-type*))) + +;;; Make-Old-FP-Save-Location, Make-Return-PC-Save-Location -- Interface +;;; +;;; Make the TNs used to hold Old-FP and Return-PC within the current +;;; function. We treat these specially so that the debugger can find them at a +;;; known location. +;;; +;;; Without using a save-tn - which does not make much sense if it is +;;; wire to the stack? No problems. +(def-vm-support-routine make-old-fp-save-location (env) + (environment-debug-live-tn (make-wired-tn *fixnum-primitive-type* + control-stack-sc-number + ocfp-save-offset) + env)) +;;; +;;; Using a save-tn. No problems. +#+nil +(def-vm-support-routine make-old-fp-save-location (env) + (specify-save-tn + (environment-debug-live-tn (make-normal-tn *fixnum-primitive-type*) env) + (make-wired-tn *fixnum-primitive-type* control-stack-sc-number + ocfp-save-offset))) + +;;; +;;; Without using a save-tn - which does not make much sense if it is +;;; wire to the stack? No problems. +(def-vm-support-routine make-return-pc-save-location (env) + (environment-debug-live-tn + (make-wired-tn (primitive-type-or-lose 'system-area-pointer *backend*) + sap-stack-sc-number return-pc-save-offset) + env)) +;;; +;;; Using a save-tn. No problems. +#+nil +(def-vm-support-routine make-return-pc-save-location (env) + (let ((ptype (primitive-type-or-lose 'system-area-pointer *backend*))) + (specify-save-tn + (environment-debug-live-tn (make-normal-tn ptype) env) + (make-wired-tn ptype sap-stack-sc-number return-pc-save-offset)))) + +;;; Make-Argument-Count-Location -- Interface +;;; +;;; Make a TN for the standard argument count passing location. We only +;;; need to make the standard location, since a count is never passed when we +;;; are using non-standard conventions. +;;; +(def-vm-support-routine make-argument-count-location () + (make-wired-tn *fixnum-primitive-type* any-reg-sc-number rcx-offset)) + + +;;; MAKE-NFP-TN -- Interface +;;; +;;; Make a TN to hold the number-stack frame pointer. This is allocated +;;; once per component, and is component-live. +;;; +(def-vm-support-routine make-nfp-tn () + (make-restricted-tn *fixnum-primitive-type* ignore-me-sc-number)) + +;;; MAKE-STACK-POINTER-TN () +;;; +(def-vm-support-routine make-stack-pointer-tn () + (make-normal-tn *fixnum-primitive-type*)) + +;;; MAKE-NUMBER-STACK-POINTER-TN () +;;; +(def-vm-support-routine make-number-stack-pointer-tn () + (make-restricted-tn *fixnum-primitive-type* ignore-me-sc-number)) + +;;; Make-Unknown-Values-Locations -- Interface +;;; +;;; Return a list of TNs that can be used to represent an unknown-values +;;; continuation within a function. +;;; +(def-vm-support-routine make-unknown-values-locations () + (list (make-stack-pointer-tn) + (make-normal-tn *fixnum-primitive-type*))) + + +;;; Select-Component-Format -- Interface +;;; +;;; This function is called by the Entry-Analyze phase, allowing +;;; VM-dependent initialization of the IR2-Component structure. We push +;;; placeholder entries in the Constants to leave room for additional +;;; noise in the code object header. +;;; +;;; For the x86 the first constant is a pointer to a list of fixups, +;;; or nil if the code object has none. +;;; +(def-vm-support-routine select-component-format (component) + (declare (type component component)) + (dotimes (i (1+ code-constants-offset)) + (vector-push-extend nil + (ir2-component-constants (component-info component)))) + (undefined-value)) + + +;;;; Frame hackery: + +;;; Used for setting up the Old-FP in local call. +;;; +(define-vop (current-fp) + (:results (val :scs (any-reg control-stack))) + (:generator 1 + (move val rbp-tn))) + +;;; We don't have a seperate NFP, so we don't need to do anything here. +;;; +(define-vop (compute-old-nfp) + (:results (val)) + (:ignore val) + (:generator 1 + nil)) + + +(define-vop (xep-allocate-frame) + (:info start-lab copy-more-arg-follows) + (:vop-var vop) + (:generator 1 + ;; Make sure the function is aligned, and drop a label pointing to this + ;; function header. + (align lowtag-bits) + (trace-table-entry trace-table-function-prologue) + (emit-label start-lab) + ;; Skip space for the function header. + (inst function-header-word) + (dotimes (i (1- vm:function-code-offset)) + (inst qword 0)) + + ;; The start of the actual code. + ;; Save the return-pc. + (popw rbp-tn (- (1+ return-pc-save-offset))) + + ;; If copy-more-arg follows it will allocate the correct stack + ;; size. The stack is not allocated first here as this may expose + ;; args on the stack if they take up more space than the frame! + (unless copy-more-arg-follows + ;; The args fit within the frame so just allocate the frame. + (inst lea rsp-tn + (make-ea :qword :base rbp-tn + :disp (- (* vm:word-bytes + (max 3 (sb-allocated-size 'stack))))))) + + (trace-table-entry trace-table-normal))) + +;;; This is emitted directly before either a known-call-local, call-local, +;;; or a multiple-call-local. All it does is allocate stack space for the +;;; callee (who has the same size stack as us). +;;; +(define-vop (allocate-frame) + (:results (res :scs (any-reg control-stack)) + (nfp)) + (:info callee) + (:ignore nfp callee) + (:generator 2 + (move res rsp-tn) + (inst sub rsp-tn (* vm:word-bytes (sb-allocated-size 'stack))))) + +;;; Allocate a partial frame for passing stack arguments in a full call. Nargs +;;; is the number of arguments passed. We allocate at least 3 slots, because +;;; the XEP noise is going to want to use them before it can extend the stack. +;;; +(define-vop (allocate-full-call-frame) + (:info nargs) + (:results (res :scs (any-reg control-stack))) + (:generator 2 + (move res rsp-tn) + (inst sub rsp-tn (* (max nargs 3) vm:word-bytes)))) + + + +;;; Default-Unknown-Values -- Internal +;;; +;;; Emit code needed at the return-point from an unknown-values call for a +;;; fixed number of values. Values is the head of the TN-Ref list for the +;;; locations that the values are to be received into. Nvals is the number of +;;; values that are to be received (should equal the length of Values). +;;; +;;; Move-Temp is a Descriptor-Reg TN used as a temporary. +;;; +;;; This code exploits the fact that in the unknown-values convention, a +;;; single value return returns at the return PC + 3, whereas a return of other +;;; than one value returns directly at the return PC. +;;; +;;; If 0 or 1 values are expected, then we just emit an instruction to reset +;;; the SP (which will only be executed when other than 1 value is returned.) +;;; +;;; In the general case we have to do three things: +;;; -- Default unsupplied register values. This need only be done when a +;;; single value is returned, since register values are defaulted by the +;;; called in the non-single case. +;;; -- Default unsupplied stack values. This needs to be done whenever there +;;; are stack values. +;;; -- Reset SP. This must be done whenever other than 1 value is returned, +;;; regardless of the number of values desired. +;;; +;;; +(defun default-unknown-values (vop values nvals) + (declare (type (or tn-ref null) values) + (type unsigned-byte nvals)) + (cond + ((<= nvals 1) + (note-this-location vop :single-value-return) + (inst mov rsp-tn rbx-tn)) + ((<= nvals register-arg-count) + (let ((regs-defaulted (gen-label))) + (note-this-location vop :unknown-return) + (inst jmp-short regs-defaulted) + ;; Default the unsuppled registers. + (let* ((2nd-tn-ref (tn-ref-across values)) + (2nd-tn (tn-ref-tn 2nd-tn-ref))) + (inst mov 2nd-tn nil-value) + (when (> nvals 2) + (loop + for tn-ref = (tn-ref-across 2nd-tn-ref) + then (tn-ref-across tn-ref) + for count from 2 below register-arg-count + do (inst mov (tn-ref-tn tn-ref) 2nd-tn)))) + (inst mov rbx-tn rsp-tn) + (emit-label regs-defaulted) + (inst mov rsp-tn rbx-tn))) + ((<= nvals 7) + ;; Number of bytes depends on the relative jump instructions. Best + ;; case is 31+(n-3)*14, worst case is 35+(n-3)*18. For nvals=6 + ;; that is 73/89 bytes, and for nvals=7 that is 87/107 bytes which + ;; is likely better than using the blt below. + (let ((regs-defaulted (gen-label)) + (defaulting-done (gen-label)) + (default-stack-slots (gen-label))) + (note-this-location vop :unknown-return) + ;; Branch off to the MV case. + (inst jmp-short regs-defaulted) + ;; Do the single value case. + ;; Default the register args + (inst mov rax-tn nil-value) + (do ((i 1 (1+ i)) + (val (tn-ref-across values) (tn-ref-across val))) + ((= i (min nvals register-arg-count))) + (inst mov (tn-ref-tn val) rax-tn)) + + ;; Fake other registers so it looks like we returned with all the + ;; registers filled in. + (move rbx-tn rsp-tn) + (inst push rdx-tn) + (inst jmp default-stack-slots) + + (emit-label regs-defaulted) + + (inst mov rax-tn nil-value) + (storew rdx-tn rbx-tn -1) + (collect ((defaults)) + (do ((i register-arg-count (1+ i)) + (val (do ((i 0 (1+ i)) + (val values (tn-ref-across val))) + ((= i register-arg-count) val)) + (tn-ref-across val))) + ((null val)) + (let ((default-lab (gen-label)) + (tn (tn-ref-tn val))) + (defaults (cons default-lab tn)) + + (inst cmp rcx-tn (fixnumize i)) + (inst jmp :be default-lab) + (loadw rdx-tn rbx-tn (- (1+ i))) + (inst mov tn rdx-tn))) + + (emit-label defaulting-done) + (loadw rdx-tn rbx-tn -1) + (move rsp-tn rbx-tn) + + (let ((defaults (defaults))) + (when defaults + (assemble (*elsewhere*) + (trace-table-entry trace-table-function-prologue) + (emit-label default-stack-slots) + (dolist (default defaults) + (emit-label (car default)) + (inst mov (cdr default) rax-tn)) + (inst jmp defaulting-done) + (trace-table-entry trace-table-normal))))))) + (t + ;; 91 bytes for this branch. + (let ((regs-defaulted (gen-label)) + (restore-rdi (gen-label)) + (no-stack-args (gen-label)) + (default-stack-vals (gen-label)) + (count-okay (gen-label))) + (note-this-location vop :unknown-return) + ;; Branch off to the MV case. + (inst jmp-short regs-defaulted) + + ;; Default the register args, and set up the stack as if we entered + ;; the MV return point. + (inst mov rbx-tn rsp-tn) + (inst push rdx-tn) + (inst mov rdi-tn nil-value) + (inst push rdi-tn) + (inst mov rsi-tn rdi-tn) + ;; Compute a pointer to where to put the [defaulted] stack values. + (emit-label no-stack-args) + (inst lea rdi-tn + (make-ea :qword :base rbp-tn + :disp (* (- (1+ register-arg-count)) word-bytes))) + ;; Load RAX with NIL so we can quickly store it, and set up stuff + ;; for the loop. + (inst mov rax-tn nil-value) + (inst std) + (inst mov rcx-tn (- nvals register-arg-count)) + ;; Jump into the default loop. + (inst jmp default-stack-vals) + + ;; The regs are defaulted. We need to copy any stack arguments, + ;; and then default the remaining stack arguments. + (emit-label regs-defaulted) + ;; Save RDI. + (storew rdi-tn rbx-tn (- (1+ 1))) + ;; Compute the number of stack arguments, and if it's zero or less, + ;; don't copy any stack arguments. + (inst sub rcx-tn (fixnumize register-arg-count)) + (inst jmp :le no-stack-args) + + ;; Throw away any unwanted args. + (inst cmp rcx-tn (fixnumize (- nvals register-arg-count))) + (inst jmp :be count-okay) + (inst mov rcx-tn (fixnumize (- nvals register-arg-count))) + (emit-label count-okay) + ;; Save the number of stack values. + (inst mov rax-tn rcx-tn) + ;; Compute a pointer to where the stack args go. + (inst lea rdi-tn + (make-ea :qword :base rbp-tn + :disp (* (- (1+ register-arg-count)) word-bytes))) + ;; Save RSI, and compute a pointer to where the args come from. + (storew rsi-tn rbx-tn (- (1+ 2))) + (inst lea rsi-tn + (make-ea :qword :base rbx-tn + :disp (* (- (1+ register-arg-count)) word-bytes))) + ;; Do the copy. + (inst shr rcx-tn 2) ; make word count + (inst std) + (inst rep) + (inst movs :qword) + ;; Restore RSI. + (loadw rsi-tn rbx-tn (- (1+ 2))) + ;; Now we have to default the remaining args. Find out how many. + (inst sub rax-tn (fixnumize (- nvals register-arg-count))) + (inst neg rax-tn) + ;; If none, then just blow out of here. + (inst jmp :le restore-rdi) + (inst mov rcx-tn rax-tn) + (inst shr rcx-tn 2) ; word count + ;; Load RAX with NIL for fast storing. + (inst mov rax-tn nil-value) + ;; Do the store. + (emit-label default-stack-vals) + (inst rep) + (inst stos rax-tn) + ;; Restore RDI, and reset the stack. + (emit-label restore-rdi) + (loadw rdi-tn rbx-tn (- (1+ 1))) + (inst mov rsp-tn rbx-tn)))) + (undefined-value)) + + + +;;;; Unknown values receiving: + +;;; Receive-Unknown-Values -- Internal +;;; +;;; Emit code needed at the return point for an unknown-values call for an +;;; arbitrary number of values. +;;; +;;; We do the single and non-single cases with no shared code: there doesn't +;;; seem to be any potential overlap, and receiving a single value is more +;;; important efficiency-wise. +;;; +;;; When there is a single value, we just push it on the stack, returning +;;; the old SP and 1. +;;; +;;; When there is a variable number of values, we move all of the argument +;;; registers onto the stack, and return Args and Nargs. +;;; +;;; Args and Nargs are TNs wired to the named locations. We must +;;; explicitly allocate these TNs, since their lifetimes overlap with the +;;; results Start and Count (also, it's nice to be able to target them). +;;; +(defun receive-unknown-values (args nargs start count) + (declare (type tn args nargs start count)) + (let ((variable-values (gen-label)) + (done (gen-label))) + (inst jmp-short variable-values) + + (inst mov start rsp-tn) + (inst push (first register-arg-tns)) + (inst mov count (fixnumize 1)) + (inst jmp done) + + (emit-label variable-values) + ;; dtc: this writes the registers onto the stack even if they are + ;; not needed, only the number specified in ecx are used and have + ;; stack allocated to them. No harm is done. + (loop + for arg in register-arg-tns + for i downfrom -1 + do (storew arg args i)) + (move start args) + (move count nargs) + + (emit-label done)) + (undefined-value)) + + +;;; VOP that can be inherited by unknown values receivers. The main thing this +;;; handles is allocation of the result temporaries. +;;; +(define-vop (unknown-values-receiver) + (:temporary (:sc descriptor-reg :offset rbx-offset + :from :eval :to (:result 0)) + values-start) + (:temporary (:sc any-reg :offset rcx-offset + :from :eval :to (:result 1)) + nvals) + (:results (start :scs (any-reg control-stack)) + (count :scs (any-reg control-stack)))) + + +;;;; Local call with unknown values convention return: + +;;; Non-TR local call for a fixed number of values passed according to the +;;; unknown values convention. +;;; +;;; FP is the frame pointer in install before doing the call. +;;; +;;; NFP would be the number-stack frame pointer if we had a seperate number +;;; stack. +;;; +;;; Args are the argument passing locations, which are specified only to +;;; terminate their lifetimes in the caller. +;;; +;;; Values are the return value locations (wired to the standard passing +;;; locations). +;;; Nvals is the number of values received. +;;; +;;; Save is the save info, which we can ignore since saving has been done. +;;; +;;; Target is a continuation pointing to the start of the called function. +;;; +;;; +(define-vop (call-local) + (:args (fp) + (nfp) + (args :more t)) + (:results (values :more t)) + (:save-p t) + (:move-args :local-call) + (:info arg-locs callee target nvals) + (:vop-var vop) + (:ignore nfp arg-locs args #+nil callee) + (:generator 5 + (trace-table-entry trace-table-call-site) + (move rbp-tn fp) + + (let ((ret-tn (callee-return-pc-tn callee))) + #+nil + (format t "*call-local ~s; tn-kind ~s; tn-save-tn ~s; its tn-kind ~s~%" + ret-tn (c::tn-kind ret-tn) (c::tn-save-tn ret-tn) + (c::tn-kind (c::tn-save-tn ret-tn))) + + ;; Is the return-pc on the stack or in a register? + (sc-case ret-tn + ((sap-stack) + #+nil (format t "*call-local: ret-tn on stack; offset=~s~%" + (tn-offset ret-tn)) + ;; Stack + (storew (make-fixup nil :code-object return) + rbp-tn (- (1+ (tn-offset ret-tn))))) + ((sap-reg) + ;; Register + (inst lea ret-tn (make-fixup nil :code-object return))))) + + (note-this-location vop :call-site) + (inst jmp target) + RETURN + (default-unknown-values vop values nvals) + (trace-table-entry trace-table-normal))) + +;;; Non-TR local call for a variable number of return values passed according +;;; to the unknown values convention. The results are the start of the values +;;; glob and the number of values received. +;;; +(define-vop (multiple-call-local unknown-values-receiver) + (:args (fp) + (nfp) + (args :more t)) + (:save-p t) + (:move-args :local-call) + (:info save callee target) + (:ignore args save nfp #+nil callee) + (:vop-var vop) + (:generator 20 + (trace-table-entry trace-table-call-site) + (move rbp-tn fp) + + (let ((ret-tn (callee-return-pc-tn callee))) + #+nil + (format t "*multiple-call-local ~s; tn-kind ~s; tn-save-tn ~s; its tn-kind ~s~%" + ret-tn (c::tn-kind ret-tn) (c::tn-save-tn ret-tn) + (c::tn-kind (c::tn-save-tn ret-tn))) + + ;; Is the return-pc on the stack or in a register? + (sc-case ret-tn + ((sap-stack) + #+nil (format t "*multiple-call-local: ret-tn on stack; offset=~s~%" + (tn-offset ret-tn)) + ;; Stack + (storew (make-fixup nil :code-object return) + rbp-tn (- (1+ (tn-offset ret-tn))))) + ((sap-reg) + ;; Register + (inst lea ret-tn (make-fixup nil :code-object return))))) + + (note-this-location vop :call-site) + (inst jmp target) + RETURN + (note-this-location vop :unknown-return) + (receive-unknown-values values-start nvals start count) + (trace-table-entry trace-table-normal))) + + +;;;; Local call with known values return: + +;;; Non-TR local call with known return locations. Known-value return works +;;; just like argument passing in local call. +;;; +;;; Note: we can't use normal load-tn allocation for the fixed args, since all +;;; registers may be tied up by the more operand. Instead, we use +;;; MAYBE-LOAD-STACK-TN. +;;; +(define-vop (known-call-local) + (:args (fp) + (nfp) + (args :more t)) + (:temporary (:sc any-reg) temp-tn) ; from/to? + (:results (res :more t)) + (:move-args :local-call) + (:save-p t) + (:info save callee target) + (:ignore args res save nfp #+nil callee) + (:vop-var vop) + (:generator 5 + (trace-table-entry trace-table-call-site) + (move rbp-tn fp) + + (let ((ret-tn (callee-return-pc-tn callee))) + + #+nil + (format t "*known-call-local ~s; tn-kind ~s; tn-save-tn ~s; its tn-kind ~s~%" + ret-tn (c::tn-kind ret-tn) (c::tn-save-tn ret-tn) + (c::tn-kind (c::tn-save-tn ret-tn))) + + ;; Is the return-pc on the stack or in a register? + (sc-case ret-tn + ((sap-stack) + #+nil (format t "*known-call-local: ret-tn on stack; offset=~s~%" + (tn-offset ret-tn)) + ;; Stack + ;; need a temp register since we need 64-bit address here + (inst mov-imm temp-tn (make-fixup nil :code-object return)) + (storew temp-tn rbp-tn (- (1+ (tn-offset ret-tn))))) + ((sap-reg) + ;; Register + (inst lea ret-tn (make-fixup nil :code-object return))))) + + (note-this-location vop :call-site) + (inst jmp target) + RETURN + (note-this-location vop :known-return) + (trace-table-entry trace-table-normal))) + +;;; Return from known values call. We receive the return locations as +;;; arguments to terminate their lifetimes in the returning function. We +;;; restore FP and CSP and jump to the Return-PC. +;;; +;;; We can assume we know exactly where old-fp and return-pc are because +;;; make-old-fp-save-location and make-return-pc-save-location always +;;; return the same place. +;;; +#+nil +(define-vop (known-return) + (:args (old-fp) + (return-pc :scs (any-reg immediate-stack) :target rpc) + (vals :more t)) + (:move-args :known-return) + (:info val-locs) + (:temporary (:sc unsigned-reg :from (:argument 1)) rpc) + (:ignore val-locs vals) + (:vop-var vop) + (:generator 6 + (trace-table-entry trace-table-function-epilogue) + ;; Save the return-pc in a register 'cause the frame-pointer is going away. + ;; Note this not in the usual stack location so we can't use RET + (move rpc return-pc) + ;; Restore the stack. + (move rsp-tn rbp-tn) + ;; Restore the old fp. We know OLD-FP is going to be in it's stack + ;; save slot, which is a different frame that than this one, + ;; so we don't have to worry about having just cleared + ;; most of the stack. + (move rbp-tn old-fp) + (inst jmp rpc) + (trace-table-entry trace-table-normal))) + +;;; From Douglas Crosher +;;; Return from known values call. We receive the return locations as +;;; arguments to terminate their lifetimes in the returning function. We +;;; restore FP and CSP and jump to the Return-PC. +;;; +;;; The old-fp may be either in a register or on the stack in its +;;; standard save locations - slot 0. +;;; +;;; The return-pc may be in a register or on the stack in any slot. +;;; +(define-vop (known-return) + (:args (old-fp) + (return-pc) + (vals :more t)) + (:move-args :known-return) + (:info val-locs) + (:ignore val-locs vals) + (:vop-var vop) + (:generator 6 + (trace-table-entry trace-table-function-epilogue) + + #+nil (format t "*known-return: old-fp ~s, tn-kind ~s; ~s ~s~%" + old-fp (c::tn-kind old-fp) (c::tn-save-tn old-fp) + (c::tn-kind (c::tn-save-tn old-fp))) + + #+nil (format t "*known-return: return-pc ~s, tn-kind ~s; ~s ~s~%" + return-pc (c::tn-kind return-pc) (c::tn-save-tn return-pc) + (c::tn-kind (c::tn-save-tn return-pc))) + + ;; return-pc may be either in a register or on the stack. + (sc-case return-pc + ((sap-reg) + (sc-case old-fp + ((control-stack) + + #+nil (format t "*known-return: old-fp ~s on stack; offset=~s~%" + old-fp (tn-offset old-fp)) + + (cond ((zerop (tn-offset old-fp)) + ;; Zot all of the stack except for the old-fp. + (inst lea rsp-tn (make-ea :qword :base rbp-tn + :disp (- (* (1+ ocfp-save-offset) + word-bytes)))) + ;; Restore the old fp from its save location on the stack, + ;; and zot the stack. + (inst pop rbp-tn)) + + (t + (cerror "Continue any-way" + "VOP return-local doesn't work if old-fp (in slot %s) is not in slot 0" + (tn-offset old-fp))))) + + ((any-reg descriptor-reg) + ;; Zot all the stack. + (move rsp-tn rbp-tn) + ;; Restore the old-fp. + (move rbp-tn old-fp))) + + ;; Return; return-pc is in a register. + (inst jmp return-pc)) + + ((sap-stack) + + #+nil (format t "*known-return: return-pc ~s on stack; offset=~s~%" + return-pc (tn-offset return-pc)) + + ;; Zot all of the stack except for the old-fp and return-pc. + (inst lea rsp-tn + (make-ea :qword :base rbp-tn + :disp (- (* (1+ (tn-offset return-pc)) word-bytes)))) + ;; Restore the old fp. old-fp may be either on the stack in its + ;; save location or in a register, in either case this restores it. + (move rbp-tn old-fp) + ;; The return pops the return address (8 bytes), then we need + ;; to pop all the slots before the return-pc which includes the + ;; 8 bytes for the old-fp. + (inst ret (* (tn-offset return-pc) word-bytes)))) + + (trace-table-entry trace-table-normal))) + + +;;;; Full call: +;;; +;;; There is something of a cross-product effect with full calls. Different +;;; versions are used depending on whether we know the number of arguments or +;;; the name of the called function, and whether we want fixed values, unknown +;;; values, or a tail call. +;;; +;;; In full call, the arguments are passed creating a partial frame on the +;;; stack top and storing stack arguments into that frame. On entry to the +;;; callee, this partial frame is pointed to by FP. + +;;; Define-Full-Call -- Internal +;;; +;;; This macro helps in the definition of full call VOPs by avoiding code +;;; replication in defining the cross-product VOPs. +;;; +;;; Name is the name of the VOP to define. +;;; +;;; Named is true if the first argument is an fdefinition object whose +;;; definition is to be called. +;;; +;;; Return is either :Fixed, :Unknown or :Tail: +;;; -- If :Fixed, then the call is for a fixed number of values, returned in +;;; the standard passing locations (passed as result operands). +;;; -- If :Unknown, then the result values are pushed on the stack, and the +;;; result values are specified by the Start and Count as in the +;;; unknown-values continuation representation. +;;; -- If :Tail, then do a tail-recursive call. No values are returned. +;;; The Old-Fp and Return-PC are passed as the second and third arguments. +;;; +;;; In non-tail calls, the pointer to the stack arguments is passed as the last +;;; fixed argument. If Variable is false, then the passing locations are +;;; passed as a more arg. Variable is true if there are a variable number of +;;; arguments passed on the stack. Variable cannot be specified with :Tail +;;; return. TR variable argument call is implemented separately. +;;; +;;; In tail call with fixed arguments, the passing locations are passed as a +;;; more arg, but there is no new-FP, since the arguments have been set up in +;;; the current frame. +;;; +(defmacro define-full-call (name named return variable) + (assert (not (and variable (eq return :tail)))) + `(define-vop (,name + ,@(when (eq return :unknown) + '(unknown-values-receiver))) + (:args + ,@(unless (eq return :tail) + '((new-fp :scs (any-reg) :to (:argument 1)))) + + (fun :scs (descriptor-reg control-stack) + :target rax :to (:argument 0)) + + ,@(when (eq return :tail) + '((old-fp) + (return-pc))) + + ,@(unless variable '((args :more t :scs (descriptor-reg))))) + + ,@(when (eq return :fixed) + '((:results (values :more t)))) + + (:save-p ,(if (eq return :tail) :compute-only t)) + + ,@(unless (or (eq return :tail) variable) + '((:move-args :full-call))) + + (:vop-var vop) + (:info + ,@(unless (or variable (eq return :tail)) '(arg-locs)) + ,@(unless variable '(nargs)) + ,@(when (eq return :fixed) '(nvals))) + + (:ignore + ,@(unless (or variable (eq return :tail)) '(arg-locs)) + ,@(unless variable '(args))) + + ;; We pass either the fdefn object (for named call) or the actual + ;; function object (for unnamed call) in RAX. With named call, + ;; closure-tramp will replace it with the real function and invoke + ;; the real function for closures. Non-closures do not need this + ;; value, so don't care what shows up in it. + (:temporary + (:sc descriptor-reg :offset rax-offset :from (:argument 0) :to :eval) + rax) + + ;; We pass the number of arguments in RCX. + (:temporary (:sc unsigned-reg :offset rcx-offset :to :eval) rcx) + + ;; With variable call, we have to load the register-args out + ;; of the (new) stack frame before doing the call. Therefore, + ;; we have to tell the lifetime stuff that we need to use them. + ,@(when variable + (mapcar #'(lambda (name offset) + `(:temporary (:sc descriptor-reg + :offset ,offset + :from (:argument 0) + :to :eval) + ,name)) + register-arg-names register-arg-offsets)) + + ,@(when (eq return :tail) + '((:temporary (:sc unsigned-reg + :from (:argument 1) :to (:argument 2)) old-fp-tmp))) + + (:generator ,(+ (if named 5 0) + (if variable 19 1) + (if (eq return :tail) 0 10) + 15 + (if (eq return :unknown) 25 0)) + (trace-table-entry trace-table-call-site) + + ;; This has to be done before the frame pointer is changed! + ;; rax stores the 'lexical environment' needed for closures + (move rax fun) + + + ,@(if variable + ;; For variable call, compute the number of arguments and + ;; move some of the arguments to registers. + (collect ((noise)) + ;; Compute the number of arguments. + (noise '(inst mov rcx new-fp)) + (noise '(inst sub rcx rsp-tn)) + (noise '(inst shr rcx 1)) + ;; Move the necessary args to registers, this + ;; moves them all even if they are not all needed. + (loop + for name in register-arg-names + for index downfrom -1 + do (noise `(loadw ,name new-fp ,index))) + (noise)) + '((if (zerop nargs) + (inst xor rcx rcx) + (inst mov rcx (fixnumize nargs))))) + ,@(cond ((eq return :tail) + '(;; Python has figured out what frame we should return + ;; to so might as well use that clue. This seems + ;; really important to the implementation of things + ;; like (without-interrupts ...) + + ;; dtc; Could be doing a tail call from a + ;; known-local-call etc in which the old-fp or ret-pc + ;; are in regs or in non-standard places. If the + ;; passing location were wired to the stack in + ;; standard locations then these moves will be + ;; un-necessary; this is probably best for the x86. + (sc-case old-fp + ((control-stack) + (unless (= ocfp-save-offset (tn-offset old-fp)) + (format t "** tail-call old-fp not S0~%") + (move old-fp-tmp old-fp) + (storew old-fp-tmp rbp-tn (- (1+ ocfp-save-offset))))) + ((any-reg descriptor-reg) + (format t "** tail-call old-fp in reg not S0~%") + (storew old-fp rbp-tn (- (1+ ocfp-save-offset))))) + + ;; For tail call, we have to push the return-pc so + ;; that it looks like we CALLed despite the fact that + ;; we are going to JMP. + (inst push return-pc) + )) + (t + ;; For non-tail call, we have to save our frame pointer + ;; and install the new frame pointer. We can't load stack + ;; tns after this point. + `(;; Python doesn't seem to allocate a frame here which + ;; doesn't leave room for the ofp/ret stuff. + + ;; The variable args are on the stack and become the + ;; frame, but there may be <3 args and 3 stack slots + ;; are assumed allocate on the call. So need to ensure + ;; there are at least 3 slots. This hack just adds 3 + ;; more. + ,(if variable + '(inst sub rsp-tn (* 3 word-bytes))) + + ;; Save the fp + (storew rbp-tn new-fp (- (1+ ocfp-save-offset))) + + (move rbp-tn new-fp) ; NB - now on new stack frame. + ))) + + (note-this-location vop :call-site) + + (inst ,(if (eq return :tail) 'jmp 'call) + (make-ea :qword :base rax + :disp ,(if named + '(- (* fdefn-raw-addr-slot word-bytes) + other-pointer-type) + '(- (* closure-function-slot word-bytes) + function-pointer-type)))) + ,@(ecase return + (:fixed + '((default-unknown-values vop values nvals))) + (:unknown + '((note-this-location vop :unknown-return) + (receive-unknown-values values-start nvals start count))) + (:tail)) + (trace-table-entry trace-table-normal)))) + + +(define-full-call call nil :fixed nil) +(define-full-call call-named t :fixed nil) +(define-full-call multiple-call nil :unknown nil) +(define-full-call multiple-call-named t :unknown nil) +(define-full-call tail-call nil :tail nil) +(define-full-call tail-call-named t :tail nil) + +(define-full-call call-variable nil :fixed t) +(define-full-call multiple-call-variable nil :unknown t) + + +;;; Defined separately, since needs special code that BLT's the arguments +;;; down. All the real work is done in the assembly routine. We just +;;; set things up so that it can find what it needs. +;;; +(define-vop (tail-call-variable) + (:args (args :scs (any-reg control-stack) :target rsi) + (function :scs (descriptor-reg control-stack) :target rax) + (old-fp) + (ret-addr)) + (:temporary (:sc unsigned-reg :offset rsi-offset :from (:argument 0)) rsi) + (:temporary (:sc unsigned-reg :offset rax-offset :from (:argument 1)) rax) +; (:ignore ret-addr old-fp) + (:generator 75 + ;; Move these into the passing locations if they are not already there. + (move rsi args) + (move rax function) + + ;; The following assumes that the return-pc and old-fp are on the + ;; stack in their standard save locations - Check this. + (unless (and (sc-is old-fp control-stack) + (= (tn-offset old-fp) ocfp-save-offset)) + (error "tail-call-variable: ocfp not on stack in standard save location?")) + (unless (and (sc-is ret-addr sap-stack) + (= (tn-offset ret-addr) return-pc-save-offset)) + (error "tail-call-variable: ret-addr not on stack in standard save location?")) + + + ;; And jump to the assembly routine. + (inst jmp (make-fixup 'tail-call-variable :assembly-routine)))) + + +;;;; Unknown values return: + +;;; Return a single-value using the Unknown-Values convention. Specifically, +;;; we jump to clear the stack and jump to return-pc+3. 3 is the number of +;;; bytes for the next instruction (MOV). +;;; +;;; We require old-fp to be in a register, because we want to reset rSP before +;;; restoring rBP. If old-fp were still on the stack, it could get clobbered +;;; by a signal. +;;; +;;; pfw--get wired-tn conflicts sometimes if register sc specd for args +;;; having problems targeting args to regs -- using temps instead. +(define-vop (return-single) + (:args (old-fp) + (return-pc) + (value)) + (:temporary (:sc unsigned-reg) ofp) + (:temporary (:sc unsigned-reg) ret) + (:ignore value) + (:generator 6 + (trace-table-entry trace-table-function-epilogue) + (move ret return-pc) + ;; Clear the control stack + (move ofp old-fp) + ;; Adjust the return address for the single value return. + (inst add ret 3) + ;; Restore the frame pointer. + (move rsp-tn rbp-tn) + (move rbp-tn ofp) + ;; Out of here. + (inst jmp ret))) + +;;; Do unknown-values return of a fixed (other than 1) number of values. The +;;; Values are required to be set up in the standard passing locations. Nvals +;;; is the number of values returned. +;;; +;;; Basically, we just load rCX with the number of values returned and rBX +;;; with a pointer to the values, set rSP to point to the end of the values, +;;; and jump directly to return-pc. +;;; +(define-vop (return) + (:args (old-fp) + (return-pc :to (:eval 1)) + (values :more t)) + (:ignore values) + (:info nvals) + + ;; In the case of other than one value, we need these registers to tell + ;; the caller where they are and how many there are. + (:temporary (:sc unsigned-reg :offset rbx-offset) rbx) + (:temporary (:sc unsigned-reg :offset rcx-offset) rcx) + + ;; We need to stretch the lifetime of return-pc past the argument + ;; registers so that we can default the argument registers without + ;; trashing return-pc. + (:temporary (:sc unsigned-reg :offset (first register-arg-offsets) + :from :eval) a0) + (:temporary (:sc unsigned-reg :offset (second register-arg-offsets) + :from :eval) a1) + (:temporary (:sc unsigned-reg :offset (third register-arg-offsets) + :from :eval) a2) + + (:generator 6 + (trace-table-entry trace-table-function-epilogue) + ;; Establish the values pointer and values count. + (move rbx rbp-tn) + (if (zerop nvals) + (inst xor rcx rcx) ; smaller + (inst mov rcx (fixnumize nvals))) + ;; restore the frame pointer. + (move rbp-tn old-fp) + ;; clear as much of the stack as possible, but not past the return + ;; address. + (inst lea rsp-tn (make-ea :qword :base rbx + :disp (- (* (max nvals 2) word-bytes)))) + ;; pre-default any argument register that need it. + (when (< nvals register-arg-count) + (let* ((arg-tns (nthcdr nvals (list a0 a1 a2))) + (first (first arg-tns))) + (inst mov first nil-value) + (dolist (tn (cdr arg-tns)) + (inst mov tn first)))) + ;; And away we go. Except that return-pc is still on the + ;; stack and we've changed the stack pointer. So we have to + ;; tell it to index off of RBX instead of RBP. + (cond ((zerop nvals) + ;; Return popping the return address and the OCFP. + (inst ret word-bytes)) + ((= nvals 1) + ;; Return popping the return, leaving 1 slot. Can this + ;; happen, or is a single value return handled elsewhere? + (inst ret)) + (t + (inst jmp (make-ea :qword :base rbx + :disp (- (* (1+ (tn-offset return-pc)) + word-bytes)))))) + + (trace-table-entry trace-table-normal))) + +;;; Do unknown-values return of an arbitrary number of values (passed on the +;;; stack.) We check for the common case of a single return value, and do that +;;; inline using the normal single value return convention. Otherwise, we +;;; branch off to code that calls an assembly-routine. +;;; +;;; The assembly routine takes the following args: +;;; rAX -- the return-pc to finally jump to. +;;; rBX -- pointer to where to put the values. +;;; rCX -- number of values to find there. +;;; rSI -- pointer to where to find the values. +;;; +(define-vop (return-multiple) + (:args (old-fp :to (:eval 1) :target old-fp-temp) + (return-pc :target rax) + (vals :scs (any-reg) :target rsi) + (nvals :scs (any-reg) :target rcx)) + + (:temporary (:sc unsigned-reg :offset rax-offset :from (:argument 1)) rax) + (:temporary (:sc unsigned-reg :offset rsi-offset :from (:argument 2)) rsi) + (:temporary (:sc unsigned-reg :offset rcx-offset :from (:argument 3)) rcx) + (:temporary (:sc unsigned-reg :offset rbx-offset :from (:eval 0)) rbx) + (:temporary (:sc descriptor-reg :offset (first register-arg-offsets) + :from (:eval 0)) a0) + (:temporary (:sc unsigned-reg :from (:eval 1)) old-fp-temp) + (:node-var node) + + (:generator 13 + (trace-table-entry trace-table-function-epilogue) + ;; Load the return-pc. + (move rax return-pc) + (unless (policy node (> space speed)) + ;; Check for the single case. + (let ((not-single (gen-label))) + (inst cmp nvals (fixnumize 1)) + (inst jmp :ne not-single) + + ;; Return with one value. + (loadw a0 vals -1) + ;; Clear the stack. We load old-fp into a register before clearing + ;; the stack. + (move old-fp-temp old-fp) + (move rsp-tn rbp-tn) + (move rbp-tn old-fp-temp) + ;; Fix the return-pc to point at the single-value entry point. + (inst add rax 3) + ;; Out of here. + (inst jmp rax) + + ;; Nope, not the single case. Jump to the assembly routine. + (emit-label not-single))) + (move rsi vals) + (move rcx nvals) + (move rbx rbp-tn) + (move rbp-tn old-fp) + (inst jmp (make-fixup 'return-multiple :assembly-routine)) + (trace-table-entry trace-table-normal))) + + +;;;; XEP hackery: + +;;; We don't need to do anything special for regular functions. +;;; +(define-vop (setup-environment) + (:info label) + (:ignore label) + (:generator 0 + ;; Don't bother doing anything. + nil)) + +;;; Get the lexical environment from it's passing location. +;;; +(define-vop (setup-closure-environment) + (:results (closure :scs (descriptor-reg))) + (:info label) + (:ignore label) + (:generator 6 + ;; Get result. + (move closure rax-tn))) + +;;; Copy a more arg from the argument area to the end of the current frame. +;;; Fixed is the number of non-more arguments. +;;; +;;; The tricky part is doing this without trashing any of the calling +;;; convention registers that are still needed. This vop is emitted directly +;;; after the xep-allocate frame. That means the registers are in use as +;;; follows: +;;; +;;; RAX -- The lexenv. +;;; RBX -- Available. +;;; RCX -- The total number of arguments. +;;; RDX -- The first arg. +;;; RDI -- The second arg. +;;; RSI -- The third arg. +;;; +;;; So basically, we have one register available for our use: RBX. +;;; +;;; What we can do is push the other regs onto the stack, and then restore +;;; their values by looking directly below where we put the more-args. +;;; +(define-vop (copy-more-arg) + (:info fixed) + (:generator 20 + ;; Avoid the copy if there are no more args. + (cond ((zerop fixed) + (inst jecxz just-alloc-frame)) + (t + (inst cmp rcx-tn (fixnumize fixed)) + (inst jmp :be just-alloc-frame))) + + ;; Allocate the space on the stack. + ;; stack = rbp - (max 3 frame-size) - (nargs - fixed) + (inst lea rbx-tn + (make-ea :qword :base rbp-tn + :disp (* word-bytes + (- fixed (max 3 (sb-allocated-size 'stack)))))) + (inst sub rbx-tn rcx-tn) ; need to do this twice since rcx-tn has only 2 tag bits + (inst sub rbx-tn rcx-tn) ; Got the new stack in rbx + (inst mov rsp-tn rbx-tn) + + ;; Now: nargs>=1 && nargs>fixed + + ;; Save the original count of args. + (inst mov rbx-tn rcx-tn) + + (cond ((< fixed register-arg-count) + ;; We must stop when we run out of stack args, not when we + ;; run out of more args. + ;; Number to copy = nargs-3 + (inst sub rcx-tn (fixnumize register-arg-count)) + ;; Everything of interest in registers. + (inst jmp :be do-regs)) + (t + ;; Number to copy = nargs-fixed + (inst sub rcx-tn (fixnumize fixed)))) + + ;; Save rdi and rsi register args. + (inst push rdi-tn) + (inst push rsi-tn) + ;; Okay, we have pushed the register args. We can trash them + ;; now. + + ;; Initialize dst to be end of stack; skiping the values pushed + ;; above. + (inst lea rdi-tn (make-ea :qword :base rsp-tn :disp (* 2 word-bytes))) + + ;; Initialize src to be end of args. + (inst mov rsi-tn rbp-tn) + (inst sub rsi-tn rbx-tn) + (inst sub rsi-tn rbx-tn) ; need to do this twice since rbx-tn has only 2 tag bits + + (inst shr rcx-tn 2) ; make word count + ;; And copy the args. + (inst cld) ; auto-inc RSI and RDI. + (inst rep) + (inst movs :qword) + + ;; So now we need to restore RDI and RSI. + (inst pop rsi-tn) + (inst pop rdi-tn) + + DO-REGS + + ;; Restore RCX + (inst mov rcx-tn rbx-tn) + + ;; Here: nargs>=1 && nargs>fixed + (when (< fixed register-arg-count) + ;; Now we have to deposit any more args that showed up in + ;; registers. + (do ((i fixed)) + ( nil ) + ;; Store it relative to rbp + (inst mov (make-ea :qword :base rbp-tn + :disp (- (* word-bytes + (+ 1 (- i fixed) + (max 3 (sb-allocated-size 'stack)))))) + (nth i register-arg-tns)) + + (incf i) + (when (>= i register-arg-count) + (return)) + + ;; Don't deposit any more than there are. + (if (zerop i) + (inst test rcx-tn rcx-tn) + (inst cmp rcx-tn (fixnumize i))) + (inst jmp :eq done))) + + (inst jmp done) + + JUST-ALLOC-FRAME + (inst lea rsp-tn + (make-ea :qword :base rbp-tn + :disp (- (* vm:word-bytes + (max 3 (sb-allocated-size 'stack)))))) + + DONE)) + +;;; More args are stored contiguously on the stack, starting +;;; immediately at the context pointer. The context pointer is not +;;; typed, so the lowtag is 0. +;;; +(define-vop (more-arg) + (:translate %more-arg) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg) :to :result) + (index :scs (any-reg) :target temp)) + (:arg-types * tagged-num) + (:temporary (:sc unsigned-reg :from (:argument 1) :to :result) temp) + (:results (value :scs (any-reg descriptor-reg))) + (:result-types *) + (:generator 5 + (move temp index) + (inst neg temp) + ;; temp is tagged by 2 bits, we need another factor of 2 + (inst mov value (make-ea :qword :base object :index temp :scale 2)))) + +(define-vop (more-arg-c) + (:translate %more-arg) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg))) + (:info index) + (:arg-types * (:constant (signed-byte 30))) + (:results (value :scs (any-reg descriptor-reg))) + (:result-types *) + (:generator 4 + (inst mov value + (make-ea :qword :base object :disp (- (* index word-bytes)))))) + + +;;; Turn more arg (context, count) into a list. +;;; +(define-vop (listify-rest-args) + (:translate %listify-rest-args) + (:policy :safe) + (:args (context :scs (descriptor-reg) :target src) + (count :scs (any-reg) :target rcx)) + (:info dynamic-extent) + (:arg-types * tagged-num (:constant t)) + (:temporary (:sc unsigned-reg :offset rsi-offset :from (:argument 0)) src) + (:temporary (:sc unsigned-reg :offset rcx-offset :from (:argument 1)) rcx) + (:temporary (:sc unsigned-reg :offset rax-offset) rax) + (:temporary (:sc unsigned-reg) dst) + (:results (result :scs (descriptor-reg))) + (:node-var node) + (:generator 20 + (let ((enter (gen-label)) + (loop (gen-label)) + (done (gen-label))) + (move src context) + (move rcx count) + ;; Check to see if there are no arguments, and just return NIL if so. + (inst mov result nil-value) + (inst jecxz done) + (inst lea dst (make-ea :qword :index rcx :scale 4)) ; 2 words for each arg + (let ((*enable-pseudo-atomic* (unless dynamic-extent + *enable-pseudo-atomic*))) + (pseudo-atomic + (allocation dst dst rax node dynamic-extent) + (inst lea dst (make-ea :byte :base dst :disp list-pointer-type)) + ;; Convert the count into a raw value, so we can use the LOOP inst. + (inst shr rcx 2) + ;; Set decrement mode (successive args at lower addresses) + (inst std) + ;; Set up the result. + (move result dst) + ;; Jump into the middle of the loop, 'cause that's were we want + ;; to start. + (inst jmp enter) + (emit-label loop) + ;; Compute a pointer to the next cons. + (inst add dst (* cons-size word-bytes)) + ;; Store a pointer to this cons in the CDR of the previous cons. + (storew dst dst -1 list-pointer-type) + (emit-label enter) + ;; Grab one value and stash it in the car of this cons. + (inst lods rax) + (storew rax dst 0 list-pointer-type) + ;; Go back for more. + (inst loop loop) + ;; NIL out the last cons. + (storew nil-value dst 1 vm:list-pointer-type))) + (emit-label done)))) + +;;; Return the location and size of the more arg glob created by Copy-More-Arg. +;;; Supplied is the total number of arguments supplied (originally passed in +;;; rCX.) Fixed is the number of non-rest arguments. +;;; +;;; We must duplicate some of the work done by Copy-More-Arg, since at that +;;; time the environment is in a pretty brain-damaged state, preventing this +;;; info from being returned as values. What we do is compute +;;; supplied - fixed, and return a pointer that many words below the current +;;; stack top. +;;; +(define-vop (more-arg-context) + (:policy :fast-safe) + (:translate c::%more-arg-context) + (:args (supplied :scs (any-reg) :target count)) + (:arg-types positive-fixnum (:constant fixnum)) + (:info fixed) + (:results (context :scs (descriptor-reg)) + (count :scs (any-reg))) + (:result-types t tagged-num) + (:note "more-arg-context") + (:generator 5 + (move count supplied) + ;; SP at this point points at the last arg pushed. + ;; Point to the first more-arg, not above it. + (inst lea context (make-ea :qword :base rsp-tn + :index count :scale 2 ; count has 2 tag bits + :disp (- (* (1+ fixed) vm:word-bytes)))) + (unless (zerop fixed) + (inst sub count (fixnumize fixed))))) + +;;; Signal wrong argument count error if Nargs isn't = to Count. +;;; +(define-vop (verify-argument-count) + (:policy :fast-safe) + (:translate c::%verify-argument-count) + (:args (nargs :scs (any-reg))) + (:arg-types positive-fixnum (:constant t)) + (:info count) + (:vop-var vop) + (:save-p :compute-only) + (:generator 3 + (let ((err-lab + (generate-error-code vop invalid-argument-count-error nargs))) + (if (zerop count) + (inst test nargs nargs) ; smaller instruction + (inst cmp nargs (fixnumize count))) + (inst jmp :ne err-lab)))) + +;;; Various other error signallers. +;;; +(macrolet ((frob (name error translate &rest args) + `(define-vop (,name) + ,@(when translate + `((:policy :fast-safe) + (:translate ,translate))) + (:args ,@(mapcar #'(lambda (arg) + `(,arg :scs (any-reg descriptor-reg))) + args)) + (:vop-var vop) + (:save-p :compute-only) + (:generator 1000 + (error-call vop ,error ,@args))))) + (frob argument-count-error invalid-argument-count-error + c::%argument-count-error nargs) + (frob type-check-error object-not-type-error c::%type-check-error + object type) + (frob layout-invalid-error layout-invalid-error c::%layout-invalid-error + object layout) + (frob odd-keyword-arguments-error odd-keyword-arguments-error + c::%odd-keyword-arguments-error) + (frob unknown-keyword-argument-error unknown-keyword-argument-error + c::%unknown-keyword-argument-error key) + (frob nil-function-returned-error nil-function-returned-error nil fun)) diff --git a/compiler/amd64/cell.lisp b/compiler/amd64/cell.lisp new file mode 100644 index 0000000000000000000000000000000000000000..224aa8c8b3bf5021941417a7fd86a0dd0e797ffe --- /dev/null +++ b/compiler/amd64/cell.lisp @@ -0,0 +1,394 @@ +;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; 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: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/amd64/cell.lisp,v 1.1 2004/05/24 22:34:59 cwang Exp $") +;;; +;;; ********************************************************************** +;;; +;;; This file contains the VM definition of various primitive memory access +;;; VOPs for the amd64. +;;; +;;; Written by William Lott. +;;; +;;; Debugged by Paul F. Werkowski Spring/Summer 1995. +;;; Enhancements/debugging by Douglas T. Crosher 1996,1997,1999. +;;; + +(in-package :amd64) + + + +;;;; Data object ref/set stuff. + +(define-vop (slot) + (:args (object :scs (descriptor-reg))) + (:info name offset lowtag) + (:ignore name) + (:results (result :scs (descriptor-reg any-reg))) + (:generator 1 + (loadw result object offset lowtag))) + +(define-vop (set-slot) + (:args (object :scs (descriptor-reg)) + (value :scs (descriptor-reg any-reg immediate))) + (:info name offset lowtag) + (:ignore name) + (:results) + (:generator 1 + (if (sc-is value immediate) + (let ((val (tn-value value))) + (etypecase val + (integer + (inst mov + (make-ea :qword :base object + :disp (- (* offset word-bytes) lowtag)) + (fixnumize val))) + (symbol + (inst mov + (make-ea :qword :base object + :disp (- (* offset word-bytes) lowtag)) + (+ nil-value (static-symbol-offset val)))) + (character + (inst mov + (make-ea :qword :base object + :disp (- (* offset word-bytes) lowtag)) + (logior (ash (char-code val) type-bits) + base-char-type))))) + ;; Else, value not immediate. + (storew value object offset lowtag)))) + + + +;;;; Symbol hacking VOPs: + +;;; these next two cf the sparc version, by jrd. + +;;; The compiler likes to be able to directly SET symbols. +;;; +(define-vop (set cell-set) + (:variant symbol-value-slot other-pointer-type)) + +;;; Do a cell ref with an error check for being unbound. +;;; +(define-vop (checked-cell-ref) + (:args (object :scs (descriptor-reg) :target obj-temp)) + (:results (value :scs (descriptor-reg any-reg))) + (:policy :fast-safe) + (:vop-var vop) + (:save-p :compute-only) + (:temporary (:sc descriptor-reg :from (:argument 0)) obj-temp)) + + + +;;; With Symbol-Value, we check that the value isn't the trap object. So +;;; Symbol-Value of NIL is NIL. +;;; +(define-vop (symbol-value) + (:translate symbol-value) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg) :to (:result 1))) + (:results (value :scs (descriptor-reg any-reg))) + (:vop-var vop) + (:save-p :compute-only) + (:generator 9 + (let ((err-lab (generate-error-code vop unbound-symbol-error object))) + (loadw value object symbol-value-slot other-pointer-type) + (inst cmp value unbound-marker-type) + (inst jmp :e err-lab)))) + +(define-vop (fast-symbol-value cell-ref) + (:variant symbol-value-slot other-pointer-type) + (:policy :fast) + (:translate symbol-value)) + +(export 'kernel::set-symbol-value-conditional "KERNEL") +(defknown kernel::set-symbol-value-conditional (symbol t t) t (unsafe)) + +(define-vop (set-symbol-value-conditional cell-set-conditional) + (:translate kernel::set-symbol-value-conditional) + (:variant symbol-value-slot other-pointer-type) + (:policy :fast-safe)) + +(defknown fast-symbol-value-xadd (symbol fixnum) fixnum ()) +(define-vop (fast-symbol-value-xadd cell-xadd) + (:variant symbol-value-slot other-pointer-type) + (:policy :fast) + (:translate fast-symbol-value-xadd) + (:arg-types * tagged-num)) + +(define-vop (boundp) + (:translate boundp) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg))) + (:conditional) + (:info target not-p) + (:temporary (:sc descriptor-reg :from (:argument 0)) value) + (:generator 9 + (loadw value object symbol-value-slot other-pointer-type) + (inst cmp value unbound-marker-type) + (inst jmp (if not-p :e :ne) target))) + +(define-vop (symbol-hash) + (:policy :fast-safe) + (:translate symbol-hash) + (:args (symbol :scs (descriptor-reg))) + (:results (res :scs (any-reg))) + (:result-types positive-fixnum) + (:generator 2 + ;; the symbol-hash slot of NIL holds NIL because it is also the cdr + ;; slot, so we have to strip off the two low bits to make sure it is + ;; a fixnum. + (loadw res symbol symbol-hash-slot other-pointer-type) + (inst and res (lognot #b11)))) + + +;;;; Fdefinition (fdefn) objects. + +(define-vop (fdefn-function cell-ref) ; /pfw - alpha + (:variant fdefn-function-slot other-pointer-type)) + +(define-vop (safe-fdefn-function) + (:args (object :scs (descriptor-reg) :to (:result 1))) + (:results (value :scs (descriptor-reg any-reg))) + (:vop-var vop) + (:save-p :compute-only) + (:generator 10 + (loadw value object fdefn-function-slot other-pointer-type) + (inst cmp value nil-value) + (let ((err-lab (generate-error-code vop undefined-symbol-error object))) + (inst jmp :e err-lab)))) + +(define-vop (set-fdefn-function) + (:policy :fast-safe) + (:translate (setf fdefn-function)) + (:args (function :scs (descriptor-reg) :target result) + (fdefn :scs (descriptor-reg))) + (:temporary (:sc unsigned-reg) raw) + (:temporary (:sc byte-reg) type) + (:results (result :scs (descriptor-reg))) + (:generator 38 + (load-type type function (- function-pointer-type)) + (inst lea raw + (make-ea :byte :base function + :disp (- (* function-code-offset word-bytes) + function-pointer-type))) + (inst cmp type function-header-type) + (inst jmp :e normal-fn) + (inst mov-imm raw (make-fixup (extern-alien-name "closure_tramp") :foreign)) + NORMAL-FN + (storew function fdefn fdefn-function-slot other-pointer-type) + (storew raw fdefn fdefn-raw-addr-slot other-pointer-type) + (move result function))) + +(define-vop (fdefn-makunbound) + (:policy :fast-safe) + (:translate fdefn-makunbound) + (:args (fdefn :scs (descriptor-reg) :target result)) + (:results (result :scs (descriptor-reg))) + (:generator 38 + (storew nil-value fdefn fdefn-function-slot other-pointer-type) + (storew (make-fixup (extern-alien-name "undefined_tramp") :foreign) + fdefn fdefn-raw-addr-slot other-pointer-type) + (move result fdefn))) + + + +;;;; Binding and Unbinding. + +;;; BIND -- Establish VAL as a binding for SYMBOL. Save the old value and +;;; the symbol on the binding stack and stuff the new value into the +;;; symbol. + +(define-vop (bind) + (:args (val :scs (any-reg descriptor-reg)) + (symbol :scs (descriptor-reg))) + (:temporary (:sc descriptor-reg) temp) + (:temporary (:sc any-reg) bsp) + (:temporary (:sc any-reg) temp2) + (:generator 5 + (load-symbol-value bsp *binding-stack-pointer*) + (loadw temp symbol symbol-value-slot other-pointer-type) + (inst add bsp (* binding-size word-bytes)) + (store-symbol-value bsp *binding-stack-pointer* temp2) + (storew temp bsp (- binding-value-slot binding-size)) + (storew symbol bsp (- binding-symbol-slot binding-size)) + (storew val symbol symbol-value-slot other-pointer-type))) + +(define-vop (unbind) + (:temporary (:sc descriptor-reg) symbol value) + (:temporary (:sc any-reg) bsp) + (:generator 0 + (load-symbol-value bsp *binding-stack-pointer*) + (loadw symbol bsp (- binding-symbol-slot binding-size)) + (loadw value bsp (- binding-value-slot binding-size)) + (storew value symbol symbol-value-slot other-pointer-type) + (storew 0 bsp (- binding-symbol-slot binding-size)) + (inst sub bsp (* binding-size word-bytes)) + (store-symbol-value bsp *binding-stack-pointer* symbol))) + + +(define-vop (unbind-to-here) + (:args (where :scs (descriptor-reg any-reg))) + (:temporary (:sc descriptor-reg) symbol value) + (:temporary (:sc any-reg) bsp) + (:generator 0 + (load-symbol-value bsp *binding-stack-pointer*) + (inst cmp where bsp) + (inst jmp :e done) + + LOOP + (loadw symbol bsp (- binding-symbol-slot binding-size)) + (inst or symbol symbol) + (inst jmp :z skip) + (loadw value bsp (- binding-value-slot binding-size)) + (storew value symbol symbol-value-slot other-pointer-type) + (storew 0 bsp (- binding-symbol-slot binding-size)) + + SKIP + (inst sub bsp (* binding-size word-bytes)) + (inst cmp where bsp) + (inst jmp :ne loop) + (store-symbol-value bsp *binding-stack-pointer* symbol) + + DONE)) + + + +;;;; Closure indexing. + +(define-full-reffer closure-index-ref * + closure-info-offset function-pointer-type + (any-reg descriptor-reg) * %closure-index-ref) + +(define-full-setter set-funcallable-instance-info * + funcallable-instance-info-offset function-pointer-type + (any-reg descriptor-reg) * %set-funcallable-instance-info) + +(define-full-reffer funcallable-instance-info * + funcallable-instance-info-offset function-pointer-type + (descriptor-reg any-reg) * %funcallable-instance-info) + +(define-vop (funcallable-instance-lexenv cell-ref) + (:variant funcallable-instance-lexenv-slot function-pointer-type)) + +(define-vop (closure-ref slot-ref) + (:variant closure-info-offset function-pointer-type)) + +(define-vop (closure-init slot-set) + (:variant closure-info-offset function-pointer-type)) + + + +;;;; Value Cell hackery. + +(define-vop (value-cell-ref cell-ref) + (:variant value-cell-value-slot other-pointer-type)) + +(define-vop (value-cell-set cell-set) + (:variant value-cell-value-slot other-pointer-type)) + + +;;;; Structure hackery: + +(define-vop (instance-length) + (:policy :fast-safe) + (:translate %instance-length) + (:args (struct :scs (descriptor-reg))) + (:results (res :scs (unsigned-reg))) + (:result-types positive-fixnum) + (:generator 4 + (loadw res struct 0 instance-pointer-type) + (inst shr res type-bits))) + +(define-vop (instance-ref slot-ref) + (:variant instance-slots-offset instance-pointer-type) + (:policy :fast-safe) + (:translate %instance-ref) + (:arg-types instance (:constant index))) + +(define-vop (instance-set slot-set) + (:policy :fast-safe) + (:translate %instance-set) + (:variant instance-slots-offset instance-pointer-type) + (:arg-types instance (:constant index) *)) + +(define-full-reffer instance-index-ref * instance-slots-offset + instance-pointer-type (any-reg descriptor-reg) * %instance-ref) + +(define-full-setter instance-index-set * instance-slots-offset + instance-pointer-type (any-reg descriptor-reg) * %instance-set) + +(export 'kernel::%instance-set-conditional "KERNEL") +(defknown kernel::%instance-set-conditional (instance index t t) t + (unsafe)) + +(define-vop (instance-set-conditional-c slot-set-conditional) + (:policy :fast-safe) + (:translate kernel::%instance-set-conditional) + (:variant instance-slots-offset instance-pointer-type) + (:arg-types instance (:constant index) * *)) + +(define-vop (instance-set-conditional) + (:translate kernel::%instance-set-conditional) + (:args (object :scs (descriptor-reg) :to :eval) + (slot :scs (any-reg) :to :result) + (old-value :scs (descriptor-reg any-reg) :target rax) + (new-value :scs (descriptor-reg any-reg))) + (:arg-types instance positive-fixnum * *) + (:temporary (:sc descriptor-reg :offset rax-offset + :from (:argument 2) :to :result :target result) rax) + (:results (result :scs (descriptor-reg any-reg))) + (:guard (backend-featurep :i486)) + (:policy :fast-safe) + (:generator 5 + (move rax old-value) + (inst cmpxchg (make-ea :qword :base object :index slot :scale 1 + :disp (- (* instance-slots-offset word-bytes) + instance-pointer-type)) + new-value) + (move result rax))) + +(defknown %instance-xadd (instance index fixnum) fixnum ()) +(define-vop (instance-xadd-c slot-xadd) + (:policy :fast-safe) + (:translate %instance-xadd) + (:variant instance-slots-offset instance-pointer-type) + (:arg-types instance (:constant index) tagged-num)) + + +;;;; Code object frobbing. + +(define-full-reffer code-header-ref * 0 other-pointer-type + (any-reg descriptor-reg) * code-header-ref) + +(define-full-setter code-header-set * 0 other-pointer-type + (any-reg descriptor-reg) * code-header-set) + + +;;;; Cons conditional setters. + +(export 'kernel::rplaca-conditional "KERNEL") +(defknown kernel::rplaca-conditional (cons t t) t + (unsafe)) + +(define-vop (rplaca-conditional cell-set-conditional) + (:policy :fast-safe) + (:translate kernel::rplaca-conditional) + (:variant cons-car-slot list-pointer-type) + (:arg-types list * *)) + +(export 'kernel::rplacd-conditional "KERNEL") +(defknown kernel::rplacd-conditional (cons t t) t + (unsafe)) + +(define-vop (rplacd-conditional cell-set-conditional) + (:policy :fast-safe) + (:translate kernel::rplacd-conditional) + (:variant cons-cdr-slot list-pointer-type) + (:arg-types list * *)) diff --git a/compiler/amd64/char.lisp b/compiler/amd64/char.lisp new file mode 100644 index 0000000000000000000000000000000000000000..43babcc79c42abe9fd2a1ab295fdbd172396b8b6 --- /dev/null +++ b/compiler/amd64/char.lisp @@ -0,0 +1,199 @@ +;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; 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: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/amd64/char.lisp,v 1.1 2004/05/24 22:34:59 cwang Rel $") +;;; +;;; ********************************************************************** +;;; +;;; This file contains the x86 VM definition of character operations. +;;; +;;; Written by Rob MacLachlan +;;; Converted for the MIPS R2000 by Christopher Hoover. +;;; And then to the SPARC by William Lott. +;;; And then to the x86, again by William. +;;; +;;; Debugged by Paul F. Werkowski, June-95. +;;; Enhancements/debugging by Douglas T. Crosher 1996,1997. +;;; + +(in-package :amd64) + + +;;;; Moves and coercions: + +;;; Move a tagged char to an untagged representation. +;;; +(define-vop (move-to-base-char) + (:args (x :scs (any-reg control-stack) :target al)) + (:temporary (:sc byte-reg :offset al-offset + :from (:argument 0) :to (:eval 0)) al) + (:ignore al) + (:temporary (:sc byte-reg :offset ah-offset :target y + :from (:argument 0) :to (:result 0)) ah) + (:results (y :scs (base-char-reg base-char-stack))) + (:note "character untagging") + (:generator 1 + (move rax-tn x) + (move y ah))) +;;; +(define-move-vop move-to-base-char :move + (any-reg control-stack) (base-char-reg base-char-stack)) + + +;;; Move an untagged char to a tagged representation. +;;; +(define-vop (move-from-base-char) + (:args (x :scs (base-char-reg base-char-stack) :target ah)) + (:temporary (:sc byte-reg :offset al-offset :target y + :from (:argument 0) :to (:result 0)) al) + (:temporary (:sc byte-reg :offset ah-offset + :from (:argument 0) :to (:result 0)) ah) + (:results (y :scs (any-reg descriptor-reg control-stack))) + (:note "character tagging") + (:generator 1 + (move ah x) ; maybe move char byte + (inst mov al base-char-type) ; #x86 to type bits + (inst and rax-tn #xffff) ; remove any junk bits + (move y rax-tn))) + +;;; +(define-move-vop move-from-base-char :move + (base-char-reg base-char-stack) (any-reg descriptor-reg control-stack)) + +;;; Move untagged base-char values. +;;; +(define-vop (base-char-move) + (:args (x :target y + :scs (base-char-reg) + :load-if (not (location= x y)))) + (:results (y :scs (base-char-reg base-char-stack) + :load-if (not (location= x y)))) + (:note "character move") + (:effects) + (:affected) + (:generator 0 + (move y x))) +;;; +(define-move-vop base-char-move :move + (base-char-reg) (base-char-reg base-char-stack)) + + +;;; Move untagged base-char arguments/return-values. +;;; +(define-vop (move-base-char-argument) + (:args (x :target y + :scs (base-char-reg)) + (fp :scs (any-reg) + :load-if (not (sc-is y base-char-reg)))) + (:results (y)) + (:note "character arg move") + (:generator 0 + (sc-case y + (base-char-reg + (move y x)) + (base-char-stack + (inst mov + (make-ea :byte :base fp :disp (- (* (1+ (tn-offset y)) word-bytes))) + x))))) +;;; +(define-move-vop move-base-char-argument :move-argument + (any-reg base-char-reg) (base-char-reg)) + + +;;; Use standard MOVE-ARGUMENT + coercion to move an untagged base-char +;;; to a descriptor passing location. +;;; +(define-move-vop move-argument :move-argument + (base-char-reg) (any-reg descriptor-reg)) + + + +;;;; Other operations: + +(define-vop (char-code) + (:translate char-code) + (:policy :fast-safe) + (:args (ch :scs (base-char-reg base-char-stack))) + (:arg-types base-char) + (:results (res :scs (unsigned-reg))) + (:result-types positive-fixnum) + (:generator 1 + ;; ah to dh are not addressable when a rex prefix is used + ;; The high 32 bits of doubleword operands are + ;; zero-extended to 64-bits. + (inst movzx (64-bit-to-32-bit-tn res) ch))) + +(define-vop (code-char) + (:translate code-char) + (:policy :fast-safe) + (:args (code :scs (unsigned-reg unsigned-stack) :target rax)) + (:arg-types positive-fixnum) + (:temporary (:sc unsigned-reg :offset rax-offset :target res + :from (:argument 0) :to (:result 0)) + rax) + (:results (res :scs (base-char-reg))) + (:result-types base-char) + (:generator 1 + (move rax code) + (move res al-tn))) + + +;;; Comparison of base-chars. +;;; +(define-vop (base-char-compare) + (:args (x :scs (base-char-reg base-char-stack)) + (y :scs (base-char-reg) + :load-if (not (and (sc-is x base-char-reg) + (sc-is y base-char-stack))))) + (:arg-types base-char base-char) + (:conditional) + (:info target not-p) + (:policy :fast-safe) + (:note "inline comparison") + (:variant-vars condition not-condition) + (:generator 3 + (inst cmp x y) + (inst jmp (if not-p not-condition condition) target))) + +(define-vop (fast-char=/base-char base-char-compare) + (:translate char=) + (:variant :e :ne)) + +(define-vop (fast-char</base-char base-char-compare) + (:translate char<) + (:variant :b :nb)) + +(define-vop (fast-char>/base-char base-char-compare) + (:translate char>) + (:variant :a :na)) + +(define-vop (base-char-compare-c) + (:args (x :scs (base-char-reg))) + (:arg-types base-char (:constant base-char)) + (:conditional) + (:info target not-p y) + (:policy :fast-safe) + (:note "inline comparison") + (:variant-vars condition not-condition) + (:generator 2 + (inst cmp x (char-code y)) + (inst jmp (if not-p not-condition condition) target))) + +(define-vop (fast-char=-c/base-char base-char-compare-c) + (:translate char=) + (:variant :eq :ne)) + +(define-vop (fast-char<-c/base-char base-char-compare-c) + (:translate char<) + (:variant :b :nb)) + +(define-vop (fast-char>-c/base-char base-char-compare-c) + (:translate char>) + (:variant :a :na)) + diff --git a/compiler/amd64/debug.lisp b/compiler/amd64/debug.lisp new file mode 100644 index 0000000000000000000000000000000000000000..e30795727c260bde171f1214c91fef744ab8e029 --- /dev/null +++ b/compiler/amd64/debug.lisp @@ -0,0 +1,163 @@ +;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; 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: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/amd64/debug.lisp,v 1.1 2004/05/24 22:34:59 cwang Rel $") +;;; +;;; ********************************************************************** +;;; +;;; Compiler support for the new whizzy debugger. +;;; +;;; Written by William Lott. +;;; +;;; Debugged by Paul F. Werkowski Spring/Summer 1995. +;;; Enhancements/debugging by Douglas T. Crosher 1996,1997. +;;; +(in-package :amd64) + +(define-vop (debug-cur-sp) + (:translate current-sp) + (:policy :fast-safe) + (:results (res :scs (sap-reg sap-stack))) + (:result-types system-area-pointer) + (:generator 1 + (move res rsp-tn))) + +(define-vop (debug-cur-fp) + (:translate current-fp) + (:policy :fast-safe) + (:results (res :scs (sap-reg sap-stack))) + (:result-types system-area-pointer) + (:generator 1 + (move res rbp-tn))) + +;;; Stack-ref and %set-stack-ref can be used to read and store +;;; descriptor objects on the control stack. Use the sap-ref +;;; functions to access other data types. +(define-vop (read-control-stack) + (:translate stack-ref) + (:policy :fast-safe) + (:args (sap :scs (sap-reg) :to :eval) + (offset :scs (any-reg) :target temp)) + (:arg-types system-area-pointer positive-fixnum) + (:temporary (:sc unsigned-reg :from (:argument 1)) temp) + (:results (result :scs (descriptor-reg))) + (:result-types *) + (:generator 9 + (move temp offset) + (inst neg temp) + (inst mov result + (make-ea :qword :base sap :disp (- word-bytes) :index temp)))) + +(define-vop (read-control-stack-c) + (:translate stack-ref) + (:policy :fast-safe) + (:args (sap :scs (sap-reg))) + (:info index) + (:arg-types system-area-pointer (:constant (signed-byte 30))) + (:results (result :scs (descriptor-reg))) + (:result-types *) + (:generator 5 + (inst mov result (make-ea :qword :base sap + :disp (- (* (1+ index) word-bytes)))))) + +(define-vop (write-control-stack) + (:translate %set-stack-ref) + (:policy :fast-safe) + (:args (sap :scs (sap-reg) :to :eval) + (offset :scs (any-reg) :target temp) + (value :scs (descriptor-reg) :to :result :target result)) + (:arg-types system-area-pointer positive-fixnum *) + (:temporary (:sc unsigned-reg :from (:argument 1) :to :result) temp) + (:results (result :scs (descriptor-reg))) + (:result-types *) + (:generator 9 + (move temp offset) + (inst neg temp) + (inst mov + (make-ea :qword :base sap :disp (- word-bytes) :index temp) value) + (move result value))) + +(define-vop (write-control-stack-c) + (:translate %set-stack-ref) + (:policy :fast-safe) + (:args (sap :scs (sap-reg)) + (value :scs (descriptor-reg) :target result)) + (:info index) + (:arg-types system-area-pointer (:constant (signed-byte 30)) *) + (:results (result :scs (descriptor-reg))) + (:result-types *) + (:generator 5 + (inst mov (make-ea :qword :base sap + :disp (- (* (1+ index) word-bytes))) + value) + (move result value))) + +(define-vop (code-from-mumble) + (:policy :fast-safe) + (:args (thing :scs (descriptor-reg))) + (:results (code :scs (descriptor-reg))) + (:temporary (:sc unsigned-reg) temp) + (:variant-vars lowtag) + (:generator 5 + (let ((bogus (gen-label)) + (done (gen-label))) + (loadw temp thing 0 lowtag) + (inst shr temp type-bits) + (inst jmp :z bogus) + (inst shl temp (1- (integer-length word-bytes))) + (unless (= lowtag other-pointer-type) + (inst add temp (- lowtag other-pointer-type))) + (move code thing) + (inst sub code temp) + (emit-label done) + (assemble (*elsewhere*) + (emit-label bogus) + (inst mov code nil-value) + (inst jmp done))))) + +(define-vop (code-from-lra code-from-mumble) + (:translate di::lra-code-header) + (:variant other-pointer-type)) + +(define-vop (code-from-function code-from-mumble) + (:translate di::function-code-header) + (:variant function-pointer-type)) + +(define-vop (make-lisp-obj) + (:policy :fast-safe) + (:translate di::make-lisp-obj) + (:args (value :scs (unsigned-reg unsigned-stack) :target result)) + (:arg-types unsigned-num) + (:results (result :scs (descriptor-reg) + :load-if (not (sc-is value unsigned-reg)) + )) + (:generator 1 + (move result value))) + +(define-vop (get-lisp-obj-address) + (:policy :fast-safe) + (:translate di::get-lisp-obj-address) + (:args (thing :scs (descriptor-reg control-stack) :target result)) + (:results (result :scs (unsigned-reg) + :load-if (not (and (sc-is thing descriptor-reg) + (sc-is result unsigned-stack))))) + (:result-types unsigned-num) + (:generator 1 + (move result thing))) + + +(define-vop (function-word-offset) + (:policy :fast-safe) + (:translate di::function-word-offset) + (:args (fun :scs (descriptor-reg))) + (:results (res :scs (unsigned-reg))) + (:result-types positive-fixnum) + (:generator 5 + (loadw res fun 0 function-pointer-type) + (inst shr res type-bits))) diff --git a/compiler/amd64/float.lisp b/compiler/amd64/float.lisp new file mode 100644 index 0000000000000000000000000000000000000000..8436916e4483598719d7f8faec507ec2e5bd6cba --- /dev/null +++ b/compiler/amd64/float.lisp @@ -0,0 +1,4647 @@ +;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; 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: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/amd64/float.lisp,v 1.1 2004/05/24 22:34:59 cwang Exp $") +;;; +;;; ********************************************************************** +;;; +;;; This file contains floating point support for the x86. +;;; +;;; Written by William Lott. +;;; +;;; Debugged by Paul F. Werkowski Spring/Summer 1995. +;;; +;;; Rewrite, enhancements, complex-float and long-float support by +;;; Douglas Crosher, 1996, 1997, 1998, 1999, 2000. +;;; + +(in-package :amd64) + + + +;;; Popping the FP stack. +;;; +;;; The default is to use a store and pop, fstp fr0. +;;; For the AMD Athlon, using ffreep fr0 is faster. +;;; +(defun fp-pop () + (if (backend-featurep :athlon) + (inst ffreep fr0-tn) + (inst fstp fr0-tn))) + + +(macrolet ((ea-for-xf-desc (tn slot) + `(make-ea + :qword :base ,tn + :disp (- (* ,slot vm:word-bytes) vm:other-pointer-type)))) + (defun ea-for-sf-desc (tn) + (ea-for-xf-desc tn vm:single-float-value-slot)) + (defun ea-for-df-desc (tn) + (ea-for-xf-desc tn vm:double-float-value-slot)) + #+long-float + (defun ea-for-lf-desc (tn) + (ea-for-xf-desc tn vm:long-float-value-slot)) + ;; Complex floats + (defun ea-for-csf-real-desc (tn) + (ea-for-xf-desc tn vm:complex-single-float-real-slot)) + (defun ea-for-csf-imag-desc (tn) + (ea-for-xf-desc tn vm:complex-single-float-imag-slot)) + (defun ea-for-cdf-real-desc (tn) + (ea-for-xf-desc tn vm:complex-double-float-real-slot)) + (defun ea-for-cdf-imag-desc (tn) + (ea-for-xf-desc tn vm:complex-double-float-imag-slot)) + #+long-float + (defun ea-for-clf-real-desc (tn) + (ea-for-xf-desc tn vm:complex-long-float-real-slot)) + #+long-float + (defun ea-for-clf-imag-desc (tn) + (ea-for-xf-desc tn vm:complex-long-float-imag-slot))) + +(macrolet ((ea-for-xf-stack (tn kind) + `(make-ea + :qword :base rbp-tn + :disp (- (* (+ (tn-offset ,tn) + (ecase ,kind (:single 1) (:double 2) (:long 3))) + vm:word-bytes))))) + (defun ea-for-sf-stack (tn) + (ea-for-xf-stack tn :single)) + (defun ea-for-df-stack (tn) + (ea-for-xf-stack tn :double)) + #+long-float + (defun ea-for-lf-stack (tn) + (ea-for-xf-stack tn :long))) + +;;; Complex float stack EAs +(macrolet ((ea-for-cxf-stack (tn kind slot &optional base) + `(make-ea + :qword :base ,base + :disp (- (* (+ (tn-offset ,tn) + (* (ecase ,kind + (:single 1) + (:double 2) + (:long 3)) + (ecase ,slot (:real 1) (:imag 2)))) + vm:word-bytes))))) + (defun ea-for-csf-real-stack (tn &optional (base rbp-tn)) + (ea-for-cxf-stack tn :single :real base)) + (defun ea-for-csf-imag-stack (tn &optional (base rbp-tn)) + (ea-for-cxf-stack tn :single :imag base)) + ;; + (defun ea-for-cdf-real-stack (tn &optional (base rbp-tn)) + (ea-for-cxf-stack tn :double :real base)) + (defun ea-for-cdf-imag-stack (tn &optional (base rbp-tn)) + (ea-for-cxf-stack tn :double :imag base)) + ;; + #+long-float + (defun ea-for-clf-real-stack (tn &optional (base rbp-tn)) + (ea-for-cxf-stack tn :long :real base)) + #+long-float + (defun ea-for-clf-imag-stack (tn &optional (base rbp-tn)) + (ea-for-cxf-stack tn :long :imag base))) + +;;; Abstract out the copying of a FP register to the FP stack top, and +;;; provide two alternatives for its implementation. Note: it's not +;;; necessary to distinguish between a single or double register move +;;; here. +;;; +;;; Using a Pop then load. +(defun copy-fp-reg-to-fr0 (reg) + (assert (not (zerop (tn-offset reg)))) + (fp-pop) + (inst fld (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg *backend*) + :offset (1- (tn-offset reg))))) +;;; +;;; Using Fxch then Fst to restore the original reg contents. +#+nil +(defun copy-fp-reg-to-fr0 (reg) + (assert (not (zerop (tn-offset reg)))) + (inst fxch reg) + (inst fst reg)) + +;;; The x86 can't store a long-float to memory without popping the +;;; stack and marking a register as empty, so it is necessary to +;;; restore the register from memory. +#+long-float +(defun store-long-float (ea) + (inst fstpl ea) + (inst fldl ea)) + + +;;;; Move functions: + +;;; x is source, y is destination +(define-move-function (load-single 2) (vop x y) + ((single-stack) (single-reg)) + (with-empty-tn@fp-top(y) + (inst fld (ea-for-sf-stack x)))) + +(define-move-function (store-single 2) (vop x y) + ((single-reg) (single-stack)) + (cond ((zerop (tn-offset x)) + (inst fst (ea-for-sf-stack y))) + (t + (inst fxch x) + (inst fst (ea-for-sf-stack y)) + ;; This may not be necessary as ST0 is likely invalid now. + (inst fxch x)))) + +(define-move-function (load-double 2) (vop x y) + ((double-stack) (double-reg)) + (with-empty-tn@fp-top(y) + (inst fldd (ea-for-df-stack x)))) + +(define-move-function (store-double 2) (vop x y) + ((double-reg) (double-stack)) + (cond ((zerop (tn-offset x)) + (inst fstd (ea-for-df-stack y))) + (t + (inst fxch x) + (inst fstd (ea-for-df-stack y)) + ;; This may not be necessary as ST0 is likely invalid now. + (inst fxch x)))) + +#+long-float +(define-move-function (load-long 2) (vop x y) + ((long-stack) (long-reg)) + (with-empty-tn@fp-top(y) + (inst fldl (ea-for-lf-stack x)))) + +#+long-float +(define-move-function (store-long 2) (vop x y) + ((long-reg) (long-stack)) + (cond ((zerop (tn-offset x)) + (store-long-float (ea-for-lf-stack y))) + (t + (inst fxch x) + (store-long-float (ea-for-lf-stack y)) + ;; This may not be necessary as ST0 is likely invalid now. + (inst fxch x)))) + +;;; The i387 has instructions to load some useful constants. +;;; This doesn't save much time but might cut down on memory +;;; access and reduce the size of the constant vector (CV). +;;; Intel claims they are stored in a more precise form on chip. +;;; Anyhow, might as well use the feature. It can be turned +;;; off by hacking the "immediate-constant-sc" in vm.lisp. +(define-move-function (load-fp-constant 2) (vop x y) + ((fp-constant) (single-reg double-reg #+long-float long-reg)) + (let ((value (c::constant-value (c::tn-leaf x)))) + (with-empty-tn@fp-top(y) + (cond ((zerop value) + (inst fldz)) + ((= value 1l0) + (inst fld1)) + ((= value pi) + (inst fldpi)) + ((= value (log 10l0 2l0)) + (inst fldl2t)) + ((= value (log 2.718281828459045235360287471352662L0 2l0)) + (inst fldl2e)) + ((= value (log 2l0 10l0)) + (inst fldlg2)) + ((= value (log 2l0 2.718281828459045235360287471352662L0)) + (inst fldln2)) + (t (warn "Ignoring bogus i387 Constant ~a" value)))))) + + +;;;; Complex float move functions + +(defun complex-single-reg-real-tn (x) + (make-random-tn :kind :normal :sc (sc-or-lose 'single-reg *backend*) + :offset (tn-offset x))) +(defun complex-single-reg-imag-tn (x) + (make-random-tn :kind :normal :sc (sc-or-lose 'single-reg *backend*) + :offset (1+ (tn-offset x)))) + +(defun complex-double-reg-real-tn (x) + (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg *backend*) + :offset (tn-offset x))) +(defun complex-double-reg-imag-tn (x) + (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg *backend*) + :offset (1+ (tn-offset x)))) + +#+long-float +(defun complex-long-reg-real-tn (x) + (make-random-tn :kind :normal :sc (sc-or-lose 'long-reg *backend*) + :offset (tn-offset x))) +#+long-float +(defun complex-long-reg-imag-tn (x) + (make-random-tn :kind :normal :sc (sc-or-lose 'long-reg *backend*) + :offset (1+ (tn-offset x)))) + +;;; x is source, y is destination +(define-move-function (load-complex-single 2) (vop x y) + ((complex-single-stack) (complex-single-reg)) + (let ((real-tn (complex-single-reg-real-tn y))) + (with-empty-tn@fp-top (real-tn) + (inst fld (ea-for-csf-real-stack x)))) + (let ((imag-tn (complex-single-reg-imag-tn y))) + (with-empty-tn@fp-top (imag-tn) + (inst fld (ea-for-csf-imag-stack x))))) + +(define-move-function (store-complex-single 2) (vop x y) + ((complex-single-reg) (complex-single-stack)) + (let ((real-tn (complex-single-reg-real-tn x))) + (cond ((zerop (tn-offset real-tn)) + (inst fst (ea-for-csf-real-stack y))) + (t + (inst fxch real-tn) + (inst fst (ea-for-csf-real-stack y)) + (inst fxch real-tn)))) + (let ((imag-tn (complex-single-reg-imag-tn x))) + (inst fxch imag-tn) + (inst fst (ea-for-csf-imag-stack y)) + (inst fxch imag-tn))) + +(define-move-function (load-complex-double 2) (vop x y) + ((complex-double-stack) (complex-double-reg)) + (let ((real-tn (complex-double-reg-real-tn y))) + (with-empty-tn@fp-top(real-tn) + (inst fldd (ea-for-cdf-real-stack x)))) + (let ((imag-tn (complex-double-reg-imag-tn y))) + (with-empty-tn@fp-top(imag-tn) + (inst fldd (ea-for-cdf-imag-stack x))))) + +(define-move-function (store-complex-double 2) (vop x y) + ((complex-double-reg) (complex-double-stack)) + (let ((real-tn (complex-double-reg-real-tn x))) + (cond ((zerop (tn-offset real-tn)) + (inst fstd (ea-for-cdf-real-stack y))) + (t + (inst fxch real-tn) + (inst fstd (ea-for-cdf-real-stack y)) + (inst fxch real-tn)))) + (let ((imag-tn (complex-double-reg-imag-tn x))) + (inst fxch imag-tn) + (inst fstd (ea-for-cdf-imag-stack y)) + (inst fxch imag-tn))) + +#+long-float +(define-move-function (load-complex-long 2) (vop x y) + ((complex-long-stack) (complex-long-reg)) + (let ((real-tn (complex-long-reg-real-tn y))) + (with-empty-tn@fp-top(real-tn) + (inst fldl (ea-for-clf-real-stack x)))) + (let ((imag-tn (complex-long-reg-imag-tn y))) + (with-empty-tn@fp-top(imag-tn) + (inst fldl (ea-for-clf-imag-stack x))))) + +#+long-float +(define-move-function (store-complex-long 2) (vop x y) + ((complex-long-reg) (complex-long-stack)) + (let ((real-tn (complex-long-reg-real-tn x))) + (cond ((zerop (tn-offset real-tn)) + (store-long-float (ea-for-clf-real-stack y))) + (t + (inst fxch real-tn) + (store-long-float (ea-for-clf-real-stack y)) + (inst fxch real-tn)))) + (let ((imag-tn (complex-long-reg-imag-tn x))) + (inst fxch imag-tn) + (store-long-float (ea-for-clf-imag-stack y)) + (inst fxch imag-tn))) + + +;;;; Move VOPs: + +;;; +;;; Float register to register moves. +;;; +(define-vop (float-move) + (:args (x)) + (:results (y)) + (:note "float move") + (:generator 0 + (unless (location= x y) + (cond ((zerop (tn-offset y)) + (copy-fp-reg-to-fr0 x)) + ((zerop (tn-offset x)) + (inst fstd y)) + (t + (inst fxch x) + (inst fstd y) + (inst fxch x)))))) + +(define-vop (single-move float-move) + (:args (x :scs (single-reg) :target y :load-if (not (location= x y)))) + (:results (y :scs (single-reg) :load-if (not (location= x y))))) +(define-move-vop single-move :move (single-reg) (single-reg)) + +(define-vop (double-move float-move) + (:args (x :scs (double-reg) :target y :load-if (not (location= x y)))) + (:results (y :scs (double-reg) :load-if (not (location= x y))))) +(define-move-vop double-move :move (double-reg) (double-reg)) + +#+long-float +(define-vop (long-move float-move) + (:args (x :scs (long-reg) :target y :load-if (not (location= x y)))) + (:results (y :scs (long-reg) :load-if (not (location= x y))))) +#+long-float +(define-move-vop long-move :move (long-reg) (long-reg)) + +;;; +;;; Complex float register to register moves. +;;; +(define-vop (complex-float-move) + (:args (x :target y :load-if (not (location= x y)))) + (:results (y :load-if (not (location= x y)))) + (:note "complex float move") + (:generator 0 + (unless (location= x y) + ;; Note the complex-float-regs are aligned to every second + ;; float register so there is not need to worry about overlap. + (let ((x-real (complex-double-reg-real-tn x)) + (y-real (complex-double-reg-real-tn y))) + (cond ((zerop (tn-offset y-real)) + (copy-fp-reg-to-fr0 x-real)) + ((zerop (tn-offset x-real)) + (inst fstd y-real)) + (t + (inst fxch x-real) + (inst fstd y-real) + (inst fxch x-real)))) + (let ((x-imag (complex-double-reg-imag-tn x)) + (y-imag (complex-double-reg-imag-tn y))) + (inst fxch x-imag) + (inst fstd y-imag) + (inst fxch x-imag))))) + +(define-vop (complex-single-move complex-float-move) + (:args (x :scs (complex-single-reg) :target y + :load-if (not (location= x y)))) + (:results (y :scs (complex-single-reg) :load-if (not (location= x y))))) +(define-move-vop complex-single-move :move + (complex-single-reg) (complex-single-reg)) + +(define-vop (complex-double-move complex-float-move) + (:args (x :scs (complex-double-reg) + :target y :load-if (not (location= x y)))) + (:results (y :scs (complex-double-reg) :load-if (not (location= x y))))) +(define-move-vop complex-double-move :move + (complex-double-reg) (complex-double-reg)) + +#+long-float +(define-vop (complex-long-move complex-float-move) + (:args (x :scs (complex-long-reg) + :target y :load-if (not (location= x y)))) + (:results (y :scs (complex-long-reg) :load-if (not (location= x y))))) +#+long-float +(define-move-vop complex-long-move :move + (complex-long-reg) (complex-long-reg)) + + +;;; +;;; Move from float to a descriptor reg. allocating a new float +;;; object in the process. +;;; +(define-vop (move-from-single) + (:args (x :scs (single-reg) :to :save)) + (:results (y :scs (descriptor-reg))) + (:temporary (:sc any-reg) temp) + (:node-var node) + (:note "float to pointer coercion") + (:generator 13 + (with-fixed-allocation (y vm:single-float-type vm:single-float-size temp node) + (with-tn@fp-top(x) + (inst fst (ea-for-sf-desc y)))))) +(define-move-vop move-from-single :move + (single-reg) (descriptor-reg)) + +(define-vop (move-from-double) + (:args (x :scs (double-reg) :to :save)) + (:results (y :scs (descriptor-reg))) + (:temporary (:sc any-reg) temp) + (:node-var node) + (:note "float to pointer coercion") + (:generator 13 + (with-fixed-allocation (y vm:double-float-type vm:double-float-size temp node) + (with-tn@fp-top(x) + (inst fstd (ea-for-df-desc y)))))) +(define-move-vop move-from-double :move + (double-reg) (descriptor-reg)) + +#+long-float +(define-vop (move-from-long) + (:args (x :scs (long-reg) :to :save)) + (:results (y :scs (descriptor-reg))) + (:node-var node) + (:note "float to pointer coercion") + (:generator 13 + (with-fixed-allocation (y vm:long-float-type vm:long-float-size node) + (with-tn@fp-top(x) + (store-long-float (ea-for-lf-desc y)))))) +#+long-float +(define-move-vop move-from-long :move + (long-reg) (descriptor-reg)) + +(define-vop (move-from-fp-constant) + (:args (x :scs (fp-constant))) + (:results (y :scs (descriptor-reg))) + (:generator 2 + (ecase (c::constant-value (c::tn-leaf x)) + (0f0 (load-symbol-value y *fp-constant-0s0*)) + (1f0 (load-symbol-value y *fp-constant-1s0*)) + (0d0 (load-symbol-value y *fp-constant-0d0*)) + (1d0 (load-symbol-value y *fp-constant-1d0*)) + #+long-float + (0l0 (load-symbol-value y *fp-constant-0l0*)) + #+long-float + (1l0 (load-symbol-value y *fp-constant-1l0*)) + #+long-float + (#.pi (load-symbol-value y *fp-constant-pi*)) + #+long-float + (#.(log 10l0 2l0) (load-symbol-value y *fp-constant-l2t*)) + #+long-float + (#.(log 2.718281828459045235360287471352662L0 2l0) + (load-symbol-value y *fp-constant-l2e*)) + #+long-float + (#.(log 2l0 10l0) (load-symbol-value y *fp-constant-lg2*)) + #+long-float + (#.(log 2l0 2.718281828459045235360287471352662L0) + (load-symbol-value y *fp-constant-ln2*))))) +(define-move-vop move-from-fp-constant :move + (fp-constant) (descriptor-reg)) + +;;; +;;; Move from a descriptor to a float register +;;; +(define-vop (move-to-single) + (:args (x :scs (descriptor-reg))) + (:results (y :scs (single-reg))) + (:note "pointer to float coercion") + (:generator 2 + (with-empty-tn@fp-top(y) + (inst fld (ea-for-sf-desc x))))) +(define-move-vop move-to-single :move (descriptor-reg) (single-reg)) + +(define-vop (move-to-double) + (:args (x :scs (descriptor-reg))) + (:results (y :scs (double-reg))) + (:note "pointer to float coercion") + (:generator 2 + (with-empty-tn@fp-top(y) + (inst fldd (ea-for-df-desc x))))) +(define-move-vop move-to-double :move (descriptor-reg) (double-reg)) + +#+long-float +(define-vop (move-to-long) + (:args (x :scs (descriptor-reg))) + (:results (y :scs (long-reg))) + (:note "pointer to float coercion") + (:generator 2 + (with-empty-tn@fp-top(y) + (inst fldl (ea-for-lf-desc x))))) +#+long-float +(define-move-vop move-to-long :move (descriptor-reg) (long-reg)) + + +;;; +;;; Move from complex float to a descriptor reg. allocating a new +;;; complex float object in the process. +;;; +(define-vop (move-from-complex-single) + (:args (x :scs (complex-single-reg) :to :save)) + (:results (y :scs (descriptor-reg))) + (:temporary (:sc any-reg) temp) + (:node-var node) + (:note "complex float to pointer coercion") + (:generator 13 + (with-fixed-allocation (y vm:complex-single-float-type + vm:complex-single-float-size temp node) + (let ((real-tn (complex-single-reg-real-tn x))) + (with-tn@fp-top(real-tn) + (inst fst (ea-for-csf-real-desc y)))) + (let ((imag-tn (complex-single-reg-imag-tn x))) + (with-tn@fp-top(imag-tn) + (inst fst (ea-for-csf-imag-desc y))))))) +(define-move-vop move-from-complex-single :move + (complex-single-reg) (descriptor-reg)) + +(define-vop (move-from-complex-double) + (:args (x :scs (complex-double-reg) :to :save)) + (:results (y :scs (descriptor-reg))) + (:temporary (:sc any-reg) temp) + (:node-var node) + (:note "complex float to pointer coercion") + (:generator 13 + (with-fixed-allocation (y vm:complex-double-float-type + vm:complex-double-float-size temp node) + (let ((real-tn (complex-double-reg-real-tn x))) + (with-tn@fp-top(real-tn) + (inst fstd (ea-for-cdf-real-desc y)))) + (let ((imag-tn (complex-double-reg-imag-tn x))) + (with-tn@fp-top(imag-tn) + (inst fstd (ea-for-cdf-imag-desc y))))))) +(define-move-vop move-from-complex-double :move + (complex-double-reg) (descriptor-reg)) + +#+long-float +(define-vop (move-from-complex-long) + (:args (x :scs (complex-long-reg) :to :save)) + (:results (y :scs (descriptor-reg))) + (:node-var node) + (:note "complex float to pointer coercion") + (:generator 13 + (with-fixed-allocation (y vm:complex-long-float-type + vm:complex-long-float-size node) + (let ((real-tn (complex-long-reg-real-tn x))) + (with-tn@fp-top(real-tn) + (store-long-float (ea-for-clf-real-desc y)))) + (let ((imag-tn (complex-long-reg-imag-tn x))) + (with-tn@fp-top(imag-tn) + (store-long-float (ea-for-clf-imag-desc y))))))) +#+long-float +(define-move-vop move-from-complex-long :move + (complex-long-reg) (descriptor-reg)) + +;;; +;;; Move from a descriptor to a complex float register +;;; +(macrolet ((frob (name sc format) + `(progn + (define-vop (,name) + (:args (x :scs (descriptor-reg))) + (:results (y :scs (,sc))) + (:note "pointer to complex float coercion") + (:generator 2 + (let ((real-tn (complex-double-reg-real-tn y))) + (with-empty-tn@fp-top(real-tn) + ,@(ecase format + (:single '((inst fld (ea-for-csf-real-desc x)))) + (:double '((inst fldd (ea-for-cdf-real-desc x)))) + #+long-float + (:long '((inst fldl (ea-for-clf-real-desc x))))))) + (let ((imag-tn (complex-double-reg-imag-tn y))) + (with-empty-tn@fp-top(imag-tn) + ,@(ecase format + (:single '((inst fld (ea-for-csf-imag-desc x)))) + (:double '((inst fldd (ea-for-cdf-imag-desc x)))) + #+long-float + (:long '((inst fldl (ea-for-clf-imag-desc x))))))))) + (define-move-vop ,name :move (descriptor-reg) (,sc))))) + (frob move-to-complex-single complex-single-reg :single) + (frob move-to-complex-double complex-double-reg :double) + #+long-float + (frob move-to-complex-double complex-long-reg :long)) + + +;;; +;;; The move argument vops. +;;; +;;; Note these are also used to stuff fp numbers onto the c-call stack +;;; so the order is different than the lisp-stack. + +;;; The general move-argument vop +(macrolet ((frob (name sc stack-sc format) + `(progn + (define-vop (,name) + (:args (x :scs (,sc) :target y) + (fp :scs (any-reg) + :load-if (not (sc-is y ,sc)))) + (:results (y)) + (:note "float argument move") + (:generator ,(case format (:single 2) (:double 3) (:long 4)) + (sc-case y + (,sc + (unless (location= x y) + (cond ((zerop (tn-offset y)) + (copy-fp-reg-to-fr0 x)) + ((zerop (tn-offset x)) + (inst fstd y)) + (t + (inst fxch x) + (inst fstd y) + (inst fxch x))))) + (,stack-sc + (if (= (tn-offset fp) rsp-offset) + (let* ((offset (* (tn-offset y) word-bytes)) + (ea (make-ea :qword :base fp :disp offset))) + (with-tn@fp-top(x) + ,@(ecase format + (:single '((inst fst ea))) + (:double '((inst fstd ea))) + #+long-float + (:long '((store-long-float ea)))))) + (let ((ea (make-ea + :qword :base fp + :disp (- (* (+ (tn-offset y) + ,(case format + (:single 1) + (:double 2) + (:long 3))) + vm:word-bytes))))) + (with-tn@fp-top(x) + ,@(ecase format + (:single '((inst fst ea))) + (:double '((inst fstd ea))) + #+long-float + (:long '((store-long-float ea))))))))))) + (define-move-vop ,name :move-argument + (,sc descriptor-reg) (,sc))))) + (frob move-single-float-argument single-reg single-stack :single) + (frob move-double-float-argument double-reg double-stack :double) + #+long-float + (frob move-long-float-argument long-reg long-stack :long)) + +;;;; Complex float move-argument vop +(macrolet ((frob (name sc stack-sc format) + `(progn + (define-vop (,name) + (:args (x :scs (,sc) :target y) + (fp :scs (any-reg) + :load-if (not (sc-is y ,sc)))) + (:results (y)) + (:note "complex float argument move") + (:generator ,(ecase format (:single 2) (:double 3) (:long 4)) + (sc-case y + (,sc + (unless (location= x y) + (let ((x-real (complex-double-reg-real-tn x)) + (y-real (complex-double-reg-real-tn y))) + (cond ((zerop (tn-offset y-real)) + (copy-fp-reg-to-fr0 x-real)) + ((zerop (tn-offset x-real)) + (inst fstd y-real)) + (t + (inst fxch x-real) + (inst fstd y-real) + (inst fxch x-real)))) + (let ((x-imag (complex-double-reg-imag-tn x)) + (y-imag (complex-double-reg-imag-tn y))) + (inst fxch x-imag) + (inst fstd y-imag) + (inst fxch x-imag)))) + (,stack-sc + (let ((real-tn (complex-double-reg-real-tn x))) + (cond ((zerop (tn-offset real-tn)) + ,@(ecase format + (:single + '((inst fst + (ea-for-csf-real-stack y fp)))) + (:double + '((inst fstd + (ea-for-cdf-real-stack y fp)))) + #+long-float + (:long + '((store-long-float + (ea-for-clf-real-stack y fp)))))) + (t + (inst fxch real-tn) + ,@(ecase format + (:single + '((inst fst + (ea-for-csf-real-stack y fp)))) + (:double + '((inst fstd + (ea-for-cdf-real-stack y fp)))) + #+long-float + (:long + '((store-long-float + (ea-for-clf-real-stack y fp))))) + (inst fxch real-tn)))) + (let ((imag-tn (complex-double-reg-imag-tn x))) + (inst fxch imag-tn) + ,@(ecase format + (:single + '((inst fst (ea-for-csf-imag-stack y fp)))) + (:double + '((inst fstd (ea-for-cdf-imag-stack y fp)))) + #+long-float + (:long + '((store-long-float + (ea-for-clf-imag-stack y fp))))) + (inst fxch imag-tn)))))) + (define-move-vop ,name :move-argument + (,sc descriptor-reg) (,sc))))) + (frob move-complex-single-float-argument + complex-single-reg complex-single-stack :single) + (frob move-complex-double-float-argument + complex-double-reg complex-double-stack :double) + #+long-float + (frob move-complex-long-float-argument + complex-long-reg complex-long-stack :long)) + +(define-move-vop move-argument :move-argument + (single-reg double-reg #+long-float long-reg + complex-single-reg complex-double-reg #+long-float complex-long-reg) + (descriptor-reg)) + + +;;;; Arithmetic VOPs: + +;;; dtc: The floating point arithmetic vops. +;;; +;;; Note: Although these can accept x and y on the stack or pointed to +;;; from a descriptor register, they will work with register loading +;;; without these. Same deal with the result - it need only be a +;;; register. When load-tns are needed they will probably be in ST0 +;;; and the code below should be able to correctly handle all cases. +;;; +;;; However it seems to produce better code if all arg. and result +;;; options are used; on the P86 there is no extra cost in using a +;;; memory operand to the FP instructions - not so on the PPro. +;;; +;;; It may also be useful to handle constant args? +;;; +;;; 22-Jul-97: descriptor args lose in some simple cases when +;;; a function result computed in a loop. Then Python insists +;;; on consing the intermediate values! For example +#| +(defun test(a n) + (declare (type (simple-array double-float (*)) a) + (fixnum n)) + (let ((sum 0d0)) + (declare (type double-float sum)) + (dotimes (i n) + (incf sum (* (aref a i)(aref a i)))) + sum)) +|# +;;; So, disabling descriptor args until this can be fixed elsewhere. +;;; +(macrolet + ((frob (op fop-sti fopr-sti + fop fopr sname scost + fopd foprd dname dcost + lname lcost) + `(progn + (define-vop (,sname) + (:translate ,op) + (:args (x :scs (single-reg single-stack #+nil descriptor-reg) + :to :eval) + (y :scs (single-reg single-stack #+nil descriptor-reg) + :to :eval)) + (:temporary (:sc single-reg :offset fr0-offset + :from :eval :to :result) fr0) + (:results (r :scs (single-reg single-stack))) + (:arg-types single-float single-float) + (:result-types single-float) + (:policy :fast-safe) + (:note "inline float arithmetic") + (:vop-var vop) + (:save-p :compute-only) + (:node-var node) + (:generator ,scost + ;; Handle a few special cases + (cond + ;; x, y, and r are the same register. + ((and (sc-is x single-reg) (location= x r) (location= y r)) + (cond ((zerop (tn-offset r)) + (inst ,fop fr0)) + (t + (inst fxch r) + (inst ,fop fr0) + ;; XX the source register will not be valid. + (note-next-instruction vop :internal-error) + (inst fxch r)))) + + ;; x and r are the same register. + ((and (sc-is x single-reg) (location= x r)) + (cond ((zerop (tn-offset r)) + (sc-case y + (single-reg + ;; ST(0) = ST(0) op ST(y) + (inst ,fop y)) + (single-stack + ;; ST(0) = ST(0) op Mem + (inst ,fop (ea-for-sf-stack y))) + (descriptor-reg + (inst ,fop (ea-for-sf-desc y))))) + (t + ;; y to ST0 + (sc-case y + (single-reg + (unless (zerop (tn-offset y)) + (copy-fp-reg-to-fr0 y))) + ((single-stack descriptor-reg) + (fp-pop) + (if (sc-is y single-stack) + (inst fld (ea-for-sf-stack y)) + (inst fld (ea-for-sf-desc y))))) + ;; ST(i) = ST(i) op ST0 + (inst ,fop-sti r))) + (when (policy node (or (= debug 3) (> safety speed))) + (note-next-instruction vop :internal-error) + (inst wait))) + ;; y and r are the same register. + ((and (sc-is y single-reg) (location= y r)) + (cond ((zerop (tn-offset r)) + (sc-case x + (single-reg + ;; ST(0) = ST(x) op ST(0) + (inst ,fopr x)) + (single-stack + ;; ST(0) = Mem op ST(0) + (inst ,fopr (ea-for-sf-stack x))) + (descriptor-reg + (inst ,fopr (ea-for-sf-desc x))))) + (t + ;; x to ST0 + (sc-case x + (single-reg + (unless (zerop (tn-offset x)) + (copy-fp-reg-to-fr0 x))) + ((single-stack descriptor-reg) + (fp-pop) + (if (sc-is x single-stack) + (inst fld (ea-for-sf-stack x)) + (inst fld (ea-for-sf-desc x))))) + ;; ST(i) = ST(0) op ST(i) + (inst ,fopr-sti r))) + (when (policy node (or (= debug 3) (> safety speed))) + (note-next-instruction vop :internal-error) + (inst wait))) + ;; The default case + (t + ;; Get the result to ST0. + + ;; Special handling is needed if x or y are in ST0, and + ;; simpler code is generated. + (cond + ;; x is in ST0 + ((and (sc-is x single-reg) (zerop (tn-offset x))) + ;; ST0 = ST0 op y + (sc-case y + (single-reg + (inst ,fop y)) + (single-stack + (inst ,fop (ea-for-sf-stack y))) + (descriptor-reg + (inst ,fop (ea-for-sf-desc y))))) + ;; y is in ST0 + ((and (sc-is y single-reg) (zerop (tn-offset y))) + ;; ST0 = x op ST0 + (sc-case x + (single-reg + (inst ,fopr x)) + (single-stack + (inst ,fopr (ea-for-sf-stack x))) + (descriptor-reg + (inst ,fopr (ea-for-sf-desc x))))) + (t + ;; x to ST0 + (sc-case x + (single-reg + (copy-fp-reg-to-fr0 x)) + (single-stack + (fp-pop) + (inst fld (ea-for-sf-stack x))) + (descriptor-reg + (fp-pop) + (inst fld (ea-for-sf-desc x)))) + ;; ST0 = ST0 op y + (sc-case y + (single-reg + (inst ,fop y)) + (single-stack + (inst ,fop (ea-for-sf-stack y))) + (descriptor-reg + (inst ,fop (ea-for-sf-desc y)))))) + + (note-next-instruction vop :internal-error) + + ;; Finally save the result + (sc-case r + (single-reg + (cond ((zerop (tn-offset r)) + (when (policy node (or (= debug 3) (> safety speed))) + (inst wait))) + (t + (inst fst r)))) + (single-stack + (inst fst (ea-for-sf-stack r)))))))) + + (define-vop (,dname) + (:translate ,op) + (:args (x :scs (double-reg double-stack #+nil descriptor-reg) + :to :eval) + (y :scs (double-reg double-stack #+nil descriptor-reg) + :to :eval)) + (:temporary (:sc double-reg :offset fr0-offset + :from :eval :to :result) fr0) + (:results (r :scs (double-reg double-stack))) + (:arg-types double-float double-float) + (:result-types double-float) + (:policy :fast-safe) + (:note "inline float arithmetic") + (:vop-var vop) + (:save-p :compute-only) + (:node-var node) + (:generator ,dcost + ;; Handle a few special cases + (cond + ;; x, y, and r are the same register. + ((and (sc-is x double-reg) (location= x r) (location= y r)) + (cond ((zerop (tn-offset r)) + (inst ,fop fr0)) + (t + (inst fxch x) + (inst ,fopd fr0) + ;; XX the source register will not be valid. + (note-next-instruction vop :internal-error) + (inst fxch r)))) + + ;; x and r are the same register. + ((and (sc-is x double-reg) (location= x r)) + (cond ((zerop (tn-offset r)) + (sc-case y + (double-reg + ;; ST(0) = ST(0) op ST(y) + (inst ,fopd y)) + (double-stack + ;; ST(0) = ST(0) op Mem + (inst ,fopd (ea-for-df-stack y))) + (descriptor-reg + (inst ,fopd (ea-for-df-desc y))))) + (t + ;; y to ST0 + (sc-case y + (double-reg + (unless (zerop (tn-offset y)) + (copy-fp-reg-to-fr0 y))) + ((double-stack descriptor-reg) + (fp-pop) + (if (sc-is y double-stack) + (inst fldd (ea-for-df-stack y)) + (inst fldd (ea-for-df-desc y))))) + ;; ST(i) = ST(i) op ST0 + (inst ,fop-sti r))) + (when (policy node (or (= debug 3) (> safety speed))) + (note-next-instruction vop :internal-error) + (inst wait))) + ;; y and r are the same register. + ((and (sc-is y double-reg) (location= y r)) + (cond ((zerop (tn-offset r)) + (sc-case x + (double-reg + ;; ST(0) = ST(x) op ST(0) + (inst ,foprd x)) + (double-stack + ;; ST(0) = Mem op ST(0) + (inst ,foprd (ea-for-df-stack x))) + (descriptor-reg + (inst ,foprd (ea-for-df-desc x))))) + (t + ;; x to ST0 + (sc-case x + (double-reg + (unless (zerop (tn-offset x)) + (copy-fp-reg-to-fr0 x))) + ((double-stack descriptor-reg) + (fp-pop) + (if (sc-is x double-stack) + (inst fldd (ea-for-df-stack x)) + (inst fldd (ea-for-df-desc x))))) + ;; ST(i) = ST(0) op ST(i) + (inst ,fopr-sti r))) + (when (policy node (or (= debug 3) (> safety speed))) + (note-next-instruction vop :internal-error) + (inst wait))) + ;; The default case + (t + ;; Get the result to ST0. + + ;; Special handling is needed if x or y are in ST0, and + ;; simpler code is generated. + (cond + ;; x is in ST0 + ((and (sc-is x double-reg) (zerop (tn-offset x))) + ;; ST0 = ST0 op y + (sc-case y + (double-reg + (inst ,fopd y)) + (double-stack + (inst ,fopd (ea-for-df-stack y))) + (descriptor-reg + (inst ,fopd (ea-for-df-desc y))))) + ;; y is in ST0 + ((and (sc-is y double-reg) (zerop (tn-offset y))) + ;; ST0 = x op ST0 + (sc-case x + (double-reg + (inst ,foprd x)) + (double-stack + (inst ,foprd (ea-for-df-stack x))) + (descriptor-reg + (inst ,foprd (ea-for-df-desc x))))) + (t + ;; x to ST0 + (sc-case x + (double-reg + (copy-fp-reg-to-fr0 x)) + (double-stack + (fp-pop) + (inst fldd (ea-for-df-stack x))) + (descriptor-reg + (fp-pop) + (inst fldd (ea-for-df-desc x)))) + ;; ST0 = ST0 op y + (sc-case y + (double-reg + (inst ,fopd y)) + (double-stack + (inst ,fopd (ea-for-df-stack y))) + (descriptor-reg + (inst ,fopd (ea-for-df-desc y)))))) + + (note-next-instruction vop :internal-error) + + ;; Finally save the result + (sc-case r + (double-reg + (cond ((zerop (tn-offset r)) + (when (policy node (or (= debug 3) (> safety speed))) + (inst wait))) + (t + (inst fst r)))) + (double-stack + (inst fstd (ea-for-df-stack r)))))))) + + #+long-float + (define-vop (,lname) + (:translate ,op) + (:args (x :scs (long-reg) :to :eval) + (y :scs (long-reg) :to :eval)) + (:temporary (:sc long-reg :offset fr0-offset + :from :eval :to :result) fr0) + (:results (r :scs (long-reg))) + (:arg-types long-float long-float) + (:result-types long-float) + (:policy :fast-safe) + (:note "inline float arithmetic") + (:vop-var vop) + (:save-p :compute-only) + (:node-var node) + (:generator ,lcost + ;; Handle a few special cases + (cond + ;; x, y, and r are the same register. + ((and (location= x r) (location= y r)) + (cond ((zerop (tn-offset r)) + (inst ,fop fr0)) + (t + (inst fxch x) + (inst ,fopd fr0) + ;; XX the source register will not be valid. + (note-next-instruction vop :internal-error) + (inst fxch r)))) + + ;; x and r are the same register. + ((location= x r) + (cond ((zerop (tn-offset r)) + ;; ST(0) = ST(0) op ST(y) + (inst ,fopd y)) + (t + ;; y to ST0 + (unless (zerop (tn-offset y)) + (copy-fp-reg-to-fr0 y)) + ;; ST(i) = ST(i) op ST0 + (inst ,fop-sti r))) + (when (policy node (or (= debug 3) (> safety speed))) + (note-next-instruction vop :internal-error) + (inst wait))) + ;; y and r are the same register. + ((location= y r) + (cond ((zerop (tn-offset r)) + ;; ST(0) = ST(x) op ST(0) + (inst ,foprd x)) + (t + ;; x to ST0 + (unless (zerop (tn-offset x)) + (copy-fp-reg-to-fr0 x)) + ;; ST(i) = ST(0) op ST(i) + (inst ,fopr-sti r))) + (when (policy node (or (= debug 3) (> safety speed))) + (note-next-instruction vop :internal-error) + (inst wait))) + ;; The default case + (t + ;; Get the result to ST0. + + ;; Special handling is needed if x or y are in ST0, and + ;; simpler code is generated. + (cond + ;; x is in ST0 + ((zerop (tn-offset x)) + ;; ST0 = ST0 op y + (inst ,fopd y)) + ;; y is in ST0 + ((zerop (tn-offset y)) + ;; ST0 = x op ST0 + (inst ,foprd x)) + (t + ;; x to ST0 + (copy-fp-reg-to-fr0 x) + ;; ST0 = ST0 op y + (inst ,fopd y))) + + (note-next-instruction vop :internal-error) + + ;; Finally save the result + (cond ((zerop (tn-offset r)) + (when (policy node (or (= debug 3) (> safety speed))) + (inst wait))) + (t + (inst fst r)))))))))) + + (frob + fadd-sti fadd-sti + fadd fadd +/single-float 2 + faddd faddd +/double-float 2 + +/long-float 2) + (frob - fsub-sti fsubr-sti + fsub fsubr -/single-float 2 + fsubd fsubrd -/double-float 2 + -/long-float 2) + (frob * fmul-sti fmul-sti + fmul fmul */single-float 3 + fmuld fmuld */double-float 3 + */long-float 3) + (frob / fdiv-sti fdivr-sti + fdiv fdivr //single-float 12 + fdivd fdivrd //double-float 12 + //long-float 12)) + + +(macrolet ((frob (name inst translate sc type) + `(define-vop (,name) + (:args (x :scs (,sc) :target fr0)) + (:results (y :scs (,sc))) + (:translate ,translate) + (:policy :fast-safe) + (:arg-types ,type) + (:result-types ,type) + (:temporary (:sc double-reg :offset fr0-offset + :from :argument :to :result) fr0) + (:ignore fr0) + (:note "inline float arithmetic") + (:vop-var vop) + (:save-p :compute-only) + (:generator 1 + (note-this-location vop :internal-error) + (unless (zerop (tn-offset x)) + (inst fxch x) ; x to top of stack + (unless (location= x y) + (inst fst x))) ; maybe save it + (inst ,inst) ; clobber st0 + (unless (zerop (tn-offset y)) + (inst fst y)))))) + + (frob abs/single-float fabs abs single-reg single-float) + (frob abs/double-float fabs abs double-reg double-float) + #+long-float + (frob abs/long-float fabs abs long-reg long-float) + (frob %negate/single-float fchs %negate single-reg single-float) + (frob %negate/double-float fchs %negate double-reg double-float) + #+long-float + (frob %negate/long-float fchs %negate long-reg long-float)) + + +;;;; Comparison: + +#+long-float +(deftransform eql ((x y) (long-float long-float)) + `(and (= (long-float-low-bits x) (long-float-low-bits y)) + (= (long-float-high-bits x) (long-float-high-bits y)) + (= (long-float-exp-bits x) (long-float-exp-bits y)))) + +(define-vop (=/float) + (:args (x) (y)) + (:temporary (:sc word-reg :offset rax-offset :from :eval) temp) + (:conditional) + (:info target not-p) + (:policy :fast-safe) + (:vop-var vop) + (:save-p :compute-only) + (:note "inline float comparison") + (:ignore temp) + (:generator 3 + (note-this-location vop :internal-error) + (cond + ;; x is in ST0; y is in any reg. + ((zerop (tn-offset x)) + (inst fucom y) + (inst fnstsw)) ; status word to ax + ;; y is in ST0; x is in another reg. Can swap args saving a reg. swap. + ((zerop (tn-offset y)) + (inst fucom x) + (inst fnstsw)) ; status word to ax + ;; x and y are the same register, not ST0 + ((location= x y) + (inst fxch x) + (inst fucom fr0-tn) + (inst fnstsw) ; status word to ax + (inst fxch x)) + ;; x and y are different registers, neither ST0. + (t + (inst fxch x) + (inst fucom y) + (inst fnstsw) ; status word to ax + (inst fxch x))) + (inst and ah-tn #x45) ; C3 C2 C0 + (inst cmp ah-tn #x40) + (inst jmp (if not-p :ne :e) target))) + +(macrolet ((frob (type sc) + `(define-vop (,(symbolicate "=/" type) =/float) + (:translate =) + (:args (x :scs (,sc)) + (y :scs (,sc))) + (:arg-types ,type ,type)))) + (frob single-float single-reg) + (frob double-float double-reg) + #+long-float (frob long-float long-reg)) + +(macrolet ((frob (translate test ntest) + `(define-vop (,(symbolicate translate "/SINGLE-FLOAT")) + (:translate ,translate) + (:args (x :scs (single-reg single-stack descriptor-reg)) + (y :scs (single-reg single-stack descriptor-reg))) + (:arg-types single-float single-float) + (:temporary (:sc single-reg :offset fr0-offset :from :eval) + fr0) + (:temporary (:sc word-reg :offset rax-offset :from :eval) temp) + (:conditional) + (:info target not-p) + (:policy :fast-safe) + (:guard (not (backend-featurep :ppro))) + (:note "inline float comparison") + (:ignore temp fr0) + (:generator 3 + ;; Handle a few special cases + (cond + ;; x is ST0. + ((and (sc-is x single-reg) (zerop (tn-offset x))) + (sc-case y + (single-reg + (inst fcom y)) + ((single-stack descriptor-reg) + (if (sc-is y single-stack) + (inst fcom (ea-for-sf-stack y)) + (inst fcom (ea-for-sf-desc y))))) + (inst fnstsw) ; status word to ax + (inst and ah-tn #x45) + ,@(unless (zerop test) + `((inst cmp ah-tn ,test)))) + ;; y is ST0. + ((and (sc-is y single-reg) (zerop (tn-offset y))) + (sc-case x + (single-reg + (inst fcom x)) + ((single-stack descriptor-reg) + (if (sc-is x single-stack) + (inst fcom (ea-for-sf-stack x)) + (inst fcom (ea-for-sf-desc x))))) + (inst fnstsw) ; status word to ax + (inst and ah-tn #x45) + ,@(unless (zerop ntest) + `((inst cmp ah-tn ,ntest)))) + ;; General case when neither x or y is in ST0. + (t + ,@(if (zerop ntest) + `(;; y to ST0 + (sc-case y + (single-reg + (copy-fp-reg-to-fr0 y)) + ((single-stack descriptor-reg) + (fp-pop) + (if (sc-is y single-stack) + (inst fld (ea-for-sf-stack y)) + (inst fld (ea-for-sf-desc y))))) + (sc-case x + (single-reg + (inst fcom x)) + ((single-stack descriptor-reg) + (if (sc-is x single-stack) + (inst fcom (ea-for-sf-stack x)) + (inst fcom (ea-for-sf-desc x))))) + (inst fnstsw) ; status word to ax + (inst and ah-tn #x45)) ; C3 C2 C0 + `(;; x to ST0 + (sc-case x + (single-reg + (copy-fp-reg-to-fr0 x)) + ((single-stack descriptor-reg) + (fp-pop) + (if (sc-is x single-stack) + (inst fld (ea-for-sf-stack x)) + (inst fld (ea-for-sf-desc x))))) + (sc-case y + (single-reg + (inst fcom y)) + ((single-stack descriptor-reg) + (if (sc-is y single-stack) + (inst fcom (ea-for-sf-stack y)) + (inst fcom (ea-for-sf-desc y))))) + (inst fnstsw) ; status word to ax + (inst and ah-tn #x45) ; C3 C2 C0 + ,@(unless (zerop test) + `((inst cmp ah-tn ,test))))))) + (inst jmp (if not-p :ne :e) target))))) + (frob < #x01 #x00) + (frob > #x00 #x01)) + +(macrolet ((frob (translate test ntest) + `(define-vop (,(symbolicate translate "/DOUBLE-FLOAT")) + (:translate ,translate) + (:args (x :scs (double-reg double-stack descriptor-reg)) + (y :scs (double-reg double-stack descriptor-reg))) + (:arg-types double-float double-float) + (:temporary (:sc double-reg :offset fr0-offset :from :eval) + fr0) + (:temporary (:sc word-reg :offset rax-offset :from :eval) temp) + (:conditional) + (:info target not-p) + (:policy :fast-safe) + (:guard (not (backend-featurep :ppro))) + (:note "inline float comparison") + (:ignore temp fr0) + (:generator 3 + ;; Handle a few special cases + (cond + ;; x is in ST0. + ((and (sc-is x double-reg) (zerop (tn-offset x))) + (sc-case y + (double-reg + (inst fcomd y)) + ((double-stack descriptor-reg) + (if (sc-is y double-stack) + (inst fcomd (ea-for-df-stack y)) + (inst fcomd (ea-for-df-desc y))))) + (inst fnstsw) ; status word to ax + (inst and ah-tn #x45) + ,@(unless (zerop test) + `((inst cmp ah-tn ,test)))) + ;; y is in ST0. + ((and (sc-is y double-reg) (zerop (tn-offset y))) + (sc-case x + (double-reg + (inst fcomd x)) + ((double-stack descriptor-reg) + (if (sc-is x double-stack) + (inst fcomd (ea-for-df-stack x)) + (inst fcomd (ea-for-df-desc x))))) + (inst fnstsw) ; status word to ax + (inst and ah-tn #x45) + ,@(unless (zerop ntest) + `((inst cmp ah-tn ,ntest)))) + ;; General case when neither x or y is in ST0. + (t + ,@(if (zerop ntest) + `(;; y to ST0 + (sc-case y + (double-reg + (copy-fp-reg-to-fr0 y)) + ((double-stack descriptor-reg) + (fp-pop) + (if (sc-is y double-stack) + (inst fldd (ea-for-df-stack y)) + (inst fldd (ea-for-df-desc y))))) + (sc-case x + (double-reg + (inst fcomd x)) + ((double-stack descriptor-reg) + (if (sc-is x double-stack) + (inst fcomd (ea-for-df-stack x)) + (inst fcomd (ea-for-df-desc x))))) + (inst fnstsw) ; status word to ax + (inst and ah-tn #x45)) ; C3 C2 C0 + `(;; x to ST0 + (sc-case x + (double-reg + (copy-fp-reg-to-fr0 x)) + ((double-stack descriptor-reg) + (fp-pop) + (if (sc-is x double-stack) + (inst fldd (ea-for-df-stack x)) + (inst fldd (ea-for-df-desc x))))) + (sc-case y + (double-reg + (inst fcomd y)) + ((double-stack descriptor-reg) + (if (sc-is y double-stack) + (inst fcomd (ea-for-df-stack y)) + (inst fcomd (ea-for-df-desc y))))) + (inst fnstsw) ; status word to ax + (inst and ah-tn #x45) ; C3 C2 C0 + ,@(unless (zerop test) + `((inst cmp ah-tn ,test))))))) + (inst jmp (if not-p :ne :e) target))))) + (frob < #x01 #x00) + (frob > #x00 #x01)) + +#+long-float +(macrolet ((frob (translate test ntest) + `(define-vop (,(symbolicate translate "/LONG-FLOAT")) + (:translate ,translate) + (:args (x :scs (long-reg)) + (y :scs (long-reg))) + (:arg-types long-float long-float) + (:temporary (:sc word-reg :offset rax-offset :from :eval) temp) + (:conditional) + (:info target not-p) + (:policy :fast-safe) + (:guard (not (backend-featurep :ppro))) + (:note "inline float comparison") + (:ignore temp) + (:generator 3 + (cond + ;; x is in ST0; y is in any reg. + ((zerop (tn-offset x)) + (inst fcomd y) + (inst fnstsw) ; status word to ax + (inst and ah-tn #x45) ; C3 C2 C0 + ,@(unless (zerop test) + `((inst cmp ah-tn ,test)))) + ;; y is in ST0; x is in another reg. + ((zerop (tn-offset y)) + (inst fcomd x) + (inst fnstsw) ; status word to ax + (inst and ah-tn #x45) + ,@(unless (zerop ntest) + `((inst cmp ah-tn ,ntest)))) + ;; x and y are the same register, not ST0 + ((location= x y) + (inst fxch x) + (inst fcomd fr0-tn) + (inst fnstsw) ; status word to ax + (inst fxch x) + (inst and ah-tn #x45) ; C3 C2 C0 + ,@(unless (or (zerop test) (zerop ntest)) + `((inst cmp ah-tn ,test)))) + ;; x and y are different registers, neither ST0. + (t + ,@(cond ((zerop ntest) + `((inst fxch y) + (inst fcomd x) + (inst fnstsw) ; status word to ax + (inst fxch y) + (inst and ah-tn #x45))) ; C3 C2 C0 + (t + `((inst fxch x) + (inst fcomd y) + (inst fnstsw) ; status word to ax + (inst fxch x) + (inst and ah-tn #x45) ; C3 C2 C0 + ,@(unless (zerop test) + `((inst cmp ah-tn ,test)))))))) + (inst jmp (if not-p :ne :e) target))))) + (frob < #x01 #x00) + (frob > #x00 #x01)) + +;;; Comparisons with 0 can use the FTST instruction. + +(define-vop (float-test) + (:args (x)) + (:temporary (:sc word-reg :offset rax-offset :from :eval) temp) + (:conditional) + (:info target not-p y) + (:variant-vars code) + (:policy :fast-safe) + (:vop-var vop) + (:save-p :compute-only) + (:note "inline float comparison") + (:ignore temp y) + (:generator 2 + (note-this-location vop :internal-error) + (cond + ;; x is in ST0 + ((zerop (tn-offset x)) + (inst ftst) + (inst fnstsw)) ; status word to ax + ;; x not ST0 + (t + (inst fxch x) + (inst ftst) + (inst fnstsw) ; status word to ax + (inst fxch x))) + (inst and ah-tn #x45) ; C3 C2 C0 + (unless (zerop code) + (inst cmp ah-tn code)) + (inst jmp (if not-p :ne :e) target))) + +(macrolet ((frob (translate test) + `(progn + (define-vop (,(symbolicate translate "0/SINGLE-FLOAT") + float-test) + (:translate ,translate) + (:args (x :scs (single-reg))) + (:arg-types single-float (:constant (single-float 0f0 0f0))) + (:variant ,test)) + (define-vop (,(symbolicate translate "0/DOUBLE-FLOAT") + float-test) + (:translate ,translate) + (:args (x :scs (double-reg))) + (:arg-types double-float (:constant (double-float 0d0 0d0))) + (:variant ,test)) + #+long-float + (define-vop (,(symbolicate translate "0/LONG-FLOAT") + float-test) + (:translate ,translate) + (:args (x :scs (long-reg))) + (:arg-types long-float (:constant (long-float 0l0 0l0))) + (:variant ,test))))) + (frob > #x00) + (frob < #x01) + (frob = #x40)) + + + +;;;; Enhanced Pentium Pro floating point comparisons. + +;;; These comparisions use the faster sequences bases upon FCOMI and FUCOMI, +;;; which write to the condition codes. However, correct IEEE handling of +;;; unordered arguments requires the comparision of multiple flags which is +;;; only possible for the comparison (> ST0 operand) in which case the :b and +;;; :be tests can check that both ZF and CF are zero, or either is one +;;; respectively. For the opposite comparision (< ST0 operand), the arguments +;;; may be swapped and the > comparision used, but for equality the slower +;;; FNSTSW variation must be used. + +(define-vop (ppro-</float) + (:args (x) (y)) + (:conditional) + (:info target not-p) + (:policy :fast-safe) + (:guard (backend-featurep :ppro)) + (:note "inline float comparison") + (:generator 3 + ;; Handle a few special cases + (cond + ;; x is in ST0; y is in any reg. + ((zerop (tn-offset x)) + (inst fxch y) + (inst fcomi y) + (inst fxch y)) + ;; y is in ST0; x is in another reg. + ((zerop (tn-offset y)) + (inst fcomi x)) + ;; x and y are the same register, not ST0. + ((location= x y) + (inst fxch x) + (inst fcomi fr0-tn) + (inst fxch x)) + ;; x and y are different registers, neither ST0. + (t + (inst fxch y) + (inst fcomi x) + (inst fxch y))) + (inst jmp (if not-p :be :nbe) target))) + +(macrolet ((frob (type sc) + `(define-vop (,(symbolicate "PPRO-</" type) ppro-</float) + (:translate <) + (:args (x :scs (,sc)) + (y :scs (,sc))) + (:arg-types ,type ,type)))) + (frob single-float single-reg) + (frob double-float double-reg) + #+long-float (frob long-float long-reg)) + +(define-vop (ppro->/float) + (:args (x) (y)) + (:conditional) + (:info target not-p) + (:policy :fast-safe) + (:guard (backend-featurep :ppro)) + (:note "inline float comparison") + (:generator 3 + ;; Handle a few special cases + (cond + ;; x is in ST0; y is in any reg. + ((zerop (tn-offset x)) + (inst fcomi y)) + ;; y is in ST0; x is in another reg. + ((zerop (tn-offset y)) + (inst fxch x) + (inst fcomi x) + (inst fxch x)) + ;; x and y are the same register, not ST0. + ((location= x y) + (inst fxch x) + (inst fcomi fr0-tn) + (inst fxch x)) + ;; x and y are different registers, neither ST0. + (t + (inst fxch x) + (inst fcomi y) + (inst fxch x))) + (inst jmp (if not-p :be :nbe) target))) + +(macrolet ((frob (type sc) + `(define-vop (,(symbolicate "PPRO->/" type) ppro->/float) + (:translate >) + (:args (x :scs (,sc)) + (y :scs (,sc))) + (:arg-types ,type ,type)))) + (frob single-float single-reg) + (frob double-float double-reg) + #+long-float (frob long-float long-reg)) + + +;;;; Conversion: + +(macrolet ((frob (name translate to-sc to-type) + `(define-vop (,name) + (:args (x :scs (signed-stack signed-reg) :target temp)) + (:temporary (:sc signed-stack) temp) + (:results (y :scs (,to-sc))) + (:arg-types signed-num) + (:result-types ,to-type) + (:policy :fast-safe) + (:note "inline float coercion") + (:translate ,translate) + (:vop-var vop) + (:save-p :compute-only) + (:generator 5 + (sc-case x + (signed-reg + (inst mov temp x) + (with-empty-tn@fp-top(y) + (note-this-location vop :internal-error) + (inst fild temp))) + (signed-stack + (with-empty-tn@fp-top(y) + (note-this-location vop :internal-error) + (inst fild x)))))))) + (frob %single-float/signed %single-float single-reg single-float) + (frob %double-float/signed %double-float double-reg double-float) + #+long-float + (frob %long-float/signed %long-float long-reg long-float)) + +(macrolet ((frob (name translate to-sc to-type) + `(define-vop (,name) + (:args (x :scs (unsigned-reg))) + (:results (y :scs (,to-sc))) + (:arg-types unsigned-num) + (:result-types ,to-type) + (:policy :fast-safe) + (:note "inline float coercion") + (:translate ,translate) + (:vop-var vop) + (:save-p :compute-only) + (:generator 6 + (inst push 0) + (inst push x) + (with-empty-tn@fp-top(y) + (note-this-location vop :internal-error) + (inst fildl (make-ea :qword :base rsp-tn))) + (inst add rsp-tn 8))))) + (frob %single-float/unsigned %single-float single-reg single-float) + (frob %double-float/unsigned %double-float double-reg double-float) + #+long-float + (frob %long-float/unsigned %long-float long-reg long-float)) + +;;; These should be no-ops but the compiler might want to move +;;; some things around +(macrolet ((frob (name translate from-sc from-type to-sc to-type) + `(define-vop (,name) + (:args (x :scs (,from-sc) :target y)) + (:results (y :scs (,to-sc))) + (:arg-types ,from-type) + (:result-types ,to-type) + (:policy :fast-safe) + (:note "inline float coercion") + (:translate ,translate) + (:vop-var vop) + (:save-p :compute-only) + (:generator 2 + (note-this-location vop :internal-error) + (unless (location= x y) + (cond + ((zerop (tn-offset x)) + ;; x is in ST0, y is in another reg. not ST0 + (inst fst y)) + ((zerop (tn-offset y)) + ;; y is in ST0, x is in another reg. not ST0 + (copy-fp-reg-to-fr0 x)) + (t + ;; Neither x or y are in ST0, and they are not in + ;; the same reg. + (inst fxch x) + (inst fst y) + (inst fxch x)))))))) + + (frob %single-float/double-float %single-float double-reg + double-float single-reg single-float) + #+long-float + (frob %single-float/long-float %single-float long-reg + long-float single-reg single-float) + (frob %double-float/single-float %double-float single-reg single-float + double-reg double-float) + #+long-float + (frob %double-float/long-float %double-float long-reg long-float + double-reg double-float) + #+long-float + (frob %long-float/single-float %long-float single-reg single-float + long-reg long-float) + #+long-float + (frob %long-float/double-float %long-float double-reg double-float + long-reg long-float)) + + + +(macrolet ((frob (trans from-sc from-type round-p) + `(define-vop (,(symbolicate trans "/" from-type)) + (:args (x :scs (,from-sc))) + (:temporary (:sc signed-stack) stack-temp) + ,@(unless round-p + '((:temporary (:sc unsigned-stack) scw) + (:temporary (:sc any-reg) rcw))) + (:results (y :scs (signed-reg))) + (:arg-types ,from-type) + (:result-types signed-num) + (:translate ,trans) + (:policy :fast-safe) + (:note "inline float truncate") + (:vop-var vop) + (:save-p :compute-only) + (:generator 5 + ,@(unless round-p + '((note-this-location vop :internal-error) + ;; Catch any pending FPE exceptions. + (inst wait))) + (,(if round-p 'progn 'pseudo-atomic) + ;; normal mode (for now) is "round to best" + (with-tn@fp-top(x) + ,@(unless round-p + '((inst fnstcw scw) ; save current control word + (move rcw scw) ; into 16-bit register + (inst or rcw (ash #b11 10)) ; CHOP + (move stack-temp rcw) + (inst fldcw stack-temp))) + (sc-case y + (signed-stack + (inst fist y)) + (signed-reg + (inst fist stack-temp) + (inst mov y stack-temp))) + ,@(unless round-p + '((inst fldcw scw))))))))) + (frob %unary-truncate single-reg single-float nil) + (frob %unary-truncate double-reg double-float nil) + #+long-float + (frob %unary-truncate long-reg long-float nil) + (frob %unary-round single-reg single-float t) + (frob %unary-round double-reg double-float t) + #+long-float + (frob %unary-round long-reg long-float t)) + +(macrolet ((frob (trans from-sc from-type round-p) + `(define-vop (,(symbolicate trans "/" from-type "=>UNSIGNED")) + (:args (x :scs (,from-sc) :target fr0)) + (:temporary (:sc double-reg :offset fr0-offset + :from :argument :to :result) fr0) + ,@(unless round-p + '((:temporary (:sc unsigned-stack) stack-temp) + (:temporary (:sc unsigned-stack) scw) + (:temporary (:sc any-reg) rcw))) + (:results (y :scs (unsigned-reg))) + (:arg-types ,from-type) + (:result-types unsigned-num) + (:translate ,trans) + (:policy :fast-safe) + (:note "inline float truncate") + (:vop-var vop) + (:save-p :compute-only) + (:generator 5 + ,@(unless round-p + '((note-this-location vop :internal-error) + ;; Catch any pending FPE exceptions. + (inst wait))) + ;; normal mode (for now) is "round to best" + (unless (zerop (tn-offset x)) + (copy-fp-reg-to-fr0 x)) + ,@(unless round-p + '((inst fnstcw scw) ; save current control word + (move rcw scw) ; into 16-bit register + (inst or rcw (ash #b11 10)) ; CHOP + (move stack-temp rcw) + (inst fldcw stack-temp))) + (inst sub rsp-tn 8) + (inst fistpl (make-ea :qword :base rsp-tn)) + (inst pop y) + (inst fld fr0) ; copy fr0 to at least restore stack. + (inst add rsp-tn 4) + ,@(unless round-p + '((inst fldcw scw))))))) + (frob %unary-truncate single-reg single-float nil) + (frob %unary-truncate double-reg double-float nil) + #+long-float + (frob %unary-truncate long-reg long-float nil) + (frob %unary-round single-reg single-float t) + (frob %unary-round double-reg double-float t) + #+long-float + (frob %unary-round long-reg long-float t)) + + +(define-vop (make-single-float) + (:args (bits :scs (signed-reg) :target res + :load-if (not (or (and (sc-is bits signed-stack) + (sc-is res single-reg)) + (and (sc-is bits signed-stack) + (sc-is res single-stack) + (location= bits res)))))) + (:results (res :scs (single-reg single-stack))) + (:temporary (:sc signed-stack) stack-temp) + (:arg-types signed-num) + (:result-types single-float) + (:translate make-single-float) + (:policy :fast-safe) + (:vop-var vop) + (:generator 4 + (sc-case res + (single-stack + (sc-case bits + (signed-reg + (inst mov res bits)) + (signed-stack + (assert (location= bits res))))) + (single-reg + (sc-case bits + (signed-reg + ;; source must be in memory + (inst mov stack-temp bits) + (with-empty-tn@fp-top(res) + (inst fld stack-temp))) + (signed-stack + (with-empty-tn@fp-top(res) + (inst fld bits)))))))) + +(define-vop (make-double-float) + (:args (hi-bits :scs (signed-reg)) + (lo-bits :scs (unsigned-reg))) + (:results (res :scs (double-reg))) + (:temporary (:sc double-stack) temp) + (:arg-types signed-num unsigned-num) + (:result-types double-float) + (:translate make-double-float) + (:policy :fast-safe) + (:vop-var vop) + (:generator 2 + (let ((offset (1+ (tn-offset temp)))) + (storew hi-bits rbp-tn (- offset)) + (storew lo-bits rbp-tn (- (1+ offset))) + (with-empty-tn@fp-top(res) + (inst fldd (make-ea :qword :base rbp-tn + :disp (- (* (1+ offset) word-bytes)))))))) + +#+long-float +(define-vop (make-long-float) + (:args (exp-bits :scs (signed-reg)) + (hi-bits :scs (unsigned-reg)) + (lo-bits :scs (unsigned-reg))) + (:results (res :scs (long-reg))) + (:temporary (:sc long-stack) temp) + (:arg-types signed-num unsigned-num unsigned-num) + (:result-types long-float) + (:translate make-long-float) + (:policy :fast-safe) + (:vop-var vop) + (:generator 3 + (let ((offset (1+ (tn-offset temp)))) + (storew exp-bits rbp-tn (- offset)) + (storew hi-bits rbp-tn (- (1+ offset))) + (storew lo-bits rbp-tn (- (+ offset 2))) + (with-empty-tn@fp-top(res) + (inst fldl (make-ea :qword :base rbp-tn + :disp (- (* (+ offset 2) word-bytes)))))))) + +(define-vop (single-float-bits) + (:args (float :scs (single-reg descriptor-reg) + :load-if (not (sc-is float single-stack)))) + (:results (bits :scs (signed-reg))) + (:temporary (:sc signed-stack :from :argument :to :result) stack-temp) + (:arg-types single-float) + (:result-types signed-num) + (:translate single-float-bits) + (:policy :fast-safe) + (:vop-var vop) + (:generator 4 + (sc-case bits + (signed-reg + (sc-case float + (single-reg + (with-tn@fp-top(float) + (inst fst stack-temp) + (inst mov bits stack-temp))) + (single-stack + (inst mov bits float)) + (descriptor-reg + (loadw + bits float vm:single-float-value-slot vm:other-pointer-type)))) + (signed-stack + (sc-case float + (single-reg + (with-tn@fp-top(float) + (inst fst bits)))))))) + +(define-vop (double-float-high-bits) + (:args (float :scs (double-reg descriptor-reg) + :load-if (not (sc-is float double-stack)))) + (:results (hi-bits :scs (signed-reg))) + (:temporary (:sc double-stack) temp) + (:arg-types double-float) + (:result-types signed-num) + (:translate double-float-high-bits) + (:policy :fast-safe) + (:vop-var vop) + (:generator 5 + (sc-case float + (double-reg + (with-tn@fp-top(float) + (let ((where (make-ea :qword :base rbp-tn + :disp (- (* (+ 2 (tn-offset temp)) + word-bytes))))) + (inst fstd where))) + (loadw hi-bits rbp-tn (- (1+ (tn-offset temp))))) + (double-stack + (loadw hi-bits rbp-tn (- (1+ (tn-offset float))))) + (descriptor-reg + (loadw hi-bits float (1+ vm:double-float-value-slot) + vm:other-pointer-type))))) + +(define-vop (double-float-low-bits) + (:args (float :scs (double-reg descriptor-reg) + :load-if (not (sc-is float double-stack)))) + (:results (lo-bits :scs (unsigned-reg))) + (:temporary (:sc double-stack) temp) + (:arg-types double-float) + (:result-types unsigned-num) + (:translate double-float-low-bits) + (:policy :fast-safe) + (:vop-var vop) + (:generator 5 + (sc-case float + (double-reg + (with-tn@fp-top(float) + (let ((where (make-ea :qword :base rbp-tn + :disp (- (* (+ 2 (tn-offset temp)) + word-bytes))))) + (inst fstd where))) + (loadw lo-bits rbp-tn (- (+ 2 (tn-offset temp))))) + (double-stack + (loadw lo-bits rbp-tn (- (+ 2 (tn-offset float))))) + (descriptor-reg + (loadw lo-bits float vm:double-float-value-slot + vm:other-pointer-type))))) + +#+long-float +(define-vop (long-float-exp-bits) + (:args (float :scs (long-reg descriptor-reg) + :load-if (not (sc-is float long-stack)))) + (:results (exp-bits :scs (signed-reg))) + (:temporary (:sc long-stack) temp) + (:arg-types long-float) + (:result-types signed-num) + (:translate long-float-exp-bits) + (:policy :fast-safe) + (:vop-var vop) + (:generator 5 + (sc-case float + (long-reg + (with-tn@fp-top(float) + (let ((where (make-ea :qword :base rbp-tn + :disp (- (* (+ 3 (tn-offset temp)) + word-bytes))))) + (store-long-float where))) + (inst movsx exp-bits + (make-ea :word :base rbp-tn + :disp (* (- (1+ (tn-offset temp))) word-bytes)))) + (long-stack + (inst movsx exp-bits + (make-ea :word :base rbp-tn + :disp (* (- (1+ (tn-offset float))) word-bytes)))) + (descriptor-reg + (inst movsx exp-bits + (make-ea :word :base float + :disp (- (* (+ 2 vm:long-float-value-slot) word-bytes) + vm:other-pointer-type))))))) + +#+long-float +(define-vop (long-float-high-bits) + (:args (float :scs (long-reg descriptor-reg) + :load-if (not (sc-is float long-stack)))) + (:results (hi-bits :scs (unsigned-reg))) + (:temporary (:sc long-stack) temp) + (:arg-types long-float) + (:result-types unsigned-num) + (:translate long-float-high-bits) + (:policy :fast-safe) + (:vop-var vop) + (:generator 5 + (sc-case float + (long-reg + (with-tn@fp-top(float) + (let ((where (make-ea :qword :base rbp-tn + :disp (- (* (+ 3 (tn-offset temp)) + word-bytes))))) + (store-long-float where))) + (loadw hi-bits rbp-tn (- (+ (tn-offset temp) 2)))) + (long-stack + (loadw hi-bits rbp-tn (- (+ (tn-offset float) 2)))) + (descriptor-reg + (loadw hi-bits float (1+ vm:long-float-value-slot) + vm:other-pointer-type))))) + +#+long-float +(define-vop (long-float-low-bits) + (:args (float :scs (long-reg descriptor-reg) + :load-if (not (sc-is float long-stack)))) + (:results (lo-bits :scs (unsigned-reg))) + (:temporary (:sc long-stack) temp) + (:arg-types long-float) + (:result-types unsigned-num) + (:translate long-float-low-bits) + (:policy :fast-safe) + (:vop-var vop) + (:generator 5 + (sc-case float + (long-reg + (with-tn@fp-top(float) + (let ((where (make-ea :qword :base rbp-tn + :disp (- (* (+ 3 (tn-offset temp)) + word-bytes))))) + (store-long-float where))) + (loadw lo-bits rbp-tn (- (+ (tn-offset temp) 3)))) + (long-stack + (loadw lo-bits rbp-tn (- (+ (tn-offset float) 3)))) + (descriptor-reg + (loadw lo-bits float vm:long-float-value-slot + vm:other-pointer-type))))) + + +;;;; Float mode hackery: + +(deftype float-modes () '(unsigned-byte 32)) ; really only 16 +(defknown floating-point-modes () float-modes (flushable)) +(defknown ((setf floating-point-modes)) (float-modes) + float-modes) + +(defconstant npx-env-size (* 7 vm:word-bytes)) +(defconstant npx-cw-offset 0) +(defconstant npx-sw-offset 4) + +(define-vop (floating-point-modes) + (:results (res :scs (unsigned-reg))) + (:result-types unsigned-num) + (:translate floating-point-modes) + (:policy :fast-safe) + (:temporary (:sc unsigned-reg :offset rax-offset :target res + :to :result) rax) + (:generator 8 + (inst sub rsp-tn npx-env-size) ; make space on stack + (inst wait) ; Catch any pending FPE exceptions + (inst fstenv (make-ea :qword :base rsp-tn)) ; masks all exceptions + (inst fldenv (make-ea :qword :base rsp-tn)) ; restore previous state + ;; Current status to high word + (inst mov rax (make-ea :qword :base rsp-tn :disp (- npx-sw-offset 2))) + ;; Exception mask to low word + (inst mov ax-tn (make-ea :word :base rsp-tn :disp npx-cw-offset)) + (inst add rsp-tn npx-env-size) ; Pop stack + (inst xor rax #x3f) ; Flip exception mask to trap enable bits + (move res rax))) + +(define-vop (set-floating-point-modes) + (:args (new :scs (unsigned-reg) :to :result :target res)) + (:results (res :scs (unsigned-reg))) + (:arg-types unsigned-num) + (:result-types unsigned-num) + (:translate (setf floating-point-modes)) + (:policy :fast-safe) + (:temporary (:sc unsigned-reg :offset rax-offset + :from :eval :to :result) rax) + (:generator 3 + (inst sub rsp-tn npx-env-size) ; make space on stack + (inst wait) ; Catch any pending FPE exceptions + (inst fstenv (make-ea :qword :base rsp-tn)) + (inst mov rax new) + (inst xor rax #x3f) ; turn trap enable bits into exception mask + (inst mov (make-ea :word :base rsp-tn :disp npx-cw-offset) ax-tn) + (inst shr rax 16) ; position status word + (inst mov (make-ea :word :base rsp-tn :disp npx-sw-offset) ax-tn) + (inst fldenv (make-ea :qword :base rsp-tn)) + (inst add rsp-tn npx-env-size) ; Pop stack + (move res new))) + + + +#-long-float +(progn + +;;; Lets use some of the 80387 special functions. +;;; +;;; These defs will not take effect unless code/irrat.lisp is modified +;;; to remove the inlined alien routine def. + +(macrolet ((frob (func trans op) + `(define-vop (,func) + (:args (x :scs (double-reg) :target fr0)) + (:temporary (:sc double-reg :offset fr0-offset + :from :argument :to :result) fr0) + (:results (y :scs (double-reg))) + (:arg-types double-float) + (:result-types double-float) + (:translate ,trans) + (:policy :fast-safe) + (:note "inline NPX function") + (:vop-var vop) + (:save-p :compute-only) + (:node-var node) + (:ignore fr0) + (:generator 5 + (note-this-location vop :internal-error) + (unless (zerop (tn-offset x)) + (inst fxch x) ; x to top of stack + (unless (location= x y) + (inst fst x))) ; maybe save it + (inst ,op) ; clobber st0 + (cond ((zerop (tn-offset y)) + (when (policy node (or (= debug 3) (> safety speed))) + (inst wait))) + (t + (inst fst y))))))) + + ;; Quick versions of fsin and fcos that require the argument to be + ;; within range 2^63. + (frob fsin-quick %sin-quick fsin) + (frob fcos-quick %cos-quick fcos) + ;; + (frob fsqrt %sqrt fsqrt)) + +;;; Quick version of ftan that requires the argument to be within +;;; range 2^63. +(define-vop (ftan-quick) + (:translate %tan-quick) + (:args (x :scs (double-reg) :target fr0)) + (:temporary (:sc double-reg :offset fr0-offset + :from :argument :to :result) fr0) + (:temporary (:sc double-reg :offset fr1-offset + :from :argument :to :result) fr1) + (:results (y :scs (double-reg))) + (:arg-types double-float) + (:result-types double-float) + (:policy :fast-safe) + (:note "inline tan function") + (:vop-var vop) + (:save-p :compute-only) + (:ignore fr0) + (:generator 5 + (note-this-location vop :internal-error) + (case (tn-offset x) + (0 + (inst fstp fr1)) + (1 + (fp-pop)) + (t + (fp-pop) + (fp-pop) + (inst fldd (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg *backend*) + :offset (- (tn-offset x) 2))))) + (inst fptan) + ;; Result is in fr1 + (case (tn-offset y) + (0 + (inst fxch fr1)) + (1) + (t + (inst fxch fr1) + (inst fstd y))))) + +;;; These versions of fsin, fcos, and ftan try to use argument +;;; reduction but to do this accurately requires greater precision and +;;; it is hopelessly inaccurate. +#+nil +(macrolet ((frob (func trans op) + `(define-vop (,func) + (:translate ,trans) + (:args (x :scs (double-reg) :target fr0)) + (:temporary (:sc unsigned-reg :offset rax-offset + :from :eval :to :result) rax) + (:temporary (:sc unsigned-reg :offset fr0-offset + :from :argument :to :result) fr0) + (:temporary (:sc unsigned-reg :offset fr1-offset + :from :argument :to :result) fr1) + (:results (y :scs (double-reg))) + (:arg-types double-float) + (:result-types double-float) + (:policy :fast-safe) + (:note "inline sin/cos function") + (:vop-var vop) + (:save-p :compute-only) + (:ignore rax) + (:generator 5 + (note-this-location vop :internal-error) + (unless (zerop (tn-offset x)) + (inst fxch x) ; x to top of stack + (unless (location= x y) + (inst fst x))) ; maybe save it + (inst ,op) + (inst fnstsw) ; status word to ax + (inst and ah-tn #x04) ; C2 + (inst jmp :z DONE) + ;; Else x was out of range so reduce it; ST0 is unchanged. + (inst fstp fr1) ; Load 2*PI + (inst fldpi) + (inst fadd fr0) + (inst fxch fr1) + LOOP + (inst fprem1) + (inst fnstsw) ; status word to ax + (inst and ah-tn #x04) ; C2 + (inst jmp :nz LOOP) + (inst ,op) + DONE + (unless (zerop (tn-offset y)) + (inst fstd y)))))) + (frob fsin %sin fsin) + (frob fcos %cos fcos)) + +#+nil +(define-vop (ftan) + (:translate %tan) + (:args (x :scs (double-reg) :target fr0)) + (:temporary (:sc unsigned-reg :offset rax-offset + :from :argument :to :result) rax) + (:temporary (:sc double-reg :offset fr0-offset + :from :argument :to :result) fr0) + (:temporary (:sc double-reg :offset fr1-offset + :from :argument :to :result) fr1) + (:results (y :scs (double-reg))) + (:arg-types double-float) + (:result-types double-float) + (:policy :fast-safe) + (:note "inline tan function") + (:vop-var vop) + (:save-p :compute-only) + (:ignore rax) + (:generator 5 + (note-this-location vop :internal-error) + (case (tn-offset x) + (0 + (inst fstp fr1)) + (1 + (fp-pop)) + (t + (fp-pop) + (fp-pop) + (inst fldd (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg *backend*) + :offset (- (tn-offset x) 2))))) + (inst fptan) + (inst fnstsw) ; status word to ax + (inst and ah-tn #x04) ; C2 + (inst jmp :z DONE) + ;; Else x was out of range so reduce it; ST0 is unchanged. + (inst fldpi) ; Load 2*PI + (inst fadd fr0) + (inst fxch fr1) + LOOP + (inst fprem1) + (inst fnstsw) ; status word to ax + (inst and ah-tn #x04) ; C2 + (inst jmp :nz LOOP) + (inst fstp fr1) + (inst fptan) + DONE + ;; Result is in fr1 + (case (tn-offset y) + (0 + (inst fxch fr1)) + (1) + (t + (inst fxch fr1) + (inst fstd y))))) + +;;; These versions of fsin, fcos, and ftan simply load a 0.0 result if +;;; the argument is out of range 2^63 and would thus be hopelessly +;;; inaccurate. +(macrolet ((frob (func trans op) + `(define-vop (,func) + (:translate ,trans) + (:args (x :scs (double-reg) :target fr0)) + (:temporary (:sc double-reg :offset fr0-offset + :from :argument :to :result) fr0) + (:temporary (:sc unsigned-reg :offset rax-offset + :from :argument :to :result) rax) + (:results (y :scs (double-reg))) + (:arg-types double-float) + (:result-types double-float) + (:policy :fast-safe) + (:note "inline sin/cos function") + (:vop-var vop) + (:save-p :compute-only) + (:ignore rax fr0) + (:generator 5 + (note-this-location vop :internal-error) + (unless (zerop (tn-offset x)) + (inst fxch x) ; x to top of stack + (unless (location= x y) + (inst fst x))) ; maybe save it + (inst ,op) + (inst fnstsw) ; status word to ax + (inst and ah-tn #x04) ; C2 + (inst jmp :z DONE) + ;; Else x was out of range so reduce it; ST0 is unchanged. + (fp-pop) ; Load 0.0 + (inst fldz) + DONE + (unless (zerop (tn-offset y)) + (inst fstd y)))))) + (frob fsin %sin fsin) + (frob fcos %cos fcos)) + +(define-vop (ftan) + (:translate %tan) + (:args (x :scs (double-reg) :target fr0)) + (:temporary (:sc double-reg :offset fr0-offset + :from :argument :to :result) fr0) + (:temporary (:sc double-reg :offset fr1-offset + :from :argument :to :result) fr1) + (:temporary (:sc unsigned-reg :offset rax-offset + :from :argument :to :result) rax) + (:results (y :scs (double-reg))) + (:arg-types double-float) + (:result-types double-float) + (:ignore rax) + (:policy :fast-safe) + (:note "inline tan function") + (:vop-var vop) + (:save-p :compute-only) + (:ignore rax fr0) + (:generator 5 + (note-this-location vop :internal-error) + (case (tn-offset x) + (0 + (inst fstp fr1)) + (1 + (fp-pop)) + (t + (fp-pop) + (fp-pop) + (inst fldd (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg *backend*) + :offset (- (tn-offset x) 2))))) + (inst fptan) + (inst fnstsw) ; status word to ax + (inst and ah-tn #x04) ; C2 + (inst jmp :z DONE) + ;; Else x was out of range so reduce it; ST0 is unchanged. + (inst fldz) ; Load 0.0 + (inst fxch fr1) + DONE + ;; Result is in fr1 + (case (tn-offset y) + (0 + (inst fxch fr1)) + (1) + (t + (inst fxch fr1) + (inst fstd y))))) + +#+nil +(define-vop (fexp) + (:translate %exp) + (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0)) + (:temporary (:sc double-reg :offset fr0-offset + :from :argument :to :result) fr0) + (:temporary (:sc double-reg :offset fr1-offset + :from :argument :to :result) fr1) + (:temporary (:sc double-reg :offset fr2-offset + :from :argument :to :result) fr2) + (:results (y :scs (double-reg))) + (:arg-types double-float) + (:result-types double-float) + (:policy :fast-safe) + (:note "inline exp function") + (:vop-var vop) + (:save-p :compute-only) + (:generator 5 + (note-this-location vop :internal-error) + (sc-case x + (double-reg + (cond ((zerop (tn-offset x)) + ;; x is in fr0 + (inst fstp fr1) + (inst fldl2e) + (inst fmul fr1)) + (t + ;; x is in a FP reg, not fr0 + (fp-pop) + (inst fldl2e) + (inst fmul x)))) + ((double-stack descriptor-reg) + (fp-pop) + (inst fldl2e) + (if (sc-is x double-stack) + (inst fmuld (ea-for-df-stack x)) + (inst fmuld (ea-for-df-desc x))))) + ;; Now fr0=x log2(e) + (inst fst fr1) + (inst frndint) + (inst fst fr2) + (inst fsubp-sti fr1) + (inst f2xm1) + (inst fld1) + (inst faddp-sti fr1) + (inst fscale) + (inst fld fr0) + (case (tn-offset y) + ((0 1)) + (t (inst fstd y))))) + +;;; Modified exp that handles the following special cases: +;;; exp(+Inf) is +Inf; exp(-Inf) is 0; exp(NaN) is NaN. +(define-vop (fexp) + (:translate %exp) + (:args (x :scs (double-reg) :target fr0)) + (:temporary (:sc word-reg :offset rax-offset :from :eval :to :result) temp) + (:temporary (:sc double-reg :offset fr0-offset + :from :argument :to :result) fr0) + (:temporary (:sc double-reg :offset fr1-offset + :from :argument :to :result) fr1) + (:temporary (:sc double-reg :offset fr2-offset + :from :argument :to :result) fr2) + (:results (y :scs (double-reg))) + (:arg-types double-float) + (:result-types double-float) + (:policy :fast-safe) + (:note "inline exp function") + (:vop-var vop) + (:save-p :compute-only) + (:ignore temp) + (:generator 5 + (note-this-location vop :internal-error) + (unless (zerop (tn-offset x)) + (inst fxch x) ; x to top of stack + (unless (location= x y) + (inst fst x))) ; maybe save it + ;; Check for Inf or NaN + (inst fxam) + (inst fnstsw) + (inst sahf) + (inst jmp :nc NOINFNAN) ; Neither Inf or NaN. + (inst jmp :np NOINFNAN) ; NaN gives NaN? Continue. + (inst and ah-tn #x02) ; Test sign of Inf. + (inst jmp :z DONE) ; +Inf gives +Inf. + (fp-pop) ; -Inf gives 0 + (inst fldz) + (inst jmp-short DONE) + NOINFNAN + (inst fstp fr1) + (inst fldl2e) + (inst fmul fr1) + ;; Now fr0=x log2(e) + (inst fst fr1) + (inst frndint) + (inst fst fr2) + (inst fsubp-sti fr1) + (inst f2xm1) + (inst fld1) + (inst faddp-sti fr1) + (inst fscale) + (inst fld fr0) + DONE + (unless (zerop (tn-offset y)) + (inst fstd y)))) + +;;; Expm1 = exp(x) - 1. +;;; Handles the following special cases: +;;; expm1(+Inf) is +Inf; expm1(-Inf) is -1.0; expm1(NaN) is NaN. +(define-vop (fexpm1) + (:translate %expm1) + (:args (x :scs (double-reg) :target fr0)) + (:temporary (:sc word-reg :offset rax-offset :from :eval :to :result) temp) + (:temporary (:sc double-reg :offset fr0-offset + :from :argument :to :result) fr0) + (:temporary (:sc double-reg :offset fr1-offset + :from :argument :to :result) fr1) + (:temporary (:sc double-reg :offset fr2-offset + :from :argument :to :result) fr2) + (:results (y :scs (double-reg))) + (:arg-types double-float) + (:result-types double-float) + (:policy :fast-safe) + (:note "inline expm1 function") + (:vop-var vop) + (:save-p :compute-only) + (:ignore temp fr0) + (:generator 5 + (note-this-location vop :internal-error) + (unless (zerop (tn-offset x)) + (inst fxch x) ; x to top of stack + (unless (location= x y) + (inst fst x))) ; maybe save it + ;; Check for Inf or NaN + (inst fxam) + (inst fnstsw) + (inst sahf) + (inst jmp :nc NOINFNAN) ; Neither Inf or NaN. + (inst jmp :np NOINFNAN) ; NaN gives NaN? Continue. + (inst and ah-tn #x02) ; Test sign of Inf. + (inst jmp :z DONE) ; +Inf gives +Inf. + (fp-pop) ; -Inf gives -1.0 + (inst fld1) + (inst fchs) + (inst jmp-short DONE) + NOINFNAN + ;; Free two stack slots leaving the argument on top. + (inst fstp fr2) + (fp-pop) + (inst fldl2e) + (inst fmul fr1) ; Now fr0 = x log2(e) + (inst fst fr1) + (inst frndint) + (inst fsub-sti fr1) + (inst fxch fr1) + (inst f2xm1) + (inst fscale) + (inst fxch fr1) + (inst fld1) + (inst fscale) + (inst fstp fr1) + (inst fld1) + (inst fsub fr1) + (inst fsubr fr2) + DONE + (unless (zerop (tn-offset y)) + (inst fstd y)))) + +(define-vop (flog) + (:translate %log) + (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0)) + (:temporary (:sc double-reg :offset fr0-offset + :from :argument :to :result) fr0) + (:temporary (:sc double-reg :offset fr1-offset + :from :argument :to :result) fr1) + (:results (y :scs (double-reg))) + (:arg-types double-float) + (:result-types double-float) + (:policy :fast-safe) + (:note "inline log function") + (:vop-var vop) + (:save-p :compute-only) + (:generator 5 + (note-this-location vop :internal-error) + (sc-case x + (double-reg + (case (tn-offset x) + (0 + ;; x is in fr0 + (inst fstp fr1) + (inst fldln2) + (inst fxch fr1)) + (1 + ;; x is in fr1 + (fp-pop) + (inst fldln2) + (inst fxch fr1)) + (t + ;; x is in a FP reg, not fr0 or fr1 + (fp-pop) + (fp-pop) + (inst fldln2) + (inst fldd (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg *backend*) + :offset (1- (tn-offset x)))))) + (inst fyl2x)) + ((double-stack descriptor-reg) + (fp-pop) + (fp-pop) + (inst fldln2) + (if (sc-is x double-stack) + (inst fldd (ea-for-df-stack x)) + (inst fldd (ea-for-df-desc x))) + (inst fyl2x))) + (inst fld fr0) + (case (tn-offset y) + ((0 1)) + (t (inst fstd y))))) + +(define-vop (flog10) + (:translate %log10) + (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0)) + (:temporary (:sc double-reg :offset fr0-offset + :from :argument :to :result) fr0) + (:temporary (:sc double-reg :offset fr1-offset + :from :argument :to :result) fr1) + (:results (y :scs (double-reg))) + (:arg-types double-float) + (:result-types double-float) + (:policy :fast-safe) + (:note "inline log10 function") + (:vop-var vop) + (:save-p :compute-only) + (:generator 5 + (note-this-location vop :internal-error) + (sc-case x + (double-reg + (case (tn-offset x) + (0 + ;; x is in fr0 + (inst fstp fr1) + (inst fldlg2) + (inst fxch fr1)) + (1 + ;; x is in fr1 + (fp-pop) + (inst fldlg2) + (inst fxch fr1)) + (t + ;; x is in a FP reg, not fr0 or fr1 + (fp-pop) + (fp-pop) + (inst fldlg2) + (inst fldd (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg *backend*) + :offset (1- (tn-offset x)))))) + (inst fyl2x)) + ((double-stack descriptor-reg) + (fp-pop) + (fp-pop) + (inst fldlg2) + (if (sc-is x double-stack) + (inst fldd (ea-for-df-stack x)) + (inst fldd (ea-for-df-desc x))) + (inst fyl2x))) + (inst fld fr0) + (case (tn-offset y) + ((0 1)) + (t (inst fstd y))))) + +(define-vop (fpow) + (:translate %pow) + (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0) + (y :scs (double-reg double-stack descriptor-reg) :target fr1)) + (:temporary (:sc double-reg :offset fr0-offset + :from (:argument 0) :to :result) fr0) + (:temporary (:sc double-reg :offset fr1-offset + :from (:argument 1) :to :result) fr1) + (:temporary (:sc double-reg :offset fr2-offset + :from :load :to :result) fr2) + (:results (r :scs (double-reg))) + (:arg-types double-float double-float) + (:result-types double-float) + (:policy :fast-safe) + (:note "inline pow function") + (:vop-var vop) + (:save-p :compute-only) + (:generator 5 + (note-this-location vop :internal-error) + ;; Setup x in fr0 and y in fr1 + (cond + ;; x in fr0; y in fr1 + ((and (sc-is x double-reg) (zerop (tn-offset x)) + (sc-is y double-reg) (= 1 (tn-offset y)))) + ;; y in fr1; x not in fr0 + ((and (sc-is y double-reg) (= 1 (tn-offset y))) + ;; Load x to fr0 + (sc-case x + (double-reg + (copy-fp-reg-to-fr0 x)) + (double-stack + (fp-pop) + (inst fldd (ea-for-df-stack x))) + (descriptor-reg + (fp-pop) + (inst fldd (ea-for-df-desc x))))) + ;; x in fr0; y not in fr1 + ((and (sc-is x double-reg) (zerop (tn-offset x))) + (inst fxch fr1) + ;; Now load y to fr0 + (sc-case y + (double-reg + (copy-fp-reg-to-fr0 y)) + (double-stack + (fp-pop) + (inst fldd (ea-for-df-stack y))) + (descriptor-reg + (fp-pop) + (inst fldd (ea-for-df-desc y)))) + (inst fxch fr1)) + ;; x in fr1; y not in fr1 + ((and (sc-is x double-reg) (= 1 (tn-offset x))) + ;; Load y to fr0 + (sc-case y + (double-reg + (copy-fp-reg-to-fr0 y)) + (double-stack + (fp-pop) + (inst fldd (ea-for-df-stack y))) + (descriptor-reg + (fp-pop) + (inst fldd (ea-for-df-desc y)))) + (inst fxch fr1)) + ;; y in fr0; + ((and (sc-is y double-reg) (zerop (tn-offset y))) + (inst fxch fr1) + ;; Now load x to fr0 + (sc-case x + (double-reg + (copy-fp-reg-to-fr0 x)) + (double-stack + (fp-pop) + (inst fldd (ea-for-df-stack x))) + (descriptor-reg + (fp-pop) + (inst fldd (ea-for-df-desc x))))) + ;; Neither x or y are in either fr0 or fr1 + (t + ;; Load y then x + (fp-pop) + (fp-pop) + (sc-case y + (double-reg + (inst fldd (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg *backend*) + :offset (- (tn-offset y) 2)))) + (double-stack + (inst fldd (ea-for-df-stack y))) + (descriptor-reg + (inst fldd (ea-for-df-desc y)))) + ;; Load x to fr0 + (sc-case x + (double-reg + (inst fldd (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg *backend*) + :offset (1- (tn-offset x))))) + (double-stack + (inst fldd (ea-for-df-stack x))) + (descriptor-reg + (inst fldd (ea-for-df-desc x)))))) + + ;; Now have x at fr0; and y at fr1 + (inst fyl2x) + ;; Now fr0=y log2(x) + (inst fld fr0) + (inst frndint) + (inst fst fr2) + (inst fsubp-sti fr1) + (inst f2xm1) + (inst fld1) + (inst faddp-sti fr1) + (inst fscale) + (inst fld fr0) + (case (tn-offset r) + ((0 1)) + (t (inst fstd r))))) + +(define-vop (fscalen) + (:translate %scalbn) + (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0) + (y :scs (signed-stack signed-reg) :target temp)) + (:temporary (:sc double-reg :offset fr0-offset + :from (:argument 0) :to :result) fr0) + (:temporary (:sc double-reg :offset fr1-offset :from :eval :to :result) fr1) + (:temporary (:sc signed-stack :from (:argument 1) :to :result) temp) + (:results (r :scs (double-reg))) + (:arg-types double-float signed-num) + (:result-types double-float) + (:policy :fast-safe) + (:note "inline scalbn function") + (:ignore fr0) + (:generator 5 + ;; Setup x in fr0 and y in fr1 + (sc-case x + (double-reg + (case (tn-offset x) + (0 + (inst fstp fr1) + (sc-case y + (signed-reg + (inst mov temp y) + (inst fild temp)) + (signed-stack + (inst fild y))) + (inst fxch fr1)) + (1 + (fp-pop) + (sc-case y + (signed-reg + (inst mov temp y) + (inst fild temp)) + (signed-stack + (inst fild y))) + (inst fxch fr1)) + (t + (fp-pop) + (fp-pop) + (sc-case y + (signed-reg + (inst mov temp y) + (inst fild temp)) + (signed-stack + (inst fild y))) + (inst fld (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg *backend*) + :offset (1- (tn-offset x))))))) + ((double-stack descriptor-reg) + (fp-pop) + (fp-pop) + (sc-case y + (signed-reg + (inst mov temp y) + (inst fild temp)) + (signed-stack + (inst fild y))) + (if (sc-is x double-stack) + (inst fldd (ea-for-df-stack x)) + (inst fldd (ea-for-df-desc x))))) + (inst fscale) + (unless (zerop (tn-offset r)) + (inst fstd r)))) + +(define-vop (fscale) + (:translate %scalb) + (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0) + (y :scs (double-reg double-stack descriptor-reg) :target fr1)) + (:temporary (:sc double-reg :offset fr0-offset + :from (:argument 0) :to :result) fr0) + (:temporary (:sc double-reg :offset fr1-offset + :from (:argument 1) :to :result) fr1) + (:results (r :scs (double-reg))) + (:arg-types double-float double-float) + (:result-types double-float) + (:policy :fast-safe) + (:note "inline scalb function") + (:vop-var vop) + (:save-p :compute-only) + (:ignore fr0) + (:generator 5 + (note-this-location vop :internal-error) + ;; Setup x in fr0 and y in fr1 + (cond + ;; x in fr0; y in fr1 + ((and (sc-is x double-reg) (zerop (tn-offset x)) + (sc-is y double-reg) (= 1 (tn-offset y)))) + ;; y in fr1; x not in fr0 + ((and (sc-is y double-reg) (= 1 (tn-offset y))) + ;; Load x to fr0 + (sc-case x + (double-reg + (copy-fp-reg-to-fr0 x)) + (double-stack + (fp-pop) + (inst fldd (ea-for-df-stack x))) + (descriptor-reg + (fp-pop) + (inst fldd (ea-for-df-desc x))))) + ;; x in fr0; y not in fr1 + ((and (sc-is x double-reg) (zerop (tn-offset x))) + (inst fxch fr1) + ;; Now load y to fr0 + (sc-case y + (double-reg + (copy-fp-reg-to-fr0 y)) + (double-stack + (fp-pop) + (inst fldd (ea-for-df-stack y))) + (descriptor-reg + (fp-pop) + (inst fldd (ea-for-df-desc y)))) + (inst fxch fr1)) + ;; x in fr1; y not in fr1 + ((and (sc-is x double-reg) (= 1 (tn-offset x))) + ;; Load y to fr0 + (sc-case y + (double-reg + (copy-fp-reg-to-fr0 y)) + (double-stack + (fp-pop) + (inst fldd (ea-for-df-stack y))) + (descriptor-reg + (fp-pop) + (inst fldd (ea-for-df-desc y)))) + (inst fxch fr1)) + ;; y in fr0; + ((and (sc-is y double-reg) (zerop (tn-offset y))) + (inst fxch fr1) + ;; Now load x to fr0 + (sc-case x + (double-reg + (copy-fp-reg-to-fr0 x)) + (double-stack + (fp-pop) + (inst fldd (ea-for-df-stack x))) + (descriptor-reg + (fp-pop) + (inst fldd (ea-for-df-desc x))))) + ;; Neither x or y are in either fr0 or fr1 + (t + ;; Load y then x + (fp-pop) + (fp-pop) + (sc-case y + (double-reg + (inst fldd (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg *backend*) + :offset (- (tn-offset y) 2)))) + (double-stack + (inst fldd (ea-for-df-stack y))) + (descriptor-reg + (inst fldd (ea-for-df-desc y)))) + ;; Load x to fr0 + (sc-case x + (double-reg + (inst fldd (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg *backend*) + :offset (1- (tn-offset x))))) + (double-stack + (inst fldd (ea-for-df-stack x))) + (descriptor-reg + (inst fldd (ea-for-df-desc x)))))) + + ;; Now have x at fr0; and y at fr1 + (inst fscale) + (unless (zerop (tn-offset r)) + (inst fstd r)))) + +(define-vop (flog1p) + (:translate %log1p) + (:args (x :scs (double-reg) :to :result)) + (:temporary (:sc double-reg :offset fr0-offset + :from :argument :to :result) fr0) + (:temporary (:sc double-reg :offset fr1-offset + :from :argument :to :result) fr1) + (:temporary (:sc word-reg :offset rax-offset :from :eval) temp) + (:results (y :scs (double-reg))) + (:arg-types double-float) + (:result-types double-float) + (:policy :fast-safe) + (:guard (not (backend-featurep :pentium))) + (:note "inline log1p function") + (:ignore temp) + (:generator 5 + ;; x is in a FP reg, not fr0, fr1. + (fp-pop) + (fp-pop) + (inst fldd (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg *backend*) + :offset (- (tn-offset x) 2))) + ;; Check the range + (inst push #x3e947ae1) ; Constant 0.29 + (inst fabs) + (inst fld (make-ea :qword :base rsp-tn)) + (inst fcompp) + (inst add rsp-tn 4) + (inst fnstsw) ; status word to ax + (inst and ah-tn #x45) + (inst jmp :z WITHIN-RANGE) + ;; Out of range for fyl2xp1. + (inst fld1) + (inst faddd (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg *backend*) + :offset (- (tn-offset x) 1))) + (inst fldln2) + (inst fxch fr1) + (inst fyl2x) + (inst jmp DONE) + + WITHIN-RANGE + (inst fldln2) + (inst fldd (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg *backend*) + :offset (- (tn-offset x) 1))) + (inst fyl2xp1) + DONE + (inst fld fr0) + (case (tn-offset y) + ((0 1)) + (t (inst fstd y))))) + +;;; The Pentium has a less restricted implementation of the fyl2xp1 +;;; instruction and a range check can be avoided. +(define-vop (flog1p-pentium) + (:translate %log1p) + (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0)) + (:temporary (:sc double-reg :offset fr0-offset + :from :argument :to :result) fr0) + (:temporary (:sc double-reg :offset fr1-offset + :from :argument :to :result) fr1) + (:results (y :scs (double-reg))) + (:arg-types double-float) + (:result-types double-float) + (:policy :fast-safe) + (:guard (backend-featurep :pentium)) + (:note "inline log1p with limited x range function") + (:vop-var vop) + (:save-p :compute-only) + (:generator 5 + (note-this-location vop :internal-error) + (sc-case x + (double-reg + (case (tn-offset x) + (0 + ;; x is in fr0 + (inst fstp fr1) + (inst fldln2) + (inst fxch fr1)) + (1 + ;; x is in fr1 + (fp-pop) + (inst fldln2) + (inst fxch fr1)) + (t + ;; x is in a FP reg, not fr0 or fr1 + (fp-pop) + (fp-pop) + (inst fldln2) + (inst fldd (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg *backend*) + :offset (1- (tn-offset x))))))) + ((double-stack descriptor-reg) + (fp-pop) + (fp-pop) + (inst fldln2) + (if (sc-is x double-stack) + (inst fldd (ea-for-df-stack x)) + (inst fldd (ea-for-df-desc x))))) + (inst fyl2xp1) + (inst fld fr0) + (case (tn-offset y) + ((0 1)) + (t (inst fstd y))))) + +(define-vop (flogb) + (:translate %logb) + (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0)) + (:temporary (:sc double-reg :offset fr0-offset + :from :argument :to :result) fr0) + (:temporary (:sc double-reg :offset fr1-offset + :from :argument :to :result) fr1) + (:results (y :scs (double-reg))) + (:arg-types double-float) + (:result-types double-float) + (:policy :fast-safe) + (:note "inline logb function") + (:vop-var vop) + (:save-p :compute-only) + (:ignore fr0) + (:generator 5 + (note-this-location vop :internal-error) + (sc-case x + (double-reg + (case (tn-offset x) + (0 + ;; x is in fr0 + (inst fstp fr1)) + (1 + ;; x is in fr1 + (fp-pop)) + (t + ;; x is in a FP reg, not fr0 or fr1 + (fp-pop) + (fp-pop) + (inst fldd (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg *backend*) + :offset (- (tn-offset x) 2)))))) + ((double-stack descriptor-reg) + (fp-pop) + (fp-pop) + (if (sc-is x double-stack) + (inst fldd (ea-for-df-stack x)) + (inst fldd (ea-for-df-desc x))))) + (inst fxtract) + (case (tn-offset y) + (0 + (inst fxch fr1)) + (1) + (t (inst fxch fr1) + (inst fstd y))))) + +(define-vop (fatan) + (:translate %atan) + (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0)) + (:temporary (:sc double-reg :offset fr0-offset + :from (:argument 0) :to :result) fr0) + (:temporary (:sc double-reg :offset fr1-offset + :from (:argument 0) :to :result) fr1) + (:results (r :scs (double-reg))) + (:arg-types double-float) + (:result-types double-float) + (:policy :fast-safe) + (:note "inline atan function") + (:vop-var vop) + (:save-p :compute-only) + (:generator 5 + (note-this-location vop :internal-error) + ;; Setup x in fr1 and 1.0 in fr0 + (cond + ;; x in fr0 + ((and (sc-is x double-reg) (zerop (tn-offset x))) + (inst fstp fr1)) + ;; x in fr1 + ((and (sc-is x double-reg) (= 1 (tn-offset x))) + (fp-pop)) + ;; x not in fr0 or fr1 + (t + ;; Load x then 1.0 + (fp-pop) + (fp-pop) + (sc-case x + (double-reg + (inst fldd (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg *backend*) + :offset (- (tn-offset x) 2)))) + (double-stack + (inst fldd (ea-for-df-stack x))) + (descriptor-reg + (inst fldd (ea-for-df-desc x)))))) + (inst fld1) + ;; Now have x at fr1; and 1.0 at fr0 + (inst fpatan) + (inst fld fr0) + (case (tn-offset r) + ((0 1)) + (t (inst fstd r))))) + +(define-vop (fatan2) + (:translate %atan2) + (:args (x :scs (double-reg double-stack descriptor-reg) :target fr1) + (y :scs (double-reg double-stack descriptor-reg) :target fr0)) + (:temporary (:sc double-reg :offset fr0-offset + :from (:argument 1) :to :result) fr0) + (:temporary (:sc double-reg :offset fr1-offset + :from (:argument 0) :to :result) fr1) + (:results (r :scs (double-reg))) + (:arg-types double-float double-float) + (:result-types double-float) + (:policy :fast-safe) + (:note "inline atan2 function") + (:vop-var vop) + (:save-p :compute-only) + (:generator 5 + (note-this-location vop :internal-error) + ;; Setup x in fr1 and y in fr0 + (cond + ;; y in fr0; x in fr1 + ((and (sc-is y double-reg) (zerop (tn-offset y)) + (sc-is x double-reg) (= 1 (tn-offset x)))) + ;; x in fr1; y not in fr0 + ((and (sc-is x double-reg) (= 1 (tn-offset x))) + ;; Load y to fr0 + (sc-case y + (double-reg + (copy-fp-reg-to-fr0 y)) + (double-stack + (fp-pop) + (inst fldd (ea-for-df-stack y))) + (descriptor-reg + (fp-pop) + (inst fldd (ea-for-df-desc y))))) + ;; y in fr0, x in fr0 + ((and (sc-is y double-reg) (zerop (tn-offset y)) + (sc-is x double-reg) (zerop (tn-offset x))) + ;; Copy x to fr1, leave y in fr0 + (inst fst fr1)) + ;; y in fr0; x not in fr1 + ((and (sc-is y double-reg) (zerop (tn-offset y))) + (inst fxch fr1) + ;; Now load x to fr0 + (sc-case x + (double-reg + (copy-fp-reg-to-fr0 x)) + (double-stack + (fp-pop) + (inst fldd (ea-for-df-stack x))) + (descriptor-reg + (fp-pop) + (inst fldd (ea-for-df-desc x)))) + (inst fxch fr1)) + ;; y in fr1; x not in fr1 + ((and (sc-is y double-reg) (= 1 (tn-offset y))) + ;; Load x to fr0 + (sc-case x + (double-reg + (copy-fp-reg-to-fr0 x)) + (double-stack + (fp-pop) + (inst fldd (ea-for-df-stack x))) + (descriptor-reg + (fp-pop) + (inst fldd (ea-for-df-desc x)))) + (inst fxch fr1)) + ;; x in fr0; + ((and (sc-is x double-reg) (zerop (tn-offset x))) + (inst fxch fr1) + ;; Now load y to fr0 + (sc-case y + (double-reg + (copy-fp-reg-to-fr0 y)) + (double-stack + (fp-pop) + (inst fldd (ea-for-df-stack y))) + (descriptor-reg + (fp-pop) + (inst fldd (ea-for-df-desc y))))) + ;; Neither y or x are in either fr0 or fr1 + (t + ;; Load x then y + (fp-pop) + (fp-pop) + (sc-case x + (double-reg + (inst fldd (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg *backend*) + :offset (- (tn-offset x) 2)))) + (double-stack + (inst fldd (ea-for-df-stack x))) + (descriptor-reg + (inst fldd (ea-for-df-desc x)))) + ;; Load y to fr0 + (sc-case y + (double-reg + (inst fldd (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg *backend*) + :offset (1- (tn-offset y))))) + (double-stack + (inst fldd (ea-for-df-stack y))) + (descriptor-reg + (inst fldd (ea-for-df-desc y)))))) + + ;; Now have y at fr0; and x at fr1 + (inst fpatan) + (inst fld fr0) + (case (tn-offset r) + ((0 1)) + (t (inst fstd r))))) + +) ; progn #-long-float + + + +#+long-float +(progn + +;;; Lets use some of the 80387 special functions. +;;; +;;; These defs will not take effect unless code/irrat.lisp is modified +;;; to remove the inlined alien routine def. + +(macrolet ((frob (func trans op) + `(define-vop (,func) + (:args (x :scs (long-reg) :target fr0)) + (:temporary (:sc long-reg :offset fr0-offset + :from :argument :to :result) fr0) + (:ignore fr0) + (:results (y :scs (long-reg))) + (:arg-types long-float) + (:result-types long-float) + (:translate ,trans) + (:policy :fast-safe) + (:note "inline NPX function") + (:vop-var vop) + (:save-p :compute-only) + (:node-var node) + (:generator 5 + (note-this-location vop :internal-error) + (unless (zerop (tn-offset x)) + (inst fxch x) ; x to top of stack + (unless (location= x y) + (inst fst x))) ; maybe save it + (inst ,op) ; clobber st0 + (cond ((zerop (tn-offset y)) + (when (policy node (or (= debug 3) (> safety speed))) + (inst wait))) + (t + (inst fst y))))))) + + ;; Quick versions of fsin and fcos that require the argument to be + ;; within range 2^63. + (frob fsin-quick %sin-quick fsin) + (frob fcos-quick %cos-quick fcos) + ;; + (frob fsqrt %sqrt fsqrt)) + +;;; Quick version of ftan that requires the argument to be within +;;; range 2^63. +(define-vop (ftan-quick) + (:translate %tan-quick) + (:args (x :scs (long-reg) :target fr0)) + (:temporary (:sc long-reg :offset fr0-offset + :from :argument :to :result) fr0) + (:temporary (:sc long-reg :offset fr1-offset + :from :argument :to :result) fr1) + (:results (y :scs (long-reg))) + (:arg-types long-float) + (:result-types long-float) + (:policy :fast-safe) + (:note "inline tan function") + (:vop-var vop) + (:save-p :compute-only) + (:ignore fr0) + (:generator 5 + (note-this-location vop :internal-error) + (case (tn-offset x) + (0 + (inst fstp fr1)) + (1 + (fp-pop)) + (t + (fp-pop) + (fp-pop) + (inst fldd (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg *backend*) + :offset (- (tn-offset x) 2))))) + (inst fptan) + ;; Result is in fr1 + (case (tn-offset y) + (0 + (inst fxch fr1)) + (1) + (t + (inst fxch fr1) + (inst fstd y))))) + +;;; These versions of fsin, fcos, and ftan try to use argument +;;; reduction but to do this accurately requires greater precision and +;;; it is hopelessly inaccurate. +#+nil +(macrolet ((frob (func trans op) + `(define-vop (,func) + (:translate ,trans) + (:args (x :scs (long-reg) :target fr0)) + (:temporary (:sc unsigned-reg :offset rax-offset + :from :eval :to :result) rax) + (:temporary (:sc long-reg :offset fr0-offset + :from :argument :to :result) fr0) + (:temporary (:sc long-reg :offset fr1-offset + :from :argument :to :result) fr1) + (:results (y :scs (long-reg))) + (:arg-types long-float) + (:result-types long-float) + (:policy :fast-safe) + (:note "inline sin/cos function") + (:vop-var vop) + (:save-p :compute-only) + (:ignore rax) + (:generator 5 + (note-this-location vop :internal-error) + (unless (zerop (tn-offset x)) + (inst fxch x) ; x to top of stack + (unless (location= x y) + (inst fst x))) ; maybe save it + (inst ,op) + (inst fnstsw) ; status word to ax + (inst and ah-tn #x04) ; C2 + (inst jmp :z DONE) + ;; Else x was out of range so reduce it; ST0 is unchanged. + (inst fstp fr1) ; Load 2*PI + (inst fldpi) + (inst fadd fr0) + (inst fxch fr1) + LOOP + (inst fprem1) + (inst fnstsw) ; status word to ax + (inst and ah-tn #x04) ; C2 + (inst jmp :nz LOOP) + (inst ,op) + DONE + (unless (zerop (tn-offset y)) + (inst fstd y)))))) + (frob fsin %sin fsin) + (frob fcos %cos fcos)) + +#+nil +(define-vop (ftan) + (:translate %tan) + (:args (x :scs (long-reg) :target fr0)) + (:temporary (:sc unsigned-reg :offset rax-offset + :from :argument :to :result) rax) + (:temporary (:sc long-reg :offset fr0-offset + :from :argument :to :result) fr0) + (:temporary (:sc long-reg :offset fr1-offset + :from :argument :to :result) fr1) + (:results (y :scs (long-reg))) + (:arg-types long-float) + (:result-types long-float) + (:policy :fast-safe) + (:note "inline tan function") + (:vop-var vop) + (:save-p :compute-only) + (:ignore rax) + (:generator 5 + (note-this-location vop :internal-error) + (case (tn-offset x) + (0 + (inst fstp fr1)) + (1 + (fp-pop)) + (t + (fp-pop) + (fp-pop) + (inst fldd (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg *backend*) + :offset (- (tn-offset x) 2))))) + (inst fptan) + (inst fnstsw) ; status word to ax + (inst and ah-tn #x04) ; C2 + (inst jmp :z DONE) + ;; Else x was out of range so reduce it; ST0 is unchanged. + (inst fldpi) ; Load 2*PI + (inst fadd fr0) + (inst fxch fr1) + LOOP + (inst fprem1) + (inst fnstsw) ; status word to ax + (inst and ah-tn #x04) ; C2 + (inst jmp :nz LOOP) + (inst fstp fr1) + (inst fptan) + DONE + ;; Result is in fr1 + (case (tn-offset y) + (0 + (inst fxch fr1)) + (1) + (t + (inst fxch fr1) + (inst fstd y))))) + +;;; These versions of fsin, fcos, and ftan simply load a 0.0 result if +;;; the argument is out of range 2^63 and would thus be hopelessly +;;; inaccurate. +(macrolet ((frob (func trans op) + `(define-vop (,func) + (:translate ,trans) + (:args (x :scs (long-reg) :target fr0)) + (:temporary (:sc long-reg :offset fr0-offset + :from :argument :to :result) fr0) + (:temporary (:sc unsigned-reg :offset rax-offset + :from :argument :to :result) rax) + (:results (y :scs (long-reg))) + (:arg-types long-float) + (:result-types long-float) + (:policy :fast-safe) + (:note "inline sin/cos function") + (:vop-var vop) + (:save-p :compute-only) + (:ignore rax fr0) + (:generator 5 + (note-this-location vop :internal-error) + (unless (zerop (tn-offset x)) + (inst fxch x) ; x to top of stack + (unless (location= x y) + (inst fst x))) ; maybe save it + (inst ,op) + (inst fnstsw) ; status word to ax + (inst and ah-tn #x04) ; C2 + (inst jmp :z DONE) + ;; Else x was out of range so reduce it; ST0 is unchanged. + (fp-pop) ; Load 0.0 + (inst fldz) + DONE + (unless (zerop (tn-offset y)) + (inst fstd y)))))) + (frob fsin %sin fsin) + (frob fcos %cos fcos)) + +(define-vop (ftan) + (:translate %tan) + (:args (x :scs (long-reg) :target fr0)) + (:temporary (:sc long-reg :offset fr0-offset + :from :argument :to :result) fr0) + (:temporary (:sc long-reg :offset fr1-offset + :from :argument :to :result) fr1) + (:temporary (:sc unsigned-reg :offset rax-offset + :from :argument :to :result) rax) + (:results (y :scs (long-reg))) + (:arg-types long-float) + (:result-types long-float) + (:ignore rax) + (:policy :fast-safe) + (:note "inline tan function") + (:vop-var vop) + (:save-p :compute-only) + (:ignore rax fr0) + (:generator 5 + (note-this-location vop :internal-error) + (case (tn-offset x) + (0 + (inst fstp fr1)) + (1 + (fp-pop)) + (t + (fp-pop) + (fp-pop) + (inst fldd (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg *backend*) + :offset (- (tn-offset x) 2))))) + (inst fptan) + (inst fnstsw) ; status word to ax + (inst and ah-tn #x04) ; C2 + (inst jmp :z DONE) + ;; Else x was out of range so reduce it; ST0 is unchanged. + (inst fldz) ; Load 0.0 + (inst fxch fr1) + DONE + ;; Result is in fr1 + (case (tn-offset y) + (0 + (inst fxch fr1)) + (1) + (t + (inst fxch fr1) + (inst fstd y))))) + +;;; Modified exp that handles the following special cases: +;;; exp(+Inf) is +Inf; exp(-Inf) is 0; exp(NaN) is NaN. +(define-vop (fexp) + (:translate %exp) + (:args (x :scs (long-reg) :target fr0)) + (:temporary (:sc word-reg :offset rax-offset :from :eval :to :result) temp) + (:temporary (:sc long-reg :offset fr0-offset + :from :argument :to :result) fr0) + (:temporary (:sc long-reg :offset fr1-offset + :from :argument :to :result) fr1) + (:temporary (:sc long-reg :offset fr2-offset + :from :argument :to :result) fr2) + (:results (y :scs (long-reg))) + (:arg-types long-float) + (:result-types long-float) + (:policy :fast-safe) + (:note "inline exp function") + (:vop-var vop) + (:save-p :compute-only) + (:ignore temp) + (:generator 5 + (note-this-location vop :internal-error) + (unless (zerop (tn-offset x)) + (inst fxch x) ; x to top of stack + (unless (location= x y) + (inst fst x))) ; maybe save it + ;; Check for Inf or NaN + (inst fxam) + (inst fnstsw) + (inst sahf) + (inst jmp :nc NOINFNAN) ; Neither Inf or NaN. + (inst jmp :np NOINFNAN) ; NaN gives NaN? Continue. + (inst and ah-tn #x02) ; Test sign of Inf. + (inst jmp :z DONE) ; +Inf gives +Inf. + (fp-pop) ; -Inf gives 0 + (inst fldz) + (inst jmp-short DONE) + NOINFNAN + (inst fstp fr1) + (inst fldl2e) + (inst fmul fr1) + ;; Now fr0=x log2(e) + (inst fst fr1) + (inst frndint) + (inst fst fr2) + (inst fsubp-sti fr1) + (inst f2xm1) + (inst fld1) + (inst faddp-sti fr1) + (inst fscale) + (inst fld fr0) + DONE + (unless (zerop (tn-offset y)) + (inst fstd y)))) + +;;; Expm1 = exp(x) - 1. +;;; Handles the following special cases: +;;; expm1(+Inf) is +Inf; expm1(-Inf) is -1.0; expm1(NaN) is NaN. +(define-vop (fexpm1) + (:translate %expm1) + (:args (x :scs (long-reg) :target fr0)) + (:temporary (:sc word-reg :offset rax-offset :from :eval :to :result) temp) + (:temporary (:sc long-reg :offset fr0-offset + :from :argument :to :result) fr0) + (:temporary (:sc long-reg :offset fr1-offset + :from :argument :to :result) fr1) + (:temporary (:sc long-reg :offset fr2-offset + :from :argument :to :result) fr2) + (:results (y :scs (long-reg))) + (:arg-types long-float) + (:result-types long-float) + (:policy :fast-safe) + (:note "inline expm1 function") + (:vop-var vop) + (:save-p :compute-only) + (:ignore temp fr0) + (:generator 5 + (note-this-location vop :internal-error) + (unless (zerop (tn-offset x)) + (inst fxch x) ; x to top of stack + (unless (location= x y) + (inst fst x))) ; maybe save it + ;; Check for Inf or NaN + (inst fxam) + (inst fnstsw) + (inst sahf) + (inst jmp :nc NOINFNAN) ; Neither Inf or NaN. + (inst jmp :np NOINFNAN) ; NaN gives NaN? Continue. + (inst and ah-tn #x02) ; Test sign of Inf. + (inst jmp :z DONE) ; +Inf gives +Inf. + (fp-pop) ; -Inf gives -1.0 + (inst fld1) + (inst fchs) + (inst jmp-short DONE) + NOINFNAN + ;; Free two stack slots leaving the argument on top. + (inst fstp fr2) + (fp-pop) + (inst fldl2e) + (inst fmul fr1) ; Now fr0 = x log2(e) + (inst fst fr1) + (inst frndint) + (inst fsub-sti fr1) + (inst fxch fr1) + (inst f2xm1) + (inst fscale) + (inst fxch fr1) + (inst fld1) + (inst fscale) + (inst fstp fr1) + (inst fld1) + (inst fsub fr1) + (inst fsubr fr2) + DONE + (unless (zerop (tn-offset y)) + (inst fstd y)))) + +(define-vop (flog) + (:translate %log) + (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0)) + (:temporary (:sc long-reg :offset fr0-offset + :from :argument :to :result) fr0) + (:temporary (:sc long-reg :offset fr1-offset + :from :argument :to :result) fr1) + (:results (y :scs (long-reg))) + (:arg-types long-float) + (:result-types long-float) + (:policy :fast-safe) + (:note "inline log function") + (:vop-var vop) + (:save-p :compute-only) + (:generator 5 + (note-this-location vop :internal-error) + (sc-case x + (long-reg + (case (tn-offset x) + (0 + ;; x is in fr0 + (inst fstp fr1) + (inst fldln2) + (inst fxch fr1)) + (1 + ;; x is in fr1 + (fp-pop) + (inst fldln2) + (inst fxch fr1)) + (t + ;; x is in a FP reg, not fr0 or fr1 + (fp-pop) + (fp-pop) + (inst fldln2) + (inst fldd (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg *backend*) + :offset (1- (tn-offset x)))))) + (inst fyl2x)) + ((long-stack descriptor-reg) + (fp-pop) + (fp-pop) + (inst fldln2) + (if (sc-is x long-stack) + (inst fldl (ea-for-lf-stack x)) + (inst fldl (ea-for-lf-desc x))) + (inst fyl2x))) + (inst fld fr0) + (case (tn-offset y) + ((0 1)) + (t (inst fstd y))))) + +(define-vop (flog10) + (:translate %log10) + (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0)) + (:temporary (:sc long-reg :offset fr0-offset + :from :argument :to :result) fr0) + (:temporary (:sc long-reg :offset fr1-offset + :from :argument :to :result) fr1) + (:results (y :scs (long-reg))) + (:arg-types long-float) + (:result-types long-float) + (:policy :fast-safe) + (:note "inline log10 function") + (:vop-var vop) + (:save-p :compute-only) + (:generator 5 + (note-this-location vop :internal-error) + (sc-case x + (long-reg + (case (tn-offset x) + (0 + ;; x is in fr0 + (inst fstp fr1) + (inst fldlg2) + (inst fxch fr1)) + (1 + ;; x is in fr1 + (fp-pop) + (inst fldlg2) + (inst fxch fr1)) + (t + ;; x is in a FP reg, not fr0 or fr1 + (fp-pop) + (fp-pop) + (inst fldlg2) + (inst fldd (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg *backend*) + :offset (1- (tn-offset x)))))) + (inst fyl2x)) + ((long-stack descriptor-reg) + (fp-pop) + (fp-pop) + (inst fldlg2) + (if (sc-is x long-stack) + (inst fldl (ea-for-lf-stack x)) + (inst fldl (ea-for-lf-desc x))) + (inst fyl2x))) + (inst fld fr0) + (case (tn-offset y) + ((0 1)) + (t (inst fstd y))))) + +(define-vop (fpow) + (:translate %pow) + (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0) + (y :scs (long-reg long-stack descriptor-reg) :target fr1)) + (:temporary (:sc long-reg :offset fr0-offset + :from (:argument 0) :to :result) fr0) + (:temporary (:sc long-reg :offset fr1-offset + :from (:argument 1) :to :result) fr1) + (:temporary (:sc long-reg :offset fr2-offset + :from :load :to :result) fr2) + (:results (r :scs (long-reg))) + (:arg-types long-float long-float) + (:result-types long-float) + (:policy :fast-safe) + (:note "inline pow function") + (:vop-var vop) + (:save-p :compute-only) + (:generator 5 + (note-this-location vop :internal-error) + ;; Setup x in fr0 and y in fr1 + (cond + ;; x in fr0; y in fr1 + ((and (sc-is x long-reg) (zerop (tn-offset x)) + (sc-is y long-reg) (= 1 (tn-offset y)))) + ;; y in fr1; x not in fr0 + ((and (sc-is y long-reg) (= 1 (tn-offset y))) + ;; Load x to fr0 + (sc-case x + (long-reg + (copy-fp-reg-to-fr0 x)) + (long-stack + (fp-pop) + (inst fldl (ea-for-lf-stack x))) + (descriptor-reg + (fp-pop) + (inst fldl (ea-for-lf-desc x))))) + ;; x in fr0; y not in fr1 + ((and (sc-is x long-reg) (zerop (tn-offset x))) + (inst fxch fr1) + ;; Now load y to fr0 + (sc-case y + (long-reg + (copy-fp-reg-to-fr0 y)) + (long-stack + (fp-pop) + (inst fldl (ea-for-lf-stack y))) + (descriptor-reg + (fp-pop) + (inst fldl (ea-for-lf-desc y)))) + (inst fxch fr1)) + ;; x in fr1; y not in fr1 + ((and (sc-is x long-reg) (= 1 (tn-offset x))) + ;; Load y to fr0 + (sc-case y + (long-reg + (copy-fp-reg-to-fr0 y)) + (long-stack + (fp-pop) + (inst fldl (ea-for-lf-stack y))) + (descriptor-reg + (fp-pop) + (inst fldl (ea-for-lf-desc y)))) + (inst fxch fr1)) + ;; y in fr0; + ((and (sc-is y long-reg) (zerop (tn-offset y))) + (inst fxch fr1) + ;; Now load x to fr0 + (sc-case x + (long-reg + (copy-fp-reg-to-fr0 x)) + (long-stack + (fp-pop) + (inst fldl (ea-for-lf-stack x))) + (descriptor-reg + (fp-pop) + (inst fldl (ea-for-lf-desc x))))) + ;; Neither x or y are in either fr0 or fr1 + (t + ;; Load y then x + (fp-pop) + (fp-pop) + (sc-case y + (long-reg + (inst fldd (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg *backend*) + :offset (- (tn-offset y) 2)))) + (long-stack + (inst fldl (ea-for-lf-stack y))) + (descriptor-reg + (inst fldl (ea-for-lf-desc y)))) + ;; Load x to fr0 + (sc-case x + (long-reg + (inst fldd (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg *backend*) + :offset (1- (tn-offset x))))) + (long-stack + (inst fldl (ea-for-lf-stack x))) + (descriptor-reg + (inst fldl (ea-for-lf-desc x)))))) + + ;; Now have x at fr0; and y at fr1 + (inst fyl2x) + ;; Now fr0=y log2(x) + (inst fld fr0) + (inst frndint) + (inst fst fr2) + (inst fsubp-sti fr1) + (inst f2xm1) + (inst fld1) + (inst faddp-sti fr1) + (inst fscale) + (inst fld fr0) + (case (tn-offset r) + ((0 1)) + (t (inst fstd r))))) + +(define-vop (fscalen) + (:translate %scalbn) + (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0) + (y :scs (signed-stack signed-reg) :target temp)) + (:temporary (:sc long-reg :offset fr0-offset + :from (:argument 0) :to :result) fr0) + (:temporary (:sc long-reg :offset fr1-offset :from :eval :to :result) fr1) + (:temporary (:sc signed-stack :from (:argument 1) :to :result) temp) + (:results (r :scs (long-reg))) + (:arg-types long-float signed-num) + (:result-types long-float) + (:policy :fast-safe) + (:note "inline scalbn function") + (:ignore fr0) + (:generator 5 + ;; Setup x in fr0 and y in fr1 + (sc-case x + (long-reg + (case (tn-offset x) + (0 + (inst fstp fr1) + (sc-case y + (signed-reg + (inst mov temp y) + (inst fild temp)) + (signed-stack + (inst fild y))) + (inst fxch fr1)) + (1 + (fp-pop) + (sc-case y + (signed-reg + (inst mov temp y) + (inst fild temp)) + (signed-stack + (inst fild y))) + (inst fxch fr1)) + (t + (fp-pop) + (fp-pop) + (sc-case y + (signed-reg + (inst mov temp y) + (inst fild temp)) + (signed-stack + (inst fild y))) + (inst fld (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg *backend*) + :offset (1- (tn-offset x))))))) + ((long-stack descriptor-reg) + (fp-pop) + (fp-pop) + (sc-case y + (signed-reg + (inst mov temp y) + (inst fild temp)) + (signed-stack + (inst fild y))) + (if (sc-is x long-stack) + (inst fldl (ea-for-lf-stack x)) + (inst fldl (ea-for-lf-desc x))))) + (inst fscale) + (unless (zerop (tn-offset r)) + (inst fstd r)))) + +(define-vop (fscale) + (:translate %scalb) + (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0) + (y :scs (long-reg long-stack descriptor-reg) :target fr1)) + (:temporary (:sc long-reg :offset fr0-offset + :from (:argument 0) :to :result) fr0) + (:temporary (:sc long-reg :offset fr1-offset + :from (:argument 1) :to :result) fr1) + (:results (r :scs (long-reg))) + (:arg-types long-float long-float) + (:result-types long-float) + (:policy :fast-safe) + (:note "inline scalb function") + (:vop-var vop) + (:save-p :compute-only) + (:ignore fr0) + (:generator 5 + (note-this-location vop :internal-error) + ;; Setup x in fr0 and y in fr1 + (cond + ;; x in fr0; y in fr1 + ((and (sc-is x long-reg) (zerop (tn-offset x)) + (sc-is y long-reg) (= 1 (tn-offset y)))) + ;; y in fr1; x not in fr0 + ((and (sc-is y long-reg) (= 1 (tn-offset y))) + ;; Load x to fr0 + (sc-case x + (long-reg + (copy-fp-reg-to-fr0 x)) + (long-stack + (fp-pop) + (inst fldl (ea-for-lf-stack x))) + (descriptor-reg + (fp-pop) + (inst fldl (ea-for-lf-desc x))))) + ;; x in fr0; y not in fr1 + ((and (sc-is x long-reg) (zerop (tn-offset x))) + (inst fxch fr1) + ;; Now load y to fr0 + (sc-case y + (long-reg + (copy-fp-reg-to-fr0 y)) + (long-stack + (fp-pop) + (inst fldl (ea-for-lf-stack y))) + (descriptor-reg + (fp-pop) + (inst fldl (ea-for-lf-desc y)))) + (inst fxch fr1)) + ;; x in fr1; y not in fr1 + ((and (sc-is x long-reg) (= 1 (tn-offset x))) + ;; Load y to fr0 + (sc-case y + (long-reg + (copy-fp-reg-to-fr0 y)) + (long-stack + (fp-pop) + (inst fldl (ea-for-lf-stack y))) + (descriptor-reg + (fp-pop) + (inst fldl (ea-for-lf-desc y)))) + (inst fxch fr1)) + ;; y in fr0; + ((and (sc-is y long-reg) (zerop (tn-offset y))) + (inst fxch fr1) + ;; Now load x to fr0 + (sc-case x + (long-reg + (copy-fp-reg-to-fr0 x)) + (long-stack + (fp-pop) + (inst fldl (ea-for-lf-stack x))) + (descriptor-reg + (fp-pop) + (inst fldl (ea-for-lf-desc x))))) + ;; Neither x or y are in either fr0 or fr1 + (t + ;; Load y then x + (fp-pop) + (fp-pop) + (sc-case y + (long-reg + (inst fldd (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg *backend*) + :offset (- (tn-offset y) 2)))) + (long-stack + (inst fldl (ea-for-lf-stack y))) + (descriptor-reg + (inst fldl (ea-for-lf-desc y)))) + ;; Load x to fr0 + (sc-case x + (long-reg + (inst fldd (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg *backend*) + :offset (1- (tn-offset x))))) + (long-stack + (inst fldl (ea-for-lf-stack x))) + (descriptor-reg + (inst fldl (ea-for-lf-desc x)))))) + + ;; Now have x at fr0; and y at fr1 + (inst fscale) + (unless (zerop (tn-offset r)) + (inst fstd r)))) + +(define-vop (flog1p) + (:translate %log1p) + (:args (x :scs (long-reg) :to :result)) + (:temporary (:sc long-reg :offset fr0-offset + :from :argument :to :result) fr0) + (:temporary (:sc long-reg :offset fr1-offset + :from :argument :to :result) fr1) + (:temporary (:sc word-reg :offset rax-offset :from :eval) temp) + (:results (y :scs (long-reg))) + (:arg-types long-float) + (:result-types long-float) + (:policy :fast-safe) + (:guard (not (backend-featurep :pentium))) + (:note "inline log1p function") + (:ignore temp) + (:generator 5 + ;; x is in a FP reg, not fr0, fr1. + (fp-pop) + (fp-pop) + (inst fldd (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg *backend*) + :offset (- (tn-offset x) 2))) + ;; Check the range + (inst push #x3e947ae1) ; Constant 0.29 + (inst fabs) + (inst fld (make-ea :qword :base rsp-tn)) + (inst fcompp) + (inst add rsp-tn 4) + (inst fnstsw) ; status word to ax + (inst and ah-tn #x45) + (inst jmp :z WITHIN-RANGE) + ;; Out of range for fyl2xp1. + (inst fld1) + (inst faddd (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg *backend*) + :offset (- (tn-offset x) 1))) + (inst fldln2) + (inst fxch fr1) + (inst fyl2x) + (inst jmp DONE) + + WITHIN-RANGE + (inst fldln2) + (inst fldd (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg *backend*) + :offset (- (tn-offset x) 1))) + (inst fyl2xp1) + DONE + (inst fld fr0) + (case (tn-offset y) + ((0 1)) + (t (inst fstd y))))) + +;;; The Pentium has a less restricted implementation of the fyl2xp1 +;;; instruction and a range check can be avoided. +(define-vop (flog1p-pentium) + (:translate %log1p) + (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0)) + (:temporary (:sc long-reg :offset fr0-offset + :from :argument :to :result) fr0) + (:temporary (:sc long-reg :offset fr1-offset + :from :argument :to :result) fr1) + (:results (y :scs (long-reg))) + (:arg-types long-float) + (:result-types long-float) + (:policy :fast-safe) + (:guard (backend-featurep :pentium)) + (:note "inline log1p function") + (:generator 5 + (sc-case x + (long-reg + (case (tn-offset x) + (0 + ;; x is in fr0 + (inst fstp fr1) + (inst fldln2) + (inst fxch fr1)) + (1 + ;; x is in fr1 + (fp-pop) + (inst fldln2) + (inst fxch fr1)) + (t + ;; x is in a FP reg, not fr0 or fr1 + (fp-pop) + (fp-pop) + (inst fldln2) + (inst fldd (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg *backend*) + :offset (1- (tn-offset x))))))) + ((long-stack descriptor-reg) + (fp-pop) + (fp-pop) + (inst fldln2) + (if (sc-is x long-stack) + (inst fldl (ea-for-lf-stack x)) + (inst fldl (ea-for-lf-desc x))))) + (inst fyl2xp1) + (inst fld fr0) + (case (tn-offset y) + ((0 1)) + (t (inst fstd y))))) + +(define-vop (flogb) + (:translate %logb) + (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0)) + (:temporary (:sc long-reg :offset fr0-offset + :from :argument :to :result) fr0) + (:temporary (:sc long-reg :offset fr1-offset + :from :argument :to :result) fr1) + (:results (y :scs (long-reg))) + (:arg-types long-float) + (:result-types long-float) + (:policy :fast-safe) + (:note "inline logb function") + (:vop-var vop) + (:save-p :compute-only) + (:ignore fr0) + (:generator 5 + (note-this-location vop :internal-error) + (sc-case x + (long-reg + (case (tn-offset x) + (0 + ;; x is in fr0 + (inst fstp fr1)) + (1 + ;; x is in fr1 + (fp-pop)) + (t + ;; x is in a FP reg, not fr0 or fr1 + (fp-pop) + (fp-pop) + (inst fldd (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg *backend*) + :offset (- (tn-offset x) 2)))))) + ((long-stack descriptor-reg) + (fp-pop) + (fp-pop) + (if (sc-is x long-stack) + (inst fldl (ea-for-lf-stack x)) + (inst fldl (ea-for-lf-desc x))))) + (inst fxtract) + (case (tn-offset y) + (0 + (inst fxch fr1)) + (1) + (t (inst fxch fr1) + (inst fstd y))))) + +(define-vop (fatan) + (:translate %atan) + (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0)) + (:temporary (:sc long-reg :offset fr0-offset + :from (:argument 0) :to :result) fr0) + (:temporary (:sc long-reg :offset fr1-offset + :from (:argument 0) :to :result) fr1) + (:results (r :scs (long-reg))) + (:arg-types long-float) + (:result-types long-float) + (:policy :fast-safe) + (:note "inline atan function") + (:vop-var vop) + (:save-p :compute-only) + (:generator 5 + (note-this-location vop :internal-error) + ;; Setup x in fr1 and 1.0 in fr0 + (cond + ;; x in fr0 + ((and (sc-is x long-reg) (zerop (tn-offset x))) + (inst fstp fr1)) + ;; x in fr1 + ((and (sc-is x long-reg) (= 1 (tn-offset x))) + (fp-pop)) + ;; x not in fr0 or fr1 + (t + ;; Load x then 1.0 + (fp-pop) + (fp-pop) + (sc-case x + (long-reg + (inst fldd (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg *backend*) + :offset (- (tn-offset x) 2)))) + (long-stack + (inst fldl (ea-for-lf-stack x))) + (descriptor-reg + (inst fldl (ea-for-lf-desc x)))))) + (inst fld1) + ;; Now have x at fr1; and 1.0 at fr0 + (inst fpatan) + (inst fld fr0) + (case (tn-offset r) + ((0 1)) + (t (inst fstd r))))) + +(define-vop (fatan2) + (:translate %atan2) + (:args (x :scs (long-reg long-stack descriptor-reg) :target fr1) + (y :scs (long-reg long-stack descriptor-reg) :target fr0)) + (:temporary (:sc long-reg :offset fr0-offset + :from (:argument 1) :to :result) fr0) + (:temporary (:sc long-reg :offset fr1-offset + :from (:argument 0) :to :result) fr1) + (:results (r :scs (long-reg))) + (:arg-types long-float long-float) + (:result-types long-float) + (:policy :fast-safe) + (:note "inline atan2 function") + (:vop-var vop) + (:save-p :compute-only) + (:generator 5 + (note-this-location vop :internal-error) + ;; Setup x in fr1 and y in fr0 + (cond + ;; y in fr0; x in fr1 + ((and (sc-is y long-reg) (zerop (tn-offset y)) + (sc-is x long-reg) (= 1 (tn-offset x)))) + ;; x in fr1; y not in fr0 + ((and (sc-is x long-reg) (= 1 (tn-offset x))) + ;; Load y to fr0 + (sc-case y + (long-reg + (copy-fp-reg-to-fr0 y)) + (long-stack + (fp-pop) + (inst fldl (ea-for-lf-stack y))) + (descriptor-reg + (fp-pop) + (inst fldl (ea-for-lf-desc y))))) + ;; y in fr0; x not in fr1 + ((and (sc-is y long-reg) (zerop (tn-offset y))) + (inst fxch fr1) + ;; Now load x to fr0 + (sc-case x + (long-reg + (copy-fp-reg-to-fr0 x)) + (long-stack + (fp-pop) + (inst fldl (ea-for-lf-stack x))) + (descriptor-reg + (fp-pop) + (inst fldl (ea-for-lf-desc x)))) + (inst fxch fr1)) + ;; y in fr1; x not in fr1 + ((and (sc-is y long-reg) (= 1 (tn-offset y))) + ;; Load x to fr0 + (sc-case x + (long-reg + (copy-fp-reg-to-fr0 x)) + (long-stack + (fp-pop) + (inst fldl (ea-for-lf-stack x))) + (descriptor-reg + (fp-pop) + (inst fldl (ea-for-lf-desc x)))) + (inst fxch fr1)) + ;; x in fr0; + ((and (sc-is x long-reg) (zerop (tn-offset x))) + (inst fxch fr1) + ;; Now load y to fr0 + (sc-case y + (long-reg + (copy-fp-reg-to-fr0 y)) + (long-stack + (fp-pop) + (inst fldl (ea-for-lf-stack y))) + (descriptor-reg + (fp-pop) + (inst fldl (ea-for-lf-desc y))))) + ;; Neither y or x are in either fr0 or fr1 + (t + ;; Load x then y + (fp-pop) + (fp-pop) + (sc-case x + (long-reg + (inst fldd (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg *backend*) + :offset (- (tn-offset x) 2)))) + (long-stack + (inst fldl (ea-for-lf-stack x))) + (descriptor-reg + (inst fldl (ea-for-lf-desc x)))) + ;; Load y to fr0 + (sc-case y + (long-reg + (inst fldd (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg *backend*) + :offset (1- (tn-offset y))))) + (long-stack + (inst fldl (ea-for-lf-stack y))) + (descriptor-reg + (inst fldl (ea-for-lf-desc y)))))) + + ;; Now have y at fr0; and x at fr1 + (inst fpatan) + (inst fld fr0) + (case (tn-offset r) + ((0 1)) + (t (inst fstd r))))) + +) ; progn #+long-float + + +;;;; Complex float VOPs + +(define-vop (make-complex-single-float) + (:translate complex) + (:args (real :scs (single-reg) :to :result :target r + :load-if (not (location= real r))) + (imag :scs (single-reg) :to :save)) + (:arg-types single-float single-float) + (:results (r :scs (complex-single-reg) :from (:argument 0) + :load-if (not (sc-is r complex-single-stack)))) + (:result-types complex-single-float) + (:note "inline complex single-float creation") + (:policy :fast-safe) + (:generator 5 + (sc-case r + (complex-single-reg + (let ((r-real (complex-double-reg-real-tn r))) + (unless (location= real r-real) + (cond ((zerop (tn-offset r-real)) + (copy-fp-reg-to-fr0 real)) + ((zerop (tn-offset real)) + (inst fstd r-real)) + (t + (inst fxch real) + (inst fstd r-real) + (inst fxch real))))) + (let ((r-imag (complex-double-reg-imag-tn r))) + (unless (location= imag r-imag) + (cond ((zerop (tn-offset imag)) + (inst fstd r-imag)) + (t + (inst fxch imag) + (inst fstd r-imag) + (inst fxch imag)))))) + (complex-single-stack + (unless (location= real r) + (cond ((zerop (tn-offset real)) + (inst fst (ea-for-csf-real-stack r))) + (t + (inst fxch real) + (inst fst (ea-for-csf-real-stack r)) + (inst fxch real)))) + (inst fxch imag) + (inst fst (ea-for-csf-imag-stack r)) + (inst fxch imag))))) + +(define-vop (make-complex-double-float) + (:translate complex) + (:args (real :scs (double-reg) :target r + :load-if (not (location= real r))) + (imag :scs (double-reg) :to :save)) + (:arg-types double-float double-float) + (:results (r :scs (complex-double-reg) :from (:argument 0) + :load-if (not (sc-is r complex-double-stack)))) + (:result-types complex-double-float) + (:note "inline complex double-float creation") + (:policy :fast-safe) + (:generator 5 + (sc-case r + (complex-double-reg + (let ((r-real (complex-double-reg-real-tn r))) + (unless (location= real r-real) + (cond ((zerop (tn-offset r-real)) + (copy-fp-reg-to-fr0 real)) + ((zerop (tn-offset real)) + (inst fstd r-real)) + (t + (inst fxch real) + (inst fstd r-real) + (inst fxch real))))) + (let ((r-imag (complex-double-reg-imag-tn r))) + (unless (location= imag r-imag) + (cond ((zerop (tn-offset imag)) + (inst fstd r-imag)) + (t + (inst fxch imag) + (inst fstd r-imag) + (inst fxch imag)))))) + (complex-double-stack + (unless (location= real r) + (cond ((zerop (tn-offset real)) + (inst fstd (ea-for-cdf-real-stack r))) + (t + (inst fxch real) + (inst fstd (ea-for-cdf-real-stack r)) + (inst fxch real)))) + (inst fxch imag) + (inst fstd (ea-for-cdf-imag-stack r)) + (inst fxch imag))))) + +#+long-float +(define-vop (make-complex-long-float) + (:translate complex) + (:args (real :scs (long-reg) :target r + :load-if (not (location= real r))) + (imag :scs (long-reg) :to :save)) + (:arg-types long-float long-float) + (:results (r :scs (complex-long-reg) :from (:argument 0) + :load-if (not (sc-is r complex-long-stack)))) + (:result-types complex-long-float) + (:note "inline complex long-float creation") + (:policy :fast-safe) + (:generator 5 + (sc-case r + (complex-long-reg + (let ((r-real (complex-double-reg-real-tn r))) + (unless (location= real r-real) + (cond ((zerop (tn-offset r-real)) + (copy-fp-reg-to-fr0 real)) + ((zerop (tn-offset real)) + (inst fstd r-real)) + (t + (inst fxch real) + (inst fstd r-real) + (inst fxch real))))) + (let ((r-imag (complex-double-reg-imag-tn r))) + (unless (location= imag r-imag) + (cond ((zerop (tn-offset imag)) + (inst fstd r-imag)) + (t + (inst fxch imag) + (inst fstd r-imag) + (inst fxch imag)))))) + (complex-long-stack + (unless (location= real r) + (cond ((zerop (tn-offset real)) + (store-long-float (ea-for-clf-real-stack r))) + (t + (inst fxch real) + (store-long-float (ea-for-clf-real-stack r)) + (inst fxch real)))) + (inst fxch imag) + (store-long-float (ea-for-clf-imag-stack r)) + (inst fxch imag))))) + + +(define-vop (complex-float-value) + (:args (x :target r)) + (:results (r)) + (:variant-vars offset) + (:policy :fast-safe) + (:generator 3 + (cond ((sc-is x complex-single-reg complex-double-reg + #+long-float complex-long-reg) + (let ((value-tn + (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg *backend*) + :offset (+ offset (tn-offset x))))) + (unless (location= value-tn r) + (cond ((zerop (tn-offset r)) + (copy-fp-reg-to-fr0 value-tn)) + ((zerop (tn-offset value-tn)) + (inst fstd r)) + (t + (inst fxch value-tn) + (inst fstd r) + (inst fxch value-tn)))))) + ((sc-is r single-reg) + (let ((ea (sc-case x + (complex-single-stack + (ecase offset + (0 (ea-for-csf-real-stack x)) + (1 (ea-for-csf-imag-stack x)))) + (descriptor-reg + (ecase offset + (0 (ea-for-csf-real-desc x)) + (1 (ea-for-csf-imag-desc x))))))) + (with-empty-tn@fp-top(r) + (inst fld ea)))) + ((sc-is r double-reg) + (let ((ea (sc-case x + (complex-double-stack + (ecase offset + (0 (ea-for-cdf-real-stack x)) + (1 (ea-for-cdf-imag-stack x)))) + (descriptor-reg + (ecase offset + (0 (ea-for-cdf-real-desc x)) + (1 (ea-for-cdf-imag-desc x))))))) + (with-empty-tn@fp-top(r) + (inst fldd ea)))) + #+long-float + ((sc-is r long-reg) + (let ((ea (sc-case x + (complex-long-stack + (ecase offset + (0 (ea-for-clf-real-stack x)) + (1 (ea-for-clf-imag-stack x)))) + (descriptor-reg + (ecase offset + (0 (ea-for-clf-real-desc x)) + (1 (ea-for-clf-imag-desc x))))))) + (with-empty-tn@fp-top(r) + (inst fldl ea)))) + (t (error "Complex-float-value VOP failure"))))) + +(define-vop (realpart/complex-single-float complex-float-value) + (:translate realpart) + (:args (x :scs (complex-single-reg complex-single-stack descriptor-reg) + :target r)) + (:arg-types complex-single-float) + (:results (r :scs (single-reg))) + (:result-types single-float) + (:note "complex float realpart") + (:variant 0)) + +(define-vop (realpart/complex-double-float complex-float-value) + (:translate realpart) + (:args (x :scs (complex-double-reg complex-double-stack descriptor-reg) + :target r)) + (:arg-types complex-double-float) + (:results (r :scs (double-reg))) + (:result-types double-float) + (:note "complex float realpart") + (:variant 0)) + +#+long-float +(define-vop (realpart/complex-long-float complex-float-value) + (:translate realpart) + (:args (x :scs (complex-long-reg complex-long-stack descriptor-reg) + :target r)) + (:arg-types complex-long-float) + (:results (r :scs (long-reg))) + (:result-types long-float) + (:note "complex float realpart") + (:variant 0)) + +(define-vop (imagpart/complex-single-float complex-float-value) + (:translate imagpart) + (:args (x :scs (complex-single-reg complex-single-stack descriptor-reg) + :target r)) + (:arg-types complex-single-float) + (:results (r :scs (single-reg))) + (:result-types single-float) + (:note "complex float imagpart") + (:variant 1)) + +(define-vop (imagpart/complex-double-float complex-float-value) + (:translate imagpart) + (:args (x :scs (complex-double-reg complex-double-stack descriptor-reg) + :target r)) + (:arg-types complex-double-float) + (:results (r :scs (double-reg))) + (:result-types double-float) + (:note "complex float imagpart") + (:variant 1)) + +#+long-float +(define-vop (imagpart/complex-long-float complex-float-value) + (:translate imagpart) + (:args (x :scs (complex-long-reg complex-long-stack descriptor-reg) + :target r)) + (:arg-types complex-long-float) + (:results (r :scs (long-reg))) + (:result-types long-float) + (:note "complex float imagpart") + (:variant 1)) + + +;;; A hack dummy VOP to bias the representation selection of its +;;; argument towards a FP register which can help avoid consing at +;;; inappropriate locations. + +(defknown double-float-reg-bias (double-float) (values)) +;;; +(define-vop (double-float-reg-bias) + (:translate double-float-reg-bias) + (:args (x :scs (double-reg double-stack) :load-if nil)) + (:arg-types double-float) + (:policy :fast-safe) + (:note "inline dummy FP register bias") + (:ignore x) + (:generator 0)) + +(defknown single-float-reg-bias (single-float) (values)) +;;; +(define-vop (single-float-reg-bias) + (:translate single-float-reg-bias) + (:args (x :scs (single-reg single-stack) :load-if nil)) + (:arg-types single-float) + (:policy :fast-safe) + (:note "inline dummy FP register bias") + (:ignore x) + (:generator 0)) diff --git a/compiler/amd64/insts.lisp b/compiler/amd64/insts.lisp new file mode 100644 index 0000000000000000000000000000000000000000..8d817dc7cc12f5378f6c85ee1d75b45e80808b99 --- /dev/null +++ b/compiler/amd64/insts.lisp @@ -0,0 +1,3068 @@ +;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; 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: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/amd64/insts.lisp,v 1.1 2004/05/24 22:34:59 cwang Exp $") +;;; +;;; ********************************************************************** +;;; +;;; Description of the AMD64 instruction set. +;;; +;;; Written by William Lott +;;; +;;; Debugged by Paul F. Werkowski Spring/Summer 1995. +;;; Debugging and enhancements by Douglas Crosher 1996, 1997, 1998. +;;; + +(in-package :amd64) + +(use-package :new-assem) + +(def-assembler-params + :scheduler-p nil) + +(disassem:set-disassem-params :instruction-alignment 8 + :opcode-column-width 8) + + + +;;;; Primitive emitters. + +(define-emitter emit-word 16 + (byte 16 0)) + +(define-emitter emit-dword 32 + (byte 32 0)) + +(define-emitter emit-qword 64 + (byte 64 0)) + +(define-emitter emit-byte-with-reg 8 + (byte 5 3) (byte 3 0)) + +(define-emitter emit-mod-reg-r/m-byte 8 + (byte 2 6) (byte 3 3) (byte 3 0)) + +(define-emitter emit-sib-byte 8 + (byte 2 6) (byte 3 3) (byte 3 0)) + + + +;;;; Fixup emitters. + +(defun emit-absolute-fixup (segment fixup &optional 64-bit-p) + ;; absolute fixup should always be 64 bit. + (note-fixup segment :absolute fixup) + (let ((offset (fixup-offset fixup))) + (if 64-bit-p + (if (label-p offset) + (emit-back-patch segment 8 + #'(lambda (segment posn) + (declare (ignore posn)) + (emit-qword segment + (- (+ (component-header-length) + (or (label-position offset) 0)) + other-pointer-type)))) + (emit-qword segment (or offset 0))) + ;; should get rid of this case + (if (label-p offset) + (emit-back-patch segment 4 + #'(lambda (segment posn) + (declare (ignore posn)) + (emit-dword segment + (- (+ (component-header-length) + (or (label-position offset) 0)) + other-pointer-type)))) + (emit-dword segment (or offset 0)))))) + +(defun emit-relative-fixup (segment fixup) + (note-fixup segment :relative fixup) + (emit-dword segment (or (fixup-offset fixup) 0))) + + + +;;;; The effective-address (ea) structure. + +(defun reg-tn-encoding (tn) + (declare (type tn tn)) + (assert (eq (sb-name (sc-sb (tn-sc tn))) 'registers)) + (let ((offset (tn-offset tn))) + (logior (ash (logand offset 1) 2) + (ash offset -1)))) + +(defstruct (ea + (:constructor make-ea (size &key base index scale disp)) + (:print-function %print-ea)) + (size nil :type (member :byte :word :dword :qword)) + (base nil :type (or tn null)) + (index nil :type (or tn null)) + (scale 1 :type (member 1 2 4 8)) + (disp 0 :type (or (signed-byte 32) fixup))) + +(defun valid-displacement-p (x) + (typep x '(or (signed-byte 32) fixup))) + +(defun %print-ea (ea stream depth) + (declare (ignore depth)) + (cond ((or *print-escape* *print-readably*) + (print-unreadable-object (ea stream :type t) + (format stream + "~S~@[ base=~S~]~@[ index=~S~]~@[ scale=~S~]~@[ disp=~S~]" + (ea-size ea) + (ea-base ea) + (ea-index ea) + (let ((scale (ea-scale ea))) + (if (= scale 1) nil scale)) + (ea-disp ea)))) + (t + (format stream "~A PTR [" (symbol-name (ea-size ea))) + (when (ea-base ea) + (write-string (amd64-location-print-name (ea-base ea)) stream) + (when (ea-index ea) + (write-string "+" stream))) + (when (ea-index ea) + (write-string (amd64-location-print-name (ea-index ea)) stream)) + (unless (= (ea-scale ea) 1) + (format stream "*~A" (ea-scale ea))) + (typecase (ea-disp ea) + (null) + (integer + (format stream "~@D" (ea-disp ea))) + (t + (format stream "+~A" (ea-disp ea)))) + (write-char #\] stream)))) + +(defun absolute-ea-p (ea) + (and (ea-p ea) + (eq (ea-size ea) :qword) + (null (ea-base ea)) + (null (ea-index ea)) + (= (ea-scale ea) 1))) + +(defun emit-absolute-ea (segment ea) + (assert (absolute-ea-p ea)) + (emit-qword segment (ea-disp ea))) + +(defun emit-ea (segment thing reg &optional allow-constants) + (etypecase thing + (tn + (ecase (sb-name (sc-sb (tn-sc thing))) + (registers + (emit-mod-reg-r/m-byte segment #b11 reg (reg-tn-encoding thing))) + (stack + ;; Convert stack tns into an index off of RBP. + (let ((disp (- (* (1+ (tn-offset thing)) word-bytes)))) + (cond ((< -128 disp 127) + (emit-mod-reg-r/m-byte segment #b01 reg #b101) + (emit-byte segment disp)) + (t + (emit-mod-reg-r/m-byte segment #b10 reg #b101) + (emit-dword segment disp))))) + (constant + (unless allow-constants + (error + "Constant TNs can only be directly used in MOV, PUSH, and CMP.")) + (emit-mod-reg-r/m-byte segment #b00 reg #b100) + ;; This is bad. We'd get rid of 32 bit addresses + (emit-sib-byte segment #b00 #b100 #b101) ; set to zero-based disp 32 + (emit-absolute-fixup segment + (make-fixup nil + :code-object + (- (* (tn-offset thing) word-bytes) + other-pointer-type)))))) + (ea + (let* ((base (ea-base thing)) + (index (ea-index thing)) + (scale (ea-scale thing)) + (disp (ea-disp thing)) + (mod (cond ((or (null base) + (and (eql disp 0) + (not (= (reg-tn-encoding base) #b101)))) + #b00) + ((and (fixnump disp) (<= -128 disp 127)) + #b01) + (t + #b10))) + (r/m (cond (index #b100) + ((null base) #b101) + (t (reg-tn-encoding base))))) + (emit-mod-reg-r/m-byte segment mod reg r/m) + (when (= r/m #b100) + (let ((ss (1- (integer-length scale))) + (index (if (null index) + #b100 + (let ((index (reg-tn-encoding index))) + (if (= index #b100) + (error "Can't index off of ESP") + index)))) + (base (if (null base) + #b101 + (reg-tn-encoding base)))) + (emit-sib-byte segment ss index base))) + (cond ((= mod #b01) + (emit-byte segment disp)) + ((or (= mod #b10) (null base)) + (if (fixup-p disp) + (emit-absolute-fixup segment disp) + (emit-dword segment disp)))))) + (fixup + (emit-mod-reg-r/m-byte segment #b00 reg #b100) + ;; This is bad. We'd get rid of 32 bit addresses + (emit-sib-byte segment #b00 #b100 #b101) ; set to zero-based disp 32 + (emit-absolute-fixup segment thing)))) + +(defun fp-reg-tn-p (thing) + (and (tn-p thing) + (eq (sb-name (sc-sb (tn-sc thing))) 'float-registers))) + +;;; +;;; like the above, but for fp-instructions--jrd +;;; +(defun emit-fp-op (segment thing op) + (if (fp-reg-tn-p thing) + (emit-byte segment (dpb op (byte 3 3) (dpb (tn-offset thing) + (byte 3 0) + #b11000000))) + (emit-ea segment thing op))) + +(defun byte-reg-p (thing) + (and (tn-p thing) + (eq (sb-name (sc-sb (tn-sc thing))) 'registers) + (member (sc-name (tn-sc thing)) byte-sc-names) + t)) + +(defun byte-ea-p (thing) + (typecase thing + (ea (eq (ea-size thing) :byte)) + (tn + (and (member (sc-name (tn-sc thing)) byte-sc-names) t)) + (t nil))) + +(defun word-reg-p (thing) + (and (tn-p thing) + (eq (sb-name (sc-sb (tn-sc thing))) 'registers) + (member (sc-name (tn-sc thing)) word-sc-names) + t)) + +(defun word-ea-p (thing) + (typecase thing + (ea (eq (ea-size thing) :word)) + (tn (and (member (sc-name (tn-sc thing)) word-sc-names) t)) + (t nil))) + +(defun dword-reg-p (thing) + (and (tn-p thing) + (eq (sb-name (sc-sb (tn-sc thing))) 'registers) + (member (sc-name (tn-sc thing)) dword-sc-names) + t)) + +(defun dword-ea-p (thing) + (typecase thing + (ea (eq (ea-size thing) :dword)) + (tn + (and (member (sc-name (tn-sc thing)) dword-sc-names) t)) + (t nil))) + +(defun qword-reg-p (thing) + (and (tn-p thing) + (eq (sb-name (sc-sb (tn-sc thing))) 'registers) + (member (sc-name (tn-sc thing)) qword-sc-names) + t)) + +(defun register-p (thing) + (and (tn-p thing) + (eq (sb-name (sc-sb (tn-sc thing))) 'registers))) + +(defun accumulator-p (thing) + (and (register-p thing) + (= (tn-offset thing) 0))) + +(eval-when (compile load eval) +(defconstant conditions + '((:o . 0) + (:no . 1) + (:b . 2) (:nae . 2) (:c . 2) + (:nb . 3) (:ae . 3) (:nc . 3) + (:eq . 4) (:e . 4) (:z . 4) + (:ne . 5) (:nz . 5) + (:be . 6) (:na . 6) + (:nbe . 7) (:a . 7) + (:s . 8) + (:ns . 9) + (:p . 10) (:pe . 10) + (:np . 11) (:po . 11) + (:l . 12) (:nge . 12) + (:nl . 13) (:ge . 13) + (:le . 14) (:ng . 14) + (:nle . 15) (:g . 15))) + +(defun conditional-opcode (condition) + (cdr (assoc condition conditions :test #'eq)))) + + + +;;;; Utilities. + +#-lispworks3 +(defconstant operand-size-prefix-byte #b01100110) + +#+lispworks3 +(eval-when (compile load eval) + (defconstant operand-size-prefix-byte #b01100110)) + +(defparameter *default-operand-size* :dword) + +(defun maybe-emit-operand-size-prefix (segment size + &optional (default-operand-size *default-operand-size*)) + (unless (or (eq size :byte) (eq size default-operand-size)) + (case size + (:word (emit-byte segment operand-size-prefix-byte)) + (:qword (emit-byte segment #b01001000))))) ; REX prefix #x48 + +(defun operand-size (thing) + (typecase thing + (tn + (case (sc-name (tn-sc thing)) + (#.qword-sc-names + :qword) + (#.dword-sc-names + :dword) + (#.word-sc-names + :word) + (#.byte-sc-names + :byte) + ;; added by jrd. float-registers is a separate size (?) + (#.float-sc-names + :float) + (#.double-sc-names + :double) + (t + (error "Can't tell the size of ~S ~S" thing (sc-name (tn-sc thing)))))) + (ea + (ea-size thing)) + (t + nil))) + +(defun matching-operand-size (dst src) + (let ((dst-size (operand-size dst)) + (src-size (operand-size src))) + (if dst-size + (if src-size + (if (eq dst-size src-size) + dst-size + (error "Size mismatch: ~S is a ~S and ~S is a ~S" + dst dst-size src src-size)) + dst-size) + (if src-size + src-size + (error "Can't tell the size of either ~S or ~S." + dst src))))) + +(defun emit-sized-immediate (segment size value &optional allow-qword) + (ecase size + (:byte + (emit-byte segment value)) + (:word + (emit-word segment value)) + (:dword + (emit-dword segment value)) + (:qword + (if allow-qword + (emit-qword segment value) + ;; most instructions only allow 32 bit immediates + ;; I should turn on an error or warning here + ;; (assert (<= (integer-length value) 32)) + (emit-dword segment value))))) + + + +;;;; Disassembler support stuff. + +(deftype reg () '(unsigned-byte 3)) +#+cross-compiler +(lisp:deftype reg () '(unsigned-byte 3)) + +(eval-when (compile eval load) + +(defparameter *default-address-size* + ;; Actually, :dword is the only one really supported. + :qword) + +(defparameter byte-reg-names + #(al cl dl bl ah ch dh bh)) +(defparameter word-reg-names + #(ax cx dx bx sp bp si di)) +(defparameter dword-reg-names + #(eax ecx edx ebx esp ebp esi edi)) +(defparameter qword-reg-names + #(rax rcx rdx rbx rsp rbp rsi rdi)) + +(defun print-reg-with-width (value width stream dstate) + (declare (ignore dstate)) + (princ (aref (ecase width + (:byte byte-reg-names) + (:word word-reg-names) + (:dword dword-reg-names) + (:qword qword-reg-names)) + value) + stream) + ;; plus should do some source-var notes + ) + +(defun print-reg (value stream dstate) + (declare (type reg value) + (type stream stream) + (type disassem:disassem-state dstate)) + (print-reg-with-width value + (disassem:dstate-get-prop dstate 'width) + stream + dstate)) + +(defun print-word-reg (value stream dstate) + (declare (type reg value) + (type stream stream) + (type disassem:disassem-state dstate)) + (print-reg-with-width value + (or (disassem:dstate-get-prop dstate 'word-width) + *default-operand-size*) + stream + dstate)) + +(defun print-byte-reg (value stream dstate) + (declare (type reg value) + (type stream stream) + (type disassem:disassem-state dstate)) + (print-reg-with-width value :byte stream dstate)) + +(defun print-addr-reg (value stream dstate) + (declare (type reg value) + (type stream stream) + (type disassem:disassem-state dstate)) + (print-reg-with-width value *default-address-size* stream dstate)) + +;;; Value is a list of (BASE-REG OFFSET INDEX-REG INDEX-SCALE) +(defun print-mem-access (value stream print-size-p dstate) + (declare (type list value) + (type stream stream) + (type (member t nil) print-size-p) + (type disassem:disassem-state dstate)) + (when print-size-p + (princ (disassem:dstate-get-prop dstate 'width) stream) + (princ '| PTR | stream)) + (write-char #\[ stream) + (let ((firstp t)) + (macrolet ((pel ((var val) &body body) + ;; Print an element of the address, maybe with + ;; a leading separator. + `(let ((,var ,val)) + (when ,var + (unless firstp + (write-char #\+ stream)) + ,@body + (setq firstp nil))))) + (pel (base-reg (first value)) + (print-addr-reg base-reg stream dstate)) + (pel (index-reg (third value)) + (print-addr-reg index-reg stream dstate) + (let ((index-scale (fourth value))) + (when (and index-scale (not (= index-scale 1))) + (write-char #\* stream) + (princ index-scale stream)))) + (let ((offset (second value))) + (when (and offset (or firstp (not (zerop offset)))) + (unless (or firstp (minusp offset)) + (write-char #\+ stream)) + (if firstp + (let ((unsigned-offset (if (minusp offset) + (+ #x100000000 offset) + offset))) + (disassem:princ16 unsigned-offset stream) + (or (nth-value 1 + (disassem::note-code-constant-absolute unsigned-offset + dstate)) + (disassem:maybe-note-assembler-routine unsigned-offset + stream + dstate) + (let ((offs (- offset disassem::nil-addr))) + (when (typep offs 'disassem::offset) + (or (disassem::maybe-note-nil-indexed-symbol-slot-ref offs + dstate) + (disassem::maybe-note-static-function offs dstate)))))) + (princ offset stream)))))) + (write-char #\] stream)) + +(defun print-imm-data (value stream dstate) + (let ((offset (- value disassem::nil-addr))) + (if (zerop offset) + (format stream "#x~X" value) + (format stream "~A" value)) + (when (typep offset 'disassem::offset) + (or (disassem::maybe-note-nil-indexed-object offset dstate) + (let ((unsigned-offset (if (and (numberp value) (minusp value)) + (+ value #x100000000) + value))) + (disassem::maybe-note-assembler-routine unsigned-offset stream dstate)) + (nth-value 1 + (disassem::note-code-constant-absolute offset + dstate)))))) + +(defun print-reg/mem (value stream dstate) + (declare (type (or list reg) value) + (type stream stream) + (type disassem:disassem-state dstate)) + (if (typep value 'reg) + (print-reg value stream dstate) + (print-mem-access value stream nil dstate))) + +;; Same as print-reg/mem, but prints an explicit size indicator for +;; memory references. +(defun print-sized-reg/mem (value stream dstate) + (declare (type (or list reg) value) + (type stream stream) + (type disassem:disassem-state dstate)) + (if (typep value 'reg) + (print-reg value stream dstate) + (print-mem-access value stream t dstate))) + +(defun print-byte-reg/mem (value stream dstate) + (declare (type (or list reg) value) + (type stream stream) + (type disassem:disassem-state dstate)) + (if (typep value 'reg) + (print-byte-reg value stream dstate) + (print-mem-access value stream t dstate))) + +(defun print-label (value stream dstate) + (declare (ignore dstate)) + (disassem:princ16 value stream)) + +;;; Returns either an integer, meaning a register, or a list of +;;; (BASE-REG OFFSET INDEX-REG INDEX-SCALE), where any component +;;; may be missing or nil to indicate that it's not used or has the +;;; obvious default value (e.g., 1 for the index-scale). +(defun prefilter-reg/mem (value dstate) + (declare (type list value) + (type disassem:disassem-state dstate)) + (let ((mod (car value)) + (r/m (cadr value))) + (declare (type (unsigned-byte 2) mod) + (type (unsigned-byte 3) r/m)) + (cond ((= mod #b11) + ;; registers + r/m) + ((= r/m #b100) + ;; sib byte + (let ((sib (disassem:read-suffix 8 dstate))) + (declare (type (unsigned-byte 8) sib)) + (let ((base-reg (ldb (byte 3 0) sib)) + (index-reg (ldb (byte 3 3) sib)) + (index-scale (ldb (byte 2 6) sib))) + (declare (type (unsigned-byte 3) base-reg index-reg) + (type (unsigned-byte 2) index-scale)) + (let* ((offset + (case mod + (#b00 + (if (= base-reg #b101) + (disassem:read-signed-suffix 32 dstate) + nil)) + (#b01 + (disassem:read-signed-suffix 8 dstate)) + (#b10 + (disassem:read-signed-suffix 32 dstate))))) + (list (if (and (= mod #b00) (= base-reg #b101)) nil base-reg) + offset + (if (= index-reg #b100) nil index-reg) + (ash 1 index-scale)))))) + ((and (= mod #b00) (= r/m #b101)) + (list nil (disassem:read-signed-suffix 32 dstate)) ) + ((= mod #b00) + (list r/m)) + ((= mod #b01) + (list r/m (disassem:read-signed-suffix 8 dstate))) + (t ; (= mod #b10) + (list r/m (disassem:read-signed-suffix 32 dstate)))))) + + +;;; This is a sort of bogus prefilter that just +;;; stores the info globally for other people to use; it +;;; probably never gets printed. +(defun prefilter-width (value dstate) + (setf (disassem:dstate-get-prop dstate 'width) + (if (zerop value) + :byte + (let ((word-width + ;; set by a prefix instruction + (or (disassem:dstate-get-prop dstate 'word-width) + *default-operand-size*))) + (when (not (eql word-width *default-operand-size*)) + ;; reset it + (setf (disassem:dstate-get-prop dstate 'word-width) + *default-operand-size*)) + word-width)))) + +(defun offset-next (value dstate) + (declare (type integer value) + (type disassem:disassem-state dstate)) + (+ (disassem:dstate-next-addr dstate) value)) + +(defun read-address (value dstate) + (declare (ignore value)) ; always nil anyway + (disassem:read-suffix (width-bits *default-address-size*) dstate)) + +(defun width-bits (width) + (ecase width + (:byte 8) + (:word 16) + (:dword 32) + (:qword 64) + (:float 32) + (:double 64))) + +); eval-when + + +;;;; Disassembler argument types. + +(disassem:define-argument-type accum + :printer #'(lambda (value stream dstate) + (declare (ignore value) + (type stream stream) + (type disassem:disassem-state dstate)) + (print-reg 0 stream dstate)) + ) + +(disassem:define-argument-type word-accum + :printer #'(lambda (value stream dstate) + (declare (ignore value) + (type stream stream) + (type disassem:disassem-state dstate)) + (print-word-reg 0 stream dstate)) + ) + +(disassem:define-argument-type reg + :printer #'print-reg) + +(disassem:define-argument-type addr-reg + :printer #'print-addr-reg) + +(disassem:define-argument-type word-reg + :printer #'print-word-reg) + +(disassem:define-argument-type imm-addr + :prefilter #'read-address + :printer #'print-label) + +(disassem:define-argument-type imm-data + :prefilter #'(lambda (value dstate) + (declare (ignore value)) ; always nil anyway + (disassem:read-suffix + (width-bits (disassem:dstate-get-prop dstate 'width)) + dstate)) + :printer #'print-imm-data + ) + +(disassem:define-argument-type signed-imm-data + :prefilter #'(lambda (value dstate) + (declare (ignore value)) ; always nil anyway + (let ((width (disassem:dstate-get-prop dstate 'width))) + (disassem:read-signed-suffix (width-bits width) dstate))) + ) + +(disassem:define-argument-type signed-imm-byte + :prefilter #'(lambda (value dstate) + (declare (ignore value)) ; always nil anyway + (disassem:read-signed-suffix 8 dstate))) + +(disassem:define-argument-type signed-imm-dword + :prefilter #'(lambda (value dstate) + (declare (ignore value)) ; always nil anyway + (disassem:read-signed-suffix 32 dstate))) + +(disassem:define-argument-type imm-word + :prefilter #'(lambda (value dstate) + (declare (ignore value)) ; always nil anyway + (let ((width + (or (disassem:dstate-get-prop dstate 'word-width) + *default-operand-size*))) + (disassem:read-suffix (width-bits width) dstate)))) + +;;; Needed for the ret imm16 instruction +(disassem:define-argument-type imm-word-16 + :prefilter #'(lambda (value dstate) + (declare (ignore value)) ; always nil anyway + (disassem:read-suffix 16 dstate))) + +(disassem:define-argument-type reg/mem + :prefilter #'prefilter-reg/mem + :printer #'print-reg/mem) +(disassem:define-argument-type sized-reg/mem + ;; Same as reg/mem, but prints an explicit size indicator for + ;; memory references. + :prefilter #'prefilter-reg/mem + :printer #'print-sized-reg/mem) +(disassem:define-argument-type byte-reg/mem + :prefilter #'prefilter-reg/mem + :printer #'print-byte-reg/mem) + +;;; +;;; added by jrd +;;; +(eval-when (compile load eval) +(defun print-fp-reg (value stream dstate) + (declare (ignore dstate)) + (format stream "~A(~D)" 'st value)) + +(defun prefilter-fp-reg (value dstate) + ;; just return it + (declare (ignore dstate)) + value) +) +(disassem:define-argument-type fp-reg + :prefilter #'prefilter-fp-reg + :printer #'print-fp-reg) + +(disassem:define-argument-type width + :prefilter #'prefilter-width + :printer #'(lambda (value stream dstate) + (if ;; (zerop value) + (or (null value) (and (numberp value) (zerop value))) ; zzz jrd + (princ 'b stream) + (let ((word-width + ;; set by a prefix instruction + (or (disassem:dstate-get-prop dstate 'word-width) + *default-operand-size*))) + (princ (schar (symbol-name word-width) 0) stream))))) + + +;;;; Disassembler instruction formats. + +(eval-when (compile eval) + (defun swap-if (direction field1 separator field2) + `(:if (,direction :constant 0) + (,field1 ,separator ,field2) + (,field2 ,separator ,field1)))) + +(disassem:define-instruction-format (byte 8 :default-printer '(:name)) + (op :field (byte 8 0)) + ;; optional fields + (accum :type 'accum) + (imm)) + +(disassem:define-instruction-format (simple 8) + (op :field (byte 7 1)) + (width :field (byte 1 0) :type 'width) + ;; optional fields + (accum :type 'accum) + (imm)) + +;;; Same as simple, but with direction bit +(disassem:define-instruction-format (simple-dir 8 :include 'simple) + (op :field (byte 6 2)) + (dir :field (byte 1 1))) + +;;; Same as simple, but with the immediate value occuring by default, +;;; and with an appropiate printer. +(disassem:define-instruction-format (accum-imm 8 + :include 'simple + :default-printer '(:name + :tab accum ", " imm)) + (imm :type 'imm-data)) + +(disassem:define-instruction-format (reg-no-width 8 + :default-printer '(:name :tab reg)) + (op :field (byte 5 3)) + (reg :field (byte 3 0) :type 'word-reg) + ;; optional fields + (accum :type 'word-accum) + (imm)) + +;;; adds a width field to reg-no-width +(disassem:define-instruction-format (reg 8 :default-printer '(:name :tab reg)) + (op :field (byte 4 4)) + (width :field (byte 1 3) :type 'width) + (reg :field (byte 3 0) :type 'reg) + ;; optional fields + (accum :type 'accum) + (imm) + ) + +;;; Same as reg, but with direction bit +(disassem:define-instruction-format (reg-dir 8 :include 'reg) + (op :field (byte 3 5)) + (dir :field (byte 1 4))) + +(disassem:define-instruction-format (two-bytes 16 + :default-printer '(:name)) + (op :fields (list (byte 8 0) (byte 8 8)))) + +(disassem:define-instruction-format (reg-reg/mem 16 + :default-printer + `(:name :tab reg ", " reg/mem)) + (op :field (byte 7 1)) + (width :field (byte 1 0) :type 'width) + (reg/mem :fields (list (byte 2 14) (byte 3 8)) + :type 'reg/mem) + (reg :field (byte 3 11) :type 'reg) + ;; optional fields + (imm)) + +;;; same as reg-reg/mem, but with direction bit +(disassem:define-instruction-format (reg-reg/mem-dir 16 + :include 'reg-reg/mem + :default-printer + `(:name + :tab + ,(swap-if 'dir 'reg/mem ", " 'reg))) + (op :field (byte 6 2)) + (dir :field (byte 1 1))) + +;;; Same as reg-rem/mem, but uses the reg field as a second op code. +(disassem:define-instruction-format (reg/mem 16 + :default-printer '(:name :tab reg/mem)) + (op :fields (list (byte 7 1) (byte 3 11))) + (width :field (byte 1 0) :type 'width) + (reg/mem :fields (list (byte 2 14) (byte 3 8)) + :type 'sized-reg/mem) + ;; optional fields + (imm)) + +;;; Same as reg/mem, but with the immediate value occuring by default, +;;; and with an appropiate printer. +(disassem:define-instruction-format (reg/mem-imm 16 + :include 'reg/mem + :default-printer + '(:name :tab reg/mem ", " imm)) + (reg/mem :type 'sized-reg/mem) + (imm :type 'imm-data)) + +;;; Same as reg/mem, but with using the accumulator in the default printer +(disassem:define-instruction-format + (accum-reg/mem 16 + :include 'reg/mem :default-printer '(:name :tab accum ", " reg/mem)) + (reg/mem :type 'reg/mem) ; don't need a size + (accum :type 'accum)) + +;;; Same as reg-reg/mem, but with a prefix of #b00001111 +(disassem:define-instruction-format (ext-reg-reg/mem 24 + :default-printer + `(:name :tab reg ", " reg/mem)) + (prefix :field (byte 8 0) :value #b00001111) + (op :field (byte 7 9)) + (width :field (byte 1 8) :type 'width) + (reg/mem :fields (list (byte 2 22) (byte 3 16)) + :type 'reg/mem) + (reg :field (byte 3 19) :type 'reg) + ;; optional fields + (imm)) + +;;; Same as reg/mem, but with a prefix of #b00001111 +(disassem:define-instruction-format (ext-reg/mem 24 + :default-printer '(:name :tab reg/mem)) + (prefix :field (byte 8 0) :value #b00001111) + (op :fields (list (byte 7 9) (byte 3 19))) + (width :field (byte 1 8) :type 'width) + (reg/mem :fields (list (byte 2 22) (byte 3 16)) + :type 'sized-reg/mem) + ;; optional fields + (imm)) + +;;; ---------------------------------------------------------------- +;;; this section added by jrd, for fp instructions. + +;;; +;;; regular fp inst to/from registers/memory +;;; +(disassem:define-instruction-format (floating-point 16 + :default-printer `(:name :tab reg/mem)) + (prefix :field (byte 5 3) :value #b11011) + (op :fields (list (byte 3 0) (byte 3 11))) + (reg/mem :fields (list (byte 2 14) (byte 3 8)) :type 'reg/mem)) + +;;; +;;; fp insn to/from fp reg +;;; +(disassem:define-instruction-format (floating-point-fp 16 + :default-printer `(:name :tab fp-reg)) + (prefix :field (byte 5 3) :value #b11011) + (suffix :field (byte 2 14) :value #b11) + (op :fields (list (byte 3 0) (byte 3 11))) + (fp-reg :field (byte 3 8) :type 'fp-reg)) + +;;; +;;; fp insn to/from fp reg, with the reversed source/destination flag. +;;; +(disassem:define-instruction-format + (floating-point-fp-d 16 + :default-printer `(:name :tab ,(swap-if 'd "ST0" ", " 'fp-reg))) + (prefix :field (byte 5 3) :value #b11011) + (suffix :field (byte 2 14) :value #b11) + (op :fields (list (byte 2 0) (byte 3 11))) + (d :field (byte 1 2)) + (fp-reg :field (byte 3 8) :type 'fp-reg)) + + +;;; pfw +;;; fp no operand isns +;;; +(disassem:define-instruction-format (floating-point-no 16 + :default-printer '(:name)) + (prefix :field (byte 8 0) :value #b11011001) + (suffix :field (byte 3 13) :value #b111) + (op :field (byte 5 8))) + +(disassem:define-instruction-format (floating-point-3 16 + :default-printer '(:name)) + (prefix :field (byte 5 3) :value #b11011) + (suffix :field (byte 2 14) :value #b11) + (op :fields (list (byte 3 0) (byte 6 8)))) + +(disassem:define-instruction-format (floating-point-5 16 + :default-printer '(:name)) + (prefix :field (byte 8 0) :value #b11011011) + (suffix :field (byte 3 13) :value #b111) + (op :field (byte 5 8))) + +(disassem:define-instruction-format (floating-point-st 16 + :default-printer '(:name)) + (prefix :field (byte 8 0) :value #b11011111) + (suffix :field (byte 3 13) :value #b111) + (op :field (byte 5 8))) + + +;;; ---------------------------------------------------------------- + + +;;;; General Data Transfer + +(eval-when (eval compile load) + (defun toggle-word-width (chunk inst stream dstate) + (declare (ignore chunk inst stream)) + (let ((ww (or (disassem:dstate-get-prop dstate 'word-width) + *default-operand-size*))) + (setf (disassem:dstate-get-prop dstate 'word-width) + (ecase ww + (:word :dword) + (:dword :word) + (:qword :dword)))))) ; not sure what this is for + +;;; This isn't a really an instruction, but it's easier to deal with it this +;;; way. We assume that it's actually used. +(define-instruction toggle-data-size (segment) + (:printer byte ((op operand-size-prefix-byte)) + nil ; don't actually print it + :control #'toggle-word-width)) + + +(define-instruction mov (segment dst src) + ;; immediate to register + (:printer reg ((op #b1011) (imm nil :type 'imm-data)) + '(:name :tab reg ", " imm)) + ;; absolute mem to/from accumulator + (:printer simple-dir ((op #b101000) (imm nil :type 'imm-addr)) + `(:name :tab ,(swap-if 'dir 'accum ", " '("[" imm "]")))) + ;; register to/from register/memory + (:printer reg-reg/mem-dir ((op #b100010))) + ;; immediate to register/memory + (:printer reg/mem-imm ((op '(#b1100011 #b000)))) + + (:emitter + (let ((size (matching-operand-size dst src))) + (maybe-emit-operand-size-prefix segment size) + (cond ((register-p dst) + (cond ((integerp src) + (emit-byte-with-reg segment + (if (eq size :byte) + #b10110 ; B0 + #b10111) ; B8 + (reg-tn-encoding dst)) + (emit-sized-immediate segment size src t)) ; allow qword + ((and (accumulator-p dst) + (or (fixup-p src) + (and (tn-p src) (eq (sb-name (sc-sb (tn-sc src))) 'constant)) + (absolute-ea-p src))) + (assert (eq size :qword)) + (emit-byte segment #b10100001) ; #xA1 + (etypecase src + (fixup (emit-absolute-fixup segment src t)) ; 64 bit offset + (tn (emit-absolute-fixup segment + (make-fixup nil + :code-object + (- (* (tn-offset src) word-bytes) + other-pointer-type)) + t)) ; 64 bit offset + (ea (emit-absolute-ea segment src)))) + (t + (emit-byte segment + (if (eq size :byte) + #b10001010 + #b10001011)) ; #x8b + (emit-ea segment src (reg-tn-encoding dst) t)))) + ((and (accumulator-p src) + (or (fixup-p dst) + (absolute-ea-p dst))) + (assert (eq size :qword)) + (emit-byte segment #b10100011) ; #xA3 + (etypecase dst + (fixup (emit-absolute-fixup segment dst t)) + (ea (emit-absolute-ea segment dst)))) + ((integerp src) + (emit-byte segment (if (eq size :byte) #b11000110 #b11000111)) + (emit-ea segment dst #b000) + (emit-sized-immediate segment size src)) + ((register-p src) + (emit-byte segment (if (eq size :byte) #b10001000 #b10001001)) + (emit-ea segment dst (reg-tn-encoding src))) + ((fixup-p src) + (assert (eq size :qword)) + (emit-byte segment #b11000111) ; C7 + (emit-ea segment dst #b000) + (emit-absolute-fixup segment src)) + (t + (error "Bogus arguments to MOV: ~S ~S" dst src)))))) + +;; Use this if we don't want indirect for fixup +(define-instruction mov-imm (segment dst src) + (:emitter + (assert (qword-reg-p dst)) + (assert (fixup-p src)) + (emit-byte segment #b01001000) ; prefix instruction #x48 + (emit-byte-with-reg segment + #b10111 ; B8 MOV + (reg-tn-encoding dst)) + (emit-absolute-fixup segment src t))) ; imm64 + +(defun emit-move-with-extension (segment dst src opcode) + (assert (register-p dst)) + (let ((dst-size (operand-size dst)) + (src-size (operand-size src))) + (ecase dst-size + (:word + (assert (eq src-size :byte)) + (maybe-emit-operand-size-prefix segment :word) + (emit-byte segment #b00001111) + (emit-byte segment opcode) + (emit-ea segment src (reg-tn-encoding dst))) + (:dword + (ecase src-size + (:byte + (maybe-emit-operand-size-prefix segment :dword) + (emit-byte segment #b00001111) + (emit-byte segment opcode) + (emit-ea segment src (reg-tn-encoding dst))) + (:word + (emit-byte segment #b00001111) + (emit-byte segment (logior opcode 1)) + (emit-ea segment src (reg-tn-encoding dst))))) + (:qword ; this needs to be looked at + (ecase src-size + (:byte + (maybe-emit-operand-size-prefix segment :qword) + (emit-byte segment #b00001111) + (emit-byte segment opcode) + (emit-ea segment src (reg-tn-encoding dst))) + (:word + (emit-byte segment #b00001111) + (emit-byte segment (logior opcode 1)) + (emit-ea segment src (reg-tn-encoding dst))) + (:dword + ;; I think we don't need a REX prefix here + (emit-byte segment opcode) + (emit-ea segment src (reg-tn-encoding dst)))))))) + + +(define-instruction movsx (segment dst src) + (:printer ext-reg-reg/mem ((op #b1011111) (reg nil :type 'word-reg))) + (:emitter + (emit-move-with-extension segment dst src #b10111110))) + +(define-instruction movsxd (segment dst src) + ;; source size is dword + ;; dest size is qword + (:printer ext-reg-reg/mem ((op #b01100011) (reg nil :type 'word-reg))) + (:emitter + (emit-move-with-extension segment dst src #b01100011))) ; 63 + +(define-instruction movzx (segment dst src) + (:printer ext-reg-reg/mem ((op #b1011011) (reg nil :type 'word-reg))) + (:emitter + (emit-move-with-extension segment dst src #b10110110))) + +(define-instruction push (segment src) + ;; Register. + (:printer reg-no-width ((op #b01010))) + ;; Register/Memory. + (:printer reg/mem ((op '(#b1111111 #b110)) (width 1))) + ;; Immediate. + (:printer byte ((op #b01101010) (imm nil :type 'signed-imm-byte)) + '(:name :tab imm)) + (:printer byte ((op #b01101000) (imm nil :type 'imm-word)) + '(:name :tab imm)) + ;; ### Segment registers? + + (:emitter + (cond ((integerp src) + (cond ((<= -128 src 127) + (emit-byte segment #b01101010) + (emit-byte segment src)) + (t + (emit-byte segment #b01101000) + (emit-dword segment src)))) + ((fixup-p src) + ;; Interpret the fixup as an immediate dword to push + ;; This is a problem because push can't take 64-bit immediate + (emit-byte segment #b01101000) + (emit-absolute-fixup segment src)) + (t + (let ((size (operand-size src))) + (assert (not (eq size :byte))) + (maybe-emit-operand-size-prefix segment size :qword) + (cond ((register-p src) + (emit-byte-with-reg segment #b01010 (reg-tn-encoding src))) + (t + (emit-byte segment #b11111111) + (emit-ea segment src #b110 t)))))))) + +(define-instruction pusha (segment) + (:printer byte ((op #b01100000))) + (:emitter + (emit-byte segment #b01100000))) + +(define-instruction pop (segment dst) + (:printer reg-no-width ((op #b01011))) + (:printer reg/mem ((op '(#b1000111 #b000)) (width 1))) + (:emitter + (let ((size (operand-size dst))) + (assert (not (eq size :byte))) + (maybe-emit-operand-size-prefix segment size :qword) ; doesn't need rex prefix + (cond ((register-p dst) + (emit-byte-with-reg segment #b01011 (reg-tn-encoding dst))) + (t + (emit-byte segment #b10001111) + (emit-ea segment dst #b000)))))) + +(define-instruction popa (segment) + (:printer byte ((op #b01100001))) + (:emitter + (emit-byte segment #b01100001))) + +(define-instruction xchg (segment operand1 operand2) + ;; Register with accumulator. + (:printer reg-no-width ((op #b10010)) '(:name :tab accum ", " reg)) + ;; Register/Memory with Register. + (:printer reg-reg/mem ((op #b1000011))) + (:emitter + (let ((size (matching-operand-size operand1 operand2))) + (maybe-emit-operand-size-prefix segment size) + (labels ((xchg-acc-with-something (acc something) + (if (and (not (eq size :byte)) (register-p something)) + (emit-byte-with-reg segment + #b10010 + (reg-tn-encoding something)) + (xchg-reg-with-something acc something))) + (xchg-reg-with-something (reg something) + (emit-byte segment (if (eq size :byte) #b10000110 #b10000111)) + (emit-ea segment something (reg-tn-encoding reg)))) + (cond ((accumulator-p operand1) + (xchg-acc-with-something operand1 operand2)) + ((accumulator-p operand2) + (xchg-acc-with-something operand2 operand1)) + ((register-p operand1) + (xchg-reg-with-something operand1 operand2)) + ((register-p operand2) + (xchg-reg-with-something operand2 operand1)) + (t + (error "Bogus args to XCHG: ~S ~S" operand1 operand2))))))) + +;; load effective address +;; LEA cannot take 64 bit argument. Sign extension doesn't make sense here. +(define-instruction lea (segment dst src) + (:printer reg-reg/mem ((op #b1000110) (width 1))) + (:emitter + (assert (qword-reg-p dst)) + ;; We need to turn on this assertion after changing all lea fixup to mov-imm + ;; (assert (not (fixup-p src))) + (emit-byte segment #b01001000) ; prefix instruction #x48 + (emit-byte segment #b10001101) + (emit-ea segment src (reg-tn-encoding dst)))))) + +(define-instruction cmpxchg (segment dst src) + ;; Register/Memory with Register. + (:printer ext-reg-reg/mem ((op #b1011000)) '(:name :tab reg/mem ", " reg)) + (:emitter + (assert (register-p src)) + (let ((size (matching-operand-size src dst))) + (maybe-emit-operand-size-prefix segment size) + (emit-byte segment #b00001111) + (emit-byte segment (if (eq size :byte) #b10110000 #b10110001)) + (emit-ea segment dst (reg-tn-encoding src))))) + + +;;;; Flag control instructions. + +;;; CLC -- Clear Carry Flag. +;;; +(define-instruction clc (segment) + (:printer byte ((op #b11111000))) + (:emitter + (emit-byte segment #b11111000))) + +;;; CLD -- Clear Direction Flag. +;;; +(define-instruction cld (segment) + (:printer byte ((op #b11111100))) + (:emitter + (emit-byte segment #b11111100))) + +;;; CLI -- Clear Iterrupt Enable Flag. +;;; +(define-instruction cli (segment) + (:printer byte ((op #b11111010))) + (:emitter + (emit-byte segment #b11111010))) + +;;; CMC -- Complement Carry Flag. +;;; +(define-instruction cmc (segment) + (:printer byte ((op #b11110101))) + (:emitter + (emit-byte segment #b11110101))) + +;;; LAHF -- Load AH into flags. +;;; +(define-instruction lahf (segment) + (:printer byte ((op #b10011111))) + (:emitter + (emit-byte segment #b10011111))) + +;;; POPF -- Pop flags. +;;; +(define-instruction popf (segment) + (:printer byte ((op #b10011101))) + (:emitter + (emit-byte segment #b10011101))) + +;;; PUSHF -- push flags. +;;; +(define-instruction pushf (segment) + (:printer byte ((op #b10011100))) + (:emitter + (emit-byte segment #b10011100))) + +;;; SAHF -- Store AH into flags. +;;; +(define-instruction sahf (segment) + (:printer byte ((op #b10011110))) + (:emitter + (emit-byte segment #b10011110))) + +;;; STC -- Set Carry Flag. +;;; +(define-instruction stc (segment) + (:printer byte ((op #b11111001))) + (:emitter + (emit-byte segment #b11111001))) + +;;; STD -- Set Direction Flag. +;;; +(define-instruction std (segment) + (:printer byte ((op #b11111101))) + (:emitter + (emit-byte segment #b11111101))) + +;;; STI -- Set Interrupt Enable Flag. +;;; +(define-instruction sti (segment) + (:printer byte ((op #b11111011))) + (:emitter + (emit-byte segment #b11111011))) + + + +;;;; Arithmetic + +(defun emit-random-arith-inst (name segment dst src opcode + &optional allow-constants) + (let ((size (matching-operand-size dst src))) + (maybe-emit-operand-size-prefix segment size) + (cond + ((integerp src) + (cond ((and (not (eq size :byte)) (<= -128 src 127)) + (emit-byte segment #b10000011) + (emit-ea segment dst opcode allow-constants) + (emit-byte segment src)) + ((accumulator-p dst) + (emit-byte segment + (dpb opcode + (byte 3 3) + (if (eq size :byte) + #b00000100 + #b00000101))) + (emit-sized-immediate segment size src)) + (t + (emit-byte segment (if (eq size :byte) #b10000000 #b10000001)) + (emit-ea segment dst opcode allow-constants) + (emit-sized-immediate segment size src)))) + ((register-p src) + (emit-byte segment + (dpb opcode + (byte 3 3) + (if (eq size :byte) #b00000000 #b00000001))) + (emit-ea segment dst (reg-tn-encoding src) allow-constants)) + ((register-p dst) + (emit-byte segment + (dpb opcode + (byte 3 3) + (if (eq size :byte) #b00000010 #b00000011))) + (emit-ea segment src (reg-tn-encoding dst) allow-constants)) + (t + (error "Bogus operands to ~A" name))))) + +(eval-when (compile eval) + (defun arith-inst-printer-list (subop) + `((accum-imm ((op ,(dpb subop (byte 3 2) #b0000010)))) + (reg/mem-imm ((op (#b1000000 ,subop)))) + (reg/mem-imm ((op (#b1000001 ,subop)) + (imm nil :type signed-imm-byte))) + (reg-reg/mem-dir ((op ,(dpb subop (byte 3 1) #b000000)))))) + ) + +(define-instruction add (segment dst src) + (:printer-list + (arith-inst-printer-list #b000)) + (:emitter + (emit-random-arith-inst "ADD" segment dst src #b000))) + +(define-instruction adc (segment dst src) + (:printer-list + (arith-inst-printer-list #b010)) + (:emitter + (emit-random-arith-inst "ADC" segment dst src #b010))) + +(define-instruction sub (segment dst src) + (:printer-list + (arith-inst-printer-list #b101)) + (:emitter + (emit-random-arith-inst "SUB" segment dst src #b101))) + +(define-instruction sbb (segment dst src) + (:printer-list + (arith-inst-printer-list #b011)) + (:emitter + (emit-random-arith-inst "SBB" segment dst src #b011))) + +(define-instruction cmp (segment dst src) + (:printer-list + (arith-inst-printer-list #b111)) + (:emitter + (emit-random-arith-inst "CMP" segment dst src #b111 t))) + +(define-instruction inc (segment dst) + ;; Register. + (:printer reg-no-width ((op #b01000))) + ;; Register/Memory + (:printer reg/mem ((op '(#b1111111 #b000)))) + (:emitter + (let ((size (operand-size dst))) + (maybe-emit-operand-size-prefix segment size) + ;; Note that #x40 can't be used now. + (emit-byte segment (if (eq size :byte) #b11111110 #b11111111)) + (emit-ea segment dst #b000)))) + +(define-instruction dec (segment dst) + ;; Register. + (:printer reg-no-width ((op #b01001))) + ;; Register/Memory + (:printer reg/mem ((op '(#b1111111 #b001)))) + (:emitter + (let ((size (operand-size dst))) + (maybe-emit-operand-size-prefix segment size) + ;; Note that #x48 can't be used now. + (emit-byte segment (if (eq size :byte) #b11111110 #b11111111)) + (emit-ea segment dst #b001)))) + +(define-instruction neg (segment dst) + (:printer reg/mem ((op '(#b1111011 #b011)))) + (:emitter + (let ((size (operand-size dst))) + (maybe-emit-operand-size-prefix segment size) + (emit-byte segment (if (eq size :byte) #b11110110 #b11110111)) + (emit-ea segment dst #b011)))) + +(define-instruction aaa (segment) + (:printer byte ((op #b00110111))) + (:emitter + (emit-byte segment #b00110111))) + +(define-instruction aas (segment) + (:printer byte ((op #b00111111))) + (:emitter + (emit-byte segment #b00111111))) + +(define-instruction daa (segment) + (:printer byte ((op #b00100111))) + (:emitter + (emit-byte segment #b00100111))) + +(define-instruction das (segment) + (:printer byte ((op #b00101111))) + (:emitter + (emit-byte segment #b00101111))) + +(define-instruction mul (segment dst src) + (:printer accum-reg/mem ((op '(#b1111011 #b100)))) + (:emitter + (let ((size (matching-operand-size dst src))) + (assert (accumulator-p dst)) + (maybe-emit-operand-size-prefix segment size) + (emit-byte segment (if (eq size :byte) #b11110110 #b11110111)) + (emit-ea segment src #b100)))) + +(define-instruction imul (segment dst &optional src1 src2) + (:printer accum-reg/mem ((op '(#b1111011 #b101)))) + (:printer ext-reg-reg/mem ((op #b1010111))) + (:printer reg-reg/mem ((op #b0110100) (width 1) (imm nil :type 'imm-word)) + '(:name :tab reg ", " reg/mem ", " imm)) + (:printer reg-reg/mem ((op #b0110101) (width 1) + (imm nil :type 'signed-imm-byte)) + '(:name :tab reg ", " reg/mem ", " imm)) + (:emitter + (flet ((r/m-with-immed-to-reg (reg r/m immed) + (let* ((size (matching-operand-size reg r/m)) + (sx (and (not (eq size :byte)) (<= -128 immed 127)))) + (maybe-emit-operand-size-prefix segment size) + (emit-byte segment (if sx #b01101011 #b01101001)) + (emit-ea segment r/m (reg-tn-encoding reg)) + (if sx + (emit-byte segment immed) + (emit-sized-immediate segment size immed))))) + (cond (src2 + (r/m-with-immed-to-reg dst src1 src2)) + (src1 + (if (integerp src1) + (r/m-with-immed-to-reg dst dst src1) + (let ((size (matching-operand-size dst src1))) + (maybe-emit-operand-size-prefix segment size) + (emit-byte segment #b00001111) + (emit-byte segment #b10101111) + (emit-ea segment src1 (reg-tn-encoding dst))))) + (t + (let ((size (operand-size dst))) + (maybe-emit-operand-size-prefix segment size) + (emit-byte segment (if (eq size :byte) #b11110110 #b11110111)) + (emit-ea segment dst #b101))))))) + +(define-instruction div (segment dst src) + (:printer accum-reg/mem ((op '(#b1111011 #b110)))) + (:emitter + (let ((size (matching-operand-size dst src))) + (assert (accumulator-p dst)) + (maybe-emit-operand-size-prefix segment size) + (emit-byte segment (if (eq size :byte) #b11110110 #b11110111)) + (emit-ea segment src #b110)))) + +(define-instruction idiv (segment dst src) + (:printer accum-reg/mem ((op '(#b1111011 #b111)))) + (:emitter + (let ((size (matching-operand-size dst src))) + (assert (accumulator-p dst)) + (maybe-emit-operand-size-prefix segment size) + (emit-byte segment (if (eq size :byte) #b11110110 #b11110111)) + (emit-ea segment src #b111)))) + +(define-instruction aad (segment) + (:printer two-bytes ((op '(#b11010101 #b00001010)))) + (:emitter + (emit-byte segment #b11010101) + (emit-byte segment #b00001010))) + +(define-instruction aam (segment) + (:printer two-bytes ((op '(#b11010100 #b00001010)))) + (:emitter + (emit-byte segment #b11010100) + (emit-byte segment #b00001010))) + +;;; CBW -- Convert Byte to Word. AX <- sign_xtnd(AL) +;;; +(define-instruction cbw (segment) + (:emitter + (maybe-emit-operand-size-prefix segment :word) + (emit-byte segment #b10011000))) + +;;; CWDE -- Convert Word To Double Word Extened. EAX <- sign_xtnd(AX) +;;; +(define-instruction cwde (segment) + (:emitter + (maybe-emit-operand-size-prefix segment :dword) + (emit-byte segment #b10011000))) + +;;; CWD -- Convert Word to Double Word. DX:AX <- sign_xtnd(AX) +;;; +(define-instruction cwd (segment) + (:emitter + (maybe-emit-operand-size-prefix segment :word) + (emit-byte segment #b10011001))) + +;;; CDQ -- Convert Double Word to Quad Word. EDX:EAX <- sign_xtnd(EAX) +;;; +(define-instruction cdq (segment) + (:printer byte ((op #b10011001))) + (:emitter + (maybe-emit-operand-size-prefix segment :dword) + (emit-byte segment #b10011001))) + +;;; CDO -- Convert Quad Word to Double Quad Word. RDX:RAX <- sign_xtnd(RAX) +;;; +(define-instruction cdo (segment) + (:emitter + (maybe-emit-operand-size-prefix segment :qword) + (emit-byte segment #b10011001))) + +(define-instruction xadd (segment dst src) + ;; Register/Memory with Register. + (:printer ext-reg-reg/mem ((op #b1100000)) '(:name :tab reg/mem ", " reg)) + (:emitter + (assert (register-p src)) + (let ((size (matching-operand-size src dst))) + (maybe-emit-operand-size-prefix segment size) + (emit-byte segment #b00001111) + (emit-byte segment (if (eq size :byte) #b11000000 #b11000001)) + (emit-ea segment dst (reg-tn-encoding src))))) + + +;;;; Logic. + +(defun emit-shift-inst (segment dst amount opcode) + (let ((size (operand-size dst))) + (maybe-emit-operand-size-prefix segment size) + (multiple-value-bind + (major-opcode immed) + (case amount + (:cl (values #b11010010 nil)) + (1 (values #b11010000 nil)) + (t (values #b11000000 t))) + (emit-byte segment + (if (eq size :byte) major-opcode (logior major-opcode 1))) + (emit-ea segment dst opcode) + (when immed + (emit-byte segment amount))))) + +(eval-when (compile eval) + (defun shift-inst-printer-list (subop) + `((reg/mem ((op (#b1101000 ,subop))) + (:name :tab reg/mem ", 1")) + (reg/mem ((op (#b1101001 ,subop))) + (:name :tab reg/mem ", " 'cl)) + (reg/mem-imm ((op (#b1100000 ,subop)) + (imm nil :type signed-imm-byte)))))) + +(define-instruction rol (segment dst amount) + (:printer-list + (shift-inst-printer-list #b000)) + (:emitter + (emit-shift-inst segment dst amount #b000))) + +(define-instruction ror (segment dst amount) + (:printer-list + (shift-inst-printer-list #b001)) + (:emitter + (emit-shift-inst segment dst amount #b001))) + +(define-instruction rcl (segment dst amount) + (:printer-list + (shift-inst-printer-list #b010)) + (:emitter + (emit-shift-inst segment dst amount #b010))) + +(define-instruction rcr (segment dst amount) + (:printer-list + (shift-inst-printer-list #b011)) + (:emitter + (emit-shift-inst segment dst amount #b011))) + +(define-instruction shl (segment dst amount) + (:printer-list + (shift-inst-printer-list #b100)) + (:emitter + (emit-shift-inst segment dst amount #b100))) + +(define-instruction shr (segment dst amount) + (:printer-list + (shift-inst-printer-list #b101)) + (:emitter + (emit-shift-inst segment dst amount #b101))) + +(define-instruction sar (segment dst amount) + (:printer-list + (shift-inst-printer-list #b111)) + (:emitter + (emit-shift-inst segment dst amount #b111))) + +(defun emit-double-shift (segment opcode dst src amt) + (let ((size (matching-operand-size dst src))) + (when (eq size :byte) + (error "Double shifts can only be used with words.")) + (maybe-emit-operand-size-prefix segment size) + (emit-byte segment #b00001111) + (emit-byte segment (dpb opcode (byte 1 3) + (if (eq amt :cl) #b10100101 #b10100100))) + #+nil + (emit-ea segment dst src) + (emit-ea segment dst (reg-tn-encoding src)) ; pw tries this + (unless (eq amt :cl) + (emit-byte segment amt)))) + +(eval-when (compile eval) + (defun double-shift-inst-printer-list (op) + `(#+nil + (ext-reg-reg/mem-imm ((op ,(logior op #b100)) + (imm nil :type signed-imm-byte))) + (ext-reg-reg/mem ((op ,(logior op #b101))) + (:name :tab reg/mem ", " 'cl))))) + +(define-instruction shld (segment dst src amt) + (:declare (type (or (member :cl) (mod 32)) amt)) + (:printer-list (double-shift-inst-printer-list #b10100000)) + (:emitter + (emit-double-shift segment #b0 dst src amt))) + +(define-instruction shrd (segment dst src amt) + (:declare (type (or (member :cl) (mod 32)) amt)) + (:printer-list (double-shift-inst-printer-list #b10101000)) + (:emitter + (emit-double-shift segment #b1 dst src amt))) + +(define-instruction and (segment dst src) + (:printer-list + (arith-inst-printer-list #b100)) + (:emitter + (emit-random-arith-inst "AND" segment dst src #b100))) + +(define-instruction test (segment this that) + (:printer accum-imm ((op #b1010100))) + (:printer reg/mem-imm ((op '(#b1111011 #b000)))) + (:printer reg-reg/mem ((op #b1000010))) + (:emitter + (let ((size (matching-operand-size this that))) + (maybe-emit-operand-size-prefix segment size) + (flet ((test-immed-and-something (immed something) + (cond ((accumulator-p something) + (emit-byte segment + (if (eq size :byte) #b10101000 #b10101001)) + (emit-sized-immediate segment size immed)) + (t + (emit-byte segment + (if (eq size :byte) #b11110110 #b11110111)) + (emit-ea segment something #b000) + (emit-sized-immediate segment size immed)))) + (test-reg-and-something (reg something) + (emit-byte segment (if (eq size :byte) #b10000100 #b10000101)) + (emit-ea segment something (reg-tn-encoding reg)))) + (cond ((integerp that) + (test-immed-and-something that this)) + ((integerp this) + (test-immed-and-something this that)) + ((register-p this) + (test-reg-and-something this that)) + ((register-p that) + (test-reg-and-something that this)) + (t + (error "Bogus operands for TEST: ~S and ~S" this that))))))) + +(define-instruction or (segment dst src) + (:printer-list + (arith-inst-printer-list #b001)) + (:emitter + (emit-random-arith-inst "OR" segment dst src #b001))) + +(define-instruction xor (segment dst src) + (:printer-list + (arith-inst-printer-list #b110)) + (:emitter + (emit-random-arith-inst "XOR" segment dst src #b110))) + +(define-instruction not (segment dst) + (:printer reg/mem ((op '(#b1111011 #b010)))) + (:emitter + (let ((size (operand-size dst))) + (maybe-emit-operand-size-prefix segment size) + (emit-byte segment (if (eq size :byte) #b11110110 #b11110111)) + (emit-ea segment dst #b010)))) + + +;;;; String manipulation. + +(disassem:define-instruction-format (string-op 8 + :include 'simple + :default-printer '(:name width))) + +(define-instruction cmps (segment size) + (:printer string-op ((op #b1010011))) + (:emitter + (maybe-emit-operand-size-prefix segment size) + (emit-byte segment (if (eq size :byte) #b10100110 #b10100111)))) + +(define-instruction ins (segment acc) + (:printer string-op ((op #b0110110))) + (:emitter + (let ((size (operand-size acc))) + (assert (accumulator-p acc)) + (maybe-emit-operand-size-prefix segment size) + (emit-byte segment (if (eq size :byte) #b01101100 #b01101101))))) + +(define-instruction lods (segment acc) + (:printer string-op ((op #b1010110))) + (:emitter + (let ((size (operand-size acc))) + (assert (accumulator-p acc)) + (maybe-emit-operand-size-prefix segment size) + (emit-byte segment (if (eq size :byte) #b10101100 #b10101101))))) + +;; move data from string to string +(define-instruction movs (segment size) + (:printer string-op ((op #b1010010))) + (:emitter + (maybe-emit-operand-size-prefix segment size) + (emit-byte segment (if (eq size :byte) #b10100100 #b10100101)))) + +(define-instruction outs (segment acc) + (:printer string-op ((op #b0110111))) + (:emitter + (let ((size (operand-size acc))) + (assert (accumulator-p acc)) + (maybe-emit-operand-size-prefix segment size) + (emit-byte segment (if (eq size :byte) #b01101110 #b01101111))))) + +(define-instruction scas (segment acc) + (:printer string-op ((op #b1010111))) + (:emitter + (let ((size (operand-size acc))) + (assert (accumulator-p acc)) + (maybe-emit-operand-size-prefix segment size) + (emit-byte segment (if (eq size :byte) #b10101110 #b10101111))))) + +(define-instruction stos (segment acc) + (:printer string-op ((op #b1010101))) + (:emitter + (let ((size (operand-size acc))) + (assert (accumulator-p acc)) + (maybe-emit-operand-size-prefix segment size) + (emit-byte segment (if (eq size :byte) #b10101010 #b10101011))))) + +(define-instruction xlat (segment) + (:printer byte ((op #b11010111))) + (:emitter + (emit-byte segment #b11010111))) + +(define-instruction rep (segment) + (:emitter + (emit-byte segment #b11110010))) + +(define-instruction repe (segment) + (:printer byte ((op #b11110011))) + (:emitter + (emit-byte segment #b11110011))) + +(define-instruction repne (segment) + (:printer byte ((op #b11110010))) + (:emitter + (emit-byte segment #b11110010))) + + +;;;; Bit Manipulation + +(define-instruction bsf (segment dst src) + (:printer ext-reg-reg/mem ((op #b1011110) (width 0))) + (:emitter + (let ((size (matching-operand-size dst src))) + (when (eq size :byte) + (error "Can't scan bytes: ~S" src)) + (maybe-emit-operand-size-prefix segment size) + (emit-byte segment #b00001111) + (emit-byte segment #b10111100) + (emit-ea segment src (reg-tn-encoding dst))))) + +(define-instruction bsr (segment dst src) + (:printer ext-reg-reg/mem ((op #b1011110) (width 1))) + (:emitter + (let ((size (matching-operand-size dst src))) + (when (eq size :byte) + (error "Can't scan bytes: ~S" src)) + (maybe-emit-operand-size-prefix segment size) + (emit-byte segment #b00001111) + (emit-byte segment #b10111101) + (emit-ea segment src (reg-tn-encoding dst))))) + +(defun emit-bit-test-and-mumble (segment src index opcode) + (let ((size (operand-size src))) + (when (eq size :byte) + (error "Can't scan bytes: ~S" src)) + (maybe-emit-operand-size-prefix segment size) + (emit-byte segment #b00001111) + (cond ((integerp index) + (emit-byte segment #b10111010) + (emit-ea segment src opcode) + (emit-byte segment index)) + (t + (emit-byte segment (dpb opcode (byte 3 3) #b10000011)) + (emit-ea segment src (reg-tn-encoding index)))))) + +;; Bit Test (BT) instructions +;; Ignoring the case with a src as a register, we have +;; +;; 0F A3 reg/mem BT +;; 0F BB reg/mem BTC +;; 0F B3 reg/mem +;; 0F AB reg/mem +;; +;; A3 = 10100011 +;; BB = 10111011 +;; B3 = 10110011 +;; AB = 10101011 +;; +;; So the pattern is 10xxx011 +;; +;; The instruction format is then (little-endian) +;; +;; |reg/mem|10ooo011|00001111 +(disassem:define-instruction-format + (bit-test-reg/mem 24 + :default-printer '(:name :tab reg/mem ", " reg)) + (prefix :field (byte 8 0) :value #b0001111) + (op :field (byte 3 11)) + ;;(test :fields (list (byte 2 14) (byte 3 8))) + (reg/mem :fields (list (byte 2 22) (byte 3 16)) + :type 'reg/mem) + (reg :field (byte 3 19) :type 'reg) + ;; optional fields + (imm)) + +(define-instruction bt (segment src index) + (:printer bit-test-reg/mem ((op #b100))) + (:emitter + (emit-bit-test-and-mumble segment src index #b100))) + +(define-instruction btc (segment src index) + (:printer bit-test-reg/mem ((op #b111))) + (:emitter + (emit-bit-test-and-mumble segment src index #b111))) + +(define-instruction btr (segment src index) + (:printer bit-test-reg/mem ((op #b110))) + (:emitter + (emit-bit-test-and-mumble segment src index #b110))) + +(define-instruction bts (segment src index) + (:printer bit-test-reg/mem ((op #b101))) + (:emitter + (emit-bit-test-and-mumble segment src index #b101))) + + +;;;; Control transfer. + +(eval-when (compile load eval) +(defparameter condition-name-vec + (let ((vec (make-array 16 :initial-element nil))) + (dolist (cond conditions) + (when (null (aref vec (cdr cond))) + (setf (aref vec (cdr cond)) (car cond)))) + vec))) + +(disassem:define-argument-type condition-code + :printer condition-name-vec) + +(disassem:define-argument-type displacement + :sign-extend t + :use-label #'offset-next + :printer #'(lambda (value stream dstate) + (let ((unsigned-val (if (and (numberp value) (minusp value)) + (+ value #x100000000) + value))) + (disassem:maybe-note-assembler-routine unsigned-val stream dstate)) + (print-label value stream dstate))) + +(disassem:define-instruction-format (short-cond-jump 16) + (op :field (byte 4 4)) + (cc :field (byte 4 0) :type 'condition-code) + (label :field (byte 8 8) :type 'displacement)) + +(disassem:define-instruction-format (short-jump 16 + :default-printer '(:name :tab label)) + (const :field (byte 4 4) :value #b1110) + (op :field (byte 4 0)) + (label :field (byte 8 8) :type 'displacement)) + +(disassem:define-instruction-format (near-cond-jump 16) + (op :fields (list (byte 8 0) (byte 4 12)) :value '(#b00001111 #b1000)) + (cc :field (byte 4 8) :type 'condition-code) + ;; The disassembler currently doesn't let you have an instruction > 32 bits + ;; long, so we fake it by using a prefilter to read the offset. + (label :type 'displacement + :prefilter #'(lambda (value dstate) + (declare (ignore value)) ; always nil anyway + (disassem:read-signed-suffix 32 dstate)))) + +(disassem:define-instruction-format (near-jump 8 + :default-printer '(:name :tab label)) + (op :field (byte 8 0)) + ;; The disassembler currently doesn't let you have an instruction > 32 bits + ;; long, so we fake it by using a prefilter to read the address. + (label :type 'displacement + :prefilter #'(lambda (value dstate) + (declare (ignore value)) ; always nil anyway + (disassem:read-signed-suffix 32 dstate)))) + + +(define-instruction call (segment where) + (:printer near-jump ((op #b11101000))) + (:printer reg/mem ((op '(#b1111111 #b010)) (width 1))) + (:emitter + (typecase where + (label + (emit-byte segment #b11101000) + (emit-back-patch segment 4 + #'(lambda (segment posn) + (emit-dword segment + (- (label-position where) + (+ posn 4)))))) + (fixup + (emit-byte segment #b11101000) + ;; Relative fixup is limited to 32 bits. This may not be enough. + (emit-relative-fixup segment where)) + (t + ;; REX is necessary for stuff like "callq *%rdi" + (unless (ea-p where) + (emit-byte segment #b01001000)) ; REX prefix #x48 + (emit-byte segment #b11111111) + (emit-ea segment where #b010))))) + +(defun emit-byte-displacement-backpatch (segment target) + (emit-back-patch segment 1 + #'(lambda (segment posn) + (let ((disp (- (label-position target) (1+ posn)))) + (assert (<= -128 disp 127)) + (emit-byte segment disp))))) + +;; fix it for 64 bit reg +(define-instruction jmp (segment cond &optional where) + ;; conditional jumps + (:printer short-cond-jump ((op #b0111)) '('j cc :tab label)) + (:printer near-cond-jump () '('j cc :tab label)) + ;; unconditional jumps + (:printer short-jump ((op #b1011))) + (:printer near-jump ((op #b11101001)) ) + (:printer reg/mem ((op '(#b1111111 #b100)) (width 1))) + (:emitter + (cond (where + (emit-chooser + segment 6 2 + #'(lambda (segment posn delta-if-after) + (let ((disp (- (label-position where posn delta-if-after) + (+ posn 2)))) + (when (<= -128 disp 127) + (emit-byte segment + (dpb (conditional-opcode cond) + (byte 4 0) + #b01110000)) + (emit-byte-displacement-backpatch segment where) + t))) + #'(lambda (segment posn) + (let ((disp (- (label-position where) (+ posn 6)))) + (emit-byte segment #b00001111) + (emit-byte segment + (dpb (conditional-opcode cond) + (byte 4 0) + #b10000000)) + (emit-dword segment disp))))) + ((label-p (setq where cond)) + (emit-chooser + segment 5 0 + #'(lambda (segment posn delta-if-after) + (let ((disp (- (label-position where posn delta-if-after) + (+ posn 2)))) + (when (<= -128 disp 127) + (emit-byte segment #b11101011) + (emit-byte-displacement-backpatch segment where) + t))) + #'(lambda (segment posn) + (let ((disp (- (label-position where) (+ posn 5)))) + (emit-byte segment #b11101001) + (emit-dword segment disp)) + ))) + ((fixup-p where) + (emit-byte segment #b11101001) + (emit-relative-fixup segment where)) + (t + (unless (or (ea-p where) (tn-p where)) + (error "Don't know what to do with ~A" where)) + (emit-byte segment #b11111111) + (emit-ea segment where #b100))))) + +(define-instruction jmp-short (segment label) + (:emitter + (emit-byte segment #b11101011) + (emit-byte-displacement-backpatch segment label))) + +(define-instruction ret (segment &optional stack-delta) + (:printer byte ((op #b11000011))) + (:printer byte ((op #b11000010) (imm nil :type 'imm-word-16)) + '(:name :tab imm)) + (:emitter + (cond (stack-delta + (emit-byte segment #b11000010) + (emit-word segment stack-delta)) + (t + (emit-byte segment #b11000011))))) + +(define-instruction jecxz (segment target) + (:printer short-jump ((op #b0011))) + (:emitter + (emit-byte segment #b11100011) + (emit-byte-displacement-backpatch segment target))) + +(define-instruction loop (segment target) + (:printer short-jump ((op #b0010))) + (:emitter + (emit-byte segment #b11100010) ; pfw this was 11100011, or jecxz!!!! + (emit-byte-displacement-backpatch segment target))) + +(define-instruction loopz (segment target) + (:printer short-jump ((op #b0001))) + (:emitter + (emit-byte segment #b11100001) + (emit-byte-displacement-backpatch segment target))) + +(define-instruction loopnz (segment target) + (:printer short-jump ((op #b0000))) + (:emitter + (emit-byte segment #b11100000) + (emit-byte-displacement-backpatch segment target))) + + +;;; Conditional move. + +(disassem:define-instruction-format (cond-move 24 + :default-printer + '('cmov cond :tab reg ", " reg/mem)) + (prefix :field (byte 8 0) :value #b00001111) + (op :field (byte 4 12) :value #b0100) + (cond :field (byte 4 8) :type 'condition-code) + (reg/mem :fields (list (byte 2 22) (byte 3 16)) + :type 'reg/mem) + (reg :field (byte 3 19) :type 'reg)) + +(define-instruction cmov (segment cond dst src) + (:printer cond-move ()) + (:emitter + (assert (register-p dst)) + (let ((size (matching-operand-size dst src))) + (assert (or (eq size :word) (eq size :dword))) + (maybe-emit-operand-size-prefix segment size)) + (emit-byte segment #b00001111) + (emit-byte segment (dpb (conditional-opcode cond) (byte 4 0) #b01000000)) + (emit-ea segment src (reg-tn-encoding dst)))) + + +;;;; Conditional byte set. + +(disassem:define-instruction-format (cond-set 24 + :default-printer '('set cc :tab reg/mem)) + (prefix :field (byte 8 0) :value #b00001111) + (op :field (byte 4 12) :value #b1001) + (cc :field (byte 4 8) :type 'condition-code) + (reg/mem :fields (list (byte 2 22) (byte 3 16)) + :type 'byte-reg/mem) + (reg :field (byte 3 19) :value #b000)) + +(define-instruction set (segment dst cond) + (:printer cond-set ()) + (:emitter + (emit-byte segment #b00001111) + (emit-byte segment (dpb (conditional-opcode cond) (byte 4 0) #b10010000)) + (emit-ea segment dst #b000))) + + +;;;; Enter/Leave + +(disassem:define-instruction-format (enter-format 32 + :default-printer '(:name + :tab disp + (:unless (:constant 0) + ", " level))) + (op :field (byte 8 0)) + (disp :field (byte 16 8)) + (level :field (byte 8 24))) + +(define-instruction enter (segment disp &optional (level 0)) + (:declare (type (unsigned-byte 16) disp) + (type (unsigned-byte 8) level)) + (:printer enter-format ((op #b11001000))) + (:emitter + (emit-byte segment #b11001000) + (emit-word segment disp) + (emit-byte segment level))) + +(define-instruction leave (segment) + (:printer byte ((op #b11001001))) + (:emitter + (emit-byte segment #b11001001))) + + +;;;; Interrupt instructions. + +;;; Single byte instruction with an immediate byte argument. +(disassem:define-instruction-format (byte-imm 16 + :default-printer '(:name :tab code)) + (op :field (byte 8 0)) + (code :field (byte 8 8))) + +(defun snarf-error-junk (sap offset &optional length-only) + (let* ((length (system:sap-ref-8 sap offset)) + (vector (make-array length :element-type '(unsigned-byte 8)))) + (declare (type system:system-area-pointer sap) + (type (unsigned-byte 8) length) + (type (simple-array (unsigned-byte 8) (*)) vector)) + (cond (length-only + (values 0 (1+ length) nil nil)) + (t + (kernel:copy-from-system-area sap (* byte-bits (1+ offset)) + vector (* word-bits + vector-data-offset) + (* length byte-bits)) + (collect ((sc-offsets) + (lengths)) + (lengths 1) ; the length byte + (let* ((index 0) + (error-number (c::read-var-integer vector index))) + (lengths index) + (loop + (when (>= index length) + (return)) + (let ((old-index index)) + (sc-offsets (c::read-var-integer vector index)) + (lengths (- index old-index)))) + (values error-number + (1+ length) + (sc-offsets) + (lengths)))))))) + +(defmacro break-cases (breaknum &body cases) + (let ((bn-temp (gensym))) + (collect ((clauses)) + (dolist (case cases) + (clauses `((= ,bn-temp ,(car case)) ,@(cdr case)))) + `(let ((,bn-temp ,breaknum)) + (cond ,@(clauses)))))) + +(defun break-control (chunk inst stream dstate) + (declare (ignore inst)) + (flet ((nt (x) (if stream (disassem:note x dstate)))) + (case (byte-imm-code chunk dstate) + (#.vm:error-trap + (nt "Error trap") + (disassem:handle-break-args #'snarf-error-junk stream dstate)) + (#.vm:cerror-trap + (nt "Cerror trap") + (disassem:handle-break-args #'snarf-error-junk stream dstate)) + (#.vm:breakpoint-trap + (nt "Breakpoint trap")) + (#.vm:pending-interrupt-trap + (nt "Pending interrupt trap")) + (#.vm:halt-trap + (nt "Halt trap")) + (#.vm:function-end-breakpoint-trap + (nt "Function end breakpoint trap")) + ))) + +(define-instruction break (segment code) + (:declare (type (unsigned-byte 8) code)) + (:printer byte-imm ((op #b11001100)) '(:name :tab code) + :control #'break-control) + (:emitter + (emit-byte segment #b11001100) + (emit-byte segment code))) + +(define-instruction int (segment number) + (:declare (type (unsigned-byte 8) number)) + (:printer byte-imm ((op #b11001101))) + (:emitter + (etypecase number + ((member 3) + (emit-byte segment #b11001100)) + ((unsigned-byte 8) + (emit-byte segment #b11001101) + (emit-byte segment number))))) + +(define-instruction into (segment) + (:printer byte ((op #b11001110))) + (:emitter + (emit-byte segment #b11001110))) + +(define-instruction bound (segment reg bounds) + (:emitter + (let ((size (matching-operand-size reg bounds))) + (when (eq size :byte) + (error "Can't bounds-test bytes: ~S" reg)) + (maybe-emit-operand-size-prefix segment size) + (emit-byte segment #b01100010) + (emit-ea segment bounds (reg-tn-encoding reg))))) + +(define-instruction iret (segment) + (:printer byte ((op #b11001111))) + (:emitter + (emit-byte segment #b11001111))) + +;; read-time-stamp instruction, that counts executed cycles, present +;; from Pentium onwards +(define-instruction rdtsc (segment) + (:printer two-bytes ((op '(#x0f #x31)))) + (:emitter + (emit-byte segment #x0f) + (emit-byte segment #x31))) + +(define-instruction cpuid (segment) + (:printer two-bytes ((op '(#x0f #xa2)))) + (:emitter + (emit-byte segment #x0f) + (emit-byte segment #xa2))) + + +;;;; Processor control + +(define-instruction hlt (segment) + (:printer byte ((op #b11110100))) + (:emitter + (emit-byte segment #b11110100))) + +(define-instruction nop (segment) + (:printer byte ((op #b10010000))) + (:emitter + (emit-byte segment #b10010000))) + +(define-instruction wait (segment) + (:printer byte ((op #b10011011))) + (:emitter + (emit-byte segment #b10011011))) + +(define-instruction lock (segment) + (:printer byte ((op #b11110000))) + (:emitter + (emit-byte segment #b11110000))) + + + +;;;; Random hackery + +(define-instruction byte (segment byte) + (:emitter + (emit-byte segment byte))) + +(define-instruction word (segment word) + (:emitter + (emit-word segment word))) + +(define-instruction dword (segment dword) + (:emitter + (emit-dword segment dword))) + +(define-instruction qword (segment qword) + (:emitter + (emit-qword segment qword))) + +(defun emit-header-data (segment type) + (emit-back-patch + segment 8 + #'(lambda (segment posn) + (emit-qword segment + (logior type + (ash (+ posn (component-header-length)) + (- type-bits word-shift))))))) + +(define-instruction function-header-word (segment) + (:emitter + (emit-header-data segment function-header-type))) + +(define-instruction lra-header-word (segment) + (:emitter + (emit-header-data segment return-pc-header-type))) + +;;; ---------------------------------------------------------------- +;;; added by jrd. fp instructions +;;; + +;;; +;;; we treat the single-precision and double-precision variants +;;; as separate instructions +;;; + +;;; +;;; load single to st(0) +;;; +(define-instruction fld (segment source) + (:printer floating-point ((op '(#b001 #b000)))) + (:emitter + (emit-byte segment #b11011001) + (emit-fp-op segment source #b000))) + +;;; +;;; load double to st(0) +;;; +(define-instruction fldd (segment source) + (:printer floating-point ((op '(#b101 #b000)))) + (:printer floating-point-fp ((op '(#b001 #b000)))) + (:emitter + (if (fp-reg-tn-p source) + (emit-byte segment #b11011001) + (emit-byte segment #b11011101)) + (emit-fp-op segment source #b000))) + +;;; +;;; load long to st(0) +;;; +(define-instruction fldl (segment source) + (:printer floating-point ((op '(#b011 #b101)))) + (:emitter + (emit-byte segment #b11011011) + (emit-fp-op segment source #b101))) + +;;; +;;; store single from st(0) +;;; +(define-instruction fst (segment dest) + (:printer floating-point ((op '(#b001 #b010)))) + (:emitter + (cond ((fp-reg-tn-p dest) + (emit-byte segment #b11011101) + (emit-fp-op segment dest #b010)) + (t + (emit-byte segment #b11011001) + (emit-fp-op segment dest #b010))))) + +;;; +;;; store double from st(0) +;;; +(define-instruction fstd (segment dest) + (:printer floating-point ((op '(#b101 #b010)))) + (:printer floating-point-fp ((op '(#b101 #b010)))) + (:emitter + (cond ((fp-reg-tn-p dest) + (emit-byte segment #b11011101) + (emit-fp-op segment dest #b010)) + (t + (emit-byte segment #b11011101) + (emit-fp-op segment dest #b010))))) + +;;; Arithmetic ops are all done with at least one operand at top of +;;; stack. The other operand is is another register or a 32/64 bit +;;; memory loc. + +;;; dtc: I've tried to follow the Intel ASM386 conventions, but note +;;; that these conflict with the Gdb conventions for binops. To reduce +;;; the confusion I've added comments showing the mathamatical +;;; operation and the two syntaxes. By the ASM386 convention the +;;; instruction syntax is: +;;; +;;; Fop Source +;;; or Fop Destination, Source +;;; +;;; If only one operand is given then it is the source and the +;;; destination is ST(0). There are reversed forms of the fsub and +;;; fdiv instructions inducated by an 'R' suffix. +;;; +;;; The mathematical operation for the non-reverse form is always: +;;; destination = destination op source +;;; +;;; For the reversed form it is: +;;; destination = source op destination +;;; +;;; The instructions below only accept one operand at present which is +;;; usually the source. I've hack in extra instructions to implement +;;; the fops with a ST(i) destination, these have a -sti suffix and +;;; the operand is the destination with the source being ST(0). + +;;; +;;; Add single +;;; st(0) = st(0) + memory or st(i) +;;; +(define-instruction fadd (segment source) + (:printer floating-point ((op '(#b000 #b000)))) + (:emitter + (emit-byte segment #b11011000) + (emit-fp-op segment source #b000))) + +;;; +;;; Add double +;;; st(0) = st(0) + memory or st(i) +;;; +(define-instruction faddd (segment source) + (:printer floating-point ((op '(#b100 #b000)))) + (:printer floating-point-fp ((op '(#b000 #b000)))) + (:emitter + (if (fp-reg-tn-p source) + (emit-byte segment #b11011000) + (emit-byte segment #b11011100)) + (emit-fp-op segment source #b000))) + +;;; +;;; Add double destination st(i) +;;; st(i) = st(0) + st(i) +;;; +(define-instruction fadd-sti (segment destination) + (:printer floating-point-fp ((op '(#b100 #b000))) + '(:name :tab fp-reg ", " '|ST(0)|) + :print-name 'fadd) + (:emitter + (assert (fp-reg-tn-p destination)) + (emit-byte segment #b11011100) + (emit-fp-op segment destination #b000))) +;;; With pop +(define-instruction faddp-sti (segment destination) + (:printer floating-point-fp ((op '(#b110 #b000))) + '(:name :tab fp-reg ", " '|ST(0)|) + :print-name 'faddp) + (:emitter + (assert (fp-reg-tn-p destination)) + (emit-byte segment #b11011110) + (emit-fp-op segment destination #b000))) + +;;; +;;; Subtract single +;;; st(0) = st(0) - memory or st(i) +;;; +(define-instruction fsub (segment source) + (:printer floating-point ((op '(#b000 #b100)))) + (:emitter + (emit-byte segment #b11011000) + (emit-fp-op segment source #b100))) + +;;; +;;; Subtract single, reverse +;;; st(0) = memory or st(i) - st(0) +;;; +(define-instruction fsubr (segment source) + (:printer floating-point ((op '(#b000 #b101)))) + (:emitter + (emit-byte segment #b11011000) + (emit-fp-op segment source #b101))) + +;;; +;;; Subtract double +;;; st(0) = st(0) - memory or st(i) +;;; +(define-instruction fsubd (segment source) + (:printer floating-point ((op '(#b100 #b100)))) + (:printer floating-point-fp ((op '(#b000 #b100)))) + (:emitter + (if (fp-reg-tn-p source) + (emit-byte segment #b11011000) + (emit-byte segment #b11011100)) + (emit-fp-op segment source #b100))) + +;;; +;;; Subtract double, reverse +;;; st(0) = memory or st(i) - st(0) +;;; +(define-instruction fsubrd (segment source) + (:printer floating-point ((op '(#b100 #b101)))) + (:printer floating-point-fp ((op '(#b000 #b101)))) + (:emitter + (if (fp-reg-tn-p source) + (emit-byte segment #b11011000) + (emit-byte segment #b11011100)) + (emit-fp-op segment source #b101))) + +;;; +;;; Subtract double, destination st(i) +;;; st(i) = st(i) - st(0) +;;; +;;; ASM386 syntax: FSUB ST(i), ST +;;; Gdb syntax: fsubr %st,%st(i) +;;; +(define-instruction fsub-sti (segment destination) + (:printer floating-point-fp ((op '(#b100 #b101))) + '(:name :tab fp-reg ", " '|ST(0)|) + :print-name 'fsub) + (:emitter + (assert (fp-reg-tn-p destination)) + (emit-byte segment #b11011100) + (emit-fp-op segment destination #b101))) +;;; With a pop +(define-instruction fsubp-sti (segment destination) + (:printer floating-point-fp ((op '(#b110 #b101))) + '(:name :tab fp-reg ", " '|ST(0)|) + :print-name 'fsubp) + (:emitter + (assert (fp-reg-tn-p destination)) + (emit-byte segment #b11011110) + (emit-fp-op segment destination #b101))) + +;;; +;;; Subtract double, reverse, destination st(i) +;;; st(i) = st(0) - st(i) +;;; +;;; ASM386 syntax: FSUBR ST(i), ST +;;; Gdb syntax: fsub %st,%st(i) +;;; +(define-instruction fsubr-sti (segment destination) + (:printer floating-point-fp ((op '(#b100 #b100))) + '(:name :tab fp-reg ", " '|ST(0)|) + :print-name 'fsubr) + (:emitter + (assert (fp-reg-tn-p destination)) + (emit-byte segment #b11011100) + (emit-fp-op segment destination #b100))) +;;; With a pop +(define-instruction fsubrp-sti (segment destination) + (:printer floating-point-fp ((op '(#b110 #b100))) + '(:name :tab fp-reg ", " '|ST(0)|) + :print-name 'fsubrp) + (:emitter + (assert (fp-reg-tn-p destination)) + (emit-byte segment #b11011110) + (emit-fp-op segment destination #b100))) + + +;;; +;;; Multiply single +;;; st(0) = st(0) * memory or st(i) +;;; +(define-instruction fmul (segment source) + (:printer floating-point ((op '(#b000 #b001)))) + (:emitter + (emit-byte segment #b11011000) + (emit-fp-op segment source #b001))) + +;;; +;;; Multiply double +;;; st(0) = st(0) * memory or st(i) +;;; +(define-instruction fmuld (segment source) + (:printer floating-point ((op '(#b100 #b001)))) + (:printer floating-point-fp ((op '(#b000 #b001)))) + (:emitter + (if (fp-reg-tn-p source) + (emit-byte segment #b11011000) + (emit-byte segment #b11011100)) + (emit-fp-op segment source #b001))) + +;;; +;;; Multiply double, destination st(i) +;;; st(i) = st(i) * st(0) +;;; +(define-instruction fmul-sti (segment destination) + (:printer floating-point-fp ((op '(#b100 #b001))) + '(:name :tab fp-reg ", " '|ST(0)|) + :print-name 'fmul) + (:emitter + (assert (fp-reg-tn-p destination)) + (emit-byte segment #b11011100) + (emit-fp-op segment destination #b001))) + + + +;;; +;;; Divide single +;;; st(0) = st(0) / memory or st(i) +;;; +(define-instruction fdiv (segment source) + (:printer floating-point ((op '(#b000 #b110)))) + (:emitter + (emit-byte segment #b11011000) + (emit-fp-op segment source #b110))) + +;;; +;;; Divide single, reverse +;;; st(0) = memory or st(i) / st(0) +;;; +(define-instruction fdivr (segment source) + (:printer floating-point ((op '(#b000 #b111)))) + (:emitter + (emit-byte segment #b11011000) + (emit-fp-op segment source #b111))) + +;;; +;;; Divide double +;;; st(0) = st(0) / memory or st(i) +;;; +(define-instruction fdivd (segment source) + (:printer floating-point ((op '(#b100 #b110)))) + (:printer floating-point-fp ((op '(#b000 #b110)))) + (:emitter + (if (fp-reg-tn-p source) + (emit-byte segment #b11011000) + (emit-byte segment #b11011100)) + (emit-fp-op segment source #b110))) + +;;; +;;; Divide double, reverse +;;; st(0) = memory or st(i) / st(0) +;;; +(define-instruction fdivrd (segment source) + (:printer floating-point ((op '(#b100 #b111)))) + (:printer floating-point-fp ((op '(#b000 #b111)))) + (:emitter + (if (fp-reg-tn-p source) + (emit-byte segment #b11011000) + (emit-byte segment #b11011100)) + (emit-fp-op segment source #b111))) + +;;; +;;; Divide double, destination st(i) +;;; st(i) = st(i) / st(0) +;;; +;;; ASM386 syntax: FDIV ST(i), ST +;;; Gdb syntax: fdivr %st,%st(i) +;;; +(define-instruction fdiv-sti (segment destination) + (:printer floating-point-fp ((op '(#b100 #b111))) + '(:name :tab fp-reg ", " '|ST(0)|) + :print-name 'fdiv) + (:emitter + (assert (fp-reg-tn-p destination)) + (emit-byte segment #b11011100) + (emit-fp-op segment destination #b111))) + +;;; +;;; Divide double, reverse, destination st(i) +;;; st(i) = st(0) / st(i) +;;; +;;; ASM386 syntax: FDIVR ST(i), ST +;;; Gdb syntax: fdiv %st,%st(i) +;;; +(define-instruction fdivr-sti (segment destination) + (:printer floating-point-fp ((op '(#b100 #b110))) + '(:name :tab fp-reg ", " '|ST(0)|) + :print-name 'fdivr) + (:emitter + (assert (fp-reg-tn-p destination)) + (emit-byte segment #b11011100) + (emit-fp-op segment destination #b110))) + +;;; +;;; exchange fr0 with fr(n). no double variant +;;; +(define-instruction fxch (segment source) + (:printer floating-point-fp ((op '(#b001 #b001)))) + (:emitter + (unless (and (tn-p source) + (eq (sb-name (sc-sb (tn-sc source))) 'float-registers)) + (lisp:break)) + (emit-byte segment #b11011001) + (emit-fp-op segment source #b001))) +;;; +;;; +;;; push 32-bit integer to st0 +;;; +(define-instruction fild (segment source) + (:printer floating-point ((op '(#b011 #b000)))) + (:emitter + (emit-byte segment #b11011011) + (emit-fp-op segment source #b000))) +;;; +;;; push 64-bit integer to st0 +;;; +(define-instruction fildl (segment source) + (:printer floating-point ((op '(#b111 #b101)))) + (:emitter + (emit-byte segment #b11011111) + (emit-fp-op segment source #b101))) +;;; +;;; store 32-bit integer +;;; +(define-instruction fist (segment dest) + (:printer floating-point ((op '(#b011 #b010)))) + (:emitter + (emit-byte segment #b11011011) + (emit-fp-op segment dest #b010))) +;;; +;;; Store and pop 32-bit integer +;;; +(define-instruction fistp (segment dest) + (:printer floating-point ((op '(#b011 #b011)))) + (:emitter + (emit-byte segment #b11011011) + (emit-fp-op segment dest #b011))) +;;; +;;; Store and pop 64-bit integer +;;; +(define-instruction fistpl (segment dest) + (:printer floating-point ((op '(#b111 #b111)))) + (:emitter + (emit-byte segment #b11011111) + (emit-fp-op segment dest #b111))) +;;; +;;; store single from st(0) and pop +;;; +(define-instruction fstp (segment dest) + (:printer floating-point ((op '(#b001 #b011)))) + (:emitter + (cond ((fp-reg-tn-p dest) + (emit-byte segment #b11011101) + (emit-fp-op segment dest #b011)) + (t + (emit-byte segment #b11011001) + (emit-fp-op segment dest #b011))))) +;;; +;;; store double from st(0) and pop +;;; +(define-instruction fstpd (segment dest) + (:printer floating-point ((op '(#b101 #b011)))) + (:printer floating-point-fp ((op '(#b101 #b011)))) + (:emitter + (cond ((fp-reg-tn-p dest) + (emit-byte segment #b11011101) + (emit-fp-op segment dest #b011)) + (t + (emit-byte segment #b11011101) + (emit-fp-op segment dest #b011))))) +;;; +;;; store long from st(0) and pop +;;; +(define-instruction fstpl (segment dest) + (:printer floating-point ((op '(#b011 #b111)))) + (:emitter + (emit-byte segment #b11011011) + (emit-fp-op segment dest #b111))) + +;;; +;;; decrement stack-top pointer +;;; +(define-instruction fdecstp (segment) + (:printer floating-point-no ((op #b10110))) + (:emitter + (emit-byte segment #b11011001) + (emit-byte segment #b11110110))) +;;; +;;; increment stack-top pointer +;;; +(define-instruction fincstp (segment) + (:printer floating-point-no ((op #b10111))) + (:emitter + (emit-byte segment #b11011001) + (emit-byte segment #b11110111))) +;;; +;;; free fp register +;;; +(define-instruction ffree (segment dest) + (:printer floating-point-fp ((op '(#b101 #b000)))) + (:emitter + (emit-byte segment #b11011101) + (emit-fp-op segment dest #b000))) +;;; +;;; Free fp register and pop the stack. +;;; +(define-instruction ffreep (segment dest) + (:printer floating-point-fp ((op '(#b111 #b000)))) + (:emitter + (emit-byte segment #b11011111) + (emit-fp-op segment dest #b000))) + +(define-instruction fabs (segment) + (:printer floating-point-no ((op #b00001))) + (:emitter + (emit-byte segment #b11011001) + (emit-byte segment #b11100001))) + +(define-instruction fchs (segment) + (:printer floating-point-no ((op #b00000))) + (:emitter + (emit-byte segment #b11011001) + (emit-byte segment #b11100000))) + +(define-instruction frndint(segment) + (:printer floating-point-no ((op #b11100))) + (:emitter + (emit-byte segment #b11011001) + (emit-byte segment #b11111100))) + +;;; +;;; Initialize NPX +;;; +(define-instruction fninit(segment) + (:printer floating-point-5 ((op #b00011))) + (:emitter + (emit-byte segment #b11011011) + (emit-byte segment #b11100011))) + +;;; +;;; Store Status Word to AX +;;; +(define-instruction fnstsw(segment) + (:printer floating-point-st ((op #b00000))) + (:emitter + (emit-byte segment #b11011111) + (emit-byte segment #b11100000))) + +;;; +;;; Load Control Word +;;; +;;; src must be a memory location +(define-instruction fldcw(segment src) + (:printer floating-point ((op '(#b001 #b101)))) + (:emitter + (emit-byte segment #b11011001) + (emit-fp-op segment src #b101))) + +;;; +;;; Store Control Word +;;; +(define-instruction fnstcw(segment dst) + (:printer floating-point ((op '(#b001 #b111)))) + (:emitter + (emit-byte segment #b11011001) + (emit-fp-op segment dst #b111))) +;;; +;;; Store FP Environment +;;; +(define-instruction fstenv(segment dst) + (:printer floating-point ((op '(#b001 #b110)))) + (:emitter + (emit-byte segment #b11011001) + (emit-fp-op segment dst #b110))) +;;; +;;; Retore FP Environment +;;; +(define-instruction fldenv(segment src) + (:printer floating-point ((op '(#b001 #b100)))) + (:emitter + (emit-byte segment #b11011001) + (emit-fp-op segment src #b100))) +;;; +;;; Save FP State +;;; +(define-instruction fsave(segment dst) + (:printer floating-point ((op '(#b101 #b110)))) + (:emitter + (emit-byte segment #b11011101) + (emit-fp-op segment dst #b110))) +;;; +;;; Restore FP State +;;; +(define-instruction frstor (segment src) + (:printer floating-point ((op '(#b101 #b100)))) + (:emitter + (emit-byte segment #b11011101) + (emit-fp-op segment src #b100))) +;;; +;;; Clear exceptions +;;; +(define-instruction fnclex (segment) + (:printer floating-point-5 ((op #b00010))) + (:emitter + (emit-byte segment #b11011011) + (emit-byte segment #b11100010))) + +;;; +;;; Comparison +;;; +(define-instruction fcom (segment src) + (:printer floating-point ((op '(#b000 #b010)))) + (:emitter + (emit-byte segment #b11011000) + (emit-fp-op segment src #b010))) + +(define-instruction fcomd (segment src) + (:printer floating-point ((op '(#b100 #b010)))) + (:printer floating-point-fp ((op '(#b000 #b010)))) + (:emitter + (if (fp-reg-tn-p src) + (emit-byte segment #b11011000) + (emit-byte segment #b11011100)) + (emit-fp-op segment src #b010))) + +;;; Compare ST1 to ST0, popping the stack twice. +(define-instruction fcompp (segment) + (:printer floating-point-3 ((op '(#b110 #b011001)))) + (:emitter + (emit-byte segment #b11011110) + (emit-byte segment #b11011001))) + +;;; +;;; Compare ST(i) to ST0 and update the flags. +;;; +;;; Intel syntax: FCOMI ST, ST(i) +;;; +(define-instruction fcomi (segment src) + (:printer floating-point-fp ((op '(#b011 #b110)))) + (:emitter + (assert (fp-reg-tn-p src)) + (emit-byte segment #b11011011) + (emit-fp-op segment src #b110))) + +;;; +;;; Unordered comparison +;;; +(define-instruction fucom (segment src) + (:printer floating-point-fp ((op '(#b101 #b100)))) + (:emitter + (assert (fp-reg-tn-p src)) + (emit-byte segment #b11011101) + (emit-fp-op segment src #b100))) +;;; +;;; Unordered compare ST(i) to ST0 and update the flags. +;;; +;;; Intel syntax: FUCOMI ST, ST(i) +;;; +(define-instruction fucomi (segment src) + (:printer floating-point-fp ((op '(#b011 #b101)))) + (:emitter + (assert (fp-reg-tn-p src)) + (emit-byte segment #b11011011) + (emit-fp-op segment src #b101))) + +(define-instruction ftst (segment) + (:printer floating-point-no ((op #b00100))) + (:emitter + (emit-byte segment #b11011001) + (emit-byte segment #b11100100))) + +;;; Compare and move ST(i) to ST0. +;;; +;;; Intel syntal: FCMOVcc ST, ST(i) +;;; +(define-instruction fcmov (segment cond src) + #+nil (:printer floating-point ((op '(#b01? #b???)))) + (:emitter + (assert (fp-reg-tn-p src)) + (emit-byte segment (ecase cond + ((:b :e :be :u) #b11011010) + ((:nb :ne :nbe :nu) #b11011011))) + (emit-fp-op segment src (ecase cond + ((:b :nb) #b000) + ((:e :ne) #b000) + ((:be :nbe) #b000) + ((:u nu) #b000))))) + +;;; +;;; 80387 Specials +;;; +;;; +(define-instruction fsqrt (segment) + (:printer floating-point-no ((op #b11010))) + (:emitter + (emit-byte segment #b11011001) + (emit-byte segment #b11111010))) + +(define-instruction fscale (segment) + (:printer floating-point-no ((op #b11101))) + (:emitter + (emit-byte segment #b11011001) + (emit-byte segment #b11111101))) + +(define-instruction fxtract (segment) + (:printer floating-point-no ((op #b10100))) + (:emitter + (emit-byte segment #b11011001) + (emit-byte segment #b11110100))) + +(define-instruction fsin (segment) + (:printer floating-point-no ((op #b11110))) + (:emitter + (emit-byte segment #b11011001) + (emit-byte segment #b11111110))) + +(define-instruction fcos (segment) + (:printer floating-point-no ((op #b11111))) + (:emitter + (emit-byte segment #b11011001) + (emit-byte segment #b11111111))) + +(define-instruction fprem1 (segment) + (:printer floating-point-no ((op #b10101))) + (:emitter + (emit-byte segment #b11011001) + (emit-byte segment #b11110101))) + +(define-instruction fprem (segment) + (:printer floating-point-no ((op #b11000))) + (:emitter + (emit-byte segment #b11011001) + (emit-byte segment #b11111000))) + +(define-instruction fxam (segment) + (:printer floating-point-no ((op #b00101))) + (:emitter + (emit-byte segment #b11011001) + (emit-byte segment #b11100101))) + +;;; These do push/pop to stack and need special handling +;;; in any VOPs that use them. See the book. + +;; st0 <- st1*log2(st0) +(define-instruction fyl2x (segment) ; POPS STACK + (:printer floating-point-no ((op #b10001))) + (:emitter + (emit-byte segment #b11011001) + (emit-byte segment #b11110001))) + +(define-instruction fyl2xp1 (segment) + (:printer floating-point-no ((op #b11001))) + (:emitter + (emit-byte segment #b11011001) + (emit-byte segment #b11111001))) + +(define-instruction f2xm1 (segment) + (:printer floating-point-no ((op #b10000))) + (:emitter + (emit-byte segment #b11011001) + (emit-byte segment #b11110000))) + +(define-instruction fptan (segment) ; st(0) <- 1; st(1) <- tan + (:printer floating-point-no ((op #b10010))) + (:emitter + (emit-byte segment #b11011001) + (emit-byte segment #b11110010))) + +(define-instruction fpatan (segment) ; POPS STACK + (:printer floating-point-no ((op #b10011))) + (:emitter + (emit-byte segment #b11011001) + (emit-byte segment #b11110011))) + +;;; load constant + +(define-instruction fldz (segment) + (:printer floating-point-no ((op #b01110))) + (:emitter + (emit-byte segment #b11011001) + (emit-byte segment #b11101110))) + +(define-instruction fld1 (segment) + (:printer floating-point-no ((op #b01000))) + (:emitter + (emit-byte segment #b11011001) + (emit-byte segment #b11101000))) + +(define-instruction fldpi (segment) + (:printer floating-point-no ((op #b01011))) + (:emitter + (emit-byte segment #b11011001) + (emit-byte segment #b11101011))) + +(define-instruction fldl2t (segment) + (:printer floating-point-no ((op #b01001))) + (:emitter + (emit-byte segment #b11011001) + (emit-byte segment #b11101001))) + +(define-instruction fldl2e (segment) + (:printer floating-point-no ((op #b01010))) + (:emitter + (emit-byte segment #b11011001) + (emit-byte segment #b11101010))) + +(define-instruction fldlg2 (segment) + (:printer floating-point-no ((op #b01100))) + (:emitter + (emit-byte segment #b11011001) + (emit-byte segment #b11101100))) + +(define-instruction fldln2 (segment) + (:printer floating-point-no ((op #b01101))) + (:emitter + (emit-byte segment #b11011001) + (emit-byte segment #b11101101))) diff --git a/compiler/amd64/macros.lisp b/compiler/amd64/macros.lisp new file mode 100644 index 0000000000000000000000000000000000000000..1e4d7f331524dc61887aafbcc3246e522a0f640c --- /dev/null +++ b/compiler/amd64/macros.lisp @@ -0,0 +1,553 @@ +;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; 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: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/amd64/macros.lisp,v 1.1 2004/05/24 22:35:00 cwang Exp $") +;;; +;;; ********************************************************************** +;;; +;;; This file contains the a bunch of handy macros for the amd64. +;;; +;;; Written by William Lott. +;;; +;;; Debugged by Paul F. Werkowski Spring/Summer 1995. +;;; Enhancements/debugging by Douglas T. Crosher 1996,1997,1998,1999. +;;; +(in-package :amd64) + + +;;; We can load/store into fp registers through the top of +;;; stack %st(0) (fr0 here). Loads imply a push to an empty register +;;; which then changes all the reg numbers. These macros help manage that. + +;;; Use this when don't have to load anything. It preserves old tos value +;;; But probably destroys tn with operation. +(defmacro with-tn@fp-top((tn) &body body) + `(progn + (unless (zerop (tn-offset ,tn)) + (inst fxch ,tn)) + ,@body + (unless (zerop (tn-offset ,tn)) + (inst fxch ,tn)))) + +;;; Use this to prepare for load of new value from memory. This +;;; changes the register numbering so the next instruction had better +;;; be a FP load from memory; a register load from another register +;;; will probably be loading the wrong register! +(defmacro with-empty-tn@fp-top((tn) &body body) + `(progn + (inst fstp ,tn) + ,@body + (unless (zerop (tn-offset ,tn)) + (inst fxch ,tn)))) ; save into new dest and restore st(0) + + +;;; Instruction-like macros. +(defmacro move (dst src) + "Move SRC into DST unless they are location=." + (once-only ((n-dst dst) + (n-src src)) + `(unless (location= ,n-dst ,n-src) + (inst mov ,n-dst ,n-src)))) + +(defmacro make-ea-for-object-slot (ptr slot lowtag) + `(make-ea :qword :base ,ptr :disp (- (* ,slot word-bytes) ,lowtag))) + +(defmacro loadw (value ptr &optional (slot 0) (lowtag 0)) + `(inst mov ,value (make-ea-for-object-slot ,ptr ,slot ,lowtag))) + +(defmacro storew (value ptr &optional (slot 0) (lowtag 0)) + (once-only ((value value)) + `(inst mov (make-ea-for-object-slot ,ptr ,slot ,lowtag) ,value))) + +(defmacro pushw (ptr &optional (slot 0) (lowtag 0)) + `(inst push (make-ea-for-object-slot ,ptr ,slot ,lowtag))) + +(defmacro popw (ptr &optional (slot 0) (lowtag 0)) + `(inst pop (make-ea-for-object-slot ,ptr ,slot ,lowtag))) + + +;;;; Macros to generate useful values. + +(defmacro load-symbol (reg symbol) + `(inst mov ,reg (+ nil-value (static-symbol-offset ,symbol)))) + +(defmacro load-symbol-value (reg symbol) + `(if (= (tn-offset ,reg) rax-offset) + ;; only rax can do this in one instruction + (inst mov ,reg + (make-ea :qword + :disp (+ nil-value + (static-symbol-offset ',symbol) + (ash symbol-value-slot word-shift) + (- other-pointer-type)))) + (progn + ;; other registers need 2 instructions + (inst mov ,reg + (+ nil-value + (static-symbol-offset ',symbol) + (ash symbol-value-slot word-shift) + (- other-pointer-type))) + (inst mov ,reg (make-ea :qword :base ,reg))))) + + +(defmacro store-symbol-value (reg symbol &optional temp) ; temp is unnecessary for rax + `(if (or (= (tn-offset ,reg) rax-offset) (not ,temp)) + ;; only rax can do this in one instruction + (inst mov + (make-ea :qword + :disp (+ nil-value + (static-symbol-offset ',symbol) + (ash symbol-value-slot word-shift) + (- other-pointer-type))) + ,reg) + (progn + ;; other registers need 2 instructions + (inst mov ,temp + (+ nil-value + (static-symbol-offset ',symbol) + (ash symbol-value-slot word-shift) + (- other-pointer-type))) + (inst mov (make-ea :qword :base ,temp) ,reg)))) + + +(defun symbol-value-address (symbol) + (+ nil-value + (static-symbol-offset symbol) + (ash symbol-value-slot word-shift) + (- other-pointer-type))) + +(defmacro load-type (target source &optional (offset 0)) + "Loads the type bits of a pointer into target independent of + byte-ordering issues." + (once-only ((n-target target) + (n-source source) + (n-offset offset)) + (ecase (backend-byte-order *target-backend*) + (:little-endian + `(inst mov ,n-target + (make-ea :byte :base ,n-source :disp ,n-offset))) + (:big-endian + `(inst mov ,n-target + (make-ea :byte :base ,n-source :disp (+ ,n-offset 3))))))) + +(defmacro load-foreign-data-symbol (reg name ) + #+linkage-table `(inst mov ,reg (make-fixup (extern-alien-name ,name) + :foreign-data)) + #-linkage-table `(inst lea ,reg (make-fixup (extern-alien-name ,name) + :foreign))) + +;; the right one to use +(defmacro load-foreign-data-symbol2 (reg name temp) + #+linkage-table `(progn + (inst mov-imm ,temp (make-fixup (extern-alien-name ,name) + :foreign-data)) + (inst mov ,reg (make-ea :qword :base ,temp))) + #-linkage-table `(inst lea ,reg (make-fixup (extern-alien-name ,name) + :foreign)) + ) + +;;;; Allocation helpers + +;;; Two allocation approaches are implemented. A call into C can be +;;; used where special care can be taken to disable +;;; interrupts. Alternatively with gencgc inline allocation is possible +;;; although it isn't interrupt safe. + +;;; For GENCGC it is possible to inline object allocation, to permit +;;; this set the following variable to True. +(defparameter *maybe-use-inline-allocation* t) + +(defun load-size (alloc-tn dst-tn size) + (unless (and (tn-p size) (location= alloc-tn size)) + (inst mov dst-tn size))) + +(defun inline-allocation (alloc-tn size temp-tn) + (let ((ok (gen-label))) + ;; + ;; Load the size first so that the size can be in the same + ;; register as alloc-tn. + (load-size alloc-tn alloc-tn size) + ;; + (inst mov temp-tn (symbol-value-address '*current-region-free-pointer*)) + (inst add alloc-tn (make-ea :qword :base temp-tn)) + (inst mov temp-tn (symbol-value-address '*current-region-end-addr*)) + (inst cmp alloc-tn (make-ea :qword :base temp-tn)) + (inst jmp :be OK) + ;; + ;; Dispatch to the appropriate overflow routine. There is a + ;; routine for each destination. + (inst mov-imm temp-tn + (make-fixup (extern-alien-name + (ecase (tn-offset alloc-tn) + (#.rax-offset "alloc_overflow_rax") + (#.rcx-offset "alloc_overflow_rcx") + (#.rdx-offset "alloc_overflow_rdx") + (#.rbx-offset "alloc_overflow_rbx") + (#.rsi-offset "alloc_overflow_rsi") + (#.rdi-offset "alloc_overflow_rdi"))) + :foreign)) + (inst call temp-tn) + (emit-label ok) + (inst mov temp-tn (symbol-value-address '*current-region-free-pointer*)) + (inst xchg (make-ea :qword :base temp-tn) alloc-tn)) + (values)) + +(defun not-inline-allocation (alloc-tn size temp-tn) + ;; C call to allocate via dispatch routines. Each destination has a + ;; special entry point. The size may be a register or a constant. + ;; This is used only if space is more important than speed. + (ecase (tn-offset alloc-tn) + (#.rax-offset + (load-size alloc-tn rax-tn size) + (inst mov-imm temp-tn (make-fixup (extern-alien-name "alloc_to_rax") + :foreign))) + (#.rcx-offset + (load-size alloc-tn rcx-tn size) + (inst mov-imm temp-tn (make-fixup (extern-alien-name "alloc_to_rcx") + :foreign))) + (#.rdx-offset + (load-size alloc-tn rdx-tn size) + (inst mov-imm temp-tn (make-fixup (extern-alien-name "alloc_to_rdx") + :foreign))) + (#.rbx-offset + (load-size alloc-tn rbx-tn size) + (inst mov-imm temp-tn (make-fixup (extern-alien-name "alloc_to_rbx") + :foreign))) + (#.rsi-offset + (load-size alloc-tn rsi-tn size) + (inst mov-imm temp-tn (make-fixup (extern-alien-name "alloc_to_rsi") + :foreign))) + (#.rdi-offset + (load-size alloc-tn rdi-tn size) + (inst mov-imm temp-tn (make-fixup (extern-alien-name "alloc_to_rdi") + :foreign)))) + (inst call temp-tn) + (values)) + +;;; +;;; Allocate SIZE bytes from the stack, storing a pointer to the +;;; allocated memory in ALLOC-TN. +;;; +(defun dynamic-extent-allocation (alloc-tn nbytes) + (inst sub rsp-tn nbytes) + (inst and rsp-tn #xfffffffffffffff0) ; alignment + (inst mov alloc-tn rsp-tn) + (values)) + +(defun allocation (alloc-tn size temp-tn &optional inline dynamic-extent) + "Allocate an object with a size in bytes given by Size. + The size may be an integer or a TN. + If Inline is a VOP node-var then it is used to make an appropriate + speed vs size decision. If Dynamic-Extent is true, and otherwise + appropriate, allocate from the stack." + (cond (dynamic-extent + (dynamic-extent-allocation alloc-tn size)) + ((and *maybe-use-inline-allocation* + (or (null inline) + (policy inline (>= speed space))) + (backend-featurep :gencgc)) + (inline-allocation alloc-tn size temp-tn)) + (t + (not-inline-allocation alloc-tn size temp-tn))) + (values)) + +(defmacro with-fixed-allocation ((result-tn type-code size temp-tn &optional inline) + &rest forms) + "Allocate an other-pointer object of fixed Size with a single + word header having the specified Type-Code. The result is placed in + Result-TN." + `(pseudo-atomic + (allocation ,result-tn (pad-data-block ,size) ,temp-tn ,inline) + (storew (logior (ash (1- ,size) vm:type-bits) ,type-code) ,result-tn) + (inst lea ,result-tn + (make-ea :byte :base ,result-tn :disp other-pointer-type)) + ,@forms)) + + +;;;; Error Code + +(eval-when (compile load eval) + (defun emit-error-break (vop kind code values) + (let ((vector (gensym)) + (length (gensym))) + `((inst int 3) ; i386 breakpoint instruction + ;; The return PC points here; note the location for the debugger. + (let ((vop ,vop)) + (when vop + (note-this-location vop :internal-error))) + (inst byte ,kind) ; eg trap_Xyyy + (let ((,vector (make-array 8 :element-type '(unsigned-byte 8) + :fill-pointer 0 :adjustable t))) + (write-var-integer (error-number-or-lose ',code) ,vector) + ,@(mapcar #'(lambda (tn) + `(let ((tn ,tn)) + (write-var-integer + (make-sc-offset (sc-number (tn-sc tn)) + ;; tn-offset is zero for constant tns. + (or (tn-offset tn) 0)) + ,vector))) + values) + (let ((,length (length ,vector))) + (inst byte ,length) + (dotimes (i ,length) + (inst byte (aref ,vector i))))))))) + +(defmacro error-call (vop error-code &rest values) + "Cause an error. ERROR-CODE is the error to cause." + (cons 'progn + (emit-error-break vop error-trap error-code values))) + + +(defmacro cerror-call (vop label error-code &rest values) + "Cause a continuable error. If the error is continued, execution resumes at + LABEL." + `(progn + ,@(emit-error-break vop cerror-trap error-code values) + (inst jmp ,label))) + +(defmacro generate-error-code (vop error-code &rest values) + "Generate-Error-Code Error-code Value* + Emit code for an error with the specified Error-Code and context Values." + `(assemble (*elsewhere*) + (let ((start-lab (gen-label))) + (emit-label start-lab) + (error-call ,vop ,error-code ,@values) + start-lab))) + +(defmacro generate-cerror-code (vop error-code &rest values) + "Generate-CError-Code Error-code Value* + Emit code for a continuable error with the specified Error-Code and + context Values. If the error is continued, execution resumes after + the GENERATE-CERROR-CODE form." + (let ((continue (gensym "CONTINUE-LABEL-")) + (error (gensym "ERROR-LABEL-"))) + `(let ((,continue (gen-label)) + (,error (gen-label))) + (emit-label ,continue) + (assemble (*elsewhere*) + (emit-label ,error) + (cerror-call ,vop ,continue ,error-code ,@values)) + ,error))) + + + +;;;; PSEUDO-ATOMIC. + +(defparameter *enable-pseudo-atomic* nil) ; remember to turn this back on + +;;; PSEUDO-ATOMIC -- Internal Interface. +;;; +(defmacro pseudo-atomic (&rest forms) + (let ((label (gensym "LABEL-"))) + `(let ((,label (gen-label))) + (when *enable-pseudo-atomic* + (inst mov (make-ea :byte :disp (+ nil-value + (static-symbol-offset + 'lisp::*pseudo-atomic-interrupted*) + (ash symbol-value-slot word-shift) + (- other-pointer-type))) + 0) + (inst mov (make-ea :byte :disp (+ nil-value + (static-symbol-offset + 'lisp::*pseudo-atomic-atomic*) + (ash symbol-value-slot word-shift) + (- other-pointer-type))) + (fixnumize 1))) + ,@forms + (when *enable-pseudo-atomic* + (inst mov (make-ea :byte :disp (+ nil-value + (static-symbol-offset + 'lisp::*pseudo-atomic-atomic*) + (ash symbol-value-slot word-shift) + (- other-pointer-type))) + 0) + (inst cmp (make-ea :byte + :disp (+ nil-value + (static-symbol-offset + 'lisp::*pseudo-atomic-interrupted*) + (ash symbol-value-slot word-shift) + (- other-pointer-type))) + 0) + (inst jmp :eq ,label) + (inst break pending-interrupt-trap) + (emit-label ,label))))) + + +;;;; Indexed references: + +(defmacro define-full-reffer (name type offset lowtag scs el-type &optional translate) + `(progn + (define-vop (,name) + ,@(when translate + `((:translate ,translate))) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg))) + (:arg-types ,type tagged-num) + (:results (value :scs ,scs)) + (:result-types ,el-type) + (:generator 3 ; pw was 5 + (inst mov value (make-ea :qword :base object :index index :scale 2 + :disp (- (* ,offset word-bytes) ,lowtag))))) + (define-vop (,(symbolicate name "-C")) + ,@(when translate + `((:translate ,translate))) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg))) + (:info index) + (:arg-types ,type (:constant (signed-byte 30))) + (:results (value :scs ,scs)) + (:result-types ,el-type) + (:generator 2 ; pw was 5 + (inst mov value (make-ea :qword :base object + :disp (- (* (+ ,offset index) word-bytes) + ,lowtag))))))) + +(defmacro define-full-setter (name type offset lowtag scs el-type &optional translate) + `(progn + (define-vop (,name) + ,@(when translate + `((:translate ,translate))) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg)) + (value :scs ,scs :target result)) + (:arg-types ,type tagged-num ,el-type) + (:results (result :scs ,scs)) + (:result-types ,el-type) + (:generator 4 ; was 5 + (inst mov (make-ea :qword :base object :index index :scale 2 + :disp (- (* ,offset word-bytes) ,lowtag)) + value) + (move result value))) + (define-vop (,(symbolicate name "-C")) + ,@(when translate + `((:translate ,translate))) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (value :scs ,scs :target result)) + (:info index) + (:arg-types ,type (:constant (signed-byte 30)) ,el-type) + (:results (result :scs ,scs)) + (:result-types ,el-type) + (:generator 3 ; was 5 + (inst mov (make-ea :qword :base object + :disp (- (* (+ ,offset index) word-bytes) ,lowtag)) + value) + (move result value))))) + +(defmacro define-half-reffer (name type offset lowtag scs el-type &optional translate) + `(progn + (define-vop (,name) + ,@(when translate + `((:translate ,translate))) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg))) + (:arg-types ,type tagged-num) + (:results (value :scs ,scs)) + (:result-types ,el-type) + (:generator 3 ; pw was 5 + ;; high 32 bits of doubleword operands are zero + ;; extended to 64 bits + (inst mov (64-bit-to-32-bit-tn value) + (make-ea :dword :base object :index index + :disp (- (* ,offset word-bytes) ,lowtag))))) + (define-vop (,(symbolicate name "-C")) + ,@(when translate + `((:translate ,translate))) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg))) + (:info index) + (:arg-types ,type (:constant (signed-byte 30))) + (:results (value :scs ,scs)) + (:result-types ,el-type) + (:generator 2 ; pw was 5 + (inst mov (64-bit-to-32-bit-tn value) + (make-ea :dword :base object + :disp (- (+ (* ,offset word-bytes) (* index 4)) + ,lowtag))))))) + +(defmacro define-half-setter (name type offset lowtag scs el-type &optional translate) + `(progn + (define-vop (,name) + ,@(when translate + `((:translate ,translate))) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg)) + (value :scs ,scs :target result)) + (:arg-types ,type tagged-num ,el-type) + (:results (result :scs ,scs)) + (:result-types ,el-type) + (:generator 4 ; was 5 + (inst mov (make-ea :dword :base object :index index + :disp (- (* ,offset word-bytes) ,lowtag)) + (64-bit-to-32-bit-tn value)) + (move result value))) + (define-vop (,(symbolicate name "-C")) + ,@(when translate + `((:translate ,translate))) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (value :scs ,scs :target result)) + (:info index) + (:arg-types ,type (:constant (signed-byte 30)) ,el-type) + (:results (result :scs ,scs)) + (:result-types ,el-type) + (:generator 3 ; was 5 + (inst mov (make-ea :dword :base object + :disp (- (+ (* index 4) (* ,offset word-bytes)) ,lowtag)) + (64-bit-to-32-bit-tn value)) + (move result value))))) + +(defmacro define-full-conditional-setter (name type offset lowtag scs el-type + &optional translate) + `(progn + (define-vop (,name) + ,@(when translate + `((:translate ,translate))) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg) :to :result) + (index :scs (any-reg) :to :result) + (old-value :scs ,scs :target rax) + (new-value :scs ,scs)) + (:arg-types ,type tagged-num ,el-type ,el-type) + (:temporary (:sc ,(first scs) :offset rax-offset + :from (:argument 2) :to :result :target result) rax) + (:results (result :scs ,scs)) + (:result-types ,el-type) + (:guard (backend-featurep :i486)) + (:generator 5 + (move rax old-value) + (inst cmpxchg (make-ea :qword :base object :index index :scale 1 + :disp (- (* ,offset word-bytes) ,lowtag)) + new-value) + (move result rax))) + (define-vop (,(symbolicate name "-C")) + ,@(when translate + `((:translate ,translate))) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg) :to :result) + (old-value :scs ,scs :target rax) + (new-value :scs ,scs)) + (:info index) + (:arg-types ,type (:constant (signed-byte 30)) ,el-type ,el-type) + (:temporary (:sc ,(first scs) :offset rax-offset + :from (:argument 1) :to :result :target result) rax) + (:results (result :scs ,scs)) + (:result-types ,el-type) + (:guard (backend-featurep :i486)) + (:generator 4 + (move rax old-value) + (inst cmpxchg (make-ea :qword :base object + :disp (- (* (+ ,offset index) word-bytes) + ,lowtag)) + new-value) + (move result rax))))) diff --git a/compiler/amd64/memory.lisp b/compiler/amd64/memory.lisp new file mode 100644 index 0000000000000000000000000000000000000000..0556cf485a7bb2f5cd8803679caa806a2909dd5c --- /dev/null +++ b/compiler/amd64/memory.lisp @@ -0,0 +1,185 @@ +;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; 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: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/amd64/memory.lisp,v 1.1 2004/05/24 22:35:00 cwang Rel $") +;;; +;;; ********************************************************************** +;;; +;;; This file contains the x86 definitions of some general purpose memory +;;; reference VOPs inherited by basic memory reference operations. +;;; +;;; Written by William Lott. +;;; +;;; Debugged by Paul F. Werkowski Spring/Summer 1995. +;;; Enhancements/debugging by Douglas T. Crosher 1996,1997,1999. +;;; + +(in-package :amd64) + +;;; Cell-Ref and Cell-Set are used to define VOPs like CAR, where the offset to +;;; be read or written is a property of the VOP used. Cell-Setf is similar to +;;; Cell-Set, but delivers the new value as the result. Cell-Setf-Function +;;; takes its arguments as if it were a setf function (new value first, as +;;; apposed to a setf macro, which takes the new value last). +;;; +(define-vop (cell-ref) + (:args (object :scs (descriptor-reg))) + (:results (value :scs (descriptor-reg any-reg))) + (:variant-vars offset lowtag) + (:policy :fast-safe) + (:generator 4 + (loadw value object offset lowtag))) +;;; +(define-vop (cell-set) + (:args (object :scs (descriptor-reg)) + (value :scs (descriptor-reg any-reg))) + (:variant-vars offset lowtag) + (:policy :fast-safe) + (:generator 4 + (storew value object offset lowtag))) +;;; +(define-vop (cell-setf) + (:args (object :scs (descriptor-reg)) + (value :scs (descriptor-reg any-reg) :target result)) + (:results (result :scs (descriptor-reg any-reg))) + (:variant-vars offset lowtag) + (:policy :fast-safe) + (:generator 4 + (storew value object offset lowtag) + (move result value))) +;;; +(define-vop (cell-setf-function) + (:args (value :scs (descriptor-reg any-reg) :target result) + (object :scs (descriptor-reg))) + (:results (result :scs (descriptor-reg any-reg))) + (:variant-vars offset lowtag) + (:policy :fast-safe) + (:generator 4 + (storew value object offset lowtag) + (move result value))) + +;;; Define-Cell-Accessors -- Interface +;;; +;;; Define accessor VOPs for some cells in an object. If the operation name +;;; is NIL, then that operation isn't defined. If the translate function is +;;; null, then we don't define a translation. +;;; +(defmacro define-cell-accessors (offset lowtag + ref-op ref-trans set-op set-trans) + `(progn + ,@(when ref-op + `((define-vop (,ref-op cell-ref) + (:variant ,offset ,lowtag) + ,@(when ref-trans + `((:translate ,ref-trans)))))) + ,@(when set-op + `((define-vop (,set-op cell-setf) + (:variant ,offset ,lowtag) + ,@(when set-trans + `((:translate ,set-trans)))))))) + +(define-vop (cell-set-conditional) + (:args (object :scs (descriptor-reg) :to :eval) + (old-value :scs (descriptor-reg any-reg) :target rax) + (new-value :scs (descriptor-reg any-reg))) + (:temporary (:sc descriptor-reg :offset rax-offset + :from (:argument 1) :to :result :target result) rax) + (:variant-vars offset lowtag) + (:results (result :scs (descriptor-reg any-reg))) + (:guard (backend-featurep :i486)) + (:generator 4 + (move rax old-value) + (inst cmpxchg (make-ea :qword :base object + :disp (- (* offset word-bytes) lowtag)) + new-value) + (move result rax))) + +;;; X86 special +(define-vop (cell-xadd) + (:args (object :scs (descriptor-reg) :to :result) + (value :scs (any-reg) :target result)) + (:results (result :scs (any-reg) :from (:argument 1))) + (:result-types tagged-num) + (:variant-vars offset lowtag) + (:policy :fast-safe) + (:generator 4 + (move result value) + (inst xadd (make-ea :qword :base object + :disp (- (* offset word-bytes) lowtag)) + value))) + +;;; Slot-Ref and Slot-Set are used to define VOPs like Closure-Ref, where the +;;; offset is constant at compile time, but varies for different uses. +;;; +(define-vop (slot-ref) + (:args (object :scs (descriptor-reg))) + (:results (value :scs (descriptor-reg any-reg))) + (:variant-vars base lowtag) + (:info offset) + (:generator 4 + (loadw value object (+ base offset) lowtag))) +;;; +(define-vop (slot-set) + (:args (object :scs (descriptor-reg)) + (value :scs (descriptor-reg any-reg immediate))) + (:variant-vars base lowtag) + (:info offset) + (:generator 4 + (if (sc-is value immediate) + (let ((val (tn-value value))) + (etypecase val + (integer + (inst mov + (make-ea :qword :base object + :disp (- (* (+ base offset) word-bytes) lowtag)) + (fixnumize val))) + (symbol + (inst mov + (make-ea :qword :base object + :disp (- (* (+ base offset) word-bytes) lowtag)) + (+ nil-value (static-symbol-offset val)))) + (character + (inst mov + (make-ea :qword :base object + :disp (- (* (+ base offset) word-bytes) lowtag)) + (logior (ash (char-code val) type-bits) + base-char-type))))) + ;; Else, value not immediate. + (storew value object (+ base offset) lowtag)))) + +(define-vop (slot-set-conditional) + (:args (object :scs (descriptor-reg) :to :eval) + (old-value :scs (descriptor-reg any-reg) :target rax) + (new-value :scs (descriptor-reg any-reg))) + (:temporary (:sc descriptor-reg :offset rax-offset + :from (:argument 1) :to :result :target result) rax) + (:variant-vars base lowtag) + (:results (result :scs (descriptor-reg any-reg))) + (:info offset) + (:guard (backend-featurep :i486)) + (:generator 4 + (move rax old-value) + (inst cmpxchg (make-ea :qword :base object + :disp (- (* (+ base offset) word-bytes) lowtag)) + new-value) + (move result rax))) + +;;; X86 special +(define-vop (slot-xadd) + (:args (object :scs (descriptor-reg) :to :result) + (value :scs (any-reg) :target result)) + (:results (result :scs (any-reg) :from (:argument 1))) + (:result-types tagged-num) + (:variant-vars base lowtag) + (:info offset) + (:generator 4 + (move result value) + (inst xadd (make-ea :qword :base object + :disp (- (* (+ base offset) word-bytes) lowtag)) + value))) diff --git a/compiler/amd64/move.lisp b/compiler/amd64/move.lisp new file mode 100644 index 0000000000000000000000000000000000000000..6a6a678d127c1a81ff0a395580630a0f43c4390f --- /dev/null +++ b/compiler/amd64/move.lisp @@ -0,0 +1,439 @@ +;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; 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: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/amd64/move.lisp,v 1.1 2004/05/24 22:35:00 cwang Exp $") +;;; +;;; ********************************************************************** +;;; +;;; This file contains the AMD64 VM definition of operand loading/saving and +;;; the Move VOP. +;;; +;;; Written by William Lott. +;;; +;;; Debugged by Paul F. Werkowski Spring/Summer 1995. +;;; Enhancements/debugging by Douglas T. Crosher 1996,1997. +;;; +(in-package :amd64) + +(define-move-function (load-immediate 1) (vop x y) + ((immediate) + (any-reg descriptor-reg)) + (let ((val (tn-value x))) + (etypecase val + (integer + (if (zerop val) + (inst xor y y) + (inst mov y (fixnumize val)))) + (symbol + (load-symbol y val)) + (character + (inst mov y (logior (ash (char-code val) type-bits) + base-char-type)))))) + +(define-move-function (load-number 1) (vop x y) + ((immediate) (signed-reg unsigned-reg)) + (inst mov y (tn-value x))) + +(define-move-function (load-base-char 1) (vop x y) + ((immediate) (base-char-reg)) + (inst mov y (char-code (tn-value x)))) + +(define-move-function (load-system-area-pointer 1) (vop x y) + ((immediate) (sap-reg)) + (inst mov y (sap-int (tn-value x)))) + +(define-move-function (load-constant 5) (vop x y) + ((constant) (descriptor-reg any-reg)) + (inst mov y x)) + +(define-move-function (load-stack 5) (vop x y) + ((control-stack) (any-reg descriptor-reg) + (base-char-stack) (base-char-reg) + (sap-stack) (sap-reg) + (signed-stack) (signed-reg) + (unsigned-stack) (unsigned-reg)) + (inst mov y x)) + +(define-move-function (store-stack 5) (vop x y) + ((any-reg descriptor-reg) (control-stack) + (base-char-reg) (base-char-stack) + (sap-reg) (sap-stack) + (signed-reg) (signed-stack) + (unsigned-reg) (unsigned-stack)) + (inst mov y x)) + + +;;;; The Move VOP: +;;; +(define-vop (move) + (:args (x :scs (any-reg descriptor-reg immediate) :target y + :load-if (not (location= x y)))) + (:results (y :scs (any-reg descriptor-reg) + :load-if + (not (or (location= x y) + (and (sc-is x any-reg descriptor-reg immediate) + (sc-is y control-stack)))))) + (:effects) + (:affected) + (:generator 0 + (if (and (sc-is x immediate) + (sc-is y any-reg descriptor-reg control-stack)) + (let ((val (tn-value x))) + (etypecase val + (integer + (if (and (zerop val) (sc-is y any-reg descriptor-reg)) + (inst xor y y) + (inst mov y (fixnumize val)))) + (symbol + (inst mov y (+ nil-value (static-symbol-offset val)))) + (character + (inst mov y (logior (ash (char-code val) type-bits) + base-char-type))))) + (move y x)))) + +(define-move-vop move :move + (any-reg descriptor-reg immediate) + (any-reg descriptor-reg)) + + +;;; Make Move the check VOP for T so that type check generation doesn't think +;;; it is a hairy type. This also allows checking of a few of the values in a +;;; continuation to fall out. +;;; +(primitive-type-vop move (:check) t) + +;;; The Move-Argument VOP is used for moving descriptor values into another +;;; frame for argument or known value passing. +;;; +;;; Note: It is not going to be possible to move a constant directly +;;; to another frame, except if the destination is a register and in +;;; this case the loading works out. +(define-vop (move-argument) + (:args (x :scs (any-reg descriptor-reg immediate) :target y + :load-if (not (and (sc-is y any-reg descriptor-reg) + (sc-is x control-stack)))) + (fp :scs (any-reg) + :load-if (not (sc-is y any-reg descriptor-reg)))) + (:results (y)) + (:generator 0 + (sc-case y + ((any-reg descriptor-reg) + (if (sc-is x immediate) + (let ((val (tn-value x))) + (etypecase val + (integer + (if (zerop val) + (inst xor y y) + (inst mov y (fixnumize val)))) + (symbol + (load-symbol y val)) + (character + (inst mov y (logior (ash (char-code val) type-bits) + base-char-type))))) + (move y x))) + ((control-stack) + (if (sc-is x immediate) + (let ((val (tn-value x))) + (if (= (tn-offset fp) rsp-offset) + ;; C-call + (etypecase val + (integer + (storew (fixnumize val) fp (tn-offset y))) + (symbol + (storew (+ nil-value (static-symbol-offset val)) + fp (tn-offset y))) + (character + (storew (logior (ash (char-code val) type-bits) + base-char-type) + fp (tn-offset y)))) + ;; Lisp stack + (etypecase val + (integer + (storew (fixnumize val) fp (- (1+ (tn-offset y))))) + (symbol + (storew (+ nil-value (static-symbol-offset val)) + fp (- (1+ (tn-offset y))))) + (character + (storew (logior (ash (char-code val) type-bits) + base-char-type) + fp (- (1+ (tn-offset y)))))))) + (if (= (tn-offset fp) rsp-offset) + ;; C-call + (storew x fp (tn-offset y)) + ;; Lisp stack + (storew x fp (- (1+ (tn-offset y)))))))))) + +;;; +(define-move-vop move-argument :move-argument + (any-reg descriptor-reg) + (any-reg descriptor-reg)) + + + +;;;; ILLEGAL-MOVE + +;;; This VOP exists just to begin the lifetime of a TN that couldn't be written +;;; legally due to a type error. An error is signalled before this VOP is +;;; so we don't need to do anything (not that there would be anything sensible +;;; to do anyway.) +;;; +(define-vop (illegal-move) + (:args (x) (type)) + (:results (y)) + (:ignore y) + (:vop-var vop) + (:save-p :compute-only) + (:generator 666 + (error-call vop object-not-type-error x type))) + + + +;;;; Moves and coercions: + +;;; These MOVE-TO-WORD VOPs move a tagged integer to a raw full-word +;;; representation. Similarly, the MOVE-FROM-WORD VOPs converts a raw integer +;;; to a tagged bignum or fixnum. + +;;; Arg is a fixnum, so just shift it. We need a type restriction because some +;;; possible arg SCs (control-stack) overlap with possible bignum arg SCs. +;;; +(define-vop (move-to-word/fixnum) + (:args (x :scs (any-reg descriptor-reg) :target y + :load-if (not (location= x y)))) + (:results (y :scs (signed-reg unsigned-reg) + :load-if (not (location= x y)))) + (:arg-types tagged-num) + (:note "fixnum untagging") + (:generator 1 + (move y x) + (inst sar y 2))) +;;; +(define-move-vop move-to-word/fixnum :move + (any-reg descriptor-reg) (signed-reg unsigned-reg)) + +;;; Arg is a non-immediate constant, load it. +(define-vop (move-to-word-c) + (:args (x :scs (constant))) + (:results (y :scs (signed-reg unsigned-reg))) + (:note "constant load") + (:generator 1 + (inst mov y (tn-value x)))) +;;; +(define-move-vop move-to-word-c :move + (constant) (signed-reg unsigned-reg)) + + +;;; Arg is a fixnum or bignum, figure out which and load if necessary. +(define-vop (move-to-word/integer) + (:args (x :scs (descriptor-reg) :target rax)) + (:results (y :scs (signed-reg unsigned-reg))) + (:note "integer to untagged word coercion") + (:temporary (:sc unsigned-reg :offset rax-offset + :from (:argument 0) :to (:result 0) :target y) rax) + (:generator 4 + (move rax x) + (inst test al-tn 3) + (inst jmp :z fixnum) + (loadw y rax bignum-digits-offset other-pointer-type) + (inst jmp done) + FIXNUM + (inst sar rax 2) + (move y rax) + DONE)) +;;; +(define-move-vop move-to-word/integer :move + (descriptor-reg) (signed-reg unsigned-reg)) + + +;;; Result is a fixnum, so we can just shift. We need the result type +;;; restriction because of the control-stack ambiguity noted above. +;;; +(define-vop (move-from-word/fixnum) + (:args (x :scs (signed-reg unsigned-reg) :target y + :load-if (not (location= x y)))) + (:results (y :scs (any-reg descriptor-reg) + :load-if (not (location= x y)))) + (:result-types tagged-num) + (:note "fixnum tagging") + (:generator 1 + (cond ((and (sc-is x signed-reg unsigned-reg) + (not (location= x y))) + ;; Uses 7 bytes, but faster on the Pentium + (inst lea y (make-ea :qword :index x :scale 4))) + (t + ;; Uses: If x is a reg 2 + 3; if x = y uses only 3 bytes + (move y x) + (inst shl y 2))))) +;;; +(define-move-vop move-from-word/fixnum :move + (signed-reg unsigned-reg) (any-reg descriptor-reg)) + +;;; Result may be a bignum, so we have to check. Use a worst-case cost to make +;;; sure people know they may be number consing. +;;; +#+nil +(define-vop (move-from-signed) + (:args (x :scs (signed-reg unsigned-reg) :target rax)) + (:temporary (:sc unsigned-reg :offset rax-offset :from (:argument 0)) rax) + (:temporary (:sc unsigned-reg :offset rbx-offset :to (:result 0) :target y) + rbx) + (:temporary (:sc unsigned-reg :offset rcx-offset + :from (:argument 0) :to (:result 0)) rcx) + (:ignore rcx) + (:results (y :scs (any-reg descriptor-reg))) + (:note "signed word to integer coercion") + (:generator 20 + (move rax x) + (inst call (make-fixup 'move-from-signed :assembly-routine)) + (move y rbx))) +;;; +;;; Faster inline version, +(define-vop (move-from-signed) + (:args (x :scs (signed-reg unsigned-reg) :to :result)) + (:results (y :scs (any-reg descriptor-reg) :from :argument)) + (:temporary (:sc any-reg) temp) + (:note "signed word to integer coercion") + (:node-var node) + (:generator 20 + (assert (not (location= x y))) + (let ((bignum (gen-label)) + (done (gen-label))) + (inst mov y x) + (inst shl y 1) + (inst jmp :o bignum) + (inst shl y 1) + (inst jmp :o bignum) + (emit-label done) + + (assemble (*elsewhere*) + (emit-label bignum) + (with-fixed-allocation + (y bignum-type (+ bignum-digits-offset 1) temp node) + (storew x y bignum-digits-offset other-pointer-type)) + (inst jmp done))))) +;;; +(define-move-vop move-from-signed :move + (signed-reg) (descriptor-reg)) + + +;;; Check for fixnum, and possibly allocate one or two word bignum result. Use +;;; a worst-case cost to make sure people know they may be number consing. +;;; +#+nil +(define-vop (move-from-unsigned) + (:args (x :scs (signed-reg unsigned-reg) :target rax)) + (:temporary (:sc unsigned-reg :offset rax-offset :from (:argument 0)) rax) + (:temporary (:sc unsigned-reg :offset rbx-offset :to (:result 0) :target y) + rbx) + (:temporary (:sc unsigned-reg :offset rcx-offset + :from (:argument 0) :to (:result 0)) rcx) + (:ignore rcx) + (:results (y :scs (any-reg descriptor-reg))) + (:note "unsigned word to integer coercion") + (:generator 20 + (move rax x) + (inst call (make-fixup 'move-from-unsigned :assembly-routine)) + (move y rbx))) +;;; +;;; Faster inline version. +(define-vop (move-from-unsigned) + (:args (x :scs (signed-reg unsigned-reg) :to :save)) + (:temporary (:sc unsigned-reg) alloc) + (:results (y :scs (any-reg descriptor-reg))) + (:node-var node) + (:note "unsigned word to integer coercion") + (:generator 20 + (assert (not (location= x y))) + (assert (not (location= x alloc))) + (assert (not (location= y alloc))) + (let ((bignum (gen-label)) + (done (gen-label)) + (one-word-bignum (gen-label)) + (l1 (gen-label))) + (inst mov alloc #xe000000000000000) ; 111000..... + (inst test x alloc) + (inst jmp :nz bignum) + ;; Fixnum. + (inst lea y (make-ea :qword :index x :scale 4)) ; Faster but bigger. + (emit-label done) + + (assemble (*elsewhere*) + (emit-label bignum) + ;; Note: As on the mips port, space for a two word bignum is + ;; always allocated and the header size is set to either one + ;; or two words as appropriate. + (inst jmp :ns one-word-bignum) + ;; Two word bignum. + (inst mov y (logior (ash (1- (+ bignum-digits-offset 2)) vm:type-bits) + bignum-type)) + (inst jmp l1) + (emit-label one-word-bignum) + (inst mov y (logior (ash (1- (+ bignum-digits-offset 1)) vm:type-bits) + bignum-type)) + (emit-label l1) + (pseudo-atomic + ;; We don't have enough registers. So I'm using y here + ;; We can fix it when we use r8-r15 + (inst push y) + (allocation alloc (pad-data-block (+ bignum-digits-offset 2)) y node) + (inst pop y) + (storew y alloc) + (inst lea y (make-ea :byte :base alloc :disp other-pointer-type)) + (storew x y bignum-digits-offset other-pointer-type)) + (inst jmp done))))) +;;; +(define-move-vop move-from-unsigned :move + (unsigned-reg) (descriptor-reg)) + + +;;; Move untagged numbers. +;;; +(define-vop (word-move) + (:args (x :scs (signed-reg unsigned-reg) :target y + :load-if (not (location= x y)))) + (:results (y :scs (signed-reg unsigned-reg) + :load-if + (not (or (location= x y) + (and (sc-is x signed-reg unsigned-reg) + (sc-is y signed-stack unsigned-stack)))))) + (:effects) + (:affected) + (:note "word integer move") + (:generator 0 + (move y x))) +;;; +(define-move-vop word-move :move + (signed-reg unsigned-reg) (signed-reg unsigned-reg)) + +;;; Move untagged number arguments/return-values. +;;; +(define-vop (move-word-argument) + (:args (x :scs (signed-reg unsigned-reg) :target y) + (fp :scs (any-reg) :load-if (not (sc-is y sap-reg)))) + (:results (y)) + (:note "word integer argument move") + (:generator 0 + (sc-case y + ((signed-reg unsigned-reg) + (move y x)) + ((signed-stack unsigned-stack) + (if (= (tn-offset fp) rsp-offset) + (storew x fp (tn-offset y)) ; c-call + (storew x fp (- (1+ (tn-offset y))))))))) + +;;; +(define-move-vop move-word-argument :move-argument + (descriptor-reg any-reg signed-reg unsigned-reg) (signed-reg unsigned-reg)) + + +;;; Use standard MOVE-ARGUMENT + coercion to move an untagged number to a +;;; descriptor passing location. +;;; +(define-move-vop move-argument :move-argument + (signed-reg unsigned-reg) (any-reg descriptor-reg)) diff --git a/compiler/amd64/nlx.lisp b/compiler/amd64/nlx.lisp new file mode 100644 index 0000000000000000000000000000000000000000..42cd5c7acf9e173063142bb9dd0c995304d69225 --- /dev/null +++ b/compiler/amd64/nlx.lisp @@ -0,0 +1,264 @@ +;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; 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: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/amd64/nlx.lisp,v 1.1 2004/05/24 22:35:00 cwang Exp $") +;;; +;;; ********************************************************************** +;;; +;;; This file contains the VM definition of non-local exit for the x86. +;;; +;;; Written by William Lott. +;;; +;;; Debugged by Paul F. Werkowski Spring/Summer 1995. +;;; Enhancements/debugging by Douglas T. Crosher 1996,1997,1998. +;;; +(in-package :amd64) + +;;; MAKE-NLX-SP-TN -- Interface +;;; +;;; Make an environment-live stack TN for saving the SP for NLX entry. +;;; +(def-vm-support-routine make-nlx-sp-tn (env) + (environment-live-tn + (make-representation-tn *fixnum-primitive-type* any-reg-sc-number) + env)) + +;;; Make-NLX-Entry-Argument-Start-Location -- Interface +;;; +;;; Make a TN for the argument count passing location for a +;;; non-local entry. +;;; +(def-vm-support-routine make-nlx-entry-argument-start-location () + (make-wired-tn *fixnum-primitive-type* any-reg-sc-number rbx-offset)) + +(defun catch-block-ea (tn) + (assert (sc-is tn catch-block)) + (make-ea :qword :base rbp-tn + :disp (- (* (+ (tn-offset tn) catch-block-size) word-bytes)))) + + +;;; Save and restore dynamic environment. +;;; +;;; These VOPs are used in the reentered function to restore the +;;; appropriate dynamic environment. Currently we only save the +;;; Current-Catch, the eval stack pointer, and the alien stack +;;; pointer. +;;; +;;; We don't need to save/restore the current unwind-protect, since +;;; unwind-protects are implicitly processed during unwinding. +;;; +;;; We don't need to save the BSP, because that is handled automatically. + +;;; Make-Dynamic-State-TNs -- Interface +;;; +;;; Return a list of TNs that can be used to snapshot the dynamic state for +;;; use with the Save/Restore-Dynamic-Environment VOPs. +;;; +(def-vm-support-routine make-dynamic-state-tns () + (make-n-tns 3 *any-primitive-type*)) + +(define-vop (save-dynamic-state) + (:results (catch :scs (descriptor-reg)) + (eval :scs (descriptor-reg)) + (alien-stack :scs (descriptor-reg))) + (:generator 13 + (load-symbol-value catch lisp::*current-catch-block*) + (load-symbol-value eval lisp::*eval-stack-top*) + (load-symbol-value alien-stack *alien-stack*))) + +(define-vop (restore-dynamic-state) + (:args (catch :scs (descriptor-reg)) + (eval :scs (descriptor-reg)) + (alien-stack :scs (descriptor-reg))) + (:temporary (:sc descriptor-reg) temp) + (:generator 10 + (store-symbol-value catch lisp::*current-catch-block* temp) + (store-symbol-value eval lisp::*eval-stack-top* temp) + (store-symbol-value alien-stack *alien-stack* temp))) + +(define-vop (current-stack-pointer) + (:results (res :scs (any-reg control-stack))) + (:generator 1 + (move res rsp-tn))) + +(define-vop (current-binding-pointer) + (:results (res :scs (any-reg descriptor-reg))) + (:generator 1 + (load-symbol-value res *binding-stack-pointer*))) + + +;;;; Unwind block hackery: + +;;; Compute the address of the catch block from its TN, then store into the +;;; block the current Fp, Env, Unwind-Protect, and the entry PC. + +(define-vop (make-unwind-block) + (:args (tn)) + (:info entry-label) + (:temporary (:sc unsigned-reg) temp) + (:results (block :scs (any-reg))) + (:generator 22 + (inst lea block (catch-block-ea tn)) + (load-symbol-value temp lisp::*current-unwind-protect-block*) + (storew temp block unwind-block-current-uwp-slot) + (storew rbp-tn block unwind-block-current-cont-slot) + (storew (make-fixup nil :code-object entry-label) + block catch-block-entry-pc-slot))) + +;;; Like Make-Unwind-Block, except that we also store in the specified tag, and +;;; link the block into the Current-Catch list. +;;; + +(define-vop (make-catch-block) + (:args (tn) + (tag :scs (descriptor-reg any-reg) :to (:result 1))) + (:info entry-label) + (:results (block :scs (any-reg))) + (:temporary (:sc descriptor-reg) temp) + (:generator 44 + (inst lea block (catch-block-ea tn)) + (load-symbol-value temp lisp::*current-unwind-protect-block*) + (storew temp block unwind-block-current-uwp-slot) + (storew rbp-tn block unwind-block-current-cont-slot) + (storew (make-fixup nil :code-object entry-label) + block catch-block-entry-pc-slot) + (storew tag block catch-block-tag-slot) + (load-symbol-value temp lisp::*current-catch-block*) + (storew temp block catch-block-previous-catch-slot) + (store-symbol-value block lisp::*current-catch-block* temp))) + +;;; Just set the current unwind-protect to TN's address. This instantiates an +;;; unwind block as an unwind-protect. +;;; +(define-vop (set-unwind-protect) + (:args (tn)) + (:temporary (:sc unsigned-reg) new-uwp) + (:generator 7 + (inst lea new-uwp (catch-block-ea tn)) + (store-symbol-value new-uwp lisp::*current-unwind-protect-block*))) + +(define-vop (unlink-catch-block) + (:temporary (:sc unsigned-reg) block) + (:policy :fast-safe) + (:translate %catch-breakup) + (:generator 17 + (load-symbol-value block lisp::*current-catch-block*) + (loadw block block catch-block-previous-catch-slot) + (store-symbol-value block lisp::*current-catch-block*))) + +(define-vop (unlink-unwind-protect) + (:temporary (:sc unsigned-reg) block) + (:policy :fast-safe) + (:translate %unwind-protect-breakup) + (:generator 17 + (load-symbol-value block lisp::*current-unwind-protect-block*) + (loadw block block unwind-block-current-uwp-slot) + (store-symbol-value block lisp::*current-unwind-protect-block*))) + + +;;;; NLX entry VOPs: +(define-vop (nlx-entry) + ;; Note: we can't list an sc-restriction, 'cause any load vops would + ;; be inserted before the return-pc label. + (:args (sp) + (start) + (count)) + (:results (values :more t)) + (:temporary (:sc descriptor-reg) move-temp) + (:info label nvals) + (:save-p :force-to-stack) + (:vop-var vop) + (:generator 30 + (emit-label label) + (note-this-location vop :non-local-entry) + (cond ((zerop nvals)) + ((= nvals 1) + (let ((no-values (gen-label))) + (inst mov (tn-ref-tn values) nil-value) + (inst jecxz no-values) + (loadw (tn-ref-tn values) start -1) + (emit-label no-values))) + (t + (collect ((defaults)) + (do ((i 0 (1+ i)) + (tn-ref values (tn-ref-across tn-ref))) + ((null tn-ref)) + (let ((default-lab (gen-label)) + (tn (tn-ref-tn tn-ref))) + (defaults (cons default-lab tn)) + + (inst cmp count (fixnumize i)) + (inst jmp :le default-lab) + (sc-case tn + ((descriptor-reg any-reg) + (loadw tn start (- (1+ i)))) + ((control-stack) + (loadw move-temp start (- (1+ i))) + (inst mov tn move-temp))))) + (let ((defaulting-done (gen-label))) + (emit-label defaulting-done) + (assemble (*elsewhere*) + (dolist (def (defaults)) + (emit-label (car def)) + (inst mov (cdr def) nil-value)) + (inst jmp defaulting-done)))))) + (inst mov rsp-tn sp))) + +(define-vop (nlx-entry-multiple) + (:args (top) + (source) + (count :target rcx)) + ;; Again, no SC restrictions for the args, 'cause the loading would + ;; happen before the entry label. + (:info label) + (:temporary (:sc unsigned-reg :offset rcx-offset :from (:argument 2)) rcx) + (:temporary (:sc unsigned-reg :offset rsi-offset) rsi) + (:temporary (:sc unsigned-reg :offset rdi-offset) rdi) + (:results (result :scs (any-reg) :from (:argument 0)) + (num :scs (any-reg control-stack))) + (:save-p :force-to-stack) + (:vop-var vop) + (:generator 30 + (emit-label label) + (note-this-location vop :non-local-entry) + + (inst lea rsi (make-ea :qword :base source :disp (- word-bytes))) + ;; The 'top' arg contains the %esp value saved at the time the + ;; catch block was created and points to where the thrown values + ;; should sit. + (move rdi top) + (move result rdi) + + (inst sub rdi word-bytes) + (move rcx count) ; fixnum words == bytes + (move num rcx) + (inst shr rcx word-shift) ; word count for <rep movs> + ;; If we got zero, we be done. + (inst jecxz done) + ;; Copy them down. + (inst std) + (inst rep) + (inst movs :qword) + + DONE + ;; Reset the CSP at last moved arg. + (inst lea rsp-tn (make-ea :qword :base rdi :disp word-bytes)))) + + +;;; This VOP is just to force the TNs used in the cleanup onto the stack. +;;; +(define-vop (uwp-entry) + (:info label) + (:save-p :force-to-stack) + (:results (block) (start) (count)) + (:ignore block start count) + (:vop-var vop) + (:generator 0 + (emit-label label) + (note-this-location vop :non-local-entry))) diff --git a/compiler/amd64/parms.lisp b/compiler/amd64/parms.lisp new file mode 100644 index 0000000000000000000000000000000000000000..155b7bddbb5c1a7658a8387e0117ab17f0984ccb --- /dev/null +++ b/compiler/amd64/parms.lisp @@ -0,0 +1,337 @@ +;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; Package: python-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: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/amd64/parms.lisp,v 1.1 2004/05/24 22:35:00 cwang Exp $") +;;; +;;; ********************************************************************** +;;; +;;; This file contains some parameterizations of various VM +;;; attributes for the amd64. This file is separate from other stuff so +;;; that it can be compiled and loaded earlier. +;;; +;;; Written by William Lott. +;;; +;;; Debugged by Paul F. Werkowski Spring/Summer 1995. +;;; Enhancements/debugging by Douglas T. Crosher 1996,1997. +;;; + +(in-package :amd64) +(use-package :c) + +;;; ### Note: we simultaneously use ``word'' to mean a 64 bit quantity and +;;; a 16 bit quantity depending on context. This is because Intel insists +;;; on calling 16 bit things words and 32 bit things double-words (or dwords). +;;; Therefore, in the instruction definition and register specs, we use the +;;; Intel convention. But whenever we are talking about stuff the rest of +;;; the lisp system might be interested in, we use ``word'' to mean the size +;;; of a descriptor object, which is 64 bits. + + +;;;; Compiler constants. + +(eval-when (compile eval load) + +(setf (backend-name *target-backend*) "AMD64") +(setf (backend-version *target-backend*) "AMD x86-64") +(setf (backend-fasl-file-type *target-backend*) "amd64f") +(setf (backend-fasl-file-implementation *target-backend*) + amd64-fasl-file-implementation) +(setf (backend-fasl-file-version *target-backend*) #x18e) +(setf (backend-register-save-penalty *target-backend*) 3) +(setf (backend-byte-order *target-backend*) :little-endian) + +;;;#+cross-compiler +;;;(setf (backend-package *target-backend*) :python-x86) + +(setf (backend-page-size *target-backend*) 4096) +); eval-when + + +;;;; Machine Architecture parameters: + +(export '(word-bits byte-bits word-shift word-bytes float-sign-shift + + single-float-bias single-float-exponent-byte + single-float-significand-byte single-float-normal-exponent-min + single-float-normal-exponent-max single-float-hidden-bit + single-float-trapping-nan-bit single-float-digits + + double-float-bias double-float-exponent-byte + double-float-significand-byte double-float-normal-exponent-min + double-float-normal-exponent-max double-float-hidden-bit + double-float-trapping-nan-bit double-float-digits + + long-float-bias long-float-exponent-byte + long-float-significand-byte long-float-normal-exponent-min + long-float-normal-exponent-max long-float-hidden-bit + long-float-trapping-nan-bit long-float-digits + + float-underflow-trap-bit float-overflow-trap-bit + float-imprecise-trap-bit float-invalid-trap-bit + float-divide-by-zero-trap-bit)) + + + +(eval-when (compile load eval) + +(defconstant word-bits 64 + "Number of bits per word where a word holds one lisp descriptor.") + +(defconstant byte-bits 8 + "Number of bits per byte where a byte is the smallest addressable object.") + +(defconstant word-shift (1- (integer-length (/ word-bits byte-bits))) + "Number of bits to shift between word addresses and byte addresses.") + +(defconstant word-bytes (/ word-bits byte-bits) + "Number of bytes in a word.") +) ; eval-when + +(eval-when (compile load eval) +(defconstant float-sign-shift 31) + +;; These values were taken from the alpha code. The values for +;; bias and exponent min/max are not the same as shown in the 486 book. +;; They may be correct for how Python uses them. +(defconstant single-float-bias 126) ; Intel says 127 +(defconstant single-float-exponent-byte (byte 8 23)) +(defconstant single-float-significand-byte (byte 23 0)) +;; The 486 book shows the exponent range -126 to +127. The Lisp +;; code that uses these values seems to want already biased numbers. +(defconstant single-float-normal-exponent-min 1) +(defconstant single-float-normal-exponent-max 254) +(defconstant single-float-hidden-bit (ash 1 23)) +(defconstant single-float-trapping-nan-bit (ash 1 22)) + +(defconstant double-float-bias 1022) +(defconstant double-float-exponent-byte (byte 11 20)) +(defconstant double-float-significand-byte (byte 20 0)) +(defconstant double-float-normal-exponent-min 1) +(defconstant double-float-normal-exponent-max #x7FE) +(defconstant double-float-hidden-bit (ash 1 20)) +(defconstant double-float-trapping-nan-bit (ash 1 19)) + +(defconstant long-float-bias 16382) +(defconstant long-float-exponent-byte (byte 15 0)) +(defconstant long-float-significand-byte (byte 31 0)) +(defconstant long-float-normal-exponent-min 1) +(defconstant long-float-normal-exponent-max #x7FFE) +(defconstant long-float-hidden-bit (ash 1 31)) ; Actually not hidden +(defconstant long-float-trapping-nan-bit (ash 1 30)) + +(defconstant single-float-digits + (+ (byte-size single-float-significand-byte) 1)) + +(defconstant double-float-digits + (+ (byte-size double-float-significand-byte) word-bits 1)) + +(defconstant long-float-digits + (+ (byte-size long-float-significand-byte) word-bits 1)) + +;;; pfw -- from i486 microprocessor programmers reference manual +(defconstant float-invalid-trap-bit (ash 1 0)) +(defconstant float-denormal-trap-bit (ash 1 1)) +(defconstant float-divide-by-zero-trap-bit (ash 1 2)) +(defconstant float-overflow-trap-bit (ash 1 3)) +(defconstant float-underflow-trap-bit (ash 1 4)) +(defconstant float-inexact-trap-bit (ash 1 5)) + +(defconstant float-round-to-nearest 0) +(defconstant float-round-to-negative 1) +(defconstant float-round-to-positive 2) +(defconstant float-round-to-zero 3) + +(defconstant float-precision-24-bit 0) +(defconstant float-precision-53-bit 2) +(defconstant float-precision-64-bit 3) + +(defconstant float-rounding-mode (byte 2 10)) +(defconstant float-sticky-bits (byte 6 16)) +(defconstant float-traps-byte (byte 6 0)) +(defconstant float-exceptions-byte (byte 6 16)) +(defconstant float-precision-control (byte 2 8)) +(defconstant float-fast-bit 0) ; No fast mode on x86 +); eval-when + + +;;;; Description of the target address space. + +(export '(target-read-only-space-start + target-static-space-start + target-dynamic-space-start + target-foreign-linkage-space-start + target-foreign-linkage-entry-size)) + +;;; Where to put the different spaces. +;;; +(defparameter target-read-only-space-start #x10000000) +(defparameter target-static-space-start #x28000000) +(defparameter target-dynamic-space-start #x48000000) +(defparameter target-foreign-linkage-space-start #xB0000000) +(defconstant target-foreign-linkage-entry-size 16) ;In bytes. Duh. + +;;; Given that NIL is the first thing allocated in static space, we +;;; know its value at compile time: +;;; +(defparameter nil-value (+ target-static-space-start #x13)) + + +;;;; Other random constants. + +(export '(halt-trap pending-interrupt-trap error-trap cerror-trap + breakpoint-trap function-end-breakpoint-trap + single-step-breakpoint-trap + object-not-list-trap object-not-instance-trap + trace-table-normal trace-table-call-site + trace-table-function-prologue trace-table-function-epilogue)) + +(defenum (:suffix -trap :start 8) + halt + pending-interrupt + error + cerror + breakpoint + function-end-breakpoint + single-step-breakpoint) + +(defenum (:prefix object-not- :suffix -trap :start 16) + list + instance) + +(defenum (:prefix trace-table-) + normal + call-site + function-prologue + function-epilogue) + + + +;;;; Static symbols. + +(export '(static-symbols static-functions)) + +;;; These symbols are loaded into static space directly after NIL so +;;; that the system can compute their address by adding a constant +;;; amount to NIL. +;;; +;;; The fdefn objects for the static functions are loaded into static +;;; space directly after the static symbols. That way, the raw-addr +;;; can be loaded directly out of them by indirecting relative to NIL. +;;; +;;; pfw X86 doesn't have enough registers to keep these things there. +;;; Note these spaces grow from low to high addresses. +(defvar *allocation-pointer*) +(defvar *binding-stack-pointer*) +(defvar *x86-cgc-active-p*) +(defvar *static-blue-bag* nil) + +(defparameter static-symbols + '(t + + ;; The C startup code must fill these in. + lisp::lisp-environment-list + lisp::lisp-command-line-list + ext::*batch-mode* + lisp::*initial-fdefn-objects* + + ;; Functions that the C code needs to call + lisp::%initial-function + lisp::maybe-gc + kernel::internal-error + #+stack-checking kernel::yellow-zone-hit + #+stack-checking kernel::red-zone-hit + di::handle-breakpoint + lisp::fdefinition-object + + ;; Free Pointers. + lisp::*read-only-space-free-pointer* + lisp::*static-space-free-pointer* + lisp::*initial-dynamic-space-free-pointer* + + ;; Things needed for non-local-exit. + lisp::*current-catch-block* + lisp::*current-unwind-protect-block* + *eval-stack-top* + *alien-stack* + + ;; Interrupt Handling + lisp::*pseudo-atomic-atomic* + lisp::*pseudo-atomic-interrupted* + unix::*interrupts-enabled* + unix::*interrupt-pending* + lisp::*free-interrupt-context-index* + + *allocation-pointer* + *binding-stack-pointer* + *internal-gc-trigger* ; Not used. + + ;; The FP constants + *fp-constant-0d0* + *fp-constant-1d0* + *fp-constant-0s0* + *fp-constant-1s0* + ;; Following are all long-floats. + *fp-constant-0l0* + *fp-constant-1l0* + *fp-constant-pi* + *fp-constant-l2t* + *fp-constant-l2e* + *fp-constant-lg2* + *fp-constant-ln2* + + ;; Used by gencgc. + *scavenge-read-only-space* + + ;; Multi-process support. + *control-stacks* + + ;; Make the ..slot-unbound.. symbol static to optimise the + ;; common slot unbound check. + pcl::..slot-unbound.. + + ;; These are filled in the C run-time. + lisp::*cmucl-lib* + lisp::*cmucl-core-path* + + ;; Spare symbols. Rename these when you need to add some static + ;; symbols and don't want to do a cross-compile. + spare-8 + spare-7 + spare-6 + spare-5 + spare-4 + spare-3 + spare-2 + spare-1 + + ;; Used by CGC. + *x86-cgc-active-p* + ;; Foreign linkage stuff + lisp::*linkage-table-data* + system::*global-table* + *current-region-free-pointer* + *current-region-end-addr* + *static-blue-bag* ; Must be last or change C code + + + )) + +(defparameter static-functions + '(length + two-arg-+ two-arg-- two-arg-* two-arg-/ two-arg-< two-arg-> two-arg-= eql + %negate two-arg-and two-arg-ior two-arg-xor two-arg-gcd two-arg-lcm + )) + +;;; +;;; Stuff added by jrd ---- +;;; + + +;;; cf the sparc PARMS.LISP +(defparameter *assembly-unit-length* 8) diff --git a/compiler/amd64/pred.lisp b/compiler/amd64/pred.lisp new file mode 100644 index 0000000000000000000000000000000000000000..0ab7a589df20fbe731e2f382b21b000648e2e2ca --- /dev/null +++ b/compiler/amd64/pred.lisp @@ -0,0 +1,80 @@ +;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; 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: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/amd64/pred.lisp,v 1.1 2004/05/24 22:35:00 cwang Exp $") +;;; +;;; ********************************************************************** +;;; +;;; This file contains the VM definition of predicate VOPs for the x86. +;;; +;;; Written by William Lott. +;;; Enhancements/debugging by Douglas T. Crosher 1996,1997. +;;; + +(in-package :amd64) + + +;;;; The Branch VOP. + +;;; The unconditional branch, emitted when we can't drop through to the desired +;;; destination. Dest is the continuation we transfer control to. +;;; +(define-vop (branch) + (:info dest) + (:generator 5 + (inst jmp dest))) + + +;;;; Conditional VOPs: + +;;; Note: a constant-tn is allowed in CMP; it uses an EA displacement, +;;; not immediate data. +(define-vop (if-eq) + (:args (x :scs (any-reg descriptor-reg control-stack constant) + :load-if (not (and (sc-is x immediate) + (sc-is y any-reg descriptor-reg + control-stack constant)))) + (y :scs (any-reg descriptor-reg immediate) + :load-if (not (and (sc-is x any-reg descriptor-reg immediate) + (sc-is y control-stack constant))))) + (:conditional) + (:info target not-p) + (:policy :fast-safe) + (:translate eq) + (:generator 3 + (cond + ((sc-is y immediate) + (let ((val (tn-value y))) + (etypecase val + (integer + (if (and (zerop val) (sc-is x any-reg descriptor-reg)) + (inst test x x) ; smaller + (inst cmp x (fixnumize val)))) + (symbol + (inst cmp x (+ nil-value (static-symbol-offset val)))) + (character + (inst cmp x (logior (ash (char-code val) type-bits) + base-char-type)))))) + ((sc-is x immediate) ; and y not immediate + ;; Swap the order to fit the compare instruction. + (let ((val (tn-value x))) + (etypecase val + (integer + (if (and (zerop val) (sc-is y any-reg descriptor-reg)) + (inst test y y) ; smaller + (inst cmp y (fixnumize val)))) + (symbol + (inst cmp y (+ nil-value (static-symbol-offset val)))) + (character + (inst cmp y (logior (ash (char-code val) type-bits) + base-char-type)))))) + (t + (inst cmp x y))) + + (inst jmp (if not-p :ne :e) target))) diff --git a/compiler/amd64/print.lisp b/compiler/amd64/print.lisp new file mode 100644 index 0000000000000000000000000000000000000000..1f894cff087727c66a82e51c16c10e165e965536 --- /dev/null +++ b/compiler/amd64/print.lisp @@ -0,0 +1,35 @@ +;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; 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: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/amd64/print.lisp,v 1.1 2004/05/24 22:35:00 cwang Exp $") +;;; +;;; ********************************************************************** +;;; +;;; This file contains the print VOP, which is used while booting the kernel +;;; core to keep the user entertained. +;;; +;;; Written by William Lott. +;;; Enhancements/debugging by Douglas T. Crosher 1996. +;;; +(in-package :amd64) + +(define-vop (print) + (:args (object :scs (descriptor-reg any-reg))) + (:temporary (:sc unsigned-reg :offset rax-offset :target result + :from :eval :to :result) rax) + (:temporary (:sc unsigned-reg :offset rdi-offset) rdi) ; from/to? + (:results (result :scs (descriptor-reg))) + (:save-p t) + (:generator 100 + (move rdi object) ;; C arg 1 + ;; LEA can't be used because it can only do sign-extended 32 bit argument. + ;; We need to specify immediate here because we don't want to be indirected + (inst mov-imm rax (make-fixup (extern-alien-name "debug_print") :foreign)) + (inst call (make-fixup (extern-alien-name "call_into_c") :foreign)) + (move result rax))) diff --git a/compiler/amd64/sap.lisp b/compiler/amd64/sap.lisp new file mode 100644 index 0000000000000000000000000000000000000000..065e93c0cb100d5b624dfdad74ba86eb842bade0 --- /dev/null +++ b/compiler/amd64/sap.lisp @@ -0,0 +1,613 @@ +;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; 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: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/amd64/sap.lisp,v 1.1 2004/05/24 22:35:00 cwang Exp $") +;;; +;;; ********************************************************************** +;;; +;;; This file contains the AMD64 VM definition of SAP operations. +;;; +;;; Written by William Lott. +;;; +;;; Debugged by Paul F. Werkowski Spring/Summer 1995. +;;; Enhancements/debugging by Douglas T. Crosher 1996,1997,1998,1999. +;;; +(in-package :amd64) + + +;;;; Moves and coercions: + +;;; Move a tagged SAP to an untagged representation. +;;; +(define-vop (move-to-sap) + (:args (x :scs (descriptor-reg))) + (:results (y :scs (sap-reg))) + (:note "pointer to SAP coercion") + (:generator 1 + (loadw y x sap-pointer-slot other-pointer-type))) +;;; +(define-move-vop move-to-sap :move + (descriptor-reg) (sap-reg)) + +;;; Move an untagged SAP to a tagged representation. +;;; + +(define-vop (move-from-sap) + (:args (sap :scs (sap-reg) :to :result)) + (:results (res :scs (descriptor-reg) :from :argument)) + (:temporary (:sc any-reg) temp) + (:note "SAP to pointer coercion") + (:node-var node) + (:generator 20 + (with-fixed-allocation (res sap-type sap-size temp node) + (storew sap res sap-pointer-slot other-pointer-type)))) + +;;; +(define-move-vop move-from-sap :move + (sap-reg) (descriptor-reg)) + + +;;; Move untagged sap values. +;;; +(define-vop (sap-move) + (:args (x :target y + :scs (sap-reg) + :load-if (not (location= x y)))) + (:results (y :scs (sap-reg) + :load-if (not (location= x y)))) + (:note "SAP move") + (:effects) + (:affected) + (:generator 0 + (move y x))) + + +;;; +(define-move-vop sap-move :move + (sap-reg) (sap-reg)) + + +;;; Move untagged sap arguments/return-values. +;;; +(define-vop (move-sap-argument) + (:args (x :target y + :scs (sap-reg)) + (fp :scs (any-reg) + :load-if (not (sc-is y sap-reg)))) + (:results (y)) + (:note "SAP argument move") + (:generator 0 + (sc-case y + (sap-reg + (move y x)) + (sap-stack + (if (= (tn-offset fp) rsp-offset) + (storew x fp (tn-offset y)) ; c-call + (storew x fp (- (1+ (tn-offset y))))))))) +;;; +(define-move-vop move-sap-argument :move-argument + (descriptor-reg sap-reg) (sap-reg)) + + +;;; Use standard MOVE-ARGUMENT + coercion to move an untagged sap to a +;;; descriptor passing location. +;;; +(define-move-vop move-argument :move-argument + (sap-reg) (descriptor-reg)) + + + +;;;; SAP-INT and INT-SAP + +(define-vop (sap-int) + (:args (sap :scs (sap-reg) :target int)) + (:arg-types system-area-pointer) + (:results (int :scs (unsigned-reg))) + (:result-types unsigned-num) + (:translate sap-int) + (:policy :fast-safe) + (:generator 1 + (move int sap))) + +(define-vop (int-sap) + (:args (int :scs (unsigned-reg) :target sap)) + (:arg-types unsigned-num) + (:results (sap :scs (sap-reg))) + (:result-types system-area-pointer) + (:translate int-sap) + (:policy :fast-safe) + (:generator 1 + (move sap int))) + +(define-vop (fixnum-sap) + (:args (int :scs (any-reg))) + (:arg-types tagged-num) + (:results (sap :scs (sap-reg))) + (:result-types system-area-pointer) + (:translate fixnum-sap) + (:policy :fast-safe) + (:generator 1 + (move sap int))) + +#+nil +(define-vop (fixnum-sap) + (:args (x :scs (any-reg descriptor-reg) :target sap + :load-if (not (location= x sap)))) + (:arg-types tagged-num) + (:results (sap :scs (sap-reg) + :load-if (not (location= x sap)))) + (:result-types system-area-pointer) + (:note "fixnum as sap") + (:generator 1 + (move sap x))) + +#+nil +(define-move-vop fixnum-sap :move + (any-reg descriptor-reg) (sap-reg)) + +#+nil +(define-vop (fixnum-sap) + (:args (arg :scs (any-reg descriptor-reg) :target sap + ; :load-if (not (location= arg sap)) + )) + (:arg-types tagged-num) + (:results (sap :scs (sap-reg) + ; :load-if (not (location= arg sap)) + )) + (:result-types system-area-pointer) + (:translate fixnum-sap) + (:policy :fast-safe) + (:generator 1 + (move sap arg))) + +#+nil +(define-vop (fixnum-sap) + (:args (int :scs (any-reg descriptor-reg) :target sap)) + (:arg-types fixnum) + (:results (sap :scs (sap-reg))) + (:result-types system-area-pointer) + (:translate fixnum-sap) + (:policy :fast-safe) + (:generator 1 + (move sap fixnum))) + + +;;;; POINTER+ and POINTER- + +(define-vop (pointer+) + (:translate sap+) + (:args (ptr :scs (sap-reg) :target res + :load-if (not (location= ptr res))) + (offset :scs (signed-reg immediate))) + (:arg-types system-area-pointer signed-num) + (:results (res :scs (sap-reg) :from (:argument 0) + :load-if (not (location= ptr res)))) + (:result-types system-area-pointer) + (:policy :fast-safe) + (:generator 1 + (cond ((and (sc-is ptr sap-reg) (sc-is res sap-reg) + (not (location= ptr res))) + (sc-case offset + (signed-reg + (inst lea res (make-ea :qword :base ptr :index offset :scale 1))) + (immediate + (inst lea res (make-ea :qword :base ptr + :disp (tn-value offset)))))) + (t + (move res ptr) + (sc-case offset + (signed-reg + (inst add res offset)) + (immediate + (inst add res (tn-value offset)))))))) + +(define-vop (pointer-) + (:translate sap-) + (:args (ptr1 :scs (sap-reg) :target res) + (ptr2 :scs (sap-reg))) + (:arg-types system-area-pointer system-area-pointer) + (:policy :fast-safe) + (:results (res :scs (signed-reg) :from (:argument 0))) + (:result-types signed-num) + (:generator 1 + (move res ptr1) + (inst sub res ptr2))) + + + +;;;; mumble-SYSTEM-REF and mumble-SYSTEM-SET + +(eval-when (compile eval) + +(defmacro def-system-ref-and-set + (ref-name set-name sc type size &optional signed) + (let ((ref-name-c (symbolicate ref-name "-C")) + (set-name-c (symbolicate set-name "-C")) + (temp-sc (symbolicate size "-REG"))) + `(progn + (define-vop (,ref-name) + (:translate ,ref-name) + (:policy :fast-safe) + (:args (sap :scs (sap-reg)) + (offset :scs (signed-reg))) + (:arg-types system-area-pointer signed-num) + (:results (result :scs (,sc))) + (:result-types ,type) + (:generator 5 + (inst ,(cond ((or (eq size :qword) + (and (eq size :dword) (not signed))) + 'mov) + ((eq size :dword) ; signed + 'movsxd) + (signed 'movsx) ; word and byte + (t 'movzx)) + ,(if (and (eq size :dword) (not signed)) + ;; high 32 bits of doubleword operands are zero + ;; extended to 64 bits + '(64-bit-to-32-bit-tn result) + 'result) + (make-ea ,size :base sap :index offset)))) + (define-vop (,ref-name-c) + (:translate ,ref-name) + (:policy :fast-safe) + (:args (sap :scs (sap-reg))) + (:arg-types system-area-pointer (:constant (signed-byte 32))) + (:info offset) + (:results (result :scs (,sc))) + (:result-types ,type) + (:generator 4 + (inst ,(cond ((or (eq size :qword) + (and (eq size :dword) (not signed))) + 'mov) + ((eq size :dword) ; signed + 'movsxd) + (signed 'movsx) ; word and byte + (t 'movzx)) + ,(if (and (eq size :dword) (not signed)) + ;; high 32 bits of doubleword operands are zero + ;; extended to 64 bits + '(64-bit-to-32-bit-tn result) + 'result) + (make-ea ,size :base sap :disp offset)))) + (define-vop (,set-name) + (:translate ,set-name) + (:policy :fast-safe) + (:args (sap :scs (sap-reg) :to (:eval 0)) + (offset :scs (signed-reg) :to (:eval 0)) + (value :scs (,sc) + :target ,(if (eq size :byte) 'temp 'result))) + (:arg-types system-area-pointer signed-num ,type) + ,@(when (eq size :byte) + `((:temporary (:sc ,temp-sc :offset rax-offset + :from (:argument 2) :to (:result 0) + :target result) + temp))) + (:results (result :scs (,sc))) + (:result-types ,type) + (:generator 5 + ,(ecase size + (:qword + '(inst mov (make-ea :qword :base sap :index offset) + value)) + (:dword + '(inst mov (make-ea :dword :base sap :index offset) + (64-bit-to-32-bit-tn value))) + (:word + '(inst mov (make-ea :word :base sap :index offset) + (64-bit-to-16-bit-tn value))) + (:byte + '(let ((low-8-bit-tn (64-bit-to-8-bit-tn value)) + (ea (make-ea :byte :base sap :index offset))) + (if low-8-bit-tn + (inst mov ea low-8-bit-tn) + ;; We can't access the lower 8 bits so we use + ;; another move. + (progn + (move rax-tn value) + (inst mov ea temp)))))) + (move result value))) + (define-vop (,set-name-c) + (:translate ,set-name) + (:policy :fast-safe) + (:args (sap :scs (sap-reg) :to (:eval 0)) + (value :scs (,sc) + :target ,(if (eq size :byte) 'temp 'result))) + (:arg-types system-area-pointer (:constant (signed-byte 32)) ,type) + (:info offset) + ,@(when (eq size :byte) + `((:temporary (:sc ,temp-sc :offset rax-offset + :from (:argument 2) :to (:result 0) + :target result) + temp))) + (:results (result :scs (,sc))) + (:result-types ,type) + (:generator 4 + ,(ecase size + (:qword + '(inst mov (make-ea :qword :base sap :disp offset) + value)) + (:dword + '(inst mov (make-ea :dword :base sap :disp offset) + (64-bit-to-32-bit-tn value))) + (:word + '(inst mov (make-ea :word :base sap :disp offset) + (64-bit-to-16-bit-tn value))) + (:byte + '(let ((low-8-bit-tn (64-bit-to-8-bit-tn value)) + (ea (make-ea :byte :base sap :disp offset))) + (if low-8-bit-tn + (inst mov ea low-8-bit-tn) + ;; We can't access the lower 8 bits so we use + ;; another move. + (progn + (move rax-tn value) + (inst mov ea temp)))))) + (move result value)))))) + +); eval-when (compile eval) + +(def-system-ref-and-set sap-ref-8 %set-sap-ref-8 + unsigned-reg positive-fixnum :byte nil) +(def-system-ref-and-set signed-sap-ref-8 %set-signed-sap-ref-8 + signed-reg tagged-num :byte t) + +(def-system-ref-and-set sap-ref-16 %set-sap-ref-16 + unsigned-reg positive-fixnum :word nil) +(def-system-ref-and-set signed-sap-ref-16 %set-signed-sap-ref-16 + signed-reg tagged-num :word t) + +(def-system-ref-and-set sap-ref-32 %set-sap-ref-32 + unsigned-reg positive-fixnum :dword nil) +(def-system-ref-and-set signed-sap-ref-32 %set-signed-sap-ref-32 + signed-reg tagged-num :dword t) + +(def-system-ref-and-set sap-ref-64 %set-sap-ref-64 + unsigned-reg unsigned-num :qword nil) +(def-system-ref-and-set signed-sap-ref-64 %set-signed-sap-ref-64 + signed-reg signed-num :qword t) + +(def-system-ref-and-set sap-ref-sap %set-sap-ref-sap + sap-reg system-area-pointer :qword) + + +;;; Sap-Ref-Double +(define-vop (sap-ref-double) + (:translate sap-ref-double) + (:policy :fast-safe) + (:args (sap :scs (sap-reg)) + (offset :scs (signed-reg))) + (:arg-types system-area-pointer signed-num) + (:results (result :scs (double-reg))) + (:result-types double-float) + (:generator 5 + (with-empty-tn@fp-top(result) + (inst fldd (make-ea :qword :base sap :index offset))))) + +(define-vop (sap-ref-double-c) + (:translate sap-ref-double) + (:policy :fast-safe) + (:args (sap :scs (sap-reg))) + (:arg-types system-area-pointer (:constant (signed-byte 32))) + (:info offset) + (:results (result :scs (double-reg))) + (:result-types double-float) + (:generator 4 + (with-empty-tn@fp-top(result) + (inst fldd (make-ea :qword :base sap :disp offset))))) + +(define-vop (%set-sap-ref-double) + (:translate %set-sap-ref-double) + (:policy :fast-safe) + (:args (sap :scs (sap-reg) :to (:eval 0)) + (offset :scs (signed-reg) :to (:eval 0)) + (value :scs (double-reg))) + (:arg-types system-area-pointer signed-num double-float) + (:results (result :scs (double-reg))) + (:result-types double-float) + (:generator 5 + (cond ((zerop (tn-offset value)) + ;; Value is in ST0 + (inst fstd (make-ea :qword :base sap :index offset)) + (unless (zerop (tn-offset result)) + ;; Value is in ST0 but not result. + (inst fstd result))) + (t + ;; Value is not in ST0. + (inst fxch value) + (inst fstd (make-ea :qword :base sap :index offset)) + (cond ((zerop (tn-offset result)) + ;; The result is in ST0. + (inst fstd value)) + (t + ;; Neither value or result are in ST0 + (unless (location= value result) + (inst fstd result)) + (inst fxch value))))))) + +(define-vop (%set-sap-ref-double-c) + (:translate %set-sap-ref-double) + (:policy :fast-safe) + (:args (sap :scs (sap-reg) :to (:eval 0)) + (value :scs (double-reg))) + (:arg-types system-area-pointer (:constant (signed-byte 32)) double-float) + (:info offset) + (:results (result :scs (double-reg))) + (:result-types double-float) + (:generator 4 + (cond ((zerop (tn-offset value)) + ;; Value is in ST0 + (inst fstd (make-ea :qword :base sap :disp offset)) + (unless (zerop (tn-offset result)) + ;; Value is in ST0 but not result. + (inst fstd result))) + (t + ;; Value is not in ST0. + (inst fxch value) + (inst fstd (make-ea :qword :base sap :disp offset)) + (cond ((zerop (tn-offset result)) + ;; The result is in ST0. + (inst fstd value)) + (t + ;; Neither value or result are in ST0 + (unless (location= value result) + (inst fstd result)) + (inst fxch value))))))) + + +;;; Sap-Ref-Single +(define-vop (sap-ref-single) + (:translate sap-ref-single) + (:policy :fast-safe) + (:args (sap :scs (sap-reg)) + (offset :scs (signed-reg))) + (:arg-types system-area-pointer signed-num) + (:results (result :scs (single-reg))) + (:result-types single-float) + (:generator 5 + (with-empty-tn@fp-top(result) + (inst fld (make-ea :qword :base sap :index offset))))) + +(define-vop (sap-ref-single-c) + (:translate sap-ref-single) + (:policy :fast-safe) + (:args (sap :scs (sap-reg))) + (:arg-types system-area-pointer (:constant (signed-byte 32))) + (:info offset) + (:results (result :scs (single-reg))) + (:result-types single-float) + (:generator 4 + (with-empty-tn@fp-top(result) + (inst fld (make-ea :qword :base sap :disp offset))))) + +(define-vop (%set-sap-ref-single) + (:translate %set-sap-ref-single) + (:policy :fast-safe) + (:args (sap :scs (sap-reg) :to (:eval 0)) + (offset :scs (signed-reg) :to (:eval 0)) + (value :scs (single-reg))) + (:arg-types system-area-pointer signed-num single-float) + (:results (result :scs (single-reg))) + (:result-types single-float) + (:generator 5 + (cond ((zerop (tn-offset value)) + ;; Value is in ST0 + (inst fst (make-ea :qword :base sap :index offset)) + (unless (zerop (tn-offset result)) + ;; Value is in ST0 but not result. + (inst fst result))) + (t + ;; Value is not in ST0. + (inst fxch value) + (inst fst (make-ea :qword :base sap :index offset)) + (cond ((zerop (tn-offset result)) + ;; The result is in ST0. + (inst fst value)) + (t + ;; Neither value or result are in ST0 + (unless (location= value result) + (inst fst result)) + (inst fxch value))))))) + +(define-vop (%set-sap-ref-single-c) + (:translate %set-sap-ref-single) + (:policy :fast-safe) + (:args (sap :scs (sap-reg) :to (:eval 0)) + (value :scs (single-reg))) + (:arg-types system-area-pointer (:constant (signed-byte 32)) single-float) + (:info offset) + (:results (result :scs (single-reg))) + (:result-types single-float) + (:generator 4 + (cond ((zerop (tn-offset value)) + ;; Value is in ST0 + (inst fst (make-ea :qword :base sap :disp offset)) + (unless (zerop (tn-offset result)) + ;; Value is in ST0 but not result. + (inst fst result))) + (t + ;; Value is not in ST0. + (inst fxch value) + (inst fst (make-ea :qword :base sap :disp offset)) + (cond ((zerop (tn-offset result)) + ;; The result is in ST0. + (inst fst value)) + (t + ;; Neither value or result are in ST0 + (unless (location= value result) + (inst fst result)) + (inst fxch value))))))) + + +;;; Sap-Ref-Long +(define-vop (sap-ref-long) + (:translate sap-ref-long) + (:policy :fast-safe) + (:args (sap :scs (sap-reg)) + (offset :scs (signed-reg))) + (:arg-types system-area-pointer signed-num) + (:results (result :scs (#+long-float long-reg #-long-float double-reg))) + (:result-types #+long-float long-float #-long-float double-float) + (:generator 5 + (with-empty-tn@fp-top(result) + (inst fldl (make-ea :qword :base sap :index offset))))) + +(define-vop (sap-ref-long-c) + (:translate sap-ref-long) + (:policy :fast-safe) + (:args (sap :scs (sap-reg))) + (:arg-types system-area-pointer (:constant (signed-byte 32))) + (:info offset) + (:results (result :scs (#+long-float long-reg #-long-float double-reg))) + (:result-types #+long-float long-float #-long-float double-float) + (:generator 4 + (with-empty-tn@fp-top(result) + (inst fldl (make-ea :qword :base sap :disp offset))))) + +#+long-float +(define-vop (%set-sap-ref-long) + (:translate %set-sap-ref-long) + (:policy :fast-safe) + (:args (sap :scs (sap-reg) :to (:eval 0)) + (offset :scs (signed-reg) :to (:eval 0)) + (value :scs (long-reg))) + (:arg-types system-area-pointer signed-num long-float) + (:results (result :scs (long-reg))) + (:result-types long-float) + (:generator 5 + (cond ((zerop (tn-offset value)) + ;; Value is in ST0 + (store-long-float (make-ea :qword :base sap :index offset)) + (unless (zerop (tn-offset result)) + ;; Value is in ST0 but not result. + (inst fstd result))) + (t + ;; Value is not in ST0. + (inst fxch value) + (store-long-float (make-ea :qword :base sap :index offset)) + (cond ((zerop (tn-offset result)) + ;; The result is in ST0. + (inst fstd value)) + (t + ;; Neither value or result are in ST0 + (unless (location= value result) + (inst fstd result)) + (inst fxch value))))))) + + +;;; Noise to convert normal lisp data objects into SAPs. + +(define-vop (vector-sap) + (:translate vector-sap) + (:policy :fast-safe) + (:args (vector :scs (descriptor-reg) :target sap)) + (:results (sap :scs (sap-reg))) + (:result-types system-area-pointer) + (:generator 2 + (move sap vector) + (inst add sap (- (* vector-data-offset word-bytes) other-pointer-type)))) diff --git a/compiler/amd64/static-fn.lisp b/compiler/amd64/static-fn.lisp new file mode 100644 index 0000000000000000000000000000000000000000..cb50c68a6c51a34de9cd072704a927b9fbdbb19b --- /dev/null +++ b/compiler/amd64/static-fn.lisp @@ -0,0 +1,169 @@ +;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; 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: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/amd64/static-fn.lisp,v 1.1 2004/05/24 22:35:00 cwang Rel $") +;;; +;;; ********************************************************************** +;;; +;;; This file contains the VOPs and macro magic necessary to call static +;;; functions. +;;; +;;; Written by William Lott. +;;; +;;; Debugged by Paul F. Werkowski Spring/Summer 1995. +;;; Enhancements/debugging by Douglas T. Crosher 1996,1997. +;;; +(in-package :amd64) + + +(define-vop (static-function-template) + (:save-p t) + (:policy :safe) + (:variant-vars function) + (:vop-var vop) + (:node-var node) + (:temporary (:sc unsigned-reg :offset rbx-offset + :from (:eval 0) :to (:eval 2)) rbx) + (:temporary (:sc unsigned-reg :offset rcx-offset + :from (:eval 0) :to (:eval 2)) rcx)) + +(eval-when (compile load eval) + +(defun static-function-template-name (num-args num-results) + (intern (format nil "~:@(~R-arg-~R-result-static-function~)" + num-args num-results))) + +(defun moves (dst src) + (collect ((moves)) + (do ((dst dst (cdr dst)) + (src src (cdr src))) + ((or (null dst) (null src))) + (moves `(move ,(car dst) ,(car src)))) + (moves))) + +(defun static-function-template-vop (num-args num-results) + (assert (and (<= num-args register-arg-count) + (<= num-results register-arg-count)) + (num-args num-results) + "Either too many args (~D) or too many results (~D). Max = ~D" + num-args num-results register-arg-count) + (let ((num-temps (max num-args num-results))) + (collect ((temp-names) (temps) (arg-names) (args) (result-names) (results)) + (dotimes (i num-results) + (let ((result-name (intern (format nil "RESULT-~D" i)))) + (result-names result-name) + (results `(,result-name :scs (any-reg descriptor-reg))))) + (dotimes (i num-temps) + (let ((temp-name (intern (format nil "TEMP-~D" i)))) + (temp-names temp-name) + (temps `(:temporary (:sc descriptor-reg + :offset ,(nth i register-arg-offsets) + :from ,(if (< i num-args) + `(:argument ,i) + '(:eval 1)) + :to ,(if (< i num-results) + `(:result ,i) + '(:eval 1)) + ,@(when (< i num-results) + `(:target ,(nth i (result-names))))) + ,temp-name)))) + (dotimes (i num-args) + (let ((arg-name (intern (format nil "ARG-~D" i)))) + (arg-names arg-name) + (args `(,arg-name + :scs (any-reg descriptor-reg) + :target ,(nth i (temp-names)))))) + `(define-vop (,(static-function-template-name num-args num-results) + static-function-template) + (:args ,@(args)) + ,@(temps) + (:temporary (:sc unsigned-reg) temp) ; from/to? + (:results ,@(results)) + (:generator ,(+ 50 num-args num-results) + ,@(moves (temp-names) (arg-names)) + + ;; If speed not more important than size, duplicate the + ;; effect of the ENTER with discrete instructions. Takes + ;; 2+1+3+2=8 bytes as opposed to 4+3=7 bytes. + (cond ((policy node (>= speed space)) + (inst mov rbx rsp-tn) + ;; Save the old-fp + (inst push rbp-tn) + ;; Ensure that at least three slots are available; one + ;; above, two more needed. + (inst sub rsp-tn (fixnumize 2)) + (inst mov rbp-tn rbx)) + (t + (inst enter (fixnumize 2)) + ;; The enter instruction pushes RBP and then copies + ;; RSP into RBP. We want the new RBP to be the + ;; original RSP, so we fix it up afterwards. + (inst add rbp-tn (fixnumize 1)))) + + ,(if (zerop num-args) + '(inst xor rcx rcx) + `(inst mov rcx (fixnumize ,num-args))) + + (note-this-location vop :call-site) + ;; Static-function-offset gives the offset from the start of + ;; the nil object to the static function fdefn and has the + ;; low tag of 1 added. When the nil symbol value with its + ;; low tag of 3 is added the resulting value points to the + ;; raw address slot of the fdefn (at +4). + ;; We must add a MOV instruction here because indirect call is + ;; limited to 32 bit addresses. + (inst mov temp (+ nil-value (static-function-offset function))) + (inst call (make-ea :qword :base temp)) + ,(collect ((bindings) (links)) + (do ((temp (temp-names) (cdr temp)) + (name 'values (gensym)) + (prev nil name) + (i 0 (1+ i))) + ((= i num-results)) + (bindings `(,name + (make-tn-ref ,(car temp) nil))) + (when prev + (links `(setf (tn-ref-across ,prev) ,name)))) + `(let ,(bindings) + ,@(links) + (default-unknown-values + vop + ,(if (zerop num-results) nil 'values) + ,num-results))) + ,@(moves (result-names) (temp-names))))))) + + +) ; eval-when (compile load eval) + + +(macrolet ((frob (num-args num-res) + (static-function-template-vop (eval num-args) (eval num-res)))) + (frob 0 1) + (frob 1 1) + (frob 2 1) + (frob 3 1)) + + +(defmacro define-static-function (name args &key (results '(x)) translate + policy cost arg-types result-types) + `(define-vop (,name + ,(static-function-template-name (length args) + (length results))) + (:variant ',name) + (:note ,(format nil "static-function ~@(~S~)" name)) + ,@(when translate + `((:translate ,translate))) + ,@(when policy + `((:policy ,policy))) + ,@(when cost + `((:generator-cost ,cost))) + ,@(when arg-types + `((:arg-types ,@arg-types))) + ,@(when result-types + `((:result-types ,@result-types))))) diff --git a/compiler/amd64/subprim.lisp b/compiler/amd64/subprim.lisp new file mode 100644 index 0000000000000000000000000000000000000000..7466aca2f78bd969a33509f7290ccdafbe5897ea --- /dev/null +++ b/compiler/amd64/subprim.lisp @@ -0,0 +1,93 @@ +;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; 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: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/amd64/subprim.lisp,v 1.1 2004/05/24 22:35:00 cwang Rel $") +;;; +;;; ********************************************************************** +;;; +;;; Linkage information for standard static functions, and random vops. +;;; +;;; Written by William Lott. +;;; +;;; Debugged by Paul F. Werkowski Spring/Summer 1995. +;;; +(in-package :amd64) + + + +;;;; Length + +(define-vop (length/list) + (:translate length) + (:args (object :scs (descriptor-reg control-stack) :target ptr)) + (:arg-types list) + (:temporary (:sc unsigned-reg :offset rax-offset) rax) + (:temporary (:sc descriptor-reg :from (:argument 0)) ptr) + (:results (count :scs (any-reg))) + (:result-types positive-fixnum) + (:policy :fast-safe) + (:vop-var vop) + (:save-p :compute-only) + (:generator 40 + ;; Move OBJECT into a temp we can bash on, and initialize the count. + (move ptr object) + (inst xor count count) + ;; If we are starting with NIL, then it's real easy. + (inst cmp ptr nil-value) + (inst jmp :e done) + ;; Note: we don't have to test to see if the original argument is a + ;; list, because this is a :fast-safe vop. + LOOP + ;; Get the CDR and boost the count. + (loadw ptr ptr cons-cdr-slot list-pointer-type) + (inst add count (fixnumize 1)) + ;; If we hit NIL, then we are done. + (inst cmp ptr nil-value) + (inst jmp :e done) + ;; Otherwise, check to see if we hit the end of a dotted list. If + ;; not, loop back for more. + (move rax ptr) + (inst and al-tn lowtag-mask) + (inst cmp al-tn list-pointer-type) + (inst jmp :e loop) + ;; It's dotted all right. Flame out. + (error-call vop object-not-list-error ptr) + ;; We be done. + DONE)) + +(define-vop (fast-length/list) + (:translate length) + (:args (object :scs (descriptor-reg control-stack) :target ptr)) + (:arg-types list) + (:temporary (:sc descriptor-reg :from (:argument 0)) ptr) + (:results (count :scs (any-reg))) + (:result-types positive-fixnum) + (:policy :fast) + (:vop-var vop) + (:save-p :compute-only) + (:generator 30 + ;; Get a copy of OBJECT in a register we can bash on, and + ;; initialize COUNT. + (move ptr object) + (inst xor count count) + ;; If we are starting with NIL, we be done. + (inst cmp ptr nil-value) + (inst jmp :e done) + ;; Indirect the next cons cell, and boost the count. + LOOP + (loadw ptr ptr cons-cdr-slot list-pointer-type) + (inst add count (fixnumize 1)) + ;; If we arn't done, go back for more. + (inst cmp ptr nil-value) + (inst jmp :ne loop) + DONE)) + + +(define-static-function length (object) :translate length) + diff --git a/compiler/amd64/system.lisp b/compiler/amd64/system.lisp new file mode 100644 index 0000000000000000000000000000000000000000..9867f32bd2c8f4654ed4002929c70d92d22595f3 --- /dev/null +++ b/compiler/amd64/system.lisp @@ -0,0 +1,608 @@ +;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; 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: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/amd64/system.lisp,v 1.1 2004/05/24 22:35:00 cwang Rel $") +;;; +;;; ********************************************************************** +;;; +;;; x86 VM definitions of various system hacking operations. +;;; +;;; Written by William Lott. +;;; +;;; Debugged by Paul F. Werkowski Spring/Summer 1995. +;;; Enhancements/debugging by Douglas T. Crosher 1996,1997,1998,1999. +;;; + +(in-package :amd64) + + +;;;; Type frobbing VOPs + +(define-vop (get-lowtag) + (:translate get-lowtag) + (:policy :fast-safe) + (:args (object :scs (any-reg descriptor-reg control-stack) + :target result)) + (:results (result :scs (unsigned-reg))) + (:result-types positive-fixnum) + (:generator 1 + (move result object) + (inst and result lowtag-mask))) + +(define-vop (get-type) + (:translate get-type) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg))) + (:temporary (:sc unsigned-reg :offset rax-offset :to (:result 0)) rax) + (:results (result :scs (unsigned-reg))) + (:result-types positive-fixnum) + (:generator 6 + (inst mov rax object) + (inst and al-tn lowtag-mask) + (inst cmp al-tn other-pointer-type) + (inst jmp :e other-ptr) + (inst cmp al-tn function-pointer-type) + (inst jmp :e function-ptr) + + ;; pick off structures and list pointers + (inst test al-tn 1) + (inst jmp :ne done) + + ;; pick off fixnums + (inst and al-tn 3) + (inst jmp :e done) + + ;; must be an other immediate + (inst mov rax object) + (inst jmp done) + + FUNCTION-PTR + (load-type al-tn object (- vm:function-pointer-type)) + (inst jmp done) + + OTHER-PTR + (load-type al-tn object (- vm:other-pointer-type)) + + DONE + (inst movzx result al-tn))) + +(define-vop (function-subtype) + (:translate function-subtype) + (:policy :fast-safe) + (:args (function :scs (descriptor-reg))) + (:temporary (:sc byte-reg :from (:eval 0) :to (:eval 1)) temp) + (:results (result :scs (unsigned-reg))) + (:result-types positive-fixnum) + (:generator 6 + (load-type temp function (- vm:function-pointer-type)) + (inst movzx result temp))) + +(define-vop (set-function-subtype) + (:translate (setf function-subtype)) + (:policy :fast-safe) + (:args (type :scs (unsigned-reg) :target rax) + (function :scs (descriptor-reg))) + (:arg-types positive-fixnum *) + (:temporary (:sc unsigned-reg :offset rax-offset :from (:argument 0) + :to (:result 0) :target result) + rax) + (:results (result :scs (unsigned-reg))) + (:result-types positive-fixnum) + (:generator 6 + (move rax type) + (inst mov + (make-ea :byte :base function :disp (- function-pointer-type)) + al-tn) + (move result rax))) + +(define-vop (get-header-data) + (:translate get-header-data) + (:policy :fast-safe) + (:args (x :scs (descriptor-reg))) + (:results (res :scs (unsigned-reg))) + (:result-types positive-fixnum) + (:generator 6 + (loadw res x 0 other-pointer-type) + (inst shr res type-bits))) + +(define-vop (get-closure-length) + (:translate get-closure-length) + (:policy :fast-safe) + (:args (x :scs (descriptor-reg))) + (:results (res :scs (unsigned-reg))) + (:result-types positive-fixnum) + (:generator 6 + (loadw res x 0 function-pointer-type) + (inst shr res type-bits))) + +(define-vop (set-header-data) + (:translate set-header-data) + (:policy :fast-safe) + (:args (x :scs (descriptor-reg) :target res :to (:result 0)) + (data :scs (any-reg) :target rax)) + (:arg-types * positive-fixnum) + (:results (res :scs (descriptor-reg))) + (:temporary (:sc unsigned-reg :offset rax-offset + :from (:argument 1) :to (:result 0)) rax) + (:generator 6 + (move rax data) + (inst shl rax (- type-bits 2)) + (inst mov al-tn (make-ea :byte :base x :disp (- other-pointer-type))) + (storew rax x 0 other-pointer-type) + (move res x))) + +(define-vop (make-fixnum) + (:args (ptr :scs (any-reg descriptor-reg) :target res)) + (:results (res :scs (any-reg descriptor-reg))) + (:generator 1 + ;; + ;; Some code (the hash table code) depends on this returning a + ;; positive number so make sure it does. + (move res ptr) + (inst shl res 3) + (inst shr res 1))) + +(define-vop (make-other-immediate-type) + (:args (val :scs (any-reg descriptor-reg) :target res) + (type :scs (unsigned-reg immediate))) + (:results (res :scs (any-reg descriptor-reg) :from (:argument 0))) + (:generator 2 + (move res val) + (inst shl res (- type-bits 2)) + (inst or res (sc-case type + (unsigned-reg type) + (immediate (tn-value type)))))) + + +;;;; Allocation + +(define-vop (dynamic-space-free-pointer) + (:results (int :scs (sap-reg))) + (:result-types system-area-pointer) + (:translate dynamic-space-free-pointer) + (:policy :fast-safe) + (:generator 1 + (load-symbol-value int *allocation-pointer*))) + +(define-vop (binding-stack-pointer-sap) + (:results (int :scs (sap-reg))) + (:result-types system-area-pointer) + (:translate binding-stack-pointer-sap) + (:policy :fast-safe) + (:generator 1 + (load-symbol-value int *binding-stack-pointer*))) + +(defknown (setf binding-stack-pointer-sap) + (system-area-pointer) system-area-pointer ()) + +(define-vop (set-binding-stack-pointer-sap) + (:args (new-value :scs (sap-reg) :target int)) + (:arg-types system-area-pointer) + (:results (int :scs (sap-reg))) + (:result-types system-area-pointer) + (:translate (setf binding-stack-pointer-sap)) + (:policy :fast-safe) + (:generator 1 + (store-symbol-value new-value *binding-stack-pointer*) + (move int new-value))) + +(define-vop (control-stack-pointer-sap) + (:results (int :scs (sap-reg))) + (:result-types system-area-pointer) + (:translate control-stack-pointer-sap) + (:policy :fast-safe) + (:generator 1 + (move int rsp-tn))) + + +;;;; Code object frobbing. + +(define-vop (code-instructions) + (:translate code-instructions) + (:policy :fast-safe) + (:args (code :scs (descriptor-reg) :to (:result 0))) + (:results (sap :scs (sap-reg) :from (:argument 0))) + (:result-types system-area-pointer) + (:generator 10 + (loadw sap code 0 other-pointer-type) + (inst shr sap type-bits) + (inst lea sap (make-ea :byte :base code :index sap :scale 8 + :disp (- other-pointer-type))))) + +(define-vop (compute-function) + (:args (code :scs (descriptor-reg) :to (:result 0)) + (offset :scs (signed-reg unsigned-reg) :to (:result 0))) + (:arg-types * positive-fixnum) + (:results (func :scs (descriptor-reg) :from (:argument 0))) + (:generator 10 + (loadw func code 0 other-pointer-type) + (inst shr func type-bits) + (inst lea func + (make-ea :byte :base offset :index func :scale 8 + :disp (- function-pointer-type other-pointer-type))) + (inst add func code))) + +(defknown %function-self (function) function (flushable)) + +(define-vop (%function-self) + (:policy :fast-safe) + (:translate %function-self) + (:args (function :scs (descriptor-reg))) + (:results (result :scs (descriptor-reg))) + (:generator 3 + (loadw result function function-self-slot function-pointer-type) + (inst lea result + (make-ea :byte :base result + :disp (- function-pointer-type + (* function-code-offset word-bytes)))))) + +;;; Closure function slot is a pointer to raw code on X86 instead of +;;; a pointer to the code function object itself. This VOP is used +;;; to reference the function object given the closure object. +(def-source-transform %closure-function (closure) + `(%function-self ,closure)) + +(def-source-transform %funcallable-instance-function (fin) + `(%function-self ,fin)) + +(defknown (setf %function-self) (function function) function (unsafe)) + +(define-vop (%set-function-self) + (:policy :fast-safe) + (:translate (setf %function-self)) + (:args (new-self :scs (descriptor-reg) :target result :to :result) + (function :scs (descriptor-reg) :to :result)) + (:temporary (:sc any-reg :from (:argument 0) :to :result) temp) + (:results (result :scs (descriptor-reg))) + (:generator 3 + (inst lea temp + (make-ea :byte :base new-self + :disp (- (ash function-code-offset word-shift) + function-pointer-type))) + (storew temp function function-self-slot function-pointer-type) + (move result new-self))) + +;; Would have really liked to use a source-transform for this, but they +;; don't work with setf functions. +;; +(defknown ((setf %funcallable-instance-function)) (function function) function + (unsafe)) +(deftransform (setf %funcallable-instance-function) ((value fin)) + '(setf (%function-self fin) value)) + + + +;;;; Other random VOPs. + +(defknown unix::do-pending-interrupt () (values)) +(define-vop (unix::do-pending-interrupt) + (:policy :fast-safe) + (:translate unix::do-pending-interrupt) + (:generator 1 + (inst break pending-interrupt-trap))) + +(define-vop (halt) + (:generator 1 + (inst break halt-trap))) + +(defknown float-wait () (values)) +(define-vop (float-wait) + (:policy :fast-safe) + (:translate float-wait) + (:vop-var vop) + (:save-p :compute-only) + (:generator 1 + (note-next-instruction vop :internal-error) + (inst wait))) + +;;;; Dynamic vop count collection support + +(define-vop (count-me) + (:args (count-vector :scs (descriptor-reg))) + (:info index) + (:generator 0 + (inst inc (make-ea :qword :base count-vector + :disp (- (* (+ vector-data-offset index) word-bytes) + other-pointer-type))))) + + + +(defknown lisp::%scrub-control-stack () (values)) + +;;; Scrub the control stack. +;;; +;;; On the amd64 port the stack grows downwards, and to support grow on +;;; demand stacks the stack must be decreased as it is scrubbed. +;;; +(define-vop (%scrub-control-stack) + (:policy :fast-safe) + (:translate lisp::%scrub-control-stack) + (:args) + (:results) + (:temporary (:sc unsigned-reg) count) + (:temporary (:sc any-reg) stack-save zero) + (:generator 25 + (inst mov stack-save rsp-tn) + (inst mov zero 0) + (inst push zero) + ;; Scrub the stack. + SCRUB + (inst add rsp-tn 8) + (inst mov count 2048) + SCRUB-LOOP + (inst dec count) + (inst push zero) + (inst jmp :nz SCRUB-LOOP) + ;; Look for a clear stack unit. + (inst mov count 2048) + LOOK-LOOP + (inst sub rsp-tn 8) + (inst cmp (make-ea :qword :base rsp-tn) zero) + (inst jmp :ne SCRUB) + (inst dec count) + (inst jmp :nz LOOK-LOOP) + ;; Done, restore the stack pointer. + (inst mov rsp-tn stack-save))) + + +;;;; Primitive multi-thread support. + +(export 'control-stack-fork) +(defknown control-stack-fork ((simple-array (unsigned-byte 32) (*)) t) + (member t nil)) + +(define-vop (control-stack-fork) + (:policy :fast-safe) + (:translate control-stack-fork) + (:args (save-stack :scs (descriptor-reg) :to :result) + (inherit :scs (descriptor-reg))) + (:arg-types simple-array-unsigned-byte-32 *) + (:results (child :scs (descriptor-reg))) + (:result-types t) + (:temporary (:sc unsigned-reg :from (:eval 0) :to (:eval 1)) index) + (:temporary (:sc unsigned-reg :from (:eval 0) :to (:eval 1)) stack) + (:temporary (:sc unsigned-reg :from (:eval 0) :to (:eval 1)) temp) + (:save-p t) + (:generator 25 + (inst cmp inherit nil-value) + (inst jmp :e FRESH-STACK) + + ;; Child inherits the stack of the parent. + + ;; Setup the return context. + (inst push (make-fixup nil :code-object return)) + (inst push rbp-tn) + ;; Save the stack. + (inst xor index index) + ;; First the stack-pointer. + (inst mov (make-ea :qword :base save-stack :index index :scale 4 + :disp (- (* vm:vector-data-offset vm:word-bytes) + vm:other-pointer-type)) + rsp-tn) + (inst inc index) + (load-foreign-data-symbol stack "control_stack_end") + (inst mov stack (make-ea :qword :base stack)) + (inst jmp-short LOOP) + + FRESH-STACK + ;; Child has a fresh control stack. + + ;; Setup the return context. + (inst push (make-fixup nil :code-object return)) + (load-foreign-data-symbol stack "control_stack_end") + (inst mov stack (make-ea :qword :base stack)) + ;; New FP is the Top of the stack. + (inst push stack) + ;; Save the stack. + (inst xor index index) + ;; First save the adjusted stack-pointer. + (inst sub stack rbp-tn) + (inst add stack rsp-tn) + (inst mov (make-ea :qword :base save-stack :index index :scale 4 + :disp (- (* vm:vector-data-offset vm:word-bytes) + vm:other-pointer-type)) + stack) + ;; Save the current frame, replacing the OCFP and RA by 0. + (inst mov (make-ea :qword :base save-stack :index index :scale 4 + :disp (- (* (+ vm:vector-data-offset 1) vm:word-bytes) + vm:other-pointer-type)) + 0) + ;; Save 0 for the OCFP. + (inst mov (make-ea :qword :base save-stack :index index :scale 4 + :disp (- (* (+ vm:vector-data-offset 2) vm:word-bytes) + vm:other-pointer-type)) + 0) + (inst add index 3) + ;; Copy the remainder of the frame, skiping the OCFP and RA which + ;; are saved above. + (inst lea stack (make-ea :byte :base rbp-tn :disp -8)) + + LOOP + (inst cmp stack rsp-tn) + (inst jmp :le stack-save-done) + (inst sub stack 4) + (inst mov temp (make-ea :qword :base stack)) + (inst mov (make-ea :qword :base save-stack :index index :scale 4 + :disp (- (* vm:vector-data-offset vm:word-bytes) + vm:other-pointer-type)) + temp) + (inst inc index) + (inst jmp-short LOOP) + + RETURN + ;; Stack already clean if it reaches here. Parent returns NIL. + (inst mov child nil-value) + (inst jmp-short DONE) + + STACK-SAVE-DONE + ;; Cleanup the stack + (inst add rsp-tn 8) + ;; Child returns T. + (load-symbol child t) + DONE)) + +(export 'control-stack-resume) +(defknown control-stack-resume ((simple-array (unsigned-byte 32) (*)) + (simple-array (unsigned-byte 32) (*))) + (values)) + +(define-vop (control-stack-resume) + (:policy :fast-safe) + (:translate control-stack-resume) + (:args (save-stack :scs (descriptor-reg) :to :result) + (new-stack :scs (descriptor-reg) :to :result)) + (:arg-types simple-array-unsigned-byte-32 simple-array-unsigned-byte-32) + (:temporary (:sc unsigned-reg :from (:eval 0) :to (:eval 1)) index) + (:temporary (:sc unsigned-reg :from (:eval 0) :to (:eval 1)) stack) + (:temporary (:sc unsigned-reg :from (:eval 0) :to (:eval 1)) temp) + (:save-p t) + (:generator 25 + ;; Setup the return context. + (inst push (make-fixup nil :code-object RETURN)) + (inst push rbp-tn) + ;; Save the stack. + (inst xor index index) + ;; First the stack-pointer. + (inst mov (make-ea :qword :base save-stack :index index :scale 4 + :disp (- (* vm:vector-data-offset vm:word-bytes) + vm:other-pointer-type)) + rsp-tn) + (inst inc index) + (load-foreign-data-symbol stack "control_stack_end") + (inst mov stack (make-ea :qword :base stack)) + LOOP + (inst cmp stack rsp-tn) + (inst jmp :le STACK-SAVE-DONE) + (inst sub stack 4) + (inst mov temp (make-ea :qword :base stack)) + (inst mov (make-ea :qword :base save-stack :index index :scale 4 + :disp (- (* vm:vector-data-offset vm:word-bytes) + vm:other-pointer-type)) + temp) + (inst inc index) + (inst jmp-short LOOP) + + STACK-SAVE-DONE + ;; Cleanup the stack + (inst add rsp-tn 8) + + ;; Restore the new-stack. + (inst xor index index) + ;; First the stack-pointer. + (inst mov rsp-tn + (make-ea :qword :base new-stack :index index :scale 4 + :disp (- (* vm:vector-data-offset vm:word-bytes) + vm:other-pointer-type))) + (inst inc index) + (load-foreign-data-symbol stack "control_stack_end") + (inst mov stack (make-ea :qword :base stack)) + LOOP2 + (inst cmp stack rsp-tn) + (inst jmp :le STACK-RESTORE-DONE) + (inst sub stack 4) + (inst mov temp (make-ea :qword :base new-stack :index index :scale 4 + :disp (- (* vm:vector-data-offset vm:word-bytes) + vm:other-pointer-type))) + (inst mov (make-ea :qword :base stack) temp) + (inst inc index) + (inst jmp-short LOOP2) + STACK-RESTORE-DONE + ;; Pop the frame pointer, and resume at the return address. + (inst pop rbp-tn) + (inst ret) + + ;; Original thread resumes, stack has been cleaned up. + RETURN)) + + +(export 'control-stack-return) +(defknown control-stack-return ((simple-array (unsigned-byte 32) (*))) + (values)) + +(define-vop (control-stack-return) + (:policy :fast-safe) + (:translate control-stack-return) + (:args (new-stack :scs (descriptor-reg) :to :result)) + (:arg-types simple-array-unsigned-byte-32) + (:temporary (:sc unsigned-reg :from (:eval 0) :to (:eval 1)) index) + (:temporary (:sc unsigned-reg :from (:eval 0) :to (:eval 1)) stack) + (:temporary (:sc unsigned-reg :from (:eval 0) :to (:eval 1)) temp) + (:save-p t) + (:generator 25 + ;; Restore the new-stack. + (inst xor index index) + ;; First the stack-pointer. + (inst mov rsp-tn + (make-ea :qword :base new-stack :index index :scale 4 + :disp (- (* vm:vector-data-offset vm:word-bytes) + vm:other-pointer-type))) + (inst inc index) + (load-foreign-data-symbol stack "control_stack_end") + (inst mov stack (make-ea :qword :base stack)) + LOOP + (inst cmp stack rsp-tn) + (inst jmp :le STACK-RESTORE-DONE) + (inst sub stack 4) + (inst mov temp (make-ea :qword :base new-stack :index index :scale 4 + :disp (- (* vm:vector-data-offset vm:word-bytes) + vm:other-pointer-type))) + (inst mov (make-ea :qword :base stack) temp) + (inst inc index) + (inst jmp-short LOOP) + STACK-RESTORE-DONE + ;; Pop the frame pointer, and resume at the return address. + (inst pop rbp-tn) + (inst ret))) + + +;; the RDTSC instruction (present on Pentium processors and +;; successors) allows you to access the time-stamp counter, a 64-bit +;; model-specific register that counts executed cycles. The +;; instruction returns the low cycle count in EAX and high cycle count +;; in EDX. +;; +;; In order to obtain more significant results on out-of-order +;; processors (such as the Pentium II and later), we issue a +;; serializing CPUID instruction before reading the cycle counter. +;; This instruction is used for its side effect of emptying the +;; processor pipeline, to ensure that the RDTSC instruction is +;; executed once all pending instructions have been completed. +;; +;; Note that cache effects mean that the cycle count can vary for +;; different executions of the same code (it counts cycles, not +;; retired instructions). Furthermore, the results are per-processor +;; and not per-process, so are unreliable on multiprocessor machines +;; where processes can migrate between processors. +;; +;; This method of obtaining a cycle count has the advantage of being +;; very fast (around 20 cycles), and of not requiring a system call. +;; However, you need to know your processor's clock speed to translate +;; this into real execution time. + +(defknown read-cycle-counter () (values (unsigned-byte 32) (unsigned-byte 32)) ()) + +(define-vop (read-cycle-counter) + (:translate read-cycle-counter) + (:guard (backend-featurep :pentium)) + (:args ) + (:policy :fast-safe) + (:results (lo :scs (unsigned-reg)) + (hi :scs (unsigned-reg))) + (:result-types unsigned-num unsigned-num) + (:temporary (:sc unsigned-reg :offset rax-offset :target lo) rax) + (:temporary (:sc unsigned-reg :offset rdx-offset :target hi) rdx) + (:generator 1 + (inst cpuid) + (inst rdtsc) + (move hi rdx) + (move lo rax))) + +#+pentium +(defun read-cycle-counter () + (read-cycle-counter)) diff --git a/compiler/amd64/type-vops.lisp b/compiler/amd64/type-vops.lisp new file mode 100644 index 0000000000000000000000000000000000000000..50960ffcd24bc1ec2944ecb1078fa2596527d03f --- /dev/null +++ b/compiler/amd64/type-vops.lisp @@ -0,0 +1,761 @@ +;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; 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: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/amd64/type-vops.lisp,v 1.1 2004/05/24 22:35:00 cwang Rel $") +;;; +;;; ********************************************************************** +;;; +;;; This file contains the VM definition of type testing and checking VOPs +;;; for the AMD64. +;;; +;;; Written by William Lott. +;;; +;;; Debugged by Paul F. Werkowski, Spring-95. +;;; Enhancements/debugging by Douglas T. Crosher 1996,1997,1998. +;;; +(in-package :amd64) + + + +;;;; Test generation utilities. + +(eval-when (compile eval) + +(defparameter immediate-types + (list unbound-marker-type base-char-type)) + + +(defparameter function-header-types + (list funcallable-instance-header-type dylan-function-header-type + byte-code-function-type byte-code-closure-type + function-header-type closure-function-header-type + closure-header-type)) + +(defun canonicalize-headers (headers) + (collect ((results)) + (let ((start nil) + (prev nil) + (delta (- other-immediate-1-type other-immediate-0-type))) + (flet ((emit-test () + (results (if (= start prev) + start + (cons start prev))))) + (dolist (header (sort headers #'<)) + (cond ((null start) + (setf start header) + (setf prev header)) + ((= header (+ prev delta)) + (setf prev header)) + (t + (emit-test) + (setf start header) + (setf prev header)))) + (emit-test))) + (results))) + +(defmacro test-type (value target not-p &rest type-codes) + ;; Determine what interesting combinations we need to test for. + (let* ((type-codes (mapcar #'eval type-codes)) + (fixnump (and (member even-fixnum-type type-codes) + (member odd-fixnum-type type-codes) + t)) + (lowtags (remove lowtag-limit type-codes :test #'<)) + (extended (remove lowtag-limit type-codes :test #'>)) + (immediates (intersection extended immediate-types :test #'eql)) + (headers (set-difference extended immediate-types :test #'eql)) + (function-p (if (intersection headers function-header-types) + (if (subsetp headers function-header-types) + t + (error "Can't test for mix of function subtypes ~ + and normal header types.")) + nil))) + (unless type-codes + (error "Must supply at least one type for test-type.")) + (cond + (fixnump + (when (remove-if #'(lambda (x) + (or (= x even-fixnum-type) + (= x odd-fixnum-type))) + lowtags) + (error "Can't mix fixnum testing with other lowtags.")) + (when function-p + (error "Can't mix fixnum testing with function subtype testing.")) + (when immediates + (error "Can't mix fixnum testing with other immediates.")) + (if headers + `(%test-fixnum-and-headers ,value ,target ,not-p + ',(canonicalize-headers headers)) + `(%test-fixnum ,value ,target ,not-p))) + (immediates + (when headers + (error "Can't mix testing of immediates with testing of headers.")) + (when lowtags + (error "Can't mix testing of immediates with testing of lowtags.")) + (when (cdr immediates) + (error "Can't test multiple immediates at the same time.")) + `(%test-immediate ,value ,target ,not-p ,(car immediates))) + (lowtags + (when (cdr lowtags) + (error "Can't test multiple lowtags at the same time.")) + (if headers + `(%test-lowtag-and-headers + ,value ,target ,not-p ,(car lowtags) + ,function-p ',(canonicalize-headers headers)) + `(%test-lowtag ,value ,target ,not-p ,(car lowtags)))) + (headers + `(%test-headers ,value ,target ,not-p ,function-p + ',(canonicalize-headers headers))) + (t + (error "Nothing to test?"))))) + + +); eval-when (compile eval) + +;;; Emit the most compact form of the test immediate instruction, +;;; using an 8 bit test when the immediate is only 8 bits and the +;;; value is one of the four low registers (eax, ebx, ecx, edx) or the +;;; control-stack. +;;; +(defun generate-fixnum-test (value) + (let ((offset (tn-offset value))) + (cond ((and (sc-is value any-reg descriptor-reg) + (or (= offset rax-offset) (= offset rbx-offset) + (= offset rcx-offset) (= offset rdx-offset))) + (inst test (make-random-tn :kind :normal + :sc (sc-or-lose 'byte-reg *backend*) + :offset offset) + 3)) + ((sc-is value control-stack) + (inst test (make-ea :byte :base rbp-tn + :disp (- (* (1+ offset) vm:word-bytes))) + 3)) + (t + (inst test value 3))))) + +(defun %test-fixnum (value target not-p) + (generate-fixnum-test value) + (inst jmp (if not-p :nz :z) target)) + +(defun %test-fixnum-and-headers (value target not-p headers) + (let ((drop-through (gen-label))) + (generate-fixnum-test value) + (inst jmp :z (if not-p drop-through target)) + (%test-headers value target not-p nil headers drop-through))) + +(defun %test-immediate (value target not-p immediate) + ;; Code a single instruction byte test if possible. + (let ((offset (tn-offset value))) + (cond ((and (sc-is value any-reg descriptor-reg) + (or (= offset rax-offset) (= offset rbx-offset) + (= offset rcx-offset) (= offset rdx-offset))) + (inst cmp (make-random-tn :kind :normal + :sc (sc-or-lose 'byte-reg *backend*) + :offset offset) + immediate)) + (t + (move rax-tn value) + (inst cmp al-tn immediate)))) + (inst jmp (if not-p :ne :e) target)) + +(defun %test-lowtag (value target not-p lowtag &optional al-loaded) + (unless al-loaded + (move rax-tn value) + (inst and al-tn lowtag-mask)) + (inst cmp al-tn lowtag) + (inst jmp (if not-p :ne :e) target)) + +(defun %test-lowtag-and-headers (value target not-p lowtag function-p headers) + (let ((drop-through (gen-label))) + (%test-lowtag value (if not-p drop-through target) nil lowtag) + (%test-headers value target not-p function-p headers drop-through t))) + + +(defun %test-headers (value target not-p function-p headers + &optional (drop-through (gen-label)) al-loaded) + (let ((lowtag (if function-p function-pointer-type other-pointer-type))) + (multiple-value-bind + (equal less-or-equal when-true when-false) + ;; EQUAL and LESS-OR-EQUAL are the conditions for branching to TARGET. + ;; WHEN-TRUE and WHEN-FALSE are the labels to branch to when we know + ;; it's true and when we know it's false respectively. + (if not-p + (values :ne :a drop-through target) + (values :e :na target drop-through)) + (%test-lowtag value when-false t lowtag al-loaded) + (inst mov al-tn (make-ea :byte :base value :disp (- lowtag))) + (do ((remaining headers (cdr remaining))) + ((null remaining)) + (let ((header (car remaining)) + (last (null (cdr remaining)))) + (cond + ((atom header) + (inst cmp al-tn header) + (if last + (inst jmp equal target) + (inst jmp :e when-true))) + (t + (let ((start (car header)) + (end (cdr header))) + (unless (= start bignum-type) + (inst cmp al-tn start) + (inst jmp :b when-false)) ; was :l + (inst cmp al-tn end) + (if last + (inst jmp less-or-equal target) + (inst jmp :be when-true))))))) ; was :le + (emit-label drop-through)))) + +;; pw -- based on RISC version. Not sure extra hair is needed yet. +;; difference is that this one uses SUB which overwrites operand +;; both cmp and sub take 2 cycles so maybe its a wash +#+nil +(defun %test-headers (value target not-p function-p headers + &optional (drop-through (gen-label)) al-loaded) + (let ((lowtag (if function-p function-pointer-type other-pointer-type))) + (multiple-value-bind + (equal less-or-equal when-true when-false) + ;; EQUAL and LESS-OR-EQUAL are the conditions for branching to TARGET. + ;; WHEN-TRUE and WHEN-FALSE are the labels to branch to when we know + ;; it's true and when we know it's false respectively. + (if not-p + (values :ne :a drop-through target) + (values :e :na target drop-through)) + (%test-lowtag value when-false t lowtag al-loaded) + (inst mov al-tn (make-ea :byte :base value :disp (- lowtag))) + (let ((delta 0)) + (do ((remaining headers (cdr remaining))) + ((null remaining)) + (let ((header (car remaining)) + (last (null (cdr remaining)))) + (cond + ((atom header) + (inst sub al-tn (- header delta)) + (setf delta header) + (if last + (inst jmp equal target) + (inst jmp :e when-true))) + (t + (let ((start (car header)) + (end (cdr header))) + (unless (= start bignum-type) + (inst sub al-tn (- start delta)) + (setf delta start) + (inst jmp :l when-false)) + (inst sub al-tn (- end delta)) + (setf delta end) + (if last + (inst jmp less-or-equal target) + (inst jmp :le when-true)))))))) + (emit-label drop-through)))) + + +;;;; Type checking and testing: + +(define-vop (check-type) + (:args (value :target result :scs (any-reg descriptor-reg))) + (:results (result :scs (any-reg descriptor-reg))) + (:temporary (:sc unsigned-reg :offset rax-offset :to (:result 0)) rax) + (:ignore rax) + (:vop-var vop) + (:save-p :compute-only)) + +(define-vop (type-predicate) + (:args (value :scs (any-reg descriptor-reg))) + (:temporary (:sc unsigned-reg :offset rax-offset) rax) + (:ignore rax) + (:conditional) + (:info target not-p) + (:policy :fast-safe)) + +;;; Simpler VOP that don't need a temporary register. +(define-vop (simple-check-type) + (:args (value :target result :scs (any-reg descriptor-reg))) + (:results (result :scs (any-reg descriptor-reg) + :load-if (not (and (sc-is value any-reg descriptor-reg) + (sc-is result control-stack))))) + (:vop-var vop) + (:save-p :compute-only)) + +(define-vop (simple-type-predicate) + (:args (value :scs (any-reg descriptor-reg control-stack))) + (:conditional) + (:info target not-p) + (:policy :fast-safe)) + +(eval-when (compile eval) + +(defun cost-to-test-types (type-codes) + (+ (* 2 (length type-codes)) + (if (> (apply #'max type-codes) lowtag-limit) 7 2))) + +(defmacro def-type-vops (pred-name check-name ptype error-code + &rest type-codes) + (let ((cost (cost-to-test-types (mapcar #'eval type-codes)))) + `(progn + ,@(when pred-name + `((define-vop (,pred-name type-predicate) + (:translate ,pred-name) + (:generator ,cost + (test-type value target not-p ,@type-codes))))) + ,@(when check-name + `((define-vop (,check-name check-type) + (:generator ,cost + (let ((err-lab + (generate-error-code vop ,error-code value))) + (test-type value err-lab t ,@type-codes) + (move result value)))))) + ,@(when ptype + `((primitive-type-vop ,check-name (:check) ,ptype)))))) + +(defmacro def-simple-type-vops (pred-name check-name ptype error-code + &rest type-codes) + (let ((cost (cost-to-test-types (mapcar #'eval type-codes)))) + `(progn + ,@(when pred-name + `((define-vop (,pred-name simple-type-predicate) + (:translate ,pred-name) + (:generator ,cost + (test-type value target not-p ,@type-codes))))) + ,@(when check-name + `((define-vop (,check-name simple-check-type) + (:generator ,cost + (let ((err-lab + (generate-error-code vop ,error-code value))) + (test-type value err-lab t ,@type-codes) + (move result value)))))) + ,@(when ptype + `((primitive-type-vop ,check-name (:check) ,ptype)))))) + +); eval-when (compile eval) + +(def-simple-type-vops fixnump check-fixnum fixnum object-not-fixnum-error + even-fixnum-type odd-fixnum-type) + +(def-type-vops functionp check-function function + object-not-function-error function-pointer-type) + +(def-type-vops listp check-list list object-not-list-error + list-pointer-type) + +(def-type-vops %instancep check-instance instance object-not-instance-error + instance-pointer-type) + +(def-type-vops bignump check-bignum bignum + object-not-bignum-error bignum-type) + +(def-type-vops ratiop check-ratio ratio + object-not-ratio-error ratio-type) + +(def-type-vops complexp check-complex complex object-not-complex-error + complex-type complex-single-float-type complex-double-float-type + #+long-float complex-long-float-type) + +(def-type-vops complex-rational-p check-complex-rational nil + object-not-complex-rational-error complex-type) + +(def-type-vops complex-float-p check-complex-float nil + object-not-complex-float-error + complex-single-float-type complex-double-float-type + #+long-float complex-long-float-type) + +(def-type-vops complex-single-float-p check-complex-single-float + complex-single-float object-not-complex-single-float-error + complex-single-float-type) + +(def-type-vops complex-double-float-p check-complex-double-float + complex-double-float object-not-complex-double-float-error + complex-double-float-type) + +#+long-float +(def-type-vops complex-long-float-p check-complex-long-float + complex-long-float object-not-complex-long-float-error + complex-long-float-type) + +(def-type-vops single-float-p check-single-float single-float + object-not-single-float-error single-float-type) + +(def-type-vops double-float-p check-double-float double-float + object-not-double-float-error double-float-type) + +#+long-float +(def-type-vops long-float-p check-long-float long-float + object-not-long-float-error long-float-type) + +(def-type-vops simple-string-p check-simple-string simple-string + object-not-simple-string-error simple-string-type) + +(def-type-vops simple-bit-vector-p check-simple-bit-vector simple-bit-vector + object-not-simple-bit-vector-error simple-bit-vector-type) + +(def-type-vops simple-vector-p check-simple-vector simple-vector + object-not-simple-vector-error simple-vector-type) + +(def-type-vops simple-array-unsigned-byte-2-p + check-simple-array-unsigned-byte-2 + simple-array-unsigned-byte-2 + object-not-simple-array-unsigned-byte-2-error + simple-array-unsigned-byte-2-type) + +(def-type-vops simple-array-unsigned-byte-4-p + check-simple-array-unsigned-byte-4 + simple-array-unsigned-byte-4 + object-not-simple-array-unsigned-byte-4-error + simple-array-unsigned-byte-4-type) + +(def-type-vops simple-array-unsigned-byte-8-p + check-simple-array-unsigned-byte-8 + simple-array-unsigned-byte-8 + object-not-simple-array-unsigned-byte-8-error + simple-array-unsigned-byte-8-type) + +(def-type-vops simple-array-unsigned-byte-16-p + check-simple-array-unsigned-byte-16 + simple-array-unsigned-byte-16 + object-not-simple-array-unsigned-byte-16-error + simple-array-unsigned-byte-16-type) + +(def-type-vops simple-array-unsigned-byte-32-p + check-simple-array-unsigned-byte-32 + simple-array-unsigned-byte-32 + object-not-simple-array-unsigned-byte-32-error + simple-array-unsigned-byte-32-type) + +(def-type-vops simple-array-signed-byte-8-p + check-simple-array-signed-byte-8 + simple-array-signed-byte-8 + object-not-simple-array-signed-byte-8-error + simple-array-signed-byte-8-type) + +(def-type-vops simple-array-signed-byte-16-p + check-simple-array-signed-byte-16 + simple-array-signed-byte-16 + object-not-simple-array-signed-byte-16-error + simple-array-signed-byte-16-type) + +(def-type-vops simple-array-signed-byte-30-p + check-simple-array-signed-byte-30 + simple-array-signed-byte-30 + object-not-simple-array-signed-byte-30-error + simple-array-signed-byte-30-type) + +(def-type-vops simple-array-signed-byte-32-p + check-simple-array-signed-byte-32 + simple-array-signed-byte-32 + object-not-simple-array-signed-byte-32-error + simple-array-signed-byte-32-type) + +(def-type-vops simple-array-single-float-p check-simple-array-single-float + simple-array-single-float object-not-simple-array-single-float-error + simple-array-single-float-type) + +(def-type-vops simple-array-double-float-p check-simple-array-double-float + simple-array-double-float object-not-simple-array-double-float-error + simple-array-double-float-type) + +#+long-float +(def-type-vops simple-array-long-float-p check-simple-array-long-float + simple-array-long-float object-not-simple-array-long-float-error + simple-array-long-float-type) + +(def-type-vops simple-array-complex-single-float-p + check-simple-array-complex-single-float + simple-array-complex-single-float + object-not-simple-array-complex-single-float-error + simple-array-complex-single-float-type) + +(def-type-vops simple-array-complex-double-float-p + check-simple-array-complex-double-float + simple-array-complex-double-float + object-not-simple-array-complex-double-float-error + simple-array-complex-double-float-type) + +#+long-float +(def-type-vops simple-array-complex-long-float-p + check-simple-array-complex-long-float + simple-array-complex-long-float + object-not-simple-array-complex-long-float-error + simple-array-complex-long-float-type) + +(def-type-vops base-char-p check-base-char base-char + object-not-base-char-error base-char-type) + +(def-type-vops system-area-pointer-p check-system-area-pointer + system-area-pointer object-not-sap-error sap-type) + +(def-type-vops weak-pointer-p check-weak-pointer weak-pointer + object-not-weak-pointer-error weak-pointer-type) + +(def-type-vops scavenger-hook-p nil nil nil + #-gencgc 0 #+gencgc scavenger-hook-type) + +(def-type-vops code-component-p nil nil nil + code-header-type) + +(def-type-vops lra-p nil nil nil + return-pc-header-type) + +(def-type-vops fdefn-p nil nil nil + fdefn-type) + +(def-type-vops funcallable-instance-p nil nil nil + funcallable-instance-header-type) + +(def-type-vops array-header-p nil nil nil + simple-array-type complex-string-type complex-bit-vector-type + complex-vector-type complex-array-type) + +(def-type-vops nil check-function-or-symbol nil + object-not-function-or-symbol-error + function-pointer-type symbol-header-type) + +(def-type-vops stringp check-string nil object-not-string-error + simple-string-type complex-string-type) + +(def-type-vops bit-vector-p check-bit-vector nil object-not-bit-vector-error + simple-bit-vector-type complex-bit-vector-type) + +(def-type-vops vectorp check-vector nil object-not-vector-error + simple-string-type simple-bit-vector-type simple-vector-type + simple-array-unsigned-byte-2-type simple-array-unsigned-byte-4-type + simple-array-unsigned-byte-8-type simple-array-unsigned-byte-16-type + simple-array-unsigned-byte-32-type + simple-array-signed-byte-8-type simple-array-signed-byte-16-type + simple-array-signed-byte-30-type simple-array-signed-byte-32-type + simple-array-single-float-type simple-array-double-float-type + #+long-float simple-array-long-float-type + simple-array-complex-single-float-type + simple-array-complex-double-float-type + #+long-float simple-array-complex-long-float-type + complex-string-type complex-bit-vector-type complex-vector-type) + +(def-type-vops simple-array-p check-simple-array nil object-not-simple-array-error + simple-array-type simple-string-type simple-bit-vector-type + simple-vector-type simple-array-unsigned-byte-2-type + simple-array-unsigned-byte-4-type simple-array-unsigned-byte-8-type + simple-array-unsigned-byte-16-type simple-array-unsigned-byte-32-type + simple-array-signed-byte-8-type simple-array-signed-byte-16-type + simple-array-signed-byte-30-type simple-array-signed-byte-32-type + simple-array-single-float-type simple-array-double-float-type + #+long-float simple-array-long-float-type + simple-array-complex-single-float-type + simple-array-complex-double-float-type + #+long-float simple-array-complex-long-float-type) + +(def-type-vops arrayp check-array nil object-not-array-error + simple-array-type simple-string-type simple-bit-vector-type + simple-vector-type simple-array-unsigned-byte-2-type + simple-array-unsigned-byte-4-type simple-array-unsigned-byte-8-type + simple-array-unsigned-byte-16-type simple-array-unsigned-byte-32-type + simple-array-signed-byte-8-type simple-array-signed-byte-16-type + simple-array-signed-byte-30-type simple-array-signed-byte-32-type + simple-array-single-float-type simple-array-double-float-type + #+long-float simple-array-long-float-type + simple-array-complex-single-float-type + simple-array-complex-double-float-type + #+long-float simple-array-complex-long-float-type + complex-string-type complex-bit-vector-type complex-vector-type + complex-array-type) + +(def-type-vops numberp check-number nil object-not-number-error + even-fixnum-type odd-fixnum-type bignum-type ratio-type + single-float-type double-float-type #+long-float long-float-type complex-type + complex-single-float-type complex-double-float-type + #+long-float complex-long-float-type) + +(def-type-vops rationalp check-rational nil object-not-rational-error + even-fixnum-type odd-fixnum-type ratio-type bignum-type) + +(def-type-vops integerp check-integer nil object-not-integer-error + even-fixnum-type odd-fixnum-type bignum-type) + +(def-type-vops floatp check-float nil object-not-float-error + single-float-type double-float-type #+long-float long-float-type) + +(def-type-vops realp check-real nil object-not-real-error + even-fixnum-type odd-fixnum-type ratio-type bignum-type + single-float-type double-float-type #+long-float long-float-type) + + +;;;; Other integer ranges. + +;;; A (signed-byte 32) can be represented with either fixnum or a bignum with +;;; exactly one digit. + +;; need to look at this for large fixnum +(define-vop (signed-byte-32-p type-predicate) + (:translate signed-byte-32-p) + (:generator 45 + (multiple-value-bind + (yep nope) + (if not-p + (values not-target target) + (values target not-target)) + (generate-fixnum-test value) + (inst jmp :e yep) + (move rax-tn value) + (inst and al-tn lowtag-mask) + (inst cmp al-tn other-pointer-type) + (inst jmp :ne nope) + (loadw rax-tn value 0 other-pointer-type) + (inst cmp rax-tn (+ (ash 1 type-bits) bignum-type)) + (inst jmp (if not-p :ne :e) target)) + NOT-TARGET)) + +(define-vop (check-signed-byte-32 check-type) + (:generator 45 + (let ((nope (generate-error-code vop + object-not-signed-byte-32-error + value))) + (generate-fixnum-test value) + (inst jmp :e yep) + (move rax-tn value) + (inst and al-tn lowtag-mask) + (inst cmp al-tn other-pointer-type) + (inst jmp :ne nope) + (loadw rax-tn value 0 other-pointer-type) + (inst cmp rax-tn (+ (ash 1 type-bits) bignum-type)) + (inst jmp :ne nope)) + YEP + (move result value))) + +;;; An (unsigned-byte 32) can be represented with either a positive fixnum, a +;;; bignum with exactly one positive digit, or a bignum with exactly two digits +;;; and the second digit all zeros. + +;; Need to look at this for big fixnums +(define-vop (unsigned-byte-32-p type-predicate) + (:translate unsigned-byte-32-p) + (:generator 45 + (let ((not-target (gen-label)) + (single-word (gen-label)) + (fixnum (gen-label))) + (multiple-value-bind + (yep nope) + (if not-p + (values not-target target) + (values target not-target)) + ;; Is it a fixnum? + (generate-fixnum-test value) + (move rax-tn value) + (inst jmp :e fixnum) + + ;; If not, is it an other pointer? + (inst and al-tn lowtag-mask) + (inst cmp al-tn other-pointer-type) + (inst jmp :ne nope) + ;; Get the header. + (loadw rax-tn value 0 other-pointer-type) + ;; Is it one? + (inst cmp rax-tn (+ (ash 1 type-bits) bignum-type)) + (inst jmp :e single-word) + ;; If it's other than two, we can't be an (unsigned-byte 32) + (inst cmp rax-tn (+ (ash 2 type-bits) bignum-type)) + (inst jmp :ne nope) + ;; Get the second digit. + (loadw rax-tn value (1+ bignum-digits-offset) other-pointer-type) + ;; All zeros, its an (unsigned-byte 32). + (inst or rax-tn rax-tn) + (inst jmp :z yep) + (inst jmp nope) + + (emit-label single-word) + ;; Get the single digit. + (loadw rax-tn value bignum-digits-offset other-pointer-type) + + ;; positive implies (unsigned-byte 32). + (emit-label fixnum) + (inst or rax-tn rax-tn) + (inst jmp (if not-p :s :ns) target) + + (emit-label not-target))))) + +(define-vop (check-unsigned-byte-32 check-type) + (:generator 45 + (let ((nope + (generate-error-code vop object-not-unsigned-byte-32-error value)) + (yep (gen-label)) + (fixnum (gen-label)) + (single-word (gen-label))) + + ;; Is it a fixnum? + (generate-fixnum-test value) + (move rax-tn value) + (inst jmp :e fixnum) + + ;; If not, is it an other pointer? + (inst and al-tn lowtag-mask) + (inst cmp al-tn other-pointer-type) + (inst jmp :ne nope) + ;; Get the header. + (loadw rax-tn value 0 other-pointer-type) + ;; Is it one? + (inst cmp rax-tn (+ (ash 1 type-bits) bignum-type)) + (inst jmp :e single-word) + ;; If it's other than two, we can't be an (unsigned-byte 32) + (inst cmp rax-tn (+ (ash 2 type-bits) bignum-type)) + (inst jmp :ne nope) + ;; Get the second digit. + (loadw rax-tn value (1+ bignum-digits-offset) other-pointer-type) + ;; All zeros, its an (unsigned-byte 32). + (inst or rax-tn rax-tn) + (inst jmp :z yep) + (inst jmp nope) + + (emit-label single-word) + ;; Get the single digit. + (loadw rax-tn value bignum-digits-offset other-pointer-type) + + ;; positive implies (unsigned-byte 32). + (emit-label fixnum) + (inst or rax-tn rax-tn) + (inst jmp :s nope) + + (emit-label yep) + (move result value)))) + + +;;;; List/symbol types: +;;; +;;; symbolp (or symbol (eq nil)) +;;; consp (and list (not (eq nil))) + +(define-vop (symbolp type-predicate) + (:translate symbolp) + (:generator 12 + (let ((is-symbol-label (if not-p drop-thru target))) + (inst cmp value nil-value) + (inst jmp :e is-symbol-label) + (test-type value target not-p symbol-header-type)) + DROP-THRU)) + +(define-vop (check-symbol check-type) + (:generator 12 + (let ((error (generate-error-code vop object-not-symbol-error value))) + (inst cmp value nil-value) + (inst jmp :e drop-thru) + (test-type value error t symbol-header-type)) + DROP-THRU + (move result value))) + +(define-vop (consp type-predicate) + (:translate consp) + (:generator 8 + (let ((is-not-cons-label (if not-p target drop-thru))) + (inst cmp value nil-value) + (inst jmp :e is-not-cons-label) + (test-type value target not-p list-pointer-type)) + DROP-THRU)) + +(define-vop (check-cons check-type) + (:generator 8 + (let ((error (generate-error-code vop object-not-cons-error value))) + (inst cmp value nil-value) + (inst jmp :e error) + (test-type value error t list-pointer-type) + (move result value)))) diff --git a/compiler/amd64/values.lisp b/compiler/amd64/values.lisp new file mode 100644 index 0000000000000000000000000000000000000000..3808bdd50a68d0d3bd195db90912ef5ec9b20df5 --- /dev/null +++ b/compiler/amd64/values.lisp @@ -0,0 +1,135 @@ +;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; 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: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/amd64/values.lisp,v 1.1 2004/05/24 22:35:00 cwang Exp $") +;;; +;;; ********************************************************************** +;;; +;;; This file contains the implementation of unknown-values VOPs. +;;; +;;; Written by William Lott. +;;; +;;; Debugged by Paul F. Werkowski Spring/Summer 1995. +;;; %more-arg-values by Douglas Thomas Crosher, March 1996. +;;; Enhancements/debugging by Douglas T. Crosher 1996. + +(in-package :amd64) + +(define-vop (reset-stack-pointer) + (:args (ptr :scs (any-reg))) + (:generator 1 + (move rsp-tn ptr))) + +;;; Push some values onto the stack, returning the start and number of values +;;; pushed as results. It is assumed that the Vals are wired to the standard +;;; argument locations. Nvals is the number of values to push. +;;; +;;; The generator cost is pseudo-random. We could get it right by defining a +;;; bogus SC that reflects the costs of the memory-to-memory moves for each +;;; operand, but this seems unworthwhile. +;;; +(define-vop (push-values) + (:args (vals :more t)) + (:temporary (:sc unsigned-reg :to (:result 0) :target start) temp) + (:results (start) (count)) + (:info nvals) + (:generator 20 + (move temp rsp-tn) ; WARN pointing 1 below + (do ((val vals (tn-ref-across val))) + ((null val)) + (inst push (tn-ref-tn val))) + (move start temp) + (inst mov count (fixnumize nvals)))) + +;;; Push a list of values on the stack, returning Start and Count as used in +;;; unknown values continuations. +;;; +(define-vop (values-list) + (:args (arg :scs (descriptor-reg) :target list)) + (:arg-types list) + (:policy :fast-safe) + (:results (start :scs (any-reg)) + (count :scs (any-reg))) + (:temporary (:sc descriptor-reg :from (:argument 0) :to (:result 1)) list) + (:temporary (:sc descriptor-reg :to (:result 1)) nil-temp) + (:temporary (:sc unsigned-reg :offset rax-offset :to (:result 1)) rax) + (:vop-var vop) + (:save-p :compute-only) + (:generator 0 + (move list arg) + (move start rsp-tn) ; WARN pointing 1 below + (inst mov nil-temp nil-value) + + LOOP + (inst cmp list nil-temp) + (inst jmp :e done) + (pushw list cons-car-slot list-pointer-type) + (loadw list list cons-cdr-slot list-pointer-type) + (inst mov rax list) + (inst and al-tn lowtag-mask) + (inst cmp al-tn list-pointer-type) + (inst jmp :e loop) + (error-call vop bogus-argument-to-values-list-error list) + + DONE + (inst mov count start) ; start is high address + (inst sub count rsp-tn))) ; stackp is low address + +;;; Copy the more arg block to the top of the stack so we can use them +;;; as function arguments. +;;; +;;; Accepts a context as produced by more-arg-context; points to the first +;;; value on the stack, not 4 bytes above as in other contexts. +;;; +;;; Return a context that is 4 bytes above the first value, suitable for +;;; defining a new stack frame. +;;; +;;; +(define-vop (%more-arg-values) + (:args (context :scs (descriptor-reg any-reg) :target src) + (skip :scs (any-reg immediate)) + (num :scs (any-reg) :target count)) + (:arg-types * positive-fixnum positive-fixnum) + (:temporary (:sc any-reg :offset rsi-offset :from (:argument 0)) src) + (:temporary (:sc descriptor-reg :offset rax-offset) temp) + (:temporary (:sc unsigned-reg :offset rcx-offset) temp1) + (:results (start :scs (any-reg)) + (count :scs (any-reg))) + (:generator 20 + (sc-case skip + (immediate + (cond ((zerop (tn-value skip)) + (move src context) + (move count num)) + (t + (inst lea src (make-ea :qword :base context + :disp (- (* (tn-value skip) word-bytes)))) + (move count num) + (inst sub count (* (tn-value skip) word-bytes))))) + + (any-reg + (move src context) + (inst sub src skip) + (move count num) + (inst sub count skip))) + + (move temp1 count) + (inst mov start rsp-tn) + (inst jecxz done) ; check for 0 count? + + (inst shr temp1 word-shift) ; convert the fixnum to a count. + + (inst std) ; move down the stack as more value are copied to the bottom. + LOOP + (inst lods temp) + (inst push temp) + (inst loop loop) + + DONE)) + diff --git a/compiler/amd64/vm.lisp b/compiler/amd64/vm.lisp new file mode 100644 index 0000000000000000000000000000000000000000..2066c7a29f0e2ddd9a49f2c54485b9b0eb866024 --- /dev/null +++ b/compiler/amd64/vm.lisp @@ -0,0 +1,501 @@ +;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; Package: python-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: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/amd64/vm.lisp,v 1.1 2004/05/24 22:35:01 cwang Exp $") +;;; +;;; ********************************************************************** +;;; +;;; This file contains the VM definition noise for amd64. +;;; +;;; Written by William Lott +;;; +;;; Debugged by Paul F. Werkowski Spring/Summer 1995. +;;; Enhancements/debugging by Douglas T. Crosher 1996, 1997, 1998. +;;; + +(in-package :amd64) + + +;;;; Register specs + +(eval-when (compile eval) + +(defmacro defreg (name offset size) + (let ((offset-sym (symbolicate name "-OFFSET")) + (names-vector (symbolicate "*" size "-REGISTER-NAMES*"))) + `(progn + (eval-when (compile eval load) + (defconstant ,offset-sym ,offset)) + (setf (svref ,names-vector ,offset-sym) ,(symbol-name name))))) + +(defmacro defregset (name &rest regs) + `(eval-when (compile eval load) + (defconstant ,name + (list ,@(mapcar #'(lambda (name) (symbolicate name "-OFFSET")) regs))))) + +); eval-when + +;;; Byte registers. +;;; +;;; Note: the encoding here is different than that used by the chip. We +;;; use this encoding so that the compiler thinks that AX (and EAX) overlap +;;; AL and AH instead of AL and CL. +;;; +(eval-when (compile load eval) + (defvar *byte-register-names* (make-array 8 :initial-element nil))) +;;; +(defreg al 0 :byte) +(defreg ah 1 :byte) +(defreg cl 2 :byte) +(defreg ch 3 :byte) +(defreg dl 4 :byte) +(defreg dh 5 :byte) +(defreg bl 6 :byte) +(defreg bh 7 :byte) +;;; +(defregset byte-regs al ah cl ch dl dh bl bh) + +;;; Word registers. +;;; +(eval-when (compile load eval) + (defvar *word-register-names* (make-array 16 :initial-element nil))) +;;; +(defreg ax 0 :word) +(defreg cx 2 :word) +(defreg dx 4 :word) +(defreg bx 6 :word) +(defreg sp 8 :word) +(defreg bp 10 :word) +(defreg si 12 :word) +(defreg di 14 :word) +;;; +(defregset word-regs ax cx dx bx si di) + +;;; Double Word registers. +;;; +(eval-when (compile load eval) + (defvar *dword-register-names* (make-array 16 :initial-element nil))) +;;; +(defreg eax 0 :dword) +(defreg ecx 2 :dword) +(defreg edx 4 :dword) +(defreg ebx 6 :dword) +(defreg esp 8 :dword) +(defreg ebp 10 :dword) +(defreg esi 12 :dword) +(defreg edi 14 :dword) +;;; +(defregset dword-regs eax ecx edx ebx esi edi) + +;;; Quad Word registers. +;;; +(eval-when (compile load eval) + (defvar *qword-register-names* (make-array 16 :initial-element nil))) +;;; +(defreg rax 0 :qword) +(defreg rcx 2 :qword) +(defreg rdx 4 :qword) +(defreg rbx 6 :qword) +(defreg rsp 8 :qword) +(defreg rbp 10 :qword) +(defreg rsi 12 :qword) +(defreg rdi 14 :qword) +;;; +(defregset qword-regs rax rcx rdx rbx rsi rdi) + +;;; added by jrd +(eval-when (compile load eval) + (defvar *float-register-names* (make-array 8 :initial-element nil))) +(defreg fr0 0 :float) +(defreg fr1 1 :float) +(defreg fr2 2 :float) +(defreg fr3 3 :float) +(defreg fr4 4 :float) +(defreg fr5 5 :float) +(defreg fr6 6 :float) +(defreg fr7 7 :float) +(defregset float-regs fr0 fr1 fr2 fr3 fr4 fr5 fr6 fr7) + + +;;;; SB definitions. + +;;; Despite the fact that there are only 8 different registers, we consider +;;; them 16 in order to describe the overlap of byte registers. The only +;;; thing we need to represent is what registers overlap. Therefore, we +;;; consider bytes to take one unit, and words, dwords or qwords to take two. We +;;; don't need to tell the difference between words, dwords, and qwords, because +;;; you can't put two words in a dword. + +(define-storage-base registers :finite :size 16) + +;;; +;;; jrd changed this from size 1 to size 8. it doesn't seem to make much +;;; sense to use the 387's idea of a stack. 8 separate registers is easier +;;; to deal with. +;;; (define-storage-base float-registers :finite :size 1) +(define-storage-base float-registers :finite :size 8) + +(define-storage-base stack :unbounded :size 8) +(define-storage-base constant :non-packed) +(define-storage-base immediate-constant :non-packed) +(define-storage-base noise :unbounded :size 2) + + + +;;;; SC definitions. + +;;; +;;; Handy macro so we don't have to keep changing all the numbers whenever +;;; we insert a new storage class. +;;; +(defmacro define-storage-classes (&rest classes) + (collect ((forms)) + (let ((index 0)) + (dolist (class classes) + (let* ((sc-name (car class)) + (constant-name (symbolicate sc-name "-SC-NUMBER"))) + (forms `(define-storage-class ,sc-name ,index + ,@(cdr class))) + (forms `(defconstant ,constant-name ,index)) + (forms `(export ',constant-name)) + (incf index)))) + `(progn + ,@(forms)))) + +(define-storage-classes + + ;; Non-immediate constants in the constant pool + (constant constant) + + ;; Some FP constants can be generated in the i387 silicon. + (fp-constant immediate-constant) + + (immediate immediate-constant) + + ;; **** The stacks. + + ;; The control stack. + (control-stack stack) ; may be pointers, scanned by GC + + ;; The non-descriptor stacks. + (signed-stack stack) ; (signed-byte 32) + (unsigned-stack stack) ; (unsigned-byte 32) + (base-char-stack stack) ; non-descriptor characters. + (sap-stack stack) ; System area pointers. + (single-stack stack) ; single-floats + (double-stack stack :element-size 2) ; double-floats. + #+long-float + (long-stack stack :element-size 3) ; long-floats. + (complex-single-stack stack :element-size 2) ; complex-single-floats + (complex-double-stack stack :element-size 4) ; complex-double-floats + #+long-float + (complex-long-stack stack :element-size 6) ; complex-long-floats + + ;; **** Magic SCs. + + (ignore-me noise) + + ;; **** Things that can go in the integer registers. + + ;; We don't have to distinguish between descriptor and + ;; non-descriptor registers, because of the conservative GC. + ;; Therefore, we only use different scs to distinguish between + ;; descriptor and non-descriptor values and to specify size. + + + ;; Immediate descriptor objects. Don't have to be seen by GC, but nothing + ;; bad will happen if they are. (fixnums, characters, header values, etc). + (any-reg registers + :locations #.qword-regs + :element-size 2 +; :reserve-locations (#.rax-offset) + :constant-scs (immediate) + :save-p t + :alternate-scs (control-stack)) + + ;; Pointer descriptor objects. Must be seen by GC. + (descriptor-reg registers + :locations #.qword-regs + :element-size 2 +; :reserve-locations (#.rax-offset) + :constant-scs (constant immediate) + :save-p t + :alternate-scs (control-stack)) + + ;; Non-Descriptor characters + (base-char-reg registers + :locations #.byte-regs + :reserve-locations (#.ah-offset #.al-offset) + :constant-scs (immediate) + :save-p t + :alternate-scs (base-char-stack)) + + ;; Non-Descriptor SAP's (arbitrary pointers into address space) + (sap-reg registers + :locations #.qword-regs + :element-size 2 +; :reserve-locations (#.rax-offset) + :constant-scs (immediate) + :save-p t + :alternate-scs (sap-stack)) + + ;; Non-Descriptor (signed or unsigned) numbers. + (signed-reg registers + :locations #.qword-regs + :element-size 2 +; :reserve-locations (#.rax-offset) + :constant-scs (immediate) + :save-p t + :alternate-scs (signed-stack)) + (unsigned-reg registers + :locations #.qword-regs + :element-size 2 +; :reserve-locations (#.rax-offset) + :constant-scs (immediate) + :save-p t + :alternate-scs (unsigned-stack)) + + ;; Random objects that must not be seen by GC. Used only as temporaries. + (dword-reg registers + :locations #.dword-regs + :element-size 2 + ) + (word-reg registers + :locations #.word-regs + :element-size 2 +; :reserve-locations (#.ax-offset) + ) + (byte-reg registers + :locations #.byte-regs +; :reserve-locations (#.al-offset #.ah-offset) + ) + + ;; **** Things that can go in the floating point registers. + + ;; Non-Descriptor single-floats. + (single-reg float-registers + :locations (0 1 2 3 4 5 6 7) + :constant-scs (fp-constant) + :save-p t + :alternate-scs (single-stack)) + + ;; Non-Descriptor double-floats. + (double-reg float-registers + :locations (0 1 2 3 4 5 6 7) + :constant-scs (fp-constant) + :save-p t + :alternate-scs (double-stack)) + + ;; Non-Descriptor long-floats. + #+long-float + (long-reg float-registers + :locations (0 1 2 3 4 5 6 7) + :constant-scs (fp-constant) + :save-p t + :alternate-scs (long-stack)) + + (complex-single-reg float-registers + :locations (0 2 4 6) + :element-size 2 + :constant-scs () + :save-p t + :alternate-scs (complex-single-stack)) + + (complex-double-reg float-registers + :locations (0 2 4 6) + :element-size 2 + :constant-scs () + :save-p t + :alternate-scs (complex-double-stack)) + + #+long-float + (complex-long-reg float-registers + :locations (0 2 4 6) + :element-size 2 + :constant-scs () + :save-p t + :alternate-scs (complex-long-stack)) + + ;; A catch or unwind block. + (catch-block stack :element-size vm:catch-block-size) + ) + +(eval-when (compile load eval) + +(defconstant byte-sc-names '(base-char-reg byte-reg base-char-stack)) +(defconstant word-sc-names '(word-reg)) +(defconstant dword-sc-names '(dword-reg)) +(defconstant qword-sc-names + '(any-reg descriptor-reg sap-reg signed-reg unsigned-reg control-stack + signed-stack unsigned-stack sap-stack single-stack constant)) + +;;; +;;; added by jrd. I guess the right thing to do is to treat floats +;;; as a separate size... +;;; +;;; These are used to (at least) determine operand size. +(defconstant float-sc-names '(single-reg)) +(defconstant double-sc-names '(double-reg double-stack)) +) + + + +;;;; Random TNs for the various registers. + +(eval-when (compile eval) + (defmacro def-random-reg-tns (sc-name &rest reg-names) + (collect ((forms)) + (dolist (reg-name reg-names) + (let ((reg-tn-name (symbolicate reg-name "-TN")) + (reg-offset-name (symbolicate reg-name "-OFFSET"))) + ;;(forms `(export ',reg-tn-name)) + (forms `(defparameter ,reg-tn-name + (make-random-tn :kind :normal + :sc (sc-or-lose ',sc-name) + :offset ,reg-offset-name))))) + `(progn ,@(forms))))) + +(def-random-reg-tns unsigned-reg rax rbx rcx rdx rbp rsp rdi rsi) +(def-random-reg-tns dword-reg eax ebx ecx edx ebp esp edi esi) +(def-random-reg-tns word-reg ax bx cx dx bp sp di si) +(def-random-reg-tns byte-reg al ah bl bh cl ch dl dh) + +;; added by jrd +(def-random-reg-tns single-reg fr0 fr1 fr2 fr3 fr4 fr5 fr6 fr7) + +;; Added by pw. + +(defparameter fp-constant-tn + (make-random-tn :kind :normal + :sc (sc-or-lose 'fp-constant) + :offset 31)) ; Offset doesn't get used. + + +;;; Immediate-Constant-SC +;;; +;;; If value can be represented as an immediate constant, then return the +;;; appropriate SC number, otherwise return NIL. +;;; +(def-vm-support-routine immediate-constant-sc (value) + (typecase value + ((or fixnum system-area-pointer character) + (sc-number-or-lose 'immediate *backend*)) + (bignum + ;; during cross compilation, a fixnum in 64-bit may be a bignum in 32-bit + (when (<= target-most-negative-fixnum value target-most-positive-fixnum) + (sc-number-or-lose 'immediate *backend*))) + (symbol + (when (static-symbol-p value) + (sc-number-or-lose 'immediate *backend*))) + (single-float + (when (or (eql value 0f0) (eql value 1f0)) + (sc-number-or-lose 'fp-constant *backend*))) + (double-float + (when (or (eql value 0d0) (eql value 1d0)) + (sc-number-or-lose 'fp-constant *backend*))) + #+long-float + (long-float + (when (or (eql value 0l0) (eql value 1l0) + (eql value pi) + (eql value (log 10l0 2l0)) + (eql value (log 2.718281828459045235360287471352662L0 2l0)) + (eql value (log 2l0 10l0)) + (eql value (log 2l0 2.718281828459045235360287471352662L0))) + (sc-number-or-lose 'fp-constant *backend*))))) + + +;;;; Function Call Parameters + +;;; Offsets of special stack frame locations +(defconstant ocfp-save-offset 0) +(defconstant return-pc-save-offset 1) +(defconstant code-save-offset 2) + +;;; names of these things seem to have changed. these aliases by jrd +(defconstant lra-save-offset return-pc-save-offset) + +(defconstant cfp-offset rbp-offset) ; pfw - needed by stuff in /code + ; related to sigcontext stuff + +;;; The number of arguments/return values passed in registers. +;;; +(defconstant register-arg-count 3) + +;;; Names, Offsets, and TNs to use for the argument registers. +;;; +(defconstant register-arg-names '(rdx rdi rsi)) +(defregset register-arg-offsets rdx rdi rsi) +(defparameter register-arg-tns (list rdx-tn rdi-tn rsi-tn)) + +;;; SINGLE-VALUE-RETURN-BYTE-OFFSET +;;; +;;; This is used by the debugger. +;;; +(export 'single-value-return-byte-offset) +(defconstant single-value-return-byte-offset 2) + + +;;; LOCATION-PRINT-NAME -- Interface +;;; +;;; This function is called by debug output routines that want a pretty name +;;; for a TN's location. It returns a thing that can be printed with PRINC. +;;; +(def-vm-support-routine location-print-name (tn) + (declare (type tn tn)) + (let* ((sc (tn-sc tn)) + (sb (sb-name (sc-sb sc))) + (offset (tn-offset tn))) + (ecase sb + (registers + (let* ((sc-name (sc-name sc)) + (name-vec (cond ((member sc-name byte-sc-names) + *byte-register-names*) + ((member sc-name word-sc-names) + *word-register-names*) + ((member sc-name dword-sc-names) + *dword-register-names*) + ((member sc-name qword-sc-names) + *qword-register-names*)))) + (or (and name-vec + (< -1 offset (length name-vec)) + (svref name-vec offset)) + (format nil "<Unknown Reg: off=~D, sc=~A>" offset sc-name)))) + (float-registers (format nil "FR~D" offset)) + (stack (format nil "S~D" offset)) + (constant (format nil "Const~D" offset)) + (immediate-constant "Immed") + (noise (symbol-name (sc-name sc)))))) + +;; low 8-bit registers +(defun 64-bit-to-8-bit-tn (tn) + (case (tn-offset tn) + (#.rax-offset al-tn) + (#.rbx-offset bl-tn) + (#.rcx-offset cl-tn) + (#.rdx-offset dl-tn))) + +(defun 64-bit-to-16-bit-tn (tn) + (ecase (tn-offset tn) + (#.rax-offset ax-tn) + (#.rbx-offset bx-tn) + (#.rcx-offset cx-tn) + (#.rdx-offset dx-tn) + (#.rsi-offset si-tn) + (#.rdi-offset di-tn) + (#.rbp-offset bp-tn) + (#.rsp-offset sp-tn))) + +(defun 64-bit-to-32-bit-tn (qword-tn) + (ecase (tn-offset qword-tn) + (#.rax-offset eax-tn) + (#.rbx-offset ebx-tn) + (#.rcx-offset ecx-tn) + (#.rdx-offset edx-tn) + (#.rsi-offset esi-tn) + (#.rdi-offset edi-tn)))