--- /dev/null
+#| -*-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))
+\f
+(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))))
+\f
+;;;; 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.")))
+\f
+(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))
+\f
+;;;; 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))
+\f
+(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)))))
+\f
+;;;; 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?)))
+\f
+(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))))
+\f
+;;;; 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)))
+ '||))
+\f
+(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)))
+\f
+;;;; 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))))
+\f
+(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)))))
+\f
+(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))
+\f
+(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)))
+\f
+(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))
+\f
+(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
--- /dev/null
+#| -*-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".
+\f
+(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)
+\f
+(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))
+\f
+(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)
+\f
+(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)
+\f
+(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)
+\f
+(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)
+\f
+(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)
+\f
+(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)
+\f
+(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
--- /dev/null
+#| -*-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))
+\f
+;;;; 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))
+\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)))
+\f
+;;;; 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))
+\f
+(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))))
+\f
+;;;; 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)
+\f
+;;;; 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))
+\f
+;;;; 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)
+\f
+;;;; 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)))
+ '())))
+\f
+;;;; 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))
+\f
+;;;; 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)
+ ???)
+\f
+(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)))))
+\f
+;;;; 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)
+\f
+;;;; 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))))
+\f
+(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
projects / mit-scheme.git / commitdiff