;;;; transforms and other stuff used to compile ALIEN operations

;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
;;;;
;;;; This software is derived from the CMU CL system, which was
;;;; written at Carnegie Mellon University and released into the
;;;; public domain. The software is in the public domain and is
;;;; provided with absolutely no warranty. See the COPYING and CREDITS
;;;; files for more information.

(in-package "SB-C")

;;;; DEFKNOWNs

(defknown %sap-alien (system-area-pointer alien-type) alien-value
  (flushable movable))
(defknown alien-sap (alien-value) system-area-pointer
  (flushable movable)) ; (could be always-translatable depending on the backend)

(defknown slot (alien-value symbol) t
  (flushable recursive))
(defknown %set-slot (alien-value symbol t) t
  (recursive))
(defknown %slot-addr (alien-value symbol) (alien (* t))
  (flushable movable recursive))

(defknown deref (alien-value &rest index) t
  (flushable))
(defknown %set-deref (alien-value t &rest index) t
  ())
(defknown %deref-addr (alien-value &rest index) (alien (* t))
  (flushable movable))

(defknown %heap-alien (heap-alien-info) t
  (flushable))
(defknown %set-heap-alien (heap-alien-info t) t
  ())
(defknown %heap-alien-addr (heap-alien-info) (alien (* t))
  (flushable movable))

(defknown make-local-alien (local-alien-info) t
  ())
(defknown note-local-alien-type (local-alien-info t) null
  ())
(defknown local-alien (local-alien-info t) t
  (flushable))
(defknown %local-alien-forced-to-memory-p (local-alien-info) (member t nil)
  (movable))
(defknown %set-local-alien (local-alien-info t t) t
  ())
(defknown %local-alien-addr (local-alien-info t) (alien (* t))
  (flushable movable))

(defknown %cast (alien-value alien-type) alien
  (flushable movable))

(defknown naturalize (t alien-type) alien
  (flushable movable))
(defknown deport (alien alien-type) t
  (flushable movable))
(defknown deport-alloc (alien alien-type) t
  (flushable movable))
(defknown %alien-value (system-area-pointer word alien-type) t
  (flushable))
(defknown (setf %alien-value) (t system-area-pointer word alien-type) t
  ())

;;; alien-funcall calls a foreign function and returns its result.
;;; For struct returns, it allocates heap memory and returns an alien wrapper.
(defknown alien-funcall (alien-value &rest t) *
  (any recursive))

;;; alien-funcall-into calls a foreign function that returns a struct,
;;; writing the result to a caller-provided buffer (typically stack-allocated
;;; via with-alien). Returns (values) - caller accesses result via the buffer.
;;; The function type is extracted from the alien-function argument.
(defknown alien-funcall-into (alien-value system-area-pointer &rest t)
    (values)
  (any recursive))

(defknown sb-alien::string-to-c-string (simple-string t) (or (simple-array (unsigned-byte 8) (*))
                                                             simple-base-string)
    (movable flushable))
(defknown sb-alien::c-string-to-string (system-area-pointer t t) simple-string
    (movable flushable))
(defknown sb-alien::c-string-external-format * *
        (movable flushable))

;;;; cosmetic transforms

