More WIP compiler stuff, generating combinators, possibly correct?

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 @@
 ;;          | <num> | <var> | #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) '())))
+