diff --git a/scmvm/language/scheme.scm b/scmvm/language/scheme.scm index 26ea99a..dfcc198 100644 --- a/scmvm/language/scheme.scm +++ b/scmvm/language/scheme.scm @@ -3,7 +3,12 @@ #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:use-module (ice-9 match) - #:export (compile decompile ir-convert)) + #:use-module ((rnrs base) + #:version (6) + #:select (assert)) + #:export (desugar-prgm + cps-convert-prgm + ir-convert)) ;; Scheme compiler ;; Scheme subset we're targeting @@ -23,9 +28,6 @@ (symbol? x) (boolean? x))) -(define (primitive? x) - (memq x '(+ - * / = < > <= >=))) - (define-syntax-rule (define-cps-loop name unit) (define (name v* k) (if (null? v*) @@ -104,6 +106,7 @@ ;; | | | #t | #f ;; ;; We choose a hybrid transformation based on https://matt.might.net/articles/cps-conversion/ +;; Admittedly this is a little black magic to me, but it's useful (define undefined-value (make-symbol "undefined")) @@ -111,7 +114,7 @@ ;; M dispatches to the appropriate transformer (match expr [('lambda (var ...) e) - (let ([$k (gensym "$k")]) + (let ([$k (gensym "$k-")]) `(lambda (,@var ,$k) ,(T-c e $k)))] [(? atomic?) expr])) @@ -135,13 +138,8 @@ [ ('set! var expr) (T-k expr (lambda ($expr) `(set-then! ,var ,$expr ,(k undefined-value))))] - [((? primitive? f) e* ...) - (let* ([$rv (gensym "$rv")] - [cont `(lambda (,$rv) ,(k $rv))]) - (T*-k e* (lambda ($e*) - `((cps ,f) ,@$e* ,cont))))] [(f e* ...) - (let* ([$rv (gensym "$rv")] + (let* ([$rv (gensym "$rv-")] [cont `(lambda (,$rv) ,(k $rv))]) (T-k f (lambda ($f) (T*-k e* (lambda ($e*) @@ -159,7 +157,7 @@ [ ('let ([v* e*] ...) body) (T-c `((lambda (,@v*) ,body) ,@e*) c)] [ ('if exp1 exp2 exp3) - (let ([$k (gensym "$k")]) ;; Bind cont to avoid blow up + (let ([$k (gensym "$k-")]) ;; Bind cont to avoid blow up `((lambda (,$k) ,(T-k exp1 (lambda (aexp) `(if ,aexp @@ -169,9 +167,6 @@ [ ('set! var expr) (T-k expr (lambda ($expr) `(set-then! ,var ,$expr (,c ,undefined-value))))] - [ ((? primitive? f) e* ...) - (T*-k e* (lambda ($e*) - `((cps ,f) ,@$e* ,c)))] [ (f e* ...) (T-k f (lambda ($f) (T*-k e* (lambda ($e*) @@ -185,10 +180,154 @@ (define (ir-convert prgm) (cps-convert-prgm (desugar-prgm prgm))) -;; Useful for testing -;; (define (cps prim) -;; (lambda vars -;; (let* ([rev (reverse vars)] -;; [k (car rev)] -;; [args (reverse (cdr rev))]) -;; (k (apply prim args))))) + ;; Denotation + +(define *globals* (make-parameter '())) +(define *predefined* (make-parameter '())) + +(define (meaning e r) + (match e + [(? constant?) (meaning-constant e)] + [(? symbol?) (meaning-reference e r)] + [('lambda (vars ...) body) + (meaning-abstraction vars body r)] + [('set-then! var e k) + (meaning-assignment var e k r)] + [('define-then! var e k) + (meaning-definition var e k r)] + [('if e k1 k2) + (meaning-alternative e k1 k2 r)] + [(f e* ... k) + (meaning-application f e* k r)])) + +(define (meaning-reference v r) + (match (locate-variable v r) + [`(local ,i) (+local-reference+ i)] + [`(global ,i) (+global-reference+ i)] + [`(predefined ,p) (+predefined+ p)] + [_ (static-error "Reference to undefined variable" v)])) + +(define (meaning-constant c) + (+constant+ c)) + +(define (meaning-abstraction vars body r) + (let* ([arity (length vars)] + [r0 (r-extend r vars)] + [m+ (meaning body r0)]) + (append-meanings + (+fix-closure+ arity) + m+ + (+return+ arity)))) + +(define (meaning-assignment var e k r) + (let* ([m (meaning e r)] + [ma (match (locate-variable var r) + [`(local ,i) (+set!-local+ i)] + [`(global ,i) (+set!-global+ i)] + [`(predefined ,_) (static-error "Assignment to predefined variable" var)] + [_ (static-error "Assignment to undefined variable" var)])] + [mk (meaning k r)]) + (append-meanings m ma mk))) + +(define (meaning-definition var e k r) + (let* ([m (meaning e r)] + [mv (match (locate-variable var r) + [`(local ,_) (static-error "Definition conflicts local variable" var)] + [`(global ,_) (static-error "Redefinition of global variable" var)] + [`(predefined ,_) (static-error "Redefinition of predefined" var)] + [#f (+global-definition+ var)])] + [mk (meaning k r)]) + (append-meanings m mv mk))) + +(define (meaning-alternative e k1 k2 r) + (let* ([jump-false-label (gensym "jump-false-")] + [endif-label (gensym "endif-")] + [m (meaning e r)] + [mk1 (meaning k1 r)] + [mk2 (meaning k2 r)]) + (append-meanings + m + (+branch+ jump-false-label) mk1 (+goto+ endif-label) + (+label+ jump-false-label) mk2 (+label+ endif-label)))) + +(define (meaning-application f e* k r) + (let* ([arity (length e*)] + [mf (meaning f r)] + [m* (meaning* e* r)] + [mk (meaning k r)]) + (append-meanings + mf + m* (+frame-allocate+ arity) + (+frame-push+ arity) (+function-invoke+) (+frame-pop+ arity) + mk))) + +(define (meaning* e* r) + (if (pair? e*) + (let ([m (meaning (car e*) r)] + [m* (meaning* (cdr e*) r)]) + (append-meanings m m*)) + '())) + +(define (locate-variable v r) + (cond + [(list-index (lambda (v0) (eq? v v0)) r) => + (lambda (i) `(local ,i))] + [(list-index (lambda (v0) (eq? v v0)) (*globals*)) => + (lambda (i) `(global ,i))] + [(list-index (lambda (v0) (eq? v v0)) (*predefined*)) => + (lambda (p) `(predefined ,p))] + [else #f])) + +(define (constant? x) + (or (number? x) + (boolean? x) + (and (pair? x) (eq? 'quote (car x))))) + +(define (drop-environment vars r) + (let ([n (length vars)]) + (assert (equal? vars (take n r))) + (drop n r))) + +(define append-meanings append) + +(define (r-extend r vars) + (append vars r)) + +(define (global-extend! vars) + (*globals* (append vars (*globals*)))) + +(define (static-error . args) + `((+error+ ,@args))) + +(define-syntax define-combinator + (syntax-rules () + [(_ (name args ...)) + (define (name args ...) + `((name ,@(list args ...))))])) + +(define-combinator (+predefined+ i)) +(define-combinator (+global-reference+ i)) +(define-combinator (+local-reference+ i)) +(define-combinator (+constant+ c)) +(define-combinator (+fix-closure+ arity)) +(define-combinator (+return+ arity)) +(define-combinator (+set!-global+ i)) +(define-combinator (+set!-local+ i)) +(define-combinator (+alternative+ i)) +(define-combinator (+global-definition+ v)) +(define-combinator (+branch+ label)) +(define-combinator (+goto+ label)) +(define-combinator (+label+ name)) +(define-combinator (+frame-allocate+ size)) +(define-combinator (+frame-push+ size)) +(define-combinator (+function-invoke+)) +(define-combinator (+frame-pop+ size)) + +(define (std-predefined) + '(cons car cdr eq? pair? null? symbol? = + - * /)) + +(define* (scheme-compile prgm #:key (globals '())) + (parameterize ([*globals* globals] + [*predefined* (std-predefined)]) + (meaning (ir-convert prgm) '()))) +