(deftransform slot ((object slot)
                    ((alien (* t)) symbol))
  '(slot (deref object) slot))

(deftransform %set-slot ((object slot value)
                         ((alien (* t)) symbol t))
  '(%set-slot (deref object) slot value))

(deftransform %slot-addr ((object slot)
                          ((alien (* t)) symbol))
  '(%slot-addr (deref object) slot))

;;;; SLOT support

(defun find-slot-offset-and-type (alien slot)
  (unless (constant-lvar-p slot)
    (give-up-ir1-transform
     "The slot is not constant, so access cannot be open coded."))
  (let ((type (lvar-type alien)))
    (unless (alien-type-type-p type)
      (give-up-ir1-transform))
    (let ((alien-type (alien-type-type-alien-type type)))
      (unless (alien-record-type-p alien-type)
        (give-up-ir1-transform))
      (let* ((slot-name (lvar-value slot))
             (field (find slot-name (alien-record-type-fields alien-type)
                          :key #'alien-record-field-name)))
        (unless field
          (abort-ir1-transform "~S~% doesn't have a slot named ~S"
                               type slot-name))
        (values (alien-record-field-offset field)
                (alien-record-field-type field))))))

#+nil ;; Shouldn't be necessary.
(defoptimizer (slot derive-type) ((alien slot))
  (block nil
    (catch 'give-up-ir1-transform
      (multiple-value-bind (slot-offset slot-type)
          (find-slot-offset-and-type alien slot)
        (declare (ignore slot-offset))
        (return (make-alien-type-type slot-type))))
    *wild-type*))

(deftransform slot ((alien slot))
  (multiple-value-bind (slot-offset slot-type)
      (find-slot-offset-and-type alien slot)
    `(%alien-value (alien-sap alien)
                   ,slot-offset
                   ',slot-type)))

#+nil ;; ### But what about coercions?
(defoptimizer (%set-slot derive-type) ((alien slot value))
  (block nil
    (catch 'give-up-ir1-transform
      (multiple-value-bind (slot-offset slot-type)
          (find-slot-offset-and-type alien slot)
        (declare (ignore slot-offset))
        (let ((type (make-alien-type-type slot-type)))
          (assert-lvar-type value type)
          (return type))))
    *wild-type*))

(deftransform %set-slot ((alien slot value))
  (multiple-value-bind (slot-offset slot-type)
      (find-slot-offset-and-type alien slot)
    `(setf (%alien-value (alien-sap alien)
                         ,slot-offset
                         ',slot-type)
           value)))

(defoptimizer (%slot-addr derive-type) ((alien slot))
  (block nil
    (catch 'give-up-ir1-transform
      (multiple-value-bind (slot-offset slot-type)
          (find-slot-offset-and-type alien slot)
        (declare (ignore slot-offset))
        (return (make-alien-type-type
                 (make-alien-pointer-type :to slot-type)))))
    *wild-type*))

(deftransform %slot-addr ((alien slot))
  (multiple-value-bind (slot-offset slot-type)
      (find-slot-offset-and-type alien slot)
    (/noshow "in DEFTRANSFORM %SLOT-ADDR, creating %SAP-ALIEN")
    `(%sap-alien (sap+ (alien-sap alien) (/ ,slot-offset sb-vm:n-byte-bits))
                 ',(make-alien-pointer-type :to slot-type))))

;;;; DEREF support

(defun find-deref-alien-type (alien)
  (let ((alien-type (lvar-type alien)))
    (unless (alien-type-type-p alien-type)
      (give-up-ir1-transform))
    (alien-type-type-alien-type alien-type)))

(defun find-deref-element-type (alien)
  (let ((alien-type (find-deref-alien-type alien)))
    (typecase alien-type
      (alien-pointer-type
       (alien-pointer-type-to alien-type))
      (alien-array-type
       (alien-array-type-element-type alien-type))
      (t
       (give-up-ir1-transform)))))

(defun compute-deref-guts (alien indices)
  (let ((alien-type (find-deref-alien-type alien)))
    (typecase alien-type
      (alien-pointer-type
       (when (cdr indices)
         (abort-ir1-transform "too many indices for pointer deref: ~W"
                              (length indices)))
       (let ((element-type (alien-pointer-type-to alien-type)))
         (unless element-type
           (give-up-ir1-transform "unable to open code deref of wild pointer type"))
         (if indices
             (let ((bits (alien-type-bits element-type))
                   (alignment (alien-type-alignment element-type)))
               (unless bits
                 (abort-ir1-transform "unknown element size"))
               (unless alignment
                 (abort-ir1-transform "unknown element alignment"))
               (values '(offset)
                       `(* offset
                           ,(align-offset bits alignment))
                       element-type))
             (values nil 0 element-type))))
      (alien-array-type
       (let* ((element-type (alien-array-type-element-type alien-type))
              (bits (alien-type-bits element-type))
              (alignment (alien-type-alignment element-type))
              (dims (alien-array-type-dimensions alien-type)))
         (unless (= (length indices) (length dims))
           (give-up-ir1-transform "incorrect number of indices"))
         (unless bits
           (give-up-ir1-transform "Element size is unknown."))
         (unless alignment
           (give-up-ir1-transform "Element alignment is unknown."))
         (if (null dims)
             (values nil 0 element-type)
             (let* ((arg (gensym))
                    (args (list arg))
                    (offsetexpr arg))
               (dolist (dim (cdr dims))
                 (let ((arg (gensym)))
                   (push arg args)
                   (setf offsetexpr `(+ (* ,offsetexpr ,dim) ,arg))))
               (values (reverse args)
                       `(* ,offsetexpr
                           ,(align-offset bits alignment))
                       element-type)))))
      (t
       (abort-ir1-transform "~S not either a pointer or array type."
                            alien-type)))))

#+nil ;; Shouldn't be necessary.
(defoptimizer (deref derive-type) ((alien &rest noise))
  (block nil
    (catch 'give-up-ir1-transform
      (return (make-alien-type-type (find-deref-element-type alien))))
    *wild-type*))

(deftransform deref ((alien &rest indices))
  (multiple-value-bind (indices-args offset-expr element-type)
      (compute-deref-guts alien indices)
    `(lambda (alien ,@indices-args)
       (%alien-value (alien-sap alien)
                     ,offset-expr
                     ',element-type))))

#+nil ;; ### Again, the value might be coerced.
(defoptimizer (%set-deref derive-type) ((alien value &rest noise))
  (block nil
    (catch 'give-up-ir1-transform
      (let ((type (make-alien-type-type
                   (make-alien-pointer-type
                    :to (find-deref-element-type alien)))))
        (assert-lvar-type value type)
        (return type)))
    *wild-type*))

(deftransform %set-deref ((alien value &rest indices))
  (multiple-value-bind (indices-args offset-expr element-type)
      (compute-deref-guts alien indices)
    `(lambda (alien value ,@indices-args)
       (setf (%alien-value (alien-sap alien)
                           ,offset-expr
                           ',element-type)
             value))))

(defoptimizer (%deref-addr derive-type) ((alien &rest noise))
  (block nil
    (catch 'give-up-ir1-transform
      (return (make-alien-type-type
               (make-alien-pointer-type
                :to (find-deref-element-type alien)))))
    *wild-type*))

(deftransform %deref-addr ((alien &rest indices))
  (multiple-value-bind (indices-args offset-expr element-type)
      (compute-deref-guts alien indices)
    (/noshow "in DEFTRANSFORM %DEREF-ADDR, creating (LAMBDA .. %SAP-ALIEN)")
    `(lambda (alien ,@indices-args)
       (%sap-alien (sap+ (alien-sap alien) (/ ,offset-expr sb-vm:n-byte-bits))
                   ',(make-alien-pointer-type :to element-type)))))

;;;; support for aliens on the heap

(defun heap-alien-sap-and-type (info)
  (unless (constant-lvar-p info)
    (give-up-ir1-transform "info not constant; can't open code"))
  (let ((info (lvar-value info)))
    (values (heap-alien-info-sap-form info)
            (heap-alien-info-type info))))

#+nil ; shouldn't be necessary
(defoptimizer (%heap-alien derive-type) ((info))
  (block nil
    (catch 'give-up
      (multiple-value-bind (sap type) (heap-alien-sap-and-type info)
        (declare (ignore sap))
        (return (make-alien-type-type type))))
    *wild-type*))

(deftransform %heap-alien ((info) ((constant-arg heap-alien-info)) *)
  (multiple-value-bind (sap type) (heap-alien-sap-and-type info)
    `(%alien-value ,sap 0 ',type)))

#+nil ;; ### Again, deposit value might change the type.
(defoptimizer (%set-heap-alien derive-type) ((info value))
  (block nil
    (catch 'give-up-ir1-transform
      (multiple-value-bind (sap type) (heap-alien-sap-and-type info)
        (declare (ignore sap))
        (let ((type (make-alien-type-type type)))
          (assert-lvar-type value type)
          (return type))))
    *wild-type*))

(deftransform %set-heap-alien ((info value) (heap-alien-info t) *)
  (multiple-value-bind (sap type) (heap-alien-sap-and-type info)
    `(setf (%alien-value ,sap 0 ',type) value)))

(defoptimizer (%heap-alien-addr derive-type) ((info))
  (block nil
    (catch 'give-up-ir1-transform
      (multiple-value-bind (sap type) (heap-alien-sap-and-type info)
        (declare (ignore sap))
        (return (make-alien-type-type (make-alien-pointer-type :to type)))))
    *wild-type*))

(deftransform %heap-alien-addr ((info))
  (multiple-value-bind (sap type) (heap-alien-sap-and-type info)
    (/noshow "in DEFTRANSFORM %HEAP-ALIEN-ADDR, creating %SAP-ALIEN")
    `(%sap-alien ,sap ',(make-alien-pointer-type :to type))))


;;;; support for local (stack or register) aliens

(defun alien-info-constant-or-abort (info)
  (unless (constant-lvar-p info)
    (abort-ir1-transform "Local alien info isn't constant?")))

(deftransform make-local-alien ((info))
  (alien-info-constant-or-abort info)
  (let* ((info (lvar-value info))
         (alien-type (local-alien-info-type info))
         (bits (alien-type-bits alien-type)))
    (unless bits
      (abort-ir1-transform "unknown size: ~S" (unparse-alien-type alien-type)))
    (/noshow "in DEFTRANSFORM MAKE-LOCAL-ALIEN" info)
    (/noshow (local-alien-info-force-to-memory-p info))
    (/noshow alien-type (unparse-alien-type alien-type) (alien-type-bits alien-type))
    (if (local-alien-info-force-to-memory-p info)
        #+(or x86 x86-64)
        `(%primitive alloc-alien-stack-space
                     ,(ceiling (alien-type-bits alien-type)
                               sb-vm:n-byte-bits))
        #-(or x86 x86-64)
        `(%primitive alloc-number-stack-space
                     ,(ceiling (alien-type-bits alien-type)
                               sb-vm:n-byte-bits))
        (let* ((alien-rep-type-spec (compute-alien-rep-type alien-type))
               (alien-rep-type (specifier-type alien-rep-type-spec)))
          (cond ((csubtypep (specifier-type 'system-area-pointer)
                            alien-rep-type)
                 '(int-sap 0))
                ((ctypep 0 alien-rep-type) 0)
                ((ctypep 0.0f0 alien-rep-type) 0.0f0)
                ((ctypep 0.0d0 alien-rep-type) 0.0d0)
                (t
                 (compiler-error
                  "Aliens of type ~S cannot be represented immediately."
                  (unparse-alien-type alien-type))))))))

(deftransform note-local-alien-type ((info var))
  (alien-info-constant-or-abort info)
  (let ((info (lvar-value info)))
    (unless (local-alien-info-force-to-memory-p info)
      (let ((var-node (lvar-uses var)))
        (when (and (ref-p var-node)
                   (constant-reference-p var-node))
          (propagate-to-refs (ref-leaf var-node)
                             (specifier-type
                              (compute-alien-rep-type
                               (local-alien-info-type info))))))))
  nil)

(deftransform local-alien ((info var))
  (alien-info-constant-or-abort info)
  (let* ((info (lvar-value info))
         (alien-type (local-alien-info-type info)))
    (/noshow "in DEFTRANSFORM LOCAL-ALIEN" info alien-type)
    (/noshow (local-alien-info-force-to-memory-p info))
    (if (local-alien-info-force-to-memory-p info)
        `(%alien-value var 0 ',alien-type)
        `(naturalize var ',alien-type))))

(deftransform %local-alien-forced-to-memory-p ((info))
  (alien-info-constant-or-abort info)
  (let ((info (lvar-value info)))
    (local-alien-info-force-to-memory-p info)))

(deftransform %set-local-alien ((info var value))
  (alien-info-constant-or-abort info)
  (let* ((info (lvar-value info))
         (alien-type (local-alien-info-type info)))
    (if (local-alien-info-force-to-memory-p info)
        `(setf (%alien-value var 0 ',alien-type) value)
        '(error "This should be eliminated as dead code."))))

(defoptimizer (%local-alien-addr derive-type) ((info var))
  (if (constant-lvar-p info)
      (let* ((info (lvar-value info))
             (alien-type (local-alien-info-type info)))
        (make-alien-type-type (make-alien-pointer-type :to alien-type)))
      *wild-type*))

(deftransform %local-alien-addr ((info var))
  (alien-info-constant-or-abort info)
  (let* ((info (lvar-value info))
         (alien-type (local-alien-info-type info)))
    (/noshow "in DEFTRANSFORM %LOCAL-ALIEN-ADDR, creating %SAP-ALIEN")
    (if (local-alien-info-force-to-memory-p info)
        `(%sap-alien var ',(make-alien-pointer-type :to alien-type))
        (error "This shouldn't happen."))))

;;;; %CAST

(defoptimizer (%cast derive-type) ((alien type))
  (or (when (constant-lvar-p type)
        (let ((alien-type (lvar-value type)))
          (when (alien-type-p alien-type)
            (make-alien-type-type alien-type))))
      *wild-type*))

(deftransform %cast ((alien target-type))
  (unless (constant-lvar-p target-type)
    (give-up-ir1-transform
     "The alien type is not constant, so access cannot be open coded."))
  (let ((target-type (lvar-value target-type)))
    (cond ((or (alien-pointer-type-p target-type)
               (alien-array-type-p target-type)
               (alien-fun-type-p target-type))
           `(naturalize (alien-sap alien) ',target-type))
          (t
           (abort-ir1-transform "cannot cast to alien type ~S" target-type)))))

;;;; ALIEN-SAP, %SAP-ALIEN, %ADDR, etc.

;;; I enabled this as a sanity check to verfify that the compiler only inserts ALIEN-SAP
;;; calls on things which are instances of ALIEN-VALUE. But this is not needed, and
;;; it's actually inadequate because apparently both (ALIEN (* (FUNCTION ...))) and
;;; (ALIEN (FUNCTION ...)) are acceptable to ALIEN-SAP.  So I didn't feel like coming up
;;; with an exhaustive list of what to expect, for fear of leaving something out.
#+sb-devel
(defun pointerish-alientype-p (x) ; (tree-shaken out anyway)
  (or (and (alien-type-type-p x)
           (let ((type (alien-type-type-alien-type x)))
             (or (alien-pointer-type-p type)
                 (alien-array-type-p type))))
      (and (union-type-p x)
           (every #'pointerish-alientype-p (union-type-types x)))
      (type= x (specifier-type 'alien-value))))

;;; The IR1 transform for ALIEN-SAP tries to un-realize aliens by converting the
;;; composition of sap-alien followed by alien-sap into an identity operation.
;;; But sometimes ALIEN-SAP is just ALIEN-VALUE-SAP (i.e. %INSTANCE-REF)
;;; However I didn't want to further complicate this, so If ALIEN-SAP remains in
;;; the IR, then it's an ALIEN-VALUE (no need to check) and a vop can do the rest.
(deftransform alien-sap ((alien))
  (let ((alien-node (lvar-uses alien)))
    (typecase alien-node
      (combination
       (splice-fun-args alien '%sap-alien 2)
       '(lambda (sap type)
         (declare (ignore type))
         sap))
      (ref
       ;; Go through a variable in the %sap-alien transform below
       (map-all-uses (lambda (use)
                       (when (combination-is use '(%sap-alien))
                         (reoptimize-node use)))
                     alien)
       (give-up-ir1-transform))
      (t
       (give-up-ir1-transform)))))

(deftransform %sap-alien ((sap type) * * :node node)
  "optimize away %SAP-ALIEN"
  (let (alien-saps)
    ;; Optimize multiple alien-saps through a variable
    (cond ((block nil
             (map-refs
              (lambda (dest lvar)
                (declare (ignore lvar))
                (cond ((combination-is dest '(alien-sap))
                       (pushnew dest alien-saps :test #'eq))
                      ((combination-is dest '(eq)))
                      (t
                       (return))))
              (node-lvar node)
              :leaf-set (lambda () (return))
              :multiple-uses (lambda () (return)))
             alien-saps)
           (erase-node-type node (values-specifier-type '(values system-area-pointer &optional)))
           (loop for alien-sap in alien-saps
                 do
                 (transform-call alien-sap
                                 `(lambda (sap)
                                    sap)
                                 'alien-sap
                                 nil))
           'sap)
          (t
           (give-up-ir1-transform
            "forced to do runtime allocation of alien-value structure")))))

(defoptimizer (%sap-alien derive-type) ((sap type))
  (if (constant-lvar-p type)
      (make-alien-type-type (lvar-value type))
      *wild-type*))

;;;; NATURALIZE/DEPORT/EXTRACT/DEPOSIT magic

(flet ((%computed-lambda (compute-lambda type)
         (declare (type function compute-lambda))
         (unless (constant-lvar-p type)
           (give-up-ir1-transform
            "The type is not constant at compile time; can't open code."))
         (handler-case
             (let ((result (funcall compute-lambda (lvar-value type))))
               (/noshow "in %COMPUTED-LAMBDA" (lvar-value type) result)
               result)
           (error (condition)
                  (compiler-error "~A" condition)))))
  (deftransform naturalize ((object type))
    (%computed-lambda #'compute-naturalize-lambda type))
  (deftransform deport ((alien type))
    (%computed-lambda #'compute-deport-lambda type))
  (deftransform deport-alloc ((alien type))
    (%computed-lambda #'compute-deport-alloc-lambda type))
  (deftransform %alien-value ((sap offset type))
    (%computed-lambda #'compute-extract-lambda type))
  (deftransform (setf %alien-value) ((value sap offset type))
    (%computed-lambda #'compute-deposit-lambda type)))

;;;; ALIEN-FUNCALL support

;;; Size-dispatched SETF forms that write exactly SIZE bytes (1..8)
;;; from TEMP, a (unsigned-byte 64), into [result-sap+offset].  Used
;;; for the trailing partial eightbyte of a struct-by-value return.
#-sb-xc-host
(defun %gen-int-slot-store (result-sap offset size temp)
  (ecase size
    (8 `(setf (sb-sys:sap-ref-64 ,result-sap ,offset) ,temp))
    (4 `(setf (sb-sys:sap-ref-32 ,result-sap ,offset)
              (ldb (byte 32 0) ,temp)))
    (2 `(setf (sb-sys:sap-ref-16 ,result-sap ,offset)
              (ldb (byte 16 0) ,temp)))
    (1 `(setf (sb-sys:sap-ref-8 ,result-sap ,offset)
              (ldb (byte 8 0) ,temp)))
    ((3 5 6 7)
     ;; No primitive store matches; fall back to byte-granular.
     `(progn
        ,@(loop for i from 0 below size collect
                `(setf (sb-sys:sap-ref-8 ,result-sap ,(+ offset i))
                       (ldb (byte 8 ,(* i 8)) ,temp)))))))

;;; Generate code to store struct register values to memory.
#-sb-xc-host
(defun generate-struct-store-code (temps register-slots bytes result-sap)
  "Generate SETF forms to store register values to struct memory."
  (let ((offset 0)
        (stores nil)
        (temp-idx 0))
    (dolist (class register-slots)
      (let* ((remaining (- bytes offset))
             (slot-size (case class
                          ((:integer :double) (min 8 remaining))
                          (:single (min 4 remaining)))))
        (ecase class
          (:integer
           (push (%gen-int-slot-store result-sap offset slot-size
                                      (nth temp-idx temps))
                 stores)
           (incf offset 8)
           (incf temp-idx))
          (:double
           (cond
             ((= slot-size 8)
              (push `(setf (sb-sys:sap-ref-double ,result-sap ,offset)
                           ,(nth temp-idx temps))
                    stores))
             ((= slot-size 4)
              (push `(setf (sb-sys:sap-ref-32 ,result-sap ,offset)
                           (sb-kernel:double-float-low-bits
                            ,(nth temp-idx temps)))
                    stores))
             (t
              (error "Unexpected :double slot size ~A at offset ~A ~
                      (struct size ~A)" slot-size offset bytes)))
           (incf offset 8)
           (incf temp-idx))
          ;; :single is ARM64 HFA only - x86-64 classifies all floats as :double
          (:single
           (push `(setf (sb-sys:sap-ref-single ,result-sap ,offset)
                        ,(nth temp-idx temps))
                 stores)
           (incf offset 4)
           (incf temp-idx)))))
    (nreverse stores)))

;;; Build the function expression for %alien-funcall, optimizing to use
;;; the function name directly when possible (for call-out-named VOP).
;;; Returns (values func-expr ignore-function-p)
(defun alien-funcall-func-expr (function alien-type)
  (declare (ignorable function)) ; unused on platforms without call-out-named
  (or (when-vop-existsp (:named call-out-named)
        (when (lvar-matches function :fun-names '(%sap-alien)
                                     :arg-count 2)
          (let ((sap (first (combination-args (lvar-use function)))))
            (when (lvar-matches sap :fun-names '(foreign-symbol-sap)
                                    :arg-count 1)
              (let ((sym (first (combination-args (lvar-use sap)))))
                (when (and (constant-lvar-p sym)
                           (stringp (lvar-value sym)))
                  (return-from alien-funcall-func-expr
                    (values (lvar-value sym) t))))))))
      (values `(deport function ',alien-type) nil)))

;;; Wrap body with pinning and deport-alloc for alien call parameters.
;;; The deport-alloc step converts arguments (e.g., Unicode strings to octet
;;; arrays) and must happen before pinning to ensure we pin the right objects.
(defun wrap-with-deport (body params arg-types)
  (let ((wrapped `(maybe-with-pinned-objects ,params ,arg-types ,body)))
    (loop for param in params
          for arg-type in arg-types
          do (setf wrapped
                   `(let ((,param (deport-alloc ,param ',arg-type)))
                      ,wrapped)))
    wrapped))

;;; Wrap body with FP saving if required by policy.
#+c-stack-is-control-stack
(defun wrap-with-fp-save (body node)
  (if (policy node (= 3 alien-funcall-saves-fp-and-pc))
      `(invoke-with-saved-fp (lambda () ,body))
      body))
#-c-stack-is-control-stack
(defun wrap-with-fp-save (body node)
  (declare (ignore node))
  body)

;;; Generate code for a struct-returning foreign call that writes to BUFFER-VAR.
;;; FUNC-EXPR is the deported function expression.
;;; DEPORTS is a list of deported argument expressions.
;;; BUFFER-VAR is the variable/symbol holding the destination SAP.
;;; For large structs, BUFFER-VAR is passed as hidden first arg to %alien-funcall.
;;; For small structs, register values are stored to BUFFER-VAR after the call.
;;; Returns (values) - caller wraps result as alien if needed.
#-sb-xc-host
(defun generate-struct-return-code (func-expr alien-type return-type deports buffer-var)
  (multiple-value-bind (in-registers-p register-slots bytes)
      (sb-alien::struct-return-info return-type)
    (cond
      ;; Large struct: pass buffer as hidden first arg
      ((not in-registers-p)
       `(progn
          (%alien-funcall ,func-expr ',alien-type ,buffer-var ,@deports)
          (values)))
      ;; Small struct: receive registers, store to buffer
      (t
       (let ((temps (loop repeat (length register-slots) collect (gensym))))
         `(multiple-value-bind ,temps
              (%alien-funcall ,func-expr ',alien-type ,@deports)
            ,@(generate-struct-store-code temps register-slots bytes buffer-var)
            (values)))))))

(deftransform alien-funcall ((function &rest args)
                             ((alien (* t)) &rest t) *)
  (let ((names (make-gensym-list (length args))))
    (/noshow "entering first DEFTRANSFORM ALIEN-FUNCALL" function args)
    `(lambda (function ,@names)
       (alien-funcall (deref function) ,@names))))

(deftransform alien-funcall ((function &rest args) * * :node node)
  (let ((type (lvar-type function)))
    (unless (alien-type-type-p type)
      (give-up-ir1-transform "can't tell function type at compile time"))
    (/noshow "entering second DEFTRANSFORM ALIEN-FUNCALL" function)
    (let ((alien-type (alien-type-type-alien-type type)))
      (unless (alien-fun-type-p alien-type)
        (give-up-ir1-transform))
      (let ((arg-types (alien-fun-type-arg-types alien-type)))
        (unless (= (length args) (length arg-types))
          (abort-ir1-transform
           "wrong number of arguments; expected ~W, got ~W"
           (length arg-types)
           (length args)))
        (collect ((params) (deports))
          (dolist (arg-type arg-types)
            (let ((param (gensym)))
              (params param)
              (deports `(deport ,param ',arg-type))))
          (let ((return-type (alien-fun-type-result-type alien-type)))
            (multiple-value-bind (func-expr ignore-fun)
                (alien-funcall-func-expr function alien-type)
              ;; Check for struct return - handled via unified helper
              #-sb-xc-host
              (multiple-value-bind (in-registers-p register-slots size)
                  (sb-alien::struct-return-info return-type)
                (declare (ignore in-registers-p register-slots))
                (when size
                  (let* ((buf (gensym "BUF"))
                         (body (generate-struct-return-code
                                func-expr alien-type return-type (deports) buf)))
                    (setf body (wrap-with-deport body (params) arg-types))
                    ;; Wrap with allocation and return alien-wrapped buffer
                    (setf body `(let ((,buf (sb-alien::%make-alien ,size)))
                                  ,body
                                  (sb-alien::%sap-alien ,buf ',return-type)))
                    (setf body (wrap-with-fp-save body node))
                    (return-from alien-funcall
                      `(lambda (function ,@(params))
                         ,@(when ignore-fun '((declare (ignore function))))
                         (declare (optimize (let-conversion 3)))
                         ,body)))))
              ;; Non-struct return: standard %alien-funcall
              (let ((body `(%alien-funcall ,func-expr ',alien-type ,@(deports))))
                (setf body (wrap-with-deport body (params) arg-types))
                (cond
                  ((alien-values-type-p return-type)
                   (collect ((temps) (results))
                     (dolist (type (alien-values-type-values return-type))
                       (let ((temp (gensym)))
                         (temps temp)
                         (results `(naturalize ,temp ',type))))
                     (setf body
                           `(multiple-value-bind ,(temps) ,body
                              (values ,@(results))))))
                  (t
                   (setf body `(naturalize ,body ',return-type))))
                (setf body (wrap-with-fp-save body node))
                (/noshow "returning from DEFTRANSFORM ALIEN-FUNCALL" (params) body)
                `(lambda (function ,@(params))
                   ,@(when ignore-fun '((declare (ignore function))))
                   (declare (optimize (let-conversion 3)))
                   ,body)))))))))

;;; alien-funcall-into: call foreign function, write struct result to buffer.
;;; Like alien-funcall but writes to caller-provided buffer instead of heap.
;;; Arguments: (function result-buffer &rest args)
;;;
;;; Only available on x86-64 and ARM64 where struct-by-value ABI is implemented.
#+(and (or x86-64 arm64) (not sb-xc-host))
(deftransform sb-alien::alien-funcall-into ((function result-buffer &rest args)
                                            * * :node node)
  (let ((type (lvar-type function)))
    (unless (alien-type-type-p type)
      (give-up-ir1-transform "can't tell function type at compile time"))
    (let ((alien-type (alien-type-type-alien-type type)))
      (unless (alien-fun-type-p alien-type)
        (give-up-ir1-transform))
      (let* ((arg-types (alien-fun-type-arg-types alien-type))
             (return-type (alien-fun-type-result-type alien-type)))
        (unless (= (length args) (length arg-types))
          (abort-ir1-transform
           "wrong number of arguments; expected ~W, got ~W"
           (length arg-types)
           (length args)))
        (multiple-value-bind (in-registers-p register-slots size)
            (sb-alien::struct-return-info return-type)
          (declare (ignore in-registers-p register-slots))
          (unless size
            (abort-ir1-transform
             "alien-funcall-into requires a struct return type"))
          (collect ((params) (deports))
            (dolist (arg-type arg-types)
              (let ((param (gensym)))
                (params param)
                (deports `(deport ,param ',arg-type))))
            (multiple-value-bind (func-expr ignore-fun)
                (alien-funcall-func-expr function alien-type)
              (let ((body (generate-struct-return-code
                           func-expr alien-type return-type (deports) 'result-buffer)))
                (setf body (wrap-with-deport body (params) arg-types))
                (setf body (wrap-with-fp-save body node))
                `(lambda (function result-buffer ,@(params))
                   ,@(when ignore-fun '((declare (ignore function))))
                   (declare (optimize (let-conversion 3)))
                   ,body)))))))))

(defoptimizer (%alien-funcall derive-type) ((function type &rest args))
  (unless (and (constant-lvar-p type)
               (alien-fun-type-p (lvar-value type)))
    (error "Something is broken."))
  (let* ((result-type (alien-fun-type-result-type (lvar-value type)))
         (spec (compute-alien-rep-type result-type :result)))
    (cond
      ;; For struct-by-value returns, derive the multiple-values type
      ;; based on the register slot classification
      #-sb-xc-host
      ((multiple-value-bind (in-registers-p register-slots)
           (sb-alien::struct-return-info result-type)
         (when in-registers-p
           ;; Return VALUES type for the register values
           (make-values-type
            (mapcar (lambda (class)
                      (case class
                        (:integer (specifier-type '(unsigned-byte 64)))
                        (:double (specifier-type 'double-float))
                        (:single! (specifier-type 'single-float))
                        (t *universal-type*)))
                    register-slots)))))
      (t
       (if (eq spec '*) *wild-type* (values-specifier-type spec))))))

;;; arg-tn-loader bundles struct-by-value argument data: TNs for
;;; register allocator visibility and a function to emit load VOPs.
(defstruct (arg-tn-loader
            (:constructor make-arg-tn-loader (tns fn))
            (:copier nil)
            (:predicate arg-tn-loader-p))
  (tns nil :type list :read-only t)
  (fn nil :type function :read-only t))

(defun extract-arg-tns (entry)
  "Extract TNs from an arg-tns entry."
  (if (arg-tn-loader-p entry)
      (arg-tn-loader-tns entry)
      (remove-if-not #'tn-p (ensure-list entry))))

(defoptimizer (%alien-funcall ltn-annotate)
              ((function type &rest args) node)
  (setf (basic-combination-info node) :funny)
  (setf (node-tail-p node) nil)
  (unless (and (constant-lvar-p function)
               (stringp function))
    (annotate-ordinary-lvar function))
  (dolist (arg args)
    (annotate-ordinary-lvar arg)))

;;; We support both the stdcall and cdecl calling conventions on win32 by
;;; resetting ESP after the foreign function returns. This way it works
;;; correctly whether the party that is supposed to pop arguments from
;;; the stack is the caller (cdecl) or the callee (stdcall).
(defoptimizer (%alien-funcall ir2-convert)
              ((function type &rest args) call block)
  (let ((type (if (constant-lvar-p type)
                  (lvar-value type)
                  (error "Something is broken.")))
        (lvar (node-lvar call))
        ;; KLUDGE: On ARM systems our register pressure is so high
        ;; that if we process register args before stack args we end
        ;; up with all of our non-descriptor regs either
        ;; component-live (NFP) or wired (everything else) and can't
        ;; actually process the stack args.  Processing the arguments
        ;; in reverse order here doesn't change the semantics, but we
        ;; deal with all of the stack arguments before the wired
        ;; register arguments become live.
        (args #-arm args #+arm (reverse args))
        #+c-stack-is-control-stack
        (stack-pointer (make-stack-pointer-tn)))
    (multiple-value-bind (nsp stack-frame-size arg-tns result-tns
                          #+(or arm64 x86-64) large-struct-return-p)
        (make-call-out-tns type)
      ;; For large struct returns, the first arg is the sret pointer
      ;; Extract it from args so it's not processed as a regular arg
      ;; Emit the VOP to set x8 (ARM64) or RDI (x86-64) just before
      ;; the call. Watch out for the kludge above, if anyone comes
      ;; along and writes sret for arm32.
      (let ((sret-tn #+(or arm64 x86-64) (when large-struct-return-p
                                           (lvar-tn call block (pop args)))
                     #-(or arm64 x86-64) nil))
        (declare (ignorable sret-tn))
      #+x86
      (vop set-fpu-word-for-c call block)
      ;; Save the stack pointer, it will get aligned and subtracting
      ;; the size will not restore the original value, and some
      ;; things, like SB-C::CALL-VARIABLE, use the stack pointer to
      ;; calculate the number of saved values.
      ;; See alien.impure.lisp/:stack-misalignment
      #+c-stack-is-control-stack
      (vop current-stack-pointer call block stack-pointer)
      (vop alloc-number-stack-space call block stack-frame-size nsp)
      ;; KLUDGE: This is where the second half of the ARM
      ;; register-pressure change lives (see above).
      (dolist (tn #-arm arg-tns #+arm (reverse arg-tns))
        (cond ((arg-tn-loader-p tn)
               ;; Struct-by-value: call loader, TNs exposed via arg-tn-loader-tns
               (loop for tn in (arg-tn-loader-tns tn)
                     do
                        (when (eq (sb-kind (sc-sb (tn-sc tn))) :unbounded) ;; stacks are unbounded
                          ;; Avoid allocating this TN on the caller's stack
                          (setf (tn-kind tn) :arg-pass)))
               (funcall (arg-tn-loader-fn tn) (pop args) call block nsp))
              ((functionp tn)
               (funcall tn (pop args) call block nsp))
              (t
               ;; On PPC, TN might be a list. This is used to indicate
               ;; something special needs to happen. See below.
               ;;
               ;; FIXME: We should implement something better than this.
               (let* ((first-tn (if (listp tn) (car tn) tn))
                      (arg (pop args))
                      (sc (tn-sc first-tn))
                      (scn (sc-number sc))
                      (move-arg-vops (svref (sc-move-arg-vops sc) scn)))
                 (aver arg)
                 (unless (= (length move-arg-vops) 1)
                   (error "no unique move-arg-vop for moves in SC ~S" (sc-name sc)))

                 (cond
                   #+(or arm-softfp riscv loongarch64)
                   ((and (listp tn)
                         (symbolp (car (last tn))))
                    (emit-template call block
                                   (template-or-lose (car (last tn)))
                                   (reference-tn (lvar-tn call block arg) nil)
                                   (reference-tn-list (butlast tn) t)))
                   (t
                    (when (eq (sb-kind (sc-sb sc)) :unbounded) ;; stacks are unbounded
                      ;; Avoid allocating this TN on the caller's stack
                      (setf (tn-kind first-tn) :arg-pass))
                    #+(or x86 x86-64)
                    (emit-move-arg-template call
                                            block
                                            (first move-arg-vops)
                                            (lvar-tn call block arg)
                                            nsp
                                            first-tn)
                    #-(or x86 x86-64)
                    (let* ((primitive-type (tn-primitive-type first-tn))
                           ;; If the destination is a stack TN make sure
                           ;; the temporary TN is a register.
                           (scn (if (sc-number-stack-p sc)
                                    (car (primitive-type-scs primitive-type))
                                    scn))
                           (temp-tn (make-representation-tn primitive-type scn)))
                      (emit-move call block (lvar-tn call block arg) temp-tn)
                      (emit-move-arg-template call
                                              block
                                              (first move-arg-vops)
                                              temp-tn
                                              nsp
                                              first-tn))))
                 #+(and ppc darwin)
                 (when (listp tn)
                   ;; This means that we have a float arg that we need to
                   ;; also copy to some int regs. The list contains the TN
                   ;; for the float as well as the TNs to use for the int
                   ;; arg.
                   (destructuring-bind (float-tn i1-tn &optional i2-tn)
                       tn
                     (if i2-tn
                         (vop sb-vm::move-double-to-int-arg call block
                              float-tn i1-tn i2-tn)
                         (vop sb-vm::move-single-to-int-arg call block
                              float-tn i1-tn))))))))
      (aver (null args))
      (let* ((result-tns (ensure-list result-tns))
             (arg-operands
              (reference-tn-list (mapcan #'extract-arg-tns arg-tns) nil))
             (result-operands
              (reference-tn-list (remove-if-not #'tn-p result-tns) t)))
        ;; For large struct returns, set the sret pointer register
        ;; (x8 on ARM64, RDI on x86-64) right before making the call
        (when sret-tn
          (when-vop-existsp (:named sb-vm::set-struct-return-pointer)
            (vop sb-vm::set-struct-return-pointer call block sret-tn)))
        (cond #+#.(cl:if (sb-c::vop-existsp :named sb-vm::call-out-named) '(and) '(or))
              ((and (constant-lvar-p function) (stringp (lvar-value function)))
               (vop* call-out-named call block (arg-operands) (result-operands)
                     (lvar-value function)
                     (sb-alien::alien-fun-type-varargs type)))
              (t
               (vop* call-out call block
                     ((lvar-tn call block function) arg-operands)
                     (result-operands))))
        #-c-stack-is-control-stack
        (vop dealloc-number-stack-space call block stack-frame-size)
        #+c-stack-is-control-stack
        (vop reset-stack-pointer call block stack-pointer)
        #+x86
        (vop set-fpu-word-for-lisp call block)
        (cond
          #+arm-softfp
          ((and lvar
                (symbolp (car (last result-tns))))
           (emit-template call block
                          (template-or-lose (car (last result-tns)))
                          (reference-tn-list (butlast result-tns 2) nil)
                          (reference-tn (car (last result-tns 2)) t))
           (move-lvar-result call block (list (car (last result-tns 2))) lvar))
          (t
           (move-lvar-result call block result-tns lvar))))))))

(deftransform sb-alien::c-string-external-format ((type)
                                                  ((constant-arg sb-alien::alien-c-string-type)))
  (let ((format (sb-alien::alien-c-string-type-external-format
                 (lvar-value type))))
    (if (eq format :default)
        `(sb-alien::default-c-string-external-format)
        `',format)))
;;; This transform which recognizes :UTF8 as an easy case if the argument is simple-base-string
;;; does not have to additionally recognize :ASCII, which is done elsewhere - either deport-alloc-gen
;;; or deport-alloc (I'm not sure which). An ETYPECASE is inserted over the possible choices of
;;; Lisp arg type, one of which is SIMPLE-BASE-STRING, which undergoes no conversion
;;; (assisted by SB-ALIEN::C-STRING-NEEDS-CONVERSION-P given :ASCII as the format).
;;; However I noticed a premature optimization which either accidentally or intentionally
;;; fails on non-simple strings. Consider the function F:
;;; (defun f (s)
;;;   (alien-funcall (extern-alien "getenv"
;;;                   (function system-area-pointer (c-string :external-format :ascii)))
;;;                  (the string s)))
;;; * (f (make-array 4 :element-type 'base-char :displaced-to (coerce "HOME" 'simple-base-string)))
;;; which gets:
;;;    debugger invoked on a CASE-FAILURE @1201809010 in thread
;;;    #<THREAD tid=663886 "main thread" RUNNING {1201758003}>:
;;;      "HOME" fell through ETYPECASE expression.
;;;      Wanted one of (NULL (ALIEN (* CHAR)) SIMPLE-BASE-STRING SIMPLE-STRING).
;;;
;;; That seems slightly amiss, but I am unwilling to deoptimize the above example by adding
;;; more branching to the call-out, given absence of any complaints about it in forever.
#+sb-unicode
(deftransform sb-alien::string-to-c-string ((string type)
                                            (simple-base-string (constant-arg (eql :utf8))))
  'string)
