src/assembly/ppc/assem-rtns.lisp

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