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

Fix accessor struct inlining in GOOPS

Browse source 
Fixes bug #17355.

* module/oop/goops.scm (memoize-effective-method!): Adapt to
  compute-effective-method change.
  (compute-effective-method, %compute-effective-method): Renamed from
  compute-cmethod; now a generic protocol.
  (compute-specialized-effective-method)
  (%compute-specialized-effective-method): New sub-protocol.
  (memoize-generic-function-application!): Adapt to call the hard-wired
  compute-applicable-methods based on the concrete arguments types --
  the semantics is that %compute-applicable-methods is the
  implementation for <generic> functions.  Perhaps we should do the same
  for sort-applicable-methods and method-more-specific?.
  (compute-getter-method, compute-setter-method): The standard
  #:procedure is now a generic slot-ref.  It wasn't valid to inline
  field access here, because subtypes could have different field
  layouts.
  (compute-applicable-methods): Refactor generic definition to use
  lexical scoping.
  (compute-specialized-effective-method): New method for
  <accessor-method>, which does field access inlining based on the
  concrete types being applied.

* test-suite/tests/goops.test ("accessor slots"): New test.
This commit is contained in:
Andy Wingo 2015-01-24 18:59:15 +01:00
parent 4bde3f04ea
commit e7097386cb
2 changed files with 104 additions and 25 deletions
Download patch file Download diff file Expand all files Collapse all files

95
module/oop/goops.scm
View file

@ -1465,7 +1465,10 @@ function."
(lp (1+ n) args)))))
typev))
(let* ((typev (record-types args))
(cmethod (compute-cmethod applicable typev))
(compute-effective-method (if (eq? (class-of gf) <generic>)
%compute-effective-method
compute-effective-method))
(cmethod (compute-effective-method gf applicable typev))
(cache (acons typev cmethod (slot-ref gf 'effective-methods))))
(slot-set! gf 'effective-methods cache)
(recompute-generic-function-dispatch-procedure! gf)
@ -1482,26 +1485,44 @@ function."
;;; An effective method is bound to a specific `next-method' by the
;;; `make-procedure' slot of a <method>, which returns the new closure.
;;;
(define (compute-cmethod methods types)
(define (%compute-specialized-effective-method gf method types next-method)
(match (slot-ref method 'make-procedure)
(#f (method-procedure method))
(make-procedure (make-procedure next-method))))
(define (compute-specialized-effective-method gf method types next-method)
(%compute-specialized-effective-method gf method types next-method))
(define (%compute-effective-method gf methods types)
(match methods
((method . methods)
(match (slot-ref method 'make-procedure)
(#f (method-procedure method))
(make-procedure
(make-procedure
(match methods
(()
(lambda args
(no-next-method (method-generic-function method) args)))
(methods
(compute-cmethod methods types)))))))))
(let ((compute-specialized-effective-method
(if (and (eq? (class-of gf) <generic>)
(eq? (class-of method) <method>))
%compute-specialized-effective-method
compute-specialized-effective-method)))
(compute-specialized-effective-method
gf method types
(match methods
(()
(lambda args
(no-next-method gf args)))
(methods
(let ((compute-effective-method (if (eq? (class-of gf) <generic>)
%compute-effective-method
compute-effective-method)))
(compute-effective-method gf methods types)))))))))
;; Boot definition; overrided with a generic later.
(define (compute-effective-method gf methods types)
(%compute-effective-method gf methods types))
;;;
;;; Memoization
;;;
(define (memoize-generic-function-application! gf args)
(let ((applicable ((if (eq? gf compute-applicable-methods)
(let ((applicable ((if (eq? (class-of gf) <generic>)
%compute-applicable-methods
compute-applicable-methods)
gf args)))
@ -2635,17 +2656,17 @@ function."
slots))
(define-method (compute-getter-method (class <class>) slot)
(let ((slot-ref (slot-definition-slot-ref slot)))
(let ((name (slot-definition-name slot)))
(make <accessor-method>
#:specializers (list class)
#:procedure slot-ref
#:procedure (lambda (o) (slot-ref o name))
#:slot-definition slot)))
(define-method (compute-setter-method (class <class>) slot)
(let ((slot-set! (slot-definition-slot-set! slot)))
(let ((name (slot-definition-name slot)))
(make <accessor-method>
#:specializers (list class <top>)
#:procedure slot-set!
#:procedure (lambda (o v) (slot-set! o name v))
#:slot-definition slot)))
(define (make-generic-bound-check-getter proc)
@ -2970,14 +2991,11 @@ var{initargs}."
(no-applicable-method gf args))))
;; compute-applicable-methods is bound to %compute-applicable-methods.
;; *fixme* use let
(define %%compute-applicable-methods
(make <generic> #:name 'compute-applicable-methods))
(define-method (%%compute-applicable-methods (gf <generic>) args)
(%compute-applicable-methods gf args))
(set! compute-applicable-methods %%compute-applicable-methods)
(define compute-applicable-methods
(let ((gf (make <generic> #:name 'compute-applicable-methods)))
(add-method! gf (method ((gf <generic>) args)
(%compute-applicable-methods gf args)))
gf))
(define-method (sort-applicable-methods (gf <generic>) methods args)
(%sort-applicable-methods methods (map class-of args)))
@ -2985,6 +3003,33 @@ var{initargs}."
(define-method (method-more-specific? (m1 <method>) (m2 <method>) targs)
(%method-more-specific? m1 m2 targs))
(define compute-effective-method
(let ((gf (make <generic> #:name 'compute-effective-method)))
(add-method! gf (method ((gf <generic>) methods typev)
(%compute-effective-method gf methods typev)))
gf))
(define compute-specialized-effective-method
(let ((gf (make <generic> #:name 'compute-specialized-effective-method)))
(add-method!
gf
(method ((gf <generic>) (method <method>) typev next)
(%compute-specialized-effective-method gf method typev next)))
gf))
(define-method (compute-specialized-effective-method (gf <generic>)
(m <accessor-method>)
typev
next)
(let ((name (slot-definition-name (accessor-method-slot-definition m))))
(match typev
(#(class)
(slot-definition-slot-ref (class-slot-definition class name)))
(#(class _)
(slot-definition-slot-set! (class-slot-definition class name)))
(_
(next-method)))))
(define-method (apply-method (gf <generic>) methods build-next args)
(apply (method-procedure (car methods))
(build-next (cdr methods) args)

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

@ -621,3 +621,37 @@
(pass-if-equal "<a>"
(list <a> <b> <d> <c> <e> <f> <object> <top>)
(compute-cpl <a>)))
(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))))