r7 interpreter progress!

mvitousek · mvitousek · commit 6f871d7f948a · 2016-03-29T15:30:03.000-04:00
diff --git a/dynamic-interp.rkt b/dynamic-interp.rkt
@@ -0,0 +1,102 @@
+#lang racket
+(require racket/fixnum)
+(require "utilities.rkt" (prefix-in runtime-config: "runtime-config.rkt"))
+(provide interp-r7)
+
+(define get-injected-type
+  (lambda (e)
+    (match e
+      [`(inject ,v ,ty) ty])))
+
+(define valid-op?
+  (lambda (op)
+    (member op '(+ - and or not))))
+
+(define interp-r7-op
+  (lambda (op es)
+    (match `(,op ,es)
+      [`(+ ((inject ,v1 Integer) (inject ,v2 Integer)))
+       `(inject ,(fx+ v1 v2) Integer)]
+      [`(- ((inject ,v Integer)))
+       `(inject ,(fx- 0 v) Integer)]
+      [`(and (,v1 ,v2))
+       (match v1
+         [`(inject #f Boolean) v1]
+         [else v2])]
+      [`(or (,v1 ,v2))
+       (match v1
+         [`(inject #f Boolean) v2]
+         [else v1])]
+      [`(not (,v1))
+       (match v1
+         [`(inject #f Boolean) `(inject #t Boolean)]
+         [else `(inject #f Boolean)])])))
+         
+(define (interp-r7 env)
+  (lambda (ast)
+    (vomit "interp-r7" ast env)
+    (match ast
+      [(? symbol?) (lookup ast env)]
+      [`(function-ref ,f) (lookup f env)]
+      [`(function-ref ,f ,n) (lookup f env)] ;; This is to deal with the detail of our translation that it keeps the arity of functions in the funref 
+      [(? integer?) `(inject ,ast Integer)]
+      [#t `(inject #t Boolean)]
+      [#f `(inject #f Boolean)]
+      [`(read) `(inject ,(read-fixnum) Integer)]
+      [`(lambda (,xs ...) ,body)
+       `(inject (lambda ,xs ,body ,env) (,@(map (lambda (x) 'Any) xs) -> Any))]
+      [`(define (,f ,xs ...) ,body)
+       (mcons f `(lambda ,xs ,body))]
+      [`(program ,ds ... ,body)
+       (let ([top-level (map (interp-r7 '()) ds)])
+         ;; Use set-cdr! on define lambda's for mutual recursion
+         (for/list ([b top-level])
+           (set-mcdr! b (match (mcdr b)
+                          [`(lambda ,xs ,body)
+                           `(inject (lambda ,xs ,body ,top-level) 
+                                    (,@(map (lambda (x) 'Any) xs) -> Any))])))
+         ((interp-r7 top-level) body))]
+      [`(vector ,es ...)
+       (let* ([elts (map (interp-r7 env) es)]
+              [tys (map get-injected-type elts)])
+         `(inject ,(apply vector (map (interp-r7 env) es)) (Vector ,@tys)))]
+      [`(vector-set! ,e1 ,n ,e2)
+       (let ([e1^ ((interp-r7 env) e1)]
+             [e2^ ((interp-r7 env) e2)])
+         (match e1^ 
+           [`(inject ,vec ,ty) 
+            (vector-set! vec n e2^)
+            `(inject (void) Void)]))]
+      [`(vector-ref ,e ,n)
+       (let ([e^ ((interp-r7 env) e)])
+         (match e^ 
+           [`(inject ,vec ,ty) 
+            (vector-ref vec n)]))]
+      [`(let ([,x ,e]) ,body)
+       (let ([v ((interp-r7 env) e)])
+         ((interp-r7 (cons (cons x v) env)) body))]
+      [`(,op ,es ...) #:when (valid-op? op)
+       (interp-r7-op op (map (interp-r7 env) es))]
+      [`(eq? ,l ,r)
+       `(inject ,(equal? ((interp-r7 env) l) ((interp-r7 env) r)) Boolean)]
+      [`(if ,q ,t ,f)
+       (match ((interp-r7 env) q)
+         [`(inject #f Boolean)
+          ((interp-r7 env) f)]
+         [else ((interp-r7 env) t)])]
+      [`(app ,f ,es ...) 
+       (define new-args (map (interp-r7 env) es))
+       (let ([f-val ((interp-r7 env) f)])
+         (match f-val 
+           [`(inject (lambda (,xs ...) ,body ,lam-env) ,ty)
+            (define new-env (append (map cons xs new-args) lam-env))
+            ((interp-r7 new-env) body)]
+           [else (error "interp-r7, expected function, not" f-val)]))]
+      [`(,f ,es ...)
+       (define new-args (map (interp-r7 env) es))
+       (let ([f-val ((interp-r7 env) f)])
+         (match f-val 
+           [`(inject (lambda (,xs ...) ,body ,lam-env) ,ty)
+            (define new-env (append (map cons xs new-args) lam-env))
+            ((interp-r7 new-env) body)]
+           [else (error "interp-r7, expected function, not" f-val)]))])))
diff --git a/dynamic-typing.rkt b/dynamic-typing.rkt
@@ -2,6 +2,7 @@
 (require racket/set)
 (require "utilities.rkt")
 (require "interp.rkt")
