speed improvements

pull/84/head
Matthew Butterick 9 years ago
parent 5c108ebcd6
commit f809cd3dfb

@ -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))

@ -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.
(define kvs
(let ([meta-key (world:current-meta-export)])
(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))))
(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)])

@ -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)
(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/pagetree pollen/template pollen/top)
(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))))]))))
(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))))
@ -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))))
[current-output-port (current-error-port)])
(eval expr-to-eval)))
Loading…
Cancel
Save