Commit 524f0792 authored by Juan Jose Garcia Ripoll's avatar Juan Jose Garcia Ripoll
Browse files

VV/VV-TEMP locations are now structures

parent e5e835ab
......@@ -27,14 +27,8 @@
(defun wt-h1 (form)
(if (consp form)
(let ((fun (gethash (car form) *wt-loc-dispatch-table*)))
(if fun
(let ((*compiler-output1* *compiler-output2*))
(apply fun (cdr form)))
(cmperr "The location ~s is undefined." form)))
(princ form *compiler-output2*))
(let ((*compiler-output1* *compiler-output2*))
(wt1 form)))
(defun wt (&rest forms)
(mapc #'wt1 forms))
......@@ -68,12 +68,12 @@
(single-float 'single-float-value)
(double-float 'double-float-value)
(long-float 'long-float-value)))
(location `(VV ,c-value)))
(location (make-vv :location c-value)))
(cons value (make-c1form* 'LOCATION :type type
:args (list loc-type value location)))))
(cons name (make-c1form* 'LOCATION :type (type-of name)
:args `(VV ,c-value)))))
:args (make-vv :location c-value)))))
......@@ -76,6 +76,8 @@
((stringp loc)
((vv-p loc)
((member loc '(value0 values va-arg cl-va-arg))
((atom loc)
......@@ -103,17 +105,19 @@
(values t nil))
((ext:fixnump loc)
(values t loc))
((atom loc)
(values nil nil))
((or (eq (setf head (car loc)) 'VV)
(eq head 'VV-TEMP))
((vv-p loc)
(let ((value (vt-loc-value loc)))
(if (ext:fixnump value)
(if (or (null value) (ext:fixnump value))
(values nil nil)
(values t value))))
((atom loc)
(values nil nil))
((member head '(fixnum-value character-value long-float-value
double-float-value single-float-value))
(values t (second loc)))))
(values t (second loc)))
(values nil nil))))
(defun set-loc (loc &aux fd)
(when (eql *destination* loc)
......@@ -145,6 +149,8 @@
(t (cond
((var-p *destination*)
(set-var loc *destination*))
((vv-p *destination*)
(set-vv loc *destination*))
((or (not (consp *destination*))
(not (symbolp (car *destination*))))
......@@ -173,7 +179,9 @@
(wt "value0"))
((var-p loc)
(wt-var loc))
((or (not (consp loc))
((vv-p loc)
(wt-vv loc))
((or (atom loc)
(not (symbolp (car loc))))
(baboon :format-control "Unknown location found in WT-LOC~%~S"
:format-arguments (list loc)))
......@@ -197,16 +205,6 @@
(defun wt-lcl (lcl) (unless (numberp lcl) (baboon)) (wt "V" lcl))
(defun wt-vv (vv &optional object)
(if (numberp vv)
(wt "VV[" vv "]")
(wt vv)))
(defun wt-vv-temp (vv &optional object)
(if (numberp vv)
(wt "VVtemp[" vv "]")
(wt vv)))
(defun wt-lcl-loc (lcl &optional type)
(wt-lcl lcl))
......@@ -108,8 +108,6 @@
(temp . wt-temp)
(lcl . wt-lcl-loc)
(vv . wt-vv)
(vv-temp . wt-vv-temp)
(car . wt-car)
(cdr . wt-cdr)
(cadr . wt-cadr)
......@@ -810,6 +810,8 @@
(maxarg (fun-maxarg fun))
(narg (if (= minarg maxarg) maxarg nil)))
(format stream "~%{0,0,~D,0,MAKE_FIXNUM(~D),MAKE_FIXNUM(~D),(cl_objectfn)~A,Cnil,MAKE_FIXNUM(~D)},"
(or narg -1) (second loc) (second fname-loc)
(or narg -1)
(vv-location loc)
(vv-location fname-loc)
cfun (fun-file-position fun))))
(format stream "~%};")))))
......@@ -248,3 +248,19 @@
(toplevel-form nil)
(file nil)
(file-position 0))
(defstruct (vv :named (:type list))
(location nil)
(used nil))
(defstruct (vv-temp :named (:type list))
(location nil)
(used nil))
(defstruct vv
(location nil)
(used nil))
(defstruct (vv-temp (:include vv)))
......@@ -46,6 +46,11 @@
(defun data-get-all-objects ()
;; We collect all objects that are to be externalized, but filter out
;; those which will be created by a lisp form.
(loop for array in (list *permanent-objects* *temporary-objects*)
do (loop for (object vv-record . rest) across array
do (unless (vv-used vv-record)
(cmpwarn "Object found in array but not used~%~A"
(loop for i in (nconc (map 'list #'first *permanent-objects*)
(map 'list #'first *temporary-objects*))
collect (if (gethash i *load-objects*)
......@@ -113,16 +118,17 @@
;; end up having two non-EQ objects created for the same value.
(let* ((test (if *compiler-constants* 'eq 'equal))
(array (if permanent *permanent-objects* *temporary-objects*))
(vv (if permanent 'VV 'VV-temp))
(make-vv (if permanent #'make-vv #'make-vv-temp))
(x (or (and (not permanent)
(find object *permanent-objects* :test test
:key #'first))
(find object array :test test :key #'first)))
(next-ndx (length array))
(forced duplicate)
(cond ((add-static-constant object))
((and x duplicate)
(setq x (list vv next-ndx))
(setq x (funcall make-vv :location next-ndx :used forced))
(vector-push-extend (list object x next-ndx) array)
......@@ -132,7 +138,7 @@
(multiple-value-setq (found x) (si::mangle-name object)))
(setq x (list vv next-ndx))
(setq x (funcall make-vv :location next-ndx :used forced))
(vector-push-extend (list object x next-ndx) array)
(unless *compiler-constants*
(add-load-form object x))
......@@ -249,16 +255,41 @@
(when builder
(let* ((c-name (format nil "_ecl_static_~D" (length *static-constants*))))
(push (list object c-name builder) *static-constants*)
`(VV ,c-name))))))))
(make-vv :location c-name))))))))
(defun vt-loc-value (loc)
(flet ((static-constant-value (index)
(first (find index *static-constants* :key #'second
:test #'string=))))
(let ((index (second loc)))
(cond ((stringp index)
(static-constant-value index))
((eq (car loc) 'VV)
(aref *permanent-objects* index))
(VV-TEMP (aref *temporary-objects* index)))))))
(if (vv-temp-p loc)
(aref *temporary-objects* (vv-temp-location index))
(if (vv-p loc)
(let ((index (vv-location loc)))
(if (stringp index)
(static-constant-value index)
(aref *permanent-objects* index)))
(baboon :format-control "VT-LOC-VALUE got an invalid location ~A"
:format-arguments (list loc))))))
(defun wt-vv-index (index temp)
(cond ((not (numberp index))
(wt index))
(wt "VVtemp[" index "]"))
(wt "VV[" index "]"))))
(defun set-vv-index (loc index temp)
(wt-nl) (wt-vv-index index temp) (wt "= ")
(wt-coerce-loc :object loc)
(wt ";"))
(defun wt-vv (vv-loc)
(setf (vv-used vv-loc) t)
(wt-vv-index (vv-location vv-loc) (vv-temp-p vv-loc)))
(defun set-vv (loc vv-loc)
(setf (vv-used vv-loc) t)
(set-vv-index loc (vv-location vv-loc) (vv-temp-p vv-loc)))
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