continuing to parse lams. temporarily broken

assemble.rkt

@@ -8,6 +8,7 @@
          "assemble-expression.rkt"
          "assemble-perform-statement.rkt"
          "collect-jump-targets.rkt"
+         "expression-structs.rkt"
          racket/string
          racket/list)
 

expression-structs.rkt

@@ -62,17 +62,28 @@
                         [consequent : Expression]
                         [alternative : Expression]) #:transparent)
 
-(define-struct: CaseLam ([name : (U Symbol False)]
+(define-struct: CaseLam ([name : (U Symbol LamPositionalName)]
                          [clauses : (Listof Lam)]
                          [entry-label : Symbol]) #:transparent)
 
-(define-struct: Lam ([name : (U Symbol False)]
+(define-struct: Lam ([name : (U Symbol LamPositionalName)]
                      [num-parameters : Natural]
                      [rest? : Boolean]
                      [body : Expression]
                      [closure-map : (Listof Natural)]
                      [entry-label : Symbol]) #:transparent)
 
+
+;; We may have more information about the lambda's name.  This will show it.
+(define-struct: LamPositionalName ([name : Symbol] 
+                                   [path : String] 
+                                   [line : Natural] 
+                                   [column : Natural] 
+                                   [offset : Natural] 
+                                   [span : Natural]) #:transparent)
+
+
+
 (define-struct: Seq ([actions : (Listof Expression)]) #:transparent)
 (define-struct: Splice ([actions : (Listof Expression)]) #:transparent)
 (define-struct: App ([operator : Expression]
@@ -123,3 +134,13 @@
 
 (: rest-exps ((Listof Expression) -> (Listof Expression)))
 (define (rest-exps seq) (cdr seq))
+
+
+
+
+(: make-label (Symbol -> Symbol))
+(define make-label
+  (let ([n 0])
+    (lambda (l)
+      (set! n (add1 n))
+      (string->symbol (format "~a~a" l n)))))

il-structs.rkt

@@ -395,12 +395,6 @@
   #:transparent)
 (define empty-instruction-sequence (make-instruction-sequence '()))
 
-(: make-label (Symbol -> Symbol))
-(define make-label
-  (let ([n 0])
-    (lambda (l)
-      (set! n (add1 n))
-      (string->symbol (format "~a~a" l n)))))
 
 
 (: statements (InstructionSequence -> (Listof Statement)))

parse-bytecode-5.1.1.rkt

@@ -30,10 +30,16 @@
      (error 'current-module-path-index-resolver))))
 
 
+;; seen-lambdas: 
+(define seen-lambdas (make-parameter (make-hasheq)))
+
+
+
 ;; parse-bytecode: Input-Port -> Expression
 (define (parse-bytecode in)
-  (let ([compilation-top (zo-parse in)])
-    (parse-top compilation-top)))
+  (parameterize ([seen-lambdas (make-hasheq)])
+    (let ([compilation-top (zo-parse in)])
+      (parse-top compilation-top))))
 
 
 (define (parse-top a-top)
@@ -204,7 +210,7 @@
                            (match a-provided
                              [(struct provided (name src src-name nom-mod src-phase protected? insp))
                               ;; fixme: we're not considering all of the fields here...
-                              (make-Provided name src-name)])])
+                              (make-Provided name src-name)]))])
     (let loop ([provides provides])
       (cond
         [(empty? provides)
@@ -273,17 +279,21 @@
 
 (define (parse-lam expr)
   (match expr
-    [(struct lam (name flags num-params rest? closure-map closure-types max-let-depth body))
+    [(struct lam (name flags num-params param-types rest? closure-map closure-types max-let-depth body))
      (let ([lam-name (cond
                        [(symbol? name)
                         name]
                        [(vector? name)
-                        ...]
+                        (string->symbol (format "~s" name))]
                        [else
-                        (error
-     (make-Lam 
-     ...]))
-
+                        (error "lam name neither symbol nor vector: ~e" name)])])
+       (make-Lam lam-name 
+                 num-params 
+                 rest?
+                 (parse-lam-body body)
+                 (vector->list closure-map)
+                 (make-label 'lamEntry)))]))
+               
 (define (parse-lam-body body)
   (cond
     [(expr? body)
@@ -296,7 +306,11 @@
 
 
 (define (parse-closure expr)
-  (error 'fixme))
+  (match expr
+    [(struct closure (code gen-id))
+     ;; Fixme: we must handle cycles here.
+     (parse-lam code)]))
+
 
 (define (parse-case-lam exp)
   (error 'fixme))
@@ -317,10 +331,19 @@
   (error 'fixme))
 
 (define (parse-localref expr)
-  (error 'fixme))
+  (match expr
+    [(struct localref (unbox? pos clear? other-clears? flonum?))
+     ;; FIXME: we should use clear? at the very least: as I understand it,
+     ;; this is here to maintain safe-for-space behavior.
+     ;; We should also make use of flonum information to generate better code.
+     (make-LocalRef pos unbox?)]))
+
 
 (define (parse-toplevel expr)
-  (error 'fixme))
+  (match expr
+    ;; FIXME: we should also keep track of const? and ready? to produce better code.
+    [(struct toplevel (depth pos const? ready?))
+     (make-ToplevelRef depth pos)]))
 
 (define (parse-topsyntax expr)
   (error 'fixme))

sample-small-file-bytecode.rkt

@@ -0,0 +1,14 @@
+#lang racket
+(require compiler/zo-parse)
+(require (for-syntax racket/base))
+
+(provide bytecode)
+
+
+(define bytecode
+  (parameterize ([current-namespace (make-base-namespace)])
+  (let ([bc (compile (parameterize ([read-accept-reader #t])
+                       (read (open-input-file "/home/dyoo/work/js-sicp-5-5/sample-small-file.rkt"))))]
+        [op (open-output-bytes)])
+    (write bc op)
+    (zo-parse (open-input-bytes (get-output-bytes op))))))

sample-small-file.rkt

@@ -0,0 +1,9 @@
+#lang racket/base
+(provide f)
+(define (f x)
+  (* x x))
+
+
+;; infinite loop
+(letrec ([g (lambda () (g))])
+  (g))

test-parse-bytecode-5.1.1.rkt

@@ -0,0 +1,69 @@
+#lang racket/base
+
+(require compiler/zo-parse
+         rackunit
+         (for-syntax racket/base)
+         "parse-bytecode-5.1.1.rkt"
+         "lexical-structs.rkt"
+         "expression-structs.rkt")
+
+
+(define (run-zo-parse stx)
+  (parameterize ([current-namespace (make-base-namespace)])
+    (let ([bc (compile stx)]
+          [op (open-output-bytes)])
+      (write bc op)
+      (zo-parse (open-input-bytes (get-output-bytes op))))))
+
+(define (run-my-parse stx)
+  (parameterize ([current-namespace (make-base-namespace)])
+    (let ([bc (compile stx)]
+          [op (open-output-bytes)])
+      (write bc op)
+      (parse-bytecode (open-input-bytes (get-output-bytes op))))))
+
+
+
+(check-equal? (run-my-parse #'"hello world")
+              (make-Top (make-Prefix (list))
+                        (make-Constant "hello world")))
+              
+(check-equal? (run-my-parse #'42)
+              (make-Top (make-Prefix (list))
+                        (make-Constant 42)))
+
+(check-equal? (run-my-parse #'x)
+              (make-Top (make-Prefix (list (make-GlobalBucket 'x)))
+                        (make-ToplevelRef 0 0)))
+ 
+
+
+;; Lambdas
+(run-my-parse #'(lambda (x) x))
+
+
+
+
+
+
+
+
+
+
+;; infinite loop
+#;(run-zo-parse #'(letrec ([g (lambda () (g))])
+                  (g)))
+#;(run-zo-parse #'(letrec ([g (lambda () (h))]
+                         [h (lambda () (g))])
+                  (g)))
+;; FIXME: we need to handle closure cycles here.
+
+
+
+
+
+
+
+
+;(run-zo-parse #'(lambda (x) (* x x)))
+;(run-my-parse #'(lambda (x) (* x x)))