This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
re-work opslab handling to avoid non-portable alignment assumptions
authorTony Cook <tony@develop-help.com>
Thu, 25 Jun 2020 05:26:32 +0000 (15:26 +1000)
committerKarl Williamson <khw@cpan.org>
Thu, 30 Jul 2020 22:08:59 +0000 (16:08 -0600)
Fixes #17871

The op slab allocator code made the assumption that since OP and
hence OPSLOT contain pointers, the base of each of those would be
an integral number of sizeof(pointer) (pointer units) from the
beginning of OPSLAB.

This assumption is non-portable, and broke calculating the location
of the slab based on the address of the op slot and the op slot offset
on m68k platforms.

To avoid that, this change now stores the opslot_offset as the
offset in pointer units from the beginning of opslab_slots rather
than from the beginning of the slab.

If alignment on a pointer boundary for OPs is required, the compiler
will align opslab_opslots and since we work in pointer units from there,
any allocated op slots will also be aligned.

If we assume PADOFFSET is no larger than a pointer and requires no
stricter alignment and structures in themselves have no stricter
alignment requirements then since we work in pointer units all core
OP structures should have sufficient alignment (if this isn't true,
then it's not a new problem, and not the problem I'm trying to solve
here.)

I haven't been able to test this on m68k hardware (the emulator I
tried to use can't maintain a network connection.)

op.c
op.h

diff --git a/op.c b/op.c
index e2c6d95..8b7f472 100644 (file)
--- a/op.c
+++ b/op.c
@@ -207,7 +207,10 @@ S_prune_chain_head(OP** op_p)
 
 /* rounds up to nearest pointer */
 #define SIZE_TO_PSIZE(x)       (((x) + sizeof(I32 *) - 1)/sizeof(I32 *))
 
 /* rounds up to nearest pointer */
 #define SIZE_TO_PSIZE(x)       (((x) + sizeof(I32 *) - 1)/sizeof(I32 *))
-#define DIFF(o,p)              ((size_t)((I32 **)(p) - (I32**)(o)))
+
+#define DIFF(o,p)      \
+    (assert(((char *)(p) - (char *)(o)) % sizeof(I32**) == 0), \
+      ((size_t)((I32 **)(p) - (I32**)(o))))
 
 /* requires double parens and aTHX_ */
 #define DEBUG_S_warn(args)                                            \
 
 /* requires double parens and aTHX_ */
 #define DEBUG_S_warn(args)                                            \
@@ -215,20 +218,29 @@ S_prune_chain_head(OP** op_p)
        PerlIO_printf(Perl_debug_log, "%s", SvPVx_nolen(Perl_mess args)) \
     )
 
        PerlIO_printf(Perl_debug_log, "%s", SvPVx_nolen(Perl_mess args)) \
     )
 
