src/assembly/sparc/assem-rtns.lisp

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