view release on metacpan or  search on metacpan

FastProf.xs  view on Meta::CPAN

	AV *lines = get_file_src(aTHX_ fn);
	if (lines) {
	    putmark(2);
	    putiv(aTHX_ file_id_generator);
	    putav(aTHX_ lines);
	}
    }
    return file_id_generator;
}

static IV
mapid(pTHX_ HV *fpidmap, IV pid, IV fid) {
    static IV lfpid = 0;
    static SV *key = 0;
    SV **ent;
    char *k;
    STRLEN l;
    if (!key) key = newSV(30);
    sv_setpvf(key, "%d:%d", pid, fid);
    k = SvPV(key, l);
    ent = hv_fetch(fpidmap, k, l, TRUE);
    if (!SvOK(*ent))
	sv_setiv(*ent, ++lfpid);
    return SvIV(*ent);
}

static void
flock_and_header(pTHX) {
    static IV lpid = 0;
    IV pid = getpid();
    if (pid != lpid && lpid) {
	out = fopen(outname, "ab");
	if (!out)
	    Perl_croak(aTHX_ "unable to reopen file %s", outname);

	flock(fileno(out), LOCK_EX);
	fseek(out, 0, SEEK_END);

	putmark(5);
	putiv(aTHX_ pid);

	putmark(6);
	putiv(aTHX_ lpid);

    }
    else {
	flock(fileno(out), LOCK_EX);
	fseek(out, 0, SEEK_END);

	putmark(5);
	putiv(aTHX_ pid);
    }
    lpid = pid;
}


MODULE = Devel::FastProf		PACKAGE = DB
PROTOTYPES: DISABLE

void DB(...)
PPCODE:
    {
        IV ticks;
        if (usecputime) {
            struct tms buf;
            times(&buf);
            ticks = buf.tms_utime - old_tms.tms_utime + buf.tms_stime - old_tms.tms_stime;
        }
        else {
#if defined(HAS_GETTIMEOD)
            struct timeval time;
            gettimeofday(&time, NULL);
            if (time.tv_sec < old_time.tv_sec + 2000) {
                ticks = (time.tv_sec - old_time.tv_sec) * 1000000 + time.tv_usec - old_time.tv_usec;
            }
#else
            UV time[2];
            (*u2time)(aTHX_ time);
            if (time[0] < old_time[0] + 2000) {
                ticks = (time[0] - old_time[0]) * 1000000 + time[1] - old_time[1];
            }
#endif
            else {
                ticks = 2000000000;
            }
        }
        if (out) { /* out should never be NULL anyway */
            IV fid;
            IV line;
            char *file;
#if (PERL_VERSION < 8) || ((PERL_VERSION == 8) && (PERL_SUBVERSION < 8))
            PERL_CONTEXT *cx = cxstack + cxstack_ix;
#endif
            if (canfork)
                flock_and_header(aTHX);
#if (PERL_VERSION < 8) || ((PERL_VERSION == 8) && (PERL_SUBVERSION < 8))
            file = OutCopFILE(cx->blk_oldcop);
            line = CopLINE(cx->blk_oldcop);
#else
            file = OutCopFILE(PL_curcop);
            line = CopLINE(PL_curcop);
#endif
            if (strcmp(file, old_fn)) {
                fid = get_file_id(aTHX_ file);
                putmark(7);
                putiv(aTHX_ fid);
                old_fn = file;
            }
            putiv(aTHX_ line);
            if (ticks < 0) ticks = 0;
            putiv(aTHX_ ticks);
            
            if (canfork) {
                fflush(out);
                flock(fileno(out), LOCK_UN);
            }
        }
        if (usecputime) {
            times(&old_tms);
        }
        else {
#if defined (HAS_GETTIMEOD)
            gettimeofday(&old_time, NULL);
#else
            (*u2time)(aTHX_ old_time);
#endif
        }
    }

void _finish()
PPCODE:
    {
        if (out) {
            if (canfork) {
                flock_and_header(aTHX);
                fflush(out);
                flock(fileno(out), LOCK_UN);
            }
            fclose(out);
            out = NULL;
        }
    }


