speed improvements

cache-ns.rkt

@@ -1,22 +1,38 @@
 #lang racket/base
-(require (for-syntax racket/base racket/syntax))
+(require (for-syntax racket/base racket/syntax) sugar/test)
 (provide (all-defined-out))
 
 (define-syntax (define-caching-ns stx)
   (syntax-case stx ()
     [(_ name)
-     (with-syntax ([caching-module-name (generate-temporary)]
+     #'(define-caching-ns name null)]
-                   [NS-NAME (format-id stx "~a" #'name)])
+    [(_ name mods)
+     (with-syntax ([caching-module-name (generate-temporary)])
        #'(begin
            (module caching-module-name racket/base
              (define-namespace-anchor nsa) ; could handle this macro-introduced name better
              (provide nsa))
            (require 'caching-module-name)
-           (define NS-NAME (namespace-anchor->namespace nsa))))]))
+           (define name (namespace-anchor->namespace nsa))
+           (require-in-namespace name mods)))]))
+
+(define (require-in-namespace ns module-names)
+  (parameterize ([current-namespace ns])
+    (for-each (λ(mod-name) (namespace-require mod-name)) module-names)))
+
+(define (attach-from-namespace from-ns to-ns module-names)
+  (for-each (λ(mod-name) (namespace-attach-module from-ns mod-name to-ns)) module-names)
+  (require-in-namespace to-ns module-names))
+
+
+(module-test-external
+ (define module-names '(xml racket/function))
+ (define-caching-ns from-ns module-names)
+ (check-true (eval '(andmap procedure? (list xexpr? curry)) from-ns))
+ 
+ (define to-ns (make-base-namespace))
+ (attach-from-namespace from-ns to-ns module-names)
+ (check-true (eval '(andmap procedure? (list xexpr? curry)) to-ns)))
 
 
-(define (load-in-namespace to-ns . module-names)
-  (for-each (λ(mn) (eval `(require ,mn) to-ns)) module-names))
 
-(define (copy-from-namespace from-ns to-ns . module-names)
-  (for-each (λ(mn) (namespace-attach-module from-ns mn to-ns)) module-names))

cache.rkt

@@ -1,5 +1,5 @@
 #lang racket/base
-(require racket/path racket/file file/cache sugar/coerce "project.rkt" "world.rkt" "rerequire.rkt" "cache-ns.rkt")
+(require racket/path racket/file file/cache sugar/coerce "project.rkt" "world.rkt" "rerequire.rkt" "cache-ns.rkt" "debug.rkt")
 
 ;; The cache is a hash with paths as keys.
 ;; The cache values are also hashes, with key/value pairs for that path.
@@ -38,48 +38,17 @@
   (and directory-require-files (map dynamic-rerequire directory-require-files))
   (void))
 
-;; set up namespace for module caching
-(define-caching-ns caching-module-ns)
-(define cached-module-names '(xml
-                              racket/bool
-                              racket/class
-                              racket/contract 
-                              racket/draw
-                              racket/file
-                              racket/format
-                              racket/function
-                              racket/port 
-                              racket/list
-                              racket/match
-                              racket/string
-                              racket/syntax
-                              ;pollen/cache ;; causes loading cycle
-                              pollen/debug
-                              pollen/decode
-                              pollen/file
-                              pollen/include-template
-                              ;pollen/main ;; causes loading cycle
-                              pollen/reader-base
-                              ;pollen/pagetree ;; causes loading cycle
-                              pollen/rerequire
-                              pollen/tag
-                              ;pollen/template ;; causes loading cycle
-                              pollen/world
-                              pollen/project
-                              sugar
-                              txexpr))
-
-
 
 (define (path->hash path subkey)
-  (dynamic-rerequire path)
   ;; new namespace forces dynamic-require to re-instantiate 'path'
   ;; otherwise it gets cached in current namespace.
-  (parameterize ([current-namespace (make-base-namespace)])
+  (define kvs
-    (apply copy-from-namespace caching-module-ns (current-namespace) cached-module-names)
+    (let ([meta-key (world:current-meta-export)])
-    (hash subkey (dynamic-require (if (eq? subkey (world:current-meta-export))
+      (parameterize ([current-namespace (make-base-namespace)])
-                                      `(submod ,path ,subkey) ; use metas submodule for speed
+        (if (eq? subkey meta-key)
-                                      path) subkey))))
+            (list meta-key (dynamic-require (list 'submod path 'metas) meta-key))
+            (list subkey (dynamic-require path subkey) meta-key (dynamic-require path meta-key))))))
+  (apply hash kvs))
 
 ;; include this from 6.2 for compatibility back to 6.0 (formerly `make-parent-directory*`)
 (define (make-parent-directory p)
@@ -120,7 +89,9 @@
                                                       #:exists-ok? #t
                                                       key
                                                       cache-dir
-                                                      (λ _ (write-to-file (path->hash path subkey) dest-file #:exists 'replace))
+                                                      (λ _
+                                                        (message (format "caching: ~a from ~a" subkey (find-relative-path (current-directory) path)))
+                                                        (write-to-file (path->hash path subkey) dest-file #:exists 'replace))
                                                       #:max-cache-size (world:current-compile-cache-max-size))
                                           (file->value dest-file))) subkey)]
     [else (parameterize ([current-namespace (make-base-namespace)])

render.rkt

@@ -178,16 +178,17 @@
   (define expr-to-eval 
     `(begin 
        (require (for-syntax racket/base))
-       (require pollen/include-template pollen/cache pollen/debug)
+       (require pollen/include-template pollen/cache pollen/debug pollen/pagetree)
        ,(require-directory-require-files source-path)
-       (let ([,(world:current-main-export) (cached-require ,(path->string source-path) ',(world:current-main-export))]
+       (parameterize ([current-pagetree (make-project-pagetree ,(world:current-project-root))])
-             [,(world:current-meta-export) (cached-require ,(path->string source-path) ',(world:current-meta-export))])
+         (let ([,(world:current-main-export) (cached-require ,(path->string source-path) ',(world:current-main-export))]
-         (local-require pollen/pagetree pollen/template pollen/top)
+               [,(world:current-meta-export) (cached-require ,(path->string source-path) ',(world:current-meta-export))])
-         (define here (metas->here ,(world:current-meta-export)))
+           (local-require pollen/template pollen/top)
-         (cond 
+           (define here (metas->here ,(world:current-meta-export)))
-           [(bytes? ,(world:current-main-export)) ,(world:current-main-export)] ; if main export is binary, just pass it through
+           (cond 
-           [else
+             [(bytes? ,(world:current-main-export)) ,(world:current-main-export)] ; if main export is binary, just pass it through
-            (include-template #:command-char ,(world:current-command-char) (file ,(->string (find-relative-path source-dir template-path))))]))))
+             [else
+              (include-template #:command-char ,(world:current-command-char) (file ,(->string (find-relative-path source-dir template-path))))])))))
   (time (parameterize ([current-directory (->complete-path source-dir)]) ; because include-template wants to work relative to source location
           (render-through-eval expr-to-eval))))
 
@@ -208,9 +209,9 @@
                          (list
                           ;; this op touches the cache so set up current-directory correctly
                           (parameterize ([current-directory (world:current-project-root)])
-                          (let ([source-metas (cached-require source-path (world:current-meta-export))])
+                            (let ([source-metas (cached-require source-path (world:current-meta-export))])
-                            (and (hash-has-key? source-metas (->symbol (world:current-template-meta-key)))
+                              (and (hash-has-key? source-metas (->symbol (world:current-template-meta-key)))
-                                 (build-path source-dir (select-from-metas (->string (world:current-template-meta-key)) source-metas))))) ; path based on metas
+                                   (build-path source-dir (select-from-metas (->string (world:current-template-meta-key)) source-metas))))) ; path based on metas
                           (and (filename-extension output-path) (build-path (world:current-project-root) 
                                                                             (add-ext (world:current-default-template-prefix) (get-ext output-path))))))) ; path to default template
           (and (filename-extension output-path) (build-path (world:current-server-extras-path) (add-ext (world:current-fallback-template-prefix) (get-ext output-path)))))))) ; fallback template
@@ -223,43 +224,8 @@
        (> (length (dynamic-rerequire source-path)) 0)))
 
 
-;; set up namespace for module caching
-(define-caching-ns caching-module-ns)
-(define cached-module-names '(xml
-                                   racket/bool
-                                   racket/class
-                                   racket/contract 
-                                   racket/draw
-                                   racket/file
-                                   racket/format
-                                   racket/function
-                                   racket/port 
-                                   racket/list
-                                   racket/match
-                                   racket/string
-                                   racket/syntax
-                                   pollen/cache
-                                   pollen/debug
-                                   pollen/decode
-                                   pollen/file
-                                   pollen/include-template
-                                   pollen/main
-                                   pollen/reader-base
-                                   pollen/pagetree
-                                   pollen/rerequire
-                                   pollen/tag
-                                   pollen/template
-                                   pollen/world
-                                   pollen/project
-                                   sugar
-                                   txexpr))
-
-(apply load-in-namespace caching-module-ns cached-module-names)
-
 (define/contract (render-through-eval expr-to-eval)
   (list? . -> . (or/c string? bytes?))
   (parameterize ([current-namespace (make-base-namespace)]
-                 [current-output-port (current-error-port)]
+                 [current-output-port (current-error-port)])
-                 [current-pagetree (make-project-pagetree (world:current-project-root))])
+    (eval expr-to-eval)))
-    (apply copy-from-namespace caching-module-ns (current-namespace) cached-module-names)   
-    (eval expr-to-eval (current-namespace))))