Update of /cvsroot/sbcl/sbcl/src/code
In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv28442/src/code
Modified Files:
Tag: lutex-branch
typedefs.lisp toplevel.lisp target-alieneval.lisp load.lisp
fop.lisp eval.lisp early-fasl.lisp defboot.lisp
Log Message:
0.9.12.26.lutex-branch.33
* merging 0.9.12.26 changes onto the lutex branch
Index: typedefs.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/typedefs.lisp,v
retrieving revision 1.20
retrieving revision 1.20.6.1
diff -u -d -r1.20 -r1.20.6.1
--- typedefs.lisp 14 Jul 2005 16:30:40 -0000 1.20
+++ typedefs.lisp 15 May 2006 17:07:51 -0000 1.20.6.1
@@ -59,6 +59,8 @@
;;; DEFVARs for these come later, after we have enough stuff defined.
(declaim (special *wild-type* *universal-type* *empty-type*))
+(defvar *type-random-state*)
+
;;; the base class for the internal representation of types
(def!struct (ctype (:conc-name type-)
(:constructor nil)
@@ -77,7 +79,11 @@
(enumerable nil :read-only t)
;; an arbitrary hash code used in EQ-style hashing of identity
;; (since EQ hashing can't be done portably)
- (hash-value (random #.(ash 1 15))
+ (hash-value (random #.(ash 1 15)
+ (if (boundp '*type-random-state*)
+ *type-random-state*
+ (setf *type-random-state*
+ (make-random-state))))
:type (and fixnum unsigned-byte)
:read-only t)
;; Can this object contain other types? A global property of our
Index: toplevel.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/toplevel.lisp,v
retrieving revision 1.80.2.1
retrieving revision 1.80.2.2
diff -u -d -r1.80.2.1 -r1.80.2.2
--- toplevel.lisp 22 Apr 2006 03:08:08 -0000 1.80.2.1
+++ toplevel.lisp 15 May 2006 17:07:51 -0000 1.80.2.2
@@ -588,6 +588,7 @@
;; In the event of a control-stack-exhausted-error, we
;; should have unwound enough stack by the time we get
;; here that this is now possible.
+ #!-win32
(sb!kernel::protect-control-stack-guard-page 1)
(funcall repl-fun noprint)
(critically-unreachable "after REPL"))))))))))
Index: target-alieneval.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/target-alieneval.lisp,v
retrieving revision 1.43
retrieving revision 1.43.2.1
diff -u -d -r1.43 -r1.43.2.1
--- target-alieneval.lisp 27 Feb 2006 13:12:35 -0000 1.43
+++ target-alieneval.lisp 15 May 2006 17:07:51 -0000 1.43.2.1
@@ -933,8 +933,8 @@
(setf (callback-info-function info) nil)
t)))
-;;; FIXME: This calls assembles a new callback for every closure,
-;;; which suck hugely. ...not that I can think of an obvious
+;;; FIXME: This call assembles a new callback for every closure,
+;;; which sucks hugely. ...not that I can think of an obvious
;;; solution. Possibly maybe we could write a generalized closure
;;; callback analogous to closure_tramp, and share the actual wrapper?
;;;
Index: load.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/load.lisp,v
retrieving revision 1.39
retrieving revision 1.39.2.1
diff -u -d -r1.39 -r1.39.2.1
--- load.lisp 30 Dec 2005 00:21:42 -0000 1.39
+++ load.lisp 15 May 2006 17:07:51 -0000 1.39.2.1
@@ -174,9 +174,12 @@
(aver (member pushp '(nil t :nope)))
(with-unique-names (fop-stack)
`(let ((,fop-stack *fop-stack*))
- (declare (type (vector t) ,fop-stack))
+ (declare (type (vector t) ,fop-stack)
+ (ignorable ,fop-stack))
(macrolet ((pop-stack ()
`(vector-pop ,',fop-stack))
+ (push-stack (value)
+ `(vector-push-extend ,value ,',fop-stack))
(call-with-popped-args (fun n)
`(%call-with-popped-args ,fun ,n ,',fop-stack)))
,(if pushp
@@ -365,10 +368,11 @@
(defun load-fasl-group (stream)
(when (check-fasl-header stream)
(catch 'fasl-group-end
- (let ((*current-fop-table-index* 0))
+ (let ((*current-fop-table-index* 0)
+ (*skip-until* nil))
+ (declare (special *skip-until*))
(loop
(let ((byte (read-byte stream)))
-
;; Do some debugging output.
#!+sb-show
(when *show-fops-p*
Index: fop.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/fop.lisp,v
retrieving revision 1.43
retrieving revision 1.43.4.1
diff -u -d -r1.43 -r1.43.4.1
--- fop.lisp 9 Sep 2005 14:16:18 -0000 1.43
+++ fop.lisp 15 May 2006 17:07:51 -0000 1.43.4.1
@@ -2,6 +2,12 @@
(in-package "SB!FASL")
+;;; Sometimes we want to skip over any FOPs with side-effects (like
+;;; function calls) while executing other FOPs. *SKIP-UNTIL* will
+;;; either contain the position where the skipping will stop, or
+;;; NIL if we're executing normally.
+(defvar *skip-until* nil)
+
;;; Define NAME as a fasl operation, with op-code FOP-CODE. PUSHP
;;; describes what the body does to the fop stack:
;;; T
@@ -507,43 +513,53 @@
res)))
(define-fop (fop-eval 53)
- (let ((result (eval (pop-stack))))
- ;; FIXME: CMU CL had this code here:
- ;; (when *load-print*
- ;; (load-fresh-line)
- ;; (prin1 result)
- ;; (terpri))
- ;; Unfortunately, this dependence on the *LOAD-PRINT* global
- ;; variable is non-ANSI, so for now we've just punted printing in
- ;; fasl loading.
- result))
+ (if *skip-until*
+ (pop-stack)
+ (let ((result (eval (pop-stack))))
+ ;; FIXME: CMU CL had this code here:
+ ;; (when *load-print*
+ ;; (load-fresh-line)
+ ;; (prin1 result)
+ ;; (terpri))
+ ;; Unfortunately, this dependence on the *LOAD-PRINT* global
+ ;; variable is non-ANSI, so for now we've just punted printing in
+ ;; fasl loading.
+ result)))
(define-fop (fop-eval-for-effect 54 :pushp nil)
- (let ((result (eval (pop-stack))))
- ;; FIXME: See the comment about *LOAD-PRINT* in FOP-EVAL.
- (declare (ignore result))
- #+nil (when *load-print*
- (load-fresh-line)
- (prin1 result)
- (terpri))))
+ (if *skip-until*
+ (pop-stack)
+ (let ((result (eval (pop-stack))))
+ ;; FIXME: See the comment about *LOAD-PRINT* in FOP-EVAL.
+ (declare (ignore result))
+ #+nil (when *load-print*
+ (load-fresh-line)
+ (prin1 result)
+ (terpri)))))
(define-fop (fop-funcall 55)
(let ((arg (read-byte-arg)))
- (if (zerop arg)
- (funcall (pop-stack))
- (do ((args () (cons (pop-stack) args))
- (n arg (1- n)))
- ((zerop n) (apply (pop-stack) args))
- (declare (type index n))))))
+ (if *skip-until*
+ (dotimes (i (1+ arg))
+ (pop-stack))
+ (if (zerop arg)
+ (funcall (pop-stack))
+ (do ((args () (cons (pop-stack) args))
+ (n arg (1- n)))
+ ((zerop n) (apply (pop-stack) args))
+ (declare (type index n)))))))
(define-fop (fop-funcall-for-effect 56 :pushp nil)
(let ((arg (read-byte-arg)))
- (if (zerop arg)
- (funcall (pop-stack))
- (do ((args () (cons (pop-stack) args))
- (n arg (1- n)))
- ((zerop n) (apply (pop-stack) args))
- (declare (type index n))))))
+ (if *skip-until*
+ (dotimes (i (1+ arg))
+ (pop-stack))
+ (if (zerop arg)
+ (funcall (pop-stack))
+ (do ((args () (cons (pop-stack) args))
+ (n arg (1- n)))
+ ((zerop n) (apply (pop-stack) args))
+ (declare (type index n)))))))
;;;; fops for fixing up circularities
@@ -718,3 +734,46 @@
(foreign-symbol-address sym t)
kind)
code-object))
+
+;;; FOPs needed for implementing an IF operator in a FASL
+
+;;; Skip until a FOP-MAYBE-STOP-SKIPPING with the same POSITION is
+;;; executed. While skipping, we execute most FOPs normally, except
+;;; for ones that a) funcall/eval b) start skipping. This needs to
+;;; be done to ensure that the fop table gets populated correctly
+;;; regardless of the execution path.
+(define-fop (fop-skip 151 :pushp nil)
+ (let ((position (pop-stack)))
+ (unless *skip-until*
+ (setf *skip-until* position)))
+ (values))
+
+;;; As before, but only start skipping if the top of the FOP stack is NIL.
+(define-fop (fop-skip-if-false 152 :pushp nil)
+ (let ((condition (pop-stack))
+ (position (pop-stack)))
+ (unless (or condition
+ *skip-until*)
+ (setf *skip-until* position)))
+ (values))
+
+;;; If skipping, pop the top of the stack and discard it. Needed for
+;;; ensuring that the stack stays balanced when skipping.
+(define-fop (fop-drop-if-skipping 153 :pushp nil)
+ (when *skip-until*
+ (pop-stack))
+ (values))
+
+;;; If skipping, push a dummy value on the stack. Needed for
+;;; ensuring that the stack stays balanced when skipping.
+(define-fop (fop-push-nil-if-skipping 154 :pushp nil)
+ (when *skip-until*
+ (push-stack nil))
+ (values))
+
+;;; Stop skipping if the top of the stack matches *SKIP-UNTIL*
+(define-fop (fop-maybe-stop-skipping 155 :pushp nil)
+ (let ((label (pop-stack)))
+ (when (eql *skip-until* label)
+ (setf *skip-until* nil)))
+ (values))
Index: eval.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/eval.lisp,v
retrieving revision 1.34.6.1
retrieving revision 1.34.6.2
diff -u -d -r1.34.6.1 -r1.34.6.2
--- eval.lisp 22 Apr 2006 03:08:08 -0000 1.34.6.1
+++ eval.lisp 15 May 2006 17:07:51 -0000 1.34.6.2
@@ -231,6 +231,11 @@
then
else)
lexenv)))
+ ((let let*)
+ (destructuring-bind (definitions &rest body) (rest exp)
+ (if (null definitions)
+ (eval-locally `(locally ,@body) lexenv)
+ (%eval exp lexenv))))
(t
(if (and (symbolp name)
(eq (info :function :kind name) :function))
Index: early-fasl.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/early-fasl.lisp,v
retrieving revision 1.63.2.1
retrieving revision 1.63.2.2
diff -u -d -r1.63.2.1 -r1.63.2.2
--- early-fasl.lisp 22 Apr 2006 03:08:08 -0000 1.63.2.1
+++ early-fasl.lisp 15 May 2006 17:07:51 -0000 1.63.2.2
@@ -76,7 +76,7 @@
;;; versions which break binary compatibility. But it certainly should
;;; be incremented for release versions which break binary
;;; compatibility.
-(def!constant +fasl-file-version+ 65)
+(def!constant +fasl-file-version+ 66)
;;; (record of versions before 2003 deleted in 2003-04-26/0.pre8.107 or so)
;;; 38: (2003-01-05) changed names of internal SORT machinery
;;; 39: (2003-02-20) in 0.7.12.1 a slot was added to
@@ -135,6 +135,7 @@
;;; 64: (2006-03-24) New calling convention for unknown-values on x86 and
;;; x86-64. Also (belatedly) PPC/gencgc, including :gencgc on FPAFF.
;;; 65: (2006-04-11) Package locking interface changed.
+;;; 66: (2006-05-13) Fopcompiler
;;; the conventional file extension for our fasl files
(declaim (type simple-string *fasl-file-type*))
Index: defboot.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/defboot.lisp,v
retrieving revision 1.51
retrieving revision 1.51.4.1
diff -u -d -r1.51 -r1.51.4.1
--- defboot.lisp 6 Nov 2005 08:40:31 -0000 1.51
+++ defboot.lisp 15 May 2006 17:07:51 -0000 1.51.4.1
@@ -23,9 +23,10 @@
;;;; IN-PACKAGE
-(defmacro-mundanely in-package (package-designator)
- `(eval-when (:compile-toplevel :load-toplevel :execute)
- (setq *package* (find-undeleted-package-or-lose ',package-designator))))
+(defmacro-mundanely in-package (string-designator)
+ (let ((string (string string-designator)))
+ `(eval-when (:compile-toplevel :load-toplevel :execute)
+ (setq *package* (find-undeleted-package-or-lose ,string)))))
;;;; MULTIPLE-VALUE-FOO
|