contrib/make-contrib.lisp

   1 (setf (sb-ext:readtable-base-char-preference *readtable*) :both)
   2 (defvar *system* (second sb-ext:*posix-argv*))
   3 ;; Convert dep filenames into module names. Depending on whether each Make step
   4 ;; saw the fasls as already-existing, or is making them, the dep is either the
   5 ;; unadorned fasl name, or containing the 'vpath' in it already.
   6 (defvar *deps*
   7   (mapcar 'string-upcase (mapcar 'pathname-name (cddr sb-ext:*posix-argv*))))
   8 (format t "; Note: Building ~S~@[, deps=~S~]~%" *system* *deps*)
   9 (mapc 'require *deps*)
  10
  11 (declaim (muffle-conditions (and compiler-note (not sb-c::unknown-typep-note))))
  12
  13 (defun run-defs-to-lisp (inputs output)
  14   (flet ((invoke (string &rest args)
  15            #+android
  16            (when (string= string "RUN-C-COMPILER")
  17              (format t "~a ~{~a~^ ~}~%" string args)
  18              (sleep 5) ;; FIXME: should check if the file was compiled
  19              (return-from invoke 0))
  20            (apply (find-symbol string "SB-GROVEL") args)))
  21     (let ((c-file (merge-pathnames "runme.c" output))
  22           (all-headers)
  23           (all-definitions)
  24           (package))
  25       (dolist (input inputs)
  26         (if package
  27             (assert (eq (cdr input) package))
  28             (setf package (cdr input)))
  29         ;; Combine input specifications so that we run the C compiler once only
  30         (multiple-value-bind (headers definitions)
  31             (with-open-file (stream (merge-pathnames (make-pathname :type "lisp")
  32                                                      (car input))
  33                                     :direction :input)
  34               (values (read stream) (read stream)))
  35           (setf all-headers (nconc all-headers headers)) ; can be order-sensitive!
  36           (setf all-definitions (nconc all-definitions definitions))))
  37       (with-open-file (stream c-file :direction :output :if-exists :supersede)
  38         (invoke "PRINT-C-SOURCE" stream all-headers all-definitions package))
  39       (let* ((c-compiler-output (merge-pathnames #+unix "a.out" #+win32 "a.exe" output))
  40              (result (invoke "RUN-C-COMPILER" c-file c-compiler-output)))
  41         (unless (= result 0) (error "C compilation failed"))
  42         (let ((result
  43                (process-exit-code
  44                 (run-program (namestring c-compiler-output) (list (namestring output))
  45                              :search nil :input nil :output *trace-output*))))
  46           (unless (= result 0) (error "C execution failed")))))))
  47
  48 (defparameter +genfile+ "generated-constants")
  49 (defun logicalize (path generated)
  50   (make-pathname :host "SYS"
  51                  :directory
  52                  (append '(:absolute)
  53                          (if generated
  54                              (list "OBJ" "FROM-SELF" "CONTRIB" *system*)
  55                              (list* "CONTRIB"
  56                                     (append (last (pathname-directory *default-pathname-defaults*))
  57                                             (cdr (pathname-directory path))))))
  58                  :name (pathname-name path)
  59                  :type (pathname-type path)))
  60
  61 (defun ignorable-warning-p (c)
  62   (and (typep c 'simple-warning)
  63        (let ((s (simple-condition-format-control c)))
  64          (and (stringp s)
  65               ;; these two strings are easy to look for
  66               (or (member s '("Capstone not loaded." "GMP not loaded.")
  67                           :test 'string=)
  68                   ;; this has a load warning and a version warning
  69                   (search "MPFR" s))))))
  70
  71 (defun perform (defsystem)
  72   (let* ((specified-sources (getf defsystem :components))
  73          ;; This path is basically arbitrary. I wanted to avoid creating
  74          ;; another directory under "obj/" but alas ...
  75          (objdir (format nil "../../obj/from-self/contrib/~A/" *system*))
  76          (*features* (append '(:sb-building-contrib) *features*
  77                              sb-impl:+internal-features+)))
  78     (ensure-directories-exist objdir)
  79     ;; For source locations.
  80     ;; Even though generated files are not shipped as sources it's
  81     ;; better to hide the original pathnames.
  82     (push (list "SYS:OBJ;**;*.*.*"
  83                 (merge-pathnames "**/*.*" (truename "../../obj/")))
  84           (logical-pathname-translations "SYS"))
  85     (sb-int:collect ((alien-constants) (flattened-sources) (fasls))
  86       (with-open-file (f (merge-pathnames "module-setup.lisp" objdir)
  87                          :direction :output :if-exists :supersede)
  88         (format f "~{(require \"~A\")~%~}" *deps*))
  89       (flattened-sources `(t "module-setup"))
  90       ;; Compile all files serially. :depends-on is just documentation for the user
  91       (sb-int:named-let flatten ((prefix "") (sources specified-sources))
  92         (dolist (source sources)
  93           (ecase (car source)
  94             (:module
  95              (let* ((subdir (cadr source))
  96                     (pathname (getf source :pathname subdir))
  97                     (newprefix (if (string= pathname  "")
  98                                    prefix
  99                                    (concatenate 'string prefix subdir "/"))))
 100                (unless (string= pathname "")
 101                  (ensure-directories-exist (format nil "~A~A" objdir newprefix)))
 102                (flatten newprefix (getf source :components))))
 103             (:file
 104              (let ((if-feature (getf source :if-feature)))
 105                (when (or (not if-feature) (sb-int:featurep if-feature))
 106                  (flattened-sources
 107                   `(nil ,(concatenate 'string prefix (cadr source)))))))
 108             (:sb-grovel-constants-file
 109              ;; We don't run sb-grovel as a contrib module for building other modules.
 110              ;; sb-grovel interacts with ASDF when REQUIREd, but this script doesn't.
 111              (destructuring-bind (specfile &key package if-feature &allow-other-keys)
 112                  (cdr source)
 113                (assert package)
 114                (when (or (not if-feature) (sb-int:featurep if-feature))
 115                  (unless (alien-constants) ; add in a source file
 116                    (flattened-sources `(t ,+genfile+)))
 117                  (alien-constants (cons specfile package))))))))
 118       (with-open-file (f (merge-pathnames "module-provide.lisp" objdir)
 119                          :direction :output :if-exists :supersede)
 120         (format f "(provide \"~A\")~%" (string-upcase *system*)))
 121       (flattened-sources `(t "module-provide"))
 122
 123       (when (alien-constants)
 124         (load "../sb-grovel/defpackage") ; faster to interpret than compile
 125         (let ((*evaluator-mode* :compile)) (load "../sb-grovel/def-to-lisp"))
 126         (run-defs-to-lisp (alien-constants) ; specification files
 127                           (format nil "~A~A.lisp" objdir +genfile+)) ; file to generate
 128         ;; foreign-glue contains macros needed to compile the generated file
 129         (let ((*evaluator-mode* :compile)) (load "../sb-grovel/foreign-glue")))
 130       (let (wcu-warnings)
 131         (handler-bind (((and warning (not style-warning))
 132                         (lambda (c)
 133                           (unless (ignorable-warning-p c)
 134                             (push c wcu-warnings)))))
 135           (with-compilation-unit ()
 136             (loop for (generated-p stem) in (flattened-sources)
 137              do
 138                 (format t "Compile-File ~S~%" stem)
 139                 (multiple-value-bind (output warnings errors)
 140                     (compile-file (logicalize stem generated-p)
 141                                   :output-file (format nil "~A~A.fasl" objdir stem))
 142                   (when (or warnings errors) (sb-sys:os-exit 1))
 143                   (fasls output)
 144                   (load output)))))
 145         ;; Deferred warnings occur *after* exiting the W-C-U body.
 146         ;; See also lp#1078460 - "unknown variable" is not really ever resolved.
 147         (when wcu-warnings (sb-sys:os-exit 1)))
 148       (let ((outputs (mapcar 'namestring (fasls)))
 149             (joined (format nil "../../obj/sbcl-home/contrib/~A.fasl" *system*)))
 150         (ensure-directories-exist joined)
 151         (with-open-file (asd (merge-pathnames (make-pathname :type "asd") joined)
 152                              :direction :output :if-exists :supersede
 153                              :if-does-not-exist :create)
 154           (format asd "(defsystem :~A :class require-system)~%" *system*))
 155         (sb-sys:os-exit
 156          (process-status
 157           ;; for #+win32 it's probably /usr/bin/cat.exe,
 158           ;; for #+unix it's supposed to be /bin/cat, but lp#1995224 says otherwise
 159           (run-program "cat" outputs :search t
 160                        :output joined :if-output-exists :supersede)))))))
 161
 162 (compile 'perform)
 163 (let ((form (with-open-file (f (format nil "~A.asd" *system*))
 164               (let ((form (read f)))
 165                 ;; each .asd file has an ERROR form preventing users from LOADing it
 166                 (assert (eq (car form) 'error))
 167                 (read f)))))
 168   (let ((eval (getf form :eval)))
 169     (when eval (eval eval)))
 170   (let ((bindings (getf form :bind))
 171         (*compile-verbose* nil)) ; set the default
 172     (progv (mapcar 'first bindings) (mapcar 'second bindings)
 173       (perform form))))