mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-15 08:10:17 +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} ;;; {Structs}
;;; ;;;
@ -1253,10 +1263,14 @@ VALUE."
#,@(let lp ((n 0)) #,@(let lp ((n 0))
(if (< n *max-static-argument-count*) (if (< n *max-static-argument-count*)
(cons (with-syntax (((formal ...) (make-formals n)) (cons (with-syntax (((formal ...) (make-formals n))
((idx ...) (iota n))
(n n)) (n n))
#'((n) #'((n)
(lambda (formal ...) (lambda (formal ...)
(make-struct rtd 0 formal ...)))) (let ((s (allocate-struct rtd n)))
(struct-set! s idx formal)
...
s))))
(lp (1+ n))) (lp (1+ n)))
'())) '()))
(else (else
@ -2211,14 +2225,21 @@ written into the port is returned."
(cons #'f (field-list #'rest))))) (cons #'f (field-list #'rest)))))
(define (constructor rtd type-name fields exp) (define (constructor rtd type-name fields exp)
(let ((ctor (make-id rtd type-name '-constructor)) (let* ((ctor (make-id rtd type-name '-constructor))
(args (field-list fields))) (args (field-list fields))
(n (length fields))
(slots (iota n)))
(predicate rtd type-name fields (predicate rtd type-name fields
#`(begin #,exp #`(begin #,exp
(define #,ctor (define #,ctor
(let ((rtd #,rtd)) (let ((rtd #,rtd))
(lambda #,args (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) (struct-set! #,rtd (+ vtable-offset-user 2)
#,ctor))))) #,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} ;;; {While}
;;; ;;;
;;; with `continue' and `break'. ;;; with `continue' and `break'.

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

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