#| -*-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
(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
,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
+)
+
\f
(define (load-dnw n d)
(cond ((zero? n)
(define-integrable (register-effective-address? effective-address)
(memq (lap:ea-keyword effective-address) '(A D)))
\f
-(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
(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)
(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)
((ONE-PLUS-FIXNUM) fixnum-one-plus-gen)
((MINUS-ONE-PLUS-FIXNUM) fixnum-minus-one-plus-gen)
))
+\f
+;;;; 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)))
\f
(define-integrable (data-register? register)
(< register 8))
(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
#| -*-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
\f;;; 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)
;; 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))))
\f
(define (rtl:machine-register? rtl-register)
#| -*-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
(add-pseudo-register-alias! target temp-reg false)
operation)))
\f
+;;;; 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)))))
+
+\f
+;;;; 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)))))
+
+\f
;;;; Transfers to Memory
(define-rule statement
#| -*-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
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
(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))))
\f
-(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)
(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)))
\f
(define-export (expression-simplify-for-statement expression receiver)
(expression-simplify expression scfg*scfg->scfg! receiver))
(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))))))
(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)
(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)
(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))
#| -*-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
;;; 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
\f
(define (rtl:map-subexpressions expression procedure)
(if (rtl:constant? expression)
#| -*-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
(declare (usual-integrations))
\f
+(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)
#| -*-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
(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))))
\f
-;;; 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
#| -*-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
define-fixnum-pred-1-arg
'(ZERO-FIXNUM? POSITIVE-FIXNUM? NEGATIVE-FIXNUM?)))
+\f
+;;; 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
#| -*-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
'(OBJECT->ADDRESS OBJECT->DATUM
OBJECT->TYPE
OBJECT->FIXNUM
+ CHAR->ASCII
OFFSET-ADDRESS
VARIABLE-CACHE
ASSIGNMENT-CACHE)))))))
(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)
(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)
#| -*-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
(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)
projects / mit-scheme.git / commitdiff