From f809cd3dfb7796a85d10a92448a8445f6c1eecea Mon Sep 17 00:00:00 2001 From: Matthew Butterick Date: Sat, 22 Aug 2015 17:14:23 -0700 Subject: [PATCH] speed improvements --- cache-ns.rkt | 32 ++++++++++++++++++------- cache.rkt | 51 +++++++++------------------------------- render.rkt | 66 +++++++++++++--------------------------------------- 3 files changed, 51 insertions(+), 98 deletions(-) diff --git a/cache-ns.rkt b/cache-ns.rkt index 22fa7fb..ef72982 100644 --- a/cache-ns.rkt +++ b/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)] - [NS-NAME (format-id stx "~a" #'name)]) + #'(define-caching-ns name null)] + [(_ 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)) diff --git a/cache.rkt b/cache.rkt index caf7050..4858a08 100644 --- a/cache.rkt +++ b/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)]) - (apply copy-from-namespace caching-module-ns (current-namespace) cached-module-names) - (hash subkey (dynamic-require (if (eq? subkey (world:current-meta-export)) - `(submod ,path ,subkey) ; use metas submodule for speed - path) subkey)))) + (define kvs + (let ([meta-key (world:current-meta-export)]) + (parameterize ([current-namespace (make-base-namespace)]) + (if (eq? subkey meta-key) + (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)]) diff --git a/render.rkt b/render.rkt index a752ed3..fb0666f 100644 --- a/render.rkt +++ b/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-directory-require-files source-path) - (let ([,(world:current-main-export) (cached-require ,(path->string source-path) ',(world:current-main-export))] - [,(world:current-meta-export) (cached-require ,(path->string source-path) ',(world:current-meta-export))]) - (local-require pollen/pagetree pollen/template pollen/top) - (define here (metas->here ,(world:current-meta-export))) - (cond - [(bytes? ,(world:current-main-export)) ,(world:current-main-export)] ; if main export is binary, just pass it through - [else - (include-template #:command-char ,(world:current-command-char) (file ,(->string (find-relative-path source-dir template-path))))])))) + (require pollen/include-template pollen/cache pollen/debug pollen/pagetree) + ,(require-directory-require-files source-path) + (parameterize ([current-pagetree (make-project-pagetree ,(world:current-project-root))]) + (let ([,(world:current-main-export) (cached-require ,(path->string source-path) ',(world:current-main-export))] + [,(world:current-meta-export) (cached-require ,(path->string source-path) ',(world:current-meta-export))]) + (local-require pollen/template pollen/top) + (define here (metas->here ,(world:current-meta-export))) + (cond + [(bytes? ,(world:current-main-export)) ,(world:current-main-export)] ; if main export is binary, just pass it through + [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))]) - (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 + (let ([source-metas (cached-require source-path (world:current-meta-export))]) + (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 (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-pagetree (make-project-pagetree (world:current-project-root))]) - (apply copy-from-namespace caching-module-ns (current-namespace) cached-module-names) - (eval expr-to-eval (current-namespace)))) \ No newline at end of file + [current-output-port (current-error-port)]) + (eval expr-to-eval))) \ No newline at end of file