+(require "dynamic-interp.rkt")
 (require "lambda.rkt")
 
 (provide compile-R6 R6-passes R6-typechecker R7-passes)
@@ -440,41 +441,42 @@
       )))
 
 (define R7-passes
-  (let ([compiler (new compile-R7)])
+  (let ([compiler (new compile-R7)]
+        [interp (new interp-R6)])
     `(
       ("uniquify" ,(send compiler uniquify '())
-       #f)
+       ,(interp-r7 '()))
       ("reveal-functions" ,(send compiler reveal-functions '())
-       #f)
+       ,(interp-r7 '()))
       ("translate" ,(send compiler cast-insert)
-       #f)
+       ,(send interp interp-scheme '()))
       ("inserthastype" ,(send compiler type-check '())
-       #f)
+       ,(send interp interp-scheme '()))
       ("convert-to-closures" ,(send compiler convert-to-closures)
-       #f)
+       ,(send interp interp-scheme '()))
       ("flatten" ,(send compiler flatten #f)
-       #f)
+       ,(send interp interp-C '()))
       ("expose allocation"
        ,(send compiler expose-allocation)
-       #f)
+       ,(send interp interp-C '()))
       ("uncover call live roots"
        ,(send compiler uncover-call-live-roots)
-       #f)
+       ,(send interp interp-C '()))
       ("instruction selection" ,(send compiler select-instructions)
-       #f)
+       ,(send interp interp-x86 '()))
       ("liveness analysis" ,(send compiler uncover-live (void))
-       #f)
+       ,(send interp interp-x86 '()))
       ("build interference" ,(send compiler build-interference
                                    (void) (void))
-       #f)
+       ,(send interp interp-x86 '()))
       ("build move graph" ,(send compiler
                                  build-move-graph (void))
-       #f)
+       ,(send interp interp-x86 '()))
       ("allocate registers" ,(send compiler allocate-registers)
-       #f)
+       ,(send interp interp-x86 '()))
       ("lower conditionals" ,(send compiler lower-conditionals)
-       #f)
+       ,(send interp interp-x86 '()))
       ("patch instructions" ,(send compiler patch-instructions)
-       #f)
+       ,(send interp interp-x86 '()))
       ("print x86" ,(send compiler print-x86) #f)
       )))
diff --git a/interp.rkt b/interp.rkt
@@ -888,6 +888,15 @@
 	 [else (super interp-op op)]
 	 ))
 
+    (define/public (tyeq? t1 t2)
+ ;;     (display t1) (display " ") (display t2) (newline) (flush-output)
+      (match `(,t1 ,t2)
+        [`((Vectorof ,t1) (Vector ,t2s ...))
+         (foldr (lambda (x y) (and x y)) #t (map (lambda (x) (tyeq? t1 x)) t2s))] ;; wtf racket, why cant i just pass and?
+        [`((Vector ,t1s ...) (Vectorof ,t2))
+         (foldr (lambda (x y) (and x y)) #t (map (lambda (x) (tyeq? t2 x)) t1s))]
+        [else (equal? t1 t2)]))
+
     (define/override (interp-scheme env)
       (lambda (ast)
         (verbose "R6/interp-scheme" ast)
@@ -898,7 +907,7 @@
 	   (define v ((interp-scheme env) e))
 	   (match v
 	      [`(inject ,v1 ,t1)
-	       (cond [(equal? t1 t2)
+	       (cond [(tyeq? t1 t2)
 		      v1]
 		     [else
 		      (error "in project, type mismatch" t1 t2)])]
@@ -918,7 +927,7 @@
 	   (define v ((interp-C env) e))
 	   (match v
 	      [`(inject ,v1 ,t1)
-	       (cond [(equal? t1 t2)
+	       (cond [(tyeq? t1 t2)
 		      v1]
 		     [else
 		      (error "in project, type mismatch" t1 t2)])]
diff --git a/run-tests.rkt b/run-tests.rkt
@@ -8,6 +8,7 @@
 (require "lambda.rkt")
 (require "dynamic-typing.rkt")
 (require "interp.rkt")
+(require "dynamic-interp.rkt")
 (require "runtime-config.rkt")
 
 ;; I have made the original run-tests more programmatic so that we
@@ -20,15 +21,15 @@
 ;; Table associating names of compilers with the information for
 ;; running and testing them.
 (define compiler-list
-  ;; Name           Typechecker               Compiler-Passes      Use interpreter? Valid suites
-  `(("int_exp"      #f                        ,int-exp-passes      #t               (0))
-    ("reg_int_exp"  #f                        ,reg-int-exp-passes  #t               (0))
-    ("conditionals" ,conditionals-typechecker ,conditionals-passes #t               (0 1))
-    ("vectors"      ,vectors-typechecker      ,vectors-passes      #t               (0 1 2))
-    ("functions"    ,functions-typechecker    ,functions-passes    #t               (0 1 2 3))
-    ("lambda"       ,lambda-typechecker       ,lambda-passes       #t               (0 1 2 3 4))
-    ("any"          ,R6-typechecker           ,R6-passes           #t               (0 1 2 3 4 6))
-    ("dynamic"      #f                        ,R7-passes           #f               (7))
+  ;; Name           Typechecker               Compiler-Passes      Initial interpreter  Valid suites
+  `(("int_exp"      #f                        ,int-exp-passes      ,interp-scheme       (0))
+    ("reg_int_exp"  #f                        ,reg-int-exp-passes  ,interp-scheme       (0))
+    ("conditionals" ,conditionals-typechecker ,conditionals-passes ,interp-scheme       (0 1))
+    ("vectors"      ,vectors-typechecker      ,vectors-passes      ,interp-scheme       (0 1 2))
+    ("functions"    ,functions-typechecker    ,functions-passes    ,interp-scheme       (0 1 2 3))
+    ("lambda"       ,lambda-typechecker       ,lambda-passes       ,interp-scheme       (0 1 2 3 4))
+    ("any"          ,R6-typechecker           ,R6-passes           ,interp-scheme       (0 1 2 3 4 6))
+    ("dynamic"      #f                        ,R7-passes           ,(interp-r7 '())     (7))
     ))
 
 (define compiler-table (make-immutable-hash compiler-list))
@@ -56,8 +57,7 @@
 (define (test-compiler name typechecker use-interp passes test-suite test-nums)
   (display "------------------------------------------------------")(newline)
   (display "testing compiler ")(display name)(newline)
-  (unless (not use-interp)
-    (interp-tests name typechecker passes interp-scheme test-suite test-nums))
+  (interp-tests name typechecker passes use-interp test-suite test-nums)
   (compiler-tests name typechecker passes test-suite test-nums)
   (newline)(display "tests passed")(newline))
 
diff --git a/tests/s7_3.rkt b/tests/s7_3.rkt
@@ -1,5 +1,5 @@
 (let ([x (vector 1 2 3 42)])
-  (let ([y (vector-set! x 0 42)])
-    (let ([z (vector-set! x 1 42)])
+  (let ([y (vector-set! x 1 42)])
+    (let ([z (vector-set! x 0 42)])
       ((lambda (vec) (vector-ref vec 3)) x))))
 
