Cosmetic
authorTony Garnock-Jones <tonygarnockjones@gmail.com>
Sun, 29 Jul 2018 22:15:45 +0100
changeset 429 ffe1b880d9c6
parent 428 a94fb6aff9ef
child 430 b57692a51f6b
Cosmetic
experiments/little-smalltalk/pe-SmallWorld-2015.rkt
--- a/experiments/little-smalltalk/pe-SmallWorld-2015.rkt	Sun Jul 29 21:58:14 2018 +0100
+++ b/experiments/little-smalltalk/pe-SmallWorld-2015.rkt	Sun Jul 29 22:15:45 2018 +0100
@@ -157,13 +157,12 @@
 
 (define (unwrap-cached-method vm cm)
   (or (cached-method-proc cm)
-      (match cm
-        [(cached-method class name-bytes _bcm _proc)
-         (define bcm (lookup-method vm class name-bytes))
-         (define proc (and bcm (compile-method-proc vm class bcm #f)))
-         (set-cached-method-bytecode-method! cm bcm)
-         (set-cached-method-proc! cm proc)
-         proc])))
+      (match cm [(cached-method class name-bytes _bcm _proc)
+                 (define bcm (lookup-method vm class name-bytes))
+                 (define proc (and bcm (compile-method-proc vm class bcm #f)))
+                 (set-cached-method-bytecode-method! cm bcm)
+                 (set-cached-method-proc! cm proc)
+                 proc])))
 
 (define (invalidate-cached-method! cm)
   (set-cached-method-bytecode-method! cm #f)
@@ -261,69 +260,48 @@
       0
       (+ 1 (Ctx-depth (Ctx-previous c)))))
 
-(define (Ctx-arg c n)
-  (vector-ref (Ctx-arguments c) n))
-
-(define (Ctx-receiver c)
-  (Ctx-arg c 0))
+(define (Ctx-name c) (method-name (Ctx-method c) (Ctx-receiver-class c)))
+(define (Ctx-arg c n) (vector-ref (Ctx-arguments c) n))
+(define (Ctx-receiver c) (Ctx-arg c 0))
 
 (define (Ctx-receiver-class c)
   (Constant-value (AbsVal-desc (ObjClass (Ctx-vm c) (Ctx-receiver c)))))
 
-(define (Ctx-name c)
-  (method-name (Ctx-method c) (Ctx-receiver-class c)))
-
 (define (already-compiling? c class method)
   (let check ((c c))
     (cond [(DynamicCtx? c) #f]
           [(and (eq? (Ctx-receiver-class c) class) (eq? (Ctx-method c) method)) #t]
           [else (check (Ctx-previous c))])))
 
-(define (gen-lit* litmap lit)
-  (if (number? lit)
-      lit
-      (hash-ref! litmap lit (lambda ()
-                              (define n (hash-count litmap))
-                              (cond
-                                [(bv? lit) (mksym "lit~a-~a" n (bv->string lit))]
-                                [(list? lit) (mksym "lit~a" n)]
-                                [(vector? lit) (mksym "pic~a" n)]
-                                [else (mksym "lit~a-~a" n lit)])))))
+(define (gen-lit litmap lit)
+  (define var (if (number? lit)
+                  lit
+                  (hash-ref! litmap lit (lambda ()
+                                          (define n (hash-count litmap))
+                                          (cond [(bv? lit) (mksym "lit~a-~a" n (bv->string lit))]
+                                                [(list? lit) (mksym "lit~a" n)]
+                                                [(vector? lit) (mksym "pic~a" n)]
+                                                [else (mksym "lit~a-~a" n lit)])))))
+  (AbsVal var (Constant lit)))
 
-(define (gen-lit litmap lit)
-  (AbsVal (gen-lit* litmap lit) (Constant lit)))
-
-(define (Ctx-litmap c)
-  (State-litmap (Ctx-state c)))
-
-(define (Ctx-lit c literal)
-  (gen-lit (Ctx-litmap c) literal))
+(define (Ctx-lit c literal) (gen-lit (State-litmap (Ctx-state c)) literal))
+(define (Ctx-lit* c literal) (AbsVal-expr (Ctx-lit c literal)))
 
 (define (Ctx-update c new-ip stack-transformer)
   (struct-copy Ctx c [ip new-ip] [stack (stack-transformer (Ctx-stack c))]))
 
-(define (Ctx-push c v)
-  (Ctx-update c (Ctx-ip c) (lambda (s) (cons v s))))
-
-(define (Ctx-drop c n)
-  (Ctx-update c (Ctx-ip c) (lambda (s) (drop s n))))
-
-(define (Ctx-goto c ip)
-  (Ctx-update c ip values))
-
-(define (Ctx-push-and-goto c ip v)
-  (Ctx-update c ip (lambda (s) (cons v s))))
+(define (Ctx-push c v) (Ctx-update c (Ctx-ip c) (lambda (s) (cons v s))))
+(define (Ctx-drop c n) (Ctx-update c (Ctx-ip c) (lambda (s) (drop s n))))
+(define (Ctx-goto c ip) (Ctx-update c ip values))
+(define (Ctx-push-and-goto c ip v) (Ctx-update c ip (lambda (s) (cons v s))))
 
 (define (format-Ctx c)
-  (string-join (reverse
-                (let pieces ((c c))
-                  (if (DynamicCtx? c)
-                      '()
-                      (cons (format "~a @~a" (Ctx-name c) (Ctx-ip c))
-                            (pieces (Ctx-previous c))))))
-               ","
-               #:before-first "["
-               #:after-last "]"))
+  (define pieces
+    (let loop ((c c))
+      (if (DynamicCtx? c)
+          '()
+          (cons (format "~a @~a" (Ctx-name c) (Ctx-ip c)) (loop (Ctx-previous c))))))
+  (string-join (reverse pieces) "," #:before-first "[" #:after-last "]"))
 
 ;;===========================================================================
 ;; Compilation and code generation
@@ -335,27 +313,16 @@
   (define pic-infos (hash->list (State-picmap (Ctx-state c))))
   (define stable? (equal? (if old-picmap (list->set (hash-keys old-picmap)) 'unknown)
                           (list->set (map car pic-infos))))
-  ;; (log-vm/jit/recompile-debug "Evaluating stability of ~a:" (Ctx-name c))
-  ;; (log-vm/jit/recompile-debug "  old-picmap --> ~a" (if old-picmap (list->set (hash-keys old-picmap)) 'unknown))
-  ;; (log-vm/jit/recompile-debug "  pic-infos  --> ~a" (list->set (map car pic-infos)))
   (when stable?
     (log-vm/jit/recompile-info "Compilation of ~a is now stable." (method-name method class)))
   (define inner-code
-    `(let ((call-counter 0)
-           (cmi #f))
+    `(let ((call-counter 0) (cmi #f))
        (case-lambda
          [()
           (when (not cmi)
-            (set! cmi
-                  (compiled-method-info
-                   ,(AbsVal-expr (Ctx-lit c method))
-                   ,(AbsVal-expr (Ctx-lit c pic-infos))
-                   ,stable?)))
+            (set! cmi (compiled-method-info ,(Ctx-lit* c method) ,(Ctx-lit* c pic-infos) ,stable?)))
           cmi]
          [(,top-k ,@(map AbsVal-expr (vector->list (Ctx-arguments c))))
-          ;; (log-vm/jit-debug "Entering ~a with ~a"
-          ;;                   ,(method-name method class)
-          ;;                   (list ,@(map AbsVal-expr (vector->list (Ctx-arguments c)))))
           (set! call-counter (+ call-counter 1))
           ;; TODO: aging of call-counter by right-shifting at most once every few seconds, or so
           (when (= call-counter 1000)
@@ -367,7 +334,7 @@
   (finish-compilation c compile-time-vm inner-code))
 
 (define (finish-compilation c vm inner-code)
-  (define litmap-list (hash->list (Ctx-litmap c)))
+  (define litmap-list (hash->list (State-litmap (Ctx-state c))))
   (define code `(lambda (vm ,@(map cdr litmap-list)) ,inner-code))
   (log-vm/jit/code-debug "Resulting code for ~a:\n~a" (Ctx-name c) (pretty-format code))
   (define boot
@@ -414,7 +381,7 @@
       `(build-jit-context vm
                           ,(gen-build-jit-context (Ctx-previous c))
                           (vector ,@(map AbsVal-expr (vector->list (Ctx-arguments c))))
-                          ,(AbsVal-expr (Ctx-lit c (Ctx-method c)))
+                          ,(Ctx-lit* c (Ctx-method c))
                           ,(Ctx-ip c)
                           ,(Ctx-temporaries c)
                           (vector ,@(map AbsVal-expr (reverse (Ctx-stack c)))))))
@@ -423,8 +390,7 @@
   `(let ((,(Ctx-temporaries c)
           ,(match (slotAt (Ctx-method c) 4)
              [0 `'#()]
-             [temp-count
-              `(make-vector ,temp-count ,(AbsVal-expr (Ctx-lit c (VM-nil (Ctx-vm c)))))])))
+             [temp-count `(make-vector ,temp-count ,(Ctx-lit* c (VM-nil (Ctx-vm c))))])))
      ,body-code))
 
 (define (bytecode-exceeding? method limit)
@@ -438,18 +404,14 @@
 (define (gen-pic c name-bytes extension)
   (define key (Ctx->pic-key c))
   (define picmap (State-picmap (Ctx-state c)))
-  (define p
-    (cadr
-     (hash-ref! picmap
-                key
-                (lambda ()
-                  (list name-bytes
-                        (if (null? extension)
-                            (pic)
-                            (apply extended-pic
-                                   (flatten (take (append extension empty-pic-extension)
-                                                  pic-entry-count)))))))))
-  (define m (gen-lit* (Ctx-litmap c) p))
+  (define (mkpic)
+    (list name-bytes (if (null? extension)
+                         (pic)
+                         (apply extended-pic
+                                (flatten (take (append extension empty-pic-extension)
+                                               pic-entry-count))))))
+  (define p (cadr (hash-ref! picmap key mkpic)))
+  (define m (Ctx-lit* c p))
   (log-vm/jit/recompile-debug "Produced pic ~a for send of ~a at ~a (~a)" m name-bytes c p)
   m)
 
@@ -467,13 +429,7 @@
   (define ic
     (inline-compilation (Ctx-vm kc) method (list->vector arg-avs) #f 0 kc #f (Ctx-state kc)))
   (log-vm/jit/code-debug "Inlining send of ~a into method ~a" (Ctx-name ic) (Ctx-name kc))
-  (define body-code
-    `(begin
-       ;; (log-vm/jit/code-debug "Entering inlined send of ~a returning to ~a with ~a"
-       ;;                        ,(method-name method)
-       ;;                        ,(format-Ctx kc)
-       ;;                        (list ,@(map AbsVal-expr arg-avs)))
-       ,(gen-fresh-temps ic (gen-label-definitions ic (gen-code ic)))))
+  (define body-code (gen-fresh-temps ic (gen-label-definitions ic (gen-code ic))))
   (log-vm/jit/code-debug "INLINED for send of ~a into method ~a:\n~a"
                          (Ctx-name ic)
                          (Ctx-name kc)
@@ -503,10 +459,9 @@
   (if (DynamicCtx? c)
       (DynamicCtx-var c)
       (let ((ans (gensym 'answer)))
-        `(case-lambda [() ,(gen-build-jit-context c)]
-                      [(,ans)
-                       ;; (log-vm/jit-debug "Continuing ~a with ~a" ,(format-Ctx c) ,ans)
-                       ,(truncate-histories c (gen-continuation (Ctx-push c (AbsVal ans (Unknown)))))]))))
+        `(case-lambda
+           [() ,(gen-build-jit-context c)]
+           [(,ans) ,(truncate-histories c (gen-continuation (Ctx-push c (AbsVal ans (Unknown)))))]))))
 
 (define (gen-continuation c)
   (if (remaining-basic-block-size-tiny? c)
@@ -517,7 +472,6 @@
   (log-vm/jit-debug "Send of ~a at ~a returning to ~a" name-bytes c kc)
   (define vm (Ctx-vm c))
   (define class-desc (AbsVal-desc class-absval))
-  ;; (log-vm/jit-debug "class-absval is ~a" class-absval)
   (log-vm/jit-debug "arg-avs = ~a" arg-avs)
   (if (Constant? class-desc)
       (let* ((class (Constant-value class-desc))
@@ -528,7 +482,7 @@
         (if (or (already-compiling? c class bmethod)
                 (not (tiny-method? bmethod))
                 (not (sufficiently-static? c arg-avs)))
-            `((unwrap-cached-method vm ,(AbsVal-expr (Ctx-lit c cm)))
+            `((unwrap-cached-method vm ,(Ctx-lit* c cm))
               ,(Ctx->expr kc) ,@(map AbsVal-expr arg-avs))
             (gen-inline-send kc bmethod arg-avs)))
       (let ()
@@ -546,13 +500,13 @@
                 [(cons (list predicted-class predicted-cm) more-predictions)
                  (define predicted-bmethod (cached-method-bytecode-method predicted-cm))
                  (define final-arg-avs (augment-receiver-class c arg-avs predicted-class))
-                 `(if (eq? ,(AbsVal-expr class-absval) ,(AbsVal-expr (Ctx-lit c predicted-class)))
+                 `(if (eq? ,(AbsVal-expr class-absval) ,(Ctx-lit* c predicted-class))
                       (begin
                         (pic-bump! ,pic-m ,counter)
                         ,(if (or (already-compiling? c predicted-class predicted-bmethod)
                                  (not (small-method? predicted-bmethod))
                                  (not (sufficiently-static? c final-arg-avs)))
-                             `((unwrap-cached-method vm ,(AbsVal-expr (Ctx-lit c predicted-cm)))
+                             `((unwrap-cached-method vm ,(Ctx-lit* c predicted-cm))
                                k-send ,@(map AbsVal-expr final-arg-avs))
                              (gen-inline-send kc predicted-bmethod final-arg-avs)))
                       ,(loop more-predictions (+ counter 1)))]))))))
@@ -577,7 +531,6 @@
                                  (or (Ctx-home c) (Ctx-previous c)) ;; ??
                                  (Ctx-state c)))
   `(lambda (,block-k . block-arguments)
-     ;; (log-vm/jit-debug "Entering block at ~a with ~a" ,(format-Ctx bc) block-arguments)
      ,(let loop ((i argument-location))
         (if (>= i temp-count)
             `(void)
@@ -722,14 +675,14 @@
              [0 (emit c [isNil pure
                                (if (equal? (Constant (VM-nil vm)) (AbsVal-desc (car stack)))
                                    (Ctx-lit c (VM-true vm))
-                                   (AbsVal `(boolean->obj vm (eq? ,(AbsVal-expr (Ctx-lit c (VM-nil vm)))
+                                   (AbsVal `(boolean->obj vm (eq? ,(Ctx-lit* c (VM-nil vm))
                                                                   ,(AbsVal-expr (car stack))))
                                            (Unknown)))]
                       (translate (Ctx-push (Ctx-drop c 1) isNil)))]
              [1 (emit c [notNil pure
                                 (if (equal? (Constant (VM-nil vm)) (AbsVal-desc (car stack)))
                                     (Ctx-lit c (VM-false vm))
-                                    (AbsVal `(boolean->obj vm (not (eq? ,(AbsVal-expr (Ctx-lit c (VM-nil vm)))
+                                    (AbsVal `(boolean->obj vm (not (eq? ,(Ctx-lit* c (VM-nil vm))
                                                                         ,(AbsVal-expr (car stack)))))
                                             (Unknown)))]
                       (translate (Ctx-push (Ctx-drop c 1) notNil)))])]
@@ -753,43 +706,33 @@
                                    (gen-send c0
                                              (ObjClass vm iv)
                                              name-bytes
-                                             (AbsVal `(mkbv ,(AbsVal-expr (Ctx-lit c (VM-nil vm)))
-                                                            ,name-bytes)
-                                                     (Bv (Ctx-lit c (VM-nil vm))
-                                                         (vector)
-                                                         name-bytes))
+                                             (AbsVal `(mkbv ,(Ctx-lit* c (VM-nil vm)) ,name-bytes)
+                                                     (Bv (Ctx-lit c (VM-nil vm)) (vector) name-bytes))
                                              (list iv jv)
                                              c))))])]
        [12 (let ((target (next-byte!))
                  (argument-location arg))
+             (define inline-block
+               (let ((c c))
+                 (lambda (kc arg-avs)
+                   (log-vm/jit-debug "Inlining block ~a returning to ~a" c kc)
+                   (define bc (inline-compilation vm
+                                                  method
+                                                  (Ctx-arguments c)
+                                                  (Ctx-temporaries c)
+                                                  (Ctx-ip c)
+                                                  kc
+                                                  (or (Ctx-home c) (Ctx-previous c)) ;; ??
+                                                  (Ctx-state c)))
+                   (for [(i (in-naturals argument-location)) (arg arg-avs)]
+                     (define av
+                       (AbsVal `(vector-set! ,(Ctx-temporaries c) ,i ,(AbsVal-expr arg)) (Unknown)))
+                     (emit bc [blkarg effect av] (void)))
+                   (truncate-histories bc (gen-label-definitions bc (gen-code bc))))))
              (emit c [block pure
                             (AbsVal
-                             `(mkffiv ,(AbsVal-expr (Ctx-lit c (VM-Block vm)))
-                                      ,(gen-block c argument-location))
-                             (Ffiv (Ctx-lit c (VM-Block vm))
-                                   #f
-                                   (let ((c c))
-                                     (lambda (kc arg-avs)
-                                       (log-vm/jit-debug "Inlining block ~a returning to ~a" c kc)
-                                       (define bc
-                                         (inline-compilation vm
-                                                             method
-                                                             (Ctx-arguments c)
-                                                             (Ctx-temporaries c)
-                                                             (Ctx-ip c)
-                                                             kc
-                                                             (or (Ctx-home c) (Ctx-previous c)) ;; ??
-                                                             (Ctx-state c)))
-                                       (for [(i (in-naturals argument-location)) (arg arg-avs)]
-                                         (define av
-                                           (AbsVal `(vector-set! ,(Ctx-temporaries c)
-                                                                 ,i
-                                                                 ,(AbsVal-expr arg))
-                                                   (Unknown)))
-                                         (emit bc [blkarg effect av] (void)))
-                                       (truncate-histories
-                                        bc
-                                        (gen-label-definitions bc (gen-code bc)))))))]
+                             `(mkffiv ,(Ctx-lit* c (VM-Block vm)) ,(gen-block c argument-location))
+                             (Ffiv (Ctx-lit c (VM-Block vm)) #f inline-block))]
                    (translate (Ctx-push-and-goto c target block))))]
        [13 (define primitive-number (next-byte!))
            (define primitive-arg-count arg)
@@ -802,8 +745,7 @@
                 (emit c [(obj (gensym (class-temp-name class)))
                          effect
                          (AbsVal `(obj ,(AbsVal-expr class)
-                                       (make-vector ,(AbsVal-expr count)
-                                                    ,(AbsVal-expr (Ctx-lit c (VM-nil vm)))))
+                                       (make-vector ,(AbsVal-expr count) ,(Ctx-lit* c (VM-nil vm))))
                                  (Obj class #f))]
                       (translate (Ctx-push c obj)))]
              [8 (let ((v (gensym 'blockresult))
@@ -823,7 +765,7 @@
                            ;; ^ reason being the image BUGGILY (?!?) relies on primitive 8
                            ;; immediately returning to the surrounding context!!
                            ,@(map AbsVal-expr primitive-args))]
-                         [(obj (== ,(AbsVal-expr (Ctx-lit c (VM-Block vm)))) _)
+                         [(obj (== ,(Ctx-lit* c (VM-Block vm))) _)
                           (log-vm/jit-warning "Unoptimized block!")
                           ,(let ((expr `((block->thunk vm
                                                        ,(AbsVal-expr block)
@@ -836,7 +778,7 @@
              [34 (Ctx-lit c (VM-nil vm))]
              [35 (emit c [ctxref pure (AbsVal (gen-build-jit-context c) (Unknown))]
                        (translate (Ctx-push c ctxref)))]
-             [36 (emit c [arr effect (AbsVal `(mkobj ,(AbsVal-expr (Ctx-lit c (VM-Array vm)))
+             [36 (emit c [arr effect (AbsVal `(mkobj ,(Ctx-lit* c (VM-Array vm))
                                                      ,@(map AbsVal-expr primitive-args))
                                              (Obj (Ctx-lit c (VM-Array vm))
                                                   (list->vector primitive-args)))]
@@ -868,7 +810,7 @@
                   (log-vm/jit-debug "if ~a true jump to ~a, else continue at ~a" disc target (Ctx-ip c))
                   (if (equal? (Constant (VM-true vm)) (AbsVal-desc disc))
                       (gen-code (Ctx-goto c target))
-                      `(if (eq? ,(AbsVal-expr disc) ,(AbsVal-expr (Ctx-lit c (VM-true vm))))
+                      `(if (eq? ,(AbsVal-expr disc) ,(Ctx-lit* c (VM-true vm)))
                            ,(gen-continuation (Ctx-goto c target))
                            ,(gen-continuation c))))]
              [8 (let ((target (next-byte!))
@@ -877,7 +819,7 @@
                   (log-vm/jit-debug "if ~a false jump to ~a, else continue at ~a" disc target (Ctx-ip c))
                   (if (equal? (Constant (VM-false vm)) (AbsVal-desc disc))
                       (gen-code (Ctx-goto c target))
-                      `(if (eq? ,(AbsVal-expr disc) ,(AbsVal-expr (Ctx-lit c (VM-false vm))))
+                      `(if (eq? ,(AbsVal-expr disc) ,(Ctx-lit* c (VM-false vm)))
                            ,(gen-continuation (Ctx-goto c target))
                            ,(gen-continuation c))))]
              ;; 11 inlined in the processing of bytecode 8
@@ -891,22 +833,11 @@
     [_
      "newobj"]))
 
-;; (define (dump-full-context c)
-;;   (log-vm/jit-debug "FULL CONTEXT:")
-;;   (let loop ((c c))
-;;     (log-vm/jit-debug "  ~a: stack ~a" c (Ctx-stack c))
-;;     (cond [(Ctx-previous c) => loop]
-;;           [else (void)]))
-;;   (log-vm/jit-debug "HISTORIES: ~a" ((State-histories (Ctx-state c)))))
-
 (define (gen-jump-to-label c)
   (define labels (Ctx-labels c))
   (define key (Ctx-ip c))
   (when (not (hash-has-key? labels key))
-    (define var
-      (gensym (mksym "label-~a-~a-"
-                     (bv->string (slotAt (Ctx-method c) 0))
-                     (Ctx-ip c))))
+    (define var (gensym (mksym "label-~a-~a-" (bv->string (slotAt (Ctx-method c) 0)) (Ctx-ip c))))
     (hash-set! labels key (cons 'placeholder var))
     (define newstack (for/list [(i (length (Ctx-stack c)))] (AbsVal (mksym "stack~a" i) (Unknown))))
     (log-vm/jit-debug "Producing label ~a" var)
@@ -914,9 +845,7 @@
     (define expr (truncate-histories
                   c
                   (let* ((c (Ctx-update c (Ctx-ip c) (lambda (_s) newstack)))
-                         (c (struct-copy Ctx c [previous (DynamicCtx (list 'label key) bb-k)]))
-                         )
-                    ;; (dump-full-context c)
+                         (c (struct-copy Ctx c [previous (DynamicCtx (list 'label key) bb-k)])))
                     (gen-code c))))
     (log-vm/jit-debug "Produced label ~a" var)
     (hash-set! labels key (cons `(lambda (,bb-k ,@(map AbsVal-expr newstack)) ,expr) var)))