From 743b3850b72e7c030f81c5a5b799e0b42f262333 Mon Sep 17 00:00:00 2001
From: wlott <wlott>
Date: Tue, 15 Dec 1992 19:33:49 +0000
Subject: [PATCH] Fixed a call to continuation-tn to have all three arguments. 
 Added some generational GC stuff conditionalized under #+gengc.

---
 compiler/generic/vm-ir2tran.lisp | 76 +++++++++++++++++++++++++++++---
 1 file changed, 71 insertions(+), 5 deletions(-)

diff --git a/compiler/generic/vm-ir2tran.lisp b/compiler/generic/vm-ir2tran.lisp
index ade65200f..163a5a08f 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.1 1992/12/13 15:14:50 wlott Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/vm-ir2tran.lisp,v 1.2 1992/12/15 19:33:49 wlott Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -26,16 +26,24 @@
 	 name offset lowtag res)
     (move-continuation-result node block locs cont)))
 
+#+gengc
+(defun needs-remembering (cont)
+  (if (csubtypep (continuation-type cont)
+		 (load-time-value (specifier-type '(or fixnum character
+						       (member t nil)))))
+      nil
+      t))
+
 (defoptimizer ir2-convert-setter ((object value) node block name offset lowtag)
   (let ((value-tn (continuation-tn node block value)))
     (vop set-slot node block (continuation-tn node block object) value-tn
-	 name offset lowtag)
+	 name offset lowtag #+gengc (needs-remembering value))
     (move-continuation-result node block (list value-tn) (node-cont node))))
 
 (defoptimizer ir2-convert-setfer ((value object) node block name offset lowtag)
   (let ((value-tn (continuation-tn node block value)))
     (vop set-slot node block (continuation-tn node block object) value-tn
-	 name offset lowtag)
+	 name offset lowtag #+gengc (needs-remembering value))
     (move-continuation-result node block (list value-tn) (node-cont node))))
 
 (defun do-inits (node block name result lowtag inits args)
@@ -58,7 +66,7 @@
 			    tn))))
 	       (:null
 		(emit-constant nil)))
-	     name slot lowtag))))
+	     name slot lowtag #+gengc nil))))
   (assert (null args)))
 
 (defoptimizer ir2-convert-fixed-allocation
@@ -84,8 +92,66 @@
 	  (vop fixed-alloc node block name words
 	       (logior (ash words vm:type-bits) type)
 	       lowtag result))
-	(vop var-alloc node block (continuation-tn extra) name words
+	(vop var-alloc node block (continuation-tn node block extra) name words
 	     (logior (ash words vm:type-bits) type)
 	     lowtag result))
     (do-inits node block name result lowtag inits args)
     (move-continuation-result node block locs cont)))
+
+
+
+;;;; Replacements for stuff in ir2tran to make gengc work.
+
+#+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)))
+	 (locs (if (continuation-info cont)
+		   (continuation-result-tns
+		    cont (list (primitive-type (leaf-type leaf))))
+		   nil)))
+    (etypecase leaf
+      (lambda-var
+       (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)))))
+      (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))))))
+
+    (when locs
+      (emit-move node block val (first locs))
+      (move-continuation-result node block locs cont)))
+  (undefined-value))
+
+
+#+gengc
+(defoptimizer (%lexical-exit-breakup ir2-convert) ((info) node block)
+  (vop value-cell-set node block
+       (find-in-environment (continuation-value info) (node-environment node))
+       (emit-constant 0)
+       nil))
+
+
+#+gengc
+(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)
+	 val
+	 (dsd-index
+	  (slot-accessor-slot
+	   (ref-leaf
+	    (continuation-use
+	     (combination-fun node)))))
+	 (needs-remembering value))
+  
+    (move-continuation-result node block (list val) (node-cont node))))
-- 
GitLab