--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
-;;;; 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.
(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)
(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)
: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)
(values opt1 nil))
(t
(values :local opt1))))
+ (/show allocation initial-value)
(setf body
(ecase allocation
#+nil
`((setq ,symbol ,initial-value)))
,@body)))))
(:extern
+ (/show ":EXTERN case")
(let ((info (make-heap-alien-info
:type alien-type
:sap-form `(foreign-symbol-address
((,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))))
`((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))))
;; (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)
(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
((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))))))
`(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)
(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
(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))
(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)
(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)
(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
;;; 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)
:var
3-bits)))
(extract-branch-target (byte)
+ (/show "in EXTRACT-BRANCH-TARGET")
(if (logbitp 0 byte)
(let ((disp (next-byte)))
(if (logbitp 7 disp)
(aref constants index)
"<bogus 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
(newline)
(let ((byte (next-byte)))
+ (/show "at head of DISPATCH" index byte)
(macrolet ((dispatch (&rest clauses)
`(cond ,@(mapcar #'(lambda (clause)
`((= (logand byte ,(caar clause))
;; 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)
; 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)
;; 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
projects / sbcl.git / commitdiff