From 9167e0b88d3829a6b54d4b4faa6197b3675bb38e Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 24 Dec 2014 09:37:14 -0500 Subject: [PATCH] compute-cpl implementation only in Scheme * libguile/goops.c (build_class_class_slots, create_basic_classes): Instead of creating with uninitialized `direct-slots', `slots', and `getters-n-setters' fields and initializing them later, create with a "boot" version of unspecialized slots and later replace the fields with specialized slot classes. This allows slot-ref to work during early boot, which is necessary to move compute-cpl to Scheme. (create_standard_classes): Finish initializing here. (map, filter_cpl, compute_cpl): Remove the boot-time compute-cpl in C and its helpers. (scm_basic_basic_make_class): Call compute-cpl in Scheme. (fix_cpl): Remove; since we use the correct compute-cpl from the beginning, there's no need to correct for the deficiencies of the C implementation any more. (build_slots_list): Adapt to build_class_class_slots change. * module/oop/goops.scm (compute-std-cpl, compute-cpl): Move these up to the top, so they can be called by the boot process. (compute-clos-cpl, top-sort, std-tie-breaker, build-transitive-closure) (build-constraints): Remove unused private code. --- libguile/goops.c | 156 +++++++++------------------------ module/oop/goops.scm | 202 +++++++++++++------------------------------ 2 files changed, 102 insertions(+), 256 deletions(-) diff --git a/libguile/goops.c b/libguile/goops.c index c62ea7c61..f76f74572 100644 --- a/libguile/goops.c +++ b/libguile/goops.c @@ -336,63 +336,6 @@ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0, } #undef FUNC_NAME -/****************************************************************************** - * - * Compute-cpl - * - * This version doesn't fully handle multiple-inheritance. It serves - * only for booting classes and will be overloaded in Scheme - * - ******************************************************************************/ - -static SCM -map (SCM (*proc) (SCM), SCM ls) -{ - if (scm_is_null (ls)) - return ls; - else - { - SCM res = scm_cons (proc (SCM_CAR (ls)), SCM_EOL); - SCM h = res; - ls = SCM_CDR (ls); - while (scm_is_pair (ls)) - { - SCM_SETCDR (h, scm_cons (proc (SCM_CAR (ls)), SCM_EOL)); - h = SCM_CDR (h); - ls = SCM_CDR (ls); - } - return res; - } -} - -static SCM -filter_cpl (SCM ls) -{ - SCM res = SCM_EOL; - while (scm_is_pair (ls)) - { - SCM el = SCM_CAR (ls); - if (scm_is_false (scm_c_memq (el, res))) - res = scm_cons (el, res); - ls = SCM_CDR (ls); - } - return res; -} - -static SCM -compute_cpl (SCM class) -{ - if (goops_loaded_p) - return scm_call_1 (SCM_VARIABLE_REF (var_compute_cpl), class); - else - { - SCM supers = SCM_SLOT (class, scm_si_direct_supers); - SCM ls = scm_append (scm_acons (class, supers, - map (compute_cpl, supers))); - return scm_reverse_x (filter_cpl (ls), SCM_EOL); - } -} - /****************************************************************************** * * compute-slots @@ -428,8 +371,8 @@ check_cpl (SCM slots, SCM bslots) "field cannot be redefined", SCM_EOL); } -static SCM -build_class_class_slots (void); +enum build_class_class_slots_mode { BOOT_SLOTS, FINAL_SLOTS }; +static SCM build_class_class_slots (enum build_class_class_slots_mode mode); static SCM build_slots_list (SCM dslots, SCM cpl) @@ -443,7 +386,7 @@ build_slots_list (SCM dslots, SCM cpl) if (classp) { - bslots = build_class_class_slots (); + bslots = build_class_class_slots (FINAL_SLOTS); check_cpl (res, bslots); } else @@ -841,7 +784,7 @@ scm_basic_basic_make_class (SCM class, SCM name, SCM dsupers, SCM dslots) /* Initialize its slots */ SCM_SET_SLOT (z, scm_si_direct_supers, dsupers); - cpl = compute_cpl (z); + cpl = scm_call_1 (SCM_VARIABLE_REF (var_compute_cpl), z); slots = build_slots_list (maplist (dslots), cpl); nfields = scm_from_int (scm_ilength (slots)); g_n_s = compute_getters_n_setters (slots); @@ -909,29 +852,37 @@ SCM_SYMBOL (sym_getters_n_setters, "getters-n-setters"); SCM_SYMBOL (sym_nfields, "nfields"); +static int specialized_slots_initialized = 0; + static SCM -build_class_class_slots (void) +build_class_class_slots (enum build_class_class_slots_mode mode) { +#define SPECIALIZED_SLOT(name, class) \ + (mode == BOOT_SLOTS ? scm_list_1 (name) : scm_list_3 (name, k_class, class)) + + if (mode == FINAL_SLOTS && !specialized_slots_initialized) + abort (); + /* has to be kept in sync with SCM_VTABLE_BASE_LAYOUT and SCM_CLASS_CLASS_LAYOUT */ return scm_list_n ( - scm_list_3 (sym_layout, k_class, scm_class_protected_read_only), - scm_list_3 (sym_flags, k_class, scm_class_hidden), - scm_list_3 (sym_self, k_class, scm_class_self), - scm_list_3 (sym_instance_finalizer, k_class, scm_class_hidden), + SPECIALIZED_SLOT (sym_layout, scm_class_protected_read_only), + SPECIALIZED_SLOT (sym_flags, scm_class_hidden), + SPECIALIZED_SLOT (sym_self, scm_class_self), + SPECIALIZED_SLOT (sym_instance_finalizer, scm_class_hidden), scm_list_1 (sym_print), - scm_list_3 (sym_name, k_class, scm_class_protected_hidden), - scm_list_3 (sym_reserved_0, k_class, scm_class_hidden), - scm_list_3 (sym_reserved_1, k_class, scm_class_hidden), + SPECIALIZED_SLOT (sym_name, scm_class_protected_hidden), + SPECIALIZED_SLOT (sym_reserved_0, scm_class_hidden), + SPECIALIZED_SLOT (sym_reserved_1, scm_class_hidden), scm_list_1 (sym_redefined), - scm_list_3 (sym_h0, k_class, scm_class_int), - scm_list_3 (sym_h1, k_class, scm_class_int), - scm_list_3 (sym_h2, k_class, scm_class_int), - scm_list_3 (sym_h3, k_class, scm_class_int), - scm_list_3 (sym_h4, k_class, scm_class_int), - scm_list_3 (sym_h5, k_class, scm_class_int), - scm_list_3 (sym_h6, k_class, scm_class_int), - scm_list_3 (sym_h7, k_class, scm_class_int), + SPECIALIZED_SLOT (sym_h0, scm_class_int), + SPECIALIZED_SLOT (sym_h1, scm_class_int), + SPECIALIZED_SLOT (sym_h2, scm_class_int), + SPECIALIZED_SLOT (sym_h3, scm_class_int), + SPECIALIZED_SLOT (sym_h4, scm_class_int), + SPECIALIZED_SLOT (sym_h5, scm_class_int), + SPECIALIZED_SLOT (sym_h6, scm_class_int), + SPECIALIZED_SLOT (sym_h7, scm_class_int), scm_list_1 (sym_direct_supers), scm_list_1 (sym_direct_slots), scm_list_1 (sym_direct_subclasses), @@ -947,7 +898,7 @@ build_class_class_slots (void) static void create_basic_classes (void) { - /* SCM slots_of_class = build_class_class_slots (); */ + SCM slots_of_class = build_class_class_slots (BOOT_SLOTS); /**** ****/ SCM cs = scm_from_locale_string (SCM_CLASS_CLASS_LAYOUT); @@ -958,14 +909,14 @@ create_basic_classes (void) SCM_SET_SLOT (scm_class_class, scm_vtable_index_name, name); SCM_SET_SLOT (scm_class_class, scm_si_direct_supers, SCM_EOL); /* will be changed */ - /* SCM_SET_SLOT (scm_class_class, scm_si_direct_slots, slots_of_class); */ + SCM_SET_SLOT (scm_class_class, scm_si_direct_slots, slots_of_class); /* will be changed */ SCM_SET_SLOT (scm_class_class, scm_si_direct_subclasses, SCM_EOL); SCM_SET_SLOT (scm_class_class, scm_si_direct_methods, SCM_EOL); SCM_SET_SLOT (scm_class_class, scm_si_cpl, SCM_EOL); /* will be changed */ - /* SCM_SET_SLOT (scm_class_class, scm_si_slots, slots_of_class); */ + SCM_SET_SLOT (scm_class_class, scm_si_slots, slots_of_class); /* will be changed */ SCM_SET_SLOT (scm_class_class, scm_si_nfields, scm_from_int (SCM_N_CLASS_SLOTS)); - /* SCM_SET_SLOT (scm_class_class, scm_si_getters_n_setters, - compute_getters_n_setters (slots_of_class)); */ + SCM_SET_SLOT (scm_class_class, scm_si_getters_n_setters, + compute_getters_n_setters (slots_of_class)); /* will be changed */ SCM_SET_SLOT (scm_class_class, scm_si_redefined, SCM_BOOL_F); prep_hashsets (scm_class_class); @@ -2045,33 +1996,6 @@ SCM_DEFINE (scm_make, "make", 0, 0, 1, * ******************************************************************************/ -/* Munge the CPL of C in place such that BEFORE appears before AFTER, - assuming that currently the reverse is true. Recalculate slots and - associated getters-n-setters. */ -static void -fix_cpl (SCM c, SCM before, SCM after) -{ - SCM cpl = SCM_SLOT (c, scm_si_cpl); - SCM ls = scm_c_memq (after, cpl); - SCM tail; - - if (scm_is_false (ls)) - /* if this condition occurs, fix_cpl should not be applied this way */ - abort (); - - tail = scm_delq1_x (before, SCM_CDR (ls)); - SCM_SETCAR (ls, before); - SCM_SETCDR (ls, scm_cons (after, tail)); - { - SCM dslots = SCM_SLOT (c, scm_si_direct_slots); - SCM slots = build_slots_list (maplist (dslots), cpl); - SCM g_n_s = compute_getters_n_setters (slots); - SCM_SET_SLOT (c, scm_si_slots, slots); - SCM_SET_SLOT (c, scm_si_getters_n_setters, g_n_s); - } -} - - static void make_stdcls (SCM *var, char *name, SCM meta, SCM super, SCM slots) { @@ -2146,9 +2070,11 @@ create_standard_classes (void) make_stdcls (&scm_class_double, "", scm_class_class, scm_class_foreign_slot, SCM_EOL); - /* Continue initialization of class */ + specialized_slots_initialized = 1; - slots = build_class_class_slots (); + /* Finish initialization of class */ + + slots = build_class_class_slots (FINAL_SLOTS); SCM_SET_SLOT (scm_class_class, scm_si_direct_slots, slots); SCM_SET_SLOT (scm_class_class, scm_si_slots, slots); SCM_SET_SLOT (scm_class_class, scm_si_getters_n_setters, @@ -2195,9 +2121,6 @@ create_standard_classes (void) scm_list_2 (scm_class_accessor, scm_class_extended_generic_with_setter), SCM_EOL); - /* is misplaced. */ - fix_cpl (scm_class_extended_accessor, - scm_class_extended_generic, scm_class_generic_with_setter); SCM_SET_CLASS_FLAGS (scm_class_extended_accessor, SCM_CLASSF_PURE_GENERIC); /* Primitive types classes */ @@ -2505,8 +2428,6 @@ SCM_DEFINE (scm_sys_goops_loaded, "%goops-loaded", 0, 0, 0, scm_module_variable (scm_module_goops, sym_slot_unbound); var_slot_missing = scm_module_variable (scm_module_goops, sym_slot_missing); - var_compute_cpl = - scm_module_variable (scm_module_goops, sym_compute_cpl); var_no_applicable_method = scm_module_variable (scm_module_goops, sym_no_applicable_method); var_change_class = @@ -2527,6 +2448,9 @@ scm_init_goops_builtins (void) #include "libguile/goops.x" + var_compute_cpl = + scm_module_variable (scm_module_goops, sym_compute_cpl); + hell = scm_calloc (hell_size * sizeof (*hell)); hell_mutex = scm_make_mutex (); diff --git a/module/oop/goops.scm b/module/oop/goops.scm index ebc47eb30..654ee867e 100644 --- a/module/oop/goops.scm +++ b/module/oop/goops.scm @@ -135,6 +135,64 @@ (define *goops-module* (current-module)) +(eval-when (compile load eval) + ;;; The standard class precedence list computation algorithm + ;;; + ;;; Correct behaviour: + ;;; + ;;; (define-class food ()) + ;;; (define-class fruit (food)) + ;;; (define-class spice (food)) + ;;; (define-class apple (fruit)) + ;;; (define-class cinnamon (spice)) + ;;; (define-class pie (apple cinnamon)) + ;;; => cpl (pie) = pie apple fruit cinnamon spice food object top + ;;; + ;;; (define-class d ()) + ;;; (define-class e ()) + ;;; (define-class f ()) + ;;; (define-class b (d e)) + ;;; (define-class c (e f)) + ;;; (define-class a (b c)) + ;;; => cpl (a) = a b d c e f object top + ;;; + + (define (compute-std-cpl c get-direct-supers) + (define (only-non-null lst) + (filter (lambda (l) (not (null? l))) lst)) + + (define (merge-lists reversed-partial-result inputs) + (cond + ((every null? inputs) + (reverse! reversed-partial-result)) + (else + (let* ((candidate (lambda (c) + (and (not (any (lambda (l) + (memq c (cdr l))) + inputs)) + c))) + (candidate-car (lambda (l) + (and (not (null? l)) + (candidate (car l))))) + (next (any candidate-car inputs))) + (if (not next) + (goops-error "merge-lists: Inconsistent precedence graph")) + (let ((remove-next (lambda (l) + (if (eq? (car l) next) + (cdr l) + l)))) + (merge-lists (cons next reversed-partial-result) + (only-non-null (map remove-next inputs)))))))) + (let ((c-direct-supers (get-direct-supers c))) + (merge-lists (list c) + (only-non-null (append (map class-precedence-list + c-direct-supers) + (list c-direct-supers)))))) + + ;; Bootstrap version. + (define (compute-cpl class) + (compute-std-cpl class class-direct-supers))) + ;; XXX FIXME: figure out why the 'eval-when's in this file must use ;; 'compile' and must avoid 'expand', but only in 2.2, and only when ;; compiling something that imports goops, e.g. (ice-9 occam-channel), @@ -1358,150 +1416,14 @@ ;;; compute-cpl ;;; -;;; Correct behaviour: -;;; -;;; (define-class food ()) -;;; (define-class fruit (food)) -;;; (define-class spice (food)) -;;; (define-class apple (fruit)) -;;; (define-class cinnamon (spice)) -;;; (define-class pie (apple cinnamon)) -;;; => cpl (pie) = pie apple fruit cinnamon spice food object top -;;; -;;; (define-class d ()) -;;; (define-class e ()) -;;; (define-class f ()) -;;; (define-class b (d e)) -;;; (define-class c (e f)) -;;; (define-class a (b c)) -;;; => cpl (a) = a b d c e f object top -;;; + +;; Replace the bootstrap compute-cpl with this definition. +(define compute-cpl + (make #:name 'compute-cpl)) (define-method (compute-cpl (class )) (compute-std-cpl class class-direct-supers)) -;; Support - -(define (only-non-null lst) - (filter (lambda (l) (not (null? l))) lst)) - -(define (compute-std-cpl c get-direct-supers) - (let ((c-direct-supers (get-direct-supers c))) - (merge-lists (list c) - (only-non-null (append (map class-precedence-list - c-direct-supers) - (list c-direct-supers)))))) - -(define (merge-lists reversed-partial-result inputs) - (cond - ((every null? inputs) - (reverse! reversed-partial-result)) - (else - (let* ((candidate (lambda (c) - (and (not (any (lambda (l) - (memq c (cdr l))) - inputs)) - c))) - (candidate-car (lambda (l) - (and (not (null? l)) - (candidate (car l))))) - (next (any candidate-car inputs))) - (if (not next) - (goops-error "merge-lists: Inconsistent precedence graph")) - (let ((remove-next (lambda (l) - (if (eq? (car l) next) - (cdr l) - l)))) - (merge-lists (cons next reversed-partial-result) - (only-non-null (map remove-next inputs)))))))) - -;; Modified from TinyClos: -;; -;; A simple topological sort. -;; -;; It's in this file so that both TinyClos and Objects can use it. -;; -;; This is a fairly modified version of code I originally got from Anurag -;; Mendhekar . -;; - -(define (compute-clos-cpl c get-direct-supers) - (top-sort ((build-transitive-closure get-direct-supers) c) - ((build-constraints get-direct-supers) c) - (std-tie-breaker get-direct-supers))) - - -(define (top-sort elements constraints tie-breaker) - (let loop ((elements elements) - (constraints constraints) - (result '())) - (if (null? elements) - result - (let ((can-go-in-now - (filter - (lambda (x) - (every (lambda (constraint) - (or (not (eq? (cadr constraint) x)) - (memq (car constraint) result))) - constraints)) - elements))) - (if (null? can-go-in-now) - (goops-error "top-sort: Invalid constraints") - (let ((choice (if (null? (cdr can-go-in-now)) - (car can-go-in-now) - (tie-breaker result - can-go-in-now)))) - (loop - (filter (lambda (x) (not (eq? x choice))) - elements) - constraints - (append result (list choice))))))))) - -(define (std-tie-breaker get-supers) - (lambda (partial-cpl min-elts) - (let loop ((pcpl (reverse partial-cpl))) - (let ((current-elt (car pcpl))) - (let ((ds-of-ce (get-supers current-elt))) - (let ((common (filter (lambda (x) - (memq x ds-of-ce)) - min-elts))) - (if (null? common) - (if (null? (cdr pcpl)) - (goops-error "std-tie-breaker: Nothing valid") - (loop (cdr pcpl))) - (car common)))))))) - - -(define (build-transitive-closure get-follow-ons) - (lambda (x) - (let track ((result '()) - (pending (list x))) - (if (null? pending) - result - (let ((next (car pending))) - (if (memq next result) - (track result (cdr pending)) - (track (cons next result) - (append (get-follow-ons next) - (cdr pending))))))))) - -(define (build-constraints get-follow-ons) - (lambda (x) - (let loop ((elements ((build-transitive-closure get-follow-ons) x)) - (this-one '()) - (result '())) - (if (or (null? this-one) (null? (cdr this-one))) - (if (null? elements) - result - (loop (cdr elements) - (cons (car elements) - (get-follow-ons (car elements))) - result)) - (loop elements - (cdr this-one) - (cons (list (car this-one) (cadr this-one)) - result)))))) - ;;; compute-get-n-set ;;; (define-method (compute-get-n-set (class ) s)