--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/compile.scm Thu Mar 31 01:25:02 2005 +1200
@@ -0,0 +1,238 @@
+;; Compile AST to a set of prototype methods and blocks.
+
+(define-record-type compilation-state
+ (make-compilation-state* next-literal rev-literals)
+ compilation-state?
+ (next-literal compilation-state-next-literal)
+ (rev-literals compilation-state-rev-literals))
+
+(define (make-compilation-state)
+ (make-compilation-state* 0 '()))
+
+(define (push-literal state val)
+ (let ((i (compilation-state-next-literal state)))
+ (values i
+ (make-compilation-state* (+ i 1)
+ (cons val (compilation-state-rev-literals state))))))
+
+(define (finish-compilation-state state)
+ (list->vector (reverse (compilation-state-rev-literals state))))
+
+(define *all-method-code-prologues* '())
+(define *invocation-count-decay-half-life* 15) ;; seconds
+(define *invocation-count-update-interval* 4) ;; seconds
+(define *recompilation-count-limit* 1000)
+
+(define (instruction->code instr is-closure)
+ (let ((prologue (vector 0 (if is-closure *true* *false*))))
+ (let ((locative (make-weak-locative prologue 0)))
+ (push! *all-method-code-prologues* locative))
+ (cons prologue instr)))
+
+(define (invocation-count-decay-constant)
+ (exp (/ (log 2)
+ (/ *invocation-count-decay-half-life* *invocation-count-update-interval*))))
+
+(define (decay-invocation-counts!)
+ (debug 0 "Decaying invocation counts...")
+ (let ((decay-constant (invocation-count-decay-constant)))
+ (set! *all-method-code-prologues*
+ (filter! (lambda (locative)
+ (let ((prologue (locative->object locative)))
+ (if prologue
+ (vector-set! prologue 0 (/ (vector-ref prologue 0) decay-constant)))
+ prologue))
+ *all-method-code-prologues*))))
+
+(define (bump-invocation-count! prologue method)
+ (let ((invocation-count (+ (vector-ref prologue 0) 1)))
+ (vector-set! prologue 0 invocation-count)
+ (if (>= invocation-count *recompilation-count-limit*)
+ (begin
+ (vector-set! prologue 0 0)
+ (recompile-method! method)))))
+
+(define compile-ThiNG
+ (let ()
+ (define (do-ref cenv state name)
+ (let* ((name (string->symbol name)))
+ (values (cond ((memq name cenv) `#(local ,name))
+ (else `#(global ,name)))
+ state)))
+
+ (define (compile-tuple cenv state exprs)
+ (let loop ((exprs exprs)
+ (state state)
+ (acc '()))
+ (if (null? exprs)
+ (values (list->vector (reverse acc)) state)
+ (let*-values (((instr state) (compile cenv state (car exprs))))
+ (loop (cdr exprs)
+ state
+ (cons instr acc))))))
+
+ (define (do-send cenv state selector exprs)
+ (let-values (((selector) (string->symbol selector))
+ ((instrs state) (compile-tuple cenv state exprs)))
+ (values `#(send ,selector ,instrs)
+ state)))
+
+ (define (do-block cenv state binders statements)
+ (let* ((block (clone-object *block*))
+ (num-formals (length binders))
+ (formals (map string->symbol binders))
+ (formal-cenv (append (cons '_ formals) cenv))
+ (selector (if (zero? num-formals)
+ 'do
+ (string->symbol
+ (string-concatenate (cons "applyWith:"
+ (make-list (- num-formals 1) "with:")))))))
+ (let*-values (((instr block-state)
+ (compile formal-cenv (make-compilation-state)
+ `(scope ,*nil* ,statements)))
+ ((litvec) (finish-compilation-state block-state))
+ ((method) (define-method! selector (cons '_ formals) (list block)
+ (instruction->code instr #t)))
+ ((block-index state) (push-literal state block)))
+ (set-slot! method 'literals litvec)
+ (values `#(closure ,block-index)
+ state))))
+
+ (define (do-scope cenv state name statements)
+ (if (eq? *nil* name)
+ (let-values (((instrs state) (compile-statements cenv state statements)))
+ (values `#(begin ,instrs)
+ state))
+ (let*-values (((name) (string->symbol name))
+ ((instrs state) (compile-statements (cons name cenv) state statements)))
+ (values `#(scope ,name ,instrs)
+ state))))
+
+ (define (do-literal cenv state val)
+ (let-values (((index state) (push-literal state val)))
+ (values `#(literal ,index)
+ state)))
+
+ (define (do-update cenv state template-expr updates)
+ (let*-values (((template-instr state) (compile cenv state template-expr))
+ ((updates state)
+ (let loop ((updates updates)
+ (state state)
+ (acc '()))
+ (if (null? updates)
+ (values (list->vector (reverse acc)) state)
+ (let*-values (((update) (car updates))
+ ((update-instr state)
+ (compile cenv state (caddr update))))
+ (loop (cdr updates)
+ state
+ (cons (vector (car update)
+ (string->symbol (cadr update))
+ update-instr)
+ acc)))))))
+ (values `#(update ,template-instr ,updates)
+ state)))
+
+ (define (do-tuple cenv state exprs)
+ (let-values (((instrs state) (compile-tuple cenv state exprs)))
+ (values `#(tuple ,instrs)
+ state)))
+
+ (define (do-resend cenv state)
+ (values `#(resend)
+ state))
+
+ (define (do-method cenv state pattern statements)
+ (let* ((selector (string->symbol (cadr pattern)))
+ (params (caddr pattern))
+ (formals (map (lambda (entry) (string->symbol (or (non-*false*? (car entry))
+ "_")))
+ params)))
+ (let*-values (((specializer-instrs state)
+ (compile-tuple cenv state (map (lambda (entry)
+ (let ((exp (cadr entry)))
+ (if (non-*false*? exp)
+ exp
+ `(ref "NoRole"))))
+ params)))
+ ((body-instr method-state)
+ (compile formals (make-compilation-state) `(scope ,*nil* ,statements)))
+ ((method-litvec) (finish-compilation-state method-state)))
+ (values `#(method ,selector ,formals ,specializer-instrs
+ ,(instruction->code body-instr #f)
+ ,method-litvec)
+ state))))
+
+ (define (compile-statement cenv state statement)
+ (if (and (pair? statement)
+ (eq? (car statement) 'let))
+ (let* ((name (string->symbol (cadr statement)))
+ (expr (caddr statement))
+ (newenv (cons name cenv)))
+ (let-values (((instr state) (compile newenv state expr)))
+ (values `#(bind ,name ,instr)
+ newenv
+ state)))
+ (let-values (((instr state) (compile cenv state statement)))
+ (values instr cenv state))))
+
+ (define (compile-statements cenv state statements)
+ (let loop ((cenv cenv)
+ (state state)
+ (statements statements)
+ (acc '()))
+ (if (null? statements)
+ (values (list->vector (reverse acc))
+ state)
+ (let-values (((instr cenv state) (compile-statement cenv state (car statements))))
+ (loop cenv
+ state
+ (cdr statements)
+ (cons instr acc))))))
+
+ (define (compile cenv state ast)
+ (debug 1 "compile "ast" "cenv)
+ (cond
+ ((pair? ast)
+ (apply (cond
+ ((assq (car ast) `((ref ,do-ref)
+ (send ,do-send)
+ (block ,do-block)
+ (scope ,do-scope)
+ (string ,do-literal)
+ (symbol ,do-literal)
+ (number ,do-literal)
+ (update ,do-update)
+ (tuple ,do-tuple)
+ (resend ,do-resend)
+ (method ,do-method)
+ )) => cadr)
+ (else (error "Unknown ast kind" ast)))
+ cenv state
+ (cdr ast)))
+ (else (error "Non-pair ast" ast))))
+
+ (lambda (ast)
+ (let-values (((instr state) (compile '() (make-compilation-state) ast)))
+ (values instr
+ (finish-compilation-state state))))))
+
+(define (instruction-vector-size seed instr-vec)
+ (vector-fold (lambda (instr acc) (+ (instruction-size instr) acc)) seed instr-vec))
+
+(define (instruction-size instr)
+ (case (vector-ref instr 0)
+ ((local global closure literal resend) 1)
+ ((send) (instruction-vector-size 1 (vector-ref instr 2)))
+ ((begin) (instruction-vector-size 0 (vector-ref instr 1)))
+ ((scope) (instruction-vector-size 0 (vector-ref instr 2)))
+ ((update) (instruction-vector-size 1 (vector-ref instr 2)))
+ ((tuple) (instruction-vector-size 1 (vector-ref instr 1)))
+ ((method) 1) ;; not quite correct, but mneh. until the macro is expanded properly, will do.
+ (else (error "Illegal instruction in instruction-size" instr))))
+
+(define (recompile-method! method)
+ (let ((instr (cdr (get-slot method 'code))))
+ (pretty-print `(recompile-method!
+ (size ,(instruction-size instr))
+ (instr ,instr)))))