Merge in SSE2 changes from sse2-packed-branch (tag (cb786538) · Commits · Carl Shapiro / cmucl

bootfiles/19e/boot-2008-09-sse2.lisp

0 → 100644

+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)))

code/commandline.lisp

+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.16 2008/11/12 15:04:23 rtoy Exp $")
		;;;
		;;; **********************************************************************
		;;;
		@@ -206,3 +206,5 @@
		(defswitch "lib")
		(defswitch "quiet")
		(defswitch "debug-lisp-search")
		#+x86
		(defswitch "fpu")

code/error.lisp

+4 −4

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/error.lisp,v 1.85 2006/01/03 18:09:55 rtoy Exp $")
		"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/error.lisp,v 1.86 2008/11/12 15:04:23 rtoy Exp $")
		;;;
		;;; **********************************************************************
		;;;
		@@ -908,7 +908,7 @@
		(multiple-value-prog1
		(progn ,@forms)
		;; Wait for any float exceptions
		#+x86 (float-wait))))
		#+x87 (float-wait))))


		;;;; Condition definitions.
		@@ -1172,8 +1172,8 @@
		(go ,(car annotated-case)))))
		annotated-cases)
		(return-from ,tag
		#-x86 ,form
		#+x86 (multiple-value-prog1 ,form
		#-x87 ,form
		#+x87 (multiple-value-prog1 ,form
		;; Need to catch FP errors here!
		(kernel::float-wait))))
		,@(mapcan

code/exports.lisp

+6 −2

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/exports.lisp,v 1.272 2008/10/03 13:34:01 rtoy Exp $")
		"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/exports.lisp,v 1.273 2008/11/12 15:04:23 rtoy Exp $")
		;;;
		;;; **********************************************************************
		;;;
		@@ -2222,7 +2222,11 @@
		"SIMPLE-UNDEFINED-FUNCTION" "SIMPLE-PARSE-ERROR" "SIMPLE-STREAM-ERROR"
		"BYTE-FUNCTION-TYPE" "SLOT-CLASS-PRINT-FUNCTION"
		"REDEFINE-LAYOUT-WARNING" "SLOT-CLASS" "INSURED-FIND-CLASS"
		"CONDITION-FUNCTION-NAME")
		"CONDITION-FUNCTION-NAME"

		"%COMPLEX-SINGLE-FLOAT"
		"%COMPLEX-DOUBLE-FLOAT"
		"%COMPLEX-DOUBLE-DOUBLE-FLOAT")
		#+heap-overflow-check
		(:export "DYNAMIC-SPACE-OVERFLOW-WARNING-HIT"
		"DYNAMIC-SPACE-OVERFLOW-ERROR-HIT"

code/float-trap.lisp

+48 −2

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/float-trap.lisp,v 1.32 2008/01/03 11:41:51 cshapiro Exp $")
		"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/float-trap.lisp,v 1.33 2008/11/12 15:04:23 rtoy Exp $")
		;;;
		;;; **********************************************************************
		;;;
		@@ -54,9 +54,42 @@

		;;; Interpreter stubs.
		;;;
		#-sse2
		(progn
		(defun floating-point-modes () (floating-point-modes))
		(defun (setf floating-point-modes) (new) (setf (floating-point-modes) new))
		)

		#+sse2
		(progn
		(defun floating-point-modes ()
		;; Combine the modes from the FPU and SSE2 units. Since the sse
		;; mode contains all of the common information we want, we massage
		;; the x87-modes to match, and then OR the x87 and sse2 modes
		;; together. Note: We ignore the rounding control bits from the
		;; FPU and only use the SSE2 rounding control bits.
		(let* ((x87-modes (vm::x87-floating-point-modes))
		(sse-modes (vm::sse2-floating-point-modes))
		(final-mode (logior sse-modes
		(ash (logand #x3f x87-modes) 7) ; control
		(logand #x3f (ash x87-modes -16)))))

		final-mode))
		(defun (setf floating-point-modes) (new-mode)
		(declare (type (unsigned-byte 24) new-mode))
		;; Set the floating point modes for both X87 and SSE2. This
		;; include the rounding control bits.
		(let* ((rc (ldb float-rounding-mode new-mode))
		(x87-modes
		(logior (ash (logand #x3f new-mode) 16)
		(ash rc 10)
		(logand #x3f (ash new-mode -7))
		;; Set precision control to be 64-bit, always.
		(ash 3 8))))
		(setf (vm::sse2-floating-point-modes) new-mode)
		(setf (vm::x87-floating-point-modes) x87-modes))
		new-mode)
		)

		;;; SET-FLOATING-POINT-MODES -- Public
		;;;
		@@ -188,6 +221,20 @@
		(setf (sigcontext-floating-point-modes
		(alien:sap-alien scp (* unix:sigcontext)))
		new-modes))
		#+sse2
		(let* ((new-modes modes)
		(new-exceptions (logandc2 (ldb float-exceptions-byte new-modes)
		traps)))
		;; Clear out the status for any enabled traps. With SSE2, if
		;; the current exception is enabled, the next FP instruction
		;; will cause the exception to be signaled again. Hence, we
		;; need to clear out the exceptions that we are handling here.
		(setf (ldb float-exceptions-byte new-modes) new-exceptions)
		;; XXX: This seems not right. Shouldn't we be setting the modes
		;; in the sigcontext instead? This however seems to do what we
		;; want.
		(setf (vm:floating-point-modes) new-modes))

		(multiple-value-bind (fop operands)
		(let ((sym (find-symbol "GET-FP-OPERANDS" "VM")))
		(if (fboundp sym)
		@@ -216,7 +263,6 @@
		(t
		(error "SIGFPE with no exceptions currently enabled?"))))))


		;;; WITH-FLOAT-TRAPS-MASKED -- Public
		;;;
		(defmacro with-float-traps-masked (traps &body body)