Create a specific SV type for object instances

9 files changed, 148 insertions, 31 deletions

diff --git a/class.c b/class.c
index 88a4205a99..6642a01d5d 100644
--- a/class.c
+++ b/class.c
@@ -30,6 +30,20 @@ Perl_croak_kw_unless_class(pTHX_ const char *kw)
         croak("Cannot '%s' outside of a 'class'", kw);
 }
 
+#define newSVobject(fieldcount)  Perl_newSVobject(aTHX_ fieldcount)
+SV *
+Perl_newSVobject(pTHX_ Size_t fieldcount)
+{
+    SV *sv = newSV_type(SVt_PVOBJ);
+
+    Newx(ObjectFIELDS(sv), fieldcount, SV *);
+    ObjectMAXFIELD(sv) = fieldcount - 1;
+
+    Zero(ObjectFIELDS(sv), fieldcount, SV *);
+
+    return sv;
+}
+
 XS(injected_constructor);
 XS(injected_constructor)
 {
@@ -65,10 +79,12 @@ XS(injected_constructor)
         }
     }
 
-    AV *fields = newAV();
-    SV *self = sv_2mortal(newRV_noinc((SV *)fields));
+    SV *instance = newSVobject(aux->xhv_class_next_fieldix);
+    SV *self = sv_2mortal(newRV_noinc(instance));
     sv_bless(self, stash);
 
+    SV **fields = ObjectFIELDS(instance);
+
     /* create fields */
     for(PADOFFSET fieldix = 0; fieldix < aux->xhv_class_next_fieldix; fieldix++) {
         PADNAME *pn = PadnamelistARRAY(aux->xhv_class_fields)[fieldix];
@@ -93,7 +109,7 @@ XS(injected_constructor)
                 NOT_REACHED;
         }
 
