Thu May 14 14:07:00 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>
* Dump Lisp image & make bundle with C wrapper libraries.
hunk ./smoke.mbd 34
- ("CMakeLists.txt" static-file)
hunk ./smoke.mbd 55
- ;; Make release-action add this files
- ("CMakeLists.txt" static-file)
- ("csmokebinding.h" static-file)
- ("csmokebinding.cpp" static-file)
- ("smoke-c.cpp" static-file)
-
hunk ./smoke.mbd 64
- (:components "get-value")))))
+ (:requires (:sb-posix (:for :sbcl)))
+ (:components "get-value"
+ ("image" (:for (:not :sbcl)))
+ ("image-sbcl" (:for :sbcl)))))))
hunk ./src/class-map.lisp 8
-(defmacro id-class-map (smoke)
- `(gethash (pointer-address ,smoke)
- *smoke-id-class-map*))
+
+(defun id-class-map (smoke)
+ (let ((value (gethash (pointer-address smoke)
+ *smoke-id-class-map*)))
+ (assert value [_$_]
+ ()
+ "Unknown smoke module ~A ~A."
+ smoke (smoke-get-module-name smoke))
+ value))
+
+(defun (setf id-class-map) (new-value smoke)
+ (setf (gethash (pointer-address smoke) *smoke-id-class-map*)
+ new-value))
hunk ./src/class-map.lisp 23
- (unless (nth-value 1 (id-class-map smoke))
- (setf (id-class-map smoke)
- (make-hash-table))))
+ (setf (id-class-map smoke)
+ (make-hash-table)))
hunk ./src/class-map.lisp 28
+ (declare (smoke-class smoke-class)
+ (smoke-standard-class class))
hunk ./src/clos.lisp 136
- ())
+ ((smoke :reader smoke-symbol :initarg :smoke-symbol
+ :type symbol)))
+
+(defmethod smoke ((class smoke-wrapper-class))
+ (eval (smoke-symbol class)))
hunk ./src/clos.lisp 185
- :smoke (smoke superclass)
+ :smoke (get-smoke-variable-for-pointer (smoke superclass))
hunk ./src/clos.lisp 202
- :smoke (smoke superclass)
+ :smoke (get-smoke-variable-for-pointer (smoke superclass))
hunk ./src/clos.lisp 214
- (declare (optimize (speed 3))
- (cffi:foreign-pointer smoke))
+ (declare (foreign-pointer smoke)
+ (optimize (speed 3)))
hunk ./src/cxx-method.lisp 89
- (remove-method (closer-mop:method-generic-function) method))))
+ (remove-method generic-function method))))
hunk ./src/method.lisp 20
- :type (make-instance 'smoke-type
+ :type (make-instance 'smoke-lazy-type
hunk ./src/method.lisp 22
- :smoke ,smoke))
+ :smoke ',smoke))
hunk ./src/method.lisp 24
- `(export (quote ,symbol)))))
+ symbol)))
hunk ./src/method.lisp 53
- `(export (quote ,name)))))
+ name)))
hunk ./src/method.lisp 55
-(defun ensure-generic-methods (symbols-names)
- "Ensures the generic functions for SYMBOLS-NAMES."
- (declare (list symbols-names)
- (optimize (speed 3)))
- (dolist (symbol-name symbols-names)
- (ensure-generic-function (first symbol-name)
- :cxx-name (rest symbol-name)
+(defun generic-method-definition (name cxx-name)
+ (values [_$_]
+ `(ensure-generic-function (quote ,name)
+ :cxx-name ,cxx-name
hunk ./src/method.lisp 61
- (export (first symbol-name) :CXX)))
+ name))
hunk ./src/method.lisp 92
+ (ensure-generics)
hunk ./src/method.lisp 95
+ (cxx-exports)
hunk ./src/method.lisp 141
+ (loop for name being the hash-key of generics
+ for cxx-name being the hash-value of generics do
+ (multiple-value-bind (definition export)
+ (generic-method-definition name cxx-name)
+ (push definition ensure-generics)
+ (push export cxx-exports)))
hunk ./src/method.lisp 149
- (eval-when (:load-toplevel :execute)
+ (eval-startup (:execute)
hunk ./src/method.lisp 151
- (ensure-generic-methods ',(hash-table-alist generics))
hunk ./src/method.lisp 152
+ (eval-when (:load-toplevel :execute)
+ ,@ensure-generics)
+ (export (quote ,cxx-exports) :cxx)
hunk ./src/method.lisp 156
- ,@exports)))
+ (export (quote ,exports)))))
hunk ./src/objects/class.lisp 28
+ (declare (function function)
+ (foreign-pointer smoke)
+ (optimize (speed 3)))
hunk ./src/objects/class.lisp 32
- :id 0
- :smoke smoke)))
- (loop for id from 1 to (1- (smoke-classes-size smoke)) do
+ :id 0
+ :smoke smoke)))
+ (loop for id from 1 to (1- (the fixnum (smoke-classes-size smoke))) do
hunk ./src/objects/enum.lisp 23
- :type (make-instance 'smoke::smoke-type
+ :type (make-instance 'smoke::smoke-lazy-type
hunk ./src/objects/enum.lisp 25
- :smoke ,(smoke::get-smoke-variable-for-pointer
+ :smoke ',(smoke::get-smoke-variable-for-pointer
hunk ./src/objects/type.lisp 7
+(defclass smoke-lazy-type (smoke::smoke-type)
+ ((id :reader smoke::id
+ :initarg :id)
+ (smoke :initarg :smoke
+ :reader smoke-symbol)))
+
+(defmethod smoke::smoke ((type smoke-lazy-type))
+ (eval (smoke-symbol type)))
hunk ./src/package.lisp 19
+ #:eval-startup
hunk ./src/package.lisp 37
- #:pointer))
+ #:pointer
+ #:define-smoke-module
+
+ #+sbcl #:save-bundle))
hunk ./src/package.lisp 60
-
-
-
-(in-package #:smoke)
hunk ./src/smoke.lisp 164
+(defmacro define-smoke-module (library (variable variable-name)
+ (init-function function-name))
+ "Define a Smoke module."
+ `(progn
+ (eval-startup (:compile-toplevel :execute)
+ (define-foreign-library ,library
+ (:unix ,(format nil "~(~A~).so.2" library))
+ (t (:default ,(format nil "~(~A~)" library))))
+ (use-foreign-library ,library)
+ (defcvar (,variable ,variable-name :read-only t) :pointer)
+ (defcfun (,init-function ,(format nil "_Z~A~Av" (length function-name)
+ function-name))
+ :void))
+ (eval-startup (:compile-toplevel :execute)
+ (,init-function)
+ (init ,variable))
+ (define-methods ,variable)))
+ [_$_]
+
addfile ./src/utils/image-sbcl.lisp
hunk ./src/utils/image-sbcl.lisp 1
+(in-package :smoke)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defvar *startup-functions* nil
+ "Functions to run (in order) on startup.")
+
+ (defun add-startup-function (function)
+ (setf *startup-functions*
+ (nconc *startup-functions* (list function))))
+
+ (defun add-and-run-startup-function (function)
+ (add-startup-function function)
+ (funcall function))
+
+ (defun run-startup-functions ()
+ (mapcar #'funcall *startup-functions*)))
+
+(eval-when (:load-toplevel :execute)
+ (push #'run-startup-functions sb-ext:*init-hooks*))
+
+(defmacro eval-startup ((&rest situations) &body body)
+ "Runs BODY when it is loaded."
+ `(eval-when (,@situations :load-toplevel)
+ (add-and-run-startup-function #'(lambda ()
+ (let ((*package* ,*package*))
+ ,@body)))))
+
+(defun strip-foreign-libraries-path ()
+ (dolist (library sb-alien::*shared-objects*)
+ (setf (slot-value library 'namestring)
+ (file-namestring (slot-value library 'pathname)))))
+
+(defun make-temporary-directory ()
+ (pathname (concatenate 'string (sb-posix:mkdtemp "/tmp/cl-smokeXXXXXX")
+ "/")))
+
+(defmacro with-temporary-directory ((directory) &body body)
+ "Binds DIRECTORY to the pathname of a temporary directory and executes body:"
+ `(let ((,directory (make-temporary-directory)))
+ (unwind-protect (progn ,@body)
+ (unless (zerop
+ (sb-ext:process-exit-code
+ (sb-ext:run-program "/bin/rm"
+ (list "-r" (namestring ,directory)))))
+ (cerror "ignore"
+ "could not remove temponary directory ~A"
+ ,directory)))))
+ [_$_]
+(defun save-image (file-name &rest options &key &allow-other-keys)
+ "Save the lisp image in FILE-NAME."
+ (let ((pid (sb-posix:fork)))
+ (if (= 0 pid)
+ (progn
+ (strip-foreign-libraries-path)
+ (apply #'sb-ext:save-lisp-and-die file-name :executable t
+ options))
+ (sb-posix:waitpid pid 0))))
+
+(defun write-shell-wrapper (pathname core-name)
+ (with-open-file (stream pathname :direction :output)
+ (format stream "#!/bin/sh
+cd `dirname \"$0\"`
+LD_LIBRARY_PATH=./ exec -a \"$0\" ./~A $@
+" core-name))
+ (sb-posix:chmod pathname #o0755))
+
+(defun make-tarball (run-directory tarball-pathname &rest pathnames)
+ (flet ((arguments (&rest args)
+ (format nil "~{~A ~}" args)))
+ (unless (zerop
+ (sb-ext:process-exit-code
+ (sb-ext:run-program
+ "/bin/sh"
+ (list "-c"
+ (apply #'arguments
+ "cd " (namestring run-directory) " && "
+ "tar -cvjf " (namestring tarball-pathname)
+ " --strip 2 "
+ (mapcar #'namestring pathnames))))))
+ (error "Create tarball ~A failed." tarball-pathname))))
+
+(defun makeself (run-directory directory-name file-name label [_$_]
+ &optional (startup-script "") &rest args)
+ "Make self-extractable archives on Unix
+http://megastep.org/makeself/"
+ ;; make an absolute pathname sine we change the directory.
+ (let ((file-name (merge-pathnames file-name)))
+ (flet ((arguments (&rest args)
+ (format nil "~{~A ~}" args)))
+ (unless (zerop
+ (sb-ext:process-exit-code
+ (sb-ext:run-program
+ "/bin/sh"
+ (list "-c"
+ (apply #'arguments
+ "cd " (namestring run-directory) " && "
+ "makeself --nox11" (namestring directory-name)
+ (namestring file-name) label
+ startup-script args)))))
+ (error "Create ~A failed." file-name)))))
+
+(defun save-bundle (file-name &optional extra-files &rest options &key &allow-other-keys)
+ "Creates a FILE-NAME.tar.bz2 in the current directory.
+This bundle contains a dumped image, the wrapper libraries and a
+script to run in. OPTIONS is passed to SB-EXT:SAVE-LISP-AND-DIE."
+ (with-temporary-directory (dir)
+ (let ((bundle-dir (merge-pathnames (make-pathname :directory
+ (list :relative file-name))
+ dir)))
+ (sb-posix:mkdir bundle-dir #o0755)
+ (dolist (library sb-alien::*shared-objects*)
+ (sb-ext:run-program
+ "/bin/cp" (list (namestring (slot-value library 'pathname))
+ (namestring bundle-dir))))
+ (apply #'save-image (namestring (make-pathname :name "sbcl-core"
+ :defaults bundle-dir))
+ options)
+ (write-shell-wrapper (make-pathname :defaults bundle-dir
+ :name "run"
+ :type "sh")
+ "sbcl-core")
+;; (make-tarball dir (concatenate 'string file-name ".tar.bz2")
+;; file-name)
+ (dolist (file extra-files)
+ (copy-file file (merge-pathnames bundle-dir file)))
+ (makeself dir bundle-dir file-name "sbcl-bundle"
+ "./run.sh"))))
+;; (copy-file (make-pathname :defaults dir
+;; :name (concatenate 'string file-name ".tar")
+;; :type "bz2")
+; (concatenate 'string file-name ".tar.bz2")))))
addfile ./src/utils/image.lisp
hunk ./src/utils/image.lisp 1
+(in-package :smoke)
+
+(defmacro eval-startup ((&rest situations) &body body)
+ "Runs BODY when it is loaded."
+ `(eval-when (,@situations :load-toplevel)
+ ,@body))
addfile ./test-bundle.sh
hunk ./test-bundle.sh 1
+#!/bin/sh
+if [[ $# -ne 0 ]]; then
+ echo "Test cl-smoke bundle creation."
+ echo "Usage: $0"
+ exit 1
+fi
+
+sbcl --eval '(mb:load :qt.tests)' \
+ --eval '(smoke:save-bundle "qt.test.run")' \
+ --eval '(quit)' || exit 1
+
+echo "(progn (5am:run!) (quit))" | ./qt.test.run [_$_]
hunk ./test.lisp 2
-exec -a "$0" sbcl --noinform --noprint --disable-debugger --load $0 --end-toplevel-options "$@"
+sbcl --noinform --noprint --disable-debugger --load $0 --end-toplevel-options "$@" || exit 1
+sh ./test-bundle.sh || exit 2
+exit 0