contrib/sb-grovel/def-to-lisp.lisp

   1 (in-package #:sb-grovel)
   2
   3 (defvar *default-c-stream* nil)
   4
   5 (defun split-cflags (string)
   6   (remove-if (lambda (flag)
   7                (zerop (length flag)))
   8              (loop
   9                 for start = 0 then (if end (1+ end) nil)
  10                 for end = (and start (position #\Space string :start start))
  11                 while start
  12                 collect (subseq string start end))))
  13
  14 (defun c-escape (string &optional (dangerous-chars '(#\")) (escape-char #\\))
  15   "Escape DANGEROUS-CHARS in STRING, with ESCAPE-CHAR."
  16   (declare (simple-string string))
  17   (coerce (loop for c across string
  18                 if (member c dangerous-chars) collect escape-char
  19                 collect c)
  20           'string))
  21
  22 (defun as-c (&rest args)
  23   "Pretty-print ARGS into the C source file, separated by #\Space"
  24   (format *default-c-stream* "~A~{ ~A~}~%" (first args) (rest args)))
  25
  26 (defun word-cast (arg)
  27   (format nil "CAST_SIGNED(~A)" arg))
  28
  29 #+(and win32 x86-64)
  30 (defun printf-transform-long-long (x)
  31   (with-output-to-string (str)
  32     (loop for previous = #\a then char
  33           for char across x
  34           do
  35           (write-char char str)
  36           (when (and (char= previous #\%)
  37                      (char= char #\l))
  38             (write-char #\l str)))))
  39
  40 #-(and win32 x86-64)
  41 (defun printf-transform-long-long (x)
  42   x)
  43
  44 (defun printf (formatter &rest args)
  45   "Emit C code to fprintf the quoted code, via FORMAT.
  46 The first argument is the C string that should be passed to
  47 printf.
  48
  49 The rest of the arguments are consumed by FORMAT clauses, until
  50 there are no more FORMAT clauses to fill. If there are more
  51 arguments, they are emitted as printf arguments.
  52
  53 There is no error checking done, unless you pass too few FORMAT
  54 clause args. I recommend using this formatting convention in
  55 code:
  56
  57  (printf \"string ~A ~S %ld %ld\" format-arg-1 format-arg-2
  58          (word-cast printf-arg-1) (word-cast printf-arg-2))"
  59   (let ((*print-pretty* nil))
  60     (apply #'format *default-c-stream*
  61            "    fprintf(out, \"~@?\\n\"~@{, ~A~});~%"
  62            (printf-transform-long-long
  63             (c-escape formatter))
  64            args)))
  65
  66 (defun c-for-enum (lispname elements export)
  67   (printf "(cl:eval-when (:compile-toplevel :load-toplevel :execute) (sb-alien:define-alien-type ~A (sb-alien:enum nil" lispname)
  68   (dolist (element elements)
  69     (destructuring-bind (lisp-element-name c-element-name) element
  70       (printf " (~S %ld)" lisp-element-name (word-cast c-element-name))))
  71   (printf ")))")
  72   (when export
  73     (dolist (element elements)
  74       (destructuring-bind (lisp-element-name c-element-name) element
  75         (declare (ignore c-element-name))
  76         (unless (keywordp lisp-element-name)
  77           (printf "(export '~S)" lisp-element-name))))))
  78
  79 (defun c-for-structure (lispname cstruct)
  80   (destructuring-bind (cname &rest elements) cstruct
  81     (printf "(cl:eval-when (:compile-toplevel :load-toplevel :execute) (sb-grovel::define-c-struct ~A %ld" lispname
  82             (word-cast (format nil "sizeof(~A)" cname)))
  83     (dolist (e elements)
  84       (destructuring-bind (lisp-type lisp-el-name c-type c-el-name &key distrust-length) e
  85         (printf " (~A ~A \"~A\"" lisp-el-name lisp-type c-type)
  86         ;; offset
  87         (as-c "{" cname "t;")
  88         (printf "  %lu"
  89                 (format nil "((unsigned long~A)&(t.~A)) - ((unsigned long~A)&(t))"
  90                         #+(and win32 x86-64) " long" #-(and win32 x86-64) ""
  91                         c-el-name
  92                         #+(and win32 x86-64) " long" #-(and win32 x86-64) ""))
  93         (as-c "}")
  94         ;; length
  95         (if distrust-length
  96             (printf "  0)")
  97             (progn
  98               (as-c "{" cname "t;")
  99               (printf "  %ld)"
 100                       (word-cast (format nil "sizeof(t.~A)" c-el-name)))
 101               (as-c "}")))))
 102     (printf "))")))
 103
 104 (defun print-c-source (stream headers definitions package-name)
 105   (declare (ignorable definitions package-name))
 106   (let ((*default-c-stream* stream)
 107         (*print-right-margin* nil))
 108     (loop for i in (cons "stdio.h" headers)
 109           do (format stream "#include <~A>~%" i))
 110     (as-c "#define SIGNEDP(x) (((x)-1)<0)")
 111     (as-c "#define SIGNED_(x) (SIGNEDP(x)?\"\":\"un\")")
 112     ;; KLUDGE: some win32 constants are unsigned even though the
 113     ;; functions accepting them declare them as signed
 114     ;; e.g. ioctlsocket and FIONBIO.
 115     ;; Cast to signed long when possible.
 116     ;; Other platforms do not seem to be affected by this,
 117     ;; but we used to cast everything to INT on x86-64, preserve that behaviour.
 118     #+(and win32 x86-64)
 119     (as-c "#define CAST_SIGNED(x) ((sizeof(x) == 4)? (long long) (long) (x): (x))")
 120     #+(and (not win32) x86-64)
 121     (as-c "#define CAST_SIGNED(x) ((sizeof(x) == 4)? (long) (int) (x): (x))")
 122     ;; the C compiler on macOS warns that %ld is the wrong format for an int
 123     ;; even though 'long' and 'int' are both 4 bytes.
 124     #+x86
 125     (as-c "#define CAST_SIGNED(x) ((long) (x))")
 126     #-(or x86 x86-64)
 127     (as-c "#define CAST_SIGNED(x) ((int) (x))")
 128     (as-c "int main(int argc, char *argv[]) {")
 129     (as-c "    FILE *out;")
 130     (as-c "    if (argc != 2) {")
 131     (as-c "        printf(\"Invalid argcount!\");")
 132     (as-c "        return 1;")
 133     (as-c "    } else")
 134     (as-c "        out = fopen(argv[1], \"w\");")
 135     (as-c "    if (!out) {")
 136     (as-c "        printf(\"Error opening output file!\");")
 137     (as-c "        return 1;")
 138     (as-c "    }")
 139     (printf "(cl:in-package #:~A)" package-name)
 140     (printf "(cl:eval-when (:compile-toplevel)")
 141     (printf "  (cl:defparameter *integer-sizes* (cl:make-hash-table))")
 142     (dolist (type '("char" "short" "long long" "long" "int"))
 143       (printf "  (cl:setf (cl:gethash %ld *integer-sizes*) 'sb-alien:~A)" (substitute #\- #\Space type)
 144               (word-cast (format nil "sizeof(~A)" type))))
 145     (printf ")")
 146     (dolist (def definitions)
 147       (destructuring-bind (type lispname cname &optional doc export) def
 148         (case type
 149           ((:integer :errno)
 150            (as-c "#ifdef" cname)
 151            (printf "(cl:defconstant ~A %ld \"~A\")" lispname doc
 152                    (word-cast cname))
 153            (when (eql type :errno)
 154              (printf "(cl:setf (get '~A 'errno) t)" lispname))
 155            (as-c "#else")
 156            (printf "(sb-int:style-warn \"Couldn't grovel for ~~A (unknown to the C compiler).\" \"~A\")" cname)
 157            (as-c "#endif"))
 158           ((:integer-no-check)
 159            (printf "(cl:defconstant ~A %ld \"~A\")" lispname doc (word-cast cname)))
 160           (:enum
 161            (c-for-enum lispname cname export))
 162           (:type
 163            (printf "(cl:eval-when (:compile-toplevel :load-toplevel :execute) (sb-alien:define-alien-type ~A (sb-alien:%ssigned %ld)))" lispname
 164                    (format nil "SIGNED_(~A)" cname)
 165                    (word-cast (format nil "(8*sizeof(~A))" cname))))
 166           (:string
 167            (printf "(cl:defparameter ~A %s \"~A\"" lispname doc
 168                    cname))
 169           (:function
 170            (printf "(cl:declaim (cl:inline ~A))" lispname)
 171            (destructuring-bind (f-cname &rest definition) cname
 172              (printf "(sb-grovel::define-foreign-routine (\"~A\" ~A)" f-cname lispname)
 173              (printf "~{  ~W~^\\n~})" definition)))
 174           (:structure
 175            (c-for-structure lispname cname))
 176           (otherwise
 177            ;; should we really not sprechen espagnol, monsieurs?
 178            (error "Unknown grovel keyword encountered: ~A" type)))
 179         (when export
 180           (printf "(cl:export '~A)" lispname))))
 181     (as-c "return 0;")
 182     (as-c "}")))
 183
 184 (defun c-constants-extract  (filename output-file package)
 185   (with-open-file (f output-file :direction :output :if-exists :supersede)
 186     (with-open-file (i filename :direction :input)
 187       (let* ((headers (read i))
 188              (definitions (read i)))
 189         (print-c-source  f headers definitions package)))))
 190
 191 (defclass grovel-constants-file (cl-source-file)
 192   ((package :accessor constants-package :initarg :package)
 193    (do-not-grovel :accessor do-not-grovel
 194                   :initform nil
 195                   :initarg :do-not-grovel)))
 196 (defclass asdf::sb-grovel-constants-file (grovel-constants-file) ())
 197
 198 (define-condition c-compile-failed (compile-file-error)
 199   ((description :initform "C compiler failed")))
 200 (define-condition a-dot-out-failed (compile-file-error)
 201   ((description :initform "a.out failed")))
 202
 203 (defmethod perform ((op compile-op)
 204                     (component grovel-constants-file))
 205   ;; we want to generate all our temporary files in the fasl directory
 206   ;; because that's where we have write permission.  Can't use /tmp;
 207   ;; it's insecure (these files will later be owned by root)
 208   (let* ((output-files (output-files op component))
 209          (output-file (first output-files))
 210          (warnings-file (second output-files))
 211          (filename (component-pathname component))
 212          (context-format "~/asdf-action::format-action/")
 213          (context-arguments `((,op . ,component)))
 214          (condition-arguments `(:context-format ,context-format
 215                                 :context-arguments ,context-arguments))
 216          (real-output-file
 217           (if (typep output-file 'logical-pathname)
 218               (translate-logical-pathname output-file)
 219               (pathname output-file)))
 220          (tmp-c-source (merge-pathnames #p"foo.c" real-output-file))
 221          (tmp-a-dot-out (merge-pathnames #-win32 #p"a.out" #+win32 #p"a.exe"
 222                                          real-output-file))
 223          (tmp-constants (merge-pathnames #p"constants.lisp-temp"
 224                                          real-output-file)))
 225     (funcall (intern "C-CONSTANTS-EXTRACT" (find-package "SB-GROVEL"))
 226              filename tmp-c-source (constants-package component))
 227     (unless (do-not-grovel component)
 228       (let* ((cc (or (and (string/= (sb-ext:posix-getenv "CC") "")
 229                           (sb-ext:posix-getenv "CC"))
 230                      (if (member :sb-building-contrib *features*)
 231                          (error "~@<The CC environment variable not set during ~
 232                                  SB-GROVEL build.~:@>")
 233                          (sb-int:style-warn
 234                           "CC environment variable not set, SB-GROVEL falling back to \"cc\"."))
 235                      "cc"))
 236              (code (sb-ext:process-exit-code
 237                     (sb-ext:run-program
 238                      cc
 239                      (append
 240                       (split-cflags (sb-ext:posix-getenv "EXTRA_CFLAGS"))
 241                       #+(and linux largefile)
 242                       '("-D_LARGEFILE_SOURCE"
 243                         "-D_LARGEFILE64_SOURCE"
 244                         "-D_FILE_OFFSET_BITS=64")
 245                       #+(and (or x86 ppc sparc) (or linux freebsd)) '("-m32")
 246                       #+(and x86-64 darwin inode64)
 247                       `("-arch" "x86_64"
 248                         ,(format nil "-mmacosx-version-min=~A"
 249                                  (or (sb-ext:posix-getenv "SBCL_MACOSX_VERSION_MIN")
 250                                      "10.5"))
 251                         "-D_DARWIN_USE_64_BIT_INODE")
 252                       #+(and x86-64 darwin (not inode64))
 253                       '("-arch" "x86_64"
 254                         "-mmacosx-version-min=10.4")
 255                       #+(and x86 darwin)
 256                       `("-arch" "i386"
 257                        ,(format nil "-mmacosx-version-min=~A"
 258                                 (or (sb-ext:posix-getenv "SBCL_MACOSX_VERSION_MIN")
 259                                      "10.4")))
 260                       #+(and x86-64 sunos) '("-m64")
 261                       (list "-o"
 262                             (namestring tmp-a-dot-out)
 263                             (namestring tmp-c-source)))
 264                      :search t
 265                      :input nil
 266                      :output *trace-output*))))
 267         (unless (= code 0)
 268           (apply 'error 'c-compile-failed condition-arguments)))
 269       (let ((code (sb-ext:process-exit-code
 270                    (sb-ext:run-program (namestring tmp-a-dot-out)
 271                                        (list (namestring tmp-constants))
 272                                        :search nil
 273                                        :input nil
 274                                        :output *trace-output*))))
 275         (unless (= code 0)
 276           (apply 'error 'a-dot-out-failed condition-arguments)))
 277     (multiple-value-bind (output warnings-p failure-p)
 278         (compile-file* tmp-constants :output-file output-file :warnings-file warnings-file)
 279       (check-lisp-compile-results output warnings-p failure-p context-format context-arguments)))))