diff --git a/compiler/generic/vm-ir2tran.lisp b/compiler/generic/vm-ir2tran.lisp
index 25112780241ca051c742f4b04e33f5176ecaf7b0..a295c63ce4931afae4ccd264b6fe8ff2aa0f2c63 100644
--- a/compiler/generic/vm-ir2tran.lisp
+++ b/compiler/generic/vm-ir2tran.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/vm-ir2tran.lisp,v 1.5 1992/12/18 11:19:50 wlott Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/vm-ir2tran.lisp,v 1.6 1993/05/07 07:22:14 wlott Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -15,7 +15,8 @@
 ;;; 
 (in-package :c)
 
-(export '(slot set-slot make-unbound-marker fixed-alloc var-alloc))
+(export '(slot set-slot make-unbound-marker fixed-alloc var-alloc
+	  %set-function-self large-alloc))
 
 (defoptimizer ir2-convert-reffer ((object) node block name offset lowtag)
   (let* ((cont (node-cont node))
@@ -70,13 +71,26 @@
 	     name slot lowtag #+gengc nil))))
   (assert (null args)))
 
+#+gengc
+(defun do-fixed-alloc (node block name words type lowtag result)
+  (if (and (backend-featurep :gengc)
+	   (>= words vm:large-object-cutoff))
+      (vop large-alloc node block (emit-constant (logandc2 (1+ words) 1))
+	   (emit-constant lowtag) (emit-constant type) (emit-constant 0) name
+	   result)
+      (vop fixed-alloc node block name words type lowtag result)))
+
+#-gengc
+(defun do-fixed-alloc (node block name words type lowtag result)
+  (vop fixed-alloc node block name words type lowtag result))
+
 (defoptimizer ir2-convert-fixed-allocation
 	      ((&rest args) node block name words type lowtag inits)
   (let* ((cont (node-cont node))
 	 (locs (continuation-result-tns
 		cont (list (backend-any-primitive-type *backend*))))
 	 (result (first locs)))
-    (vop fixed-alloc node block name words type lowtag result)
+    (do-fixed-alloc node block name words type lowtag result)
     (do-inits node block name result lowtag inits args)
     (move-continuation-result node block locs cont)))
 
@@ -88,22 +102,85 @@
 	 (result (first locs)))
     (if (constant-continuation-p extra)
 	(let ((words (+ (continuation-value extra) words)))
-	  (vop fixed-alloc node block name words type lowtag result))
+	  (do-fixed-alloc node block name words type lowtag result))
 	(vop var-alloc node block (continuation-tn node block extra) name words
 	     type lowtag result))
     (do-inits node block name result lowtag inits args)
     (move-continuation-result node block locs cont)))
 
 
+
+;;;; Other allocation support.
+
+
+#+gengc
+(defoptimizer (make-array-header ir2-convert) ((type rank) node block)
+  (let* ((cont (node-cont node))
+	 (locs (continuation-result-tns
+		cont (list (backend-any-primitive-type *backend*))))
+	 (result (first locs)))
+    (if (and (constant-continuation-p type)
+	     (constant-continuation-p rank))
+	(do-fixed-alloc node block 'make-array-header
+			(+ (continuation-value rank)
+			   vm:array-dimensions-offset)
+			(continuation-value type)
+			vm:other-pointer-type result)
+	(vop make-array-header node block (continuation-tn node block type)
+	     (continuation-tn node block rank) result))
+    (move-continuation-result node block locs cont)))
+
+#+gengc
+(setf (function-info-ltn-annotate (function-info-or-lose 'make-array-header))
+      #'annotate-funny-call)
+
 
 ;;;; Replacements for stuff in ir2tran to make gengc work.
 
+#+gengc
+(defun ir2-convert-closure (node block leaf res)
+  (declare (type ref node) (type ir2-block block)
+	   (type functional leaf) (type tn res))
+  (unless (leaf-info leaf)
+    (setf (leaf-info leaf) (make-entry-info)))
+  (let ((entry (make-load-time-constant-tn :entry leaf))
+	(closure (etypecase leaf
+		   (clambda
+		    (environment-closure (get-lambda-environment leaf)))
+		   (functional
+		    (assert (eq (functional-kind leaf) :top-level-xep))
+		    nil))))
+    (cond (closure
+	   (let ((this-env (node-environment node)))
+	     (cond
+	      ((backend-featurep :gengc)
+	       (do-fixed-alloc node block 'make-closure
+			       (+ (length closure) vm:closure-info-offset)
+			       vm:closure-header-type vm:function-pointer-type
+			       res)
+	       (vop %set-function-self node block res entry))
+	      (t
+	       (vop make-closure node block entry (length closure) res)))
+	     (loop for what in closure and n from 0 do
+	       (unless (and (lambda-var-p what)
+			    (null (leaf-refs what)))
+		 (vop closure-init node block
+		      res
+		      (find-in-environment what this-env)
+		      n
+		      nil)))))
+	  (t
+	   (emit-move node block entry res))))
+  (undefined-value))
+
+
 #+gengc
 (defun ir2-convert-set (node block)
   (declare (type cset node) (type ir2-block block))
   (let* ((cont (node-cont node))
 	 (leaf (set-var node))
-	 (val (continuation-tn node block (set-value node)))
+	 (value (set-value node))
+	 (val-tn (continuation-tn node block value))
 	 (locs (if (continuation-info cont)
 		   (continuation-result-tns
 		    cont (list (primitive-type (leaf-type leaf))))
@@ -113,18 +190,18 @@
        (when (leaf-refs leaf)
 	 (let ((tn (find-in-environment leaf (node-environment node))))
 	   (if (lambda-var-indirect leaf)
-	       (vop value-cell-set node block tn val
-		    (needs-remembering val))
-	       (emit-move node block val tn)))))
+	       (vop value-cell-set node block tn val-tn
+		    (needs-remembering value))
+	       (emit-move node block val-tn tn)))))
       (global-var
        (ecase (global-var-kind leaf)
 	 ((:special :global)
 	  (assert (symbolp (leaf-name leaf)))
-	  (vop set node block (emit-constant (leaf-name leaf)) val
-	       (needs-remembering val))))))
+	  (vop set node block (emit-constant (leaf-name leaf)) val-tn
+	       (needs-remembering value))))))
 
     (when locs
-      (emit-move node block val (first locs))
+      (emit-move node block val-tn (first locs))
       (move-continuation-result node block locs cont)))
   (undefined-value))
 
@@ -140,7 +217,7 @@
 #+gengc
 (defoptimizer (%slot-setter ir2-convert) ((value str) node block)
   (let ((val (continuation-tn node block value)))
-    (vop structure-set node block
+    (vop instance-set node block
 	 (continuation-tn node block str)
 	 val
 	 (dsd-index