gexp: Store compilers in a hash table for O(1) lookup.
* guix/gexp.scm (<gexp-compiler>)[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.
This commit is contained in:
Ludovic Courtès
parent
e71479747b
commit
1cdecf24f5
|
|
@ -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>
|
||||
(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 <gexp-compiler>.
|
||||
'())
|
||||
;; 'eq?' mapping of record type descriptor to <gexp-compiler>.
|
||||
(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
|
||||
(($ <gexp-compiler> 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
|
||||
(($ <gexp-compiler> 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 <derivation>) 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 <local-file>) system target)
|
||||
;; "Compile" FILE by adding it to the store.
|
||||
(match file
|
||||
(($ <local-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 <plain-file>) system target)
|
||||
;; "Compile" FILE by adding it to the store.
|
||||
(match file
|
||||
(($ <plain-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 <computed-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 <program-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 <scheme-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 <file-append>
|
||||
compiler => (lambda (obj system target)
|
||||
(match obj
|
||||
(($ <file-append> base _)
|
||||
|
|
|
|||
|
|
@ -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 <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 <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))
|
||||
|
|
|
|||
Loading…
Reference in a new issue