assem-rtns.lisp 10.3 KB
Newer Older
chiles's avatar
chiles committed
1 2 3 4
;;; -*- Package: RT; Log: c.log -*-
;;;
;;; **********************************************************************
;;; This code was written as part of the CMU Common Lisp project at
ram's avatar
ram committed
5 6 7
;;; Carnegie Mellon University, and has been placed in the public domain.
;;;
(ext:file-comment
8
  "$Header: src/assembly/rt/assem-rtns.lisp $")
ram's avatar
ram committed
9
;;;
chiles's avatar
chiles committed
10 11
;;; **********************************************************************
;;;
12
;;; $Header: src/assembly/rt/assem-rtns.lisp $
chiles's avatar
chiles committed
13 14 15 16 17 18 19 20 21
;;;

(in-package "RT")



;;;; Non-local exit noise.

(define-assembly-routine (unwind (:translate %continue-unwind)
chiles's avatar
chiles committed
22
				 (:return-style :none)
chiles's avatar
chiles committed
23 24 25 26 27 28 29 30 31 32 33 34 35 36 37
				 (:policy :fast-safe))
			 ((:arg block (word-pointer-reg any-reg descriptor-reg)
				a0-offset)
			  (:arg start (word-pointer-reg any-reg descriptor-reg)
				ocfp-offset)
			  (:arg count (any-reg descriptor-reg) nargs-offset)
			  (:temp lip interior-reg lip-offset)
			  (:temp lra descriptor-reg lra-offset)
			  (:temp cur-uwp any-reg nl0-offset)
			  (:temp next-uwp any-reg cname-offset)
			  (:temp target-uwp any-reg lexenv-offset))
  (declare (ignore start count))

  (let ((error (generate-error-code nil invalid-unwind-error)))
    (inst c block 0)
chiles's avatar
chiles committed
38
    (inst bc :eq error))
chiles's avatar
chiles committed
39 40 41 42 43 44 45 46 47 48

  (load-symbol-value cur-uwp lisp::*current-unwind-protect-block*)
  (loadw target-uwp block unwind-block-current-uwp-slot)
  (inst c cur-uwp target-uwp)
  (inst bnc :eq do-uwp)

  (move cur-uwp block)

  DO-EXIT

chiles's avatar
chiles committed
49
  (loadw cfp-tn cur-uwp unwind-block-current-cont-slot)
chiles's avatar
chiles committed
50 51 52 53 54 55 56 57 58 59
  (loadw code-tn cur-uwp unwind-block-current-code-slot)
  (loadw lra cur-uwp unwind-block-entry-pc-slot)
  (lisp-return lra lip :frob-code nil)

  DO-UWP

  (loadw next-uwp cur-uwp unwind-block-current-uwp-slot)
  (inst bx do-exit)
  (store-symbol-value next-uwp lisp::*current-unwind-protect-block*))

