From 778a3ca4d0896dae04ff8370d96f61e67b2c78bb Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Mon, 18 May 2009 03:27:31 -0700
Subject: [PATCH] Initial git check-in.

---
 .../machines/svm/assembler-compiler.scm       | 1044 +++++++++++++++++
 src/compiler/machines/svm/assembler-rules.scm |  589 ++++++++++
 .../machines/svm/assembler-runtime.scm        |  908 ++++++++++++++
 3 files changed, 2541 insertions(+)
 create mode 100644 src/compiler/machines/svm/assembler-compiler.scm
 create mode 100644 src/compiler/machines/svm/assembler-rules.scm
 create mode 100644 src/compiler/machines/svm/assembler-runtime.scm

diff --git a/src/compiler/machines/svm/assembler-compiler.scm b/src/compiler/machines/svm/assembler-compiler.scm
new file mode 100644
index 000000000..19f15dcd9
--- /dev/null
+++ b/src/compiler/machines/svm/assembler-compiler.scm
@@ -0,0 +1,1044 @@
+#| -*-Scheme-*-
+
+$Id$
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+    1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+    2006, 2007, 2008 Massachusetts Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; SVM assembler: rules compiler
+
+(declare (usual-integrations))
+
+(define (compile-assembler-rules pathname)
+  (let ((dir (directory-pathname pathname)))
+    (receive (coding-types key-abbrevs defns)
+	(classify-records
+	 (parse-inputs (read-file (pathname-default-type pathname "scm"))))
+      (for-each (lambda (procedure)
+		  (procedure coding-types))
+		defns)
+      (check-coding-types coding-types)
+      (expand-implicit-coding-types coding-types)
+      (let ((explicit
+	     (keep-matching-items coding-types coding-type-explicit?)))
+	(check-coding-types explicit)
+	(check-code-allocations explicit)
+	(for-each (lambda (coding-type)
+		    (assign-defn-names coding-type key-abbrevs))
+		  explicit)
+	(write-scheme-header explicit
+			     key-abbrevs
+			     (merge-pathnames "svm1-opcodes.scm" dir))
+	(write-c-header explicit
+			key-abbrevs
+			(merge-pathnames "svm1-defns.h" dir))
+	(if #t				;debugging
+	    (write-coding-types explicit (pathname-new-type pathname "exp")))
+	(write-rt-coding-types explicit
+			       (merge-pathnames "assembler-db.scm" dir))))))
+
+(define (classify-records records)
+  (let ((coding-types (make-queue))
+	(key-abbrevs (make-queue))
+	(defns (make-queue)))
+    (for-each (lambda (record)
+		(enqueue! (cond ((coding-type? record) coding-types)
+				((key-abbrev? record) key-abbrevs)
+				((procedure? record) defns)
+				(else (error "Unknown record type:" record)))
+			  record))
+	      records)
+    (values (queue->list coding-types)
+	    (queue->list key-abbrevs)
+	    (queue->list defns))))
+
+(define (find-coding-type name coding-types #!optional error?)
+  (or (find-matching-item coding-types
+	(lambda (type)
+	  (eq? (coding-type-name type) name)))
+      (and (if (default-object? error?) #t error?)
+	   (error "Unknown coding-type name:" name))))
+
+;;;; Datatypes
+
+(define-record-type <coding-type>
+    (make-coding-type name n-bits start-index)
+    coding-type?
+  (name coding-type-name)
+  (n-bits coding-type-n-bits)
+  (start-index coding-type-start-index)
+  (defns coding-type-defns set-coding-type-defns!))
+
+(define (coding-type-code-limit type)
+  (expt 2 (coding-type-n-bits type)))
+
+(define (coding-type-explicit? type)
+  (if (coding-type-n-bits type) #t #f))
+
+(define-record-type <defn>
+    (%make-defn coding-type pattern pvars has-code? coding)
+    defn?
+  (coding-type defn-coding-type set-defn-coding-type!)
+  (pattern defn-pattern)
+  (pvars defn-pvars)
+  (has-code? defn-has-code?)
+  (coding defn-coding)
+  (code defn-code set-defn-code!)
+  (name defn-name set-defn-name!))
+
+(define (make-defn type-name pattern has-code? coding)
+  (%make-defn type-name
+	      pattern
+	      (parse-pattern pattern)
+	      has-code?
+	      coding))
+
+(define-record-type <key-abbrev>
+    (make-key-abbrev keyword abbreviation)
+    key-abbrev?
+  (keyword key-abbrev-keyword)
+  (abbreviation key-abbrev-abbreviation))
+
+(define (check-coding-types coding-types)
+  ;; Check that all coding-type names are unique.
+  (do ((coding-types coding-types (cdr coding-types)))
+      ((not (pair? coding-types)))
+    (let ((name (coding-type-name (car coding-types))))
+      (if (find-coding-type name (cdr coding-types) #f)
+	  (error "Duplicate coding-type name:" name))))
+  ;; Check that each definition is well-formed.
+  (for-each (lambda (coding-type)
+	      (for-each (lambda (defn) (check-defn defn coding-types))
+			(coding-type-defns coding-type)))
+	    coding-types)
+  ;; Check that the coding-type references form an acyclic graph with
+  ;; a single root.
+  (check-coding-type-graph coding-types))
+
+(define (check-defn defn coding-types)
+  ;; Check for duplicate pattern variables.
+  (do ((pvars (defn-pvars defn) (cdr pvars)))
+      ((not (pair? pvars)))
+    (if (there-exists? (cdr pvars)
+	  (lambda (pv)
+	    (eq? (pvar-name pv) (pvar-name (car pvars)))))
+	(error "Duplicate pattern variable:" (car pvars))))
+  ;; Check for missing or extra variable references in coding.
+  (let ((pvars1 (defn-pvars defn))
+	(pvars2 (defn-coding defn)))
+    (if (not (and (fix:= (length pvars1) (length pvars2))
+		  (for-all? pvars1 (lambda (pv1) (memq pv1 pvars2)))
+		  (for-all? pvars2 (lambda (pv2) (memq pv2 pvars1)))))
+	(error "Pattern/coding mismatch:" pvars1 pvars2)))
+  ;; Check for incorrect use of code marker.
+  (if (and (defn-has-code? defn)
+	   (not (coding-type-explicit? (defn-coding-type defn))))
+      (error "Code marker not allowed in implicit type.")))
+
+(define (check-coding-type-graph coding-types)
+  (let ((nodes
+	 (map (lambda (coding-type)
+		(vector coding-type '() '()))
+	      coding-types))
+	(queue (make-queue)))
+    ;; Compute initial references.
+    (let ((find-node
+	   (lambda (coding-type)
+	     (find-matching-item nodes
+	       (lambda (node)
+		 (eq? (vector-ref node 0) coding-type))))))
+      (for-each (lambda (coding-type from)
+		  (for-each (lambda (to)
+			      (enqueue! queue (cons from (find-node to))))
+			    (compute-references coding-type coding-types)))
+		coding-types
+		nodes))
+    ;; Transitively close the reference graph.
+    (queue-map! queue
+      (lambda (p)
+	(let loop ((from (car p)) (to (cdr p)))
+	  (if (not (memq to (vector-ref from 1)))
+	      (begin
+		(vector-set! from 1 (cons to (vector-ref from 1)))
+		(vector-set! to 2 (cons from (vector-ref to 2)))
+		(for-each (lambda (to)
+			    (enqueue! queue (cons from to)))
+			  (vector-ref to 1))
+		(for-each (lambda (to) (loop from to))
+			  (vector-ref to 1))
+		(for-each (lambda (from) (loop from to))
+			  (vector-ref from 2)))))))
+    ;; Check for cycles.
+    (for-each (lambda (node)
+		(if (memq node (vector-ref node 1))
+		    (error "Cycle in coding-type graph:" node)))
+	      nodes)
+    ;; Check for single root.
+    (let ((roots
+	   (keep-matching-items nodes
+	     (lambda (node)
+	       (null? (vector-ref node 2))))))
+      (if (not (pair? roots))
+	  (error "No roots in coding-type graph."))
+      (if (pair? (cdr roots))
+	  (error "Multiple roots in coding-type graph:" roots)))))
+
+(define (compute-references coding-type coding-types)
+  ;; Check that all pvar types are bound, and return references.
+  (do ((defns (coding-type-defns coding-type) (cdr defns))
+       (refs '()
+	     (do ((pvars (defn-pvars (car defns)) (cdr pvars))
+		  (refs refs
+			(let ((name (pvar-type (car pvars))))
+			  (if (lookup-pvar-type name)
+			      refs
+			      (let ((ref (find-coding-type name coding-types)))
+				(if (memq ref refs)
+				    refs
+				    (cons ref refs)))))))
+		 ((not (pair? pvars)) refs))))
+      ((not (pair? defns)) refs)))
+
+(define (check-code-allocations coding-types)
+  (for-each (lambda (coding-type)
+	      (for-each (lambda (defn)
+			  (if (defn-has-code? defn)
+			      (if (not (defn-code defn))
+				  (error "Missing code:" defn))
+			      (if (defn-code defn)
+				  (error "Unwanted code:" defn))))
+			(coding-type-defns coding-type)))
+	    coding-types))
+
+;;;; Parsing
+
+(define (parse-inputs inputs)
+  (receive (inputs abbrevs)
+      (expand-abbrevs inputs '())
+    (map (lambda (input)
+	   (let loop ((alist parser-alist))
+	     (if (not (pair? alist))
+		 (error "Unknown input:" input))
+	     (if (and (pair? input)
+		      (eq? (car input) (caaar alist))
+		      (syntax-match? (cdaar alist) (cdr input)))
+		 ((cdar alist) input abbrevs)
+		 (loop (cdr alist)))))
+	 inputs)))
+
+(define (expand-abbrevs inputs abbrevs)
+  (receive (abbrev-defs inputs) (split-list inputs abbrev-def?)
+    (let ((abbrevs
+	   (map* abbrevs
+		 (lambda (abbrev-def)
+		   (cons `(',(caadr abbrev-def) ,@(cdadr abbrev-def))
+			 (eval (caddr abbrev-def)
+			       (make-top-level-environment))))
+		 abbrev-defs))
+	  (any-expansions? #f))
+      (let ((outputs
+	     (append-map (lambda (input)
+			   (let ((abbrev
+				  (find-matching-item abbrevs
+				    (lambda (abbrev)
+				      (syntax-match? (car abbrev) input)))))
+			     (if abbrev
+				 (begin
+				   (set! any-expansions? #t)
+				   ((cdr abbrev) input))
+				 (list input))))
+			 inputs)))
+	(if any-expansions?
+	    (expand-abbrevs outputs abbrevs)
+	    (values outputs abbrevs))))))
+
+(define (split-list items predicate)
+  (let loop ((items items) (true '()) (false '()))
+    (if (pair? items)
+	(if (predicate (car items))
+	    (loop (cdr items) (cons (car items) true) false)
+	    (loop (cdr items) true (cons (car items) false)))
+	(values (reverse! true) (reverse! false)))))
+
+(define (abbrev-def? input)
+  (syntax-match? '('DEFINE-ABBREVIATION (SYMBOL * DATUM) EXPRESSION)
+		 input))
+
+(define (define-parser keyword pattern parser)
+  (let loop ((ps parser-alist))
+    (if (pair? ps)
+	(if (eq? (caaar ps) keyword)
+	    (begin
+	      (set-cdr! (caar ps) pattern)
+	      (set-cdr! (car ps) parser))
+	    (loop (cdr ps)))
+	(begin
+	  (set! parser-alist
+		(cons (cons (cons keyword pattern) parser)
+		      parser-alist))
+	  unspecific))))
+
+(define parser-alist
+  '())
+
+(define-parser 'DEFINE-KEYWORD-ABBREVIATION '(SYMBOL SYMBOL)
+  (lambda (input abbrevs)
+    abbrevs
+    (make-key-abbrev (cadr input) (caddr input))))
+
+(define-parser 'DEFINE-IMPLICIT-CODING-TYPE '(SYMBOL * DATUM)
+  (lambda (input abbrevs)
+    (let ((coding-type (make-coding-type (cadr input) #f 0)))
+      (parse-coding-type-body coding-type (cddr input) abbrevs)
+      coding-type)))
+
+(define-parser 'DEFINE-EXPLICIT-CODING-TYPE
+  `(SYMBOL (,exact-positive-integer? ? ,exact-nonnegative-integer?) * DATUM)
+  (lambda (input abbrevs)
+    (let ((name (cadr input))
+	  (n-bits (caaddr input))
+	  (start-index (if (pair? (cdaddr input)) (car (cdaddr input)) 0))
+	  (body (cdddr input)))
+      (let ((code-limit (expt 2 n-bits)))
+	(if (not (< start-index code-limit))
+	    (error:bad-range-argument start-index
+				      'DEFINE-EXPLICIT-CODING-TYPE)))
+      (let ((coding-type (make-coding-type name n-bits start-index)))
+	(parse-coding-type-body coding-type body abbrevs)
+	coding-type))))
+
+(define (parse-coding-type-body coding-type body abbrevs)
+  (set-coding-type-defns!
+   coding-type
+   (map (lambda (input)
+	  (if (not (syntax-match? '('DEFINE-CODE-SEQUENCE DATUM * DATUM)
+				  input))
+	      (error "Illegal sequence definition:" input))
+	  (parse-code-sequence coding-type (cadr input) (cddr input)))
+	(receive (body abbrevs) (expand-abbrevs body abbrevs)
+	  abbrevs
+	  body))))
+
+(define-parser 'DEFINE-CODE-SEQUENCE '(SYMBOL DATUM * DATUM)
+  (lambda (input abbrevs)
+    abbrevs
+    (lambda (coding-types)
+      (let ((coding-type (find-coding-type (cadr input) coding-types)))
+	(let ((defn
+		(parse-code-sequence coding-type (caddr input) (cdddr input))))
+	  (set-coding-type-defns!
+	   coding-type
+	   (append! (coding-type-defns coding-type) (list defn)))
+	  defn)))))
+
+(define (parse-code-sequence coding-type pattern coding)
+  (let ((pvars (parse-pattern pattern)))
+    (receive (has-code? coding)
+	(if (coding-type-explicit? coding-type)
+	    (if (and (pair? coding)
+		     (equal? (car coding) '(NO-CODE)))
+		(values #f (cdr coding))
+		(values #t coding))
+	    (values #f coding))
+      (%make-defn coding-type
+		  pattern
+		  pvars
+		  has-code?
+		  (map (lambda (item)
+			 (guarantee-symbol item #f)
+			 (or (find-matching-item pvars
+			       (lambda (pv)
+				 (eq? (pvar-name pv) item)))
+			     (error "Missing name reference:" item)))
+		       coding)))))
+
+;;;; Expansion
+
+(define (expand-implicit-coding-types coding-types)
+  (let ((to-substitute (make-queue))
+	(to-expand (make-queue))
+	(next-pass (make-queue)))
+    (let ((queue-ct
+	   (lambda (type)
+	     (if (independent-coding-type? type coding-types)
+		 (if (coding-type-explicit? type)
+		     (assign-defn-codes type)
+		     (enqueue! to-substitute type))
+		 (enqueue! to-expand type)))))
+      (for-each queue-ct coding-types)
+      (queue-map! to-substitute
+	(lambda (type1)
+	  (queue-map! to-expand
+	    (lambda (type2)
+	      (expand-coding-type type1 type2)
+	      (enqueue! next-pass type2)))
+	  (queue-map! next-pass queue-ct))))
+    (queue-map! to-expand
+      (lambda (type)
+	(if (not (coding-type-explicit? type))
+	    (error "Unexpanded coding type:" type))
+	(assign-defn-codes type)))))
+
+(define (independent-coding-type? type coding-types)
+  (let ((implicit-types
+	 (delete-matching-items coding-types coding-type-explicit?)))
+    (for-all? (coding-type-defns type)
+      (lambda (defn)
+	(not (there-exists? (defn-pvars defn)
+	       (lambda (pv)
+		 (find-coding-type (pvar-type pv) implicit-types #f))))))))
+
+(define (expand-coding-type to-substitute to-expand)
+  (let ((type-name (coding-type-name to-substitute)))
+    (let loop ()
+      (let ((any-changes? #f))
+	(set-coding-type-defns!
+	 to-expand
+	 (append-map! (lambda (defn)
+			(let ((pv
+			       (find-matching-item (defn-pvars defn)
+				 (lambda (pv)
+				   (eq? (pvar-type pv) type-name)))))
+			  (if pv
+			      (begin
+				(set! any-changes? #t)
+				(map (lambda (defn*)
+				       (specialize-defn defn pv defn*))
+				     (coding-type-defns to-substitute)))
+			      (list defn))))
+		      (coding-type-defns to-expand)))
+	(if any-changes?
+	    (loop))))))
+
+(define (assign-defn-codes coding-type)
+  (let ((code-limit (coding-type-code-limit coding-type)))
+    (do ((defns (coding-type-defns coding-type) (cdr defns))
+	 (code (coding-type-start-index coding-type)
+	       (let ((defn (car defns)))
+		 (if (defn-has-code? defn)
+		     (begin
+		       (if (not (< code code-limit))
+			   (error "Too many codes assigned:" coding-type))
+		       (set-defn-code! defn code)
+		       (+ code 1))
+		     (begin
+		       (set-defn-code! defn #f)
+		       code)))))
+	((not (pair? defns)) unspecific))))
+
+(define (coding-type-end-index coding-type)
+  (+ (coding-type-start-index coding-type)
+     (count-matching-items (coding-type-defns coding-type) defn-has-code?)))
+
+(define (specialize-defn defn pv defn*)
+  (let ((defn* (maybe-rename defn* defn)))
+    (make-defn (defn-coding-type defn)
+	       (rewrite-pattern (lambda (pv*)
+				  (if (eq? (pvar-name pv*) (pvar-name pv))
+				      (defn-pattern defn*)
+				      pv*))
+				(defn-pattern defn))
+	       (defn-has-code? defn)
+	       (append-map (lambda (item)
+			     (if (and (pvar? item)
+				      (eq? (pvar-name item) (pvar-name pv)))
+				 (defn-coding defn*)
+				 (list item)))
+			   (defn-coding defn)))))
+
+(define (maybe-rename defn defn*)
+  (let ((alist
+	 (let loop
+	     ((pvars (defn-pvars defn))
+	      (pvars* (defn-pvars defn*)))
+	   (if (pair? pvars)
+	       (let ((pv (car pvars))
+		     (clash?
+		      (lambda (name)
+			(there-exists? pvars*
+			  (lambda (pv)
+			    (eq? (pvar-name pv) name)))))
+		     (k
+		      (lambda (pv)
+			(loop (cdr pvars) (cons pv pvars*)))))
+		 (if (clash? (pvar-name pv))
+		     (let find-rename ((n 1))
+		       (let ((rename (symbol (pvar-name pv) '- n)))
+			 (if (clash? rename)
+			     (find-rename (+ n 1))
+			     (let ((pv* (make-pvar rename (pvar-type pv))))
+			       (cons (cons pv pv*)
+				     (k pv*))))))
+		     (k pv)))
+	       '()))))
+    (if (null? alist)
+	defn
+	(let ((rename-pv
+	       (lambda (item)
+		 (let ((p
+			(and (pvar? item)
+			     (assq item alist))))
+		   (if p
+		       (cdr p)
+		       item)))))
+	  (make-defn (defn-coding-type defn)
+		     (rewrite-pattern rename-pv (defn-pattern defn))
+		     (defn-has-code? defn)
+		     (map rename-pv (defn-coding defn)))))))
+
+(define (rewrite-pattern procedure pattern)
+  (let loop ((pattern pattern))
+    (cond ((pvar? pattern) (procedure pattern))
+	  ((pair? pattern) (map loop pattern))
+	  (else pattern))))
+
+;;;; Name assignment
+
+(define (assign-defn-names coding-type key-abbrevs)
+  (let ((defns (coding-type-defns coding-type)))
+    ;; Generate names as lists of symbols.
+    (for-each (lambda (defn)
+		(set-defn-name! defn
+				(pattern->defn-name (defn-pattern defn)
+						    key-abbrevs)))
+	      defns)
+    ;; Eliminate redundant items in names.
+    (for-each (lambda (defns)
+		(if (pair? (cdr defns))
+		    (begin
+		      (delete-shared-prefixes defns)
+		      (for-each (lambda (item)
+				  (delete-corresponding-name-items defns item))
+				(deleteable-name-items)))
+		    (let ((defn (car defns)))
+		      (set-defn-name!
+		       defn
+		       (delete-matching-items! (defn-name defn)
+			 deleteable-name-item?)))))
+	      (group-defns-by-prefix defns))
+    ;; Join name items into hyphen-separated symbols.
+    (for-each (lambda (defn)
+		(set-defn-name! defn (defn-name->symbol (defn-name defn))))
+	      defns)))
+
+(define (pattern->defn-name pattern key-abbrevs)
+  (let ((items
+	 (let loop ((pattern pattern))
+	   (cond ((symbol? pattern)
+		  (list (map-key-abbrevs pattern key-abbrevs)))
+		 ((pvar? pattern)
+		  (list (let ((pvt (lookup-pvar-type (pvar-type pattern))))
+			  (if pvt
+			      (pvt-abbreviation pvt)
+			      (map-key-abbrevs (pvar-type pattern)
+					       key-abbrevs)))))
+		 ((pair? pattern) (append-map! loop pattern))
+		 (else '())))))
+    (let trim-tail ((items items))
+      (if (and (fix:>= (length items) 3)
+	       (let ((l (reverse items)))
+		 (eq? (car l) (cadr l))))
+	  (trim-tail (except-last-pair! items))
+	  items))))
+
+(define (map-key-abbrevs keyword key-abbrevs)
+  (let ((key-abbrev
+	 (find-matching-item key-abbrevs
+	   (lambda (key-abbrev)
+	     (eq? (key-abbrev-keyword key-abbrev) keyword)))))
+    (if key-abbrev
+	(key-abbrev-abbreviation key-abbrev)
+	keyword)))
+
+(define (defn-name->symbol items)
+  (if (pair? items)
+      (apply symbol
+	     (car items)
+	     (append-map (lambda (item) (list '- item))
+			 (cdr items)))
+      '||))
+
+(define (group-defns-by-prefix defns)
+  (let ((groups '()))
+    (for-each (lambda (defn)
+		(let ((name (defn-name defn)))
+		  (let ((p (assq (car name) groups)))
+		    (if p
+			(set-cdr! p (cons defn (cdr p)))
+			(begin
+			  (set! groups (cons (list (car name) defn) groups))
+			  unspecific)))))
+	      defns)
+    (reverse! (map (lambda (group) (reverse! (cdr group))) groups))))
+
+(define (delete-shared-prefixes defns)
+  (let ((names (map defn-name defns)))
+    (let ((n
+	   (length
+	    (fold-left (lambda (a b)
+			 (let join ((a a) (b b))
+			   (if (and (pair? a) (pair? b) (eqv? (car a) (car b)))
+			       (cons (car a) (join (cdr a) (cdr b)))
+			       '())))
+		       (car names)
+		       (cdr names)))))
+      (for-each (lambda (defn name)
+		  (set-defn-name! defn (cons (car name) (list-tail name n))))
+		defns
+		names))))
+
+(define (delete-corresponding-name-items defns to-delete)
+  (let loop ((lower-limit 1))
+    (let ((indices
+	   (map (lambda (defn)
+		  (index-of-deleted-name-item to-delete
+					      (defn-name defn)
+					      lower-limit))
+		defns)))
+      (if (for-all? indices (lambda (i) i))
+	  (loop (if (apply = indices)
+		    (let ((index (car indices)))
+		      (let ((names
+			     (map (lambda (defn)
+				    (delete-name-item (defn-name defn) index))
+				  defns)))
+			(if (distinct-names? names)
+			    (begin
+			      (for-each set-defn-name! defns names)
+			      index)
+			    (fix:+ index 1))))
+		    (fix:+ (apply min indices) 1)))))))
+
+(define (index-of-deleted-name-item to-delete items lower-limit)
+  (let loop ((items items) (index 0))
+    (and (pair? items)
+	 (if (and (fix:>= index lower-limit)
+		  (eq? (car items) to-delete))
+	     index
+	     (loop (cdr items) (fix:+ index 1))))))
+
+(define (delete-name-item items index)
+  (let loop ((items items) (i 0))
+    (if (fix:< i index)
+	(cons (car items) (loop (cdr items) (fix:+ i 1)))
+	(cdr items))))
+
+(define (distinct-names? names)
+  (if (pair? names)
+      (if (member (car names) (cdr names))
+	  #f
+	  (distinct-names? (cdr names)))
+      #t))
+
+(define (deleteable-name-item? item)
+  (there-exists? (pvar-types)
+    (lambda (pvt)
+      (eq? (pvt-abbreviation pvt) item))))
+
+(define (deleteable-name-items)
+  (map pvt-abbreviation (pvar-types)))
+
+;;;; Output
+
+(define (write-scheme-header coding-types key-abbrevs pathname)
+  (wrap-scheme-output "Opcodes for SVM version 1" pathname
+    (lambda (port)
+      (for-each
+       (lambda (coding-type)
+	 (let ((limit
+		(apply max
+		       (map defn-name-length
+			    (coding-type-defns coding-type)))))
+	   (for-each
+	    (lambda (defn)
+	      (let ((opcode (defn-code defn)))
+		(if opcode
+		    (begin
+		      (write-string "(define-integrable svm1-" port)
+		      (write (map-key-abbrevs (coding-type-name coding-type)
+					      key-abbrevs)
+			     port)
+		      (write-string ":" port)
+		      (write (defn-name defn) port)
+		      (write-spaces (fix:- limit (defn-name-length defn))
+				    port)
+		      (write-string " #x" port)
+		      (if (fix:< opcode #x10)
+			  (write-char #\0 port))
+		      (write-string (number->string opcode 16) port)
+		      (write-string ")" port)
+		      (newline port)))))
+	    (coding-type-defns coding-type))))
+       coding-types))))
+
+(define (defn-name-length defn)
+  (string-length (symbol-name (defn-name defn))))
+
+(define (wrap-scheme-output title pathname generator)
+  (call-with-output-file pathname
+    (lambda (port)
+      (write-string "#| -*-Scheme-*-\n\n" port)
+      (write-copyright+license pathname port)
+      (newline port)
+      (write-string "|#\n\n" port)
+      (write-string ";;;; " port)
+      (write-string title port)
+      (write-string "\n\n" port)
+      (write-string "(declare (usual-integrations))\n" port)
+      (write-string "\f\n" port)
+      (generator port))))
+
+(define (write-c-header coding-types key-abbrevs pathname)
+  (wrap-c-header "Instructions for SVM version 1" pathname
+    (lambda (port)
+      (for-each (lambda (p)
+		  (write-string "#define SVM1_REG_" port)
+		  (write-c-name (car p) #t port)
+		  (write-string " " port)
+		  (write (cdr p) port)
+		  (newline port))
+		fixed-registers)
+      (newline port)
+      (for-each
+       (lambda (coding-type)
+	 (let ((prefix
+		(string-append
+		 "SVM1_"
+		 (name->c-string (map-key-abbrevs (coding-type-name coding-type)
+						  key-abbrevs)
+				 #t)
+		 "_"))
+	       (long-form?
+		(there-exists? (coding-type-defns coding-type)
+		  (lambda (defn)
+		    (pair? (defn-coding defn))))))
+	   (write-c-code-macro prefix
+			       "START_CODE"
+			       (coding-type-start-index coding-type)
+			       port)
+	   (write-c-code-macro prefix
+			       "END_CODE"
+			       (coding-type-end-index coding-type)
+			       port)
+	   (newline port)
+	   (write-c-type-bindings prefix coding-type port)
+	   (newline port)
+	   (for-each (let ((proc
+			    (if long-form?
+				write-c-opcode+decoder
+				write-c-opcode)))
+		       (lambda (defn)
+			 (if (defn-has-code? defn)
+			     (proc prefix defn port))))
+		     (coding-type-defns coding-type))
+	   (if (not long-form?)
+	       (newline port))))
+       coding-types))))
+
+(define (wrap-c-header title pathname generator)
+  (call-with-output-file pathname
+    (lambda (port)
+      (let ((cs
+	     (string-append "SCM_"
+			    (name-string->c-string (pathname-name pathname) #t)
+			    "_H")))
+	(write-string "/* -*-C-*-\n\n" port)
+	(write-copyright+license pathname port)
+	(newline port)
+	(write-string "*/\n\n" port)
+	(write-string "/* " port)
+	(write-string title port)
+	(write-string " */\n\n" port)
+	(write-string "#ifndef " port)
+	(write-string cs port)
+	(write-string "\n" port)
+	(write-string "#define " port)
+	(write-string cs port)
+	(write-string " 1\n\n" port)
+	(generator port)
+	(write-string "#endif /* not " port)
+	(write-string cs port)
+	(write-string " */\n" port)))))
+
+(define (write-c-type-bindings prefix coding-type port)
+  (write-string "#define " port)
+  (write-string prefix port)
+  (write-string "BINDINGS(binder) \\" port)
+  (newline port)
+  (write-c-macro-body (lambda (defn port)
+			(write-string "  " port)
+			(write-string "binder (" port)
+			(write-string prefix port)
+			(write-c-name (defn-name defn) #t port)
+			(write-string ", " port)
+			(write-c-name (defn-name defn) #f port)
+			(write-string ")" port))
+		      (keep-matching-items (coding-type-defns coding-type)
+			defn-has-code?)
+		      port))
+
+(define (write-c-opcode+decoder prefix defn port)
+  (write-c-opcode prefix defn port)
+  (let ((coding (defn-coding defn)))
+    (if (pair? coding)
+	(begin
+	  (write-string "#define DECODE_" port)
+	  (write-string prefix port)
+	  (write-c-name (defn-name defn) #t port)
+	  (write-string "(" port)
+	  (write-c-name (pvar-name (car coding)) #f port)
+	  (for-each (lambda (pv)
+		      (write-string ", " port)
+		      (write-c-name (pvar-name pv) #f port))
+		    (cdr coding))
+	  (write-string ") \\" port)
+	  (newline port)
+	  (write-c-macro-body (lambda (pv port)
+				(write-string "  DECODE_" port)
+				(write-c-name (pvar-type pv) #t port)
+				(write-string " (" port)
+				(write-c-name (pvar-name pv) #f port)
+				(write-string ")" port))
+			      coding
+			      port))))
+  (newline port))
+
+(define (write-c-opcode prefix defn port)
+  (write-c-code-macro prefix
+		      (name->c-string (defn-name defn) #t)
+		      (defn-code defn)
+		      port))
+
+(define (write-c-code-macro prefix name code port)
+  (write-string "#define " port)
+  (write-string prefix port)
+  (write-string name port)
+  (write-string " " port)
+  (write-c-hex-code code port)
+  (newline port))
+
+(define (write-c-hex-code n port)
+  (write-string "0x" port)
+  (write-string (string-pad-left (number->string n 16) 2 #\0) port))
+
+(define (write-c-macro-body write-item items port)
+  (for-each (lambda (item)
+	      (write-item item port)
+	      (write-string "; \\" port)
+	      (newline port))
+	    (except-last-pair items))
+  (write-item (last items) port)
+  (newline port))
+
+(define (write-copyright+license pathname port)
+  (write-string "DO NOT EDIT: this file was generated by a program." port)
+  (newline port)
+  (newline port)
+  ;; Don't use dollar-sign; could cause unwanted keyword expansion.
+  (write-string "\044Id\044" port)
+  (newline port)
+  (newline port)
+  (write-mit-scheme-copyright port)
+  (newline port)
+  (newline port)
+  (write-mit-scheme-license port)
+  (newline port))
+
+(define (name->c-string name upcase?)
+  (name-string->c-string (symbol-name name) upcase?))
+
+(define (name-string->c-string name upcase?)
+  (call-with-output-string
+    (lambda (port)
+      (write-c-name-string name upcase? port))))
+
+(define (write-c-name name upcase? port)
+  (write-c-name-string (symbol-name name) upcase? port))
+
+(define (write-c-name-string name upcase? port)
+  (let ((e (string-length name))
+	(recase
+	 (lambda (s)
+	   (if upcase? s (string-downcase s)))))
+    (let loop ((i 0))
+      (if (fix:< i e)
+	  (let ((c (string-ref name i)))
+	    (cond ((char-alphanumeric? c)
+		   (write-char (if upcase?
+				   (char-upcase c)
+				   (char-downcase c))
+			       port)
+		   (loop (fix:+ i 1)))
+		  ((fix:= i 0)
+		   (write-string (recase (case c
+					   ((#\+) "ADD")
+					   ((#\-) "SUBTRACT")
+					   ((#\*) "MULTIPLY")
+					   ((#\/) "DIVIDE")
+					   (else (error "Unknown char:" c))))
+				 port)
+		   (loop (fix:+ i 1)))
+		  ((char=? c #\-)
+		   (if (and (fix:< (fix:+ i 1) e)
+			    (char=? (string-ref name (fix:+ i 1)) #\>))
+		       (begin
+			 (write-string (recase "_TO_") port)
+			 (loop (fix:+ i 2)))
+		       (begin
+			 (write-char #\_ port)
+			 (loop (fix:+ i 1)))))
+		  ((char=? c #\?)
+		   (write-string (recase "_P") port)
+		   (loop (fix:+ i 1)))
+		  ((char=? c #\!)
+		   (write-string (recase "_X") port)
+		   (loop (fix:+ i 1)))
+		  (else
+		   (error "Unknown char:" c))))))))
+
+(define (write-spaces n port)
+  (do ((i 0 (fix:+ i 1)))
+      ((not (fix:< i n)))
+    (write-char #\space port)))
+
+(define (write-coding-types coding-types pathname)
+  (wrap-scheme-output "Expanded coding types" pathname
+    (lambda (port)
+      (if (pair? coding-types)
+	  (begin
+	    (write-coding-type (car coding-types) port)
+	    (for-each (lambda (coding-type)
+			(newline port)
+			(newline port)
+			(write-coding-type coding-type port))
+		      (cdr coding-types)))))))
+
+(define (write-coding-type coding-type port)
+  (let ((indentation 2))
+    (write-string "(" port)
+    (write (if (coding-type-explicit? coding-type)
+	       'DEFINE-EXPLICIT-CODING-TYPE
+	       'DEFINE-IMPLICIT-CODING-TYPE)
+	   port)
+    (write-string " " port)
+    (write (coding-type-name coding-type) port)
+    (if (coding-type-explicit? coding-type)
+	(begin
+	  (write-string " " port)
+	  (write (coding-type-start-index coding-type) port)))
+    (newline port)
+    (for-each (lambda (defn)
+		(newline port)
+		(write-defn defn indentation port))
+	      (coding-type-defns coding-type))
+    (write-spaces indentation port)
+    (write-string ")" port)))
+
+(define (write-defn defn indentation port)
+  (write-spaces indentation port)
+  (write-string ";; " port)
+  (write (defn-name defn) port)
+  (newline port)
+  (write-spaces indentation port)
+  (write-string "(define-code-sequence " port)
+  (newline port)
+  (let ((indentation (+ indentation 2)))
+    (pretty-print (defn-pattern defn) port #t indentation)
+    (if (defn-has-code? defn)
+	(begin
+	  (newline port)
+	  (write-spaces indentation port)
+	  (write (defn-code defn) port)))
+    (for-each (lambda (pv)
+		(newline port)
+		(write-spaces indentation port)
+		(write (pvar-name pv) port))
+	      (defn-coding defn)))
+  (write-char #\) port)
+  (newline port))
+
+(define (write-rt-coding-types coding-types pathname)
+  (wrap-scheme-output "Opcodes for SVM version 1" pathname
+    (lambda (port)
+      (if (pair? coding-types)
+	  (begin
+	    (pretty-print (rt-coding-type-constructor (car coding-types)) port)
+	    (for-each (lambda (coding-type)
+			(newline port)
+			(newline port)
+			(pretty-print (rt-coding-type-constructor coding-type)
+				      port))
+		      (cdr coding-types)))))))
+
+(define (rt-coding-type-constructor coding-type)
+  `(MAKE-RT-CODING-TYPE
+    ',(coding-type-name coding-type)
+    (LIST
+     ,@(map (lambda (defn)
+	      `(MAKE-RT-DEFN ',(defn-name defn)
+			     ,(if (defn-has-code? defn) `,(defn-code defn) `#F)
+			     ',(defn-pattern defn)
+			     ,(rt-defn-encoder-constructor defn)
+			     ,(rt-defn-decoder-constructor defn)))
+	    (coding-type-defns coding-type)))))
+
+(define (rt-defn-encoder-constructor defn)
+  `(LAMBDA (INSTANCE WRITE-BYTE)
+     ,@(map (lambda (item)
+	      (let ((pval `(RT-INSTANCE-PVAL ',(pvar-name item) INSTANCE))
+		    (pvt (lookup-pvar-type (pvar-type item))))
+		(if pvt
+		    `(,(pvt-encoder pvt) ,pval WRITE-BYTE)
+		    `(LET ((PVAL ,pval))
+		       ((RT-INSTANCE-ENCODER PVAL) PVAL WRITE-BYTE)))))
+	    (defn-coding defn))))
+
+(define (rt-defn-decoder-constructor defn)
+  (let ((pvars (defn-pvars defn)))
+    (let ((n-pvars (length pvars))
+	  (body
+	   (lambda (pv)
+	     (let ((pvt (lookup-pvar-type (pvar-type pv))))
+	       (if pvt
+		   `(,(pvt-decoder pvt) READ-BYTE)
+		   `(DECODE-RT-CODING-TYPE ',(pvar-type pv)
+					   READ-BYTE
+					   CODING-TYPES))))))
+      `(LAMBDA (READ-BYTE CODING-TYPES)
+	 ,(if (fix:= n-pvars 1)
+	      `(LIST ,(body (car pvars)))
+	      `(LET* ,(map (lambda (pv)
+			     `(,(symbol 'V (pvar-index pv pvars)) ,(body pv)))
+			   (defn-coding defn))
+		 (LIST ,@(let loop ((i 0))
+			   (if (fix:< i n-pvars)
+			       (cons (symbol 'V i) (loop (fix:+ i 1)))
+			       '())))))))))
+
+(define (pvar-index pv pvars)
+  (let loop ((pvars pvars) (index 0))
+    (if (not (pair? pvars))
+	(error:bad-range-argument pv 'PVAR-INDEX))
+    (if (eq? (car pvars) pv)
+	index
+	(loop (cdr pvars) (fix:+ index 1)))))
\ No newline at end of file
diff --git a/src/compiler/machines/svm/assembler-rules.scm b/src/compiler/machines/svm/assembler-rules.scm
new file mode 100644
index 000000000..f66f122c8
--- /dev/null
+++ b/src/compiler/machines/svm/assembler-rules.scm
@@ -0,0 +1,589 @@
+#| -*-Scheme-*-
+
+$Id$
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+    1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+    2006, 2007, 2008 Massachusetts Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; SVM assembler rules
+
+;;; Primitive types:
+;;; unsigned-8
+;;; unsigned-16
+;;; unsigned-32
+;;; signed-8
+;;; signed-16
+;;; signed-32
+;;; float
+;;; register
+;;; word-register
+;;; float-register
+;;; type-word (6-bit unsigned)
+
+;;; Names consist of symbols drawn from a restricted character set.
+;;; The allowed characters are alphanumerics, hyphen, question mark,
+;;; and exclamation point.  The first character must be a letter.
+;;; When forming a C name for an opcode, hyphen is rewritten as
+;;; underscore, question mark as "_p", and exclamation-point as "_x".
+
+(define-abbreviation (define-implicit-enumeration symbol + symbol)
+  (lambda (form)
+    `((DEFINE-IMPLICIT-CODING-TYPE ,(cadr form)
+	,@(map (lambda (keyword)
+		 `(DEFINE-CODE-SEQUENCE ,keyword))
+	       (cddr form))))))
+
+(define-abbreviation (define-explicit-enumeration symbol + symbol)
+  (lambda (form)
+    `((DEFINE-EXPLICIT-CODING-TYPE ,(cadr form) (8 1)
+	,@(map (lambda (keyword)
+		 `(DEFINE-CODE-SEQUENCE ,keyword))
+	       (cddr form))))))
+
+(define-implicit-enumeration scale-factor
+  byte
+  word
+  float)
+
+(define-implicit-coding-type unsigned-integer
+
+  (define-code-sequence (_ value unsigned-8)
+    value)
+
+  (define-code-sequence (_ value unsigned-16)
+    value)
+
+  (define-code-sequence (_ value unsigned-32)
+    value))
+
+(define-implicit-coding-type signed-integer
+
+  (define-code-sequence (_ value signed-8)
+    value)
+
+  (define-code-sequence (_ value signed-16)
+    value)
+
+  (define-code-sequence (_ value signed-32)
+    value))
+
+(define-keyword-abbreviation byte b)
+(define-keyword-abbreviation word w)
+(define-keyword-abbreviation float f)
+(define-keyword-abbreviation indirect indir)
+(define-keyword-abbreviation indexed index)
+(define-keyword-abbreviation pre-decrement predec)
+(define-keyword-abbreviation pre-increment preinc)
+(define-keyword-abbreviation post-decrement postdec)
+(define-keyword-abbreviation post-increment postinc)
+(define-keyword-abbreviation pc-relative pcr)
+(define-keyword-abbreviation instruction inst)
+(define-keyword-abbreviation address addr)
+(define-keyword-abbreviation indirect-jump ijump)
+(define-keyword-abbreviation indirect-call icall)
+(define-keyword-abbreviation conditional-jump cjump)
+
+(define-explicit-coding-type address (8 1)
+
+  (define-code-sequence (indirect (_ base word-register))
+    base)
+
+  (define-code-sequence (offset (_ base word-register)
+				(_ offset unsigned-8)
+				(_ oscale scale-factor))
+    base
+    offset
+    oscale)
+
+  (define-code-sequence (indexed (_ base word-register)
+				 (_ offset unsigned-8)
+				 (_ oscale scale-factor)
+				 (_ index word-register)
+				 (_ iscale scale-factor))
+    base
+    offset
+    oscale
+    index
+    iscale)
+
+  (define-code-sequence (pre-decrement (_ base word-register)
+				       (_ scale scale-factor))
+    base
+    scale)
+
+  (define-code-sequence (pre-increment (_ base word-register)
+				       (_ scale scale-factor))
+    base
+    scale)
+
+  (define-code-sequence (post-decrement (_ base word-register)
+					(_ scale scale-factor))
+    base
+    scale)
+
+  (define-code-sequence (post-increment (_ base word-register)
+					(_ scale scale-factor))
+    base
+    scale)
+
+  (define-code-sequence (pc-relative (_ n signed-integer))
+    n))
+
+(define-explicit-coding-type instruction (8 1))
+
+(define-code-sequence instruction
+  (store byte
+	 (_ source word-register)
+	 (_ target address))
+  source
+  target)
+
+(define-code-sequence instruction
+  (store word
+	 (_ source word-register)
+	 (_ target address))
+  source
+  target)
+
+(define-code-sequence instruction
+  (store float
+	 (_ source float-register)
+	 (_ target address))
+  source
+  target)
+
+(define-code-sequence instruction
+  (load byte
+	(_ target word-register)
+	(_ source address))
+  target
+  source)
+
+(define-code-sequence instruction
+  (load word
+	(_ target word-register)
+	(_ source address))
+  target
+  source)
+
+(define-code-sequence instruction
+  (load float
+	(_ target float-register)
+	(_ source address))
+  target
+  source)
+
+(define-code-sequence instruction
+  (load-address (_ target word-register)
+		(_ source address))
+  target
+  source)
+
+(define-code-sequence instruction
+  (load-immediate (_ target word-register)
+		  (_ value signed-integer))
+  target
+  value)
+
+(define-code-sequence instruction
+  (load-immediate (_ target word-register)
+		  (_ value unsigned-integer))
+  target
+  value)
+
+(define-code-sequence instruction
+  (load-immediate (_ target float-register)
+		  (_ value float))
+  target
+  value)
+
+(define-code-sequence instruction
+  (copy-block (_ size unsigned-8)
+	      word
+	      (_ from word-register)
+	      (_ to word-register))
+  to
+  from
+  size)
+
+(define-code-sequence instruction
+  (copy-block (_ size word-register)
+	      word
+	      (_ from word-register)
+	      (_ to word-register))
+  to
+  from
+  size)
+
+(define-implicit-coding-type type-operand
+  (define-code-sequence (_ type type-word)
+    type)
+  (define-code-sequence (_ source word-register)
+    source))
+
+(define-code-sequence instruction
+  (load-non-pointer (_ target word-register)
+		    (_ type type-operand)
+		    (_ datum unsigned-integer))
+  target
+  type
+  datum)
+
+(define-code-sequence instruction
+  (load-non-pointer (_ target word-register)
+		    (_ type type-operand)
+		    (_ datum word-register))
+  target
+  type
+  datum)
+
+(define-code-sequence instruction
+  (load-pointer (_ target word-register)
+		(_ type type-operand)
+		(_ address word-register))
+  target
+  type
+  address)
+
+(define-code-sequence instruction
+  (jump (pc-relative (_ offset signed-integer)))
+  offset)
+
+(define-code-sequence instruction
+  (jump (indirect (_ address word-register)))
+  address)
+
+(define-code-sequence instruction
+  (indirect-jump (pc-relative (_ offset unsigned-integer)))
+  offset)
+
+(define-code-sequence instruction
+  (indirect-call (pc-relative (_ offset unsigned-integer)))
+  offset)
+
+(define-code-sequence instruction
+  (conditional-jump (_ condition word-condition-1)
+		    (_ source1 word-register)
+		    (_ source2 word-register)
+		    (pc-relative (_ offset signed-integer)))
+  condition
+  source1
+  source2
+  offset)
+
+(define-implicit-enumeration word-condition-1
+  eq neq
+  lt ge
+  gt le
+  slt sge
+  sgt sle)
+
+(define-code-sequence instruction
+  (conditional-jump (_ condition word-condition-2)
+		    (_ source word-register)
+		    (pc-relative (_ offset signed-integer)))
+  condition
+  source
+  offset)
+
+(define-implicit-enumeration word-condition-2
+  eq neq
+  slt sge
+  sgt sle)
+
+(define-code-sequence instruction
+  (conditional-jump (_ condition fixnum-condition)
+		    (_ source word-register)
+		    (pc-relative (_ offset signed-integer)))
+  condition
+  source
+  offset)
+
+(define-implicit-enumeration fixnum-condition
+  fix nfix
+  ifix nifix)
+
+(define-code-sequence instruction
+  (conditional-jump (_ condition float-condition)
+		    (_ source1 float-register)
+		    (_ source2 float-register)
+		    (pc-relative (_ offset signed-integer)))
+  condition
+  source1
+  source2
+  offset)
+
+(define-code-sequence instruction
+  (conditional-jump (_ condition float-condition)
+		    (_ source float-register)
+		    (pc-relative (_ offset signed-integer)))
+  condition
+  source
+  offset)
+
+(define-implicit-enumeration float-condition
+  eq neq
+  lt gt
+  le ge
+  cmp ncmp)
+
+(define-code-sequence instruction
+  (trap (_ code trap-0))
+  code)
+
+(define-explicit-enumeration trap-0
+  add
+  decrement
+  divide
+  equal?
+  greater?
+  increment
+  less?
+  modulo
+  multiply
+  negative?
+  operator-1-0
+  operator-2-0
+  operator-2-1
+  operator-3-0
+  operator-3-1
+  operator-3-2
+  operator-4-0
+  operator-4-1
+  operator-4-2
+  operator-4-3
+  operator-apply
+  operator-lexpr
+  operator-lookup
+  operator-primitive
+  positive?
+  quotient
+  reflect-to-interface
+  remainder
+  return-to-interpreter
+  subtract
+  zero?)
+
+(define-code-sequence instruction
+  (trap (_ code trap-1)
+	(_ arg0 word-register))
+  code
+  arg0)
+
+(define-explicit-enumeration trap-1
+  error
+  lookup
+  primitive-apply
+  primitive-lexpr-apply
+  safe-lookup
+  unassigned?)
+
+(define-code-sequence instruction
+  (trap (_ code trap-2)
+	(_ arg0 word-register)
+	(_ arg1 word-register))
+  code
+  arg0
+  arg1)
+
+(define-explicit-enumeration trap-2
+  apply
+  assignment
+  lexpr-apply
+  primitive-error)
+
+(define-code-sequence instruction
+  (trap (_ code trap-3)
+	(_ arg0 word-register)
+	(_ arg1 word-register)
+	(_ arg2 word-register))
+  code
+  arg0
+  arg1
+  arg2)
+
+(define-explicit-enumeration trap-3
+  cache-reference-apply
+  link)
+
+(define-code-sequence instruction (interrupt-test-procedure))
+(define-code-sequence instruction (interrupt-test-dynamic-link))
+(define-code-sequence instruction (interrupt-test-closure))
+(define-code-sequence instruction (interrupt-test-ic-procedure))
+(define-code-sequence instruction (interrupt-test-continuation))
+
+(define-code-sequence instruction
+  (flonum-header (_ target word-register)
+		 (_ n-elts unsigned-integer))
+  target
+  n-elts)
+
+(define-code-sequence instruction
+  (flonum-header (_ target word-register)
+		 (_ n-elts word-register))
+  target
+  n-elts)
+
+(define-code-sequence instruction
+  (datum-u8 (_ datum unsigned-8))
+  (no-code)
+  datum)
+
+(define-code-sequence instruction
+  (datum-u16 (_ datum unsigned-16))
+  (no-code)
+  datum)
+
+(define-code-sequence instruction
+  (datum-u32 (_ datum unsigned-32))
+  (no-code)
+  datum)
+
+(define-code-sequence instruction
+  (datum-s8 (_ datum signed-8))
+  (no-code)
+  datum)
+
+(define-code-sequence instruction
+  (datum-s16 (_ datum signed-16))
+  (no-code)
+  datum)
+
+(define-code-sequence instruction
+  (datum-s32 (_ datum signed-32))
+  (no-code)
+  datum)
+
+(define-abbreviation (define-generic-unary-instruction symbol)
+  (lambda (form)
+    (let ((name (cadr form)))
+      `((DEFINE-CODE-SEQUENCE INSTRUCTION
+	  (,name (_ TARGET WORD-REGISTER)
+		 (_ SOURCE WORD-REGISTER))
+	  TARGET
+	  SOURCE)
+	(DEFINE-CODE-SEQUENCE INSTRUCTION
+	  (,name (_ TARGET FLOAT-REGISTER)
+		 (_ SOURCE FLOAT-REGISTER))
+	  TARGET
+	  SOURCE)))))
+
+(define-generic-unary-instruction copy)
+(define-generic-unary-instruction negate)
+(define-generic-unary-instruction increment)
+(define-generic-unary-instruction decrement)
+(define-generic-unary-instruction abs)
+
+(define-abbreviation (define-word-unary-instruction symbol)
+  (lambda (form)
+    `((DEFINE-CODE-SEQUENCE INSTRUCTION
+	(,(cadr form) (_ TARGET WORD-REGISTER)
+		      (_ SOURCE WORD-REGISTER))
+	TARGET
+	SOURCE))))
+
+(define-word-unary-instruction object-type)
+(define-word-unary-instruction object-datum)
+(define-word-unary-instruction object-address)
+(define-word-unary-instruction fixnum->integer)
+(define-word-unary-instruction integer->fixnum)
+(define-word-unary-instruction not)
+(define-word-unary-instruction flonum-align)
+(define-word-unary-instruction flonum-length)
+
+(define-abbreviation (define-float-unary-instruction symbol)
+  (lambda (form)
+    `((DEFINE-CODE-SEQUENCE INSTRUCTION
+	(,(cadr form) (_ TARGET FLOAT-REGISTER)
+		      (_ SOURCE FLOAT-REGISTER))
+	TARGET
+	SOURCE))))
+
+(define-float-unary-instruction sqrt)
+(define-float-unary-instruction round)
+(define-float-unary-instruction ceiling)
+(define-float-unary-instruction floor)
+(define-float-unary-instruction truncate)
+(define-float-unary-instruction log)
+(define-float-unary-instruction exp)
+(define-float-unary-instruction cos)
+(define-float-unary-instruction sin)
+(define-float-unary-instruction tan)
+(define-float-unary-instruction acos)
+(define-float-unary-instruction asin)
+(define-float-unary-instruction atan)
+
+(define-abbreviation (define-generic-binary-instruction symbol)
+  (lambda (form)
+    (let ((name (cadr form)))
+      `((DEFINE-CODE-SEQUENCE INSTRUCTION
+	  (,name (_ TARGET WORD-REGISTER)
+		 (_ SOURCE1 WORD-REGISTER)
+		 (_ SOURCE2 WORD-REGISTER))
+	  TARGET
+	  SOURCE1
+	  SOURCE2)
+	(DEFINE-CODE-SEQUENCE INSTRUCTION
+	  (,name (_ TARGET FLOAT-REGISTER)
+		 (_ SOURCE1 FLOAT-REGISTER)
+		 (_ SOURCE2 FLOAT-REGISTER))
+	  TARGET
+	  SOURCE1
+	  SOURCE2)))))
+
+(define-generic-binary-instruction +)
+(define-generic-binary-instruction -)
+(define-generic-binary-instruction *)
+
+(define-abbreviation (define-word-binary-instruction symbol)
+  (lambda (form)
+    `((DEFINE-CODE-SEQUENCE INSTRUCTION
+	(,(cadr form) (_ TARGET WORD-REGISTER)
+		      (_ SOURCE1 WORD-REGISTER)
+		      (_ SOURCE2 WORD-REGISTER))
+	TARGET
+	SOURCE1
+	SOURCE2))))
+
+(define-word-binary-instruction quotient)
+(define-word-binary-instruction remainder)
+(define-word-binary-instruction lsh)
+(define-word-binary-instruction and)
+(define-word-binary-instruction andc)
+(define-word-binary-instruction or)
+(define-word-binary-instruction xor)
+(define-word-binary-instruction max-unsigned)
+(define-word-binary-instruction min-unsigned)
+
+(define-abbreviation (define-float-binary-instruction symbol)
+  (lambda (form)
+    `((DEFINE-CODE-SEQUENCE INSTRUCTION
+	(,(cadr form) (_ TARGET FLOAT-REGISTER)
+		      (_ SOURCE1 FLOAT-REGISTER)
+		      (_ SOURCE2 FLOAT-REGISTER))
+	TARGET
+	SOURCE1
+	SOURCE2))))
+
+(define-float-binary-instruction /)
+(define-float-binary-instruction atan2)
\ No newline at end of file
diff --git a/src/compiler/machines/svm/assembler-runtime.scm b/src/compiler/machines/svm/assembler-runtime.scm
new file mode 100644
index 000000000..76e95c05c
--- /dev/null
+++ b/src/compiler/machines/svm/assembler-runtime.scm
@@ -0,0 +1,908 @@
+#| -*-Scheme-*-
+
+$Id$
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+    1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+    2006, 2007, 2008 Massachusetts Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; SVM assembler: runtime
+
+(declare (usual-integrations))
+
+;;;; Datatypes
+
+;;; The model for an assembler consists of a group of "coding types",
+;;; each of which represents a group of interchangeable assembler
+;;; expressions that are distinguished by a unique code byte.  For
+;;; example, the "instruction" coding type has a number of possible
+;;; machine instructions, which are distinguished by an opcode byte.
+
+(define-record-type <rt-coding-type>
+    (make-rt-coding-type name defns)
+    rt-coding-type?
+  (name rt-coding-type-name)
+  (defns rt-coding-type-defns))
+
+;;; Each coding type has a number of definitions, each of which
+;;; represents the code sequence associated with a particular value of
+;;; the coding-type's code byte.  Each definition has a pattern (or
+;;; template) that specifies the syntax of the sequence, and
+;;; procedures to encode or decode the sequence.  There is also a
+;;; unique name (a symbol) and a unique code (a byte value); the code
+;;; is optional and may be #F.
+
+(define-record-type <rt-defn>
+    (%make-rt-defn name code pattern pvars encoder decoder)
+    rt-defn?
+  (name rt-defn-name)
+  (code rt-defn-code)
+  (pattern rt-defn-pattern)
+  (pvars rt-defn-pvars)
+  (encoder rt-defn-encoder)
+  (decoder rt-defn-decoder))
+
+(define (make-rt-defn name code pattern encoder decoder)
+  (%make-rt-defn name code pattern (parse-pattern pattern) encoder decoder))
+
+(define-record-type <rt-instance>
+    (make-rt-instance defn pvals)
+    rt-instance?
+  (defn rt-instance-defn)
+  (pvals rt-instance-pvals))
+
+(define (rt-instance-pattern instance)
+  (rt-defn-pattern (rt-instance-defn instance)))
+
+(define (rt-instance-pvars instance)
+  (rt-defn-pvars (rt-instance-defn instance)))
+
+(define (rt-instance-encoder instance)
+  (rt-defn-encoder (rt-instance-defn instance)))
+
+(define (rt-instance-pval name instance)
+  (let loop
+      ((pvars (rt-instance-pvars instance))
+       (pvals (rt-instance-pvals instance)))
+    (if (not (pair? pvars))
+	(error:bad-range-argument name 'RT-INSTANCE-PVAL))
+    (if (not (pair? pvals))
+	(error:bad-range-argument instance 'RT-INSTANCE-PVAL))
+    (if (eq? (pvar-name (car pvars)) name)
+	(car pvals)
+	(loop (cdr pvars) (cdr pvals)))))
+
+;;; The assembler maintains a symbol table that tracks the values of
+;;; labels and defined constants.  The bindings in the symbol table
+;;; are typed.
+
+(define-record-type <symbol-binding>
+    (make-symbol-binding name type value)
+    symbol-binding?
+  (name symbol-binding-name)
+  (type symbol-binding-type)
+  (value symbol-binding-value))
+
+(define (make-symbol-table)
+  (make-eq-hash-table))
+
+(define (define-symbol name type value symbol-table)
+  (hash-table/get symbol-table name (make-symbol-binding name type value)))
+
+(define (lookup-symbol name symbol-table)
+  (hash-table/get symbol-table name #f))
+
+;;;; Top level
+
+;;; **** where are real top-level entries? ****
+
+(define (match-rt-coding-type name expression coding-types symbol-table)
+  (let loop ((defns (rt-coding-type-defns (rt-coding-type name coding-types))))
+    (and (pair? defns)
+	 (let ((pvals
+		(match-pattern (rt-defn-pattern (car defns))
+			       expression
+			       coding-types
+			       symbol-table)))
+	   (if pvals
+	       (make-rt-instance (car defns) pvals)
+	       (loop (cdr defns)))))))
+
+(define (decode-rt-coding-type name read-byte coding-types)
+  (let ((type (rt-coding-type name coding-types))
+	(code (read-byte)))
+    (let ((rcd
+	   (find-matching-item (rt-coding-type-defns type)
+	     (lambda (rcd)
+	       (eqv? (rt-defn-code rcd) code)))))
+      (if (not rcd)
+	  (error "No matching code:" code type))
+      (make-rt-instance rcd ((rt-defn-decoder rcd) read-byte coding-types)))))
+
+(define (rt-coding-type name coding-types)
+  (or (find-matching-item coding-types
+	(lambda (rt-coding-type)
+	  (eq? (rt-coding-type-name rt-coding-type) name)))
+      (error:bad-range-argument name 'RT-CODING-TYPE)))
+
+;;;; Patterns
+
+(define (parse-pattern pattern)
+  (reverse!
+   (let ((lose (lambda () (error "Ill-formed pattern:" pattern))))
+     (let loop ((pattern pattern) (pvars '()))
+       (if (pair? pattern)
+	   (if (eq? (car pattern) '_)
+	       (begin
+		 (if (not (and (pair? (cdr pattern))
+				   (symbol? (cadr pattern))
+				   (pair? (cddr pattern))
+				   (symbol? (caddr pattern))
+				   (null? (cdddr pattern))))
+		     (lose))
+		 (if (there-exists? pvars
+		       (lambda (pv)
+			 (eq? (pvar-name pv) (pvar-name pattern))))
+		     ;; Don't add duplicate pvar.
+		     pvars
+		     (cons pattern pvars)))
+	       (begin
+		 (if (not (list? (cdr pattern)))
+		     (lose))
+		 (let traverse
+		     ((items (cdr pattern))
+		      (pvars (loop (car pattern) pvars)))
+		   (if (pair? items)
+		       (traverse (cdr items) (loop (car items) pvars))
+		       pvars))))
+	   (begin
+	     (if (not (or (symbol? pattern)
+			  (exact-integer? pattern)
+			  (flo:flonum? pattern)
+			  (boolean? pattern)
+			  (null? pattern)))
+		 (lose))
+	     pvars))))))
+
+(define (pvar? object) (and (pair? object) (eq? (car object) '_)))
+(define-integrable (make-pvar name type) `(_ ,name ,type))
+(define-integrable (pvar-name pv) (cadr pv))
+(define-integrable (pvar-type pv) (caddr pv))
+
+(define (match-pattern pattern expression coding-types symbol-table)
+  (let loop ((pattern pattern) (expression expression) (pvals '()))
+    (if (pair? pattern)
+	(if (eq? (car pattern) '_)
+	    (let ((pvt (lookup-pvar-type (pvar-type pattern))))
+	      (if pvt
+		  (and (or ((pvt-predicate pvt) expression)
+			   (eq? (match-symbolic-expression expression
+							   symbol-table)
+				(pvt-sb-type pvt)))
+		       (cons expression pvals))
+		  (let ((instance
+			 (match-rt-coding-type (pvar-type pattern)
+					       expression
+					       coding-types
+					       symbol-table)))
+		    (and instance
+			 (cons instance pvals)))))
+	    (let traverse
+		((patterns pattern)
+		 (expressions expression)
+		 (pvals pvals))
+	      (if (pair? patterns)
+		  (and (pair? expressions)
+		       (let ((pvals
+			      (loop (car patterns)
+				    (car expressions)
+				    pvals)))
+			 (and pvals
+			      (traverse (cdr patterns)
+					(cdr expressions)
+					pvals))))
+		  (and (null? expressions)
+		       pvals))))
+	(and (eqv? pattern expression)
+	     pvals))))
+
+(define (rt-instance-expression instance)
+  (let loop
+      ((pattern (rt-instance-pattern instance))
+       (pvals (rt-instance-pvals instance))
+       (k
+	(lambda (expression pvals)
+	  pvals
+	  expression)))
+    (if (pair? pattern)
+	(if (eq? (car pattern) '_)
+	    (k (let ((pval (car pvals)))
+		 (if (rt-instance? pval)
+		     (rt-instance-expression pval)
+		     pval))
+	       (cdr pvals))
+	    (let traverse ((patterns pattern) (pvals pvals) (expressions '()))
+	      (if (pair? patterns)
+		  (loop (car patterns)
+			pvals
+			(lambda (expression pvals)
+			  (traverse (cdr patterns)
+				    pvals
+				    (cons expression expressions))))
+		  (k (reverse! expressions) pvals))))
+	(k pattern pvals))))
+
+;;;; Instructions
+
+(define-syntax define-inst
+  (sc-macro-transformer
+   (lambda (form environment)
+     (if (syntax-match? '(SYMBOL * SYMBOL) (cdr form))
+	 (let ((tag (cadr form))
+	       (params (cddr form)))
+	   (let ((name (symbol-append 'INST: tag)))
+	     `(BEGIN
+		(DEFINE-INTEGRABLE (,name ,@params)
+		  (LIST (LIST ',tag ,@params)))
+		(DEFINE-INTEGRABLE (,(symbol-append name '?) INST)
+		  (EQ? (CAR INST) ',tag)))))
+	 (ill-formed-syntax form)))))
+
+(define-syntax define-unary-operations
+  (sc-macro-transformer
+   (lambda (form environment)
+     (if (syntax-match? '(* SYMBOL) (cdr form))
+	 `(BEGIN
+	    ,@(let loop ((names (cdr form)))
+		(if (pair? names)
+		    (cons `(DEFINE-INST ,(car names) TARGET SOURCE)
+			  (loop (cdr names)))
+		    '())))
+	 (ill-formed-syntax form)))))
+
+(define-syntax define-generic-unary-operations
+  (sc-macro-transformer
+   (lambda (form environment)
+     (if (syntax-match? '(* SYMBOL) (cdr form))
+	 `(BEGIN
+	    ,@(let loop ((names (cdr form)))
+		(if (pair? names)
+		    (cons `(DEFINE-INST ,(car names) TYPE TARGET SOURCE)
+			  (loop (cdr names)))
+		    '())))
+	 (ill-formed-syntax form)))))
+
+(define-syntax define-binary-operations
+  (sc-macro-transformer
+   (lambda (form environment)
+     (if (syntax-match? '(* SYMBOL) (cdr form))
+	 `(BEGIN
+	    ,@(let loop ((names (cdr form)))
+		(if (pair? names)
+		    (cons `(DEFINE-INST ,(car names) TARGET SOURCE1 SOURCE2)
+			  (loop (cdr names)))
+		    '())))
+	 (ill-formed-syntax form)))))
+
+(define-syntax define-generic-binary-operations
+  (sc-macro-transformer
+   (lambda (form environment)
+     (if (syntax-match? '(* SYMBOL) (cdr form))
+	 `(BEGIN
+	    ,@(let loop ((names (cdr form)))
+		(if (pair? names)
+		    (cons `(DEFINE-INST ,(car names) TYPE
+			     TARGET SOURCE1 SOURCE2)
+			  (loop (cdr names)))
+		    '())))
+	 (ill-formed-syntax form)))))
+
+(define-inst store size source address)
+(define-inst load size target address)
+(define-inst load-address target address)
+(define-inst load-immediate target value)
+(define-inst copy-block size size-type from to)
+
+(define (load-immediate-operand? n)
+  (or (and (exact-integer? n)
+	   (<= #x80000000 n < #x100000000))
+      (flo:flonum? n)))
+
+;; TYPE and DATUM can be constants or registers; address is a register.
+(define-inst load-pointer target type address)
+(define-inst load-non-pointer target type datum)
+
+(define-inst label label)
+(define-inst entry-point label)
+
+(define-inst jump address)
+
+(define (inst:trap n . args)
+  (list (cons* 'TRAP n args)))
+
+(define (inst:conditional-jump condition source arg3 #!optional arg4)
+  (list (cons* 'CONDITIONAL-JUMP
+	       condition
+	       source
+	       arg3
+	       (if (default-object? arg4) '() (list arg4)))))
+
+(define (inst:conditional-jump? inst)
+  (eq? (car inst) 'CONDITIONAL-JUMP))
+
+;; N-ELTS is a constant or a register.
+(define-inst flonum-header target n-elts)
+
+(define-inst datum-u8 expression)
+(define-inst datum-u16 expression)
+(define-inst datum-u32 expression)
+(define-inst datum-s8 expression)
+(define-inst datum-s16 expression)
+(define-inst datum-s32 expression)
+
+(define-generic-unary-operations
+  copy negate increment decrement abs)
+
+(define-unary-operations
+  object-type object-datum object-address
+  fixnum->integer integer->fixnum address->integer integer->address
+  not
+  sqrt round ceiling floor truncate
+  log exp cos sin tan acos asin atan
+  flonum-align flonum-length)
+
+(define-generic-binary-operations
+  + - *)
+
+(define-binary-operations
+  quotient remainder
+  lsh and andc or xor
+  max-unsigned min-unsigned
+  / atan2)
+
+;;;; Memory addressing
+
+(define-syntax define-ea
+  (sc-macro-transformer
+   (lambda (form environment)
+     (if (syntax-match? '(SYMBOL * SYMBOL) (cdr form))
+	 (let ((tag (cadr form))
+	       (params (cddr form)))
+	   (let ((name (symbol-append 'EA: tag)))
+	     `(BEGIN
+		(DEFINE-INTEGRABLE (,name ,@params)
+		  (INST-EA (,tag ,@(map (lambda (p) `(UNQUOTE p)) params))))
+		(DEFINE-INTEGRABLE (,(symbol-append name '?) EA)
+		  (AND (PAIR? EA)
+		       (EQ? (CAR EA) ',tag))))))
+	 (ill-formed-syntax form)))))
+
+(define-ea indirect base)
+(define-ea offset base offset scale)
+(define-ea indexed base offset oscale index iscale)
+(define-ea pre-decrement base scale)
+(define-ea pre-increment base scale)
+(define-ea post-decrement base scale)
+(define-ea post-increment base scale)
+(define-ea pc-relative offset)
+
+(define (memory-reference? ea)
+  (or (ea:indirect? ea)
+      (ea:offset? ea)
+      (ea:indexed? ea)
+      (ea:pre-decrement? ea)
+      (ea:pre-increment? ea)
+      (ea:post-decrement? ea)
+      (ea:post-increment? ea)
+      (ea:pc-relative? ea)))
+
+(define (ea:address label)
+  (ea:pc-relative `(- ,label *PC*)))
+
+(define (ea:stack-pop)
+  (ea:post-increment regnum:stack-pointer 'WORD))
+
+(define (ea:stack-push)
+  (ea:pre-decrement regnum:stack-pointer 'WORD))
+
+(define (ea:stack-ref index)
+  (ea:offset regnum:stack-pointer index 'WORD))
+
+(define (ea:alloc-word)
+  (ea:post-increment regnum:free-pointer 'WORD))
+
+(define (ea:alloc-byte)
+  (ea:post-increment regnum:free-pointer 'BYTE))
+
+(define (ea:alloc-float)
+  (ea:post-increment regnum:free-pointer 'FLOAT))
+
+;;;; Traps
+
+(define-syntax define-traps
+  (sc-macro-transformer
+   (lambda (form environment)
+     environment
+     `(BEGIN
+	,@(map (lambda (name)
+		 `(DEFINE ,(symbol-append 'TRAP: name)
+		    (INST:TRAP ',name)))
+	       (cddr form))))))
+
+(define-traps
+  ;; This group doesn't return; don't push return address.
+  apply lexpr-apply cache-reference-apply lookup-apply
+  primitive-apply primitive-lexpr-apply
+  error primitive-error
+  &+ &- &* &/ 1+ -1+ quotient remainder modulo
+  &= &< &> zero? positive? negative?
+
+  ;; This group returns; push return address.
+  link conditionally-serialize
+  interrupt-closure interrupt-dlink interrupt-procedure
+  interrupt-continuation interrupt-ic-procedure
+  reference-trap safe-reference-trap assignment-trap unassigned?-trap
+  lookup safe-lookup set! unassigned? define unbound? access)
+
+;;;; Machine registers
+
+(define-integrable number-of-machine-registers 512)
+(define-integrable number-of-temporary-registers 512)
+
+(define-syntax define-fixed-registers
+  (sc-macro-transformer
+   (lambda (form environment)
+     (if (syntax-match? '(* SYMBOL) (cdr form))
+	 (let ((alist
+		(let loop ((names (cdr form)) (index 0))
+		  (if (pair? names)
+		      (cons (cons (car names) index)
+			    (loop (cdr names) (+ index 1)))
+		      '()))))
+	   `(BEGIN
+	      ,@(map (lambda (p)
+		       `(DEFINE-INTEGRABLE ,(symbol-append 'REGNUM: (car p))
+			  ,(cdr p)))
+		     alist)
+	      (DEFINE FIXED-REGISTERS ',alist)))
+	 (ill-formed-syntax form)))))
+
+(define-fixed-registers
+  stack-pointer
+  dynamic-link
+  free-pointer
+  value
+  environment)
+
+(define-integrable regnum:float-0 256)
+
+(define (any-register? object)
+  (and (index-fixnum? object)
+       (fix:< object number-of-machine-registers)
+       object))
+
+(define (word-register? object)
+  (and (any-register? object)
+       (fix:< object regnum:float-0)
+       object))
+
+(define (float-register? object)
+  (and (any-register? object)
+       (fix:>= object regnum:float-0)
+       (fix:- object regnum:float-0)))
+
+(define available-machine-registers
+  (let loop ((r regnum:environment))
+    (if (< r number-of-machine-registers)
+	(cons r (loop (+ r 1)))
+	'())))
+
+;;;; Register references
+
+(define register-reference
+  (let ((references
+	 (list->vector
+	  (map (lambda (r) `(R ,r)) available-machine-registers))))
+    (lambda (register)
+      (guarantee-limited-index-fixnum register
+				      number-of-machine-registers
+				      'REGISTER-REFERENCE)
+      (vector-ref references register))))
+
+(define (register-reference? object)
+  (and (pair? object)
+       (eq? (car object) 'R)
+       (pair? (cdr object))
+       (index-fixnum? (cadr object))
+       (fix:< (cadr object) number-of-machine-registers)
+       (null? (cddr object))))
+
+(define (word-register-reference? object)
+  (and (pair? object)
+       (eq? (car object) 'R)
+       (pair? (cdr object))
+       (index-fixnum? (cadr object))
+       (fix:< (cadr object) regnum:float-0)
+       (null? (cddr object))))
+
+(define (float-register-reference? object)
+  (and (pair? object)
+       (eq? (car object) 'R)
+       (pair? (cdr object))
+       (index-fixnum? (cadr object))
+       (fix:>= (cadr object) regnum:float-0)
+       (fix:< (cadr object) number-of-machine-registers)
+       (null? (cddr object))))
+
+(define-guarantee register-reference "register reference")
+
+(define (reference->register reference)
+  (guarantee-register-reference reference 'REFERENCE->REGISTER)
+  (cadr reference))
+
+;;;; Symbolic expressions
+
+(define (match-symbolic-expression expression symbol-table)
+  (let loop ((expression expression))
+    (cond ((symbol? expression)
+	   (let ((binding (lookup-symbol expression symbol-table)))
+	     (and binding
+		  (symbol-binding-type binding))))
+	  ((and (pair? expression)
+		(symbol? (car expression))
+		(list? (cdr expression))
+		(lookup-symbolic-operator (car expression) #f))
+	   => (lambda (op)
+		(let ((types
+		       (map (lambda (expression)
+			      (cond ((se-integer? expression) 'INTEGER)
+				    ((se-float? expression) 'FLOAT)
+				    (else (loop expression))))
+			    (cdr expression))))
+		  (and (pair? types)
+		       (for-all? types (lambda (type) type))
+		       ((symbolic-operator-matcher op) types)))))
+	  (else #f))))
+
+(define (symbolic-pval? pval)
+  (or (symbol? pval)
+      (and (pair? pval)
+	   (symbol? (car pval)))))
+
+(define (sb-type:address? type) (eq? type 'ADDRESS))
+(define (sb-type:integer? type) (eq? type 'INTEGER))
+(define (sb-type:float? type) (eq? type 'FLOAT))
+
+(define (define-symbolic-operator name matcher evaluator)
+  (hash-table/put! symbolic-operators name (cons matcher evaluator)))
+
+(define (symbolic-operator-matcher op)
+  (car op))
+
+(define (symbolic-operator-evaluator op)
+  (cdr op))
+
+(define (lookup-symbolic-operator name error?)
+  (or (hash-table/get symbolic-operators name #f)
+      (error:bad-range-argument name #f)))
+
+(define symbolic-operators
+  (make-eq-hash-table))
+
+(define-integrable (se-integer? object)
+  (exact-integer? object))
+
+(define-integrable (se-float? object)
+  (flo:flonum? object))
+
+(define (se-address? object)
+  ???)
+
+(define (se-address:+ address offset)
+  ???)
+
+(define (se-address:- address1 address2)
+  ???)
+
+(define-symbolic-operator '+
+  (lambda (types)
+    (and (or (for-all? types sb-type:integer?)
+	     (for-all? types sb-type:float?)
+	     (and (sb-type:address? (car types))
+		  (for-all? (cdr types) sb-type:integer?)))
+	 (car types)))
+  (lambda (pvals)
+    (if (se-address? (car pvals))
+	(se-address:+ (car pvals) (apply + (cdr pvals)))
+	(apply + pvals))))
+
+(define-symbolic-operator '-
+  (lambda (types)
+    (and (fix:= (length types) 2)
+	 (let ((t1 (car types))
+	       (t2 (cadr types)))
+	   (cond ((and (sb-type:address? t1) (sb-type:integer? t2)) t1)
+		 ((not (eq? t1 t2)) #f)
+		 ((or (sb-type:integer? t1) (sb-type:float? t1)) t1)
+		 ((sb-type:address? t1) 'INTEGER)
+		 (else #f)))))
+  (lambda (pvals)
+    (let ((pv1 (car pvals))
+	  (pv2 (cadr pvals)))
+      (if (se-address? pv1)
+	  (if (se-address? pv2)
+	      (se-address:- pv1 pv2)
+	      (se-address:+ pv1 (- pv2)))
+	  (- pv1 pv2)))))
+
+(define-symbolic-operator '*
+  (lambda (types)
+    (and (or (for-all? types sb-type:integer?)
+	     (for-all? types sb-type:float?))
+	 (car types)))
+  (lambda (pvals)
+    (apply * pvals)))
+
+(define-symbolic-operator '/
+  (lambda (types)
+    (and (fix:= (length types) 2)
+	 (let ((t1 (car types))
+	       (t2 (cadr types)))
+	   (and (eq? t1 t2)
+		(or (sb-type:integer? t1)
+		    (sb-type:float? t1))
+		t1))))
+  (lambda (pvals)
+    (let ((pv1 (car pvals))
+	  (pv2 (cadr pvals)))
+      (if (exact-integer? pv1)
+	  (quotient pv1 pv2)
+	  (/ pv1 pv2)))))
+
+;;;; Pattern-variable types
+
+(define-record-type <pvt>
+    (make-pvt name abbreviation sb-type predicate encoder decoder)
+    pvt?
+  (name pvt-name)
+  (abbreviation pvt-abbreviation)
+  (sb-type pvt-sb-type)
+  (predicate pvt-predicate)
+  (encoder pvt-encoder)
+  (decoder pvt-decoder))
+
+(define (lookup-pvar-type keyword)
+  (hash-table/get pvar-type-table keyword #f))
+
+(define (pvar-types)
+  (hash-table/datum-list pvar-type-table))
+
+(define pvar-type-table
+  (make-eq-hash-table))
+
+(define (define-pvt name abbreviation sb-type predicate encoder decoder)
+  (hash-table/put! pvar-type-table
+		   name
+		   (make-pvt name abbreviation sb-type
+			     predicate encoder decoder))
+  name)
+
+(define (define-pvt-unsigned n-bytes)
+  (let ((n-bits (* n-bytes 8)))
+    (let ((limit (expt 2 n-bits)))
+      (define-pvt (symbol 'UNSIGNED- n-bits) (symbol 'U n-bits) 'INTEGER
+	(lambda (object)
+	  (and (exact-nonnegative-integer? object)
+	       (< object limit)))
+	(symbol 'ENCODE-UNSIGNED-INTEGER- n-bits)
+	(symbol 'DECODE-UNSIGNED-INTEGER- n-bits)))))
+
+(define-pvt-unsigned 1)
+(define-pvt-unsigned 2)
+(define-pvt-unsigned 4)
+
+(define (define-pvt-signed n-bytes)
+  (let ((n-bits (* n-bytes 8)))
+    (let ((limit (expt 2 (- n-bits 1))))
+      (define-pvt (symbol 'SIGNED- n-bits) (symbol 'S n-bits) 'INTEGER
+	(lambda (object)
+	  (and (exact-integer? object)
+	       (>= object (- limit))
+	       (< object limit)))
+	(symbol 'ENCODE-SIGNED-INTEGER- n-bits)
+	(symbol 'DECODE-SIGNED-INTEGER- n-bits)))))
+
+(define-pvt-signed 1)
+(define-pvt-signed 2)
+(define-pvt-signed 4)
+
+(define-pvt 'TYPE-WORD 'TC 'INTEGER
+  (lambda (object)
+    (and (se-integer? object)
+	 (< object #x40)))
+  'ENCODE-UNSIGNED-INTEGER-8
+  'DECODE-UNSIGNED-INTEGER-8)
+
+(define-pvt 'FLOAT 'FLT 'FLOAT
+  (lambda (object)
+    (se-float? object))
+  'ENCODE-FLOAT
+  'DECODE-FLOAT)
+
+(define-pvt 'REGISTER 'R 'REGISTER
+  register-reference?
+  'ENCODE-RREF
+  'DECODE-RREF)
+
+(define-pvt 'WORD-REGISTER 'WR 'REGISTER
+  word-register-reference?
+  'ENCODE-RREF
+  'DECODE-RREF)
+
+(define-pvt 'FLOAT-REGISTER 'FR 'REGISTER
+  float-register-reference?
+  'ENCODE-RREF
+  'DECODE-RREF)
+
+;;;; Primitive codecs
+
+(define (encode-unsigned-integer-8 n write-byte)
+  (write-byte (remainder n #x100))
+  (write-byte (quotient n #x100)))
+
+(define (encode-unsigned-integer-16 n write-byte)
+  (write-byte (remainder n #x100))
+  (write-byte (quotient n #x100)))
+
+(define (encode-unsigned-integer-32 n write-byte)
+  (encode-unsigned-integer-16 (remainder n #x10000) write-byte)
+  (encode-unsigned-integer-16 (quotient n #x10000) write-byte))
+
+(define (encode-unsigned-integer-64 n write-byte)
+  (encode-unsigned-integer-32 (remainder n #x100000000) write-byte)
+  (encode-unsigned-integer-32 (quotient n #x100000000) write-byte))
+
+(define (decode-unsigned-integer-8 read-byte)
+  (read-byte))
+
+(define (decode-unsigned-integer-16 read-byte)
+  (let ((b0 (read-byte)))
+    (fix:+ (fix:lsh (read-byte) 8) b0)))
+
+(define (decode-unsigned-integer-32 read-byte)
+  (let ((d0 (decode-unsigned-integer-16 read-byte)))
+    (+ (* (decode-unsigned-integer-16 read-byte) #x10000) d0)))
+
+(define (decode-unsigned-integer-64 read-byte)
+  (let ((d0 (decode-unsigned-integer-32 read-byte)))
+    (+ (* (decode-unsigned-integer-32 read-byte) #x100000000) d0)))
+
+(define (encode-signed-integer-8 n write-byte)
+  (write-byte (if (fix:< n 0)
+		  (fix:+ n #x100)
+		  n)))
+
+(define (encode-signed-integer-16 n write-byte)
+  (encode-unsigned-integer-16 (if (fix:< n 0)
+				  (fix:+ n #x10000)
+				  n)
+			      write-byte))
+
+(define (encode-signed-integer-32 n write-byte)
+  (encode-unsigned-integer-32 (if (< n 0)
+				  (+ n #x100000000)
+				  n)
+			      write-byte))
+
+(define (encode-signed-integer-64 n write-byte)
+  (encode-unsigned-integer-64 (if (< n 0)
+				  (+ n #x10000000000000000)
+				  n)
+			      write-byte))
+
+(define (decode-signed-integer-8 read-byte)
+  (let ((n (read-byte)))
+    (if (fix:< n #x80)
+	n
+	(fix:- n #x100))))
+
+(define (decode-signed-integer-16 read-byte)
+  (let ((n (decode-unsigned-integer-16 read-byte)))
+    (if (fix:< n #x8000)
+	n
+	(fix:- n #x10000))))
+
+(define (decode-signed-integer-32 read-byte)
+  (let ((n (decode-unsigned-integer-32 read-byte)))
+    (if (< n #x80000000)
+	n
+	(- n #x100000000))))
+
+(define (decode-signed-integer-64 read-byte)
+  (let ((n (decode-unsigned-integer-64 read-byte)))
+    (if (< n #x8000000000000000)
+	n
+	(- n #x10000000000000000))))
+
+(define (encode-float x write-byte)
+  (receive (n e) (float->integers x)
+    (encode-signed-integer-64 n write-byte)
+    (encode-signed-integer-16 e write-byte)))
+
+(define (decode-float read-byte)
+  (let ((n (decode-signed-integer-64 read-byte)))
+    (integers->float n (decode-signed-integer-16 read-byte))))
+
+(define (float->integers x)
+  (let ((x>0
+	 (let ((done
+		(lambda (x e)
+		  (let ((n (inexact->exact x)))
+		    (if (not (exact-nonnegative-integer? n))
+			(error "Flonum decode failed:" x))
+		    (values n e)))))
+	   (lambda (x)
+	     (if (and (> x 1)
+		      (= x (/ x 2)))
+		 (error "Can't encode infinity:" x))
+	     (let ((n (expt 2 flo:significand-digits-base-2)))
+	       (let ((n/2 (/ n 2)))
+		 (if (< x n/2)
+		     (let loop ((x (* x 2)) (e -1))
+		       (if (< x n/2)
+			   (loop (* x 2) (- e 1))
+			   (done x e)))
+		     (let loop ((x x) (e 0))
+		       (if (>= x n)
+			   (loop (/ x 2) (+ e 1))
+			   (done x e))))))))))
+    (cond ((> x 0)
+	   (x>0 x))
+	  ((< x 0)
+	   (receive (n e) (x>0 (- x))
+	     (values (- n) e)))
+	  ((= x 0)
+	   (values 0 0))
+	  (else
+	   (error "Can't encode NaN:" x)))))
+
+(define (integers->float n e)
+  (if (= n 0)
+      0.
+      (let ((x (exact->inexact n)))
+	(cond ((> e 0)
+	       (let loop ((x (* x 2)) (e (- e 1)))
+		 (if (> e 0)
+		     (loop (* x 2) (- e 1))
+		     x)))
+	      ((< e 0)
+	       (let loop ((x (/ x 2)) (e (+ e 1)))
+		 (if (< e 0)
+		     (loop (/ x 2) (+ e 1))
+		     x)))
+	      (else x)))))
+
+(define (encode-rref rref write-byte)
+  (encode-unsigned-integer-8 (reference->register rref) write-byte))
+
+(define (decode-rref read-byte)
+  (register-reference (decode-unsigned-integer-8 read-byte)))
\ No newline at end of file
-- 
2.25.1