Loading assembly/amd64/alloc.lisp 0 → 100644 +1 −0 Original line number Diff line number Diff line ;; Just a dummy file to keep comcom happy. assembly/amd64/arith.lisp 0 → 100644 +413 −0 Original line number Diff line number Diff line ;;; -*- 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)) assembly/amd64/array.lisp 0 → 100644 +135 −0 Original line number Diff line number Diff line ;;; -*- 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)) Loading
assembly/amd64/alloc.lisp 0 → 100644 +1 −0 Original line number Diff line number Diff line ;; Just a dummy file to keep comcom happy.
assembly/amd64/arith.lisp 0 → 100644 +413 −0 Original line number Diff line number Diff line ;;; -*- 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))
assembly/amd64/array.lisp 0 → 100644 +135 −0 Original line number Diff line number Diff line ;;; -*- 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))