conservatory
/
picrin
4
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

WIP: add compiler

This commit is contained in:
Yuichi Nishiwaki 2017-04-05 16:18:00 +09:00
parent c1a7f6d2d8
commit 1e345d8228
3 changed files with 1272 additions and 816 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
contrib/60.repl/repl.scm
View File

@ -35,6 +35,7 @@
(scheme time)
(scheme eval)
(scheme r5rs)
(picrin pretty-print)
(picrin macro))
'(picrin user)))

1312
lib/ext/boot.c
View File

File diff suppressed because it is too large Load Diff

317
piclib/compile.scm
View File

@ -1,3 +1,7 @@
(begin
;; expand
(define-values (make-identifier
identifier?
identifier=?
@ -10,8 +14,7 @@
add-identifier!
set-identifier!
macro-objects
compile
eval)
expand)
(let ()
;; identifier
@ -227,20 +230,27 @@
expand))
;; compile
(values make-identifier
identifier?
identifier=?
identifier-name
identifier-environment
make-environment
default-environment
environment?
find-identifier
add-identifier!
set-identifier!
macro-objects
expand)))
(define (compile expr . env)
(expand expr (if (null? env) default-environment (car env))))
;; eval
(define (eval expr . env)
(load (compile expr (if (null? env) default-environment (car env)))))
;; built-in macros
(let ()
(define (define-transformer name transformer)
(dictionary-set! global-macro-table name transformer))
(dictionary-set! (macro-objects) name transformer))
(define (the var)
(make-identifier var default-environment))
@ -601,20 +611,275 @@
(,the-if (,pred obj)
(,(the 'vector-set!) (,(the 'record-datum) obj) ,pos value)
(,(the 'error) "record type mismatch" obj ',type))))))))
(loop (cdr fields) (+ pos 1) `(,@defs . ,acc)))))))))))
(loop (cdr fields) (+ pos 1) `(,@defs . ,acc))))))))))))
(values make-identifier
identifier?
identifier=?
identifier-name
identifier-environment
make-environment
default-environment
environment?
find-identifier
add-identifier!
set-identifier!
macro-objects
compile
eval)))
;; compile
(define-values (compile)
(let ()
(define (caddr x) (car (cddr x)))
(define (cadddr x) (cadr (cddr x)))
(define (max a b) (if (< a b) b a))
(define (integer? n) (and (number? n) (exact? n)))
(define normalize
(let ((defs (make-parameter '())))
;; 1. remove core# prefix from keywords
;; 2. eliminates internal definitions by replacing with equivalent let & set!
;; 3. transform a var into (ref var)
;; 4. wrap raw constants with quote
;; TODO: warn redefinition, warn duplicate variables
(define (normalize e)
(cond
((symbol? e) `(ref ,e))
((not (pair? e)) `(quote ,e))
(else
(case (car e)
((core#quote) `(quote . ,(cdr e)))
((core#define)
(let ((var (cadr e)) (val (caddr e)))
(defs (cons var (defs)))
`(set! ,var ,(normalize val))))
((core#lambda)
(let ((args (cadr e)) (body (caddr e)))
(parameterize ((defs '()))
(let ((body (normalize body)))
(if (null? (defs))
`(lambda ,args ,body)
`(lambda ,args
((lambda ,(defs) ,body) ,@(map (lambda (_) #f) (defs)))))))))
((core#set!) `(set! . ,(map normalize (cdr e))))
((core#if) `(if . ,(map normalize (cdr e))))
((core#begin) `(begin . ,(map normalize (cdr e))))
(else
(map normalize e))))))
normalize))
(define transform
(let ()
;; tail-conscious higher-order CPS transformation
;; target language
;; E ::= A
;; | (if A E E)
;; | (set! v A E)
;; | (A A ...)
;; A ::= (lambda (var ...) E)
;; | (ref v)
;; | (quote x)
;; | (undefined)
(define uniq
(let ((n 0))
(lambda ()
(set! n (+ n 1))
(string->symbol
(string-append "$" (number->string n))))))
(define (transform-k e k)
(case (car e)
((ref lambda quote) (k (transform-v e)))
((begin) (transform-k (cadr e)
(lambda (_)
(transform-k (caddr e) k))))
((set!) (transform-k (caddr e)
(lambda (v)
`(set! ,(cadr e) ,v ,(k '(undefined))))))
((if) (let ((v (uniq))
(c `(ref ,(uniq))))
`((lambda (,c)
,(transform-k (cadr e)
(lambda (x)
`(if ,x
,(transform-c (caddr e) c)
,(transform-c (cadddr e) c)))))
(lambda (,v) ,(k `(ref ,v))))))
(else
(let* ((v (uniq))
(c `(lambda (,v) ,(k `(ref ,v)))))
(transform-k (car e)
(lambda (f)
(transform*-k (cdr e)
(lambda (args)
`(,f ,c ,@args)))))))))
(define (transform*-k es k)
(if (null? es)
(k '())
(transform-k (car es)
(lambda (x)
(transform*-k (cdr es)
(lambda (xs)
(k (cons x xs))))))))
(define (transform-c e c)
(case (car e)
((ref lambda quote) `(,c ,(transform-v e)))
((begin) (transform-k (cadr e)
(lambda (_)
(transform-c (caddr e) c))))
((set!) (transform-k (caddr e)
(lambda (v)
`(set! ,(cadr e) ,v (,c (undefined))))))
((if) (if (and (pair? c) (eq? 'lambda (car c)))
(let ((k `(ref ,(uniq))))
`((lambda (,k)
,(transform-k (cadr e)
(lambda (x)
`(if ,x
,(transform-c (caddr e) k)
,(transform-c (cadddr e) k)))))
,c))
(transform-k (cadr e)
(lambda (x)
`(if ,x
,(transform-c (caddr e) c)
,(transform-c (cadddr e) c))))))
(else
(transform-k (car e)
(lambda (f)
(transform*-k (cdr e)
(lambda (args)
`(,f ,c ,@args))))))))
(define (transform-v e)
(case (car e)
((ref quote) e)
((lambda)
(let ((k (uniq)))
`(lambda (,k ,@(cadr e)) ,(transform-c (caddr e) `(ref ,k)))))))
(lambda (e)
(let ((k (uniq)))
`(lambda (,k) ,(transform-c e `(ref ,k)))))))
(define codegen
(let ()
;; TODO: check range of index/depth/frame_size/irepc/objc
(define (lookup var env)
(let up ((depth 0) (env env))
(if (null? env)
`(global ,var)
(let loop ((index 1) (binding (car env)))
(if (symbol? binding)
(if (eq? var binding)
`(local ,depth ,index)
(up (+ depth 1) (cdr env)))
(if (null? binding)
(up (+ depth 1) (cdr env))
(if (eq? var (car binding))
`(local ,depth ,index)
(loop (+ index 1) (cdr binding)))))))))
(define env (make-parameter '()))
(define code (make-parameter '()))
(define reps (make-parameter '()))
(define objs (make-parameter '()))
(define (emit inst)
(code (cons inst (code))))
(define (emit-irep irep)
(let ((n (length (reps))))
(reps (cons irep (reps)))
n))
(define (emit-objs obj) ; TODO remove duplicates
(let ((n (length (objs))))
(objs (cons obj (objs)))
n))
(define make-label
(let ((n 0))
(lambda ()
(let ((m n))
(set! n (+ n 1))
m))))
(define (emit-label label)
(code (cons label (code))))
(define (codegen-e e)
(case (car e)
((ref lambda quote undefined) (codegen-a e 0))
((set!) (begin
(codegen-a (caddr e) 0)
(let* ((x (lookup (cadr e) (env)))
(op (if (eq? 'global (car x)) 'GSET 'LSET)))
(emit `(,op 0 . ,(cdr x))))
(codegen-e (cadddr e))))
((if) (begin
(codegen-a (cadr e) 0)
(let ((label (make-label)))
(emit `(COND 0 ,label))
(codegen-e (caddr e))
(emit-label label)
(codegen-e (cadddr e)))))
(else (begin
(let loop ((i 0) (e e))
(unless (null? e)
(codegen-a (car e) i)
(loop (+ i 1) (cdr e))))
(emit `(CALL ,(length e)))))))
(define (codegen-a e i)
(case (car e)
((ref) (let* ((x (lookup (cadr e) (env)))
(op (if (eq? 'global (car x)) 'GREF 'LREF)))
(emit `(,op ,i . ,(cdr x)))))
((quote) (let ((obj (cadr e)))
(cond ((eq? #t obj) (emit `(LOADT ,i)))
((eq? #f obj) (emit `(LOADF ,i)))
((null? obj) (emit `(LOADN ,i)))
((and (integer? obj) (<= -128 obj 127)) (emit `(LOADI ,i ,obj)))
(else (let ((n (emit-obj obj)))
(emit `(LOAD ,i ,n)))))))
((undefined) (emit `(LOADU ,i)))
((lambda) (let ((frame-size
(let loop ((e (caddr e)))
(case (car e)
((ref lambda quote undefined) 1)
((if) (max (loop (caddr e)) (loop (cadddr e))))
((set!) (loop (cadddr e)))
(else (+ 1 (length e))))))
(argc-varg
(let loop ((args (cadr e)) (c 0))
(if (symbol? args)
(cons (+ 1 c) #t)
(if (null? args)
(cons c #f)
(loop (cdr args) (+ 1 c)))))))
(let ((irep
(parameterize ((code '())
(env (cons (cadr e) (env)))
(reps '())
(objs '()))
(codegen-e (caddr e))
(list (reverse (code)) (reverse (reps)) (reverse (objs)) argc-varg frame-size))))
(let ((n (emit-irep irep)))
(emit `(PROC ,i ,n))))))))
(lambda (e)
(parameterize ((code '()) (env '()) (reps '()) (objs '()))
(codegen-e e)
(car (reps))))))
(lambda (e)
(codegen (transform (normalize e))))))
;; eval
(define (eval expr . env)
(load (expand expr (if (null? env) default-environment (car env))))))