From: Guillermo J. Rozas <edu/mit/csail/zurich/gjr>
Date: Wed, 8 Jul 1987 21:54:59 +0000 (+0000)
Subject: The RTL is now translated directly to bits, rather than LAP.
X-Git-Tag: 20090517-FFI~13270
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=6734814c8e8cc227497048376f9311bd4afcc060;p=mit-scheme.git

The RTL is now translated directly to bits, rather than LAP.
---

diff --git a/v7/src/compiler/base/macros.scm b/v7/src/compiler/base/macros.scm
index ae93d702d..50aee55e1 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 1.58 1987/05/21 14:55:09 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/macros.scm,v 1.59 1987/07/08 21:52:32 jinx Exp $
 
 Copyright (c) 1987 Massachusetts Institute of Technology
 
@@ -45,6 +45,9 @@ MIT in each case. |#
 (define assembler-syntax-table
   (make-syntax-table compiler-syntax-table))
 
+(define early-syntax-table
+  (make-syntax-table compiler-syntax-table))
+
 (syntax-table-define compiler-syntax-table 'PACKAGE
   (in-package system-global-environment
     (declare (usual-integrations))
@@ -73,6 +76,9 @@ MIT in each case. |#
 (define enable-integration-declarations
   true)
 
+(define enable-expansion-declarations
+  true)
+
 (let ()
 
 (define (parse-define-syntax pattern body if-variable if-lambda)
@@ -243,11 +249,46 @@ MIT in each case. |#
 (syntax-table-define lap-generator-syntax-table 'DEFINE-RULE
   (macro (type pattern . body)
     (parse-rule pattern body
-      (lambda (pattern names transformer qualifier actions)
+      (lambda (pattern variables qualifier actions)
 	`(,(case type
 	     ((STATEMENT) 'ADD-STATEMENT-RULE!)
 	     ((PREDICATE) 'ADD-STATEMENT-RULE!)
 	     (else (error "Unknown rule type" type)))
 	  ',pattern
-	  ,(rule-result-expression names transformer qualifier
-				   `(BEGIN ,@actions)))))))
\ No newline at end of file
+	  ,(rule-result-expression variables qualifier
+				   `(BEGIN ,@actions)))))))
+
+;;;; Lap instruction sequences.
+
+;; The effect of unquote and unquote-splicing is the same since
+;; syntax-instruction actually returns a bit-level instruction sequence.
+;; Kept separate for clarity and because it does not have to be like that.
+
+(syntax-table-define compiler-syntax-table 'LAP
+  (macro some-instructions
+    (define (handle current remaining)
+      (let ((processed
+	     (cond ((eq? (car current) 'UNQUOTE)
+		    (cadr current))
+		   ((eq? (car current) 'UNQUOTE-SPLICING)
+		    (cadr current))
+		   (else `(INST ,current)))))
+	(if (null? remaining)
+	    processed
+	    `(APPEND-INSTRUCTION-SEQUENCES!
+	      ,processed
+	      ,(handle (car remaining) (cdr remaining))))))
+    (if (null? some-instructions)
+	`EMPTY-INSTRUCTION-SEQUENCE
+	(handle (car some-instructions) (cdr some-instructions)))))
+
+(syntax-table-define compiler-syntax-table 'INST
+  (macro (the-instruction)
+    `(LAP:SYNTAX-INSTRUCTION
+      ,(list 'QUASIQUOTE the-instruction))))
+
+;; This is a NOP for now.
+
+(syntax-table-define compiler-syntax-table 'INST-EA
+  (macro (ea)
+    (list 'QUASIQUOTE ea)))
\ No newline at end of file
diff --git a/v7/src/compiler/base/pmlook.scm b/v7/src/compiler/base/pmlook.scm
index 73381e9c7..770e3e001 100644
--- a/v7/src/compiler/base/pmlook.scm
+++ b/v7/src/compiler/base/pmlook.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/pmlook.scm,v 1.4 1987/05/07 00:09:08 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/pmlook.scm,v 1.5 1987/07/08 21:53:09 jinx Exp $
 
 Copyright (c) 1987 Massachusetts Institute of Technology
 
@@ -39,6 +39,9 @@ MIT in each case. |#
 (define pattern-lookup)
 (define pattern-variables)
 (define make-pattern-variable)
+(define pattern-variable?)
+(define pattern-variable-name)
+
 (let ((pattern-variable-tag (make-named-tag "Pattern Variable")))
 
 ;;; PATTERN-LOOKUP returns either false or a pair whose car is the
@@ -87,6 +90,14 @@ MIT in each case. |#
   (named-lambda (make-pattern-variable name)
     (cons pattern-variable-tag name)))
 
+(set! pattern-variable?
+      (named-lambda (pattern-variable? obj)
+	(and (pair? obj) (eq? (car obj) pattern-variable-tag))))
+
+(set! pattern-variable-name
+      (named-lambda (pattern-variable-name var)
+	(cdr var)))
+
 )
 
 ;;; ALL-TRUE? is used to determine if splicing variables with
diff --git a/v7/src/compiler/base/pmpars.scm b/v7/src/compiler/base/pmpars.scm
index ec02fd8f0..134a1697a 100644
--- a/v7/src/compiler/base/pmpars.scm
+++ b/v7/src/compiler/base/pmpars.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/pmpars.scm,v 1.1.1.1 1987/06/10 21:22:36 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/pmpars.scm,v 1.2 1987/07/08 21:53:25 jinx Exp $
 
 Copyright (c) 1987 Massachusetts Institute of Technology
 
@@ -163,5 +163,4 @@ MIT in each case. |#
 			 (caddr var)))))))))))
 
 ;; End of PARSE-RULE environment.
-)
 )
\ No newline at end of file
diff --git a/v7/src/compiler/base/utils.scm b/v7/src/compiler/base/utils.scm
index 58593258e..ac8eab695 100644
--- a/v7/src/compiler/base/utils.scm
+++ b/v7/src/compiler/base/utils.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/utils.scm,v 1.89 1987/06/24 04:51:11 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/utils.scm,v 1.90 1987/07/08 21:54:59 jinx Exp $
 
 Copyright (c) 1987 Massachusetts Institute of Technology
 
@@ -71,7 +71,7 @@ MIT in each case. |#
 	    'FLUID-LET)
 	   (else prefix)))
     "-"
-    (write-to-string (generate-label-number)))))
+    (number->string (generate-label-number)))))
 
 (define *current-label-number*)
 
@@ -189,11 +189,15 @@ MIT in each case. |#
   (define-scode-operator make-combination)
   (define-scode-operator make-comment)
   (define-scode-operator make-conditional)
+  (define-scode-operator make-declaration)
   (define-scode-operator make-definition)
+  (define-scode-operator make-disjunction)
   (define-scode-operator make-lambda)
   (define-scode-operator make-quotation)
   (define-scode-operator make-sequence)
+  (define-scode-operator make-the-environment)
   (define-scode-operator make-variable)
+  (define-scode-operator make-unassigned-object)
   (define-scode-operator open-block-components)
   (define-scode-operator open-block?)
   (define-scode-operator primitive-procedure?)
@@ -205,9 +209,51 @@ MIT in each case. |#
   (define-scode-operator unbound?-name)
   (define-scode-operator variable-name)
   (define-scode-operator variable?))
+
+;;; Scode constants
+
+(define scode/constant?
+  (access scode-constant? system-global-environment))
 
 (define scode/constant?
   (access scode-constant? system-global-environment))
+
+(define-integrable (scode/constant-value const)
+  const)
+
+(define-integrable (scode/make-constant const)
+  const)
+
+;;; Abolute variables and combinations
+
+(define (scode/make-absolute-reference variable-name)
+  (scode/make-access '() variable-name))
+
+(define (scode/absolute-reference? obj)
+  (and (scode/access? obj)
+       (scode/access-components
+	obj
+	(lambda (environment name)
+	  (null? environment)))))
+
+(define (scode/absolute-reference-name obj)
+  (scode/access-components obj (lambda (ignore name) name)))
+
+(define (scode/make-absolute-combination name operands)
+  (scode/make-combination (scode/make-absolute-reference name) operands))
+
+(define (scode/absolute-combination? obj)
+  (and (scode/combination? obj)
+       (scode/combination-components
+	obj
+	(lambda (op ops)
+	  (scode/absolute-reference? obj)))))
+
+(define (scode/absolute-combination-components obj receiver)
+  (scode/combination-components
+   obj
+   (lambda (op ops)
+     (receiver (scode/absolute-reference-name op) ops))))
 
 (define (scode/error-combination-components combination receiver)
   (scode/combination-components combination
@@ -215,18 +261,19 @@ MIT in each case. |#
       (receiver (car operands)
 		(let ((irritant (cadr operands)))
 		  (cond ((scode/access? irritant) '())
-			((scode/combination? irritant)
-			 (scode/combination-components irritant
-			   (lambda (operator operands)
-			     (if (and (scode/access? operator)
-				      (scode/access-components operator
-					(lambda (environment name)
-					  (and (null? environment)
-					       (eq? name 'LIST)))))
+			((scode/absolute-combination? irritant)
+			 (scode/absolute-combination-components irritant
+			   (lambda (name operands)
+			     (if (eq? name 'LIST)
 				 operands
 				 (list irritant)))))
 			(else (list irritant))))))))
 
+(define (scode/make-error-combination message operand)
+  (scode/make-absolute-combination
+   'ERROR-PROCEDURE
+   (list message operand (scode/make-the-environment))))
+
 (define (scode/procedure-type-code *lambda)
   (cond ((primitive-type? type-code:lambda *lambda)
 	 type-code:procedure)
@@ -242,41 +289,23 @@ MIT in each case. |#
 
 ;;;; Type Codes
 
-(define type-code:lambda
-  (microcode-type 'LAMBDA))
-
-(define type-code:extended-lambda
-  (microcode-type 'EXTENDED-LAMBDA))
-
-(define type-code:procedure
-  (microcode-type 'PROCEDURE))
-
-(define type-code:extended-procedure
-  (microcode-type 'EXTENDED-PROCEDURE))
-
-(define type-code:cell
-  (microcode-type 'CELL))
-
-(define type-code:compiled-expression
-  (microcode-type 'COMPILED-EXPRESSION))
-
-(define type-code:compiler-link
-  (microcode-type 'COMPILER-LINK))
-
-(define type-code:compiled-procedure
-  (microcode-type 'COMPILED-PROCEDURE))
-
-(define type-code:environment
-  (microcode-type 'ENVIRONMENT))
-
-(define type-code:stack-environment
-  (microcode-type 'STACK-ENVIRONMENT))
-
-(define type-code:return-address
-  (microcode-type 'COMPILER-RETURN-ADDRESS))
-
-(define type-code:unassigned
-  (microcode-type 'UNASSIGNED))
+(let-syntax ((define-type-code
+	       (macro (var-name type-name)
+		 `(define-integrable ,var-name ',(microcode-type type-name)))))
+
+(define-type-code type-code:lambda LAMBDA)
+(define-type-code type-code:extended-lambda EXTENDED-LAMBDA)
+(define-type-code type-code:procedure PROCEDURE)
+(define-type-code type-code:extended-procedure EXTENDED-PROCEDURE)
+(define-type-code type-code:cell CELL)
+(define-type-code type-code:compiled-expression COMPILED-EXPRESSION)
+(define-type-code type-code:compiler-link COMPILER-LINK)
+(define-type-code type-code:compiled-procedure COMPILED-PROCEDURE)
+(define-type-code type-code:environment ENVIRONMENT)
+(define-type-code type-code:stack-environment STACK-ENVIRONMENT)
+(define-type-code type-code:return-address COMPILER-RETURN-ADDRESS)
+(define-type-code type-code:unassigned UNASSIGNED)
+)
 
 ;;; Disgusting hack to replace microcode implementation.
 
diff --git a/v7/src/compiler/machines/bobcat/decls.scm b/v7/src/compiler/machines/bobcat/decls.scm
index 31fc319d2..7495261db 100644
--- a/v7/src/compiler/machines/bobcat/decls.scm
+++ b/v7/src/compiler/machines/bobcat/decls.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/decls.scm,v 1.15 1987/07/02 20:54:11 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/decls.scm,v 1.16 1987/07/08 21:54:41 jinx Exp $
 
 Copyright (c) 1987 Massachusetts Institute of Technology
 
@@ -55,6 +55,15 @@ MIT in each case. |#
 		   (pathname->absolute-pathname (->pathname dependency)))
 		 dependencies))))))
 
