From: Guillermo J. Rozas <edu/mit/csail/zurich/gjr>
Date: Wed, 1 Jul 1987 20:53:42 +0000 (+0000)
Subject: Done with early assembly.
X-Git-Tag: 20090517-FFI~13307
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=d1a33d000c95c4d95702ee9bc406767a1c1670c8;p=mit-scheme.git

Done with early assembly.
---

diff --git a/v7/src/compiler/back/insseq.scm b/v7/src/compiler/back/insseq.scm
index 3403bdd84..777d8da7e 100644
--- a/v7/src/compiler/back/insseq.scm
+++ b/v7/src/compiler/back/insseq.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/insseq.scm,v 1.1 1987/06/25 10:48:10 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/insseq.scm,v 1.2 1987/07/01 20:48:04 jinx Exp $
 
 Copyright (c) 1987 Massachusetts Institute of Technology
 
@@ -36,32 +36,53 @@ MIT in each case. |#
 
 (declare (usual-integrations))
 
-(define-integrable empty-lap-instructions '())
+(define lap:syntax-instruction)
 
-(define (lap-instructions->directives insts)
-  (car insts))
+(define (instruction-sequence->directives insts)
+  (if (null? insts)
+      '()
+      (car insts)))
 
-(define (->instruction-sequence bits)
-  (if (null? bits)
-      empty-lap-instructions
-      (cons bits (last-pair bits))))
+;; instruction->instruction-sequence is expanded.
 
-(define (->lap-instructions pattern)
-  (->instruction-sequence ((access syntax-instruction lap-syntax-package)
-			   pattern)))
+(declare (integrate empty-instruction-sequence)
+	 (integrate-operator directive->instruction-sequence))
 
-(define (append-lap-instructions! directives directives*)
-  (cond ((null? directives) directives*)
-	((null? directives*) directives)
+(define empty-instruction-sequence '())
+
+(define (directive->instruction-sequence directive)
+  (declare (integrate directive))
+  (let ((pair (cons directive '())))
+    (cons pair pair)))
+
+(define (instruction->instruction-sequence inst)
+  (cons inst (last-pair inst)))
+
+(define (copy-instruction-sequence seq)
+  (define (with-last-pair l receiver)
+    (if (null? (cdr l))
+	(receiver l l)
+	(with-last-pair (cdr l)
+			(lambda (rest last)
+			  (receiver (cons (car l) rest)
+				    last)))))
+
+  (if (null? seq)
+      '()
+      (with-last-pair (car seq) cons)))
+
+(define (append-instruction-sequences! seq1 seq2)
+  (cond ((null? seq1) seq2)
+	((null? seq2) seq1)
 	(else
-	 (if (and (bit-string? (cadr directives))
-		  (bit-string? (caar directives*)))
-	     (let ((result (bit-string-append (caar directives*)
-					      (cadr directives))))
-	       (set-car! (cdr directives) result)
-	       (if (not (eq? (car directives*) (cdr directives*)))
-		   (begin (set-cdr! (cdr directives) (cdr (car directives*)))
-			  (set-cdr! directives (cdr directives*)))))
-	     (begin (set-cdr! (cdr directives) (car directives*))
-		    (set-cdr! directives (cdr directives*))))
-	 directives)))
\ No newline at end of file
+	 (if (and (bit-string? (cadr seq1))
+		  (bit-string? (caar seq2)))
+	     (let ((result (bit-string-append (caar seq2)
+					      (cadr seq1))))
+	       (set-car! (cdr seq1) result)
+	       (if (not (eq? (car seq2) (cdr seq2)))
+		   (begin (set-cdr! (cdr seq1) (cdr (car seq2)))
+			  (set-cdr! seq1 (cdr seq2)))))
+	     (begin (set-cdr! (cdr seq1) (car seq2))
+		    (set-cdr! seq1 (cdr seq2))))
+	 seq1)))
\ No newline at end of file
diff --git a/v7/src/compiler/back/syerly.scm b/v7/src/compiler/back/syerly.scm
index 8eabc8c44..c01ed2cfc 100644
--- a/v7/src/compiler/back/syerly.scm
+++ b/v7/src/compiler/back/syerly.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/syerly.scm,v 1.1 1987/06/25 10:56:09 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/syerly.scm,v 1.2 1987/07/01 20:47:29 jinx Exp $
 
 Copyright (c) 1987 Massachusetts Institute of Technology
 
@@ -36,42 +36,45 @@ MIT in each case. |#
 
 (declare (usual-integrations))
 
-(define ->lap-instructions-expander
+;;;; Early instruction assembly
+
+(define lap:syntax-instruction-expander
   ((access scode->scode-expander package/expansion package/scode-optimizer)
    (lambda (operands if-expanded if-not-expanded)
-     (define (wrap expression)
-       (if-expanded
-	(scode/make-combination
-	 (scode/make-variable '->INSTRUCTION-SEQUENCE)
-	 (list expression))))
-
-     (define (kernel instruction rules)
+     (define (kernel opcode instruction rules)
        (early-pattern-lookup
 	rules
 	instruction
+	early-transformers
+	(scode/make-constant opcode)
 	(lambda (mode result)
 	  (cond ((false? mode)
-		 (error "->lap-instruction-expander: unknown instruction"
+		 (error "lap:syntax-instruction-expander: unknown instruction"
 			instruction))
 		((eq? mode 'TOO-MANY)
 		 (if-not-expanded))
-		(else (wrap result))))
+		(else (if-expanded result))))
 	1))
 
      (let ((instruction (scode/unquasiquote (car operands))))
        (cond ((not (pair? instruction))
-	      (error "->lap-instruction-expander: bad instruction" instruction))
-	     ((eq? (car instruction) 'EVALUATE)
+	      (error "lap:syntax-instruction-expander: bad instruction" instruction))
+	     ((eq? (car instruction) 'UNQUOTE)
 	      (if-not-expanded))
 	     ((memq (car instruction)
 		    '(EQUATE SCHEME-OBJECT ENTRY-POINT LABEL))
-	      (wrap (scode/make-absolute-combination 'LIST operands)))
+	      (if-expanded
+	       (scode/make-combination
+		(scode/make-variable  'DIRECTIVE->INSTRUCTION-SEQUENCE)
+		operands)))
 	     (else
 	      (let ((place (assq (car instruction) early-instructions)))
 		(if (null? place)
-		    (error "->lap-instruction-expander: unknown opcode"
+		    (error "lap:syntax-instruction-expander: unknown opcode"
 			   (car instruction))
-		    (kernel (cdr instruction) (cdr place))))))))))
+		    (kernel (car instruction) (cdr instruction) (cdr place))))))))))
+
+;;;; Quasiquote unsyntaxing
 
 (define (scode/unquasiquote exp)
   (cond ((scode/combination? exp)
@@ -91,16 +94,147 @@ MIT in each case. |#
 		 (mapcan (lambda (component)
 			   (if (scode/constant? component)
 			       (scode/constant-value component)
-			       (list (list 'EVALUATE-SPLICE component))))
+			       (list (list 'UNQUOTE-SPLICING component))))
 			 operands))
-		(else (list 'EVALUATE exp))))
+		(else (list 'UNQUOTE exp))))
 	    (cond ((eq? operator cons)
 		   ;; integrations
 		   (kernel 'CONS))
 		  ((scode/absolute-reference? operator)
 		   (kernel (scode/absolute-reference-name operator)))
-		  (else (list 'EVALUATE exp))))))
+		  (else (list 'UNQUOTE exp))))))
 	((scode/constant? exp)
 	 (scode/constant-value exp))
-	(else (list 'EVALUATE exp))))
-      
+	(else (list 'UNQUOTE exp))))
+
+;;;; Bit compression expanders
+
+;;; SYNTAX-EVALUATION and OPTIMIZE-GROUP expanders
+
+(define syntax-evaluation-expander
+  ((access scode->scode-expander package/expansion package/scode-optimizer)
+   (lambda (operands if-expanded if-not-expanded)
+     (if (and (scode/constant? (car operands))
+	      (scode/variable? (cadr operands))
+	      (not (lexical-unreferenceable?
+		    (access lap-syntax-package compiler-package)
+		    (scode/variable-name (cadr operands)))))
+	 (if-expanded
+	  (scode/make-constant
+	   ((lexical-reference (access lap-syntax-package compiler-package)
+			       (scode/variable-name (cadr operands)))
+	    (scode/constant-value (car operands)))))
+	 (if-not-expanded)))))
+
+;; This relies on the fact that scode/constant-value = identity-procedure.
+
+(define optimize-group-expander
+  ((access scode->scode-expander package/expansion package/scode-optimizer)
+   (lambda (operands if-expanded if-not-expanded)
+     (optimize-group-internal
+      operands
+      (lambda (result make-group?)
+	(if make-group?
+	    (if-expanded
+	     (scode/make-combination (scode/make-variable 'OPTIMIZE-GROUP)
+				     result))
+	    (if-expanded
+	     (scode/make-constant result))))))))
+
+;;;; CONS-SYNTAX expander
+
+(define (is-operator? expr name primitive)
+  (or (and primitive
+	   (scode/constant? expr)
+	   (eq? (scode/constant-value expr) primitive))
+      (and (scode/variable? expr)
+	   (eq? (scode/variable-name expr) name))
+      (and (scode/absolute-reference? expr)
+	   (eq? (scode/absolute-reference-name expr) name))))
+
+(define cons-syntax-expander
+  ((access scode->scode-expander package/expansion package/scode-optimizer)
+   (lambda (operands if-expanded if-not-expanded)
+     (define (default)
+       (cond ((not (scode/constant? (cadr operands)))
+	      (if-not-expanded))
+	     ((not (null? (scode/constant-value (cadr operands))))
+	      (error "cons-syntax-expander: bad tail" (cadr operands)))
+	     (else
+	      (if-expanded
+	       (scode/make-absolute-combination 'CONS
+						operands)))))
+
+     (if (and (scode/constant? (car operands))
+	      (bit-string? (scode/constant-value (car operands)))
+	      (scode/combination? (cadr operands)))
+	 (scode/combination-components
+	  (cadr operands)
+	  (lambda (operator inner-operands)
+	    (if (and (or (is-operator? operator 'CONS-SYNTAX false)
+			 (is-operator? operator 'CONS cons))
+		     (scode/constant? (car inner-operands))
+		     (bit-string? (scode/constant-value (car inner-operands))))
+		(if-expanded
+		 (scode/make-combination
+		  (if (scode/constant? (cadr inner-operands))
+		      (scode/make-absolute-reference 'CONS)
+		      operator)
+		  (cons (bit-string-append
+			 (scode/constant-value (car inner-operands))
+			 (scode/constant-value (car operands)))
+			(cdr inner-operands))))
+		(default))))
+	 (default)))))
+
+;;;; INSTRUCTION->INSTRUCTION-SEQUENCE expander
+
+(define instruction->instruction-sequence-expander
+  (let ()
+    (define (parse expression receiver)
+      (if (not (scode/combination? expression))
+	  (receiver false false false)
+	  (scode/combination-components
+	   expression
+	   (lambda (operator operands)
+	     (cond ((and (not (is-operator? operator 'CONS cons))
+			 (not (is-operator? operator 'CONS-SYNTAX false)))
+		    (receiver false false false))
+		   ((scode/constant? (cadr operands))
+		    (if (not (null? (scode/constant-value (cadr operands))))
+			(error "inst->inst-seq-expander: bad CONS-SYNTAX tail"
+			       (scode/constant-value (cadr operands)))
+			(let ((name
+			       (generate-uninterned-symbol
+				'INSTRUCTION-TAIL-)))
+			  (receiver true
+				    (cons name expression)
+				    (scode/make-variable name)))))
+		   (else
+		    (parse (cadr operands)
+			   (lambda (mode info rest)
+			     (if (not mode)
+				 (receiver false false false)
+				 (receiver true info
+					   (scode/make-combination
+					    operator
+					    (list (car operands)
+						  rest))))))))))))
+    
+    ((access scode->scode-expander package/expansion package/scode-optimizer)
+     (lambda (operands if-expanded if-not-expanded)
+       (if (not (scode/combination? (car operands)))
+	   (if-not-expanded)
+	   (parse (car operands)
+		  (lambda (mode binding rest)
+		    (if (not mode)
+			(if-not-expanded)
+			(if-expanded
+			 (scode/make-let
+			  (list (car binding))
+			  (list (cdr binding))
+			  (scode/make-absolute-combination
+			   'CONS
+			   (list rest
+				 (scode/make-variable
+				  (car binding))))))))))))))
diff --git a/v7/src/compiler/base/pmerly.scm b/v7/src/compiler/base/pmerly.scm
index 26e517e9f..ac66eae39 100644
--- a/v7/src/compiler/base/pmerly.scm
+++ b/v7/src/compiler/base/pmerly.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/pmerly.scm,v 1.1 1987/06/25 10:51:09 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/pmerly.scm,v 1.2 1987/07/01 20:51:29 jinx Exp $
 
 Copyright (c) 1987 Massachusetts Institute of Technology
 
@@ -40,7 +40,7 @@ MIT in each case. |#
 
 (define early-parse-rule)
 (define early-pattern-lookup)
-(define define-transformer)
+(define early-make-rule)
 (define make-database-transformer)
 (define make-symbol-transformer)
 (define make-bit-mask-transformer)
@@ -49,16 +49,17 @@ MIT in each case. |#
 
 ;;;; Database construction
 
-(define-export (early-parse-rule pattern expression)
-  (extract-variables pattern
-		     (lambda (pattern variables)
-		       `(,pattern ,variables ,expression))))
+(define-export (early-make-rule pattern variables body)
+  (list pattern variables body))
+
+(define-export (early-parse-rule pattern receiver)
+  (extract-variables pattern receiver))
 
 (define (extract-variables pattern receiver)
   (cond ((not (pair? pattern))
 	 (receiver pattern '()))
 	((eq? (car pattern) '@)
-	 (error "unify-parse-rule: ?@ is not an implemented pattern"
+	 (error "early-parse-rule: ?@ is not an implemented pattern"
 		pattern))
 	((eq? (car pattern) '?)
 	 (receiver (make-pattern-variable (cadr pattern))
@@ -87,7 +88,7 @@ MIT in each case. |#
 		     (merge-variables-lists (cdr x)
 					    (delq! entry y)))
 	       |#
-	       (error "unify-parse-rule: repeated variables not supported"
+	       (error "early-parse-rule: repeated variables not supported"
 		      (list (caar x) entry))
 	       (cons (car x)
 		     (merge-variables-lists (cdr x)
@@ -95,61 +96,63 @@ MIT in each case. |#
 
 ;;;; Early rule processing and code compilation
 
-(define *rule-limit* '())
-
-(define-export (early-pattern-lookup rules unparsed #!optional receiver limit)
+(define-export (early-pattern-lookup
+		rules instance #!optional transformers unparsed receiver limit)
   (if (unassigned? limit) (set! limit *rule-limit*))
-  (if (unassigned? receiver)
+  (if (or (unassigned? receiver) (null? receiver))
       (set! receiver
 	    (lambda (result code)
 	      (cond ((false? result)
 		     (error "early-pattern-lookup: No pattern matches"
-			    unparsed))
+			    instance))
 		    ((eq? result 'TOO-MANY)
 		     (error "early-pattern-lookup: Too many patterns match"
-			    limit))
+			    limit instance))
 		    (else code)))))
-
-  (parse-instance unparsed
+  (parse-instance instance
    (lambda (expression bindings)
-     (apply
-      (lambda (result program)
-	(receiver result
-		  (if (or (eq? result true) (eq? result 'MAYBE))
-		      (scode/make-block bindings '() program)
-		      false)))
-      (fluid-let ((*rule-limit* limit))
-	(try-rules rules
-		   expression
-		   (scode/make-error-combination
-		    "early-pattern-lookup: No pattern matches"
-		    (scode/make-constant unparsed))
-		   list))))))
+     (apply (lambda (result program)
+	      (receiver result
+			(if (or (eq? result true) (eq? result 'MAYBE))
+			    (scode/make-block bindings '() program)
+			    false)))
+	    (fluid-let ((*rule-limit* limit)
+			(*transformers* (if (unassigned? transformers)
+					    '()
+					    transformers)))
+	      (try-rules rules expression
+			 (scode/make-error-combination
+			  "early-pattern-lookup: No pattern matches"
+			  (if (or (unassigned? unparsed) (null? unparsed))
+			      (scode/make-constant instance)
+			      unparsed))
+			 list))))))
 
 (define (parse-instance instance receiver)
   (cond ((not (pair? instance))
 	 (receiver instance '()))
-	((eq? (car instance) 'EVALUATE)
+	((eq? (car instance) 'UNQUOTE)
 	 ;; Shadowing may not permit the optimization below.
-	 ;; I think the code is being careful about uses of
-	 ;; the expressions, but...
+	 ;; I think the code is being careful, but...
 	 (let ((expression (cadr instance)))
 	   (if (scode/variable? expression)
-	       (receiver (make-evaluation expression)
-			 '())
+	       (receiver (make-evaluation expression) '())
 	       (let ((var (make-variable-name 'RESULT)))
 		 (receiver (make-evaluation (scode/make-variable var))
 			   (list (scode/make-binding var expression)))))))
-	(else
-	 (parse-instance (car instance)
-	  (lambda (instance-car car-bindings)
-	    (parse-instance (cdr instance)
-			    (lambda (instance-cdr cdr-bindings)
-			      (receiver (cons instance-car instance-cdr)
-					(append car-bindings cdr-bindings)))))))))
+	((eq? (car instance) 'UNQUOTE-SPLICING)
+	 (error "parse-instance: unquote-splicing not supported" instance))
+	(else (parse-instance (car instance)
+	       (lambda (instance-car car-bindings)
+		 (parse-instance (cdr instance)
+		  (lambda (instance-cdr cdr-bindings)
+		    (receiver (cons instance-car instance-cdr)
+			      (append car-bindings cdr-bindings)))))))))
 
 ;;;; Find matching rules and collect them
 
+(define *rule-limit* '())
+
 (define (try-rules rules expression null-form receiver)
   (define (loop rules null-form bindings nrules)
     (cond ((and (not (null? *rule-limit*))
@@ -463,7 +466,7 @@ MIT in each case. |#
 	(apply-transformer trans-exp name rename exp receiver))))
 
 (define (apply-transformer transformer name rename exp receiver)
-  (receiver name
+  (receiver (scode/make-variable name)
 	    (transformer-bindings name rename (unevaluate exp)
 	     (lambda (exp)
 	       (scode/make-combination (scode/make-variable transformer)
@@ -475,12 +478,7 @@ MIT in each case. |#
       (list (make-outer-binding rename expression)
 	    (make-late-binding name (mapper (scode/make-variable rename))))))
 
-(define *transformers* '())
-
-(define-export (define-transformer name transformer)
-  (set! *transformers*
-	`((,name . ,transformer) ,@*transformers*))
-  name)
+(define *transformers*)
 
 (define (find-transformer expression)
   (and (symbol? expression)
@@ -496,21 +494,22 @@ MIT in each case. |#
 	   (scode/make-constant (generate-uninterned-symbol 'NOT-FOUND-))))
       (try-rules database exp null-form
        (lambda (result code)
-	 (define (possible test)
+	 (define (possible test make-binding)
 	   (receiver test
-		     (cons (make-outer-binding rename code)
+		     (cons (make-binding rename code)
 			   (if (eq? name rename)
 			       '()
-			       (list (make-outer-binding name
-							 (unevaluate exp)))))))
+			       (list (make-binding name
+						   (unevaluate exp)))))))
 
 	 (cond ((false? result)
 		(transformer-fail receiver))
 	       ((eq? result 'TOO-MANY)
 		(apply-transformer texp name rename exp receiver))
 	       ((eq? result 'MAYBE)
-		(possible (make-simple-transformer-test name null-form)))
-	       (else (possible true))))))))
+		(possible (make-simple-transformer-test name null-form)
+			  make-outer-binding))
+	       (else (possible true make-early-binding))))))))
 
 (define-integrable (make-simple-transformer-test name tag)
   (scode/make-absolute-combination 'NOT
diff --git a/v7/src/compiler/machines/bobcat/insutl.scm b/v7/src/compiler/machines/bobcat/insutl.scm
index 751d51109..e48cd48ea 100644
--- a/v7/src/compiler/machines/bobcat/insutl.scm
+++ b/v7/src/compiler/machines/bobcat/insutl.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/insutl.scm,v 1.1 1987/06/25 10:35:23 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/insutl.scm,v 1.2 1987/07/01 20:53:42 jinx Exp $
 
 Copyright (c) 1987 Massachusetts Institute of Technology
 
@@ -38,6 +38,11 @@ MIT in each case. |#
 
 ;;;; Effective Addressing
 
+;;; *** NOTE: If this format changes, inerly.scm must also be changed! ***
+
+(define ea-tag
+  "Effective-Address")
+
 (define (make-effective-address keyword mode register extension categories)
   (vector ea-tag keyword mode register extension categories))
 
@@ -46,9 +51,6 @@ MIT in each case. |#
        (not (zero? (vector-length object)))
        (eq? (vector-ref object 0) ea-tag)))
 
-(define ea-tag
-  "Effective-Address")
-
 (define-integrable (ea-keyword ea)
   (vector-ref ea 1))
 
@@ -63,6 +65,30 @@ MIT in each case. |#
 
 (define-integrable (ea-categories ea)
   (vector-ref ea 5))
+
+(define-integrable (with-ea ea receiver)
+  (receiver (ea-keyword ea)
+	    (ea-mode ea)
+	    (ea-register ea)
+	    (ea-extension ea)
+	    (ea-categories ea)))
+
+;; For completeness
+
+(define (ea-keyword-early ea)
+  (vector-ref ea 1))
+
+(define (ea-mode-early ea)
+  (vector-ref ea 2))
+
+(define (ea-register-early ea)
+  (vector-ref ea 3))
+
+(define (ea-extension-early ea)
+  (vector-ref ea 4))
+
+(define (ea-categories-early ea)
+  (vector-ref ea 5))
 
 ;;;; Effective Address Extensions