diff --git a/src/CHANGELOG b/src/CHANGELOG index 57808e82e..b91930222 100644 --- a/src/CHANGELOG +++ b/src/CHANGELOG @@ -108,6 +108,11 @@ ECL 0.9i OpenBSD & Ubuntu. You may need to supply appropiate LDFLAGS & CFLAGS for the configuration to detect the headers. + - ECL now can compile files with constants that do not print readably, such as + CLOS objects. In those cases, MAKE-LOAD-FORM is used to recreate these + constants. The only case where this fail is when the "unreadable" constant + is part of a circular structure (contributed by Brian Spilsbury). + * MOP compatibility: - SLOT-VALUE, SLOT-BOUNDP, etc, together with MOP SLOT*-USING-CLASS generic diff --git a/src/clos/print.lsp b/src/clos/print.lsp index 7c212aa04..5f1bf0092 100644 --- a/src/clos/print.lsp +++ b/src/clos/print.lsp @@ -12,6 +12,11 @@ ;;; ---------------------------------------------------------------------- ;;; Load forms ;;; +;;; ECL extends the ANSI specification by allowing to use MAKE-LOAD-FORM on any +;;; kind of lisp object. The only caveats is that ECL currently does not +;;; support circularity when the object has to be externalized using lisp +;;; forms. For instance something like #1=(# #1#). +;;; (defun make-load-form-saving-slots (object &key slot-names environment) (declare (ignore environment)) @@ -32,42 +37,66 @@ initialization))))) (defun need-to-make-load-form-p (object) - (typecase object - ((or character number symbol pathname string bit-vector) - nil) - ((array) - (unless (subtypep (array-element-type object) '(or character number)) - (dotimes (i (array-total-size object) nil) - (when (need-to-make-load-form-p (row-major-aref object i)) - (return-from need-to-make-load-form-p t))))) - ((cons) - (or (need-to-make-load-form-p (car object)) - (and (cdr object) - (need-to-make-load-form-p (cdr object))))) - (t - t))) + "Return T if the object cannot be externalized using the lisp +printer and we should rather use MAKE-LOAD-FORM." + (let ((*load-form-cache* nil)) + (declare (special *load-form-cache*)) + (labels ((recursive-test (object) + ;; For simple, atomic objects we just return NIL. There is no need to + ;; call MAKE-LOAD-FORM on them + (when (typep object '(or character number symbol pathname string bit-vector)) + (return-from recursive-test nil)) + ;; For complex objects we set up a cache and run through the + ;; objects content looking for data that might require + ;; MAKE-LOAD-FORM to be externalized. The cache is used to + ;; solve the problem of circularity and of EQ references. The + ;; solution is however bad: we cannot have circular structrures + ;; and at the same time use MAKE-LOAD-FORM. + (let ((output 'null)) + (if *load-form-cache* + (setf output (gethash object *load-form-cache* 'null)) + (setf *load-form-cache* (make-hash-table :size 128 :test #'eql))) + (cond ((eq output nil) + (return-from recursive-test nil)) + ((eq output t) + (error "MAKE-LOAD-FORM cannot handle circular structures") + (return-from recursive-test t)) + ((typep object 'array) + (unless (subtypep (array-element-type object) '(or character number)) + (dotimes (i (array-total-size object) (setf output nil)) + (when (need-to-make-load-form-p (row-major-aref object i)) + (setf output t) + (return))))) + ((consp object) + (setf output (or (recursive-test (car object)) + (and (cdr object) (recursive-test (cdr object)))))) + (t + (setf output t))) + (setf (gethash object *load-form-cache*) output) + output))) + (recursive-test object)))) (defmethod make-load-form ((object t) &optional environment) (unless (need-to-make-load-form-p object) (return-from make-load-form (if (consp object) `',object object))) (typecase object (array - `(make-array ,(array-dimensions object) - :element-type ,(array-element-type object) - :adjustable ,(array-adjustable-p object) - :initial-data - ,(loop for i from 0 by (array-total-size object) + `(make-array ',(array-dimensions object) + :element-type ',(array-element-type object) + :adjustable ',(adjustable-array-p object) + :initial-contents + ',(loop for i from 0 below (array-total-size object) collect (make-load-form (row-major-aref object i))))) (cons - (do* ((x object) + (do* ((x object (rest x)) (out '())) ((atom x) (progn - (setf out (mapcar #'make-load-form (nreverse out))) + (setf out (mapcar #'(lambda (form) `',form) (nreverse out))) (if x - `(list* ,out ,(make-load-form x)) - `(list ,out)))) - (push x out))) + `(list* ,@out ',x) + `(list ,@out)))) + (push (first x) out))) (hash-table (values `(make-hash-table :size ,(hash-table-size object) diff --git a/src/cmp/cmpct.lsp b/src/cmp/cmpct.lsp index 264d45a5c..f2e0c2a59 100644 --- a/src/cmp/cmpct.lsp +++ b/src/cmp/cmpct.lsp @@ -13,7 +13,7 @@ (defvar +optimizable-constant+ '()) -(defun c1constant-value (val always-p) +(defun c1constant-value (val &key always only-small-values) (cond ((let ((x (assoc val +optimizable-constant+))) (and x (c1expr (cdr x))))) @@ -30,9 +30,10 @@ ((typep val 'SHORT-FLOAT) (make-c1form* 'LOCATION :type 'SHORT-FLOAT :args (list 'SHORT-FLOAT-VALUE val (add-object val)))) - (always-p + (always (make-c1form* 'LOCATION :type (object-type val) :args (list 'VV (add-object val)))) + (only-small-values nil) (t nil))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/src/cmp/cmpdefs.lsp b/src/cmp/cmpdefs.lsp index 5e9fe585d..f9ac13a0e 100644 --- a/src/cmp/cmpdefs.lsp +++ b/src/cmp/cmpdefs.lsp @@ -445,6 +445,8 @@ coprocessor).") ;;; --cmptop.lsp-- ;;; +(defvar *compiler-phase* nil) + (defvar *volatile*) (defvar *setjmps* 0) @@ -463,6 +465,7 @@ lines are inserted, but the order is preserved") ; or *temporary-objects* (defvar *permanent-objects* nil) ; holds { ( object (VV vv-index) ) }* (defvar *temporary-objects* nil) ; holds { ( object (VV vv-index) ) }* +(defvar *load-objects* nil) ; hash with association object -> vv-location (defvar *load-time-values* nil) ; holds { ( vv-index form ) }*, ;;; where each vv-index should be given an object before ;;; defining the current function during loading process. @@ -480,6 +483,9 @@ lines are inserted, but the order is preserved") (defvar *linking-calls* nil) ; holds { ( global-fun-name fun symbol c-fun-name var-name ) }* (defvar *local-funs* nil) ; holds { fun }* (defvar *top-level-forms* nil) ; holds { top-level-form }* +(defvar *make-forms* nil) ; holds { top-level-form }* +(defvar *init-forms* nil) ; holds { top-level-form }* + ;;; ;;; top-level-form: ;;; ( 'DEFUN' fun-name cfun lambda-expr doc-vv sp ) diff --git a/src/cmp/cmpenv.lsp b/src/cmp/cmpenv.lsp index ebfb72e02..ff011fdd7 100644 --- a/src/cmp/cmpenv.lsp +++ b/src/cmp/cmpenv.lsp @@ -17,12 +17,16 @@ ;;; included in the compiled code. The default value is OFF. (defun init-env () + (setq *compiler-phase* 't1) (setq *callbacks* nil) (setq *max-temp* 0) (setq *temp* 0) (setq *next-cmacro* 0) (setq *next-cfun* 0) (setq *last-label* 0) + (setq *load-objects* (make-hash-table :size 128 :test #'eql)) + (setq *make-forms* nil) + (setq *init-forms* nil) (setq *permanent-objects* nil) (setq *temporary-objects* nil) (setq *local-funs* nil) diff --git a/src/cmp/cmpeval.lsp b/src/cmp/cmpeval.lsp index 76f7f8b07..c8bc8f122 100644 --- a/src/cmp/cmpeval.lsp +++ b/src/cmp/cmpeval.lsp @@ -24,7 +24,7 @@ (make-c1form* 'LOCATION :type (object-type form) :args (add-symbol form))) ((constantp form) - (or (c1constant-value (symbol-value form) nil) + (or (c1constant-value (symbol-value form) :only-small-values t) (c1var form))) (t (c1var form)))) ((consp form) @@ -34,7 +34,7 @@ ((and (consp fun) (eq (car fun) 'LAMBDA)) (c1funcall form)) (t (cmperr "~s is not a legal function name." fun))))) - (t (c1constant-value form t))))) + (t (c1constant-value form :always t))))) (if (eq form '*cmperr-tag*) (c1nil) form)) diff --git a/src/cmp/cmpspecial.lsp b/src/cmp/cmpspecial.lsp index b663da93c..50fc71e2a 100644 --- a/src/cmp/cmpspecial.lsp +++ b/src/cmp/cmpspecial.lsp @@ -15,7 +15,7 @@ (defun c1quote (args) (check-args-number 'QUOTE args 1 1) - (c1constant-value (car args) t)) + (c1constant-value (car args) :always t)) (defun c1declare (args) (cmperr "The declaration ~s was found in a bad place." (cons 'DECLARE args))) diff --git a/src/cmp/cmptop.lsp b/src/cmp/cmptop.lsp index ff8d7658f..acb06e65a 100644 --- a/src/cmp/cmptop.lsp +++ b/src/cmp/cmptop.lsp @@ -157,8 +157,10 @@ (wt-nl "memcpy(VV, data->vector.self.t, VM*sizeof(cl_object));}")) (wt-nl "VVtemp = Cblock->cblock.temp_data;") + (setq *compiler-phase* 't2) + ;; useless in initialization. - (dolist (form *top-level-forms*) + (dolist (form (append (nreverse *make-forms*) (nreverse *init-forms*) *top-level-forms*)) (let ((*compile-to-linking-call* nil) (*env* 0) (*level* 0) (*temp* 0)) (t2expr form)) @@ -207,6 +209,8 @@ (wt-nl1 "static cl_object " c-name "(cl_narg narg, ...)" "{TRAMPOLINK(narg," lisp-name ",&" var-name ",Cblock);}"))) + (setq *compiler-phase* 't3) + ;;; Callbacks (when *callbacks* (wt-h "#include ") @@ -445,6 +449,18 @@ (c2expr form) (wt-label *exit*))) +(defun t2make-form (vv-loc form) + (let* ((*exit* (next-label)) (*unwind-exit* (list *exit*)) + (*destination* vv-loc)) + (c2expr form) + (wt-label *exit*))) + +(defun t2init-form (vv-loc form) + (let* ((*exit* (next-label)) (*unwind-exit* (list *exit*)) + (*destination* 'TRASH)) + (c2expr form) + (wt-label *exit*))) + (defun t2decl-body (decls body) (let ((*safety* *safety*) (*space* *space*) @@ -669,4 +685,6 @@ (put-sysprop 'PROGN 'T2 #'t2progn) (put-sysprop 'ORDINARY 'T2 #'t2ordinary) (put-sysprop 'LOAD-TIME-VALUE 'T2 't2load-time-value) +(put-sysprop 'MAKE-FORM 'T2 't2make-form) +(put-sysprop 'INIT-FORM 'T2 't2init-form) (put-sysprop 'SI:FSET 'C2 'c2fset) diff --git a/src/cmp/cmptype.lsp b/src/cmp/cmptype.lsp index 1cbe09551..794cdbfbc 100644 --- a/src/cmp/cmptype.lsp +++ b/src/cmp/cmptype.lsp @@ -201,7 +201,7 @@ (long-float . 0.0L1) (short-float . 0.0S1)) :test #'subtypep)))) (if new-value - (c1constant-value new-value nil) + (c1constant-value new-value :only-small-values t) (c1nil)))) ;;---------------------------------------------------------------------- diff --git a/src/cmp/cmpwt.lsp b/src/cmp/cmpwt.lsp index 92e08b940..14c46a756 100644 --- a/src/cmp/cmpwt.lsp +++ b/src/cmp/cmpwt.lsp @@ -126,8 +126,13 @@ *temporary-objects* (make-array 128 :adjustable t :fill-pointer 0)))) (defun data-get-all-objects () - (nconc (map 'list #'first *permanent-objects*) - (map 'list #'first *temporary-objects*))) + ;; We collect all objects that are to be externalized, but filter out + ;; those which will be created by a lisp form. + (loop for i in (nconc (map 'list #'first *permanent-objects*) + (map 'list #'first *temporary-objects*)) + collect (if (gethash i *load-objects*) + 0 + i))) (defun data-dump (stream &optional as-lisp-file &aux must-close) (etypecase stream @@ -181,6 +186,20 @@ (defun data-empty-loc () (add-object 0 :duplicate t :permanent t)) +(defun add-load-form (object location) + (when (and (not (gethash object *load-objects*)) + (clos::need-to-make-load-form-p object)) + (if (not (eq *compiler-phase* 't1)) + (cmperr "Unable to internalize complex object ~A in ~a phase" object *compiler-phase*) + (multiple-value-bind (make-form init-form) (make-load-form object) + (setf (gethash object *load-objects*) location) + (let* ((make (and make-form + (make-c1form* 'MAKE-FORM :args location (c1expr make-form)))) + (init (and init-form + (make-c1form* 'INIT-FORM :args location (c1expr init-form))))) + (push make *make-forms*) + (push init *init-forms*)))))) + (defun add-object (object &key (duplicate nil) (permanent (or (symbolp object) *permanent-data*))) (when (and (not *compiler-constants*) (typep object '(or function package))) @@ -207,6 +226,8 @@ (t (setq x (list vv next-ndx)) (vector-push-extend (list object x next-ndx) array) + (unless *compiler-constants* + (add-load-form object x)) x)))) (defun add-symbol (symbol)