src/compiler/x86-64/static-fn.lisp

   1 ;;;; the VOPs and macro magic required to call 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 function)
  18   (:vop-var vop)
  19   (:temporary (:sc unsigned-reg :offset ecx-offset
  20                    :from (:eval 0) :to (:eval 2)) ecx))
  21
  22 (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
  23
  24 (defun static-fun-template-name (num-args num-results)
  25   (intern (format nil "~:@(~R-arg-~R-result-static-fun~)"
  26                   num-args num-results)))
  27
  28 (defun moves (dst src)
  29   (collect ((moves))
  30     (do ((dst dst (cdr dst))
  31          (src src (cdr src)))
  32         ((or (null dst) (null src)))
  33       (moves `(move ,(car dst) ,(car src))))
  34     (moves)))
  35
  36 (defun static-fun-template-vop (num-args num-results)
  37   (unless (and (<= num-args register-arg-count)
  38                (<= num-results register-arg-count))
  39     (error "either too many args (~W) or too many results (~W); max = ~W"
  40            num-args num-results register-arg-count))
  41   (let ((num-temps (max num-args num-results))
  42         (node (sb!xc:gensym "NODE-"))
  43         (new-rbp-ea
  44          '(make-ea :qword
  45            :disp (frame-byte-offset (+ sp->fp-offset -3 ocfp-save-offset))
  46            :base rsp-tn)))
  47     (collect ((temp-names) (temps) (arg-names) (args) (result-names) (results))
  48       (dotimes (i num-results)
  49         (let ((result-name (intern (format nil "RESULT-~D" i))))
  50           (result-names result-name)
  51           (results `(,result-name :scs (any-reg descriptor-reg)))))
  52       (dotimes (i num-temps)
  53         (let ((temp-name (intern (format nil "TEMP-~D" i))))
  54           (temp-names temp-name)
  55           (temps `(:temporary (:sc descriptor-reg
  56                                :offset ,(nth i *register-arg-offsets*)
  57                                :from ,(if (< i num-args)
  58                                           `(:argument ,i)
  59                                           '(:eval 1))
  60                                :to ,(if (< i num-results)
  61                                         `(:result ,i)
  62                                         '(:eval 1))
  63                                ,@(when (< i num-results)
  64                                    `(:target ,(nth i (result-names)))))
  65                               ,temp-name))))
  66       (dotimes (i num-args)
  67         (let ((arg-name (intern (format nil "ARG-~D" i))))
  68           (arg-names arg-name)
  69           (args `(,arg-name
  70                   :scs (any-reg descriptor-reg)
  71                   :target ,(nth i (temp-names))))))
  72       `(define-vop (,(static-fun-template-name num-args num-results)
  73                     static-fun-template)
  74         (:args ,@(args))
  75         ,@(temps)
  76         (:results ,@(results))
  77         (:node-var ,node)
  78         (:generator ,(+ 50 num-args num-results)
  79          ,@(moves (temp-names) (arg-names))
  80
  81          ;; If speed is at least as important as size, duplicate the
  82          ;; effect of the ENTER with discrete instructions. Takes
  83          ;; 3+4+4=11 bytes as opposed to 1+4=5 bytes.
  84          (cond ((policy ,node (>= speed space))
  85                 (inst sub rsp-tn (* 3 n-word-bytes))
  86                 (inst mov ,new-rbp-ea rbp-tn)
  87                 (inst lea rbp-tn ,new-rbp-ea))
  88                (t
  89                 ;; Dummy for return address.
  90                 (inst push rbp-tn)
  91                 (inst enter n-word-bytes)))
  92
  93          ,(if (zerop num-args)
  94               '(zeroize ecx)
  95               `(inst mov ecx ,(fixnumize num-args)))
  96
  97          (note-this-location vop :call-site)
  98          ;; Old CMU CL comment:
  99          ;;   STATIC-FUN-OFFSET gives the offset from the start of
 100          ;;   the NIL object to the static function FDEFN and has the
 101          ;;   low tag of 1 added. When the NIL symbol value with its
 102          ;;   low tag of 3 is added the resulting value points to the
 103          ;;   raw address slot of the fdefn (at +4).
 104          ;; FIXME: Since the fork from CMU CL, we've swapped
 105          ;; FUN-POINTER-LOWTAG and INSTANCE-POINTER-LOWTAG, so the
 106          ;; text above is no longer right. Mysteriously, things still
 107          ;; work. It would be good to explain why. (Is this code no
 108          ;; longer executed? Does it not depend on the
 109          ;; 1+3=4=fdefn_raw_address_offset relationship above?
 110          ;; Is something else going on?)
 111          #!+immobile-code
 112          (cond ((neq (sb!c::component-kind (sb!c::node-component ,node)) :toplevel)
 113                 (inst call (make-fixup function :static-call)))
 114                (t
 115                 ;; While we could use CALL-INDIRECT here,
 116                 ;; the fixup allows calling _any_ Lisp function,
 117                 ;; not just those in *static-funs*.
 118                 (inst mov temp-reg-tn (make-fixup function :static-call))
 119                 (inst call temp-reg-tn)))
 120          #!-immobile-code
 121          (call-indirect (+ nil-value (static-fun-offset function)))
 122          ,(collect ((bindings) (links))
 123                    (do ((temp (temp-names) (cdr temp))
 124                         (name 'values (gensym))
 125                         (prev nil name)
 126                         (i 0 (1+ i)))
 127                        ((= i num-results))
 128                      (bindings `(,name
 129                                  (make-tn-ref ,(car temp) nil)))
 130                      (when prev
 131                        (links `(setf (tn-ref-across ,prev) ,name))))
 132                    `(let ,(bindings)
 133                      ,@(links)
 134                      (default-unknown-values
 135                          vop
 136                          ,(if (zerop num-results) nil 'values)
 137                        ,num-results
 138                        ,node)))
 139          ,@(moves (result-names) (temp-names)))))))
 140
 141 ) ; EVAL-WHEN
 142
 143 (macrolet ((frob (num-args num-res)
 144              (static-fun-template-vop (eval num-args) (eval num-res))))
 145   (frob 0 1)
 146   (frob 1 1)
 147   (frob 2 1)
 148   (frob 3 1))
 149
 150 (defmacro define-static-fun (name args &key (results '(x)) translate
 151                                   policy cost arg-types result-types)
 152   `(define-vop (,name
 153                 ,(static-fun-template-name (length args)
 154                                            (length results)))
 155      (:variant ',name)
 156      (:note ,(format nil "static-fun ~@(~S~)" name))
 157      ,@(when translate
 158          `((:translate ,translate)))
 159      ,@(when policy
 160          `((:policy ,policy)))
 161      ,@(when cost
 162          `((:generator-cost ,cost)))
 163      ,@(when arg-types
 164          `((:arg-types ,@arg-types)))
 165      ,@(when result-types
 166          `((:result-types ,@result-types)))))