Tue May 19 15:59:22 CEST 2009 Tobias Rautenkranz * Clozure CL save image diff -rN -u old-smoke/smoke.mbd new-smoke/smoke.mbd --- old-smoke/smoke.mbd 2014-10-01 11:42:53.000000000 +0200 +++ new-smoke/smoke.mbd 2014-10-01 11:42:54.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)) diff -rN -u old-smoke/src/clos.lisp new-smoke/src/clos.lisp --- old-smoke/src/clos.lisp 2014-10-01 11:42:53.000000000 +0200 +++ new-smoke/src/clos.lisp 2014-10-01 11:42:54.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) diff -rN -u old-smoke/src/utils/image/image.lisp new-smoke/src/utils/image/image.lisp --- old-smoke/src/utils/image/image.lisp 1970-01-01 01:00:00.000000000 +0100 +++ new-smoke/src/utils/image/image.lisp 2014-10-01 11:42:53.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))))) diff -rN -u old-smoke/src/utils/image/impl/ccl.lisp new-smoke/src/utils/image/impl/ccl.lisp --- 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-10-01 11:42:53.000000000 +0200 @@ -0,0 +1,4 @@ +(in-package :smoke) + +(defun add-startup-function (function) + (push function ccl:*lisp-startup-functions*)) diff -rN -u old-smoke/src/utils/image/impl/sbcl.lisp new-smoke/src/utils/image/impl/sbcl.lisp --- 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-10-01 11:42:53.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*)) diff -rN -u old-smoke/src/utils/image-sbcl.lisp new-smoke/src/utils/image-sbcl.lisp --- old-smoke/src/utils/image-sbcl.lisp 2014-10-01 11:42:53.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"))))) diff -rN -u old-smoke/src/utils/image.lisp new-smoke/src/utils/image.lisp --- old-smoke/src/utils/image.lisp 2014-10-01 11:42:53.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)) diff -rN -u old-smoke/src/utils/sbcl-bundle.lisp new-smoke/src/utils/sbcl-bundle.lisp --- old-smoke/src/utils/sbcl-bundle.lisp 1970-01-01 01:00:00.000000000 +0100 +++ new-smoke/src/utils/sbcl-bundle.lisp 2014-10-01 11:42:53.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"))))