Commit d0ccb652 authored by rtoy's avatar rtoy
Browse files

Initial checkin of unicode branch. This is incomplete.

What works:
o Cross-compile works on sparc and a lisp.core is created.  This core
  is able to build code and appears to use 16-bit strings.

What doesn't:
o The sparc version is not able to rebuild itself.  It hangs when
  trying to create a new lisp.core.
o The x86 version will cross-compile, but worldload fails.  The files
  being loaded have bizarre names.  Probably some deftransform not
  working correctly.

Issues:
o Characters are still essentially 8 bits.  This needs to be fixed.
o All input/output is basically still 8 bits.  Only the low 8 bits of
  a character are output.  For input, characters are assumed to be
  8-bit.
o No external formats or anything is supported.
o Readtable support not done.


Use boot-2008-05-cross-unicode-{sparc,x86}.lisp to cross-compile the
unicode changes.

Untested whether this code can still be compiled without :unicode.

Changes:

code/array.lisp:
o Base-char strings are 16 bits wide, not 8.

code/c-call.lisp:
o Define versions of DEPORT-GEN, %NATURALIZE-C-STRING to "handle"
  unicode strings.

code/debug-info.lisp:
o Adjust READ-VAR-STRING to use 16-bit strings.  (Needed to at least
  to make the disassembler work.)

code/debug.lisp:
o Add address when printing out objects that can't be printed.
  (Generally useful and not just for unicode.)

code/fd-stream.lisp:
o Hack output routines to only use the low 8-bits of the character.
  (This needs significant work!)

code/filesys.lisp:
o Some debugging %primitive prints left in, but commented out, in
  PARSE-UNIX-NAMESTRING.

code/lispinit.lisp:
o Debugging %primitive print's for top-level forms.

code/load.lisp:
o Update FOP-SHORT-CHARACTER for unicode.  But still only output the
  low 8 bits of a character to a fasl/core.  This needs updating.
o Hack routines for symbols to explicitly read in the individual bytes
  of the symbol/package name because READ-N-BYTES isn't working for us
  right now.
o Update FOP-STRING/FOP-SMALL-STRING to read in 16-bit elements for
  strings.  Full 16-bit strings supported.
o Currently only write 8-bit chars for foreign names.  This needs
  fixing.

code/misc.lisp:
o Register :unicode runtime feature.

code/pathname.lisp:
o Debugging %primitive prints left in, but commented out.

code/stream.lisp:
o Replace %primitive byte-blt with REPLACE for now to get the desired
  characters.

code/unix-glibc2.lisp:
o Workaround for unix-current-directory to return 16-bit strings.
  (Not necessary anymore?)
o UNIX-RESOLVE-LINKS doesn't seem to like MAKE-STRING with an
  INITIAL-ELEMENT specified.  Remove initial-element.  (Needs fixing.)

code/unix.lisp:
o Same as for unix-glibc2.lisp

compiler/array-tran.lisp:
o Turn off the MAKE-STRING deftransform.
o Update ARRAY-INFO to create 16-bit arrays for an element-type of
  base-char.

compiler/dump.lisp:
o Only dump 8-bit chars to a fasl for foreign fixups.
o Explicitly dump the characters of symbol name.  DUMP-BYTES not quite
  working for us now?
o Make DUMP-SIMPLE-STRING dump all 16 bits of each character.
o Characters are dumped as the low 8 bits.  Needs fixing.

compiler/generic/new-genesis.lisp:
o STRING-TO-CORE writes 16-bit strings to the core file.
o FOP-SHORT-CHARACTER for unicode added, but we still only write 8
  bits to the core.  (Needs fixing.)
o COLD-LOAD-SYMBOL modified to read 16-bit characters from the fasl
  file to create a symbol.
o FOP-UNINTERNED-SYMBOL-SAVE and FOP-UNINTERNED-SMALL-SYMBOL-SAVE
  reads 16-bit characters for symbol names.
o FOP-STRING/FOP-SMALL-STRING reads 16-bit characters for strings.
o FOP-FOREIGN-FIXUP and FOP-FOREIGN-DATA-FIXUP still only read 8-bit
  characters for foreign names.  (Needs fixing.)

compiler/generic/vm-tran.lisp:
o New deftransforms to support unicode.  Not the most efficient but
  should be workable for now.  Old deftransforms didn't copy enough
  bits.
o Deftransform for concatenate completely disabled.  This needs
  fixing.

compiler/sparc/array.lisp:
o Change simple-string accessor to use halfword accessors instead of
  byte accessors.

compiler/x86/array.lisp:
o Change simple-string accessor to use halfword accessors instead of
  byte accessors.

lisp/Config.linux_gencgc:
o Define -DUNICODE as needed

lisp/Config.sun4_solaris_sunc
o Define -DUNICODE as needed.

lisp/alloc.c:
o alloc_string needs to allocate 16-bit strings

lisp/backtrace.c:
o Tell ldb backtrace how to print out 16-bit strings.  This is a hack!

lisp/gencgc.c:
o Tell GC how long the 16-bit strings are now.

lisp/interr.c:
o Not really needed but make debug_print (aka %primitive print)
  support all objects by calling ldb's print function to print the
  object.

lisp/os-common.c:
o Add hack convert_lisp_string to take a 16-bit Lisp string and create
  a new string containing just the low 8 bits of each Lisp character.
o OS foreign linkage stuff needs 8-bit strings, so we need to convert
  Lisp strings to the desired size.  Very hackish!

lisp/print.c:
o Teach ldb how to print Lisp 16-bit strings.  Currently, just dump
  out each byte of the 16-bit string.  This needs major work!

lisp/purify.c:
o Teach purify about the 16-bit strings.
parent 7e7cb462
Loading
Loading
Loading
Loading
+164 −0
Original line number Diff line number Diff line
(pushnew :unicode *features*)
(in-package "C")

;; Not sure why dump-bytes doesn't work. So we explicitly dump the
;; bytes ourselves.
(defun dump-simple-string (s file)
  (declare (type simple-base-string s))
  (let ((length (length s)))
    (dump-fop* length lisp::fop-small-string lisp::fop-string file)
    #+nil
    (dump-bytes s (* 2 length) file)

    (dotimes (k length)
      (let ((code (char-code (aref s k))))
	(dump-byte (ldb (byte 8 8) code) file)
	(dump-byte (ldb (byte 8 0) code) file))))
  (undefined-value))

;; Like dump-simple-string, but dump the characters explicitly.
(defun dump-symbol (s file)
  (let* ((pname (symbol-name s))
	 (pname-length (length pname))
	 (pkg (symbol-package s)))

    (cond ((null pkg)
	   (dump-fop* pname-length lisp::fop-uninterned-small-symbol-save
		      lisp::fop-uninterned-symbol-save file))
	  ;; Why do we do this?  It causes weird things to happen if
	  ;; you're in, say, the KERNEL package when you compile-file
	  ;; something and load the fasl back in when you're in a
	  ;; different package.
	  #-(and)
	  ((eq pkg *package*)
	   (dump-fop* pname-length lisp::fop-small-symbol-save
		      lisp::fop-symbol-save file))
	  ((eq pkg ext:*lisp-package*)
	   (dump-fop* pname-length lisp::fop-lisp-small-symbol-save
		      lisp::fop-lisp-symbol-save file))
	  ((eq pkg ext:*keyword-package*)
	   (dump-fop* pname-length lisp::fop-keyword-small-symbol-save
		      lisp::fop-keyword-symbol-save file))
	  ((< pname-length 256)
	   (dump-fop* (dump-package pkg file)
		      lisp::fop-small-symbol-in-byte-package-save
		      lisp::fop-small-symbol-in-package-save file)
	   (dump-byte pname-length file))
	  (t
	   (dump-fop* (dump-package pkg file)
		      lisp::fop-symbol-in-byte-package-save
		      lisp::fop-symbol-in-package-save file)
	   (dump-unsigned-32 pname-length file)))

    (dotimes (k pname-length)
      (let ((code (char-code (aref pname k))))
	(dump-byte (ldb (byte 8 8) code) file)
	(dump-byte (ldb (byte 8 0) code) file)))

    (unless *cold-load-dump*
      (setf (gethash s (fasl-file-eq-table file)) (fasl-file-table-free file)))

    (incf (fasl-file-table-free file)))

  (undefined-value))

(in-package "LISP")

;; Needed to read in 16-bit strings.
(clone-fop (fop-string 37)
	   (fop-small-string 38)
  (let* ((arg (clone-arg))
	 (res (make-string arg)))
    #+nil
    (read-n-bytes *fasl-file* res 0 (* 2 arg))
    
    (dotimes (k arg)
      (let ((c-hi (read-arg 1))
	    (c-lo (read-arg 1)))
	(setf (aref res k) (code-char (+ c-lo
					 (ash c-hi 8))))))
    res))

;; Needed to read in 16-bit strings to create the symbols.
(macrolet ((frob (name code name-size package)
	     (let ((n-package (gensym "PACKAGE-"))
		   (n-size (gensym "SIZE-"))
		   (n-buffer (gensym "BUFFER-"))
		   (k (gensym "IDX-")))
	       `(define-fop (,name ,code)
		  (prepare-for-fast-read-byte *fasl-file*
		    (let ((,n-package ,package)
			  (,n-size (fast-read-u-integer ,name-size)))
		      (when (> ,n-size *load-symbol-buffer-size*)
			(setq *load-symbol-buffer*
			      (make-string (setq *load-symbol-buffer-size*
						 (* ,n-size 2)))))
		      (done-with-fast-read-byte)
		      (let ((,n-buffer *load-symbol-buffer*))
			(dotimes (,k ,n-size)
			  (setf (aref ,n-buffer ,k)
				(code-char (+ (ash (read-arg 1) 8) (read-arg 1)))))
			(push-table (intern* ,n-buffer ,n-size ,n-package)))))))))
  (frob fop-symbol-save 6 4 *package*)
  (frob fop-small-symbol-save 7 1 *package*)
  (frob fop-lisp-symbol-save 75 4 *lisp-package*)
  (frob fop-lisp-small-symbol-save 76 1 *lisp-package*)
  (frob fop-keyword-symbol-save 77 4 *keyword-package*)
  (frob fop-keyword-small-symbol-save 78 1 *keyword-package*)

  (frob fop-symbol-in-package-save 8 4
    (svref *current-fop-table* (fast-read-u-integer 4)))
  (frob fop-small-symbol-in-package-save 9 1
    (svref *current-fop-table* (fast-read-u-integer 4)))
  (frob fop-symbol-in-byte-package-save 10 4
    (svref *current-fop-table* (fast-read-u-integer 1)))
  (frob fop-small-symbol-in-byte-package-save 11 1
    (svref *current-fop-table* (fast-read-u-integer 1))))

(clone-fop (fop-uninterned-symbol-save 12)
	   (fop-uninterned-small-symbol-save 13)
  (let* ((arg (clone-arg))
	 (res (make-string arg)))
    (dotimes (k arg)
      (setf (aref res k)
	    (code-char (+ (ash (read-arg 1) 8) (read-arg 1)))))
    (push-table (make-symbol res))))

;; Kill the any deftransforms.  They get in the way because they
;; assume 8-bit strings.
(in-package "C")
(dolist (f '(concatenate subseq replace copy-seq))
  (setf (c::function-info-transforms (c::function-info-or-lose f)) nil))

(in-package "C-CALL")

;; For some reason (make-array n :element-type '(unsigned-byte 8))
;; returns a simple-vector when compiled in c-string deport-gen.  So
;; instead of that, call out to make-array-unsigned-byte-8 which seems
;; to do the right thing.
(defun make-array-unsigned-byte-8 (n)
  (declare (fixnum n)
	   (optimize (speed 3) (safety 0)))
  (make-array n :element-type '(unsigned-byte 8)))

(def-alien-type-method (c-string :deport-gen) (type value)
  (declare (ignore type))
  (let ((s (gensym "C-STRING-"))
	(len (gensym "LEN-"))
	(k (gensym "IDX-")))
    `(etypecase ,value
       (null (int-sap 0))
       ((alien (* char)) (alien-sap ,value))
       (simple-base-string
	(let* ((,len (length ,value))
	       (,s (make-array-unsigned-byte-8 ,len)))
	  #+nil
	  (progn
	    (lisp::%primitive lisp::print "deport string")
	    (lisp::%primitive lisp::print ,value)
	    (lisp::%primitive lisp::print ,s))
	  (dotimes (,k ,len)
	    (setf (aref ,s ,k) (logand #xff (char-code (aref ,value ,k)))))
	  #+nil
	  (lisp::%primitive lisp::print ,s)
	  (vector-sap ,s))))))
+284 −0
Original line number Diff line number Diff line
(in-package :cl-user)

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

(c::new-backend "SPARC"
   ;; Features to add here
   '(:sparc
     :sparc-v9				; For Ultrasparc processors
     :complex-fp-vops			; Some slightly faster FP vops on complex numbers
     :linkage-table
     :stack-checking			; Throw error if we run out of stack
     :heap-overflow-check		; Throw error if we run out of
					; heap (This requires gencgc!)
     :gencgc				; Generational GC
     :relative-package-names		; Relative package names from Allegro
     :conservative-float-type
     :hash-new
     :random-mt19937			; MT-19937 generator
     :cmu				; Announce this is CMUCL
     :cmu19 :cmu19e			; Current version identifier
     :modular-arith			; Modular arithmetic
     :double-double			; Double-double float support
     :unicode
     )
   ;; Features to remove from current *features* here
   '(:sparc-v8 :sparc-v7		; Choose only one of :sparc-v7, :sparc-v8, :sparc-v9
     ;; Other architectures we aren't using.
     :x86 :x86-bootstrap
     :alpha :osf1 :mips
     ;; Really old stuff that should have been removed long ago.
     :propagate-fun-type :propagate-float-type :constrain-float-type
     ;; Other OSes were not using
     :openbsd :freebsd :glibc2 :linux
     :pentium
     :long-float
     :new-random
     :small))

;;; May need to add some symbols to *features* and
;;; sys::*runtime-features* as well.  This might be needed even if we
;;; have those listed above, because of the code checks for things in
;;; *features* and not in the backend-features..  So do that here.

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Things needed to cross-compile unicode changes.

(in-package "C")
(handler-bind ((error #'(lambda (c)
                          (declare (ignore c))
                          (invoke-restart 'kernel::continue))))
(defconstant array-info
  '((base-char #\NULL 16 old-sparc:simple-string-type)
    (single-float 0.0f0 32 old-sparc:simple-array-single-float-type)
    (double-float 0.0d0 64 old-sparc:simple-array-double-float-type)
    #+long-float (long-float 0.0l0 #+x86 96 #+sparc 128
		  old-sparc:simple-array-long-float-type)
    #+double-double
    (double-double-float 0w0 128
		  old-sparc::simple-array-double-double-float-type)
    (bit 0 1 old-sparc:simple-bit-vector-type)
    ((unsigned-byte 2) 0 2 old-sparc:simple-array-unsigned-byte-2-type)
    ((unsigned-byte 4) 0 4 old-sparc:simple-array-unsigned-byte-4-type)
    ((unsigned-byte 8) 0 8 old-sparc:simple-array-unsigned-byte-8-type)
    ((unsigned-byte 16) 0 16 old-sparc:simple-array-unsigned-byte-16-type)
    ((unsigned-byte 32) 0 32 old-sparc:simple-array-unsigned-byte-32-type)
    ((signed-byte 8) 0 8 old-sparc:simple-array-signed-byte-8-type)
    ((signed-byte 16) 0 16 old-sparc:simple-array-signed-byte-16-type)
    ((signed-byte 30) 0 32 old-sparc:simple-array-signed-byte-30-type)
    ((signed-byte 32) 0 32 old-sparc:simple-array-signed-byte-32-type)
    ((complex single-float) #C(0.0f0 0.0f0) 64
     old-sparc:simple-array-complex-single-float-type)
    ((complex double-float) #C(0.0d0 0.0d0) 128
     old-sparc:simple-array-complex-double-float-type)
    #+long-float
    ((complex long-float) #C(0.0l0 0.0l0) #+x86 192 #+sparc 256
     old-sparc:simple-array-complex-long-float-type)
    #+double-double
    ((complex double-double-float) #C(0.0w0 0.0w0) 256
     old-sparc::simple-array-complex-double-double-float-type)
    (t 0 32 old-sparc:simple-vector-type)))
)

;; Kill the any deftransforms
(in-package "C")
(dolist (f '(concatenate subseq replace copy-seq))
  (setf (c::function-info-transforms (c::function-info-or-lose f)) nil))

(load "target:bootfiles/19e/boot-2008-05-cross-unicode-common.lisp")


;; End changes for unicode
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; Extern-alien-name for the new backend.
(in-package :vm)
(defun extern-alien-name (name)
  (declare (type simple-string name))
  #+(and bsd (not elf))
  (concatenate 'string "_" name)
  #-(and bsd (not elf))
  name)
;; When compiling the compiler, vm:fixup-code-object and
;; vm:sanctify-for-execution are undefined.  Import these to get rid
;; of that error.
(import 'old-sparc::fixup-code-object)
(import 'old-sparc::sanctify-for-execution)
(export 'extern-alien-name)
(export 'fixup-code-object)
(export 'sanctify-for-execution)

(in-package :cl-user)

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

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

;; Load the backend of the compiler.

(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")
(load "vm:system")
(load "vm:char")
(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")
(load "vm:print")
(load "vm:alloc")
(load "vm:call")
(load "vm:nlx")
(load "vm:values")
(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-SPARC:BYTE-BITS OLD-SPARC:WORD-BITS
	OLD-SPARC:LOWTAG-BITS
	#+long-float OLD-SPARC:SIMPLE-ARRAY-LONG-FLOAT-TYPE 
	OLD-SPARC:SIMPLE-ARRAY-DOUBLE-FLOAT-TYPE 
	OLD-SPARC:SIMPLE-ARRAY-SINGLE-FLOAT-TYPE
	#+long-float OLD-SPARC:SIMPLE-ARRAY-COMPLEX-LONG-FLOAT-TYPE 
	OLD-SPARC:SIMPLE-ARRAY-COMPLEX-DOUBLE-FLOAT-TYPE 
	OLD-SPARC:SIMPLE-ARRAY-COMPLEX-SINGLE-FLOAT-TYPE
	OLD-SPARC:SIMPLE-ARRAY-UNSIGNED-BYTE-2-TYPE 
	OLD-SPARC:SIMPLE-ARRAY-UNSIGNED-BYTE-4-TYPE
	OLD-SPARC:SIMPLE-ARRAY-UNSIGNED-BYTE-8-TYPE 
	OLD-SPARC:SIMPLE-ARRAY-UNSIGNED-BYTE-16-TYPE 
	OLD-SPARC:SIMPLE-ARRAY-UNSIGNED-BYTE-32-TYPE 
	OLD-SPARC:SIMPLE-ARRAY-SIGNED-BYTE-8-TYPE 
	OLD-SPARC:SIMPLE-ARRAY-SIGNED-BYTE-16-TYPE
	OLD-SPARC:SIMPLE-ARRAY-SIGNED-BYTE-30-TYPE 
	OLD-SPARC:SIMPLE-ARRAY-SIGNED-BYTE-32-TYPE
	OLD-SPARC:SIMPLE-BIT-VECTOR-TYPE
	OLD-SPARC:SIMPLE-STRING-TYPE OLD-SPARC:SIMPLE-VECTOR-TYPE 
	OLD-SPARC:SIMPLE-ARRAY-TYPE OLD-SPARC:VECTOR-DATA-OFFSET
	OLD-SPARC:DOUBLE-FLOAT-DIGITS
	old-sparc:single-float-digits
	OLD-SPARC:DOUBLE-FLOAT-EXPONENT-BYTE
	OLD-SPARC:DOUBLE-FLOAT-NORMAL-EXPONENT-MAX
	OLD-SPARC:DOUBLE-FLOAT-SIGNIFICAND-BYTE
	OLD-SPARC:SINGLE-FLOAT-EXPONENT-BYTE
	OLD-SPARC:SINGLE-FLOAT-NORMAL-EXPONENT-MAX
	OLD-SPARC:SINGLE-FLOAT-SIGNIFICAND-BYTE
	)
  #+double-double
  (frob OLD-SPARC:SIMPLE-ARRAY-COMPLEX-DOUBLE-DOUBLE-FLOAT-TYPE
	OLD-SPARC:SIMPLE-ARRAY-DOUBLE-DOUBLE-FLOAT-TYPE)
  )

;; Modular arith hacks.  When cross-compiling, the compiler wants to
;; constant-fold some stuff, and it needs the following functions to
;; do so.  This just gets rid of the hundreds of errors that happen.
(setf (fdefinition 'vm::ash-left-mod32) #'old-sparc::ash-left-mod32)
(setf (fdefinition 'vm::lognot-mod32) #'old-sparc::lognot-mod32)
;; End modular 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)

;; Sometimes during cross-compile sparc::any-reg isn't defined during
;; cross-compile.
;;
;; hack, hack, hack: Make old-sparc::any-reg the same as
;; sparc::any-reg as an SC.  Do this by adding old-sparc::any-reg
;; to the hash table with the same value as sparc::any-reg.
(let ((ht (c::backend-sc-names c::*target-backend*)))
  (setf (gethash 'old-sparc::any-reg ht)
	(gethash 'sparc::any-reg ht)))
+242 −0
Original line number Diff line number Diff line
(in-package :cl-user)

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

(c::new-backend "X86"
   ;; Features to add here
   '(:x86 :i486 :pentium
     :stack-checking
     :heap-overflow-check
     :relative-package-names
     :mp
     :gencgc
     :conservative-float-type
     :hash-new :random-mt19937
     :linux :glibc2 :glibc2.1
     :cmu :cmu19 :cmu19e
     :double-double
     :unicode
     )
   ;; Features to remove from current *features* here
   '(:x86-bootstrap :alpha :osf1 :mips
     :propagate-fun-type :propagate-float-type :constrain-float-type
     :openbsd :freebsd :glibc2 :linux
     :long-float :new-random :small))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Things needed to cross-compile unicode changes.

(in-package "C")
(handler-bind ((error #'(lambda (c)
                          (declare (ignore c))
                          (invoke-restart 'kernel::continue))))
(defconstant array-info
  '((base-char #\NULL 16 old-x86:simple-string-type)
    (single-float 0.0f0 32 old-x86:simple-array-single-float-type)
    (double-float 0.0d0 64 old-x86:simple-array-double-float-type)
    #+long-float (long-float 0.0l0 #+x86 96 #+sparc 128
		  old-x86:simple-array-long-float-type)
    #+double-double
    (double-double-float 0w0 128
		  old-x86::simple-array-double-double-float-type)
    (bit 0 1 old-x86:simple-bit-vector-type)
    ((unsigned-byte 2) 0 2 old-x86:simple-array-unsigned-byte-2-type)
    ((unsigned-byte 4) 0 4 old-x86:simple-array-unsigned-byte-4-type)
    ((unsigned-byte 8) 0 8 old-x86:simple-array-unsigned-byte-8-type)
    ((unsigned-byte 16) 0 16 old-x86:simple-array-unsigned-byte-16-type)
    ((unsigned-byte 32) 0 32 old-x86:simple-array-unsigned-byte-32-type)
    ((signed-byte 8) 0 8 old-x86:simple-array-signed-byte-8-type)
    ((signed-byte 16) 0 16 old-x86:simple-array-signed-byte-16-type)
    ((signed-byte 30) 0 32 old-x86:simple-array-signed-byte-30-type)
    ((signed-byte 32) 0 32 old-x86:simple-array-signed-byte-32-type)
    ((complex single-float) #C(0.0f0 0.0f0) 64
     old-x86:simple-array-complex-single-float-type)
    ((complex double-float) #C(0.0d0 0.0d0) 128
     old-x86:simple-array-complex-double-float-type)
    #+long-float
    ((complex long-float) #C(0.0l0 0.0l0) #+x86 192 #+sparc 256
     old-x86:simple-array-complex-long-float-type)
    #+double-double
    ((complex double-double-float) #C(0.0w0 0.0w0) 256
     old-x86::simple-array-complex-double-double-float-type)
    (t 0 32 old-x86:simple-vector-type)))
)

;; Kill the any deftransforms
(in-package "C")
(dolist (f '(concatenate subseq replace copy-seq))
  (setf (c::function-info-transforms (c::function-info-or-lose f)) nil))

(load "target:bootfiles/19e/boot-2008-05-cross-unicode-common.lisp")

;; Kill the any deftransforms
(in-package "C")
(dolist (f '(concatenate subseq replace copy-seq))
  (setf (c::function-info-transforms (c::function-info-or-lose f)) nil))

;; End changes for unicode
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(in-package :cl-user)

;;; Compile the new backend.
(pushnew :bootstrap *features*)
(pushnew :building-cross-compiler *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.

(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")
(load "vm:system")
(load "vm:char")
(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")
(load "vm:print")
(load "vm:alloc")
(load "vm:call")
(load "vm:nlx")
(load "vm:values")
(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-X86:BYTE-BITS OLD-X86:WORD-BITS
	#+long-float OLD-X86:SIMPLE-ARRAY-LONG-FLOAT-TYPE 
	OLD-X86:SIMPLE-ARRAY-DOUBLE-FLOAT-TYPE 
	OLD-X86:SIMPLE-ARRAY-SINGLE-FLOAT-TYPE
	#+long-float OLD-X86:SIMPLE-ARRAY-COMPLEX-LONG-FLOAT-TYPE 
	OLD-X86:SIMPLE-ARRAY-COMPLEX-DOUBLE-FLOAT-TYPE 
	OLD-X86:SIMPLE-ARRAY-COMPLEX-SINGLE-FLOAT-TYPE
	OLD-X86:SIMPLE-ARRAY-UNSIGNED-BYTE-2-TYPE 
	OLD-X86:SIMPLE-ARRAY-UNSIGNED-BYTE-4-TYPE
	OLD-X86:SIMPLE-ARRAY-UNSIGNED-BYTE-8-TYPE 
	OLD-X86:SIMPLE-ARRAY-UNSIGNED-BYTE-16-TYPE 
	OLD-X86:SIMPLE-ARRAY-UNSIGNED-BYTE-32-TYPE 
	OLD-X86:SIMPLE-ARRAY-SIGNED-BYTE-8-TYPE 
	OLD-X86:SIMPLE-ARRAY-SIGNED-BYTE-16-TYPE
	OLD-X86:SIMPLE-ARRAY-SIGNED-BYTE-30-TYPE 
	OLD-X86:SIMPLE-ARRAY-SIGNED-BYTE-32-TYPE
	OLD-X86:SIMPLE-BIT-VECTOR-TYPE
	OLD-X86:SIMPLE-STRING-TYPE OLD-X86:SIMPLE-VECTOR-TYPE 
	OLD-X86:SIMPLE-ARRAY-TYPE OLD-X86:VECTOR-DATA-OFFSET
	OLD-X86:DOUBLE-FLOAT-EXPONENT-BYTE
	OLD-X86:DOUBLE-FLOAT-NORMAL-EXPONENT-MAX 
	OLD-X86:DOUBLE-FLOAT-SIGNIFICAND-BYTE
	OLD-X86:SINGLE-FLOAT-EXPONENT-BYTE
	OLD-X86:SINGLE-FLOAT-NORMAL-EXPONENT-MAX
	OLD-X86:SINGLE-FLOAT-SIGNIFICAND-BYTE
	)
  #+double-double
  (frob OLD-X86:SIMPLE-ARRAY-COMPLEX-DOUBLE-DOUBLE-FLOAT-TYPE
	OLD-X86:SIMPLE-ARRAY-DOUBLE-DOUBLE-FLOAT-TYPE))

;; Modular arith hacks
(setf (fdefinition 'vm::ash-left-mod32) #'old-x86::ash-left-mod32)
(setf (fdefinition 'vm::lognot-mod32) #'old-x86::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-x86::any-reg the same as
;; x86::any-reg as an SC.  Do this by adding old-x86::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-x86::any-reg ht)
	(gethash 'x86::any-reg ht)))
+4 −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/array.lisp,v 1.43 2007/06/20 17:33:08 rtoy Exp $")
  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/array.lisp,v 1.43.4.1 2008/05/14 16:12:04 rtoy Exp $")
;;;
;;; **********************************************************************
;;;
@@ -121,7 +121,10 @@

(defun %vector-type-code (type)
  (pick-type type
    #-unicode
    (base-char (values #.vm:simple-string-type #.vm:byte-bits))
    #+unicode
    (base-char (values #.vm:simple-string-type 16))
    (bit (values #.vm:simple-bit-vector-type 1))
    ((unsigned-byte 2) (values #.vm:simple-array-unsigned-byte-2-type 2))
    ((unsigned-byte 4) (values #.vm:simple-array-unsigned-byte-4-type 4))
+65 −1

File changed.

Preview size limit exceeded, changes collapsed.

Loading