Commit 85b80477 authored by cwang's avatar cwang
Browse files

amd64 assembly files

parent e50e46c2
;;; -*- 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/assembly/amd64/arith.lisp,v 1.1 2004/05/21 22:46:43 cwang Exp $")
;;;
;;; **********************************************************************
;;;
;;; Stuff to handle simple cases for generic arithmetic.
;;;
;;; Written by William Lott.
;;; Debugged by Paul Werkowski -- Spring/Summer 1995.
;;;
(in-package :amd64)
(eval-when (compile eval)
;;;; Addition, Subtraction, and Multiplication
(defmacro define-generic-arith-routine ((fun cost) &body body)
`(define-assembly-routine (,(symbolicate "GENERIC-" fun)
(:cost ,cost)
(:return-style :full-call)
(:translate ,fun)
(:policy :safe)
(:save-p t))
((:arg x (descriptor-reg any-reg) rdx-offset)
(:arg y (descriptor-reg any-reg)
;; this seems wrong esi-offset
rdi-offset)
(:res res (descriptor-reg any-reg) rdx-offset)
(:temp rax unsigned-reg rax-offset)
(:temp rbx unsigned-reg rbx-offset)
(:temp rcx unsigned-reg rcx-offset))
(inst test x 3) ; fixnum?
(inst jmp :nz DO-STATIC-FUN) ; no - do generic
(inst test y 3) ; fixnum?
(inst jmp :z DO-BODY) ; yes - doit here
DO-STATIC-FUN
(inst pop rax)
(inst push rbp-tn)
(inst lea rbp-tn (make-ea :qword :base rsp-tn :disp word-bytes))
(inst sub rsp-tn (* 2 word-bytes))
(inst push rax) ; callers return addr
(inst mov rcx (fixnumize 2)) ; arg count
(inst mov rbx (+ nil-value (static-function-offset
',(symbolicate "TWO-ARG-" fun))))
(inst jmp (make-ea :qword :base rbx))
DO-BODY
,@body))
); eval-when
(define-generic-arith-routine (+ 10)
(move res x)
(inst add res y)
(inst jmp :no OKAY)
(inst rcr res 1) ; carry has correct sign
(inst sar res 1) ; remove type bits
(move rcx res)
(with-fixed-allocation (res bignum-type (1+ bignum-digits-offset) rax)
(storew rcx res bignum-digits-offset other-pointer-type))
OKAY)
(define-generic-arith-routine (- 10)
;;; I can't figure out the flags on subtract. Overflow never gets
;;; set and carry always does. (- 0 most-negative-fixnum) can't be
;;; easily detected so just let the upper level stuff do it.
(inst jmp DO-STATIC-FUN)
;; this is junk code. clean this up!!!
(move res x)
(inst sub res y)
(inst jmp :no OKAY)
(inst rcr res 1)
(inst sar res 1) ; remove type bits
(move rcx res)
(with-fixed-allocation (res bignum-type (1+ bignum-digits-offset) rax)
(storew rcx res bignum-digits-offset other-pointer-type))
OKAY)
(define-generic-arith-routine (* 30)
(move rax x) ; must use rax for 64-bit result
(inst sar rax 2) ; remove *4 fixnum bias
(inst imul y) ; result in rdx:eax
(inst jmp :no okay) ; still fixnum
;; zzz jrd changed rdx to rbx in here, as rdx isn't listed as a temp, above
;; pfw says that loses big -- rdx is target for arg x and result res
;; note that 'rdx' is not defined -- using x
(inst shrd rax x 2) ; high bits from rdx
(inst sar x 2) ; now shift rdx too
(move rcx x) ; save high bits from cdq
(inst cdq) ; rdx:eax <- sign-extend of rax
(inst cmp x rcx)
(inst jmp :e SINGLE-WORD-BIGNUM)
(with-fixed-allocation (res bignum-type (+ bignum-digits-offset 2) rbx)
(storew rax res bignum-digits-offset other-pointer-type)
(storew rcx res (1+ bignum-digits-offset) other-pointer-type))
(inst jmp DONE)
SINGLE-WORD-BIGNUM
(with-fixed-allocation (res bignum-type (1+ bignum-digits-offset) rbx)
(storew rax res bignum-digits-offset other-pointer-type))
(inst jmp DONE)
OKAY
(move res rax)
DONE)
(define-assembly-routine (generic-negate
(:cost 10)
(:return-style :full-call)
(:policy :safe)
(:translate %negate)
(:save-p t))
((:arg x (descriptor-reg any-reg) rdx-offset)
(:res res (descriptor-reg any-reg) rdx-offset)
(:temp rax unsigned-reg rax-offset)
(:temp rcx unsigned-reg rcx-offset))
(inst test x 3)
(inst jmp :z FIXNUM)
(inst pop rax)
(inst push rbp-tn)
(inst lea rbp-tn (make-ea :qword :base rsp-tn :disp word-bytes))
(inst sub rsp-tn (fixnumize 2))
(inst push rax)
(inst mov rcx (fixnumize 1)) ; arg count
(inst mov rax (+ nil-value (static-function-offset '%negate)))
(inst jmp (make-ea :qword :base rax))
FIXNUM
(move res x)
(inst neg res) ; (- most-negative-fixnum) is BIGNUM
(inst jmp :no OKAY)
(inst shr res 2) ; sign bit is data - remove type bits
(move rcx res)
(with-fixed-allocation (res bignum-type (1+ bignum-digits-offset) rax)
(storew rcx res bignum-digits-offset other-pointer-type))
OKAY)
;;;; Comparison routines.
(eval-when (compile eval)
(defmacro define-cond-assem-rtn (name translate static-fn test)
`(define-assembly-routine (,name
(:cost 10)
(:return-style :full-call)
(:policy :safe)
(:translate ,translate)
(:save-p t))
((:arg x (descriptor-reg any-reg) rdx-offset)
(:arg y (descriptor-reg any-reg) rdi-offset)
(:res res descriptor-reg rdx-offset)
(:temp rax unsigned-reg rax-offset)
(:temp rcx unsigned-reg rcx-offset))
(inst test x 3)
(inst jmp :nz DO-STATIC-FN)
(inst test y 3)
(inst jmp :z DO-COMPARE)
DO-STATIC-FN
(inst pop rax)
(inst push rbp-tn)
(inst lea rbp-tn (make-ea :qword :base rsp-tn :disp word-bytes))
(inst sub rsp-tn (* 2 word-bytes))
(inst push rax)
(inst mov rcx (fixnumize 2))
(inst mov rax (+ nil-value
(static-function-offset ',static-fn)))
(inst jmp (make-ea :qword :base rax))
DO-COMPARE
(inst cmp x y)
(inst jmp ,test TRUE)
(inst mov res nil-value)
(inst pop rax)
(inst add rax 3) ; single value return
(inst jmp rax)
TRUE
(load-symbol res t)))
); eval-when
(define-cond-assem-rtn generic-< < two-arg-< :l)
(define-cond-assem-rtn generic-> > two-arg-> :g)
(define-assembly-routine (generic-eql
(:cost 10)
(:return-style :full-call)
(:policy :safe)
(:translate eql)
(:save-p t))
((:arg x (descriptor-reg any-reg) rdx-offset)
(:arg y (descriptor-reg any-reg) rdi-offset)
(:res res descriptor-reg rdx-offset)
(:temp rax unsigned-reg rax-offset)
(:temp rcx unsigned-reg rcx-offset))
(inst cmp x y)
(inst jmp :e RETURN-T)
(inst test x 3)
(inst jmp :z RETURN-NIL)
(inst test y 3)
(inst jmp :nz DO-STATIC-FN)
RETURN-NIL
(inst mov res nil-value)
(inst pop rax)
(inst add rax 3) ; single value return
(inst jmp rax)
DO-STATIC-FN
(inst pop rax)
(inst push rbp-tn)
(inst lea rbp-tn (make-ea :qword :base rsp-tn :disp word-bytes))
(inst sub rsp-tn (fixnumize 2))
(inst push rax) ; return address
(inst mov rcx (fixnumize 2)) ; number of arguments
(inst mov rax (+ nil-value (static-function-offset 'eql)))
(inst jmp (make-ea :qword :base rax))
RETURN-T
(load-symbol res t))
(define-assembly-routine (generic-=
(:cost 10)
(:return-style :full-call)
(:policy :safe)
(:translate =)
(:save-p t))
((:arg x (descriptor-reg any-reg) rdx-offset)
(:arg y (descriptor-reg any-reg) rdi-offset)
(:res res descriptor-reg rdx-offset)
(:temp rax unsigned-reg rax-offset)
(:temp rcx unsigned-reg rcx-offset)
)
(inst test x 3) ; descriptor?
(inst jmp :nz DO-STATIC-FN) ; yes do it here
(inst test y 3) ; descriptor?
(inst jmp :nz DO-STATIC-FN)
(inst cmp x y)
(inst jmp :e RETURN-T) ; ok
(inst mov res nil-value)
(inst pop rax)
(inst add rax 3)
(inst jmp rax)
DO-STATIC-FN
(inst pop rax)
(inst push rbp-tn)
(inst lea rbp-tn (make-ea :qword :base rsp-tn :disp word-bytes))
(inst sub rsp-tn (* 2 word-bytes))
(inst push rax)
(inst mov rcx (fixnumize 2))
(inst mov rax (+ nil-value (static-function-offset 'two-arg-=)))
(inst jmp (make-ea :qword :base rax))
RETURN-T
(load-symbol res t))
;;; 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.
;;;
;;; This assembly routine is called from the inline VOP and updates
;;; the state vector with new random numbers. The state vector is
;;; passed in the rAX register.
;;;
#+assembler ; we don't want a vop for this one.
(define-assembly-routine
(random-mt19937-update)
((:temp state unsigned-reg rax-offset)
(:temp k unsigned-reg rbx-offset)
(:temp y unsigned-reg rcx-offset)
(:temp tmp unsigned-reg rdx-offset))
;; Save the temporary registers.
(inst push k)
(inst push y)
(inst push tmp)
;; Generate a new set of results.
(inst xor k k)
LOOP1
(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)))
(inst mov tmp (make-ea :qword :base state :index k :scale 4
:disp (- (* (+ 1 3 vm:vector-data-offset)
vm:word-bytes)
vm:other-pointer-type)))
(inst and y #x80000000)
(inst and tmp #x7fffffff)
(inst or y tmp)
(inst shr y 1)
(inst jmp :nc skip1)
(inst xor y #x9908b0df)
SKIP1
(inst xor y (make-ea :qword :base state :index k :scale 4
:disp (- (* (+ 397 3 vm:vector-data-offset)
vm:word-bytes)
vm:other-pointer-type)))
(inst mov (make-ea :qword :base state :index k :scale 4
:disp (- (* (+ 3 vm:vector-data-offset) vm:word-bytes)
vm:other-pointer-type))
y)
(inst inc k)
(inst cmp k (- 624 397))
(inst jmp :b loop1)
LOOP2
(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)))
(inst mov tmp (make-ea :qword :base state :index k :scale 4
:disp (- (* (+ 1 3 vm:vector-data-offset)
vm:word-bytes)
vm:other-pointer-type)))
(inst and y #x80000000)
(inst and tmp #x7fffffff)
(inst or y tmp)
(inst shr y 1)
(inst jmp :nc skip2)
(inst xor y #x9908b0df)
SKIP2
(inst xor y (make-ea :qword :base state :index k :scale 4
:disp (- (* (+ (- 397 624) 3 vm:vector-data-offset)
vm:word-bytes)
vm:other-pointer-type)))
(inst mov (make-ea :qword :base state :index k :scale 4
:disp (- (* (+ 3 vm:vector-data-offset) vm:word-bytes)
vm:other-pointer-type))
y)
(inst inc k)
(inst cmp k (- 624 1))
(inst jmp :b loop2)
(inst mov y (make-ea :qword :base state
:disp (- (* (+ (- 624 1) 3 vm:vector-data-offset)
vm:word-bytes)
vm:other-pointer-type)))
(inst mov tmp (make-ea :qword :base state
:disp (- (* (+ 0 3 vm:vector-data-offset)
vm:word-bytes)
vm:other-pointer-type)))
(inst and y #x80000000)
(inst and tmp #x7fffffff)
(inst or y tmp)
(inst shr y 1)
(inst jmp :nc skip3)
(inst xor y #x9908b0df)
SKIP3
(inst xor y (make-ea :qword :base state
:disp (- (* (+ (- 397 1) 3 vm:vector-data-offset)
vm:word-bytes)
vm:other-pointer-type)))
(inst mov (make-ea :qword :base state
:disp (- (* (+ (- 624 1) 3 vm:vector-data-offset)
vm:word-bytes)
vm:other-pointer-type))
y)
;; Restore the temporary registers and return.
(inst pop tmp)
(inst pop y)
(inst pop k)
(inst ret))
;;; -*- 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/assembly/amd64/array.lisp,v 1.1 2004/05/21 22:46:43 cwang Exp $")
;;;
;;; **********************************************************************
;;;
;;; This file contains various array operations that are too expensive
;;; (in space) to do inline.
;;;
;;; Written by William Lott.
;;;
;;; Debugged by Paul F. Werkowski -- Spring 1995.
;;;
(in-package :amd64)
;;;; Allocation
(define-assembly-routine (allocate-vector
(:policy :fast-safe)
(:translate allocate-vector)
(:arg-types positive-fixnum
positive-fixnum
positive-fixnum))
((:arg type unsigned-reg rax-offset)
(:arg length any-reg rbx-offset)
(:arg words any-reg rcx-offset)
(:temp temp any-reg rdi-offset)
(:res result descriptor-reg rdx-offset))
;; compute the number of bytes
;; words is a fixnum
(inst lea result (make-ea :byte :base words :index words :disp
(+ 15 (* vector-data-offset word-bytes))))
(inst and result (lognot 15)) ; alignment
(pseudo-atomic
(allocation result result temp)
(inst lea result (make-ea :byte :base result :disp other-pointer-type))
(storew type result 0 other-pointer-type)
(storew length result vector-length-slot other-pointer-type))
(inst ret))
;;;; Hash primitives
(define-assembly-routine (sxhash-simple-string
(:translate %sxhash-simple-string)
(:policy :fast-safe)
(:result-types positive-fixnum))
((:arg string descriptor-reg rbx-offset)
(:res result any-reg rdx-offset)
(:temp length any-reg rdi-offset)
(:temp rsi unsigned-reg rsi-offset)
(:temp rcx unsigned-reg rcx-offset)
(:temp rax unsigned-reg rax-offset))
(declare (ignore result rsi rcx rax))
(loadw length string vector-length-slot other-pointer-type)
(inst jmp (make-fixup 'sxhash-simple-substring :assembly-routine)))
(define-assembly-routine (sxhash-simple-substring
(:translate %sxhash-simple-substring)
(:policy :fast-safe)
(:arg-types * positive-fixnum)
(:result-types positive-fixnum))
((:arg string descriptor-reg rbx-offset)
(:arg length any-reg rdi-offset)
(:res result any-reg rdx-offset)
(:temp rsi unsigned-reg rsi-offset)
(:temp rcx unsigned-reg rcx-offset)
(:temp rax unsigned-reg rax-offset))
;; Compute a pointer to where we are going to be extracting the bits.
(inst lea rsi (make-ea :byte :base string
:disp (- (* vector-data-offset word-bytes)
other-pointer-type)))
;; Initialize the result.
(inst xor result result)
;; Get the count. If it's zero, blow out.
(inst mov rcx length)
(inst jecxz done) ; I'd probably change all jecxz to jrcxz
;; Convert it into count of the number of full words. If zero, then skip
;; to the part that handles the tail.
(inst shr rcx 5) ; 2 tag bits + 3
(inst jecxz do-extra)
;; Clear the direction flag, so we advance through memory.
(inst cld)
LOOP
;; Merge each successive word with the result.
(inst lods rax) ; load 64-bits into rax and (+8 rsi)
(inst rol result 5)
(inst xor result rax)
(inst loop loop)
DO-EXTRA
;; Now we have to take care of any bytes that don't make up a full word.
;; First, check to see how many of them there are. If zero, blow out of
;; here. Otherwise, multiply by 8.
(inst mov rcx length)
(inst and rcx (fixnumize 7))
(inst jecxz done)
;; some bytes are left
(inst shl rcx 1)
;; Grab the last word.
(inst lods rax)
;; Convert the count into a mask. The count is multiplied by 8, so we just
;; shift -1 left, which shifts count*8 zeros into the low order end. We
;; then invert that, ending up with a mask of count*8 ones.
(inst mov rsi -1)
(inst shl rsi :cl)
(inst not rsi)
;; Use the mask to strip off the bits we arn't interested in, and merge
;; the remaining bits with the result.
(inst and rax rsi)
(inst rol result 5)
(inst xor result rax)
DONE
;; Force result to be a 32-bit positive fixnum because hash-vector is a
;; 32-bit vector. This hash function is not good. We need to use the
;; upper half of the word and change the hash-vector.
(inst and result #x7ffffffc)
(inst ret))
;;; -*- 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/assembly/amd64/assem-rtns.lisp,v 1.1 2004/05/21 22:46:43 cwang Exp $")
;;;
;;; **********************************************************************
;;;
;;; This file contains the machine specific support routines needed by
;;; the file assembler.
;;;
;;; Written by William Lott
;;;
;;; Debugged by Paul F. Werkowski -- Spring/Summer 1995.
;;; Enhancements/debugging by Douglas T. Crosher 1997.
;;;
(in-package :amd64)
;;;; Return-multiple
;;; For return-multiple, we have to move the results from the end of the
;;; frame for the function that is returning to the end of the frame for
;;; the function being returned to.
#+assembler ;; we don't want a vop for this one.
(define-assembly-routine
(return-multiple (:return-style :none))
(;; These four are really arguments.
(:temp rax unsigned-reg rax-offset) ; the return-pc to finally jump to.
(:temp rbx unsigned-reg rbx-offset) ; pointer to where to put the values.
(:temp rcx unsigned-reg rcx-offset) ; number of values to find there.
(:temp rsi unsigned-reg rsi-offset) ; pointer to where to find the values.
;; These we need as temporaries.
(:temp rdx unsigned-reg rdx-offset)
(:temp rdi unsigned-reg rdi-offset))
;; Pick off the cases where everything fits in register args.
(inst jecxz zero-values)
(inst cmp rcx (fixnumize 1))
(inst jmp :e one-value)
(inst cmp rcx (fixnumize 2))
(inst jmp :e two-values)
(inst cmp rcx (fixnumize 3))
(inst jmp :e three-values)
;; Save the count, because the loop is going to destroy it.
(inst mov rdx rcx)
;; Blit the values down the stack. Note: there might be overlap, so we have
;; to be careful not to clobber values before we've read them. Because the
;; stack builds down, we are copying to a larger address. Therefore, we need
;; to iterate from larger addresses to smaller addresses.
;; pfw-this says copy rcx words from rsi to rdi counting down.
(inst shr rcx 2) ; fixnum to raw word count
(inst std) ; count down
(inst sub rsi 8) ; ?
(inst lea rdi (make-ea :qword :base rbx :disp (-