+/* opslot_size includes the size of the slot header, and an op can't be smaller than BASEOP */
+#define OPSLOT_SIZE_BASE (SIZE_TO_PSIZE(sizeof(OPSLOT)))
+
+/* the number of bytes to allocate for a slab with sz * sizeof(I32 **) space for op */
+#define OpSLABSizeBytes(sz) \
+    ((sz) * sizeof(I32 *) + STRUCT_OFFSET(OPSLAB, opslab_slots))
 
 /* malloc a new op slab (suitable for attaching to PL_compcv).
 
 /* malloc a new op slab (suitable for attaching to PL_compcv).
- * sz is in units of pointers */
+ * sz is in units of pointers from the beginning of opslab_opslots */
 
 static OPSLAB *
 S_new_slab(pTHX_ OPSLAB *head, size_t sz)
 {
     OPSLAB *slab;
 
 static OPSLAB *
 S_new_slab(pTHX_ OPSLAB *head, size_t sz)
 {
     OPSLAB *slab;
+    size_t sz_bytes = OpSLABSizeBytes(sz);
 
     /* opslot_offset is only U16 */
 
     /* opslot_offset is only U16 */
-    assert(sz  < U16_MAX);
+    assert(sz < U16_MAX);
+    /* room for at least one op */
+    assert(sz >= OPSLOT_SIZE_BASE);
 
 #ifdef PERL_DEBUG_READONLY_OPS
 
 #ifdef PERL_DEBUG_READONLY_OPS
-    slab = (OPSLAB *) mmap(0, sz * sizeof(I32 *),
+    slab = (OPSLAB *) mmap(0, sz_bytes,
                                   PROT_READ|PROT_WRITE,
                                   MAP_ANON|MAP_PRIVATE, -1, 0);
     DEBUG_m(PerlIO_printf(Perl_debug_log, "mapped %lu at %p\n",
                                   PROT_READ|PROT_WRITE,
                                   MAP_ANON|MAP_PRIVATE, -1, 0);
     DEBUG_m(PerlIO_printf(Perl_debug_log, "mapped %lu at %p\n",
@@ -238,7 +250,8 @@ S_new_slab(pTHX_ OPSLAB *head, size_t sz)
        abort();
     }
 #else
        abort();
     }
 #else
-    slab = (OPSLAB *)PerlMemShared_calloc(sz, sizeof(I32 *));
+    slab = (OPSLAB *)PerlMemShared_malloc(sz_bytes);
+    Zero(slab, sz_bytes, char);
 #endif
     slab->opslab_size = (U16)sz;
 
 #endif
     slab->opslab_size = (U16)sz;
 
@@ -246,7 +259,7 @@ S_new_slab(pTHX_ OPSLAB *head, size_t sz)
     /* The context is unused in non-Windows */
     PERL_UNUSED_CONTEXT;
 #endif
     /* The context is unused in non-Windows */
     PERL_UNUSED_CONTEXT;
 #endif
-    slab->opslab_free_space = sz - DIFF(slab, &slab->opslab_slots);
+    slab->opslab_free_space = sz;
     slab->opslab_head = head ? head : slab;
     DEBUG_S_warn((aTHX_ "allocated new op slab sz 0x%x, %p, head slab %p",
         (unsigned int)slab->opslab_size, (void*)slab,
     slab->opslab_head = head ? head : slab;
     DEBUG_S_warn((aTHX_ "allocated new op slab sz 0x%x, %p, head slab %p",
         (unsigned int)slab->opslab_size, (void*)slab,
@@ -254,8 +267,6 @@ S_new_slab(pTHX_ OPSLAB *head, size_t sz)
     return slab;
 }
 
     return slab;
 }
 
-/* opslot_size includes the size of the slot header, and an op can't be smaller than BASEOP */
-#define OPSLOT_SIZE_BASE (SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P)
 #define OPSLOT_SIZE_TO_INDEX(sz) ((sz) - OPSLOT_SIZE_BASE)
 
 #define link_freed_op(slab, o) S_link_freed_op(aTHX_ slab, o)
 #define OPSLOT_SIZE_TO_INDEX(sz) ((sz) - OPSLOT_SIZE_BASE)
 
 #define link_freed_op(slab, o) S_link_freed_op(aTHX_ slab, o)
@@ -308,7 +319,7 @@ Perl_Slab_Alloc(pTHX_ size_t sz)
     OPSLAB *slab2;
     OPSLOT *slot;
     OP *o;
     OPSLAB *slab2;
     OPSLOT *slot;
     OP *o;
-    size_t opsz;
+    size_t sz_in_p; /* size in pointer units, including the OPSLOT header */
 
     /* We only allocate ops from the slab during subroutine compilation.
        We find the slab via PL_compcv, hence that must be non-NULL. It could
 
     /* We only allocate ops from the slab during subroutine compilation.
        We find the slab via PL_compcv, hence that must be non-NULL. It could
@@ -337,18 +348,17 @@ Perl_Slab_Alloc(pTHX_ size_t sz)
     }
     else ++(head_slab = (OPSLAB *)CvSTART(PL_compcv))->opslab_refcnt;
 
     }
     else ++(head_slab = (OPSLAB *)CvSTART(PL_compcv))->opslab_refcnt;
 
-    opsz = SIZE_TO_PSIZE(sz);
-    sz = opsz + OPSLOT_HEADER_P;
+    sz_in_p = SIZE_TO_PSIZE(sz + OPSLOT_HEADER);
 
     /* The head slab for each CV maintains a free list of OPs. In particular, constant folding
        will free up OPs, so it makes sense to re-use them where possible. A
        freed up slot is used in preference to a new allocation.  */
     if (head_slab->opslab_freed &&
 
     /* The head slab for each CV maintains a free list of OPs. In particular, constant folding
        will free up OPs, so it makes sense to re-use them where possible. A
        freed up slot is used in preference to a new allocation.  */
     if (head_slab->opslab_freed &&
-        OPSLOT_SIZE_TO_INDEX(sz) < head_slab->opslab_freed_size) {
+        OPSLOT_SIZE_TO_INDEX(sz_in_p) < head_slab->opslab_freed_size) {
         U16 base_index;
 
         /* look for a large enough size with any freed ops */
         U16 base_index;
 
         /* look for a large enough size with any freed ops */
-        for (base_index = OPSLOT_SIZE_TO_INDEX(sz);
+        for (base_index = OPSLOT_SIZE_TO_INDEX(sz_in_p);
              base_index < head_slab->opslab_freed_size && !head_slab->opslab_freed[base_index];
              ++base_index) {
         }
              base_index < head_slab->opslab_freed_size && !head_slab->opslab_freed[base_index];
              ++base_index) {
         }
@@ -358,18 +368,16 @@ Perl_Slab_Alloc(pTHX_ size_t sz)
             o = head_slab->opslab_freed[base_index];
 
             DEBUG_S_warn((aTHX_ "realloced  op at %p, slab %p, head slab %p",
             o = head_slab->opslab_freed[base_index];
 
             DEBUG_S_warn((aTHX_ "realloced  op at %p, slab %p, head slab %p",
-                (void*)o,
-                (I32**)OpSLOT(o) - OpSLOT(o)->opslot_offset,
-                (void*)head_slab));
+                          (void *)o, (void *)OpMySLAB(o), (void *)head_slab));
            head_slab->opslab_freed[base_index] = o->op_next;
            head_slab->opslab_freed[base_index] = o->op_next;
-           Zero(o, opsz, I32 *);
+           Zero(o, sz, char);
            o->op_slabbed = 1;
            goto gotit;
        }
     }
 
 #define INIT_OPSLOT(s) \
            o->op_slabbed = 1;
            goto gotit;
        }
     }
 
 #define INIT_OPSLOT(s) \
-           slot->opslot_offset = DIFF(slab2, slot) ;   \
+           slot->opslot_offset = DIFF(&slab2->opslab_slots, slot) ;    \
            slot->opslot_size = s;                      \
            slab2->opslab_free_space -= s;              \
            o = &slot->opslot_op;                       \
            slot->opslot_size = s;                      \
            slab2->opslab_free_space -= s;              \
            o = &slot->opslot_op;                       \
@@ -377,14 +385,16 @@ Perl_Slab_Alloc(pTHX_ size_t sz)
 
     /* The partially-filled slab is next in the chain. */
     slab2 = head_slab->opslab_next ? head_slab->opslab_next : head_slab;
 
     /* The partially-filled slab is next in the chain. */
     slab2 = head_slab->opslab_next ? head_slab->opslab_next : head_slab;
-    if (slab2->opslab_free_space  < sz) {
+    if (slab2->opslab_free_space < sz_in_p) {
        /* Remaining space is too small. */
        /* If we can fit a BASEOP, add it to the free chain, so as not
           to waste it. */
        /* Remaining space is too small. */
        /* If we can fit a BASEOP, add it to the free chain, so as not
           to waste it. */
-       if (slab2->opslab_free_space >= SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P) {
+       if (slab2->opslab_free_space >= OPSLOT_SIZE_BASE) {
            slot = &slab2->opslab_slots;
            INIT_OPSLOT(slab2->opslab_free_space);
            o->op_type = OP_FREED;
            slot = &slab2->opslab_slots;
            INIT_OPSLOT(slab2->opslab_free_space);
            o->op_type = OP_FREED;
+            DEBUG_S_warn((aTHX_ "linked unused op space at %p, slab %p, head slab %p",
+                          (void *)o, (void *)slab2, (void *)head_slab));
             link_freed_op(head_slab, o);
        }
 
             link_freed_op(head_slab, o);
        }
 
@@ -396,14 +406,12 @@ Perl_Slab_Alloc(pTHX_ size_t sz)
        slab2->opslab_next = head_slab->opslab_next;
        head_slab->opslab_next = slab2;
     }
        slab2->opslab_next = head_slab->opslab_next;
        head_slab->opslab_next = slab2;
     }
-    assert(slab2->opslab_size >= sz);
+    assert(slab2->opslab_size >= sz_in_p);
 
     /* Create a new op slot */
 
     /* Create a new op slot */
-    slot = (OPSLOT *)
-                ((I32 **)&slab2->opslab_slots
-                                + slab2->opslab_free_space - sz);
+    slot = OpSLOToff(slab2, slab2->opslab_free_space - sz_in_p);
     assert(slot >= &slab2->opslab_slots);
     assert(slot >= &slab2->opslab_slots);
-    INIT_OPSLOT(sz);
+    INIT_OPSLOT(sz_in_p);
     DEBUG_S_warn((aTHX_ "allocating op at %p, slab %p, head slab %p",
         (void*)o, (void*)slab2, (void*)head_slab));
 
     DEBUG_S_warn((aTHX_ "allocating op at %p, slab %p, head slab %p",
         (void*)o, (void*)slab2, (void*)head_slab));
 
@@ -427,9 +435,9 @@ Perl_Slab_to_ro(pTHX_ OPSLAB *slab)
     slab->opslab_readonly = 1;
     for (; slab; slab = slab->opslab_next) {
        /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->ro %lu at %p\n",
     slab->opslab_readonly = 1;
     for (; slab; slab = slab->opslab_next) {
        /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->ro %lu at %p\n",
-                             (unsigned long) slab->opslab_size, slab));*/
-       if (mprotect(slab, slab->opslab_size * sizeof(I32 *), PROT_READ))
-           Perl_warn(aTHX_ "mprotect for %p %lu failed with %d", slab,
+                             (unsigned long) slab->opslab_size, (void *)slab));*/
+       if (mprotect(slab, OpSLABSizeBytes(slab->opslab_size), PROT_READ))
+           Perl_warn(aTHX_ "mprotect for %p %lu failed with %d", (void *)slab,
                             (unsigned long)slab->opslab_size, errno);
     }
 }
                             (unsigned long)slab->opslab_size, errno);
     }
 }
