diff --git a/debug/compilation/simple.scm b/debug/compilation/simple.scm new file mode 100644 index 00000000..9539e90d --- /dev/null +++ b/debug/compilation/simple.scm @@ -0,0 +1,15 @@ +;; Experimenting with primitives and continuations. +;; There are several primitives that do not require conts. Can we +;; compile them in such as way that they are not wrapped in a cont? +;; idea is to reduce compiled code, and number of allocated closures. +(import + (scheme base) + (scheme write)) + +(define (test a b c) + (write + (cons + (+ a b c) + (- a b c)))) + +(test 1 2 3) diff --git a/debug/compilation/tmp.scm b/debug/compilation/tmp.scm new file mode 100644 index 00000000..fd763223 --- /dev/null +++ b/debug/compilation/tmp.scm @@ -0,0 +1,135 @@ +(import + (scheme base) + (scheme cyclone util) + (scheme cyclone transforms)) + +(define (my-cps-convert ast) + + (define (cps ast cont-ast) + (cond + ((const? ast) + (list cont-ast ast)) + + ((ref? ast) + (list cont-ast ast)) + + ((quote? ast) + (list cont-ast ast)) + + ((set!? ast) + (cps-list (cddr ast) ;; expr passed to set + (lambda (val) + (list cont-ast + `(set! ,(cadr ast) ,@val))))) ;; cadr => variable + + ((if? ast) + (let ((xform + (lambda (cont-ast) + (cps-list (list (cadr ast)) + (lambda (test) + (list 'if + (car test) + (cps (caddr ast) + cont-ast) + (cps (cadddr ast) + cont-ast))))))) + (if (ref? cont-ast) ; prevent combinatorial explosion + (xform cont-ast) + (let ((k (gensym 'k))) + (list (list 'lambda + (list k) + (xform k)) + cont-ast))))) + + ((prim-call? ast) + (cps-list (cdr ast) ; args to primitive function + (lambda (args) + (list cont-ast + `(,(car ast) ; op + ,@args))))) + + ((lambda? ast) + (let ((k (gensym 'k)) + (ltype (lambda-formals-type ast))) + (list cont-ast + `(lambda + ,(list->lambda-formals + (cons k (cadr ast)) ; lam params + (if (equal? ltype 'args:varargs) + 'args:fixed-with-varargs ;; OK? promote due to k + ltype)) + ,(cps-seq (cddr ast) k))))) + + ((app? ast) + (let ((fn (app->fun ast))) + (cond + ((lambda? fn) + (cps-list (app->args ast) + (lambda (vals) + (cons (list + 'lambda + (lambda->formals fn) + (cps-seq (cddr fn) ;(ast-subx fn) + cont-ast)) + vals)))) + (else + (cps-list ast ;(ast-subx ast) + (lambda (args) + (cons (car args) + (cons cont-ast + (cdr args))))))))) + + (else + (error "unknown ast" ast)))) + + (define (cps-list asts inner) + (define (body x) + (cps-list (cdr asts) + (lambda (new-asts) + (inner (cons x new-asts))))) + + (cond ((null? asts) + (inner '())) + ((or (const? (car asts)) + (ref? (car asts))) + (body (car asts))) + (else + (let ((r (gensym 'r))) + (cps (car asts) + `(lambda (,r) ,(body r))))))) + + (define (cps-seq asts cont-ast) + (cond ((null? asts) + (list cont-ast #f)) + ((null? (cdr asts)) + (cps (car asts) cont-ast)) + (else + (let ((r (gensym 'r))) + (cps (car asts) + `(lambda + (,r) + ,(cps-seq (cdr asts) cont-ast))))))) + + ;; Remove dummy symbol inserted into define forms converted to CPS + (define (remove-unused ast) + (list (car ast) (cadr ast) (cadddr ast))) + + (let* ((global-def? (define? ast)) ;; No internal defines by this phase + (ast-cps + (cond + (global-def? + (remove-unused + `(define ,(define->var ast) + ,@(let ((k (gensym 'k)) + (r (gensym 'r))) + (cps (car (define->exp ast)) 'unused))))) + ((define-c? ast) + ast) + (else + (cps ast '%halt))))) + ast-cps)) + +(trace:error + (my-cps-convert + '((define test (lambda (a$3 b$2 c$1) (write (cons (+ a$3 b$2 c$1) (- a$3 b$2 c$1))))) ((lambda () 0 (test 1 2 3)))) +))