Commit 81fea73c authored by rtoy's avatar rtoy
Browse files

Merge changes from utf16 branch to update to snapshot 2008-12.

parent 38372d1a
Loading
Loading
Loading
Loading
+14 −1
Original line number Diff line number Diff line
@@ -74,9 +74,14 @@
(load "vm:primtype")
(load "vm:move")
(load "vm:sap")
(when (target-featurep :sse2)
  (load "vm:sse2-sap"))

(load "vm:system")
(load "vm:char")
(load "vm:float")
(if (target-featurep :sse2)
    (load "vm:float-sse2")
    (load "vm:float"))

(load "vm:memory")
(load "vm:static-fn")
@@ -85,11 +90,19 @@
(load "vm:subprim")
(load "vm:debug")
(load "vm:c-call")
(when (target-featurep :sse2)
  (load "vm:sse2-c-call"))

(load "vm:print")
(load "vm:alloc")
(load "vm:call")
(load "vm:nlx")
(load "vm:values")
;; These need to be loaded before array because array wants to use
;; some vops as templates.
(load (if (target-featurep :sse2)
	  "vm:sse2-array"
	  "vm:x87-array"))
(load "vm:array")
(load "vm:pred")
(load "vm:type-vops")
+212 −0
Original line number Diff line number Diff line
;; Bootstrap file for cross-compiling SSE2 support for x86.

(in-package :cl-user)

;;; Rename the X86 package and backend so that new-backend does the
;;; right thing.
(rename-package "X86" "OLD-X86" '("OLD-VM"))
(setf (c:backend-name c:*native-backend*) "OLD-X86")

(c::new-backend "X86"
   ;; Features to add here.  These are just examples.  You may not
   ;; need to list anything here.  We list them here anyway as a
   ;; record of typical features for all x86 ports.
   '(:x86 :i486 :pentium
     :stack-checking			; Catches stack overflow
     :heap-overflow-check		; Catches heap overflows
     :relative-package-names		; relative package names
     :mp				; multiprocessing
     :gencgc				; Generational GC
     :conservative-float-type
     :hash-new
     :random-mt19937
     :cmu :cmu19 :cmu19e		; Version features
     :double-double			; double-double float support
     :sse2				; SSE2 support
     :complex-fp-vops			; VOPs for complex arithmetic
     )
   ;; Features to remove from current *features* here.  Normally don't
   ;; need to list anything here unless you are trying to remove a
   ;; feature.
   '(:x86-bootstrap
     ;; :alpha :osf1 :mips
     :propagate-fun-type :propagate-float-type :constrain-float-type
     ;; :openbsd :freebsd :glibc2 :linux
     :long-float :new-random :small))

;;; Compile the new backend.
(pushnew :bootstrap *features*)
(pushnew :building-cross-compiler *features*)
(pushnew :sse2 *features*)
(pushnew :complex-fp-vops *features*)
(load "target:tools/comcom")