@@ -445,10 +453,10 @@ Perl_Slab_to_rw(pTHX_ OPSLAB *const slab)
     slab2 = slab;
     for (; slab2; slab2 = slab2->opslab_next) {
        /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->rw %lu at %p\n",
     slab2 = slab;
     for (; slab2; slab2 = slab2->opslab_next) {
        /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->rw %lu at %p\n",
-                             (unsigned long) size, slab2));*/
-       if (mprotect((void *)slab2, slab2->opslab_size * sizeof(I32 *),
+                             (unsigned long) size, (void *)slab2));*/
+       if (mprotect((void *)slab2, OpSLABSizeBytes(slab2->opslab_size),
                     PROT_READ|PROT_WRITE)) {
                     PROT_READ|PROT_WRITE)) {
-           Perl_warn(aTHX_ "mprotect RW for %p %lu failed with %d", slab,
+           Perl_warn(aTHX_ "mprotect RW for %p %lu failed with %d", (void *)slab,
                             (unsigned long)slab2->opslab_size, errno);
        }
     }
                             (unsigned long)slab2->opslab_size, errno);
        }
     }
@@ -504,9 +512,7 @@ Perl_Slab_Free(pTHX_ void *op)
     o->op_type = OP_FREED;
     link_freed_op(slab, o);
     DEBUG_S_warn((aTHX_ "freeing    op at %p, slab %p, head slab %p",
     o->op_type = OP_FREED;
     link_freed_op(slab, o);
     DEBUG_S_warn((aTHX_ "freeing    op at %p, slab %p, head slab %p",
-        (void*)o,
-        (I32**)OpSLOT(o) - OpSLOT(o)->opslot_offset,
-        (void*)slab));
+        (void*)o, (void *)OpMySLAB(o), (void*)slab));
     OpslabREFCNT_dec_padok(slab);
 }
 
     OpslabREFCNT_dec_padok(slab);
 }
 
