#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/utils.scm,v 4.12 1989/05/31 20:01:36 jinx Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/utils.scm,v 4.13 1989/08/28 18:33:09 cph Exp $
Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology
(define (side-effect-free-primitive? operator) (memq operator side-effect-free-primitives))
(define procedure-object?
- (lexical-reference system-global-environment 'PROCEDURE?))
\ No newline at end of file
+ (lexical-reference system-global-environment 'PROCEDURE?))
+
+(define (careful-object-datum object)
+ ;; This works correctly when cross-compiling.
+ (if (and (object-type? (ucode-type fixnum) object)
+ (negative? object))
+ (+ object unsigned-fixnum/upper-limit)
+ (object-datum object)))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/assmd.scm,v 1.35 1988/08/31 05:55:31 cph Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/assmd.scm,v 1.36 1989/08/28 18:33:33 cph Rel $
-Copyright (c) 1988 Massachusetts Institute of Technology
+Copyright (c) 1988, 1989 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(declare (usual-integrations))
\f
-(let-syntax ((fold
- (macro (expression)
- (eval expression system-global-environment))))
-
-(define-integrable addressing-granularity 8)
-(define-integrable scheme-object-width 32)
-(define-integrable endianness 'BIG)
+(let-syntax ((ucode-type (macro (name) `',(microcode-type name))))
(define-integrable maximum-padding-length
;; Instruction length is always a multiple of 16 bits
16)
-(define-integrable padding-string
+(define padding-string
;; Pad with ILLEGAL instructions
- (fold (unsigned-integer->bit-string 16 #b0100101011111100)))
+ (unsigned-integer->bit-string maximum-padding-length #b0100101011111100))
(define-integrable block-offset-width
;; Block offsets are always 16 bit words
16)
(define-integrable maximum-block-offset
- (fold (- (expt 2 16) 2)))
+ (- (expt 2 block-offset-width) 2))
-(define-integrable (block-offset->bit-string offset start?)
+(define (block-offset->bit-string offset start?)
(unsigned-integer->bit-string block-offset-width (+ offset (if start? 0 1))))
-(define-integrable nmv-type-string
- (fold (unsigned-integer->bit-string 8 (microcode-type 'MANIFEST-NM-VECTOR))))
-
(define (make-nmv-header n)
- (bit-string-append (unsigned-integer->bit-string 24 n) nmv-type-string))
+ (bit-string-append (unsigned-integer->bit-string scheme-datum-width n)
+ nmv-type-string))
+
+(define nmv-type-string
+ (unsigned-integer->bit-string scheme-type-width
+ (ucode-type manifest-nm-vector)))
(define (object->bit-string object)
(bit-string-append
- (unsigned-integer->bit-string 24 (object-datum object))
- (unsigned-integer->bit-string 8 (object-type object))))
+ (unsigned-integer->bit-string scheme-datum-width
+ (careful-object-datum object))
+ (unsigned-integer->bit-string scheme-type-width (object-type object))))
;;; Machine dependent instruction order
-(define-integrable (instruction-initial-position block)
- (bit-string-length block))
-
(define (instruction-insert! bits block position receiver)
(let* ((l (bit-string-length bits))
(new-position (- position l)))
(bit-substring-move-right! bits 0 l block new-position)
(receiver new-position)))
-(define-integrable instruction-append
- bit-string-append-reversed)
+(define instruction-initial-position bit-string-length)
+(define-integrable instruction-append bit-string-append-reversed)
+
;;; end let-syntax
)
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/compiler.sf,v 1.10 1989/08/21 19:33:37 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/compiler.sf,v 1.11 1989/08/28 18:33:37 cph Exp $
Copyright (c) 1988, 1989 Massachusetts Institute of Technology
\f
;; Guarantee that the package modeller is loaded.
(if (not (name->package '(CROSS-REFERENCE)))
- (with-working-directory-pathname "/scheme/cref" (lambda () (load "make"))))
+ (with-working-directory-pathname "../cref" (lambda () (load "make"))))
;; Guarantee that the compiler's package structure exists.
(if (not (name->package '(COMPILER)))
((access initialize-package! environment)))
(sf-and-load '("base/pmlook") '(COMPILER PATTERN-MATCHER/LOOKUP))
(sf-and-load '("base/pmpars") '(COMPILER PATTERN-MATCHER/PARSER))
- (sf-and-load '("machines/bobcat/assmd") '(COMPILER ASSEMBLER)) (sf-and-load '("back/syntax") '(COMPILER LAP-SYNTAXER))
+ (fluid-let ((sf/default-syntax-table
+ (access compiler-syntax-table
+ (->environment '(COMPILER MACROS)))))
+ (sf-and-load '("machines/bobcat/machin") '(COMPILER)))
+ (fluid-let ((sf/default-declarations
+ '((integrate-external "insseq")
+ (integrate-external "machin")
+ (usual-definition (set expt)))))
+ (sf-and-load '("machines/bobcat/assmd") '(COMPILER ASSEMBLER)))
+ (sf-and-load '("back/syntax") '(COMPILER LAP-SYNTAXER))
(sf-and-load '("machines/bobcat/coerce" "back/asmmac"
"machines/bobcat/insmac")
'(COMPILER LAP-SYNTAXER))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/decls.scm,v 4.22 1989/07/25 12:40:16 arthur Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/decls.scm,v 4.23 1989/08/28 18:33:41 cph Exp $
Copyright (c) 1988, 1989 Massachusetts Institute of Technology
;;;; Integration Dependencies
(define (initialize/integration-dependencies!)
+
+ (define (add-declaration! declaration filenames)
+ (for-each (lambda (filenames)
+ (let ((node (filename->source-node filenames)))
+ (set-source-node/declarations!
+ node
+ (cons declaration
+ (source-node/declarations node)))))
+ filenames))
+
(let ((front-end-base
(filename/append "base"
"blocks" "cfg1" "cfg2" "cfg3"
(define-integration-dependencies "rtlopt" "rcserq" "base" "object")
(define-integration-dependencies "rtlopt" "rlife" "base" "cfg2")
- (file-dependency/integration/join
- (append instruction-base
- lapgen-base
- lapgen-body
- assembler-base
- assembler-body
- (filename/append "back" "linear" "syerly"))
- instruction-base)
+ (let ((dependents
+ (append instruction-base
+ lapgen-base
+ lapgen-body
+ assembler-base
+ assembler-body
+ (filename/append "back" "linear" "syerly"))))
+ (add-declaration! '(USUAL-DEFINITION (SET EXPT)) dependents)
+ (file-dependency/integration/join dependents instruction-base))
+
(file-dependency/integration/join (append lapgen-base lapgen-body)
lapgen-base)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/instr1.scm,v 1.66 1988/06/14 08:47:12 cph Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/instr1.scm,v 1.67 1989/08/28 18:33:49 cph Rel $
-Copyright (c) 1988 Massachusetts Institute of Technology
+Copyright (c) 1988, 1989 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(define-symbol-transformer nwl (N . 1) (W . 2) (L . 3))
(define-symbol-transformer bwlq (B . 0) (W . 1) (L . 2) (Q . 3))
(define-symbol-transformer bwl-b (W . 1) (L . 2))
-(define-symbol-transformer bwl (B . 0) (W . 1) (L . 2))
+(define-symbol-transformer bwl
+ (B . 0) (W . 1) (L . 2) (UB . 0) (UW . 1) (UL . 2))
(define-symbol-transformer bw (B . 0) (W . 1))
(define-symbol-transformer wl (W . 0) (L . 1))
-(define-symbol-transformer lw (W . 1) (L . 0))
+(define-symbol-transformer lw (W . 1) (L . 0) (UW . 1) (UL . 0))
(define-symbol-transformer rl (R . 0) (L . 1))
(define-symbol-transformer us (U . 0) (S . 1))
(define-symbol-transformer chkwl (W . 6) (L . 4))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/instr2.scm,v 1.16 1988/10/20 16:11:07 markf Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/instr2.scm,v 1.17 1989/08/28 18:33:52 cph Rel $
-Copyright (c) 1987 Massachusetts Institute of Technology
+Copyright (c) 1987, 1989 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(WORD (8 #b00001100)
(2 s)
(6 ea DESTINATION-EA))
- (immediate-words data ssym))
+ (immediate-unsigned-words data ssym))
(((? s bwl) (@A+ (? ry)) (@A+ (? rx))) ;CMPM
(WORD (4 #b1011)
(WORD (8 #b00001100)
(2 s)
(6 ea DESTINATION-EA))
- (immediate-words data ssym)))
+ (immediate-unsigned-words data ssym)))
(define-instruction TST
(((? s bwl) (? dea ea-d&a))
(4 ,Iopcode)
(2 s)
(6 ea DESTINATION-EA))
- (immediate-words data ssym))
+ (immediate-unsigned-words data ssym))
(((? s bwl ssym) (& (? data)) (SR)) ;fooI to CCR/SR
(WORD (4 #b0000)
(4 ,Iopcode)
(2 s)
(6 #b111100))
- (immediate-words data ssym))))))
+ (immediate-unsigned-words data ssym))))))
(define-bitwise-logical AND #b1100 #b0010) ; and ANDI
(define-bitwise-logical OR #b1000 #b0000)) ; and ORI
(WORD (8 #b00001010)
(2 s)
(6 ea DESTINATION-EA))
- (immediate-words data ssym))
+ (immediate-unsigned-words data ssym))
(((? s bw ssym) (& (? data)) (SR)) ;EORI to CCR/SR
(WORD (8 #b00001010)
(2 s)
(6 #b111100))
- (immediate-words data ssym)))
+ (immediate-unsigned-words data ssym)))
(define-instruction NOT
(((? s bwl) (? dea ea-d&a))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/insutl.scm,v 1.6 1988/06/14 08:47:30 cph Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/insutl.scm,v 1.7 1989/08/28 18:33:55 cph Exp $
-Copyright (c) 1988 Massachusetts Institute of Technology
+Copyright (c) 1988, 1989 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(define (output-immediate-data immediate-size i)
(case immediate-size
- ((B)
- (EXTENSION-WORD (8 #b00000000)
- (8 i SIGNED)))
- ((W)
- (EXTENSION-WORD (16 i SIGNED)))
- ((L)
- (EXTENSION-WORD (32 i SIGNED)))
- (else
- (error "OUTPUT-IMMEDIATE-DATA: illegal immediate size"
- immediate-size))))
+ ((B) (EXTENSION-WORD (8 #b00000000) (8 i SIGNED)))
+ ((UB) (EXTENSION-WORD (8 #b00000000) (8 i UNSIGNED)))
+ ((W) (EXTENSION-WORD (16 i SIGNED)))
+ ((UW) (EXTENSION-WORD (16 i UNSIGNED)))
+ ((L) (EXTENSION-WORD (32 i SIGNED)))
+ ((UL) (EXTENSION-WORD (32 i UNSIGNED)))
+ (else (error "illegal immediate size" immediate-size))))
\f
;;; Support for 68020 addressing modes
((B) (immediate-byte data))
((W) (immediate-word data))
((L) (immediate-long data))
- (else (error "IMMEDIATE-WORD: Illegal size" size))))
+ ((UB) (immediate-unsigned-byte data))
+ ((UW) (immediate-unsigned-word data))
+ ((UL) (immediate-unsigned-long data))
+ (else (error "Illegal size" size))))
+
+(define (immediate-unsigned-words data size)
+ (case size
+ ((B UB) (immediate-unsigned-byte data))
+ ((W UW) (immediate-unsigned-word data))
+ ((L UL) (immediate-unsigned-long data))
+ (else (error "Illegal size" size))))
(define-integrable (immediate-byte data)
`(GROUP ,(make-bit-string 8 0)
,(syntax-evaluation data coerce-8-bit-signed)))
+(define-integrable (immediate-unsigned-byte data)
+ `(GROUP ,(make-bit-string 8 0)
+ ,(syntax-evaluation data coerce-8-bit-unsigned)))
+
(define-integrable (immediate-word data)
(syntax-evaluation data coerce-16-bit-signed))
+(define-integrable (immediate-unsigned-word data)
+ (syntax-evaluation data coerce-16-bit-unsigned))
+
(define-integrable (immediate-long data)
(syntax-evaluation data coerce-32-bit-signed))
+(define-integrable (immediate-unsigned-long data)
+ (syntax-evaluation data coerce-32-bit-unsigned))
+
(define-integrable (relative-word address)
(syntax-evaluation `(- ,address *PC*) coerce-16-bit-signed))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/lapgen.scm,v 4.20 1989/07/25 12:40:04 arthur Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/lapgen.scm,v 4.21 1989/08/28 18:33:59 cph Exp $
Copyright (c) 1988, 1989 Massachusetts Institute of Technology
(offset-reference regnum:regs-pointer
(pseudo-register-offset register)))
-(define-integrable (machine->machine-register source target)
+(define (machine->machine-register source target)
(cond ((float-register? source)
(if (float-register? target)
(INST (FMOVE ,source ,target))
,(register-reference source)
,(register-reference target))))))
-(define-integrable (machine-register->memory source target)
+(define (machine-register->memory source target)
(if (float-register? source)
(INST (FMOVE X ,(register-reference source) ,target))
(INST (MOV L ,(register-reference source) ,target))))
-(define-integrable (memory->machine-register source target)
+(define (memory->machine-register source target)
(if (float-register? target)
(INST (FMOVE X ,source ,(register-reference target)))
(INST (MOV L ,source ,(register-reference target)))))
(define (load-constant constant target)
(if (non-pointer-object? constant)
- (load-non-pointer (object-type constant)
- (object-datum constant)
- target)
+ (load-non-pointer-constant constant target)
(INST (MOV L
(@PCR ,(constant->label constant))
,target))))
+(define (load-non-pointer-constant constant target)
+ (load-non-pointer (object-type constant)
+ (careful-object-datum constant)
+ target))
+
(define (load-non-pointer type datum target)
(cond ((not (zero? type))
- (INST (MOV L
+ (INST (MOV UL
(& ,(make-non-pointer-literal type datum))
,target)))
((and (zero? datum)
(effective-address/data-register? target))
(INST (MOVEQ (& ,datum) ,target)))
(else
- (INST (MOV L (& ,datum) ,target)))))
-
+ (INST (MOV UL (& ,datum) ,target)))))
+\f
(define (test-byte n effective-address)
+ ;; This is used to test actual bytes.
+ ;; Type codes are "preprocessed" by the pertinent rule.
(if (and (zero? n) (effective-address/data&alterable? effective-address))
(INST (TST B ,effective-address))
(INST (CMPI B (& ,n) ,effective-address))))
+(define (test-non-pointer-constant constant target)
+ (test-non-pointer (object-type constant)
+ (careful-object-datum constant)
+ target))
+
(define (test-non-pointer type datum effective-address)
(if (and (zero? type) (zero? datum)
(effective-address/data&alterable? effective-address))
,effective-address))))
(define make-non-pointer-literal
- (let ((type-scale-factor (expt 2 24)))
+ (let ((type-scale-factor (expt 2 scheme-datum-width)))
(lambda (type datum)
- (+ (* (if (negative? datum) (1+ type) type)
- type-scale-factor)
- datum))))
+ (if (negative? datum)
+ (error "Non-pointer datum must be nonnegative" datum))
+ (+ (* type type-scale-factor) datum))))
(define (set-standard-branches! cc)
(set-current-branches!
(delete-machine-register! register)
result)))
-(define (put-type-in-ea type-code ea)
- (cond ((effective-address/data-register? ea)
- (LAP (AND L ,mask-reference ,ea)
- (OR L (& ,(make-non-pointer-literal type-code 0)) ,ea)))
- ((effective-address/data&alterable? ea)
- (LAP (MOV B (& ,type-code) ,ea)))
- (else
- (error "PUT-TYPE-IN-EA: Illegal effective-address" ea))))
+(define (memory-set-type type target)
+ (if (= 8 scheme-type-width)
+ (INST (MOV B (& ,type) ,target))
+ (INST (OR B (& ,(* type-scale-factor type)) ,target))))
(define (standard-target-expression? target)
(or (rtl:offset? target)
(if (not (unsigned-fixnum? n)) (error "Not a unsigned fixnum" n))
n)
-(define-integrable (load-fixnum-constant constant register-reference)
- (LAP (MOV L (& ,(* #x100 constant)) ,register-reference)))
+(define fixnum-1
+ (expt 2 scheme-type-width))
+
+(define (load-fixnum-constant constant register-reference)
+ (LAP (MOV L (& ,(* constant fixnum-1)) ,register-reference)))
-(define-integrable (object->fixnum reg-ref)
- (LAP (LS L L (& 8) ,reg-ref)))
+(define (object->fixnum reg-ref)
+ (LAP (LS L L (& ,scheme-type-width) ,reg-ref)))
-(define-integrable (address->fixnum reg-ref)
- (LAP (LS L L (& 8) ,reg-ref)))
+(define (address->fixnum reg-ref)
+ (LAP (LS L L (& ,scheme-type-width) ,reg-ref)))
(define (fixnum->object reg-ref)
- (LAP
- (MOV B (& ,(ucode-type fixnum)) ,reg-ref)
- (RO R L (& 8) ,reg-ref)))
+ (LAP (OR B (& ,(ucode-type fixnum)) ,reg-ref)
+ (RO R L (& ,scheme-type-width) ,reg-ref)))
-(define-integrable (fixnum->address reg-ref)
- (LAP
- (LS R L (& 8) ,reg-ref)))
+(define (fixnum->address reg-ref)
+ (LAP (LS R L (& ,scheme-type-width) ,reg-ref)))
(define (test-fixnum effective-address)
(if (effective-address/data&alterable? effective-address)
\f
(define-fixnum-method 'ONE-PLUS-FIXNUM fixnum-methods/1-arg
(lambda (reference)
- (LAP (ADD L (& #x100) ,reference))))
+ (LAP (ADD L (& ,fixnum-1) ,reference))))
(define-fixnum-method 'MINUS-ONE-PLUS-FIXNUM fixnum-methods/1-arg
(lambda (reference)
- (LAP (SUB L (& #x100) ,reference))))
+ (LAP (SUB L (& ,fixnum-1) ,reference))))
(define-fixnum-method 'PLUS-FIXNUM fixnum-methods/2-args
(lambda (target source)
(define-fixnum-method 'PLUS-FIXNUM fixnum-methods/2-args-constant
(lambda (target n)
(cond ((zero? n) (LAP))
- (else (LAP (ADD L (& ,(* n #x100)) ,target))))))
+ (else (LAP (ADD L (& ,(* n fixnum-1)) ,target))))))
(define-fixnum-method 'MULTIPLY-FIXNUM fixnum-methods/2-args
(lambda (target source)
;;; moved into the rules.
(LAP
(MOV L ,source ,new-source)
- (AS R L (& 8) ,target)
+ (AS R L (& ,scheme-type-width) ,target)
(MUL S L ,new-source ,target)))
(LAP
- (AS R L (& 8) ,target)
+ (AS R L (& ,scheme-type-width) ,target)
(MUL S L ,source ,target)))))
(define-fixnum-method 'MULTIPLY-FIXNUM fixnum-methods/2-args-constant
(define-fixnum-method 'MINUS-FIXNUM fixnum-methods/2-args-constant
(lambda (target n)
(cond ((zero? n) (LAP))
- (else (LAP (SUB L (& ,(* n #x100)) ,target))))))
+ (else (LAP (SUB L (& ,(* n fixnum-1)) ,target))))))
\f
;;;; Flonum Operators
(define (load-constant-datum constant register-ref)
(if (non-pointer-object? constant)
- (LAP (MOV L (& ,(object-datum constant)) ,register-ref))
+ (LAP (MOV L (& ,(careful-object-datum constant)) ,register-ref))
(LAP (MOV L
(@PCR ,(constant->label constant))
,register-ref)
,@(object->address register-ref))))
-(define-integrable (object->address register-reference)
+(define (object->address register-reference)
(LAP (AND L ,mask-reference ,register-reference)))
-(define-integrable (object->datum register-reference)
+(define (object->datum register-reference)
(LAP (AND L ,mask-reference ,register-reference)))
-(define-integrable (object->type register-reference)
- (LAP (RO L L (& 8) ,register-reference)))
+(define scheme-type-mask
+ (-1+ (expt 2 scheme-type-width)))
+
+(define (object->type register-reference)
+ (if (= scheme-type-width 8)
+ (LAP (RO L L (& 8) ,register-reference))
+ (LAP (RO L L (& ,scheme-type-width) ,register-reference)
+ (AND B (& ,scheme-type-mask) ,register-reference))))
+
;;;; CHAR->ASCII rules
(define (coerce->any/byte-reference register)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/machin.scm,v 4.15 1989/07/25 12:39:50 arthur Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/machin.scm,v 4.16 1989/08/28 18:34:05 cph Exp $
Copyright (c) 1988, 1989 Massachusetts Institute of Technology
\f;;; Size of words. Some of the stuff in "assmd.scm" might want to
;;; come here.
+(define-integrable endianness 'BIG)
(define-integrable addressing-granularity 8)
(define-integrable scheme-object-width 32)
-(define-integrable scheme-datum-width 24)
-(define-integrable scheme-type-width 8)
+(define-integrable scheme-type-width 6) ;or 8
+
+(define-integrable scheme-datum-width
+ (- scheme-object-width scheme-type-width))
+
+(define-integrable type-scale-factor
+ (expt 2 (- 8 scheme-type-width)))
+
(define-integrable flonum-size 2)
(define-integrable float-alignment 32)
;; of address units per character. This will cause problems on a
;; machine that is word addressed, in which case we will have to
;; rethink the character addressing strategy.
-(define-integrable address-units-per-object 4)
+
+(define address-units-per-object
+ (quotient scheme-object-width addressing-granularity))
+
(define-integrable address-units-per-packed-char 1)
-(let-syntax ((fold
- (macro (expression)
- (eval expression system-global-environment))))
- (define-integrable unsigned-fixnum/upper-limit (fold (expt 2 24)))
- (define-integrable signed-fixnum/upper-limit (fold (expt 2 23)))
- (define-integrable signed-fixnum/lower-limit (fold (- (expt 2 23)))))
+(define-integrable signed-fixnum/upper-limit
+ (expt 2 (-1+ scheme-datum-width)))
-(define-integrable (stack->memory-offset offset)
- offset)
+(define-integrable signed-fixnum/lower-limit
+ (- signed-fixnum/upper-limit))
-(define ic-block-first-parameter-offset
- 2)
+(define-integrable unsigned-fixnum/upper-limit
+ (* 2 signed-fixnum/upper-limit))
-(define closure-block-first-offset
- 2)
+(define-integrable (stack->memory-offset offset) offset)
+(define-integrable ic-block-first-parameter-offset 2)
+(define-integrable closure-block-first-offset 2)
(define (rtl:machine-register? rtl-register)
(case rtl-register
(define-integrable fp5 21)
(define-integrable fp6 22)
(define-integrable fp7 23)
-(define number-of-machine-registers 24)
-(define number-of-temporary-registers 50)
+(define-integrable number-of-machine-registers 24)
+(define-integrable number-of-temporary-registers 50)
(define-integrable regnum:dynamic-link a4)
(define-integrable regnum:free-pointer a5)
(define-integrable regnum:regs-pointer a6)
(define-integrable regnum:stack-pointer a7)
-
-(define-integrable (sort-machine-registers registers)
- registers)
+(define-integrable (sort-machine-registers registers) registers)
(define available-machine-registers
(list d0 d1 d2 d3 d4 d5 d6
(list d7 a4 a5 a6 a7))
\f
(define (float-register? register)
- (if (machine-register? register)
- (eq? (register-type register) 'FLOAT)
- (error "FLOAT-REGISTER? valid only for machine registers" register)))
+ (if (not (machine-register? register))
+ (error "Not a machine-register" register))
+ (eq? (register-type register) 'FLOAT))
(define (word-register? register)
(if (machine-register? register)
- (memq (register-type register)
- '(DATA ADDRESS))))
+ (memq (register-type register) '(DATA ADDRESS))))
-(define (register-types-compatible? type1 type2) (eq? (eq? type1 'FLOAT) (eq? type2 'FLOAT)))
+(define-integrable (register-types-compatible? type1 type2)
+ (eq? (eq? type1 'FLOAT) (eq? type2 'FLOAT)))
(define register-type
(let ((types (make-vector number-of-machine-registers)))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/make.scm-68040,v 4.49 1989/08/21 19:33:43 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/make.scm-68040,v 4.50 1989/08/28 18:34:09 cph Exp $
Copyright (c) 1988, 1989 Massachusetts Institute of Technology
((package/reference (find-package name) 'INITIALIZE-PACKAGE!)))
'((COMPILER MACROS)
(COMPILER DECLARATIONS)))
-(add-system! (make-system "Liar (Motorola MC68020)" 4 49 '()))
\ No newline at end of file
+(add-system! (make-system "Liar (Motorola MC68020)" 4 50 '()))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rules1.scm,v 4.24 1989/08/13 09:57:21 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rules1.scm,v 4.25 1989/08/28 18:34:13 cph Exp $
Copyright (c) 1988, 1989 Massachusetts Institute of Technology
(delete-dead-registers!)
(let ((target (reference-target-alias! target 'DATA)))
(if (non-pointer-object? constant)
- (LAP ,(load-non-pointer 0 (object-datum constant) target))
+ (LAP ,(load-non-pointer 0 (careful-object-datum constant) target))
(LAP ,(load-constant constant target)
,@(conversion target)))))
(QUALIFIER (and (pseudo-register? target) (machine-register? datum)))
(let ((target (reference-target-alias! target 'DATA)))
(LAP (MOV L ,(register-reference datum) ,target)
- (OR L (& ,(make-non-pointer-literal type 0)) ,target))))
+ (OR UL (& ,(make-non-pointer-literal type 0)) ,target))))
(define-rule statement
(ASSIGN (REGISTER (? target))
(CONS-POINTER (CONSTANT (? type)) (REGISTER (? datum))))
(QUALIFIER (and (pseudo-register? target) (pseudo-register? datum)))
(let ((target (move-to-alias-register! datum 'DATA target)))
- (LAP (OR L (& ,(make-non-pointer-literal type 0)) ,target))))
-
+ (LAP (OR UL (& ,(make-non-pointer-literal type 0)) ,target))))
(define-rule statement
(ASSIGN (REGISTER (? target))
(CONS-POINTER (CONSTANT (? type)) (CONSTANT (? datum))))
(LAP (LEA (@PCR ,(rtl-procedure/external-label (label->object label)))
,temp)
(MOV L ,temp ,target)
- (OR L (& ,(make-non-pointer-literal type 0)) ,target)))))
+ (OR UL (& ,(make-non-pointer-literal type 0)) ,target)))))
(define-rule statement
(ASSIGN (REGISTER (? target)) (OBJECT->FIXNUM (CONSTANT (? constant))))
(CONS-POINTER (CONSTANT (? type)) (REGISTER (? datum))))
(let ((target (indirect-reference! address offset)))
(LAP (MOV L ,(standard-register-reference datum 'DATA) ,target)
- (MOV B (& ,type) ,target))))
+ ,(memory-set-type type target))))
(define-rule statement
(ASSIGN (OFFSET (REGISTER (? address)) (? offset))
(LAP (LEA (@PCR ,(rtl-procedure/external-label (label->object label)))
,temp)
(MOV L ,temp ,target)
- (MOV B (& ,type) ,target))))
+ ,(memory-set-type type target))))
(define-rule statement
(ASSIGN (OFFSET (REGISTER (? a0)) (? n0))
(ASSIGN (PRE-INCREMENT (REGISTER 15) -1)
(CONS-POINTER (CONSTANT (? type)) (REGISTER (? datum))))
(LAP (MOV L ,(standard-register-reference datum 'DATA) (@-A 7))
- (MOV B (& ,type) (@A 7))))
+ ,(memory-set-type type (INST-EA (@A 7)))))
(define-rule statement
(ASSIGN (PRE-INCREMENT (REGISTER 15) -1)
(CONS-POINTER (CONSTANT (? type)) (ENTRY:PROCEDURE (? label))))
(LAP (PEA (@PCR ,(rtl-procedure/external-label (label->object label))))
- (MOV B (& ,type) (@A 7))))
+ ,(memory-set-type type (INST-EA (@A 7)))))
(define-rule statement
(ASSIGN (PRE-INCREMENT (REGISTER 15) -1) (OFFSET (REGISTER (? r)) (? n)))
(define-rule statement
(ASSIGN (PRE-INCREMENT (REGISTER 15) -1) (ENTRY:CONTINUATION (? label)))
(LAP (PEA (@PCR ,label))
- (MOV B (& ,(ucode-type compiled-entry)) (@A 7))))
-
+ ,(memory-set-type (ucode-type compiled-entry) (INST-EA (@A 7)))))
(define-rule statement
(ASSIGN (PRE-INCREMENT (REGISTER 15) -1)
(FIXNUM->OBJECT (REGISTER (? r))))
(operate-on-target (reference-target-alias! target 'DATA)))
operate-on-target))
\f
-#|
-
-;;; This code would have been a nice idea except that 10 is not a
-;;; valid value as a shift constant.
+;;; The maximum value for a shift constant is 8, so these rules can
+;;; only be used when the type width is 6 bits or less.
-(define (convert-index->fixnum/register target source)
- (reuse-and-load-fixnum-target! target source
- (lambda (target)
- (LAP (LS L L (& 10) ,target)))))
+(if (<= scheme-type-width 6)
+ (begin
(define-rule statement
(ASSIGN (? target)
(QUALIFIER (and (fixnum-operation-target? target) (pseudo-register? source)))
(convert-index->fixnum/register target source))
-(define (convert-index->fixnum/offset target address offset)
- (let ((source (indirect-reference! address offset)))
- (reuse-and-operate-on-fixnum-target! target
- (lambda (target)
- (LAP (MOV L ,source ,target)
- (LS L L (& 10) ,target))))))
-
(define-rule statement
(ASSIGN (? target)
(FIXNUM-2-ARGS MULTIPLY-FIXNUM
(QUALIFIER (fixnum-operation-target? target))
(convert-index->fixnum/offset target r n))
-|#\f
+;;; end (IF (<= SCHEME-TYPE-WIDTH 6) ...)
+))
+
+;;; It doesn't hurt for these to be defined when the above rules are
+;;; not in use.
+
+(define (convert-index->fixnum/register target source)
+ (reuse-and-load-fixnum-target! target source
+ (lambda (target)
+ (LAP (LS L L (& ,(+ scheme-type-width 2)) ,target)))))
+
+(define (convert-index->fixnum/offset target address offset)
+ (let ((source (indirect-reference! address offset)))
+ (reuse-and-operate-on-fixnum-target! target
+ (lambda (target)
+ (LAP (MOV L ,source ,target)
+ (LS L L (& ,(+ scheme-type-width 2)) ,target))))))\f
(define-rule statement
(ASSIGN (? target)
(FIXNUM-2-ARGS (? operator)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rules2.scm,v 4.8 1989/07/25 12:38:07 arthur Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rules2.scm,v 4.9 1989/08/28 18:34:18 cph Exp $
Copyright (c) 1988, 1989 Massachusetts Institute of Technology
(QUALIFIER (pseudo-register? register))
(set-standard-branches! 'EQ)
(let ((reference (move-to-temporary-register! register 'DATA)))
- (LAP (RO L L (& 8) ,reference)
+ (LAP ,@(object->type reference)
,(test-byte type reference))))
(define-rule predicate
(TYPE-TEST (OBJECT->TYPE (? memory)) (? type))
(QUALIFIER (predicate/memory-operand? memory))
(set-standard-branches! 'EQ)
- (LAP ,(test-byte type (predicate/memory-operand-reference memory))))
+ (if (= scheme-type-width 8)
+ (LAP ,(test-byte type (predicate/memory-operand-reference memory)))
+ (let ((temp (reference-temporary-register! 'DATA)))
+ (LAP (MOV L ,(predicate/memory-operand-reference memory) ,temp)
+ ,@(object->type temp)
+ ,(test-byte type temp)))))
(define-rule predicate
(UNASSIGNED-TEST (REGISTER (? register)))
(if (non-pointer-object? constant)
(begin
(set-standard-branches! 'EQ)
- (LAP ,(test-non-pointer (object-type constant)
- (object-datum constant)
- (standard-register-reference register 'DATA))))
+ (LAP ,(test-non-pointer-constant
+ constant
+ (standard-register-reference register 'DATA))))
(compare/register*memory register
(INST-EA (@PCR ,(constant->label constant)))
'EQ)))
(if (non-pointer-object? constant)
(begin
(set-standard-branches! 'EQ)
- (LAP ,(test-non-pointer (object-type constant)
- (object-datum constant)
- memory)))
+ (LAP ,(test-non-pointer-constant constant memory)))
(compare/memory*memory memory
(INST-EA (@PCR ,(constant->label constant)))
'EQ)))
(guarantee-signed-fixnum constant)
(let ((reference (standard-register-reference register 'DATA)))
(if (effective-address/register? reference)
- (LAP (CMP L (& ,(* constant #x100)) ,reference))
- (LAP (CMPI L (& ,(* constant #x100)) ,reference)))))
+ (LAP (CMP L (& ,(* constant fixnum-1)) ,reference))
+ (LAP (CMPI L (& ,(* constant fixnum-1)) ,reference)))))
(define-rule predicate
(FIXNUM-PRED-2-ARGS (? predicate)
(define (fixnum-predicate/memory*constant memory constant cc)
(set-standard-branches! cc)
(guarantee-signed-fixnum constant)
- (LAP (CMPI L (& ,(* constant #x100)) ,memory)))
+ (LAP (CMPI L (& ,(* constant fixnum-1)) ,memory)))
+
(define-rule predicate
(FIXNUM-PRED-2-ARGS (? predicate)
(? memory)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rules3.scm,v 4.16 1989/08/21 19:33:47 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rules3.scm,v 4.17 1989/08/28 18:34:21 cph Exp $
Copyright (c) 1988, 1989 Massachusetts Institute of Technology
\f
;;;; Invocations
+(define-integrable (clear-continuation-type-code)
+ (if (= scheme-type-width 8)
+ (INST (CLR B (@A 7)))
+ (INST (AND L ,mask-reference (@A 7)))))
+
(define-rule statement
(POP-RETURN)
(LAP ,@(clear-map!)
- (CLR B (@A 7))
+ ,(clear-continuation-type-code)
(RTS)))
(define-rule statement
frame-size continuation
;; It expects the procedure at the top of the stack
(LAP ,@(clear-map!)
- (CLR B (@A 7))
+ ,(clear-continuation-type-code)
(RTS)))
(define-rule statement
;; It expects the procedure at the top of the stack
(LAP ,@(clear-map!)
,(load-dnw number-pushed 0)
- (CLR B (@A 7))
+ ,(clear-continuation-type-code)
(MOV L (@A+ 7) (A 0))
(JMP ,entry:compiler-lexpr-apply)))
;;;; Closures. These two statements are intertwined:
(define magic-closure-constant
- (- (* #x1000000 (ucode-type compiled-entry)) 6))
+ (- (make-non-pointer-literal (ucode-type compiled-entry) 0) 6))
(define-rule statement
(CLOSURE-HEADER (? internal-label))
(LAP (LABEL ,gc-label)
(JMP ,entry:compiler-interrupt-closure)
,@(make-external-label internal-entry-code-word external-label)
- (ADD L (& ,magic-closure-constant) (@A 7))
+ (ADD UL (& ,magic-closure-constant) (@A 7))
(LABEL ,internal-label)
(CMP L ,reg:compiled-memtop (A 5))
(B GE B (@PCR ,gc-label))))))
,(load-non-pointer (ucode-type manifest-closure)
(+ 3 size)
(INST-EA (@A+ 5)))
- (MOVE L (& ,(+ (* (make-procedure-code-word min max) #x10000) 8))
- (@A+ 5))
- (MOVE L (A 5) ,target)
- (OR L (& ,(make-non-pointer-literal type 0)) ,target)
- (MOVE W (& #x4eb9) (@A+ 5)) ; (JSR (L <entry>))
- (MOVE L ,temporary (@A+ 5))
+ (MOV UL
+ (& ,(+ (* (make-procedure-code-word min max) #x10000) 8))
+ (@A+ 5))
+ (MOV L (A 5) ,target)
+ (OR UL (& ,(make-non-pointer-literal type 0)) ,target)
+ (MOV UW (& #x4eb9) (@A+ 5)) ; (JSR (L <entry>))
+ (MOV L ,temporary (@A+ 5))
(CLR W (@A+ 5))
,@(increment-machine-register 13 size))))
\f
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rules4.scm,v 4.5 1988/12/30 07:05:28 cph Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rules4.scm,v 4.6 1989/08/28 18:34:25 cph Exp $
-Copyright (c) 1988 Massachusetts Institute of Technology
+Copyright (c) 1988, 1989 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(let ((clear-map (clear-map!)))
(LAP ,@set-environment
(MOV L ,datum ,reg:temp)
- (MOV B (& ,type) ,reg:temp)
+ ,(memory-set-type type reg:temp)
,@clear-map
(MOV L ,reg:temp (A 2))
,(load-constant name (INST-EA (A 1)))
(LAP ,@set-environment
,@(clear-map!)
(PEA (@PCR ,(rtl-procedure/external-label (label->object label))))
- (MOV B (& ,type) (@A 7))
+ ,(memory-set-type type (INST-EA (@A 7)))
(MOV L (@A+ 7) (A 2))
,(load-constant name (INST-EA (A 1)))
(JSR ,entry))))
(let ((datum (standard-register-reference datum false))) (let ((clear-map (clear-map!)))
(LAP ,@set-extension
(MOV L ,datum ,reg:temp)
- (MOV B (& ,type) ,reg:temp)
+ ,(memory-set-type type reg:temp)
,@clear-map
(MOV L ,reg:temp (A 1))
(JSR ,entry:compiler-assignment-trap))))))
(LAP ,@set-extension
,@(clear-map!)
(PEA (@PCR ,(rtl-procedure/external-label (label->object label))))
- (MOV B (& ,type) (@A 7)) (MOV L (@A+ 7) (A 1))
+ ,(memory-set-type type (INST-EA (@A 7)))
+ (MOV L (@A+ 7) (A 1))
(JSR ,entry:compiler-assignment-trap))))
(define-rule statement
projects / mit-scheme.git / commitdiff