Thu May 14 14:07:00 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>

* Dump Lisp image & make bundle with C wrapper libraries.

--- old-smoke/smoke.mbd 2014-09-28 09:40:24.000000000 +0200

+++ new-smoke/smoke.mbd 2014-09-28 09:40:25.000000000 +0200

@@ -31,7 +31,6 @@

(:src module

(:needs "CMakeLists")

(:components

- ("CMakeLists.txt" static-file)

"package"

("translate" (:needs "package"))

("using-type" (:needs "package"))

@@ -53,12 +52,6 @@

(:components ("libsmoke-c" cmake-library)

("libsmoke-c-util" cmake-library)

- ;; Make release-action add this files

- ("CMakeLists.txt" static-file)

- ("csmokebinding.h" static-file)

- ("csmokebinding.cpp" static-file)

- ("smoke-c.cpp" static-file)

-

("smoke-c" (:needs "libsmoke-c"

"libsmoke-c-util"))

("class" (:needs "smoke-c"))

@@ -68,7 +61,10 @@

(:utils module

(:needs "package")

- (:components "get-value")))))

+ (:requires (:sb-posix (:for :sbcl)))

+ (:components "get-value"

+ ("image" (:for (:not :sbcl)))

+ ("image-sbcl" (:for :sbcl)))))))

(:needs :sysdef.cmake :cffi :closer-mop

:alexandria

:trivial-garbage :bordeaux-threads))

--- old-smoke/src/class-map.lisp 2014-09-28 09:40:24.000000000 +0200

+++ new-smoke/src/class-map.lisp 2014-09-28 09:40:25.000000000 +0200

@@ -5,17 +5,28 @@

"Maps a Smoke module pointer - id pair to a class.")

;; FIXME disallow adding a class when threads are running or add a lock.

-(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))

(defun add-id-class-map (smoke)

- (unless (nth-value 1 (id-class-map smoke))

- (setf (id-class-map smoke)

- (make-hash-table))))

+ (setf (id-class-map smoke)

+ (make-hash-table)))

(defun add-id (smoke-class class)

"Associates the CLOS class CLASS with SMOKE-CLASS."

+ (declare (smoke-class smoke-class)

+ (smoke-standard-class class))

(setf (gethash (id smoke-class)

(id-class-map (smoke smoke-class)))

class))

--- old-smoke/src/clos.lisp 2014-09-28 09:40:24.000000000 +0200

+++ new-smoke/src/clos.lisp 2014-09-28 09:40:25.000000000 +0200

@@ -133,7 +133,11 @@

(:documentation "A Smoke C++ class"))

(defclass smoke-wrapper-class (smoke-standard-class)

- ())

+ ((smoke :reader smoke-symbol :initarg :smoke-symbol

+ :type symbol)))

+

+(defmethod smoke ((class smoke-wrapper-class))

+ (eval (smoke-symbol class)))

(defclass cxx:class (smoke-wrapper-class)

()

@@ -178,7 +182,7 @@

(apply

#'call-next-method class

:id (id superclass)

- :smoke (smoke superclass)

+ :smoke (get-smoke-variable-for-pointer (smoke superclass))

:direct-superclasses direct-superclasses

args)))

@@ -195,7 +199,7 @@

(apply

#'call-next-method class

:id (id superclass)

- :smoke (smoke superclass)

+ :smoke (get-smoke-variable-for-pointer (smoke superclass))

:direct-superclasses direct-superclasses

args)))

@@ -207,8 +211,8 @@

(defun make-smoke-classes (smoke)

"Construts a lisp class for each one in the Smoke module SMOKE."

- (declare (optimize (speed 3))

- (cffi:foreign-pointer smoke))

+ (declare (foreign-pointer smoke)

+ (optimize (speed 3)))

(add-id-class-map smoke)

(map-classes

#'(lambda (class)

--- old-smoke/src/cxx-method.lisp 2014-09-28 09:40:24.000000000 +0200

+++ new-smoke/src/cxx-method.lisp 2014-09-28 09:40:25.000000000 +0200

@@ -86,7 +86,7 @@

"Removes METHOD from its generic-function."

(let ((generic-function (closer-mop:method-generic-function method)))

(when generic-function

- (remove-method (closer-mop:method-generic-function) method))))

+ (remove-method generic-function method))))

;(when (null (closer-mop:generic-function-methods generic-function))

; TODO

--- old-smoke/src/method.lisp 2014-09-28 09:40:24.000000000 +0200

+++ new-smoke/src/method.lisp 2014-09-28 09:40:25.000000000 +0200

@@ -17,11 +17,11 @@

`(define-constant ,symbol

(make-instance 'enum

:value ,(enum-call method)

- :type (make-instance 'smoke-type

+ :type (make-instance 'smoke-lazy-type

:id ,(id (return-type method))

- :smoke ,smoke))

+ :smoke ',smoke))

:test #'enum=)

- `(export (quote ,symbol)))))

+ symbol)))

(defun static-method-symbol (method)

"Returns the lisp symbol for the static method METHOD."

@@ -50,18 +50,15 @@

,(if (< argument-count 0)

'args

`(list ,@(make-lambda argument-count)))))

- `(export (quote ,name)))))

+ name)))

-(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

:generic-function-class 'smoke-gf

:lambda-list '(object &rest args))

- (export (first symbol-name) :CXX)))

