From: Chris Hanson <org/chris-hanson/cph>
Date: Thu, 31 Dec 1987 10:01:50 +0000 (+0000)
Subject: Change particular constructors from procedures to macros so we can
X-Git-Tag: 20090517-FFI~12961
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=7bf4f57b50b9a9e71e6a399d373d1f19d30b4b41;p=mit-scheme.git

Change particular constructors from procedures to macros so we can
inline code them as calls to `vector', rather than as lexpr primitives
which call `list->vector'.
---

diff --git a/v7/src/compiler/base/cfg1.scm b/v7/src/compiler/base/cfg1.scm
index 5eb0ff5f1..5e2860989 100644
--- a/v7/src/compiler/base/cfg1.scm
+++ b/v7/src/compiler/base/cfg1.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/cfg1.scm,v 4.2 1987/12/30 06:57:50 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/cfg1.scm,v 4.3 1987/12/31 10:01:31 cph Rel $
 
 Copyright (c) 1987 Massachusetts Institute of Technology
 
@@ -51,8 +51,9 @@ MIT in each case. |#
 (define snode? (tagged-vector/subclass-predicate snode-tag))
 (define-vector-slots snode 4 next-edge)
 
-(define (make-snode tag . extra)
-  (list->vector (cons* tag false '() '() false extra)))
+;;; converted to a macro.
+;;; (define (make-snode tag . extra)
+;;;   (list->vector (cons* tag false '() '() false extra)))
 
 (set-vector-tag-description!
  snode-tag
@@ -64,8 +65,9 @@ MIT in each case. |#
 (define pnode? (tagged-vector/subclass-predicate pnode-tag))
 (define-vector-slots pnode 4 consequent-edge alternative-edge)
 
-(define (make-pnode tag . extra)
-  (list->vector (cons* tag false '() '() false false extra)))
+;;; converted to a macro.
+;;; (define (make-pnode tag . extra)
+;;;   (list->vector (cons* tag false '() '() false false extra)))
 
 (set-vector-tag-description!
  pnode-tag
@@ -78,6 +80,10 @@ MIT in each case. |#
 
 (define (delete-node-previous-edge! node edge)
   (set-node-previous-edges! node (delq! edge (node-previous-edges node))))
+
+;;;; Edge Datatype
+
+(define-structure (edge (type vector)) left-node left-connect right-node)
 
 (define (edge-next-node edge)
   (and edge (edge-right-node edge)))
@@ -90,10 +96,6 @@ MIT in each case. |#
 
 (define-integrable (pnode-alternative pnode)
   (edge-next-node (pnode-alternative-edge pnode)))
-
-;;;; Edge Datatype
-
-(define-structure (edge (type vector)) left-node left-connect right-node)
 
 (define (create-edge! left-node left-connect right-node)
   (let ((edge (make-edge left-node left-connect right-node)))
@@ -119,7 +121,7 @@ MIT in each case. |#
       (begin
 	(set-edge-right-node! edge right-node)
 	(add-node-previous-edge! right-node edge))))
-
+
 (define (edge-disconnect-left! edge)
   (let ((left-node (edge-left-node edge))
 	(left-connect (edge-left-connect edge)))
diff --git a/v7/src/compiler/base/lvalue.scm b/v7/src/compiler/base/lvalue.scm
index fb98060d0..031029d68 100644
--- a/v7/src/compiler/base/lvalue.scm
+++ b/v7/src/compiler/base/lvalue.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/lvalue.scm,v 4.2 1987/12/30 06:58:51 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/lvalue.scm,v 4.3 1987/12/31 10:01:42 cph Exp $
 
 Copyright (c) 1987 Massachusetts Institute of Technology
 
@@ -53,13 +53,14 @@ MIT in each case. |#
 
 (define *lvalues*)
 
-(define (make-lvalue tag . extra)
-  (let ((lvalue
-	 (list->vector
-	  (cons* tag '() '() '() 'NOT-CACHED false '() false false '()
-		 extra))))
-    (set! *lvalues* (cons lvalue *lvalues*))
-    lvalue))
+;;; converted to a macro.
+;;; (define (make-lvalue tag . extra)
+;;;   (let ((lvalue
+;;; 	 (list->vector
+;;; 	  (cons* tag '() '() '() 'NOT-CACHED false '() false false '()
+;;; 		 extra))))
+;;;     (set! *lvalues* (cons lvalue *lvalues*))
+;;;     lvalue))
 
 (define (add-lvalue-application! lvalue application)
   (set-lvalue-applications! lvalue
diff --git a/v7/src/compiler/base/macros.scm b/v7/src/compiler/base/macros.scm
index 18efab17d..b5b011685 100644
--- a/v7/src/compiler/base/macros.scm
+++ b/v7/src/compiler/base/macros.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/macros.scm,v 4.2 1987/12/30 06:58:58 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/macros.scm,v 4.3 1987/12/31 10:00:54 cph Exp $
 
 Copyright (c) 1987 Massachusetts Institute of Technology
 
@@ -175,6 +175,17 @@ MIT in each case. |#
 	       ,tag-name
 	       (LAMBDA (,type)
 		 (DESCRIPTOR-LIST ,type ,@slots)))))))
+
+(syntax-table-define compiler-syntax-table 'DESCRIPTOR-LIST
+  (macro (type . slots)
+    (let ((ref-name (lambda (slot) (symbol-append type '- slot))))
+      `(LIST ,@(map (lambda (slot)
+		      (if (pair? slot)
+			  (let ((ref-names (map ref-name slot)))
+			    ``(,',ref-names ,(,(car ref-names) ,type)))
+			  (let ((ref-name (ref-name slot)))
+			    ``(,',ref-name ,(,ref-name ,type)))))
+		    slots)))))
 
 (let-syntax
  ((define-type-definition
@@ -200,16 +211,32 @@ MIT in each case. |#
  (define-type-definition rvalue 2 rvalue-types)
  (define-type-definition lvalue 10 false))
 
-(syntax-table-define compiler-syntax-table 'DESCRIPTOR-LIST
-  (macro (type . slots)
-    (let ((ref-name (lambda (slot) (symbol-append type '- slot))))
-      `(LIST ,@(map (lambda (slot)
-		      (if (pair? slot)
-			  (let ((ref-names (map ref-name slot)))
-			    ``(,',ref-names ,(,(car ref-names) ,type)))
-			  (let ((ref-name (ref-name slot)))
-			    ``(,',ref-name ,(,ref-name ,type)))))
-		    slots)))))
+;;; Kludge to make these compile efficiently.
+
+(syntax-table-define compiler-syntax-table 'MAKE-SNODE
+  (macro (tag . extra)
+    `((ACCESS VECTOR SYSTEM-GLOBAL-ENVIRONMENT)
+      ,tag FALSE '() '() FALSE ,@extra)))
+
+(syntax-table-define compiler-syntax-table 'MAKE-PNODE
+  (macro (tag . extra)
+    `((ACCESS VECTOR SYSTEM-GLOBAL-ENVIRONMENT)
+      ,tag FALSE '() '() FALSE FALSE ,@extra)))
+
+(syntax-table-define compiler-syntax-table 'MAKE-RVALUE
+  (macro (tag . extra)
+    `((ACCESS VECTOR SYSTEM-GLOBAL-ENVIRONMENT)
+      ,tag FALSE ,@extra)))
+
+(syntax-table-define compiler-syntax-table 'MAKE-LVALUE
+  (macro (tag . extra)
+    (let ((result (generate-uninterned-symbol)))
+      `(let ((,result
+	      ((ACCESS VECTOR SYSTEM-GLOBAL-ENVIRONMENT)
+	       ,tag '() '() '() 'NOT-CACHED FALSE '() FALSE FALSE '()
+	       ,@extra)))
+	 (SET! *LVALUES* (CONS ,result *LVALUES*))
+	 ,result))))
 
 (let ((rtl-common
        (lambda (type prefix components wrap-constructor)
diff --git a/v7/src/compiler/base/rvalue.scm b/v7/src/compiler/base/rvalue.scm
index 90dd26009..16a51010e 100644
--- a/v7/src/compiler/base/rvalue.scm
+++ b/v7/src/compiler/base/rvalue.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/rvalue.scm,v 4.1 1987/12/04 20:04:48 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/rvalue.scm,v 4.2 1987/12/31 10:01:50 cph Exp $
 
 Copyright (c) 1987 Massachusetts Institute of Technology
 
@@ -39,8 +39,9 @@ MIT in each case. |#
 (define-root-type rvalue
   %passed-out?)
 
-(define (make-rvalue tag . extra)
-  (list->vector (cons* tag false extra)))
+;;; converted to a macro.
+;;; (define (make-rvalue tag . extra)
+;;;   (list->vector (cons* tag false extra)))
 
 (define-enumeration rvalue-type
   (block