improved code gen for project

Author: jsiek

dynamic-typing.rkt

@@ -205,23 +205,44 @@
 		 [else
 		  `((movq ,new-e ,new-lhs)
 		    (orq (int ,(any-tag ty)) ,new-lhs))])]
+	  ;; Old inefficient version of project. -Jeremy
+          ;; [`(assign ,lhs (project ,e ,ty))
+          ;;  (define new-lhs (recur lhs))
+	  ;;  (define new-e (recur e))
+	  ;;  `((movq ,new-e ,new-lhs)
+	  ;;    (andq (int ,any-mask) ,new-lhs)
+	  ;;    (if (eq? ,new-lhs (int ,(any-tag ty)))
+	  ;; 	 ((andq (int ,pointer-mask) ,new-lhs)
+	  ;; 	  (if (eq? ,new-lhs (int ,pointer-mask))
+	  ;; 	      ;; vectors and procedures.
+	  ;; 	      ;; To do: check length of vector, arity of procedure. -Jeremy
+	  ;; 	      ((movq (int ,any-mask) ,new-lhs)
+	  ;; 	       (notq ,new-lhs)
+	  ;; 	       (andq  ,new-e ,new-lhs))
+	  ;; 	      ;; booleans and integers
+	  ;; 	      ((movq ,new-e ,new-lhs)
+	  ;; 	       (sarq (int ,tag-len) ,new-lhs))
+	  ;; 	      ))
+	  ;; 	 ;; shouldn't we push the status code? -Jeremy
+	  ;; 	 ((callq ,(string->symbol (label-name 'exit))))))]
           [`(assign ,lhs (project ,e ,ty))
            (define new-lhs (recur lhs))
 	   (define new-e (recur e))
 	   `((movq ,new-e ,new-lhs)
 	     (andq (int ,any-mask) ,new-lhs)
 	     (if (eq? ,new-lhs (int ,(any-tag ty)))
-		 ((andq (int ,pointer-mask) ,new-lhs)
-		  (if (eq? ,new-lhs (int ,pointer-mask))
-		      ;; vectors and procedures.
-		      ;; To do: check length of vector, arity of procedure. -Jeremy
-		      ((movq (int ,any-mask) ,new-lhs)
+		 ,(match ty
+		    [(or 'Integer 'Boolean)
+		     ;; booleans and integers
+		     `((movq ,new-e ,new-lhs)
+		       (sarq (int ,tag-len) ,new-lhs))]
+		    [else ;; vectors and procedures (pointers)
+		     ;; vectors and procedures.
+		     ;; To do: check length of vector, arity of procedure. -Jeremy
+		     `((movq (int ,any-mask) ,new-lhs)
 		       (notq ,new-lhs)
 		       (andq  ,new-e ,new-lhs))
-		      ;; booleans and integers
-		      ((movq ,new-e ,new-lhs)
-		       (sarq (int ,tag-len) ,new-lhs))
-		      ))
+		     ])
 		 ;; shouldn't we push the status code? -Jeremy
 		 ((callq ,(string->symbol (label-name 'exit))))))]
 	  [`(assign ,lhs (,pred ,e)) #:when (set-member? type-predicates pred)

tests/s7_5.rkt

@@ -1,8 +1,9 @@
 (define (hello) 24)
 (define (world) 24)
 (let ([x (vector 0 0)])
-  (let ([voidx (vector-set! x 0 (hello))])
+  (let ([y (hello)])
+  (let ([voidx (vector-set! x 0 y)])
     (let ([voidy (vector-set! x 1 (world))])
       (+ (- 6) (+ (vector-ref x 0) (vector-ref x 1)))
-      )))
+      ))))
 

utilities.rkt

@@ -213,6 +213,15 @@
 ;; raises an error using the (error) function when it encounters a
 ;; type error, or returns #f when it encounters a type error. 
 
+(define (strip-has-type e)
+  (match e 
+    [`(has-type ,e ,T)
+     (strip-has-type e)]
+    [`(,(app strip-has-type e*) ...)
+      `(,@e*)]
+    [else
+     e]))
+
 (define (check-passes name typechecker passes initial-interp)
   (lambda (test-name)
     (debug "** compiler " name)
@@ -247,12 +256,12 @@
                   (let ([input p])
                     (debug (string-append "running pass: " pass-name
 					  " on test: " test-name)
-                           input))
+                           (strip-has-type input)))
                   (define new-p (pass p))
                   (let ([output new-p])
                     (trace (string-append "running pass: " pass-name
 					  " on test: " test-name)
-                           output))
+                           (strip-has-type output)))
                   (cond [interp
                          (let ([new-result
                                 ;; if there is an input file with the same name
@@ -313,7 +322,7 @@
                                    (let ([new-p (pass p)])
 				     (trace (string-append "running pass: "
 							   name)
-					    new-p)
+					    (strip-has-type new-p))
                                      (loop (cdr passes) new-p)
                                      )])]))])
               (cond [(string? x86)