src/compiler/x86/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   ;;(:node-var node)
  20   (:temporary (:sc unsigned-reg :offset ebx-offset
  21                    :from (:eval 0) :to (:eval 2)) ebx)
  22   (:temporary (:sc unsigned-reg :offset ecx-offset
  23                    :from (:eval 0) :to (:eval 2)) ecx))
  24
  25 (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
  26
  27 (defun static-fun-template-name (num-args num-results)
  28   (intern (format nil "~:@(~R-arg-~R-result-static-fun~)"
  29                   num-args num-results)))
  30
  31 (defun moves (dst src)
  32   (collect ((moves))
  33     (do ((dst dst (cdr dst))
  34          (src src (cdr src)))
  35         ((or (null dst) (null src)))
  36       (moves `(move ,(car dst) ,(car src))))
  37     (moves)))
  38
  39 (defun static-fun-template-vop (num-args num-results)
  40   (unless (and (<= num-args register-arg-count)
  41                (<= num-results register-arg-count))
  42     (error "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                                :from ,(if (< i num-args)
  56                                           `(:argument ,i)
  57                                           '(:eval 1))
  58                                :to ,(if (< i num-results)
  59                                         `(:result ,i)
  60                                         '(:eval 1))
  61                                ,@(when (< i num-results)
  62                                    `(:target ,(nth i (result-names)))))
  63                               ,temp-name))))
  64       (dotimes (i num-args)
  65         (let ((arg-name (intern (format nil "ARG-~D" i))))
  66           (arg-names arg-name)
  67           (args `(,arg-name
  68                   :scs (any-reg descriptor-reg)
  69                   :target ,(nth i (temp-names))))))
  70       `(define-vop (,(static-fun-template-name num-args num-results)
  71                     static-fun-template)
  72         (:args ,@(args))
  73         ,@(temps)
  74         (:results ,@(results))
  75         (:generator ,(+ 50 num-args num-results)
  76          ,@(moves (temp-names) (arg-names))
  77
  78          ;; If speed not more important than size, duplicate the
  79          ;; effect of the ENTER with discrete instructions. Takes
  80          ;; 2+1+3+2=8 bytes as opposed to 4+3=7 bytes.
  81          (cond (t ;(policy node (>= speed space))
  82                 (inst mov ebx esp-tn)
  83                 ;; Dummy for return address
  84                 (inst push ebp-tn)
  85                 ;; Save the old-fp
  86                 (inst push ebp-tn)
  87                 ;; Ensure that at least three slots are available; one
  88                 ;; above, two more needed.
  89                 (inst sub esp-tn (fixnumize 1))
  90                 (inst mov ebp-tn ebx))
  91                #+(or) (t
  92                 (inst enter (fixnumize 2))
  93                 ;; The enter instruction pushes EBP and then copies
  94                 ;; ESP into EBP. We want the new EBP to be the
  95                 ;; original ESP, so we fix it up afterwards.
  96                 (inst add ebp-tn (fixnumize 1))))
  97
  98          ,(if (zerop num-args)
  99               '(inst xor ecx ecx)
 100               `(inst mov ecx (fixnumize ,num-args)))
 101
 102          (note-this-location vop :call-site)
 103          ;; Old CMU CL comment:
 104          ;;   STATIC-FUN-OFFSET gives the offset from the start of
 105          ;;   the NIL object to the static function FDEFN and has the
 106          ;;   low tag of 1 added. When the NIL symbol value with its
 107          ;;   low tag of 3 is added the resulting value points to the
 108          ;;   raw address slot of the fdefn (at +4).
 109          ;; FIXME: Since the fork from CMU CL, we've swapped
 110          ;; FUN-POINTER-LOWTAG and INSTANCE-POINTER-LOWTAG, so the
 111          ;; text above is no longer right. Mysteriously, things still
 112          ;; work. It would be good to explain why. (Is this code no
 113          ;; longer executed? Does it not depend on the
 114          ;; 1+3=4=fdefn_raw_address_offset relationship above?
 115          ;; Is something else going on?)
 116          (inst call (make-ea :dword
 117                              :disp (+ nil-value
 118                                       (static-fun-offset function))))
 119          ,(collect ((bindings) (links))
 120                    (do ((temp (temp-names) (cdr temp))
 121                         (name 'values (gensym))
 122                         (prev nil name)
 123                         (i 0 (1+ i)))
 124                        ((= i num-results))
 125                      (bindings `(,name
 126                                  (make-tn-ref ,(car temp) nil)))
 127                      (when prev
 128                        (links `(setf (tn-ref-across ,prev) ,name))))
 129                    `(let ,(bindings)
 130                      ,@(links)
 131                      (default-unknown-values
 132                          vop
 133                          ,(if (zerop num-results) nil 'values)
 134                        ,num-results)))
 135          ,@(moves (result-names) (temp-names)))))))
 136
 137 ) ; EVAL-WHEN
 138
 139 (macrolet ((frob (num-args num-res)
 140              (static-fun-template-vop (eval num-args) (eval num-res))))
 141   (frob 0 1)
 142   (frob 1 1)
 143   (frob 2 1)
 144   (frob 3 1))
 145
 146 (defmacro define-static-fun (name args &key (results '(x)) translate
 147                                   policy cost arg-types result-types)
 148   `(define-vop (,name
 149                 ,(static-fun-template-name (length args)
 150                                            (length results)))
 151      (:variant ',name)
 152      (:note ,(format nil "static-fun ~@(~S~)" name))
 153      ,@(when translate
 154          `((:translate ,translate)))
 155      ,@(when policy
 156          `((:policy ,policy)))
 157      ,@(when cost
 158          `((:generator-cost ,cost)))
 159      ,@(when arg-types
 160          `((:arg-types ,@arg-types)))
 161      ,@(when result-types
 162          `((:result-types ,@result-types)))))