From c8218514d751c4d777892b79bbf1ca6597f731c0 Mon Sep 17 00:00:00 2001 From: William Harold Newman Date: Tue, 21 Aug 2001 19:58:13 +0000 Subject: [PATCH] 0.pre7.14.flaky4.5: (Oops: In the previous version, I worked on "reimplemented ONCE-ONLY so it expands into a single LET, so that DECLAREs inside work as they should" enough that I put it into the commit notes, but then I realized that using an inline function is a nice way to solve the UNIX-FAST-SELECT problemm, so I undid the ONCE-ONLY changes, but forgot to clean up the commit notes.) (This version builds under sbcl-0.6.13 with :SB-SHOW, and without :SB-INTERPRETER, in target *FEATURES*. Now maybe I can use the result to figure out why it can't build itself.) Maybe we don't need the extra space in DISASSEM-BYTE-COMPONENT after all. added :IGNORE-FAILURE-P for src/cold/cold-init in order to build with :SB-SHOW got rid of various early /SHOWs (before the definition of UNWIND in assem-rtns.lisp is loaded) so that the system could cold init chopped make-target-2.sh *PRINT-LEVEL* back down to 5 so that /SHOW statements terminate before hell freezes over --- make-target-2.sh | 8 +++++--- package-data-list.lisp-expr | 15 +++++++++++---- src/code/byte-interp.lisp | 6 +++--- src/code/early-setf.lisp | 2 +- src/code/target-alieneval.lisp | 10 ++++++++++ src/cold/warm.lisp | 8 ++++++-- src/compiler/array-tran.lisp | 33 ++++++++++++++++++--------------- src/compiler/ir1tran.lisp | 8 ++++++-- src/compiler/srctran.lisp | 4 +--- src/compiler/target-byte-comp.lisp | 10 +++++++++- stems-and-flags.lisp-expr | 26 ++++++++++++++++++++++---- 11 files changed, 92 insertions(+), 38 deletions(-) diff --git a/make-target-2.sh b/make-target-2.sh index 4431c60..fb85d1d 100644 --- a/make-target-2.sh +++ b/make-target-2.sh @@ -29,12 +29,14 @@ echo //doing warm init --core output/cold-sbcl.core \ --sysinit /dev/null --userinit /dev/null <<-'EOF' || exit 1 - (sb!int:/show "hello, world!") + ;; Now that we use the byte compiler for macros, + ;; interpreted /SHOW doesn't work until later in init. + #+sb-show (print "/hello, world!") ;; Do warm init. (let ((*print-length* 10) - (*print-level* 10)) - (sb!int:/show "about to LOAD warm.lisp") + (*print-level* 5)) + #+sb-show (print "/about to LOAD warm.lisp") (load "src/cold/warm.lisp")) ;; Unintern no-longer-needed stuff before the possible PURIFY diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 3db1afc..62a1ed8 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -1,9 +1,16 @@ -;;;; the specifications of SBCL-specific packages, except.. +;;;; -*- Lisp -*- + +;;;; the specifications of target packages, except for a few things +;;;; which are handled elsewhere by other mechanisms: ;;;; * the creation of the trivial SB-SLOT-ACCESSOR-NAME package ;;;; * any SHADOWing hackery -;;;; The standard, non-SBCL-specific packages COMMON-LISP, -;;;; COMMON-LISP-USER, and KEYWORD are also handled through other -;;;; mechanisms. +;;;; * the standard, non-SBCL-specific packages COMMON-LISP, +;;;; COMMON-LISP-USER, and KEYWORD +;;;; +;;;; The packages are named SB!FOO here and elsewhere in +;;;; cross-compilation, in order to avoid collision with corresponding +;;;; SB-FOO packages in the cross-compilation host. They're renamed to +;;;; SB-FOO later, after the danger of collision has passed. ;;;; This software is part of the SBCL system. See the README file for ;;;; more information. diff --git a/src/code/byte-interp.lisp b/src/code/byte-interp.lisp index a309344..e510d17 100644 --- a/src/code/byte-interp.lisp +++ b/src/code/byte-interp.lisp @@ -615,9 +615,9 @@ (type pc pc)) pc) -;;; This is exactly like THROW, except that the tag is the last thing on -;;; the stack instead of the first. This is used for RETURN-FROM (hence the -;;; name). +;;; This is exactly like THROW, except that the tag is the last thing +;;; on the stack instead of the first. This is used for RETURN-FROM +;;; (hence the name). (define-xop return-from (component old-pc pc fp) (declare (type code-component component) (type pc old-pc) diff --git a/src/code/early-setf.lisp b/src/code/early-setf.lisp index ff87f9f..da77d6a 100644 --- a/src/code/early-setf.lisp +++ b/src/code/early-setf.lisp @@ -524,7 +524,7 @@ GET-SETF-EXPANSION directly." (sb!xc:define-setf-expander ldb (bytespec place &environment env) #!+sb-doc "The first argument is a byte specifier. The second is any place form - acceptable to SETF. Replaces the specified byte of the number in this + acceptable to SETF. Replace the specified byte of the number in this place with bits from the low-order end of the new value." (declare (type sb!c::lexenv env)) (multiple-value-bind (dummies vals newval setter getter) diff --git a/src/code/target-alieneval.lisp b/src/code/target-alieneval.lisp index 344fe7a..38a0f58 100644 --- a/src/code/target-alieneval.lisp +++ b/src/code/target-alieneval.lisp @@ -97,12 +97,16 @@ :EXTERN No alien is allocated, but VAR is established as a local name for the external alien given by EXTERNAL-NAME." + (/show "entering WITH-ALIEN" bindings) (with-auxiliary-alien-types env (dolist (binding (reverse bindings)) + (/show binding) (destructuring-bind (symbol type &optional (opt1 nil opt1p) (opt2 nil opt2p)) binding + (/show symbol type opt1 opt2) (let ((alien-type (parse-alien-type type env))) + (/show alien-type) (multiple-value-bind (allocation initial-value) (if opt2p (values opt1 opt2) @@ -113,6 +117,7 @@ (values opt1 nil)) (t (values :local opt1)))) + (/show allocation initial-value) (setf body (ecase allocation #+nil @@ -128,6 +133,7 @@ `((setq ,symbol ,initial-value))) ,@body))))) (:extern + (/show ":EXTERN case") (let ((info (make-heap-alien-info :type alien-type :sap-form `(foreign-symbol-address @@ -136,9 +142,11 @@ ((,symbol (%heap-alien ',info))) ,@body)))) (:local + (/show ":LOCAL case") (let ((var (gensym)) (initval (if initial-value (gensym))) (info (make-local-alien-info :type alien-type))) + (/show var initval info) `((let ((,var (make-local-alien ',info)) ,@(when initial-value `((,initval ,initial-value)))) @@ -150,7 +158,9 @@ `((setq ,symbol ,initval))) ,@body) (dispose-local-alien ',info ,var)))))))))))) + (/show "revised" body) (verify-local-auxiliaries-okay) + (/show "back from VERIFY-LOCAL-AUXILIARIES-OK, returning") `(symbol-macrolet ((&auxiliary-type-definitions& ,(append *new-auxiliary-types* (auxiliary-type-definitions env)))) diff --git a/src/cold/warm.lisp b/src/cold/warm.lisp index 973f66b..70d8c95 100644 --- a/src/cold/warm.lisp +++ b/src/cold/warm.lisp @@ -46,12 +46,16 @@ ;; (Hopefully this will go away as we move the files above into cold load.) ;; -- WHN 19991214 (let ((fullname (concatenate 'string stem ".lisp"))) - (sb!int:/show "about to compile" fullname) + ;; (Now that we use the byte compiler for interpretation, + ;; /SHOW doesn't get compiled properly until the src/assembly + ;; files have been loaded.) + #+sb-show (print "/about to compile src/assembly file") + #+sb-show (print fullname) (multiple-value-bind (compiled-truename compilation-warnings-p compilation-failure-p) (compile-file fullname) (declare (ignore compilation-warnings-p)) - (sb!int:/show "done compiling" fullname) + #+sb-show (print "/done compiling src/assembly file") (if compilation-failure-p (error "COMPILE-FILE of ~S failed." fullname) (unless (load compiled-truename) diff --git a/src/compiler/array-tran.lisp b/src/compiler/array-tran.lisp index 782368c..e1fddb3 100644 --- a/src/compiler/array-tran.lisp +++ b/src/compiler/array-tran.lisp @@ -499,21 +499,24 @@ (element-type '*) unsafe? fail-inline?) + (/show "in %WITH-ARRAY-DATA-MACRO, yes.." array start end) (let ((size (gensym "SIZE-")) + (defaulted-end (gensym "DEFAULTED-END-")) (data (gensym "DATA-")) (cumulative-offset (gensym "CUMULATIVE-OFFSET-"))) `(let* ((,size (array-total-size ,array)) - (,end (cond (,end - (unless (or ,unsafe? (<= ,end ,size)) - ,(if fail-inline? - `(error "End ~D is greater than total size ~D." - ,end ,size) - `(failed-%with-array-data ,array ,start ,end))) - ,end) - (t ,size)))) - (unless (or ,unsafe? (<= ,start ,end)) + (,defaulted-end + (cond (,end + (unless (or ,unsafe? (<= ,end ,size)) + ,(if fail-inline? + `(error "End ~D is greater than total size ~D." + ,end ,size) + `(failed-%with-array-data ,array ,start ,end))) + ,end) + (t ,size)))) + (unless (or ,unsafe? (<= ,start ,defaulted-end)) ,(if fail-inline? - `(error "Start ~D is greater than end ~D." ,start ,end) + `(error "Start ~D is greater than end ~D." ,start ,defaulted-end) `(failed-%with-array-data ,array ,start ,end))) (do ((,data ,array (%array-data-vector ,data)) (,cumulative-offset 0 @@ -522,7 +525,7 @@ ((not (array-header-p ,data)) (values (the (simple-array ,element-type 1) ,data) (the index (+ ,cumulative-offset ,start)) - (the index (+ ,cumulative-offset ,end)) + (the index (+ ,cumulative-offset ,defaulted-end)) (the index ,cumulative-offset))) (declare (type index ,cumulative-offset)))))) @@ -584,10 +587,10 @@ `(lambda (,',array ,@n-indices ,@',(when new-value (list new-value))) (let* (,@(let ((,index -1)) - (mapcar #'(lambda (name) - `(,name (array-dimension - ,',array - ,(incf ,index)))) + (mapcar (lambda (name) + `(,name (array-dimension + ,',array + ,(incf ,index)))) dims)) (,',index ,(if (null dims) diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp index 271931d..d2e0ca5 100644 --- a/src/compiler/ir1tran.lisp +++ b/src/compiler/ir1tran.lisp @@ -585,7 +585,8 @@ (muffle-warning) (error "internal error -- no MUFFLE-WARNING restart")) -;;; Trap errors during the macroexpansion. +;;; Expand FORM using the macro whose MACRO-FUNCTION is FUN, trapping +;;; errors which occur during the macroexpansion. (defun careful-expand-macro (fun form) (handler-bind (;; When cross-compiling, we can get style warnings ;; about e.g. undefined functions. An unhandled @@ -2831,6 +2832,8 @@ (aver (proper-list-of-length-p qdef 2)) (second qdef)))) + (/show "doing IR1 translator for %DEFMACRO" name) + (unless (symbolp name) (compiler-error "The macro name ~S is not a symbol." name)) @@ -2840,7 +2843,8 @@ (remhash name *free-functions*) (undefine-function-name name) (compiler-warning - "~S is being redefined as a macro when it was previously ~(~A~) to be a function." + "~S is being redefined as a macro when it was ~ + previously ~(~A~) to be a function." name (info :function :where-from name))) (:macro) diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp index 96761d9..58585f4 100644 --- a/src/compiler/srctran.lisp +++ b/src/compiler/srctran.lisp @@ -2706,7 +2706,7 @@ (dolist (x '(= char= + * logior logand logxor)) (%deftransform x '(function * *) #'commutative-arg-swap - "place constant arg last.")) + "place constant arg last")) ;;; Handle the case of a constant BOOLE-CODE. (deftransform boole ((op x y) * * :when :both) @@ -3439,8 +3439,6 @@ (defoptimizer (coerce derive-type) ((value type)) (let ((value-type (continuation-type value)) (type-type (continuation-type type))) - #!+sb-show (format t "~&coerce-derive-type value-type ~A type-type ~A~%" - value-type type-type) (labels ((good-cons-type-p (cons-type) ;; Make sure the cons-type we're looking at is something diff --git a/src/compiler/target-byte-comp.lisp b/src/compiler/target-byte-comp.lisp index 844b199..436815c 100644 --- a/src/compiler/target-byte-comp.lisp +++ b/src/compiler/target-byte-comp.lisp @@ -114,19 +114,22 @@ ;;; Disassemble byte code from a SAP and constants vector. (defun disassem-byte-sap (sap bytes constants eps) (declare (optimize (inhibit-warnings 3))) + (/show "entering DISASSEM-BYTE-SAP" bytes constants eps) (let ((index 0)) (labels ((newline () (format t "~&~4D:" index)) (next-byte () (let ((byte (sap-ref-8 sap index))) - (format t " ~2,'0X " byte) + (format t " ~2,'0X" byte) (incf index) byte)) (extract-24-bits () + (/show "in EXTRACT-24-BITS") (logior (ash (next-byte) 16) (ash (next-byte) 8) (next-byte))) (extract-extended-op () + (/show "in EXTRACT-EXTENDED-OP") (let ((byte (next-byte))) (if (= byte 255) (extract-24-bits) @@ -142,6 +145,7 @@ :var 3-bits))) (extract-branch-target (byte) + (/show "in EXTRACT-BRANCH-TARGET") (if (logbitp 0 byte) (let ((disp (next-byte))) (if (logbitp 7 disp) @@ -155,10 +159,12 @@ (aref constants index) ""))) (loop + (/show "at head of LOOP" index bytes) (unless (< index bytes) (return)) (when (eql index (first eps)) + (/show "in EQL INDEX (FIRST EPS) case") (newline) (pop eps) (let ((frame-size @@ -172,6 +178,7 @@ (newline) (let ((byte (next-byte))) + (/show "at head of DISPATCH" index byte) (macrolet ((dispatch (&rest clauses) `(cond ,@(mapcar #'(lambda (clause) `((= (logand byte ,(caar clause)) @@ -251,6 +258,7 @@ ;; if-eq (note "if-eq ~D" (extract-branch-target byte))) ((#b11111000 #b11011000) + (/show "in XOP case") ;; XOP (let* ((low-3-bits (extract-3-bit-op byte)) (xop (nth (if (eq low-3-bits :var) (next-byte) low-3-bits) diff --git a/stems-and-flags.lisp-expr b/stems-and-flags.lisp-expr index 8d44b6a..8e2f125 100644 --- a/stems-and-flags.lisp-expr +++ b/stems-and-flags.lisp-expr @@ -575,11 +575,13 @@ ; from "code/pathname" ("src/code/sharpm" :not-host) ; uses stuff from "code/reader" - ;; stuff for byte compilation. Note that although byte code is + ;; stuff for byte compilation + ;; + ;; This is mostly :NOT-HOST because even though byte code is ;; "portable", it'd be hard to make it work on the cross-compilation ;; host, because fundamental BYTE-FUNCTION-OR-CLOSURE types are - ;; implemented as FUNCALLABLE-INSTANCEs, and it's not obvious - ;; how to emulate those in a vanilla ANSI Common Lisp. + ;; implemented as FUNCALLABLE-INSTANCEs, and it's not obvious how to + ;; emulate those in a vanilla ANSI Common Lisp. ("src/code/byte-types" :not-host) ("src/compiler/byte-comp") ("src/compiler/target-byte-comp" :not-host) @@ -609,7 +611,23 @@ ;; FIXME: Does this really need stuff from compiler/dump.lisp? ("src/compiler/target-dump" :not-host) ; needs stuff from compiler/dump.lisp - ("src/code/cold-init" :not-host) ; needs (SETF EXTERN-ALIEN) macroexpansion + ("src/code/cold-init" :not-host ; needs (SETF EXTERN-ALIEN) macroexpansion + ;; FIXME: When building sbcl-0.pre7.14.flaky4.5 under sbcl-0.6.12.1 + ;; with :SB-SHOW on the target *FEATURES* list, cross-compilation of + ;; this file gives a WARNING in HEXSTR, + ;; Lisp error during constant folding: + ;; Argument X is not a REAL: NIL + ;; This seems to come from DEF!MACRO %WITH-ARRAY-DATA-MACRO code + ;; which looks like + ;; (cond (,end + ;; (unless (or ,unsafe? (<= ,end ,size)) + ;; ..)) + ;; ..) + ;; where the system is trying to constant-fold the <= form when the + ;; ,END binding is known to be NIL at compile time. Since the <= form + ;; is unreachable in that case, this shouldn't be signalling a WARNING; + ;; but as long as it is, we have to ignore it in order to go on. + :ignore-failure-p) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; target macros and DECLAIMs installed at build-the-cross-compiler time -- 1.7.10.4