;;; Load the new backend.
(setf (search-list "c:")
      '("target:compiler/"))
(setf (search-list "vm:")
      '("c:x86/" "c:generic/"))
(setf (search-list "assem:")
      '("target:assembly/" "target:assembly/x86/"))

;; Load the backend of the compiler.

;; Why do it explicitly this way?  Why not use loadbackend.lisp?

(in-package "C")

(load "vm:vm-macs")
(load "vm:parms")
(load "vm:objdef")
(load "vm:interr")
(load "assem:support")

(load "target:compiler/srctran")
(load "vm:vm-typetran")
(load "target:compiler/float-tran")
(load "target:compiler/saptran")

(load "vm:macros")
(load "vm:utils")

(load "vm:vm")
(load "vm:insts")
(load "vm:primtype")
(load "vm:move")
(load "vm:sap")
(when (target-featurep :sse2)
  (load "vm:sse2-sap"))

(load "vm:system")
(load "vm:char")
(if (target-featurep :sse2)
    (load "vm:float-sse2")
    (load "vm:float"))

(load "vm:memory")
(load "vm:static-fn")
(load "vm:arith")
(load "vm:cell")
(load "vm:subprim")
(load "vm:debug")
(load "vm:c-call")
(when (target-featurep :sse2)
  (load "vm:sse2-c-call"))
(load "vm:print")
(load "vm:alloc")
(load "vm:call")
(load "vm:nlx")
(load "vm:values")
;; These need to be loaded before array because array wants to use
;; some vops as templates.
(load (if (target-featurep :sse2)
	  "vm:sse2-array"
	  "vm:x87-array"))
(load "vm:array")
(load "vm:pred")
(load "vm:type-vops")

(load "assem:assem-rtns")

(load "assem:array")
(load "assem:arith")
(load "assem:alloc")

(load "c:pseudo-vops")

(check-move-function-consistency)

(load "vm:new-genesis")

;;; OK, the cross compiler backend is loaded.

(setf *features* (remove :building-cross-compiler *features*))

;;; Info environment hacks.
(macrolet ((frob (&rest syms)
	     `(progn ,@(mapcar #'(lambda (sym)
				   `(defconstant ,sym
				      (symbol-value
				       (find-symbol ,(symbol-name sym)
						    :vm))))
			       syms))))
  (frob OLD-VM:BYTE-BITS OLD-VM:WORD-BITS
	#+long-float OLD-VM:SIMPLE-ARRAY-LONG-FLOAT-TYPE 
	OLD-VM:SIMPLE-ARRAY-DOUBLE-FLOAT-TYPE 
	OLD-VM:SIMPLE-ARRAY-SINGLE-FLOAT-TYPE
	#+long-float OLD-VM:SIMPLE-ARRAY-COMPLEX-LONG-FLOAT-TYPE 
	OLD-VM:SIMPLE-ARRAY-COMPLEX-DOUBLE-FLOAT-TYPE 
	OLD-VM:SIMPLE-ARRAY-COMPLEX-SINGLE-FLOAT-TYPE
	OLD-VM:SIMPLE-ARRAY-UNSIGNED-BYTE-2-TYPE 
	OLD-VM:SIMPLE-ARRAY-UNSIGNED-BYTE-4-TYPE
	OLD-VM:SIMPLE-ARRAY-UNSIGNED-BYTE-8-TYPE 
	OLD-VM:SIMPLE-ARRAY-UNSIGNED-BYTE-16-TYPE 
	OLD-VM:SIMPLE-ARRAY-UNSIGNED-BYTE-32-TYPE 
	OLD-VM:SIMPLE-ARRAY-SIGNED-BYTE-8-TYPE 
	OLD-VM:SIMPLE-ARRAY-SIGNED-BYTE-16-TYPE
	OLD-VM:SIMPLE-ARRAY-SIGNED-BYTE-30-TYPE 
	OLD-VM:SIMPLE-ARRAY-SIGNED-BYTE-32-TYPE
	OLD-VM:SIMPLE-BIT-VECTOR-TYPE
	OLD-VM:SIMPLE-STRING-TYPE OLD-VM:SIMPLE-VECTOR-TYPE 
	OLD-VM:SIMPLE-ARRAY-TYPE OLD-VM:VECTOR-DATA-OFFSET
	OLD-VM:DOUBLE-FLOAT-EXPONENT-BYTE
	OLD-VM:DOUBLE-FLOAT-NORMAL-EXPONENT-MAX 
	OLD-VM:DOUBLE-FLOAT-SIGNIFICAND-BYTE
	OLD-VM:SINGLE-FLOAT-EXPONENT-BYTE
	OLD-VM:SINGLE-FLOAT-NORMAL-EXPONENT-MAX
	OLD-VM:SINGLE-FLOAT-SIGNIFICAND-BYTE
	)
  #+double-double
  (frob OLD-VM:SIMPLE-ARRAY-COMPLEX-DOUBLE-DOUBLE-FLOAT-TYPE
	OLD-VM:SIMPLE-ARRAY-DOUBLE-DOUBLE-FLOAT-TYPE))

