#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/asmmac.scm,v 1.3 1987/07/08 22:00:25 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/asmmac.scm,v 1.4 1987/07/22 17:15:34 jinx Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
(lambda (pattern actions)
(if (null? actions)
(error "DEFINE-INSTRUCTION: Too few forms")
- (parse-word (car actions) (cdr actions))))))))
+ (parse-instruction (car actions) (cdr actions) false)))))))
(define (compile-database cases procedure)
`(LIST
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/bittop.scm,v 1.2 1987/07/16 10:14:16 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/bittop.scm,v 1.3 1987/07/22 17:14:09 jinx Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
(vector-ref this 1)
(vector-ref this 2)))
((VARIABLE-WIDTH-EXPRESSION)
- (let ((sel (vector-ref this 3)))
- (evaluation (selector/handler sel)
+ (let ((sel (car (vector-ref this 3))))
+ (evaluation (variable-handler-wrapper (selector/handler sel))
(vector-ref this 1)
(selector/length sel))))
(else
((VARIABLE-WIDTH-EXPRESSION)
(process-variable-width
(vector 'VARIABLE-WIDTH-EXPRESSION
- (cadr directive)
+ (cadr this)
(if (null? pc-stack)
(make-machine-interval pcmin pcmax)
(car pc-stack))
- (map list->vector (cddr directive)))))
+ (map list->vector (cddr this)))))
((GROUP)
(new-directive! (vector 'TICK true))
(loop (append (cdr this)
(define (phase-1 directives)
(define (loop rem pcmin pcmax pc-stack vars)
(if (null? rem)
- (let ((ecmin (pad pcmin))
+ (let ((emin (pad pcmin))
(emax (+ pcmax maximum-padding-length)))
(symbol-table-define! *the-symbol-table*
*end-label*
(v (vector 'EVALUATION
(vector-ref var 1) ; Expression
(selector/length sel)
- (selector/handler sel))))
+ (variable-handler-wrapper (selector/handler sel)))))
(vector-set! var 0 'FIXED-WIDTH-GROUP)
(vector-set! var 1 l)
(vector-set! var 2 (list v))
(vector-set! var 3 '())))
+\f
+(define (variable-handler-wrapper handler)
+ (lambda (value)
+ (let ((l (handler value)))
+ (if (null? l)
+ (bit-string-allocate 0)
+ (list->bit-string l)))))
+
+(define (list->bit-string l)
+ (if (null? (cdr l))
+ (car l)
+ (bit-string-append (car l)
+ (list->bit-string (cdr l)))))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/bitutl.scm,v 1.1 1987/07/15 03:00:44 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/bitutl.scm,v 1.2 1987/07/22 17:14:31 jinx Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
(declare (integrate sel))
(vector-ref sel 1))
-(define (selector/handler sel)
+(define (selector/length sel)
(declare (integrate sel))
(vector-ref sel 2))
-(define (selector/length sel)
+(define (selector/handler sel)
(declare (integrate sel))
(vector-ref sel 3))
\f
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/syntax.scm,v 1.16 1987/07/15 02:57:43 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/syntax.scm,v 1.17 1987/07/22 17:15:00 jinx Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
(define instructions
'())
-
+\f
(define (integer-syntaxer expression coercion-type size)
(let ((coercion (make-coercion-name coercion-type size)))
(if (integer? expression)
`',((lexical-reference coercion-environment coercion) expression)
- `(SYNTAX-EVALUATION ,expression ,coercion))))
-\f
+ `(SYNTAX-EVALUATION ,expression ,coercion))))
+
(define (syntax-evaluation expression coercion)
(if (integer? expression)
(coercion expression)
(receiver (car components) false))
(else (receiver components true)))))))
\f
+;;;; Variable width expression processing
+
+(define (choose-clause value clauses)
+ (define (in-range? value low high)
+ (and (or (null? low)
+ (<= low value))
+ (or (null? high)
+ (<= value high))))
+
+ (cond ((null? clauses)
+ (error "choose-clause: value out of range" value))
+ ((in-range? value (caar clauses) (cadar clauses))
+ (car clauses))
+ (else (choose-clause (cdr clauses)))))
+
+(define (variable-width-expression-syntaxer name expression clauses)
+ (if (integer? expression)
+ (let ((chosen (choose-clause expression clauses)))
+ `(let ((,name ,expression))
+ (declare (integrate ,name))
+ ,(cadddr chosen)))
+ `(LIST
+ (SYNTAX-VARIABLE-WIDTH-EXPRESSION
+ ,expression
+ (LIST
+ ,@(map (LAMBDA (clause)
+ `(LIST ,(car clause)
+ ,(cadr clause)
+ ,(caddr clause)
+ (LAMBDA (,name)
+ ,(cadddr clause))))
+ clauses))))))
+
+(define (syntax-variable-width-expression expression clauses)
+ (if (integer? expression) (let ((chosen (choose-clause expression clauses)))
+ ((cadddr chosen) expression))
+ (cons* 'VARIABLE-WIDTH-EXPRESSION
+ expression
+ clauses)))
+\f
;;;; Coercion Machinery
(define (make-coercion-name coercion-type size)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/inerly.scm,v 1.2 1987/07/01 21:02:47 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/inerly.scm,v 1.3 1987/07/22 17:16:22 jinx Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
(syntax-table-define early-syntax-table 'DEFINE-INSTRUCTION
(macro (opcode . patterns)
`(set! early-instructions
- (cons (list ',opcode
- ,@(map (lambda (pattern)
- `(early-parse-rule
- ',(car pattern)
- (lambda (pat vars)
- (early-make-rule
- pat
- vars
- (scode-quote
- (instruction->instruction-sequence
- ,(parse-word (cadr pattern)
- (cddr pattern)
- true)))))))
- patterns))
+ (cons
+ (list ',opcode
+ ,@(map (lambda (pattern)
+ `(early-parse-rule
+ ',(car pattern)
+ (lambda (pat vars)
+ (early-make-rule
+ pat
+ vars
+ (scode-quote
+ (instruction->instruction-sequence
+ ,(parse-instruction (cadr pattern)
+ (cddr pattern)
+ true)))))))
+ patterns))
early-instructions))))
(syntax-table-define early-syntax-table 'EXTENSION-WORD
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/insmac.scm,v 1.121 1987/07/21 18:34:23 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/insmac.scm,v 1.122 1987/07/22 17:16:31 jinx Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
\f
;;;; Utility procedures
-(define (parse-word expression tail #!optional early?)
+(define (parse-instruction expression tail early?)
(define (kernel)
- (expand-descriptors (cdr expression)
- (lambda (instruction size src dst)
- (if (zero? (remainder size 16))
- (let ((code
- (let ((code
- (let ((code (if dst `(,@dst '()) '())))
- (if src
- `(,@src ,code)
- code))))
- (if (null? tail)
- code
- `(,(if (null? code) 'CONS 'CONS-SYNTAX)
- ,(car tail)
- ,code)))))
- `(,(if (null? code) 'CONS 'CONS-SYNTAX)
- ,(optimize-group-syntax instruction
- (if (unassigned? early?) false early?))
- ,code))
- (error "PARSE-WORD: Instructions must be 16 bit multiples" size)))))
+ (case (car expression)
+ ((WORD)
+ (parse-word expression tail))
+ ((GROWING-WORD)
+ (parse-growing-word expression tail))
+ (else
+ (error "PARSE-INSTRUCTION: unknown expression" expression))))
+
(if (or (unassigned? early?) (not early?))
- (kernel)
+ (with-normal-selectors kernel)
(with-early-selectors kernel)))
+;;; Variable width instruction parsing
+
+(define (parse-growing-word expression tail)
+ (if (not (null? tail))
+ (error "PARSE-GROWING-WORD: non null tail" tail))
+ (let ((binding (cadr expression)))
+ (variable-width-expression-syntaxer
+ (car binding)
+ (cadr binding)
+ (map (lambda (clause)
+ (if (not (null? (cddr clause)))
+ (error "PARSE-GROWING-WORD: Extension found in clause" clause))
+ (expand-descriptors
+ (cdadr clause)
+ (lambda (instruction size src dst)
+ (if (not (zero? (remainder size 16)))
+ (error "PARSE-GROWING-WORD: Instructions must be 16 bit multiples"
+ size)
+ (list (caar clause) ; Range low
+ (cadar clause) ; Range high
+ size ; Width in bits
+ (collect-word instruction src dst '()))))))
+ (cddr expression)))))
+\f
+;;;; Fixed width instruction parsing
+
+(define (parse-word expression tail)
+ (expand-descriptors (cdr expression)
+ (lambda (instruction size src dst)
+ (if (zero? (remainder size 16))
+ (collect-word instruction src dst tail)
+ (error "PARSE-WORD: Instructions must be 16 bit multiples" size)))))
+
+(define (collect-word instruction src dst tail)
+ (let ((code
+ (let ((code
+ (let ((code (if dst `(,@dst '()) '())))
+ (if src
+ `(,@src ,code)
+ code))))
+ (cond ((null? tail) code)
+ ((null? (cdr tail))
+ `(,(if (null? code) 'CONS 'CONS-SYNTAX)
+ ,(car tail)
+ ,code))
+ (else
+ (error "PARSE-WORD: multiple tail elements" tail))))))
+ `(,(if (null? code) 'CONS 'CONS-SYNTAX)
+ ,(optimize-group-syntax instruction early-instruction-parsing?)
+ ,code)))
+
(define (expand-descriptors descriptors receiver)
(if (null? descriptors)
(receiver '() 0 false false)
destination)
destination*))))))))
\f
+;;;; Hooks for early instruction processing
+
+(define early-instruction-parsing? false)
(define ea-keyword-selector 'EA-KEYWORD)
(define ea-categories-selector 'EA-CATEGORIES)
(define ea-mode-selector 'EA-MODE)
(define ea-register-selector 'EA-REGISTER)
(define ea-extension-selector 'EA-EXTENSION)
+(define (with-normal-selectors handle)
+ (fluid-let ((early-instruction-parsing? false)
+ (ea-keyword-selector 'EA-KEYWORD)
+ (ea-categories-selector 'EA-CATEGORIES)
+ (ea-mode-selector 'EA-MODE)
+ (ea-register-selector 'EA-REGISTER)
+ (ea-extension-selector 'EA-EXTENSION))
+ (handle)))
+
(define (with-early-selectors handle)
- (fluid-let ((ea-keyword-selector 'EA-KEYWORD-EARLY)
+ (fluid-let ((early-instruction-parsing? true)
+ (ea-keyword-selector 'EA-KEYWORD-EARLY)
(ea-categories-selector 'EA-CATEGORIES-EARLY)
(ea-mode-selector 'EA-MODE-EARLY)
(ea-register-selector 'EA-REGISTER-EARLY)
(ea-extension-selector 'EA-EXTENSION-EARLY))
(handle)))
-
+\f
(define (expand-descriptor descriptor receiver)
(let ((size (car descriptor))
(expression (cadr descriptor))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/instr3.scm,v 1.12 1987/07/17 15:49:06 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/instr3.scm,v 1.13 1987/07/22 17:16:43 jinx Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
(declare (usual-integrations))
\f
-;;;; Control Transfer
+;;;; Control Transfer: Branch instructions
;; The size U (unknown, undecided?) means that the assembler should
-;; choose the right size. For the time being it is the same as W.
-
-(define-instruction B
- (((? c cc) B (@PCO (? o)))
- (WORD (4 #b0110)
- (4 c)
- (8 o SIGNED)))
-
- (((? c cc) B (@PCR (? l)))
- (WORD (4 #b0110)
- (4 c)
- (8 l SHORT-LABEL)))
-
- (((? c cc) W (@PCO (? o)))
- (WORD (4 #b0110)
- (4 c)
- (8 #b00000000))
- (immediate-word o))
-
- (((? c cc) W (@PCR (? l)))
- (WORD (4 #b0110)
- (4 c)
- (8 #b00000000))
- (relative-word l))
-
- ;; 68020 only
-
- (((? c cc) L (@PCO (? o)))
- (WORD (4 #b0110)
- (4 cc)
- (8 #b11111111))
- (immediate-long o))
-
- (((? c cc) L (@PCR (? l)))
- (WORD (4 #b0110)
- (4 cc)
- (8 #b11111111))
- (relative-long l))
-
- (((? c cc) U (@PCO (? o)))
- (WORD (4 #b0110)
- (4 c)
- (8 #b00000000))
- (immediate-word o))
-
- (((? c cc) U (@PCR (? l)))
- (WORD (4 #b0110)
- (4 c)
- (8 #b00000000))
- (relative-word l)))
-\f
-(define-instruction BRA
- ((B (@PCO (? o)))
- (WORD (8 #b01100000)
- (8 o SIGNED)))
-
- ((B (@PCR (? l)))
- (WORD (8 #b01100000)
- (8 l SHORT-LABEL)))
-
- ((W (@PCO (? o)))
- (WORD (16 #b0110000000000000))
- (immediate-word o))
-
- ((W (@PCR (? l)))
- (WORD (16 #b0110000000000000))
- (relative-word l))
-
- ;; 68020 only
-
- ((L (@PCO (? o)))
- (WORD (16 #b0110000011111111))
- (immediate-long o))
-
- ((L (@PCR (? l)))
- (WORD (16 #b0110000011111111))
- (relative-long l))
-
- ((U (@PCO (? o)))
- (WORD (16 #b0110000000000000))
- (immediate-word o))
-
- ((U (@PCR (? l)))
- (WORD (16 #b0110000000000000))
- (relative-word l)))
+;; choose the right size.
+
+;; When the displacement goes to 0, a NOP is issued.
+;; The instruction is hard to remove because of the workings of the
+;; branch tensioner. Note that the NOP ``kludge'' is not correct for
+;; the BSR instruction.
+
+(let-syntax
+ ((define-branch-instruction
+ (macro (opcode prefix . field)
+ `(define-instruction ,opcode
+ ((,@prefix B (@PCO (? o)))
+ (WORD ,@field
+ (8 o SIGNED)))
+
+ ((,@prefix B (@PCR (? l)))
+ (WORD ,@field
+ (8 l SHORT-LABEL)))
+
+ ((,@prefix W (@PCO (? o)))
+ (WORD ,@field
+ (8 #b00000000))
+ (immediate-word o))
+
+ ((,@prefix W (@PCR (? l)))
+ (WORD ,@field
+ (8 #b00000000))
+ (relative-word l))
+
+ ;; 68020 only
+
+ ((,@prefix L (@PCO (? o)))
+ (WORD ,@field
+ (8 #b11111111))
+ (immediate-long o))
+
+ ((,@prefix L (@PCR (? l)))
+ (WORD ,@field
+ (8 #b11111111))
+ (relative-long l))
\f
-(define-instruction BSR
- ((B (@PCO (? o)))
- (WORD (8 #b01100001)
- (8 o SIGNED)))
-
- ((B (@PCR (? o)))
- (WORD (8 #b01100001)
- (8 o SHORT-LABEL)))
-
- ((W (@PCO (? o)))
- (WORD (16 #b0110000100000000))
- (immediate-word o))
-
- ((W (@PCR (? l)))
- (WORD (16 #b0110000100000000))
- (relative-word l))
-
- ;; 68020 onlyu
-
- ((L (@PCO (? o)))
- (WORD (16 #b0110000111111111))
- (immediate-long o))
-
- ((L (@PCR (? l)))
- (WORD (16 #b0110000111111111))
- (relative-long l))
-
- ((U (@PCO (? o)))
- (WORD (16 #b0110000100000000))
- (immediate-word o))
-
- ((U (@PCR (? l)))
- (WORD (16 #b0110000100000000))
- (relative-word l)))
+ ((,@prefix U (@PCO (? o)))
+ (GROWING-WORD (disp o)
+ ((0 0)
+ (WORD (16 #b0100111001110001))) ; NOP
+ ((-128 127)
+ (WORD ,@field
+ (8 disp SIGNED)))
+ ((-32768 32767)
+ (WORD ,@field
+ (8 #b00000000)
+ (16 disp SIGNED)))
+ ((() ())
+ (WORD ,@field
+ (8 #b11111111)
+ (32 disp SIGNED)))))
+
+ ((,@prefix U (@PCR (? l)))
+ (GROWING-WORD (disp `(- ,l (+ *PC* 2)))
+ ((0 0)
+ (WORD (16 #b0100111001110001))) ; NOP
+ ((-128 127)
+ (WORD ,@field
+ (8 disp SIGNED)))
+ ((-32768 32767)
+ (WORD ,@field
+ (8 #b00000000)
+ (16 disp SIGNED)))
+ ((() ())
+ (WORD ,@field
+ (8 #b11111111)
+ (32 disp SIGNED)))))))))
+
+ (define-branch-instruction B ((? c cc)) (4 #b0110) (4 c))
+ (define-branch-instruction BRA () (8 #b01100000))
+ (define-branch-instruction BSR () (8 #b01100001)))
\f
(define-instruction DB
(((? c cc) (D (? rx)) (@PCO (? o)))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/make.scm-68040,v 1.35 1987/07/21 18:34:56 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/make.scm-68040,v 1.36 1987/07/22 17:17:01 jinx Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
(make-environment
(define :name "Liar (Bobcat 68020)")
(define :version 1)
- (define :modification 35)
+ (define :modification 36)
(define :files)
; (parse-rcs-header
-; "$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/make.scm-68040,v 1.35 1987/07/21 18:34:56 jinx Exp $"
+; "$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/make.scm-68040,v 1.36 1987/07/22 17:17:01 jinx Exp $"
; (lambda (filename version date time zone author state)
; (set! :version (car version))
; (set! :modification (cadr version))))
projects / mit-scheme.git / commitdiff