ikarus/scheme/ikarus.compiler.tag-annotat...

438 lines
15 KiB
Scheme
Raw Normal View History

;;; Ikarus Scheme -- A compiler for R6RS Scheme.
;;; Copyright (C) 2006,2007,2008 Abdulaziz Ghuloum
;;;
;;; This program is free software: you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License version 3 as
;;; published by the Free Software Foundation.
;;;
;;; This program is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;; General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program. If not, see <http://www.gnu.org/licenses/>.
;;; THIS IS WIP
(include "ikarus.ontology.ss")
(define tag-analysis-output (make-parameter #f))
(define (introduce-tags x)
(define who 'introduce-tags)
#;
(define primitive-return-types
'(
[= boolean]
[< boolean]
[<= boolean]
[> boolean]
[>= boolean]
[even? boolean]
[odd? boolean]
[rational? boolean]
[rational-valued? boolean]
[real? boolean]
[real-valued? boolean]
[bignum? boolean]
[ratnum? boolean]
[flonum? boolean]
[fixnum? boolean]
[integer? boolean]
[exact? boolean]
[finite? boolean]
[inexact? boolean]
[infinite? boolean]
[positive? boolean]
[negative? boolean]
[nan? boolean]
[number? boolean]
[compnum? boolean]
[cflonum? boolean]
[complex? boolean]
[list? boolean]
[eq? boolean]
[eqv? boolean]
[equal? boolean]
[gensym? boolean]
[symbol-bound? boolean]
[code? boolean]
[immediate? boolean]
[pair? boolean]
[procedure? boolean]
[symbol? boolean]
[symbol=? boolean]
[boolean? boolean]
[boolean=? boolean]
[vector? boolean]
[bitwise-bit-set? boolean]
[bytevector? boolean]
[bytevector=? boolean]
[enum-set=? boolean]
[binary-port? boolean]
[textual-port? boolean]
[input-port? boolean]
[output-port? boolean]
[port? boolean]
[port-eof? boolean]
[port-closed? boolean]
[char-ready? boolean]
[eof-object? boolean]
[hashtable? boolean]
[hashtable-mutable? boolean]
[file-exists? boolean]
[file-regular? boolean]
[file-directory? boolean]
[file-symbolic-link? boolean]
[record? boolean]
[record-field-mutable? boolean]
[record-type-generative? boolean]
[record-type-sealed? boolean]
[record-type-descriptor boolean]
[free-identifier=? boolean]
[bound-identifier=? boolean]
[identifier? boolean]
[char-lower-case? boolean]
[char-upper-case? boolean]
[char-title-case? boolean]
[char-whitespace? boolean]
[char-numeric? boolean]
[char-alphabetic? boolean]
))
(define number!
(let ([i 0])
(lambda (x)
(set-prelex-operand! x i)
(set! i (+ i 1)))))
(define (V* x* env)
(cond
[(null? x*) (values '() env '())]
[else
(let-values ([(x env1 t) (V (car x*) env)]
[(x* env2 t*) (V* (cdr x*) env)])
(values (cons x x*)
(and-envs env1 env2)
(cons t t*)))]))
(define (constant-type x)
(define (numeric x)
(define (size x t)
(T:and t
(cond
[(< x 0) T:negative]
[(> x 0) T:positive]
[(= x 0) T:zero]
[else t])))
(cond
[(fixnum? x) (size x T:fixnum)]
[(flonum? x) (size x T:flonum)]
[(or (bignum? x) (ratnum? x))
(size x (T:and T:exact T:other-number))]
[else T:number]))
(cond
[(number? x) (numeric x)]
[(boolean? x) (if x T:true T:false)]
[(null? x) T:null]
[(char? x) T:char]
[(string? x) T:string]
[(vector? x) T:vector]
[(pair? x) T:pair]
[(eq? x (void)) T:void]
[else T:object]))
(define (V x env)
(struct-case x
[(constant k) (values x env (constant-type k))]
[(prelex) (values x env (lookup x env))]
[(primref op) (values x env T:procedure)]
[(seq e0 e1)
(let-values ([(e0 env t) (V e0 env)])
(cond
[(eq? (T:object? t) 'no)
(values e0 env t)]
[else
(let-values ([(e1 env t) (V e1 env)])
(values (make-seq e0 e1) env t))]))]
[(conditional e0 e1 e2)
(let-values ([(e0 env t) (V e0 env)])
(cond
[(eq? (T:object? t) 'no)
(values e0 env t)]
[(eq? (T:false? t) 'yes)
(let-values ([(e2 env t) (V e2 env)])
(values (make-seq e0 e2) env t))]
[(eq? (T:false? t) 'no)
(let-values ([(e1 env t) (V e1 env)])
(values (make-seq e0 e1) env t))]
[else
(let-values ([(e1 env1 t1) (V e1 env)]
[(e2 env2 t2) (V e2 env)])
(values (make-conditional e0 e1 e2)
(or-envs env1 env2)
(T:or t1 t2)))]))]
[(bind lhs* rhs* body)
(let-values ([(rhs* env t*) (V* rhs* env)])
(for-each number! lhs*)
(let ([env (extend-env* lhs* t* env)])
(let-values ([(body env t) (V body env)])
(values
(make-bind lhs* rhs* body)
env t))))]
[(fix lhs* rhs* body)
(for-each number! lhs*)
(let-values ([(rhs* env t*) (V* rhs* env)])
(let ([env (extend-env* lhs* t* env)])
(let-values ([(body env t) (V body env)])
(values
(make-fix lhs* rhs* body)
env t))))]
[(clambda g cls* cp free name)
(values
(make-clambda g
(map
(lambda (x)
(struct-case x
[(clambda-case info body)
(for-each number! (case-info-args info))
(let-values ([(body env t) (V body env)])
;;; dropped env and t
(make-clambda-case info body))]))
cls*)
cp free name)
env
T:procedure)]
[(funcall rator rand*)
(let-values ([(rator rator-env rator-val) (V rator env)]
[(rand* rand*-env rand*-val) (V* rand* env)])
(apply-funcall rator rand*
rator-val rand*-val
rator-env rand*-env))]
[(forcall rator rand*)
(let-values ([(rand* rand*-env rand*-val) (V* rand* env)])
(values (make-forcall rator rand*)
rand*-env
T:object))]
[else (error who "invalid expression" (unparse x))]))
(define (annotate x t)
(cond
[(T=? t T:object) x]
[else (make-known x t)]))
(define (apply-funcall rator rand* rator-val rand*-val rator-env rand*-env)
(let ([env (and-envs rator-env rand*-env)]
[rand* (map annotate rand* rand*-val)])
(struct-case rator
[(primref op)
(apply-primcall op rand* env)]
[else
(values (make-funcall (annotate rator rator-val) rand*)
env
T:object)])))
(define (apply-primcall op rand* env)
(define (return t)
(values (make-funcall (make-primref op) rand*) env t))
(define (inject ret-t . rand-t*)
(define (extend* x* t* env)
(define (extend x t env)
(struct-case x
[(known expr t0)
(extend expr (T:and t t0) env)]
[(prelex)
(extend-env x t env)]
[else env]))
(cond
[(null? x*) env]
[else (extend (car x*) (car t*)
(extend* (cdr x*) (cdr t*) env))]))
(cond
[(= (length rand-t*) (length rand*))
(values (make-funcall (make-primref op) rand*)
(extend* rand* rand-t* env)
ret-t)]
[else
(error 'apply-primcall "invalid extesion" op rand*)]))
(define (inject* ret-t arg-t)
(define (extend* x* env)
(define (extend x t env)
(struct-case x
[(known expr t0)
(extend expr (T:and t t0) env)]
[(prelex)
(extend-env x t env)]
[else env]))
(cond
[(null? x*) env]
[else (extend (car x*) arg-t
(extend* (cdr x*) env))]))
(values (make-funcall (make-primref op) rand*)
(extend* rand* env)
ret-t))
(case op
[(cons)
(return T:pair)]
[(car cdr
caar cadr cdar cddr
caaar caadr cadar caddr cdaar cdadr cddar cdddr
caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr)
(inject T:object T:pair)]
[(set-car! set-cdr!)
(inject T:void T:pair T:object)]
[(vector make-vector list->vector)
(return T:vector)]
[(string make-string list->string)
(return T:string)]
[(string-length)
(inject T:fixnum T:string)]
[(vector-length)
(inject T:fixnum T:vector)]
[(string-ref)
(inject T:char T:string T:fixnum)]
[(string-set!)
(inject T:void T:string T:fixnum T:char)]
[(vector-ref)
(inject T:object T:vector T:fixnum)]
[(vector-set!)
(inject T:void T:vector T:fixnum T:object)]
[(length)
(inject T:fixnum (T:or T:null T:pair))]
[(bytevector-length)
(inject T:fixnum T:bytevector)]
[(integer->char)
(inject T:char T:fixnum)]
[(char->integer)
(inject T:fixnum T:char)]
[(bytevector-u8-ref bytevector-s8-ref
bytevector-u16-native-ref bytevector-s16-native-ref)
(inject T:fixnum T:bytevector T:fixnum)]
[(bytevector-u16-ref bytevector-s16-ref)
(inject T:fixnum T:bytevector T:fixnum T:symbol)]
[(bytevector-u8-set! bytevector-s8-set!
bytevector-u16-native-set! bytevector-s16-native-set!)
(inject T:void T:bytevector T:fixnum T:fixnum)]
[(bytevector-u16-set! bytevector-s16-set!)
(inject T:void T:bytevector T:fixnum T:fixnum T:symbol)]
[(fx+ fx- fx* fxadd1 fxsub1
fxquotient fxremainder fxmodulo fxsll fxsra
fxand fxdiv fxdiv0 fxif fxior
fxlength fxmax fxmin fxmod fxmod0
fxnot fxxor fxlogand fxlogor fxlognot
fxlogxor)
(inject* T:fixnum T:fixnum)]
[(fx= fx< fx<= fx> fx>= fx=? fx<? fx<=? fx>? fx>=?
fxeven? fxodd? fxnegative? fxpositive? fxzero?
fxbit-set?)
(inject* T:boolean T:fixnum)]
[(fl=? fl<? fl<=? fl>? fl>=?
fleven? flodd? flzero? flpositive? flnegative?
flfinite? flinfinite? flinteger? flnan?)
(inject* T:boolean T:flonum)]
[(char=? char<? char<=? char>? char>=?
char-ci=? char-ci<? char-ci<=? char-ci>? char-ci>=?)
(inject* T:boolean T:char)]
[(string=? string<? string<=? string>? string>=?
string-ci=? string-ci<? string-ci<=? string-ci>?
string-ci>=?)
(inject* T:boolean T:string)]
[(make-parameter
record-constructor
record-accessor
record-constructor
record-predicate
condition-accessor
condition-predicate
enum-set-constructor
enum-set-indexer
make-guardian)
(return T:procedure)]
[(fixnum-width greatest-fixnum least-fixnum)
(return T:fixnum)]
[else
(return T:object)]))
;;;
(define (extend-env* x* v* env)
(cond
[(null? x*) env]
[else
(extend-env* (cdr x*) (cdr v*)
(extend-env (car x*) (car v*) env))]))
(define (extend-env x t env)
(cond
[(T=? t T:object) env]
[else
(let ([x (prelex-operand x)])
(let f ([env env])
(cond
[(or (null? env) (< x (caar env)))
(cons (cons x t) env)]
[else
(cons (car env) (f (cdr env)))])))]))
(define (or-envs env1 env2)
(define (cons-env x v env)
(cond
[(T=? v T:object) env]
[else (cons (cons x v) env)]))
(define (merge-envs1 a1 env1 env2)
(if (pair? env2)
(merge-envs2 a1 env1 (car env2) (cdr env2))
empty-env))
(define (merge-envs2 a1 env1 a2 env2)
(let ([x1 (car a1)] [x2 (car a2)])
(if (eq? x1 x2)
(cons-env x1 (T:or (cdr a1) (cdr a2))
(merge-envs env1 env2))
(if (< x2 x1)
(merge-envs1 a1 env1 env2)
(merge-envs1 a2 env2 env1)))))
(define (merge-envs env1 env2)
(if (eq? env1 env2)
env1
(if (pair? env1)
(if (pair? env2)
(merge-envs2 (car env1) (cdr env1) (car env2) (cdr env2))
empty-env)
empty-env)))
(merge-envs env1 env2))
(define (and-envs env1 env2)
(define (cons-env x v env)
(cond
[(T=? v T:object) env]
[else (cons (cons x v) env)]))
(define (merge-envs1 a1 env1 env2)
(if (pair? env2)
(merge-envs2 a1 env1 (car env2) (cdr env2))
env1))
(define (merge-envs2 a1 env1 a2 env2)
(let ([x1 (car a1)] [x2 (car a2)])
(if (eq? x1 x2)
(cons-env x1 (T:and (cdr a1) (cdr a2))
(merge-envs env1 env2))
(if (< x2 x1)
(cons a2 (merge-envs1 a1 env1 env2))
(cons a1 (merge-envs1 a2 env2 env1))))))
(define (merge-envs env1 env2)
(if (eq? env1 env2)
env1
(if (pair? env1)
(if (pair? env2)
(merge-envs2 (car env1) (cdr env1) (car env2) (cdr env2))
env1)
env2)))
(merge-envs env1 env2))
(define empty-env '())
(define (lookup x env)
(cond
[(eq? env 'bottom) #f]
[else
(let ([x (prelex-operand x)])
(cond
[(assq x env) => cdr]
[else T:object]))]))
(let-values ([(x env t) (V x empty-env)])
(when (tag-analysis-output)
(pretty-print (unparse-pretty x)))
x))