-        av_push(fields, val);
+        fields[fieldix] = val;
     }
 
     if(aux->xhv_class_adjust_blocks) {
@@ -164,7 +180,7 @@ PP(pp_methstart)
 
     if(!SvROK(self) ||
         !SvOBJECT((rv = SvRV(self))) ||
-        SvTYPE(rv) != SVt_PVAV) { /* TODO: SVt_INSTANCE */
+        SvTYPE(rv) != SVt_PVOBJ) {
         HEK *namehek = CvGvNAME_HEK(curcv);
         croak(
             namehek ? "Cannot invoke method %" HEKf_QUOTEDPREFIX " on a non-instance" :
@@ -182,14 +198,14 @@ PP(pp_methstart)
 
     UNOP_AUX_item *aux = cUNOP_AUX->op_aux;
     if(aux) {
-        assert(SvTYPE(SvRV(self)) == SVt_PVAV);
-        AV *fields = MUTABLE_AV(SvRV(self));
-        SV **fieldp = AvARRAY(fields);
+        assert(SvTYPE(SvRV(self)) == SVt_PVOBJ);
+        SV *instance = SvRV(self);
+        SV **fieldp = ObjectFIELDS(instance);
 
         U32 fieldcount = (aux++)->uv;
         U32 max_fieldix = (aux++)->uv;
 
-        assert(av_count(fields) > max_fieldix);
+        assert(ObjectMAXFIELD(instance)+1 > max_fieldix);
         PERL_UNUSED_VAR(max_fieldix);
 
         for(Size_t i = 0; i < fieldcount; i++) {
diff --git a/dump.c b/dump.c
index 6209e1ac5b..62f41b4392 100644
--- a/dump.c
+++ b/dump.c
@@ -45,7 +45,8 @@ static const char* const svtypenames[SVt_LAST] = {
     "PVHV",
     "PVCV",
     "PVFM",
-    "PVIO"
+    "PVIO",
+    "PVOBJ",
 };
 
 
@@ -65,7 +66,8 @@ static const char* const svshorttypenames[SVt_LAST] = {
     "HV",
     "CV",
     "FM",
-    "IO"
+    "IO",
+    "OBJ",
 };
 
 struct flag_to_name {
@@ -2004,8 +2006,7 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo
 
     /* Dump general SV fields */
 
-    if ((type >= SVt_PVIV && type != SVt_PVAV && type != SVt_PVHV
-         && type != SVt_PVCV && type != SVt_PVFM && type != SVt_PVIO
+    if ((type >= SVt_PVIV && type <= SVt_PVLV
          && type != SVt_REGEXP && !isGV_with_GP(sv) && !SvVALID(sv))
         || (type == SVt_IV && !SvROK(sv))) {
         if (SvIsUV(sv)
@@ -2016,9 +2017,8 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo
         (void)PerlIO_putc(file, '\n');
     }
 
-    if ((type >= SVt_PVNV && type != SVt_PVAV && type != SVt_PVHV
-                && type != SVt_PVCV && type != SVt_PVFM  && type != SVt_REGEXP
-                && type != SVt_PVIO && !isGV_with_GP(sv) && !SvVALID(sv))
+    if ((type >= SVt_PVNV && type <= SVt_PVLV
+         && type != SVt_REGEXP && !isGV_with_GP(sv) && !SvVALID(sv))
                || type == SVt_NV) {
         DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
         STORE_LC_NUMERIC_SET_STANDARD();
@@ -2704,6 +2704,29 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo
                            maxnest, dumpops, pvlim);
         }
         break;
+    case SVt_PVOBJ:
+        Perl_dump_indent(aTHX_ level, file, "  MAXFIELD = %" IVdf "\n",
+                (IV)ObjectMAXFIELD(sv));
+        Perl_dump_indent(aTHX_ level, file, "  FIELDS = 0x%" UVxf "\n",
+                PTR2UV(ObjectFIELDS(sv)));
+        if (nest < maxnest && ObjectFIELDS(sv)) {
+            SSize_t count;
+            SV **svp = ObjectFIELDS(sv);
+            PADNAME **pname = PadnamelistARRAY(HvAUX(SvSTASH(sv))->xhv_class_fields);
+            for (count = 0;
+                 count <= ObjectMAXFIELD(sv) && count < maxnest;
+                 count++, svp++)
+            {
+                SV *const field = *svp;
+                PADNAME *pn = pname[count];
+
+                Perl_dump_indent(aTHX_ level + 1, file, "Field No. %" IVdf " (%s)\n",
+                        (IV)count, PadnamePV(pn));
+
+                do_sv_dump(level+1, file, field, nest+1, maxnest, dumpops, pvlim);
+            }
+        }
+        break;
     }
     SvREFCNT_dec_NN(d);
 }
diff --git a/ext/B/B.pm b/ext/B/B.pm
index 176cd31ddc..d0a04c6a12 100644
--- a/ext/B/B.pm
+++ b/ext/B/B.pm
@@ -20,7 +20,7 @@ sub import {
 # walkoptree comes from B.xs
 
 BEGIN {
-    $B::VERSION = '1.87';
+    $B::VERSION = '1.88';
     @B::EXPORT_OK = ();
 
     # Our BOOT code needs $VERSION set, and will append to @EXPORT_OK.
@@ -62,6 +62,7 @@ push @B::EXPORT_OK, (qw(minus_c ppname save_BEGINs
 @B::CV::ISA = 'B::PVMG';
 @B::IO::ISA = 'B::PVMG';
 @B::FM::ISA = 'B::CV';
+@B::OBJ::ISA = 'B::PVMG';
 
 @B::OP::ISA = 'B::OBJECT';
 @B::UNOP::ISA = 'B::OP';
diff --git a/ext/B/B.xs b/ext/B/B.xs
index b7f763d347..49b35cbf2f 100644
--- a/ext/B/B.xs
+++ b/ext/B/B.xs
@@ -40,6 +40,7 @@ static const char* const svclassnames[] = {
     "B::CV",
     "B::FM",
     "B::IO",
+    "B::OBJ",
 };
 
 
diff --git a/perl.h b/perl.h
index 1372655683..40d43d8194 100644
--- a/perl.h
+++ b/perl.h
@@ -3249,6 +3249,7 @@ typedef struct xpvcv XPVCV;
 typedef struct xpvbm XPVBM;
 typedef struct xpvfm XPVFM;
 typedef struct xpvio XPVIO;
+typedef struct xobject XPVOBJ;
 typedef struct mgvtbl MGVTBL;
 typedef union any ANY;
 typedef struct ptr_tbl_ent PTR_TBL_ENT_t;
@@ -6256,19 +6257,19 @@ EXTCONST U8 PL_magic_data[256];
 #endif
 
 #ifdef DOINIT
-                        /* NL IV NV PV INV PI PN MG RX GV LV AV HV CV FM IO */
+                        /* NL IV NV PV INV PI PN MG RX GV LV AV HV CV FM IO OBJ */
 EXTCONST bool
-PL_valid_types_IVX[]    = { 0, 1, 0, 0, 0, 1, 1, 1, 0, 1, 1, 0, 0, 0, 0, 0 };
+PL_valid_types_IVX[]    = { 0, 1, 0, 0, 0, 1, 1, 1, 0, 1, 1, 0, 0, 0, 0, 0, 0 };
 EXTCONST bool
-PL_valid_types_NVX[]    = { 0, 0, 1, 0, 0, 0, 1, 1, 0, 1, 1, 0, 0, 0, 0, 0 };
+PL_valid_types_NVX[]    = { 0, 0, 1, 0, 0, 0, 1, 1, 0, 1, 1, 0, 0, 0, 0, 0, 0 };
 EXTCONST bool
-PL_valid_types_PVX[]    = { 0, 0, 0, 1, 1, 1, 1, 1, 1, 1, 1, 0, 0, 1, 1, 1 };
+PL_valid_types_PVX[]    = { 0, 0, 0, 1, 1, 1, 1, 1, 1, 1, 1, 0, 0, 1, 1, 1, 0 };
 EXTCONST bool
-PL_valid_types_RV[]     = { 0, 1, 0, 1, 0, 1, 1, 1, 1, 1, 1, 0, 0, 0, 0, 1 };
+PL_valid_types_RV[]     = { 0, 1, 0, 1, 0, 1, 1, 1, 1, 1, 1, 0, 0, 0, 0, 1, 0 };
 EXTCONST bool
-PL_valid_types_IV_set[] = { 0, 1, 0, 0, 0, 1, 1, 1, 1, 1, 1, 0, 0, 0, 1, 1 };
+PL_valid_types_IV_set[] = { 0, 1, 0, 0, 0, 1, 1, 1, 1, 1, 1, 0, 0, 0, 1, 1, 0 };
 EXTCONST bool
-PL_valid_types_NV_set[] = { 0, 0, 1, 0, 0, 0, 1, 1, 1, 1, 1, 0, 0, 0, 0, 0 };
+PL_valid_types_NV_set[] = { 0, 0, 1, 0, 0, 0, 1, 1, 1, 1, 1, 0, 0, 0, 0, 0, 0 };
 
 EXTCONST U8
 PL_deBruijn_bitpos_tab32[] = {
diff --git a/sv.c b/sv.c
index 470ff3eddb..8f11e9778f 100644
--- a/sv.c
+++ b/sv.c
@@ -1041,6 +1041,7 @@ Perl_sv_upgrade(pTHX_ SV *const sv, svtype new_type)
         return;
     case SVt_PVHV:
     case SVt_PVAV:
+    case SVt_PVOBJ:
         assert(new_type_details->body_size);
 
 #ifndef PURIFY
@@ -1056,14 +1057,16 @@ Perl_sv_upgrade(pTHX_ SV *const sv, svtype new_type)
         new_body = new_NOARENAZ(new_type_details);
 #endif
         SvANY(sv) = new_body;
-        if (new_type == SVt_PVAV) {
+        switch(new_type) {
+        case SVt_PVAV:
             *((XPVAV*) SvANY(sv)) = (XPVAV) {
                 .xmg_stash = NULL, .xmg_u = {.xmg_magic = NULL},
                 .xav_fill = -1, .xav_max = -1, .xav_alloc = 0
                 };
 
             AvREAL_only(sv);
-        } else {
+            break;
+        case SVt_PVHV:
             *((XPVHV*) SvANY(sv)) = (XPVHV) {
                 .xmg_stash = NULL, .xmg_u = {.xmg_magic = NULL},
                 .xhv_keys = 0,
@@ -1076,6 +1079,16 @@ Perl_sv_upgrade(pTHX_ SV *const sv, svtype new_type)
 #ifndef NODEFAULT_SHAREKEYS
             HvSHAREKEYS_on(sv);         /* key-sharing on by default */
 #endif
+            break;
+        case SVt_PVOBJ:
+            *((XPVOBJ*) SvANY(sv)) = (XPVOBJ) {
+                .xmg_stash = NULL, .xmg_u = {.xmg_magic = NULL},
+                .xobject_maxfield = -1,
+                .xobject_fields = NULL,
+            };
+            break;
+        default:
+            NOT_REACHED;
         }
 
         /* SVt_NULL isn't the only thing upgraded to AV or HV.
@@ -6758,6 +6771,16 @@ Perl_sv_clear(pTHX_ SV *const orig_sv)
             }
 
             break;
+        case SVt_PVOBJ:
+            if(ObjectMAXFIELD(sv) > -1) {
+                next_sv = ObjectFIELDS(sv)[ObjectMAXFIELD(sv)--];
+                /* save old iter_sv in top-most field, and pray that it
+                 * doesn't get wiped in the meantime */
+                ObjectFIELDS(sv)[(ObjectITERSVAT(sv) = ObjectMAXFIELD(sv) + 1)] = iter_sv;
+                iter_sv = sv;
+                goto get_next_sv;
+            }
+            break;
         case SVt_PVLV:
             if (LvTYPE(sv) == 'T') { /* for tie: return HE to pool */
                 SvREFCNT_dec(HeKEY_sv((HE*)LvTARG(sv)));
@@ -6944,6 +6967,17 @@ Perl_sv_clear(pTHX_ SV *const orig_sv)
                     Safefree(AvALLOC(av));
                     goto free_body;
                 }
+            } else if (SvTYPE(iter_sv) == SVt_PVOBJ) {
+                if (ObjectMAXFIELD(iter_sv) > -1) {
+                    sv = ObjectFIELDS(iter_sv)[ObjectMAXFIELD(iter_sv)--];
+                }
+                else { /* no more fields in the current SV to free */
+                    sv = iter_sv;
+                    type = SvTYPE(sv);
+                    iter_sv = ObjectFIELDS(sv)[ObjectITERSVAT(sv)];
+                    Safefree(ObjectFIELDS(sv));
+                    goto free_body;
+                }
             } else if (SvTYPE(iter_sv) == SVt_PVHV) {
                 sv = Perl_hfree_next_entry(aTHX_ (HV*)iter_sv, &hash_index);
                 if (!sv && !HvTOTALKEYS((HV *)iter_sv)) {
@@ -10435,6 +10469,7 @@ Perl_sv_reftype(pTHX_ const SV *const sv, const int ob)
         case SVt_PVIO:		return "IO";
         case SVt_INVLIST:	return "INVLIST";
         case SVt_REGEXP:	return "REGEXP";
+        case SVt_PVOBJ:         return "OBJECT";
         default:		return "UNKNOWN";
         }
     }
diff --git a/sv.h b/sv.h
index c296dcc6e7..9c2370196c 100644
--- a/sv.h
+++ b/sv.h
@@ -38,9 +38,11 @@ The types are:
     SVt_PVCV
     SVt_PVFM
     SVt_PVIO
+    SVt_PVOBJ
 
 These are most easily explained from the bottom up.
 
+C<SVt_PVOBJ> is for object instances of the new `use feature 'class'` kind.
 C<SVt_PVIO> is for I/O objects, C<SVt_PVFM> for formats, C<SVt_PVCV> for
 subroutines, C<SVt_PVHV> for hashes and C<SVt_PVAV> for arrays.
 
@@ -120,6 +122,9 @@ Type flag for formats.  See L</svtype>.
 =for apidoc AmnU||SVt_PVIO
 Type flag for I/O objects.  See L</svtype>.
 
+=for apidoc AmnUx||SVt_PVOBJ
+Type flag for object instances.  See L</svtype>.
+
 =cut
 
   These are ordered so that the simpler types have a lower value; SvUPGRADE
@@ -149,7 +154,8 @@ typedef enum {
         SVt_PVCV,	/* 13 */
         SVt_PVFM,	/* 14 */
         SVt_PVIO,	/* 15 */
-                        /* 16-31: Unused, though one should be reserved for a
+        SVt_PVOBJ,      /* 16 */
+                        /* 17-31: Unused, though one should be reserved for a
                          * freed sv, if the other 3 bits below the flags ones
                          * get allocated */
         SVt_LAST	/* keep last in enum. used to size arrays */
@@ -273,6 +279,11 @@ struct invlist {
     _SV_HEAD_UNION;
 };
 
+struct object {
+    _SV_HEAD(XPVOBJ*);          /* pointer to xobject body */
+    _SV_HEAD_UNION;
+};
+
 #undef _SV_HEAD
 #undef _SV_HEAD_UNION		/* ensure no pollution */
 
@@ -667,6 +678,18 @@ struct xpvio {
 #define IOf_FAKE_DIRP	64	/* xio_dirp is fake (source filters kludge)
                                    Also, when this is set, SvPVX() is valid */
 
+struct xobject {
+    HV*         xmg_stash;
+    union _xmgu xmg_u;
+    SSize_t     xobject_maxfield;
+    SSize_t     xobject_iter_sv_at; /* this is only used by Perl_sv_clear() */
+    SV**        xobject_fields;
+};
+
+#define ObjectMAXFIELD(inst)  ((XPVOBJ *)SvANY(inst))->xobject_maxfield
+#define ObjectITERSVAT(inst)  ((XPVOBJ *)SvANY(inst))->xobject_iter_sv_at
+#define ObjectFIELDS(inst)    ((XPVOBJ *)SvANY(inst))->xobject_fields
+
 /* The following macros define implementation-independent predicates on SVs. */
 
 /*
diff --git a/sv_inline.h b/sv_inline.h
index d1ed6f0d54..1bb8c2897d 100644
--- a/sv_inline.h
+++ b/sv_inline.h
@@ -125,7 +125,7 @@ struct body_details {
     U8 body_size;      /* Size to allocate  */
     U8 copy;           /* Size of structure to copy (may be shorter)  */
     U8 offset;         /* Size of unalloced ghost fields to first alloced field*/
-    PERL_BITFIELD8 type : 4;        /* We have space for a sanity check. */
+    PERL_BITFIELD8 type : 5;        /* We have space for a sanity check. */
     PERL_BITFIELD8 cant_upgrade : 1;/* Cannot upgrade this type */
     PERL_BITFIELD8 zero_nv : 1;     /* zero the NV when upgrading from this */
     PERL_BITFIELD8 arena : 1;       /* Allocated from an arena */
@@ -149,6 +149,7 @@ ALIGNED_TYPE(XPVHV_WITH_AUX);
 ALIGNED_TYPE(XPVCV);
 ALIGNED_TYPE(XPVFM);
 ALIGNED_TYPE(XPVIO);
+ALIGNED_TYPE(XPVOBJ);
 
 #define HADNV FALSE
 #define NONV TRUE
@@ -280,6 +281,12 @@ static const struct body_details bodies_by_type[] = {
       0,
       SVt_PVIO, TRUE, NONV, HASARENA,
       FIT_ARENA(24, sizeof(ALIGNED_TYPE_NAME(XPVIO))) },
+
+    { sizeof(ALIGNED_TYPE_NAME(XPVOBJ)),
+      copy_length(XPVOBJ, xobject_fields),
+      0,
+      SVt_PVOBJ, TRUE, NONV, HASARENA,
+      FIT_ARENA(0, sizeof(ALIGNED_TYPE_NAME(XPVOBJ))) },
 };
 
 #define new_body_allocated(sv_type)            \
@@ -390,6 +397,7 @@ Perl_newSV_type(pTHX_ const svtype type)
         break;
     case SVt_PVHV:
     case SVt_PVAV:
+    case SVt_PVOBJ:
         assert(type_details->body_size);
 
 #ifndef PURIFY
@@ -409,13 +417,15 @@ Perl_newSV_type(pTHX_ const svtype type)
         SvSTASH_set(sv, NULL);
         SvMAGIC_set(sv, NULL);
 
-        if (type == SVt_PVAV) {
+        switch(type) {
+        case SVt_PVAV:
             AvFILLp(sv) = -1;
             AvMAX(sv) = -1;
             AvALLOC(sv) = NULL;
 
             AvREAL_only(sv);
-        } else {
+            break;
+        case SVt_PVHV:
             HvTOTALKEYS(sv) = 0;
             /* start with PERL_HASH_DEFAULT_HvMAX+1 buckets: */
             HvMAX(sv) = PERL_HASH_DEFAULT_HvMAX;
@@ -427,6 +437,13 @@ Perl_newSV_type(pTHX_ const svtype type)
 #endif
             /* start with PERL_HASH_DEFAULT_HvMAX+1 buckets: */
             HvMAX(sv) = PERL_HASH_DEFAULT_HvMAX;
+            break;
+        case SVt_PVOBJ:
+            ObjectMAXFIELD(sv) = -1;
+            ObjectFIELDS(sv) = NULL;
+            break;
+        default:
+            NOT_REACHED;
         }
 
         sv->sv_u.svu_array = NULL; /* or svu_hash  */
diff --git a/t/class/construct.t b/t/class/construct.t
index de5c7d3872..0be00f4463 100644
--- a/t/class/construct.t
+++ b/t/class/construct.t
@@ -28,11 +28,11 @@ use builtin qw( blessed reftype );
     # they could be moved to their own file.
     is(ref $obj, "Test1", 'ref of $obj');
     is(blessed $obj, "Test1", 'blessed of $obj');
-    is(reftype $obj, "ARRAY", 'reftype of $obj');
+    is(reftype $obj, "OBJECT", 'reftype of $obj');
 
     # num/stringification of object without overload
     is($obj+0, builtin::refaddr($obj), 'numified object');
-    like("$obj", qr/^Test1=ARRAY\(0x[[:xdigit:]]+\)$/, 'stringified object' );
+    like("$obj", qr/^Test1=OBJECT\(0x[[:xdigit:]]+\)$/, 'stringified object' );
 
     ok(!eval { Test1->new(y => 456); 1 }, 'Unrecognised parameter fails');
     like($@, qr/^Unrecognised parameters for "Test1" constructor: y at /,