mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-12 06:41:13 +02:00
Code Activity

Use allocate-struct in define-record-type implementations

Browse source 
* module/ice-9/boot-9.scm (iota): Move up.
  (make-record-type, define-record-type): Use allocate-struct and
  struct-set!.

* module/srfi/srfi-9.scm (%%set-fields, %define-record-type): Use
  allocate-struct and struct-set!.

Note that this makes the stack VM slower, but it will make RTL
compilation faster.
This commit is contained in:
Andy Wingo 2013-07-21 17:06:41 +02:00
parent 14d102920f
commit 746065c92e
2 changed files with 59 additions and 42 deletions
Download patch file Download diff file Expand all files Collapse all files

39
module/ice-9/boot-9.scm
View file

@ -1189,6 +1189,16 @@ VALUE."
;;; {IOTA functions: generating lists of numbers}
;;;
(define (iota n)
(let loop ((count (1- n)) (result '()))
(if (< count 0) result
(loop (1- count) (cons count result)))))
;;; {Structs}
;;;
@ -1253,10 +1263,14 @@ 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 ...)
(make-struct rtd 0 formal ...))))
(let ((s (allocate-struct rtd n)))
(struct-set! s idx formal)
...
s))))
(lp (1+ n)))
'()))
(else
@ -2211,14 +2225,21 @@ written into the port is returned."
(cons #'f (field-list #'rest)))))
(define (constructor rtd type-name fields exp)
(let ((ctor (make-id rtd type-name '-constructor))
(args (field-list fields)))
(let* ((ctor (make-id rtd type-name '-constructor))
(args (field-list fields))
(n (length fields))
(slots (iota n)))
(predicate rtd type-name fields
#`(begin #,exp
(define #,ctor
(let ((rtd #,rtd))
(lambda #,args
(make-struct rtd 0 #,@args))))
(let ((s (allocate-struct rtd #,n)))
#,@(map
(lambda (arg slot)
#`(struct-set! s #,slot #,arg))
args slots)
s))))
(struct-set! #,rtd (+ vtable-offset-user 2)
#,ctor)))))
@ -3496,16 +3517,6 @@ but it fails to load."
;;; {IOTA functions: generating lists of numbers}
;;;
(define (iota n)
(let loop ((count (1- n)) (result '()))
(if (< count 0) result
(loop (1- count) (cons count result)))))
;;; {While}
;;;
;;; with `continue' and `break'.

62
module/srfi/srfi-9.scm
View file

@ -1,6 +1,6 @@
;;; srfi-9.scm --- define-record-type
;; Copyright (C) 2001, 2002, 2006, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
;; Copyright (C) 2001, 2002, 2006, 2009, 2010, 2011, 2012, 2013 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
@ -156,7 +156,8 @@
((_ type-name (getter-id ...) check? s (getter expr) ...)
(every identifier? #'(getter ...))
(let ((copier-name (syntax->datum (make-copier-id #'type-name)))
(getter+exprs #'((getter expr) ...)))
(getter+exprs #'((getter expr) ...))
(nfields (length #'(getter-id ...))))
(define (lookup id default-expr)
(let ((results
(filter (lambda (g+e)
@ -175,12 +176,16 @@
copier-name "unknown getter" x id)))
#'(getter ...))
(with-syntax ((unsafe-expr
#`(make-struct
type-name 0
#,@(map (lambda (getter index)
(lookup getter #`(struct-ref s #,index)))
#'(getter-id ...)
(iota (length #'(getter-id ...)))))))
#`(let ((new (allocate-struct type-name #,nfields)))
#,@(map (lambda (getter index)
#`(struct-set!
new
#,index
#,(lookup getter
#`(struct-ref s #,index))))
#'(getter-id ...)
(iota nfields))
new)))
(if (syntax->datum #'check?)
#`(if (eq? (struct-vtable s) type-name)
unsafe-expr
@ -204,26 +209,27 @@
((name getter setter) #'getter)))
field-specs))
(define (constructor form type-name constructor-spec field-names)
(define (constructor form type-name constructor-spec field-ids)
(syntax-case constructor-spec ()
((ctor field ...)
(every identifier? #'(field ...))
(let ((ctor-args (map (lambda (field)
(let ((name (syntax->datum field)))
(or (memq name field-names)
(syntax-violation
(syntax-case form ()
((macro . args)
(syntax->datum #'macro)))
"unknown field in constructor spec"
form field))
(cons name field)))
#'(field ...))))
(let ((slots (map (lambda (field)
(or (list-index (lambda (x)
(free-identifier=? x field))
field-ids)
(syntax-violation
(syntax-case form ()
((macro . args)
(syntax->datum #'macro)))
"unknown field in constructor spec"
form field)))
#'(field ...))))
#`(define-inlinable #,constructor-spec
(make-struct #,type-name 0
#,@(map (lambda (name)
(assq-ref ctor-args name))
field-names)))))))
(let ((s (allocate-struct #,type-name #,(length field-ids))))
#,@(map (lambda (arg slot)
#`(struct-set! s #,slot #,arg))
#'(field ...) slots)
s))))))
(define (getters type-name getter-ids copier-id)
(map (lambda (getter index)
@ -267,8 +273,9 @@
(iota (length field-specs))))
(define (record-layout immutable? count)
(let ((desc (if immutable? "pr" "pw")))
(string-concatenate (make-list count desc))))
;; Mutability is expressed on the record level; all structs in the
;; future will be mutable.
(string-concatenate (make-list count "pw")))
(syntax-case x ()
((_ immutable? form type-name constructor-spec predicate-name
@ -300,12 +307,11 @@
(field-count (length field-ids))
(immutable? (syntax->datum #'immutable?))
(layout (record-layout immutable? field-count))
(field-names (map syntax->datum field-ids))
(ctor-name (syntax-case #'constructor-spec ()
((ctor args ...) #'ctor)))
(copier-id (make-copier-id #'type-name)))
#`(begin
#,(constructor #'form #'type-name #'constructor-spec field-names)
#,(constructor #'form #'type-name #'constructor-spec field-ids)
(define type-name
(let ((rtd (make-struct/no-tail