| 1 | ;;;-*- Mode: Lisp; Package: CCL -*-
|
|---|
| 2 | ;;;
|
|---|
| 3 | ;;; Copyright (C) 2004, 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 "PPCENV"))
|
|---|
| 24 |
|
|---|
| 25 |
|
|---|
| 26 | ;;; Callbacks. Both LinuxPPC64 and DarwinPPC64 follow something
|
|---|
| 27 | ;;; close to the PowerOpen ABI. LinuxPPC uses transition vectors
|
|---|
| 28 | ;;; and a TOC, but it's not clear that we need to care about that
|
|---|
| 29 | ;;; here.
|
|---|
| 30 | (defun define-ppc64-poweropen-callback (name args body env)
|
|---|
| 31 | (let* ((stack-word (gensym))
|
|---|
| 32 | (stack-ptr (gensym))
|
|---|
| 33 | (fp-arg-regs (gensym))
|
|---|
| 34 | (fp-arg-num 0)
|
|---|
| 35 | (arg-names ())
|
|---|
| 36 | (arg-types ())
|
|---|
| 37 | (return-type :void)
|
|---|
| 38 | (args args)
|
|---|
| 39 | (woi nil)
|
|---|
| 40 | (monitor nil)
|
|---|
| 41 | (dynamic-extent-names ())
|
|---|
| 42 | (error-return nil))
|
|---|
| 43 | (loop
|
|---|
| 44 | (when (null args) (return))
|
|---|
| 45 | (when (null (cdr args))
|
|---|
| 46 | (setq return-type (car args))
|
|---|
| 47 | (return))
|
|---|
| 48 | (if (eq (car args) :without-interrupts)
|
|---|
| 49 | (setq woi (cadr args) args (cddr args))
|
|---|
| 50 | (if (eq (car args) :monitor-exception-ports)
|
|---|
| 51 | (setq monitor (cadr args) args (cddr args))
|
|---|
| 52 | (if (eq (car args) :error-return)
|
|---|
| 53 | (setq error-return
|
|---|
| 54 | (cadr args)
|
|---|
| 55 | args (cddr args))
|
|---|
| 56 | (progn
|
|---|
| 57 | (push (foreign-type-to-representation-type (pop args)) arg-types)
|
|---|
| 58 | (push (pop args) arg-names))))))
|
|---|
| 59 | (setq arg-names (nreverse arg-names)
|
|---|
| 60 | arg-types (nreverse arg-types))
|
|---|
| 61 | (setq return-type (foreign-type-to-representation-type return-type))
|
|---|
| 62 | (when (eq return-type :void)
|
|---|
| 63 | (setq return-type nil))
|
|---|
| 64 | (let* ((offset 0)
|
|---|
| 65 | (need-stack-pointer (or arg-names return-type error-return))
|
|---|
| 66 | (lets
|
|---|
| 67 | (mapcar
|
|---|
| 68 | #'(lambda (name type)
|
|---|
| 69 | (let* ((delta 8)
|
|---|
| 70 | (bias 0)
|
|---|
| 71 | (use-fp-args nil))
|
|---|
| 72 | (prog1
|
|---|
| 73 | (list name
|
|---|
| 74 | `(,
|
|---|
| 75 | (if (typep type 'unsigned-byte)
|
|---|
| 76 | (progn (setq delta (* 8 type)) '%inc-ptr)
|
|---|
| 77 | (ecase type
|
|---|
| 78 | (:single-float
|
|---|
| 79 | (if (< (incf fp-arg-num) 14)
|
|---|
| 80 | (progn
|
|---|
| 81 | (setq use-fp-args t)
|
|---|
| 82 | '%get-single-float-from-double-ptr)
|
|---|
| 83 | (progn
|
|---|
| 84 | (setq bias 4)
|
|---|
| 85 | '%get-single-float)))
|
|---|
| 86 | (:double-float
|
|---|
| 87 | (setq delta 8)
|
|---|
| 88 | (if (< (incf fp-arg-num) 14)
|
|---|
| 89 | (setq use-fp-args t))
|
|---|
| 90 | '%get-double-float)
|
|---|
| 91 | (:signed-doubleword (setq delta 8) '%%get-signed-longlong)
|
|---|
| 92 | (:signed-fullword
|
|---|
| 93 | (setq bias 4)
|
|---|
| 94 | '%get-signed-long)
|
|---|
| 95 | (:signed-halfword (setq bias 6)
|
|---|
| 96 | '%get-signed-word)
|
|---|
| 97 | (:signed-byte (setq bias 7)
|
|---|
| 98 | '%get-signed-byte)
|
|---|
| 99 | (:unsigned-doubleword (setq delta 8) '%%get-unsigned-longlong)
|
|---|
| 100 | (:unsigned-fullword
|
|---|
| 101 | (setq bias 4)
|
|---|
| 102 | '%get-unsigned-long)
|
|---|
| 103 | (:unsigned-halfword
|
|---|
| 104 | (setq bias 6)
|
|---|
| 105 | '%get-unsigned-word)
|
|---|
| 106 | (:unsigned-byte
|
|---|
| 107 | (setq bias 7)
|
|---|
| 108 | '%get-unsigned-byte)
|
|---|
| 109 | (:address '%get-ptr)))
|
|---|
| 110 | ,(if use-fp-args fp-arg-regs stack-ptr)
|
|---|
| 111 | ,(if use-fp-args (* 8 (1- fp-arg-num))
|
|---|
| 112 | `(+ ,offset ,bias))))
|
|---|
| 113 | (when (or (eq type :address)
|
|---|
| 114 | (typep type 'unsigned-byte))
|
|---|
| 115 | (push name dynamic-extent-names))
|
|---|
| 116 | (incf offset delta))))
|
|---|
| 117 | arg-names arg-types)))
|
|---|
| 118 | (multiple-value-bind (body decls doc) (parse-body body env t)
|
|---|
| 119 | `(progn
|
|---|
| 120 | (declaim (special ,name))
|
|---|
| 121 | (define-callback-function
|
|---|
| 122 | (nfunction ,name
|
|---|
| 123 | (lambda (,stack-word)
|
|---|
| 124 | (declare (ignorable ,stack-word))
|
|---|
| 125 | (block ,name
|
|---|
| 126 | (with-macptrs (,@(and need-stack-pointer (list `(,stack-ptr))))
|
|---|
| 127 | ,(when need-stack-pointer
|
|---|
| 128 | `(%setf-macptr-to-object ,stack-ptr ,stack-word))
|
|---|
| 129 | ,(defcallback-body stack-ptr lets dynamic-extent-names
|
|---|
| 130 | decls body return-type error-return
|
|---|
| 131 | (- ppc64::c-frame.savelr ppc64::c-frame.param0)
|
|---|
| 132 | fp-arg-regs
|
|---|
| 133 | )))))
|
|---|
| 134 | ,doc
|
|---|
| 135 | ,woi
|
|---|
| 136 | ,monitor))))))
|
|---|
| 137 |
|
|---|
| 138 | (defun defcallback-body-ppc64-poweropen (stack-ptr lets dynamic-extent-names decls body return-type error-return error-delta fp-arg-ptr)
|
|---|
| 139 | (let* ((result (gensym))
|
|---|
| 140 | (result-ptr (case return-type
|
|---|
| 141 | ((:single-float :double-float) fp-arg-ptr)
|
|---|
| 142 | (t stack-ptr)))
|
|---|
| 143 | (condition-name (if (atom error-return) 'error (car error-return)))
|
|---|
| 144 | (error-return-function (if (atom error-return) error-return (cadr error-return)))
|
|---|
| 145 | (body
|
|---|
| 146 | `(with-macptrs ((,fp-arg-ptr (%get-ptr ,stack-ptr (- ppc64::c-frame.unused-1 ppc64::c-frame.param0))))
|
|---|
| 147 | (declare (ignorable ,fp-arg-ptr))
|
|---|
| 148 | (let ,lets
|
|---|
| 149 | (declare (dynamic-extent ,@dynamic-extent-names))
|
|---|
| 150 | ,@decls
|
|---|
| 151 |
|
|---|
| 152 | (let ((,result (progn ,@body)))
|
|---|
| 153 | (declare (ignorable ,result))
|
|---|
| 154 | ,@(progn
|
|---|
| 155 | ;; Coerce SINGLE-FLOAT result to DOUBLE-FLOAT
|
|---|
| 156 | (when (eq return-type :single-float)
|
|---|
| 157 | (setq result `(float ,result 0.0d0)))
|
|---|
| 158 | nil)
|
|---|
| 159 |
|
|---|
| 160 | ,(when return-type
|
|---|
| 161 | `(setf (,
|
|---|
| 162 | (case return-type
|
|---|
| 163 | (:address '%get-ptr)
|
|---|
| 164 | (:signed-doubleword '%%get-signed-longlong)
|
|---|
| 165 | (:unsigned-doubleword '%%get-unsigned-longlong)
|
|---|
| 166 | ((:double-float :single-float) '%get-double-float)
|
|---|
| 167 | (t '%%get-signed-longlong )) ,result-ptr 0) ,result)))))))
|
|---|
| 168 | (if error-return
|
|---|
| 169 | (let* ((cond (gensym)))
|
|---|
| 170 | `(handler-case ,body
|
|---|
| 171 | (,condition-name (,cond) (,error-return-function ,cond ,stack-ptr (%inc-ptr ,stack-ptr ,error-delta)))))
|
|---|
| 172 | body)))
|
|---|
| 173 |
|
|---|
| 174 | (defvar *ppc64-vinsn-templates* (make-hash-table :test #'eq))
|
|---|
| 175 |
|
|---|
| 176 |
|
|---|
| 177 |
|
|---|
| 178 | (defvar *known-ppc64-backends* ())
|
|---|
| 179 |
|
|---|
| 180 |
|
|---|
| 181 | #+linuxppc-target
|
|---|
| 182 | (defvar *linuxppc64-backend*
|
|---|
| 183 | (make-backend :lookup-opcode #'lookup-ppc-opcode
|
|---|
| 184 | :lookup-macro #'ppc::ppc-macro-function
|
|---|
| 185 | :lap-opcodes ppc::*ppc-opcodes*
|
|---|
| 186 | :define-vinsn 'define-ppc-vinsn
|
|---|
| 187 | :platform-syscall-mask (logior platform-os-linux platform-cpu-ppc)
|
|---|
| 188 |
|
|---|
| 189 | :p2-dispatch *ppc2-specials*
|
|---|
| 190 | :p2-vinsn-templates *ppc64-vinsn-templates*
|
|---|
| 191 | :p2-template-hash-name '*ppc64-vinsn-templates*
|
|---|
| 192 | :p2-compile 'ppc2-compile
|
|---|
| 193 | :target-specific-features
|
|---|
| 194 | '(:powerpc :ppc-target :poweropen-target :linux-target :linuxppc-target :ppc64-target :64-bit-target :big-endian-target)
|
|---|
| 195 | :target-fasl-pathname (make-pathname :type "p64fsl")
|
|---|
| 196 | :target-platform (logior platform-cpu-ppc
|
|---|
| 197 | platform-os-linux
|
|---|
| 198 | platform-word-size-64)
|
|---|
| 199 | :target-os :linuxppc
|
|---|
| 200 | :name :linuxppc64
|
|---|
| 201 | :target-arch-name :ppc64
|
|---|
| 202 | :target-foreign-type-data nil
|
|---|
| 203 | :target-arch ppc64::*ppc64-target-arch*
|
|---|
| 204 | :define-callback 'define-ppc64-poweropen-callback
|
|---|
| 205 | :defcallback-body 'defcallback-body-ppc64-poweropen
|
|---|
| 206 | ))
|
|---|
| 207 |
|
|---|
| 208 |
|
|---|
| 209 | #+darwinppc-target
|
|---|
| 210 | (defvar *darwinppc64-backend*
|
|---|
| 211 | (make-backend :lookup-opcode #'lookup-ppc-opcode
|
|---|
| 212 | :lookup-macro #'ppc::ppc-macro-function
|
|---|
| 213 | :lap-opcodes ppc::*ppc-opcodes*
|
|---|
| 214 | :define-vinsn 'define-ppc-vinsn
|
|---|
| 215 | :platform-syscall-mask (logior platform-os-darwin platform-cpu-ppc)
|
|---|
| 216 |
|
|---|
| 217 | :p2-dispatch *ppc2-specials*
|
|---|
| 218 | :p2-vinsn-templates *ppc64-vinsn-templates*
|
|---|
| 219 | :p2-template-hash-name '*ppc64-vinsn-templates*
|
|---|
| 220 | :p2-compile 'ppc2-compile
|
|---|
| 221 | :target-specific-features
|
|---|
| 222 | '(:powerpc :ppc-target :darwin-target :darwinppc-target :ppc64-target :64-bit-target :big-endian-target)
|
|---|
| 223 | :target-fasl-pathname (make-pathname :type "d64fsl")
|
|---|
| 224 | :target-platform (logior platform-cpu-ppc
|
|---|
| 225 | platform-os-darwin
|
|---|
| 226 | platform-word-size-64)
|
|---|
| 227 | :target-os :darwinppc
|
|---|
| 228 | :name :darwinppc64
|
|---|
| 229 | :target-arch-name :ppc64
|
|---|
| 230 | :target-foreign-type-data nil
|
|---|
| 231 | :target-arch ppc64::*ppc64-target-arch*
|
|---|
| 232 | :define-callback 'define-ppc64-poweropen-callback
|
|---|
| 233 | :defcallback-body 'defcallback-body-ppc64-poweropen))
|
|---|
| 234 |
|
|---|
| 235 | #+linuxppc-target
|
|---|
| 236 | (pushnew *linuxppc64-backend* *known-ppc64-backends* :key #'backend-name)
|
|---|
| 237 |
|
|---|
| 238 |
|
|---|
| 239 | #+darwinppc-target
|
|---|
| 240 | (pushnew *darwinppc64-backend* *known-ppc64-backends* :key #'backend-name)
|
|---|
| 241 |
|
|---|
| 242 | (defvar *ppc64-backend* (car *known-ppc64-backends*))
|
|---|
| 243 |
|
|---|
| 244 | (defun fixup-ppc64-backend ()
|
|---|
| 245 | (dolist (b *known-ppc64-backends*)
|
|---|
| 246 | (setf (backend-lap-opcodes b) ppc::*ppc-opcodes*
|
|---|
| 247 | (backend-p2-dispatch b) *ppc2-specials*
|
|---|
| 248 | (backend-p2-vinsn-templates b) *ppc64-vinsn-templates*)
|
|---|
| 249 | (or (backend-lap-macros b) (setf (backend-lap-macros b)
|
|---|
| 250 | (make-hash-table :test #'equalp)))))
|
|---|
| 251 |
|
|---|
| 252 |
|
|---|
| 253 |
|
|---|
| 254 | (fixup-ppc64-backend)
|
|---|
| 255 |
|
|---|
| 256 | #+ppc64-target
|
|---|
| 257 | (setq *host-backend* *ppc64-backend* *target-backend* *ppc64-backend*)
|
|---|
| 258 | #-ppc64-target
|
|---|
| 259 | (unless (backend-target-foreign-type-data *ppc64-backend*)
|
|---|
| 260 | (let* ((ftd (make-ftd
|
|---|
| 261 | :interface-db-directory
|
|---|
| 262 | #+darwinppc-target "ccl:darwin-headers64;"
|
|---|
| 263 | #+linuxppc-target "ccl:headers64;"
|
|---|
| 264 | :interface-package-name
|
|---|
| 265 | #+darwinppc-target "DARWIN64"
|
|---|
| 266 | #+linuxppc-target "LINUX64"
|
|---|
| 267 | :attributes
|
|---|
| 268 | #+darwinppc-target
|
|---|
| 269 | '(:signed-char t
|
|---|
| 270 | :struct-by-value t
|
|---|
| 271 | :struct-return-in-registers t
|
|---|
| 272 | :struct-return-explicit t
|
|---|
| 273 | :struct-by-value-by-field t
|
|---|
| 274 | :prepend-underscores t
|
|---|
| 275 | :bits-per-word 64)
|
|---|
| 276 | #+linuxppc-target
|
|---|
| 277 | '(:bits-per-word 64)
|
|---|
| 278 | :ff-call-expand-function
|
|---|
| 279 | #+linuxppc-target
|
|---|
| 280 | 'linux64::expand-ff-call
|
|---|
| 281 | #+darwinppc-target
|
|---|
| 282 | 'darwin64::expand-ff-call
|
|---|
| 283 | :ff-call-struct-return-by-implicit-arg-function
|
|---|
| 284 | #+linuxppc-target
|
|---|
| 285 | linux64::record-type-returns-structure-as-first-arg
|
|---|
| 286 | #+darwinppc-target
|
|---|
| 287 | darwin64::record-type-returns-structure-as-first-arg
|
|---|
| 288 | :callback-bindings-function
|
|---|
| 289 | #+linuxppc-target
|
|---|
| 290 | linux64::generate-callback-bindings
|
|---|
| 291 | #+darwinppc-target
|
|---|
| 292 | darwin64::generate-callback-bindings
|
|---|
| 293 | :callback-return-value-function
|
|---|
| 294 | #+linuxppc-target
|
|---|
| 295 | linux64::generate-callback-return-value
|
|---|
| 296 | #+darwinppc-target
|
|---|
| 297 | darwin64::generate-callback-return-value
|
|---|
| 298 | )))
|
|---|
| 299 | (install-standard-foreign-types ftd)
|
|---|
| 300 | (use-interface-dir :libc ftd)
|
|---|
| 301 | (setf (backend-target-foreign-type-data *ppc64-backend*) ftd)))
|
|---|
| 302 |
|
|---|
| 303 | (pushnew *ppc64-backend* *known-backends* :key #'backend-name)
|
|---|
| 304 |
|
|---|
| 305 | #+ppc64-target
|
|---|
| 306 | (require "PPC64-VINSNS")
|
|---|
| 307 |
|
|---|
| 308 | (provide "PPC64-BACKEND")
|
|---|
