[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 01/01: Fix accessor struct field inlining
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] 01/01: Fix accessor struct field inlining |
|
Date: |
Sat, 24 Jan 2015 18:23:33 +0000 |
wingo pushed a commit to branch stable-2.0
in repository guile.
commit 583a23bf104c84d9617222856e188f3f3af4934d
Author: Andy Wingo <address@hidden>
Date: Sat Jan 24 19:22:47 2015 +0100
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 | 40 +---------------
module/oop/goops/dispatch.scm | 5 +-
test-suite/tests/goops.test | 34 ++++++++++++++
4 files changed, 108 insertions(+), 69 deletions(-)
diff --git a/module/oop/goops.scm b/module/oop/goops.scm
index 9ab1eb2..486a652 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 <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)))
-
-(define-method (compute-setter-method (class <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 <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)))
diff --git a/module/oop/goops/compile.scm b/module/oop/goops/compile.scm
index 8c546e0..93fdbf7 100644
--- a/module/oop/goops/compile.scm
+++ b/module/oop/goops/compile.scm
@@ -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))
diff --git a/module/oop/goops/dispatch.scm b/module/oop/goops/dispatch.scm
index 0198a9f..6665974 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 724c0ee..1c6d33e 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))
+ (<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))))