src/compiler/ppc/c-call.lisp

   1 ;;;; VOPs and other machine-specific support routines for call-out to C
   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 ;;; Return the number of bytes needed for the current non-descriptor
  15 ;;; stack frame.  Non-descriptor stack frames must be multiples of 16
  16 ;;; bytes under the PPC SVr4 ABI (though the EABI may be less
  17 ;;; restrictive).  On linux, two words are reserved for the stack
  18 ;;; backlink and saved LR (see SB!VM::NUMBER-STACK-DISPLACEMENT).
  19
  20 (defconstant +stack-alignment-bytes+
  21   ;; Duh.  PPC Linux (and VxWorks) adhere to the EABI.
  22   #!-darwin 7
  23   ;; But Darwin doesn't
  24   #!+darwin 15)
  25
  26 (defun my-make-wired-tn (prim-type-name sc-name offset)
  27   (make-wired-tn (primitive-type-or-lose prim-type-name)
  28                  (sc-number-or-lose sc-name)
  29                  offset))
  30
  31 (defstruct arg-state
  32   (gpr-args 0)
  33   (fpr-args 0)
  34   ;; SVR4 [a]abi wants two words on stack (callee saved lr,
  35   ;; backpointer).
  36   #!-darwin (stack-frame-size 2)
  37   ;; PowerOpen ABI wants 8 words on the stack corresponding to GPR3-10
  38   ;; in addition to the 6 words of link area (see number-stack-displacement)
  39   #!+darwin (stack-frame-size (+ 8 6)))
  40
  41 (defun int-arg (state prim-type reg-sc stack-sc)
  42   (let ((reg-args (arg-state-gpr-args state)))
  43     (cond ((< reg-args 8)
  44            (setf (arg-state-gpr-args state) (1+ reg-args))
  45            (my-make-wired-tn prim-type reg-sc (+ reg-args nl0-offset)))
  46           (t
  47            (let ((frame-size (arg-state-stack-frame-size state)))
  48              (setf (arg-state-stack-frame-size state) (1+ frame-size))
  49              (my-make-wired-tn prim-type stack-sc frame-size))))))
  50
  51 (define-alien-type-method (integer :arg-tn) (type state)
  52   (if (alien-integer-type-signed type)
  53       (int-arg state 'signed-byte-32 'signed-reg 'signed-stack)
  54       (int-arg state 'unsigned-byte-32 'unsigned-reg 'unsigned-stack)))
  55
  56 (define-alien-type-method (system-area-pointer :arg-tn) (type state)
  57   (declare (ignore type))
  58   (int-arg state 'system-area-pointer 'sap-reg 'sap-stack))
  59
  60 ;;; If a single-float arg has to go on the stack, it's promoted to
  61 ;;; double.  That way, C programs can get subtle rounding errors when
  62 ;;; unrelated arguments are introduced.
  63
  64 #!-darwin
  65 (define-alien-type-method (single-float :arg-tn) (type state)
  66   (declare (ignore type))
  67   (let* ((fprs (arg-state-fpr-args state)))
  68     (cond ((< fprs 8)
  69            (incf (arg-state-fpr-args state))
  70            ;; Assign outgoing FPRs starting at FP1
  71            (my-make-wired-tn 'single-float 'single-reg (1+ fprs)))
  72           (t
  73            (let* ((stack-offset (arg-state-stack-frame-size state)))
  74              (if (oddp stack-offset)
  75                (incf stack-offset))
  76              (setf (arg-state-stack-frame-size state) (+ stack-offset 2))
  77              (my-make-wired-tn 'double-float 'double-stack stack-offset))))))
  78
  79 #!+darwin
  80 (define-alien-type-method (single-float :arg-tn) (type state)
  81   (declare (ignore type))
  82   (let* ((fprs (arg-state-fpr-args state))
  83          (gprs (arg-state-gpr-args state)))
  84     (cond ((< gprs 8) ; and by implication also (< fprs 13)
  85            ;; Corresponding GPR is kept empty for functions with fixed args
  86            (incf (arg-state-gpr-args state))
  87            (incf (arg-state-fpr-args state))
  88            ;; Assign outgoing FPRs starting at FP1
  89            (my-make-wired-tn 'single-float 'single-reg (1+ fprs)))
  90           ((< fprs 13)
  91            ;; According to PowerOpen ABI, we need to pass those both in the
  92            ;; FPRs _and_ the stack.  However empiric testing on OS X/gcc
  93            ;; shows they are only passed in FPRs, AFAICT.
  94            ;;
  95            ;; "I" in "AFAICT" probably refers to PRM.  -- CSR, still
  96            ;; reverse-engineering comments in 2003 :-)
  97            (incf (arg-state-fpr-args state))
  98            (incf (arg-state-stack-frame-size state))
  99            (my-make-wired-tn 'single-float 'single-reg (1+ fprs)))
 100           (t
 101            ;; Pass on stack only
 102            (let ((stack-offset (arg-state-stack-frame-size state)))
 103              (incf (arg-state-stack-frame-size state))
 104              (my-make-wired-tn 'single-float 'single-stack stack-offset))))))
 105 #!-darwin
 106 (define-alien-type-method (double-float :arg-tn) (type state)
 107   (declare (ignore type))
 108   (let* ((fprs (arg-state-fpr-args state)))
 109     (cond ((< fprs 8)
 110            (incf (arg-state-fpr-args state))
 111            ;; Assign outgoing FPRs starting at FP1
 112            (my-make-wired-tn 'double-float 'double-reg (1+ fprs)))
 113           (t
 114            (let* ((stack-offset (arg-state-stack-frame-size state)))
 115              (if (oddp stack-offset)
 116                (incf stack-offset))
 117              (setf (arg-state-stack-frame-size state) (+ stack-offset 2))
 118              (my-make-wired-tn 'double-float 'double-stack stack-offset))))))
 119
 120 #!+darwin
 121 (define-alien-type-method (double-float :arg-tn) (type state)
 122   (declare (ignore type))
 123   (let ((fprs (arg-state-fpr-args state))
 124         (gprs (arg-state-gpr-args state)))
 125     (cond ((< gprs 8) ; and by implication also (< fprs 13)
 126            ;; Corresponding GPRs are also kept empty
 127            (incf (arg-state-gpr-args state) 2)
 128            (when (> (arg-state-gpr-args state) 8)
 129              ;; Spill one word to stack
 130              (decf (arg-state-gpr-args state))
 131              (incf (arg-state-stack-frame-size state)))
 132            (incf (arg-state-fpr-args state))
 133            ;; Assign outgoing FPRs starting at FP1
 134            (my-make-wired-tn 'double-float 'double-reg (1+ fprs)))
 135           ((< fprs 13)
 136            ;; According to PowerOpen ABI, we need to pass those both in the
 137            ;; FPRs _and_ the stack.  However empiric testing on OS X/gcc
 138            ;; shows they are only passed in FPRs, AFAICT.
 139            (incf (arg-state-stack-frame-size state) 2)
 140            (incf (arg-state-fpr-args state))
 141            (my-make-wired-tn 'double-float 'double-reg (1+ fprs)))
 142           (t
 143            ;; Pass on stack only
 144            (let ((stack-offset (arg-state-stack-frame-size state)))
 145              (incf (arg-state-stack-frame-size state) 2)
 146              (my-make-wired-tn 'double-float 'double-stack stack-offset))))))
 147
 148 ;;; Result state handling
 149
 150 (defstruct result-state
 151   (num-results 0))
 152
 153 (defun result-reg-offset (slot)
 154   (ecase slot
 155     (0 nl0-offset)
 156     (1 nl1-offset)))
 157
 158 ;;; FIXME: These #!-DARWIN methods should be adjusted to take a state
 159 ;;; argument, firstly because that's our "official" API (see
 160 ;;; src/code/host-alieneval) and secondly because that way we can
 161 ;;; probably have less duplication of code.  -- CSR, 2003-07-29
 162
 163 #!-darwin
 164 (define-alien-type-method (system-area-pointer :result-tn) (type)
 165   (declare (ignore type))
 166   (my-make-wired-tn 'system-area-pointer 'sap-reg nl0-offset))
 167
 168 #!+darwin
 169 (define-alien-type-method (system-area-pointer :result-tn) (type state)
 170   (declare (ignore type))
 171   (let ((num-results (result-state-num-results state)))
 172     (setf (result-state-num-results state) (1+ num-results))
 173     (my-make-wired-tn 'system-area-pointer 'sap-reg
 174                       (result-reg-offset num-results))))
 175
 176 #!-darwin
 177 (define-alien-type-method (single-float :result-tn) (type)
 178   (declare (ignore type state))
 179   (my-make-wired-tn 'single-float 'single-reg 1))
 180
 181 #!+darwin
 182 (define-alien-type-method (single-float :result-tn) (type state)
 183   (declare (ignore type state))
 184   (my-make-wired-tn 'single-float 'single-reg 1))
 185
 186 #!-darwin
 187 (define-alien-type-method (double-float :result-tn) (type)
 188   (declare (ignore type))
 189   (my-make-wired-tn 'double-float 'double-reg 1))
 190
 191 #!+darwin
 192 (define-alien-type-method (double-float :result-tn) (type state)
 193   (declare (ignore type state))
 194   (my-make-wired-tn 'double-float 'double-reg 1))
 195
 196 #!-darwin
 197 (define-alien-type-method (values :result-tn) (type)
 198   (mapcar #'(lambda (type)
 199               (invoke-alien-type-method :result-tn type))
 200           (alien-values-type-values type)))
 201
 202 #!+darwin
 203 (define-alien-type-method (values :result-tn) (type state)
 204   (let ((values (alien-values-type-values type)))
 205     (when (> (length values) 2)
 206       (error "Too many result values from c-call."))
 207     (mapcar #'(lambda (type)
 208                 (invoke-alien-type-method :result-tn type state))
 209             values)))
 210 #!-darwin
 211 (define-alien-type-method (integer :result-tn) (type)
 212   (if (alien-integer-type-signed type)
 213       (my-make-wired-tn 'signed-byte-32 'signed-reg nl0-offset)
 214       (my-make-wired-tn 'unsigned-byte-32 'unsigned-reg nl0-offset)))
 215
 216 #!+darwin
 217 (define-alien-type-method (integer :result-tn) (type state)
 218   (let ((num-results (result-state-num-results state)))
 219     (setf (result-state-num-results state) (1+ num-results))
 220     (multiple-value-bind (ptype reg-sc)
 221         (if (alien-integer-type-signed type)
 222             (values 'signed-byte-32 'signed-reg)
 223             (values 'unsigned-byte-32 'unsigned-reg))
 224       (my-make-wired-tn ptype reg-sc (result-reg-offset num-results)))))
 225
 226
 227 (!def-vm-support-routine make-call-out-tns (type)
 228   (declare (type alien-fun-type type))
 229   (let ((arg-state (make-arg-state)))
 230     (collect ((arg-tns))
 231       (dolist (arg-type (alien-fun-type-arg-types type))
 232         (arg-tns (invoke-alien-type-method :arg-tn arg-type arg-state)))
 233       (values (my-make-wired-tn 'positive-fixnum 'any-reg nsp-offset)
 234               (* (arg-state-stack-frame-size arg-state) n-word-bytes)
 235               (arg-tns)
 236               (invoke-alien-type-method
 237                :result-tn
 238                (alien-fun-type-result-type type)
 239                #!+darwin (make-result-state))))))
 240
 241 #!+darwin
 242 (deftransform %alien-funcall ((function type &rest args))
 243   (assert (sb!c::constant-lvar-p type))
 244   (let* ((type (sb!c::lvar-value type))
 245          (arg-types (alien-fun-type-arg-types type))
 246          (result-type (alien-fun-type-result-type type)))
 247     (assert (= (length arg-types) (length args)))
 248     ;; We need to do something special for 64-bit integer arguments
 249     ;; and results.
 250     (if (or (some #'(lambda (type)
 251                       (and (alien-integer-type-p type)
 252                            (> (sb!alien::alien-integer-type-bits type) 32)))
 253                   arg-types)
 254             (and (alien-integer-type-p result-type)
 255                  (> (sb!alien::alien-integer-type-bits result-type) 32)))
 256         (collect ((new-args) (lambda-vars) (new-arg-types))
 257                  (dolist (type arg-types)
 258                    (let ((arg (gensym)))
 259                      (lambda-vars arg)
 260                      (cond ((and (alien-integer-type-p type)
 261                                  (> (sb!alien::alien-integer-type-bits type) 32))
 262                             ;; 64-bit long long types are stored in
 263                             ;; consecutive locations, most significant word
 264                             ;; first (big-endian).
 265                             (new-args `(ash ,arg -32))
 266                             (new-args `(logand ,arg #xffffffff))
 267                             (if (alien-integer-type-signed type)
 268                                 (new-arg-types (parse-alien-type '(signed 32) (sb!kernel:make-null-lexenv)))
 269                                 (new-arg-types (parse-alien-type '(unsigned 32) (sb!kernel:make-null-lexenv))))
 270                             (new-arg-types (parse-alien-type '(unsigned 32) (sb!kernel:make-null-lexenv))))
 271                            (t
 272                             (new-args arg)
 273                             (new-arg-types type)))))
 274                  (cond ((and (alien-integer-type-p result-type)
 275                              (> (sb!alien::alien-integer-type-bits result-type) 32))
 276                         (let ((new-result-type
 277                                (let ((sb!alien::*values-type-okay* t))
 278                                  (parse-alien-type
 279                                   (if (alien-integer-type-signed result-type)
 280                                       '(values (signed 32) (unsigned 32))
 281                                       '(values (unsigned 32) (unsigned 32)))
 282                                   (sb!kernel:make-null-lexenv)))))
 283                           `(lambda (function type ,@(lambda-vars))
 284                             (declare (ignore type))
 285                             (multiple-value-bind (high low)
 286                                 (%alien-funcall function
 287                                                 ',(make-alien-fun-type
 288                                                    :arg-types (new-arg-types)
 289                                                    :result-type new-result-type)
 290                                                 ,@(new-args))
 291                               (logior low (ash high 32))))))
 292                        (t
 293                         `(lambda (function type ,@(lambda-vars))
 294                           (declare (ignore type))
 295                           (%alien-funcall function
 296                            ',(make-alien-fun-type
 297                               :arg-types (new-arg-types)
 298                               :result-type result-type)
 299                            ,@(new-args))))))
 300         (sb!c::give-up-ir1-transform))))
 301
 302 (define-vop (foreign-symbol-address)
 303   (:translate foreign-symbol-address)
 304   (:policy :fast-safe)
 305   (:args)
 306   (:arg-types (:constant simple-string))
 307   (:info foreign-symbol)
 308   (:results (res :scs (sap-reg)))
 309   (:result-types system-area-pointer)
 310   (:generator 2
 311     (inst lr res  (make-fixup foreign-symbol :foreign))))
 312
 313 #!+linkage-table
 314 (define-vop (foreign-symbol-dataref-address)
 315   (:translate foreign-symbol-dataref-address)
 316   (:policy :fast-safe)
 317   (:args)
 318   (:arg-types (:constant simple-string))
 319   (:info foreign-symbol)
 320   (:results (res :scs (sap-reg)))
 321   (:result-types system-area-pointer)
 322   (:temporary (:scs (non-descriptor-reg)) addr)
 323   (:generator 2
 324     (inst lr addr (make-fixup foreign-symbol :foreign-dataref))
 325     (loadw res addr)))
 326
 327 (define-vop (call-out)
 328   (:args (function :scs (sap-reg) :target cfunc)
 329          (args :more t))
 330   (:results (results :more t))
 331   (:ignore args results)
 332   (:save-p t)
 333   (:temporary (:sc any-reg :offset cfunc-offset
 334                    :from (:argument 0) :to (:result 0)) cfunc)
 335   (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save)
 336   (:temporary (:scs (non-descriptor-reg)) temp)
 337   (:vop-var vop)
 338   (:generator 0
 339     (let ((cur-nfp (current-nfp-tn vop)))
 340       (when cur-nfp
 341         (store-stack-tn nfp-save cur-nfp))
 342       (inst lr temp (make-fixup "call_into_c" :foreign))
 343       (inst mtctr temp)
 344       (move cfunc function)
 345       (inst bctrl)
 346       (when cur-nfp
 347         (load-stack-tn cur-nfp nfp-save)))))
 348
 349
 350 (define-vop (alloc-number-stack-space)
 351   (:info amount)
 352   (:results (result :scs (sap-reg any-reg)))
 353   (:temporary (:scs (unsigned-reg) :to (:result 0)) temp)
 354   (:generator 0
 355     (unless (zerop amount)
 356       ;; FIXME: I don't understand why we seem to be adding
 357       ;; NUMBER-STACK-DISPLACEMENT twice here.  Weird.  -- CSR,
 358       ;; 2003-08-20
 359       (let ((delta (- (logandc2 (+ amount number-stack-displacement
 360                                    +stack-alignment-bytes+)
 361                                 +stack-alignment-bytes+))))
 362         (cond ((>= delta (ash -1 16))
 363                (inst stwu nsp-tn nsp-tn delta))
 364               (t
 365                (inst lr temp delta)
 366                (inst stwux  nsp-tn nsp-tn temp)))))
 367     (unless (location= result nsp-tn)
 368       ;; They are only location= when the result tn was allocated by
 369       ;; make-call-out-tns above, which takes the number-stack-displacement
 370       ;; into account itself.
 371       (inst addi result nsp-tn number-stack-displacement))))
 372
 373 (define-vop (dealloc-number-stack-space)
 374   (:info amount)
 375   (:policy :fast-safe)
 376   (:generator 0
 377     (unless (zerop amount)
 378       (let ((delta (logandc2 (+ amount number-stack-displacement
 379                                 +stack-alignment-bytes+)
 380                              +stack-alignment-bytes+)))
 381         (cond ((< delta (ash 1 16))
 382                (inst addi nsp-tn nsp-tn delta))
 383               (t
 384                (inst lwz nsp-tn nsp-tn 0)))))))