Changeset 10302


Ignore:
Timestamp:
Aug 4, 2008, 8:24:04 AM (11 years ago)
Author:
gb
Message:

Merge in some stuff from working-0711, especially stuff dealing
with early/cold-load istruct cells.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/xdump/xfasload.lisp

    r10075 r10302  
    2424(defmacro defxloadfaslop (n arglist &body body)
    2525  `(setf (svref *xload-fasl-dispatch-table* ,n)
    26          #'(lambda ,arglist ,@body)))
     26         (nfunction ,n (lambda ,arglist ,@body))))
    2727
    2828(defmacro xload-copy-faslop (n)
     
    351351(defparameter *xload-cold-load-documentation* nil)
    352352(defparameter *xload-loading-file-source-file* nil)
     353(defparameter *xload-loading-toplevel-location* nil)
     354(defparameter *xload-early-class-cells* nil)
     355(defparameter *xload-early-istruct-cells* nil)
    353356
    354357(defparameter *xload-pure-code-p* t)     ; when T, subprims are copied to readonly space
     
    698701    (error "Not a cons: #x~x" addr)))
    699702
     703(defun xload-caar (addr)
     704  (xload-car (xload-car addr)))
     705
     706(defun xload-cadr (addr)
     707  (xload-car (xload-cdr addr)))
     708
     709(defun xload-cdar (addr)
     710  (xload-cdr (xload-car addr)))
     711
     712(defun xload-cddr (addr)
     713  (xload-cdr (xload-cdr addr)))
     714
    700715(defun xload-symbol-value (addr)
    701716  (unless (= *xload-target-fulltag-for-symbols*
     
    749764            (xload-make-cons *xload-target-nil* new)))
    750765    new))
    751      
     766
     767;;; Emulate REGISTER-ISTRUCT-CELL, kinda.  Maintain
     768;;; *xload-early-istruct-istruct-cells* in the image.
     769(defun xload-register-istruct-cell (xsym)
     770  (do* ((alist *xload-early-istruct-cells* (xload-cdr alist)))
     771       ((= alist *xload-target-nil*)
     772        (let* ((pair (xload-make-cons xsym *xload-target-nil*)))
     773          (setq *xload-early-istruct-cells*
     774                (xload-make-cons pair *xload-early-istruct-cells*))
     775          pair))
     776    (let* ((pair (xload-car alist)))
     777      (when (= (xload-car pair) xsym)
     778        (return pair)))))
     779
    752780 
    753781;;; This handles constants set to themselves.  Unless
     
    893921             (*loading-files* (cons path *loading-files*))
    894922             (*xload-loading-file-source-file* nil)
     923             (*xload-loading-toplevel-location* nil)
    895924             (*loading-file-source-file* (namestring source-file)))
    896925        (when *load-verbose*
     
    9931022         (*xload-symbol-addresses* (make-hash-table :test #'eql))
    9941023         (*xload-spaces* nil)
     1024         (*xload-early-class-cells* nil)
     1025         (*xload-early-istruct-cells* *xload-target-nil*)
    9951026         (*xload-readonly-space* (init-xload-space *xload-readonly-space-address* *xload-readonly-space-size* area-readonly))
    9961027         (*xload-dynamic-space* (init-xload-space *xload-dynamic-space-address* *xload-dynamic-space-size* area-dynamic))
     
    10021033         (*xload-cold-load-documentation* nil)
    10031034         (*xload-loading-file-source-file* nil)
     1035         (*xload-loading-toplevel-location* nil)
    10041036         (*xload-aliased-package-addresses* nil)
    10051037         (*xload-special-binding-indices*
     
    10691101          (xload-save-list (setq *xload-cold-load-functions*
    10701102                                 (nreverse *xload-cold-load-functions*))))
     1103    #+notyet
     1104    (when *xload-early-class-cells*
     1105      (setf (xload-symbol-value (xload-copy-symbol '*early-class-cells*))
     1106            (xload-save-list (mapcar #'xload-save-list *xload-early-class-cells*))))
     1107    (setf (xload-symbol-value (xload-copy-symbol '*istruct-cells*))
     1108          *xload-early-istruct-cells*)
    10711109    (let* ((svnrev (local-svn-revision))
    10721110           (tree (svn-tree)))
     
    13711409(defxloadfaslop $fasl-eval (s)
    13721410  (let* ((expr (%fasl-expr-preserve-epush s)))
    1373     (error "Can't evaluate expression ~s in cold load ." expr)
    1374     (%epushval s (eval expr))))         ; could maybe evaluate symbols, constants ...
     1411    (cond #+notyet
     1412          ((and (xload-target-consp expr)
     1413                (eq (xload-lookup-symbol-address (xload-car expr))
     1414                    'find-class-cell)
     1415                (xload-target-consp (xload-car (xload-cdr expr)))
     1416                (eq (xload-lookup-symbol-address (xload-car (xload-car (xload-cdr expr))))
     1417                    'quote))
     1418           (let* ((class-name (xload-cadr (xload-cadr expr)))
     1419                  (cell (cdr (assoc class-name *xload-early-class-cells*))))
     1420             (unless cell
     1421               (setq cell (xload-make-gvector :istruct 5))
     1422               (setf (xload-%svref cell 0) (xload-register-istruct-cell
     1423                                            (xload-copy-symbol 'class-cell)))
     1424               (setf (xload-%svref cell 1) class-name)
     1425               (setf (xload-%svref cell 2) *xload-target-nil*)
     1426               (setf (xload-%svref cell 3) (xload-copy-symbol '%make-instance))
     1427               (setf (xload-%svref cell 4) *xload-target-nil*)
     1428               (push (cons class-name cell) *xload-early-class-cells*))
     1429             (%epushval s cell)))
     1430          ((and (xload-target-consp expr)
     1431                (eq (xload-lookup-symbol-address (xload-car expr))
     1432                    'register-istruct-cell)
     1433                (xload-target-consp (xload-cadr expr))
     1434                (eq (xload-lookup-symbol-address (xload-cdar expr))
     1435                    'quote))
     1436           (%epushval s (xload-register-istruct-cell (xload-cadr (xload-cadr expr)))))
     1437          (t
     1438           (error "Can't evaluate expression ~s in cold load ." expr)
     1439           (%epushval s (eval expr))))))         ; could maybe evaluate symbols, constants ...
    13751440
    13761441
     
    15361601
    15371602(defun xload-record-source-file (symaddr indicator)
     1603  ;; need to do something with *xload-loading-toplevel-location*
    15381604  (when *xload-record-source-file-p*
    15391605    (when (or (eq indicator 'function)
     
    16671733  (let* ((path (%fasl-expr s)))
    16681734    (setq *xload-loading-file-source-file* path)))
     1735
     1736(defxloadfaslop $fasl-toplevel-location (s)
     1737  (%cant-epush s)
     1738  (let* ((location (%fasl-expr s)))
     1739    (setq *xload-loading-toplevel-location* location)))
    16691740
    16701741;;; Use the offsets in the self-reference table to replace the :self
     
    17231794          (declare (fixnum i numconst constidx))
    17241795          (setf (xload-%svref vector constidx) (%fasl-expr s)))))))
     1796
     1797(defxloadfaslop $fasl-istruct-cell (s)
     1798  (%epushval s (xload-register-istruct-cell (%fasl-expr-preserve-epush s))))
     1799
    17251800
    17261801
Note: See TracChangeset for help on using the changeset viewer.