chiles's avatar
chiles committed
60 61
(define-assembly-routine (throw
			  (:return-style :none))
chiles's avatar
chiles committed
62 63 64 65 66 67 68
			 ((:arg target descriptor-reg a0-offset)
			  (:arg start word-pointer-reg ocfp-offset)
			  (:arg count any-reg nargs-offset)
			  (:temp catch any-reg a1-offset)
			  (:temp tag descriptor-reg a2-offset)
			  (:temp ndescr non-descriptor-reg nl0-offset))
  
chiles's avatar
chiles committed
69 70 71
  ;; These are needed by UNWIND, but not by us directly.
  (declare (ignore start count))

chiles's avatar
chiles committed
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
  (load-symbol-value catch lisp::*current-catch-block*)
  
  LOOP

  (let ((error (generate-error-code nil unseen-throw-tag-error target)))
    (inst c catch 0)
    (inst bc :eq error))

  (loadw tag catch catch-block-tag-slot)
  (inst c tag target)
  (inst bc :eq exit)
  (loadw catch catch catch-block-previous-catch-slot)
  (inst b loop)

  EXIT

  (move target catch)
  (inst cai ndescr (make-fixup 'unwind :assembly-routine))
  (inst b ndescr))



;;;; Return unknown multiple values (known not to be one value).

(define-assembly-routine really-return-multiple
			 ((:arg ocfp any-reg nl0-offset)
			  (:arg lra descriptor-reg lra-offset)
			  ;; Pointer into cstack, so looks like fixnum.
			  (:arg src any-reg cname-offset)
			  (:arg nvals any-reg nargs-offset)

chiles's avatar
chiles committed
103
			  (:temp lip interior-reg lip-offset)
chiles's avatar
chiles committed
104 105 106
			  (:temp count any-reg ocfp-offset)
			  ;; Pointer into cstack, so looks like fixnum.
			  (:temp dst any-reg lexenv-offset)
chiles's avatar
chiles committed
107
			  (:temp temp any-reg nfp-offset)
chiles's avatar
chiles committed
108 109 110 111 112 113 114 115
			  (:temp a0 descriptor-reg a0-offset)
			  (:temp a1 descriptor-reg a1-offset)
			  (:temp a2 descriptor-reg a2-offset))
  ;;
  ;; Load the register args, bailing out when we are done.
  (inst c nvals 0)
  (inst bc :eq default-a0-and-on)
  (loadw a0 src 0)
116
  (inst c nvals (fixnumize 1))
chiles's avatar
chiles committed
117 118
  (inst bc :eq default-a1-and-on)
  (loadw a1 src 1)
119
  (inst c nvals (fixnumize 2))
chiles's avatar
chiles committed
120 121 122 123 124
  (inst bc :eq default-a2-and-on)
  (loadw a2 src 2)
  ;;
  ;; Copy the remaining args to the top of the stack.
  (inst inc src (* word-bytes register-arg-count))
chiles's avatar
chiles committed
125
  (inst cal dst cfp-tn (* word-bytes register-arg-count))
126
  (inst s count nvals (fixnumize 3))
chiles's avatar
chiles committed
127 128 129 130 131 132
  (inst bnc :gt done)
  LOOP
  (loadw temp src)
  (inst inc src word-bytes)
  (storew temp dst)
  (inst inc dst word-bytes)
133
  (inst s count (fixnumize 1))
chiles's avatar
chiles committed
134 135 136 137 138 139 140 141 142 143 144 145 146 147
  (inst bc :gt loop)
  (inst b done)
  ;;
  ;; Default some number of registers.
  DEFAULT-A0-AND-ON
  (move a0 null-tn)
  DEFAULT-A1-AND-ON
  (move a1 null-tn)
  DEFAULT-A2-AND-ON
  (move a2 null-tn)
  ;;
  ;; Clear the stack.
  DONE
  (move count cfp-tn) ;Put pointer to the start of values in ocfp.
chiles's avatar
chiles committed
148 149
  (inst cas csp-tn nvals count) ;Adjust the stack top: <ptr-to-vals>+<nvals>.
  (move cfp-tn ocfp) ;Restore returnee's fp.
chiles's avatar
chiles committed
150 151 152 153 154 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 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198
  ;;
  ;; Return.
  (lisp-return lra lip))



;;;; Copying more args on call (known to be at least one more arg.)

;;; REALLY-COPY-MORE-ARGS -- Assembler Routine.
;;;
;;; This miscop has weird register usage conventions, since it is called at the
;;; very beginning of entry to a more-arg XEP.  All of the registers used
;;; by the full call convention are in use, and must not be trashed, but none
;;; of the normal local & temporary registers are in use, since we haven't done
;;; anything yet.  The number of fixed arguments is passed in a3, since we
;;; can't trash a0..a2.
;;;
;;; The VOP COPY-MORE-ARG has allocated some temporaries for us: a3, l0, l1.

;;; The registers we can use are NL1, A3, L0 and L1.  We save L2 and L3 to give
;;; us some more registers to work with.  The caller saves the function return
;;; PC in L2 (the now unused NAME) so that it can be used for the miscop return
;;; PC.
;;;
;;; What we do is fairly simple: we copy the incoming more arguments (index >=
;;; a3) onto the top of the stack.  The loop runs backwards, since we are
;;; copying args upward on the stack, and the source and destination can
;;; overlap.
;;;
;;; This loop terminates when we either run out of more args to copy or we run
;;; out of stack arguments.  If we run out of stack arguments before we finish,
;;; then there are register more args.  In this case, we dispatch off of the
;;; number of fixed arguments (A3) to determine how many argument registers to
;;; store.
;;;
(define-assembly-routine really-copy-more-args
			 ;; Fixedargs contains the number of fixed arguments.
			 ((:arg fixedargs any-reg cname-offset)
			  (:temp count/src any-reg nfp-offset)
			  (:temp ocsp any-reg nl0-offset)
			  ;; Temporaries to get my hands on argument registers.
			  (:temp a0 any-reg a0-offset)
			  (:temp a1 any-reg a1-offset)
			  (:temp a2 any-reg a2-offset)
			  ;; We save the contents of these registers before
			  ;; using them.
			  (:temp srcstart any-reg lexenv-offset)
			  (:temp dstend any-reg lra-offset)
			  (:temp temp any-reg ocfp-offset))
199 200
  ;; First, save count/src (the NFP) on the number stack.  We need to do this
  ;; instead of with the other saves, because we need to use this register to
rtoy's avatar
rtoy committed
201
  ;; figure out where to save the others.  We can't save them all there,
202 203
  ;; because some of the others hold descriptor values.
  (storew count/src nsp-tn -1)
chiles's avatar
chiles committed
204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222
  ;; How many more args are there to copy to the stack?
  (move count/src nargs-tn)
  (inst s count/src fixedargs)
  ;; Save the current stack top as the start of the more args.
  (move ocsp csp-tn)
  ;; Bump the stack by the number of more args.
  (inst cas csp-tn csp-tn count/src)
  ;; Bump the stack three for the registers we have to save.
  (inst cal csp-tn csp-tn (* 3 word-bytes))

  ;; Dump the registers to make room for the temporaries we need.
  (storew srcstart csp-tn -3)
  (storew dstend csp-tn -2)
  (storew temp csp-tn -1)

  ;; Compute the source start, but remember we are copying from the end.
  ;; The start location is the last one we copy.
  (inst cal srcstart cfp-tn (* register-arg-count word-bytes))
  ;; Compute the source location of the last more arg.
chiles's avatar
chiles committed
223
  (inst cas count/src nargs-tn cfp-tn)
chiles's avatar
chiles committed
224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244
  (inst dec count/src word-bytes) ;not an exclusive end.
  ;; Compute destination end, which is the stack pointer minus three register
  ;; slots we saved and minus one to make it an inclusive end.
  (inst cal dstend csp-tn (* -4 word-bytes))

  ;; Copy some args.
  (inst b cma-test)
  CMA-LOOP
  (loadw temp count/src)
  (storew temp dstend)
  (inst dec count/src word-bytes)
  (inst dec dstend word-bytes)
  CMA-TEST
  ;; Are we totally done?
  (inst c dstend ocsp)
  (inst bc :lt CMA-DONE)
  ;; Are we done copying stack more args?
  (inst c count/src srcstart)
  (inst bnc :lt CMA-LOOP)
  
  ;; Figure out which argument registers may be more args.
245
  (inst c fixedargs (fixnumize 2))
chiles's avatar
chiles committed
246
  (inst bc :eq two-fixed-args)
247
  (inst c fixedargs (fixnumize 1))
chiles's avatar
chiles committed
248 249 250 251
  (inst bc :eq one-fixed-arg)
  
  ;; Copy register more args being careful to stop before running out of args.
  (storew a0 ocsp)
252
  (inst c nargs-tn (fixnumize 1))
chiles's avatar
chiles committed
253 254 255 256
  (inst bc :eq CMA-DONE)
  (inst inc ocsp word-bytes)
  ONE-FIXED-ARG
  (storew a1 ocsp)
257
  (inst c nargs-tn (fixnumize 2))
chiles's avatar
chiles committed
258 259 260 261 262 263 264 265 266 267
  (inst bc :eq CMA-DONE)
  (inst inc ocsp word-bytes)
  TWO-FIXED-ARGS
  (storew a2 ocsp)

  ;; Restore registers we dumped.
  CMA-DONE
  (loadw srcstart csp-tn -3)
  (loadw dstend csp-tn -2)
  (loadw temp csp-tn -1)
268
  (inst dec csp-tn (* 3 word-bytes))
269
  (loadw count/src nsp-tn -1)
chiles's avatar
chiles committed
270 271 272 273 274 275 276 277 278 279
  (inst b lip-tn))



;;;; Tail call variable.

(define-assembly-routine (really-tail-call-variable (:return-style :none))
			 ;; These are really args.
			 ((:temp args any-reg nl0-offset)
			  ;; These are needed by the blitting code.
280 281 282
			  (:temp count any-reg lra-offset)
			  (:temp dst any-reg lexenv-offset)
			  (:temp nargs any-reg nargs-offset)
chiles's avatar
chiles committed
283 284 285 286 287 288
			  (:temp temp descriptor-reg cname-offset)
			  ;; These are needed so we can get at the register args.
			  (:temp a0 descriptor-reg a0-offset)
			  (:temp a1 descriptor-reg a1-offset)
			  (:temp a2 descriptor-reg a2-offset))
  ;; Calculate NARGS (as a fixnum).
289 290
  (move nargs csp-tn)
  (inst s nargs args)
chiles's avatar
chiles committed
291 292
  ;; Load the argument registers now because the argument moving might trash
  ;; these locations.
293 294 295 296
  (loadw a0 args 0)
  (loadw a1 args 1)
  (loadw a2 args 2)
  ;; Are we done?
297
  (inst c nargs (fixnumize register-arg-count))
chiles's avatar
chiles committed
298
  (inst bnc :gt done)
299 300 301 302
  ;; Calc DST and COUNT after saving those registers.
  (inst inc csp-tn (* word-bytes 2))
  (storew count csp-tn -1)
  (storew dst csp-tn -2)
303
  (inst a count nargs (fixnumize (- register-arg-count)))
304 305
  (inst a args (* vm:word-bytes register-arg-count))
  (inst a dst cfp-tn (* vm:word-bytes register-arg-count))
chiles's avatar
chiles committed
306 307
  LOOP
  ;; Copy one arg.
308 309 310
  (loadw temp args)
  (inst inc args vm:word-bytes)
  (storew temp dst)
311
  (inst s count (fixnumize 1))
312 313 314 315 316 317
  (inst bcx :gt loop)
  (inst inc dst vm:word-bytes)
  ;; Restore
  (loadw count csp-tn -1)
  (loadw dst csp-tn -2)
  (inst dec csp-tn (* word-bytes 2))
chiles's avatar
chiles committed
318 319
  DONE
  ;; We are done.  Do the jump.
320
  (loadw temp dst vm:closure-function-slot vm:function-pointer-type)
chiles's avatar
chiles committed
321
  (lisp-jump temp lip-tn))