;; Modular arith hacks
(setf (fdefinition 'vm::ash-left-mod32) #'old-vm::ash-left-mod32)
(setf (fdefinition 'vm::lognot-mod32) #'old-vm::lognot-mod32)
;; End arith hacks

(let ((function (symbol-function 'kernel:error-number-or-lose)))
  (let ((*info-environment* (c:backend-info-environment c:*target-backend*)))
    (setf (symbol-function 'kernel:error-number-or-lose) function)
    (setf (info function kind 'kernel:error-number-or-lose) :function)
    (setf (info function where-from 'kernel:error-number-or-lose) :defined)))

(defun fix-class (name)
  (let* ((new-value (find-class name))
	 (new-layout (kernel::%class-layout new-value))
	 (new-cell (kernel::find-class-cell name))
	 (*info-environment* (c:backend-info-environment c:*target-backend*)))
    (remhash name kernel::*forward-referenced-layouts*)
    (kernel::%note-type-defined name)
    (setf (info type kind name) :instance)
    (setf (info type class name) new-cell)
    (setf (info type compiler-layout name) new-layout)
    new-value))
(fix-class 'c::vop-parse)
(fix-class 'c::operand-parse)

#+random-mt19937
(declaim (notinline kernel:random-chunk))

(setf c:*backend* c:*target-backend*)

;;; Extern-alien-name for the new backend.
(in-package :vm)
(defun extern-alien-name (name)
  (declare (type simple-string name))
  name)
(export 'extern-alien-name)
(export 'fixup-code-object)
(export 'sanctify-for-execution)
(in-package :cl-user)

;;; Don't load compiler parts from the target compilation

(defparameter *load-stuff* nil)

;; hack, hack, hack: Make old-vm::any-reg the same as
;; x86::any-reg as an SC.  Do this by adding old-vm::any-reg
;; to the hash table with the same value as x86::any-reg.
(let ((ht (c::backend-sc-names c::*target-backend*)))
  (setf (gethash 'old-vm::any-reg ht)
	(gethash 'vm::any-reg ht)))
+4 −0
Original line number Diff line number Diff line
;; Re-enable this on sparc.  It makes the simple FFT butterfly 2.5
;; times faster.
#+sparc
(pushnew :complex-fp-vops *features*)
+3 −1
Original line number Diff line number Diff line
@@ -5,7 +5,7 @@
;;; Carnegie Mellon University, and has been placed in the public domain.
;;;
(ext:file-comment
  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/commandline.lisp,v 1.15 2004/08/17 20:24:37 rtoy Exp $")
  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/commandline.lisp,v 1.15.20.1 2008/12/19 01:31:32 rtoy Exp $")
;;;
;;; **********************************************************************
;;;
@@ -206,3 +206,5 @@
(defswitch "lib")
(defswitch "quiet")
(defswitch "debug-lisp-search")
#+x86
(defswitch "fpu")
+4 −19
Original line number Diff line number Diff line
@@ -5,7 +5,7 @@
;;; Carnegie Mellon University, and has been placed in the public domain.
;;;
(ext:file-comment
  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/debug-int.lisp,v 1.133.6.1 2008/11/02 13:30:00 rtoy Exp $")
  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/debug-int.lisp,v 1.133.6.2 2008/12/19 01:31:32 rtoy Exp $")
;;;
;;; **********************************************************************
;;;
@@ -1421,23 +1421,8 @@ The result is a symbol or nil if the routine cannot be found."
    (alien:with-alien
	((lisp-interrupt-contexts (array (* unix:sigcontext) nil) :extern))
      (let ((scp (alien:deref lisp-interrupt-contexts index)))
	;; FIXME: The mcontext slot on Darwin was sometimes 0, which
	;; causes an error if we try to look up the cfp-offset value.
	;; This seems to gone now, but we leave this in for now to
	;; catch this condition.  If this doesn't happen anymore, we
	;; can remove this later.
	#+ignore
	(when (zerop (sys:sap-int (alien:alien-sap (alien:slot scp 'vm::sc-mcontext))))
	  (cerror "Continue."
		  "NULL mcontext found at index ~D, scp = ~S.  Please report this bug!"
		  index
		  (alien:alien-sap scp)))
	(when (and
	       #+ignore
	       (not
		(zerop (sys:sap-int (alien:alien-sap (alien:slot scp 'vm::sc-mcontext)))))
	       (= (system:sap-int frame-pointer)
		  (vm:sigcontext-register scp vm::cfp-offset)))
	(when (= (system:sap-int frame-pointer)
		 (vm:sigcontext-register scp vm::cfp-offset))
	  (system:without-gcing
	   (let* ((component-ptr
		   (component-ptr-from-pc (vm:sigcontext-program-counter scp)))
Loading