rewrote remove-danger in nanopass.

eholk · Feb 24, 2014 · a945432 · a945432
1 parent ec8be99
commit a945432
Show file tree

Hide file tree

Showing 4 changed files with 62 additions and 107 deletions.
diff --git a/harlan/middle/compile-middle.scm b/harlan/middle/compile-middle.scm
@@ -47,8 +47,8 @@
    (optimize-fuse-kernels
     verify-optimize-fuse-kernels
     1)
-   (remove-danger
-    verify-remove-danger)
+   (nanopasses
+    (remove-danger : M7 -> M7.0.0))
    (remove-nested-kernels
     verify-remove-nested-kernels)
    (returnify-kernels

diff --git a/harlan/middle/languages.scm b/harlan/middle/languages.scm
@@ -8,7 +8,8 @@
           M3 unparse-M3 parse-M3
           M5 unparse-M5 parse-M5
           M6 unparse-M6
-          M7 unparse-M7
+          M7 unparse-M7 parse-M7
+          M7.0.0 unparse-M7.0.0
           M7.0 unparse-M7.0 parse-M7.0
           M7.1 unparse-M7.1
           ;;M7.2 unparse-M7.2
@@ -240,9 +241,17 @@
      (+ (kernel t r (e* ...) (((x0 t0) (e1 t1) i*) ...) e)
         (make-vector t r e))))
 
+  ;; After remove-danger
+  (define-language M7.0.0
+    (extends M7)
+
+    (Expr (e)
+          (+ (error x))
+          (- (unsafe-vector-ref t e0 e1))))
+
   ;; before lower-vectors
   (define-language M7.0
-    (extends M7)
+    (extends M7.0.0)
 
     (FreeVars
      (fv)
@@ -259,10 +268,10 @@
         (print e1 e2)
         (assert e)
         (set! e1 e2)
+        (error x)
         (begin stmt ...)
         (if e stmt1 stmt2)
         (if e stmt)
-        (error x)
         (while e stmt)
         (do e)
         (kernel t (e* ...) fv stmt)
@@ -287,7 +296,8 @@
 
     (Expr
      (e)
-     (- (kernel t r (e* ...) (((x0 t0) (e1 t1) i*) ...) e))
+     (- (kernel t r (e* ...) (((x0 t0) (e1 t1) i*) ...) e)
+        (error x))
      (+ (addressof e)
         (deref e))))
 
@@ -487,7 +497,7 @@
   (define-parser parse-M0 M0)
   (define-parser parse-M3 M3)
   (define-parser parse-M5 M5)
-  ;;(define-parser parse-M7 M7)
+  (define-parser parse-M7 M7)
   (define-parser parse-M7.0 M7.0)
   ;;(define-parser parse-M7.1 M7.1)
   (define-parser parse-M8 M8)

diff --git a/harlan/middle/lower-vectors.scm b/harlan/middle/lower-vectors.scm
@@ -68,6 +68,7 @@
                ,rest)))
     (((,x ,t ,e) . ,[rest])
      ;;(display `((,x ,t ,e) ,rest)) (newline)
+     ;;(display (car e)) (newline)
      (assert (not (and (pair? e) (or (eq? (car e) 'vector)
                                      (eq? (car e) 'box)))))
      `(let ((,x ,t ,e)) ,rest))

diff --git a/harlan/middle/remove-danger.scm b/harlan/middle/remove-danger.scm
@@ -3,9 +3,10 @@
   (export remove-danger)
   (import
    (rnrs)
-   (harlan compile-opts)
-   (harlan helpers)
-   (except (elegant-weapons helpers) ident?))
+   (nanopass)
+   (harlan middle languages)
+   (only (elegant-weapons helpers) gensym)
+   (harlan compile-opts))
 
   ;; This pass inserts vector bounds checks. So far we only support
   ;; this and allocation failures. The checking code for allocation
@@ -55,105 +56,48 @@
   ;;
   ;; This is software engineering at its finest.
 
