Tighten let@ definition
authorTony Garnock-Jones <tonygarnockjones@gmail.com>
Mon, 16 Jul 2018 15:22:58 +0100
changeset 385 0d3839af02db
parent 384 2d82efe83d59
child 386 552736e4616c
Tighten let@ definition
experiments/little-smalltalk/jit-SmallWorld-2015.rkt
--- a/experiments/little-smalltalk/jit-SmallWorld-2015.rkt	Sun Jul 15 13:43:34 2018 +0100
+++ b/experiments/little-smalltalk/jit-SmallWorld-2015.rkt	Mon Jul 16 15:22:58 2018 +0100
@@ -272,10 +272,14 @@
                         (vector ,@(vector->list tmpnames))
                         (vector ,@(reverse stack))))
 
-  (define-syntax-rule (let@ [n n-exp n-code-exp] body-code-exp)
-    (let ((n n-exp))
-      `(let ((,n ,n-code-exp))
-         ,body-code-exp)))
+  (define-syntax let@
+    (syntax-rules ()
+      [(_ [n n-code-exp] body-code-exp)
+       (let@ [n (gensym 'n) n-code-exp] body-code-exp)]
+      [(_ [n n-exp n-code-exp] body-code-exp)
+       (let ((n (gensym n-exp)))
+         `(let ((,n ,n-code-exp))
+            ,body-code-exp))]))
 
   (define labels (make-hash))
 
@@ -308,10 +312,10 @@
     (define-values (opcode arg) (decode!))
     (log-vm/jit-debug " ~a: ~a ~a" ip0 opcode arg)
     (match opcode
-      [1 (let@ [n (mksym "slot~a" arg) `(vector-ref (obj-slots self) ,arg)]
+      [1 (let@ [n (mksym "slot~a_" arg) `(vector-ref (obj-slots self) ,arg)]
                (translate ip (cons n stack)))]
       [2 (translate ip (cons (vector-ref argnames arg) stack))]
-      [3 (let@ [n (gensym 'tmpcopy) (vector-ref tmpnames arg)]
+      [3 (let@ [n (mksym "tmp~a_" arg) (vector-ref tmpnames arg)]
                (translate ip (cons n stack)))]
       [4 (translate ip (cons (vector-ref litnames arg) stack))]
       [5 (match arg
@@ -354,14 +358,13 @@
       ;;                     ,(vector-ref litnames arg)))]
 
       [10 (match arg
-            [0 (let@ [n (gensym 'isNil) `(boolean->obj vm (eq? NIL ,(car stack)))]
-                     (translate ip (cons n (cdr stack))))]
-            [1 (let@ [n (gensym 'notNil) `(boolean->obj vm (not (eq? NIL ,(car stack))))]
-                     (translate ip (cons n (cdr stack))))])]
+            [0 (let@ [isNil `(boolean->obj vm (eq? NIL ,(car stack)))]
+                     (translate ip (cons isNil (cdr stack))))]
+            [1 (let@ [notNil `(boolean->obj vm (not (eq? NIL ,(car stack))))]
+                     (translate ip (cons notNil (cdr stack))))])]
       [11 (match stack
             [(list* j i stack)
-             (let@ [binop-k (gensym 'binop-k)
-                            (let ((binop-result (gensym 'binop-result)))
+             (let@ [binop-k (let ((binop-result (gensym 'binop-result)))
                               `(case-lambda
                                  [() ,(build-jit-context-exp ip stack)]
                                  [(,binop-result) ,(translate ip (cons binop-result stack))]))]
@@ -378,8 +381,7 @@
                                                    [1 #"<="]
                                                    [2 #"+"])))))])]
       [12 (let ((target (next-byte!)))
-            (let@ [block (gensym 'block)
-                         `(mkffiv BLOCK
+            (let@ [block `(mkffiv BLOCK
                                   (lambda (_vm k . block-arguments)
                                     ,(let loop ((i arg))
                                        (if (>= i temp-count)
@@ -407,21 +409,20 @@
                     [(obj (== BLOCK) _)
                      (k ((block->thunk vm ,block (list ,@(reverse (take stack argc))))))]))]
             [34 'NIL]
-            [35 (let@ [n (gensym 'ctx) (build-jit-context-exp ip stack)]
-                      (translate ip (cons n stack)))]
-            [36 (let@ [n (gensym 'arr) `(mkobj ARRAY ,@(reverse (take stack arg)))]
-                      (translate ip (cons n (drop stack arg))))]
-            [_ (let@ [v (gensym 'primresult)
-                        (let ((generator (hash-ref *primitive-code-snippets*
-                                                   primitive-number
-                                                   (lambda ()
-                                                     (error 'compile-native-proc
-                                                            "Unknown primitive: ~a"
-                                                            primitive-number)))))
-                          (generator 'vm (reverse (take stack arg))))]
-                     (translate ip (cons v (drop stack arg))))])]
-      [14 (let@ [n (gensym 'clsvar) `(slotAt (obj-class* vm self) ,(+ arg 5))]
-                (translate ip (cons n stack)))]
+            [35 (let@ [ctxref (build-jit-context-exp ip stack)]
+                      (translate ip (cons ctxref stack)))]
+            [36 (let@ [arr `(mkobj ARRAY ,@(reverse (take stack arg)))]
+                      (translate ip (cons arr (drop stack arg))))]
+            [_ (let@ [primresult (let ((generator (hash-ref *primitive-code-snippets*
+                                                            primitive-number
+                                                            (lambda ()
+                                                              (error 'compile-native-proc
+                                                                     "Unknown primitive: ~a"
+                                                                     primitive-number)))))
+                                   (generator 'vm (reverse (take stack arg))))]
+                     (translate ip (cons primresult (drop stack arg))))])]
+      [14 (let@ [clsvar `(slotAt (obj-class* vm self) ,(+ arg 5))]
+                (translate ip (cons clsvar stack)))]
       [15 (match arg
             [1 `(k self)]
             [2 `(k ,(car stack))]