adding initial type inference library

lib/chibi/ast.c

@@ -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);

lib/chibi/ast.module

@@ -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")

lib/chibi/type-inference.module

@@ -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"))
+

lib/chibi/type-inference.scm

@@ -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))))))