From 583a23bf104c84d9617222856e188f3f3af4934d Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sat, 24 Jan 2015 19:22:47 +0100 Subject: [PATCH] Fix accessor struct field inlining * 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. --- module/oop/goops.scm | 98 ++++++++++++++++++++++++----------- module/oop/goops/compile.scm | 76 ++++++++------------------- module/oop/goops/dispatch.scm | 5 +- test-suite/tests/goops.test | 34 ++++++++++++ 4 files changed, 126 insertions(+), 87 deletions(-) rewrite module/oop/goops/compile.scm (62%) diff --git a/module/oop/goops.scm b/module/oop/goops.scm index 9ab1eb22a..486a652c0 100644 --- a/module/oop/goops.scm +++ b/module/oop/goops.scm @@ -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 ) + (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 ) slotdef) - (let ((init-thunk (cadr slotdef)) - (g-n-s (cddr slotdef))) +(define-method (compute-getter-method (class ) g-n-s) + (let ((name (car g-n-s))) (make #: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))) - -(define-method (compute-setter-method (class ) slotdef) - (let ((g-n-s (cddr slotdef))) + #:procedure (lambda (o) (slot-ref o name)) + #:slot-definition g-n-s))) + +(define-method (compute-setter-method (class ) g-n-s) + (let ((name (car g-n-s))) (make - #:specializers (list class ) - #:procedure (if (pair? g-n-s) - (cadr g-n-s) - (standard-set g-n-s)) - #:slot-definition slotdef))) + #:specializers (list class ) + #: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))) diff --git a/module/oop/goops/compile.scm b/module/oop/goops/compile.scm dissimilarity index 62% index 8c546e03f..93fdbf76e 100644 --- a/module/oop/goops/compile.scm +++ b/module/oop/goops/compile.scm @@ -1,55 +1,21 @@ -;;;; Copyright (C) 1999, 2001, 2006, 2009 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 -;;;; License as published by the Free Software Foundation; either -;;;; version 3 of the License, or (at your option) any later version. -;;;; -;;;; This library is distributed in the hope that it will be useful, -;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;;; Lesser General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU Lesser General Public -;;;; License along with this library; if not, write to the Free Software -;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA -;;;; - - -;; 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))))) +;;;; 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 +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA +;;;; + + +(define-module (oop goops compile) + #:use-module (oop goops internal) + #:re-export (compute-cmethod)) diff --git a/module/oop/goops/dispatch.scm b/module/oop/goops/dispatch.scm index 0198a9f40..666597441 100644 --- a/module/oop/goops/dispatch.scm +++ b/module/oop/goops/dispatch.scm @@ -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) diff --git a/test-suite/tests/goops.test b/test-suite/tests/goops.test index 724c0eec0..1c6d33ec0 100644 --- a/test-suite/tests/goops.test +++ b/test-suite/tests/goops.test @@ -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)) + ( (class () + (a #:init-keyword #:a #:accessor a-accessor) + #:name ')) + ( (class () + (b #:init-keyword #:b #:accessor b-accessor) + #:name ')) + ( (class ( ) #:name ')) + ( (class ( ) #:name ')) + ( (class () + (a #:init-keyword #:a) + #:name ')) + ( (class () + (a #:init-keyword #:a) + #:name ')) + (a (make #:a 'a)) + (b (make #:b 'b)) + (ab (make #:a 'a #:b 'b)) + (ba (make #:a 'a #:b 'b)) + (cab (make #:a 'a #:b 'b)) + (cba (make #: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)))) -- 2.20.1