diff --git a/pollen/cache.rkt b/pollen/cache.rkt index 3e741fe..c42e1cb 100644 --- a/pollen/cache.rkt +++ b/pollen/cache.rkt @@ -46,7 +46,7 @@ (raise-argument-error caller-name "path to existing file" path-or-path-string)) (cond [(setup:compile-cache-active path) - (define key (paths->key path)) + (define key (paths->key 'source path)) (define (convert-path-to-cache-record) (when (let ([crs (current-render-source)]) (and crs (not (equal? crs path)))) diff --git a/pollen/private/cache-utils.rkt b/pollen/private/cache-utils.rkt index eb1586e..d0e9315 100644 --- a/pollen/private/cache-utils.rkt +++ b/pollen/private/cache-utils.rkt @@ -22,7 +22,9 @@ ;; because we don't want to attach a mod date ;; because cache validity is not sensitive to mod date of output path ;; (in fact we would expect it to be earlier, since we want to rely on an earlier version) -(define (paths->key source-path [template-path #false] [output-path #false]) +(define (paths->key cache-type source-path [template-path #false] [output-path #false]) + (unless (symbol? cache-type) + (raise-argument-error 'paths->key "symbol" cache-type)) (define path-strings-to-track (list* source-path ;; if template has a source file, track that instead @@ -38,20 +40,22 @@ (define poly-flag (and (has-inner-poly-ext? source-path) (current-poly-target))) (define path+mod-time-pairs (for/list ([ps (in-list path-strings-to-track)]) - (cond - [ps (define cp (->complete-path ps)) + (match ps + [(? symbol? sym) sym] + [#false #false] + [_ (define cp (->complete-path ps)) (unless (file-exists? cp) (message (format "watchlist file /~a does not exist" (find-relative-path (current-project-root) cp)))) - (cons (path->string cp) (file-or-directory-modify-seconds cp #false (λ () 0)))] - [else #false]))) - (list* env-rec poly-flag (and output-path (path->string output-path)) path+mod-time-pairs)) + (cons (path->string cp) (file-or-directory-modify-seconds cp #false (λ () 0)))]))) + (list* cache-type env-rec poly-flag (and output-path (path->string output-path)) path+mod-time-pairs)) -(define (key->source-path key) (car (fourth key))) -(define (key->output-path key) (third key)) +(define (key->source-path key) (car (fifth key))) +(define (key->output-path key) (fourth key)) +(define (key->type key) (car key)) (module-test-internal (define ps "/users/nobody/project/source.html.pm") - (check-equal? (key->source-path (paths->key ps)) ps)) + (check-equal? (key->source-path (paths->key 'source ps)) ps)) (define-namespace-anchor cache-utils-module-ns) @@ -94,11 +98,11 @@ (values cache-dir private-cache-dir)) (define (cache-ref! key path-hash-thunk - #:dest-path [path-for-dest 'source] #:notify-cache-use [notify-proc void]) - (define dest-path ((case path-for-dest - [(source) key->source-path] - [(output) key->output-path]) key)) + (define dest-path ((match (key->type key) + ['source key->source-path] + ['output key->output-path] + ['template (λ (k) (path-add-extension (key->source-path key) (string->bytes/utf-8 (format ".~a-template" (current-poly-target)))))]) key)) (define-values (cache-dir private-cache-dir) (make-cache-dirs dest-path)) (define-values (dest-path-dir dest-path-filename _) (split-path dest-path)) (define dest-file (build-path cache-dir (format "~a.rktd" dest-path-filename))) @@ -124,4 +128,4 @@ [(or "cache attempt failed: could not acquire exclusive lock" "cache attempt failed: could not acquire shared lock") (void)] [_ (log-pollen-error str)]))) - (deserialize (file->value dest-file))) \ No newline at end of file + (deserialize (file->value dest-file))) diff --git a/pollen/private/preheat-cache.rkt b/pollen/private/preheat-cache.rkt index 617cecc..9e5f12a 100644 --- a/pollen/private/preheat-cache.rkt +++ b/pollen/private/preheat-cache.rkt @@ -14,7 +14,7 @@ (define-values (_ private-cache-dir) (make-cache-dirs path)) (define cache-db-file (build-path private-cache-dir "cache.rktd")) (and (file-exists? cache-db-file) - (hash-has-key? (file->value cache-db-file) (paths->key path)))) + (hash-has-key? (file->value cache-db-file) (paths->key 'source path)))) (define (preheat-cache starting-dir [wants-parallel-setup? #false] [wants-dry-run? #false]) (unless (and (path-string? starting-dir) (directory-exists? starting-dir)) @@ -69,11 +69,11 @@ (loop rest (cons wpidx actives))])] [(list wpidx wp 'job-finished path result) (if result - (cache-ref! (paths->key path) (λ () result)) + (cache-ref! (paths->key 'source path) (λ () result)) (message (format "caching failed on job ~a: ~a" (add1 wpidx) (find-relative-path starting-dir path)))) (loop paths (remq wpidx actives))])))] [else (for ([path (in-list uncached-paths)]) (message (format "caching: ~a" (find-relative-path starting-dir path))) (match (with-handlers ([exn:fail? (λ (e) #f)]) (path->hash path)) [#false (message (format "caching failed: ~a" (find-relative-path starting-dir path)))] - [result (cache-ref! (paths->key path) (λ () result))]))])) \ No newline at end of file + [result (cache-ref! (paths->key 'source path) (λ () result))]))])) \ No newline at end of file diff --git a/pollen/private/ts.rktd b/pollen/private/ts.rktd index f6611a7..9020ffe 100644 --- a/pollen/private/ts.rktd +++ b/pollen/private/ts.rktd @@ -1 +1 @@ -1580599066 +1580709571 diff --git a/pollen/render.rkt b/pollen/render.rkt index 311a8b3..68874a4 100644 --- a/pollen/render.rkt +++ b/pollen/render.rkt @@ -42,10 +42,10 @@ ;; create a new key with current files. If the key is in the hash, the render has happened. ;; if not, a new render is needed. (define (update-mod-date-hash! source-path template-path) - (hash-set! mod-date-hash (paths->key source-path template-path) #true)) + (hash-set! mod-date-hash (paths->key 'output source-path template-path) #true)) (define (mod-date-missing-or-changed? source-path template-path) - (not (hash-has-key? mod-date-hash (paths->key source-path template-path)))) + (not (hash-has-key? mod-date-hash (paths->key 'output source-path template-path)))) (define (parallel-render source-paths-in job-count-arg) ;; if jobs are already in the cache, pull them out before assigning workers @@ -53,15 +53,15 @@ (define-values (uncached-source-paths previously-cached-jobs) (for/fold ([usps null] [pcjs null]) - ([path (in-list source-paths-in)]) + ([source-path (in-list source-paths-in)]) (match (let/ec exit - ;; todo: faster test - ;; the problem with this test is that it's not cheap for uncached files: - ;; it ultimatedly calls get-template-for, - ;; which looks in metas, so the file ends up being compiled anyhow. - (render-to-file-if-needed path #f #f (λ () (exit 'cache-miss)))) - ['cache-miss (values (cons path usps) pcjs)] - [_ (values usps (cons (cons path #true) pcjs))]))) + (define exiter (λ () (exit 'cache-miss))) + (define output-path (or (->output-path source-path) #false)) + (define template-path + (cache-ref! (template-cache-key source-path output-path) exiter)) + (render-to-file-if-needed source-path template-path output-path exiter)) + ['cache-miss (values (cons source-path usps) pcjs)] + [_ (values usps (cons (cons source-path #true) pcjs))]))) (define job-count (min @@ -74,22 +74,22 @@ ;; initialize the workers (define worker-evts (for/list ([wpidx (in-range job-count)]) - (define wp (place ch - (let loop () - (match-define (cons path poly-target) - (place-channel-put/get ch (list 'wants-job))) - (parameterize ([current-poly-target poly-target]) - (place-channel-put/get ch (list 'wants-lock (->output-path path))) - ;; trap any exceptions and pass them back as crashed jobs. - ;; otherwise, a crashed rendering place can't recover, and the parallel job will be stuck. - (with-handlers ([exn:fail? (λ (e) (place-channel-put ch (list 'crashed-job path #f)))]) - (match-define-values (_ _ ms _) - ;; we don't use `render-to-file-if-needed` because we've already checked the render cache - ;; if we reached this point, we know we need a render - (time-apply render-to-file (list path))) - (place-channel-put ch (list 'finished-job path ms)))) - (loop)))) - (handle-evt wp (λ (val) (list* wpidx wp val))))) + (define wp (place ch + (let loop () + (match-define (cons path poly-target) + (place-channel-put/get ch (list 'wants-job))) + (parameterize ([current-poly-target poly-target]) + (place-channel-put/get ch (list 'wants-lock (->output-path path))) + ;; trap any exceptions and pass them back as crashed jobs. + ;; otherwise, a crashed rendering place can't recover, and the parallel job will be stuck. + (with-handlers ([exn:fail? (λ (e) (place-channel-put ch (list 'crashed-job path #f)))]) + (match-define-values (_ _ ms _) + ;; we don't use `render-to-file-if-needed` because we've already checked the render cache + ;; if we reached this point, we know we need a render + (time-apply render-to-file (list path))) + (place-channel-put ch (list 'finished-job path ms)))) + (loop)))) + (handle-evt wp (λ (val) (list* wpidx wp val))))) (define poly-target (current-poly-target)) @@ -127,7 +127,7 @@ ;; crashed jobs are completed jobs that weren't finished (for/list ([(path finished?) (in-dict completed-jobs)] #:unless finished?) - path)] + path)] [else (match (apply sync worker-evts) [(list wpidx wp 'wants-job) @@ -240,14 +240,13 @@ (define render-result (cond [render-cache-activated? - (define key (paths->key source-path template-path output-path)) + (define key (paths->key 'output source-path template-path output-path)) (hash-ref! render-ram-cache ;; within a session, this will prevent repeat players like "template.html.p" ;; from hitting the file cache repeatedly key (cache-ref! key render-thunk - #:dest-path 'output #:notify-cache-use (λ (str) (message (format "from cache /~a" @@ -312,7 +311,6 @@ (define (render-null-source source-path . ignored-paths) ;((complete-path?) #:rest any/c . ->* . bytes?) ;; All this does is copy the source. Hence, "null". - ;; todo: add test to avoid copying if unnecessary (good idea in case the file is large) (file->bytes source-path)) (define-namespace-anchor render-module-ns) @@ -383,7 +381,7 @@ (define (file-exists-or-has-source? path) ; path could be #f (and path (for/first ([proc (in-list (list values ->preproc-source-path ->null-source-path))] #:when (file-exists? (proc path))) - path))) + path))) (define (get-template-from-metas source-path output-path-ext) (with-handlers ([exn:fail:contract? (λ (e) #f)]) ; in case source-path doesn't work with cached-require @@ -406,22 +404,35 @@ (build-path (current-server-extras-path) (add-ext (setup:fallback-template-prefix source-path) output-path-ext)))) +(define template-ram-cache (make-hash)) +(define (template-cache-key source-path output-path) + (paths->key 'template source-path (current-poly-target) output-path)) + (define+provide/contract (get-template-for source-path [maybe-output-path #f]) ((complete-path?)((or/c #f complete-path?)) . ->* . (or/c #f complete-path?)) - (match source-path - [(or (? markup-source?) (? markdown-source?)) - (define output-path (cond - [maybe-output-path] - [(->output-path source-path)] - [else #false])) - ;; output-path may not have an extension - (define output-path-ext (cond - [(get-ext output-path)] - [(current-poly-target)] - [else #false])) - (for/or ([proc (list get-template-from-metas get-default-template get-fallback-template)]) - (file-exists-or-has-source? (proc source-path output-path-ext)))] - [_ #false])) + (define output-path (cond + [maybe-output-path] + [(->output-path source-path)] + [else #false])) + (define key (template-cache-key source-path output-path)) + (hash-ref! template-ram-cache + ;; within a session, this will prevent repeat players like "template.html.p" + ;; from hitting the file cache repeatedly + key + (cache-ref! key + (λ () + (match source-path + [(or (? markup-source?) (? markdown-source?)) + ;; output-path may not have an extension + (define output-path-ext (cond + [(get-ext output-path)] + [(current-poly-target)] + [else #false])) + (for/or ([proc (list get-template-from-metas + get-default-template + get-fallback-template)]) + (file-exists-or-has-source? (proc source-path output-path-ext)))] + [_ #false]))))) (module-test-external (require pollen/setup sugar/file sugar/coerce)