test-assemble.rkt

#lang racket

(require (planet dyoo/browser-evaluate)
         "../js-assembler/assemble.rkt"
         "../js-assembler/package.rkt"
         "../compiler/lexical-structs.rkt"
         "../compiler/il-structs.rkt"
         "../compiler/arity-structs.rkt"
         racket/port
         racket/promise
         racket/runtime-path)

(printf "test-assemble.rkt\n")

(define runtime (get-runtime))


; Test out the compiler, using the simulator.
(define-syntax (test stx)
  (syntax-case stx ()
    [(_ expr expected)
     (with-syntax ([stx stx])
       (syntax/loc #'stx
         (begin
           (printf "Running ~s ...\n" (syntax->datum #'expr))
           (let ([actual 
                  (with-handlers ([void
                                   (lambda (exn)
                                     (raise-syntax-error #f (format "Runtime error: got ~s" exn)
                                                         #'stx))])
                    expr)])
             (unless (equal? actual expected)
               (raise-syntax-error #f (format "Expected ~s, got ~s" expected actual)
                                   #'stx))
             (printf "ok.\n\n")))))]))


;; evaluating single expression
(define -E (delay (make-evaluate
                   (lambda (a-statement+inspector op)
                     (let* ([a-statement (car a-statement+inspector)]
                            [inspector (cdr a-statement+inspector)]
                            [snippet (assemble-statement a-statement)]
                            [code
                             (string-append
                              "(function() { "

                              runtime
                              "var RT = plt.runtime;"
                              "var M = new plt.runtime.Machine();\n"

                              "return function(success, fail, params){" 
			      snippet
                              (format "success(plt.runtime.toDisplayedString(~a)); };" inspector)
                              "});")])
                       (displayln snippet)
                       (display code op))))))
(define (E-single a-statement (inspector "M.val"))
  (evaluated-value ((force -E) (cons a-statement inspector))))

;; evaluating many expressions[.
(define -E-many (delay (make-evaluate
                        (lambda (a-statement+inspector op)
                          (let* ([a-statement (car a-statement+inspector)]
                                 [inspector (cdr a-statement+inspector)])

                            (display runtime op)
                            "var RT = plt.runtime;"
                            (display "var M = new plt.runtime.Machine();\n" op)                           
                            (display "(function() { " op)
                            (display "var myInvoke = " op)
                            (assemble/write-invoke a-statement op)
                            (display ";" op)
                            (fprintf op 
                                     "return function(succ, fail, params) {
                                           var newParams = { currentDisplayer: function(M, v) {
                                                                    params.currentDisplayer(v); } };

                                           myInvoke(M,
                                                    function(v) { succ(plt.runtime.toDisplayedString(~a));},
                                                    function(M, exn) { fail(exn); },
                                                    newParams);
                                      }"
                                     inspector)
                            (display "})" op))))))
(define (E-many stmts (inspector "M.val"))
  (evaluated-value ((force -E-many) (cons stmts inspector))))








;; Assigning a number
(test (E-single (make-AssignImmediateStatement 'val (make-Const 42)))
      "42")
;; Assigning a string
(test (E-single (make-AssignImmediateStatement 'val (make-Const "Danny")))
      "Danny")
;; Assigning a cons
(test (E-single (make-AssignImmediateStatement 'val (make-Const (cons 1 2))))
      "(1 . 2)")
;; Assigning a void
(test (E-single (make-AssignImmediateStatement 'val (make-Const (void))))
      "#<void>")
;; Assigning to proc means val should still be uninitialized.
(test (E-single (make-AssignImmediateStatement 'proc (make-Const "Danny")))
      "#<undefined>")
;; But we should see the assignment if we inspect M.proc.
(test (E-single (make-AssignImmediateStatement 'proc (make-Const "Danny"))
                "M.proc")
      "Danny")


(test (E-single (make-PushEnvironment 1 #f)
                "M.env.length")
      "1")
(test (E-single (make-PushEnvironment 20 #f)
                "M.env.length")
      "20")

;; PopEnvironment
(test (E-many (list (make-PushEnvironment 2 #f))
              "M.env.length")
      "2")
(test (E-many (list (make-PushEnvironment 2 #f)
                    (make-PopEnvironment (make-Const 1) 
                                         (make-Const 0)))
              "M.env.length")
      "1")



;; Assigning to the environment
(test (E-many (list (make-PushEnvironment 2 #f)
                    (make-AssignImmediateStatement (make-EnvLexicalReference 0 #f)
                                                   (make-Const 12345)))
              "M.env[1]")
      "12345")
(test (E-many (list (make-PushEnvironment 2 #f)
                    (make-AssignImmediateStatement (make-EnvLexicalReference 0 #f)
                                                   (make-Const 12345)))
              "M.env[0]")
      "#<undefined>")
(test (E-many (list (make-PushEnvironment 2 #f)
                    (make-AssignImmediateStatement (make-EnvLexicalReference 1 #f)
                                                   (make-Const 12345)))
              "M.env[0]")
      "12345")


;; Toplevel Environment loading
(test (E-single (make-PerformStatement (make-ExtendEnvironment/Prefix! '(pi)))
                "plt.runtime.toWrittenString(M.env[0]).slice(0, 5)")
      "3.141")



;; Simple application
;; (test (E-many (list (make-PerformStatement (make-ExtendEnvironment/Prefix! '(+)))
;;                     (make-AssignImmediateStatement 'proc (make-EnvPrefixReference 0 0))
;;                     (make-PushEnvironment 2 #f)
;;                     (make-AssignImmediateStatement (make-EnvLexicalReference 0 #f)
;;                                                    (make-Const 3))
;;                     (make-AssignImmediateStatement (make-EnvLexicalReference 1 #f)
;;                                                    (make-Const 4))
;;                     (make-AssignImmediateStatement 'argcount (make-Const 2))
;;                     (make-AssignPrimOpStatement 'val (make-ApplyPrimitiveProcedure))
;;                     'done))
;;       "7")




;; A do-nothing closure
(test (E-many (list (make-GotoStatement (make-Label 'afterLambda))
                    'closureStart
                    (make-GotoStatement (make-Label 'afterLambda))
                    'afterLambda
                    (make-AssignPrimOpStatement 'val (make-MakeCompiledProcedure 'closureStart 0 '() 'closureStart)))
              "M.val.displayName")
      "closureStart")


;; A do-nothing closure with a few values
(test (E-many (list (make-GotoStatement (make-Label 'afterLambda))
                    'closureStart
                    (make-GotoStatement (make-Label 'afterLambda))
                    'afterLambda
                    (make-PushEnvironment 2 #f)
                    (make-AssignImmediateStatement (make-EnvLexicalReference 0 #f)
                                                   (make-Const "hello"))
                    (make-AssignImmediateStatement (make-EnvLexicalReference 1 #f)
                                                   (make-Const "world"))
                    (make-AssignPrimOpStatement 'val (make-MakeCompiledProcedure 'closureStart 0 
                                                                                 (list 0 1)
                                                                                 'closureStart)))
              "M.val.closedVals[1] + ',' + M.val.closedVals[0]")
      "hello,world")

;; Let's try to install the closure values.
(test (E-many (list (make-GotoStatement (make-Label 'afterLambdaBody))
                    
                    'closureStart
                    (make-PerformStatement (make-InstallClosureValues!))
                    (make-GotoStatement (make-Label 'theEnd))

                    'afterLambdaBody
                    (make-PushEnvironment 2 #f)
                    (make-AssignImmediateStatement (make-EnvLexicalReference 0 #f)
                                                   (make-Const "hello"))
                    (make-AssignImmediateStatement (make-EnvLexicalReference 1 #f)
                                                   (make-Const "world"))
                    (make-AssignPrimOpStatement 'proc (make-MakeCompiledProcedure 'closureStart 0 
                                                                                 (list 0 1)
                                                                                 'closureStart))
                    (make-PopEnvironment (make-Const 2) 
                                         (make-Const 0))
                    (make-GotoStatement (make-Label 'closureStart))
                    'theEnd)
              "plt.runtime.toWrittenString(M.env.length) + ',' + M.env[1] + ',' + M.env[0]")
      "2,hello,world")



;; get-compiled-procedure-entry
(test (E-many (list (make-GotoStatement (make-Label 'afterLambdaBody))
                    
                    'closureStart
                    (make-PerformStatement (make-InstallClosureValues!))
                    (make-GotoStatement (make-Label 'theEnd))

                    'afterLambdaBody
                    (make-PushEnvironment 2 #f)
                    (make-AssignImmediateStatement (make-EnvLexicalReference 0 #f)
                                                   (make-Const "hello"))
                    (make-AssignImmediateStatement (make-EnvLexicalReference 1 #f)
                                                   (make-Const "world"))
                    (make-AssignPrimOpStatement 'proc (make-MakeCompiledProcedure 'closureStart 0 
                                                                                 (list 0 1)
                                                                                 'closureStart))
                    (make-PopEnvironment (make-Const 2) (make-Const 0))
                    (make-AssignPrimOpStatement 'val (make-GetCompiledProcedureEntry))
                    'theEnd)
              "typeof(M.val) + ',' + (M.val === M.proc.label)")
      "function,true")


;; check-closure-arity.  This should succeed.
(void (E-many (list (make-GotoStatement (make-Label 'afterLambdaBody))
                    
                    'closureStart
                    (make-PerformStatement (make-InstallClosureValues!))
                    (make-GotoStatement (make-Label 'theEnd))

                    'afterLambdaBody
                    (make-PushEnvironment 2 #f)
                    (make-AssignImmediateStatement (make-EnvLexicalReference 0 #f)
                                                   (make-Const "hello"))
                    (make-AssignImmediateStatement (make-EnvLexicalReference 1 #f)
                                                   (make-Const "world"))
                    (make-AssignPrimOpStatement 'proc (make-MakeCompiledProcedure 'closureStart 5 
                                                                                  (list 0 1)
                                                                                  'closureStart))
                    (make-PopEnvironment (make-Const 2) (make-Const 0))
                    (make-PerformStatement (make-CheckClosureAndArity! (make-Const 5)))
                    'theEnd)))

;; this should fail, since the check is for 1, but the closure expects 5.
(let/ec return
  (with-handlers ([void
                   (lambda (exn) (return))])
    (E-many (list (make-GotoStatement (make-Label 'afterLambdaBody))
                  
                  'closureStart
                  (make-PerformStatement (make-InstallClosureValues!))
                  (make-GotoStatement (make-Label 'theEnd))
                  
                  'afterLambdaBody
                  (make-PushEnvironment 2 #f)
                  (make-AssignImmediateStatement (make-EnvLexicalReference 0 #f)
                                                 (make-Const "hello"))
                  (make-AssignImmediateStatement (make-EnvLexicalReference 1 #f)
                                                 (make-Const "world"))
                  (make-AssignPrimOpStatement 'proc (make-MakeCompiledProcedure 'closureStart 5 
                                                                                (list 0 1)
                                                                                'closureStart))
                  (make-PopEnvironment (make-Const 2) (make-Const 0))
                  (make-PerformStatement (make-CheckClosureAndArity! (make-Const 1)))
                  'theEnd)))
  (error 'expected-failure))





(test (E-many `(,(make-AssignImmediateStatement 'val (make-Const 42))
                ,(make-TestAndJumpStatement (make-TestFalse (make-Reg 'val)) 'onFalse)
                ,(make-AssignImmediateStatement 'val (make-Const 'ok))
                ,(make-GotoStatement (make-Label 'end))
                onFalse
                ,(make-AssignImmediateStatement 'val (make-Const 'not-ok))
                end))
      "ok")

;; TestAndBranch: try the false branch
(test (E-many `(,(make-AssignImmediateStatement 'val (make-Const #f))
                ,(make-TestAndJumpStatement (make-TestFalse (make-Reg 'val)) 'onFalse)
                ,(make-AssignImmediateStatement 'val (make-Const 'not-ok))
                ,(make-GotoStatement (make-Label 'end))
                onFalse
                ,(make-AssignImmediateStatement 'val (make-Const 'ok))
                end))
      "ok")

;; ;; Test for primitive procedure
;; (test (E-many `(,(make-AssignImmediateStatement 'val (make-Const '+))
;;                 ,(make-TestAndJumpStatement (make-TestPrimitiveProcedure (make-Reg 'val)) 'onTrue)
;;                 ,(make-AssignImmediateStatement 'val (make-Const 'ok))
;;                 ,(make-GotoStatement (make-Label 'end))
;;                 onTrue
;;                 ,(make-AssignImmediateStatement 'val (make-Const 'not-ok))
;;                 end))
;;       "ok")

;; ;; Give a primitive procedure in val
;; (test (E-many `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(+)))
;;                 ,(make-AssignImmediateStatement 'val (make-EnvPrefixReference 0 0))
;;                 ,(make-TestAndJumpStatement (make-TestPrimitiveProcedure (make-Reg 'val)) 'onTrue)
;;                 ,(make-AssignImmediateStatement 'val (make-Const 'not-ok))
;;                 ,(make-GotoStatement (make-Label 'end))
;;                 onTrue
;;                 ,(make-AssignImmediateStatement 'val (make-Const 'ok))
;;                 end))
;;       "ok")

;; ;; Give a primitive procedure in proc, but test val
;; (test (E-many `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(+)))
;;                 ,(make-AssignImmediateStatement 'proc (make-EnvPrefixReference 0 0))
;;                 ,(make-TestAndJumpStatement (make-TestPrimitiveProcedure (make-Reg 'val)) 'onTrue)
;;                 ,(make-AssignImmediateStatement 'val (make-Const 'not-a-procedure))
;;                 ,(make-GotoStatement (make-Label 'end))
;;                 onTrue
;;                 ,(make-AssignImmediateStatement 'val (make-Const 'a-procedure))
;;                 end))
;;       "not-a-procedure")

;; ;; Give a primitive procedure in proc and test proc
;; (test (E-many `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(+)))
;;                 ,(make-AssignImmediateStatement 'proc (make-EnvPrefixReference 0 0))
;;                 ,(make-TestAndJumpStatement (make-TestPrimitiveProcedure (make-Reg 'proc)) 'onTrue)
;;                 ,(make-AssignImmediateStatement 'val (make-Const 'not-a-procedure))
;;                 ,(make-GotoStatement (make-Label 'end))
;;                 onTrue
;;                 ,(make-AssignImmediateStatement 'val (make-Const 'a-procedure))
;;                 end))
;;       "a-procedure")



;; Set-toplevel
(test (E-many `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(advisor)))
                ,(make-AssignImmediateStatement 'val (make-Const "Kathi"))
                ,(make-AssignImmediateStatement (make-EnvPrefixReference 0 0) (make-Reg 'val)))
              "M.env[0][0]")
      "Kathi")


;; check-toplevel-bound
(let/ec return
  (let ([dont-care 
         (with-handlers ([void (lambda (exn) (return))])
           (E-many `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(some-variable)))
                     ,(make-PerformStatement (make-CheckToplevelBound! 0 0)))))])
    (raise "I expected an error")))
  
;; check-toplevel-bound shouldn't fail here.
(test (E-many `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(another-advisor)))
                ,(make-AssignImmediateStatement 'val (make-Const "Shriram"))
                ,(make-AssignImmediateStatement (make-EnvPrefixReference 0 0) (make-Reg 'val))
                ,(make-PerformStatement (make-CheckToplevelBound! 0 0)))
              "M.env[0][0]")
      "Shriram")



(test (E-many `(,(make-PushEnvironment 1 #f)
                ,(make-AssignImmediateStatement (make-EnvLexicalReference 0 #f)
                                                (make-Const '(1 2 3)))
                ,(make-AssignImmediateStatement 'argcount (make-Const 1))
                ,(make-PerformStatement (make-SpliceListIntoStack! (make-Const 0))))
              "M.argcount + ',' + M.env[0] + ',' + M.env[1] + ',' + M.env[2]")
      "3,3,2,1")


(test (E-many `(,(make-PushEnvironment 3 #f)
                ,(make-AssignImmediateStatement (make-EnvLexicalReference 0 #f)
                                                (make-Const "hello"))
                ,(make-AssignImmediateStatement (make-EnvLexicalReference 1 #f)
                                                (make-Const "world"))
                ,(make-AssignImmediateStatement (make-EnvLexicalReference 2 #f)
                                                (make-Const '(1 2 3)))
                ,(make-AssignImmediateStatement 'argcount (make-Const 3))
                ,(make-PerformStatement (make-SpliceListIntoStack! (make-Const 2))))
              "M.argcount + ',' + M.env[0] + ',' + M.env[1] + ',' + M.env[2] + ',' + M.env[3] + ',' + M.env[4]")
      "5,3,2,1,world,hello")







;; testing rest splicing
(test (E-many `(,(make-PushEnvironment 1 #f)
                ,(make-AssignImmediateStatement (make-EnvLexicalReference 0 #f)
                                                (make-Const "hello"))
                ,(make-AssignImmediateStatement 'argcount (make-Const 1))
                ,(make-PerformStatement (make-UnspliceRestFromStack! (make-Const 0)
                                                                     (make-Const 1))))
              "M.argcount + ',' + plt.runtime.isList(M.env[0])")
      "1,true")


(test (E-many
       `(,(make-PushEnvironment 5 #f)
         ,(make-AssignImmediateStatement (make-EnvLexicalReference 0 #f)
                                         (make-Const "hello"))
         ,(make-AssignImmediateStatement (make-EnvLexicalReference 1 #f)
                                         (make-Const "world"))
         ,(make-AssignImmediateStatement (make-EnvLexicalReference 2 #f)
                                         (make-Const 'x))
         ,(make-AssignImmediateStatement (make-EnvLexicalReference 3 #f)
                                         (make-Const 'y))
         ,(make-AssignImmediateStatement (make-EnvLexicalReference 4 #f)
                                         (make-Const 'z))
         ,(make-AssignImmediateStatement 'argcount (make-Const 5))
         ,(make-PerformStatement (make-UnspliceRestFromStack! (make-Const 2)  (make-Const 3))))
       "M.argcount + ',' + M.env.length + ',' + plt.runtime.isList(M.env[0]) + ',' + M.env[2] + ',' + M.env[1]")
      "3,3,true,hello,world")



;; Check closure mismatch.  Make sure we're getting the right values from the test.
(test (E-many `(procedure-entry
                        ;; doesn't matter about the procedure entry...
                        ,(make-AssignPrimOpStatement 
                          'proc
                          (make-MakeCompiledProcedure 'procedure-entry 0 (list) 'procedure-entry))
                        ,(make-TestAndJumpStatement
                          (make-TestClosureArityMismatch (make-Reg 'proc) (make-Const 0))
                          'bad)
                        ,(make-AssignImmediateStatement 'val (make-Const 'ok))
                        ,(make-GotoStatement (make-Label 'end))
                        bad
                        ,(make-AssignImmediateStatement 'val (make-Const 'bad))
                        end)
              "M.val")
      "ok")
      

(test (E-many `(procedure-entry
                        ;; doesn't matter about the procedure entry...
                        ,(make-AssignPrimOpStatement 
                          'proc
                          (make-MakeCompiledProcedure 'procedure-entry 0 (list) 'procedure-entry))
                        ,(make-TestAndJumpStatement
                          (make-TestClosureArityMismatch (make-Reg 'proc) (make-Const 1))
                          'ok)
                        ,(make-AssignImmediateStatement 'val (make-Const 'bad))
                        ,(make-GotoStatement (make-Label 'end))
                        ok
                        ,(make-AssignImmediateStatement 'val (make-Const 'ok))
                        end)
              "M.val")
      "ok")

(test (E-many `(procedure-entry
                        ;; doesn't matter about the procedure entry...
                        ,(make-AssignPrimOpStatement 
                          'proc
                          (make-MakeCompiledProcedure 'procedure-entry (make-ArityAtLeast 2) (list) 'procedure-entry))
                        ,(make-TestAndJumpStatement
                          (make-TestClosureArityMismatch (make-Reg 'proc) (make-Const 0))
                          'ok)
                        ,(make-AssignImmediateStatement 'val (make-Const 'bad))
                        ,(make-GotoStatement (make-Label 'end))
                        ok
                        ,(make-AssignImmediateStatement 'val (make-Const 'ok))
                        end)
              "M.val")
      "ok")

(test (E-many `(procedure-entry
                        ;; doesn't matter about the procedure entry...
                        ,(make-AssignPrimOpStatement 
                          'proc
                          (make-MakeCompiledProcedure 'procedure-entry (make-ArityAtLeast 2) (list) 'procedure-entry))
                        ,(make-TestAndJumpStatement
                          (make-TestClosureArityMismatch (make-Reg 'proc) (make-Const 2))
                          'bad)
                        ,(make-AssignImmediateStatement 'val (make-Const 'ok))
                        ,(make-GotoStatement (make-Label 'end))
                        bad
                        ,(make-AssignImmediateStatement 'val (make-Const 'bad))
                        end)
              "M.val")
      "ok")




;; Let's test closure value lookup.
(test (E-many `(,(make-PushImmediateOntoEnvironment (make-Const 3) #f)
                ,(make-PushImmediateOntoEnvironment (make-Const 4) #f)
                procedure-entry
                ;; doesn't matter about the procedure entry...
                ,(make-AssignPrimOpStatement 
                          'proc
                          (make-MakeCompiledProcedure 'procedure-entry (make-ArityAtLeast 2) (list 0 1) 'procedure-entry))
                ,(make-AssignImmediateStatement 'val (make-CompiledProcedureClosureReference (make-Reg 'proc) 0)))
              "M.val")
      "4")

(test (E-many `(,(make-PushImmediateOntoEnvironment (make-Const 3) #f)
                ,(make-PushImmediateOntoEnvironment (make-Const 4) #f)
                procedure-entry
                ;; doesn't matter about the procedure entry...
                ,(make-AssignPrimOpStatement 
                          'proc
                          (make-MakeCompiledProcedure 'procedure-entry (make-ArityAtLeast 2) (list 0 1) 'procedure-entry))
                ,(make-AssignImmediateStatement 'val (make-CompiledProcedureClosureReference (make-Reg 'proc) 1)))
              "M.val")
      "3")