| 1 | ;;;-*- Mode: Lisp; Package: CCL -*-
|
|---|
| 2 | ;;;
|
|---|
| 3 | ;;; Copyright (C) 2005 Clozure Associates
|
|---|
| 4 | ;;; This file is part of OpenMCL.
|
|---|
| 5 | ;;;
|
|---|
| 6 | ;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public
|
|---|
| 7 | ;;; License , known as the LLGPL and distributed with OpenMCL as the
|
|---|
| 8 | ;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL,
|
|---|
| 9 | ;;; which is distributed with OpenMCL as the file "LGPL". Where these
|
|---|
| 10 | ;;; conflict, the preamble takes precedence.
|
|---|
| 11 | ;;;
|
|---|
| 12 | ;;; OpenMCL is referenced in the preamble as the "LIBRARY."
|
|---|
| 13 | ;;;
|
|---|
| 14 | ;;; The LLGPL is also available online at
|
|---|
| 15 | ;;; http://opensource.franz.com/preamble.html
|
|---|
| 16 |
|
|---|
| 17 | (in-package "CCL")
|
|---|
| 18 | (eval-when (:compile-toplevel :load-toplevel :execute)
|
|---|
| 19 | (require "BACKEND"))
|
|---|
| 20 |
|
|---|
| 21 | (eval-when (:compile-toplevel :execute)
|
|---|
| 22 | (require "NXENV")
|
|---|
| 23 | (require "X8664ENV"))
|
|---|
| 24 |
|
|---|
| 25 |
|
|---|
| 26 | (defvar *x8664-vinsn-templates* (make-hash-table :test #'eq))
|
|---|
| 27 |
|
|---|
| 28 |
|
|---|
| 29 |
|
|---|
| 30 | (defvar *known-x8664-backends* ())
|
|---|
| 31 |
|
|---|
| 32 |
|
|---|
| 33 | #+(or linuxx86-target (not x86-target))
|
|---|
| 34 | (defvar *linuxx8664-backend*
|
|---|
| 35 | (make-backend :lookup-opcode 'lookup-x86-opcode
|
|---|
| 36 | :lookup-macro #'false
|
|---|
| 37 | :lap-opcodes x86::*x8664-opcode-templates*
|
|---|
| 38 | :define-vinsn 'define-x86-vinsn
|
|---|
| 39 | :platform-syscall-mask (logior platform-os-linux platform-cpu-x86 platform-word-size-64)
|
|---|
| 40 | :p2-dispatch *x862-specials*
|
|---|
| 41 | :p2-vinsn-templates *x8664-vinsn-templates*
|
|---|
| 42 | :p2-template-hash-name '*x8664-vinsn-templates*
|
|---|
| 43 | :p2-compile 'x862-compile
|
|---|
| 44 | :target-specific-features
|
|---|
| 45 | '(:x8664 :x86-target :linux-target :linuxx86-target :x8664-target
|
|---|
| 46 | :linuxx8664-target
|
|---|
| 47 | :little-endian-target
|
|---|
| 48 | :64-bit-target)
|
|---|
| 49 | :target-fasl-pathname (make-pathname :type "lx64fsl")
|
|---|
| 50 | :target-platform (logior platform-cpu-x86
|
|---|
| 51 | platform-os-linux
|
|---|
| 52 | platform-word-size-64)
|
|---|
| 53 | :target-os :linuxx86
|
|---|
| 54 | :name :linuxx8664
|
|---|
| 55 | :target-arch-name :x8664
|
|---|
| 56 | :target-foreign-type-data nil
|
|---|
| 57 |
|
|---|
| 58 |
|
|---|
| 59 | :target-arch x8664::*x8664-target-arch*
|
|---|
| 60 | :lisp-context-register x8664::gs
|
|---|
| 61 | ))
|
|---|
| 62 |
|
|---|
| 63 |
|
|---|
| 64 | #+darwinx86-target
|
|---|
| 65 | (defvar *darwinx8664-backend*
|
|---|
| 66 | (make-backend :lookup-opcode 'lookup-x86-opcode
|
|---|
| 67 | :lookup-macro #'false
|
|---|
| 68 | :lap-opcodes x86::*x8664-opcode-templates*
|
|---|
| 69 | :define-vinsn 'define-x86-vinsn
|
|---|
| 70 | :p2-dispatch *x862-specials*
|
|---|
| 71 | :p2-vinsn-templates *x8664-vinsn-templates*
|
|---|
| 72 | :p2-template-hash-name '*x8664-vinsn-templates*
|
|---|
| 73 | :p2-compile 'x862-compile
|
|---|
| 74 | :platform-syscall-mask (logior platform-os-darwin platform-cpu-x86 platform-word-size-64)
|
|---|
| 75 | :target-specific-features
|
|---|
| 76 | '(:x8664 :x86-target :darwin-target :darwinx86-target :x8664-target
|
|---|
| 77 | :darwinx8664-target
|
|---|
| 78 | :little-endian-target
|
|---|
| 79 | :64-bit-target)
|
|---|
| 80 | :target-fasl-pathname (make-pathname :type "dx64fsl")
|
|---|
| 81 | :target-platform (logior platform-cpu-x86
|
|---|
| 82 | platform-os-darwin
|
|---|
| 83 | platform-word-size-64)
|
|---|
| 84 | :target-os :darwinx86
|
|---|
| 85 | :name :darwinx8664
|
|---|
| 86 | :target-arch-name :x8664
|
|---|
| 87 | :target-foreign-type-data nil
|
|---|
| 88 | :target-arch x8664::*x8664-target-arch*
|
|---|
| 89 | ;; Overload %gs until Apple straightens things out.
|
|---|
| 90 | :lisp-context-register x8664::gs
|
|---|
| 91 | ))
|
|---|
| 92 |
|
|---|
| 93 | #+freebsdx86-target
|
|---|
| 94 | (defvar *freebsdx8664-backend*
|
|---|
| 95 | (make-backend :lookup-opcode 'lookup-x86-opcode
|
|---|
| 96 | :lookup-macro #'false
|
|---|
| 97 | :lap-opcodes x86::*x8664-opcode-templates*
|
|---|
| 98 | :define-vinsn 'define-x86-vinsn
|
|---|
| 99 | :p2-dispatch *x862-specials*
|
|---|
| 100 | :p2-vinsn-templates *x8664-vinsn-templates*
|
|---|
| 101 | :p2-template-hash-name '*x8664-vinsn-templates*
|
|---|
| 102 | :p2-compile 'x862-compile
|
|---|
| 103 | :target-specific-features
|
|---|
| 104 | '(:x8664 :x86-target :freebsd-target :freebsdx86-target :x8664-target
|
|---|
| 105 | :freebsdx8664-target
|
|---|
| 106 | :little-endian-target
|
|---|
| 107 | :64-bit-target)
|
|---|
| 108 | :target-fasl-pathname (make-pathname :type "fx64fsl")
|
|---|
| 109 | :target-platform (logior platform-cpu-x86
|
|---|
| 110 | platform-os-freebsd
|
|---|
| 111 | platform-word-size-64)
|
|---|
| 112 | :target-os :freebsdx86
|
|---|
| 113 | :name :freebsdx8664
|
|---|
| 114 | :target-arch-name :x8664
|
|---|
| 115 | :target-foreign-type-data nil
|
|---|
| 116 | :target-arch x8664::*x8664-target-arch*
|
|---|
| 117 | :platform-syscall-mask (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64)
|
|---|
| 118 | :lisp-context-register x8664::gs
|
|---|
| 119 | ))
|
|---|
| 120 |
|
|---|
| 121 | #+(or linuxx86-target (not x86-target))
|
|---|
| 122 | (pushnew *linuxx8664-backend* *known-x8664-backends* :key #'backend-name)
|
|---|
| 123 |
|
|---|
| 124 |
|
|---|
| 125 | #+darwinx86-target
|
|---|
| 126 | (pushnew *darwinx8664-backend* *known-x8664-backends* :key #'backend-name)
|
|---|
| 127 |
|
|---|
| 128 | #+freebsdx86-target
|
|---|
| 129 | (pushnew *freebsdx8664-backend* *known-x8664-backends* :key #'backend-name)
|
|---|
| 130 |
|
|---|
| 131 | (defvar *x8664-backend* (car *known-x8664-backends*))
|
|---|
| 132 |
|
|---|
| 133 | (defun fixup-x8664-backend ()
|
|---|
| 134 | (dolist (b *known-x8664-backends*)
|
|---|
| 135 | (setf #| (backend-lap-opcodes b) x86::*x86-opcodes* |#
|
|---|
| 136 | (backend-p2-dispatch b) *x862-specials*
|
|---|
| 137 | (backend-p2-vinsn-templates b) *x8664-vinsn-templates*)
|
|---|
| 138 | (or (backend-lap-macros b) (setf (backend-lap-macros b)
|
|---|
| 139 | (make-hash-table :test #'equalp)))))
|
|---|
| 140 |
|
|---|
| 141 |
|
|---|
| 142 |
|
|---|
| 143 | (fixup-x8664-backend)
|
|---|
| 144 |
|
|---|
| 145 | #+x8664-target
|
|---|
| 146 | (setq *host-backend* *x8664-backend* *target-backend* *x8664-backend*)
|
|---|
| 147 |
|
|---|
| 148 | (defun setup-x8664-ftd (backend)
|
|---|
| 149 | (or (backend-target-foreign-type-data backend)
|
|---|
| 150 | (let* ((name (backend-name backend))
|
|---|
| 151 | (ftd
|
|---|
| 152 | (case name
|
|---|
| 153 | (:linuxx8664
|
|---|
| 154 | (make-ftd :interface-db-directory
|
|---|
| 155 | (if (eq backend *host-backend*)
|
|---|
| 156 | "ccl:x86-headers64;"
|
|---|
| 157 | "ccl:cross-x86-headers64;")
|
|---|
| 158 | :interface-package-name "X86-LINUX64"
|
|---|
| 159 | :attributes '(:bits-per-word 64
|
|---|
| 160 | :struct-by-value t)
|
|---|
| 161 | :ff-call-expand-function
|
|---|
| 162 | (intern "EXPAND-FF-CALL" "X86-LINUX64")
|
|---|
| 163 | :ff-call-struct-return-by-implicit-arg-function
|
|---|
| 164 | (intern "RECORD-TYPE-RETURNS-STRUCTURE-AS-FIRST-ARG"
|
|---|
| 165 | "X86-LINUX64")
|
|---|
| 166 | :callback-bindings-function
|
|---|
| 167 | (intern "GENERATE-CALLBACK-BINDINGS" "X86-LINUX64")
|
|---|
| 168 | :callback-return-value-function
|
|---|
| 169 | (intern "GENERATE-CALLBACK-RETURN-VALUE" "X86-LINUX64")))
|
|---|
| 170 | (:darwinx8664
|
|---|
| 171 | (make-ftd :interface-db-directory
|
|---|
| 172 | (if (eq backend *host-backend*)
|
|---|
| 173 | "ccl:darwin-x86-headers64;"
|
|---|
| 174 | "ccl:cross-darwin-x86-headers64;")
|
|---|
| 175 | :interface-package-name "X86-DARWIN64"
|
|---|
| 176 | :attributes '(:bits-per-word 64
|
|---|
| 177 | :signed-char t
|
|---|
| 178 | :struct-by-value t
|
|---|
| 179 | :prepend-underscore t)
|
|---|
| 180 | :ff-call-expand-function
|
|---|
| 181 | (intern "EXPAND-FF-CALL" "X86-DARWIN64")
|
|---|
| 182 | :ff-call-struct-return-by-implicit-arg-function
|
|---|
| 183 | (intern "RECORD-TYPE-RETURNS-STRUCTURE-AS-FIRST-ARG"
|
|---|
| 184 | "X86-DARWIN64")
|
|---|
| 185 | :callback-bindings-function
|
|---|
| 186 | (intern "GENERATE-CALLBACK-BINDINGS" "X86-DARWIN64")
|
|---|
| 187 | :callback-return-value-function
|
|---|
| 188 | (intern "GENERATE-CALLBACK-RETURN-VALUE" "X86-DARWIN64")))
|
|---|
| 189 | (:freebsdx8664
|
|---|
| 190 | (make-ftd :interface-db-directory
|
|---|
| 191 | (if (eq backend *host-backend*)
|
|---|
| 192 | "ccl:freebsd-headers64;"
|
|---|
| 193 | "ccl:cross-freebsd-headers64;")
|
|---|
| 194 | :interface-package-name "X86-FREEBSD64"
|
|---|
| 195 | :attributes '(:bits-per-word 64
|
|---|
| 196 | :struct-by-value t)
|
|---|
| 197 | :ff-call-expand-function
|
|---|
| 198 | (intern "EXPAND-FF-CALL" "X86-FREEBSD64")
|
|---|
| 199 | :ff-call-struct-return-by-implicit-arg-function
|
|---|
| 200 | (intern "RECORD-TYPE-RETURNS-STRUCTURE-AS-FIRST-ARG"
|
|---|
| 201 | "X86-FREEBSD64")
|
|---|
| 202 | :callback-bindings-function
|
|---|
| 203 | (intern "GENERATE-CALLBACK-BINDINGS" "X86-FREEBSD64")
|
|---|
| 204 | :callback-return-value-function
|
|---|
| 205 | (intern "GENERATE-CALLBACK-RETURN-VALUE" "X86-FREEBSD64"))))))
|
|---|
| 206 | (install-standard-foreign-types ftd)
|
|---|
| 207 | (use-interface-dir :libc ftd)
|
|---|
| 208 | (setf (backend-target-foreign-type-data backend) ftd))))
|
|---|
| 209 |
|
|---|
| 210 | #-x8664-target
|
|---|
| 211 | (setup-x8664-ftd *x8664-backend*)
|
|---|
| 212 |
|
|---|
| 213 | (pushnew *x8664-backend* *known-backends* :key #'backend-name)
|
|---|
| 214 |
|
|---|
| 215 | ;;; FFI stuff. Seems to be shared by Darwin/Linux/FreeBSD.
|
|---|
| 216 |
|
|---|
| 217 | ;;; A returned structure is passed as an invisible first argument if
|
|---|
| 218 | ;;; it's more than 2 doublewords long or if it contains unaligned fields.
|
|---|
| 219 | ;;; Not clear how the latter case can happen, so this just checks for
|
|---|
| 220 | ;;; the first.
|
|---|
| 221 | (defun x8664::record-type-returns-structure-as-first-arg (rtype)
|
|---|
| 222 | (when (and rtype
|
|---|
| 223 | (not (typep rtype 'unsigned-byte))
|
|---|
| 224 | (not (member rtype *foreign-representation-type-keywords*
|
|---|
| 225 | :test #'eq)))
|
|---|
| 226 | (let* ((ftype (if (typep rtype 'foreign-type)
|
|---|
| 227 | rtype
|
|---|
| 228 | (parse-foreign-type rtype))))
|
|---|
| 229 | (> (ensure-foreign-type-bits ftype) 128))))
|
|---|
| 230 |
|
|---|
| 231 | ;;; On x8664, structures can be passed by value:
|
|---|
| 232 | ;;; a) in memory, if they're more than 128 bits in size or if there aren't
|
|---|
| 233 | ;;; enough of the right kind of register to pass them entirely in registers.
|
|---|
| 234 | ;;; b) as a series of 64-bit chunks, passed in GPRs if any component of the
|
|---|
| 235 | ;;; chunk is a non FLOAT or in FPRs otherwise.
|
|---|
| 236 | ;;; Note that this means that a chunk consisting of two SINGLE-FLOATs would
|
|---|
| 237 | ;;; be passed in the low 64 bit of an SSE (xmm) register.
|
|---|
| 238 |
|
|---|
| 239 | (defun x8664::field-is-of-class-integer (field)
|
|---|
| 240 | ;; Return true if field is of "class" integer or if it's a record
|
|---|
| 241 | ;; type of class integer. (See the System V AMD64 ABI document for
|
|---|
| 242 | ;; a convoluted definition of field "classes".)
|
|---|
| 243 | (let* ((ftype (foreign-record-field-type field)))
|
|---|
| 244 | (typecase ftype
|
|---|
| 245 | ((or foreign-integer-type foreign-pointer-type) t)
|
|---|
| 246 | (foreign-record-type (dolist (f (foreign-record-type-fields ftype))
|
|---|
| 247 | (when (x8664::field-is-of-class-integer f)
|
|---|
| 248 | (return t))))
|
|---|
| 249 | (otherwise nil))))
|
|---|
| 250 |
|
|---|
| 251 | (defun x8664::classify-8byte (field-list bit-limit)
|
|---|
| 252 | ;; CDR down the fields in FIELD-LIST until we find a field of class integer,
|
|---|
| 253 | ;; hit the end of the list, or find a field whose offset is >= BIT-LIMIT.
|
|---|
| 254 | ;; In the first case, return :INTEGER. In other cases, return :FLOAT.
|
|---|
| 255 | (dolist (field field-list :float)
|
|---|
| 256 | (if (<= bit-limit (foreign-record-field-offset field))
|
|---|
| 257 | (return :float)
|
|---|
| 258 | (if (x8664::field-is-of-class-integer field)
|
|---|
| 259 | (return :integer)))))
|
|---|
| 260 |
|
|---|
| 261 | ;;; Return a first value :memory, :integer, or::float and a second
|
|---|
| 262 | ;;; value of NIL, :integer, or :float according to how the structure
|
|---|
| 263 | ;;; RTYPE should ideally be passed or returned. Note that the caller
|
|---|
| 264 | ;;; may decide to turn this to :memory if there aren't enough
|
|---|
| 265 | ;;; available registers of the right class when passing an instance of
|
|---|
| 266 | ;;; this structure type.
|
|---|
| 267 | (defun x8664::classify-record-type (rtype)
|
|---|
| 268 | (let* ((nbits (ensure-foreign-type-bits rtype))
|
|---|
| 269 | (fields (foreign-record-type-fields rtype)))
|
|---|
| 270 | (cond ((> nbits 128) (values :memory nil))
|
|---|
| 271 | ((<= nbits 64) (values (x8664::classify-8byte fields 64) nil))
|
|---|
| 272 | (t (values (x8664::classify-8byte fields 64)
|
|---|
| 273 | (do* ()
|
|---|
| 274 | ((>= (foreign-record-field-offset (car fields)) 64)
|
|---|
| 275 | (x8664::classify-8byte fields 128))
|
|---|
| 276 | (setq fields (cdr fields))))))))
|
|---|
| 277 |
|
|---|
| 278 | (defun x8664::struct-from-regbuf-values (r rtype regbuf)
|
|---|
| 279 | (multiple-value-bind (first second)
|
|---|
| 280 | (x8664::classify-record-type rtype)
|
|---|
| 281 | (let* ((gpr-offset 0)
|
|---|
| 282 | (fpr-offset 16))
|
|---|
| 283 | ;; Do this 32 bits at a time, to avoid consing.
|
|---|
| 284 | (collect ((forms))
|
|---|
| 285 | (case first
|
|---|
| 286 | (:integer (forms `(setf (%get-unsigned-long ,r 0)
|
|---|
| 287 | (%get-unsigned-long ,regbuf 0)))
|
|---|
| 288 | (forms `(setf (%get-unsigned-long ,r 4)
|
|---|
| 289 | (%get-unsigned-long ,regbuf 4)))
|
|---|
| 290 | (setq gpr-offset 8))
|
|---|
| 291 | (:float (forms `(setf (%get-unsigned-long ,r 0)
|
|---|
| 292 | (%get-unsigned-long ,regbuf 16)))
|
|---|
| 293 | (forms `(setf (%get-unsigned-long ,r 4)
|
|---|
| 294 | (%get-unsigned-long ,regbuf 20)))
|
|---|
| 295 | (setf fpr-offset 24)))
|
|---|
| 296 | (case second
|
|---|
| 297 | (:integer (forms `(setf (%get-unsigned-long ,r 8)
|
|---|
| 298 | (%get-unsigned-long ,regbuf ,gpr-offset)))
|
|---|
| 299 | (forms `(setf (%get-unsigned-long ,r 12)
|
|---|
| 300 | (%get-unsigned-long ,regbuf ,(+ gpr-offset 4)))))
|
|---|
| 301 | (:float (forms `(setf (%get-unsigned-long ,r 8)
|
|---|
| 302 | (%get-unsigned-long ,regbuf ,fpr-offset)))
|
|---|
| 303 | (forms `(setf (%get-unsigned-long ,r 12)
|
|---|
| 304 | (%get-unsigned-long ,regbuf ,(+ fpr-offset 4))))))
|
|---|
| 305 | `(progn ,@(forms))))))
|
|---|
| 306 |
|
|---|
| 307 | (defun x8664::expand-ff-call (callform args &key (arg-coerce #'null-coerce-foreign-arg) (result-coerce #'null-coerce-foreign-result))
|
|---|
| 308 | (let* ((result-type-spec (or (car (last args)) :void))
|
|---|
| 309 | (regbuf nil)
|
|---|
| 310 | (result-temp nil)
|
|---|
| 311 | (result-form nil)
|
|---|
| 312 | (struct-result-type nil)
|
|---|
| 313 | (structure-arg-temp nil))
|
|---|
| 314 | (multiple-value-bind (result-type error)
|
|---|
| 315 | (ignore-errors (parse-foreign-type result-type-spec))
|
|---|
| 316 | (if error
|
|---|
| 317 | (setq result-type-spec :void result-type *void-foreign-type*)
|
|---|
| 318 | (setq args (butlast args)))
|
|---|
| 319 | (collect ((argforms))
|
|---|
| 320 | (when (eq (car args) :monitor-exception-ports)
|
|---|
| 321 | (argforms (pop args)))
|
|---|
| 322 | (when (typep result-type 'foreign-record-type)
|
|---|
| 323 | (setq result-form (pop args)
|
|---|
| 324 | struct-result-type result-type
|
|---|
| 325 | result-type *void-foreign-type*
|
|---|
| 326 | result-type-spec :void)
|
|---|
| 327 | (if (x8664::record-type-returns-structure-as-first-arg struct-result-type)
|
|---|
| 328 | (progn
|
|---|
| 329 | (argforms :address)
|
|---|
| 330 | (argforms result-form))
|
|---|
| 331 | (progn
|
|---|
| 332 | (setq regbuf (gensym)
|
|---|
| 333 | result-temp (gensym))
|
|---|
| 334 | (argforms :registers)
|
|---|
| 335 | (argforms regbuf))))
|
|---|
| 336 | (let* ((valform nil))
|
|---|
| 337 | (unless (evenp (length args))
|
|---|
| 338 | (error "~s should be an even-length list of alternating foreign types and values" args))
|
|---|
| 339 | (do* ((args args (cddr args))
|
|---|
| 340 | (remaining-gprs 6)
|
|---|
| 341 | (remaining-fprs 8))
|
|---|
| 342 | ((null args))
|
|---|
| 343 | (let* ((arg-type-spec (car args))
|
|---|
| 344 | (arg-value-form (cadr args)))
|
|---|
| 345 | (if (or (member arg-type-spec *foreign-representation-type-keywords*
|
|---|
| 346 | :test #'eq)
|
|---|
| 347 | (typep arg-type-spec 'unsigned-byte))
|
|---|
| 348 | (progn
|
|---|
| 349 | (if (or (eq arg-type-spec :double-float)
|
|---|
| 350 | (eq arg-type-spec :single-float))
|
|---|
| 351 | (decf remaining-fprs)
|
|---|
| 352 | (unless (typep arg-type-spec 'unsigned-byte)
|
|---|
| 353 | (decf remaining-gprs)))
|
|---|
| 354 | (argforms arg-type-spec)
|
|---|
| 355 | (argforms arg-value-form))
|
|---|
| 356 | (let* ((ftype (parse-foreign-type arg-type-spec)))
|
|---|
| 357 | (if (typep ftype 'foreign-record-type)
|
|---|
| 358 | (multiple-value-bind (first8 second8)
|
|---|
| 359 | (x8664::classify-record-type ftype)
|
|---|
| 360 | (let* ((gprs remaining-gprs)
|
|---|
| 361 | (fprs remaining-fprs))
|
|---|
| 362 | (case first8
|
|---|
| 363 | (:integer (if (< (decf gprs) 0) (setq first8 :memory)))
|
|---|
| 364 | (:float (if (< (decf fprs) 0) (setq first8 :memory))))
|
|---|
| 365 | (case second8
|
|---|
| 366 | (:integer (if (< (decf gprs) 0) (setq first8 :memory)))
|
|---|
| 367 | (:float (if (< (decf fprs) 0) (setq first8 :memory)))))
|
|---|
| 368 | (if (eq first8 :memory)
|
|---|
| 369 | (progn
|
|---|
| 370 | (argforms (ceiling (foreign-record-type-bits ftype) 64))
|
|---|
| 371 | (argforms arg-value-form))
|
|---|
| 372 | (progn
|
|---|
| 373 | (if second8
|
|---|
| 374 | (progn
|
|---|
| 375 | (unless structure-arg-temp
|
|---|
| 376 | (setq structure-arg-temp (gensym)))
|
|---|
| 377 | (setq valform `(%setf-macptr ,structure-arg-temp ,arg-value-form)))
|
|---|
| 378 | (setq valform arg-value-form))
|
|---|
| 379 | (if (eq first8 :float)
|
|---|
| 380 | (progn
|
|---|
| 381 | (decf remaining-fprs)
|
|---|
| 382 | (argforms :double-float)
|
|---|
| 383 | (argforms `(%get-double-float ,valform 0)))
|
|---|
| 384 | (progn
|
|---|
| 385 | (decf remaining-gprs)
|
|---|
| 386 | (argforms :unsigned-doubleword)
|
|---|
| 387 | (argforms `(%%get-unsigned-longlong ,valform 0))))
|
|---|
| 388 | (when second8
|
|---|
| 389 | (setq valform structure-arg-temp)
|
|---|
| 390 | (if (eq second8 :float)
|
|---|
| 391 | (progn
|
|---|
| 392 | (decf remaining-fprs)
|
|---|
| 393 | (argforms :double-float)
|
|---|
| 394 | (argforms `(%get-double-float ,valform 8)))
|
|---|
| 395 | (progn
|
|---|
| 396 | (decf remaining-gprs)
|
|---|
| 397 | (argforms :unsigned-doubleword)
|
|---|
| 398 | (argforms `(%%get-unsigned-longlong ,valform 8))))))))
|
|---|
| 399 | (let* ((rtype (foreign-type-to-representation-type ftype)))
|
|---|
| 400 | (if (or (eq rtype :singlefloat) (eq rtype :double-float))
|
|---|
| 401 | (decf remaining-fprs)
|
|---|
| 402 | (decf remaining-gprs))
|
|---|
| 403 | (argforms rtype)
|
|---|
| 404 | (argforms (funcall arg-coerce arg-type-spec arg-value-form))))))))
|
|---|
| 405 | (argforms (foreign-type-to-representation-type result-type))
|
|---|
| 406 | (let* ((call (funcall result-coerce result-type-spec `(,@callform ,@(argforms)))))
|
|---|
| 407 | (when structure-arg-temp
|
|---|
| 408 | (setq call `(let* ((,structure-arg-temp (%null-ptr)))
|
|---|
| 409 | (declare (dynamic-extent ,structure-arg-temp)
|
|---|
| 410 | (type macptr ,structure-arg-temp))
|
|---|
| 411 | ,call)))
|
|---|
| 412 | (if regbuf
|
|---|
| 413 | `(let* ((,result-temp (%null-ptr)))
|
|---|
| 414 | (declare (dynamic-extent ,result-temp)
|
|---|
| 415 | (type macptr ,result-temp))
|
|---|
| 416 | (%setf-macptr ,result-temp ,result-form)
|
|---|
| 417 | (%stack-block ((,regbuf (+ (* 2 8) (* 2 8))))
|
|---|
| 418 | ,call
|
|---|
| 419 | ,(x8664::struct-from-regbuf-values result-temp struct-result-type regbuf)))
|
|---|
| 420 | call)))))))
|
|---|
| 421 |
|
|---|
| 422 |
|
|---|
| 423 | ;;; Return 7 values:
|
|---|
| 424 | ;;; A list of RLET bindings
|
|---|
| 425 | ;;; A list of LET* bindings
|
|---|
| 426 | ;;; A list of DYNAMIC-EXTENT declarations for the LET* bindings
|
|---|
| 427 | ;;; A list of initializaton forms for (some) structure args
|
|---|
| 428 | ;;; A FOREIGN-TYPE representing the "actual" return type.
|
|---|
| 429 | ;;; A form which can be used to initialize FP-ARGS-PTR, relative
|
|---|
| 430 | ;;; to STACK-PTR. (This is unused on linuxppc32.)
|
|---|
| 431 | ;;; The byte offset of the foreign return address, relative to STACK-PTR
|
|---|
| 432 |
|
|---|
| 433 | (defun x8664::generate-callback-bindings (stack-ptr fp-args-ptr argvars argspecs result-spec struct-result-name)
|
|---|
| 434 | (declare (ignore fp-args-ptr))
|
|---|
| 435 | (collect ((lets)
|
|---|
| 436 | (rlets)
|
|---|
| 437 | (inits)
|
|---|
| 438 | (dynamic-extent-names))
|
|---|
| 439 | (let* ((rtype (parse-foreign-type result-spec)))
|
|---|
| 440 | (when (typep rtype 'foreign-record-type)
|
|---|
| 441 | (if (x8664::record-type-returns-structure-as-first-arg rtype)
|
|---|
| 442 | (setq argvars (cons struct-result-name argvars)
|
|---|
| 443 | argspecs (cons :address argspecs)
|
|---|
| 444 | rtype *void-foreign-type*)
|
|---|
| 445 | (rlets (list struct-result-name (foreign-record-type-name rtype)))))
|
|---|
| 446 | (do* ((argvars argvars (cdr argvars))
|
|---|
| 447 | (argspecs argspecs (cdr argspecs))
|
|---|
| 448 | (gpr-arg-num 0)
|
|---|
| 449 | (gpr-arg-offset -8)
|
|---|
| 450 | (fpr-arg-num 0)
|
|---|
| 451 | (fpr-arg-offset -56)
|
|---|
| 452 | (memory-arg-offset 16)
|
|---|
| 453 | (fp nil nil))
|
|---|
| 454 | ((null argvars)
|
|---|
| 455 | (values (rlets) (lets) (dynamic-extent-names) (inits) rtype nil 8))
|
|---|
| 456 | (flet ((next-gpr ()
|
|---|
| 457 | (if (<= (incf gpr-arg-num) 6)
|
|---|
| 458 | (prog1
|
|---|
| 459 | gpr-arg-offset
|
|---|
| 460 | (decf gpr-arg-offset 8))
|
|---|
| 461 | (prog1
|
|---|
| 462 | memory-arg-offset
|
|---|
| 463 | (incf memory-arg-offset 8))))
|
|---|
| 464 | (next-fpr ()
|
|---|
| 465 | (if (<= (incf fpr-arg-num) 8)
|
|---|
| 466 | (prog1
|
|---|
| 467 | fpr-arg-offset
|
|---|
| 468 | (decf fpr-arg-offset 8))
|
|---|
| 469 | (prog1
|
|---|
| 470 | memory-arg-offset
|
|---|
| 471 | (incf memory-arg-offset 8)))))
|
|---|
| 472 | (let* ((name (car argvars))
|
|---|
| 473 | (spec (car argspecs))
|
|---|
| 474 | (argtype (parse-foreign-type spec))
|
|---|
| 475 | (bits (require-foreign-type-bits argtype)))
|
|---|
| 476 | (if (typep argtype 'foreign-record-type)
|
|---|
| 477 | (multiple-value-bind (first8 second8)
|
|---|
| 478 | (x8664::classify-record-type argtype)
|
|---|
| 479 | (let* ((gprs (- 6 gpr-arg-num))
|
|---|
| 480 | (fprs (- 8 fpr-arg-num)))
|
|---|
| 481 | (case first8
|
|---|
| 482 | (:integer (if (< (decf gprs) 0) (setq first8 :memory)))
|
|---|
| 483 | (:float (if (< (decf fprs) 0) (setq first8 :memory))))
|
|---|
| 484 | (case second8
|
|---|
| 485 | (:integer (if (< (decf gprs) 0) (setq first8 :memory)))
|
|---|
| 486 | (:float (if (< (decf fprs) 0) (setq first8 :memory)))))
|
|---|
| 487 | (if (eq first8 :memory)
|
|---|
| 488 | (progn
|
|---|
| 489 | (lets (list name `(%inc-ptr ,stack-ptr ,(prog1 memory-arg-offset
|
|---|
| 490 | (incf memory-arg-offset (* 8 (ceiling bits 64)))))))
|
|---|
| 491 | (dynamic-extent-names name))
|
|---|
| 492 | (progn
|
|---|
| 493 | (rlets (list name (foreign-record-type-name argtype)))
|
|---|
| 494 | (inits `(setf (%%get-unsigned-longlong ,name 0)
|
|---|
| 495 | (%%get-unsigned-longlong ,stack-ptr ,(if (eq first8 :integer) (next-gpr) (next-fpr)))))
|
|---|
| 496 | (if second8
|
|---|
| 497 | (inits `(setf (%%get-unsigned-longlong ,name 8)
|
|---|
| 498 | (%%get-unsigned-longlong ,stack-ptr ,(if (eq second8 :integer) (next-gpr) (next-fpr)))))))))
|
|---|
| 499 | (lets (list name
|
|---|
| 500 | `(,
|
|---|
| 501 | (ecase (foreign-type-to-representation-type argtype)
|
|---|
| 502 | (:single-float (setq fp t) '%get-single-float)
|
|---|
| 503 | (:double-float (setq fp t) '%get-double-float)
|
|---|
| 504 | (:signed-doubleword '%%get-signed-longlong)
|
|---|
| 505 | (:signed-fullword '%get-signed-long)
|
|---|
| 506 | (:signed-halfword '%get-signed-word)
|
|---|
| 507 | (:signed-byte '%get-signed-byte)
|
|---|
| 508 | (:unsigned-doubleword '%%get-unsigned-longlong)
|
|---|
| 509 | (:unsigned-fullword '%get-unsigned-long)
|
|---|
| 510 | (:unsigned-halfword '%get-unsigned-word)
|
|---|
| 511 | (:unsigned-byte '%get-unsigned-byte)
|
|---|
| 512 | (:address
|
|---|
| 513 | ;(dynamic-extent-names name)
|
|---|
| 514 | '%get-ptr))
|
|---|
| 515 | ,stack-ptr
|
|---|
| 516 | ,(if fp (next-fpr) (next-gpr))))))))))))
|
|---|
| 517 |
|
|---|
| 518 | (defun x8664::generate-callback-return-value (stack-ptr fp-args-ptr result return-type struct-return-arg)
|
|---|
| 519 | (declare (ignore fp-args-ptr))
|
|---|
| 520 | (unless (eq return-type *void-foreign-type*)
|
|---|
| 521 | (let* ((gpr-offset -8)
|
|---|
| 522 | (fpr-offset -24))
|
|---|
| 523 | (if (typep return-type 'foreign-record-type)
|
|---|
| 524 | ;;; Would have been mapped to :VOID unless record-type was <= 128 bits.
|
|---|
| 525 | (collect ((forms))
|
|---|
| 526 | (multiple-value-bind (first8 second8)
|
|---|
| 527 | (x8664::classify-record-type return-type)
|
|---|
| 528 | (forms `(setf (%%get-signed-longlong ,stack-ptr ,(if (eq first8 :integer) gpr-offset fpr-offset))
|
|---|
| 529 | (%%get-signed-longlong ,struct-return-arg 0)))
|
|---|
| 530 | (when second8
|
|---|
| 531 | (if (eq first8 :integer) (decf gpr-offset 8) (decf fpr-offset 8))
|
|---|
| 532 | (forms `(setf (%%get-signed-longlong ,stack-ptr ,(if (eq first8 :integer) gpr-offset fpr-offset))
|
|---|
| 533 | (%%get-signed-longlong ,struct-return-arg 8))))
|
|---|
| 534 | `(progn ,@(forms))))
|
|---|
| 535 | (let* ((return-type-keyword (foreign-type-to-representation-type return-type))
|
|---|
| 536 | (offset (case return-type-keyword
|
|---|
| 537 | ((:single-float :double-float) fpr-offset)
|
|---|
| 538 | (t gpr-offset))))
|
|---|
| 539 | `(setf (,
|
|---|
| 540 | (case return-type-keyword
|
|---|
| 541 | (:address '%get-ptr)
|
|---|
| 542 | (:signed-doubleword '%%get-signed-longlong)
|
|---|
| 543 | (:unsigned-doubleword '%%get-unsigned-longlong)
|
|---|
| 544 | (:double-float '%get-double-float)
|
|---|
| 545 | (:single-float '%get-single-float)
|
|---|
| 546 | (:unsigned-fullword '%get-unsigned-long)
|
|---|
| 547 | (t '%%get-signed-longlong )
|
|---|
| 548 | ) ,stack-ptr ,offset) ,result))))))
|
|---|
| 549 |
|
|---|
| 550 |
|
|---|
| 551 |
|
|---|
| 552 | #+x8664-target
|
|---|
| 553 | (require "X8664-VINSNS")
|
|---|
| 554 |
|
|---|
| 555 | (provide "X8664-BACKEND")
|
|---|