#| -*-Scheme-*-
-$Id: make.scm,v 4.96 1992/12/28 22:03:26 cph Exp $
+$Id: make.scm,v 4.97 1993/01/08 00:05:44 cph Exp $
-Copyright (c) 1988-1992 Massachusetts Institute of Technology
+Copyright (c) 1988-1993 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(initialize-package! '(COMPILER DECLARATIONS)))
(add-system!
(make-system (string-append "Liar (" architecture-name ")")
- 4 96
+ 4 97
'())))
\ No newline at end of file
#| -*-Scheme-*-
-$Id: machin.scm,v 1.3 1992/11/18 03:52:32 gjr Exp $
+$Id: machin.scm,v 1.4 1993/01/08 00:03:32 cph Exp $
-Copyright (c) 1992 Digital Equipment Corporation (D.E.C.)
+Copyright (c) 1992-1993 Digital Equipment Corporation (D.E.C.)
This software was developed at the Digital Equipment Corporation
Cambridge Research Laboratory. Permission to copy this software, to
(interpreter-dynamic-link))
((VALUE)
(interpreter-value-register))
+ ((FREE)
+ (interpreter-free-pointer))
+ ((MEMORY-TOP)
+ (rtl:make-machine-register regnum:memtop))
((INTERPRETER-CALL-RESULT:ACCESS)
(interpreter-register:access))
((INTERPRETER-CALL-RESULT:CACHE-REFERENCE)
(define (rtl:interpreter-register? rtl-register)
(case rtl-register
- ((MEMORY-TOP) 0)
- ((STACK-GUARD) 1)
+ ((INT-MASK) 1)
((ENVIRONMENT) 3)
((TEMPORARY) 4)
(else false)))
(define (rtl:interpreter-register->offset locative)
(or (rtl:interpreter-register? locative)
(error "Unknown register type" locative)))
-
+\f
(define (rtl:constant-cost expression)
;; Magic numbers. Cycles needed to generate value in specified
;; register.
#| -*-Scheme-*-
-$Id: dassm2.scm,v 4.20 1992/09/25 01:17:58 cph Exp $
+$Id: dassm2.scm,v 4.21 1993/01/08 00:03:51 cph Exp $
-Copyright (c) 1988-1992 Massachusetts Institute of Technology
+Copyright (c) 1988-1993 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(make-entries (+ index 8) (cdr names)))))
`(;; Interpreter registers
(0 . (REGISTER MEMORY-TOP))
- (4 . (REGISTER STACK-GUARD))
+ (4 . (REGISTER INT-MASK))
(8 . (REGISTER VALUE))
(12 . (REGISTER ENVIRONMENT))
(16 . (REGISTER TEMPORARY))
+ (44 . (REGISTER STACK-GUARD))
;; Interpreter entry points
,@(make-entries
first-entry
#| -*-Scheme-*-
-$Id: machin.scm,v 4.28 1992/11/18 03:47:54 gjr Exp $
+$Id: machin.scm,v 4.29 1993/01/08 00:04:03 cph Exp $
-Copyright (c) 1988-1992 Massachusetts Institute of Technology
+Copyright (c) 1988-1993 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(interpreter-dynamic-link))
((VALUE)
(interpreter-value-register))
+ ((FREE)
+ (interpreter-free-pointer))
((INTERPRETER-CALL-RESULT:ACCESS)
(interpreter-register:access))
((INTERPRETER-CALL-RESULT:CACHE-REFERENCE)
(define (rtl:interpreter-register? rtl-register)
(case rtl-register
((MEMORY-TOP) 0)
- ((STACK-GUARD) 1)
+ ((INT-MASK) 1)
((ENVIRONMENT) 3)
((TEMPORARY) 4)
(else false)))
#| -*-Scheme-*-
-$Id: machin.scm,v 1.15 1992/11/18 03:49:35 gjr Exp $
+$Id: machin.scm,v 1.16 1993/01/08 00:04:22 cph Exp $
-Copyright (c) 1992 Massachusetts Institute of Technology
+Copyright (c) 1992-93 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(error "illegal machine register" register))))
(define-integrable register-block/memtop-offset 0)
+(define-integrable register-block/int-mask-offset 1)
(define-integrable register-block/value-offset 2)
(define-integrable register-block/environment-offset 3)
(define-integrable register-block/dynamic-link-offset 4) ; compiler temp
((VALUE)
(interpreter-value-register))
|#
+ ((FREE)
+ (interpreter-free-pointer))
((INTERPRETER-CALL-RESULT:ACCESS)
(interpreter-register:access))
((INTERPRETER-CALL-RESULT:CACHE-REFERENCE)
(case rtl-register
((MEMORY-TOP)
register-block/memtop-offset)
+ ((INT-MASK)
+ register-block/int-mask-offset)
((STACK-GUARD)
register-block/stack-guard-offset)
((VALUE)
(define (rtl:interpreter-register->offset locative)
(or (rtl:interpreter-register? locative)
(error "Unknown register type" locative)))
-
+\f
(define (rtl:constant-cost expression)
;; i486 clock count for instruction to construct/fetch into register.
(let ((if-integer
#| -*-Scheme-*-
-$Id: machin.scm,v 1.10 1992/12/22 02:17:06 cph Exp $
+$Id: machin.scm,v 1.11 1993/01/08 00:04:37 cph Exp $
-Copyright (c) 1988-1992 Massachusetts Institute of Technology
+Copyright (c) 1988-1993 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(interpreter-dynamic-link))
((VALUE)
(interpreter-value-register))
+ ((MEMORY-TOP)
+ (rtl:make-machine-register regnum:memtop))
+ ((FREE)
+ (interpreter-free-pointer))
((INTERPRETER-CALL-RESULT:ACCESS)
(interpreter-register:access))
((INTERPRETER-CALL-RESULT:CACHE-REFERENCE)
(define (rtl:interpreter-register? rtl-register)
(case rtl-register
- ((MEMORY-TOP) 0)
- ((STACK-GUARD) 1)
+ ((INT-MASK) 1)
((ENVIRONMENT) 3)
((TEMPORARY) 4)
(else false)))
(define (rtl:interpreter-register->offset locative)
(or (rtl:interpreter-register? locative)
(error "Unknown register type" locative)))
-
+\f
(define (rtl:constant-cost expression)
;; Magic numbers.
(let ((if-integer
true)
(define compiler:primitives-with-no-open-coding
- '(DIVIDE-FIXNUM GCD-FIXNUM FIXNUM-QUOTIENT FIXNUM-REMAINDER FIXNUM-LSH
+ '(DIVIDE-FIXNUM GCD-FIXNUM FIXNUM-QUOTIENT FIXNUM-REMAINDER
INTEGER-QUOTIENT INTEGER-REMAINDER &/ QUOTIENT REMAINDER
FLONUM-SIN FLONUM-COS FLONUM-TAN FLONUM-ASIN FLONUM-ACOS
FLONUM-ATAN FLONUM-EXP FLONUM-LOG FLONUM-TRUNCATE FLONUM-ROUND
#| -*-Scheme-*-
-$Id: rulfix.scm,v 1.8 1992/12/28 22:01:22 cph Exp $
+$Id: rulfix.scm,v 1.9 1993/01/08 00:04:44 cph Exp $
-Copyright (c) 1989-1992 Massachusetts Institute of Technology
+Copyright (c) 1989-1993 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(define fixnum-methods/1-arg
(list 'FIXNUM-METHODS/1-ARG))
+(define-rule statement
+ ;; execute a binary fixnum operation
+ (ASSIGN (REGISTER (? target))
+ (FIXNUM-2-ARGS (? operation)
+ (REGISTER (? source1))
+ (REGISTER (? source2))
+ (? overflow?)))
+ (standard-binary-conversion source1 source2 target
+ (lambda (source1 source2 target)
+ ((fixnum-2-args/operator operation) target source1 source2 overflow?))))
+
+(define (fixnum-2-args/operator operation)
+ (lookup-arithmetic-method operation fixnum-methods/2-args))
+
+(define fixnum-methods/2-args
+ (list 'FIXNUM-METHODS/2-ARGS))
+\f
+(define-rule statement
+ ;; execute binary fixnum operation with constant second arg
+ (ASSIGN (REGISTER (? target))
+ (FIXNUM-2-ARGS (? operation)
+ (REGISTER (? source))
+ (OBJECT->FIXNUM (CONSTANT (? constant)))
+ (? overflow?)))
+ (QUALIFIER (fixnum-2-args/operator/register*constant? operation))
+ (standard-unary-conversion source target
+ (lambda (source target)
+ ((fixnum-2-args/operator/register*constant operation)
+ target source constant overflow?))))
+
+(define-rule statement
+ ;; execute binary fixnum operation with constant first arg
+ (ASSIGN (REGISTER (? target))
+ (FIXNUM-2-ARGS (? operation)
+ (OBJECT->FIXNUM (CONSTANT (? constant)))
+ (REGISTER (? source))
+ (? overflow?)))
+ (QUALIFIER
+ (or (fixnum-2-args/operator/constant*register? operation)
+ (and (fixnum-2-args/commutative? operation)
+ (fixnum-2-args/operator/register*constant? operation))))
+ (standard-unary-conversion source target
+ (lambda (source target)
+ (if (fixnum-2-args/commutative? operation)
+ ((fixnum-2-args/operator/register*constant operation)
+ target source constant overflow?)
+ ((fixnum-2-args/operator/constant*register operation)
+ target constant source overflow?)))))
+
+(define (fixnum-2-args/commutative? operator)
+ (memq operator
+ '(PLUS-FIXNUM MULTIPLY-FIXNUM FIXNUM-AND FIXNUM-OR FIXNUM-XOR)))
+
+(define (fixnum-2-args/operator/register*constant operation)
+ (lookup-arithmetic-method operation fixnum-methods/2-args/register*constant))
+
+(define (fixnum-2-args/operator/register*constant? operation)
+ (arithmetic-method? operation fixnum-methods/2-args/register*constant))
+
+(define fixnum-methods/2-args/register*constant
+ (list 'FIXNUM-METHODS/2-ARGS/REGISTER*CONSTANT))
+
+(define (fixnum-2-args/operator/constant*register operation)
+ (lookup-arithmetic-method operation fixnum-methods/2-args/constant*register))
+
+(define (fixnum-2-args/operator/constant*register? operation)
+ (arithmetic-method? operation fixnum-methods/2-args/constant*register))
+
+(define fixnum-methods/2-args/constant*register
+ (list 'FIXNUM-METHODS/2-ARGS/CONSTANT*REGISTER))
+\f
(define-arithmetic-method 'ONE-PLUS-FIXNUM fixnum-methods/1-arg
(lambda (tgt src overflow?)
(fixnum-add-constant tgt src 1 overflow?)))
(BLTZ ,tgt (@PCR ,if-no-overflow))
(NOP)))))))
(LAP)))))
-
-(define-arithmetic-method 'FIXNUM-NOT fixnum-methods/1-arg
- (lambda (tgt src overflow?)
- overflow?
- (LAP (NOR ,tgt 0 ,src))))
\f
-(define-rule statement
- ;; execute a binary fixnum operation
- (ASSIGN (REGISTER (? target))
- (FIXNUM-2-ARGS (? operation)
- (REGISTER (? source1))
- (REGISTER (? source2))
- (? overflow?)))
- (standard-binary-conversion source1 source2 target
- (lambda (source1 source2 target)
- ((fixnum-2-args/operator operation) target source1 source2 overflow?))))
-
-(define (fixnum-2-args/operator operation)
- (lookup-arithmetic-method operation fixnum-methods/2-args))
-
-(define fixnum-methods/2-args
- (list 'FIXNUM-METHODS/2-ARGS))
-
(define-arithmetic-method 'PLUS-FIXNUM fixnum-methods/2-args
(lambda (tgt src1 src2 overflow?)
(if overflow?
(do-overflow-addition tgt src1 src2)
(LAP (ADDU ,tgt ,src1 ,src2)))))
+(define-arithmetic-method 'PLUS-FIXNUM fixnum-methods/2-args/register*constant
+ (lambda (tgt src constant overflow?)
+ (guarantee-signed-fixnum constant)
+ (fixnum-add-constant tgt src constant overflow?)))
+
;;; Use of REGNUM:ASSEMBLER-TEMP is OK here, but only because its
;;; value is not used after the branch instruction that tests it.
;;; The long form of the @PCR branch will test it correctly, but
(do-overflow-subtraction tgt src1 src2))
(LAP (SUB ,tgt ,src1 ,src2)))))
+(define-arithmetic-method 'MINUS-FIXNUM fixnum-methods/2-args/register*constant
+ (lambda (tgt src constant overflow?)
+ (guarantee-signed-fixnum constant)
+ (fixnum-add-constant tgt src (- constant) overflow?)))
+
+(define-arithmetic-method 'MINUS-FIXNUM fixnum-methods/2-args/constant*register
+ (lambda (tgt constant src overflow?)
+ (guarantee-signed-fixnum constant)
+ (with-values (lambda () (immediate->register (* constant fixnum-1)))
+ (lambda (prefix alias)
+ (LAP ,@prefix
+ ,@(if overflow?
+ (do-overflow-subtraction tgt alias src)
+ (LAP (SUB ,tgt ,alias ,src))))))))
+
(define (do-overflow-subtraction tgt src1 src2)
(set-current-branches!
(lambda (if-overflow)
(BLTZ ,regnum:assembler-temp (@PCR ,if-no-overflow))))
(NOP))))
(LAP))
+\f
+(define-arithmetic-method 'MULTIPLY-FIXNUM fixnum-methods/2-args
+ (lambda (tgt src1 src2 overflow?)
+ (do-multiply tgt src1 src2 overflow?)))
+
+(define-arithmetic-method 'MULTIPLY-FIXNUM
+ fixnum-methods/2-args/register*constant
+ (lambda (tgt src constant overflow?)
+ (cond ((zero? constant)
+ (if overflow? (no-overflow-branches!))
+ (LAP (ADDI ,tgt 0 0)))
+ ((= constant 1)
+ (if overflow? (no-overflow-branches!))
+ (LAP (ADD ,tgt 0 ,src)))
+ ((let loop ((n constant))
+ (and (> n 0)
+ (if (= n 1)
+ 0
+ (and (even? n)
+ (let ((m (loop (quotient n 2))))
+ (and m
+ (+ m 1)))))))
+ =>
+ (lambda (power-of-two)
+ (if overflow?
+ (do-left-shift-overflow tgt src power-of-two)
+ (LAP (SLL ,tgt ,src ,power-of-two)))))
+ (else
+ (with-values (lambda () (immediate->register (* constant fixnum-1)))
+ (lambda (prefix alias)
+ (LAP ,@prefix
+ ,@(do-multiply tgt src alias overflow?))))))))
(define (do-multiply tgt src1 src2 overflow?)
(if overflow?
(MULT ,regnum:assembler-temp ,src2)
(MFLO ,tgt)))
-(define-arithmetic-method 'MULTIPLY-FIXNUM fixnum-methods/2-args do-multiply)
+(define (do-left-shift-overflow tgt src power-of-two)
+ (if (= tgt src)
+ (let ((temp (standard-temporary!)))
+ (set-current-branches!
+ (lambda (if-overflow)
+ (LAP (SLL ,temp ,src ,power-of-two)
+ (SRA ,regnum:assembler-temp ,temp ,power-of-two)
+ (BNE ,regnum:assembler-temp ,src (@PCR ,if-overflow))
+ (ADD ,tgt 0 ,temp)))
+ (lambda (if-no-overflow)
+ (LAP (SLL ,temp ,src ,power-of-two)
+ (SRA ,regnum:assembler-temp ,temp ,power-of-two)
+ (BEQ ,regnum:assembler-temp ,src (@PCR ,if-no-overflow))
+ (ADD ,tgt 0 ,temp)))))
+ (set-current-branches!
+ (lambda (if-overflow)
+ (LAP (SLL ,tgt ,src ,power-of-two)
+ (SRA ,regnum:assembler-temp ,tgt ,power-of-two)
+ (BNE ,regnum:assembler-temp ,src (@PCR ,if-overflow))
+ (NOP)))
+ (lambda (if-no-overflow)
+ (LAP (SLL ,tgt ,src ,power-of-two)
+ (SRA ,regnum:assembler-temp ,tgt ,power-of-two)
+ (BEQ ,regnum:assembler-temp ,src (@PCR ,if-no-overflow))
+ (NOP)))))
+ (LAP))
+\f
+(define-arithmetic-method 'FIXNUM-NOT fixnum-methods/1-arg
+ (lambda (tgt src overflow?)
+ overflow?
+ (LAP (NOR ,tgt 0 ,src))))
(define-arithmetic-method 'FIXNUM-AND fixnum-methods/2-args
(lambda (tgt src1 src2 overflow?)
(lambda (tgt src1 src2 overflow?)
overflow?
(LAP (XOR ,tgt ,src1 ,src2))))
-\f
-(define-rule statement
- ;; execute binary fixnum operation with constant second arg
- (ASSIGN (REGISTER (? target))
- (FIXNUM-2-ARGS (? operation)
- (REGISTER (? source))
- (OBJECT->FIXNUM (CONSTANT (? constant)))
- (? overflow?)))
- (QUALIFIER (fixnum-2-args/operator/register*constant? operation))
- (standard-unary-conversion source target
- (lambda (source target)
- ((fixnum-2-args/operator/register*constant operation)
- target source constant overflow?))))
-
-(define-rule statement
- ;; execute binary fixnum operation with constant first arg
- (ASSIGN (REGISTER (? target))
- (FIXNUM-2-ARGS (? operation)
- (OBJECT->FIXNUM (CONSTANT (? constant)))
- (REGISTER (? source))
- (? overflow?)))
- (QUALIFIER
- (or (fixnum-2-args/operator/constant*register? operation)
- (and (fixnum-2-args/commutative? operation)
- (fixnum-2-args/operator/register*constant? operation))))
- (standard-unary-conversion source target
- (lambda (source target)
- (if (fixnum-2-args/commutative? operation)
- ((fixnum-2-args/operator/register*constant operation)
- target source constant overflow?)
- ((fixnum-2-args/operator/constant*register operation)
- target constant source overflow?)))))
-
-(define (fixnum-2-args/commutative? operator)
- (memq operator
- '(PLUS-FIXNUM MULTIPLY-FIXNUM FIXNUM-AND FIXNUM-OR FIXNUM-XOR)))
-
-(define (fixnum-2-args/operator/register*constant operation)
- (lookup-arithmetic-method operation fixnum-methods/2-args/register*constant))
-
-(define (fixnum-2-args/operator/register*constant? operation)
- (arithmetic-method? operation fixnum-methods/2-args/register*constant))
-
-(define fixnum-methods/2-args/register*constant
- (list 'FIXNUM-METHODS/2-ARGS/REGISTER*CONSTANT))
-(define (fixnum-2-args/operator/constant*register operation)
- (lookup-arithmetic-method operation fixnum-methods/2-args/constant*register))
-
-(define (fixnum-2-args/operator/constant*register? operation)
- (arithmetic-method? operation fixnum-methods/2-args/constant*register))
-
-(define fixnum-methods/2-args/constant*register
- (list 'FIXNUM-METHODS/2-ARGS/CONSTANT*REGISTER))
-\f
-(define-arithmetic-method 'PLUS-FIXNUM
- fixnum-methods/2-args/register*constant
- (lambda (tgt src constant overflow?)
- (guarantee-signed-fixnum constant)
- (fixnum-add-constant tgt src constant overflow?)))
-
-(define-arithmetic-method 'MINUS-FIXNUM
- fixnum-methods/2-args/register*constant
+(define-arithmetic-method 'FIXNUM-LSH fixnum-methods/2-args
+ (lambda (tgt src1 src2 overflow?)
+ overflow?
+ (let ((merge (generate-label 'LSH-MERGE))
+ (neg (generate-label 'LSH-NEG)))
+ (LAP (BLTZ ,src2 (@PCR ,neg))
+ (SRA ,regnum:assembler-temp ,src2 ,scheme-type-width)
+ (BGEZ 0 (@PCR ,merge))
+ (SLLV ,tgt ,src1 ,regnum:assembler-temp)
+ (LABEL ,neg)
+ (SUB ,regnum:assembler-temp 0 ,regnum:assembler-temp)
+ (SRLV ,tgt ,src1 ,regnum:assembler-temp)
+ (SRL ,tgt ,tgt ,scheme-type-width)
+ (SLL ,tgt ,tgt ,scheme-type-width)
+ (LABEL ,merge)))))
+
+(define-arithmetic-method 'FIXNUM-LSH fixnum-methods/2-args/register*constant
(lambda (tgt src constant overflow?)
+ overflow?
(guarantee-signed-fixnum constant)
- (fixnum-add-constant tgt src (- constant) overflow?)))
-
-(define-arithmetic-method 'MULTIPLY-FIXNUM
- fixnum-methods/2-args/register*constant
- (lambda (tgt src constant overflow?)
- (cond ((zero? constant)
- (if overflow? (no-overflow-branches!))
- (LAP (ADDI ,tgt 0 0)))
- ((= constant 1)
- (if overflow? (no-overflow-branches!))
+ (cond ((= constant 0)
(LAP (ADD ,tgt 0 ,src)))
- ((let loop ((n constant))
- (and (> n 0)
- (if (= n 1)
- 0
- (and (even? n)
- (let ((m (loop (quotient n 2))))
- (and m
- (+ m 1)))))))
- =>
- (lambda (power-of-two)
- (if overflow?
- (do-left-shift-overflow tgt src power-of-two)
- (LAP (SLL ,tgt ,src ,power-of-two)))))
+ ((<= 1 constant (- scheme-datum-width 1))
+ (LAP (SLL ,tgt ,src ,constant)))
+ ((<= 1 (- constant) (- scheme-datum-width 1))
+ (LAP (SRL ,tgt ,src ,(+ (- constant) scheme-type-width))
+ (SLL ,tgt ,tgt ,scheme-type-width)))
(else
- (with-values (lambda () (immediate->register (* constant fixnum-1)))
- (lambda (prefix alias)
- (LAP ,@prefix
- ,@(do-multiply tgt src alias overflow?))))))))
-
-(define (do-left-shift-overflow tgt src power-of-two)
- (if (= tgt src)
- (let ((temp (standard-temporary!)))
- (set-current-branches!
- (lambda (if-overflow)
- (LAP (SLL ,temp ,src ,power-of-two)
- (SRA ,regnum:assembler-temp ,temp ,power-of-two)
- (BNE ,regnum:assembler-temp ,src (@PCR ,if-overflow))
- (ADD ,tgt 0 ,temp)))
- (lambda (if-no-overflow)
- (LAP (SLL ,temp ,src ,power-of-two)
- (SRA ,regnum:assembler-temp ,temp ,power-of-two)
- (BEQ ,regnum:assembler-temp ,src (@PCR ,if-no-overflow))
- (ADD ,tgt 0 ,temp)))))
- (set-current-branches!
- (lambda (if-overflow)
- (LAP (SLL ,tgt ,src ,power-of-two)
- (SRA ,regnum:assembler-temp ,tgt ,power-of-two)
- (BNE ,regnum:assembler-temp ,src (@PCR ,if-overflow))
- (NOP)))
- (lambda (if-no-overflow)
- (LAP (SLL ,tgt ,src ,power-of-two)
- (SRA ,regnum:assembler-temp ,tgt ,power-of-two)
- (BEQ ,regnum:assembler-temp ,src (@PCR ,if-no-overflow))
- (NOP)))))
- (LAP))
-
-(define-arithmetic-method 'MINUS-FIXNUM
- fixnum-methods/2-args/constant*register
- (lambda (tgt constant src overflow?)
- (guarantee-signed-fixnum constant)
- (with-values (lambda () (immediate->register (* constant fixnum-1)))
- (lambda (prefix alias)
- (LAP ,@prefix
- ,@(if overflow?
- (do-overflow-subtraction tgt alias src)
- (LAP (SUB ,tgt ,alias ,src))))))))
+ (LAP (ADDIU ,tgt 0 0))))))
\f
;;;; Predicates
#| -*-Scheme-*-
-$Id: rulrew.scm,v 1.4 1992/12/23 18:14:20 cph Exp $
+$Id: rulrew.scm,v 1.5 1993/01/08 00:04:50 cph Exp $
-Copyright (c) 1990-92 Massachusetts Institute of Technology
+Copyright (c) 1990-93 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(QUALIFIER (rtl:constant-fixnum? source))
(rtl:make-object->fixnum source))
+(define-rule rewriting
+ (FIXNUM-2-ARGS FIXNUM-LSH
+ (? operand-1)
+ (REGISTER (? operand-2 register-known-value))
+ #F)
+ (QUALIFIER (and (rtl:register? operand-1)
+ (rtl:constant-fixnum? operand-2)))
+ (rtl:make-fixnum-2-args 'FIXNUM-LSH operand-1 operand-2 #F))
+
(define-rule rewriting
(FIXNUM-2-ARGS MULTIPLY-FIXNUM
(REGISTER (? operand-1 register-known-value))
#| -*-Scheme-*-
-$Id: machin.scm,v 4.26 1992/11/18 00:46:45 gjr Exp $
+$Id: machin.scm,v 4.27 1993/01/08 00:05:02 cph Exp $
-Copyright (c) 1988-1992 Massachusetts Institute of Technology
+Copyright (c) 1988-1993 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(interpreter-dynamic-link))
((VALUE)
(interpreter-value-register))
+ ((FREE)
+ (interpreter-free-pointer))
+ ((MEMORY-TOP)
+ (rtl:make-machine-register regnum:memtop-pointer))
((INTERPRETER-CALL-RESULT:ACCESS)
(interpreter-register:access))
((INTERPRETER-CALL-RESULT:CACHE-REFERENCE)
(define (rtl:interpreter-register? rtl-register)
(case rtl-register
- ((MEMORY-TOP) 0)
- ((STACK-GUARD) 1)
+ ((INT-MASK) 1)
((ENVIRONMENT) 3)
((TEMPORARY) 4)
(else false)))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/vax/dassm2.scm,v 4.11 1992/08/11 04:43:37 jinx Exp $
-$MC68020-Header: dassm2.scm,v 4.17 90/05/03 15:17:04 GMT jinx Exp $
+$Id: dassm2.scm,v 4.12 1993/01/08 00:05:17 cph Exp $
-Copyright (c) 1987-1992 Massachusetts Institute of Technology
+Copyright (c) 1987-1993 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(make-entries (+ index 6) (cdr names)))))
`(;; Interpreter registers
(0 . (REGISTER MEMORY-TOP))
- (4 . (REGISTER STACK-GUARD))
+ (4 . (REGISTER INT-MASK))
(8 . (REGISTER VALUE))
(12 . (REGISTER ENVIRONMENT))
(16 . (REGISTER TEMPORARY))
(28 . (REGISTER LEXPR-PRIMITIVE-ACTUALS))
(32 . (REGISTER MINIMUM-LENGTH))
(36 . (REGISTER PRIMITIVE))
+ (44 . (REGISTER STACK-GUARD))
;; Interface entry points
,@(make-entries
#x0280
#| -*-Scheme-*-
-$Id: machin.scm,v 4.10 1992/11/18 03:55:03 gjr Exp $
+$Id: machin.scm,v 4.11 1993/01/08 00:05:10 cph Exp $
-Copyright (c) 1987-1992 Massachusetts Institute of Technology
+Copyright (c) 1987-1993 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(interpreter-dynamic-link))
((VALUE)
(interpreter-value-register))
+ ((FREE)
+ (interpreter-free-pointer))
((INTERPRETER-CALL-RESULT:ACCESS)
(interpreter-register:access))
((INTERPRETER-CALL-RESULT:CACHE-REFERENCE)
(define (rtl:interpreter-register? rtl-register)
(case rtl-register
((MEMORY-TOP) 0)
- ((STACK-GUARD) 1)
+ ((INT-MASK) 1)
#| ((VALUE) 2) |#
((ENVIRONMENT) 3)
((TEMPORARY) 4)
#| -*-Scheme-*-
-$Id: rtlty2.scm,v 4.10 1992/11/18 00:48:50 gjr Exp $
+$Id: rtlty2.scm,v 4.11 1993/01/08 00:05:27 cph Exp $
-Copyright (c) 1988-1992 Massachusetts Institute of Technology
+Copyright (c) 1988-1993 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(define-integrable register:value
'VALUE)
+(define-integrable register:int-mask
+ 'INT-MASK)
+
+(define-integrable register:memory-top
+ 'MEMORY-TOP)
+
+(define-integrable register:free
+ 'FREE)
+
(define-integrable (rtl:interpreter-call-result:access)
(rtl:make-fetch 'INTERPRETER-CALL-RESULT:ACCESS))
#| -*-Scheme-*-
-$Id: opncod.scm,v 4.56 1992/12/30 14:13:45 gjr Exp $
+$Id: opncod.scm,v 4.57 1993/01/08 00:05:35 cph Exp $
-Copyright (c) 1988-1992 Massachusetts Institute of Technology
+Copyright (c) 1988-1993 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(define (index-locative-generator make-locative
header-length-in-objects
- address-units-per-index)
+ address-units-per-index
+ scfg*scfg->scfg!)
(let ((header-length-in-indexes
(back-end:* header-length-in-objects
(back-end:quotient address-units-per-object
(define object-memory-reference
(indexed-memory-reference
(lambda (expression) expression false)
- (index-locative-generator rtl:locative-offset 0 address-units-per-object)))
+ (index-locative-generator rtl:locative-offset
+ 0
+ address-units-per-object
+ scfg*scfg->scfg!)))
(define vector-memory-reference
(indexed-memory-reference
(lambda (expression) (rtl:make-fetch (rtl:locative-offset expression 0)))
- (index-locative-generator rtl:locative-offset 1 address-units-per-object)))
+ (index-locative-generator rtl:locative-offset
+ 1
+ address-units-per-object
+ scfg*scfg->scfg!)))
(define string-memory-reference
(indexed-memory-reference
(lambda (expression) (rtl:make-fetch (rtl:locative-offset expression 1)))
(index-locative-generator rtl:locative-byte-offset
2
- address-units-per-packed-char)))
+ address-units-per-packed-char
+ scfg*scfg->scfg!)))
\f
(define (rtl:length-fetch locative)
(rtl:make-cons-non-pointer (rtl:make-machine-constant (ucode-type fixnum))
(finish (rtl:make-eq-test (car expressions) (cadr expressions))))
'(0 1)
false))
-
+\f
(define-open-coder/predicate 'OBJECT-TYPE?
+ (lambda (operands)
+ (let ((operand (rvalue-known-value (car operands))))
+ (if (and operand
+ (rvalue/constant? operand)
+ (let ((value (constant-value operand)))
+ (and (exact-nonnegative-integer? value)
+ (back-end:< value scheme-type-limit))))
+ (values (lambda (combination expressions finish)
+ combination
+ (let ((type (car expressions))
+ (object (cadr expressions)))
+ (finish
+ (rtl:make-type-test (rtl:make-object->type object)
+ (rtl:constant-value type)))))
+ '(0 1)
+ false)
+ (values (lambda (combination expressions finish)
+ (let ((type (car expressions))
+ (object (cadr expressions)))
+ (open-code:with-checks
+ combination
+ (list
+ (open-code:type-check type (ucode-type fixnum))
+ (open-code:range-check type
+ (rtl:make-machine-constant
+ scheme-type-limit)))
+ (finish
+ (rtl:make-eq-test (rtl:make-object->datum type)
+ (rtl:make-object->type object)))
+ (lambda (expression)
+ (finish (rtl:make-true-test expression)))
+ 'OBJECT-TYPE?
+ expressions)))
+ '(0 1)
+ internal-close-coding-for-type-or-range-checks)))))
+
+(let ((open-coder
+ (simple-open-coder
+ (lambda (combination expressions finish)
+ combination
+ (finish
+ (rtl:make-cons-non-pointer
+ (rtl:make-machine-constant (ucode-type fixnum))
+ (rtl:make-object->type (car expressions)))))
+ '(0)
+ false)))
+ (define-open-coder/value 'OBJECT-TYPE open-coder)
+ (define-open-coder/value 'PRIMITIVE-OBJECT-TYPE open-coder))
+
+(define-open-coder/value 'PRIMITIVE-OBJECT-SET-TYPE
+ (filter/type-code
+ (lambda (type)
+ (lambda (combination expressions finish)
+ combination
+ (finish
+ (rtl:make-cons-non-pointer
+ (rtl:make-machine-constant type)
+ (rtl:make-object->datum (car expressions))))))
+ 0
+ '(1)
+ false))
+\f
+(define-open-coder/value 'GET-INTERRUPT-ENABLES
(simple-open-coder
(lambda (combination expressions finish)
- (let ((type (car expressions))
- (object (cadr expressions)))
- (let* ((ok? (rtl:constant? type))
- (tag (and ok?
- (rtl:constant-value type))))
- (if (and ok?
- (exact-nonnegative-integer? tag)
- (back-end:< tag scheme-type-limit))
- (finish
- (rtl:make-type-test (rtl:make-object->type object)
- tag))
- (open-code:with-checks
- combination
- (list
- (open-code:type-check type (ucode-type fixnum))
- (open-code:range-check type
- (rtl:make-machine-constant
- scheme-type-limit)))
- (finish
- (rtl:make-eq-test (rtl:make-object->datum type)
- (rtl:make-object->type object)))
- (lambda (expression)
- (finish (rtl:make-true-test expression)))
- 'OBJECT-TYPE?
- expressions)))))
- '(0 1)
+ combination expressions
+ (finish (rtl:length-fetch register:int-mask)))
+ '()
false))
+
+(define-open-coder/effect 'SET-INTERRUPT-ENABLES!
+ (simple-open-coder
+ (lambda (combination expressions finish)
+ (let ((mask (car expressions)))
+ (open-code:with-checks
+ combination
+ (list (open-code:type-check mask (ucode-type fixnum)))
+ (let ((assignment
+ (rtl:make-assignment register:int-mask
+ (rtl:make-object->datum mask))))
+ (if finish
+ (load-temporary-register scfg*scfg->scfg!
+ (rtl:length-fetch register:int-mask)
+ (lambda (temporary)
+ (scfg*scfg->scfg! assignment (finish temporary))))
+ assignment))
+ finish
+ 'SET-INTERRUPT-ENABLES!
+ expressions)
+ ))
+ '(0)
+ internal-close-coding-for-type-checks))
+\f
+(define-open-coder/value 'PRIMITIVE-GET-FREE
+ (filter/type-code
+ (lambda (type)
+ (lambda (combination expressions finish)
+ combination expressions
+ (finish
+ (rtl:make-cons-pointer (rtl:make-machine-constant type)
+ (rtl:make-fetch register:free)))))
+ 0
+ '()
+ false))
+
+(define-open-coder/effect 'PRIMITIVE-INCREMENT-FREE
+ (simple-open-coder
+ (lambda (combination expressions finish)
+ (let ((length (car expressions)))
+ (open-code:with-checks
+ combination
+ (list (open-code:type-check length (ucode-type fixnum))
+ (open-code:nonnegative-check length))
+ (let ((assignment
+ ((index-locative-generator rtl:locative-offset
+ 0
+ address-units-per-object
+ scfg*scfg->scfg!)
+ (rtl:make-fetch register:free)
+ length
+ (lambda (locative)
+ (rtl:make-assignment register:free
+ (rtl:make-address locative))))))
+ (if finish
+ (scfg*scfg->scfg! assignment
+ (finish (rtl:make-constant unspecific)))
+ assignment))
+ finish
+ 'PRIMITIVE-INCREMENT-FREE
+ expressions)))
+ '(0)
+ internal-close-coding-for-type-or-range-checks))
+
+(define-open-coder/predicate 'HEAP-AVAILABLE?
+ (simple-open-coder
+ (lambda (combination expressions finish)
+ (let ((length (car expressions)))
+ (open-code:with-checks
+ combination
+ (list (open-code:type-check length (ucode-type fixnum))
+ (open-code:nonnegative-check length))
+ ((index-locative-generator rtl:locative-offset
+ 0
+ address-units-per-object
+ scfg*pcfg->pcfg!)
+ (rtl:make-fetch register:free)
+ length
+ (lambda (locative)
+ (finish
+ (rtl:make-fixnum-pred-2-args
+ 'LESS-THAN-FIXNUM?
+ (rtl:make-address->fixnum (rtl:make-address locative))
+ (rtl:make-address->fixnum (rtl:make-fetch register:memory-top))))))
+ finish
+ 'PRIMITIVE-INCREMENT-FREE
+ expressions)))
+ '(0)
+ internal-close-coding-for-type-or-range-checks))
\f
(let ((open-code/pair-cons
(lambda (type)
(open-code:with-checks
combination
(list (open-code:nonnegative-check length))
- (finish
- (rtl:make-typed-cons:string
- (rtl:make-machine-constant (ucode-type string))
- length))
+ (scfg*scfg->scfg!
+ (finish
+ (rtl:make-typed-cons:string
+ (rtl:make-machine-constant (ucode-type string))
+ length)))
finish
'STRING-ALLOCATE
expressions)))
(let ((expression (car expressions)))
(open-code:with-checks
combination
- (if type
- (list (open-code:type-check expression type))
- '())
+ (list (open-code:type-check expression type))
(finish (make-fetch (rtl:locative-offset expression index)))
finish
name
(user-ref 'CELL-CONTENTS rtl:make-fetch (ucode-type cell) 0)
(user-ref 'VECTOR-LENGTH rtl:length-fetch (ucode-type vector) 0)
(user-ref '%RECORD-LENGTH rtl:vector-length-fetch (ucode-type record) 0)
- (user-ref 'SYSTEM-VECTOR-SIZE rtl:vector-length-fetch false 0)
(user-ref 'STRING-LENGTH rtl:length-fetch (ucode-type string) 1)
(user-ref 'BIT-STRING-LENGTH rtl:length-fetch (ucode-type vector-1b) 1)
(user-ref 'CAR rtl:make-fetch (ucode-type pair) 0)
(system-ref 'SYSTEM-PAIR-CDR rtl:make-fetch 1)
(system-ref 'SYSTEM-HUNK3-CXR0 rtl:make-fetch 0)
(system-ref 'SYSTEM-HUNK3-CXR1 rtl:make-fetch 1)
- (system-ref 'SYSTEM-HUNK3-CXR2 rtl:make-fetch 2))
-
-(let ((open-coder
- (simple-open-coder
- (lambda (combination expressions finish)
- combination
- (finish
- (rtl:make-cons-non-pointer
- (rtl:make-machine-constant (ucode-type fixnum))
- (rtl:make-object->type (car expressions)))))
- '(0)
- false)))
- (define-open-coder/value 'OBJECT-TYPE open-coder)
- (define-open-coder/value 'PRIMITIVE-OBJECT-TYPE open-coder))
+ (system-ref 'SYSTEM-HUNK3-CXR2 rtl:make-fetch 2)
+ (system-ref 'SYSTEM-VECTOR-SIZE rtl:vector-length-fetch 0))
-(define-open-coder/value 'PRIMITIVE-OBJECT-SET-TYPE
- (filter/type-code
- (lambda (type)
- (lambda (combination expressions finish)
- combination
- (finish
- (rtl:make-cons-non-pointer
- (rtl:make-machine-constant type)
- (rtl:make-object->datum (car expressions))))))
- 0
- '(1)
- false))
-\f
(let ((make-ref
(lambda (name type)
(define-open-coder/value name
(finish (rtl:make-fetch locative))))
'(0 1)
false))
-
-;; For now SYSTEM-XXXX side effect procedures are considered dangerous
-;; to the garbage collector's health. Some day we will again be able
-;; to enable them.
-
+\f
(let ((fixed-assignment
(lambda (name type index)
(define-open-coder/effect name
(let ((object (car expressions)))
(open-code:with-checks
combination
- (if type (list (open-code:type-check object type)) '())
+ (list (open-code:type-check object type))
(finish-vector-assignment (rtl:locative-offset object index)
(cadr expressions)
finish)
internal-close-coding-for-type-checks)))))
(fixed-assignment 'SET-CAR! (ucode-type pair) 0)
(fixed-assignment 'SET-CDR! (ucode-type pair) 1)
- (fixed-assignment 'SET-CELL-CONTENTS! (ucode-type cell) 0)
- #|
- (fixed-assignment 'SYSTEM-PAIR-SET-CAR! false 0)
- (fixed-assignment 'SYSTEM-PAIR-SET-CDR! false 1)
- (fixed-assignment 'SYSTEM-HUNK3-SET-CXR0! false 0)
- (fixed-assignment 'SYSTEM-HUNK3-SET-CXR1! false 1)
- (fixed-assignment 'SYSTEM-HUNK3-SET-CXR2! false 2)
- |#)
+ (fixed-assignment 'SET-CELL-CONTENTS! (ucode-type cell) 0))
+
+(define-open-coder/effect 'SET-STRING-LENGTH!
+ (simple-open-coder
+ (lambda (combination expressions finish)
+ (let ((object (car expressions))
+ (length (cadr expressions)))
+ (open-code:with-checks
+ combination
+ (list (open-code:type-check object (ucode-type string))
+ (open-code:type-check length (ucode-type fixnum))
+ (open-code:nonnegative-check length))
+ (finish-vector-assignment (rtl:locative-offset object 1)
+ (rtl:make-object->datum length)
+ finish)
+ finish
+ 'SET-STRING-LENGTH!
+ expressions)))
+ '(0 1)
+ internal-close-coding-for-type-or-range-checks))
(let ((make-assignment
(lambda (name type)
'(0 1 2)
internal-close-coding-for-type-or-range-checks)))))
(make-assignment 'VECTOR-SET! (ucode-type vector))
- (make-assignment '%RECORD-SET! (ucode-type record))
- #|(make-assignment 'SYSTEM-VECTOR-SET! false)|#)
+ (make-assignment '%RECORD-SET! (ucode-type record)))
(define-open-coder/effect 'PRIMITIVE-OBJECT-SET!
(simple-open-coder
false)))
'(ZERO-FIXNUM? POSITIVE-FIXNUM? NEGATIVE-FIXNUM?))
\f
-;;; Floating Point Arithmetic
+;;;; Floating Point Arithmetic
;; On some machines, there are optional floating-point co-processors,
;; The decision of whether to open-code floating-point arithmetic or
internal-close-coding-for-type-checks)))
'(FLONUM-EQUAL? FLONUM-LESS? FLONUM-GREATER?))
\f
-;;; Generic arithmetic
+;;;; Generic arithmetic
(define (generic-binary-operator generic-op)
(define-open-coder/value generic-op
projects / mit-scheme.git / commitdiff