assem-rtns.lisp 8.48 KB
Newer Older
cwang's avatar
cwang committed
1 2 3 4 5 6 7 8 9
;;; -*- 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
10
 "$Header: src/assembly/amd64/assem-rtns.lisp $")
cwang's avatar
cwang committed
11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44
;;;
;;; **********************************************************************
;;; 
;;; 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.
cwang's avatar
cwang committed
45
  (inst jrcxz zero-values)
cwang's avatar
cwang committed
46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115
  (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
rtoy's avatar
rtoy committed
116 117
;;; stack frame (where args are produced) to the start of our stack frame
;;; (where args are expected).
cwang's avatar
cwang committed
118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146
;;;
;;; 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)

rtoy's avatar
rtoy committed
147
  ;; Save the OLD-FP and RETURN-PC because the blit is going to trash
cwang's avatar
cwang committed
148 149 150 151 152 153
  ;; 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)

rtoy's avatar
rtoy committed
154
  ;; Do the blit.  Because we are copying from smaller addresses to larger
cwang's avatar
cwang committed
155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180
  ;; 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.
rtoy's avatar
rtoy committed
181 182 183 184
  (inst jmp 
	(make-ea :byte :base rax
		 :disp (- (* closure-function-slot word-bytes)
			  function-pointer-type)))
cwang's avatar
cwang committed
185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242

  ;; 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)
cwang's avatar
cwang committed
243 244
			  (:temp uwp unsigned-reg rsi-offset)
			  (:temp temp unsigned-reg r11-offset))
cwang's avatar
cwang committed
245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264
  (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)
cwang's avatar
cwang committed
265
  (store-symbol-value uwp lisp::*current-unwind-protect-block* temp)
cwang's avatar
cwang committed
266 267 268 269 270 271 272 273 274 275 276
  
  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))))