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
  42 (defun local-vendor ()
  43   #+(or linux windows) "-pc"
  44   #+darwin "-apple"
  45   #+(not (or linux windows darwin)) "-unknown")
  46
  47 (defun local-os ()
  48   #+linux "-linux"
  49   #+windows "-windows-msvc"
  50   #+darwin "-darwin9"
  51   #+freebsd "-freebsd")
  52
  53 (defun local-environment ()
  54   #+linux "-gnu"
  55   #-linux "")
  56
  57 (defun local-arch ()
  58   (strcat (local-cpu) (local-vendor) (local-os) (local-environment)))
  59
  60 (defparameter *known-archs*
  61   '("i686-pc-linux-gnu"
  62     "x86_64-pc-linux-gnu"
  63     "i686-pc-windows-msvc"
  64     "x86_64-pc-windows-msvc"
  65     "i686-apple-darwin9"
  66     "x86_64-apple-darwin9"
  67     "i386-unknown-freebsd"
  68     "x86_64-unknown-freebsd"))
  69
  70 (defvar *c2ffi-executable* "c2ffi")
  71
  72 (defvar *trace-c2ffi* nil)
  73
  74 (defun c2ffi-executable-available? ()
  75   ;; This is a hack to determine if c2ffi exists; it assumes if it
  76   ;; doesn't exist, we will get a return code other than 0.
  77   (zerop (nth-value 2 (uiop:run-program `(,*c2ffi-executable* "-h")
  78                                         :ignore-error-status t))))
  79
  80 (defun run-program* (program args &key (output (if *trace-c2ffi* *standard-output* nil))
  81                                     (error-output (if *trace-c2ffi* *error-output* nil))
  82                                     ignore-error-status)
  83   (when *trace-c2ffi*
  84     (format *debug-io* "~&; Invoking: ~A~{ ~A~}~%" program args))
  85   (zerop (nth-value 2 (uiop:run-program (list* program args) :output output
  86                                         :error-output error-output
  87                                         :ignore-error-status ignore-error-status))))
  88
  89 (defun generate-spec-with-c2ffi (input-header-file output-spec-path
  90                                  &key arch sys-include-paths ignore-error-status)
  91   "Run c2ffi on `INPUT-HEADER-FILE`, outputting to `OUTPUT-FILE` and
  92 `MACRO-OUTPUT-FILE`, optionally specifying a target triple `ARCH`."
  93   (uiop:with-temporary-file (:pathname tmp-macro-file
  94                              :keep *trace-c2ffi*)
  95     nil ; workaround for an UIOP bug; delme eventually (attila, 2016-01-27).
  96     :close-stream
  97     (let* ((arch (when arch (list "--arch" arch)))
  98            (sys-include-paths (loop
  99                                 :for dir :in sys-include-paths
 100                                 :append (list "--sys-include" dir))))
 101       ;; Invoke c2ffi to first emit C #define's into TMP-MACRO-FILE. We ask c2ffi
 102       ;; to first generate a file of C global variables that are assigned the
 103       ;; value of the corresponding #define's, so that in the second pass below
 104       ;; the C compiler evaluates for us their right hand side and thus we can
 105       ;; get hold of their value. This is a kludge and eventually we could/should
 106       ;; support generating cffi-grovel files, and in grovel mode not rely
 107       ;; on this kludge anymore.
 108       (when (run-program* *c2ffi-executable* (list* (namestring input-header-file)
 109                                                     "--driver" "null"
 110                                                     "--macro-file" (namestring tmp-macro-file)
 111                                                     (append arch sys-include-paths))
 112                           :output *standard-output*
 113                           :ignore-error-status ignore-error-status)
 114         ;; Write a tmp header file that #include's the original input file and
 115         ;; the above generated macros file which will form the input for our
 116         ;; final, second pass.
 117         (uiop:with-temporary-file (:stream tmp-include-file-stream
 118                                    :pathname tmp-include-file
 119                                    :keep *trace-c2ffi*)
 120           (format tmp-include-file-stream "#include \"~A\"~%" input-header-file)
 121           (format tmp-include-file-stream "#include \"~A\"~%" tmp-macro-file)
 122           :close-stream
 123           ;; Invoke c2ffi again to generate the final output.
 124           (run-program* *c2ffi-executable* (list* (namestring tmp-include-file)
 125                                                   "--output" (namestring output-spec-path)
 126                                                   (append arch sys-include-paths))
 127                         :output *standard-output*
 128                         :ignore-error-status ignore-error-status))))))
 129
 130 (defun spec-path (base-name &key version (arch (local-arch)))
 131   (check-type base-name pathname)
 132   (make-pathname :defaults base-name
 133                  :name (strcat (pathname-name base-name)
 134                                (if version
 135                                    (strcat "-" version)
 136                                    "")
 137                                "."
 138                                arch)
 139                  :type "spec"))
 140
 141 (defun find-local-spec (base-name &optional (errorp t))
 142   (let* ((spec-path (spec-path base-name))
 143          (probed (probe-file spec-path)))
 144     (if probed
 145         spec-path
 146         (when errorp
 147           (error "c2ffi spec file not found for base name ~S" base-name)))))
 148
 149 (defun ensure-spec-file-is-up-to-date (header-file-path
 150                                        &key exclude-archs sys-include-paths version)
 151   (let ((spec-path (find-local-spec header-file-path nil)))
 152     (flet ((regenerate-spec-file ()
 153              (let ((local-arch (local-arch)))
 154                (unless (c2ffi-executable-available?)
 155                  (error "No spec found for ~S on arch '~A' and c2ffi not found"
 156                         header-file-path local-arch))
 157                (generate-spec-with-c2ffi header-file-path
 158                                          (spec-path header-file-path
 159                                                     :arch local-arch
 160                                                     :version version)
 161                                          :arch local-arch
 162                                          :sys-include-paths sys-include-paths)
 163                ;; Try to run c2ffi for other architectures, but tolerate failure
 164                (dolist (arch *known-archs*)
 165                  (unless (or (string= local-arch arch)
 166                              (member arch exclude-archs :test #'string=))
 167                    (unless (generate-spec-with-c2ffi header-file-path
 168                                                      (spec-path header-file-path
 169                                                                 :arch arch
 170                                                                 :version version)
 171                                                      :arch arch
 172                                                      :sys-include-paths sys-include-paths
 173                                                      :ignore-error-status t)
 174                      (warn "Failed to generate spec for other arch: ~S" arch))))
 175                (find-local-spec header-file-path))))
 176       (if (and spec-path
 177                (uiop:timestamp< (file-write-date header-file-path)
 178                                 (file-write-date spec-path)))
 179           spec-path            ; it's up to date, just return it as is
 180           (restart-case
 181               (regenerate-spec-file)
 182             (touch-old-copy ()
 183               :report (lambda (stream)
 184                         (format stream "Update the modification time of the out-of-date copy ~S" spec-path))
 185               ;; Make it only be visible when the spec file exists (but it's out of date)
 186               :test (lambda (condition)
 187                       (declare (ignore condition))
 188                       (not (null spec-path)))
 189               ;; Update the last modification time. Yes, it's convoluted and wasteful,
 190               ;; but I can't see any other way.
 191               (with-staging-pathname (tmp-file spec-path)
 192                 (copy-file spec-path tmp-file))
 193               ;; The return value of RESTART-CASE
 194               spec-path))))))