src/compiler/mips/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 (defstruct arg-state
  15   (stack-frame-size 0)
  16   (did-int-arg nil)
  17   (float-args 0))
  18
  19 (define-alien-type-method (integer :arg-tn) (type state)
  20   (let ((stack-frame-size (arg-state-stack-frame-size state)))
  21     (setf (arg-state-stack-frame-size state) (1+ stack-frame-size))
  22     (setf (arg-state-did-int-arg state) t)
  23     (multiple-value-bind
  24         (ptype reg-sc stack-sc)
  25         (if (alien-integer-type-signed type)
  26             (values 'signed-byte-32 signed-reg-sc-number signed-stack-sc-number)
  27             (values 'unsigned-byte-32 unsigned-reg-sc-number unsigned-stack-sc-number))
  28       (if (< stack-frame-size 4)
  29           (make-wired-tn* ptype reg-sc (+ stack-frame-size 4))
  30           (make-wired-tn* ptype stack-sc stack-frame-size)))))
  31
  32 (define-alien-type-method (system-area-pointer :arg-tn) (type state)
  33   (declare (ignore type))
  34   (let ((stack-frame-size (arg-state-stack-frame-size state)))
  35     (setf (arg-state-stack-frame-size state) (1+ stack-frame-size))
  36     (setf (arg-state-did-int-arg state) t)
  37     (if (< stack-frame-size 4)
  38         (make-wired-tn* 'system-area-pointer sap-reg-sc-number
  39                           (+ stack-frame-size 4))
  40         (make-wired-tn* 'system-area-pointer sap-stack-sc-number
  41                           stack-frame-size))))
  42
  43 (define-alien-type-method (double-float :arg-tn) (type state)
  44   (declare (ignore type))
  45   (let ((stack-frame-size (logandc2 (1+ (arg-state-stack-frame-size state)) 1))
  46         (float-args (arg-state-float-args state)))
  47     (setf (arg-state-stack-frame-size state) (+ stack-frame-size 2))
  48     (setf (arg-state-float-args state) (1+ float-args))
  49     (cond ((>= stack-frame-size 4)
  50            (make-wired-tn* 'double-float double-stack-sc-number
  51                              stack-frame-size))
  52           ((and (not (arg-state-did-int-arg state))
  53                 (< float-args 2))
  54            (make-wired-tn* 'double-float double-reg-sc-number
  55                              (+ (* float-args 2) 12)))
  56           (t
  57            (make-wired-tn* 'double-float double-int-carg-reg-sc-number
  58                              (+ stack-frame-size 4))))))
  59
  60 (define-alien-type-method (single-float :arg-tn) (type state)
  61   (declare (ignore type))
  62   (let ((stack-frame-size (arg-state-stack-frame-size state))
  63         (float-args (arg-state-float-args state)))
  64     (setf (arg-state-stack-frame-size state) (1+ stack-frame-size))
  65     (setf (arg-state-float-args state) (1+ float-args))
  66     (cond ((>= stack-frame-size 4)
  67            (make-wired-tn* 'single-float single-stack-sc-number
  68                              stack-frame-size))
  69           ((and (not (arg-state-did-int-arg state))
  70                 (< float-args 2))
  71            (make-wired-tn* 'single-float single-reg-sc-number
  72                              (+ (* float-args 2) 12)))
  73           (t
  74            (make-wired-tn* 'single-float single-int-carg-reg-sc-number
  75                              (+ stack-frame-size 4))))))
  76
  77 (defstruct result-state
  78   (num-results 0))
  79
  80 (defun result-reg-offset (slot)
  81   (ecase slot
  82     (0 nl0-offset)
  83     (1 nl1-offset)))
  84
  85 (define-alien-type-method (integer :result-tn) (type state)
  86   (let ((num-results (result-state-num-results state)))
  87     (setf (result-state-num-results state) (1+ num-results))
  88     (multiple-value-bind (ptype reg-sc)
  89         (if (alien-integer-type-signed type)
  90             (values 'signed-byte-32 signed-reg-sc-number)
  91             (values 'unsigned-byte-32 unsigned-reg-sc-number))
  92       (make-wired-tn* ptype reg-sc (result-reg-offset num-results)))))
  93
  94 (define-alien-type-method (system-area-pointer :result-tn) (type state)
  95   (declare (ignore type))
  96   (let ((num-results (result-state-num-results state)))
  97     (setf (result-state-num-results state) (1+ num-results))
  98     (make-wired-tn* 'system-area-pointer sap-reg-sc-number (result-reg-offset num-results))))
  99
 100 ;;; FIXME: do these still work? -- CSR, 2002-08-28
 101 (define-alien-type-method (double-float :result-tn) (type state)
 102   (declare (ignore type))
 103   (let ((num-results (result-state-num-results state)))
 104     (setf (result-state-num-results state) (1+ num-results))
 105     (make-wired-tn* 'double-float double-reg-sc-number (* num-results 2))))
 106
 107 (define-alien-type-method (single-float :result-tn) (type state)
 108   (declare (ignore type))
 109   (let ((num-results (result-state-num-results state)))
 110     (setf (result-state-num-results state) (1+ num-results))
 111     (make-wired-tn* 'single-float single-reg-sc-number (* num-results 2))))
 112
 113 (define-alien-type-method (values :result-tn) (type state)
 114   (let ((values (alien-values-type-values type)))
 115     (when (> (length values) 2)
 116       (error "Too many result values from c-call."))
 117     (mapcar #'(lambda (type)
 118                 (invoke-alien-type-method :result-tn type state))
 119             values)))
 120
 121 (defun make-call-out-tns (type)
 122   (let ((arg-state (make-arg-state)))
 123     (collect ((arg-tns))
 124       (dolist (arg-type (alien-fun-type-arg-types type))
 125         (arg-tns (invoke-alien-type-method :arg-tn arg-type arg-state)))
 126       (values (make-wired-tn* 'positive-fixnum any-reg-sc-number nsp-offset)
 127               (* (max (arg-state-stack-frame-size arg-state) 4) n-word-bytes)
 128               (arg-tns)
 129               (invoke-alien-type-method :result-tn
 130                                         (alien-fun-type-result-type type)
 131                                         (make-result-state))))))
 132
 133 (deftransform %alien-funcall ((function type &rest args))
 134   (aver (sb!c::constant-lvar-p type))
 135   (let* ((type (sb!c::lvar-value type))
 136          (env (make-null-lexenv))
 137          (arg-types (alien-fun-type-arg-types type))
 138          (result-type (alien-fun-type-result-type type)))
 139     (aver (= (length arg-types) (length args)))
 140     ;; We need to do something special for 64-bit integer arguments
 141     ;; and results.
 142     (if (or (some #'(lambda (type)
 143                       (and (alien-integer-type-p type)
 144                            (> (sb!alien::alien-integer-type-bits type) 32)))
 145                   arg-types)
 146             (and (alien-integer-type-p result-type)
 147                  (> (sb!alien::alien-integer-type-bits result-type) 32)))
 148         (collect ((new-args) (lambda-vars) (new-arg-types))
 149                  (dolist (type arg-types)
 150                    (let ((arg (gensym)))
 151                      (lambda-vars arg)
 152                      (cond ((and (alien-integer-type-p type)
 153                                  (> (sb!alien::alien-integer-type-bits type) 32))
 154                             ;; 64-bit long long types are stored in
 155                             ;; consecutive locations, endian word order,
 156                             ;; aligned to 8 bytes.
 157                             (when (oddp (length (new-args)))
 158                               (new-args nil))
 159                             #!-little-endian
 160                             (progn (new-args `(ash ,arg -32))
 161                                    (new-args `(logand ,arg #xffffffff))
 162                                    (if (oddp (length (new-arg-types)))
 163                                        (new-arg-types (parse-alien-type '(unsigned 32) env)))
 164                                    (if (alien-integer-type-signed type)
 165                                        (new-arg-types (parse-alien-type '(signed 32) env))
 166                                        (new-arg-types (parse-alien-type '(unsigned 32) env)))
 167                                    (new-arg-types (parse-alien-type '(unsigned 32) env)))
 168                             #!+little-endian
 169                             (progn (new-args `(logand ,arg #xffffffff))
 170                                    (new-args `(ash ,arg -32))
 171                                    (if (oddp (length (new-arg-types)))
 172                                        (new-arg-types (parse-alien-type '(unsigned 32) env)))
 173                                    (new-arg-types (parse-alien-type '(unsigned 32) env))
 174                                    (if (alien-integer-type-signed type)
 175                                        (new-arg-types (parse-alien-type '(signed 32) env))
 176                                        (new-arg-types (parse-alien-type '(unsigned 32) env)))))
 177                            (t
 178                             (new-args arg)
 179                             (new-arg-types type)))))
 180                  (cond ((and (alien-integer-type-p result-type)
 181                              (> (sb!alien::alien-integer-type-bits result-type) 32))
 182                         (let ((new-result-type
 183                                (let ((sb!alien::*values-type-okay* t))
 184                                  (parse-alien-type
 185                                   (if (alien-integer-type-signed result-type)
 186                                       #!-little-endian
 187                                       '(values (signed 32) (unsigned 32))
 188                                       #!+little-endian
 189                                       '(values (unsigned 32) (signed 32))
 190                                       '(values (unsigned 32) (unsigned 32)))
 191                                   env))))
 192                           `(lambda (function type ,@(lambda-vars))
 193                             (declare (ignore type))
 194                              (multiple-value-bind
 195                                #!-little-endian
 196                                (high low)
 197                                #!+little-endian
 198                                (low high)
 199                                (%alien-funcall function
 200                                   ',(make-alien-fun-type
 201                                        :arg-types (new-arg-types)
 202                                        :result-type new-result-type)
 203                                   ,@(new-args))
 204                                (logior low (ash high 32))))))
 205                        (t
 206                         `(lambda (function type ,@(lambda-vars))
 207                           (declare (ignore type))
 208                           (%alien-funcall function
 209                            ',(make-alien-fun-type
 210                               :arg-types (new-arg-types)
 211                               :result-type result-type)
 212                            ,@(new-args))))))
 213         (sb!c::give-up-ir1-transform))))
 214
 215 (define-vop (foreign-symbol-sap)
 216   (:translate foreign-symbol-sap)
 217   (:policy :fast-safe)
 218   (:args)
 219   (:arg-types (:constant simple-string))
 220   (:info foreign-symbol)
 221   (:results (res :scs (sap-reg)))
 222   (:result-types system-area-pointer)
 223   (:generator 2
 224     (inst li res (make-fixup foreign-symbol :foreign))))
 225
 226 #!+linkage-table
 227 (define-vop (foreign-symbol-dataref-sap)
 228   (:translate foreign-symbol-dataref-sap)
 229   (:policy :fast-safe)
 230   (:args)
 231   (:arg-types (:constant simple-string))
 232   (:info foreign-symbol)
 233   (:results (res :scs (sap-reg)))
 234   (:result-types system-area-pointer)
 235   (:temporary (:scs (non-descriptor-reg)) addr)
 236   (:generator 2
 237     (inst li addr (make-fixup foreign-symbol :foreign-dataref))
 238     (loadw res addr)))
 239
 240 (define-vop (call-out)
 241   (:args (function :scs (sap-reg) :target cfunc)
 242          (args :more t))
 243   (:results (results :more t))
 244   (:ignore args results)
 245   (:save-p t)
 246   (:temporary (:sc any-reg :offset cfunc-offset
 247                    :from (:argument 0) :to (:result 0)) cfunc)
 248   (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save)
 249   (:vop-var vop)
 250   (:generator 0
 251     (let ((cur-nfp (current-nfp-tn vop)))
 252       (when cur-nfp
 253         (store-stack-tn nfp-save cur-nfp))
 254       (inst jal (make-fixup "call_into_c" :foreign))
 255       (move cfunc function t)
 256       (when cur-nfp
 257         (load-stack-tn cur-nfp nfp-save)))))
 258
 259 (define-vop (alloc-number-stack-space)
 260   (:info amount)
 261   (:result-types system-area-pointer)
 262   (:results (result :scs (sap-reg any-reg)))
 263   (:temporary (:scs (unsigned-reg) :to (:result 0)) temp)
 264   (:generator 0
 265     (unless (zerop amount)
 266       (let ((delta (logandc2 (+ amount 7) 7)))
 267         (cond ((< delta (ash 1 15))
 268                (inst subu nsp-tn delta))
 269               (t
 270                (inst li temp delta)
 271                (inst subu nsp-tn temp)))))
 272     (move result nsp-tn)))
 273
 274 (define-vop (dealloc-number-stack-space)
 275   (:info amount)
 276   (:policy :fast-safe)
 277   (:temporary (:scs (unsigned-reg) :to (:result 0)) temp)
 278   (:generator 0
 279     (unless (zerop amount)
 280       (let ((delta (logandc2 (+ amount 7) 7)))
 281         (cond ((< delta (ash 1 15))
 282                (inst addu nsp-tn delta))
 283               (t
 284                (inst li temp delta)
 285                (inst addu nsp-tn temp)))))))
 286
 287 #-sb-xc-host
 288 (defun alien-callback-accessor-form (type sap offset)
 289   ;; KLUDGE: OFFSET is given to be word-aligned (32-bit aligned), but
 290   ;; double-float and long-long (both 64-bit wide) arguments need to
 291   ;; be 64-bit aligned.  And then there's the bit where sub-word-wide
 292   ;; values are aligned towards the END of the word on big-endian
 293   ;; systems.  For both cases, we need to parse the alien type, but we
 294   ;; aren't given the environment that our caller has access to, so we
 295   ;; substitute a null lexenv (KLUDGE number one), then we do some bit
 296   ;; twiddling to determine how much alignment we need.  Why, oh why
 297   ;; can't we have something like the :ARG-TN methods for all of this
 298   ;; mess?  -- AB, 2015-Nov-02
 299   (let* ((parsed-type (parse-alien-type type nil))
 300          (alignment-bits (sb!alien::alien-type-alignment parsed-type))
 301          (alignment-bytes (truncate alignment-bits n-byte-bits))
 302          ;; OFFSET is at least 32-bit aligned, we're trying to pick
 303          ;; out the cases where we need 64-bit alignment.
 304          (delta (logand offset (1- alignment-bytes))))
 305     (values
 306      (ecase *backend-byte-order*
 307        (:big-endian
 308         (if (alien-integer-type-p parsed-type)
 309             (let ((bits (sb!alien::alien-integer-type-bits parsed-type)))
 310               (let ((byte-offset
 311                      (cond ((< bits n-word-bits)
 312                             (- n-word-bytes
 313                                (ceiling bits n-byte-bits)))
 314                            (t 0))))
 315                 `(deref (sap-alien (sap+ ,sap
 316                                          ,(+ byte-offset offset delta))
 317                                    (* ,type)))))
 318           `(deref (sap-alien (sap+ ,sap ,(+ offset delta)) (* ,type)))))
 319        (:little-endian
 320         `(deref (sap-alien (sap+ ,sap ,(+ offset delta)) (* ,type)))))
 321      delta)))
 322
 323 ;;; Returns a vector in static space containing machine code for the
 324 ;;; callback wrapper
 325 #-sb-xc-host
 326 (defun alien-callback-assembler-wrapper (index result-type argument-types)
 327   "Cons up a piece of code which calls enter-alien-callback with INDEX
 328 and a pointer to the arguments."
 329   (flet ((make-gpr (n)
 330            (make-random-tn :kind :normal :sc (sc-or-lose 'any-reg) :offset n))
 331          (make-fpr (n)
 332            (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg) :offset n)))
 333     (let* ((segment (make-segment))
 334            (n-argument-words
 335              (mapcar (lambda (arg) (ceiling (alien-type-bits arg) n-word-bits))
 336                      argument-types))
 337            (n-linkage-area-bytes 8)
 338            (n-return-area-words
 339              (ceiling (or (alien-type-bits result-type) 0) n-word-bits))
 340            (n-return-area-bytes (* n-return-area-words n-word-bytes))
 341            (n-callee-register-args-bytes 16)
 342            (n-frame-bytes (logandc2 (+ n-linkage-area-bytes
 343                                        n-return-area-bytes
 344                                        n-callee-register-args-bytes
 345                                        7)
 346                                     7))
 347            (words-processed 0)
 348            (int-seen)
 349            (gprs (mapcar #'make-gpr '(4 5 6 7)))
 350            (fprs (mapcar #'make-fpr '(12 14))))
 351       (flet ((save-arg (type words)
 352              (let ((offset (* words-processed n-word-bytes)))
 353                (cond ((not (alien-float-type-p type))
 354                       (when (and (alien-integer-type-p type)
 355                                  (> (sb!alien::alien-integer-type-bits type)
 356                                     n-word-bits)
 357                                  (oddp words-processed))
 358                         (pop gprs)
 359                         (incf words-processed)
 360                         (incf offset n-word-bytes))
 361                       (when gprs
 362                         (loop repeat words
 363                           for gpr = (pop gprs)
 364                           when gpr do
 365                             (inst sw gpr nsp-tn offset)
 366                           do
 367                             (setf int-seen t)
 368                             (incf words-processed)
 369                             (incf offset n-word-bytes))))
 370                      ((alien-single-float-type-p type)
 371                       (when gprs
 372                         (let ((gpr (pop gprs))
 373                               (fpr (pop fprs)))
 374                           (cond
 375                            ((and (not int-seen) fpr)
 376                             (inst swc1 fpr nsp-tn offset))
 377                            (gpr
 378                             (inst sw gpr nsp-tn offset))))
 379                         (incf words-processed)))
 380                      ((alien-double-float-type-p type)
 381                       (when (oddp words-processed)
 382                         (pop gprs)
 383                         (incf words-processed)
 384                         (incf offset n-word-bytes))
 385                       (when gprs
 386                         (let* ((gpr1 (pop gprs))
 387                                (gpr2 (pop gprs))
 388                                (fpr (pop fprs)))
 389                           (cond
 390                            ((and (not int-seen) fpr)
 391                             (ecase *backend-byte-order*
 392                               (:big-endian
 393                                (inst swc1 fpr nsp-tn (+ offset n-word-bytes))
 394                                (inst swc1-odd fpr nsp-tn offset))
 395                               (:little-endian
 396                                (inst swc1 fpr nsp-tn offset)
 397                                (inst swc1-odd fpr nsp-tn (+ offset n-word-bytes)))))
 398                            (gpr1
 399                             (ecase *backend-byte-order*
 400                               (:big-endian
 401                                (inst sw gpr1 nsp-tn offset)
 402                                (inst sw gpr2 nsp-tn (+ offset n-word-bytes)))
 403                               (:little-endian
 404                                (inst sw gpr2 nsp-tn offset)
 405                                (inst sw gpr1 nsp-tn (+ offset n-word-bytes)))))))
 406                         (incf words-processed 2)))
 407                      (t
 408                       (bug "Unknown alien floating point type: ~S" type))))))
 409         (assemble (segment)
 410           (mapc #'save-arg argument-types n-argument-words)
 411           ;; funcall3 (enter-alien-callback, index, args, return-area)
 412           ;;
 413           ;; INDEX is fixnumized, ARGS and RETURN-AREA don't need to be
 414           ;; because they're word-aligned. Kinda gross, but hey ...
 415           (destructuring-bind (v0 v1 a0 a1 a2 a3 t9 gp sp ra)
 416               (mapcar #'make-gpr '(2 3 4 5 6 7 25 28 29 31))
 417             ;; Allocate stack frame.
 418             (inst subu sp n-frame-bytes)
 419
 420             ;; Save GP and RA.
 421             (inst sw gp sp (- n-frame-bytes (* 2 n-word-bytes)))
 422             (inst sw ra sp (- n-frame-bytes n-word-bytes))
 423
 424             ;; Setup the args and make the call.
 425             (inst li a0 (static-fdefn-fun-addr 'enter-alien-callback))
 426             (inst lw a0 a0)
 427             (inst li t9 (foreign-symbol-address "funcall3"))
 428             (inst li a1 (fixnumize index))
 429             (inst addu a2 sp n-frame-bytes)
 430             (inst jal t9)
 431             (inst addu a3 sp n-callee-register-args-bytes)
 432
 433             ;; We're back! Restore GP.
 434             (inst lw gp sp (- n-frame-bytes (* 2 n-word-bytes)))
 435
 436             ;; Load the return value.
 437             (cond
 438               ((alien-single-float-type-p result-type)
 439                (inst lwc1 (make-fpr 0) sp n-callee-register-args-bytes))
 440               ((alien-double-float-type-p result-type)
 441                (ecase *backend-byte-order*
 442                  (:big-endian
 443                   (inst lwc1 (make-fpr 0) sp (+ n-callee-register-args-bytes
 444                                                 n-word-bytes))
 445                   (inst lwc1 (make-fpr 1) sp n-callee-register-args-bytes))
 446                  (:little-endian
 447                   (inst lwc1 (make-fpr 0) sp n-callee-register-args-bytes)
 448                   (inst lwc1 (make-fpr 1) sp (+ n-callee-register-args-bytes
 449                                                 n-word-bytes)))))
 450               ((and (alien-integer-type-p result-type)
 451                     (> (sb!alien::alien-integer-type-bits result-type)
 452                        n-word-bits))
 453                (inst lw v0 sp n-callee-register-args-bytes)
 454                (inst lw v1 sp (+ n-callee-register-args-bytes n-word-bytes)))
 455               ((or (alien-integer-type-p result-type)
 456                    (alien-pointer-type-p result-type)
 457                    (alien-type-= #.(parse-alien-type 'system-area-pointer nil)
 458                                    result-type))
 459                (inst lw v0 sp n-callee-register-args-bytes))
 460               ((alien-void-type-p result-type))
 461               (t
 462                (error "unrecognized alien type: ~A" result-type)))
 463
 464             ;; Restore RA, free stack frame, and return.
 465             (inst lw ra sp (- n-frame-bytes n-word-bytes))
 466             (inst j ra)
 467             (inst addu sp n-frame-bytes))))
 468       (finalize-segment segment)
 469       ;; Now that the segment is done, convert it to a static
 470       ;; vector we can point foreign code to.
 471       (let* ((buffer (sb!assem::segment-buffer segment))
 472              (vector (make-static-vector (length buffer)
 473                                          :element-type '(unsigned-byte 8)
 474                                          :initial-contents buffer))
 475              (sap (vector-sap vector)))
 476         (alien-funcall
 477          (extern-alien "os_flush_icache"
 478                        (function void
 479                                  system-area-pointer
 480                                  unsigned-long))
 481          sap (length buffer))
 482         vector))))