Changeset 9530


Ignore:
Timestamp:
May 16, 2008, 2:29:42 AM (11 years ago)
Author:
gb
Message:

A little bit of cold-load $fasl-eval support: make early class-cells,
istruct cells.

XLOAD-CXXR, just to stay saner a little longer.

Make defxloadfaslop name the function; not sure why we don't do this
in nfasload as well.

Add new operator for $fasl-istruct-cell.

New binaries soon; all of these changes are hard to bootstrap.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • branches/working-0711-perf/ccl/xdump/xfasload.lisp

    r9444 r9530  
    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-loading-file-source-file* nil)
    352352(defparameter *xload-loading-toplevel-location* nil)
     353(defparameter *xload-early-class-cells* nil)
     354(defparameter *xload-early-istruct-cells* nil)
    353355
    354356(defparameter *xload-pure-code-p* t)     ; when T, subprims are copied to readonly space
     
    698700    (error "Not a cons: #x~x" addr)))
    699701
     702(defun xload-caar (addr)
     703  (xload-car (xload-car addr)))
     704
     705(defun xload-cadr (addr)
     706  (xload-car (xload-cdr addr)))
     707
     708(defun xload-cdar (addr)
     709  (xload-cdr (xload-car addr)))
     710
     711(defun xload-cddr (addr)
     712  (xload-cdr (xload-cdr addr)))
     713
    700714(defun xload-symbol-value (addr)
    701715  (unless (= *xload-target-fulltag-for-symbols*
     
    749763            (xload-make-cons *xload-target-nil* new)))
    750764    new))
    751      
     765
     766;;; Emulate REGISTER-ISTRUCT-CELL, kinda.  Maintain
     767;;; *xload-early-istruct-istruct-cells* in the image.
     768(defun xload-register-istruct-cell (xsym)
     769  (do* ((alist *xload-early-istruct-cells* (xload-cdr alist)))
     770       ((= alist *xload-target-nil*)
     771        (let* ((pair (xload-make-cons xsym *xload-target-nil*)))
     772          (setq *xload-early-istruct-cells*
     773                (xload-make-cons pair *xload-early-istruct-cells*))
     774          pair))
     775    (let* ((pair (xload-car alist)))
     776      (when (= (xload-car pair) xsym)
     777        (return pair)))))
     778
    752779 
    753780;;; This handles constants set to themselves.  Unless
     
    9941021         (*xload-symbol-addresses* (make-hash-table :test #'eql))
    9951022         (*xload-spaces* nil)
     1023         (*xload-early-class-cells* nil)
     1024         (*xload-early-istruct-cells* *xload-target-nil*)
    9961025         (*xload-readonly-space* (init-xload-space *xload-readonly-space-address* *xload-readonly-space-size* area-readonly))
    9971026         (*xload-dynamic-space* (init-xload-space *xload-dynamic-space-address* *xload-dynamic-space-size* area-dynamic))
     
    10711100          (xload-save-list (setq *xload-cold-load-functions*
    10721101                                 (nreverse *xload-cold-load-functions*))))
     1102    (when *xload-early-class-cells*
     1103      (setf (xload-symbol-value (xload-copy-symbol '*early-class-cells*))
     1104            (xload-save-list (mapcar #'xload-save-list *xload-early-class-cells*))))
     1105    (setf (xload-symbol-value (xload-copy-symbol '*istruct-cells*))
     1106          *xload-early-istruct-cells*)
    10731107    (let* ((svnrev (local-svn-revision))
    10741108           (tree (svn-tree)))
     
    13731407(defxloadfaslop $fasl-eval (s)
    13741408  (let* ((expr (%fasl-expr-preserve-epush s)))
    1375     (error "Can't evaluate expression ~s in cold load ." expr)
    1376     (%epushval s (eval expr))))         ; could maybe evaluate symbols, constants ...
     1409    (cond ((and (xload-target-consp expr)
     1410                (eq (xload-lookup-symbol-address (xload-car expr))
     1411                    'find-class-cell)
     1412                (xload-target-consp (xload-car (xload-cdr expr)))
     1413                (eq (xload-lookup-symbol-address (xload-car (xload-car (xload-cdr expr))))
     1414                    'quote))
     1415           (let* ((class-name (xload-cadr (xload-cadr expr)))
     1416                  (cell (cdr (assoc class-name *xload-early-class-cells*))))
     1417             (unless cell
     1418               (setq cell (xload-make-gvector :istruct 5))
     1419               (setf (xload-%svref cell 0) (xload-register-istruct-cell
     1420                                            (xload-copy-symbol 'class-cell)))
     1421               (setf (xload-%svref cell 1) class-name)
     1422               (setf (xload-%svref cell 2) *xload-target-nil*)
     1423               (setf (xload-%svref cell 3) (xload-copy-symbol '%make-instance))
     1424               (setf (xload-%svref cell 4) *xload-target-nil*)
     1425               (push (cons class-name cell) *xload-early-class-cells*))
     1426             (%epushval s cell)))
     1427          ((and (xload-target-consp expr)
     1428                (eq (xload-lookup-symbol-address (xload-car expr))
     1429                    'register-istruct-cell)
     1430                (xload-target-consp (xload-cadr expr))
     1431                (eq (xload-lookup-symbol-address (xload-cdar expr))
     1432                    'quote))
     1433           (%epushval s (xload-register-istruct-cell (xload-cadr (xload-cadr expr)))))
     1434          (t
     1435           (error "Can't evaluate expression ~s in cold load ." expr)
     1436           (%epushval s (eval expr))))))         ; could maybe evaluate symbols, constants ...
    13771437
    13781438
     
    16991759          (declare (fixnum i numconst constidx))
    17001760          (setf (xload-%svref vector constidx) (%fasl-expr s)))))))
     1761
     1762(defxloadfaslop $fasl-istruct-cell (s)
     1763  (%epushval s (xload-register-istruct-cell (%fasl-expr-preserve-epush s))))
     1764
    17011765
    17021766
Note: See TracChangeset for help on using the changeset viewer.