adding several utilities to chibi.modules including procedure-analysis

include/chibi/sexp.h

@@ -301,7 +301,7 @@ struct sexp_struct {
     struct sexp_core_form_struct core;
     /* ast types */
     struct {
-      sexp name, params, body, defs, locals, flags, fv, sv, source;
+      sexp name, params, body, defs, locals, flags, fv, sv, ret, types, source;
     } lambda;
     struct {
       sexp test, pass, fail, source;
@@ -704,6 +704,8 @@ SEXP_API sexp sexp_make_unsigned_integer(sexp ctx, sexp_luint_t x);
 #define sexp_lambda_body(x)   ((x)->value.lambda.body)
 #define sexp_lambda_fv(x)     ((x)->value.lambda.fv)
 #define sexp_lambda_sv(x)     ((x)->value.lambda.sv)
+#define sexp_lambda_return_type(x) ((x)->value.lambda.ret)
+#define sexp_lambda_param_types(x) ((x)->value.lambda.types)
 #define sexp_lambda_source(x) ((x)->value.lambda.source)
 
 #define sexp_cnd_test(x)      ((x)->value.cnd.test)

lib/chibi/ast.c

@@ -45,8 +45,25 @@ static sexp sexp_get_opcode_name (sexp ctx sexp_api_params(self, n), sexp op) {
     return sexp_intern(ctx, sexp_opcode_name(op), -1);
 }
 
-static sexp sexp_analyze_op (sexp ctx sexp_api_params(self, n), sexp x) {
+static sexp sexp_analyze_op (sexp ctx sexp_api_params(self, n), sexp x, sexp e) {
-  return sexp_analyze(ctx, x);
+  sexp ctx2 = ctx;
+  if (sexp_envp(e)) {
+    ctx2 = sexp_make_child_context(ctx, NULL);
+    sexp_context_env(ctx2) = e;
+  }
+  return sexp_analyze(ctx2, x);
+}
+
+static sexp sexp_optimize (sexp ctx sexp_api_params(self, n), sexp x) {
+  sexp_gc_var2(ls, res);
+  sexp_gc_preserve2(ctx, ls, res);
+  res = x;
+  ls = sexp_global(ctx, SEXP_G_OPTIMIZATIONS);
+  for ( ; sexp_pairp(ls); ls=sexp_cdr(ls))
+    res = sexp_apply1(ctx, sexp_cdar(ls), res);
+  sexp_free_vars(ctx, res, SEXP_NULL);
+  sexp_gc_release2(ctx);
+  return res;
 }
 
 #define sexp_define_type(ctx, name, tag) \
@@ -67,6 +84,8 @@ sexp sexp_init_library (sexp ctx sexp_api_params(self, n), sexp env) {
   sexp_define_type_predicate(ctx, env, "seq?", SEXP_SEQ);
   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_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!");
   sexp_define_accessors(ctx, env, SEXP_SYNCLO, 2, "syntactic-closure-expr", "syntactic-closure-expr-set!");
@@ -74,6 +93,13 @@ sexp sexp_init_library (sexp ctx sexp_api_params(self, n), sexp env) {
   sexp_define_accessors(ctx, env, SEXP_LAMBDA, 1, "lambda-params", "lambda-params-set!");
   sexp_define_accessors(ctx, env, SEXP_LAMBDA, 2, "lambda-body", "lambda-body-set!");
   sexp_define_accessors(ctx, env, SEXP_LAMBDA, 3, "lambda-defs", "lambda-defs-set!");
+  sexp_define_accessors(ctx, env, SEXP_LAMBDA, 4, "lambda-locals", "lambda-locals-set!");
+  sexp_define_accessors(ctx, env, SEXP_LAMBDA, 5, "lambda-flags", "lambda-flags-set!");
+  sexp_define_accessors(ctx, env, SEXP_LAMBDA, 6, "lambda-free-vars", "lambda-free-vars-set!");
+  sexp_define_accessors(ctx, env, SEXP_LAMBDA, 7, "lambda-set-vars", "lambda-set-vars-set!");
+  sexp_define_accessors(ctx, env, SEXP_LAMBDA, 8, "lambda-return-type", "lambda-return-type-set!");
+  sexp_define_accessors(ctx, env, SEXP_LAMBDA, 9, "lambda-param-types", "lambda-param-types-set!");
+  sexp_define_accessors(ctx, env, SEXP_LAMBDA, 10, "lambda-source", "lambda-source-set!");
   sexp_define_accessors(ctx, env, SEXP_CND, 0, "cnd-test", "cnd-test-set!");
   sexp_define_accessors(ctx, env, SEXP_CND, 1, "cnd-pass", "cnd-pass-set!");
   sexp_define_accessors(ctx, env, SEXP_CND, 2, "cnd-fail", "cnd-fail-set!");
@@ -83,10 +109,14 @@ sexp sexp_init_library (sexp ctx sexp_api_params(self, n), sexp env) {
   sexp_define_accessors(ctx, env, SEXP_REF, 1, "ref-cell", "ref-cell-set!");
   sexp_define_accessors(ctx, env, SEXP_SEQ, 0, "seq-ls", "seq-ls-set!");
   sexp_define_accessors(ctx, env, SEXP_LIT, 0, "lit-value", "lit-value-set!");
-  sexp_define_foreign(ctx, env, "analyze", 1, sexp_analyze_op);
+  sexp_define_accessors(ctx, env, SEXP_PROCEDURE, 1, "procedure-code", "procedure-code-set!");
+  sexp_define_accessors(ctx, env, SEXP_PROCEDURE, 2, "procedure-vars", "procedure-vars-set!");
+  sexp_define_accessors(ctx, env, SEXP_BYTECODE, 1, "bytecode-name", "bytecode-name-set!");
+  sexp_define_foreign_opt(ctx, env, "analyze", 2, sexp_analyze_op, SEXP_FALSE);
   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, "optimize", 1, sexp_optimize);
   return SEXP_VOID;
 }
 

lib/chibi/ast.module

@@ -1,16 +1,24 @@
 
 (define-module (chibi ast)
-  (export analyze env-cell opcode-name
+  (export analyze optimize env-cell opcode-name ast->sexp macroexpand
           lam cnd set ref seq lit
+          pair-source pair-source-set!
           syntactic-closure? lambda? cnd? set? ref? seq? lit? opcode?
           syntactic-closure-expr syntactic-closure-env syntactic-closure-vars
-          lambda-name lambda-params lambda-body lambda-defs
+          lambda-name lambda-params lambda-body lambda-defs lambda-locals
+          lambda-flags lambda-free-vars lambda-set-vars lambda-return-type
+          lambda-param-types lambda-source
           lambda-name-set! lambda-params-set! lambda-body-set! lambda-defs-set!
+          lambda-locals-set! lambda-flags-set! lambda-free-vars-set!
+          lambda-set-vars-set! lambda-return-type-set! lambda-param-types-set!
+          lambda-source-set!
           cnd-test cnd-pass cnd-fail
           cnd-test-set! cnd-pass-set! cnd-fail-set!
           set-var set-value set-var-set! set-value-set!
           ref-name ref-cell ref-name-set! ref-cell-set!
-          seq-ls seq-ls-set! lit-value lit-value-set!)
+          seq-ls seq-ls-set! lit-value lit-value-set!
+          procedure-code procedure-vars procedure-name bytecode-name)
   (import-immutable (scheme))
-  (include-shared "ast"))
+  (include-shared "ast")
+  (include "ast.scm"))
 

lib/chibi/macroexpand.module

@@ -1,6 +0,0 @@
-
-(define-module (chibi macroexpand)
-  (import-immutable (scheme))
-  (import (chibi ast))
-  (export macroexpand ast->sexp)
-  (include "macroexpand.scm"))

lib/chibi/macroexpand.scm

@@ -1,86 +0,0 @@
-;; macroexpand.scm -- macro expansion utility
-;; Copyright (c) 2009 Alex Shinn.  All rights reserved.
-;; BSD-style license: http://synthcode.com/license.txt
-
-;; This actually analyzes the expression then reverse-engineers an
-;; sexp from the result, generating a minimal amount of renames.
-
-(define (macroexpand x)
-  (ast->sexp (analyze x)))
-
-(define (ast-renames ast)
-  (define i 0)
-  (define renames '())
-  (define (rename-symbol id)
-    (set! i (+ i 1))
-    (string->symbol
-     (string-append (symbol->string (identifier->symbol id))
-                    "." (number->string i))))
-  (define (rename-lambda lam)
-    (or (assq lam renames)
-        (let ((res (list lam)))
-          (set! renames (cons res renames))
-          res)))
-  (define (rename! id lam)
-    (let ((cell (rename-lambda lam)))
-      (set-cdr! cell (cons (cons id (rename-symbol id)) (cdr cell)))))
-  (define (check-ref id lam env)
-    (let ((sym (identifier->symbol id)))
-      (let lp1 ((ls env))
-        (cond
-         ((pair? ls)
-          (let lp2 ((ls2 (car ls)) (found? #f))
-            (cond
-             ((null? ls2)
-              (if (not found?) (lp1 (cdr ls))))
-             ((and (eq? id (caar ls2)) (eq? lam (cdar ls2)))
-               (lp2 (cdr ls2) #t))
-             ((eq? sym (identifier->symbol (caar ls2)))
-              (rename! (caar ls2) (cdar ls2))
-              (lp2 (cdr ls2) found?))
-             (else
-              (lp2 (cdr ls2) found?)))))))))
-  (define (flatten-dot x)
-    (cond ((pair? x) (cons (car x) (flatten-dot (cdr x))))
-          ((null? x) x)
-          (else (list x))))
-  (define (extend-env lam env)
-    (cons (map (lambda (x) (cons x lam)) (flatten-dot (lambda-params lam))) env))
-  (let lp ((x ast) (env '()))
-    (cond
-     ((lambda? x) (lp (lambda-body x) (extend-env x env)))
-     ((ref? x) (check-ref (ref-name x) (cdr (ref-cell x)) env))
-     ((cnd? x) (lp (cnd-test x) env) (lp (cnd-pass x) env) (lp (cnd-fail x) env))
-     ((set? x) (lp (set-var x) env) (lp (set-value x) env))
-     ((seq? x) (for-each (lambda (x) (lp x env)) (seq-ls x)))
-     ((pair? x) (for-each (lambda (x) (lp x env)) x))))
-  renames)
-
-(define (get-rename id lam renames)
-  (let ((ls (assq lam renames)))
-    (if (not ls)
-        (identifier->symbol id)
-        (cond ((assq id (cdr ls)) => cdr) (else (identifier->symbol id))))))
-
-(define (ast->sexp ast)
-  (let ((renames (ast-renames ast)))
-    (let a2s ((x ast))
-      (cond
-       ((lambda? x)
-        `(lambda ,(map (lambda (id) (get-rename id x renames)) (lambda-params x))
-           ,@(map (lambda (d) `(define ,(identifier->symbol (cadar d)) #f))
-                  (lambda-defs x))
-           ,@(if (seq? (lambda-body x))
-                 (map a2s (seq-ls (lambda-body x)))
-                 (list (a2s (lambda-body x))))))
-       ((cnd? x) `(if ,(a2s (cnd-test x)) ,(a2s (cnd-pass x)) ,(a2s (cnd-fail x))))
-       ((set? x) `(set! ,(a2s (set-var x)) ,(a2s (set-value x))))
-       ((ref? x) (get-rename (ref-name x) (cdr (ref-cell x)) renames))
-       ((seq? x) `(begin ,@(map a2s (seq-ls x))))
-       ((lit? x)
-        (let ((v (lit-value x)))
-          (if (or (pair? v) (null? v) (symbol? v)) `',v v)))
-       ((pair? x) (cons (a2s (car x)) (a2s (cdr x))))
-       ((opcode? x) (or (opcode-name x) x))
-       (else x)))))
-

lib/chibi/modules.module

@@ -1,5 +1,8 @@
 
 (define-module (chibi modules)
-  (export analyze-module)
+  (export analyze-module module-ast module-ast-set!
-  (import-immutable (scheme) (config) (chibi ast))
+          module-ref module-contains? containing-module
+          procedure-analysis)
+  (import-immutable (scheme) (config))
+  (import (chibi ast))
   (include "modules.scm"))

lib/chibi/modules.scm

@@ -8,57 +8,79 @@
               (reverse res)
               (lp (cons x res))))))))
 
-;; load the module and return it with a list of all top-level forms in
+(define (module? x) (vector? x))
-;; the module analyzed
+
+(define (module-ast mod) (vector-ref mod 3))
+(define (module-ast-set! mod x) (vector-set! mod 3 x))
+
+(define (analyze-module-source name mod recursive?)
+  (let ((env (module-env mod))
+        (dir (if (equal? name '(scheme)) "" (module-name-prefix name))))
+    (define (include-source file)
+      (cond ((find-module-file (string-append dir file))
+             => (lambda (x) (cons 'body (file->sexp-list x))))
+            (else (error "couldn't find include" file))))
+    (let lp ((ls (module-meta-data mod)) (res '()))
+      (cond
+       ((not (pair? ls))
+        (reverse res))
+       (else
+        (case (and (pair? (car ls)) (caar ls))
+          ((import import-immutable)
+           (for-each
+            (lambda (m)
+              (let* ((mod2-name+imports (resolve-import m))
+                     (mod2-name (car mod2-name+imports)))
+                (if recursive?
+                    (analyze-module mod2-name #t))))
+            (cdar ls))
+           (lp (cdr ls) res))
+          ((include)
+           (lp (append (map include-source (cdar ls)) (cdr ls)) res))
+          ((body)
+           (let lp2 ((ls2 (cdar ls)) (res res))
+             (cond
+              ((pair? ls2)
+               (lp2 (cdr ls2) (cons (analyze (car ls2) env) res)))
+              (else
+               (lp (cdr ls) res)))))
+          (else
+           (lp (cdr ls) res))))))))
+
 (define (analyze-module name . o)
   (let ((recursive? (and (pair? o) (car o)))
-        (modules `(((scheme) . ,(find-module '(scheme))))))
+        (res (load-module name)))
-    (let go ((name name))
+    (if (not (module-ast res))
-      (let ((env (make-environment))
+        (module-ast-set! res (analyze-module-source name res recursive?)))
-            (dir (module-name-prefix name)))
+    res))
-        (define (load-modules files extension)
+
-          (for-each
+(define (module-ref mod var-name . o)
-           (lambda (f)
+  (let ((cell (env-cell (module-env (if (module? mod) mod (load-module mod)))
-             (let ((f (string-append dir f extension)))
+                        var-name)))
-               (cond ((find-module-file f) => (lambda (x) (load x env)))
+    (if cell
-                     (else (error "couldn't find include" f)))))
+        (cdr cell)
-           files))
+        (if (pair? o) (car o) (error "no binding in module" mod var-name)))))
-        (define (include-source file)
+
-          (cond ((find-module-file (string-append dir file))
+(define (module-contains? mod var-name)
-                 => (lambda (x) (cons 'body (file->sexp-list x))))
+  (and (env-cell (module-env (if (module? mod) mod (load-module mod))) var-name)
-                (else (error "couldn't find include" file))))
+       #t))
-        (cond
+
-         ((assoc name modules) => cdr)
+(define (containing-module x)
-         (else
+  (let lp1 ((ls *modules*))
-          (let ((mod (find-module name)))
+    (and (pair? ls)
-            (let lp ((ls (module-meta-data mod)) (res '()))
+         (let ((env (module-env (cdar ls))))
-              (cond
+           (let lp2 ((e-ls (env-exports env)))
-               ((not (pair? ls)) (reverse res))
+             (cond ((null? e-ls) (lp1 (cdr ls)))
-               (else
+                   ((eq? x (cdr (env-cell env (car e-ls)))) (car ls))
-                (case (and (pair? (car ls)) (caar ls))
+                   (else (lp2 (cdr e-ls)))))))))
-                  ((import import-immutable)
+
-                   (for-each
+(define (procedure-analysis x)
-                    (lambda (m)
+  (let ((mod (containing-module x)))
-                      (let* ((mod2-name+imports (resolve-import m))
+    (and mod
-                             (mod2 (load-module (car mod2-name+imports))))
+         (let lp ((ls (module-ast (analyze-module (car mod)))))
-                        (%env-copy! env (module-env mod2) (cdr mod2-name+imports)
+           (and (pair? ls)
-                                    (eq? (caar ls) 'import-immutable))))
+                (if (and (set? (car ls))
-                    (cdar ls))
+                         (eq? (procedure-name x) (ref-name (set-var (car ls)))))
-                   (lp (cdr ls) res))
+                    (set-value (car ls))
-                  ((include)
+                    (lp (cdr ls))))))))
-                   (lp (append (map include-source (cdar ls)) (cdr ls)) res))
+
-                  ((include-shared)
-                   (cond-expand
-                    (dynamic-loading
-                     (load-modules (cdar ls) *shared-object-extension*))
-                    (else #f)))
-                  ((body)
-                   (let lp2 ((ls2 (cdar ls)) (res res))
-                     (cond
-                      ((pair? ls2)
-                       (eval (car ls2) env)
-                       (lp2 (cdr ls2) (cons (analyze (car ls2)) res)))
-                      (else
-                       (lp (cdr ls) res)))))
-                  (else
-                   (lp (cdr ls) res)))))))))))))

lib/chibi/repl.module

@@ -1,5 +1,6 @@
 
 (define-module (chibi repl)
   (export repl)
-  (import-immutable (scheme) (chibi process))
+  (import-immutable (scheme))
+  (import (chibi process))
   (include "repl.scm"))

lib/config.scm

@@ -7,7 +7,7 @@
 
 (define *this-module* '())
 
-(define (make-module exports env meta) (vector exports env meta))
+(define (make-module exports env meta) (vector exports env meta #f))
 (define (%module-exports mod) (vector-ref mod 0))
 (define (module-env mod) (vector-ref mod 1))
 (define (module-meta-data mod) (vector-ref mod 2))
@@ -167,7 +167,8 @@
 (define-config-primitive body)
 
 (define *modules*
-  (list (cons '(scheme) (make-module #f (interaction-environment) '()))
+  (list (cons '(scheme) (make-module #f (interaction-environment)
+                                     '((include "init.scm"))))
         (cons '(config) (make-module #f (current-environment) '()))
         (cons '(srfi 0) (make-module (list 'cond-expand)
                                      (interaction-environment)

sexp.c

@@ -107,7 +107,7 @@ static struct sexp_type_struct _sexp_type_specs[] = {
   _DEF_TYPE(SEXP_BYTECODE, sexp_offsetof(bytecode, name), 3, 3, 0, 0, sexp_sizeof(bytecode), offsetof(struct sexp_struct, value.bytecode.length), 1, "bytecode", NULL),
   _DEF_TYPE(SEXP_CORE, 0, 0, 0, 0, 0, sexp_sizeof(core), 0, 0, "core-form", NULL),
   _DEF_TYPE(SEXP_OPCODE, sexp_offsetof(opcode, data), 3, 3, 0, 0, sexp_sizeof(opcode), 0, 0, "opcode", NULL),
-  _DEF_TYPE(SEXP_LAMBDA, sexp_offsetof(lambda, name), 9, 9, 0, 0, sexp_sizeof(lambda), 0, 0, "lambda", NULL),
+  _DEF_TYPE(SEXP_LAMBDA, sexp_offsetof(lambda, name), 11, 11, 0, 0, sexp_sizeof(lambda), 0, 0, "lambda", NULL),
   _DEF_TYPE(SEXP_CND, sexp_offsetof(cnd, test), 4, 4, 0, 0, sexp_sizeof(cnd), 0, 0, "conditional", NULL),
   _DEF_TYPE(SEXP_REF, sexp_offsetof(ref, name), 3, 3, 0, 0, sexp_sizeof(ref), 0, 0, "reference", NULL),
   _DEF_TYPE(SEXP_SET, sexp_offsetof(set, var), 3, 3, 0, 0, sexp_sizeof(set), 0, 0, "set!", NULL),