+ name))

(defun setf-method-definition (method)

`(defun (setf ,(lispify (subseq (name method) 3) :cxx)) (new-value object)

@@ -92,8 +89,10 @@

(let ((generics (make-hash-table))

(constants)

(functions)

+ (ensure-generics)

(function-symbols (make-hash-table))

(setf-function-symbols (make-hash-table))

+ (cxx-exports)

(exports))

(map-methods

#'(lambda (method)

@@ -139,12 +138,20 @@

-1))

(push definition functions)

(push export exports))))

+ (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)))

`(progn (check-recompile ,smoke)

,@functions

- (eval-when (:load-toplevel :execute)

+ (eval-startup (:execute)

(register-smoke-module-var (quote ,smoke))

- (ensure-generic-methods ',(hash-table-alist generics))

(make-smoke-classes ,smoke))

+ (eval-when (:load-toplevel :execute)

+ ,@ensure-generics)

+ (export (quote ,cxx-exports) :cxx)

,@constants

- ,@exports)))

+ (export (quote ,exports)))))

--- old-smoke/src/objects/class.lisp 2014-09-28 09:40:24.000000000 +0200

+++ new-smoke/src/objects/class.lisp 2014-09-28 09:40:25.000000000 +0200

@@ -25,10 +25,13 @@

(defun map-classes (function smoke)

"Applys FUNCTION to the classes of SMOKE."

+ (declare (function function)

+ (foreign-pointer smoke)

+ (optimize (speed 3)))

(let ((class (make-instance 'smoke-class

- :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

(setf (slot-value class 'id) id)

(funcall function class))))

--- old-smoke/src/objects/enum.lisp 2014-09-28 09:40:24.000000000 +0200

+++ new-smoke/src/objects/enum.lisp 2014-09-28 09:40:25.000000000 +0200

@@ -20,9 +20,9 @@

(declare (ignore environment))

`(make-instance 'enum

:value ,(value enum)

- :type (make-instance 'smoke::smoke-type

+ :type (make-instance 'smoke::smoke-lazy-type

:id ,(id (enum-type enum))

- :smoke ,(smoke::get-smoke-variable-for-pointer

+ :smoke ',(smoke::get-smoke-variable-for-pointer

(smoke::smoke (enum-type enum))))))

(defmethod print-object ((enum enum) stream)

--- old-smoke/src/objects/type.lisp 2014-09-28 09:40:24.000000000 +0200

+++ new-smoke/src/objects/type.lisp 2014-09-28 09:40:25.000000000 +0200

@@ -4,6 +4,14 @@

()

(:documentation "A type"))

+(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)))

(defmethod get-struct-slot-value ((type smoke-type) slot-name)

(foreign-slot-value (smoke-get-type (smoke type) (id type))

--- old-smoke/src/package.lisp 2014-09-28 09:40:24.000000000 +0200

+++ new-smoke/src/package.lisp 2014-09-28 09:40:25.000000000 +0200

@@ -16,6 +16,7 @@

#:get-smoke-variable-for-pointer

#:make-smoke-classes

+ #:eval-startup

#:new-object

#:delete-object

@@ -33,7 +34,10 @@

#:define-from-lisp-translation

#:make-cleanup-pointer

- #:pointer))

+ #:pointer

+ #:define-smoke-module

+

+ #+sbcl #:save-bundle))

(defpackage #:cxx

(:use) ;; do not use #:cl

@@ -53,7 +57,3 @@

#:1-

#:aref))

-

-

-

-(in-package #:smoke)

--- old-smoke/src/smoke.lisp 2014-09-28 09:40:24.000000000 +0200

+++ new-smoke/src/smoke.lisp 2014-09-28 09:40:25.000000000 +0200

@@ -161,6 +161,25 @@

(signature method))))

smoke))

+(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)))

+

+

(defun fgrep-classes (smoke str)

(map-classes #'(lambda (class)

(when (search str (name class))

--- old-smoke/src/utils/image-sbcl.lisp 1970-01-01 01:00:00.000000000 +0100

+++ new-smoke/src/utils/image-sbcl.lisp 2014-09-28 09:40:25.000000000 +0200

@@ -0,0 +1,131 @@

+(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")))))

--- old-smoke/src/utils/image.lisp 1970-01-01 01:00:00.000000000 +0100

+++ new-smoke/src/utils/image.lisp 2014-09-28 09:40:25.000000000 +0200

@@ -0,0 +1,6 @@

+(in-package :smoke)

+

+(defmacro eval-startup ((&rest situations) &body body)

+ "Runs BODY when it is loaded."

+ `(eval-when (,@situations :load-toplevel)

+ ,@body))

--- old-smoke/test-bundle.sh 1970-01-01 01:00:00.000000000 +0100

+++ new-smoke/test-bundle.sh 2014-09-28 09:40:25.000000000 +0200

@@ -0,0 +1,12 @@

+#!/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

--- old-smoke/test.lisp 2014-09-28 09:40:24.000000000 +0200

+++ new-smoke/test.lisp 2014-09-28 09:40:25.000000000 +0200

@@ -1,5 +1,7 @@

#|

-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

# do not use --script to allow loading mudballs with ${HOME}/.sbclrc

# Used for testing on darcs record.

|#