From 1cdecf24f5a7d98c9564a12a2932a015cfc31b9e Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 10 Sep 2016 11:57:37 +0200 Subject: gexp: Store compilers in a hash table for O(1) lookup. * guix/gexp.scm ()[predicate]: Remove. [type]: New field. (%gexp-compilers): Turn into a hash table. (register-compiler!, lookup-compiler, lookup-expander): Adjust accordingly. (define-gexp-compiler): Replace 'predicate' by 'record-type'. (derivation-compiler, local-file-compiler, plain-file-compiler) (computed-file-compiler, program-file-compiler, scheme-file-compiler) (file-append-compiler): Adjust accordingly. * guix/packages.scm (package-compiler, origin-compiler): Likewise. --- guix/gexp.scm | 48 ++++++++++++++++++++++-------------------------- guix/packages.scm | 4 ++-- 2 files changed, 24 insertions(+), 28 deletions(-) diff --git a/guix/gexp.scm b/guix/gexp.scm index 7e2ecf6c33..05178a5ecc 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -131,15 +131,15 @@ (define (write-gexp gexp port) ;; Compiler for a type of objects that may be introduced in a gexp. (define-record-type - (gexp-compiler predicate lower expand) + (gexp-compiler type lower expand) gexp-compiler? - (predicate gexp-compiler-predicate) + (type gexp-compiler-type) ;record type descriptor (lower gexp-compiler-lower) - (expand gexp-compiler-expand)) ;#f | DRV -> M sexp + (expand gexp-compiler-expand)) ;#f | DRV -> sexp (define %gexp-compilers - ;; List of . - '()) + ;; 'eq?' mapping of record type descriptor to . + (make-hash-table 20)) (define (default-expander thing obj output) "This is the default expander for \"things\" that appear in gexps. It @@ -152,24 +152,20 @@ (define (default-expander thing obj output) (define (register-compiler! compiler) "Register COMPILER as a gexp compiler." - (set! %gexp-compilers (cons compiler %gexp-compilers))) + (hashq-set! %gexp-compilers + (gexp-compiler-type compiler) compiler)) (define (lookup-compiler object) "Search for a compiler for OBJECT. Upon success, return the three argument procedure to lower it; otherwise return #f." - (any (match-lambda - (($ predicate lower) - (and (predicate object) lower))) - %gexp-compilers)) + (and=> (hashq-ref %gexp-compilers (struct-vtable object)) + gexp-compiler-lower)) (define (lookup-expander object) "Search for an expander for OBJECT. Upon success, return the three argument procedure to expand it; otherwise return #f." - (or (any (match-lambda - (($ predicate _ expand) - (and (predicate object) expand))) - %gexp-compilers) - default-expander)) + (and=> (hashq-ref %gexp-compilers (struct-vtable object)) + gexp-compiler-expand)) (define* (lower-object obj #:optional (system (%current-system)) @@ -197,19 +193,19 @@ (define-gexp-compiler something something? expander => (lambda (param drv output) ...)) The expander specifies how an object is converted to its sexp representation." - ((_ (name (param predicate) system target) body ...) - (define-gexp-compiler name predicate + ((_ (name (param record-type) system target) body ...) + (define-gexp-compiler name record-type compiler => (lambda (param system target) body ...) expander => default-expander)) - ((_ name predicate + ((_ name record-type compiler => compile expander => expand) (begin (define name - (gexp-compiler predicate compile expand)) + (gexp-compiler record-type compile expand)) (register-compiler! name))))) -(define-gexp-compiler (derivation-compiler (drv derivation?) system target) +(define-gexp-compiler (derivation-compiler (drv ) system target) ;; Derivations are the lowest-level representation, so this is the identity ;; compiler. (with-monad %store-monad @@ -275,7 +271,7 @@ (define (local-file-absolute-file-name file) 'system-error' exception is raised if FILE could not be found." (force (%local-file-absolute-file-name file))) -(define-gexp-compiler (local-file-compiler (file local-file?) system target) +(define-gexp-compiler (local-file-compiler (file ) system target) ;; "Compile" FILE by adding it to the store. (match file (($ file (= force absolute) name recursive? select?) @@ -302,7 +298,7 @@ (define (plain-file name content) ;; them in a declarative context. (%plain-file name content '())) -(define-gexp-compiler (plain-file-compiler (file plain-file?) system target) +(define-gexp-compiler (plain-file-compiler (file ) system target) ;; "Compile" FILE by adding it to the store. (match file (($ name content references) @@ -324,7 +320,7 @@ (define* (computed-file name gexp This is the declarative counterpart of 'gexp->derivation'." (%computed-file name gexp options)) -(define-gexp-compiler (computed-file-compiler (file computed-file?) +(define-gexp-compiler (computed-file-compiler (file ) system target) ;; Compile FILE by returning a derivation whose build expression is its ;; gexp. @@ -346,7 +342,7 @@ (define* (program-file name gexp #:key (guile #f)) This is the declarative counterpart of 'gexp->script'." (%program-file name gexp guile)) -(define-gexp-compiler (program-file-compiler (file program-file?) +(define-gexp-compiler (program-file-compiler (file ) system target) ;; Compile FILE by returning a derivation that builds the script. (match file @@ -366,7 +362,7 @@ (define* (scheme-file name gexp) This is the declarative counterpart of 'gexp->file'." (%scheme-file name gexp)) -(define-gexp-compiler (scheme-file-compiler (file scheme-file?) +(define-gexp-compiler (scheme-file-compiler (file ) system target) ;; Compile FILE by returning a derivation that builds the file. (match file @@ -385,7 +381,7 @@ (define (file-append base . suffix) SUFFIX." (%file-append base suffix)) -(define-gexp-compiler file-append-compiler file-append? +(define-gexp-compiler file-append-compiler compiler => (lambda (obj system target) (match obj (($ base _) diff --git a/guix/packages.scm b/guix/packages.scm index afbafc70a7..2264c5acef 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -1179,7 +1179,7 @@ (define package->derivation (define package->cross-derivation (store-lift package-cross-derivation)) -(define-gexp-compiler (package-compiler (package package?) system target) +(define-gexp-compiler (package-compiler (package ) system target) ;; Compile PACKAGE to a derivation for SYSTEM, optionally cross-compiled for ;; TARGET. This is used when referring to a package from within a gexp. (if target @@ -1210,7 +1210,7 @@ (define* (origin->derivation origin #:modules modules #:guile-for-build guile))))) -(define-gexp-compiler (origin-compiler (origin origin?) system target) +(define-gexp-compiler (origin-compiler (origin ) system target) ;; Compile ORIGIN to a derivation for SYSTEM. This is used when referring ;; to an origin from within a gexp. (origin->derivation origin system)) -- cgit v1.2.3