Tue May 19 15:59:22 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>

* Clozure CL save image

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

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

@@ -62,9 +62,18 @@

(:utils module

(:needs "package")

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

- (:components "get-value"

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

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

+ (:components

+ "get-value"

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

+ (:image module

+ (:components

+ ("image" (:needs "impl"))

+ (:impl module

+ (:components

+ ("sbcl" (:for :sbcl))

+ ("ccl" (:for :openmcl))

+ ("not-implemented" (:for (:not

+ (:or :sbcl :openmcl)))))))))))))

+ (:supports (:os :linux) (:implementation :sbcl :openmcl))

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

- :alexandria

- :trivial-garbage :bordeaux-threads))

+ :alexandria :trivial-garbage :bordeaux-threads))

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

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

@@ -315,7 +315,10 @@

(declare (smoke-method smoke-method)

(optimize (speed 3)))

(symbol-function (lispify (name smoke-method) "CXX")))

-;(memoize:memoize-function 'get-gf-for-method)

+

+;(eval-startup (:execute)

+; (memoize:memoize-function 'get-gf-for-method)

+; (memoize:clear-memoized-function 'get-gf-for-method))

(defcallback dispatch-method :boolean

((binding :pointer)

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

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

@@ -0,0 +1,14 @@

+(in-package :smoke)

+

+(declaim (inline add-and-run-startup-function))

+(defun add-and-run-startup-function (function)

+ (add-startup-function function)

+ (funcall function))

+

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

+ "Runs BODY when it is loaded (when the source is loaded and also

+when the Lisp image is loaded)."

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

+ (add-and-run-startup-function #'(lambda ()

+ (let ((*package* ,*package*))

+ ,@body)))))

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

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

@@ -0,0 +1,4 @@

+(in-package :smoke)

+

+(defun add-startup-function (function)

+ (push function ccl:*lisp-startup-functions*))

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

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

@@ -0,0 +1,13 @@

+(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 run-startup-functions ()

+ (mapcar #'funcall *startup-functions*)))

+

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

+ (push #'run-startup-functions sb-ext:*init-hooks*))

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

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

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

-(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 2014-09-28 09:40:29.000000000 +0200

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

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

-(in-package :smoke)

-

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

- "Runs BODY when it is loaded."

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

- ,@body))

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

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

@@ -0,0 +1,85 @@

+(in-package :smoke)

+

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

+ (dolist (file extra-files)

+ (copy-file file (merge-pathnames bundle-dir file)))

+ (makeself dir bundle-dir file-name "sbcl-bundle"

+ "./run.sh"))))