mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 20:00:19 +02:00
Code Activity

Fix accessor struct field inlining

Browse source 
* module/oop/goops/compile.scm: Inline into goops.scm, leaving a
  compatible interface stub behind.

* module/oop/goops/dispatch.scm: Don't import (oop goops compile), to
  break circularities.

* module/oop/goops.scm: Move (oop goops util) include up to the top, and
  import (ice-9 match).
  (compute-cmethod): Move here from compile.scm.  Add a special case for
  accessor methods, so as to fix bug #17355.
  (compute-getter-method, compute-setter-method): #:procedure slot is
  now generic.

* test-suite/tests/goops.test ("accessor slots"): New test.
This commit is contained in:
Andy Wingo 2015-01-24 19:22:47 +01:00
parent 1abe6ba5d8
commit 583a23bf10
4 changed files with 107 additions and 68 deletions
Download patch file Download diff file Expand all files Collapse all files

96
module/oop/goops.scm
View file

@ -25,12 +25,14 @@
;;;;
(define-module (oop goops)
:use-module (srfi srfi-1)
:export-syntax (define-class class standard-define-class
define-generic define-accessor define-method
define-extended-generic define-extended-generics
method)
:export (is-a? class-of
#:use-module (srfi srfi-1)
#:use-module (ice-9 match)
#:use-module (oop goops util)
#:export-syntax (define-class class standard-define-class
define-generic define-accessor define-method
define-extended-generic define-extended-generics
method)
#:export (is-a? class-of
ensure-metaclass ensure-metaclass-with-supers
make-class
make-generic ensure-generic
@ -71,8 +73,7 @@
method-specializers method-formals
primitive-generic-generic enable-primitive-generic!
method-procedure accessor-method-slot-definition
slot-exists? make find-method get-keyword)
:no-backtrace)
slot-exists? make find-method get-keyword))
(define *goops-module* (current-module))
@ -85,9 +86,56 @@
(add-interesting-primitive! 'class-of))
;; Then load the rest of GOOPS
(use-modules (oop goops util)
(oop goops dispatch)
(oop goops compile))
(use-modules (oop goops dispatch))
;;;
;;; Compiling next methods into method bodies
;;;
;;; So, for the reader: there basic idea is that, given that the
;;; semantics of `next-method' depend on the concrete types being
;;; dispatched, why not compile a specific procedure to handle each type
;;; combination that we see at runtime.
;;;
;;; In theory we can do much better than a bytecode compilation, because
;;; we know the *exact* types of the arguments. It's ideal for native
;;; compilation. A task for the future.
;;;
;;; I think this whole generic application mess would benefit from a
;;; strict MOP.
(define (compute-cmethod methods types)
(match methods
((method . methods)
(cond
((is-a? method <accessor-method>)
(match types
((class . _)
(let* ((name (car (accessor-method-slot-definition method)))
(g-n-s (assq name (slot-ref class 'getters-n-setters)))
(init-thunk (cadr g-n-s))
(g-n-s (cddr g-n-s)))
(match types
((class)
(cond ((pair? g-n-s)
(make-generic-bound-check-getter (car g-n-s)))
(init-thunk
(standard-get g-n-s))
(else
(bound-check-get g-n-s))))
((class value)
(if (pair? g-n-s)
(cadr g-n-s)
(standard-set g-n-s))))))))
(else
(let ((make-procedure (slot-ref method 'make-procedure)))
(if make-procedure
(make-procedure
(if (null? methods)
(lambda args
(no-next-method (method-generic-function method) args))
(compute-cmethod methods types)))
(method-procedure method))))))))
(eval-when (expand load eval)
@ -1089,27 +1137,19 @@
(compute-setter-method class g-n-s))))))
slots (slot-ref class 'getters-n-setters)))
(define-method (compute-getter-method (class <class>) slotdef)
(let ((init-thunk (cadr slotdef))
(g-n-s (cddr slotdef)))
(define-method (compute-getter-method (class <class>) g-n-s)
(let ((name (car g-n-s)))
(make <accessor-method>
#:specializers (list class)
#:procedure (cond ((pair? g-n-s)
(make-generic-bound-check-getter (car g-n-s)))
(init-thunk
(standard-get g-n-s))
(else
(bound-check-get g-n-s)))
#:slot-definition slotdef)))
#:procedure (lambda (o) (slot-ref o name))
#:slot-definition g-n-s)))
(define-method (compute-setter-method (class <class>) slotdef)
(let ((g-n-s (cddr slotdef)))
(define-method (compute-setter-method (class <class>) g-n-s)
(let ((name (car g-n-s)))
(make <accessor-method>
#:specializers (list class <top>)
#:procedure (if (pair? g-n-s)
(cadr g-n-s)
(standard-set g-n-s))
#:slot-definition slotdef)))
#:specializers (list class <top>)
#:procedure (lambda (o v) (slot-set! o name v))
#:slot-definition g-n-s)))
(define (make-generic-bound-check-getter proc)
(lambda (o) (assert-bound (proc o) o)))

40
module/oop/goops/compile.scm
View file

@ -1,4 +1,4 @@
;;;; Copyright (C) 1999, 2001, 2006, 2009 Free Software Foundation, Inc.
;;;; Copyright (C) 1999, 2001, 2006, 2009, 2015 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
@ -16,40 +16,6 @@
;;;;
;; There are circularities here; you can't import (oop goops compile)
;; before (oop goops). So when compiling, make sure that things are
;; kosher.
(eval-when (expand) (resolve-module '(oop goops)))
(define-module (oop goops compile)
:use-module (oop goops)
:use-module (oop goops util)
:export (compute-cmethod)
:no-backtrace
)
;;;
;;; Compiling next methods into method bodies
;;;
;;; So, for the reader: there basic idea is that, given that the
;;; semantics of `next-method' depend on the concrete types being
;;; dispatched, why not compile a specific procedure to handle each type
;;; combination that we see at runtime.
;;;
;;; In theory we can do much better than a bytecode compilation, because
;;; we know the *exact* types of the arguments. It's ideal for native
;;; compilation. A task for the future.
;;;
;;; I think this whole generic application mess would benefit from a
;;; strict MOP.
(define (compute-cmethod methods types)
(let ((make-procedure (slot-ref (car methods) 'make-procedure)))
(if make-procedure
(make-procedure
(if (null? (cdr methods))
(lambda args
(no-next-method (method-generic-function (car methods)) args))
(compute-cmethod (cdr methods) types)))
(method-procedure (car methods)))))
#:use-module (oop goops internal)
#:re-export (compute-cmethod))

5
module/oop/goops/dispatch.scm
View file

@ -1,4 +1,4 @@
;;;; Copyright (C) 1999, 2000, 2001, 2003, 2006, 2009, 2012 Free Software Foundation, Inc.
;;;; Copyright (C) 1999, 2000, 2001, 2003, 2006, 2009, 2012, 2015 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
@ -24,7 +24,6 @@
(define-module (oop goops dispatch)
#:use-module (oop goops)
#:use-module (oop goops util)
#:use-module (oop goops compile)
#:use-module (system base target)
#:export (memoize-method!)
#:no-backtrace)
@ -251,7 +250,7 @@
(else
(parse (1+ n) (cdr ls)))))
(define (memoize len rest? types)
(let* ((cmethod (compute-cmethod applicable types))
(let* ((cmethod ((@@ (oop goops) compute-cmethod) applicable types))
(cache (cons (vector len types rest? cmethod)
(slot-ref gf 'effective-methods))))
(slot-set! gf 'effective-methods cache)

34
test-suite/tests/goops.test
View file

@ -599,3 +599,37 @@
(pass-if-equal 100 (slot-ref a 'test))
(pass-if-equal 100 (slot-ref b 'test))
(pass-if-equal 200 (slot-ref c 'test)))))))
(with-test-prefix "accessor slots"
(let* ((a-accessor (make-accessor 'a))
(b-accessor (make-accessor 'b))
(<a> (class ()
(a #:init-keyword #:a #:accessor a-accessor)
#:name '<a>))
(<b> (class ()
(b #:init-keyword #:b #:accessor b-accessor)
#:name '<b>))
(<ab> (class (<a> <b>) #:name '<ab>))
(<ba> (class (<b> <a>) #:name '<ba>))
(<cab> (class (<ab>)
(a #:init-keyword #:a)
#:name '<cab>))
(<cba> (class (<ba>)
(a #:init-keyword #:a)
#:name '<cba>))
(a (make <a> #:a 'a))
(b (make <b> #:b 'b))
(ab (make <ab> #:a 'a #:b 'b))
(ba (make <ba> #:a 'a #:b 'b))
(cab (make <cab> #:a 'a #:b 'b))
(cba (make <cba> #:a 'a #:b 'b)))
(pass-if-equal "a accessor on a" 'a (a-accessor a))
(pass-if-equal "a accessor on ab" 'a (a-accessor ab))
(pass-if-equal "a accessor on ba" 'a (a-accessor ba))
(pass-if-equal "a accessor on cab" 'a (a-accessor cab))
(pass-if-equal "a accessor on cba" 'a (a-accessor cba))
(pass-if-equal "b accessor on a" 'b (b-accessor b))
(pass-if-equal "b accessor on ab" 'b (b-accessor ab))
(pass-if-equal "b accessor on ba" 'b (b-accessor ba))
(pass-if-equal "b accessor on cab" 'b (b-accessor cab))
(pass-if-equal "b accessor on cba" 'b (b-accessor cba))))