home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / perl560.zip / bytecode.pl < prev    next >
Perl Script  |  2000-03-06  |  11KB  |  412 lines
  1. BEGIN {
  2.   push @INC, './lib';
  3. }
  4. use strict;
  5. my %alias_to = (
  6.     U32 => [qw(PADOFFSET STRLEN)],
  7.     I32 => [qw(SSize_t long)],
  8.     U16 => [qw(OPCODE line_t short)],
  9.     U8 => [qw(char)],
  10. );
  11.  
  12. my @optype= qw(OP UNOP BINOP LOGOP LISTOP PMOP SVOP PADOP PVOP LOOP COP);
  13.  
  14. # Nullsv *must* come first in the following so that the condition
  15. # ($$sv == 0) can continue to be used to test (sv == Nullsv).
  16. my @specialsv = qw(Nullsv &PL_sv_undef &PL_sv_yes &PL_sv_no);
  17.  
  18. my (%alias_from, $from, $tos);
  19. while (($from, $tos) = each %alias_to) {
  20.     map { $alias_from{$_} = $from } @$tos;
  21. }
  22.  
  23. my $c_header = <<'EOT';
  24. /*
  25.  *      Copyright (c) 1996-1999 Malcolm Beattie
  26.  *
  27.  *      You may distribute under the terms of either the GNU General Public
  28.  *      License or the Artistic License, as specified in the README file.
  29.  *
  30.  */
  31. /*
  32.  * This file is autogenerated from bytecode.pl. Changes made here will be lost.
  33.  */
  34. EOT
  35.  
  36. my $perl_header;
  37. ($perl_header = $c_header) =~ s{[/ ]?\*/?}{#}g;
  38.  
  39. unlink "ext/ByteLoader/byterun.c", "ext/ByteLoader/byterun.h", "ext/B/B/Asmdata.pm";
  40.  
  41. #
  42. # Start with boilerplate for Asmdata.pm
  43. #
  44. open(ASMDATA_PM, ">ext/B/B/Asmdata.pm") or die "ext/B/B/Asmdata.pm: $!";
  45. print ASMDATA_PM $perl_header, <<'EOT';
  46. package B::Asmdata;
  47. use Exporter;
  48. @ISA = qw(Exporter);
  49. @EXPORT_OK = qw(%insn_data @insn_name @optype @specialsv_name);
  50. our(%insn_data, @insn_name, @optype, @specialsv_name);
  51.  
  52. EOT
  53. print ASMDATA_PM <<"EOT";
  54. \@optype = qw(@optype);
  55. \@specialsv_name = qw(@specialsv);
  56.  
  57. # XXX insn_data is initialised this way because with a large
  58. # %insn_data = (foo => [...], bar => [...], ...) initialiser
  59. # I get a hard-to-track-down stack underflow and segfault.
  60. EOT
  61.  
  62. #
  63. # Boilerplate for byterun.c
  64. #
  65. open(BYTERUN_C, ">ext/ByteLoader/byterun.c") or die "ext/ByteLoader/byterun.c: $!";
  66. print BYTERUN_C $c_header, <<'EOT';
  67.  
  68. #define PERL_NO_GET_CONTEXT
  69. #include "EXTERN.h"
  70. #include "perl.h"
  71. #define NO_XSLOCKS
  72. #include "XSUB.h"
  73.  
  74. #ifdef PERL_OBJECT
  75. #undef CALL_FPTR
  76. #define CALL_FPTR(fptr) (pPerl->*fptr)
  77. #undef PL_ppaddr
  78. #define PL_ppaddr (*get_ppaddr())
  79. #endif
  80.  
  81. #include "byterun.h"
  82. #include "bytecode.h"
  83.  
  84.  
  85. static int optype_size[] = {
  86. EOT
  87. my $i = 0;
  88. for ($i = 0; $i < @optype - 1; $i++) {
  89.     printf BYTERUN_C "    sizeof(%s),\n", $optype[$i], $i;
  90. }
  91. printf BYTERUN_C "    sizeof(%s)\n", $optype[$i], $i;
  92. print BYTERUN_C <<'EOT';
  93. };
  94.  
  95. static SV *specialsv_list[4];
  96.  
  97. static int bytecode_iv_overflows = 0;
  98. static SV *bytecode_sv;
  99. static XPV bytecode_pv;
  100. static void **bytecode_obj_list;
  101. static I32 bytecode_obj_list_fill = -1;
  102.  
  103. void *
  104. bset_obj_store(pTHXo_ void *obj, I32 ix)
  105. {
  106.     if (ix > bytecode_obj_list_fill) {
  107.     if (bytecode_obj_list_fill == -1)
  108.         New(666, bytecode_obj_list, ix + 1, void*);
  109.     else
  110.         Renew(bytecode_obj_list, ix + 1, void*);
  111.     bytecode_obj_list_fill = ix;
  112.     }
  113.     bytecode_obj_list[ix] = obj;
  114.     return obj;
  115. }
  116.  
  117. void
  118. byterun(pTHXo_ struct bytestream bs)
  119. {
  120.     dTHR;
  121.     int insn;
  122.  
  123. EOT
  124.  
  125. for (my $i = 0; $i < @specialsv; $i++) {
  126.     print BYTERUN_C "    specialsv_list[$i] = $specialsv[$i];\n";
  127. }
  128.  
  129. print BYTERUN_C <<'EOT';
  130.  
  131.     while ((insn = BGET_FGETC()) != EOF) {
  132.     switch (insn) {
  133. EOT
  134.  
  135.  
  136. my (@insn_name, $insn_num, $insn, $lvalue, $argtype, $flags, $fundtype);
  137.  
  138. while (<DATA>) {
  139.     chop;
  140.     s/#.*//;            # remove comments
  141.     next unless length;
  142.     if (/^%number\s+(.*)/) {
  143.     $insn_num = $1;
  144.     next;
  145.     } elsif (/%enum\s+(.*?)\s+(.*)/) {
  146.     create_enum($1, $2);    # must come before instructions
  147.     next;
  148.     }
  149.     ($insn, $lvalue, $argtype, $flags) = split;
  150.     $insn_name[$insn_num] = $insn;
  151.     $fundtype = $alias_from{$argtype} || $argtype;
  152.  
  153.     #
  154.     # Add the case statement and code for the bytecode interpreter in byterun.c
  155.     #
  156.     printf BYTERUN_C "\t  case INSN_%s:\t\t/* %d */\n\t    {\n",
  157.     uc($insn), $insn_num;
  158.     my $optarg = $argtype eq "none" ? "" : ", arg";
  159.     if ($optarg) {
  160.     printf BYTERUN_C "\t\t$argtype arg;\n\t\tBGET_%s(arg);\n", $fundtype;
  161.     }
  162.     if ($flags =~ /x/) {
  163.     print BYTERUN_C "\t\tBSET_$insn($lvalue$optarg);\n";
  164.     } elsif ($flags =~ /s/) {
  165.     # Store instructions store to bytecode_obj_list[arg]. "lvalue" field is rvalue.
  166.     print BYTERUN_C "\t\tBSET_OBJ_STORE($lvalue$optarg);\n";
  167.     }
  168.     elsif ($optarg && $lvalue ne "none") {
  169.     print BYTERUN_C "\t\t$lvalue = arg;\n";
  170.     }
  171.     print BYTERUN_C "\t\tbreak;\n\t    }\n";
  172.  
  173.     #
  174.     # Add the initialiser line for %insn_data in Asmdata.pm
  175.     #
  176.     print ASMDATA_PM <<"EOT";
  177. \$insn_data{$insn} = [$insn_num, \\&PUT_$fundtype, "GET_$fundtype"];
  178. EOT
  179.  
  180.     # Find the next unused instruction number
  181.     do { $insn_num++ } while $insn_name[$insn_num];
  182. }
  183.  
  184. #
  185. # Finish off byterun.c
  186. #
  187. print BYTERUN_C <<'EOT';
  188.       default:
  189.         Perl_croak(aTHX_ "Illegal bytecode instruction %d\n", insn);
  190.         /* NOTREACHED */
  191.     }
  192.     }
  193. }
  194. EOT
  195.  
  196. #
  197. # Write the instruction and optype enum constants into byterun.h
  198. #
  199. open(BYTERUN_H, ">ext/ByteLoader/byterun.h") or die "ext/ByteLoader/byterun.h: $!";
  200. print BYTERUN_H $c_header, <<'EOT';
  201. struct bytestream {
  202.     void *data;
  203.     int (*pfgetc)(void *);
  204.     int (*pfread)(char *, size_t, size_t, void *);
  205.     void (*pfreadpv)(U32, void *, XPV *);
  206. };
  207.  
  208. enum {
  209. EOT
  210.  
  211. my $add_enum_value = 0;
  212. my $max_insn;
  213. for ($i = 0; $i < @insn_name; $i++) {
  214.     $insn = uc($insn_name[$i]);
  215.     if (defined($insn)) {
  216.     $max_insn = $i;
  217.     if ($add_enum_value) {
  218.         print BYTERUN_H "    INSN_$insn = $i,\t\t\t/* $i */\n";
  219.         $add_enum_value = 0;
  220.     } else {
  221.         print BYTERUN_H "    INSN_$insn,\t\t\t/* $i */\n";
  222.     }
  223.     } else {
  224.     $add_enum_value = 1;
  225.     }
  226. }
  227.  
  228. print BYTERUN_H "    MAX_INSN = $max_insn\n};\n";
  229.  
  230. print BYTERUN_H "\nenum {\n";
  231. for ($i = 0; $i < @optype - 1; $i++) {
  232.     printf BYTERUN_H "    OPt_%s,\t\t/* %d */\n", $optype[$i], $i;
  233. }
  234. printf BYTERUN_H "    OPt_%s\t\t/* %d */\n};\n\n", $optype[$i], $i;
  235.  
  236. print BYTERUN_H <<'EOT';
  237. extern void byterun(pTHXo_ struct bytestream bs);
  238.  
  239. #define INIT_SPECIALSV_LIST STMT_START { \
  240. EOT
  241. for ($i = 0; $i < @specialsv; $i++) {
  242.     print BYTERUN_H "\tPL_specialsv_list[$i] = $specialsv[$i]; \\\n";
  243. }
  244. print BYTERUN_H <<'EOT';
  245.     } STMT_END
  246. EOT
  247.  
  248. #
  249. # Finish off insn_data and create array initialisers in Asmdata.pm
  250. #
  251. print ASMDATA_PM <<'EOT';
  252.  
  253. my ($insn_name, $insn_data);
  254. while (($insn_name, $insn_data) = each %insn_data) {
  255.     $insn_name[$insn_data->[0]] = $insn_name;
  256. }
  257. # Fill in any gaps
  258. @insn_name = map($_ || "unused", @insn_name);
  259.  
  260. 1;
  261.  
  262. __END__
  263.  
  264. =head1 NAME
  265.  
  266. B::Asmdata - Autogenerated data about Perl ops, used to generate bytecode
  267.  
  268. =head1 SYNOPSIS
  269.  
  270.     use Asmdata;
  271.  
  272. =head1 DESCRIPTION
  273.  
  274. See F<ext/B/B/Asmdata.pm>.
  275.  
  276. =head1 AUTHOR
  277.  
  278. Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
  279.  
  280. =cut
  281. EOT
  282.  
  283. __END__
  284. # First set instruction ord("#") to read comment to end-of-line (sneaky)
  285. %number 35
  286. comment        arg            comment_t
  287. # Then make ord("\n") into a no-op
  288. %number 10
  289. nop        none            none
  290. # Now for the rest of the ordinary ones, beginning with \0 which is
  291. # ret so that \0-terminated strings can be read properly as bytecode.
  292. %number 0
  293. #
  294. #opcode        lvalue                    argtype        flags    
  295. #
  296. ret        none                    none        x
  297. ldsv        bytecode_sv                svindex
  298. ldop        PL_op                    opindex
  299. stsv        bytecode_sv                U32        s
  300. stop        PL_op                    U32        s
  301. ldspecsv    bytecode_sv                U8        x
  302. newsv        bytecode_sv                U8        x
  303. newop        PL_op                    U8        x
  304. newopn        PL_op                    U8        x
  305. newpv        none                    PV
  306. pv_cur        bytecode_pv.xpv_cur            STRLEN
  307. pv_free        bytecode_pv                none        x
  308. sv_upgrade    bytecode_sv                char        x
  309. sv_refcnt    SvREFCNT(bytecode_sv)            U32
  310. sv_refcnt_add    SvREFCNT(bytecode_sv)            I32        x
  311. sv_flags    SvFLAGS(bytecode_sv)            U32
  312. xrv        SvRV(bytecode_sv)            svindex
  313. xpv        bytecode_sv                none        x
  314. xiv32        SvIVX(bytecode_sv)            I32
  315. xiv64        SvIVX(bytecode_sv)            IV64
  316. xnv        SvNVX(bytecode_sv)            NV
  317. xlv_targoff    LvTARGOFF(bytecode_sv)            STRLEN
  318. xlv_targlen    LvTARGLEN(bytecode_sv)            STRLEN
  319. xlv_targ    LvTARG(bytecode_sv)            svindex
  320. xlv_type    LvTYPE(bytecode_sv)            char
  321. xbm_useful    BmUSEFUL(bytecode_sv)            I32
  322. xbm_previous    BmPREVIOUS(bytecode_sv)            U16
  323. xbm_rare    BmRARE(bytecode_sv)            U8
  324. xfm_lines    FmLINES(bytecode_sv)            I32
  325. xio_lines    IoLINES(bytecode_sv)            long
  326. xio_page    IoPAGE(bytecode_sv)            long
  327. xio_page_len    IoPAGE_LEN(bytecode_sv)            long
  328. xio_lines_left    IoLINES_LEFT(bytecode_sv)               long
  329. xio_top_name    IoTOP_NAME(bytecode_sv)            pvcontents
  330. xio_top_gv    *(SV**)&IoTOP_GV(bytecode_sv)        svindex
  331. xio_fmt_name    IoFMT_NAME(bytecode_sv)            pvcontents
  332. xio_fmt_gv    *(SV**)&IoFMT_GV(bytecode_sv)        svindex
  333. xio_bottom_name    IoBOTTOM_NAME(bytecode_sv)        pvcontents
  334. xio_bottom_gv    *(SV**)&IoBOTTOM_GV(bytecode_sv)    svindex
  335. xio_subprocess    IoSUBPROCESS(bytecode_sv)        short
  336. xio_type    IoTYPE(bytecode_sv)            char
  337. xio_flags    IoFLAGS(bytecode_sv)            char
  338. xcv_stash    *(SV**)&CvSTASH(bytecode_sv)        svindex
  339. xcv_start    CvSTART(bytecode_sv)            opindex
  340. xcv_root    CvROOT(bytecode_sv)            opindex
  341. xcv_gv        *(SV**)&CvGV(bytecode_sv)        svindex
  342. xcv_file    CvFILE(bytecode_sv)            pvcontents
  343. xcv_depth    CvDEPTH(bytecode_sv)            long
  344. xcv_padlist    *(SV**)&CvPADLIST(bytecode_sv)        svindex
  345. xcv_outside    *(SV**)&CvOUTSIDE(bytecode_sv)        svindex
  346. xcv_flags    CvFLAGS(bytecode_sv)            U16
  347. av_extend    bytecode_sv                SSize_t        x
  348. av_push        bytecode_sv                svindex        x
  349. xav_fill    AvFILLp(bytecode_sv)            SSize_t
  350. xav_max        AvMAX(bytecode_sv)            SSize_t
  351. xav_flags    AvFLAGS(bytecode_sv)            U8
  352. xhv_riter    HvRITER(bytecode_sv)            I32
  353. xhv_name    HvNAME(bytecode_sv)            pvcontents
  354. hv_store    bytecode_sv                svindex        x
  355. sv_magic    bytecode_sv                char        x
  356. mg_obj        SvMAGIC(bytecode_sv)->mg_obj        svindex
  357. mg_private    SvMAGIC(bytecode_sv)->mg_private    U16
  358. mg_flags    SvMAGIC(bytecode_sv)->mg_flags        U8
  359. mg_pv        SvMAGIC(bytecode_sv)            pvcontents    x
  360. xmg_stash    *(SV**)&SvSTASH(bytecode_sv)        svindex
  361. gv_fetchpv    bytecode_sv                strconst    x
  362. gv_stashpv    bytecode_sv                strconst    x
  363. gp_sv        GvSV(bytecode_sv)            svindex
  364. gp_refcnt    GvREFCNT(bytecode_sv)            U32
  365. gp_refcnt_add    GvREFCNT(bytecode_sv)            I32        x
  366. gp_av        *(SV**)&GvAV(bytecode_sv)        svindex
  367. gp_hv        *(SV**)&GvHV(bytecode_sv)        svindex
  368. gp_cv        *(SV**)&GvCV(bytecode_sv)        svindex
  369. gp_file        GvFILE(bytecode_sv)            pvcontents
  370. gp_io        *(SV**)&GvIOp(bytecode_sv)        svindex
  371. gp_form        *(SV**)&GvFORM(bytecode_sv)        svindex
  372. gp_cvgen    GvCVGEN(bytecode_sv)            U32
  373. gp_line        GvLINE(bytecode_sv)            line_t
  374. gp_share    bytecode_sv                svindex        x
  375. xgv_flags    GvFLAGS(bytecode_sv)            U8
  376. op_next        PL_op->op_next                opindex
  377. op_sibling    PL_op->op_sibling            opindex
  378. op_ppaddr    PL_op->op_ppaddr            strconst    x
  379. op_targ        PL_op->op_targ                PADOFFSET
  380. op_type        PL_op                    OPCODE        x
  381. op_seq        PL_op->op_seq                U16
  382. op_flags    PL_op->op_flags                U8
  383. op_private    PL_op->op_private            U8
  384. op_first    cUNOP->op_first                opindex
  385. op_last        cBINOP->op_last                opindex
  386. op_other    cLOGOP->op_other            opindex
  387. op_children    cLISTOP->op_children            U32
  388. op_pmreplroot    cPMOP->op_pmreplroot            opindex
  389. op_pmreplrootgv    *(SV**)&cPMOP->op_pmreplroot        svindex
  390. op_pmreplstart    cPMOP->op_pmreplstart            opindex
  391. op_pmnext    *(OP**)&cPMOP->op_pmnext        opindex
  392. pregcomp    PL_op                    pvcontents    x
  393. op_pmflags    cPMOP->op_pmflags            U16
  394. op_pmpermflags    cPMOP->op_pmpermflags            U16
  395. op_sv        cSVOP->op_sv                svindex
  396. op_padix    cPADOP->op_padix            PADOFFSET
  397. op_pv        cPVOP->op_pv                pvcontents
  398. op_pv_tr    cPVOP->op_pv                op_tr_array
  399. op_redoop    cLOOP->op_redoop            opindex
  400. op_nextop    cLOOP->op_nextop            opindex
  401. op_lastop    cLOOP->op_lastop            opindex
  402. cop_label    cCOP->cop_label                pvcontents
  403. cop_stashpv    cCOP                    pvcontents    x
  404. cop_file    cCOP                    pvcontents    x
  405. cop_seq        cCOP->cop_seq                U32
  406. cop_arybase    cCOP->cop_arybase            I32
  407. cop_line    cCOP                    line_t        x
  408. cop_warnings    cCOP->cop_warnings            svindex
  409. main_start    PL_main_start                opindex
  410. main_root    PL_main_root                opindex
  411. curpad        PL_curpad                svindex        x
  412.