finally getting to CLISP bootstrapping...
...merged CSR patch "more controversial fixes" from "Re: CLISP
compilation" sbcl-devel 2002-04-15 (which don't look
very controversial except for the **CURRENT-SEGMENT**
code, which is going to have to be fixed somehow and
for which this fix looks plausible)
...made comment fixes mostly related to CSR patch
...fixed "#+"-should-be-"#!+" typos in parms.lisp
13 files changed:
per the CAUTION note above. (As of version 0.6.0, the most
memory-intensive operation in make.sh is the second call to
GENESIS, which makes the Lisp image grow to nearly 128 Mb RAM+swap.
per the CAUTION note above. (As of version 0.6.0, the most
memory-intensive operation in make.sh is the second call to
GENESIS, which makes the Lisp image grow to nearly 128 Mb RAM+swap.
- This will probably be reduced somewhat in some later version
- by allowing cold load of byte-compiled files, so that the cold
- image can be smaller.)
2. If the GNU make command is not available under the name "gmake",
then define the environment variable GNUMAKE to a name where it can
be found.
2. If the GNU make command is not available under the name "gmake",
then define the environment variable GNUMAKE to a name where it can
be found.
-;;; Lots of code wants to get to the KEYWORD package or the
-;;; COMMON-LISP package without a lot of fuss, so we cache them in
-;;; variables. TO DO: How much does this actually buy us? It sounds
-;;; sensible, but I don't know for sure that it saves space or time..
-;;; -- WHN 19990521
-;;;
-;;; (The initialization forms here only matter on the cross-compilation
-;;; host; In the target SBCL, these variables are set in cold init.)
-(declaim (type package *cl-package* *keyword-package*))
-(defvar *cl-package* (find-package "COMMON-LISP"))
-(defvar *keyword-package* (find-package "KEYWORD"))
-
;;; something not EQ to anything we might legitimately READ
(defparameter *eof-object* (make-symbol "EOF-OBJECT"))
;;; something not EQ to anything we might legitimately READ
(defparameter *eof-object* (make-symbol "EOF-OBJECT"))
,@(mapcar (lambda (x)
(if (atom x) x (car x)))
slots)
,@(mapcar (lambda (x)
(if (atom x) x (car x)))
slots)
+ ,@include-args
+ ;; KLUDGE
+ &aux (alignment (or alignment (guess-alignment bits))))))
,@slots)))))
(def!macro define-alien-type-method ((class method) lambda-list &rest body)
,@slots)))))
(def!macro define-alien-type-method ((class method) lambda-list &rest body)
(def!struct (alien-type
(:make-load-form-fun sb!kernel:just-dump-it-normally)
(def!struct (alien-type
(:make-load-form-fun sb!kernel:just-dump-it-normally)
- (:constructor make-alien-type (&key class bits alignment)))
+ (:constructor make-alien-type (&key class bits alignment
+ &aux (alignment (or alignment (guess-alignment bits))))))
(class 'root :type symbol)
(bits nil :type (or null unsigned-byte))
(class 'root :type symbol)
(bits nil :type (or null unsigned-byte))
- (alignment (guess-alignment bits) :type (or null unsigned-byte)))
+ (alignment nil :type (or null unsigned-byte)))
(def!method print-object ((type alien-type) stream)
(print-unreadable-object (type stream :type t)
(prin1 (unparse-alien-type type) stream)))
(def!method print-object ((type alien-type) stream)
(print-unreadable-object (type stream :type t)
(prin1 (unparse-alien-type type) stream)))
(def!struct (local-alien-info
(:make-load-form-fun sb!kernel:just-dump-it-normally)
(:constructor make-local-alien-info
(def!struct (local-alien-info
(:make-load-form-fun sb!kernel:just-dump-it-normally)
(:constructor make-local-alien-info
- (&key type force-to-memory-p)))
+ (&key type force-to-memory-p
+ &aux (force-to-memory-p (or force-to-memory-p
+ (alien-array-type-p type)
+ (alien-record-type-p type))))))
;; the type of the local alien
(type (missing-arg) :type alien-type)
;; Must this local alien be forced into memory? Using the ADDR macro
;; on a local alien will set this.
;; the type of the local alien
(type (missing-arg) :type alien-type)
;; Must this local alien be forced into memory? Using the ADDR macro
;; on a local alien will set this.
- (force-to-memory-p (or (alien-array-type-p type)
- (alien-record-type-p type))
- :type (member t nil)))
+ (force-to-memory-p nil :type (member t nil)))
(def!method print-object ((info local-alien-info) stream)
(print-unreadable-object (info stream :type t)
(format stream
(def!method print-object ((info local-alien-info) stream)
(print-unreadable-object (info stream :type t)
(format stream
+;;; Lots of code wants to get to the KEYWORD package or the
+;;; COMMON-LISP package without a lot of fuss, so we cache them in
+;;; variables. TO DO: How much does this actually buy us? It sounds
+;;; sensible, but I don't know for sure that it saves space or time..
+;;; -- WHN 19990521
+;;;
+;;; (The initialization forms here only matter on the cross-compilation
+;;; host; In the target SBCL, these variables are set in cold init.)
+(declaim (type package *cl-package* *keyword-package*))
+(defvar *cl-package* (find-package "COMMON-LISP"))
+(defvar *keyword-package* (find-package "KEYWORD"))
+
;;; Concatenate together the names of some strings and symbols,
;;; producing a symbol in the current package.
(eval-when (:compile-toplevel :load-toplevel :execute)
;;; Concatenate together the names of some strings and symbols,
;;; producing a symbol in the current package.
(eval-when (:compile-toplevel :load-toplevel :execute)
\f
;;;; the scheduler itself
\f
;;;; the scheduler itself
-(defmacro without-scheduling ((&optional (segment '**current-segment**))
+(defmacro without-scheduling ((&optional (segment '(%%current-segment%%)))
&body body)
#!+sb-doc
"Execute BODY (as a PROGN) without scheduling any of the instructions
&body body)
#!+sb-doc
"Execute BODY (as a PROGN) without scheduling any of the instructions
;;; This holds the current segment while assembling. Use ASSEMBLE to
;;; change it.
;;;
;;; This holds the current segment while assembling. Use ASSEMBLE to
;;; change it.
;;;
-;;; The double asterisks in the name are intended to suggest that this
+;;; The double parens in the name are intended to suggest that this
;;; isn't just any old special variable, it's an extra-special
;;; variable, because sometimes MACROLET is used to bind it. So be
;;; careful out there..
;;; isn't just any old special variable, it's an extra-special
;;; variable, because sometimes MACROLET is used to bind it. So be
;;; careful out there..
+;;;
+;;; (This used to be called **CURRENT-SEGMENT** in SBCL until 0.7.3,
+;;; and just *CURRENT-SEGMENT* in CMU CL. In both cases, the rebinding
+;;; now done with MACROLET was done with SYMBOL-MACROLET instead. The
+;;; rename-with-double-asterisks was because the SYMBOL-MACROLET made
+;;; it an extra-special variable. The change over to
+;;; %%CURRENT-SEGMENT%% was because ANSI forbids the use of
+;;; SYMBOL-MACROLET on special variable names, and CLISP correctly
+;;; complains about this when being used as a bootstrap host.)
+(defmacro %%current-segment%% () '**current-segment**)
(defvar **current-segment**)
(defvar **current-segment**)
-;;; Just like **CURRENT-SEGMENT**, except this holds the current vop.
+;;; Just like %%CURRENT-SEGMENT%%, except this holds the current vop.
;;; Used only to keep track of which vops emit which insts.
;;;
;;; The double asterisks in the name are intended to suggest that this
;;; isn't just any old special variable, it's an extra-special
;;; variable, because sometimes MACROLET is used to bind it. So be
;;; careful out there..
;;; Used only to keep track of which vops emit which insts.
;;;
;;; The double asterisks in the name are intended to suggest that this
;;; isn't just any old special variable, it's an extra-special
;;; variable, because sometimes MACROLET is used to bind it. So be
;;; careful out there..
+(defmacro %%current-vop%% () '**current-vop**)
(defvar **current-vop** nil)
(defvar **current-vop** nil)
-;;; We also SYMBOL-MACROLET **CURRENT-SEGMENT** to a local holding the
-;;; segment so uses of **CURRENT-SEGMENT** inside the body don't have
+;;; We also MACROLET %%CURRENT-SEGMENT%% to a local holding the
+;;; segment so uses of %%CURRENT-SEGMENT%% inside the body don't have
;;; to keep dereferencing the symbol. Given that ASSEMBLE is the only
;;; interface to **CURRENT-SEGMENT**, we don't have to worry about the
;;; special value becomming out of sync with the lexical value. Unless
;;; to keep dereferencing the symbol. Given that ASSEMBLE is the only
;;; interface to **CURRENT-SEGMENT**, we don't have to worry about the
;;; special value becomming out of sync with the lexical value. Unless
(when (intersection labels inherited-labels)
(error "duplicate nested labels: ~S"
(intersection labels inherited-labels)))
(when (intersection labels inherited-labels)
(error "duplicate nested labels: ~S"
(intersection labels inherited-labels)))
- `(let* ((,seg-var ,(or segment '**current-segment**))
- (,vop-var ,(or vop '**current-vop**))
- ,@(when segment
- `((**current-segment** ,seg-var)))
- ,@(when vop
- `((**current-vop** ,vop-var)))
+ `(let* ((,seg-var ,(or segment '(%%current-segment%%)))
+ (,vop-var ,(or vop '(%%current-vop%%)))
+ ,@(when segment
+ `((**current-segment** ,seg-var)))
+ ,@(when vop
+ `((**current-vop** ,vop-var)))
,@(mapcar (lambda (name)
`(,name (gen-label)))
new-labels))
,@(mapcar (lambda (name)
`(,name (gen-label)))
new-labels))
- (symbol-macrolet ((**current-segment** ,seg-var)
- (**current-vop** ,vop-var)
- ,@(when (or inherited-labels nested-labels)
+ (macrolet ((%%current-segment%% () '**current-segment**)
+ (%%current-vop%% () '**current-vop**))
+ (symbol-macrolet (,@(when (or inherited-labels nested-labels)
`((..inherited-labels.. ,nested-labels))))
,@(mapcar (lambda (form)
(if (label-name-p form)
`(emit-label ,form)
form))
`((..inherited-labels.. ,nested-labels))))
,@(mapcar (lambda (form)
(if (label-name-p form)
`(emit-label ,form)
form))
#+sb-xc-host
(sb!xc:defmacro assemble ((&optional segment vop &key labels)
&body body
#+sb-xc-host
(sb!xc:defmacro assemble ((&optional segment vop &key labels)
&body body
(when (intersection labels inherited-labels)
(error "duplicate nested labels: ~S"
(intersection labels inherited-labels)))
(when (intersection labels inherited-labels)
(error "duplicate nested labels: ~S"
(intersection labels inherited-labels)))
- `(let* ((,seg-var ,(or segment '**current-segment**))
- (,vop-var ,(or vop '**current-vop**))
- ,@(when segment
- `((**current-segment** ,seg-var)))
- ,@(when vop
- `((**current-vop** ,vop-var)))
+ `(let* ((,seg-var ,(or segment '(%%current-segment%%)))
+ (,vop-var ,(or vop '(%%current-vop%%)))
+ ,@(when segment
+ `((**current-segment** ,seg-var)))
+ ,@(when vop
+ `((**current-vop** ,vop-var)))
,@(mapcar (lambda (name)
`(,name (gen-label)))
new-labels))
,@(mapcar (lambda (name)
`(,name (gen-label)))
new-labels))
- (symbol-macrolet ((**current-segment** ,seg-var)
- (**current-vop** ,vop-var)
- ,@(when (or inherited-labels nested-labels)
+ (macrolet ((%%current-segment%% () '**current-segment**)
+ (%%current-vop%% () '**current-vop**))
+ (symbol-macrolet (,@(when (or inherited-labels nested-labels)
`((..inherited-labels.. ,nested-labels))))
,@(mapcar (lambda (form)
(if (label-name-p form)
`(emit-label ,form)
form))
`((..inherited-labels.. ,nested-labels))))
,@(mapcar (lambda (form)
(if (label-name-p form)
`(emit-label ,form)
form))
(defmacro inst (&whole whole instruction &rest args &environment env)
#!+sb-doc
(defmacro inst (&whole whole instruction &rest args &environment env)
#!+sb-doc
((functionp inst)
(funcall inst (cdr whole) env))
(t
((functionp inst)
(funcall inst (cdr whole) env))
(t
- `(,inst **current-segment** **current-vop** ,@args)))))
+ `(,inst (%%current-segment%%) (%%current-vop%%) ,@args)))))
;;; Note: The need to capture SYMBOL-MACROLET bindings of
;;; **CURRENT-SEGMENT* and **CURRENT-VOP** prevents this from being an
;;; Note: The need to capture SYMBOL-MACROLET bindings of
;;; **CURRENT-SEGMENT* and **CURRENT-VOP** prevents this from being an
(defmacro emit-label (label)
#!+sb-doc
"Emit LABEL at this location in the current segment."
(defmacro emit-label (label)
#!+sb-doc
"Emit LABEL at this location in the current segment."
- `(%emit-label **current-segment** **current-vop** ,label))
+ `(%emit-label (%%current-segment%%) (%%current-vop%%) ,label))
;;; Note: The need to capture SYMBOL-MACROLET bindings of
;;; **CURRENT-SEGMENT* prevents this from being an ordinary function.
(defmacro emit-postit (function)
;;; Note: The need to capture SYMBOL-MACROLET bindings of
;;; **CURRENT-SEGMENT* prevents this from being an ordinary function.
(defmacro emit-postit (function)
- `(%emit-postit **current-segment** ,function))
+ `(%emit-postit (%%current-segment%%) ,function))
;;; Note: The need to capture SYMBOL-MACROLET bindings of
;;; Note: The need to capture SYMBOL-MACROLET bindings of
-;;; **CURRENT-SEGMENT* and **CURRENT-VOP** prevents this from being an
+;;; **CURRENT-SEGMENT* and (%%CURRENT-VOP%%) prevents this from being an
;;; ordinary function.
(defmacro align (bits &optional (fill-byte 0))
#!+sb-doc
"Emit an alignment restriction to the current segment."
;;; ordinary function.
(defmacro align (bits &optional (fill-byte 0))
#!+sb-doc
"Emit an alignment restriction to the current segment."
- `(emit-alignment **current-segment** **current-vop** ,bits ,fill-byte))
+ `(emit-alignment (%%current-segment%%) (%%current-vop%%) ,bits ,fill-byte))
;;; FIXME: By analogy with EMIT-LABEL and EMIT-POSTIT, this should be
;;; called EMIT-ALIGNMENT, and the function that it calls should be
;;; called %EMIT-ALIGNMENT.
;;; FIXME: By analogy with EMIT-LABEL and EMIT-POSTIT, this should be
;;; called EMIT-ALIGNMENT, and the function that it calls should be
;;; called %EMIT-ALIGNMENT.
`((declare ,@decls)))
(let ((,postits (segment-postits ,segment-name)))
(setf (segment-postits ,segment-name) nil)
`((declare ,@decls)))
(let ((,postits (segment-postits ,segment-name)))
(setf (segment-postits ,segment-name) nil)
- (symbol-macrolet
- (;; Apparently this binding is intended to keep
- ;; anyone from accidentally using
- ;; **CURRENT-SEGMENT** within the body of the
- ;; emitter. The error message sorta suggests that
- ;; this can happen accidentally by including one
- ;; emitter inside another. But I dunno.. -- WHN
- ;; 19990323
- (**current-segment**
- ;; FIXME: I can't see why we have to use
- ;; (MACROLET ((LOSE () (ERROR ..))) (LOSE))
- ;; instead of just (ERROR "..") here.
- (macrolet ((lose ()
- (error "You can't use INST without an ~
- ASSEMBLE inside emitters.")))
- (lose))))
+ (macrolet ((%%current-segment%% ()
+ (error "You can't use INST without an ~
+ ASSEMBLE inside emitters.")))
,@emitter))
(values))
(eval-when (:compile-toplevel :load-toplevel :execute)
,@emitter))
(values))
(eval-when (:compile-toplevel :load-toplevel :execute)
;;; should be made more consistent.
(defun dump-package (pkg file)
(declare (type package pkg) (type fasl-output file))
;;; should be made more consistent.
(defun dump-package (pkg file)
(declare (type package pkg) (type fasl-output file))
- (declare (values index))
+ #+nil (declare (values index))
(declare (inline assoc))
(cond ((cdr (assoc pkg (fasl-output-packages file) :test #'eq)))
(t
(declare (inline assoc))
(cond ((cdr (assoc pkg (fasl-output-packages file) :test #'eq)))
(t
-;;; FIXME: It would be good to implement SB!XC:DEFCONSTANT, and use
-;;; use that here, so that the compiler is born knowing this value.
-;;; FIXME: Add a comment telling whether this holds for all vectors
-;;; or only for vectors based on simple arrays (non-adjustable, etc.).
-(defconstant vector-data-bit-offset
- (* sb!vm:vector-data-offset sb!vm:n-word-bits))
-
;;; We need to define these predicates, since the TYPEP source
;;; transform picks whichever predicate was defined last when there
;;; are multiple predicates for equivalent types.
;;; We need to define these predicates, since the TYPEP source
;;; transform picks whichever predicate was defined last when there
;;; are multiple predicates for equivalent types.
;;; demanded a function.
(defun find-free-fun (name context)
(declare (string context))
;;; demanded a function.
(defun find-free-fun (name context)
(declare (string context))
- (declare (values global-var))
+ #+nil (declare (values global-var))
(or (let ((old-free-fun (gethash name *free-funs*)))
(and (not (invalid-free-fun-p old-free-fun))
old-free-fun))
(or (let ((old-free-fun (gethash name *free-funs*)))
(and (not (invalid-free-fun-p old-free-fun))
old-free-fun))
;;; information from the global environment and enter it in
;;; *FREE-VARS*. If the variable is unknown, then we emit a warning.
(defun find-free-var (name)
;;; information from the global environment and enter it in
;;; *FREE-VARS*. If the variable is unknown, then we emit a warning.
(defun find-free-var (name)
- (declare (values (or leaf cons heap-alien-info))) ; see FIXME comment
+ #+nil (declare (values (or leaf cons heap-alien-info))) ; see FIXME comment
(unless (symbolp name)
(compiler-error "Variable name is not a symbol: ~S." name))
(or (gethash name *free-vars*)
(unless (symbolp name)
(compiler-error "Variable name is not a symbol: ~S." name))
(or (gethash name *free-vars*)
;;;; calls when all arguments are vectors with the same element type,
;;;; rather than restricting them to STRINGs only.
;;;; calls when all arguments are vectors with the same element type,
;;;; rather than restricting them to STRINGs only.
+;;; Moved here from generic/vm-tran.lisp to satisfy clisp
+;;;
+;;; FIXME: It would be good to implement SB!XC:DEFCONSTANT, and use
+;;; use that here, so that the compiler is born knowing this value.
+;;; FIXME: Add a comment telling whether this holds for all vectors
+;;; or only for vectors based on simple arrays (non-adjustable, etc.).
+(defconstant vector-data-bit-offset
+ (* sb!vm:vector-data-offset sb!vm:n-word-bits))
+
;;; FIXME: Shouldn't we be testing for legality of
;;; * START1, START2, END1, and END2 indices?
;;; * size of copied string relative to destination string?
;;; FIXME: Shouldn't we be testing for legality of
;;; * START1, START2, END1, and END2 indices?
;;; * size of copied string relative to destination string?
(in-package "SB!C")
(defun trace-table-entry (state)
(in-package "SB!C")
(defun trace-table-entry (state)
+ (declare (special *trace-table-info*))
(let ((label (gen-label)))
(emit-label label)
(push (cons label state) *trace-table-info*))
(let ((label (gen-label)))
(emit-label label)
(push (cons label state) *trace-table-info*))
(setf sb!disassem:*disassem-inst-alignment-bytes* 1)
(deftype reg () '(unsigned-byte 3))
(setf sb!disassem:*disassem-inst-alignment-bytes* 1)
(deftype reg () '(unsigned-byte 3))
+
+(defconstant +default-operand-size+ :dword)
\f
(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
\f
(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
(defconstant +operand-size-prefix-byte+ #b01100110)
(defconstant +operand-size-prefix-byte+ #b01100110)
-(defconstant +default-operand-size+ :dword)
-
(defun maybe-emit-operand-size-prefix (segment size)
(unless (or (eq size :byte) (eq size +default-operand-size+))
(emit-byte segment +operand-size-prefix-byte+)))
(defun maybe-emit-operand-size-prefix (segment size)
(unless (or (eq size :byte) (eq size +default-operand-size+))
(emit-byte segment +operand-size-prefix-byte+)))
(defconstant binding-stack-end #x3ffff000)
(defconstant control-stack-start
(defconstant binding-stack-end #x3ffff000)
(defconstant control-stack-start
- #+freebsd #x40000000
- #+openbsd #x48000000)
+ #!+freebsd #x40000000
+ #!+openbsd #x48000000)
(defconstant control-stack-end
(defconstant control-stack-end
- #+freebsd #x47fff000
- #+openbsd #x4ffff000)
+ #!+freebsd #x47fff000
+ #!+openbsd #x4ffff000)
(defconstant dynamic-space-start
(defconstant dynamic-space-start
- #+freebsd #x48000000
- #+openbsd #x50000000)
+ #!+freebsd #x48000000
+ #!+openbsd #x50000000)
(defconstant dynamic-space-end #x88000000))
;;; Given that NIL is the first thing allocated in static space, we
(defconstant dynamic-space-end #x88000000))
;;; Given that NIL is the first thing allocated in static space, we
;;; for internal versions, especially for internal versions off the
;;; main CVS branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
;;; for internal versions, especially for internal versions off the
;;; main CVS branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)