src/c2ffi/c2ffi.lisp

   1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
   2 ;;;
   3 ;;; c2ffi.lisp --- c2ffi related code
   4 ;;;
   5 ;;; Copyright (C) 2013, Ryan Pavlik <rpavlik@gmail.com>
   6 ;;; Copyright (C) 2015, Attila Lendvai <attila@lendvai.name>
   7 ;;;
   8 ;;; Permission is hereby granted, free of charge, to any person
   9 ;;; obtaining a copy of this software and associated documentation
  10 ;;; files (the "Software"), to deal in the Software without
  11 ;;; restriction, including without limitation the rights to use, copy,
  12 ;;; modify, merge, publish, distribute, sublicense, and/or sell copies
  13 ;;; of the Software, and to permit persons to whom the Software is
  14 ;;; furnished to do so, subject to the following conditions:
  15 ;;;
  16 ;;; The above copyright notice and this permission notice shall be
  17 ;;; included in all copies or substantial portions of the Software.
  18 ;;;
  19 ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
  20 ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
  21 ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
  22 ;;; NONINFRINGEMENT.  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
  23 ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
  24 ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
  25 ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
  26 ;;; DEALINGS IN THE SOFTWARE.
  27 ;;;
  28
  29 (in-package #:cffi/c2ffi)
  30
  31 ;;; NOTE: Most of this has been taken over from cl-autowrap.
  32
  33 ;;; Note this is rather untested and not very extensive at the moment;
  34 ;;; it should probably work on linux/win/osx though. Patches welcome.
  35
  36 (defun local-cpu ()
  37   #+x86-64 "x86_64"
  38   #+(and (not (or x86-64 freebsd)) x86) "i686"
  39   #+(and (not x86-64) x86 freebsd) "i386"
  40   #+arm "arm"
  41   #+arm64 "aarch64")
  42
  43 (defun local-vendor ()
  44   #+(or linux windows) "-pc"
  45   #+darwin "-apple"
  46   #+(not (or linux windows darwin)) "-unknown")
  47
  48 (defun local-os ()
  49   #+(or linux android) "-linux"
  50   #+windows "-windows-msvc"
  51   #+darwin "-darwin9"
  52   #+freebsd "-freebsd"
  53   #+openbsd "-openbsd")
  54
  55 (defun local-environment ()
  56   #+linux "-gnu"
  57   #+(and arm android) "-androideabi"
  58   #+(and (not arm) android) "-android"
  59   #+(not (or linux android)) "")
  60
  61 (defun local-arch ()
  62   (strcat (local-cpu) (local-vendor) (local-os) (local-environment)))
  63
  64 (defparameter *target-archs*
  65   '("i686-pc-linux-gnu"
  66     "x86_64-pc-linux-gnu"
  67     "i686-pc-windows-msvc"
  68     "x86_64-pc-windows-msvc"
  69     "i686-apple-darwin9"
  70     "x86_64-apple-darwin9"
  71     "i386-unknown-freebsd"
  72     "x86_64-unknown-freebsd"
  73     "i386-unknown-openbsd"
  74     "x86_64-unknown-openbsd"
  75     "arm-pc-linux-gnu"
  76     "aarch64-pc-linux-gnu"
  77     "aarch64-apple-darwin9"
  78     "arm-unknown-linux-androideabi"
  79     "aarch64-unknown-linux-android"
  80     "i686-unknown-linux-android"
  81     "x86_64-unknown-linux-android"))
  82
  83 (defvar *c2ffi-executable* "c2ffi")
  84 (defvar *c2ffi-extra-arguments* (list))
  85 (defvar *trace-c2ffi* nil)
  86
  87 (defun c2ffi-executable-available? ()
  88   ;; This is a hack to determine if c2ffi exists; it assumes if it
  89   ;; doesn't exist, we will get a return code other than 0.
  90   (zerop (nth-value 2 (uiop:run-program `(,*c2ffi-executable* "-h")
  91                                         :ignore-error-status t))))
  92
  93 (defun run-program* (program args &key (output (if *trace-c2ffi* *standard-output* nil))
  94                                     (error-output (if *trace-c2ffi* *error-output* nil))
  95                                     ignore-error-status)
  96   (when *trace-c2ffi*
  97     (format *debug-io* "~&; Invoking: ~A~{ ~A~}~%" program args))
  98   (zerop (nth-value 2 (uiop:run-program (list* program args) :output output
  99                                         :error-output error-output
 100                                         :ignore-error-status ignore-error-status))))
 101
 102 (defun generate-spec-using-c2ffi (input-header-file output-spec-path
 103                                  &key arch sys-include-paths ignore-error-status)
 104   "Run c2ffi on `INPUT-HEADER-FILE`, outputting to `OUTPUT-FILE` and
 105 `MACRO-OUTPUT-FILE`, optionally specifying a target triple `ARCH`."
 106   (format *debug-io* "; cffi/c2ffi is generating ~S~%" output-spec-path)
 107   (uiop:with-temporary-file (:pathname tmp-macro-file
 108                              :type "h"
 109                              :keep *trace-c2ffi*)
 110     nil ; workaround for an UIOP bug; delme eventually (attila, 2016-01-27).
 111     :close-stream
 112     (let* ((arch (when arch (list "--arch" arch)))
 113            (sys-include-paths (loop
 114                                 :for dir :in sys-include-paths
 115                                 :append (list "--sys-include" dir))))
 116       ;; Invoke c2ffi to first emit C #define's into TMP-MACRO-FILE. We ask c2ffi
 117       ;; to first generate a file of C global variables that are assigned the
 118       ;; value of the corresponding #define's, so that in the second pass below
 119       ;; the C compiler evaluates for us their right hand side and thus we can
 120       ;; get hold of their value. This is a kludge and eventually we could/should
 121       ;; support generating cffi-grovel files, and in grovel mode not rely
 122       ;; on this kludge anymore.
 123       (when (run-program* *c2ffi-executable* (append
 124                                               (list "--driver" "null"
 125                                                     "--macro-file" (namestring tmp-macro-file))
 126                                               arch
 127                                               sys-include-paths
 128                                               *c2ffi-extra-arguments*
 129                                               (list (namestring input-header-file)))
 130                           :output *standard-output*
 131                           :ignore-error-status ignore-error-status)
 132         ;; Write a tmp header file that #include's the original input file and
 133         ;; the above generated macros file which will form the input for our
 134         ;; final, second pass.
 135         (uiop:with-temporary-file (:stream tmp-include-file-stream
 136                                    :pathname tmp-include-file
 137                                    :type "h"
 138                                    :keep *trace-c2ffi*)
 139           (format tmp-include-file-stream "#include \"~A\"~%" input-header-file)
 140           (format tmp-include-file-stream "#include \"~A\"~%" tmp-macro-file)
 141           :close-stream
 142           ;; Invoke c2ffi again to generate the final output.
 143           (run-program* *c2ffi-executable* (append
 144                                             (list "--output" (namestring output-spec-path))
 145                                             arch
 146                                             sys-include-paths
 147                                             *c2ffi-extra-arguments*
 148                                             (list (namestring tmp-include-file)))
 149                         :output *standard-output*
 150                         :ignore-error-status ignore-error-status))))))
 151
 152 (defun spec-path (base-name &key version (arch (local-arch)))
 153   (check-type base-name pathname)
 154   (make-pathname :defaults base-name
 155                  :name (strcat (pathname-name base-name)
 156                                (if version
 157                                    (strcat "-" version)
 158                                    "")
 159                                "."
 160                                arch)
 161                  :type "spec"))
 162
 163 (defun find-local-spec (base-name &optional (errorp t))
 164   (let* ((spec-path (spec-path base-name))
 165          (probed (probe-file spec-path)))
 166     (if probed
 167         spec-path
 168         (when errorp
 169           (error "c2ffi spec file not found for base name ~S" base-name)))))
 170
 171 (defun ensure-spec-file-is-up-to-date (header-file-path
 172                                        &key exclude-archs sys-include-paths version)
 173   (let ((spec-path (find-local-spec header-file-path nil)))
 174     (flet ((regenerate-spec-file ()
 175              (let ((local-arch (local-arch)))
 176                (unless (c2ffi-executable-available?)
 177                  (error "No spec found for ~S on arch '~A' and the c2ffi executable was not found"
 178                         header-file-path local-arch))
 179                (generate-spec-using-c2ffi header-file-path
 180                                          (spec-path header-file-path
 181                                                     :arch local-arch
 182                                                     :version version)
 183                                          :arch local-arch
 184                                          :sys-include-paths sys-include-paths)
 185                ;; Try to run c2ffi for other architectures, but tolerate failure
 186                (dolist (arch *target-archs*)
 187                  (unless (or (string= local-arch arch)
 188                              (member arch exclude-archs :test #'string=))
 189                    (unless (generate-spec-using-c2ffi header-file-path
 190                                                      (spec-path header-file-path
 191                                                                 :arch arch
 192                                                                 :version version)
 193                                                      :arch arch
 194                                                      :sys-include-paths sys-include-paths
 195                                                      :ignore-error-status t)
 196                      (warn "Failed to generate spec for other arch: ~S" arch))))
 197                (find-local-spec header-file-path))))
 198       (if (and spec-path
 199                (not (zerop (with-input-from-file (s spec-path)
 200                              (file-length s))))
 201                (uiop:timestamp< (file-write-date header-file-path)
 202                                 (file-write-date spec-path)))
 203           spec-path            ; it's up to date, just return it as is
 204           (restart-case
 205               (regenerate-spec-file)
 206             (touch-old-copy ()
 207               :report (lambda (stream)
 208                         (format stream "Update the modification time of the out-of-date copy ~S" spec-path))
 209               ;; Make it only be visible when the spec file exists (but it's out of date)
 210               :test (lambda (condition)
 211                       (declare (ignore condition))
 212                       (not (null spec-path)))
 213               ;; Update the last modification time. Yes, it's convoluted and wasteful,
 214               ;; but I can't see any other way.
 215               (with-staging-pathname (tmp-file spec-path)
 216                 (copy-file spec-path tmp-file))
 217               ;; The return value of RESTART-CASE
 218               spec-path))))))