Introduce make-struct/simple

* libguile/struct.h:
* libguile/struct.c (scm_make_struct_simple): New function.
* module/ice-9/boot-9.scm (make-record-type): Recast in terms of
  make-struct/simple.
* module/ice-9/eval.scm (primitive-eval): Remove allocate-struct case.
* module/srfi/srfi-9.scm (%%set-fields, %define-record-type): Use
  make-struct/simple.

libguile/struct.c

@@ -1,5 +1,5 @@
 /* Copyright (C) 1996-2001, 2003-2004, 2006-2013, 2015,
- *               2017 Free Software Foundation, Inc.
+ *               2017-2018 Free Software Foundation, Inc.
  * 
  * This library is free software; you can redistribute it and/or
  * modify it under the terms of the GNU Lesser General Public License
@@ -413,6 +413,44 @@ SCM_DEFINE (scm_allocate_struct, "allocate-struct", 2, 0, 0,
 }
 #undef FUNC_NAME
 
+SCM_DEFINE (scm_make_struct_simple, "make-struct/simple", 1, 0, 1,
+            (SCM vtable, SCM init),
+	    "Create a new structure.\n\n"
+	    "@var{vtable} must be a vtable structure (@pxref{Vtables}).\n\n"
+	    "The @var{init1}, @dots{} arguments supply the initial values\n"
+	    "for the structure's fields\n.\n"
+	    "This is a restricted variant of @code{make-struct/no-tail}\n"
+            "which applies only if the structure has no unboxed fields.\n"
+            "@code{make-struct/simple} must be called with as many\n"
+            "@var{init} values as the struct has fields.  No finalizer is set\n"
+            "on the instance, even if the vtable has a non-zero finalizer\n"
+            "field.  No magical vtable fields are inherited.\n\n"
+            "The advantage of using @code{make-struct/simple} is that the\n"
+            "compiler can inline it, so it is faster.  When in doubt though,\n"
+            "use @code{make-struct/no-tail}.")
+#define FUNC_NAME s_scm_make_struct_simple
+{
+  long i, n_init;
+  SCM ret;
+
+  SCM_VALIDATE_VTABLE (1, vtable);
+  n_init = scm_ilength (init);
+  if (n_init != SCM_VTABLE_SIZE (vtable))
+    SCM_MISC_ERROR ("Wrong number of initializers.", SCM_EOL);
+
+  ret = scm_words (SCM_UNPACK (vtable) | scm_tc3_struct, n_init + 1);
+
+  for (i = 0; i < n_init; i++, init = scm_cdr (init))
+    {
+      SCM_ASSERT (!SCM_VTABLE_FIELD_IS_UNBOXED (vtable, i),
+                  vtable, 1, FUNC_NAME);
+      SCM_STRUCT_SLOT_SET (ret, i, scm_car (init));
+    }
+
+  return ret;
+}
+#undef FUNC_NAME
+
 SCM_DEFINE (scm_make_struct_no_tail, "make-struct/no-tail", 1, 0, 1, 
             (SCM vtable, SCM init),
 	    "Create a new structure.\n\n"

libguile/struct.h

@@ -4,7 +4,7 @@
 #define SCM_STRUCT_H
 
 /* Copyright (C) 1995,1997,1999-2001, 2006-2013, 2015,
- *               2017 Free Software Foundation, Inc.
+ *               2017-2018 Free Software Foundation, Inc.
  *
  * This library is free software; you can redistribute it and/or
  * modify it under the terms of the GNU Lesser General Public License
@@ -161,6 +161,7 @@ SCM_API SCM scm_make_struct_layout (SCM fields);
 SCM_API SCM scm_struct_p (SCM x);
 SCM_API SCM scm_struct_vtable_p (SCM x);
 SCM_INTERNAL SCM scm_allocate_struct (SCM vtable, SCM n_words);
+SCM_INTERNAL SCM scm_make_struct_simple (SCM vtable, SCM init);
 SCM_API SCM scm_make_struct_no_tail (SCM vtable, SCM init);
 SCM_API SCM scm_c_make_struct (SCM vtable, size_t n_tail, size_t n_inits,
                                scm_t_bits init, ...);

module/ice-9/boot-9.scm

@@ -1,6 +1,6 @@
 ;;; -*- mode: scheme; coding: utf-8; -*-
 
-;;;; Copyright (C) 1995-2014, 2016-2017  Free Software Foundation, Inc.
+;;;; Copyright (C) 1995-2014, 2016-2018  Free Software Foundation, Inc.
 ;;;;
 ;;;; This library is free software; you can redistribute it and/or
 ;;;; modify it under the terms of the GNU Lesser General Public
@@ -1211,14 +1211,10 @@ VALUE."
              #,@(let lp ((n 0))
                   (if (< n *max-static-argument-count*)
                       (cons (with-syntax (((formal ...) (make-formals n))
-                                          ((idx ...) (iota n))
                                           (n n))
                               #'((n)
                                  (lambda (formal ...)
-                                   (let ((s (allocate-struct rtd n)))
+                                   (make-struct/simple rtd formal ...))))
-                                     (struct-set! s idx formal)
-                                     ...
-                                     s))))
                             (lp (1+ n)))
                       '()))
              (else
@@ -1919,12 +1915,7 @@ name extensions listed in %load-extensions."
                                  (define #,ctor
                                    (let ((rtd #,rtd))
                                      (lambda #,args
-                                       (let ((s (allocate-struct rtd #,n)))
+                                       (make-struct/simple rtd #,@args))))
-                                         #,@(map
-                                             (lambda (arg slot)
-                                               #`(struct-set! s #,slot #,arg))
-                                             args slots)
-                                         s))))
                                  (struct-set! #,rtd (+ vtable-offset-user 2)
                                               #,ctor)))))
 

module/ice-9/eval.scm

@@ -1,6 +1,6 @@
 ;;; -*- mode: scheme; coding: utf-8; -*-
 
-;;;; Copyright (C) 2009, 2010, 2011, 2012, 2013, 2014, 2015 Free Software Foundation, Inc.
+;;;; Copyright (C) 2009-2015, 2018 Free Software Foundation, Inc.
 ;;;;
 ;;;; This library is free software; you can redistribute it and/or
 ;;;; modify it under the terms of the GNU Lesser General Public
@@ -157,7 +157,7 @@
                          a))
         ((a b)
          (maybe-primcall (+ - * / ash logand logior logxor
-                          cons vector-ref struct-ref allocate-struct variable-set!)
+                          cons vector-ref struct-ref variable-set!)
                          a b))
         ((a b c)
          (maybe-primcall (vector-set! struct-set!) a b c))

module/srfi/srfi-9.scm

@@ -1,7 +1,7 @@
 ;;; srfi-9.scm --- define-record-type
 
 ;; Copyright (C) 2001, 2002, 2006, 2009, 2010, 2011, 2012,
-;;   2013, 2014 Free Software Foundation, Inc.
+;;   2013, 2014, 2018 Free Software Foundation, Inc.
 ;;
 ;; This library is free software; you can redistribute it and/or
 ;; modify it under the terms of the GNU Lesser General Public
@@ -180,16 +180,12 @@
                           copier-name "unknown getter" x id)))
                    #'(getter ...))
          (with-syntax ((unsafe-expr
-                        #`(let ((new (allocate-struct type-name #,nfields)))
+                        #`(make-struct/simple
-                            #,@(map (lambda (getter index)
+                           type-name
-                                      #`(struct-set!
+                           #,@(map (lambda (getter index)
-                                         new
+                                     (lookup getter #`(struct-ref s #,index)))
-                                         #,index
+                                   #'(getter-id ...)
-                                         #,(lookup getter
+                                   (iota nfields)))))
-                                                   #`(struct-ref s #,index))))
-                                    #'(getter-id ...)
-                                    (iota nfields))
-                            new)))
            (if (syntax->datum #'check?)
                #`(if (eq? (struct-vtable s) type-name)
                      unsafe-expr
@@ -217,23 +213,24 @@
       (syntax-case constructor-spec ()
         ((ctor field ...)
          (every identifier? #'(field ...))
-         (let ((slots (map (lambda (field)
+         (letrec* ((id-list-contains?
-                             (or (list-index (lambda (x)
+                    (lambda (id-list id)
-                                               (free-identifier=? x field))
+                      (and (not (null? id-list))
-                                             field-ids)
+                           (or (free-identifier=? (car id-list) id)
-                                 (syntax-violation
+                               (id-list-contains? (cdr id-list) id)))))
-                                  (syntax-case form ()
+                   (inits (map (lambda (id)
-                                    ((macro . args)
+                                 (and (id-list-contains? #'(field ...) id) id))
-                                     (syntax->datum #'macro)))
+                               field-ids)))
-                                  "unknown field in constructor spec"
+           (for-each
-                                  form field)))
+            (lambda (field)
-                           #'(field ...))))
+              (unless (id-list-contains? field-ids field)
+                (syntax-violation
+                 (syntax-case form () ((macro . args) (syntax->datum #'macro)))
+                 "unknown field in constructor spec"
+                 form field)))
+            #'(field ...))
            #`(define-inlinable #,constructor-spec
-               (let ((s (allocate-struct #,type-name #,(length field-ids))))
+               (make-struct/simple #,type-name #,@inits))))))
-                 #,@(map (lambda (arg slot)
-                           #`(struct-set! s #,slot #,arg))
-                         #'(field ...) slots)
-                 s))))))
 
     (define (getters type-name getter-ids copier-id)
       (map (lambda (getter index)