diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h index 7adb008c..1012870f 100644 --- a/include/chibi/sexp.h +++ b/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) diff --git a/lib/chibi/ast.c b/lib/chibi/ast.c index 323d685e..3a0be629 100644 --- a/lib/chibi/ast.c +++ b/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) { - return sexp_analyze(ctx, x); +static sexp sexp_analyze_op (sexp ctx sexp_api_params(self, n), sexp x, sexp e) { + 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; } diff --git a/lib/chibi/ast.module b/lib/chibi/ast.module index 7fdbcd85..53e7e0bb 100644 --- a/lib/chibi/ast.module +++ b/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")) diff --git a/lib/chibi/macroexpand.module b/lib/chibi/macroexpand.module deleted file mode 100644 index c9a3fd8c..00000000 --- a/lib/chibi/macroexpand.module +++ /dev/null @@ -1,6 +0,0 @@ - -(define-module (chibi macroexpand) - (import-immutable (scheme)) - (import (chibi ast)) - (export macroexpand ast->sexp) - (include "macroexpand.scm")) diff --git a/lib/chibi/macroexpand.scm b/lib/chibi/macroexpand.scm deleted file mode 100644 index 81cb566f..00000000 --- a/lib/chibi/macroexpand.scm +++ /dev/null @@ -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))))) - diff --git a/lib/chibi/modules.module b/lib/chibi/modules.module index dd00c3b1..0d20861e 100644 --- a/lib/chibi/modules.module +++ b/lib/chibi/modules.module @@ -1,5 +1,8 @@ (define-module (chibi modules) - (export analyze-module) - (import-immutable (scheme) (config) (chibi ast)) + (export analyze-module module-ast module-ast-set! + module-ref module-contains? containing-module + procedure-analysis) + (import-immutable (scheme) (config)) + (import (chibi ast)) (include "modules.scm")) diff --git a/lib/chibi/modules.scm b/lib/chibi/modules.scm index f17f0cd1..3e85d40c 100644 --- a/lib/chibi/modules.scm +++ b/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 -;; the module analyzed +(define (module? x) (vector? x)) + +(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)))))) - (let go ((name name)) - (let ((env (make-environment)) - (dir (module-name-prefix name))) - (define (load-modules files extension) - (for-each - (lambda (f) - (let ((f (string-append dir f extension))) - (cond ((find-module-file f) => (lambda (x) (load x env))) - (else (error "couldn't find include" f))))) - files)) - (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)))) - (cond - ((assoc name modules) => cdr) - (else - (let ((mod (find-module name))) - (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 (load-module (car mod2-name+imports)))) - (%env-copy! env (module-env mod2) (cdr mod2-name+imports) - (eq? (caar ls) 'import-immutable)))) - (cdar ls)) - (lp (cdr ls) res)) - ((include) - (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))))))))))))) + (res (load-module name))) + (if (not (module-ast res)) + (module-ast-set! res (analyze-module-source name res recursive?))) + res)) + +(define (module-ref mod var-name . o) + (let ((cell (env-cell (module-env (if (module? mod) mod (load-module mod))) + var-name))) + (if cell + (cdr cell) + (if (pair? o) (car o) (error "no binding in module" mod var-name))))) + +(define (module-contains? mod var-name) + (and (env-cell (module-env (if (module? mod) mod (load-module mod))) var-name) + #t)) + +(define (containing-module x) + (let lp1 ((ls *modules*)) + (and (pair? ls) + (let ((env (module-env (cdar ls)))) + (let lp2 ((e-ls (env-exports env))) + (cond ((null? e-ls) (lp1 (cdr ls))) + ((eq? x (cdr (env-cell env (car e-ls)))) (car ls)) + (else (lp2 (cdr e-ls))))))))) + +(define (procedure-analysis x) + (let ((mod (containing-module x))) + (and mod + (let lp ((ls (module-ast (analyze-module (car mod))))) + (and (pair? ls) + (if (and (set? (car ls)) + (eq? (procedure-name x) (ref-name (set-var (car ls))))) + (set-value (car ls)) + (lp (cdr ls)))))))) + diff --git a/lib/chibi/repl.module b/lib/chibi/repl.module index 4db9a267..5c1035a7 100644 --- a/lib/chibi/repl.module +++ b/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")) diff --git a/lib/config.scm b/lib/config.scm index ee35e1dd..55a4e1e0 100644 --- a/lib/config.scm +++ b/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) diff --git a/sexp.c b/sexp.c index d976a147..3e64553e 100644 --- a/sexp.c +++ b/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),