mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-05-21 06:39:17 +02:00
adding initial type inference library
This commit is contained in:
Alex Shinn
parent
dcb56aa085
commit
8b590bd70c
4 changed files with 222 additions and 4 deletions
|
|
@ -75,11 +75,14 @@ static sexp sexp_get_opcode_ret_type (sexp ctx sexp_api_params(self, n), sexp op
|
|||
|
||||
static sexp sexp_get_opcode_param_type (sexp ctx sexp_api_params(self, n), sexp op, sexp k) {
|
||||
sexp res;
|
||||
int p = sexp_unbox_fixnum(k);
|
||||
if (! sexp_opcodep(op))
|
||||
return sexp_type_exception(ctx, self, SEXP_OPCODE, op);
|
||||
else if (! sexp_fixnump(k))
|
||||
return sexp_type_exception(ctx, self, SEXP_FIXNUM, k);
|
||||
switch (sexp_unbox_fixnum(k)) {
|
||||
if (p > sexp_opcode_num_args(op) && sexp_opcode_variadic_p(op))
|
||||
p = sexp_opcode_num_args(op);
|
||||
switch (p) {
|
||||
case 0:
|
||||
res = sexp_opcode_arg1_type(op);
|
||||
break;
|
||||
|
|
@ -92,7 +95,7 @@ static sexp sexp_get_opcode_param_type (sexp ctx sexp_api_params(self, n), sexp
|
|||
if (sexp_vector_length(res) > (sexp_unbox_fixnum(k)-2))
|
||||
res = sexp_vector_ref(res, sexp_fx_sub(k, SEXP_TWO));
|
||||
else
|
||||
res = sexp_type_by_index(ctx, 0);
|
||||
res = sexp_type_by_index(ctx, SEXP_OBJECT);
|
||||
}
|
||||
break;
|
||||
}
|
||||
|
|
@ -105,6 +108,12 @@ static sexp sexp_get_opcode_num_params (sexp ctx sexp_api_params(self, n), sexp
|
|||
return sexp_make_fixnum(sexp_opcode_num_args(op));
|
||||
}
|
||||
|
||||
static sexp sexp_get_opcode_variadic_p (sexp ctx sexp_api_params(self, n), sexp op) {
|
||||
if (! sexp_opcodep(op))
|
||||
return sexp_type_exception(ctx, self, SEXP_OPCODE, op);
|
||||
return sexp_make_boolean(sexp_opcode_variadic_p(op));
|
||||
}
|
||||
|
||||
static sexp sexp_analyze_op (sexp ctx sexp_api_params(self, n), sexp x, sexp e) {
|
||||
sexp ctx2 = ctx;
|
||||
if (sexp_envp(e)) {
|
||||
|
|
@ -147,6 +156,7 @@ sexp sexp_init_library (sexp ctx sexp_api_params(self, n), sexp env) {
|
|||
sexp_define_type(ctx, "seq", SEXP_SEQ);
|
||||
sexp_define_type(ctx, "lit", SEXP_LIT);
|
||||
sexp_define_type(ctx, "sc", SEXP_SYNCLO);
|
||||
sexp_define_type(ctx, "context", SEXP_CONTEXT);
|
||||
sexp_define_type_predicate(ctx, env, "environment?", SEXP_ENV);
|
||||
sexp_define_type_predicate(ctx, env, "bytecode?", SEXP_BYTECODE);
|
||||
sexp_define_type_predicate(ctx, env, "exception?", SEXP_EXCEPTION);
|
||||
|
|
@ -160,6 +170,7 @@ sexp sexp_init_library (sexp ctx sexp_api_params(self, n), sexp env) {
|
|||
sexp_define_type_predicate(ctx, env, "lit?", SEXP_LIT);
|
||||
sexp_define_type_predicate(ctx, env, "opcode?", SEXP_OPCODE);
|
||||
sexp_define_type_predicate(ctx, env, "type?", SEXP_TYPE);
|
||||
sexp_define_type_predicate(ctx, env, "context?", SEXP_CONTEXT);
|
||||
sexp_define_accessors(ctx, env, SEXP_PAIR, 2, "pair-source", "pair-source-set!");
|
||||
sexp_define_accessors(ctx, env, SEXP_SYNCLO, 0, "syntactic-closure-env", "syntactic-closure-env-set!");
|
||||
sexp_define_accessors(ctx, env, SEXP_SYNCLO, 1, "syntactic-closure-vars", "syntactic-closure-vars-set!");
|
||||
|
|
@ -191,6 +202,7 @@ sexp sexp_init_library (sexp ctx sexp_api_params(self, n), sexp env) {
|
|||
sexp_define_foreign(ctx, env, "extend-env", 2, sexp_extend_env);
|
||||
sexp_define_foreign(ctx, env, "env-cell", 2, sexp_get_env_cell);
|
||||
sexp_define_foreign(ctx, env, "opcode-name", 1, sexp_get_opcode_name);
|
||||
sexp_define_foreign(ctx, env, "opcode-variadic?", 1, sexp_get_opcode_variadic_p);
|
||||
sexp_define_foreign(ctx, env, "opcode-num-params", 1, sexp_get_opcode_num_params);
|
||||
sexp_define_foreign(ctx, env, "opcode-return-type", 1, sexp_get_opcode_ret_type);
|
||||
sexp_define_foreign(ctx, env, "opcode-param-type", 2, sexp_get_opcode_param_type);
|
||||
|
|
|
|||
|
|
@ -2,10 +2,10 @@
|
|||
(define-module (chibi ast)
|
||||
(export analyze optimize env-cell ast->sexp macroexpand
|
||||
object opcode procedure bytecode macro env number bignum flonum integer
|
||||
lam cnd set ref seq lit sc
|
||||
context lam cnd set ref seq lit sc
|
||||
pair-source pair-source-set!
|
||||
syntactic-closure? lambda? cnd? set? ref? seq? lit? opcode? type?
|
||||
environment? bytecode? exception? macro?
|
||||
environment? bytecode? exception? macro? context?
|
||||
syntactic-closure-expr syntactic-closure-env syntactic-closure-vars
|
||||
lambda-name lambda-params lambda-body lambda-defs lambda-locals
|
||||
lambda-flags lambda-free-vars lambda-set-vars lambda-return-type
|
||||
|
|
@ -20,6 +20,7 @@
|
|||
ref-name ref-cell ref-name-set! ref-cell-set!
|
||||
seq-ls seq-ls-set! lit-value lit-value-set!
|
||||
opcode-name opcode-num-params opcode-return-type opcode-param-type
|
||||
opcode-variadic?
|
||||
procedure-code procedure-vars procedure-name bytecode-name)
|
||||
(import-immutable (scheme))
|
||||
(include-shared "ast")
|
||||
|
|
|
|||
7
lib/chibi/type-inference.module
Normal file
7
lib/chibi/type-inference.module
Normal file
|
|
@ -0,0 +1,7 @@
|
|||
|
||||
(define-module (chibi type-inference)
|
||||
(export type-analyze-module type-analyze procedure-signature)
|
||||
(import-immutable (scheme))
|
||||
(import (srfi 1) (srfi 69) (chibi modules) (chibi ast) (chibi match))
|
||||
(include "type-inference.scm"))
|
||||
|
||||
198
lib/chibi/type-inference.scm
Normal file
198
lib/chibi/type-inference.scm
Normal file
|
|
@ -0,0 +1,198 @@
|
|||
|
||||
(define (typed? x)
|
||||
(and (lambda? x)
|
||||
(lambda-return-type x)))
|
||||
|
||||
(define (union-type? a)
|
||||
(and (pair? a) (equal? (car a) 'or)))
|
||||
|
||||
(define (intersection-type? a)
|
||||
(and (pair? a) (equal? (car a) 'and)))
|
||||
|
||||
(define (unfinalized-type? a)
|
||||
(and (pair? a) (memq (car a) '(return-type param-type))))
|
||||
|
||||
(define (numeric-type? a)
|
||||
(or (eq? a number) (eq? a flonum) (eq? a integer)))
|
||||
|
||||
(define (procedure-type? a)
|
||||
(or (eq? a opcode) (eq? a procedure) (and (pair? a) (eq? (car a) 'lambda))))
|
||||
|
||||
(define (type-subset? a b)
|
||||
(or (equal? a b)
|
||||
(equal? a object)
|
||||
(equal? b object)
|
||||
(and (numeric-type? a) (numeric-type? b))
|
||||
(and (procedure-type? a) (procedure-type? b))
|
||||
(if (union-type? a)
|
||||
(if (union-type? b)
|
||||
(lset<= equal? (cdr a) (cdr b))
|
||||
(member b (cdr a)))
|
||||
(and (union-type? b) (member a (cdr b))))))
|
||||
|
||||
;; XXXX check for type hierarchies
|
||||
(define (type-union a b)
|
||||
(cond
|
||||
((equal? a b) a)
|
||||
((or (equal? a object) (equal? b object)) object)
|
||||
((union-type? a)
|
||||
(if (union-type? b)
|
||||
(cons (car a) (lset-union equal? (cdr a) (cdr b)))
|
||||
(cons (car a) (lset-adjoin equal? (cdr a) b))))
|
||||
(else (list 'or a b))))
|
||||
|
||||
;; XXXX check for conflicts
|
||||
(define (type-intersection a b)
|
||||
(cond
|
||||
((equal? a b) a)
|
||||
((or (equal? a object) (unfinalized-type? a)) b)
|
||||
((or (equal? b object) (unfinalized-type? b)) a)
|
||||
((intersection-type? a)
|
||||
(if (intersection-type? b)
|
||||
(lset-intersection equal? (cdr a) (cdr b))
|
||||
(cons (car a) (lset-adjoin equal? (cdr a) b))))
|
||||
(else (list 'and a b))))
|
||||
|
||||
(define (lambda-param-types-initialize! f)
|
||||
(lambda-param-types-set! f (map (lambda (p) (list 'param-type f p))
|
||||
(lambda-params f))))
|
||||
|
||||
(define (lambda-param-type-memq f x)
|
||||
(let lp ((p (lambda-params f))
|
||||
(t (lambda-param-types f)))
|
||||
(and (pair? p)
|
||||
(pair? t)
|
||||
(if (eq? x (car p))
|
||||
t
|
||||
(lp (cdr p) (cdr t))))))
|
||||
|
||||
(define (lambda-param-type-ref f x)
|
||||
(cond ((lambda-param-type-memq f x) => car)
|
||||
(else #f)))
|
||||
|
||||
(define (lambda-param-type-set! f x y)
|
||||
(if (not (pair? (lambda-param-types f)))
|
||||
(lambda-param-types-initialize! f))
|
||||
(cond ((lambda-param-type-memq f x)
|
||||
=> (lambda (cell) (set-car! cell y)))))
|
||||
|
||||
(define (type-analyze-expr x)
|
||||
;;(write `(type-analyze-expr ,x ,(ast->sexp x)) (current-error-port)) (newline (current-error-port))
|
||||
(match x
|
||||
(($ lam name params body defs)
|
||||
(lambda-return-type-set! x (list 'return-type x))
|
||||
(lambda-param-types-initialize! x)
|
||||
(let ((ret-type (type-analyze-expr body)))
|
||||
(lambda-return-type-set! x ret-type)
|
||||
(cons 'lambda (cons ret-type (lambda-param-types x)))))
|
||||
(($ set ref value)
|
||||
(type-analyze-expr value)
|
||||
(if #f #f))
|
||||
(($ ref name (_ . loc) source)
|
||||
(if (lambda? loc)
|
||||
(lambda-param-type-ref loc name)
|
||||
object))
|
||||
(($ cnd test pass fail)
|
||||
(type-analyze-expr test)
|
||||
(type-union (type-analyze-expr pass) (type-analyze-expr fail)))
|
||||
(($ seq ls)
|
||||
(let lp ((ls ls))
|
||||
(cond ((null? (cdr ls))
|
||||
(type-analyze-expr (car ls)))
|
||||
(else
|
||||
(type-analyze-expr (car ls))
|
||||
(lp (cdr ls))))))
|
||||
((f args ...)
|
||||
(cond
|
||||
((opcode? f)
|
||||
;;(write `(opcode app ,(opcode-param-types f) ,args) (current-error-port)) (newline (current-error-port))
|
||||
(let lp ((p (opcode-param-types f))
|
||||
(a args))
|
||||
(cond
|
||||
((pair? a)
|
||||
(cond ((or (pair? p) (opcode-variadic? f))
|
||||
(match (car a)
|
||||
(($ ref name (_ . (and g ($ lam))))
|
||||
(let ((t (type-intersection (lambda-param-type-ref g name)
|
||||
(if (pair? p)
|
||||
(car p)
|
||||
(opcode-param-type f (opcode-num-params f))))))
|
||||
(lambda-param-type-set! g name t)))
|
||||
(else
|
||||
(let ((t (type-analyze-expr (car a))))
|
||||
(cond
|
||||
((not (type-subset? t (car p)))
|
||||
(display "WARNING: incompatible type: " (current-error-port))
|
||||
(write (list x t (car p)) (current-error-port))
|
||||
(newline (current-error-port))))
|
||||
t)))
|
||||
(lp (and (pair? p) (cdr p)) (cdr a)))
|
||||
(else
|
||||
(for-each type-analyze-expr a))))))
|
||||
(opcode-return-type f))
|
||||
(else
|
||||
(let ((f-type (type-analyze-expr f)))
|
||||
;; XXXX apply f-type to params
|
||||
(for-each type-analyze-expr args)
|
||||
(if (and (pair? f-type) (eq? 'lambda (car f-type)))
|
||||
(cadr f-type)
|
||||
object)))))
|
||||
(else
|
||||
;;(write `(unknown type ,x) (current-error-port)) (newline (current-error-port))
|
||||
object)))
|
||||
|
||||
(define (type-resolve-circularities x)
|
||||
#f)
|
||||
|
||||
;; basic type inference on the body of a module
|
||||
;; - internal references are to lambdas
|
||||
;; - external references are to procedures (with completed type info)
|
||||
;; - for each lambda
|
||||
;; + add parameter constraints (intersection) from body
|
||||
;; + add return type constaints (union) from last form(s)
|
||||
;; - when complete, resolve cycles (e.g. even/odd => boolean)
|
||||
(define (type-analyze-module-body name ls)
|
||||
;;(write `(type-analyze-module-body ,name) (current-error-port)) (newline (current-error-port))
|
||||
(for-each type-analyze-expr ls)
|
||||
(for-each type-resolve-circularities ls))
|
||||
|
||||
(define (type-analyze-module name)
|
||||
(let* ((mod (analyze-module name))
|
||||
(ls (and (vector? mod) (module-ast mod))))
|
||||
;;(write `(analyzing ,ls) (current-error-port)) (newline (current-error-port))
|
||||
(and ls
|
||||
(let ((x (let lp ((ls ls)) ;; first lambda
|
||||
(and (pair? ls)
|
||||
(if (and (set? (car ls))
|
||||
(lambda? (set-value (car ls))))
|
||||
(set-value (car ls))
|
||||
(lp (cdr ls)))))))
|
||||
(if (and x (not (typed? x)))
|
||||
(type-analyze-module-body name ls))
|
||||
ls))))
|
||||
|
||||
(define (type-analyze sexp . o)
|
||||
(type-analyze-expr (apply analyze sexp o)))
|
||||
|
||||
(define (opcode-param-types x)
|
||||
(let lp ((n (- (opcode-num-params x) 1)) (res '()))
|
||||
(if (< n 0)
|
||||
res
|
||||
(lp (- n 1) (cons (opcode-param-type x n) res)))))
|
||||
|
||||
(define (procedure-signature x)
|
||||
(if (opcode? x)
|
||||
(cons (opcode-return-type x) (opcode-param-types x))
|
||||
(let lp ((count 0))
|
||||
(let ((lam (procedure-analysis x)))
|
||||
(cond
|
||||
((and lam (not (typed? lam)) (zero? count)
|
||||
(containing-module x))
|
||||
=> (lambda (mod)
|
||||
(and (type-analyze-module (car mod))
|
||||
(lp (+ count 1)))))
|
||||
((lambda? lam)
|
||||
(cons (lambda-return-type lam)
|
||||
(lambda-param-types lam)))
|
||||
(else
|
||||
#f))))))
|
||||
Loading…
Add table
Reference in a new issue