#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/bittop.scm,v 1.6 1987/08/13 02:00:44 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/bittop.scm,v 1.7 1988/02/17 19:12:25 jinx Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
((not (= where (system-vector-size v)))
(error "insert-objects!: object phase error" where))
(else v)))
+
+(define (pad! block pc position)
+ (let ((l (bit-string-length padding-string)))
+ (let loop ((to-pad (- (pad pc) pc))
+ (position position))
+ (if (not (zero? to-pad))
+ (if (< to-pad l)
+ (error "pad!: Bad padding length" to-pad)
+ (instruction-insert! padding-string block position
+ (lambda (new-position)
+ (declare (integrate new-position))
+ (loop (- to-pad l) new-position))))))))
\f
(define (assemble-directives! block directives initial-position)
(define (loop directives dir-stack pc pc-stack position last-blabel blabel)
(define (actual-bits bits l)
- (instruction-insert!
- bits
- block position
+ (instruction-insert! bits block position
(lambda (np)
(declare (integrate np))
(loop (cdr directives) dir-stack (+ pc l) pc-stack np
(car pc-stack))))
l))
- (cond ((not (null? directives))
- (let ((this (car directives)))
- (case (vector-ref this 0)
- ((LABEL)
- (loop (cdr directives) dir-stack pc pc-stack position
- last-blabel blabel))
- ((TICK)
- (loop (cdr directives) dir-stack
- pc
- (if (vector-ref this 1)
- (cons (->machine-pc pc) pc-stack)
- (cdr pc-stack))
- position
- last-blabel blabel))
- ((FIXED-WIDTH-GROUP)
- (loop (vector-ref this 2) (cons (cdr directives) dir-stack)
- pc pc-stack
- position
- last-blabel blabel))
- ((CONSTANT)
- (let ((bs (vector-ref this 1)))
- (actual-bits bs (bit-string-length bs))))
- ((EVALUATION)
- (evaluation (vector-ref this 3)
- (vector-ref this 1)
- (vector-ref this 2)))
- ((VARIABLE-WIDTH-EXPRESSION)
- (let ((sel (car (vector-ref this 3))))
- (evaluation (variable-handler-wrapper (selector/handler sel))
- (vector-ref this 1)
- (selector/length sel))))
- ((BLOCK-OFFSET)
- (let* ((label (vector-ref this 1))
- (offset (evaluate `(- ,label ,blabel) '())))
- (if (> offset maximum-block-offset)
- (block-offset (evaluate `(- ,label ,last-blabel) '())
- label last-blabel)
- (block-offset offset label blabel))))
- (else
- (error "assemble-directives!: Unknown directive" this)))))
- ((not (null? dir-stack))
- (loop (car dir-stack) (cdr dir-stack) pc pc-stack position
- last-blabel blabel))
- ((not (= (abs (- position initial-position))
- (- pc starting-pc)))
- (error "assemble-directives!: phase error"
- `(PC ,starting-pc ,pc)
- `(BIT-POSITION ,initial-position ,position)))
- (else (assemble-objects! block))))
+ (define (end-assembly)
+ (cond ((not (null? dir-stack))
+ (loop (car dir-stack) (cdr dir-stack) pc pc-stack position
+ last-blabel blabel))
+ ((not (= (abs (- position initial-position))
+ (- pc starting-pc)))
+ (error "assemble-directives!: phase error"
+ `(PC ,starting-pc ,pc)
+ `(BIT-POSITION ,initial-position ,position)))
+ (else
+ (pad! block pc position)
+ (assemble-objects! block))))
+\f
+ (if (null? directives)
+ (end-assembly)
+ (let ((this (car directives)))
+ (case (vector-ref this 0)
+ ((LABEL)
+ (loop (cdr directives) dir-stack pc pc-stack position
+ last-blabel blabel))
+ ((TICK)
+ (loop (cdr directives) dir-stack
+ pc
+ (if (vector-ref this 1)
+ (cons (->machine-pc pc) pc-stack)
+ (cdr pc-stack))
+ position
+ last-blabel blabel))
+ ((FIXED-WIDTH-GROUP)
+ (loop (vector-ref this 2) (cons (cdr directives) dir-stack)
+ pc pc-stack
+ position
+ last-blabel blabel))
+ ((CONSTANT)
+ (let ((bs (vector-ref this 1)))
+ (actual-bits bs (bit-string-length bs))))
+ ((EVALUATION)
+ (evaluation (vector-ref this 3)
+ (vector-ref this 1)
+ (vector-ref this 2)))
+ ((VARIABLE-WIDTH-EXPRESSION)
+ (let ((sel (car (vector-ref this 3))))
+ (evaluation (variable-handler-wrapper (selector/handler sel))
+ (vector-ref this 1)
+ (selector/length sel))))
+ ((BLOCK-OFFSET)
+ (let* ((label (vector-ref this 1))
+ (offset (evaluate `(- ,label ,blabel) '())))
+ (if (> offset maximum-block-offset)
+ (block-offset (evaluate `(- ,label ,last-blabel) '())
+ label last-blabel)
+ (block-offset offset label blabel))))
+ (else
+ (error "assemble-directives!: Unknown directive" this))))))
+
(loop directives '() starting-pc '() initial-position
*start-label* *start-label*))
\f
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/assmd.scm,v 1.32 1987/08/13 01:58:42 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/assmd.scm,v 1.33 1988/02/17 19:12:01 jinx Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
(declare (usual-integrations))
\f
-(declare (integrate addressing-granularity scheme-object-width
- maximum-padding-length
- maximum-block-offset block-offset-width))
+(declare
+ (integrate addressing-granularity
+ scheme-object-width
+ endianness
+ maximum-padding-length
+ maximum-block-offset
+ block-offset-width)
+ (integrate-operator block-offset->bit-string
+ instruction-initial-position
+ instruction-insert!))
(define addressing-granularity 8)
(define scheme-object-width 32)
+(define endianness 'BIG)
;; Instruction length is always a multiple of 16
+;; Pad with ILLEGAL instructions
+
(define maximum-padding-length 16)
+(define padding-string
+ (unsigned-integer->bit-string 16 #b0100101011111100))
+
;; Block offsets are always words
+
(define maximum-block-offset (- (expt 2 16) 2))
(define block-offset-width 16)
-(define make-nmv-header)
-(let ()
-
-(set! make-nmv-header
-(named-lambda (make-nmv-header n)
- (bit-string-append (unsigned-integer->bit-string 24 n)
- nmv-type-string)))
+(define (block-offset->bit-string offset start?)
+ (declare (integrate offset start?))
+ (unsigned-integer->bit-string block-offset-width
+ (+ offset
+ (if start? 0 1))))
-(define nmv-type-string
- (unsigned-integer->bit-string 8 (microcode-type 'MANIFEST-NM-VECTOR)))
+(define make-nmv-header
+ (let ((nmv-type-string
+ (unsigned-integer->bit-string 8 (microcode-type
+ 'MANIFEST-NM-VECTOR))))
-)
+ (named-lambda (make-nmv-header n)
+ (bit-string-append (unsigned-integer->bit-string 24 n)
+ nmv-type-string))))
(define (object->bit-string object)
(bit-string-append
(unsigned-integer->bit-string 24 (primitive-datum object))
(unsigned-integer->bit-string 8 (primitive-type object))))
-
-(define (block-offset->bit-string offset start?)
- (unsigned-integer->bit-string block-offset-width
- (if start? offset (1+ offset))))
\f
;;; Machine dependent instruction order
(define (instruction-initial-position block)
+ (declare (integrate block))
(bit-string-length block))
(define (instruction-insert! bits block position receiver)
+ (declare (integrate block position receiver))
(let* ((l (bit-string-length bits))
(new-position (- position l)))
(bit-substring-move-right! bits 0 l block new-position)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/make.scm-68040,v 4.4 1988/01/06 17:57:03 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/make.scm-68040,v 4.5 1988/02/17 19:10:57 jinx Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
(make-environment
(define :name "Liar (Bobcat 68020)")
(define :version 4)
- (define :modification 4)
+ (define :modification 5)
(define :files)
(define :rcs-header
- "$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/make.scm-68040,v 4.4 1988/01/06 17:57:03 cph Exp $")
+ "$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/make.scm-68040,v 4.5 1988/02/17 19:10:57 jinx Exp $")
(define :files-lists
(list
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rules3.scm,v 4.2 1987/12/30 10:53:57 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rules3.scm,v 4.3 1988/02/17 19:11:22 jinx Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
(if (= how-far 1)
(LAP (MOV L (@AO 7 4) (@AO 7 8))
(MOV L (@A+ 7) (@A 7)))
- (let ((i (lambda ()
+ (let ((i (lambda (dis)
(INST (MOV L (@A+ 7)
- ,(offset-reference a7 (-1+ how-far)))))))
- (LAP ,(i)
- ,(i)
+ ,(offset-reference a7 dis))))))
+ (LAP ,(i (-1+ how-far))
+ ,(i (-1+ how-far))
,@(increment-anl 7 (- how-far 2))))))
(else
(generate/move-frame-up frame-size (offset-reference a7 offset))))))
,@(make-external-label internal-label)
(CMP L ,reg:compiled-memtop (A 5))
(B GE B (@PCR ,gc-label)))))
+
+(define-rule statement
+ (CONTINUATION-ENTRY (? internal-label))
+ (LAP ,@(make-external-label internal-label)))
\f
(define (procedure-header procedure gc-label)
(let ((internal-label (rtl-procedure/label procedure))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlty1.scm,v 4.2 1987/12/30 07:07:57 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlty1.scm,v 4.3 1988/02/17 19:13:26 jinx Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
(define-rtl-predicate unassigned-test % expression)
(define-rtl-statement assign % address expression)
+(define-rtl-statement continuation-entry rtl: continuation)
(define-rtl-statement continuation-heap-check rtl: continuation)
(define-rtl-statement procedure-heap-check rtl: procedure)
(define-rtl-statement setup-lexpr rtl: procedure)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rtlgen.scm,v 4.2 1987/12/30 07:10:47 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rtlgen.scm,v 4.3 1988/02/17 19:12:51 jinx Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
(generate/node (procedure-entry-node procedure))
true))
\f
+(define (operator/needs-no-heap-check? op)
+ (and (rvalue/constant? op)
+ (let ((obj (constant-value op)))
+ (and (normal-primitive-procedure? obj)
+ (special-primitive-handler obj)))))
+
+(define (continuation/avoid-check? continuation)
+ (and (null? (continuation/returns continuation))
+ (for-all?
+ (continuation/combinations continuation)
+ (lambda (combination)
+ (let ((op (rvalue-known-value (combination/operator combination))))
+ (and op (operator/needs-no-heap-check? op)))))))
+
(define (generate/continuation continuation)
(let ((label (continuation/label continuation)))
(transmit-values
(continuation/entry-node continuation)
(lambda (node)
(scfg-append!
- (rtl:make-continuation-heap-check label)
+ (if (continuation/avoid-check? continuation)
+ (rtl:make-continuation-entry label)
+ (rtl:make-continuation-heap-check label))
(generate/continuation-entry/ic-block continuation)
(if (block/dynamic-link?
(continuation/closing-block continuation))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rcse1.scm,v 4.4 1987/12/31 07:01:21 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rcse1.scm,v 4.5 1988/02/17 19:14:05 jinx Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
(define-cse-method 'POP-RETURN method/noop)
(define-cse-method 'PROCEDURE-HEAP-CHECK method/noop)
(define-cse-method 'CONTINUATION-HEAP-CHECK method/noop)
+(define-cse-method 'CONTINUATION-ENTRY method/noop)
(define-cse-method 'INVOCATION:APPLY method/noop)
(define-cse-method 'INVOCATION:JUMP method/noop)
(define-cse-method 'INVOCATION:LEXPR method/noop)
projects / mit-scheme.git / commitdiff