src/compiler/ppc/static-fn.lisp

   1 ;;; Written by William Lott.
   2 ;;;
   3 (in-package "SB!VM")
   4
   5
   6
   7 (define-vop (static-fun-template)
   8   (:save-p t)
   9   (:policy :safe)
  10   (:variant-vars symbol)
  11   (:vop-var vop)
  12   (:temporary (:scs (non-descriptor-reg)) temp)
  13   (:temporary (:scs (descriptor-reg)) move-temp)
  14   (:temporary (:sc descriptor-reg :offset lra-offset) lra)
  15   (:temporary (:sc interior-reg :offset lip-offset) entry-point)
  16   (:temporary (:scs (descriptor-reg)) func)
  17   (:temporary (:sc any-reg :offset nargs-offset) nargs)
  18   (:temporary (:sc any-reg :offset ocfp-offset) old-fp)
  19   (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save))
  20
  21
  22 (eval-when (:compile-toplevel :load-toplevel :execute)
  23
  24
  25 (defun static-fun-template-name (num-args num-results)
  26   (intern (format nil "~:@(~R-arg-~R-result-static-fun~)"
  27                   num-args num-results)))
  28
  29
  30 (defun moves (dst src)
  31   (collect ((moves))
  32     (do ((dst dst (cdr dst))
  33          (src src (cdr src)))
  34         ((or (null dst) (null src)))
  35       (moves `(move ,(car dst) ,(car src))))
  36     (moves)))
  37
  38 (defun static-fun-template-vop (num-args num-results)
  39   (assert (and (<= num-args register-arg-count)
  40                (<= num-results register-arg-count))
  41           (num-args num-results)
  42           "Either too many args (~W) or too many results (~W).  Max = ~W"
  43           num-args num-results register-arg-count)
  44   (let ((num-temps (max num-args num-results)))
  45     (collect ((temp-names) (temps) (arg-names) (args) (result-names) (results))
  46       (dotimes (i num-results)
  47         (let ((result-name (intern (format nil "RESULT-~D" i))))
  48           (result-names result-name)
  49           (results `(,result-name :scs (any-reg descriptor-reg)))))
  50       (dotimes (i num-temps)
  51         (let ((temp-name (intern (format nil "TEMP-~D" i))))
  52           (temp-names temp-name)
  53           (temps `(:temporary (:sc descriptor-reg
  54                                :offset ,(nth i *register-arg-offsets*)
  55                                ,@(when (< i num-args)
  56                                    `(:from (:argument ,i)))
  57                                ,@(when (< i num-results)
  58                                    `(:to (:result ,i)
  59                                      :target ,(nth i (result-names)))))
  60                               ,temp-name))))
  61       (dotimes (i num-args)
  62         (let ((arg-name (intern (format nil "ARG-~D" i))))
  63           (arg-names arg-name)
  64           (args `(,arg-name
  65                   :scs (any-reg descriptor-reg)
  66                   :target ,(nth i (temp-names))))))
  67       `(define-vop (,(static-fun-template-name num-args num-results)
  68                     static-fun-template)
  69          (:args ,@(args))
  70          ,@(temps)
  71          (:results ,@(results))
  72          (:generator ,(+ 50 num-args num-results)
  73            (let ((lra-label (gen-label))
  74                  (cur-nfp (current-nfp-tn vop)))
  75              ,@(moves (temp-names) (arg-names))
  76              (inst lwz entry-point null-tn (static-fun-offset symbol))
  77              (inst lr nargs (fixnumize ,num-args))
  78              (when cur-nfp
  79                (store-stack-tn nfp-save cur-nfp))
  80              (inst mr old-fp cfp-tn)
  81              (inst mr cfp-tn csp-tn)
  82              (inst compute-lra-from-code lra code-tn lra-label temp)
  83              (note-this-location vop :call-site)
  84              ;(inst mr code-tn func)
  85              (inst mtctr entry-point)
  86              (inst bctr)
  87              (emit-return-pc lra-label)
  88              ,(collect ((bindings) (links))
  89                 (do ((temp (temp-names) (cdr temp))
  90                      (name 'values (gensym))
  91                      (prev nil name)
  92                      (i 0 (1+ i)))
  93                     ((= i num-results))
  94                   (bindings `(,name
  95                               (make-tn-ref ,(car temp) nil)))
  96                   (when prev
  97                     (links `(setf (tn-ref-across ,prev) ,name))))
  98                 `(let ,(bindings)
  99                    ,@(links)
 100                    (default-unknown-values vop
 101                        ,(if (zerop num-results) nil 'values)
 102                        ,num-results move-temp temp lra-label)))
 103              (when cur-nfp
 104                (load-stack-tn cur-nfp nfp-save))
 105              ,@(moves (result-names) (temp-names))))))))
 106
 107
 108 ) ; EVAL-WHEN
 109
 110 (macrolet ((frob (num-args num-res)
 111              (static-fun-template-vop (eval num-args) (eval num-res))))
 112   (frob 0 1)
 113   (frob 1 1)
 114   (frob 2 1)
 115   (frob 3 1)
 116   (frob 4 1)
 117   #|(frob 5 1)|#)
 118
 119 (defmacro define-static-fun (name args &key (results '(x)) translate
 120                                        policy cost arg-types result-types)
 121   `(define-vop (,name
 122                 ,(static-fun-template-name (length args)
 123                                                 (length results)))
 124      (:variant ',name)
 125      (:note ,(format nil "static-fun ~@(~S~)" name))
 126      ,@(when translate
 127          `((:translate ,translate)))
 128      ,@(when policy
 129          `((:policy ,policy)))
 130      ,@(when cost
 131          `((:generator-cost ,cost)))
 132      ,@(when arg-types
 133          `((:arg-types ,@arg-types)))
 134      ,@(when result-types
 135          `((:result-types ,@result-types)))))