From db72ce00553df81a3289c19feba69c5efedcfe08 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Mon, 13 Jun 2011 20:54:27 +0900 Subject: [PATCH] adding experimental rest-arguments optimization --- Makefile | 3 +- lib/chibi/optimize.module | 7 ++ lib/chibi/optimize.scm | 52 ++++++++++++++ lib/chibi/optimize/rest.c | 31 ++++++++ lib/chibi/optimize/rest.module | 6 ++ lib/chibi/optimize/rest.scm | 126 +++++++++++++++++++++++++++++++++ 6 files changed, 224 insertions(+), 1 deletion(-) create mode 100644 lib/chibi/optimize.module create mode 100644 lib/chibi/optimize.scm create mode 100644 lib/chibi/optimize/rest.c create mode 100644 lib/chibi/optimize/rest.module create mode 100644 lib/chibi/optimize/rest.scm diff --git a/Makefile b/Makefile index dba4a9fd..5e9675ac 100644 --- a/Makefile +++ b/Makefile @@ -119,7 +119,8 @@ COMPILED_LIBS := lib/srfi/18/threads$(SO) lib/srfi/27/rand$(SO) \ lib/srfi/95/qsort$(SO) lib/srfi/98/env$(SO) lib/chibi/net$(SO) \ lib/chibi/filesystem$(SO) lib/chibi/process$(SO) lib/chibi/time$(SO) \ lib/chibi/system$(SO) lib/chibi/io/io$(SO) lib/chibi/stty$(SO) \ - lib/chibi/weak$(SO) lib/chibi/heap-stats$(SO) lib/chibi/disasm$(SO) + lib/chibi/weak$(SO) lib/chibi/heap-stats$(SO) lib/chibi/disasm$(SO) \ + lib/chibi/optimize/rest$(SO) libs: $(COMPILED_LIBS) diff --git a/lib/chibi/optimize.module b/lib/chibi/optimize.module new file mode 100644 index 00000000..9374112e --- /dev/null +++ b/lib/chibi/optimize.module @@ -0,0 +1,7 @@ + +(module (chibi optimize) + (import (scheme) (chibi ast) (chibi match) (srfi 1)) + (export register-lambda-optimization! + replace-references + fold-every join-seq dotted-tail) + (include "optimize.scm")) diff --git a/lib/chibi/optimize.scm b/lib/chibi/optimize.scm new file mode 100644 index 00000000..dc3b3f9a --- /dev/null +++ b/lib/chibi/optimize.scm @@ -0,0 +1,52 @@ + +(define (register-lambda-optimization! proc . o) + (define (optimize ast) + (match ast + (($ Set ref value) + (make-set ref (optimize value))) + (($ Cnd test pass fail) + (make-cnd (optimize test) (optimize pass) (optimize fail))) + (($ Seq ls) + (make-seq (map optimize ls))) + (($ Lam name params body) + (lambda-body-set! ast (optimize body)) + (proc ast)) + ((app ...) + (map optimize app)) + (else + ast))) + (register-optimization! optimize (if (pair? o) (car o) 600))) + +(define (replace-references ast name lam new) + (let replace ((x ast)) + (match x + (($ Ref _ (n . (? lambda? f))) + (if (and (eq? n name) (eq? f lam)) + new + x)) + (($ Set ref value) + (make-set (replace ref) (replace value))) + (($ Cnd test pass fail) + (make-cnd (replace test) (replace pass) (replace fail))) + (($ Seq ls) + (make-seq (map replace ls))) + (($ Lam name params body) + (lambda-body-set! x (replace body)) + x) + ((app ...) + (map replace app)) + (else + x)))) + +(define (join-seq a b) + (make-seq (append (if (seq? a) (seq-ls a) (list a)) + (if (seq? b) (seq-ls b) (list b))))) + +(define (dotted-tail ls) + (if (pair? ls) (dotted-tail (cdr ls)) ls)) + +(define (fold-every kons knil ls) + (if (null? ls) + knil + (let ((knil (kons (car ls) knil))) + (and knil (fold-every kons knil (cdr ls)))))) diff --git a/lib/chibi/optimize/rest.c b/lib/chibi/optimize/rest.c new file mode 100644 index 00000000..a7cea829 --- /dev/null +++ b/lib/chibi/optimize/rest.c @@ -0,0 +1,31 @@ +/* rest.c -- low-level utilities for VM rest optimization */ +/* Copyright (c) 2011 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#include + +static sexp sexp_num_parameters (sexp ctx sexp_api_params(self, n)) { + return sexp_stack_data(sexp_context_stack(ctx))[sexp_context_last_fp(ctx)]; +} + +struct sexp_opcode_struct local_ref_op = + {SEXP_OPC_GENERIC, SEXP_OP_LOCAL_REF, 1, 8, 0, "local-ref", NULL, NULL, + NULL, sexp_make_fixnum(SEXP_OBJECT), sexp_make_fixnum(SEXP_FIXNUM), + 0, 0, NULL}; + +static sexp sexp_copy_opcode (sexp ctx, struct sexp_opcode_struct *op) { + sexp res = sexp_alloc_type(ctx, opcode, SEXP_OPCODE); + memcpy(&(res->value), op, sizeof(op[0])); + return res; +} + +sexp sexp_init_library (sexp ctx sexp_api_params(self, n), sexp env) { + sexp_gc_var2(name, op); + sexp_gc_preserve2(ctx, name, op); + sexp_define_foreign(ctx, env, "num-parameters", 0, sexp_num_parameters); + op = sexp_copy_opcode(ctx, &local_ref_op); + name = sexp_intern(ctx, sexp_opcode_name(op), -1); + sexp_env_define(ctx, env, name, op); + sexp_gc_release2(ctx); + return SEXP_VOID; +} diff --git a/lib/chibi/optimize/rest.module b/lib/chibi/optimize/rest.module new file mode 100644 index 00000000..a65f8115 --- /dev/null +++ b/lib/chibi/optimize/rest.module @@ -0,0 +1,6 @@ + +(module (chibi optimize rest) + (export optimize-rest rest-parameter-cdrs num-parameters local-ref) + (import (scheme) (srfi 1) (chibi ast) (chibi match) (chibi optimize)) + (include-shared "rest") + (include "rest.scm")) diff --git a/lib/chibi/optimize/rest.scm b/lib/chibi/optimize/rest.scm new file mode 100644 index 00000000..90df782d --- /dev/null +++ b/lib/chibi/optimize/rest.scm @@ -0,0 +1,126 @@ + +(define (optimize-rest ast) + (cond + ((and (lambda? ast) + (not (list? (lambda-params ast))) + (rest-parameter-cdrs ast)) + => (lambda (cdrs) + (replace-rest-destructuring-with-stack-references + (length (lambda-params ast)) + ast + cdrs))) + (else + ast))) + +(define safe-primitives (list car cdr null? pair?)) + +(define (adjust-cdrs cdrs f params args) + (filter-map + (lambda (p a) + (match a + (((? (lambda (op) (eq? op cdr))) ($ Ref name (_ . (? lambda? lam)))) + (let ((x (any (lambda (r) + (and (eq? name (car r)) (eq? lam (cadr r)))) + cdrs))) + (and x (list p f (+ (caddr x) 1))))) + (($ Cnd + ((? (lambda (op) (eq? op pair?))) ($ Ref name (_ . (? lambda? lam)))) + ((? (lambda (op) (eq? op cdr))) ($ Ref name (_ . (? lambda? lam)))) + (or () ($ Lit ()))) + (let ((x (any (lambda (r) + (and (eq? name (car r)) (eq? lam (cadr r)))) + cdrs))) + (and x (list p f (+ (caddr x) 1.0))))) + (else #f))) + params + args)) + +(define (rest-parameter-cdrs ast) + (let analyze ((x (lambda-body ast)) + (cdrs (list (list (dotted-tail (lambda-params ast)) ast 0))) + (safe? #t)) + (define (recurse x cdrs) (analyze x cdrs safe?)) + (match x + (($ Ref name (_ . (? lambda? f))) + (and (not (any (lambda (r) (and (eq? name (car r)) (eq? f (cadr r)))) cdrs)) + cdrs)) + (($ Set ref value) + (and (recurse ref cdrs) (recurse value cdrs))) + (($ Cnd test pass fail) + (fold-every recurse cdrs (list test pass fail))) + (($ Seq ls) + (fold-every recurse cdrs ls)) + (($ Lam name params body) + (analyze body cdrs #f)) + (((and ($ Lam _ (params ...) body) f) args ...) + (let ((cdrs (fold-every recurse cdrs args))) + (and (equal? (length params) (length args)) + (recurse body (append (adjust-cdrs cdrs f params args) cdrs))))) + (((? opcode? op) ($ Ref _ (_ . (? lambda?)))) + (if (and safe? (memq op safe-primitives)) + cdrs + (recurse (cadr x) cdrs))) + ((app ...) + (fold-every recurse cdrs app)) + (else + cdrs)))) + +(define (replace-rest-destructuring-with-stack-references base ast cdrs) + (define (rename p) + (make-syntactic-closure + (current-environment) '() (strip-syntactic-closures p))) + (define (replace-param x) + (match x + (($ Cnd test pass fail) + (make-cnd (replace-param test) + (replace-param pass) + (replace-param fail))) + (($ Seq ls) + (let ((ls (map replace-param ls))) + (and ls (make-seq ls)))) + (((? opcode? op) ($ Ref name (_ . (? lambda? f)))) + (let ((r (and (memq op safe-primitives) + (any (lambda (r) (and (eq? name (car r)) (eq? f (cadr r)))) + cdrs)))) + (cond + ((not r) + x) + ((eq? op car) + `(,local-ref ,(+ 1 (inexact->exact (caddr r))))) + ((eq? op cdr) + (make-lit '())) + ((eq? op pair?) + `(,> (,num-parameters) ,(+ base (inexact->exact (caddr r))))) + ((eq? op null?) + `(,<= (,num-parameters) ,(+ base (inexact->exact (caddr r))))) + (else + x)))) + (($ Set ref value) + #f) + (($ Lam name params body) + #f) + ((app ...) + #f) + (else + x))) + (lambda-body-set! + ast + (let replace ((x (lambda-body ast))) + (match x + ((($ Lam name (params ...) body) args ...) + (let* ((locals (map replace-param args)) + (names (map rename params)) + (refs (map (lambda (name) (make-ref name (cons name ast))) names))) + (let ((res (fold (lambda (p new res) + (replace-references res p (car x) new)) + (replace body) + params + refs))) + (lambda-locals-set! ast (append names (lambda-locals ast))) + (join-seq (make-seq (map make-set refs locals)) + res)))) + (else + x)))) + ast) + +(register-lambda-optimization! optimize-rest)