src/assembly/hppa/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 old-fp any-reg nl1-offset)
  15      (:temp lra descriptor-reg lra-offset)
  16
  17      ;; These are just needed to facilitate the transfer
  18      (:temp count any-reg nl2-offset)
  19      (:temp src any-reg nl3-offset)
  20      (:temp dst any-reg nl4-offset)
  21      (:temp temp descriptor-reg l0-offset)
  22
  23      ;; These are needed so we can get at the register args.
  24      (:temp a0 descriptor-reg a0-offset)
  25      (:temp a1 descriptor-reg a1-offset)
  26      (:temp a2 descriptor-reg a2-offset)
  27      (:temp a3 descriptor-reg a3-offset)
  28      (:temp a4 descriptor-reg a4-offset)
  29      (:temp a5 descriptor-reg a5-offset))
  30
  31   (inst movb := nvals count default-a0-and-on :nullify t)
  32   (loadw a0 vals 0)
  33   (inst addib := (fixnumize -1) count default-a1-and-on :nullify t)
  34   (loadw a1 vals 1)
  35   (inst addib := (fixnumize -1) count default-a2-and-on :nullify t)
  36   (loadw a2 vals 2)
  37   (inst addib := (fixnumize -1) count default-a3-and-on :nullify t)
  38   (loadw a3 vals 3)
  39   (inst addib := (fixnumize -1) count default-a4-and-on :nullify t)
  40   (loadw a4 vals 4)
  41   (inst addib := (fixnumize -1) count default-a5-and-on :nullify t)
  42   (loadw a5 vals 5)
  43   (inst addib := (fixnumize -1) count done :nullify t)
  44
  45   ;; Copy the remaining args to the top of the stack.
  46   (inst addi (* 6 n-word-bytes) vals src)
  47   (inst addi (* 6 n-word-bytes) cfp-tn dst)
  48
  49   LOOP
  50   (inst ldwm 4 src temp)
  51   (inst addib :> (fixnumize -1) count loop)
  52   (inst stwm temp 4 dst)
  53
  54   (inst b done :nullify t)
  55
  56   DEFAULT-A0-AND-ON
  57   (inst move null-tn a0)
  58   DEFAULT-A1-AND-ON
  59   (inst move null-tn a1)
  60   DEFAULT-A2-AND-ON
  61   (inst move null-tn a2)
  62   DEFAULT-A3-AND-ON
  63   (inst move null-tn a3)
  64   DEFAULT-A4-AND-ON
  65   (inst move null-tn a4)
  66   DEFAULT-A5-AND-ON
  67   (inst move null-tn a5)
  68
  69   DONE
  70   ;; Clear the stack.
  71   (move cfp-tn ocfp-tn)
  72   (move old-fp cfp-tn)
  73   (inst add ocfp-tn nvals csp-tn)
  74
  75   ;; Return.
  76   (lisp-return lra))
  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
 100      ;; These are needed so we can get at the register args.
 101      (:temp a0 descriptor-reg a0-offset)
 102      (:temp a1 descriptor-reg a1-offset)
 103      (:temp a2 descriptor-reg a2-offset)
 104      (:temp a3 descriptor-reg a3-offset)
 105      (:temp a4 descriptor-reg a4-offset)
 106      (:temp a5 descriptor-reg a5-offset))
 107
 108
 109   ;; Calculate NARGS (as a fixnum)
 110   (inst sub csp-tn args nargs)
 111
 112   ;; Load the argument regs (must do this now, 'cause the blt might
 113   ;; trash these locations)
 114   (loadw a0 args 0)
 115   (loadw a1 args 1)
 116   (loadw a2 args 2)
 117   (loadw a3 args 3)
 118   (loadw a4 args 4)
 119   (loadw a5 args 5)
 120
 121   ;; Calc SRC, DST, and COUNT
 122   (inst addi (fixnumize (- register-arg-count)) nargs count)
 123   (inst comb :<= count zero-tn done :nullify t)
 124   (inst addi (* n-word-bytes register-arg-count) args src)
 125   (inst addi (* n-word-bytes register-arg-count) cfp-tn dst)
 126
 127   LOOP
 128   ;; Copy one arg.
 129   (inst ldwm 4 src temp)
 130   (inst addib :> (fixnumize -1) count loop)
 131   (inst stwm temp 4 dst)
 132
 133   DONE
 134   ;; We are done.  Do the jump.
 135   (loadw temp lexenv closure-fun-slot fun-pointer-lowtag)
 136   (lisp-jump temp))
 137
 138
 139 \f
 140 ;;;; Non-local exit noise.
 141
 142 ;;; FIXME: Really?
 143 #+sb-assembling
 144 (defparameter *unwind-entry-point* (gen-label))
 145
 146 (define-assembly-routine
 147     (unwind
 148      (:translate %continue-unwind)
 149      (:policy :fast-safe))
 150     ((:arg block (any-reg descriptor-reg) a0-offset)
 151      (:arg start (any-reg descriptor-reg) ocfp-offset)
 152      (:arg count (any-reg descriptor-reg) nargs-offset)
 153      (:temp lra descriptor-reg lra-offset)
 154      (:temp cur-uwp any-reg nl0-offset)
 155      (:temp next-uwp any-reg nl1-offset)
 156      (:temp target-uwp any-reg nl2-offset))
 157   (declare (ignore start count))
 158
 159   (emit-label *unwind-entry-point*)
 160
 161   (let ((error (generate-error-code nil invalid-unwind-error)))
 162     (inst bc := nil block zero-tn error))
 163
 164   (load-symbol-value cur-uwp *current-unwind-protect-block*)
 165   (loadw target-uwp block unwind-block-current-uwp-slot)
 166   (inst bc :<> nil cur-uwp target-uwp do-uwp)
 167
 168   (move block cur-uwp)
 169
 170   DO-EXIT
 171
 172   (loadw cfp-tn cur-uwp unwind-block-current-cont-slot)
 173   (loadw code-tn cur-uwp unwind-block-current-code-slot)
 174   (loadw lra cur-uwp unwind-block-entry-pc-slot)
 175   (lisp-return lra :frob-code nil)
 176
 177   DO-UWP
 178
 179   (loadw next-uwp cur-uwp unwind-block-current-uwp-slot)
 180   (inst b do-exit)
 181   (store-symbol-value next-uwp *current-unwind-protect-block*))
 182
 183
 184 (define-assembly-routine
 185     throw
 186     ((:arg target descriptor-reg a0-offset)
 187      (:arg start any-reg ocfp-offset)
 188      (:arg count any-reg nargs-offset)
 189      (:temp catch any-reg a1-offset)
 190      (:temp tag descriptor-reg a2-offset))
 191   (declare (ignore start count)) ; We just need them in the registers.
 192
 193   (load-symbol-value catch *current-catch-block*)
 194
 195   LOOP
 196   (let ((error (generate-error-code nil unseen-throw-tag-error target)))
 197     (inst bc := nil catch zero-tn error))
 198   (loadw tag catch catch-block-tag-slot)
 199   (inst comb :<> tag target loop :nullify t)
 200   (loadw catch catch catch-block-previous-catch-slot)
 201
 202   (inst b *unwind-entry-point*)
 203   (inst move catch target))