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