@@ -550,7 +556,7 @@ Perl_opslab_free(pTHX_ OPSLAB *slab)
 #ifdef PERL_DEBUG_READONLY_OPS
        DEBUG_m(PerlIO_printf(Perl_debug_log, "Deallocate slab at %p\n",
                                               (void*)slab));
 #ifdef PERL_DEBUG_READONLY_OPS
        DEBUG_m(PerlIO_printf(Perl_debug_log, "Deallocate slab at %p\n",
                                               (void*)slab));
-       if (munmap(slab, slab->opslab_size * sizeof(I32 *))) {
+       if (munmap(slab, OpSLABSizeBytes(slab->opslab_size))) {
            perror("munmap failed");
            abort();
        }
            perror("munmap failed");
            abort();
        }
@@ -575,10 +581,8 @@ Perl_opslab_force_free(pTHX_ OPSLAB *slab)
     PERL_ARGS_ASSERT_OPSLAB_FORCE_FREE;
     slab2 = slab;
     do {
     PERL_ARGS_ASSERT_OPSLAB_FORCE_FREE;
     slab2 = slab;
     do {
-        OPSLOT *slot = (OPSLOT*)
-                    ((I32**)&slab2->opslab_slots + slab2->opslab_free_space);
-        OPSLOT *end  = (OPSLOT*)
-                        ((I32**)slab2 + slab2->opslab_size);
+        OPSLOT *slot = OpSLOToff(slab2, slab2->opslab_free_space);
+        OPSLOT *end  = OpSLOToff(slab2, slab2->opslab_size);
        for (; slot < end;
                 slot = (OPSLOT*) ((I32**)slot + slot->opslot_size) )
         {
        for (; slot < end;
                 slot = (OPSLOT*) ((I32**)slot + slot->opslot_size) )
         {
@@ -10198,7 +10202,7 @@ Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont)
      * keep it in-place if there's space */
     if (loop->op_slabbed
         &&    OpSLOT(loop)->opslot_size
      * keep it in-place if there's space */
     if (loop->op_slabbed
         &&    OpSLOT(loop)->opslot_size
-            < SIZE_TO_PSIZE(sizeof(LOOP)) + OPSLOT_HEADER_P)
+            < SIZE_TO_PSIZE(sizeof(LOOP) + OPSLOT_HEADER))
     {
         /* no space; allocate new op */
        LOOP *tmp;
     {
         /* no space; allocate new op */
        LOOP *tmp;
diff --git a/op.h b/op.h
index fc21f03..6e7dc31 100644 (file)
--- a/op.h
+++ b/op.h
@@ -718,13 +718,18 @@ struct opslab {
 };
 
 # define OPSLOT_HEADER         STRUCT_OFFSET(OPSLOT, opslot_op)
 };
 
 # define OPSLOT_HEADER         STRUCT_OFFSET(OPSLOT, opslot_op)
-# define OPSLOT_HEADER_P       (OPSLOT_HEADER/sizeof(I32 *))
 # define OpSLOT(o)             (assert_(o->op_slabbed) \
                                 (OPSLOT *)(((char *)o)-OPSLOT_HEADER))
 
 # define OpSLOT(o)             (assert_(o->op_slabbed) \
                                 (OPSLOT *)(((char *)o)-OPSLOT_HEADER))
 
+/* the slab that owns this op */
+# define OpMySLAB(o) \
+    ((OPSLAB*)((char *)((I32**)OpSLOT(o) - OpSLOT(o)->opslot_offset)-STRUCT_OFFSET(struct opslab, opslab_slots)))
 /* the first (head) opslab of the chain in which this op is allocated */
 # define OpSLAB(o) \
 /* the first (head) opslab of the chain in which this op is allocated */
 # define OpSLAB(o) \
-    (((OPSLAB*)( (I32**)OpSLOT(o) - OpSLOT(o)->opslot_offset))->opslab_head)
+    (OpMySLAB(o)->opslab_head)
+/* calculate the slot given the owner slab and an offset */
+#define OpSLOToff(slab, offset) \
+    ((OPSLOT*)(((I32 **)&(slab)->opslab_slots)+(offset)))
 
 # define OpslabREFCNT_dec(slab)      \
        (((slab)->opslab_refcnt == 1) \
 
 # define OpslabREFCNT_dec(slab)      \
        (((slab)->opslab_refcnt == 1) \