reducing the amount of consing to append instruction sequences together

compiler/bootstrapped-primitives.rkt

@@ -39,30 +39,29 @@
 (define (make-call/cc-code)
   (statements
    (append-instruction-sequences
-    (make-instruction-sequence 
+    call/cc-label
-     `(,call/cc-label
+    ;; Precondition: the environment holds the f function that we want to jump into.
-       ;; Precondition: the environment holds the f function that we want to jump into.
+    
-       
+    ;; First, move f to the proc register
-       ;; First, move f to the proc register
+    (make-AssignImmediateStatement 'proc (make-EnvLexicalReference 0 #f))
-       ,(make-AssignImmediateStatement 'proc (make-EnvLexicalReference 0 #f))
+    
-       
+    ;; Next, capture the envrionment and the current continuation closure,.
-       ;; Next, capture the envrionment and the current continuation closure,.
+    (make-PushEnvironment 2 #f)
-       ,(make-PushEnvironment 2 #f)
+    (make-AssignPrimOpStatement (make-EnvLexicalReference 0 #f) 
-       ,(make-AssignPrimOpStatement (make-EnvLexicalReference 0 #f) 
+                                (make-CaptureControl 0 default-continuation-prompt-tag))
-                                    (make-CaptureControl 0 default-continuation-prompt-tag))
+    (make-AssignPrimOpStatement (make-EnvLexicalReference 1 #f)
-       ,(make-AssignPrimOpStatement (make-EnvLexicalReference 1 #f)
+                                ;; When capturing, skip over f and the two slots we just added.
-                                    ;; When capturing, skip over f and the two slots we just added.
+                                (make-CaptureEnvironment 3 default-continuation-prompt-tag))
-                                    (make-CaptureEnvironment 3 default-continuation-prompt-tag))
+    (make-AssignPrimOpStatement (make-EnvLexicalReference 2 #f)
-       ,(make-AssignPrimOpStatement (make-EnvLexicalReference 2 #f)
+                                 (make-MakeCompiledProcedure call/cc-closure-entry
-                                    (make-MakeCompiledProcedure call/cc-closure-entry
+                                                             1 ;; the continuation consumes a single value
-                                                                1 ;; the continuation consumes a single value
+                                                             (list 0 1)
-                                                                (list 0 1)
+                                                             'call/cc))
-                                                                'call/cc))
+    (make-PopEnvironment (make-Const 2) 
-       ,(make-PopEnvironment (make-Const 2) 
+                          (make-Const 0))
-                             (make-Const 0))))
        
     ;; Finally, do a tail call into f.
-    (make-instruction-sequence `(,(make-AssignImmediateStatement 'argcount (make-Const 1))))
+    (make-AssignImmediateStatement 'argcount (make-Const 1))
     (compile-general-procedure-call '()
                                     (make-Const 1) ;; the stack at this point holds a single argument
                                     'val
@@ -70,15 +69,14 @@
     
     ;; The code for the continuation code follows.  It's supposed to
     ;; abandon the current continuation, initialize the control and environment, and then jump.
-    (make-instruction-sequence `(,call/cc-closure-entry
+    call/cc-closure-entry
-                                 ,(make-AssignImmediateStatement 'val (make-EnvLexicalReference 0 #f))
+    (make-AssignImmediateStatement 'val (make-EnvLexicalReference 0 #f))
-                                 ,(make-PerformStatement (make-InstallClosureValues!))
+    (make-PerformStatement (make-InstallClosureValues!))
-                                 ,(make-PerformStatement 
+    (make-PerformStatement (make-RestoreControl! default-continuation-prompt-tag))
-                                   (make-RestoreControl! default-continuation-prompt-tag))
+    (make-PerformStatement (make-RestoreEnvironment!))
-                                 ,(make-PerformStatement (make-RestoreEnvironment!))
+    (make-AssignImmediateStatement 'proc (make-ControlStackLabel))
-                                 ,(make-AssignImmediateStatement 'proc (make-ControlStackLabel))
+    (make-PopControlFrame)
-                                 ,(make-PopControlFrame)
+    (make-GotoStatement (make-Reg 'proc)))))
-                                 ,(make-GotoStatement (make-Reg 'proc)))))))
 
 
 

compiler/compiler.rkt

@@ -21,8 +21,8 @@
                [ensure-const-value (Any -> const-value)])
 
 (provide (rename-out [-compile compile])
-         compile-general-procedure-call
+         compile-general-procedure-call)
-         append-instruction-sequences)
+
 
 
 
@@ -2067,22 +2067,6 @@
 
 
 
-(: append-instruction-sequences (InstructionSequence * -> InstructionSequence))
-(define (append-instruction-sequences . seqs)
-  (append-seq-list seqs))
-
-(: append-2-sequences (InstructionSequence InstructionSequence -> InstructionSequence))
-(define (append-2-sequences seq1 seq2)
-  (make-instruction-sequence
-   (append (statements seq1) (statements seq2))))
-
-(: append-seq-list ((Listof InstructionSequence) -> InstructionSequence))
-(define (append-seq-list seqs)
-  (if (null? seqs)
-      empty-instruction-sequence
-      (append-2-sequences (car seqs)
-                          (append-seq-list (cdr seqs)))))
-
 
 (: ensure-natural (Integer -> Natural))
 (define (ensure-natural n)

compiler/il-structs.rkt

@@ -481,10 +481,16 @@
 
 
 
-(define-type InstructionSequence (U Symbol LinkedLabel Statement instruction-sequence))
+(define-type InstructionSequence (U Symbol
-(define-struct: instruction-sequence ([statements : (Listof Statement)])
+                                    LinkedLabel
+                                    Statement
+                                    instruction-sequence-list
+                                    instruction-sequence-chunks))
+(define-struct: instruction-sequence-list ([statements : (Listof Statement)])
   #:transparent)
-(define empty-instruction-sequence (make-instruction-sequence '()))
+(define-struct: instruction-sequence-chunks ([chunks : (Listof InstructionSequence)])
+  #:transparent)
+(define empty-instruction-sequence (make-instruction-sequence-list '()))
 
 
 (define-predicate Statement? Statement)
@@ -498,11 +504,28 @@
          (list s)]
         [(Statement? s)
          (list s)]
-        [else
+        [(instruction-sequence-list? s)
-         (instruction-sequence-statements s)]))
+         (instruction-sequence-list-statements s)]
+        [(instruction-sequence-chunks? s)
+         (apply append (map statements (instruction-sequence-chunks-chunks s)))]))
 
 
 
+(: append-instruction-sequences (InstructionSequence * -> InstructionSequence))
+(define (append-instruction-sequences . seqs)
+  (append-seq-list seqs))
+
+(: append-2-sequences (InstructionSequence InstructionSequence -> InstructionSequence))
+(define (append-2-sequences seq1 seq2)
+  (make-instruction-sequence-chunks (list seq1 seq2)))
+
+(: append-seq-list ((Listof InstructionSequence) -> InstructionSequence))
+(define (append-seq-list seqs)
+  (if (null? seqs)
+      empty-instruction-sequence
+      (make-instruction-sequence-chunks seqs)))
+
+
 
 
 

get-module-bytecode.rkt

@@ -60,7 +60,7 @@
   (lookup-language-namespace
    #;'racket/base
    `(file ,(path->string kernel-language-path)))
-  #;(make-base-namespace))
+   #;(make-base-namespace))
 
 
 
@@ -74,7 +74,8 @@
                           (log-debug "parsing from scratch")
                           (call-with-input-file* p
                             (lambda (ip)
-                              (get-compiled-code-from-port ip))))])
+                              (get-compiled-code-from-port ip)))
+                          )])
     (get-module-code p)))
 
 

make/make.rkt

@@ -168,8 +168,7 @@
             [(hash-has-key? visited (first sources))
              (loop (rest sources))]
             [else
-             (log-debug (format "compiling a module ~a"
+             (printf "compiling a module ~a\n" (source-name (first sources)))
-                                (source-name (first sources))))
              (hash-set! visited (first sources) #t)
              (let*-values ([(this-source)
                             ((current-module-source-compiling-hook)

parser/parse-bytecode-5.1.2.rkt

@@ -144,8 +144,11 @@
                                                   base]
                                                  [else
                                                   (error 'parse-bytecode)])])
-           (parse-bytecode
+           (define start-time (current-inexact-milliseconds))
-            (open-input-bytes (get-module-bytecode normal-path)))))]    
+           (define module-bytecode (get-module-bytecode normal-path))
+           (define stop-time (current-inexact-milliseconds))
+           (printf "  parse-bytecode get-module-bytecode: ~a milliseconds\n" (- stop-time start-time))
+           (parse-bytecode (open-input-bytes module-bytecode))))]    
       [else
        (error 'parse-bytecode "Don't know how to parse from ~e" in)]))