+(define (file-dependency/expansion/join filenames expansions)
+  (for-each (lambda (filename)
+	      (file-dependency/expansion/make filename expansions))
+	    filenames))			 
+
+(define (file-dependency/expansion/make filename expansions)
+  (if enable-expansion-declarations
+      (sf/add-file-declarations! filename `((EXPAND-OPERATOR ,@expansions)))))
+
 (define (filename/append directory . names)
   (map (lambda (name)
 	 (string-append directory "/" name))
@@ -65,6 +74,8 @@ MIT in each case. |#
 	      (sf/set-file-syntax-table! filename dependency))
 	    filenames))
 
+;;;; Integration and expansion dependencies
+
 (define filenames/dependency-chain/base
   (filename/append "base"
 		   "object" "cfg1" "cfg2" "cfg3" "ctypes" "dtype1" "dtype2"
@@ -89,24 +100,98 @@ MIT in each case. |#
   (append filenames/dependency-chain/base
 	  filenames/dependency-chain/rcse)))
 
+(file-dependency/integration/join
+ (filename/append "back-end" "laptop")
+ (filename/append "back-end" "symtab" "block"))
+
 (file-dependency/integration/join filenames/dependency-group/base
 				  filenames/dependency-chain/base)
+
+;;;; Lap level integration and expansion dependencies
 
-(file-dependency/integration/join
- (filename/append "machines/bobcat" "instr2" "instr3")
- (filename/append "machines/bobcat" "instr1"))
+(define filenames/dependency-group/lap
+  (filename/append "machines/bobcat" "instr1" "instr2" "instr3"))
 
-(file-dependency/integration/join
- (filename/append "back-end" "laptop")
- (filename/append "back-end" "symtab" "block"))
+(define filenames/dependency-group/lap-syn1
+  (append (filename/append "back-end" "lapgn1" "lapgn2" "lapgn3" "regmap")
+	  (filename/append "base" "linear")))
+
+(define filenames/dependency-group/lap-syn2
+  (filename/append "machines/bobcat" "lapgen"))
+
+(define filenames/dependency-group/lap-syn3
+  (filename/append "machines/bobcat" "rules1" "rules2" "rules3" "rules4"))
+
+(define filenames/dependency-group/lap-syn4
+  (append filenames/dependency-group/lap-syn2 filenames/dependency-group/lap-syn3))
+
+(file-dependency/integration/join filenames/dependency-group/lap-syn3
+				  filenames/dependency-group/lap-syn2)
+
+(file-dependency/integration/join filenames/dependency-group/lap-syn4
+				  (append
+				   (filename/append "machines/bobcat" "machin")
+				   (filename/append "base" "utils")))
+
+(file-dependency/integration/join (append filenames/dependency-group/lap-syn1
+					  filenames/dependency-group/lap-syn4)
+				  (filename/append "back-end" "insseq"))
+
+(file-dependency/integration/join (append filenames/dependency-group/lap
+					  filenames/dependency-group/lap-syn4)
+				  (filename/append "machines/bobcat" "insutl"))
 
+(file-dependency/expansion/join filenames/dependency-group/lap-syn4
+				'((LAP:SYNTAX-INSTRUCTION
+				   (ACCESS LAP:SYNTAX-INSTRUCTION-EXPANDER
+					   LAP-SYNTAX-PACKAGE
+					   COMPILER-PACKAGE))
+				  (INSTRUCTION->INSTRUCTION-SEQUENCE
+				   (ACCESS INSTRUCTION->INSTRUCTION-SEQUENCE-EXPANDER
+					   LAP-SYNTAX-PACKAGE
+					   COMPILER-PACKAGE))
+				  (SYNTAX-EVALUATION
+				   (ACCESS SYNTAX-EVALUATION-EXPANDER
+					   LAP-SYNTAX-PACKAGE
+					   COMPILER-PACKAGE))
+				  (CONS-SYNTAX
+				   (ACCESS CONS-SYNTAX-EXPANDER
+					   LAP-SYNTAX-PACKAGE
+					   COMPILER-PACKAGE))
+				  (OPTIMIZE-GROUP-EARLY
+				   (ACCESS OPTIMIZE-GROUP-EXPANDER
+					   LAP-SYNTAX-PACKAGE
+					   COMPILER-PACKAGE))
+				  (EA-KEYWORD-EARLY
+				   (ACCESS EA-KEYWORD-EXPANDER
+					   LAP-SYNTAX-PACKAGE
+					   COMPILER-PACKAGE))
+				  (EA-MODE-EARLY
+				   (ACCESS EA-MODE-EXPANDER
+					   LAP-SYNTAX-PACKAGE
+					   COMPILER-PACKAGE))
+				  (EA-REGISTER-EARLY
+				   (ACCESS EA-REGISTER-EXPANDER
+					   LAP-SYNTAX-PACKAGE
+					   COMPILER-PACKAGE))
+				  (EA-EXTENSION-EARLY
+				   (ACCESS EA-EXTENSION-EXPANDER
+					   LAP-SYNTAX-PACKAGE
+					   COMPILER-PACKAGE))
+				  (EA-CATEGORIES-EARLY
+				   (ACCESS EA-CATEGORIES-EXPANDER
+					   LAP-SYNTAX-PACKAGE
+					   COMPILER-PACKAGE))))
+
+;;;; Syntax dependencies
+
 (file-dependency/syntax/join
  (append (filename/append "base"
 			  "bblock" "cfg1" "cfg2" "cfg3" "ctypes" "dfg" "dtype1"
-			  "dtype2" "dtype3" "emodel" "linear" "object" "queue"
-			  "regset" "rtlcfg" "rtlcon" "rtlexp" "rtlreg" "rtlty1"
-			  "rtlty2" "rtypes" "sets" "toplv1" "toplv2" "toplv3"
-			  "utils")
+			  "dtype2" "dtype3" "emodel" "linear" "object" "pmerly"
+			  "queue" "regset" "rtlcfg" "rtlcon" "rtlexp" "rtlreg"
+			  "rtlty1" "rtlty2" "rtypes" "sets" "toplv1" "toplv2"
+			  "toplv3" "utils")
 	 (filename/append "alpha" "declar" "dflow1" "dflow2" "dflow3" "dflow4"
 			  "dflow5" "dflow6" "fggen1" "fggen2")
 	 (filename/append "front-end"
@@ -114,18 +199,17 @@ MIT in each case. |#
 			  "rcsesa" "rdeath" "rdebug" "rgcomb" "rgpcom" "rgpred"
 			  "rgproc" "rgrval" "rgstmt" "rlife" "rtlgen")
 	 (filename/append "back-end"
-			  "asmmac" "block" "lapgn1" "lapgn2" "lapgn3" "laptop"
-			  "regmap" "symtab")
+			  "asmmac" "block" "insseq" "lapgn1" "lapgn2" "lapgn3"
+			  "laptop" "regmap" "symtab" "syntax")
 	 (filename/append "machines/bobcat" "insmac" "machin"))
  compiler-syntax-table)
 
 (file-dependency/syntax/join
- (append (filename/append "machines/bobcat"
-			  "lapgen" "rules1" "rules2" "rules3" "rules4")
-	 (filename/append "machines/spectrum" "lapgen"))
+ (append (filename/append "machines/spectrum" "lapgen")
+	 filenames/dependency-group/lap-syn4)
  lap-generator-syntax-table)
 
 (file-dependency/syntax/join
- (append (filename/append "machines/bobcat" "instr1" "instr2" "instr3")
+ (append (filename/append "machines/bobcat" "insutl" "instr1" "instr2" "instr3")
 	 (filename/append "machines/spectrum" "instrs"))
  assembler-syntax-table)
\ No newline at end of file