src/compiler/hppa/static-fn.lisp

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