src/compiler/ppc/static-fn.lisp

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