#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/opncod.scm,v 4.26 1989/01/07 01:25:15 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/opncod.scm,v 4.27 1989/01/21 09:12:29 cph Exp $
-Copyright (c) 1988 Massachusetts Institute of Technology
+Copyright (c) 1988, 1989 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
finish))
false)))))
+(define (combination/inline/simple? combination)
+ (not (memq (primitive-procedure-name
+ (constant-value
+ (rvalue-known-value (combination/operator combination))))
+ non-simple-primitive-names)))
+
(define (subproblem->expression subproblem)
(let ((rvalue (subproblem-rvalue subproblem)))
(let ((value (rvalue-known-value rvalue)))
(open-coder-definer invoke/value->effect
invoke/value->predicate
invoke/value->value))
+
+(define (define-non-simple-primitive! name)
+ (if (not (memq name non-simple-primitive-names))
+ (set! non-simple-primitive-names (cons name non-simple-primitive-names)))
+ unspecific)
+
+(define non-simple-primitive-names
+ '())
\f
;;;; Operand Filters
-(define (filter/constant rvalue predicate generator)
- (let ((operand (rvalue-known-value rvalue)))
- (and operand
- (rvalue/constant? operand)
- (let ((value (constant-value operand)))
- (and (predicate value)
- (generator value))))))
-
-(define (filter/nonnegative-integer operand generator)
- (filter/constant operand
- (lambda (value)
- (and (integer? value)
- (not (negative? value))))
- generator))
-
-(define (filter/positive-integer operand generator)
- (filter/constant operand
- (lambda (value)
- (and (integer? value)
- (positive? value)))
- generator))
+(define (simple-open-coder generator operand-indices)
+ (lambda (operands)
+ operands
+ (return-2 generator operand-indices)))
+
+(define (constant-filter predicate)
+ (lambda (generator constant-index operand-indices)
+ (lambda (operands)
+ (let ((operand (rvalue-known-value (list-ref operands constant-index))))
+ (and operand
+ (rvalue/constant? operand)
+ (let ((value (constant-value operand)))
+ (and (predicate value)
+ (return-2 (generator value) operand-indices))))))))
+
+(define filter/nonnegative-integer
+ (constant-filter
+ (lambda (value) (and (integer? value) (not (negative? value))))))
+
+(define filter/positive-integer
+ (constant-filter
+ (lambda (value) (and (integer? value) (positive? value)))))
\f
;;;; Constraint Checkers
-(define-integrable (make-invocation operator operands)
- `(,operator ,@operands))
-
(define (open-code:with-checks context checks non-error-cfg error-finish
- prim-invocation)
+ primitive-name expressions)
(let ((checks (list-transform-negative checks cfg-null?)))
(if (null? checks)
non-error-cfg
(with-values (lambda () (generate-continuation-entry context))
(lambda (label setup cleanup)
(scfg-append!
- (generate-primitive (car prim-invocation)
- (cdr prim-invocation)
- setup
- label)
+ (generate-primitive primitive-name expressions setup label)
cleanup
(if error-finish
(error-finish (rtl:make-fetch register:value))
(pcfg*scfg->scfg! (car checks)
(loop (cdr checks)) error-cfg)))))))
-(define (open-code:limit-check checkee-locative limit-locative)
- (if compiler:generate-range-checks?
- (pcfg/prefer-consequent!
- (rtl:make-fixnum-pred-2-args
- 'LESS-THAN-FIXNUM?
- (rtl:make-object->fixnum checkee-locative)
- (rtl:make-object->fixnum limit-locative)))
- (make-null-cfg)))
-
-(define (open-code:range-check checkee-locative limit-locative)
- (if compiler:generate-range-checks?
- (pcfg*pcfg->pcfg!
- (open-code:limit-check checkee-locative limit-locative)
- (pcfg-invert
- (pcfg/prefer-alternative!
- (rtl:make-fixnum-pred-1-arg
- 'NEGATIVE-FIXNUM?
- (rtl:make-object->fixnum checkee-locative))))
- (make-null-cfg))
- (make-null-cfg)))
-
-(define (open-code:type-check checkee-locative type)
- (if compiler:generate-type-checks?
- (generate-type-test type
- checkee-locative
- make-false-pcfg
- make-true-pcfg
- identity-procedure)
- (make-null-cfg)))
-\f
(define (generate-primitive name argument-expressions
continuation-setup continuation-label)
(scfg*scfg->scfg!
(1+ (length argument-expressions))
continuation-label
primitive))))
+\f
+(define (open-code:type-check expression type)
+ (if compiler:generate-type-checks?
+ (generate-type-test type
+ expression
+ make-false-pcfg
+ make-true-pcfg
+ identity-procedure)
+ (make-null-cfg)))
(define (generate-type-test type expression if-false if-true if-test)
- (let ((mu-type (microcode-type type)))
- (if (rtl:constant? expression)
- (if (eq? mu-type (object-type (rtl:constant-value expression)))
- (if-true)
- (if-false))
- (if-test
- (pcfg/prefer-consequent!
- (rtl:make-type-test (rtl:make-object->type expression) mu-type))))))
+ (if (rtl:constant? expression)
+ (if (object-type? type (rtl:constant-value expression))
+ (if-true)
+ (if-false))
+ (if-test
+ (pcfg/prefer-consequent!
+ (rtl:make-type-test (rtl:make-object->type expression) type)))))
+
+(define (open-code:range-check index-expression limit-locative)
+ (if compiler:generate-range-checks?
+ (pcfg*pcfg->pcfg!
+ (generate-nonnegative-check index-expression)
+ (pcfg/prefer-consequent!
+ (rtl:make-fixnum-pred-2-args
+ 'LESS-THAN-FIXNUM?
+ (rtl:make-object->fixnum index-expression)
+ (rtl:make-object->fixnum limit-locative)))
+ (make-null-cfg))
+ (make-null-cfg)))
+
+(define (open-code:nonnegative-check expression)
+ (if compiler:generate-range-checks?
+ (generate-nonnegative-check expression)
+ (make-null-cfg)))
+
+(define (generate-nonnegative-check expression)
+ (if (and (rtl:constant? expression)
+ (let ((value (rtl:constant-value expression)))
+ (and (object-type? (ucode-type fixnum) value)
+ (not (negative? value)))))
+ (make-true-pcfg)
+ (pcfg-invert
+ (pcfg/prefer-alternative!
+ (rtl:make-fixnum-pred-1-arg
+ 'NEGATIVE-FIXNUM?
+ (rtl:make-object->fixnum expression))))))
+\f
+;;;; Indexed Memory References
+
+(define (indexed-memory-reference type length-expression index-locative)
+ (lambda (name value-type generator)
+ (lambda (context expressions finish)
+ (let ((object (car expressions))
+ (index (cadr expressions)))
+ (open-code:with-checks
+ context
+ (cons*
+ (open-code:type-check object type)
+ (open-code:type-check index (ucode-type fixnum))
+ (open-code:range-check index (length-expression object))
+ (if value-type
+ (list (open-code:type-check (caddr expressions) value-type))
+ '()))
+ (index-locative object index
+ (lambda (locative)
+ (generator locative expressions finish)))
+ finish
+ name
+ expressions)))))
+
+(define (index-locative-generator make-locative
+ header-length-in-objects
+ address-units-per-index)
+ (let ((header-length-in-indexes
+ (* header-length-in-objects
+ (quotient address-units-per-object address-units-per-index))))
+ (lambda (base index finish)
+ (let ((unknown-index
+ (lambda ()
+ (load-temporary-register
+ scfg*scfg->scfg!
+ (rtl:make-fixnum->address
+ (rtl:make-fixnum-2-args
+ 'PLUS-FIXNUM
+ (rtl:make-address->fixnum (rtl:make-object->address base))
+ (let ((index (rtl:make-object->fixnum index)))
+ (if (= address-units-per-index 1)
+ index
+ (rtl:make-fixnum-2-args
+ 'MULTIPLY-FIXNUM
+ (rtl:make-object->fixnum
+ (rtl:make-constant address-units-per-index))
+ index)))))
+ (lambda (expression)
+ (finish
+ (make-locative expression header-length-in-indexes)))))))
+ (if (rtl:constant? index)
+ (let ((value (rtl:constant-value index)))
+ (if (and (object-type? (ucode-type fixnum) value)
+ (not (negative? value)))
+ (finish
+ (make-locative base (+ header-length-in-indexes value)))
+ (unknown-index)))
+ (unknown-index))))))
+
+(define vector-memory-reference
+ (indexed-memory-reference
+ (ucode-type vector)
+ (lambda (expression)
+ (rtl:make-fetch (rtl:locative-offset expression 0)))
+ (index-locative-generator rtl:locative-offset 1 address-units-per-object)))
+
+(define string-memory-reference
+ (indexed-memory-reference
+ (ucode-type string)
+ (lambda (expression)
+ (rtl:make-fetch (rtl:locative-offset expression 1)))
+ (index-locative-generator rtl:locative-byte-offset
+ 2
+ address-units-per-packed-char)))
+\f
+(define (rtl:length-fetch locative)
+ (rtl:make-cons-pointer (rtl:make-constant (ucode-type fixnum))
+ (rtl:make-fetch locative)))
+
+(define (rtl:string-fetch locative)
+ (rtl:make-cons-pointer (rtl:make-constant (ucode-type character))
+ (rtl:make-fetch locative)))
+
+(define (rtl:string-assignment locative value)
+ (rtl:make-assignment locative (rtl:make-char->ascii value)))
+
+(define (assignment-finisher make-assignment make-fetch)
+ (lambda (locative value finish)
+ (let ((assignment (make-assignment locative value)))
+ (if finish
+ (load-temporary-register scfg*scfg->scfg! (make-fetch locative)
+ (lambda (temporary)
+ (scfg*scfg->scfg! assignment (finish temporary))))
+ assignment))))
+
+(define finish-vector-assignment
+ (assignment-finisher rtl:make-assignment rtl:make-fetch))
+
+(define finish-string-assignment
+ (assignment-finisher rtl:string-assignment rtl:string-fetch))
\f
;;;; Open Coders
(define-open-coder/predicate 'NULL?
- (lambda (operands)
- operands
- (return-2 (lambda (context expressions finish)
- context
- (finish (pcfg-invert (rtl:make-true-test (car expressions)))))
- '(0))))
+ (simple-open-coder
+ (lambda (context expressions finish)
+ context
+ (finish (pcfg-invert (rtl:make-true-test (car expressions)))))
+ '(0)))
(let ((open-code/type-test
(lambda (type)
(rtl:make-type-test (rtl:make-object->type (car expressions))
type))))))
- (let ((define/type-test
- (lambda (name type)
- (define-open-coder/predicate name
- (lambda (operands)
- operands
- (return-2 (open-code/type-test type) '(0)))))))
- (define/type-test 'PAIR? (ucode-type pair))
- (define/type-test 'STRING? (ucode-type string))
- (define/type-test 'BIT-STRING? (ucode-type vector-1b)))
+ (let ((simple-type-test
+ (lambda (name type)
+ (define-open-coder/predicate name
+ (simple-open-coder (open-code/type-test type) '(0))))))
+ (simple-type-test 'PAIR? (ucode-type pair))
+ (simple-type-test 'STRING? (ucode-type string))
+ (simple-type-test 'BIT-STRING? (ucode-type vector-1b)))
(define-open-coder/predicate 'OBJECT-TYPE?
- (lambda (operands)
- (filter/nonnegative-integer (car operands)
- (lambda (type)
- (return-2 (open-code/type-test type) '(1)))))))
-
-(let ((open-code/eq-test
- (lambda (context expressions finish)
- context
- (finish (rtl:make-eq-test (car expressions) (cadr expressions))))))
- (define-open-coder/predicate 'EQ?
- (lambda (operands)
- operands
- (return-2 open-code/eq-test '(0 1)))))
+ (filter/nonnegative-integer open-code/type-test 0 '(1))))
+
+(define-open-coder/predicate 'EQ?
+ (simple-open-coder
+ (lambda (context expressions finish)
+ context
+ (finish (rtl:make-eq-test (car expressions) (cadr expressions))))
+ '(0 1)))
\f
(let ((open-code/pair-cons
(lambda (type)
(cadr expressions)))))))
(define-open-coder/value 'CONS
- (lambda (operands)
- operands
- (return-2 (open-code/pair-cons (ucode-type pair)) '(0 1))))
+ (simple-open-coder (open-code/pair-cons (ucode-type pair)) '(0 1)))
(define-open-coder/value 'SYSTEM-PAIR-CONS
- (lambda (operands)
- (filter/nonnegative-integer (car operands)
- (lambda (type)
- (return-2 (open-code/pair-cons type) '(1 2)))))))
+ (filter/nonnegative-integer open-code/pair-cons 0 '(1 2))))
(define-open-coder/value 'VECTOR
(lambda (operands)
(if (null? operands)
'()
(cons index (loop (cdr operands) (1+ index))))))
+
+#|
+;; This is somewhat painful to implement. The problem is that most of
+;; the open coding takes place in "rtlcon.scm", and the mechanism for
+;; doing such things is here. We should probably try to remodularize
+;; the code that transforms "expression-style" RTL into
+;; "statement-style" RTL, so we can call it from here and then work in
+;; the "statement-style" domain.
+
+(define-open-coder/value 'STRING-ALLOCATE
+ (simple-open-coder
+ (lambda (context expressions finish)
+ (let ((length (car expressions)))
+ (open-code:with-checks
+ context
+ (list (open-code:nonnegative-check length))
+ (finish
+ (rtl:make-typed-cons:string
+ (rtl:make-constant (ucode-type string))
+ length))
+ finish
+ 'STRING-ALLOCATE
+ expressions)))
+ '(0)))
+|#
\f
-(let ((open-code/memory-length
- (lambda (index)
+(let ((make-fixed-ref
+ (lambda (name make-fetch type index)
(lambda (context expressions finish)
- context
- (finish
- (rtl:make-cons-pointer
- (rtl:make-constant (ucode-type fixnum))
- (rtl:make-fetch
- (rtl:locative-offset (car expressions) index))))))))
- (let ((define/length
- (lambda (name index)
- (define-open-coder/value name
- (lambda (operands)
- operands
- (return-2 (open-code/memory-length index) '(0)))))))
- (define/length '(VECTOR-LENGTH SYSTEM-VECTOR-SIZE) 0)
- (define/length '(STRING-LENGTH BIT-STRING-LENGTH) 1)))
-
-(define (generate-index-locative vector index finish)
- (load-temporary-register
- scfg*scfg->scfg!
- (rtl:make-fixnum->address
- (rtl:make-fixnum-2-args
- 'PLUS-FIXNUM
- (rtl:make-address->fixnum (rtl:make-object->address vector))
- (rtl:make-fixnum-2-args
- 'MULTIPLY-FIXNUM
- (rtl:make-object->fixnum
- (rtl:make-constant
- (quotient scheme-object-width
- addressing-granularity)))
- (rtl:make-object->fixnum index))))
- finish))
-\f
-(let* ((open-code/memory-ref
- (lambda (expressions finish index)
- (finish
- (rtl:make-fetch
- (rtl:locative-offset (car expressions) index)))))
- (open-code/vector-ref
- (lambda (name)
- (lambda (context expressions finish)
- (let ((vector (car expressions))
- (index (cadr expressions)))
- (open-code:with-checks
- context
- (list
- (open-code:type-check vector 'VECTOR)
- (open-code:type-check index 'FIXNUM)
- (open-code:range-check
- index
- (rtl:make-fetch (rtl:locative-offset vector 0))))
- (generate-index-locative
- vector
- index
- (lambda (memory-locative)
- (open-code/memory-ref (list memory-locative) finish 1)))
- finish
- (make-invocation name expressions))))))
- (open-code/constant-vector-ref
- (lambda (name index)
- (lambda (context expressions finish)
- (let ((vector (car expressions)))
- (open-code:with-checks
- context
- (list
- (open-code:type-check vector 'VECTOR)
- (open-code:limit-check
- (rtl:make-constant index)
- (rtl:make-fetch (rtl:locative-offset vector 0))))
- (open-code/memory-ref expressions finish (1+ index))
- finish
- (make-invocation name expressions)))))))
- (let ((define/ref
- (lambda (name index)
- (define-open-coder/value name
- (lambda (operands)
- operands
- (return-2 (lambda (context expressions finish)
- context
- (open-code/memory-ref expressions finish index))
- '(0)))))))
- (define/ref '(CAR SYSTEM-PAIR-CAR CELL-CONTENTS SYSTEM-HUNK3-CXR0) 0)
- (define/ref '(CDR SYSTEM-PAIR-CDR SYSTEM-HUNK3-CXR1) 1)
- (define/ref 'SYSTEM-HUNK3-CXR2 2))
- (for-each
- (lambda (name)
- (define-open-coder/value name
- (lambda (operands)
- (or (filter/nonnegative-integer (cadr operands)
- (lambda (index)
- (return-2 (open-code/constant-vector-ref name index) '(0 1))))
- (return-2 (open-code/vector-ref name) '(0 1))))))
- '(VECTOR-REF SYSTEM-VECTOR-REF)))
-\f
-(let ((open-code/general-car-cdr
+ (let ((expression (car expressions)))
+ (open-code:with-checks
+ context
+ (if type (list (open-code:type-check expression type)) '())
+ (finish (make-fetch (rtl:locative-offset expression index)))
+ finish
+ name
+ expressions)))))
+ (standard-def
+ (lambda (name fixed-ref)
+ (define-open-coder/value name
+ (simple-open-coder fixed-ref '(0))))))
+ (let ((user-ref
+ (lambda (name make-fetch type index)
+ (standard-def name (make-fixed-ref name make-fetch type index)))))
+ (user-ref 'CELL-CONTENTS rtl:make-fetch (ucode-type cell) 0)
+ (user-ref 'VECTOR-LENGTH rtl:length-fetch (ucode-type vector) 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 'SYSTEM-PAIR-CAR rtl:make-fetch false 0)
+ (user-ref 'SYSTEM-PAIR-CDR rtl:make-fetch false 1)
+ (user-ref 'SYSTEM-HUNK3-CXR0 rtl:make-fetch false 0)
+ (user-ref 'SYSTEM-HUNK3-CXR1 rtl:make-fetch false 1)
+ (user-ref 'SYSTEM-HUNK3-CXR2 rtl:make-fetch false 2)
+ (user-ref 'SYSTEM-VECTOR-SIZE rtl:length-fetch false 0))
+ (let ((car-ref (make-fixed-ref 'CAR rtl:make-fetch (ucode-type pair) 0))
+ (cdr-ref (make-fixed-ref 'CDR rtl:make-fetch (ucode-type pair) 1)))
+ (standard-def 'CAR car-ref)
+ (standard-def 'CDR cdr-ref)
+ (define-open-coder/value 'GENERAL-CAR-CDR
+ (filter/positive-integer
(lambda (pattern)
(lambda (context expressions finish)
context
(let loop ((pattern pattern) (expression (car expressions)))
(if (= pattern 1)
expression
- (let ((qr (integer-divide pattern 2)))
- (loop (integer-divide-quotient qr)
- (rtl:make-fetch
- (rtl:locative-offset
- expression
- (- 1 (integer-divide-remainder qr)))))))))))))
- (define-open-coder/value 'GENERAL-CAR-CDR
- (lambda (operands)
- (filter/positive-integer (cadr operands)
- (lambda (pattern)
- (return-2 (open-code/general-car-cdr pattern) '(0)))))))
+ ((if (odd? pattern) car-ref cdr-ref)
+ context
+ (list expression)
+ (lambda (expression)
+ (loop (quotient pattern 2) expression))))))))
+ 1
+ '(0)))))
+
+(for-each (lambda (name)
+ (define-open-coder/value name
+ (simple-open-coder
+ (vector-memory-reference name false
+ (lambda (locative expressions finish)
+ expressions
+ (finish (rtl:make-fetch locative))))
+ '(0 1))))
+ '(VECTOR-REF SYSTEM-VECTOR-REF))
\f
-(let* ((open-code/memory-assignment
- (lambda (expressions finish index)
- (let* ((locative (rtl:locative-offset (car expressions) index))
- (assignment
- (rtl:make-assignment locative
- (car (last-pair expressions)))))
- (if finish
- (load-temporary-register scfg*scfg->scfg!
- (rtl:make-fetch locative)
- (lambda (temporary)
- (scfg*scfg->scfg! assignment (finish temporary))))
- assignment))))
- (open-code/vector-set
- (lambda (name)
- (lambda (context expressions finish)
- (let ((vector (car expressions))
- (index (cadr expressions))
- (newval-list (cddr expressions)))
- (open-code:with-checks
- context
- (list
- (open-code:type-check vector 'VECTOR)
- (open-code:type-check index 'FIXNUM)
- (open-code:range-check
- index
- (rtl:make-fetch (rtl:locative-offset vector 0))))
- (generate-index-locative
- vector
- index
- (lambda (memory-locative)
- (open-code/memory-assignment
- (cons memory-locative newval-list)
- finish
- 1)))
- finish
- (make-invocation name expressions))))))
- (open-code/constant-vector-set
- (lambda (name index)
- (lambda (context expressions finish)
- (let ((vector (car expressions)))
- (open-code:with-checks
- context
- (list
- (open-code:type-check vector 'VECTOR)
- (open-code:limit-check
- (rtl:make-constant index)
- (rtl:make-fetch (rtl:locative-offset vector 0))))
- (open-code/memory-assignment expressions finish index)
- finish
- (make-invocation name expressions)))))))
-
- ;; 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.
-
- (let ((define/set!
- (lambda (name index)
+;; 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.
+
+(let ((fixed-assignment
+ (lambda (name type index)
+ (define-open-coder/effect name
+ (simple-open-coder
+ (lambda (context expressions finish)
+ (let ((object (car expressions)))
+ (open-code:with-checks
+ context
+ (if type (list (open-code:type-check object type)) '())
+ (finish-vector-assignment (rtl:locative-offset object index)
+ (cadr expressions)
+ finish)
+ finish
+ name
+ expressions)))
+ '(0 1))))))
+ (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)
+ |#)
+
+(for-each (lambda (name)
(define-open-coder/effect name
- (lambda (operands)
- operands
- (return-2
- (lambda (context expressions finish)
- context
- (open-code/memory-assignment expressions finish index))
- '(0 1)))))))
- (define/set! '(SET-CAR!
- SET-CELL-CONTENTS!
- #| SYSTEM-PAIR-SET-CAR! |#
- #| SYSTEM-HUNK3-SET-CXR0! |#)
- 0)
- (define/set! '(SET-CDR!
- #| SYSTEM-PAIR-SET-CDR! |#
- #| SYSTEM-HUNK3-SET-CXR1! |#)
- 1)
- (define/set! '(#| SYSTEM-HUNK3-SET-CXR2! |#)
- 2))
-
- (for-each
- (lambda (name)
- (define-open-coder/effect name
- (lambda (operands)
- (or (filter/nonnegative-integer (cadr operands)
- (lambda (index)
- (return-2 (open-code/constant-vector-set name (1+ index))
- '(0 1 2))))
- (return-2 (open-code/vector-set name)
- '(0 1 2))))))
- '(VECTOR-SET! #| SYSTEM-VECTOR-SET! |#)))
+ (simple-open-coder
+ (vector-memory-reference name false
+ (lambda (locative expressions finish)
+ (finish-vector-assignment locative
+ (caddr expressions)
+ finish)))
+ '(0 1 2))))
+ '(VECTOR-SET! #| SYSTEM-VECTOR-SET! |#))
\f
+;;;; Character/String Primitives
+
+(define-open-coder/value 'CHAR->INTEGER
+ (simple-open-coder
+ (lambda (context expressions finish)
+ (let ((char (car expressions)))
+ (open-code:with-checks
+ context
+ (list (open-code:type-check char (ucode-type character)))
+ (finish
+ (rtl:make-cons-pointer
+ (rtl:make-constant (ucode-type fixnum))
+ (rtl:make-object->datum char)))
+ finish
+ 'CHAR->INTEGER
+ expressions)))
+ '(0)))
+
+(define-open-coder/value 'STRING-REF
+ (simple-open-coder
+ (string-memory-reference 'STRING-REF false
+ (lambda (locative expressions finish)
+ expressions
+ (finish (rtl:string-fetch locative))))
+ '(0 1)))
+
+(define-open-coder/effect 'STRING-SET!
+ (simple-open-coder
+ (string-memory-reference 'STRING-SET! (ucode-type character)
+ (lambda (locative expressions finish)
+ (finish-string-assignment locative (caddr expressions) finish)))
+ '(0 1 2)))
+\f
+;;;; Fixnum Arithmetic
+
(for-each (lambda (fixnum-operator)
(define-open-coder/value fixnum-operator
- (lambda (operands)
- operands
- (return-2
- (lambda (context expressions finish)
- context
- (finish
- (rtl:make-fixnum->object
- (rtl:make-fixnum-2-args
- fixnum-operator
- (rtl:make-object->fixnum (car expressions))
- (rtl:make-object->fixnum (cadr expressions))))))
- '(0 1)))))
+ (simple-open-coder
+ (lambda (context expressions finish)
+ context
+ (finish
+ (rtl:make-fixnum->object
+ (rtl:make-fixnum-2-args
+ fixnum-operator
+ (rtl:make-object->fixnum (car expressions))
+ (rtl:make-object->fixnum (cadr expressions))))))
+ '(0 1))))
'(PLUS-FIXNUM
MINUS-FIXNUM
MULTIPLY-FIXNUM
(for-each (lambda (fixnum-operator)
(define-open-coder/value fixnum-operator
- (lambda (operand)
- operand
- (return-2
- (lambda (context expressions finish)
- context
- (finish
- (rtl:make-fixnum->object
- (rtl:make-fixnum-1-arg
- fixnum-operator
- (rtl:make-object->fixnum (car expressions))))))
- '(0)))))
+ (simple-open-coder
+ (lambda (context expressions finish)
+ context
+ (finish
+ (rtl:make-fixnum->object
+ (rtl:make-fixnum-1-arg
+ fixnum-operator
+ (rtl:make-object->fixnum (car expressions))))))
+ '(0))))
'(ONE-PLUS-FIXNUM MINUS-ONE-PLUS-FIXNUM))
(for-each (lambda (fixnum-pred)
(define-open-coder/predicate fixnum-pred
- (lambda (operands)
- operands
- (return-2
- (lambda (context expressions finish)
- context
- (finish
- (rtl:make-fixnum-pred-2-args
- fixnum-pred
- (rtl:make-object->fixnum (car expressions))
- (rtl:make-object->fixnum (cadr expressions)))))
- '(0 1)))))
+ (simple-open-coder
+ (lambda (context expressions finish)
+ context
+ (finish
+ (rtl:make-fixnum-pred-2-args
+ fixnum-pred
+ (rtl:make-object->fixnum (car expressions))
+ (rtl:make-object->fixnum (cadr expressions)))))
+ '(0 1))))
'(EQUAL-FIXNUM? LESS-THAN-FIXNUM? GREATER-THAN-FIXNUM?))
(for-each (lambda (fixnum-pred)
(define-open-coder/predicate fixnum-pred
- (lambda (operand)
- operand
- (return-2
- (lambda (context expressions finish)
- context
- (finish
- (rtl:make-fixnum-pred-1-arg
- fixnum-pred
- (rtl:make-object->fixnum (car expressions)))))
- '(0)))))
- '(ZERO-FIXNUM? POSITIVE-FIXNUM? NEGATIVE-FIXNUM?))
-\f
+ (simple-open-coder
+ (lambda (context expressions finish)
+ context
+ (finish
+ (rtl:make-fixnum-pred-1-arg
+ fixnum-pred
+ (rtl:make-object->fixnum (car expressions)))))
+ '(0))))
+ '(ZERO-FIXNUM? POSITIVE-FIXNUM? NEGATIVE-FIXNUM?))\f
;;; Generic arithmetic
-(define (generate-generic-binary context expression finish is-pred?)
- (let ((generic-op (rtl:generic-binary-operator expression))
- (fix-op
- (generic->fixnum-op (rtl:generic-binary-operator expression)))
- (op1 (rtl:generic-binary-operand-1 expression))
- (op2 (rtl:generic-binary-operand-2 expression)))
- (let ((give-it-up
- (lambda ()
- (with-values (lambda () (generate-continuation-entry context))
- (lambda (label setup cleanup)
- (scfg-append!
- (generate-primitive generic-op (list op1 op2) setup label)
- cleanup
- (if is-pred?
- (finish
- (rtl:make-true-test (rtl:make-fetch register:value)))
- (expression-simplify-for-statement
- (rtl:make-fetch register:value)
- finish))))))))
- (if is-pred?
- (generate-binary-type-test 'FIXNUM op1 op2
- give-it-up
- (lambda ()
- (finish
- (if (eq? fix-op 'EQUAL-FIXNUM?)
- ;; This produces better code.
- (rtl:make-eq-test op1 op2)
- (rtl:make-fixnum-pred-2-args
- fix-op
- (rtl:make-object->fixnum op1)
- (rtl:make-object->fixnum op2))))))
- (let ((give-it-up (give-it-up)))
- (generate-binary-type-test 'FIXNUM op1 op2
- (lambda ()
- give-it-up)
- (lambda ()
- (load-temporary-register scfg*scfg->scfg!
- (rtl:make-fixnum-2-args
- fix-op
- (rtl:make-object->fixnum op1)
- (rtl:make-object->fixnum op2))
- (lambda (fix-temp)
- (pcfg*scfg->scfg!
- (pcfg/prefer-alternative! (rtl:make-overflow-test))
- give-it-up
- (finish (rtl:make-fixnum->object fix-temp))))))))))))
+(define (generic-binary-generator generic-op is-pred?)
+ (define-non-simple-primitive! generic-op)
+ ((if is-pred? define-open-coder/predicate define-open-coder/value)
+ generic-op
+ (simple-open-coder
+ (let ((fix-op (generic->fixnum-op generic-op)))
+ (lambda (context expressions finish)
+ (let ((op1 (car expressions))
+ (op2 (cadr expressions))
+ (give-it-up
+ (generic-default generic-op is-pred?
+ context expressions finish)))
+ (if is-pred?
+ (generate-binary-type-test (ucode-type fixnum) op1 op2
+ give-it-up
+ (lambda ()
+ (finish
+ (if (eq? fix-op 'EQUAL-FIXNUM?)
+ ;; This produces better code.
+ (rtl:make-eq-test op1 op2)
+ (rtl:make-fixnum-pred-2-args
+ fix-op
+ (rtl:make-object->fixnum op1)
+ (rtl:make-object->fixnum op2))))))
+ (let ((give-it-up (give-it-up)))
+ (generate-binary-type-test (ucode-type fixnum) op1 op2
+ (lambda ()
+ give-it-up)
+ (lambda ()
+ (load-temporary-register scfg*scfg->scfg!
+ (rtl:make-fixnum-2-args
+ fix-op
+ (rtl:make-object->fixnum op1)
+ (rtl:make-object->fixnum op2))
+ (lambda (fix-temp)
+ (pcfg*scfg->scfg!
+ (pcfg/prefer-alternative! (rtl:make-overflow-test))
+ give-it-up
+ (finish (rtl:make-fixnum->object fix-temp))))))))))))
+ '(0 1))))
(define (generate-binary-type-test type op1 op2 give-it-up do-it)
(generate-type-test type op1
(pcfg*scfg->scfg! test* (do-it) give-it-up)
give-it-up)))))))
\f
-(define (generate-generic-unary context expression finish is-pred?)
- (let ((generic-op (rtl:generic-unary-operator expression))
- (fix-op
- (generic->fixnum-op (rtl:generic-unary-operator expression)))
- (op (rtl:generic-unary-operand expression)))
- (let ((give-it-up
- (lambda ()
- (with-values (lambda () (generate-continuation-entry context))
- (lambda (label setup cleanup)
- (scfg-append!
- (generate-primitive generic-op (cddr expression) setup label)
- cleanup
- (if is-pred?
- (finish
- (rtl:make-true-test (rtl:make-fetch register:value)))
- (expression-simplify-for-statement
- (rtl:make-fetch register:value)
- finish))))))))
- (if is-pred?
- (generate-unary-type-test 'FIXNUM op
- give-it-up
- (lambda ()
- (finish
- (rtl:make-fixnum-pred-1-arg fix-op
- (rtl:make-object->fixnum op)))))
- (let ((give-it-up (give-it-up)))
- (generate-unary-type-test 'FIXNUM op
- (lambda ()
- give-it-up)
- (lambda ()
- (load-temporary-register scfg*scfg->scfg!
- (rtl:make-fixnum-1-arg
- fix-op
- (rtl:make-object->fixnum op))
- (lambda (fix-temp)
- (pcfg*scfg->scfg!
- (pcfg/prefer-alternative! (rtl:make-overflow-test))
- give-it-up
- (finish (rtl:make-fixnum->object fix-temp))))))))))))
+(define (generic-unary-generator generic-op is-pred?)
+ (define-non-simple-primitive! generic-op)
+ ((if is-pred? define-open-coder/predicate define-open-coder/value)
+ generic-op
+ (simple-open-coder
+ (let ((fix-op (generic->fixnum-op generic-op)))
+ (lambda (context expressions finish)
+ (let ((op (car expressions))
+ (give-it-up
+ (generic-default generic-op is-pred?
+ context expressions finish)))
+ (if is-pred?
+ (generate-unary-type-test (ucode-type fixnum) op
+ give-it-up
+ (lambda ()
+ (finish
+ (rtl:make-fixnum-pred-1-arg
+ fix-op
+ (rtl:make-object->fixnum op)))))
+ (let ((give-it-up (give-it-up)))
+ (generate-unary-type-test (ucode-type fixnum) op
+ (lambda ()
+ give-it-up)
+ (lambda ()
+ (load-temporary-register scfg*scfg->scfg!
+ (rtl:make-fixnum-1-arg
+ fix-op
+ (rtl:make-object->fixnum op))
+ (lambda (fix-temp)
+ (pcfg*scfg->scfg!
+ (pcfg/prefer-alternative! (rtl:make-overflow-test))
+ give-it-up
+ (finish (rtl:make-fixnum->object fix-temp))))))))))))
+ '(0))))
(define (generate-unary-type-test type op give-it-up do-it)
(generate-type-test type op
(lambda (test)
(pcfg*scfg->scfg! test (do-it) (give-it-up)))))
\f
+(define (generic-default generic-op is-pred? context expressions finish)
+ (lambda ()
+ (with-values (lambda () (generate-continuation-entry context))
+ (lambda (label setup cleanup)
+ (scfg-append!
+ (generate-primitive generic-op expressions setup label)
+ cleanup
+ (if is-pred?
+ (finish (rtl:make-true-test (rtl:make-fetch register:value)))
+ (expression-simplify-for-statement (rtl:make-fetch register:value)
+ finish)))))))
+
(define (generic->fixnum-op generic-op)
(case generic-op
((&+) 'PLUS-FIXNUM)
((positive?) 'POSITIVE-FLOATNUM?)
((negative?) 'NEGATIVE-FLOATNUM?)
(else (error "Can't find corresponding floatnum op:" generic-op))))
-\f
-(for-each (lambda (generic-op)
- (define-open-coder/value generic-op
- (lambda (operands)
- operands
- (return-2
- (lambda (context expressions finish)
- (generate-generic-binary
- context
- (rtl:make-generic-binary generic-op
- (car expressions)
- (cadr expressions))
- finish
- false))
- '(0 1)))))
- '(&+ &- &*))
(for-each (lambda (generic-op)
- (define-open-coder/value generic-op
- (lambda (operands)
- operands
- (return-2
- (lambda (context expressions finish)
- (generate-generic-unary
- context
- (rtl:make-generic-unary generic-op (car expressions))
- finish
- false))
- '(0)))))
- '(1+ -1+))
+ (generic-binary-generator generic-op false))
+ '(&+ &- &*))
(for-each (lambda (generic-op)
- (define-open-coder/predicate generic-op
- (lambda (operands)
- operands
- (return-2
- (lambda (context expressions finish)
- (generate-generic-binary
- context
- (rtl:make-generic-binary generic-op
- (car expressions)
- (cadr expressions))
- finish
- true))
- '(0 1)))))
+ (generic-binary-generator generic-op true))
'(&= &< &>))
(for-each (lambda (generic-op)
- (define-open-coder/predicate generic-op
- (lambda (operands)
- operands
- (return-2
- (lambda (context expressions finish)
- (generate-generic-unary
- context
- (rtl:make-generic-unary generic-op (car expressions))
- finish
- true))
- '(0)))))
- '(zero? positive? negative?))
-\f
-;;;; Character Primitives
-
-(let ((define-character->fixnum
- (lambda (character->fixnum rtl:coercion)
- (define-open-coder/value character->fixnum
- (lambda (operand)
- operand
- (return-2 (lambda (context expressions finish)
- context
- (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))
-\f
-;;;; String Primitives
-
-(define 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 (context expressions finish)
- (let ((string (car expressions)))
- (open-code:with-checks
- context
- (list
- (open-code:type-check string 'STRING)
- (open-code:limit-check
- (rtl:make-constant index)
- (rtl:make-fetch (rtl:locative-offset string 1))))
- (finish
- (rtl:make-cons-pointer
- (rtl:make-constant (ucode-type character))
- (rtl:make-fetch
- (rtl:locative-byte-offset string
- (+ string-header-size index)))))
- finish
- (make-invocation 'STRING-REF expressions))))
- '(0 1))))))
+ (generic-unary-generator generic-op false))
+ '(1+ -1+))
-(define-open-coder/effect 'STRING-SET!
- (lambda (operands)
- (filter/nonnegative-integer (cadr operands)
- (lambda (index)
- (return-2
- (lambda (context expressions finish)
- (let ((string (car expressions))
- (value (caddr expressions)))
- (open-code:with-checks
- context
- (list
- (open-code:type-check string 'STRING)
- (open-code:limit-check
- (rtl:make-constant index)
- (rtl:make-fetch (rtl:locative-offset string 1))))
- (let* ((locative
- (rtl:locative-byte-offset string
- (+ string-header-size index)))
- (assignment
- (rtl:make-assignment locative
- (rtl:make-char->ascii value))))
- (if finish
- (load-temporary-register
- scfg*scfg->scfg!
- (rtl:make-cons-pointer
- (rtl:make-constant (ucode-type character))
- (rtl:make-fetch locative))
- (lambda (temporary)
- (scfg*scfg->scfg! assignment (finish temporary))))
- assignment))
- finish
- (make-invocation 'STRING-SET! expressions))))
- '(0 1 2))))))
\ No newline at end of file
+(for-each (lambda (generic-op)
+ (generic-unary-generator generic-op true))
+ '(zero? positive? negative?))
\ No newline at end of file
projects / mit-scheme.git / commitdiff