From: Henry M. Wu Date: Mon, 9 May 1988 19:57:17 +0000 (+0000) Subject: Added string/char open-coding. X-Git-Tag: 20090517-FFI~12771 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=071a15d14f2d1bc6947d7790d6850f0c71f85632;p=mit-scheme.git Added string/char open-coding. --- diff --git a/v7/src/compiler/machines/bobcat/lapgen.scm b/v7/src/compiler/machines/bobcat/lapgen.scm index 06511ad61..33e85545d 100644 --- a/v7/src/compiler/machines/bobcat/lapgen.scm +++ b/v7/src/compiler/machines/bobcat/lapgen.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/lapgen.scm,v 4.5 1988/05/03 01:04:25 mhwu Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/lapgen.scm,v 4.6 1988/05/09 19:49:36 mhwu Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -53,9 +53,12 @@ MIT in each case. |# (define-integrable (machine->pseudo-register source target) (machine-register->memory source (pseudo-register-home target))) +(define-integrable (pseudo-register-offset register) + (+ #x000A (register-renumber register))) + (define-integrable (pseudo-register-home register) (offset-reference regnum:regs-pointer - (+ #x000A (register-renumber register)))) + (pseudo-register-offset register))) (define-integrable (machine->machine-register source target) (INST (MOV L @@ -72,14 +75,27 @@ MIT in each case. |# ,source ,(register-reference target)))) -(define (offset-reference register offset) - (if (zero? offset) - (if (< register 8) - (INST-EA (@D ,register)) - (INST-EA (@A ,(- register 8)))) - (if (< register 8) - (INST-EA (@DO ,register ,(* 4 offset))) - (INST-EA (@AO ,(- register 8) ,(* 4 offset)))))) +(package (offset-reference byte-offset-reference) + +(define ((make-offset-reference grain-size) register offset) + (if (zero? offset) + (if (< register 8) + (INST-EA (@D ,register)) + (INST-EA (@A ,(- register 8)))) + (if (< register 8) + (INST-EA (@DO ,register ,(* grain-size offset))) + (INST-EA (@AO ,(- register 8) ,(* grain-size offset)))))) + +(define-export offset-reference + (make-offset-reference + (quotient scheme-object-width addressing-granularity))) + +(define-export byte-offset-reference + (make-offset-reference + (quotient 8 addressing-granularity))) +;;; End PACKAGE +) + (define (load-dnw n d) (cond ((zero? n) @@ -215,7 +231,10 @@ MIT in each case. |# (define-integrable (register-effective-address? effective-address) (memq (lap:ea-keyword effective-address) '(A D))) -(define (indirect-reference! register offset) + +(package (indirect-reference! indirect-byte-reference!) + +(define ((make-indirect-reference offset-reference) register offset) (offset-reference (if (machine-register? register) register @@ -229,6 +248,13 @@ MIT in each case. |# (load-alias-register! register 'ADDRESS)))) offset)) +(define-export indirect-reference! + (make-indirect-reference offset-reference)) +(define-export indirect-byte-reference! + (make-indirect-reference byte-offset-reference)) +;;; End PACKAGE +) + (define (coerce->any register) (if (machine-register? register) (register-reference register) @@ -248,6 +274,15 @@ MIT in each case. |# (LAP (MOV L ,(coerce->any source) ,(register-reference register))))) +(define (coerce->any/byte-reference register) + (if (machine-register? register) + (register-reference register) + (let ((alias (register-alias register false))) + (if alias + (register-reference alias) + (indirect-char/ascii-reference! regnum:regs-pointer + (pseudo-register-offset register)))))) + (define (code-object-label-initialize code-object) false) @@ -449,7 +484,52 @@ MIT in each case. |# ((ONE-PLUS-FIXNUM) fixnum-one-plus-gen) ((MINUS-ONE-PLUS-FIXNUM) fixnum-minus-one-plus-gen) )) + +;;;; OBJECT->DATUM rules - Mhwu +;;; Similar to fixnum rules, but no sign extension +(define (load-constant-datum constant register-ref) + (if (non-pointer-object? constant) + (INST (MOV L (& ,(primitive-datum constant)) ,register-ref)) + (LAP (MOV L + (@PCR ,(constant->label constant)) + ,register-ref) + ,(scheme-object->datum register-ref)))) + +(define (scheme-object->datum register-reference) + (INST (AND L ,mask-reference ,register-reference))) + +;;;; CHAR->ASCII rules + +(define (indirect-char/ascii-reference! register offset) + (indirect-byte-reference! register (+ (* offset 4) 3))) + +(define (char->signed-8-bit-immediate character) + (let ((ascii (char->ascii character))) + (if (< ascii 128) ascii (- ascii 256)))) + +;;; This code uses a temporary register because right now the register +;;; allocator thinks that it could use the same register for the target +;;; and source, while what we want to happen is to first clear the target +;;; and then move from source to target. +;;; Optimal Code: (CLR L ,target-ref) +;;; (MOV B ,source ,target) +;;; source-register is passed in to check for this. Yuck. +(define (byte-offset->register source source-reg target) + (delete-dead-registers!) + (let* ((temp-ref (register-reference (allocate-temporary-register! 'DATA))) + (target (allocate-alias-register! target 'DATA))) + (if (= target source-reg) + (LAP (CLR L ,temp-ref) + (MOV B ,source ,temp-ref) + (MOV L ,temp-ref ,(register-reference target))) + (LAP (CLR L ,(register-reference target)) + (MOV B ,source ,(register-reference target)))))) + +(define (indirect-register register) + (if (machine-register? register) + register + (register-alias register false))) (define-integrable (data-register? register) (< register 8)) @@ -501,4 +581,4 @@ MIT in each case. |# (define-integrable popper:apply-closure (INST-EA (@AO 6 #x0168))) (define-integrable popper:apply-stack (INST-EA (@AO 6 #x01A8))) -(define-integrable popper:value (INST-EA (@AO 6 #x01E8))) +(define-integrable popper:value (INST-EA (@AO 6 #x01E8))) \ No newline at end of file diff --git a/v7/src/compiler/machines/bobcat/machin.scm b/v7/src/compiler/machines/bobcat/machin.scm index 88214886d..c4a9e3542 100644 --- a/v7/src/compiler/machines/bobcat/machin.scm +++ b/v7/src/compiler/machines/bobcat/machin.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/machin.scm,v 4.7 1988/05/03 01:09:33 mhwu Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/machin.scm,v 4.8 1988/05/09 19:48:57 mhwu Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -38,6 +38,7 @@ MIT in each case. |# ;;; Size of words. Some of the stuff in "assmd.scm" might want to ;;; come here. +(define-integrable addressing-granularity 8) (define-integrable scheme-object-width 32) (define-integrable scheme-datum-width 24) (define-integrable scheme-type-width 8) @@ -127,6 +128,9 @@ MIT in each case. |# ;; or.l #x01AFFFFF,reg = 8 ((MINUS-ONE-PLUS-FIXNUM) 17) (else (error "rtl:expression-cost - unknown fixnum operator" expression)))) + ;; The following are preliminary. Check with Jinx (mhwu) + ((CHAR->ASCII) 4) + ((BYTE-OFFSET) 12) (else (error "Unknown expression type" expression)))) (define (rtl:machine-register? rtl-register) diff --git a/v7/src/compiler/machines/bobcat/rules1.scm b/v7/src/compiler/machines/bobcat/rules1.scm index dc7cddbb3..c9ca0bd65 100644 --- a/v7/src/compiler/machines/bobcat/rules1.scm +++ b/v7/src/compiler/machines/bobcat/rules1.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rules1.scm,v 4.6 1988/04/22 16:20:11 markf Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rules1.scm,v 4.7 1988/05/09 19:57:17 mhwu Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -252,6 +252,84 @@ MIT in each case. |# (add-pseudo-register-alias! target temp-reg false) operation))) +;;;; OBJECT->DATUM rules. Assignment is always to a register. + +(define-rule statement + (ASSIGN (REGISTER (? target)) (OBJECT->DATUM (CONSTANT (? datum)))) + (QUALIFIER (pseudo-register? target)) + (delete-dead-registers!) + (let ((target-ref + (register-reference (allocate-alias-register! target 'DATA)))) + (load-constant-datum datum target-ref))) + +(define-rule statement + (ASSIGN (REGISTER (? target)) (OBJECT->DATUM (REGISTER (? source)))) + (QUALIFIER (pseudo-register? target)) + (let ((target-ref (move-to-alias-register! source 'DATA target))) + (LAP ,(scheme-object->datum target-ref)))) + +(define-rule statement + (ASSIGN (REGISTER (? target)) + (OBJECT->DATUM (OFFSET (REGISTER (? address)) (? offset)))) + (QUALIFIER (pseudo-register? target)) + (let ((source (indirect-reference! address offset))) + (delete-dead-registers!) + (let ((target-ref + (register-reference (allocate-alias-register! target 'DATA)))) + (LAP (MOV L ,source ,target-ref) + ,(scheme-object->datum target-ref))))) + + +;;;; CHAR->ASCII/BYTE-OFFSET + +(define-rule statement + (ASSIGN (REGISTER (? target)) + (CHAR->ASCII (OFFSET (REGISTER (? address)) (? offset)))) + (QUALIFIER (pseudo-register? target)) + (byte-offset->register (indirect-char/ascii-reference! address offset) + (indirect-register address) + target)) + +(define-rule statement + (ASSIGN (REGISTER (? target)) (CHAR->ASCII (REGISTER (? source)))) + (QUALIFIER (pseudo-register? target)) + (if (machine-register? source) + (LAP (BFEXTU ,(register-reference source) + (& 0) (& 8) + ,(register-reference (allocate-alias-register! target 'DATA)))) + (byte-offset->register + (indirect-char/ascii-reference! regnum:regs-pointer + (pseudo-register-offset source)) + (indirect-register regnum:regs-pointer) + target))) + +(define-rule statement + (ASSIGN (BYTE-OFFSET (REGISTER (? address)) (? offset)) + (CHAR->ASCII (REGISTER (? source)))) + (let ((source (coerce->any/byte-reference source))) + (let ((target (indirect-byte-reference! address offset))) + (LAP (MOV B ,source ,target))))) + +(define-rule statement + (ASSIGN (BYTE-OFFSET (REGISTER (? address)) (? offset)) + (CHAR->ASCII (CONSTANT (? character)))) + (LAP (MOV B (& ,(char->signed-8-bit-immediate character)) + ,(indirect-byte-reference! address offset)))) + +(define-rule statement + (ASSIGN (REGISTER (? target)) (BYTE-OFFSET (REGISTER (? address)) (? offset))) + (QUALIFIER (pseudo-register? target)) + (byte-offset->register (indirect-byte-reference! address offset) + (indirect-register address) + target)) + +(define-rule statement + (ASSIGN (BYTE-OFFSET (REGISTER (? target)) (? target-offset)) + (CHAR->ASCII (OFFSET (REGISTER (? source)) (? source-offset)))) + (let ((source (indirect-char/ascii-reference! source source-offset))) + (LAP (MOV B ,source ,(indirect-byte-reference! target target-offset))))) + + ;;;; Transfers to Memory (define-rule statement diff --git a/v7/src/compiler/rtlbase/rtlcon.scm b/v7/src/compiler/rtlbase/rtlcon.scm index 9e6f98eb7..454d75016 100644 --- a/v7/src/compiler/rtlbase/rtlcon.scm +++ b/v7/src/compiler/rtlbase/rtlcon.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlcon.scm,v 4.6 1988/04/26 18:33:37 markf Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlcon.scm,v 4.7 1988/05/09 19:52:24 mhwu Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -197,11 +197,19 @@ MIT in each case. |# expression-simplify-for-statement expression-simplify-for-predicate) +(define (make-offset register offset granularity) + (cond ((eq? granularity 'OBJECT) + (rtl:make-offset register offset)) + ((eq? granularity 'BYTE) + (rtl:make-byte-offset register offset)) + (else + (error "Unknown offset granularity" register offset granularity)))) + (define-export (locative-dereference-for-statement locative receiver) (locative-dereference locative scfg*scfg->scfg! receiver - (lambda (register offset) - (receiver (rtl:make-offset register offset))))) + (lambda (register offset granularity) + (receiver (make-offset register offset granularity))))) (define (locative-dereference locative scfg-append! if-register if-memory) (locative-dereference-1 locative scfg-append! locative-fetch @@ -214,51 +222,53 @@ MIT in each case. |# (if register (if-register register) (if-memory (interpreter-regs-pointer) - (rtl:interpreter-register->offset locative))))) + (rtl:interpreter-register->offset locative) + 'OBJECT)))) ((pair? locative) (case (car locative) ((REGISTER) (if-register locative)) ((FETCH) - (locative-fetch (cadr locative) 0 scfg-append! if-memory)) + (locative-fetch (cadr locative) 0 'OBJECT scfg-append! if-memory)) ((OFFSET) - (let ((fetch (cadr locative))) + (let ((fetch (rtl:locative-offset-base locative))) (if (and (pair? fetch) (eq? (car fetch) 'FETCH)) (locative-fetch (cadr fetch) - (caddr locative) + (rtl:locative-offset-offset locative) + (rtl:locative-offset-granularity locative) scfg-append! if-memory) (error "LOCATIVE-DEREFERENCE: Bad OFFSET" locative)))) ((CONSTANT) (assign-to-temporary locative scfg-append! - (lambda (register) + (lambda (register) (assign-to-address-temporary register scfg-append! (lambda (register) - (if-memory register 0)))))) + (if-memory register 0 'OBJECT)))))) (else (error "LOCATIVE-DEREFERENCE: Unknown keyword" (car locative))))) (else (error "LOCATIVE-DEREFERENCE: Illegal locative" locative)))) -(define (locative-fetch locative offset scfg-append! receiver) +(define (locative-fetch locative offset granularity scfg-append! receiver) (let ((receiver (lambda (register) (guarantee-address register scfg-append! (lambda (address) - (receiver address offset)))))) + (receiver address offset granularity)))))) (locative-dereference locative scfg-append! receiver - (lambda (register offset) - (assign-to-temporary (rtl:make-offset register offset) + (lambda (register offset granularity) + (assign-to-temporary (make-offset register offset granularity) scfg-append! receiver))))) -(define (locative-fetch-1 locative offset scfg-append! receiver) +(define (locative-fetch-1 locative offset granularity scfg-append! receiver) (locative-dereference locative scfg-append! (lambda (register) - (receiver register offset)) - (lambda (register offset*) - (receiver (rtl:make-offset register offset*) offset)))) + (receiver register offset granularity)) + (lambda (register offset* granularity*) + (receiver (make-offset register offset* granularity*) offset granularity)))) (define (guarantee-address expression scfg-append! receiver) (if (rtl:address-valued-expression? expression) @@ -272,12 +282,14 @@ MIT in each case. |# (receiver expression) (assign-to-temporary expression scfg-append! receiver))) -(define (generate-offset-address expression offset scfg-append! receiver) - (guarantee-address expression scfg-append! - (lambda (address) - (guarantee-register address scfg-append! - (lambda (register) - (receiver (rtl:make-offset-address register offset))))))) +(define (generate-offset-address expression offset granularity scfg-append! receiver) + (if (eq? granularity 'OBJECT) + (guarantee-address expression scfg-append! + (lambda (address) + (guarantee-register address scfg-append! + (lambda (register) + (receiver (rtl:make-offset-address register offset)))))) + (error "Byte Offset Address not implemented" expression offset))) (define-export (expression-simplify-for-statement expression receiver) (expression-simplify expression scfg*scfg->scfg! receiver)) @@ -338,11 +350,12 @@ MIT in each case. |# (define-expression-method 'ADDRESS (address-method (lambda (receiver scfg-append!) - (lambda (expression offset) + (lambda (expression offset granularity) (if (zero? offset) (guarantee-address expression scfg-append! receiver) (generate-offset-address expression offset + granularity scfg-append! receiver)))))) @@ -362,13 +375,13 @@ MIT in each case. |# (define-expression-method 'ENVIRONMENT (address-method (lambda (receiver scfg-append!) - (lambda (expression offset) + (lambda (expression offset granularity) (if (zero? offset) (receiver (if (rtl:address-valued-expression? expression) (rtl:make-address->environment expression) expression)) - (generate-offset-address expression offset scfg-append! + (generate-offset-address expression offset granularity scfg-append! (lambda (expression) (assign-to-temporary expression scfg-append! (lambda (register) @@ -378,8 +391,8 @@ MIT in each case. |# (lambda (receiver scfg-append! locative) (locative-dereference locative scfg-append! receiver - (lambda (register offset) - (receiver (rtl:make-offset register offset)))))) + (lambda (register offset granularity) + (receiver (make-offset register offset granularity)))))) (define-expression-method 'TYPED-CONS:PAIR (lambda (receiver scfg-append! type car cdr) @@ -441,8 +454,18 @@ MIT in each case. |# (define-expression-method 'OBJECT->TYPE (object-selector rtl:make-object->type)) +(define-expression-method 'CHAR->ASCII + (object-selector rtl:make-char->ascii)) + (define-expression-method 'OBJECT->DATUM - (object-selector rtl:make-object->datum)) + (lambda (receiver scfg-append! expression) + (expression-simplify* expression scfg-append! + (lambda (s-expression) + (assign-to-temporary + (rtl:make-object->datum s-expression) + scfg-append! + (lambda (temporary) + (receiver temporary))))))) (define-expression-method 'OBJECT->ADDRESS (object-selector rtl:make-object->address)) diff --git a/v7/src/compiler/rtlbase/rtlexp.scm b/v7/src/compiler/rtlbase/rtlexp.scm index 2b555a7fd..090586ff7 100644 --- a/v7/src/compiler/rtlbase/rtlexp.scm +++ b/v7/src/compiler/rtlbase/rtlexp.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlexp.scm,v 4.4 1988/04/25 21:44:58 markf Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlexp.scm,v 4.5 1988/05/09 19:51:39 mhwu Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -91,7 +91,7 @@ MIT in each case. |# ;;; combinatorial explosion. When that happens the next test may ;;; be replaced by true. (not (memq (rtl:expression-type expression) - '(OBJECT->FIXNUM)))) + '(OBJECT->FIXNUM OBJECT->DATUM)))) ;; Mhwu (define (rtl:map-subexpressions expression procedure) (if (rtl:constant? expression) diff --git a/v7/src/compiler/rtlbase/rtlty1.scm b/v7/src/compiler/rtlbase/rtlty1.scm index b79fa81ab..f514f469f 100644 --- a/v7/src/compiler/rtlbase/rtlty1.scm +++ b/v7/src/compiler/rtlbase/rtlty1.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlty1.scm,v 4.5 1988/04/25 21:27:54 markf Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlty1.scm,v 4.6 1988/05/09 19:50:30 mhwu Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -36,9 +36,11 @@ MIT in each case. |# (declare (usual-integrations)) +(define-rtl-expression char->ascii rtl: expression) +(define-rtl-expression byte-offset rtl: register number) (define-rtl-expression register % number) (define-rtl-expression object->address rtl: register) -(define-rtl-expression object->datum rtl: register) +(define-rtl-expression object->datum rtl: expression) (define-rtl-expression object->type rtl: register) (define-rtl-expression object->fixnum rtl: expression) (define-rtl-expression offset rtl: register number) diff --git a/v7/src/compiler/rtlbase/rtlty2.scm b/v7/src/compiler/rtlbase/rtlty2.scm index 9770703f6..239b86eef 100644 --- a/v7/src/compiler/rtlbase/rtlty2.scm +++ b/v7/src/compiler/rtlbase/rtlty2.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlty2.scm,v 4.3 1988/03/14 21:05:05 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlty2.scm,v 4.4 1988/05/09 19:51:06 mhwu Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -89,58 +89,49 @@ MIT in each case. |# (define-integrable (rtl:interpreter-call-result:unbound?) (rtl:make-fetch 'INTERPRETER-CALL-RESULT:UNBOUND?)) -(define (rtl:locative-offset locative offset) - (cond ((zero? offset) locative) - ((and (pair? locative) (eq? (car locative) 'OFFSET)) - `(OFFSET ,(cadr locative) ,(+ (caddr locative) offset))) - (else `(OFFSET ,locative ,offset)))) -;;; Expressions that are used in the intermediate form. - -(define-integrable (rtl:make-address locative) - `(ADDRESS ,locative)) - -(define-integrable (rtl:make-environment locative) - `(ENVIRONMENT ,locative)) - -(define-integrable (rtl:make-cell-cons expression) - `(CELL-CONS ,expression)) - -(define-integrable (rtl:make-fetch locative) - `(FETCH ,locative)) - -(define-integrable (rtl:make-typed-cons:pair type car cdr) - `(TYPED-CONS:PAIR ,type ,car ,cdr)) +;;; "Pre-simplification" locative offsets -(define-integrable (rtl:make-typed-cons:vector type elements) - `(TYPED-CONS:VECTOR ,type ,@elements)) +(define (rtl:locative-offset? locative) + (and (pair? locative) (eq? (car locative) 'OFFSET))) -(define-integrable (rtl:make-typed-cons:procedure label arg-info nvars) - `(TYPED-CONS:PROCEDURE ,label ,arg-info ,nvars)) +(define-integrable rtl:locative-offset-base cadr) +(define-integrable rtl:locative-offset-offset caddr) -;;; Linearizer Support +(define (rtl:locative-offset-granularity locative) + ;; This is kludged up for backward compatibility + (if (rtl:locative-offset? locative) + (if (pair? (cdddr locative)) + (cadddr locative) + 'OBJECT) + (error "Not a locative offset" locative))) -(define-integrable (rtl:make-jump-statement label) - `(JUMP ,label)) +(define-integrable (rtl:locative-byte-offset? locative) + (eq? (rtl:locative-offset-granularity locative) 'BYTE)) -(define-integrable (rtl:make-jumpc-statement predicate label) - `(JUMPC ,predicate ,label)) +(define-integrable (rtl:locative-object-offset? locative) + (eq? (rtl:locative-offset-granularity locative) 'OBJECT)) -(define-integrable (rtl:make-label-statement label) - `(LABEL ,label)) - -(define-integrable (rtl:negate-predicate expression) - `(NOT ,expression)) - -;;; Stack - -(define-integrable (stack-locative-offset locative offset) - (rtl:locative-offset locative (stack->memory-offset offset))) - -(define-integrable (stack-push-address) - (rtl:make-pre-increment (interpreter-stack-pointer) - (stack->memory-offset -1))) +(define (rtl:locative-offset locative offset) + (cond ((zero? offset) locative) + ((rtl:locative-offset? locative) + (if (rtl:locative-byte-offset? locative) + (error "Can't add object-offset to byte-offset" + locative offset) + `(OFFSET ,(rtl:locative-offset-base locative) + ,(+ (rtl:locative-offset-offset locative) offset) + OBJECT))) + (else `(OFFSET ,locative ,offset OBJECT)))) + +(define (rtl:locative-byte-offset locative byte-offset) + (cond ((zero? byte-offset) locative) + ((rtl:locative-offset? locative) + `(OFFSET ,(rtl:locative-offset-base locative) + ,(+ byte-offset + (if (rtl:locative-byte-offset? locative) + (rtl:locative-offset-offset locative) + (* (rtl:locative-offset-offset locative) + (quotient scheme-object-width 8)))) + BYTE)) + (else `(OFFSET ,locative ,byte-offset BYTE)))) -(define-integrable (stack-pop-address) - (rtl:make-post-increment (interpreter-stack-pointer) - (stack->memory-offset 1))) \ No newline at end of file diff --git a/v7/src/compiler/rtlgen/opncod.scm b/v7/src/compiler/rtlgen/opncod.scm index b4a9cb5db..8d2805698 100644 --- a/v7/src/compiler/rtlgen/opncod.scm +++ b/v7/src/compiler/rtlgen/opncod.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/opncod.scm,v 4.5 1988/04/22 16:39:45 markf Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/opncod.scm,v 4.6 1988/05/09 19:53:08 mhwu Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -427,5 +427,63 @@ MIT in each case. |# define-fixnum-pred-1-arg '(ZERO-FIXNUM? POSITIVE-FIXNUM? NEGATIVE-FIXNUM?))) + +;;; Character open-coding + +(let ((define-character->fixnum + (lambda (character->fixnum rtl:coercion) + (define-open-coder/value character->fixnum + (lambda (operand) + (return-2 (lambda (expressions finish) + (finish (rtl:make-cons-pointer + (rtl:make-constant (ucode-type fixnum)) + (rtl:coercion (car expressions))))) + '(0))))))) + (define-character->fixnum 'CHAR->INTEGER rtl:make-object->datum) + (define-character->fixnum 'CHAR->ASCII rtl:make-char->ascii)) + +;;; String + +(let ((string-header-size (quotient (* 2 scheme-object-width) 8))) + +(define-open-coder/value 'STRING-REF + (lambda (operands) + (filter/nonnegative-integer (cadr operands) + (lambda (index) + (return-2 + (lambda (expressions finish) + (finish (rtl:make-cons-pointer + (rtl:make-constant (ucode-type character)) + (rtl:make-fetch + (rtl:locative-byte-offset (car expressions) + (+ string-header-size index)))))) + '(0)))))) + +(define-open-coder/effect 'STRING-SET! + (lambda (operands) + (filter/nonnegative-integer (cadr operands) + (lambda (index) + (return-2 + (lambda (expressions finish) + (let* ((locative + (rtl:locative-byte-offset (car expressions) + (+ string-header-size index))) + (assignment + (rtl:make-assignment locative (rtl:make-char->ascii + (cadr expressions))))) + (if finish + (let ((temporary (rtl:make-pseudo-register))) + (scfg-append! + (rtl:make-assignment temporary + (rtl:make-cons-pointer + (rtl:make-constant (ucode-type character)) + (rtl:make-fetch locative))) + assignment + (finish (rtl:make-fetch temporary)))) + assignment))) + '(0 2)))))) +;;; End STRING operations, LET +) + ;;; end COMBINATION/INLINE ) \ No newline at end of file diff --git a/v7/src/compiler/rtlopt/rcse2.scm b/v7/src/compiler/rtlopt/rcse2.scm index 243369e31..710e799f6 100644 --- a/v7/src/compiler/rtlopt/rcse2.scm +++ b/v7/src/compiler/rtlopt/rcse2.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rcse2.scm,v 4.5 1988/04/26 18:48:18 markf Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rcse2.scm,v 4.6 1988/05/09 19:54:06 mhwu Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -102,6 +102,7 @@ MIT in each case. |# '(OBJECT->ADDRESS OBJECT->DATUM OBJECT->TYPE OBJECT->FIXNUM + CHAR->ASCII OFFSET-ADDRESS VARIABLE-CACHE ASSIGNMENT-CACHE))))))) @@ -113,7 +114,7 @@ MIT in each case. |# (define (expression-address-varies? expression) (and (not (interpreter-register-reference? expression)) (or (memq (rtl:expression-type expression) - '(OFFSET PRE-INCREMENT POST-INCREMENT))) + '(OFFSET BYTE-OFFSET PRE-INCREMENT POST-INCREMENT))) (rtl:any-subexpression? expression expression-address-varies?))) (define (expression-invalidate! expression) @@ -283,6 +284,9 @@ MIT in each case. |# (quantity-number (stack-reference-quantity expression)) (begin (set! hash-arg-in-memory? true) (continue expression)))) + ((BYTE-OFFSET) + (set! hash-arg-in-memory? true) + (continue expression)) ((PRE-INCREMENT POST-INCREMENT) (set! hash-arg-in-memory? true) (set! do-not-record? true) diff --git a/v7/src/compiler/rtlopt/rcseep.scm b/v7/src/compiler/rtlopt/rcseep.scm index 07998d9ec..99d45b750 100644 --- a/v7/src/compiler/rtlopt/rcseep.scm +++ b/v7/src/compiler/rtlopt/rcseep.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rcseep.scm,v 4.2 1987/12/31 07:00:47 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rcseep.scm,v 4.3 1988/05/09 19:54:46 mhwu Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -46,7 +46,7 @@ MIT in each case. |# (case type ((REGISTER) (register-equivalent? x y)) - ((OFFSET) + ((OFFSET BYTE-OFFSET) (let ((rx (rtl:offset-register x))) (and (register-equivalent? rx (rtl:offset-register y)) (if (interpreter-stack-pointer? rx)