--- /dev/null
+#| -*-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))
+\f
+(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*))))
+|#
+\f
+(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*)))))))))
+\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))))))))
+\f
+(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)))
+\f
+;; Quantities
+;;
+;; Quantities are represented as vectors:
+;; #(<hash> <effects> <variable>)
+;; #(<hash> <effects> <quoted-form>)
+;; #(<hash> <effects> <operator> . <operand-quantities>)
+;; <effects> 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))))
+\f
+(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)))
+\f
+;; 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))))))))
+\f
+(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))))
+\f
+(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 (* <inexact> 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
--- /dev/null
+#| -*-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))
+\f
+;; 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)
+
+\f
+;;;; 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")
+\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)
+ )
+
+
+\f
+;;______________________________________________________________________
+;;
+;;
+#|
+(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
projects / mit-scheme.git / commitdiff