From: Stephen Adams Date: Fri, 1 Sep 1995 18:53:45 +0000 (+0000) Subject: Initial revision X-Git-Tag: 20090517-FFI~6001 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=aa8036b0798cfb22621990163055e4dca5fd255c;p=mit-scheme.git Initial revision --- diff --git a/v8/src/compiler/midend/typerew.scm b/v8/src/compiler/midend/typerew.scm new file mode 100644 index 000000000..9e2bec8bf --- /dev/null +++ b/v8/src/compiler/midend/typerew.scm @@ -0,0 +1,978 @@ +#| -*-Scheme-*- + +$Id: typerew.scm,v 1.1 1995/09/01 18:53:45 adams Exp $ + +Copyright (c) 1994-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. |# + +;;;; Type analysis and rewriting +;;; package: (compiler midend) + +(declare (usual-integrations)) + +(define (typerew/top-level program) + (let ((program* (copier/top-level code-rewrite/remember))) + (fluid-let ((*effects* (make-monotonic-strong-eq-hash-table))) + (typerew/effect/expr program*)))) + +(define-macro (define-type-rewriter keyword bindings . body) + (let ((proc-name (symbol-append 'TYPEREW/ keyword))) + (call-with-values + (lambda () (%matchup bindings '(handler) '(cdr form))) + (lambda (names code) + `(DEFINE ,proc-name + (NAMED-LAMBDA (,proc-name FORM ENV RECEIVER) + ;; FORM, ENV and RECEIVER are in scope in handler + FORM + (LET ((HANDLER (LAMBDA ,names ,@body))) + ,code))))))) + +(define-integrable (typerew/send receiver quantity type env) + (receiver quantity type (q-env:glb/1 env quantity type))) + +(define-type-rewriter LOOKUP (name) + (let ((quantity (quantity:variable name))) + (receiver quantity (q-env:lookup env quantity) env))) + +(define-type-rewriter LAMBDA (lambda-list body) + ;; . Simple analysis: we assume that this procedure escapes and is called + ;; after someone has played with every mutable structure in the universe. + ;; . The names in the lambda-list are unknown so we dont have + ;; to add them to the quantity environment. + ;; . It is a shame to waste the returned information: it tells us the + ;; return type and constraints imposed on the arguments, and even if the + ;; procedure returns at all. + (typerew/expr + body + (q-env:restrict env effect:unknown) + (lambda (quantity type env*) + quantity type env* ; a shame + ;; Creating the closure itself is no big deal since we dont have + ;; reasonable type information for procedures. + (typerew/send receiver + (quantity:other-expression form effect:none) + type:compiled-entry + env)))) + +(define-type-rewriter CALL (rator cont #!rest rands) + (define (default) + (typerew/expr*/unordered + (cdr form) env + (lambda (quantities types envs env*) + quantities types envs ; we could use these for something + ;; Assume that the procedure wrecks everything + (receiver (quantity:other-expression form effect:unknown) + type:any ; uninteresting => no SEND + (q-env:restrict env* effect:unknown))))) + (cond ((LAMBDA/? rator) + (let ((formals (lambda/formals rator))) + (if (or (hairy-lambda-list? formals) + (not (= (length (cdr formals)) (length rands)))) + (default) + (typerew/bind (cdr formals) rands env receiver + (lambda/body rator))))) + #| + ((and (QUOTE/? rator) + (operator-type (quote/text rator))) + => (lambda (proc-type) + (typerew/expr*/unordered + rands env + (lambda (quantities types envs env*) + envs ; ignored + (typerew/known-operator form (quote/text rator) proc-type + quantities types env* receiver))))) + |# + ((and (QUOTE/? rator) + (typerew/operator-method? (quote/text rator) (length rands))) + => (lambda (method) + (typerew/expr*/unordered + rands env + (lambda (quantities types envs env*) + envs ; ignored + (method quantities types env* form receiver))))) + ((QUOTE/? rator) + (default)) + (else (default)))) + +(define-type-rewriter LET (bindings body) + (typerew/bind (map first bindings) (map second bindings) env receiver body)) + +(define (typerew/bind names exprs env receiver body) + (cond ((null? names) (typerew/expr body env receiver)) + ((null? (cdr exprs)) + (typerew/expr + (first exprs) env + (lambda (quantity type env*) + (typerew/expr + body + (q-env:glb/1 env* (quantity:variable (car names)) type) + receiver)))) + (else ; lots of arguments in some order + (typerew/expr*/unordered + exprs env + (lambda (quantities types envs env*) + envs ; ignored + (typerew/expr body + (q-env:bind* env* names quantities types) + receiver)))))) + + +#| +(define (typerew/known-operator form rator rator-type + quantities types env receiver) + + (define (types-satisfy? types test-types) + (let loop ((types types) (tests test-types)) + (cond ((and (null? types) (null? tests)) #T) + ((not (pair? tests)) #T) ;rest-list + ((not (type:subset? (car types) (car tests))) #F) + (else (loop (cdr types) (cdr tests)))))) + + (let ((result-type (procedure-type/result-type rator-type)) + (asserted-types (procedure-type/argument-assertions rator-type)) + (replacements (operator-variants rator))) + (if (and replacements (not (null? replacements))) + (begin ;look for a replacement + (if (types-satisfy? types asserted-types) + (let loop ((ops replacements)) + (cond ((null? ops) + (pp `("safe but none of replacements match" ,form))) + ((operator-type (car ops)) + => (lambda (op-type) + (if (types-satisfy? types (procedure-type/argument-types op-type)) + (pp `(suggest ,(car ops) ,op-type)) + (loop (cdr ops))))) + (else (loop (cdr ops)))))))) + (let ((env* (q-env:restrict + (q-env:glb env + (map (lambda (q a-type type) + (cons q (type:and a-type type))) + quantities + asserted-types + types)) + (procedure-type/effects-performed rator-type)))) + (typerew/send receiver + (quantity:combination rator quantities) + result-type + env*)))) +|# + +(define-type-rewriter LETREC (bindings body) + ;; This is lame. We need more complex procedure types to summarize what + ;; we found out about the procedures, and an intelligent traversal + ;; order to maximize the info (or some kind of iterative solution). + (let ((env* + (q-env:glb env + (map (lambda (binding) + (cons (quantity:variable (first binding)) + type:compiled-entry)) + bindings)))) + (let loop ((bindings bindings) + (env** env*)) + (if (null? bindings) + (typerew/expr body env** receiver) + (typerew/expr (second (car bindings)) + env** + (lambda (quantity type env***) + (loop (cdr bindings) + (q-env:glb/1 env*** quantity type)))))))) + +(define-type-rewriter QUOTE (object) + (receiver (quantity:constant form) (type:of-object object) env)) + +(define-type-rewriter DECLARE (#!rest anything) + (receiver (quantity:other-expression form effect:none) type:any env)) + +(define-type-rewriter BEGIN (#!rest actions) + (if (null? actions) + (receiver (quantity:other-expression form effect:none) type:any env) + (let loop ((actions actions) (env env)) + (if (null? (cdr actions)) + (typerew/expr (car actions) env receiver) + (typerew/expr + (car actions) env + (lambda (quantity type env*) + quantity type ; ignored + (loop (cdr actions) env*))))))) + +(define-type-rewriter IF (pred conseq alt) + (typerew/pred + pred env + (lambda (env_t env_f) + (typerew/expr + conseq env_t + (lambda (quantity_t type_t env_t*) + (typerew/expr + alt env_f + (lambda (quantity_f type_f env_f*) + (typerew/send receiver + (quantity:combination/2/assoc 'IF-MERGE + quantity_t quantity_f) + (type:or + (if (q-env:bottom? env_t*) type:empty type_t) + (if (q-env:bottom? env_f*) type:empty type_f)) + (q-env:lub env_t* env_f*))))))))) + +(define (typerew/expr*/left-to-right exprs env receiver) + ;; receiver = (lambda (quantities types env) ...) + (typerew/expr*/%ordered exprs env + (lambda (Qs Ts env*) + (receiver (reverse! Qs) (reverse! Ts) env*)))) + +(define (typerew/expr*/right-to-left exprs env receiver) + ;; receiver = (lambda (quantities types env) ...) + (typerew/expr*/%ordered (reverse exprs) env receiver)) + +(define (typerew/expr*/%ordered exprs env receiver) + ;; receiver = (lambda (quantities types env) ...) + ;; Note: Yields quantities and types in reversed order + (let loop ((Qs '()) (Ts '()) (env env) (exprs exprs)) + (if (not (pair? exprs)) + (receiver Qs Ts env) + (typerew/expr (car exprs) + env + (lambda (Q T env*) + (loop (cons Q Qs) (cons T Ts) env* (cdr exprs))))))) + +(define (typerew/expr*/unordered exprs env receiver) + ;; receiver = (lambda (quantities types envs env) ...) + ;; . ENVS are returned because they can give hints on how subexpressions + ;; should be ordered. + ;; . Try every permutation! you must be joking. + ;; . An approximation is to evaluate each expression in an environment + ;; containing all the deleterious and none of the beneficial effects of + ;; the other expressions. This is the worst that the other + ;; expressions could do if they were ordered before this + ;; expression. The output environment must then have all the + ;; deleterious effects of the other expressions applied (thus + ;; modelling their evaluation after the current expression). The + ;; result is then the GLB of the expression results. + ;; . An approximation to the approximation is punt if any expression has + ;; side-effects. + + (let ((split-env + (if (for-all? exprs form/simple&side-effect-free?) ;exponential! + env + (q-env:restrict env effect:unknown)))) + (define (glb* envs) + ;; (reduce q-env:glb q-env:top envs) + ;; Hopefully most envs are the same as passed in (lookups & quotes) + (call-with-values + (lambda () + (list-split envs (lambda (env) (eq? env split-env)))) + (lambda (splits others) + (if (and (null? splits) (pair? others)) + (fold-left q-env:glb (car others) (cdr others)) + (fold-left q-env:glb split-env others))))) + (let loop ((Qs '()) (Ts '()) (Es '()) (exprs exprs)) + (if (not (pair? exprs)) + (receiver (reverse! Qs) (reverse! Ts) (reverse! Es) (glb* Es)) + (typerew/expr (car exprs) + split-env + (lambda (Q T env*) + (loop (cons Q Qs) (cons T Ts) (cons env* Es) + (cdr exprs)))))))) + +(define (typerew/remember new old) + (code-rewrite/remember new old)) + +(define (typerew/remember* new old) + (code-rewrite/remember new old)) + +(define (typerew/new-name prefix) + (new-variable prefix)) + +(define (typerew/type-checks? class) + (and compiler:generate-type-checks? + (if (pair? compiler:generate-type-checks?) + (memq class compiler:generate-type-checks?) + #T))) + +;; Quantities +;; +;; Quantities are represented as vectors: +;; #( ) +;; #( ) +;; #( . ) +;; is the effects to which this quantity is sensitive + +(define-integrable (quantity:hash Q) + (vector-ref Q 0)) + +(define-integrable (quantity:effects Q) + (vector-ref Q 1)) + +(define-integrable (quantity:operator Q) + (vector-ref Q 2)) + +(define-integrable (quantity:operand1 Q) + (vector-ref Q 3)) + +(define (quantity:constant quoted-form) + (vector (quantity:hash-constant (quote/text quoted-form)) + effect:none + quoted-form)) + +(define (quantity:variable name) + (vector (quantity:hash-symbol name) effect:none name)) + +(define (quantity:combination/1 operator operand) + (vector (quantity:hash+ (quantity:hash-operator operator) + (quantity:hash operand)) + (effect:union (operator-sensitive-effects operator) + (quantity:effects operand)) + operator + operand)) + +(define (quantity:combination/2 operator operand1 operand2) + (vector (quantity:hash+ (quantity:hash-operator operator) + (quantity:hash+ (quantity:hash operand1) + (quantity:hash operand2))) + (effect:union (operator-sensitive-effects operator) + (effect:union (quantity:effects operand1) + (quantity:effects operand2))) + operator + operand1 + operand2)) + +(define (quantity:combination/2/assoc operator operand1 operand2) + (if (fix:<= (quantity:hash operand1) (quantity:hash operand2)) + (quantity:combination/2 operator operand1 operand2) + (quantity:combination/2 operator operand2 operand1))) + +(define (quantity:combination operator operands) + (define (default) + (list->vector + (cons* + (fold-left (lambda (hash q) (quantity:hash+ q (quantity:hash operand))) + (quantity:hash-operator operator) + operands) + (fold-left (lambda (eff q) (effect:union eff (quantity:effects q))) + (operator-sensitive-effects operator) + operands) + operator + operands))) + (cond ((not (pair? operands)) (default)) + ((not (pair? (cdr operands))) + (quantity:combination/1 operator (first operands))) + ((not (pair? (cddr operands))) + (quantity:combination/2 operator (first operands) (second operands))) + (else (default)))) + +(define (quantity:other-expression source effects) + (vector 0 effects source)) + +(define (quantity:same? q1 q2) + (let same? ((q1 q1) (q2 q2)) + (or (eq? q1 q2) + (and (vector? q1) + (vector? q2) + (fix:= (quantity:hash q1) (quantity:hash q2)) + (= (vector-length q1) (vector-length q2)) + (let loop ((i (- (vector-length q1) 1))) + (or (fix:< i 2) + (and (same? (vector-ref q1 i) (vector-ref q2 i)) + (loop (fix:- i 1))))))))) + +(define (quantity:hash-symbol sym) + (let* ((s (symbol-name sym)) + (c1 (vector-8b-ref s 0)) + (c2 (vector-8b-ref s (- (string-length s) 1)))) + (+ c1 (* 17 c2)))) + +(define (quantity:hash-constant value) + (cond ((= 0 (object-gc-type value)) + (fix:and #xFFF (object-datum value))) + ((flo:flonum? value) 1) + (else (object-type value)))) + +(define-integrable (quantity:hash+ q1 q2) + (let ((q1* (fix:* q1 7)) + (q2* (fix:* q2 13))) + (fix:and #xFFFF (fix:+ (fix:+ q1* (fix:lsh -13 q1)) + (fix:+ q2* (fix:lsh -12 q2)))))) + +(define quantity:hash-operator + (let ((table (make-monotonic-strong-eq-hash-table)) + (last 0)) + (lambda (operator) + (or (monotonic-strong-eq-hash-table/get table operator #F) + (let ((value (quantity:hash+ last 10000))) + (monotonic-strong-eq-hash-table/put! table operator value) + value))))) + +;; Quantity environments map quantities to types +;; +;; Quantity type lattice +;; +;; . bottom: everything is known to be of type:empty (this means that +;; i.e. the program never gets here) +;; . (): Top. nothing is known, i.e. every quantity may be of any type +;; . alist(quantity*type): listed quantities of of knwon type, others + +(define (q-env:lookup env quantity) ; -> a type + (cond ((q-env:bottom? env) + type:empty) + ((%q-env:lookup env quantity (quantity:hash quantity)) + => cdr) + (else type:any))) + +(define (%q-env:lookup env Q H) ; -> #F or the association + (let loop ((env env)) + (cond ((not (pair? env)) + #F) + ((fix:> (quantity:hash (caar env)) H) + #F) + ((quantity:same? Q (caar env)) + (car env)) + (else (loop (cdr env)))))) + +(define (%q-env:delete env Q H) + (let loop ((env env)) + (cond ((not (pair? env)) + '()) + ((fix:> (quantity:hash (caar env)) H) + env) + ((quantity:same? Q (caar env)) + (cdr env)) + (else (cons (car env) (loop (cdr env))))))) + +(define (q-env:restrict env effects) + ;; Remove quantities depending on EFFECTS. + ;; Computes the LUB of ENV and the environment containing all possible + ;; quantities dependent on EFFECTS mapped to type:any and all other + ;; possible quantities mapped to type:none. + (cond ((q-env:bottom? env) + env);; justified only because it implies dead code + ((effect:none? effects) + env) + (else + (list-transform-positive env + (lambda (quantity.type) + (effect:disjoint? (quantity:effects (car quantity.type)) + effects)))))) + +(define q-env:top '()) +(define q-env:bottom 'bottom) + +(define (q-env:bottom? env) + (eq? q-env:bottom env)) + +(define (q-env:top? env) + (null? env)) + +(define (q-env:lub env1 env2) + (define (merge env1 env2) + (define (skip1) (merge (cdr env1) env2)) + (if (and (pair? env1) (pair? env2)) + (let ((q1 (caar env1)) + (q2 (caar env2))) + (let ((h1 (quantity:hash q1)) + (h2 (quantity:hash q2))) + (cond ((fix:< h2 h1) (merge env1 (cdr env2))) + ((fix:< h1 h2) (skip1)) + ((%q-env:lookup env2 q1 h1) + => (lambda (q2.type2) + (let ((type* (type:or (cdar env1) (cdr q2.type2)))) + (if (type:subset? type:any type*) ; useless + (skip1) + (cons (cons q1 type*) (skip1)))))) + (else (skip1))))) + '())) + (cond ((q-env:bottom? env1) env2) + ((q-env:bottom? env2) env1) + (else (merge env1 env2)))) + +(define (q-env:glb/1 env quantity type) + (let ((op (quantity:operator quantity))) + (if (quote/? op) + (if (type:disjoint? (type:of-object (quote/text op)) type) + q-env:bottom;; we have just concluded a constant an absurd value + env) + (q-env:glb env (list (cons quantity type)))))) + +(define (q-env:glb env1 env2) + (define (merge env1 env2 accepted) + (define (accept1) (merge (cdr env1) env2 (cons (car env1) accepted))) + (define (accept2) (merge env1 (cdr env2) (cons (car env2) accepted))) + (cond ((null? env1) (append! (reverse! accepted) env2)) + ((null? env2) (append! (reverse! accepted) env1)) + (else ;(and (pair? env1) (pair? env2)) + (let ((q1 (caar env1)) + (q2 (caar env2))) + (let ((h1 (quantity:hash q1)) + (h2 (quantity:hash q2))) + (cond ((fix:< h1 h2) (accept1)) + ((fix:< h2 h1) (accept2)) + ((%q-env:lookup env2 q1 h1) + => (lambda (q2.type2) + (let ((type* (type:and (cdar env1) (cdr q2.type2)))) + (if (type:subset? type* type:empty) + q-env:bottom + (merge (cdr env1) + (%q-env:delete env2 q1 h1) + (cons (cons q1 type*) accepted)))))) + (else (accept1)))))))) + (cond ((q-env:bottom? env1) env1) + ((q-env:bottom? env2) env2) + (else (merge env1 env2 '())))) + +(define (q-env:bind* env names quantities types) + ;; introduce new names into the environment + (if (q-env:bottom? env) + env + (q-env:glb env + (map (lambda (name quantity type) + quantity ; we dont know how to chain names yet + (cons (quantity:variable name) type)) + names + quantities + types)))) + +(define (typerew/pred form env receiver) + ;; receiver = (lambda (env_t env_f) ...) + (define (->expr) + (typerew/expr + form env + (lambda (quantity type env*) + (receiver (q-env:glb/1 env* quantity type:not-false) + (q-env:glb/1 env* quantity type:false))))) + (cond ((and (CALL/? form) + (QUOTE (call/operator form)) + (operator-predicate-test-type (quote/text (call/operator form)))) + => (lambda (test-types) + (typerew/expr + form env + (lambda (quantity type env*) + (let ((arg-quantity (quantity:operand1 quantity)) + (env*_t (q-env:glb/1 env* quantity type:not-false)) + (env*_f (q-env:glb/1 env* quantity type:false))) + (receiver + (q-env:glb/1 env*_t arg-quantity (car test-types)) + (q-env:glb/1 env*_f arg-quantity (cdr test-types)))))))) + ((IF/? form) + (typerew/pred + (if/predicate form) env + (lambda (env_t env_f) + (typerew/pred + (if/consequent form) env_t + (lambda (env_tt env_tf) + (typerew/pred + (if/alternate form) env_f + (lambda (env_ft env_ff) + (receiver (q-env:lub env_tt env_ft) + (q-env:lub env_ff env_tf))))))))) + (else (->expr)))) + + +(define (typerew/expr form env receiver) + ;; receiver = (lambda (quantity type env*) ...) + (if (not (pair? form)) + (illegal form)) + (case (car form) + ((QUOTE) (typerew/quote form env receiver)) + ((LOOKUP) (typerew/lookup form env receiver)) + ((LAMBDA) (typerew/lambda form env receiver)) + ((LET) (typerew/let form env receiver)) + ((DECLARE) (typerew/declare form env receiver)) + ((CALL) (typerew/call form env receiver)) + ((BEGIN) (typerew/begin form env receiver)) + ((IF) (typerew/if form env receiver)) + ((LETREC) (typerew/letrec form env receiver)) + (else + (illegal form)))) + +(define *typerew/operator-methods* (make-monotonic-strong-eq-hash-table)) + +(define (typerew/operator-method? op arity) + (let ((arity.method + (monotonic-strong-eq-hash-table/get *typerew/operator-methods* op #F))) + (and arity.method + (if (car arity.method) ; specific arity only + (and (= (car arity.method) arity) + (cdr arity.method)) + (cdr arity.method))))) ; #F => any arity + +(define (define-typerew-operator-method op arity method) + ;; ARITY = #F means method for any arity + (monotonic-strong-eq-hash-table/put! *typerew/operator-methods* op + (cons arity method))) + +;; Operator replacement strategies + +(define (typerew-operator-replacement new-op) + ;; Coerces operator to a replacement procedure + (if (procedure? new-op) + new-op + (lambda (form) + (form/rewrite! (call/operator form) `(QUOTE ,new-op))))) + +(define (typerew/unary-diamond-operator-replacement test good-op bad-op) + (lambda (form) + (form/rewrite! form + (let ((name (typerew/new-name 'X))) + (bind name (call/operand/1 form) + `(IF (CALL ',test '#F (LOOKUP ,name)) + (CALL ',good-op '#F (LOOKUP ,name)) + (CALL ',bad-op '#F (LOOKUP ,name)))))))) + +(define (typerew/general-operator-method result-type + asserted-types + effects-performed) + (lambda (quantities types env form receiver) + form ; No operator replacement + (let ((env* (q-env:restrict + (q-env:glb env + (map (lambda (q a-type type) + (cons q (type:and a-type type))) + quantities + asserted-types + types)) + effects-performed))) + (typerew/send receiver + (quantity:combination rator quantities) + result-type + env*)))) + +;; Example: substring? + +(define-typerew-operator-method 'SUBSTRING? 2 + (typerew/general-operator-method type:boolean + (list type:string type:string) + effect:none)) + +(let () + (define (def-unary-selector name op result-type asserted-type + type-check-class + safe-replacer! + unsafe-replacer!) + ;; No effects. + (define-typerew-operator-method op 1 + (lambda (quantities types env form receiver) + (let ((quantity (car quantities)) + (type (car types))) + (if (or (not (typerew/type-checks? type-check-class)) + (type:subset? type asserted-type)) + (safe-replacer! form) + (unsafe-replacer! form)) + (let ((env* (q-env:glb/1 env quantity (type:and type asserted-type)))) + (typerew/send receiver + (quantity:combination/1 rator quantity) + result-type + env*)))))) + + (def-unary-selector CAR type:any type:pair 'PAIR + (typerew-operator-replacement %car) + (typerew/unary-diamond-operator-replacement PAIR? %car CAR)) + + (def-unary-selector CDR type:any type:pair 'PAIR + (typerew-operator-replacement %cdr) + (typerew/unary-diamond-operator-replacement PAIR? %cdr CDR))) + + + +(define-typerew-operator-method 'EXPT 2 + (let ((type:fix:+1/-1 (type:or type:exact-one type:exact-minus-one)) + (type:flo:+1/-1 (type:or (type:of-object 1.0) (type:of-object -1.0)))) + (lambda (quantities types env form receiver) + + (let ((q-base (first quantities)) + (q-exponent (second quantities)) + (t-base (first types)) + (t-exponent (second types)) + (e-base (fifth form)) + (e-exponent (sixth form))) + + (define (result result-type) + (let ((env* + (q-env:glb/1 + (q-env:glb/1 env q-base (type:and t-base type:number)) + q-exponent (type:and t-exponent type:number)))) + (typerew/send receiver + (quantity:combination/2 rator q-base q-exponent) + result-type + env*))) + + (cond ((and (type:subset? t-exponent type:fixnum) + (or (equal? e-base '(QUOTE -1)) + (equal? e-base '(QUOTE -1.0)))) + (let ((negative-one (quote/text e-base))) + (form/rewrite! form + `(IF (CALL ',eq? '#F + (CALL ',fix:and '#F ,e-exponent '1) + '0) + ',(- negative-one) + ',negative-one)) + (if (fixnum? negative-one) + (result type:fix:+1/-1) + (result type:flo:+1/-1)))) + + ((and (type:subset? t-base type:exact-minus-one) + (type:subset? t-exponent type:exact-integer)) + (result type:+1/-1)) + + (else type:number)))))) + + + +#| +(define (typerew-binary-variants-method . spec) + ;; spec: repeated (input-type1 input-type2 output-type rewriter) + ;; followed by asserted-type1 asserted-type2 default-output-type + (lambda (quantities types env form receiver) + (let ((q1 (first quantities)) + (q2 (second quantities)) + (t1 (first types)) + (t2 (second types))) + + (define (result env result-type) + (typerew/send receiver + (quantity:combination/1 rator quantity) + result-type + env)) + + (let loop ((spec spec)) + (cond ((null? (cdddr spec)) + (result + (q-env:glb/1 (q-env:glb/1 env q1 (type:and t1 (first spec))) + q2 (type:and t2 (second spec))) + (third spec))) + ((and (type:subset? t1 (first spec)) + (type:subset? t2 (second spec))) + (if (fourth spec) ((fourth spec) form)) + (result env (third spec))) + (else (loop (cdddr spec)))))))) +|# + + +(define (typerew-binary-variants-method rator . spec) + ;; spec: repeated (input-type1 input-type2 output-type rewriter) + ;; followed by asserted-type1 asserted-type2 default-output-type + + (define (result receiver result-type q1 q2 env) + (typerew/send receiver + (quantity:combination/2 rator q1 a2) + result-type + env)) + + (define (compile-spec spec) + (let ((a1 (first spec)) (a2 (second spec)) (result-type (third spec))) + (if (null? (cdddr spec)) + (lambda (t1 t2 q1 q2 env form receiver) + (result receiver result-type q1 q2 + (q-env:glb/1 (q-env:glb/1 env q1 (type:and t1 a1)) + q2 (type:and t2 a2)))) + (let ((after-tests (compile-spec (cddddr spec))) + (rewrite! (fourth spec))) + (if rewrite! + (let ((rewrite! (typerew-operator-replacement rewrite!))) + (lambda (t1 t2 q1 q2 env form receiver) + (if (and (type:subset? t1 a1) (type:subset? t2 a2)) + (begin + (rewrite!) + (result receiver result-type q1 q2 env))))) + (after-tests t1 t2 q1 q2 env form receiver)))) + (lambda (t1 t2 q1 q2 env form receiver) + (if (and (type:subset? t1 a1) (type:subset? t2 a2)) + (result receiver result-type q1 q2 env) + (after-tests t1 t2 q1 q2 env form receiver)))))))) + + (let ((compiled-spec (compile-spec spec))) + (lambda (quantities types env form receiver) + (compiled-spec (first types) (second types) + (first quantities) (second quantities) + env form receiver)))) + +(define (typerew-unary-variants-method rator . spec) + ;; spec: repeated (input-type output-type rewriter) + ;; followed by asserted-type default-output-type + (lambda (quantities types env form receiver) + (let ((quantity (car quantities)) + (type (car types))) + + (define (result env result-type) + (typerew/send receiver + (quantity:combination/1 rator quantity) + result-type + env)) + + (let loop ((spec spec)) + (cond ((null? (cddr spec)) + (result + (q-env:glb/1 env quantity (type:and type (car spec))) + (cadr spec))) + ((type:subset? type (car spec)) + (if (caddr spec) ((caddr spec) form)) + (result env (cadr spec))) + (else (loop (cdddr spec)))))))) + +(define (define-typerew-unary-variants-method name . spec) + (define-typerew-operator-method name 1 + (apply typerew-unary-variants-method name spec))) + +(define (define-typerew-binary-variants-method name . spec) + (define-typerew-operator-method name 2 + (apply typerew-binary-variants-method name spec))) + +(define-typerew-unary-variants-method 'EXACT->INEXACT + type:real type:inexact-real #F + type:recnum type:inexact-recnum #F + type:number type:number) + +(define-typerew-unary-variants-method 'COS + type:exact-zero type:exact-one #F + type:real type:flonum #F + type:number type:number) + +(define-typerew-unary-variants-method 'SIN + type:exact-zero type:exact-zero #F + type:real type:flonum #F + type:number type:number) + +(define-typerew-unary-variants-method 'TAN + type:exact-zero type:exact-zero #F + type:real type:flonum #F + type:number type:number) + +(define-typerew-unary-variants-method 'ACOS + type:exact-one type:exact-zero #F + type:number type:inexact-number) + +(define-typerew-unary-variants-method 'ASIN + type:exact-zero type:exact-zero #F + type:number type:inexact-number) + +(define-typerew-unary-variants-method 'EXP + type:recnum type:inexact-recnum #F + type:exact-zero type:exact-one #F + type:real type:inexact-real #F + type:number type:inexact-number) + +(define-typerew-unary-variants-method 'LOG + type:exact-one type:exact-zero #F + type:number type:inexact-number) + + +(define-typerew-binary-variants-method (make-primitive-procedure '&+) + type:unsigned-byte type:unsigned-byte type:small-fixnum>=0 fix:+ + type:small-fixnum>=0 type:small-fixnum>=0 type:fixnum>=0 fix:+ + type:small-fixnum type:small-fixnum type:fixnum fix:+ + type:flonum type:flonum type:flonum flo:+ + type:exact-integer type:exact-integer type:exact-integer #F + type:exact-number type:exact-number type:exact-number #F + type:inexact-number type:number type:inexact-number %+ + type:number type:inexact-number type:inexact-number %+ + type:number type:number type:number) + +(define-typerew-binary-variants-method (make-primitive-procedure '&-) + type:small-fixnum type:small-fixnum type:fixnum fix:- + type:flonum type:flonum type:flonum flo:- + type:exact-integer type:exact-integer type:exact-integer #F + type:exact-number type:exact-number type:exact-number #F + type:inexact-number type:number type:inexact-number %- + type:number type:inexact-number type:inexact-number %- + type:number type:number type:number) + +(let ((type:inexact+0 (type:or type:inexact-number type:exact-zero))) + (define-typerew-binary-variants-method (make-primitive-procedure '&*) + type:unsigned-byte type:unsigned-byte type:small-fixnum>=0 fix:* + type:flonum type:flonum type:flonum flo:* + type:exact-integer type:exact-integer type:exact-integer #F + type:exact-number type:exact-number type:exact-number #F + ;; Note that (* 0) = 0 + type:inexact-number type:inexact-number type:inexact-number %* + type:inexact-number type:number type:inexact+0 %* + type:number type:inexact-number type:inexact+0 %* + type:number type:number type:number)) + +(define-typerew-binary-variants-method (make-primitive-procedure '&/) + type:flonum type:flonum type:flonum flo:/ + type:inexact-number type:number type:inexact-number #F + type:number type:inexact-number type:inexact-number #F + type:number type:number type:number) + +(let* ((type:fixnum-not-0 (type:except type:fixnum type:exact-zero)) + (type:fixnum-not-0/-1 + (type:except type:fixnum-not-0 type:exact-minus-one))) + (define-typerew-binary-variants-method (make-primitive-procedure 'QUOTIENT) + ;; quotient on fixnums can overflow only when dividing by 0 or -1. When + ;; dividing by -1 it can only overflow when the value is the most + ;; negative fixnum (-2^(word-size-1)). The quotient has the same + ;; sign as the product. + type:unsigned-byte type:fixnum+ve type:unsigned-byte fix:quotient + type:small-fixnum type:fixnum-not-0/-1 type:small-fixnum fix:quotient + type:small-fixnum type:fixnum-not-0 type:fixnum fix:quotient + type:fixnum type:fixnum-not-0/-1 type:fixnum fix:quotient + type:flonum type:flonum type:flonum %quotient + type:exact-integer type:exact-integer type:exact-integer %quotient + ;; The only inexact integer representation is flonum + type:inexact-number type:number type:flonum %quotient + type:number type:inexact-number type:flonum %quotient + type:number type:number type:number) + + (define-typerew-binary-variants-method (make-primitive-procedure 'REMAINDER) + ;; quotient on fixnums can overflow only when dividing by 0 or -1. When + ;; dividing by -1 it can only overflow when the value is the most + ;; negative fixnum (-2^(word-size-1)). The remainder has the same + ;; sign as the dividend. + type:unsigned-byte type:fixnum-not-0 type:unsigned-byte fix:remainder + type:small-fixnum>=0 type:fixnum-not-0 type:small-fixnum>=0 fix:remainder + type:fixnum>=0 type:fixnum-not-0 type:fixnum>=0 fix:remainder + type:small-fixnum type:fixnum-not-0 type:small-fixnum fix:remainder + type:fixnum type:fixnum-not-0 type:fixnum fix:remainder + type:flonum type:flonum type:flonum %remainder + type:exact-integer type:exact-integer type:exact-integer %remainder + ;; The only inexact integer representation is flonum + type:inexact-number type:number type:flonum %remainder + type:number type:inexact-number type:flonum %remainder + type:number type:number type:number) + + ;; MODULO is not integrated. + ) + +(let () + (define (define-relational-method name fix:op flo:op out:op) + (define-typerew-binary-variants-method (make-primitive-procedure name) + type:fixnum type:fixnum type:boolean fix:op + type:flonum type:flonum type:boolean flo:op + type:exact-number type:exact-number type:boolean #F + type:inexact-number type:number type:boolean out:op + type:number type:inexact-number type:boolean out:op + type:number type:number type:boolean)) + + (define-relational-method '&< fix:< flo:< %<) + (define-relational-method '&= fix:= flo:= %=) + (define-relational-method '&> fix:> flo:> %>)) + + +(define-typerew-binary-variants-method (make-primitive-procedure 'VECTOR-REF) + ???? type & range checks + type:vector type:vector-length type:any %vector-ref/check-range + type:vector type:vector-length type:any) \ No newline at end of file diff --git a/v8/src/compiler/midend/types.scm b/v8/src/compiler/midend/types.scm new file mode 100644 index 000000000..3476e6a95 --- /dev/null +++ b/v8/src/compiler/midend/types.scm @@ -0,0 +1,658 @@ +#| -*-Scheme-*- + +$Id: types.scm,v 1.1 1995/09/01 18:53:32 adams Exp $ + +Copyright (c) 1995-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. |# + +;;;; Types +;;; package: (compiler midend) + +(declare (usual-integrations)) + +;; Types denote a set of values. + +(define-structure + (type + (named (string->symbol "#[liar:type]")) + (type vector) + (conc-name type/) + (constructor type:%make ()) + (constructor type:%make/bits (bits-0 bits-1 bits-2)) + (print-procedure + (standard-unparser-method 'TYPE + (lambda (type port) + (write-char #\space port) + (write (type:description type) port))))) + + (bits-0 0) + (bits-1 0) + (bits-2 0)) + +;; Primitive types. Primitive types are disjoint. Any particular value +;; may belong to only one primitive type. + +(define-integrable type:*max-number-of-primitive-types* 48) + +(define type:primitive-types + (make-vector type:*max-number-of-primitive-types* #F)) +(define type:number-of-primitive-types 0) +(define type:primitive-type-characteristic-predicates + (make-vector type:*max-number-of-primitive-types* #F)) +(define type:*names* '()) + +(define (define-type-name type name) + (set! type:*names* (cons (cons type name) type:*names*))) + +(define (type:description type) + (let loop ((type type) (pairs type:*names*) (description '())) + (cond ((null? pairs) + (cond ((null? description) 'type:empty) + ((null? (cdr description)) (car description)) + (else (cons 'or (reverse description))))) + ((type:subset? (caar pairs) type) + (loop (type:except type (caar pairs)) (cdr pairs) + (cons (cdar pairs) description))) + (else + (loop type (cdr pairs) description))))) + +(define type:empty (type:%make)) + +(define (make-primitive-type) + (let ((bit type:number-of-primitive-types)) + (if (>= bit type:*max-number-of-primitive-types*) + (internal-error "Not enough type bits")) + (let ((type (type:%make))) + (vector-set! type (fix:+ 1 (fix:lsh bit -4)) + (fix:lsh 1 (fix:and bit #xF))) + (vector-set! type:primitive-types bit type) + (set! type:number-of-primitive-types (+ bit 1)) + type))) + + +(define-integrable (type:bitwise op receiver) + (lambda (t1 t2) + (receiver (op (type/bits-0 t1) (type/bits-0 t2)) + (op (type/bits-1 t1) (type/bits-1 t2)) + (op (type/bits-2 t1) (type/bits-2 t2))))) + +(define type:or (type:bitwise fix:or type:%make/bits)) +(define type:and (type:bitwise fix:and type:%make/bits)) +(define type:except (type:bitwise fix:andc type:%make/bits)) + +(define (type:not t) (type:except type:any t)) + +(define type:subset? + (type:bitwise (lambda (b1 b2) (fix:= (fix:or b1 b2) b2)) + (lambda (r1 r2 r3) + (and r1 r2 r3)))) + +(define type:disjoint? + (type:bitwise (lambda (b1 b2) (fix:zero? (fix:and b1 b2))) + (lambda (r1 r2 r3) + (and r1 r2 r3)))) + +(define (type:or* . types) + (reduce type:or type:empty types)) + +(define (type:for-each-primitive-type type procedure) + (define (try-bits offset bits) + (let loop ((bits bits) (offset offset)) + (cond ((fix:= 0 bits)) + ((fix:= 0 (fix:and bits 1)) + (loop (fix:lsh bits -1) (fix:+ offset 1))) + (else + (procedure (vector-ref type:primitive-types offset)) + (loop (fix:lsh bits -1) (fix:+ offset 1)))))) + (try-bits 0 (type/bits-0 type)) + (try-bits 16 (type/bits-1 type)) + (try-bits 32 (type/bits-2 type))) + + +(let-syntax ((primitive-types + (macro names + (define (def name) + `(BEGIN + (DEFINE ,name (MAKE-PRIMITIVE-TYPE)) + (DEFINE-TYPE-NAME ,name ',name))) + `(BEGIN + ,@(map def names))))) + + (primitive-types type:exact-zero ; special numbers + type:exact-one + type:exact-minus-one + type:small-fixnum:2..255 + type:small-fixnum>255; numbers which will not overflow + type:small-fixnum<-1 ; when added or subtracted + type:big-fixnum+ve ; other fixnums + type:big-fixnum-ve ; other fixnums + type:bignum<0 + type:bignum>0 + type:ratnum + type:flonum + type:exact-recnum + type:inexact-recnum + + type:interned-symbol + type:uninterned-symbol + type:pair + type:vector + type:%record + type:string + type:character + type:cell + type:bit-string + + type:true ; special values + type:false + type:empty-list + type:unspecific + type:other-constant + + type:primitive-procedure + type:compiled-procedure + type:other-compiled-entry + + type:entity + type:compiled-code-block + + type:other ; anything else + )) + +;; For more readable reporting +(set! type:*names* (reverse type:*names*)) + +(define type:any + (let loop ((i 0) (type type:empty)) + (if (= i type:number-of-primitive-types) + type + (loop (+ i 1) (type:or type (vector-ref type:primitive-types i)))))) + +(define type:not-false (type:except type:any type:false)) + +(let-syntax ((alias + (macro (name . parts) + `(BEGIN + (DEFINE ,name (TYPE:OR* ,@parts))))) + (alias* + (macro (name . parts) + `(BEGIN + (DEFINE ,name (TYPE:OR* ,@parts)) + (DEFINE-TYPE-NAME ,name ',name))))) + + (alias type:small-fixnum>1 type:small-fixnum:2..255 type:small-fixnum>255) + (alias type:unsigned-byte + type:exact-zero type:exact-one type:small-fixnum>1) + (alias type:small-fixnum+ve type:exact-one type:small-fixnum>1) + (alias type:small-fixnum-ve type:exact-minus-one type:small-fixnum<-1) + (alias type:small-fixnum + type:exact-zero type:small-fixnum-ve type:small-fixnum+ve) + + (alias type:big-fixnum type:big-fixnum-ve type:big-fixnum+ve) + + (alias type:small-fixnum>=0 type:exact-zero type:small-fixnum+ve) + (alias* type:fixnum>=0 type:small-fixnum>=0 type:big-fixnum+ve) + + (alias type:fixnum+ve type:small-fixnum+ve type:big-fixnum+ve) + (alias type:fixnum-ve type:small-fixnum-ve type:big-fixnum-ve) + + (alias* type:fixnum type:small-fixnum type:big-fixnum) + (alias* type:bignum type:bignum<0 type:bignum>0) + (alias* type:exact-non-negative-integer type:bignum>0 type:fixnum>=0) + (alias* type:exact-integer type:fixnum type:bignum) + (alias type:exact-real type:fixnum type:bignum type:ratnum) + (alias type:inexact-real type:flonum) + (alias type:real type:exact-real type:inexact-real) + (alias type:recnum type:exact-recnum type:inexact-recnum) + (alias* type:exact-number type:exact-recnum type:exact-real) + (alias* type:inexact-number type:inexact-recnum type:inexact-real) + (alias* type:number type:exact-number type:inexact-number) + + (alias* type:symbol type:interned-symbol type:uninterned-symbol) + (alias type:boolean type:true type:false) + (alias type:vector-length type:small-fixnum>=0) + (alias type:string-length type:fixnum>=0) + + (alias type:list type:empty-list type:pair) + + (alias type:tc-constant type:true type:false type:empty-list type:unspecific + type:other-constant) + + (alias* type:compiled-entry + type:compiled-procedure type:other-compiled-entry) + + (alias type:procedure + type:compiled-procedure type:entity type:primitive-procedure) + ) + +;; Note: these are processed in last-to-first order to construct a description. + +(define-type-name type:boolean 'BOOLEAN) +(define-type-name (type:except type:fixnum type:fixnum>=0) 'NEGATIVE-FIXNUM) +(define-type-name type:fixnum 'FIXNUM?) +(define-type-name type:exact-integer 'EXACT-INTEGER) +(define-type-name type:exact-number 'EXACT-NUMBER) +(define-type-name type:inexact-number 'INEXACT-NUMBER) +(define-type-name type:number 'NUMBER) + +(define-type-name type:any 'type:ANY) + + +;;;; Correspondence between tyepcodes and primitive types +;; + +;; The tag is `covered' by this type. +(define type:tag->covering-type (make-vector 64 #F)) + +(define (type:typecode->type typecode) + (vector-ref type:tag->covering-type typecode)) + +;; This primitive type is `covered' by these tags. +(define type:primitive-type->covering-tags + (make-vector type:number-of-primitive-types '())) + +(let () + (define (define-tag tag-name type) + (let ((tag (machine-tag tag-name))) + (if (vector-ref type:tag->covering-type tag) + (internal-error "TYPECODE <-> type: configuarion error")) + (vector-set! type:tag->covering-type tag type))) + + (define-tag 'POSITIVE-FIXNUM type:fixnum>=0) + (define-tag 'NEGATIVE-FIXNUM (type:except type:fixnum type:fixnum>=0)) + (define-tag 'BIGNUM type:bignum) + (define-tag 'RATNUM type:ratnum) + (define-tag 'RECNUM type:recnum) + (define-tag 'FLONUM type:flonum) + (define-tag 'PAIR type:pair) + (define-tag 'VECTOR type:vector) + (define-tag 'RECORD type:%record) + (define-tag 'VECTOR-1B type:bit-string) + (define-tag 'VECTOR-8B type:string) + (define-tag 'CONSTANT type:tc-constant) + (define-tag 'PRIMITIVE type:primitive-procedure) + (define-tag 'ENTITY type:entity) + (define-tag 'COMPILED-ENTRY type:compiled-entry) + (define-tag 'CELL type:cell) + (define-tag 'COMPILED-CODE-BLOCK type:compiled-code-block) + (define-tag 'UNINTERNED-SYMBOL type:uninterned-symbol) + (define-tag 'INTERNED-SYMBOL type:interned-symbol) + (define-tag 'CHARACTER type:character) + + (let ((unallocated-types + (do ((i 0 (+ i 1)) + (t type:empty + (type:or t (or (vector-ref type:tag->covering-type i) type:empty)))) + ((= i 64) (type:not t))))) + (type:for-each-primitive-type + (type:except unallocated-types type:other) + (lambda (t) + (internal-warning "Type has not been allocated to typecode(s)" t))) + + (do ((i 0 (+ i 1))) + ((= i 64)) + (if (not (vector-ref type:tag->covering-type i)) + (vector-set! type:tag->covering-type i unallocated-types))))) + +(define type:of-object + (let* ((max-fixnum (object-new-type 0 -1)) + (max-small-fixnum (quotient max-fixnum 2)) + (min-small-fixnum (- -1 max-small-fixnum))) + (lambda (x) + ;; This should do lots of magic with typecodes + (cond ((fixnum? x) + (cond ((eqv? x 0) type:exact-zero) + ((eqv? x 1) type:exact-one) + ((eqv? x -1) type:exact-minus-one) + ((<= 2 x 255) type:small-fixnum:2..255) + ((<= 256 x max-small-fixnum) type:small-fixnum>255) + ((> x max-small-fixnum) type:big-fixnum+ve) + ((<= min-small-fixnum x -2) type:small-fixnum<-1) + ((< x min-small-fixnum) type:big-fixnum-ve) + (else (internal-error "Unclassified FIXNUM" x)))) + ((object-type? (object-type #F) x) + (cond ((eq? x #F) type:false) + ((eq? x #T) type:true) + ((eq? x unspecific) type:unspecific) + ((eq? x '()) type:empty-list) + (else type:other-constant))) + (else + ;; The returned value might not be unitary. + (type:typecode->type (object-type x))))))) + +;;(define (type:->covering-tags type) +;; "Return a list of tags that cover TYPE") +;; +;;(define (type:->predicate-tags type) +;; "Return a list of tags that exactly match TYPE, or return #F") + +;; Known simple predicates +;; +;; *OPERATOR-PREDICATE-TEST-TYPES* holds pairs of types. The CAR is the +;; potentially positive cases, CDR for potentially negative cases. +;; They may overlap and *must* union to all types. + +(define *operator-predicate-test-types* (make-monotonic-strong-eq-hash-table)) + +(define (operator-predicate-test-type op) + (monotonic-strong-eq-hash-table/get *operator-predicate-test-types* op #F)) + +(let () + (define (define-predicate-test-types op type1 #!optional type2) + (monotonic-strong-eq-hash-table/put! + *operator-predicate-test-types* op + (cons type1 + (if (default-object? type2) + (type:not type1) + type2)))) + + (define (def-prim name . types) + (apply define-predicate-test-types (make-primitive-procedure name) types)) + + (def-prim 'BIT-STRING? type:bit-string) + (def-prim 'CELL? type:cell) + (def-prim 'FIXNUM? type:fixnum) + (def-prim 'FLONUM? type:flonum) + (def-prim 'INDEX-FIXNUM? type:fixnum>=0) + (def-prim 'NOT type:false) + (def-prim 'NULL? type:empty-list) + (def-prim 'PAIR? type:pair) + (def-prim 'STRING? type:string) + (def-prim 'INTEGER? type:exact-integer) + (define-predicate-test-types %compiled-entry? type:compiled-entry) + ) + + + +;;______________________________________________________________________ +;; +;; +#| +(define-structure + (procedure-type + (conc-name procedure-type/)) + argument-types ; can be called on these types + argument-assertions ; returning guarantees these types + result-type + effects-performed + effects-observed + (implementation-type)) + +;; Note[1] The RESULT-TYPE should be TYPE:ANY for an operator without a +;; specified return value. TYPE:NONE means that there is no value +;; (divergence) and TYPE:UNSPECIFIC means exactly the `unspecific' +;; object. + +(define (procedure-type/new-argument-types base new) + (make-procedure-type new + (procedure-type/argument-assertions base) + (procedure-type/result-type base) + (procedure-type/effects-performed base) + (procedure-type/effects-observed base) + (procedure-type/implementation-type base))) + +(define (procedure-type/new-argument-assertions base new) + (make-procedure-type (procedure-type/argument-types base) + new + (procedure-type/result-type base) + (procedure-type/effects-performed base) + (procedure-type/effects-observed base) + (procedure-type/implementation-type base))) + +(define (procedure-type/new-result-type base new) + (make-procedure-type (procedure-type/argument-types base) + (procedure-type/argument-assertions base) + new + (procedure-type/effects-performed base) + (procedure-type/effects-observed base) + (procedure-type/implementation-type base))) + +(define (procedure-type/new-effects-performed base new) + (make-procedure-type (procedure-type/argument-types base) + (procedure-type/argument-assertions base) + (procedure-type/result-type base) + new + (procedure-type/effects-observed base) + (procedure-type/implementation-type base))) + +(define (procedure-type/new-effects-observed base new) + (make-procedure-type (procedure-type/argument-types base) + (procedure-type/argument-assertions base) + (procedure-type/result-type base) + (procedure-type/effects-performed base) + new + (procedure-type/implementation-type base))) + +(define (procedure-type/new-implementation-type base new) + (make-procedure-type (procedure-type/argument-types base) + (procedure-type/argument-assertions base) + (procedure-type/result-type base) + (procedure-type/effects-performed base) + (procedure-type/effects-observed base) + new)) + + +(define (make-primitive-procedure-type result-type . argument-types) + (make-procedure-type result-type argument-types type:primitive-procedure)) + + +(define *operator-types* (make-monotonic-strong-eq-hash-table)) +(define *operator-variants* (make-monotonic-strong-eq-hash-table)) + + +(define (operator-variants op) + (monotonic-strong-eq-hash-table/get *operator-variants* op '())) + +(define (operator-type op) + (monotonic-strong-eq-hash-table/get *operator-types* op #F)) + +(define (operator-sensitive-effects op) + (cond ((operator-type op) + => procedure-type/effects-observed) + (else effect:unknown))) + + +(let () + ;; The basic type from which most variants are derived is the + ;; non-restartable primitive type whcih checks its arguments. + (define (type eff1 eff2 result-type . argument-types) + (make-procedure-type (make-list (length argument-types) type:any) + argument-types + result-type + eff1 eff2 + type:primitive-procedure)) + + (define -> '->) + (define (signature . sig) + (let* ((t* (reverse sig)) + (result-type (car t*)) + (argument-types (reverse (cddr t*)))) + (if (not (eq? (cadr t*) ->)) + (internal-error "Illegal signature" sig)) + (make-procedure-type (make-list (length argument-types) type:any) + argument-types + result-type + effect:unknown effect:unknown + type:primitive-procedure))) + + (define (def operator type) + (monotonic-strong-eq-hash-table/put! *operator-types* operator type)) + + (define (prim . spec) (apply make-primitive-procedure spec)) + + (define (restartable base) + (procedure-type/new-argument-assertions + base + (procedure-type/argument-types base))) + + (define ((sub-range result-type) base) + (procedure-type/new-result-type base result-type)) + + (define ((sub-domain . argument-types) base) + (procedure-type/new-argument-types base argument-types)) + + (define (unchecked base) + ;; unchecked version: enforces nothing but only works on enforced + ;; sub-domain of base + (let ((assertions (procedure-type/argument-assertions base))) + (procedure-type/new-argument-types + (procedure-type/new-argument-assertions + base + (make-list (length assertions) type:any)) + assertions))) + + (define (inlined base) + (procedure-type/new-implementation-type base type:empty)) + + (define ((effects do! see) base) + (procedure-type/new-effects-observed + (procedure-type/new-effects-performed base do!) see)) + + (define ((sensitive . effects) base) + (procedure-type/new-effects-observed base (apply effect:union* effects))) + + (define (effect-free base) + (procedure-type/new-effects-performed base effect:none)) + + (define (variant base . modifiers) + (let loop ((m modifiers) (base base)) + (if (null? m) + base + (loop (cdr m) ((car m) base))))) + + (define (def-variant var-op base-op . modifiers) + (let ((base + (monotonic-strong-eq-hash-table/get *operator-types* base-op #F))) + (if (not base) + (internal-error "Base op does not have defined type" base-op)) + + (def var-op (apply variant base modifiers)) + (monotonic-strong-eq-hash-table/put! *operator-variants* base-op + (append (operator-variants base-op) + (list var-op))))) + + (define (def-global name base) + (def name (procedure-type/new-implementation-type base type:procedure))) + + (define effect-insensitive (sensitive effect:none)) + (define function (effects effect:none effect:none)) + (define allocates (effects effect:allocation effect:none)) + + (define binary-generic-arithmetic + (variant (signature type:number type:number -> type:number) + effect-insensitive + allocates)) + + (define simple-predicate + (variant (signature type:any -> type:boolean) + effect-insensitive + effect-free)) + + (define binary-generic-predicate + (variant (signature type:number type:number -> type:boolean) + effect-insensitive + effect-free)) + + (def (prim 'CONS) + (variant (signature type:any type:any -> type:pair) + effect-insensitive + allocates)) + + (def (prim 'CAR) + (variant (signature type:pair -> type:any) + effect-free + (sensitive effect:set-car!))) + (def-variant %car (prim 'CAR) inlined unchecked) + (def-variant "#CAR" (prim 'CAR) restartable) + + (def (prim 'CDR) + (variant (signature type:pair -> type:any) + effect-free + (sensitive effect:set-cdr!))) + (def-variant %cdr (prim 'CDR) inlined unchecked) + (def-variant "#CDR" (prim 'CDR) restartable) + + (def (prim 'SET-CAR!) + (variant (signature type:pair type:any -> type:any) + (effects effect:set-car! effect:none))) + (def-variant %set-car! (prim 'SET-CAR!) inlined unchecked) + (def-variant "#SET-CAR!" (prim 'SET-CAR!) restartable) + + (def (prim 'SET-CDR!) + (variant (signature type:pair type:any -> type:any) + (effects effect:set-cdr! effect:none))) + (def-variant %set-cdr! (prim 'SET-CDR!) inlined unchecked) + (def-variant "#SET-CDR!" (prim 'SET-CDR!) restartable) + + + (define (add-like gen:op fix:op flo:op out-of-line:op) + (def gen:op binary-generic-arithmetic) + (def-variant fix:op gen:op + inlined unchecked function + (sub-domain type:small-fixnum type:small-fixnum) + (sub-range type:fixnum)) + (def-variant flo:op gen:op + inlined unchecked allocates + (sub-domain type:flonum type:flonum) + (sub-range type:flonum)) + (def-variant out-of-line:op gen:op inlined)) + + (add-like (prim '&+) fix:+ flo:+ %+) + (add-like (prim '&-) fix:- flo:- "#-") + + (define (arith-pred gen:op fix:op flo:op out-of-line:op) + (def gen:op binary-generic-predicate) + (def-variant fix:op gen:op + inlined unchecked (sub-domain type:fixnum type:fixnum)) + (def-variant flo:op gen:op + inlined unchecked (sub-domain type:flonum type:flonum)) + (def-variant out-of-line:op gen:op inlined)) + + (arith-pred (prim '&<) fix:< flo:< "#<") + (arith-pred (prim '&=) fix:= flo:= "#=") + (arith-pred (prim '&>) fix:> flo:> "#>") + + (def fixnum? simple-predicate) + (def pair? simple-predicate) + + (def (prim 'VECTOR-LENGTH) + (variant (signature type:vector -> type:vector-length) + function)) + (def-variant %vector-length (prim 'VECTOR-LENGTH) inlined unchecked) + + (def-global 'SUBSTRING? + (variant (signature type:string type:string -> type:boolean) + function)) + + (def-global 'ERROR:WRONG-TYPE-ARGUMENT + (variant (signature type:any type:any -> type:empty) + function)) + unspecific) +|# \ No newline at end of file