From bd1e5ff688dbaab135df38a71b0bed337c60a5e0 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 24 Jun 2025 15:05:28 +0200 Subject: [PATCH] Switch unboxed-fields bitmask to be a Scheme integer Requires a full rebuild!! * libguile/struct.h (SCM_VTABLE_UNBOXED_FIELDS): (SCM_VTABLE_FIELD_IS_UNBOXED): Use logbit? to determine if a field is unboxed. * module/language/cps/guile-vm/lower-primcalls.scm (vtable-has-unboxed-fields?): Just check against SCM_INUM0. (vtable-field-boxed?): Likewise, the bitmask is an integer. * libguile/struct.c (set_vtable_access_fields): Set UNBOXED_FIELDS bitmask as integer. --- libguile/struct.c | 23 ++-- libguile/struct.h | 4 +- .../language/cps/guile-vm/lower-primcalls.scm | 101 ++++++++++-------- 3 files changed, 68 insertions(+), 60 deletions(-) diff --git a/libguile/struct.c b/libguile/struct.c index 17b771200..000626fa3 100644 --- a/libguile/struct.c +++ b/libguile/struct.c @@ -128,7 +128,7 @@ set_vtable_access_fields (SCM vtable) size_t len, nfields; SCM layout; const char *c_layout; - uint32_t *unboxed_fields; + SCM unboxed_fields = SCM_INUM0; layout = SCM_VTABLE_LAYOUT (vtable); c_layout = scm_i_symbol_chars (layout); @@ -137,25 +137,16 @@ set_vtable_access_fields (SCM vtable) assert (len % 2 == 0); nfields = len / 2; - if (nfields) - { - size_t bitmask_size = (nfields + 31U) / 32U; - unboxed_fields = - scm_allocate_pointerless (SCM_I_CURRENT_THREAD, - bitmask_size * sizeof (*unboxed_fields)); - memset (unboxed_fields, 0, bitmask_size * sizeof (*unboxed_fields)); - for (size_t field = 0; field < nfields; field++) - if (c_layout[field*2] == 'u') - unboxed_fields[field/32U] |= 1U << (field%32U); - } - else - unboxed_fields = NULL; + for (size_t field = 0; field < nfields; field++) + if (c_layout[field*2] == 'u') + unboxed_fields = scm_logior (unboxed_fields, + scm_ash (SCM_INUM1, + scm_from_size_t (field))); /* Record computed size of vtable's instances. */ SCM_SET_VTABLE_FLAGS (vtable, 0); SCM_STRUCT_DATA_SET (vtable, scm_vtable_index_size, nfields); - SCM_STRUCT_DATA_SET (vtable, scm_vtable_index_unboxed_fields, - (uintptr_t) unboxed_fields); + SCM_STRUCT_SLOT_SET (vtable, scm_vtable_index_unboxed_fields, unboxed_fields); } static int diff --git a/libguile/struct.h b/libguile/struct.h index 459bfbd05..b0383603e 100644 --- a/libguile/struct.h +++ b/libguile/struct.h @@ -200,8 +200,8 @@ scm_i_struct_set_raw (struct scm_struct *x, size_t idx, scm_t_bits val) #define SCM_VTABLE_NAME(X) (SCM_STRUCT_SLOT_REF (X, scm_vtable_index_name)) #define SCM_SET_VTABLE_NAME(X,V) (SCM_STRUCT_SLOT_SET (X, scm_vtable_index_name, V)) #define SCM_VTABLE_SIZE(X) (SCM_STRUCT_DATA_REF (X, scm_vtable_index_size)) -#define SCM_VTABLE_UNBOXED_FIELDS(X) ((uint32_t*) SCM_STRUCT_DATA_REF (X, scm_vtable_index_unboxed_fields)) -#define SCM_VTABLE_FIELD_IS_UNBOXED(X,F) (SCM_VTABLE_UNBOXED_FIELDS (X)[(F)>>5]&(1U<<((F)&31))) +#define SCM_VTABLE_UNBOXED_FIELDS(X) (SCM_STRUCT_SLOT_REF (X, scm_vtable_index_unboxed_fields)) +#define SCM_VTABLE_FIELD_IS_UNBOXED(X,F) (scm_is_true (scm_logbit_p (SCM_I_MAKINUM (F), SCM_VTABLE_UNBOXED_FIELDS (X)))) #define SCM_STRUCT_VTABLE(X) (SCM_PACK (SCM_CELL_WORD_0 (X) - scm_tc3_struct)) #define SCM_STRUCT_LAYOUT(X) (SCM_VTABLE_LAYOUT (SCM_STRUCT_VTABLE (X))) diff --git a/module/language/cps/guile-vm/lower-primcalls.scm b/module/language/cps/guile-vm/lower-primcalls.scm index 87b258f94..087e721a6 100644 --- a/module/language/cps/guile-vm/lower-primcalls.scm +++ b/module/language/cps/guile-vm/lower-primcalls.scm @@ -1,6 +1,6 @@ ;;; Continuation-passing style (CPS) intermediate language (IL) -;; Copyright (C) 2023 Free Software Foundation, Inc. +;; Copyright (C) 2023, 2025 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 @@ -298,31 +298,13 @@ nfields (vtable)) (define vtable-index-unboxed-fields 6) ; FIXME: pull from struct.h (define vtable-offset-unboxed-fields (1+ vtable-index-unboxed-fields)) - (define (check-any-unboxed cps ptr word) - (if (< (* word 32) nfields) - (with-cps cps - (letv idx bits) - (let$ checkboxed (check-any-unboxed ptr (1+ word))) - (letk kcheckboxed ($kargs () () ,checkboxed)) - (letk kcheck - ($kargs ('bits) (bits) - ($branch kt kcheckboxed src 'u64-imm-= 0 (bits)))) - (letk kword - ($kargs ('idx) (idx) - ($continue kcheck src - ($primcall 'u32-ref 'bitmask (vtable ptr idx))))) - (build-term - ($continue kword src - ($primcall 'load-u64 word ())))) - (with-cps cps - (build-term ($continue kf src ($values ())))))) (with-cps cps - (letv ptr) - (let$ checkboxed (check-any-unboxed ptr 0)) - (letk kcheckboxed ($kargs ('ptr) (ptr) ,checkboxed)) + (letv fields) + (letk kcheckboxed ($kargs ('fields) (fields) + ($branch kt kf src 'eq-constant? 0 (fields)))) (build-term ($continue kcheckboxed src - ($primcall 'pointer-ref/immediate + ($primcall 'scm-ref/immediate `(struct . ,vtable-offset-unboxed-fields) (vtable)))))) @@ -342,30 +324,65 @@ ($continue ktag src ($primcall 'allocate-words/immediate `(struct . ,nwords) ()))))) -;; precondition: vtable is vtable, idx less than vtable size +;; precondition: vtable is vtable (define-branching-primcall-lowerer (vtable-field-boxed? cps kf kt src idx (vtable)) (define vtable-index-unboxed-fields 6) ; FIXME: pull from struct.h (define vtable-offset-unboxed-fields (1+ vtable-index-unboxed-fields)) + (define (some-fields-boxed cps fields) + (cond + ((< idx 8) + (with-cps cps + (letv u64 res) + (letk ktest + ($kargs ('res) (res) + ($branch kf kt src 'u64-imm-= 0 (res)))) + (letk ku64 + ($kargs ('u64) (u64) + ($continue ktest src + ($primcall 'ulogand/immediate (ash 1 idx) (u64))))) + (build-term + ($continue ku64 src + ($primcall 'scm->u64/truncate #f (fields)))))) + ((< idx 64) + (with-cps cps + (letv pat u64 res) + (letk ktest + ($kargs ('res) (res) + ($branch kf kt src 'u64-imm-= 0 (res)))) + (letk kpat + ($kargs ('pat) (pat) + ($continue ktest src + ($primcall 'ulogand #f (u64 pat))))) + (letk ku64 + ($kargs ('u64) (u64) + ($continue kpat src + ($primcall 'load-u64 (ash 1 idx) ())))) + (build-term + ($continue ku64 src + ($primcall 'scm->u64/truncate #f (fields)))))) + (else + (with-cps cps + (letv pat res) + (letk ktest + ($kargs ('res) (res) + ($branch kf kt src 'eq-constant? 0 (res)))) + (letk kpat + ($kargs ('pat) (pat) + ($continue ktest src + ($primcall 'logand #f (fields pat))))) + (build-term + ($continue kpat src ($const (ash 1 idx)))))))) (with-cps cps - (letv ptr word bits res) - (letk ktest - ($kargs ('res) (res) - ($branch kf kt src 'u64-imm-= 0 (res)))) - (letk kbits - ($kargs ('bits) (bits) - ($continue ktest src - ($primcall 'ulogand/immediate (ash 1 (logand idx 31)) (bits))))) - (letk kword - ($kargs ('word) (word) - ($continue kbits src - ($primcall 'u32-ref 'bitmask (vtable ptr word))))) - (letk kptr - ($kargs ('ptr) (ptr) - ($continue kword src - ($primcall 'load-u64 (ash idx -5) ())))) + (letv fields) + (let$ test (some-fields-boxed fields)) + (letk kcheck + ($kargs () () ,test)) + (letk kfields + ($kargs ('fields) (fields) + ($branch kcheck kt src 'eq-constant? 0 (fields)))) (build-term - ($continue kptr src - ($primcall 'pointer-ref/immediate + ($continue kfields src + ($primcall 'scm-ref/immediate `(struct . ,vtable-offset-unboxed-fields) (vtable))))))