Commit ee50a03e authored by jgarcia's avatar jgarcia
Browse files

Use MAKE-LOAD-FORM to compile constants that do not have a readable printed...

Use MAKE-LOAD-FORM to compile constants that do not have a readable printed representation (Brian Spilsbury)
parent af4a6e3c
......@@ -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
......
......@@ -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=(#<a class> #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)
......
......@@ -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)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
......
......@@ -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 )
......
......@@ -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)
......
......@@ -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))
......
......@@ -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)))
......
......@@ -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 <ecl/internal.h>")
......@@ -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)
......@@ -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))))
;;----------------------------------------------------------------------
......
......@@ -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)
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment