From 76b5e40b38bd9783170844c5900e7bb1869ae1db Mon Sep 17 00:00:00 2001
From: wlott <wlott>
Date: Fri, 24 Aug 1990 18:36:10 +0000
Subject: [PATCH] Merged MIPS branch with the trunk.

---
 compiler/aliencomp.lisp  | 511 ++++++++++++++++++++++++++++-----------
 compiler/codegen.lisp    |  36 ++-
 compiler/debug-dump.lisp |  13 +-
 compiler/debug.lisp      |  41 +++-
 compiler/eval.lisp       |   8 +-
 compiler/fndb.lisp       |  44 ++--
 compiler/ir1opt.lisp     |   2 +
 compiler/ir1tran.lisp    |   4 +-
 compiler/ir2tran.lisp    |  60 ++---
 compiler/main.lisp       |  47 ++--
 compiler/vmdef.lisp      |   4 +-
 11 files changed, 542 insertions(+), 228 deletions(-)

diff --git a/compiler/aliencomp.lisp b/compiler/aliencomp.lisp
index db4fecc7f..bc87ba412 100644
--- a/compiler/aliencomp.lisp
+++ b/compiler/aliencomp.lisp
@@ -22,9 +22,11 @@
 	  ct-a-val-p ct-a-val make-ct-a-val ct-a-val-alien
 	  check<= check= %alien-indirect %aligned-sap
 	  naturalize-integer deport-integer naturalize-boolean deport-boolean
-	  sap-ref-8 sap-ref-16 sap-ref-32
+	  sap-ref-8 sap-ref-16 sap-ref-32 sap-ref-sap
 	  signed-sap-ref-8 signed-sap-ref-16 signed-sap-ref-32
-	  %set-alien-access
+	  %set-sap-ref-8 %set-sap-ref-16 %set-sap-ref-32 %set-sap-ref-sap
+	  sap+ %set-alien-access %set-sap-ref-single %set-sap-ref-double
+	  %set-sap-ref-descriptor
 	  
 	  *alien-eval-when* make-alien alien-type alien-size alien-address
 	  copy-alien dispose-alien defalien alien-value
@@ -164,7 +166,7 @@
 	       (eql (continuation-value size) 32))
     (give-up "Size may not be 32:~% ~S" (continuation-value exp)))
 
-  '(%primitive sap-system-ref sap (ash offset -4)))
+  '(sap-ref-sap sap (ash offset -5)))
 
 
 ;;; Grovel-Alien-Var  --  Internal
@@ -202,7 +204,8 @@
 (defun grovel-alien-operator (type exp info)
   (unless (or (not type)
 	      (equal (lisp::alien-info-result-type info) type))
-    (compiler-error "Does not result in a ~S alien value:~% ~S" type exp))
+    (compiler-error "Results in a ~S alien value, not a ~S:~% ~S"
+		    (lisp::alien-info-result-type info) type exp))
   
   (unless (= (lisp::alien-info-num-args info) (length (cdr exp)))
     (compiler-error "Alien operator not called with ~D args:~% ~S"
@@ -288,21 +291,26 @@
 
 ;;;; Miscellaneous internal frobs:
 
-(defknown sap+ (t t) t (movable flushable))
+(defknown sap+ (system-area-pointer integer) system-area-pointer
+  (movable flushable))
 (deftransform sap+ ((sap offset))
   (unless (and (constant-continuation-p offset)
 	       (eql (continuation-value offset) 0))
     (give-up))
   'sap)
 
-(defknown sap-int (t) unsigned-byte (movable flushable))
-(defknown int-sap (unsigned-byte) t (movable flushable))
+(defknown sap- (system-area-pointer system-area-pointer) (signed-byte 32)
+  (movable flushable))
+
+(defknown sap-int (system-area-pointer) (unsigned-byte 32) (movable flushable))
+(defknown int-sap ((unsigned-byte 32)) system-area-pointer (movable))
 
-(defknown %aligned-sap (t t t) t (movable flushable))
+(defknown %aligned-sap (system-area-pointer unsigned-byte t) system-area-pointer
+  (movable flushable))
 (deftransform %aligned-sap ((sap offset form))
   (unless (> (find-alignment offset) 3)
     (give-up))
-  '(sap+ sap offset))
+  '(sap+ sap (ash offset -3)))
 
 (defknown (check<= check=) (index index) void (movable))
 
@@ -327,12 +335,47 @@
 
 (defknown record-size (symbol) index (movable foldable flushable))
 
-(defknown sap-ref-8 (t index) (unsigned-byte 8) (flushable))
-(defknown sap-ref-16 (t index) (unsigned-byte 16) (flushable))
-(defknown sap-ref-32 (t index) (unsigned-byte 32) (flushable))
-(defknown (setf sap-ref-8) (t index (unsigned-byte 8)) (unsigned-byte 8) ())
-(defknown (setf sap-ref-16) (t index (unsigned-byte 16)) (unsigned-byte 16) ())
-(defknown (setf sap-ref-32) (t index (unsigned-byte 32)) (unsigned-byte 32) ())
+(defknown sap-ref-8 (system-area-pointer index) (unsigned-byte 8)
+  (flushable))
+(defknown sap-ref-16 (system-area-pointer index) (unsigned-byte 16)
+  (flushable))
+(defknown sap-ref-32 (system-area-pointer index) (unsigned-byte 32)
+  (flushable))
+
+(defknown signed-sap-ref-8 (system-area-pointer index) (signed-byte 8)
+  (flushable))
+(defknown signed-sap-ref-16 (system-area-pointer index) (signed-byte 16)
+  (flushable))
+(defknown signed-sap-ref-32 (system-area-pointer index) (signed-byte 32)
+  (flushable))
+
+(defknown %set-sap-ref-8
+	  (system-area-pointer index (or (unsigned-byte 8) (signed-byte 8)))
+  (or (unsigned-byte 8) (signed-byte 8)) ())
+(defknown %set-sap-ref-16
+	  (system-area-pointer index (or (unsigned-byte 16) (signed-byte 16)))
+  (or (unsigned-byte 16) (signed-byte 16)) ())
+(defknown %set-sap-ref-32
+	  (system-area-pointer index (or (unsigned-byte 32) (signed-byte 32)))
+  (or (unsigned-byte 32) (signed-byte 32)) ())
+
+(defknown sap-ref-sap (system-area-pointer index) system-area-pointer
+  (flushable))
+(defknown %set-sap-ref-sap (system-area-pointer index system-area-pointer)
+  system-area-pointer
+  ())
+
+(defknown sap-ref-single (system-area-pointer index) single-float
+  (flushable))
+(defknown sap-ref-double (system-area-pointer index) double-float
+  (flushable))
+
+(defknown %set-sap-ref-single
+	  (system-area-pointer index single-float) single-float
+  ())
+(defknown %set-sap-ref-double
+	  (system-area-pointer index double-float) double-float
+  ())
 
 
 ;;;; Alien variable special forms:
@@ -388,27 +431,209 @@
 ;;; With-Stack-Alien-Transform  --  Internal
 ;;;
 ;;;
-(def-ir1-translator with-stack-alien (((var stack) &body forms) start cont)
-  (let ((info (info alien-stack info stack)))
-    (unless info
-      (compiler-error "~S is not the name of a declared alien stack." stack))
-
-    (let* ((n-current (lisp::stack-info-current info))
-	   (n-sap (gensym))
-	   (n-alien (gensym))
-	   (a-val (make-ct-a-val :type (lisp::stack-info-type info)
-				 :size (lisp::stack-info-size info)
-				 :sap n-sap
-				 :offset 0
-				 :alien n-alien))
-	   (*lexical-environment*
-	    (make-lexenv :variables (list (cons var a-val)))))
-      (ir1-convert start cont
-		   `(let* ((,n-alien (or (car ,n-current)
-					 (,(lisp::stack-info-grow info))))
-			   (,n-sap (lisp::alien-value-sap ,n-alien))
-			   (,n-current (cdr ,n-current)))
-		      ,@forms)))))
+(def-ir1-translator with-stack-alien (((var type &optional size)
+				       &body forms) start cont)
+  (unless size
+    (let ((info (info alien-stack info type)))
+      (unless info
+	(compiler-error "~S is not the name of a declared alien stack." type))
+      (setf type (lisp::stack-info-type info))
+      (setf size (lisp::stack-info-size info))))
+  (let* ((sap-var (gensym))
+	 (*venv* (acons var
+			(make-ct-a-val :type type
+				       :size size
+				       :sap sap-var
+				       :offset 0)
+			*venv*)))
+    (ir1-convert start cont
+      `(let ((,sap-var
+	      (truly-the system-area-pointer
+			 (%primitive alloc-number-stack-space
+				     (ceiling ,size vm:byte-bits)))))
+	 (declare (ignorable ,sap-var))
+	 (multiple-value-prog1
+	     (progn ,@forms)
+	   (%primitive dealloc-number-stack-space
+		       (ceiling ,size vm:byte-bits)))))))
+
+
+;;;; CALL-FOREIGN-FUNCTION stuff.
+
+(defknown ext::call-foreign-function (simple-base-string t t &rest t) t)
+
+(defun alien-type-type (type)
+  (let ((name (if (listp type) (car type) type)))
+    (case name
+      ((unsigned-byte signed-byte system-area-pointer
+		      double-float single-float)
+       (specifier-type type))
+      (port
+       (specifier-type '(unsigned-byte 32)))
+      (t
+       (error "Alien type ~S has no corresponding Lisp type." type)))))
+
+(defoptimizer (ext::call-foreign-function derive-type)
+	      ((name return-type arg-types &rest args))
+  (assert (constant-continuation-p return-type))
+  (assert (constant-continuation-p arg-types))
+  (let ((return-type (continuation-value return-type))
+	(arg-types (continuation-value arg-types)))
+    (unless (= (length arg-types) (length args))
+      (error "Different number of argument types (~D) from arguments (~D)."
+	     (length arg-types)
+	     (length args)))
+    (dolist (type arg-types)
+      (let ((arg (pop args)))
+	(assert-continuation-type arg (alien-type-type type))))
+    (if return-type
+	(alien-type-type return-type)
+	*universal-type*)))
+
+(defun make-call-out-nsp-tn ()
+  (make-wired-tn (primitive-type-or-lose 'positive-fixnum)
+		 (sc-number-or-lose 'any-reg)
+		 nsp-offset))
+
+(defun make-call-out-argument-tns (arg-types)
+  (let ((stack-frame-size 0)
+	(did-int-arg nil)
+	(float-args 0))
+    (collect ((tns))
+      (dolist (type arg-types)
+	(let ((name (if (consp type) (car type) type)))
+	  (ecase name
+	    ((unsigned-byte port)
+	     (if (< stack-frame-size 4)
+		 (tns (make-wired-tn (primitive-type-or-lose 'unsigned-byte-32)
+				     (sc-number-or-lose 'unsigned-reg)
+				     (+ stack-frame-size 4)))
+		 (tns (make-wired-tn (primitive-type-or-lose 'unsigned-byte-32)
+				     (sc-number-or-lose 'unsigned-stack)
+				     stack-frame-size)))
+	     (incf stack-frame-size)
+	     (setf did-int-arg t))
+	    (signed-byte
+	     (if (< stack-frame-size 4)
+		 (tns (make-wired-tn (primitive-type-or-lose 'signed-byte-32)
+				     (sc-number-or-lose 'signed-reg)
+				     (+ stack-frame-size 4)))
+		 (tns (make-wired-tn (primitive-type-or-lose 'signed-byte-32)
+				     (sc-number-or-lose 'signed-stack)
+				     stack-frame-size)))
+	     (incf stack-frame-size)
+	     (setf did-int-arg t))
+	    (system-area-pointer
+	     (if (< stack-frame-size 4)
+		 (tns (make-wired-tn (primitive-type-or-lose
+				      'system-area-pointer)
+				     (sc-number-or-lose 'sap-reg)
+				     (+ stack-frame-size 4)))
+		 (tns (make-wired-tn (primitive-type-or-lose
+				      'system-area-pointer)
+				     (sc-number-or-lose 'sap-stack)
+				     stack-frame-size)))
+	     (incf stack-frame-size)
+	     (setf did-int-arg t))
+	    (double-float
+	     ;; Round to a dual-word.
+	     (setf stack-frame-size (logandc2 (1+ stack-frame-size) 1))
+	     (cond ((>= stack-frame-size 4)
+		    (tns (make-wired-tn (primitive-type-or-lose 'double-float)
+					(sc-number-or-lose 'double-stack)
+					stack-frame-size)))
+		   ((and (not did-int-arg) (< float-args 2))
+		    (tns (make-wired-tn (primitive-type-or-lose 'double-float)
+					(sc-number-or-lose 'double-reg)
+					(+ (* float-args 2) 12))))
+		   (t
+		    (error "Can't put floats in int regs yet.")))
+	     (incf stack-frame-size 2)
+	     (incf float-args))
+	    (single-float
+	     (cond ((>= stack-frame-size 4)
+		    (tns (make-wired-tn (primitive-type-or-lose 'single-float)
+					(sc-number-or-lose 'single-stack)
+					stack-frame-size)))
+		   ((and (not did-int-arg) (< float-args 2))
+		    (tns (make-wired-tn (primitive-type-or-lose 'single-float)
+				   (sc-number-or-lose 'single-reg)
+				   (+ (* float-args 2) 12))))
+		   (t
+		    (error "Can't put floats in int regs yet.")))
+	     (incf stack-frame-size)
+	     (incf float-args)))))
+      (values (tns)
+	      (logandc2 (1+ stack-frame-size) 1)))))
+
+(defun make-call-out-result-tn (type)
+  (let ((name (if (consp type) (car type) type)))
+    (ecase name
+      ((unsigned-byte port)
+       (make-wired-tn (primitive-type-or-lose 'unsigned-byte-32)
+		      (sc-number-or-lose 'unsigned-reg)
+		      2))
+      (signed-byte
+       (make-wired-tn (primitive-type-or-lose 'signed-byte-32)
+		      (sc-number-or-lose 'signed-reg)
+		      2))
+      (system-area-pointer
+       (make-wired-tn (primitive-type-or-lose 'system-area-pointer)
+		      (sc-number-or-lose 'sap-reg)
+		      2))
+      (double-float
+       (make-wired-tn (primitive-type-or-lose 'double-float)
+		      (sc-number-or-lose 'double-reg)
+		      0))
+      (single-float
+       (make-wired-tn (primitive-type-or-lose 'single-float)
+		      (sc-number-or-lose 'single-reg)
+		      0)))))
+
+(defoptimizer (ext::call-foreign-function ltn-annotate)
+	      ((name return-type arg-types &rest args) node policy)
+  (setf (basic-combination-info node) :funny)
+  (setf (node-tail-p node) nil)
+  (dolist (arg args)
+    (annotate-ordinary-continuation arg policy)))
+
+(defoptimizer (ext::call-foreign-function ir2-convert)
+	      ((name return-type arg-types &rest args) call block)
+  (assert (constant-continuation-p name))
+  (assert (constant-continuation-p return-type))
+  (assert (constant-continuation-p arg-types))
+  (let* ((name (continuation-value name))
+	 (return-type (continuation-value return-type))
+	 (arg-types (continuation-value arg-types))
+	 (cont (node-cont call)))
+    (multiple-value-bind (arg-tns stack-frame-size)
+			 (make-call-out-argument-tns arg-types)
+      (unless (zerop stack-frame-size)
+	(let ((nsp (make-call-out-nsp-tn))
+	      (args args))
+	  (vop alloc-number-stack-space call block stack-frame-size nsp)
+	  (dolist (tn arg-tns)
+	    (let* ((arg (pop args))
+		   (sc (tn-sc tn))
+		   (scn (sc-number sc))
+		   (temp-tn (make-representation-tn (tn-primitive-type tn)
+						    scn)))
+	      (assert arg)
+	      (emit-move call block (continuation-tn call block arg) temp-tn)
+	      (emit-move-arg-template call block
+				      (svref (sc-move-arg-vops sc) scn)
+				      temp-tn nsp tn)))
+	  (assert (null args))))
+
+      (let ((results (when return-type
+		       (list (make-call-out-result-tn return-type)))))
+	(vop* call-out call block
+	      ((reference-tn-list arg-tns nil))
+	      ((reference-tn-list results t))
+	      name)
+	(unless (zerop stack-frame-size)
+	  (vop dealloc-number-stack-space call block stack-frame-size))
+	(move-continuation-result call block results cont)))))
 
 
 ;;;; Transforms for basic Alien accessors.
@@ -427,11 +652,13 @@
     `(let* ,(reverse binds)
        ,(ignore-unreferenced-vars binds)
        ,@(nreverse stuff)
-       (+ (sap-int ,(ct-a-val-sap res)) (/ ,(ct-a-val-offset res) 16)))))
+       (+ (sap-int ,(ct-a-val-sap res))
+	  (/ ,(ct-a-val-offset res) vm:byte-bits)))))
 
 
 ;;; Alien-SAP soruce transform  --  Internal
 ;;;
+;;;
 (def-source-transform alien-sap (alien &whole source)
   (multiple-value-bind (binds stuff res)
 		       (analyze-alien-expression nil alien)
@@ -477,7 +704,8 @@
 		      ,(ct-a-val-size res) ',(ct-a-val-type res)
 		      ,lisp-type ',form))))
 
-(defknown %alien-access (t unsigned-byte unsigned-byte t t t) t
+(defknown %alien-access
+	  (system-area-pointer unsigned-byte unsigned-byte t t t) t
   (movable flushable))
 
 ;;; %Alien-Access transform  --  Internal
@@ -517,7 +745,8 @@
 			   ,(if nv-p new-value lisp-type)
 			   ',form))))
 
-(defknown %%set-alien-access (t unsigned-byte unsigned-byte t t t t) t)
+(defknown %%set-alien-access
+	  (system-area-pointer unsigned-byte unsigned-byte t t t t) t)
 
 ;;; %%Set-Alien-Access transform  --  Internal
 ;;;
@@ -639,14 +868,14 @@
 (defun sign-extend (form size &optional (signed t))
   (if signed
       `(let ((res ,form))
-	 (declare (fixnum res))
 	 (if (zerop (logand res ,(ash 1 (1- size))))
 	     res
 	     (logior res ,(ash -1 size))))
       form))
 
 
-(defknown naturalize-integer (t t unsigned-byte unsigned-byte t) integer
+(defknown naturalize-integer
+	  (t system-area-pointer unsigned-byte unsigned-byte t) integer
   (flushable))
 
 ;;; Naturalize-Integer Transform  --  Internal
@@ -670,56 +899,76 @@
   
   (let ((align (find-alignment offset))
 	(size (continuation-value size))
-	(signed (continuation-value signed)))
+	(signed (continuation-value signed))
+	(bits (find-bit-offset offset)))
     (cond
-     ((or (and (> size 15) (< align 4))
-	  (and (> size 16) (< align 5)))
-      (give-up "Could not show ~D bit access to be word-aligned:~%~S"
-	       size (continuation-value form)))
-     ((= size 32)
+     ((and (= size 32) (> align 4))
       (if signed
-	  '(%primitive signed-32bit-system-ref sap (ash offset -4))
-	  '(%primitive unsigned-32bit-system-ref sap (ash offset -4))))
-     ((= size 16)
+	  '(signed-sap-ref-32 sap (ash offset -5))
+	  '(sap-ref-32 sap (ash offset -5))))
+     ((and (= size 16) (> align 3))
       (if signed
-	  '(%primitive signed-16bit-system-ref sap (ash offset -4))
-	  '(%primitive 16bit-system-ref sap (ash offset -4))))
-     ((> size 15)
-      (compiler-warning "Access of ~D bit bytes is not supported:~%~S"
-			size (continuation-value form))
-      (give-up))
-     ((and (> align 2) (= size 8))
-      (sign-extend '(%primitive 8bit-system-ref sap (ash offset -3))
-		   8 signed))
+	  '(signed-sap-ref-16 sap (ash offset -4))
+	  '(sap-ref-16 sap (ash offset -4))))
+     ((and (= size 8) (> align 2))
+      (if signed
+	  '(signed-sap-ref-8 sap (ash offset -3))
+	  '(sap-ref-8 sap (ash offset -3))))
+     ((not bits)
+      (give-up "Can't determine offset within word, so cannot open-code:~%~S"
+	       (continuation-value form)))
+     ((<= (+ bits size) 32)
+      (sign-extend `(ldb (byte ,size ,bits)
+			 (sap-ref-32 sap (ash offset -5)))
+		   size signed))
+     ((> size 32)
+      (give-up "Accesses of ~D bits unsupported:~%~S"
+	       size (continuation-value form)))
      (t
-      (let ((bits (find-bit-offset offset)))
-	(unless bits
-	  (give-up "Can't determine offset within word, so cannot ~
-	  open-code:~%~S"
-		   (continuation-value form)))
-	
-	(if (>= (+ bits size) 16)
-	    (let* ((hi-bits (- 16 bits))
-		   (lo-bits (- size hi-bits)))
-	      ;;
-	      ;; If the integer spans a 16bit boundry, then the high bits in
-	      ;; the integer are the low bits in the first word, and the low
-	      ;; bits in the integer are the high bits in the next word.
-	      (sign-extend
-	       `(let ((offset (ash offset -4)))
-		  (logior (ash (ldb (byte ,hi-bits 0)
-				    (sap-ref-16 sap offset))
-			       ,lo-bits)
-			  (ash (sap-ref-16 sap (1+ offset))
-			       ,(- (- 16 lo-bits)))))
-	       size signed))
-	    (sign-extend `(ldb (byte ,size ,bits)
-			       (sap-ref-16 sap (ash offset -4)))
-			 size signed)))))))
-
-
-
-(defknown deport-integer (t t unsigned-byte unsigned-byte integer t) void
+      ;; If the integer spans a boundry, how we combine the two partial results
+      ;; depends on the target byte order.
+      ;;
+      ;; little-endian:
+      ;;   0   1   2   3   4   5   6   7
+      ;; 7      07      07      07      0
+      ;; [  ][  ][  ][  ][  ][  ][  ][  ]
+      ;; 210                          543
+      ;;  We get the low bits from the high part of the first word and
+      ;; the high bits from the low part of the second word.
+      ;; 
+      ;; big-endian: 
+      ;;   0   1   2   3   4   5   6   7
+      ;; 7      07      07      07      0
+      ;; [  ][  ][  ][  ][  ][  ][  ][  ]
+      ;;              543210
+      ;;  We get the low bits from the high part of the second word
+      ;; and the high bits from the low part of the first.
+      ;;
+      ;; Therefore, the only difference is which byte to use for what.
+      ;; What bits to use from each byte is constant.
+      ;; 
+      ;; We sign extend the high bits instead of the entire value because
+      ;; it has a higher probability of being a fixnum.
+      ;; 
+      (let* ((high-bits (- 32 bits))
+	     (low-bits (- size high-bits)))
+	(multiple-value-bind (low-byte high-byte)
+			     (ecase vm:target-byte-order
+			       (:little-endian
+				(values 'offset '(1+ offset)))
+			       (:big-endian
+				(values '(1+ offset) 'offset)))
+	  `(let ((offset (ash offset -5)))
+	     (logior (ash ,(sign-extend `(ldb (byte ,high-bits 0)
+					      (sap-ref-32 sap ,high-byte))
+					size signed)
+			  ,low-bits)
+		     (ash (sap-ref-32 sap ,low-byte)
+			  ,(- (- 32 low-bits)))))))))))
+
+
+(defknown deport-integer
+	  (t system-area-pointer unsigned-byte unsigned-byte integer t) void
   ())
 
 ;;; Deport-Integer transform  --  Internal
@@ -732,56 +981,51 @@
 	     (continuation-value form)))
 
   (let ((align (find-alignment offset))
-	(size (continuation-value size)))
+	(size (continuation-value size))
+	(bits (find-bit-offset offset)))
     (cond
-     ((or (and (> size 15) (< align 4))
-	  (and (> size 16) (< align 5)))
-      (give-up "Could not show ~D bit access to be word-aligned:~%~S"
+     ((and (= size 32) (> align 4))
+      '(setf (sap-ref-32 sap (ash offset -5)) value))
+     ((and (= size 16) (> align 3))
+      '(setf (sap-ref-16 sap (ash offset -4)) value))
+     ((and (= size 8) (> align 2))
+      '(setf (sap-ref-8 sap (ash offset -3)) value))
+     ((not bits)
+      (give-up "Can't determine offset within word, so cannot open-code:~%~S"
+	       (continuation-value form)))
+     ((<= (+ bits size) 32)
+      `(setf (ldb (byte ,size ,bits) (sap-ref-32 sap (ash offset -5)))
+	     value))
+     ((> size 32)
+      (give-up "Accesses of ~D bits unsupported:~%~S"
 	       size (continuation-value form)))
-     ((= size 32)
-      '(%primitive signed-32bit-system-set sap (ash offset -4) value))
-     ((= size 16)
-      '(%primitive 16bit-system-set sap (ash offset -4) value))
-     ((> size 15)
-      (compiler-warning "Access of ~D bit bytes is not supported:~%~S"
-			size (continuation-value form))
-      (give-up))
-     ((and (> align 2) (= size 8))
-      '(%primitive 8bit-system-set sap (ash offset -3) value))
      (t
-      (let ((bits (find-bit-offset offset)))
-	(unless bits
-	  (give-up "Can't determine offset within word, so cannot ~
-	            open-code:~%~S"
-		   (continuation-value form)))
-	
-	(if (>= (+ bits size) 16)
-	    (let* ((hi-bits (- 16 bits))
-		   (lo-bits (- size hi-bits)))
-	      ;;
-	      ;; If the integer spans a 16bit boundry, then the high bits in
-	      ;; the integer are the low bits in the first word, and the low
-	      ;; bits in the integer are the high bits in the next word.
-	      `(let ((offset (ash offset -4)))
-		 (%primitive 16bit-system-set sap offset
-			     (dpb (ash value ,(- lo-bits))
-				  (byte ,hi-bits 0)
-				  (sap-ref-16 sap offset)))
-		 (%primitive 16bit-system-set sap (1+ offset)
-			     (dpb value
-				  (byte ,lo-bits ,(- 16 lo-bits))
-				  (sap-ref-16 (1+ offset))))))
-	    `(let ((offset (ash offset -4)))
-	       (setf (sap-ref-16 sap offset)
-		     (dpb value
-			  (byte ,size ,bits)
-			  (sap-ref-16 sap offset))))))))))
+      ;;
+      ;; If the integer spans a 32 bit boundry, what we do depends on
+      ;; the byte order.  See the comments in naturalize-integer.
+      ;; 
+      (let* ((high-bits (- 32 bits))
+	     (low-bits (- size high-bits)))
+	(multiple-value-bind (low-byte high-byte)
+			     (ecase vm:target-byte-order
+			       (:little-endian
+				(values 'offset '(1+ offset)))
+			       (:big-endian
+				(values '(1+ offset) 'offset)))
+	  `(let ((offset (ash offset -5)))
+	     (setf (ldb (byte ,high-bits 0)
+			(sap-ref-32 sap ,high-byte))
+		   (ash value ,(- low-bits)))
+	     (setf (ldb (byte ,low-bits ,(- 32 low-bits))
+			(sap-ref-32 sap ,low-byte))
+		   value))))))))
 
 
 ;;;; Boolean stuff:
 
-(defknown naturalize-boolean (t index index t) boolean (flushable))
-(defknown deport-boolean (t index index t t) void ())
+(defknown naturalize-boolean (system-area-pointer index index t) boolean
+  (flushable))
+(defknown deport-boolean (system-area-pointer index index t t) void ())
 
 ;;; Naturalize and Deport Boolean transforms  --  Internal
 ;;; 
@@ -822,10 +1066,7 @@
 	       (continuation-value form)))
     (if (= size 1)
 	`(let ((offset (ash offset -3)))
-	   (setf (sap-ref-8 sap offset)
-		 (let ((old (sap-ref-8 sap offset)))
-		   (if value
-		       (logior old ,(ash 1 (- 7 off)))
-		       (logand old ,(lognot (ash 1 (- 7 off))))))))
+	   (setf (ldb (byte 1 ,off) (sap-ref-8 sap offset))
+		 (if value 1 0)))
 	`(deport-integer nil sap offset ,size (if value 1 0)
 			 ',(continuation-value form)))))
diff --git a/compiler/codegen.lisp b/compiler/codegen.lisp
index f91233bfe..14f8ba758 100644
--- a/compiler/codegen.lisp
+++ b/compiler/codegen.lisp
@@ -18,6 +18,15 @@
 
 ;;;; Utilities used during code generation.
 
+;;; Component-Header-Length   --  Interface
+;;; 
+(defun component-header-length (&optional (component *compile-component*))
+  "Returns the number of bytes used by the code object header."
+  (let* ((2comp (component-info component))
+	 (constants (ir2-component-constants 2comp))
+	 (num-consts (length constants)))
+    (ash (logandc2 (1+ num-consts) 1) vm:word-shift)))
+
 ;;; SB-Allocated-Size  --  Interface
 ;;;
 (defun sb-allocated-size (name)
@@ -58,6 +67,18 @@
   (ir2-environment-return-pc-pass 2env))
 
 
+;;;; Generate-code and support routines.
+
+(defvar *code-segment* nil)
+(defvar *elsewhere* nil)
+
+;;; Init-Assembler  --  Interface
+;;; 
+(defun init-assembler ()
+  (setf *code-segment* (make-segment))
+  (setf *elsewhere* (make-segment))
+  (undefined-value))
+
 ;;; Generate-Code  --  Interface
 ;;;
 (defun generate-code (component)
@@ -66,7 +87,8 @@
       (let ((1block (ir2-block-block block)))
 	(when (and (eq (block-info 1block) block)
 		   (block-start 1block))
-	  (emit-label (block-label 1block))
+	  (assemble (*code-segment* nil)
+	    (emit-label (block-label 1block)))
 	  (let ((env (block-environment 1block)))
 	    (unless (eq env prev-env)
 	      (let ((lab (gen-label)))
@@ -82,5 +104,15 @@
 	      (funcall gen vop)
 	      (format t "Missing generator for ~S.~%"
 		      (template-name (vop-info vop))))))))
+  (assemble (*code-segment* nil)
+    (insert-segment *elsewhere*))
+  (finalize-segment *code-segment*))
+
+
+(defun emit-label-elsewhere (label)
+  (assemble (*elsewhere* nil)
+    (emit-label label)))
+
 
-  (finish-assembly))
+(defun label-elsewhere-p (label)
+  (<= (label-position *elsewhere*) (label-position label)))
diff --git a/compiler/debug-dump.lisp b/compiler/debug-dump.lisp
index 0565691bc..7b678c706 100644
--- a/compiler/debug-dump.lisp
+++ b/compiler/debug-dump.lisp
@@ -110,7 +110,7 @@
 	0)
    *byte-buffer*)
   
-  (let ((loc (label-location label)))
+  (let ((loc (label-position label)))
     (write-var-integer (- loc *previous-location*) *byte-buffer*)
     (setq *previous-location* loc))
 
@@ -498,9 +498,8 @@
 ;;; at some particular time (after assembly) so that source map information is
 ;;; available.
 ;;; 
-(defun debug-info-for-component (component assem-nodes count)
-  (declare (type component component) (simple-vector assem-nodes)
-	   (type index count))
+(defun debug-info-for-component (component)
+  (declare (type component component))
   (let ((level (cookie-debug *default-cookie*))
 	(res (make-compiled-debug-info :name (component-name component)
 				       :package (package-name *package*))))
@@ -525,11 +524,11 @@
 				    (ir2-environment-return-pc 2env))
 			:old-fp (tn-sc-offset
 				 (ir2-environment-old-fp 2env))
-			:start-pc (label-location
+			:start-pc (label-position
 				   (ir2-environment-environment-start 2env))
 
 			:elsewhere-pc
-			(label-location
+			(label-position
 			 (ir2-environment-elsewhere-start 2env)))))
 	    
 	    (when (>= level 1)
@@ -556,7 +555,7 @@
 			 (setf (compiled-debug-function-returns dfun)
 			       (compute-debug-returns fun)))))))
 
-	    (dfuns (cons (label-location
+	    (dfuns (cons (label-position
 			  (block-label
 			   (node-block
 			    (lambda-bind fun))))
diff --git a/compiler/debug.lisp b/compiler/debug.lisp
index 32a9f1fb2..9081885e3 100644
--- a/compiler/debug.lisp
+++ b/compiler/debug.lisp
@@ -7,6 +7,8 @@
 ;;; Scott Fahlman (FAHLMAN@CMUC). 
 ;;; **********************************************************************
 ;;;
+;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/debug.lisp,v 1.13 1990/08/24 18:35:02 wlott Exp $
+;;; 
 ;;;    Utilities for debugging the compiler.  Currently contains only stuff for
 ;;; checking the consistency of the IR1.
 ;;; 
@@ -1065,15 +1067,22 @@
 (defun print-tn (tn &optional (stream *standard-output*))
   (declare (type tn tn))
   (let ((leaf (tn-leaf tn)))
-    (cond (leaf
+    (cond #-new-compiler
+	  (leaf
 	   (xp::princ (with-output-to-string (stream)
 			(print-leaf leaf stream))
 		      stream)
 	   (xp::format stream "!~D" (tn-id tn)))
+	  #+new-compiler
+	  (leaf
+	   (print-leaf leaf stream)
+	   (format stream "!~D" (tn-id tn)))
 	  (t
-	   (xp::format stream "t~D" (tn-id tn))))
+	   (#-new-compiler xp::format #+new-compiler format
+			   stream "t~D" (tn-id tn))))
     (when (and (tn-sc tn) (tn-offset tn))
-      (xp::format stream "[~A]" (location-print-name tn)))))
+      (#-new-compiler xp::format #+new-compiler format
+		      stream "[~A]" (location-print-name tn)))))
 
 
 ;;; Print-Operands  --  Internal
@@ -1083,7 +1092,8 @@
 ;;;
 (defun print-operands (refs)
   (declare (type (or tn-ref null) refs))
-  (xp:within-logical-block (nil nil)
+  (#-new-compiler xp:within-logical-block #-new-compiler (nil nil)
+		  #+new-compiler progn
     (do ((ref refs (tn-ref-across ref)))
 	((null ref))
       (let ((tn (tn-ref-tn ref))
@@ -1092,9 +1102,11 @@
 	       (print-tn tn))
 	      (t
 	       (print-tn tn)
-	       (xp::princ (if (tn-ref-write-p ref) #\< #\>))
+	       (#-new-compiler xp::princ #+new-compiler princ
+			       (if (tn-ref-write-p ref) #\< #\>))
 	       (print-tn ltn)))
-	(xp::princ #\space)
+	(#-new-compiler xp::princ #+new-compiler princ #\space)
+	#-new-compiler
 	(xp:conditional-newline :fill)))))
 
 
@@ -1103,6 +1115,7 @@
 ;;; Print the vop on a single line.
 ;;;
 (defun print-vop (vop)
+  #-new-compiler
   (xp:within-logical-block (nil nil)
     (xp::princ (vop-info-name (vop-info vop)))
     (xp::princ #\space)
@@ -1118,7 +1131,21 @@
     (when (vop-results vop)
       (xp::princ "=> ")
       (print-operands (vop-results vop))))
-  (xp::terpri))
+  #-new-compiler
+  (xp::terpri)
+  #+new-compiler
+  (progn
+    (princ (vop-info-name (vop-info vop)))
+    (princ #\space)
+    (print-operands (vop-args vop))
+    (when (vop-codegen-info vop)
+      (let ((*print-level* 1)
+	    (*print-length* 3))
+	(format t "{~{~S~^ ~}} " (vop-codegen-info vop))))
+    (when (vop-results vop)
+      (princ "=> ")
+      (print-operands (vop-results vop)))
+    (terpri)))
 
 ;;; Print-IR2-Block  --  Internal
 ;;;
diff --git a/compiler/eval.lisp b/compiler/eval.lisp
index 851f78d0d..c459f4ce4 100644
--- a/compiler/eval.lisp
+++ b/compiler/eval.lisp
@@ -7,6 +7,8 @@
 ;;; Scott Fahlman (FAHLMAN@CMUC). 
 ;;; **********************************************************************
 ;;;
+;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/eval.lisp,v 1.13 1990/08/24 18:35:11 wlott Exp $
+;;; 
 ;;; This file contains the interpreter.  We first convert to the compiler's
 ;;; IR1 and interpret that.
 ;;;
@@ -254,7 +256,7 @@
     (declare (ignore ig1 ig2))
     res))
 ;;;
-(defun (setf interpreted-function-name) (x val)
+(defun (setf interpreted-function-name) (val x)
   (let* ((eval-fun (get-eval-function x))
 	 (def (eval-function-definition eval-fun)))
     (when def
@@ -266,7 +268,7 @@
 (defun interpreted-function-arglist (x)
   (eval-function-arglist (get-eval-function x)))
 ;;;
-(defun (setf interpreted-function-arglist) (x val)
+(defun (setf interpreted-function-arglist) (val x)
   (setf (eval-function-arglist (get-eval-function x)) val))
 
 
@@ -464,7 +466,7 @@
 	  ;; binding mechanism to unbind one variable.
 	  (eval-stack-pop)
 	  (maybe-trace-funny-fun node ,name)
-	  (system:%primitive unbind 1))
+	  (system:%primitive unbind))
 	 (c::%catch
 	  (let* ((tag (eval-stack-pop))
 		 (nlx-info (eval-stack-pop))
diff --git a/compiler/fndb.lisp b/compiler/fndb.lisp
index 1d9a2a0dc..23ee289f5 100644
--- a/compiler/fndb.lisp
+++ b/compiler/fndb.lisp
@@ -7,15 +7,17 @@
 ;;; Scott Fahlman (FAHLMAN@CMUC). 
 ;;; **********************************************************************
 ;;;
+;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/fndb.lisp,v 1.10 1990/08/24 18:35:19 wlott Exp $
+;;;
 ;;;    This file defines all the standard functions to be known functions.
 ;;; Each function has type and side-effect information, and may also have IR1
 ;;; optimizers.
 ;;;
 ;;; Written by Rob MacLachlan
 ;;;
-(in-package 'c)
+(in-package "C")
 
-(in-package 'lisp)
+(in-package "LISP")
 (import '(
 	  %aset
 	  %bitset
@@ -29,6 +31,7 @@
 	  %set-documentation
 	  %set-fdefinition
 	  %set-fill-pointer
+	  %set-row-major-aref
 	  %setelt
 	  %setnth
 	  %sp-set-definition
@@ -39,6 +42,7 @@
 	  %typep
 	  %array-typep
 	  array-header-p
+	  base-char-p
 	  double-float-p
 	  long-float-p
 	  short-float-p
@@ -385,21 +389,13 @@
 
 (defknown character (t) character (movable foldable flushable))
 (defknown char-code (character) char-code (movable foldable flushable))
-(defknown char-bits (character) char-bits (movable foldable flushable))
-(defknown char-font (character) char-font (movable foldable flushable))
-(defknown code-char (char-code &optional char-bits char-font)
-  character (movable foldable flushable))
-(defknown make-char (character  &optional char-bits char-font)
-  character (movable foldable flushable))
+(defknown code-char (char-code) base-character (movable foldable flushable))
 (defknown (char-upcase char-downcase) (character) character (movable foldable flushable))
 (defknown digit-char (integer &optional integer char-bits)
   (or character null) (movable foldable flushable))
-(defknown char-int (character) char-int (movable foldable flushable))
-(defknown int-char (char-int) character (movable foldable flushable))
+(defknown char-int (character) char-code (movable foldable flushable))
 (defknown char-name (character) (or simple-string null) (movable foldable flushable))
 (defknown name-char (stringable) (or character null) (movable foldable flushable))
-(defknown char-bit (character bit-names) boolean (movable foldable flushable))
-(defknown set-char-bit (character bit-names t) character (movable foldable flushable))
 
 
 ;;;; In the "Sequences" chapter:
@@ -681,6 +677,7 @@
 (defknown vector (&rest t) simple-vector (flushable unsafe))
 
 (defknown aref (array &rest index) t (foldable flushable))
+(defknown row-major-aref (array index) t (foldable flushable))
 
 (defknown array-element-type (array) type-specifier (foldable flushable))
 (defknown array-rank (array) array-rank (foldable flushable))
@@ -725,8 +722,8 @@
 
 ;;;; In the "Strings" chapter:
 
-(defknown char (string index) string-char (foldable flushable))
-(defknown schar (simple-string index) string-char (foldable flushable))
+(defknown char (string index) character (foldable flushable))
+(defknown schar (simple-string index) character (foldable flushable))
 
 (defknown (string= string-equal)
   (stringlike stringlike &key (start1 index) (end1 sequence-end)
@@ -742,7 +739,7 @@
   (or index null)
   (foldable flushable))
 
-(defknown make-string (index &key (initial-element string-char))
+(defknown make-string (index &key (initial-element character))
   simple-string (flushable))
 
 (defknown (string-trim string-left-trim string-right-trim)
@@ -943,8 +940,8 @@
 (defknown file-length (stream) (or unsigned-byte null) (flushable))
 
 (defknown load
-  (filename &key (verbose t) (print t)
-	    (if-does-not-exist (member :error :create nil)))
+  ((or filename stream)
+   &key (verbose t) (print t) (if-does-not-exist (member :error :create nil)))
   t)
 
 (defknown directory (pathnamelike &key) list (flushable))
@@ -1044,8 +1041,12 @@
 (defknown (%dpb %deposit-field) (integer bit-index bit-index integer) integer
   (movable foldable flushable))
 (defknown %negate (number) number (movable foldable flushable))
+(defknown %check-bound (array index fixnum) index (movable foldable flushable))
+(defknown data-vector-ref (array index) t (foldable flushable))
+(defknown data-vector-set (array index t) t (unsafe))
 (defknown kernel:%caller-frame-and-pc () (values t t) (flushable))
 
+
 ;;; Structure slot accessors or setters are magically "known" to be these
 ;;; functions, although the var remains the Slot-Accessor describing the actual
 ;;; function called.
@@ -1057,6 +1058,7 @@
 ;;;; Setf inverses:
 
 (defknown %aset (array &rest t) t (unsafe))
+(defknown %set-row-major-aref (array index t) t (unsafe))
 (defknown %rplaca (cons t) t (unsafe))
 (defknown %rplacd (cons t) t (unsafe))
 (defknown %put (symbol t t) t (unsafe))
@@ -1064,8 +1066,8 @@
 (defknown %svset (simple-vector index t) t (unsafe))
 (defknown %bitset (bit-vector index bit) bit (unsafe))
 (defknown %sbitset (simple-bit-vector index bit) bit (unsafe))
-(defknown %charset (string index string-char) string-char (unsafe))
-(defknown %scharset (simple-string index string-char) string-char (unsafe))
+(defknown %charset (string index character) character (unsafe))
+(defknown %scharset (simple-string index character) character (unsafe))
 (defknown %sp-set-definition (symbol function) function (unsafe))
 (defknown %sp-set-plist (symbol t) t (unsafe))
 (defknown %set-documentation
@@ -1082,8 +1084,8 @@
 ;;; into non-standard unary predicates.
 
 (defknown (fixnump bignump ratiop short-float-p single-float-p double-float-p
-		   long-float-p %string-char-p %standard-char-p structurep
-		   array-header-p)
+	   long-float-p base-char-p %string-char-p %standard-char-p structurep
+	   array-header-p)
   (t) boolean (movable foldable flushable))
 
 
diff --git a/compiler/ir1opt.lisp b/compiler/ir1opt.lisp
index 3dd36eb8b..8b09890ba 100644
--- a/compiler/ir1opt.lisp
+++ b/compiler/ir1opt.lisp
@@ -825,6 +825,8 @@
 				    :argument-test #'types-intersect
 				    :result-test #'values-types-intersect))
 	   (setf (gethash node *failed-optimizations*) type)
+	   t)
+	  (t
 	   t))))
 
 
diff --git a/compiler/ir1tran.lisp b/compiler/ir1tran.lisp
index eab285153..d615e62ce 100644
--- a/compiler/ir1tran.lisp
+++ b/compiler/ir1tran.lisp
@@ -1468,7 +1468,7 @@
      :name name
      :type (specifier-type
 	    (if (listp name)
-		`(function (,type ,slot-type) ,slot-type)
+		`(function (,slot-type ,type) ,slot-type)
 		`(function (,type) ,slot-type)))
      :for info
      :slot slot)))
@@ -2416,7 +2416,7 @@
 	(unless (dsd-read-only slot)
 	  (process-1-ftype-proclamation
 	   `(setf ,fun)
-	   (specifier-type `(function (,name ,type) ,type))))))
+	   (specifier-type `(function (,type ,name) ,type))))))
 
     (collect ((forms))
       (when copier
diff --git a/compiler/ir2tran.lisp b/compiler/ir2tran.lisp
index 4f601fb5d..ee778a30a 100644
--- a/compiler/ir2tran.lisp
+++ b/compiler/ir2tran.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman (FAHLMAN@CMUC). 
 ;;; **********************************************************************
 ;;;
-;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ir2tran.lisp,v 1.19 1990/08/16 16:16:50 ram Exp $
+;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ir2tran.lisp,v 1.20 1990/08/24 18:35:51 wlott Exp $
 ;;;
 ;;;    This file contains the virtual machine independent parts of the code
 ;;; which does the actual translation of nodes to VOPs.
@@ -202,7 +202,7 @@
 		 (closure (environment-closure (lambda-environment leaf))))
 	     (vop make-closure node block (emit-constant (length closure))
 		  entry res)
-	     (let ((n (1- system:%function-closure-variables-offset)))
+	     (let ((n -1))
 	       (dolist (what closure)
 		 (vop closure-init node block
 		      res (find-in-environment what this-env)
@@ -1072,21 +1072,22 @@
 ;;; 
 (defun init-xep-environment (node block fun)
   (declare (type bind node) (type ir2-block block) (type clambda fun))
-  (vop xep-allocate-frame node block (entry-info-offset (leaf-info fun)))
-  (let ((ef (functional-entry-function fun)))
-    (when (and (optional-dispatch-p ef)
-	       (optional-dispatch-more-entry ef))
-      (vop copy-more-arg node block (optional-dispatch-max-args ef))))
-  
-  (let ((env (environment-info (node-environment node))))
+  (let ((start-label (entry-info-offset (leaf-info fun)))
+	(env (environment-info (node-environment node))))
+    (vop xep-allocate-frame node block start-label)
+    (let ((ef (functional-entry-function fun)))
+      (when (and (optional-dispatch-p ef)
+		 (optional-dispatch-more-entry ef))
+	(vop copy-more-arg node block (optional-dispatch-max-args ef))))
+    
     (if (ir2-environment-environment env)
 	(let ((closure (make-normal-tn *any-primitive-type*)))
-	  (vop setup-closure-environment node block closure)
-	  (let ((n (1- system:%function-closure-variables-offset)))
+	  (vop setup-closure-environment node block start-label closure)
+	  (let ((n -1))
 	    (dolist (loc (ir2-environment-environment env))
 	      (vop closure-ref node block closure (incf n) (cdr loc)))))
-	(vop setup-environment node block))
-
+	(vop setup-environment node block start-label))
+    
     (unless (eq (functional-kind fun) :top-level)
       (let ((vars (lambda-vars fun))
 	    (n 0))
@@ -1104,7 +1105,7 @@
     
     (emit-move node block (make-old-fp-passing-location t)
 	       (ir2-environment-old-fp env)))
-
+  
   (undefined-value))
 
 
@@ -1328,7 +1329,7 @@
 	 (emit-constant name))))
 ;;;
 (defoptimizer (%special-unbind ir2-convert) ((var) node block)
-  (vop unbind node block (emit-constant 1)))
+  (vop unbind node block))
 
 
 ;;; PROGV IR1 convert  --  Internal
@@ -1412,9 +1413,8 @@
 ;;;
 ;;;    Emit code to set up a non-local-exit.  Info is the NLX-Info for the
 ;;; exit, and Tag is the continuation for the catch tag (if any.)  We get at
-;;; the entry PC by making a :Label load-time constant TN.  This is a
-;;; non-immediate constant TN that is initialized to the offset of the
-;;; specified label.
+;;; the target PC by passing in the label to the vop.  The vop is responsible
+;;; for building a return-PC object.
 ;;;
 (defun emit-nlx-start (node block info tag)
   (declare (type node node) (type ir2-block block) (type nlx-info info)
@@ -1424,11 +1424,8 @@
 	 (block-tn (environment-live-tn
 		    (make-normal-tn (primitive-type-or-lose 'catch-block))
 		    (node-environment node)))
-	 (res (make-normal-tn *any-primitive-type*))
-	 (target-tn
-	  (make-load-time-constant-tn
-	   :label
-	   (block-label (nlx-info-target info)))))
+	 (res (make-stack-pointer-tn))
+	 (target-label (ir2-nlx-info-target 2info)))
 
     (vop* save-dynamic-state node block
 	  (nil)
@@ -1438,9 +1435,9 @@
     (ecase kind
       (:catch
        (vop make-catch-block node block block-tn
-	    (continuation-tn node block tag) target-tn res))
-      ((:unwind-protect :block :tagbody)
-       (vop make-unwind-block node block block-tn target-tn res)))
+	    (continuation-tn node block tag) target-label res))
+      ((:unwind-protect :entry)
+       (vop make-unwind-block node block block-tn target-label res)))
 
     (ecase kind
       ((:block :tagbody)
@@ -1508,23 +1505,26 @@
 	 (2info (nlx-info-info info))
 	 (top-loc (ir2-nlx-info-save-sp 2info))
 	 (start-loc (make-old-fp-passing-location t))
-	 (count-loc (make-argument-count-location)))
+	 (count-loc (make-argument-count-location))
+	 (target (ir2-nlx-info-target 2info)))
 
     (ecase (cleanup-kind (nlx-info-cleanup info))
       ((:catch :block :tagbody)
        (if (and 2cont (eq (ir2-continuation-kind 2cont) :unknown))
 	   (vop* nlx-entry-multiple node block
 		 (top-loc start-loc count-loc nil)
-		 ((reference-tn-list (ir2-continuation-locs 2cont) t)))
+		 ((reference-tn-list (ir2-continuation-locs 2cont) t))
+		 target)
 	   (let ((locs (standard-result-tns cont)))
 	     (vop* nlx-entry node block
 		   (top-loc start-loc count-loc nil)
 		   ((reference-tn-list locs t))
+		   target
 		   (length locs))
 	     (move-continuation-result node block locs cont))))
       (:unwind-protect
        (let ((block-loc (standard-argument-location 0)))
-	 (vop uwp-entry node block block-loc start-loc count-loc)
+	 (vop uwp-entry node block target block-loc start-loc count-loc)
 	 (move-continuation-result
 	  node block
 	  (list block-loc start-loc count-loc)
@@ -1569,7 +1569,7 @@
 	 (first res))
     (move-continuation-result node block res cont)))
 
-(defoptimizer (%slot-setter ir2-convert) ((str value) node block)
+(defoptimizer (%slot-setter ir2-convert) ((value str) node block)
   (let ((val (continuation-tn node block value)))
     (vop structure-set node block
 	 (continuation-tn node block str)
diff --git a/compiler/main.lisp b/compiler/main.lisp
index bfc8fa9cb..fb04e72da 100644
--- a/compiler/main.lisp
+++ b/compiler/main.lisp
@@ -165,7 +165,9 @@
   (loop-analyze component)
   |#
 
-  (let ((*compile-component* component))
+  (let ((*compile-component* component)
+	(*code-segment* nil)
+	(*elsewhere* nil))
     (maybe-mumble "Env ")
     (environment-analyze component)
     (maybe-mumble "GTN ")
@@ -216,22 +218,26 @@
       (describe-component component *compiler-trace-output*))
     
     (maybe-mumble "Code ")
-    (generate-code component))
-
-  (etypecase object
-    (fasl-file
-     (maybe-mumble "FASL")
-     (fasl-dump-component component *code-vector* *next-location*
-			  *assembler-nodes* (1+ *current-assembler-node*)
-			  *result-fixups* object))
-    (core-object
-     (maybe-mumble "Core"
-     (make-core-component component *code-vector* *next-location*
-			  *assembler-nodes* (1+ *current-assembler-node*)
-			  *result-fixups* object)))
-    (null))
-
-  (compiler-mumble "~%")
+    (let ((length (generate-code component)))
+      
+      (when *compiler-trace-output*
+	(format *compiler-trace-output*
+		"~|~%Assembly code for ~S~2%"
+		component)
+	(dump-segment *code-segment* *compiler-trace-output*))
+
+      (etypecase object
+	(fasl-file
+	 (maybe-mumble "FASL")
+	 (fasl-dump-component component *code-segment* length object))
+	(core-object
+	 (maybe-mumble "Core")
+	 (make-core-component component *code-segment* length object))
+	(null))
+
+      (nuke-segment *code-segment*)))
+
+  (compiler-mumble "~&")
   (undefined-value))
 
 
@@ -716,7 +722,9 @@
     (cond (*block-compile* (push tll *top-level-lambdas*))
 	  (t
 	   (compile-top-level (list tll) object)
-	   (clear-stuff)))))
+	   (clear-stuff))))
+  #+new-compiler
+  (lisp::maybe-gc))
 
 
 ;;; PROCESS-PROGN  --  Internal
@@ -1116,7 +1124,8 @@
 		       (pathname file))))
 	    
 	    (when output-file
-	      (setq output-file-name (frob output-file "nfasl"))
+	      (setq output-file-name
+		    (frob output-file vm:target-fasl-file-type))
 	      (setq fasl-file (open-fasl-file output-file-name
 					      (namestring (first source)))))
 	    
diff --git a/compiler/vmdef.lisp b/compiler/vmdef.lisp
index 373e6a8cd..c481ff7bb 100644
--- a/compiler/vmdef.lisp
+++ b/compiler/vmdef.lisp
@@ -282,7 +282,7 @@
 	     (setf (svref (sc-load-costs to-sc) num) ',cost)))))
 
      (defun ,name ,lambda-list
-       (assemble (vop-node ,(first lambda-list))
+       (assemble (*code-segment* ,(first lambda-list))
 	 ,@body))))
 
 
@@ -1209,7 +1209,7 @@
 		  ,@(binds))
 	     (declare (ignore ,@(vop-parse-ignores parse)))
 	     ,@(loads)
-	     (assemble (vop-node ,n-vop)
+	     (assemble (*code-segment* ,n-vop)
 	       ,@(vop-parse-body parse))
 	     ,@(saves))))))
 
-- 
GitLab