void _init(char *_outname, int _usecputime, int _canfork)
PPCODE:
    {
        out = fopen(_outname, "wb");
        if (!out) Perl_croak(aTHX_ "unable to open file %s for writing", _outname);
        fwrite("D::FP-" XS_VERSION "\0\0\0\0\0\0\0", 1, 12, out);
        putmark(3);
        if (_usecputime) {
            usecputime = 1;
            putiv(aTHX_ sysconf(_SC_CLK_TCK));
            times(&old_tms);
        }
        else {
            putiv(aTHX_ 1000000);
            usecputime = 0;
#if defined (HAS_GETTIMEOD)
            gettimeofday(&old_time, NULL);
#else
            {
                SV **svp = hv_fetch(PL_modglobal, "Time::U2time", 12, 0);
                if (!svp || !SvIOK(*svp)) Perl_croak(aTHX_ "Time::HiRes is required");
                u2time = INT2PTR(int(*)(pTHX_ UV*), SvIV(*svp));
            }
            (*u2time)(aTHX_ old_time);
#endif
        }
        if (_canfork) {
            canfork = 1;
            outname = strdup(_outname);
        }
        file_id_hv = get_hv("DB::file_id", TRUE);
    }


MODULE = Devel::FastProf		PACKAGE = Devel::FastProf::Reader

void _read_file(char *infn)
PPCODE:
    {
        HV *ticks = get_hv("Devel::FastProf::Reader::TICKS", TRUE);
        HV *count = get_hv("Devel::FastProf::Reader::COUNT", TRUE);
        AV *fn = get_av("Devel::FastProf::Reader::FN", TRUE);
        AV *src = get_av("Devel::FastProf::Reader::SRC", TRUE);
        HV *fpidmap = get_hv("Devel::FastProf::Reader::FPIDMAP", TRUE);
        HV *ppid = get_hv("Devel::FastProf::Reader::PPID", TRUE);
        float inv_ticks_per_second = 1.0;
        IV lfid = 0, nfid = 0, lline;
        int not_first = 0;
        IV pid = 0;
        SV *key = sv_2mortal(newSV(30));
        char *k;
        STRLEN l;
        SV **ent;
        char head[12];
        HV *pidlfid = (HV*)sv_2mortal((SV*)newHV());
        HV *pidlline = (HV*)sv_2mortal((SV*)newHV());

        FILE *in = fopen(infn, "rb");
        if (!in) Perl_croak(aTHX_ "unable to open %s for reading", infn);

        if ((fread(head, 1, 12, in) != 12) || strncmp(head, "D::FP-" XS_VERSION, 12))
            Perl_croak(aTHX_ "bad header, input file has not been generated by Devel::FastProf " XS_VERSION);

        while (fneof(in)) {
            IV mark = fgetmark(aTHX_ in);
            switch (mark) {
            case 0: /* line execution timestamp */
            {
                IV line = fgetiv(aTHX_ in);
                IV delta = fgetiv(aTHX_ in);
                /* fprintf(stderr, "fid: %d, line: %d, delta: %d\n", fid, line, delta); */
                if (not_first) {
                    SV **tsv, **csv;
                    /* SV *key = newSVpvf("%d:%d", lfid, lline); */
                    sv_setpvf(key, "%d:%d", lfid, lline);
                    k = SvPV(key, l);
                    tsv = hv_fetch(ticks, k, l, TRUE);
                    csv = hv_fetch(count, k, l, TRUE);
                    if (tsv && csv) {
                        float old = SvOK(*tsv) ? SvNV(*tsv) : 0.0;
                        /* printf("delta: %d\n", delta); */
                        sv_setnv(*tsv, old + delta * inv_ticks_per_second);
                        sv_inc(*csv);
                    }
                    else {
                        Perl_croak(aTHX_ "internal error");
                    }
                }
                else {
                    not_first = 1;
                }
                lfid = nfid;
                lline = line;
                break;
            }
            case 1: /* filename comming */
            {
                IV fid = pid ? mapid(aTHX_ fpidmap, pid, fgetiv(aTHX_ in)) : fgetiv(aTHX_ in);