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 5eb0ff5f15074b4fe65604b199a2527e80d9b35e..5e28609892304aaeaaca7d546f18e5f416c3bc64 100644 (file)
--- 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))))
+\f
+;;;; 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)))
-\f
-;;;; 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))))
-
+\f
 (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 fb98060d02f744be5ad2c54cf40d27ea1a4ab882..031029d68b0dc867fee58ef2706e8076497101e7 100644 (file)
--- 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 18efab17de95bfe3a1bf215abf09d960edc8a5cc..b5b011685178eae92deb8aa01f011881b8576690 100644 (file)
--- 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)))))
 \f
 (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))))
 \f
 (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 90dd260098e57d97040bfd92f5d95f37d0fb8701..16a51010eed42782784fcc136db2dbda5688e4a6 100644 (file)
--- 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