The fasl header is easy to deal with; writing "at cross-compile time"
instead of something depending on the host is easy. The debug-source is
harder; we set the structure slots to 0 in the cross-compiler, and
arrange for cold-init to patch sensible values in (by inventing a new
FOP to note the debug-source's arrival).
made up of 5 commits, whose individual messages follow:
deal with trivial volatile contents of fasl files
Don't try to preserve, even in the header, information about which
implementation or machine was used for the compilation.
Similarly, don't emit the timestamps in the debug-source into the fasls.
comments: delete a FIXME and explain a bare `2'
consistent source pathname for output/stuff-groveled-from-headers.lisp
At the moment it's the only compiled file not in src/; code defensively
around that fact.
fix a longstanding KLUDGE
Find the index of the source slot by introspection rather than using a
baffling literal `2'. Unfortunately, in doing so we run into bug #117.
patch in the source created/compiled information in cold-init
We can't do it before without making our fasls or cold-sbcl.core
dependent on filesystem timestamps or current time. The way we do it is
perhaps overcomplicated, compared with simply assuming that the file
timestamps are right, but has the advantage that it's demonstrably
correct: we implement a new FOP specifically for noting our
DEBUG-SOURCE, dumped only during cross-compilation, and in genesis we
interpret that FOP to build a list of debug-sources, which we can frob
in cold-init.
Everything should now be restored to its previous functionality.
13 files changed:
("src/compiler/trace-table") ; needs EMIT-LABEL macro from compiler/assem.lisp
("src/compiler/trace-table") ; needs EMIT-LABEL macro from compiler/assem.lisp
+ ("src/code/debug-info")
;; Compiling this requires fop definitions from code/fop.lisp and
;; trace table definitions from compiler/trace-table.lisp.
("src/compiler/dump")
;; Compiling this requires fop definitions from code/fop.lisp and
;; trace table definitions from compiler/trace-table.lisp.
("src/compiler/dump")
("src/compiler/tn")
("src/compiler/life")
("src/compiler/tn")
("src/compiler/life")
- ("src/code/debug-info")
-
("src/compiler/debug-dump")
("src/compiler/generic/utils")
("src/compiler/fopcompile")
("src/compiler/debug-dump")
("src/compiler/generic/utils")
("src/compiler/fopcompile")
"HANDLE-CIRCULARITY" "HOST" "IGNORE-IT" "ILL-BIN"
"ILL-BOUT" "ILL-IN" "ILL-OUT" "INDEX-OR-MINUS-1"
"INDEX-TOO-LARGE-ERROR" "*!INITIAL-ASSEMBLER-ROUTINES*"
"HANDLE-CIRCULARITY" "HOST" "IGNORE-IT" "ILL-BIN"
"ILL-BOUT" "ILL-IN" "ILL-OUT" "INDEX-OR-MINUS-1"
"INDEX-TOO-LARGE-ERROR" "*!INITIAL-ASSEMBLER-ROUTINES*"
+ "*!INITIAL-DEBUG-SOURCES*"
"*!INITIAL-FDEFN-OBJECTS*" "*!INITIAL-FOREIGN-SYMBOLS*"
"*!INITIAL-LAYOUTS*" "*!INITIAL-SYMBOLS*"
"INTEGER-DECODE-DOUBLE-FLOAT"
"*!INITIAL-FDEFN-OBJECTS*" "*!INITIAL-FOREIGN-SYMBOLS*"
"*!INITIAL-LAYOUTS*" "*!INITIAL-SYMBOLS*"
"INTEGER-DECODE-DOUBLE-FLOAT"
"!EARLY-TYPE-COLD-INIT" "!LATE-TYPE-COLD-INIT"
"!FIXUP-TYPE-COLD-INIT" "!TARGET-TYPE-COLD-INIT"
"!RANDOM-COLD-INIT" "!READER-COLD-INIT"
"!EARLY-TYPE-COLD-INIT" "!LATE-TYPE-COLD-INIT"
"!FIXUP-TYPE-COLD-INIT" "!TARGET-TYPE-COLD-INIT"
"!RANDOM-COLD-INIT" "!READER-COLD-INIT"
+ "!PATHNAME-COLD-INIT" "!DEBUG-INFO-COLD-INIT"
"!TYPECHECKFUNS-COLD-INIT" "!LOADER-COLD-INIT"
"!EXHAUST-COLD-INIT" "!PACKAGE-COLD-INIT"
"!POLICY-COLD-INIT-OR-RESANIFY"
"!TYPECHECKFUNS-COLD-INIT" "!LOADER-COLD-INIT"
"!EXHAUST-COLD-INIT" "!PACKAGE-COLD-INIT"
"!POLICY-COLD-INIT-OR-RESANIFY"
(show-and-call !late-proclaim-cold-init)
(show-and-call os-cold-init-or-reinit)
(show-and-call !late-proclaim-cold-init)
(show-and-call os-cold-init-or-reinit)
+ (show-and-call !pathname-cold-init)
+ (show-and-call !debug-info-cold-init)
(show-and-call stream-cold-init-or-reset)
(show-and-call !loader-cold-init)
(show-and-call stream-cold-init-or-reset)
(show-and-call !loader-cold-init)
(name (missing-arg) :type t)
;; A list of DEBUG-SOURCE structures describing where the code for this
;; component came from, in the order that they were read.
(name (missing-arg) :type t)
;; A list of DEBUG-SOURCE structures describing where the code for this
;; component came from, in the order that they were read.
- ;;
- ;; KLUDGE: comment from CMU CL:
- ;; *** NOTE: the offset of this slot is wired into the fasl dumper
- ;; *** so that it can backpatch the source info when compilation
- ;; *** is complete.
+(defconstant +debug-info-source-index+
+ (let* ((dd (find-defstruct-description 'debug-info))
+ (slots (dd-slots dd))
+ (source (locally (declare (notinline find)) ; bug 117 bogowarning
+ (find 'source slots :key #'dsd-name))))
+ (dsd-index source)))
+
(def!struct (compiled-debug-info
(:include debug-info)
#-sb-xc-host (:pure t))
(def!struct (compiled-debug-info
(:include debug-info)
#-sb-xc-host (:pure t))
;; works? Would this break if we used a more general memory map? --
;; WHN 20000120
(fun-map (missing-arg) :type simple-vector :read-only t))
;; works? Would this break if we used a more general memory map? --
;; WHN 20000120
(fun-map (missing-arg) :type simple-vector :read-only t))
+
+(defvar *!initial-debug-sources*)
+
+(defun !debug-info-cold-init ()
+ (let ((now (get-universal-time)))
+ (dolist (debug-source *!initial-debug-sources*)
+ (let* ((namestring (debug-source-namestring debug-source))
+ (timestamp (file-write-date namestring)))
+ (setf (debug-source-created debug-source) timestamp
+ (debug-source-compiled debug-source) now)))))
(name (pop-stack)))
(setf (fdefinition name) fn)))
(name (pop-stack)))
(setf (fdefinition name) fn)))
+(define-fop (fop-note-debug-source 174 :pushp nil)
+ (warn "~@<FOP-NOTE-DEBUG-SOURCE seen in ordinary load (not cold load) -- ~
+very strange! If you didn't do something to cause this, please report it as ~
+a bug.~@:>")
+ ;; as with COLD-FSET above, we are going to be lenient with coming
+ ;; across this fop in a warm SBCL.
+ (let ((debug-source (pop-stack)))
+ (setf (sb!c::debug-source-compiled debug-source) (get-universal-time)
+ (sb!c::debug-source-created debug-source)
+ (file-write-date (sb!c::debug-source-namestring debug-source)))))
+
;;; Modify a slot in a CONSTANTS object.
(define-cloned-fops (fop-alter-code 140 :pushp nil) (fop-byte-alter-code 141)
(let ((value (pop-stack))
;;; Modify a slot in a CONSTANTS object.
(define-cloned-fops (fop-alter-code 140 :pushp nil) (fop-byte-alter-code 141)
(let ((value (pop-stack))
#+sb-xc-host
(let ((src (position "src" dir :test #'string=
:from-end t)))
#+sb-xc-host
(let ((src (position "src" dir :test #'string=
:from-end t)))
- (if src
- (format nil "SYS:~{~:@(~A~);~}~:@(~A~).LISP"
- (subseq dir src) (pathname-name untruename))
- ;; FIXME: just output/stuff-groveled-from-headers.lisp
- (namestring untruename)))
+ (cond
+ (src (format nil "SYS:~{~:@(~A~);~}~:@(~A~).LISP"
+ (subseq dir src) (pathname-name untruename)))
+ (t (aver (string-equal (car (last dir)) "output"))
+ (aver (string-equal (pathname-name untruename) "stuff-groveled-from-headers"))
+ (aver (string-equal (pathname-type untruename) "lisp"))
+ "SYS:OUTPUT;STUFF-GROVELED-FROM-HEADERS.LISP")))
#-sb-xc-host
(if (and dir (eq (first dir) :absolute))
(namestring untruename)
#-sb-xc-host
(if (and dir (eq (first dir) :absolute))
(namestring untruename)
;; might be cute to search in "SYS:TRANSLATIONS;<name>.LISP"
(error "logical host ~S not found" host)))
;; might be cute to search in "SYS:TRANSLATIONS;<name>.LISP"
(error "logical host ~S not found" host)))
+(defun !pathname-cold-init ()
+ (let* ((sys *default-pathname-defaults*)
+ (src
+ (merge-pathnames
+ (make-pathname :directory '(:relative "src" :wild-inferiors)
+ :name :wild :type :wild)
+ sys))
+ (contrib
+ (merge-pathnames
+ (make-pathname :directory '(:relative "contrib" :wild-inferiors)
+ :name :wild :type :wild)
+ sys))
+ (output
+ (merge-pathnames
+ (make-pathname :directory '(:relative "output" :wild-inferiors)
+ :name :wild :type :wild)
+ sys)))
+ (setf (logical-pathname-translations "SYS")
+ `(("SYS:SRC;**;*.*.*" ,src)
+ ("SYS:CONTRIB;**;*.*.*" ,contrib)
+ ("SYS:OUTPUT;**;*.*.*" ,output)))))
\f
;;;; compiling and loading more of the system
\f
;;;; compiling and loading more of the system
-(let* ((sys *default-pathname-defaults*)
- (src
- (merge-pathnames
- (make-pathname :directory '(:relative "src" :wild-inferiors)
- :name :wild :type :wild)
- sys))
- (contrib
- (merge-pathnames
- (make-pathname :directory '(:relative "contrib" :wild-inferiors)
- :name :wild :type :wild)
- sys)))
- (setf (logical-pathname-translations "SYS")
- `(("SYS:SRC;**;*.*.*" ,src)
- ("SYS:CONTRIB;**;*.*.*" ,contrib))))
-
;;; FIXME: CMU CL's pclcom.lisp had extra optional stuff wrapped around
;;; COMPILE-PCL, at least some of which we should probably have too:
;;;
;;; FIXME: CMU CL's pclcom.lisp had extra optional stuff wrapped around
;;; COMPILE-PCL, at least some of which we should probably have too:
;;;
on ~A~% ~
using ~A version ~A~%"
where
on ~A~% ~
using ~A version ~A~%"
where
- (format-universal-time nil (get-universal-time))
- (machine-instance)
+ #+sb-xc-host "cross-compile time"
+ #-sb-xc-host (format-universal-time nil (get-universal-time))
+ #+sb-xc-host "cross-compile host"
+ #-sb-xc-host (machine-instance)
(sb!xc:lisp-implementation-type)
(sb!xc:lisp-implementation-version))))
stream)
(sb!xc:lisp-implementation-type)
(sb!xc:lisp-implementation-version))))
stream)
(declare (type sb!c::source-info info))
(let ((res (sb!c::debug-source-for-info info))
(*dump-only-valid-structures* nil))
(declare (type sb!c::source-info info))
(let ((res (sb!c::debug-source-for-info info))
(*dump-only-valid-structures* nil))
+ #+sb-xc-host (setf (sb!c::debug-source-created res) 0
+ (sb!c::debug-source-compiled res) 0)
(dump-object res fasl-output)
(let ((res-handle (dump-pop fasl-output)))
(dolist (info-handle (fasl-output-debug-info fasl-output))
(dump-push res-handle fasl-output)
(dump-fop 'fop-structset fasl-output)
(dump-word info-handle fasl-output)
(dump-object res fasl-output)
(let ((res-handle (dump-pop fasl-output)))
(dolist (info-handle (fasl-output-debug-info fasl-output))
(dump-push res-handle fasl-output)
(dump-fop 'fop-structset fasl-output)
(dump-word info-handle fasl-output)
- ;; FIXME: what is this bare `2'? --njf, 2004-08-16
- (dump-word 2 fasl-output))))
+ (dump-word sb!c::+debug-info-source-index+ fasl-output))
+ #+sb-xc-host
+ (progn
+ (dump-push res-handle fasl-output)
+ (dump-fop 'fop-note-debug-source fasl-output))))
(setf (fasl-output-debug-info fasl-output) nil)
(values))
\f
(setf (fasl-output-debug-info fasl-output) nil)
(values))
\f
(defvar *info-environment*)
(defvar *lexenv*)
(defvar *source-info*)
(defvar *info-environment*)
(defvar *lexenv*)
(defvar *source-info*)
(defvar *trace-table*)
(defvar *undefined-warnings*)
(defvar *warnings-p*)
(defvar *trace-table*)
(defvar *undefined-warnings*)
(defvar *warnings-p*)
;;; purposes.
(defvar *current-reversed-cold-toplevels*)
;;; purposes.
(defvar *current-reversed-cold-toplevels*)
+;;; the head of a list of DEBUG-SOURCEs which need to be patched when
+;;; the cold core starts up
+(defvar *current-debug-sources*)
+
;;; the name of the object file currently being cold loaded (as a string, not a
;;; pathname), or NIL if we're not currently cold loading any object file
(defvar *cold-load-filename* nil)
;;; the name of the object file currently being cold loaded (as a string, not a
;;; pathname), or NIL if we're not currently cold loading any object file
(defvar *cold-load-filename* nil)
(cold-set '*!initial-fdefn-objects* (list-all-fdefn-objects))
(cold-set '*!reversed-cold-toplevels* *current-reversed-cold-toplevels*)
(cold-set '*!initial-fdefn-objects* (list-all-fdefn-objects))
(cold-set '*!reversed-cold-toplevels* *current-reversed-cold-toplevels*)
+ (cold-set '*!initial-debug-sources* *current-debug-sources*)
#!+(or x86 x86-64)
(progn
#!+(or x86 x86-64)
(progn
(setf (gethash warm-name *cold-fset-warm-names*) t))
(static-fset cold-name fn)))
(setf (gethash warm-name *cold-fset-warm-names*) t))
(static-fset cold-name fn)))
+(define-cold-fop (fop-note-debug-source :pushp nil)
+ (let ((debug-source (pop-stack)))
+ (cold-push debug-source *current-debug-sources*)))
+
(define-cold-fop (fop-fdefinition)
(cold-fdefinition-object (pop-stack)))
(define-cold-fop (fop-fdefinition)
(cold-fdefinition-object (pop-stack)))
#!-gencgc sb!vm:dynamic-0-space-start))
(*nil-descriptor* (make-nil-descriptor))
(*current-reversed-cold-toplevels* *nil-descriptor*)
#!-gencgc sb!vm:dynamic-0-space-start))
(*nil-descriptor* (make-nil-descriptor))
(*current-reversed-cold-toplevels* *nil-descriptor*)
+ (*current-debug-sources* *nil-descriptor*)
(*unbound-marker* (make-other-immediate-descriptor
0
sb!vm:unbound-marker-widetag))
(*unbound-marker* (make-other-immediate-descriptor
0
sb!vm:unbound-marker-widetag))
do (entries `((eql ,n-supplied ,n)
(%funcall ,(force ep) ,@(subseq temps 0 n)))))
`(lambda (,n-supplied ,@temps)
do (entries `((eql ,n-supplied ,n)
(%funcall ,(force ep) ,@(subseq temps 0 n)))))
`(lambda (,n-supplied ,@temps)
- ;; FIXME: Make sure that INDEX type distinguishes between
- ;; target and host. (Probably just make the SB!XC:DEFTYPE
- ;; different from CL:DEFTYPE.)
(declare (type index ,n-supplied))
(cond
,@(if more (butlast (entries)) (entries))
(declare (type index ,n-supplied))
(cond
,@(if more (butlast (entries)) (entries))
;;; checkins which aren't released. (And occasionally for internal
;;; versions, especially for internal versions off the main CVS
;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
;;; checkins which aren't released. (And occasionally for internal
;;; versions, especially for internal versions off the main CVS
;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)