mirror of
git://git.code.sf.net/p/sbcl/sbcl
synced 2026-09-10 07:26:40 -04:00
302a48afba
CFLAGS can be modified to allow cross-compilation, and building the runtime already respects CFLAGS.
304 lines
13 KiB
Common Lisp
304 lines
13 KiB
Common Lisp
(in-package #:sb-grovel)
|
|
|
|
(defvar *default-c-stream* nil)
|
|
|
|
(defun split-cflags (string)
|
|
(remove-if (lambda (flag)
|
|
(zerop (length flag)))
|
|
(loop
|
|
for start = 0 then (if end (1+ end) nil)
|
|
for end = (and start (position #\Space string :start start))
|
|
while start
|
|
collect (subseq string start end))))
|
|
|
|
(defun c-escape (string &optional (dangerous-chars '(#\")) (escape-char #\\))
|
|
"Escape DANGEROUS-CHARS in STRING, with ESCAPE-CHAR."
|
|
(declare (simple-string string))
|
|
(coerce (loop for c across string
|
|
if (member c dangerous-chars) collect escape-char
|
|
collect c)
|
|
'string))
|
|
|
|
(defun as-c (&rest args)
|
|
"Pretty-print ARGS into the C source file, separated by #\Space"
|
|
(format *default-c-stream* "~A~{ ~A~}~%" (first args) (rest args)))
|
|
|
|
(defun word-cast (arg)
|
|
(format nil "CAST_SIGNED(~A)" arg))
|
|
|
|
#+(and win32 64-bit)
|
|
(defun printf-transform-long-long (x)
|
|
(with-output-to-string (str)
|
|
(loop for previous = #\a then char
|
|
for char across x
|
|
do
|
|
(write-char char str)
|
|
(when (and (char= previous #\%)
|
|
(char= char #\l))
|
|
(write-char #\l str)))))
|
|
|
|
#-(and win32 64-bit)
|
|
(defun printf-transform-long-long (x)
|
|
x)
|
|
|
|
(defun printf (formatter &rest args)
|
|
"Emit C code to fprintf the quoted code, via FORMAT.
|
|
The first argument is the C string that should be passed to
|
|
printf.
|
|
|
|
The rest of the arguments are consumed by FORMAT clauses, until
|
|
there are no more FORMAT clauses to fill. If there are more
|
|
arguments, they are emitted as printf arguments.
|
|
|
|
There is no error checking done, unless you pass too few FORMAT
|
|
clause args. I recommend using this formatting convention in
|
|
code:
|
|
|
|
(printf \"string ~A ~S %ld %ld\" format-arg-1 format-arg-2
|
|
(word-cast printf-arg-1) (word-cast printf-arg-2))"
|
|
(let ((*print-pretty* nil))
|
|
(apply #'format *default-c-stream*
|
|
" fprintf(out, \"~@?\\n\"~@{, ~A~});~%"
|
|
(printf-transform-long-long
|
|
(c-escape formatter))
|
|
args)))
|
|
|
|
(defun c-for-enum (lispname elements export)
|
|
(printf "(sb-alien:define-alien-type ~A (sb-alien:enum nil" lispname)
|
|
(dolist (element elements)
|
|
(destructuring-bind (lisp-element-name c-element-name) element
|
|
(printf " (~S %ld)" lisp-element-name (word-cast c-element-name))))
|
|
(printf "))")
|
|
(when export
|
|
(dolist (element elements)
|
|
(destructuring-bind (lisp-element-name c-element-name) element
|
|
(declare (ignore c-element-name))
|
|
(unless (keywordp lisp-element-name)
|
|
(printf "(export '~S)" lisp-element-name))))))
|
|
|
|
(defun c-for-structure (lispname cstruct)
|
|
(destructuring-bind (cname &rest elements) cstruct
|
|
(printf "(sb-grovel::define-c-struct ~A %ld" lispname
|
|
(word-cast (format nil "sizeof(~A)" cname)))
|
|
(dolist (e elements)
|
|
(destructuring-bind (lisp-type lisp-el-name c-type c-el-name &key distrust-length) e
|
|
(printf " (~A ~A \"~A\"" lisp-el-name lisp-type c-type)
|
|
;; offset
|
|
(as-c "{" cname "t;")
|
|
(printf " %lu"
|
|
(format nil "((unsigned long~A)&(t.~A)) - ((unsigned long~A)&(t))"
|
|
#+(and win32 64-bit) " long" #-(and win32 64-bit) ""
|
|
c-el-name
|
|
#+(and win32 64-bit) " long" #-(and win32 64-bit) ""))
|
|
(as-c "}")
|
|
;; length
|
|
(if distrust-length
|
|
(printf " 0)")
|
|
(progn
|
|
(as-c "{" cname "t;")
|
|
(printf " %ld)"
|
|
(word-cast (format nil "sizeof(t.~A)" c-el-name)))
|
|
(as-c "}")))))
|
|
(printf ")")))
|
|
|
|
(defun print-c-source (stream headers definitions package-name)
|
|
(declare (ignorable definitions package-name))
|
|
(let ((*default-c-stream* stream)
|
|
(*print-right-margin* nil))
|
|
(loop for i in (cons "stdio.h" headers)
|
|
do (format stream "#include <~A>~%" i))
|
|
(as-c "#define SIGNEDP(x) (((x)-1)<0)")
|
|
(as-c "#define SIGNED_(x) (SIGNEDP(x)?\"\":\"un\")")
|
|
;; KLUDGE: some win32 constants are unsigned even though the
|
|
;; functions accepting them declare them as signed
|
|
;; e.g. ioctlsocket and FIONBIO.
|
|
;; Cast to signed long when possible.
|
|
;; Other platforms do not seem to be affected by this,
|
|
;; but we used to cast everything to INT on x86-64, preserve that behaviour.
|
|
#+(and win32 64-bit)
|
|
(as-c "#define CAST_SIGNED(x) ((sizeof(x) == 4)? (long long) (long) (x): (x))")
|
|
#+(and (not win32) x86-64)
|
|
(as-c "#define CAST_SIGNED(x) ((sizeof(x) == 4)? (long) (int) (x): (x))")
|
|
;; the C compiler on x86 macOS warns that %ld is the wrong format for an int
|
|
;; even though 'long' and 'int' are both 4 bytes.
|
|
#-(or x86 64-bit)
|
|
(as-c "#define CAST_SIGNED(x) ((int) (x))")
|
|
#+(and (not x86-64) (or x86 (and (not win32) 64-bit)))
|
|
(as-c "#define CAST_SIGNED(x) ((long) (x))")
|
|
(as-c "
|
|
int main(int argc, char *argv[]) {
|
|
FILE *out;
|
|
if (argc != 2) {
|
|
fprintf(stderr, \"Invalid argcount!\\n\");
|
|
return 1;
|
|
} else
|
|
out = fopen(argv[1], \"w\");
|
|
if (!out) {
|
|
fprintf(stderr, \"Error opening output file!\\n\");
|
|
return 1;
|
|
}")
|
|
(printf "(cl:in-package #:~A)" package-name)
|
|
(printf "(cl:eval-when (:compile-toplevel :execute)")
|
|
(printf " (cl:defparameter *integer-sizes* (cl:make-hash-table))")
|
|
(dolist (type '("char" "short" "long long" "long" "int"))
|
|
(printf " (cl:setf (cl:gethash %ld *integer-sizes*) 'sb-alien:~A)" (substitute #\- #\Space type)
|
|
(word-cast (format nil "sizeof(~A)" type))))
|
|
(printf ")")
|
|
(dolist (def definitions)
|
|
(destructuring-bind (type lispname cname &optional doc export) def
|
|
(case type
|
|
((:integer :errno)
|
|
(as-c "#ifdef" cname)
|
|
(printf "(cl:defconstant ~A %ld~@[ \"~A\"~])" lispname doc
|
|
(word-cast cname))
|
|
(when (eql type :errno)
|
|
(printf "(cl:setf (get '~A 'errno) t)" lispname))
|
|
(as-c "#else")
|
|
(printf "(sb-int:style-warn \"Couldn't grovel for ~~A (unknown to the C compiler).\" \"~A\")" cname)
|
|
(as-c "#endif"))
|
|
((:integer-no-check)
|
|
(printf "(cl:defconstant ~A %ld~@[ \"~A\"~])" lispname doc (word-cast cname)))
|
|
(:enum
|
|
(c-for-enum lispname cname export))
|
|
(:type
|
|
(printf "(sb-alien:define-alien-type ~A (sb-alien:%ssigned %ld))" lispname
|
|
(format nil "SIGNED_(~A)" cname)
|
|
(word-cast (format nil "(8*sizeof(~A))" cname))))
|
|
(:string
|
|
(printf "(cl:defparameter ~A %s \"~A\"" lispname doc
|
|
cname))
|
|
(:function
|
|
(printf "(cl:declaim (cl:inline ~A))" lispname)
|
|
(destructuring-bind (f-cname &rest definition) cname
|
|
(printf "(sb-alien:define-alien-routine (\"~A\" ~A)" f-cname lispname)
|
|
(printf "~{ ~W~^\\n~})" definition)))
|
|
(:structure
|
|
(c-for-structure lispname cname))
|
|
(otherwise
|
|
;; should we really not sprechen espagnol, monsieurs?
|
|
(error "Unknown grovel keyword encountered: ~A" type)))
|
|
(when export
|
|
(printf "(cl:export '~A)" lispname))))
|
|
(as-c "return 0;")
|
|
(as-c "}")))
|
|
|
|
(defun run-c-compiler (sourcefile exefile)
|
|
(let ((cc (or (and (string/= (sb-ext:posix-getenv "CC") "")
|
|
(sb-ext:posix-getenv "CC"))
|
|
(if (member :sb-building-contrib *features*)
|
|
(error "~@<The CC environment variable not set during ~
|
|
SB-GROVEL build.~:@>")
|
|
(sb-int:style-warn
|
|
"CC environment variable not set, SB-GROVEL falling back to \"cc\"."))
|
|
"cc")))
|
|
(sb-ext:process-exit-code
|
|
(sb-ext:run-program
|
|
cc
|
|
(append
|
|
(split-cflags (sb-ext:posix-getenv "CFLAGS"))
|
|
#+(and linux largefile)
|
|
'("-D_LARGEFILE_SOURCE" "-D_LARGEFILE64_SOURCE" "-D_FILE_OFFSET_BITS=64")
|
|
#+64-bit-time
|
|
'("-D_TIME_BITS=64")
|
|
#+(and (or x86 ppc sparc) (or linux freebsd)) '("-m32")
|
|
#+(and x86-64 darwin inode64)
|
|
`("-arch" "x86_64" ,(format nil "-mmacosx-version-min=~A"
|
|
(or (sb-ext:posix-getenv "SBCL_MACOSX_VERSION_MIN")
|
|
"10.6"))
|
|
"-D_DARWIN_USE_64_BIT_INODE")
|
|
#+(and x86-64 darwin (not inode64))
|
|
'("-arch" "x86_64" "-mmacosx-version-min=10.4")
|
|
#+(and ppc darwin)
|
|
`("-arch" "ppc"
|
|
,(format nil "-mmacosx-version-min=~A"
|
|
(or (sb-ext:posix-getenv "SBCL_MACOSX_VERSION_MIN")
|
|
"10.4")))
|
|
#+(and x86-64 sunos) '("-m64")
|
|
(list "-o" (namestring exefile) (namestring sourcefile)))
|
|
:search t
|
|
:input nil
|
|
:output *trace-output*))))
|
|
|
|
;;; Extract constants as specified from INPUT, creating file OUTPUT.
|
|
;;; Very important: This OUTPUT formal parameter should ** literally ** be
|
|
;;; be named OUTPUT, and not OUTPUT-FILE. WAT ???
|
|
;;; Well, OUTPUT-FILE is the name of a class exported from ASDF and we might do
|
|
;;; (USE-PACKAGE "ASDF") *after* having loaded our 'defpackage' without ASDF.
|
|
;;; A subsequent USE-PACKAGE would cause a symbol conflict. How can there ever
|
|
;;; be a subsequent USE-PACKAGE? Because some _other_ system decides that it
|
|
;;; wants to do the following actions:
|
|
;;; - load system "A" using a non-ASDF system loading tool
|
|
;;; that wants to use SB-GROVEL
|
|
;;; - load ASDF, which pushes :ASDF on *FEATURES*
|
|
;;; - use ASDF to load system "B" which claims to need ASDF to use SB-GROVEL
|
|
;;; - which re-loads SB-GROVEL, which loads our DEFPACKAGE
|
|
;;; - which causes the aforementioned failure.
|
|
;;; Now you might think that pushing "SB-GROVEL" on to *MODULES* the first time
|
|
;;; would fix things, but it doesn't - because we actually _do_ have to reload
|
|
;;; this file, in order to pull in the CLOS stuff. This problem can't be
|
|
;;; fixed until the outside worlds' systems either all use ASDF or not.
|
|
;;; Which translates to: this won't be fixed correctly, ever.
|
|
;;;
|
|
;;; TLDR: this stupid restriction on a variable's name makes
|
|
;;; something work that didn't used to work. And victory is ours!
|
|
#+asdf
|
|
(progn
|
|
(defun c-constants-extract (input output package)
|
|
(with-open-file (f output :direction :output :if-exists :supersede)
|
|
(with-open-file (i input :direction :input)
|
|
(let* ((headers (read i))
|
|
(definitions (read i)))
|
|
(print-c-source f headers definitions package)))))
|
|
|
|
(defclass grovel-constants-file (cl-source-file)
|
|
((package :accessor constants-package :initarg :package)
|
|
(do-not-grovel :accessor do-not-grovel
|
|
:initform nil
|
|
:initarg :do-not-grovel)))
|
|
(defclass asdf::sb-grovel-constants-file (grovel-constants-file) ())
|
|
|
|
(define-condition c-compile-failed (compile-file-error)
|
|
((description :initform "C compiler failed")))
|
|
(define-condition a-dot-out-failed (compile-file-error)
|
|
((description :initform "a.out failed")))
|
|
|
|
(defmethod perform ((op compile-op)
|
|
(component grovel-constants-file))
|
|
;; we want to generate all our temporary files in the fasl directory
|
|
;; because that's where we have write permission. Can't use /tmp;
|
|
;; it's insecure (these files will later be owned by root)
|
|
(let* ((output-files (output-files op component))
|
|
(output-file (first output-files))
|
|
(warnings-file (second output-files))
|
|
(filename (component-pathname component))
|
|
(context-format "~/asdf-action::format-action/")
|
|
(context-arguments `((,op . ,component)))
|
|
(condition-arguments `(:context-format ,context-format
|
|
:context-arguments ,context-arguments))
|
|
(real-output-file
|
|
(if (typep output-file 'logical-pathname)
|
|
(translate-logical-pathname output-file)
|
|
(pathname output-file)))
|
|
(tmp-c-source (merge-pathnames #p"foo.c" real-output-file))
|
|
(tmp-a-dot-out (merge-pathnames #-win32 #p"a.out" #+win32 #p"a.exe"
|
|
real-output-file))
|
|
(tmp-constants (merge-pathnames #p"constants.lisp-temp"
|
|
real-output-file)))
|
|
(c-constants-extract filename tmp-c-source (constants-package component))
|
|
(unless (do-not-grovel component)
|
|
(let ((code (run-c-compiler tmp-c-source tmp-a-dot-out)))
|
|
(unless (= code 0)
|
|
(apply 'error 'c-compile-failed condition-arguments)))
|
|
(let ((code (sb-ext:process-exit-code
|
|
(sb-ext:run-program (namestring tmp-a-dot-out)
|
|
(list (namestring tmp-constants))
|
|
:search nil
|
|
:input nil
|
|
:output *trace-output*))))
|
|
(unless (= code 0)
|
|
(apply 'error 'a-dot-out-failed condition-arguments)))
|
|
(multiple-value-bind (output warnings-p failure-p)
|
|
(compile-file* tmp-constants :output-file output-file :warnings-file warnings-file)
|
|
(check-lisp-compile-results output warnings-p failure-p context-format context-arguments)))))
|
|
) ; end PROGN
|