-
-  (define-match remove-danger
-    ((module ,[Decl -> decl*] ...)
-     `(module ,decl* ...)))
-
-  (define-match Decl
-    ((fn ,name ,args ,t ,[Stmt -> stmt])
-     `(fn ,name ,args ,t ,stmt))
-    ((typedef ,name ,t) `(typedef ,name ,t))
-    ((extern ,name ,args -> ,rtype)
-     `(extern ,name ,args -> ,rtype)))
+  (define-pass remove-danger : M7 (m) -> M7.0.0 ()
+    (definitions
+      (define (type-of e)
+        (with-output-language
+         (M7.0.0 Rho-Type)
+         (nanopass-case
+          (M7.0.0 Expr) e
+          ((var ,t ,x) t)
+          ((vector-ref ,t ,e1 ,e2) t)
+          ((let ((,x ,t ,e) ...) ,[e0]) e0)
+          ((kernel ,t ,r (,e* ...) (((,x0 ,t0) (,e1 ,t1) ,i*) ...) ,e) t)
+          ((begin ,[e] ,[e*] ...)
+           (let loop ((e* e*))
+             (cond
+               ((null? e*) e)
+               ((null? (cdr e*)) (car e*))
+               (else (loop (cdr e*))))))
+          ((vector ,t ,r ,e)
+           `(vec ,r ,t))
+          ((if ,e1 ,[e2] ,e3) e2)
+          ((if ,e1 ,[e2]) e2)
+          ((error ,x) 'void)
+          (else (error 'remove-danger::type-of "unrecognized expr"
+                       (unparse-M7.0.0 e)))))))
 
-  (define-match Stmt
-    ((let ((,x* ,t* ,[Expr -> e*]) ...) ,[body])
-     `(let ((,x* ,t* ,e*) ...) ,body))
-    ((let-region (,r ...) ,[body]) `(let-region (,r ...) ,body))
-    ((set! ,[Expr -> lhs] ,[Expr -> rhs])
-     `(set! ,lhs ,rhs))
-    ((if ,[Expr -> test] ,[conseq] ,[altern])
-     `(if ,test ,conseq ,altern))
-    ((if ,[Expr -> test] ,[conseq])
-     `(if ,test ,conseq))
-    ((while ,[Expr -> test] ,[body])
-     `(while ,test ,body))
-    ((for (,x ,[Expr -> start] ,[Expr -> stop] ,[Expr -> step]) ,[body])
-     `(for (,x ,start ,stop ,step) ,body))
-    ((begin ,[stmt*] ...)
-     `(begin ,stmt* ...))
-    ((print ,[Expr -> e] ...)
-     `(print . ,e))
-    ((assert ,[Expr -> e])
-     `(assert ,e))
-    ((return) `(return))
-    ((return ,[Expr -> e])
-     `(return ,e))
-    ((do ,[Expr -> e])
-     `(do ,e)))
+    (Expr
+     : Expr (e) -> Expr ()
 
-  (define-match Expr
-    ((,t ,v) (guard (scalar-type? t)) `(,t ,v))
-    ((var ,t ,x) `(var ,t ,x))
-    ((cast ,t ,[e]) `(cast ,t ,e))
-    ((make-vector ,t ,r ,[e])
-     `(make-vector ,t ,r ,e))
-    ((vector-ref ,t ,[v] ,[i])
-     (if (danger-zone)
-         `(vector-ref ,t ,v ,i)
-         (let ((v-var (gensym 'vec))
-               (i-var (gensym 'refindex))
-               (vt    (type-of v)))
-           `(let ((,v-var ,vt ,v)
-                  (,i-var int ,i))
-              (begin
-                (if (>= (var int ,i-var) (length (var ,vt ,v-var)))
-                    (error ,(gensym 'vector-length-error)))
-                (vector-ref ,t (var ,vt ,v-var) (var int ,i-var)))))))
-    ((unsafe-vector-ref ,t ,[v] ,[i])
-     `(vector-ref ,t ,v ,i))
-    ((unsafe-vec-ptr ,t ,[v])
-     `(unsafe-vec-ptr ,t ,v))
-    ((length ,[e])
-     `(length ,e))
-    ((vector ,t ,r ,[e*] ...)
-     `(vector ,t ,r . ,e*))
-    ((box ,r ,t ,[e]) `(box ,r ,t ,e))
-    ((unbox ,t ,r ,[e]) `(unbox ,t ,r ,e))
-    ((call ,[f] ,[args] ...)
-     `(call ,f . ,args))
-    ((if ,[test] ,[conseq] ,[altern])
-     `(if ,test ,conseq ,altern))
-    ((kernel
-      (vec ,r ,inner-type)
-      ,r
-      (,[dim] ...)
-      (((,x* ,t*) (,[xs*] ,ts*) ,d*) ...)
-      ,[body])
-     `(kernel
-       (vec ,r ,inner-type)
-       ,r
-       ,dim
-       (((,x* ,t*) (,xs* ,ts*) ,d*) ...) ,body))
-    ((let ((,x* ,t* ,[e*]) ...) ,[e])
-     `(let ((,x* ,t* ,e*) ...) ,e))
-    ((begin ,[Stmt -> s*] ... ,[e])
-     `(begin ,s* ... ,e))
-    ((c-expr . ,whatever) `(c-expr . ,whatever))
-    ((field ,[e] ,x) `(field ,e ,x))
-    ((empty-struct) '(empty-struct))
-    ((,op ,[lhs] ,[rhs])
-     (guard (or (relop? op) (binop? op)))
-     `(,op ,lhs ,rhs)))
+     ((vector-ref ,[t] ,[e0] ,[e1])
+      (if (danger-zone)
+          `(vector-ref ,t ,e0 ,e1)
+          (let ((v-var (gensym 'vec))
+                (i-var (gensym 'refindex))
+                (vt    (type-of e0)))
+            `(let ((,v-var ,vt ,e0)
+                   (,i-var int ,e1))
+               (begin
+                 (if (>= (var int ,i-var) (length (var ,vt ,v-var)))
+                     (error ,(gensym 'vector-length-error)))
+                 (vector-ref ,t (var ,vt ,v-var) (var int ,i-var)))))))
+     ((unsafe-vector-ref ,[t] ,[e0] ,[e1])
+      `(vector-ref ,t ,e0 ,e1))))
 
-  (define-match type-of
-    ((var ,t ,_) t)
-    ((vector-ref ,t ,v ,i) t)
-    ((let ((,x ,t ,e) ...) ,[b]) b)
-    ((kernel ,t . ,_) t)
-    ((begin ,e* ... ,[e]) e))
-
-
   ;; end library
   )