From 330e6d12de3056318fe221deb0968ebe7e8d8a83 Mon Sep 17 00:00:00 2001 From: Stephen Adams Date: Wed, 1 Mar 1995 14:02:52 +0000 Subject: [PATCH] Initial revision --- v8/src/compiler/midend/ea2.scm | 1061 ++++++++++++++++++++++++++++++++ 1 file changed, 1061 insertions(+) create mode 100644 v8/src/compiler/midend/ea2.scm diff --git a/v8/src/compiler/midend/ea2.scm b/v8/src/compiler/midend/ea2.scm new file mode 100644 index 000000000..5064dc64b --- /dev/null +++ b/v8/src/compiler/midend/ea2.scm @@ -0,0 +1,1061 @@ +#| -*-Scheme-*- + +$Id: ea2.scm,v 1.1 1995/03/01 14:02:52 adams Exp $ + +Copyright (c) 1995 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; Early generic arithmetic rewrite +;;; package: (compiler midend) + +(declare (usual-integrations)) + + +;; Affects how careful we are to maintain exactness: +(define *earlyrew/maximize-exactness?* #T) + + +(define (earlyrew/top-level program) + ;; 1. Copy the program, doing some expansions and constant folding + ;; 2. Figure out some types and do some rewrites based on that + (let ((copy (earlyrew/expr program))) + (earlyrew/typeinf copy) + copy)) + +(define-macro (define-early-rewriter keyword bindings . body) + (let ((proc-name (symbol-append 'EARLYREW/ keyword))) + (call-with-values + (lambda () (%matchup bindings '(handler) '(cdr form))) + (lambda (names code) + `(DEFINE ,proc-name + (LET ((HANDLER (LAMBDA ,names ,@body))) + (NAMED-LAMBDA (,proc-name FORM) + (EARLYREW/REMEMBER ,code FORM)))))))) + +(define-early-rewriter LOOKUP (name) + `(LOOKUP ,name)) + +(define-early-rewriter LAMBDA (lambda-list body) + `(LAMBDA ,lambda-list + ,(earlyrew/expr body))) + +(define-early-rewriter CALL (rator cont #!rest rands) + (define (default) + `(CALL ,(earlyrew/expr rator) + ,(earlyrew/expr cont) + ,@(earlyrew/expr* rands))) + (cond ((and (QUOTE/? rator) + (rewrite-operator/early? (quote/text rator))) + => (lambda (handler) + (if (not (equal? cont '(QUOTE #F))) + (internal-error "Early rewrite done after CPS conversion?" + cont)) + (apply handler (earlyrew/expr* rands)))) + (else + (default)))) + +(define-early-rewriter LET (bindings body) + `(LET ,(map (lambda (binding) + (list (car binding) + (earlyrew/expr (cadr binding)))) + bindings) + ,(earlyrew/expr body))) + +(define-early-rewriter LETREC (bindings body) + `(LETREC ,(map (lambda (binding) + (list (car binding) + (earlyrew/expr (cadr binding)))) + bindings) + ,(earlyrew/expr body))) + +(define-early-rewriter QUOTE (object) + `(QUOTE ,object)) + +(define-early-rewriter DECLARE (#!rest anything) + `(DECLARE ,@anything)) + +(define-early-rewriter BEGIN (#!rest actions) + `(BEGIN ,@(earlyrew/expr* actions))) + +(define-early-rewriter IF (pred conseq alt) + `(IF ,(earlyrew/expr pred) + ,(earlyrew/expr conseq) + ,(earlyrew/expr alt))) + +(define (earlyrew/expr expr) + (if (not (pair? expr)) + (illegal expr)) + (case (car expr) + ((QUOTE) (earlyrew/quote expr)) + ((LOOKUP) (earlyrew/lookup expr)) + ((LAMBDA) (earlyrew/lambda expr)) + ((LET) (earlyrew/let expr)) + ((DECLARE) (earlyrew/declare expr)) + ((CALL) (earlyrew/call expr)) + ((BEGIN) (earlyrew/begin expr)) + ((IF) (earlyrew/if expr)) + ((LETREC) (earlyrew/letrec expr)) + (else (illegal expr)))) + +(define (earlyrew/expr* exprs) + (map earlyrew/expr exprs)) + +(define (earlyrew/remember new old) + (code-rewrite/remember new old)) + +(define (earlyrew/new-name prefix) + (new-variable prefix)) + +(define *early-rewritten-operators* + (make-eq-hash-table)) + +(define-integrable (rewrite-operator/early? rator) + (hash-table/get *early-rewritten-operators* rator false)) + +(define (define-rewrite/early operator-name-or-object handler) + (hash-table/put! *early-rewritten-operators* + (if (hash-table/get *operator-properties* + operator-name-or-object + false) + operator-name-or-object + (make-primitive-procedure operator-name-or-object)) + handler)) + +;;;; Rewrites of unary operations in terms of binary operations + +(let ((unary-rewrite + (lambda (binary-name rand2) + (let ((binary-operation (make-primitive-procedure binary-name))) + (lambda (rand1) + `(CALL (QUOTE ,binary-operation) + (QUOTE #F) + ,rand1 + (QUOTE ,rand2)))))) + (special-rewrite + (lambda (binary-name rand2) + (let ((binary-operation (make-primitive-procedure binary-name))) + (lambda (rand1) + `(CALL (QUOTE ,binary-operation) + (QUOTE #F) + ,rand1 + (QUOTE ,rand2)))))) + (special-rewrite/left + (lambda (binary-name rand1) + (let ((binary-operation (make-primitive-procedure binary-name))) + (lambda (rand2) + `(CALL (QUOTE ,binary-operation) + (QUOTE #F) + (QUOTE ,rand1) + ,rand2)))))) + + (define-rewrite/early 'ZERO? (unary-rewrite '&= 0)) + (define-rewrite/early 'POSITIVE? (unary-rewrite '&> 0)) + (define-rewrite/early 'NEGATIVE? (unary-rewrite '&< 0)) + (define-rewrite/early '1+ (unary-rewrite '&+ 1)) + (define-rewrite/early '-1+ (unary-rewrite '&- 1)) + + (define-rewrite/early 'ZERO-FIXNUM? + (special-rewrite 'EQUAL-FIXNUM? 0)) + (define-rewrite/early 'NEGATIVE-FIXNUM? + (special-rewrite 'LESS-THAN-FIXNUM? 0)) + (define-rewrite/early 'POSITIVE-FIXNUM? + (special-rewrite 'GREATER-THAN-FIXNUM? 0)) + (define-rewrite/early 'ONE-PLUS-FIXNUM + (special-rewrite 'PLUS-FIXNUM 1)) + (define-rewrite/early 'MINUS-ONE-PLUS-FIXNUM + (special-rewrite 'MINUS-FIXNUM 1)) + + (define-rewrite/early 'FLONUM-ZERO? (special-rewrite 'FLONUM-EQUAL? 0.)) + (define-rewrite/early 'FLONUM-NEGATIVE? (special-rewrite 'FLONUM-LESS? 0.)) + (define-rewrite/early 'FLONUM-POSITIVE? (special-rewrite 'FLONUM-GREATER? 0.)) + + (define-rewrite/early 'FLONUM-NEGATE + (special-rewrite/left 'FLONUM-SUBTRACT 0.))) + +#| +;; Some machines have an ABS instruction. +;; This should be enabled according to the back end. + +(define-rewrite/early 'FLONUM-ABS + (let ((flo:> (make-primitive-procedure 'FLONUM-GREATER?)) + (flo:- (make-primitive-procedure 'FLONUM-SUBTRACT))) + (lambda (x) + (let ((x-name (earlyrew/new-name 'X))) + (bind x-name x + `(IF (CALL (QUOTE ,flo:>) (QUOTE #F) (QUOTE 0.) (LOOKUP ,x-name)) + (CALL (QUOTE ,flo:-) (QUOTE #F) (QUOTE 0.) (LOOKUP ,x-name)) + (LOOKUP ,x-name))))))) +|# + +;;;; *** Special, for now *** +;; This is done this way because of current rtl generator + +(let ((allocation-rewriter + (lambda (name out-of-line limit) + (let ((primitive (make-primitive-procedure name))) + (lambda (size) + (define (default) + `(CALL (QUOTE ,out-of-line) (QUOTE #F) ,size)) + (cond ((form/number? size) + => (lambda (nbytes) + (if (not (and (exact-nonnegative-integer? nbytes) + (<= nbytes limit))) + (default) + `(CALL (QUOTE ,primitive) (QUOTE #F) ,size)))) + (else + (default)))))))) + (define-rewrite/early 'STRING-ALLOCATE + (allocation-rewriter 'STRING-ALLOCATE %string-allocate + *string-allocate-max-open-coded-length*)) + (define-rewrite/early 'FLOATING-VECTOR-CONS + (allocation-rewriter 'FLOATING-VECTOR-CONS %floating-vector-cons + *floating-vector-cons-max-open-coded-length*))) + +;; *** This can be improved by using %vector-allocate, +;; and a non-marked header moved through the vector as it is filled. *** + +(define-rewrite/early 'VECTOR-CONS + (let ((primitive (make-primitive-procedure 'VECTOR-CONS))) + (lambda (size fill) + (define (default) + `(CALL (QUOTE ,%vector-cons) (QUOTE #F) ,size ,fill)) + (cond ((form/number? size) + => (lambda (nbytes) + (if (or (not (exact-nonnegative-integer? nbytes)) + (> nbytes *vector-cons-max-open-coded-length*)) + (default) + `(CALL (QUOTE ,primitive) (QUOTE #F) ,size ,fill)))) + (else + (default)))))) + + +(define-rewrite/early 'GENERAL-CAR-CDR + (let ((prim-general-car-cdr (make-primitive-procedure 'GENERAL-CAR-CDR)) + (prim-car (make-primitive-procedure 'CAR)) + (prim-cdr (make-primitive-procedure 'CDR))) + (lambda (term pattern) + (define (default) + `(CALL (QUOTE ,prim-general-car-cdr) (QUOTE #f) ,term ,pattern)) + (cond ((form/number? pattern) + => (lambda (pattern) + (if (and (integer? pattern) (> pattern 0)) + (let walk-bits ((num pattern) + (text term)) + (if (= num 1) + text + (walk-bits (quotient num 2) + `(CALL (QUOTE ,(if (odd? num) + prim-car + prim-cdr)) + (QUOTE #f) + ,text)))) + (default)))) + (else (default)))))) + + +#| +(define (define-rewrite/early/global name arity handler) + (let ((slot (hash-table/get *early-rewritten-operators* name '()))) + (hash-table/put! *early-rewritten-operators* + name + (cons (cons arity handler) slot)))) + +(define-rewrite/early %invoke-remote-cache + (lambda (descriptor operator-cache . values) + (define (default values) + `(CALL (QUOTE ,%invoke-remote-cache) + (QUOTE #f) + ,descriptor + ,operator-cache + ,@values)) + (let* ((descriptor* (quote/text descriptor)) + (name (first descriptor*)) + (arity (second descriptor*))) + (cond ((rewrite-operator/early? name) + => (lambda (alist) + (cond ((assq arity alist) + => (lambda (arity.handler) + (apply (cdr arity.handler) default values))) + (else (default values))))) + (else + (default values)))))) +|# + + +;;______________________________________________________________________ +;; +;; Type-aware rewriting for generic arithmetic, +;; . Traverse the program and compute type information. At this time a +;; rewrite may be decided and `posted'. +;; . Traverse the program again, applying posted and other rewrites in some +;; depth first ordering. + + +(define *earlyrew/typemap*) +(define *earlyrew/posted-rewrites*) + +(define (earlyrew/typeinf program) + (fluid-let ((*earlyrew/typemap* (make-eq-hash-table)) + (*earlyrew/posted-rewrites* (make-eq-hash-table))) + (earlyrew/typeinf/expr *earlyrew/typemap* program) + (earlyrew/rewrite!/top-level program) + unspecific)) + +(define-macro (define-early-type-inferencer keyword bindings . body) + (let ((proc-name (symbol-append 'EARLYREW/TYPEINF/ keyword))) + (call-with-values + (lambda () (%matchup (cdr bindings) '(handler env) '(cdr form))) + (lambda (names code) + `(DEFINE ,proc-name + (NAMED-LAMBDA (,proc-name ENV FORM) + ;; FORM is in scope in HANDLER + (LET ((HANDLER (LAMBDA ,(cons (car bindings) names) ,@body))) + ,code))))))) + + +(define-early-type-inferencer LOOKUP (env name) + (earlyrew/typeinf/env/lookup env name)) + +(define-early-type-inferencer LAMBDA (env lambda-list body) + (let* ((names (lambda-list->names lambda-list)) + (types (make-list (length names) earlyrew/type/*unknown)) + (env* (earlyrew/typeinf/env/extend env names types))) + (earlyrew/typeinf/expr env* body)) + earlyrew/type/*procedure) + +(define-early-type-inferencer CALL (env rator cont #!rest rands) + (let ((rand-types (earlyrew/typeinf/expr* env rands)) + (rand-count (length rands))) + (define (default) earlyrew/type/*unknown) + (define (apply-handler handler rand-types) + (if (not (equal? cont '(QUOTE #F))) + (internal-error "Early rewrite done after CPS conversion?" + cont)) + (apply handler form rand-types)) + (cond ((QUOTE/? rator) + (cond ((earlyrew/type-method? (quote/text rator) rand-count) + => (lambda (handler) + (apply-handler handler rand-types))) + ((eq? (quote/text rator) %invoke-remote-cache) + (let ((descriptor (quote/text (first rands)))) + (cond ((earlyrew/type-method? (first descriptor) + (second descriptor)) + => (lambda (handler) + (apply-handler handler (cddr rand-types)))) + (else (default))))) + (else (default)))) + ((LAMBDA/? rator) + (hash-table/put! *earlyrew/typemap* rator earlyrew/type/*procedure) + (let* ((names (cdr (lambda/formals rator))) + (env* (earlyrew/typeinf/env/extend env names rand-types))) + (earlyrew/typeinf/expr env* (lambda/body rator)))) + (else + (earlyrew/typeinf/expr env rator) + (default))))) + +(define-early-type-inferencer LET (env bindings body) + (let* ((names (map first bindings)) + (types (map (lambda (binding) + (earlyrew/typeinf/expr env (cadr binding))) + bindings)) + (env* (earlyrew/typeinf/env/extend env names types))) + (earlyrew/typeinf/expr env* body))) + +(define-early-type-inferencer LETREC (env bindings body) + (let* ((names (map first bindings)) + (types (map (lambda (ignored) ignored earlyrew/type/*procedure) + bindings)) + (env* (earlyrew/typeinf/env/extend env names types))) + (earlyrew/typeinf/expr* env* (map second bindings)) + (earlyrew/typeinf/expr env* body))) + +(define-early-type-inferencer QUOTE (env object) + env ; ignored + (earlyrew/typeinf/type-of-constant object)) + +(define-early-type-inferencer DECLARE (env #!rest anything) + env anything ; ignored + earlyrew/type/*illegal-type) + +(define-early-type-inferencer BEGIN (env #!rest actions) + (let ((types (earlyrew/typeinf/expr* env actions))) + (if (equal? (first actions) '(DECLARE (RESULT-TYPE FLONUM))) + earlyrew/type/*flonum + (car (last-pair types))))) + +(define-early-type-inferencer IF (env pred conseq alt) + (earlyrew/typeinf/expr env pred) + (earlyrew/type/lub (earlyrew/typeinf/expr env conseq) + (earlyrew/typeinf/expr env alt))) + +(define (earlyrew/typeinf/expr env expr) + (if (not (pair? expr)) + (illegal expr)) + (let ((type + (case (car expr) + ((QUOTE) (earlyrew/typeinf/quote env expr)) + ((LOOKUP) (earlyrew/typeinf/lookup env expr)) + ((LAMBDA) (earlyrew/typeinf/lambda env expr)) + ((LET) (earlyrew/typeinf/let env expr)) + ((DECLARE) (earlyrew/typeinf/declare env expr)) + ((CALL) (earlyrew/typeinf/call env expr)) + ((BEGIN) (earlyrew/typeinf/begin env expr)) + ((IF) (earlyrew/typeinf/if env expr)) + ((LETREC) (earlyrew/typeinf/letrec env expr)) + (else (illegal expr))))) + ;;(if (not (fixnum? type)) + ;; (internal-error "Not a type" type expr)) + ;;Remove complex numbers: + ;;(set! type (fix:and type (fix:not (fix:or earlyrew/type/*exact-recnum earlyrew/type/*inexact-recnum)))) + (hash-table/put! *earlyrew/typemap* expr type) + type)) + +(define (earlyrew/typeinf/expr* env exprs) + (map (lambda (expr) + (earlyrew/typeinf/expr env expr)) + exprs)) + +(define (earlyrew/typeinf/env/lookup env name) + (cond ((hash-table/get env name #F)) + (else (free-var-error name)))) + +(define (earlyrew/typeinf/env/extend env names0 types0) + (define (extend! name type) + (cond ((hash-table/get env name #F) + (internal-error "Not alpha-converted? Name already defined:" name)) + (else + (hash-table/put! env name type)))) + (let loop ((names names0) (types types0) (optionals? #F)) + (cond ((and (null? names) (null? types)) + env) + ((and optionals? (null? types)) + env) + ((or (null? names) (null? types)) + (internal-error "Mismatch" names0 types0)) + ((eq? (car names) '#!optional) + (loop (cdr names) types #T)) + ((eq? (car names) '#!aux) + (loop (cdr names) types #T)) + ((eq? (car names) '#!rest) + (extend! (second names) earlyrew/type/*unknown) + env) + (else + (extend! (car names) (car types)) + (loop (cdr names) (cdr types) optionals?))))) + +(define (earlyrew/form/type form) + (let ((type (hash-table/get *earlyrew/typemap* form #F))) + (or type + (internal-warning "Form not annotated with type:" form)))) + +(let-syntax ((primitive-types + (macro names0 + (define (definer name value) + `(DEFINE ,(symbol-append 'EARLYREW/TYPE/ name) ',value)) + (let loop ((names names0) (value 1) (defs '())) + (if (null? names) + `(BEGIN ,(definer '*UNKNOWN (- value 1)) + (DEFINE EARLYREW/TYPE/TYPE-NAMES + ',(list->vector names0)) + ,@defs) + (loop (cdr names) + (* value 2) + (cons (definer (car names) value) defs))))))) + (primitive-types *exact-zero ; special numbers... + *exact-one + *exact-minus-one + *small-fixnum>1 ; numbers which won't overflow + *small-fixnum<-1 ; if added or subtracted + *big-fixnum+ve ; other fixnums + *big-fixnum-ve ; other fixnums + *bignum + *ratnum + *flonum + *exact-recnum + *inexact-recnum + *other ; anything else + )) + +(define (earlyrew/type/union . ts) + (reduce fix:or 0 ts)) + +(let-syntax ((alias + (macro (name . parts) + (define (->name name) + (symbol-append 'EARLYREW/TYPE/ name)) + `(DEFINE ,(->name name) + (EARLYREW/TYPE/UNION ,@(map ->name parts)))))) + (alias *empty) + (alias *small-fixnum+ve *exact-one *small-fixnum>1) + (alias *small-fixnum-ve *exact-minus-one *small-fixnum<-1) + (alias *small-fixnum *exact-zero *small-fixnum-ve *small-fixnum+ve) + (alias *big-fixnum *big-fixnum-ve *big-fixnum+ve) + (alias *fixnum *small-fixnum *big-fixnum) + (alias *exact-integer *fixnum *bignum) + (alias *exact-real *fixnum *bignum *ratnum) + (alias *inexact-real *flonum) + (alias *real *exact-real *inexact-real) + (alias *recnum *exact-recnum *inexact-recnum) + (alias *exact-number *exact-real *exact-recnum) + (alias *inexact-number *inexact-real *inexact-recnum) + (alias *number *real *recnum) + + (alias *small-non-negative-fixnum *exact-zero *small-fixnum+ve) + (alias *non-negative-fixnum *exact-zero *small-fixnum+ve *big-fixnum+ve) + (alias *unsigned-byte *exact-zero *exact-one *small-fixnum>1) + (alias *procedure *other) + (alias *boolean *other) + (alias *vector-length *exact-zero *small-fixnum+ve) + (alias *string-length *non-negative-fixnum)) + +(define earlyrew/type/*illegal-type 'ILLEGAL-TYPE) + +(define (earlyrew/typeinf/type->description t) + (cond ((eq? t earlyrew/type/*unknown) '(*unknown)) + ((eq? t earlyrew/type/*number) '(*number)) + ((eq? t earlyrew/type/*fixnum) '(*fixnum)) + (else + (let loop ((bit 1) (index 0)) + (if (< bit earlyrew/type/*unknown) + (if (zero? (fix:and t bit)) + (loop (* bit 2) (+ index 1)) + (cons (vector-ref earlyrew/type/type-names index) + (loop (* bit 2) (+ index 1)))) + '()))))) + + +(define-structure ea/pp/annotation + text + type) + +(define (pp/ann/ty program) + (let ((old-browser:print browser:print)) + (let ((ht (make-eq-hash-table))) + (define (ppt form) + (let ((ann (hash-table/get ht form #F))) + (pp form) + (if (ea/pp/annotation? ann) + (let ((type (ea/pp/annotation-type ann))) + (newline) + (display (unsigned-integer->bit-string 16 type)) + (pp (earlyrew/typeinf/type->description type))) + (pp type)))) + (hash-table/for-each *earlyrew/typemap* + (lambda (node type) + (if (pair? node) + (hash-table/put! ht node (make-ea/pp/annotation node type))))) + (fluid-let + ((browser:print + (lambda (object) + (if (ea/pp/annotation? object) + (let ((form (ea/pp/annotation-text object))) + (fluid-let ((*unparser-list-depth-limit* 4)) + (pp form)) + (newline) + (fluid-let ((*unparser-list-depth-limit* 1)) + (if (call/? form) + (begin + (display "\n

Argument types

\n") + (for-each (lambda (part) + (ppt part) + (display "\n")) + (if (call/%invoke-remote-cache? form) + (cddr (cdddr form)) + (cdddr form))))) + (display "\n\n

Result type

\n") + (ppt form))) + (old-browser:print object))))) + (pp/ann program ht))))) + + +(define earlyrew/typeinf/type-of-constant + (let* ((max-fixnum (object-new-type 0 -1)) + (max-small-fixnum (quotient max-fixnum 2)) + (min-small-fixnum (- -1 max-small-fixnum))) + (lambda (value) + (cond ((fixnum? value) + (cond ((eqv? value 0) earlyrew/type/*exact-zero) + ((eqv? value 1) earlyrew/type/*exact-one) + ((eqv? value -1) earlyrew/type/*exact-minus-one) + ((<= 2 value max-small-fixnum) + earlyrew/type/*small-fixnum>1) + ((<= min-small-fixnum value -2) + earlyrew/type/*small-fixnum<-1) + ((< value 0) + earlyrew/type/*big-fixnum-ve) + (else earlyrew/type/*big-fixnum+ve))) + ((exact-integer? value) + earlyrew/type/*bignum) + ((exact-rational? value) + earlyrew/type/*ratnum) + ((flo:flonum? value) + earlyrew/type/*flonum) + ((complex? value) + (if (exact? value) + earlyrew/type/*exact-recnum + earlyrew/type/*inexact-recnum)) + (else + earlyrew/type/*other))))) + +(define (earlyrew/type/lub t1 t2) + (if (and (fixnum? t1) + (fixnum? t2)) + (fix:or t1 t2) + (internal-error "LUB:" t1 t2))) + +(define (earlyrew/type/intersection t1 t2) + (if (and (fixnum? t1) + (fixnum? t2)) + (fix:and t1 t2) + (internal-error "INTERSECTION:" t1 t2))) + +(define (earlyrew/subtype? sub super) + (if (and (fixnum? sub) + (fixnum? super)) + (fix:= super (fix:or sub super)) + (internal-error "SUBTYPE:" sub super))) + +(define (earlyrew/type=? t1 t2) (fix:= t1 t2)) + +(define (earlyrew/type/not t) + (if (fixnum? t) + (fix:andc earlyrew/type/*unknown t) + (internal-error "SUBTYPE:" sub super))) + +(define (earlyrew/closed-on closed-type tu tv subject-type) + (if (and (earlyrew/subtype? tu closed-type) + (earlyrew/subtype? tv closed-type)) + (earlyrew/type/intersection subject-type closed-type) + subject-type)) + +(define (earlyrew/binary-exactness-contagion tu tv subject-type) + (cond + ((and (earlyrew/subtype? tu earlyrew/type/*exact-number) + (earlyrew/subtype? tv earlyrew/type/*exact-number)) + (earlyrew/type/intersection subject-type earlyrew/type/*exact-number)) + ((or (earlyrew/subtype? tu earlyrew/type/*inexact-number) + (earlyrew/subtype? tv earlyrew/type/*inexact-number)) + (earlyrew/type/intersection subject-type earlyrew/type/*inexact-number)) + (else + subject-type))) + +(define *earlyrew-typeinf-operators* (make-eq-hash-table)) + +(define (earlyrew/type-method? operator arity) + (cond ((hash-table/get *earlyrew-typeinf-operators* operator #F) + => (lambda (alist) + (cond ((assq arity alist) => cdr) + (else #F)))) + (else #F))) + +(define (define-early-type-method name arity handler) + (let ((slot (hash-table/get *earlyrew-typeinf-operators* name '()))) + (hash-table/put! *earlyrew-typeinf-operators* + name + (cons (cons arity handler) slot))) + name) + + +(let* ((unary-result + (lambda (type #!optional arg-type) + (default-object? arg-type) ; ignored + (lambda (op) + (define-early-type-method op 1 + (lambda (form u) form u type))))) + (binary-result + (lambda (type #!optional arg1-type arg2-type) + (default-object? arg1-type) ; ignored + (default-object? arg2-type) ; ignored + (lambda (op) + (define-early-type-method op 2 + (lambda (form u v) form u v type))))) + (do-each + (lambda (op . args) (for-each op args)))) + + (do-each (unary-result earlyrew/type/*fixnum) + fix:-1+ fix:1+ fix:not) + (do-each (binary-result earlyrew/type/*fixnum) + fix:+ fix:- fix:* fix:quotient fix:remainder + fix:andc fix:and fix:or fix:xor fix:lsh) + (do-each (unary-result earlyrew/type/*flonum) + flo:negate flo:abs flo:sqrt + flo:floor flo:ceiling flo:truncate flo:round + flo:exp flo:log flo:sin flo:cos flo:tan flo:asin + flo:acos flo:atan) + (do-each (binary-result earlyrew/type/*flonum) + flo:+ flo:- flo:* flo:/ flo:atan2 flo:expt) + + (do-each (unary-result earlyrew/type/*boolean) + not eq? null? false? + boolean? cell? pair? vector? %record? string? + fixnum? index-fixnum? flo:flonum?) + + (do-each (binary-result earlyrew/type/*boolean) + (make-primitive-procedure '&=) + (make-primitive-procedure '&<) + (make-primitive-procedure '&>) + fix:= fix:> fix:< fix:<= fix:>= + flo:= flo:> flo:< + object-type?) + + (do-each (unary-result earlyrew/type/*unsigned-byte) + char-code char->ascii) + + (do-each (binary-result earlyrew/type/*unsigned-byte) + vector-8b-ref) + + (do-each (binary-result earlyrew/type/*flonum) + flo:vector-ref) + + (do-each (unary-result earlyrew/type/*small-fixnum+ve) + char->integer) + + (do-each (unary-result earlyrew/type/*vector-length) + vector-length flo:vector-length length) + + ;;((unary-result earlyrew/type/*small-non-negative-fixnum) string-length) + ((unary-result earlyrew/type/*string-length) string-length) + + ((unary-result earlyrew/type/*small-fixnum) object-type) + ) + + +(define (earlyrew/rewrite-operator! replacement-op) + (lambda (form) + (form/rewrite! (call/operator form) `(QUOTE ,replacement-op)))) + +(define (earlyrew/rewrite-diamond gen-test-x gen-x-type + gen-test-y gen-y-type + cheap-op costly-op) + (define (test-will-fail? type type-test-checks-for) + (earlyrew/subtype? type (earlyrew/type/not type-test-checks-for))) + (define (test-will-succeed? type type-test-checks-for) + (earlyrew/subtype? type type-test-checks-for)) + + (define (generate-test var t gen-test gen-type) + (cond ((test-will-fail? t gen-type) `(QUOTE ,#F)) + ((test-will-succeed? t gen-type) `(QUOTE ,#T)) + (else (gen-test `(LOOKUP ,var))))) + (let ((rewrite-costly (earlyrew/rewrite-operator! costly-op)) + (rewrite-cheap (earlyrew/rewrite-operator! cheap-op))) + (lambda (form tx ty) + form ; ignored + (cond ((or (test-will-fail? tx gen-x-type) + (test-will-fail? ty gen-y-type)) + (rewrite-costly form)) + ((and (test-will-succeed? tx gen-x-type) + (test-will-succeed? ty gen-y-type)) + (rewrite-cheap form)) + (else + (let* ((x-name (earlyrew/new-name 'X)) + (y-name (earlyrew/new-name 'Y)) + (x-test (generate-test x-name tx gen-test-x gen-x-type)) + (y-test (generate-test y-name ty gen-test-y gen-y-type))) + (form/rewrite! form + (bind x-name (first (call/operands form)) + (bind y-name (second (call/operands form)) + `(IF ,(andify x-test y-test) + (CALL (QUOTE ,cheap-op) + (QUOTE #F) + (LOOKUP ,x-name) + (LOOKUP ,y-name)) + (CALL (QUOTE ,costly-op) + (QUOTE #F) + (LOOKUP ,x-name) + (LOOKUP ,y-name)))))))))))) + + +(let () + (define (plus/minus-pre form tu tv) + form ; ignored + (cond ((and (earlyrew/subtype? tu earlyrew/type/*small-fixnum) + (earlyrew/subtype? tv earlyrew/type/*small-fixnum)) + earlyrew/type/*fixnum) + (else + earlyrew/type/*number))) + + (define (standard-binary-method name pre post) + (define-early-type-method name 2 + (lambda (form tu tv) + (let* ((result (pre form tu tv)) + (result* + (earlyrew/binary-exactness-contagion + tu tv + (earlyrew/closed-on earlyrew/type/*real tu tv result))) + (result** + (or (and post (post form result* tu tv)) result*))) + result**)))) + + (define (number-pre form tu tv) form tu tv earlyrew/type/*number) + (define (*-post form result tu tv) + form ; ignored + (if (or (earlyrew/subtype? earlyrew/type/*exact-zero tu) + (earlyrew/subtype? earlyrew/type/*exact-zero tv)) + (fix:or earlyrew/type/*exact-zero result) + result)) + + (standard-binary-method (make-primitive-procedure '&+) plus/minus-pre #F) + (standard-binary-method (make-primitive-procedure '&-) plus/minus-pre #F) + (standard-binary-method (make-primitive-procedure '&*) number-pre *-post) + (standard-binary-method (make-primitive-procedure '&/) number-pre #F) + ) + + +(define-early-type-method 'EXACT->INEXACT 1 + (lambda (form arg-type) + form ; ignored + (cond ((earlyrew/subtype? arg-type earlyrew/type/*real) + earlyrew/type/*inexact-real) + ((earlyrew/subtype? arg-type earlyrew/type/*recnum) + earlyrew/type/*inexact-recnum) + (else + earlyrew/type/*inexact-number)))) + +(define-early-type-method 'SQRT 1 + (lambda (form arg-type) + form ; ignored + (cond ((earlyrew/subtype? arg-type earlyrew/type/*non-negative-fixnum) + earlyrew/type/*real) + ((earlyrew/subtype? arg-type earlyrew/type/*inexact-number) + earlyrew/type/*inexact-number) + (else + earlyrew/type/*number)))) + +(define-early-type-method 'EXPT 2 + (let ((type:+1/-1 (earlyrew/type/union earlyrew/type/*exact-one + earlyrew/type/*exact-minus-one))) + (lambda (form t-base t-exponent) + form ; ignored + (cond ((and (earlyrew/subtype? t-base earlyrew/type/*exact-minus-one) + (earlyrew/subtype? t-exponent earlyrew/type/*exact-integer)) + type:+1/-1) + ((earlyrew/subtype? t-exponent earlyrew/type/*exact-integer) + (fix:or earlyrew/type/*exact-one t-base)) + (else + earlyrew/type/*number))))) + +(let () + (define (unary/2 name input1 output1 input2 output2) + (define-early-type-method name 1 + (lambda (form arg-type) + form ; ignored + (cond ((earlyrew/subtype arg-type input1) output1) + ((earlyrew/subtype arg-type input2) output2) + (else earlyrew/type/*number))))) + (define (unary/3 name input1 output1 input2 output2 input3 output3) + (define-early-type-method name 1 + (lambda (form arg-type) + form ; ignored + (cond ((earlyrew/subtype arg-type input1) output1) + ((earlyrew/subtype arg-type input2) output2) + ((earlyrew/subtype arg-type input3) output3) + (else earlyrew/type/*number))))) + (unary/2 'SIN + earlyrew/type/*exact-zero earlyrew/type/*exact-zero + earlyrew/type/*real earlyrew/type/*flonum) + (unary/2 'COS + earlyrew/type/*exact-zero earlyrew/type/*exact-one + earlyrew/type/*real earlyrew/type/*flonum) + (unary/2 'TAN + earlyrew/type/*exact-zero earlyrew/type/*exact-zero + earlyrew/type/*real earlyrew/type/*flonum) + (unary/2 'ACOS + earlyrew/type/*exact-one earlyrew/type/*exact-zero + earlyrew/type/*unknown earlyrew/type/*inexact-number) + (unary/2 'ASIN + earlyrew/type/*exact-zero earlyrew/type/*exact-zero + earlyrew/type/*unknown earlyrew/type/*inexact-number) + (unary/3 'EXP + earlyrew/type/*recnum earlyrew/type/*inexact-recnum + earlyrew/type/*exact-zero earlyrew/type/*exact-one + earlyrew/type/*real earlyrew/type/*inexact-real) + (unary/2 'LOG + earlyrew/type/*exact-one earlyrew/type/*exact-zero + earlyrew/type/*number earlyrew/type/*inexact-number) ) + + +#| +(define-early-type-method 'EXPT 2 + (let ((&* (make-primitive-procedure '&*)) + (max-multiplies 3)) + (lambda (form base exponent) + (define (make-product x y) + `(CALL (QUOTE ,&*) + (QUOTE #F) + ,x ,y)) + (define (count-multiplies n) + (cond ((= n 1) 0) + ((= n 2) 1) + ((even? n) (+ (count-multiplies (/ n 2)) 1)) + ((odd? n) (+ (count-multiplies (- n 1)) 1)))) + (define (power variable n) + (cond ((= n 1) variable) + ((= n 2) (make-product variable variable)) + ((even? n) + (let ((square (earlyrew/new-name 'X))) + (bind square (make-product variable variable) + (power `(LOOKUP ,square) (/ n 2))))) + ((odd? n) + (make-product variable (power variable (- n 1)))))) + + (cond ((form/number? exponent) + => (lambda (exponent) + (cond ((form/number? base) + => (lambda (base) + `(QUOTE ,(expt base exponent)))) + ((eqv? exponent 0) + `(QUOTE 1)) + ((eqv? exponent 1) + base) + ((and (exact-integer? exponent) + (>= exponent 2) + (<= (count-multiplies exponent) max-multiplies)) + (let* ((base-name (earlyrew/new-name 'X)) + (expression (power `(LOOKUP ,base-name) exponent))) + (bind base-name base + expressions))) + (else (default))))) + (else + (default)))))) +|# + +(define (earlyrew/post-rewrite form rewrite) + (hash-table/put! *earlyrew/posted-rewrites* form rewrite)) + +(define (earlyrew/posted-rewrite? form) + (hash-table/get *earlyrew/posted-rewrites* form #F)) + +(define (earlyrew/rewrite!/top-level form) + (earlyrew/rewrite! form)) + +(define (earlyrew/rewrite! form) + (define (rewrite* forms) + (for-each earlyrew/rewrite! forms)) + (define (let&rec bindings body) + (for-each (lambda (bindings) (earlyrew/rewrite! (second bindings))) + bindings) + (earlyrew/rewrite! body)) + (cond ((QUOTE/? form)) + ((LOOKUP/? form)) + ((CALL/? form) + (let ((operator (call/operator form)) + (operands (call/operands form))) + (define (try name arity rands) + (let ((handler (earlyrew/type-rewrite? name arity))) + (if handler + (apply handler form rands)))) + (earlyrew/rewrite! operator) + (rewrite* (call/cont-and-operands form)) + (cond ((earlyrew/posted-rewrite? form) + => (lambda (rewrite!) (rewrite! form))) + ((not (QUOTE/? operator)) #F) + ((eq? (quote/text operator) %invoke-remote-cache) + (try (first (quote/text (first operands))) + (second (quote/text (first operands))) + (cddr operands))) + (else + (try (quote/text operator) (length operands) operands))))) + ((LAMBDA/? form) (earlyrew/rewrite! (lambda/body form))) + ((IF/? form) (rewrite* (cdr form))) + ((LET/? form) (let&rec (let/bindings form) (let/body form))) + ((LETREC/? form) (let&rec (letrec/bindings form) (letrec/body form))) + ((BEGIN/? form) (rewrite* (begin/exprs form))) + ((DECLARE/? form)) + (else (illegal form)))) + + +(define *earlyrew/type-rewrites* (make-eq-hash-table)) + +(define (define-type-rewrite name arity handler) + (let ((alist (hash-table/get *earlyrew/type-rewrites* name '()))) + (hash-table/put! *earlyrew/type-rewrites* + name + (cons (cons arity handler) alist))) + name) + +(define (earlyrew/type-rewrite? name arity) + (let ((alist (hash-table/get *earlyrew/type-rewrites* name '()))) + (and alist + (let ((pair (or (assq arity alist) (assq 'any alist)))) + (and pair + (cdr pair)))))) + +(define earlyrew/flonum-test + (let ((flonum? (make-primitive-procedure 'FLONUM?))) + (lambda (subject) + `(CALL (QUOTE ,flonum?) '#F ,subject)))) + +(let () + (define (small-fixnum-test/1 subject) + `(CALL (QUOTE ,%small-fixnum?) '#F ,subject '1)) + (define (additive fix:op flo:op out-of-line:op) + (let ((fix:diamond (earlyrew/rewrite-diamond + small-fixnum-test/1 earlyrew/type/*small-fixnum + small-fixnum-test/1 earlyrew/type/*small-fixnum + fix:op out-of-line:op)) + (flo:diamond (earlyrew/rewrite-diamond + earlyrew/flonum-test earlyrew/type/*flonum + earlyrew/flonum-test earlyrew/type/*flonum + flo:op out-of-line:op))) + (lambda (form x y) + (let ((tx (earlyrew/form/type x)) + (ty (earlyrew/form/type y))) + (cond ((or (earlyrew/subtype? tx earlyrew/type/*flonum) + (earlyrew/subtype? ty earlyrew/type/*flonum)) + (flo:diamond form tx ty)) + (else + (fix:diamond form tx ty))))))) + + (define (define-additive name fix:op flo:op out:op) + (define-type-rewrite (make-primitive-procedure name) 2 + (additive fix:op flo:op out:op))) + + (define-additive '&+ fix:+ flo:+ %+) + (define-additive '&- fix:- flo:- %-) + + (define-additive '&< fix:< flo:< %<) + (define-additive '&= fix:= flo:= %=) + (define-additive '&> fix:> flo:> %>)) + +(define-type-rewrite (make-primitive-procedure '&*) 2 + (let ((rewrite-out-of-line (earlyrew/rewrite-operator! %*)) + (flo:diamond (earlyrew/rewrite-diamond + earlyrew/flonum-test earlyrew/type/*flonum + earlyrew/flonum-test earlyrew/type/*flonum + flo:* %*))) + (lambda (form x y) + (let ((tx (earlyrew/form/type x)) + (ty (earlyrew/form/type y))) + (cond ((or (earlyrew/subtype? tx earlyrew/type/*flonum) + (earlyrew/subtype? ty earlyrew/type/*flonum)) + (flo:diamond form tx ty)) + (else + (rewrite-out-of-line form))))))) + -- 2.25.1