src/assembly/hppa/assem-rtns.lisp

   1 (in-package "SB!VM")
   2
   3 ;;;; Return-multiple with other than one value
   4
   5 #+sb-assembling ;; we don't want a vop for this one.
   6 (define-assembly-routine
   7     (return-multiple
   8      (:return-style :none))
   9      ;; These four are really arguments.
  10     ((:temp nvals any-reg nargs-offset)
  11      (:temp vals any-reg nl0-offset)
  12      (:temp ocfp any-reg nl1-offset)
  13      (:temp lra descriptor-reg lra-offset)
  14      ;; These are just needed to facilitate the transfer
  15      (:temp count any-reg nl2-offset)
  16      (:temp dst any-reg nl3-offset)
  17      (:temp temp descriptor-reg l0-offset)
  18      ;; These are needed so we can get at the register args.
  19      (:temp a0 descriptor-reg a0-offset)
  20      (:temp a1 descriptor-reg a1-offset)
  21      (:temp a2 descriptor-reg a2-offset)
  22      (:temp a3 descriptor-reg a3-offset)
  23      (:temp a4 descriptor-reg a4-offset)
  24      (:temp a5 descriptor-reg a5-offset))
  25   ;; Note, because of the way the return-multiple vop is written, we can
  26   ;; assume that we are never called with nvals == 1 and that a0 has already
  27   ;; been loaded. ;FIX-lav: look at old hppa , replace comb+addi with addib
  28   (inst comb :<= nvals zero-tn DEFAULT-A0-AND-ON)
  29   (inst addi (- (fixnumize 2)) nvals count)
  30   (inst comb :<= count zero-tn DEFAULT-A2-AND-ON)
  31   (inst ldw (* 1 n-word-bytes) vals a1)
  32   (inst addib :<= (- (fixnumize 1)) count DEFAULT-A3-AND-ON)
  33   (inst ldw (* 2 n-word-bytes) vals a2)
  34   (inst addib :<= (- (fixnumize 1)) count DEFAULT-A4-AND-ON)
  35   (inst ldw (* 3 n-word-bytes) vals a3)
  36   (inst addib :<= (- (fixnumize 1)) count DEFAULT-A5-AND-ON)
  37   (inst ldw (* 4 n-word-bytes) vals a4)
  38   (inst addib :<= (- (fixnumize 1)) count done)
  39   (inst ldw (* 5 n-word-bytes) vals a5)
  40   ;; Copy the remaining args to the top of the stack.
  41   (inst addi (fixnumize register-arg-count) vals vals)
  42   (inst addi (fixnumize register-arg-count) cfp-tn dst)
  43   LOOP
  44   (inst ldwm n-word-bytes vals temp)
  45   (inst addib :<> (- (fixnumize 1)) count LOOP)
  46   (inst stwm temp n-word-bytes dst)
  47   (inst b DONE :nullify t)
  48
  49   DEFAULT-A0-AND-ON
  50   (move null-tn a0)
  51   (move null-tn a1)
  52   DEFAULT-A2-AND-ON
  53   (move null-tn a2)
  54   DEFAULT-A3-AND-ON
  55   (move null-tn a3)
  56   DEFAULT-A4-AND-ON
  57   (move null-tn a4)
  58   DEFAULT-A5-AND-ON
  59   (move null-tn a5)
  60   DONE
  61   ;; Clear the stack.
  62   (move cfp-tn ocfp-tn)
  63   (move ocfp cfp-tn)
  64   (inst add ocfp-tn nvals csp-tn)
  65   (lisp-return lra))
  66
  67 \f
  68 ;;;; tail-call-variable.
  69
  70 #+sb-assembling ;; no vop for this one either.
  71 (define-assembly-routine
  72     (tail-call-variable
  73      (:return-style :none))
  74     ;; These are really args.
  75     ((:temp args any-reg nl0-offset)
  76      (:temp lexenv descriptor-reg lexenv-offset)
  77      ;; We need to compute this
  78      (:temp nargs any-reg nargs-offset)
  79      ;; These are needed by the blitting code.
  80      (:temp src any-reg nl1-offset)
  81      (:temp dst any-reg nl2-offset)
  82      (:temp count any-reg nl3-offset)
  83      (:temp temp descriptor-reg l0-offset)
  84      ;; These are needed so we can get at the register args.
  85      (:temp a0 descriptor-reg a0-offset)
  86      (:temp a1 descriptor-reg a1-offset)
  87      (:temp a2 descriptor-reg a2-offset)
  88      (:temp a3 descriptor-reg a3-offset)
  89      (:temp a4 descriptor-reg a4-offset)
  90      (:temp a5 descriptor-reg a5-offset))
  91   ;; Calculate NARGS (as a fixnum)
  92   (inst sub csp-tn args nargs)
  93   ;; Load the argument regs (must do this now, 'cause the blt might
  94   ;; trash these locations)
  95   (loadw a0 args 0)
  96   (loadw a1 args 1)
  97   (loadw a2 args 2)
  98   (loadw a3 args 3)
  99   (loadw a4 args 4)
 100   (loadw a5 args 5)
 101   ;; Calc SRC, DST, and COUNT
 102   (inst addi (- (fixnumize register-arg-count)) nargs count)
 103   (inst comb :<= count zero-tn done)
 104   (inst addi (fixnumize register-arg-count) args src)
 105   (inst addi (fixnumize register-arg-count) cfp-tn dst)
 106   LOOP
 107   ;; Copy one arg and increase src
 108   (inst ldwm n-word-bytes src temp)
 109   (inst addib :<> (- (fixnumize 1)) count LOOP)
 110   (inst stwm temp n-word-bytes dst)
 111   DONE
 112   ;; We are done.  Do the jump.
 113   (loadw temp lexenv closure-fun-slot fun-pointer-lowtag)
 114   (lisp-jump temp))
 115
 116 \f
 117 ;;;; Non-local exit noise.
 118
 119 (define-assembly-routine
 120     (unwind
 121      (:translate %continue-unwind)
 122      (:return-style :none)
 123      (:policy :fast-safe))
 124     ((:arg block (any-reg descriptor-reg) a0-offset)
 125      (:arg start (any-reg descriptor-reg) ocfp-offset)
 126      (:arg count (any-reg descriptor-reg) nargs-offset)
 127      (:temp lra descriptor-reg lra-offset)
 128      (:temp cur-uwp any-reg nl0-offset)
 129      (:temp next-uwp any-reg nl1-offset)
 130      (:temp target-uwp any-reg nl2-offset))
 131   (declare (ignore start count))
 132
 133
 134   (let ((error (generate-error-code nil invalid-unwind-error)))
 135     (inst bc := nil block zero-tn error))
 136
 137   (load-symbol-value cur-uwp *current-unwind-protect-block*)
 138   (loadw target-uwp block unwind-block-current-uwp-slot)
 139   (inst bc :<> nil cur-uwp target-uwp DO-UWP)
 140
 141   (move block cur-uwp)
 142
 143   DO-EXIT
 144   (loadw cfp-tn cur-uwp unwind-block-current-cont-slot)
 145   (loadw code-tn cur-uwp unwind-block-current-code-slot)
 146   (loadw lra cur-uwp unwind-block-entry-pc-slot)
 147   (lisp-return lra :frob-code nil)
 148
 149   DO-UWP
 150   (loadw next-uwp cur-uwp unwind-block-current-uwp-slot)
 151   (inst b DO-EXIT)
 152   (store-symbol-value next-uwp *current-unwind-protect-block*))
 153
 154 (define-assembly-routine
 155     (throw
 156      (:return-style :none))
 157     ((:arg target descriptor-reg a0-offset)
 158      (:arg start any-reg ocfp-offset)
 159      (:arg count any-reg nargs-offset)
 160      (:temp catch any-reg a1-offset)
 161      (:temp tag descriptor-reg a2-offset)
 162      (:temp fix descriptor-reg nl0-offset))
 163   (declare (ignore start count)) ; We just need them in the registers.
 164
 165   (load-symbol-value catch *current-catch-block*)
 166
 167   LOOP
 168   (let ((error (generate-error-code nil unseen-throw-tag-error target)))
 169     (inst bc := nil catch zero-tn error))
 170   (loadw tag catch catch-block-tag-slot)
 171   (inst comb := tag target EXIT :nullify t)
 172   (inst b LOOP)
 173   (loadw catch catch catch-block-previous-catch-slot)
 174   EXIT
 175   (let ((fixup (make-fixup 'unwind :assembly-routine)))
 176     (inst ldil fixup fix)
 177     (inst ble fixup lisp-heap-space fix))
 178   (move catch target t))
 179
 180 ; we need closure-tramp and funcallable-instance-tramp in
 181 ; same space as other lisp-code, because caller is doing
 182 ; normal lisp-calls where we doesnt specify space.
 183 ; if we doesnt have the lisp-function (code from defun, closure, lambda etc..)
 184 ; machine-address, resolve it here and jump to it.
 185 (define-assembly-routine
 186   (closure-tramp (:return-style :none))
 187   ((:temp lip interior-reg lip-offset)
 188    (:temp nl0 descriptor-reg nl0-offset))
 189   (inst ldw (- (* fdefn-fun-slot n-word-bytes)
 190                other-pointer-lowtag)
 191             fdefn-tn lexenv-tn)
 192   (inst ldw (- (* closure-fun-slot n-word-bytes)
 193                   fun-pointer-lowtag)
 194             lexenv-tn nl0)
 195   (inst addi (- (* simple-fun-code-offset n-word-bytes)
 196                 fun-pointer-lowtag)
 197         nl0 lip)
 198   (inst bv lip :nullify t))
 199
 200 (define-assembly-routine
 201   (funcallable-instance-tramp (:return-style :none))
 202   nil
 203   (inst nop)
 204   (inst nop)
 205   (inst nop)
 206   (inst nop)
 207   (inst nop)
 208   (inst ldw 3 lexenv-tn lexenv-tn)
 209   (inst ldw (- (* closure-fun-slot n-word-bytes)
 210                   fun-pointer-lowtag)
 211             lexenv-tn code-tn)
 212   (inst addi (- (* simple-fun-code-offset n-word-bytes)
 213                 fun-pointer-lowtag) code-tn lip-tn)
 214   (inst bv lip-tn :nullify t))
 215
 216 #!+hpux
 217 (define-assembly-routine
 218   (return-from-lisp-stub (:return-style :none))
 219   ((:temp lip interior-reg lip-offset)
 220    (:temp nl0 descriptor-reg nl0-offset)
 221    (:temp nl1 descriptor-reg nl1-offset)
 222    (:temp lra descriptor-reg lra-offset))
 223   ; before calling into lisp we must save our return address (reg_LRA)
 224   (store-symbol-value lra *c-lra*)
 225   ; note the lra we calculate next must "simulate" an fixnum,
 226   ; because compute-calling-frame will use fixnump on this value.
 227   ; either use 16 or 20, finetune it...
 228   (inst addi 19 nl0 lra) ; then setup the new LRA (rest of this routine after branch)
 229   (inst bv lip :nullify t)
 230   (inst word return-pc-header-widetag)
 231   ; ok, we are back from the lisp-call, lets return to c
 232   ; FIX-lav: steal more stuff from call_into_lisp here, ideally the whole thing
 233   (inst move ocfp-tn csp-tn) ; dont think we should ever get here
 234   (inst nop)
 235   (load-symbol-value nl0 *c-lra*)
 236   (inst addi 1 nl0 nl0)
 237   (inst ble 0 c-text-space nl0 :nullify t))