src/assembly/alpha/assem-rtns.lisp

   1 ;;; **********************************************************************
   2 ;;; This code was written as part of the CMU Common Lisp project at
   3 ;;; Carnegie Mellon University, and has been placed in the public domain.
   4 ;;;
   5 ;;;
   6 ;;; **********************************************************************
   7 ;;;
   8 (in-package "SB!VM")
   9
  10 \f
  11 ;;;; Return-multiple with other than one value
  12
  13 #+sb-assembling ;; we don't want a vop for this one.
  14 (define-assembly-routine
  15     (return-multiple
  16      (:return-style :none))
  17
  18      ;; These four are really arguments.
  19     ((:temp nvals any-reg nargs-offset)
  20      (:temp vals any-reg nl0-offset)
  21      (:temp ocfp any-reg nl1-offset)
  22      (:temp lra descriptor-reg lra-offset)
  23
  24      ;; These are just needed to facilitate the transfer
  25      (:temp lip interior-reg lip-offset)
  26      (:temp count any-reg nl2-offset)
  27      (:temp dst any-reg nl4-offset)
  28      (:temp temp descriptor-reg l0-offset)
  29
  30      ;; These are needed so we can get at the register args.
  31      (:temp a0 descriptor-reg a0-offset)
  32      (:temp a1 descriptor-reg a1-offset)
  33      (:temp a2 descriptor-reg a2-offset)
  34      (:temp a3 descriptor-reg a3-offset)
  35      (:temp a4 descriptor-reg a4-offset)
  36      (:temp a5 descriptor-reg a5-offset))
  37
  38   ;; Note, because of the way the return-multiple vop is written, we can
  39   ;; assume that we are never called with nvals == 1 and that a0 has already
  40   ;; been loaded.
  41   (inst ble nvals default-a0-and-on)
  42   (inst ldl a1 (* 1 sb!vm:word-bytes) vals)
  43   (inst subq nvals (fixnumize 2) count)
  44   (inst ble count default-a2-and-on)
  45   (inst ldl a2 (* 2 sb!vm:word-bytes) vals)
  46   (inst subq nvals (fixnumize 3) count)
  47   (inst ble count default-a3-and-on)
  48   (inst ldl a3 (* 3 sb!vm:word-bytes) vals)
  49   (inst subq nvals (fixnumize 4) count)
  50   (inst ble count default-a4-and-on)
  51   (inst ldl a4 (* 4 sb!vm:word-bytes) vals)
  52   (inst subq nvals (fixnumize 5) count)
  53   (inst ble count default-a5-and-on)
  54   (inst ldl a5 (* 5 sb!vm:word-bytes) vals)
  55   (inst subq nvals (fixnumize 6) count)
  56   (inst ble count done)
  57
  58   ;; Copy the remaining args to the top of the stack.
  59   (inst addq vals (* 6 sb!vm:word-bytes) vals)
  60   (inst addq cfp-tn (* 6 sb!vm:word-bytes) dst)
  61
  62   LOOP
  63   (inst ldl temp 0 vals)
  64   (inst addq vals sb!vm:word-bytes vals)
  65   (inst stl temp 0 dst)
  66   (inst subq count (fixnumize 1) count)
  67   (inst addq dst sb!vm:word-bytes dst)
  68   (inst bne count loop)
  69
  70   (inst br zero-tn done)
  71
  72   DEFAULT-A0-AND-ON
  73   (inst move null-tn a0)
  74   (inst move null-tn a1)
  75   DEFAULT-A2-AND-ON
  76   (inst move null-tn a2)
  77   DEFAULT-A3-AND-ON
  78   (inst move null-tn a3)
  79   DEFAULT-A4-AND-ON
  80   (inst move null-tn a4)
  81   DEFAULT-A5-AND-ON
  82   (inst move null-tn a5)
  83   DONE
  84
  85   ;; Clear the stack.
  86   (move cfp-tn ocfp-tn)
  87   (move ocfp cfp-tn)
  88   (inst addq ocfp-tn nvals csp-tn)
  89
  90   ;; Return.
  91   (lisp-return lra lip))
  92
  93 \f
  94 ;;;; tail-call-variable.
  95
  96 #+sb-assembling ;; no vop for this one either.
  97 (define-assembly-routine
  98     (tail-call-variable
  99      (:return-style :none))
 100
 101     ;; These are really args.
 102     ((:temp args any-reg nl0-offset)
 103      (:temp lexenv descriptor-reg lexenv-offset)
 104
 105      ;; We need to compute this
 106      (:temp nargs any-reg nargs-offset)
 107
 108      ;; These are needed by the blitting code.
 109      (:temp src any-reg nl1-offset)
 110      (:temp dst any-reg nl2-offset)
 111      (:temp count any-reg cfunc-offset)
 112      (:temp temp descriptor-reg l0-offset)
 113
 114      ;; Needed for the jump
 115      (:temp lip interior-reg lip-offset)
 116
 117      ;; These are needed so we can get at the register args.
 118      (:temp a0 descriptor-reg a0-offset)
 119      (:temp a1 descriptor-reg a1-offset)
 120      (:temp a2 descriptor-reg a2-offset)
 121      (:temp a3 descriptor-reg a3-offset)
 122      (:temp a4 descriptor-reg a4-offset)
 123      (:temp a5 descriptor-reg a5-offset))
 124
 125
 126   ;; Calculate NARGS (as a fixnum)
 127   (inst subq csp-tn args nargs)
 128
 129   ;; Load the argument regs (must do this now, 'cause the blt might
 130   ;; trash these locations)
 131   (inst ldl a0 (* 0 sb!vm:word-bytes) args)
 132   (inst ldl a1 (* 1 sb!vm:word-bytes) args)
 133   (inst ldl a2 (* 2 sb!vm:word-bytes) args)
 134   (inst ldl a3 (* 3 sb!vm:word-bytes) args)
 135   (inst ldl a4 (* 4 sb!vm:word-bytes) args)
 136   (inst ldl a5 (* 5 sb!vm:word-bytes) args)
 137
 138   ;; Calc SRC, DST, and COUNT
 139   (inst subq nargs (fixnumize register-arg-count) count)
 140   (inst addq args (* sb!vm:word-bytes register-arg-count) src)
 141   (inst ble count done)
 142   (inst addq cfp-tn (* sb!vm:word-bytes register-arg-count) dst)
 143
 144   LOOP
 145   ;; Copy one arg.
 146   (inst ldl temp 0 src)
 147   (inst addq src sb!vm:word-bytes src)
 148   (inst stl temp 0 dst)
 149   (inst subq count (fixnumize 1) count)
 150   (inst addq dst sb!vm:word-bytes dst)
 151   (inst bgt count loop)
 152
 153   DONE
 154   ;; We are done.  Do the jump.
 155   (progn
 156     (loadw temp lexenv sb!vm:closure-function-slot sb!vm:function-pointer-type)
 157     (lisp-jump temp lip)))
 158
 159 \f
 160 ;;;; Non-local exit noise.
 161
 162 (define-assembly-routine
 163     (unwind
 164      (:translate %continue-unwind)
 165      (:policy :fast-safe))
 166     ((:arg block (any-reg descriptor-reg) a0-offset)
 167      (:arg start (any-reg descriptor-reg) ocfp-offset)
 168      (:arg count (any-reg descriptor-reg) nargs-offset)
 169      (:temp lip interior-reg lip-offset)
 170      (:temp lra descriptor-reg lra-offset)
 171      (:temp cur-uwp any-reg nl0-offset)
 172      (:temp next-uwp any-reg nl1-offset)
 173      (:temp target-uwp any-reg nl2-offset)
 174      (:temp temp1 non-descriptor-reg nl3-offset))
 175   (declare (ignore start count))
 176
 177   (load-symbol-value cur-uwp sb!impl::*current-unwind-protect-block*)
 178   (let ((error (generate-error-code nil invalid-unwind-error)))
 179     (inst beq block error))
 180
 181   (loadw target-uwp block sb!vm:unwind-block-current-uwp-slot)
 182   (inst cmpeq cur-uwp target-uwp temp1)
 183   (inst beq temp1 do-uwp)
 184
 185   (move block cur-uwp)
 186
 187   do-exit
 188
 189   (loadw cfp-tn cur-uwp sb!vm:unwind-block-current-cont-slot)
 190   (loadw code-tn cur-uwp sb!vm:unwind-block-current-code-slot)
 191   (progn
 192     (loadw lra cur-uwp sb!vm:unwind-block-entry-pc-slot)
 193     (lisp-return lra lip :frob-code nil))
 194
 195   do-uwp
 196
 197   (loadw next-uwp cur-uwp sb!vm:unwind-block-current-uwp-slot)
 198   (store-symbol-value next-uwp sb!impl::*current-unwind-protect-block*)
 199   (inst br zero-tn do-exit))
 200
 201
 202 (define-assembly-routine
 203     throw
 204     ((:arg target descriptor-reg a0-offset)
 205      (:arg start any-reg ocfp-offset)
 206      (:arg count any-reg nargs-offset)
 207      (:temp catch any-reg a1-offset)
 208      (:temp tag descriptor-reg a2-offset)
 209      (:temp temp1 non-descriptor-reg nl0-offset))
 210
 211   (progn start count) ; We just need them in the registers.
 212
 213   (load-symbol-value catch sb!impl::*current-catch-block*)
 214
 215   loop
 216
 217   (let ((error (generate-error-code nil unseen-throw-tag-error target)))
 218     (inst beq catch error))
 219
 220   (loadw tag catch sb!vm:catch-block-tag-slot)
 221   (inst cmpeq tag target temp1)
 222   (inst bne temp1 exit)
 223   (loadw catch catch sb!vm:catch-block-previous-catch-slot)
 224   (inst br zero-tn loop)
 225
 226   exit
 227
 228   (move catch target)
 229   (inst li (make-fixup 'unwind :assembly-routine) temp1)
 230   (inst jmp zero-tn temp1 (make-fixup 'unwind :assembly-routine)))