探秘perl-解析perl源码(4)

阅读更多

void
Perl_Slab_Free(pTHX_ void *op)
{

//释放某个slab片区

    I32 * const * const ptr = (I32 **) op;
    I32 * const slab = ptr[-1];
    PERL_ARGS_ASSERT_SLAB_FREE;
    assert( ptr-1 > (I32 **) slab );
    assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
    assert( *slab > 0 );
    Slab_to_rw(op);
    if (--(*slab) == 0) {
#  ifdef NETWARE
#    define PerlMemShared PerlMem
#  endif
 
#ifdef PERL_DEBUG_READONLY_OPS
 U32 count = PL_slab_count;
 /* Need to remove this slab from our list of slabs */
 if (count) {
     while (count--) {//在片区数组中找到需要的free的片区
     if (PL_slabs[count] == slab) {//找到该片区slab
      dVAR;
      /* Found it. Move the entry at the end to overwrite it.  */
      DEBUG_m(PerlIO_printf(Perl_debug_log,
       "Deallocate %p by moving %p from %lu to %lu\n",
       PL_OpSlab,
       PL_slabs[PL_slab_count - 1],
       PL_slab_count, count));
      PL_slabs[count] = PL_slabs[--PL_slab_count];//将PL_slabs[PL_slab_count-1]即PL_slabs底部的片区移动至被释放片区中（这里的移动是指针）
      /* Could realloc smaller at this point, but probably not
         worth it.  */
      if(munmap(slab, PERL_SLAB_SIZE*sizeof(I32*))) {//释放片区
   perror("munmap failed");
   abort();
      }
       break;
  }
     }
 }
#else
    PerlMemShared_free(slab);{//释放片区

#endif
 if (slab == PL_OpSlab)  {//该片区已经用完

    PL_OpSpace = 0;
 }
    }
}
#endif

 

/*
 * In the following definition, the ", (OP*)0" is just to make the compiler
 * think the expression is of the right type: croak actually does a Siglongjmp.
 */
#define CHECKOP(type,o) \
    ((PL_op_mask && PL_op_mask[type])    \
     ? ( op_free((OP*)o),     \
  Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \
  (OP*)0 )      \
     : CALL_FPTR(PL_check[type])(aTHX_ (OP*)o))

#define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)

STATIC const char*
S_gv_ename(pTHX_ GV *gv)
{
    SV* const tmpsv = sv_newmortal();

    PERL_ARGS_ASSERT_GV_ENAME;

    gv_efullname3(tmpsv, gv, NULL);
    return SvPV_nolen_const(tmpsv);
}

STATIC OP *
S_no_fh_allowed(pTHX_ OP *o)
{
    PERL_ARGS_ASSERT_NO_FH_ALLOWED;

    yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
   OP_DESC(o)));
    return o;
}

STATIC OP *
S_too_few_arguments(pTHX_ OP *o, const char *name)
{
    PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS;

    yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
    return o;
}

STATIC OP *
S_too_many_arguments(pTHX_ OP *o, const char *name)
{
    PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS;

    yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
    return o;
}

STATIC void
S_bad_type(pTHX_ I32 n, const char *t, const char *name, const OP *kid)
{
    PERL_ARGS_ASSERT_BAD_TYPE;

    yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
   (int)n, name, t, OP_DESC(kid)));
}

STATIC void
S_no_bareword_allowed(pTHX_ const OP *o)
{
    PERL_ARGS_ASSERT_NO_BAREWORD_ALLOWED;

    if (PL_madskills)
 return;  /* various ok barewords are hidden in extra OP_NULL */
    qerror(Perl_mess(aTHX_
       "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
       SVfARG(cSVOPo_sv)));
}

/* "register" allocation */