From e7097386cb28f04cfeedc11415b06623ee2ac70c Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sat, 24 Jan 2015 18:59:15 +0100 Subject: Fix accessor struct inlining in GOOPS 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 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 , which does field access inlining based on the concrete types being applied. * test-suite/tests/goops.test ("accessor slots"): New test. --- module/oop/goops.scm | 95 ++++++++++++++++++++++++++++++++++++++-------------- 1 file changed, 70 insertions(+), 25 deletions(-) (limited to 'module/oop') diff --git a/module/oop/goops.scm b/module/oop/goops.scm index 1c4fd7de2..01ca7825c 100644 --- a/module/oop/goops.scm +++ b/module/oop/goops.scm @@ -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) ) + %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 , 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) ) + (eq? (class-of 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) ) + %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) ) %compute-applicable-methods compute-applicable-methods) gf args))) @@ -2635,17 +2656,17 @@ function." slots)) (define-method (compute-getter-method (class ) slot) - (let ((slot-ref (slot-definition-slot-ref slot))) + (let ((name (slot-definition-name slot))) (make #:specializers (list class) - #:procedure slot-ref + #:procedure (lambda (o) (slot-ref o name)) #:slot-definition slot))) (define-method (compute-setter-method (class ) slot) - (let ((slot-set! (slot-definition-slot-set! slot))) + (let ((name (slot-definition-name slot))) (make #:specializers (list class ) - #: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 #:name 'compute-applicable-methods)) - -(define-method (%%compute-applicable-methods (gf ) args) - (%compute-applicable-methods gf args)) - -(set! compute-applicable-methods %%compute-applicable-methods) +(define compute-applicable-methods + (let ((gf (make #:name 'compute-applicable-methods))) + (add-method! gf (method ((gf ) args) + (%compute-applicable-methods gf args))) + gf)) (define-method (sort-applicable-methods (gf ) methods args) (%sort-applicable-methods methods (map class-of args))) @@ -2985,6 +3003,33 @@ var{initargs}." (define-method (method-more-specific? (m1 ) (m2 ) targs) (%method-more-specific? m1 m2 targs)) +(define compute-effective-method + (let ((gf (make #:name 'compute-effective-method))) + (add-method! gf (method ((gf ) methods typev) + (%compute-effective-method gf methods typev))) + gf)) + +(define compute-specialized-effective-method + (let ((gf (make #:name 'compute-specialized-effective-method))) + (add-method! + gf + (method ((gf ) (method ) typev next) + (%compute-specialized-effective-method gf method typev next))) + gf)) + +(define-method (compute-specialized-effective-method (gf ) + (m ) + 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 ) methods build-next args) (apply (method-procedure (car methods)) (build-next (cdr methods) args) -- cgit v1.2.3