04/04: records: Insert record type ABI checks in constructors.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository guix.

commit 7874bbbb9f09cc14ea3e179fd0fa10da5f90cfc7
Author: Ludovic Courtès <address@hidden>
Date:   Wed May 16 10:05:24 2018 +0200

    records: Insert record type ABI checks in constructors.
    
    * guix/records.scm (print-record-abi-mismatch-error): New procedure.
    <top level>: Add 'set-exception-printer!' call.
    (current-abi-identifier, abi-check): New procedures.
    (make-syntactic-constructor): Add #:abi-cookie parameter.  Insert calls
    to 'abi-check'.
    (define-record-type*)[compute-abi-cookie]: New procedure.
    Use it and emit a definition of the 'current-abi-identifier' for TYPE.
    * tests/records.scm ("ABI checks"): New test.
---
 guix/records.scm  | 54 +++++++++++++++++++++++++++++++++++++++++++++++++++---
 tests/records.scm | 30 +++++++++++++++++++++++++++++-
 2 files changed, 80 insertions(+), 4 deletions(-)

diff --git a/guix/records.scm b/guix/records.scm
index c02395f..c71cfcf 100644
--- a/guix/records.scm
+++ b/guix/records.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès 
<address@hidden>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès 
<address@hidden>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -52,13 +52,45 @@
       ((weird _ ...)                              ;weird!
        (syntax-violation name "invalid field specifier" #'weird)))))
 
+(define (print-record-abi-mismatch-error port key args
+                                         default-printer)
+  (match args
+    ((rtd . _)
+     ;; The source file where this exception is thrown must be recompiled.
+     (format port "ERROR: ~a: record ABI mismatch; recompilation needed"
+             rtd))))
+
+(set-exception-printer! 'record-abi-mismatch-error
+                        print-record-abi-mismatch-error)
+
+(define (current-abi-identifier type)
+  "Return an identifier unhygienically derived from TYPE for use as its
+\"current ABI\" variable."
+  (let ((type-name (syntax->datum type)))
+    (datum->syntax
+     type
+     (string->symbol
+      (string-append "% " (symbol->string type-name)
+                     " abi-cookie")))))
+
+(define (abi-check type cookie)
+  "Return syntax that checks that the current \"application binary
+interface\" (ABI) for TYPE is equal to COOKIE."
+  (with-syntax ((current-abi (current-abi-identifier type)))
+    #`(unless (eq? current-abi #,cookie)
+        (throw 'record-abi-mismatch-error #,type))))
+
 (define-syntax make-syntactic-constructor
   (syntax-rules ()
     "Make the syntactic constructor NAME for TYPE, that calls CTOR, and
 expects all of EXPECTED fields to be initialized.  DEFAULTS is the list of
 FIELD/DEFAULT-VALUE tuples, THUNKED is the list of identifiers of thunked
-fields, and DELAYED is the list of identifiers of delayed fields."
+fields, and DELAYED is the list of identifiers of delayed fields.
+
+ABI-COOKIE is the cookie (an integer) against which to check the run-time ABI
+of TYPE matches the expansion-time ABI."
     ((_ type name ctor (expected ...)
+        #:abi-cookie abi-cookie
         #:thunked thunked
         #:delayed delayed
         #:innate innate
@@ -130,6 +162,7 @@ fields, and DELAYED is the list of identifiers of delayed 
fields."
          (syntax-case s (inherit expected ...)
            ((_ (inherit orig-record) (field value) (... ...))
             #`(let* #,(field-bindings #'((field value) (... ...)))
+                #,(abi-check #'type abi-cookie)
                 #,(record-inheritance #'orig-record
                                       #'((field value) (... ...)))))
            ((_ (field value) (... ...))
@@ -144,6 +177,7 @@ fields, and DELAYED is the list of identifiers of delayed 
fields."
                 (cond ((lset= eq? fields '(expected ...))
                        #`(let* #,(field-bindings
                                   #'((field value) (... ...)))
+                           #,(abi-check #'type abi-cookie)
                            (ctor #,@(map field-value '(expected ...)))))
                       ((pair? (lset-difference eq? fields
                                                '(expected ...)))
@@ -270,6 +304,16 @@ inherited."
                ;; The real value of that field is a promise, so force it.
                (force (real-get x)))))))
 
+    (define (compute-abi-cookie field-specs)
+      ;; Compute an "ABI cookie" for the given FIELD-SPECS.  We use
+      ;; 'string-hash' because that's a better hash function that 'hash' on a
+      ;; list of symbols.
+      (syntax-case field-specs ()
+        (((field get properties ...) ...)
+         (string-hash (object->string
+                       (syntax->datum #'((field properties ...) ...)))
+                      most-positive-fixnum))))
+
     (syntax-case s ()
       ((_ type syntactic-ctor ctor pred
           (field get properties ...) ...)
@@ -278,7 +322,8 @@ inherited."
               (delayed    (filter-map delayed-field? field-spec))
               (innate     (filter-map innate-field? field-spec))
               (defaults   (filter-map field-default-value
-                                      #'((field properties ...) ...))))
+                                      #'((field properties ...) ...)))
+              (cookie     (compute-abi-cookie field-spec)))
          (with-syntax (((field-spec* ...)
                         (map field-spec->srfi-9 field-spec))
                        ((thunked-field-accessor ...)
@@ -298,10 +343,13 @@ inherited."
                  (ctor field ...)
                  pred
                  field-spec* ...)
+               (define #,(current-abi-identifier #'type)
+                 #,cookie)
                thunked-field-accessor ...
                delayed-field-accessor ...
                (make-syntactic-constructor type syntactic-ctor ctor
                                            (field ...)
+                                           #:abi-cookie #,cookie
                                            #:thunked #,thunked
                                            #:delayed #,delayed
                                            #:innate #,innate
diff --git a/tests/records.scm b/tests/records.scm
index d6d27bb..80e08a9 100644
--- a/tests/records.scm
+++ b/tests/records.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès <address@hidden>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2018 Ludovic Courtès 
<address@hidden>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -288,6 +288,34 @@
       (and (string-match "extra.*initializer.*baz" message)
            (eq? proc 'foo)))))
 
+(test-assert "ABI checks"
+  (let ((module (test-module)))
+    (eval '(begin
+             (define-record-type* <foo> foo make-foo
+               foo?
+               (bar foo-bar (default 42)))
+
+             (define (make-me-a-record) (foo)))
+          module)
+    (unless (eval '(foo? (make-me-a-record)) module)
+      (error "what?" (eval '(make-me-a-record) module)))
+
+    ;; Redefine <foo> with an additional field.
+    (eval '(define-record-type* <foo> foo make-foo
+             foo?
+             (baz foo-baz)
+             (bar foo-bar (default 42)))
+          module)
+
+    ;; Now 'make-me-a-record' is out of sync because it does an
+    ;; 'allocate-struct' that corresponds to the previous definition of <foo>.
+    (catch 'record-abi-mismatch-error
+      (lambda ()
+        (eval '(foo? (make-me-a-record)) module)
+        #f)
+      (lambda (key rtd . _)
+        (eq? rtd (eval '<foo> module))))))
+
 (test-equal "recutils->alist"
   '((("Name" . "foo")
      ("Version" . "0.1")