Skip to content
Snippets Groups Projects
Commit 85b80477 authored by cwang's avatar cwang
Browse files

amd64 assembly files

parent e50e46c2
No related branches found
No related tags found
No related merge requests found
;;; -*- 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 (- word-bytes)))
(inst rep)
(inst movs :qword)
;; Restore the count.
(inst mov rcx rdx)
;; Set the stack top to the last result.
(inst lea rsp-tn (make-ea :qword :base rdi :disp word-bytes))
;; Load the register args.
(loadw rdx rbx -1)
(loadw rdi rbx -2)
(loadw rsi rbx -3)
;; And back we go.
(inst jmp rax)
;; Handle the register arg cases.
ZERO-VALUES
(move rsp-tn rbx)
(inst mov rdx nil-value)
(inst mov rdi rdx)
(inst mov rsi rdx)
(inst jmp rax)
ONE-VALUE ; Note: we can get this, because the return-multiple vop
; doesn't check for this case when size > speed.
(loadw rdx rsi -1)
(inst mov rsp-tn rbx)
(inst add rax 3)
(inst jmp rax)
TWO-VALUES
(loadw rdx rsi -1)
(loadw rdi rsi -2)
(inst mov rsi nil-value)
(inst lea rsp-tn (make-ea :qword :base rbx :disp (* -2 word-bytes)))
(inst jmp rax)
THREE-VALUES
(loadw rdx rsi -1)
(loadw rdi rsi -2)
(loadw rsi rsi -3)
(inst lea rsp-tn (make-ea :qword :base rbx :disp (* -3 word-bytes)))
(inst jmp rax))
;;;; tail-call-variable.
;;; For tail-call-variable, we have to copy the arguments from the end of our
;;; stack frame (were args are produced) to the start of our stack frame
;;; (were args are expected).
;;;
;;; We take the function to call in rAX and a pointer to the arguments in
;;; rSI. rBP says the same over the jump, and the old frame pointer is
;;; still saved in the first stack slot. The return-pc is saved in
;;; the second stack slot, so we have to push it to make it look like
;;; we actually called. We also have to compute rCX from the difference
;;; between rSI and the stack top.
;;;
#+assembler ;; no vop for this one either.
(define-assembly-routine
(tail-call-variable
(:return-style :none))
((:temp rax unsigned-reg rax-offset)
(:temp rbx unsigned-reg rbx-offset)
(:temp rcx unsigned-reg rcx-offset)
(:temp rdx unsigned-reg rdx-offset)
(:temp rdi unsigned-reg rdi-offset)
(:temp rsi unsigned-reg rsi-offset))
;; Calculate NARGS (as a fixnum)
(move rcx rsi)
(inst sub rcx rsp-tn)
(inst shr rcx 1)
;; Check for all the args fitting the the registers.
(inst cmp rcx (fixnumize 3))
(inst jmp :le REGISTER-ARGS)
;; Save the OLD-FP and RETURN-PC because the blit it going to trash
;; those stack locations. Save the rCX, because the loop is going
;; to trash it.
(pushw rbp-tn -1)
(loadw rbx rbp-tn -2)
(inst push rcx)
;; Do the blit. Because we are coping from smaller addresses to larger
;; addresses, we have to start at the largest pair and work our way down.
(inst shr rcx 2) ; fixnum to raw words
(inst std) ; count down
(inst lea rdi (make-ea :qword :base rbp-tn :disp (- word-bytes)))
(inst sub rsi word-bytes)
(inst rep)
(inst movs :qword)
;; Load the register arguments carefully.
(loadw rdx rbp-tn -1)
;; Restore OLD-FP and rCX.
(inst pop rcx)
(popw rbp-tn -1) ; overwrites a0
;; Blow off the stack above the arguments.
(inst lea rsp-tn (make-ea :qword :base rdi :disp word-bytes))
;; remaining register args
(loadw rdi rbp-tn -2)
(loadw rsi rbp-tn -3)
;; Push the (saved) return-pc so it looks like we just called.
(inst push rbx)
;; And jump into the function.
(inst jmp
(make-ea :byte :base rax
:disp (- (* closure-function-slot word-bytes)
function-pointer-type)))
;; All the arguments fit in registers, so load them.
REGISTER-ARGS
(loadw rdx rsi -1)
(loadw rdi rsi -2)
(loadw rsi rsi -3)
;; Clear most of the stack.
(inst lea rsp-tn
(make-ea :qword :base rbp-tn :disp (* -3 word-bytes)))
;; Push the return-pc so it looks like we just called.
(pushw rbp-tn -2)
;; And away we go.
(inst jmp (make-ea :byte :base rax
:disp (- (* closure-function-slot word-bytes)
function-pointer-type))))
(define-assembly-routine (throw
(:return-style :none))
((:arg target (descriptor-reg any-reg) rdx-offset)
(:arg start any-reg rbx-offset)
(:arg count any-reg rcx-offset)
(:temp catch any-reg rax-offset))
(declare (ignore start count))
(load-symbol-value catch lisp::*current-catch-block*)
LOOP
(let ((error (generate-error-code nil unseen-throw-tag-error target)))
(inst or catch catch) ; check for NULL pointer
(inst jmp :z error))
(inst cmp target (make-ea-for-object-slot catch catch-block-tag-slot 0))
(inst jmp :e exit)
(loadw catch catch catch-block-previous-catch-slot)
(inst jmp loop)
EXIT
;; Here rAX points to catch block containing symbol pointed to by rDX.
(inst jmp (make-fixup 'unwind :assembly-routine)))
;;;; Non-local exit noise.
(define-assembly-routine (unwind
(:return-style :none)
(:translate %continue-unwind)
(:policy :fast-safe))
((:arg block (any-reg descriptor-reg) rax-offset)
(:arg start (any-reg descriptor-reg) rbx-offset)
(:arg count (any-reg descriptor-reg) rcx-offset)
(:temp uwp unsigned-reg rsi-offset))
(declare (ignore start count))
(let ((error (generate-error-code nil invalid-unwind-error)))
(inst or block block) ; check for NULL pointer
(inst jmp :z error))
(load-symbol-value uwp lisp::*current-unwind-protect-block*)
;; Does *cuwpb* match value stored in argument cuwp slot?
(inst cmp uwp
(make-ea-for-object-slot block unwind-block-current-uwp-slot 0))
;; If a match, return to context in arg block.
(inst jmp :e do-exit)
;; Not a match - return to *current-unwind-protect-block* context.
;; Important! Must save (and return) the arg 'block' for later use!!
(move rdx-tn block)
(move block uwp)
;; Set next unwind protect context.
(loadw uwp uwp unwind-block-current-uwp-slot)
(store-symbol-value uwp lisp::*current-unwind-protect-block*)
DO-EXIT
(loadw rbp-tn block unwind-block-current-cont-slot)
;; Uwp-entry expects some things in known locations so that they can
;; be saved on the stack: the block in rdx-tn; start in rbx-tn; and
;; count in rcx-tn
(inst jmp (make-ea :byte :base block
:disp (* unwind-block-entry-pc-slot word-bytes))))
;;; -*- 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/support.lisp,v 1.1 2004/05/21 22:46:43 cwang Rel $")
;;;
;;; **********************************************************************
;;;
;;; This file contains the machine specific support routines needed by
;;; the file assembler.
;;;
;;; Written by William Lott.
;;;
(in-package :amd64)
(def-vm-support-routine generate-call-sequence (name style vop)
(ecase style
(:raw
(values
`((inst call (make-fixup ',name :assembly-routine)))
nil))
(:full-call
(values
`((note-this-location ,vop :call-site)
(inst call (make-fixup ',name :assembly-routine))
(note-this-location ,vop :single-value-return)
(move rsp-tn rbx-tn))
'((:save-p :compute-only))))
(:none
(values
`((inst jmp (make-fixup ',name :assembly-routine)))
nil))))
(def-vm-support-routine generate-return-sequence (style)
(ecase style
(:raw
`(inst ret))
(:full-call
`(
(inst pop rax-tn)
(inst add rax-tn 3) ; single value return
(inst jmp rax-tn)))
(:none)))
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment