Bytecode56.pm 26 KB

1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283848586878889909192939495969798991001011021031041051061071081091101111121131141151161171181191201211221231241251261271281291301311321331341351361371381391401411421431441451461471481491501511521531541551561571581591601611621631641651661671681691701711721731741751761771781791801811821831841851861871881891901911921931941951961971981992002012022032042052062072082092102112122132142152162172182192202212222232242252262272282292302312322332342352362372382392402412422432442452462472482492502512522532542552562572582592602612622632642652662672682692702712722732742752762772782792802812822832842852862872882892902912922932942952962972982993003013023033043053063073083093103113123133143153163173183193203213223233243253263273283293303313323333343353363373383393403413423433443453463473483493503513523533543553563573583593603613623633643653663673683693703713723733743753763773783793803813823833843853863873883893903913923933943953963973983994004014024034044054064074084094104114124134144154164174184194204214224234244254264274284294304314324334344354364374384394404414424434444454464474484494504514524534544554564574584594604614624634644654664674684694704714724734744754764774784794804814824834844854864874884894904914924934944954964974984995005015025035045055065075085095105115125135145155165175185195205215225235245255265275285295305315325335345355365375385395405415425435445455465475485495505515525535545555565575585595605615625635645655665675685695705715725735745755765775785795805815825835845855865875885895905915925935945955965975985996006016026036046056066076086096106116126136146156166176186196206216226236246256266276286296306316326336346356366376386396406416426436446456466476486496506516526536546556566576586596606616626636646656666676686696706716726736746756766776786796806816826836846856866876886896906916926936946956966976986997007017027037047057067077087097107117127137147157167177187197207217227237247257267277287297307317327337347357367377387397407417427437447457467477487497507517527537547557567577587597607617627637647657667677687697707717727737747757767777787797807817827837847857867877887897907917927937947957967977987998008018028038048058068078088098108118128138148158168178188198208218228238248258268278288298308318328338348358368378388398408418428438448458468478488498508518528538548558568578588598608618628638648658668678688698708718728738748758768778788798808818828838848858868878888898908918928938948958968978988999009019029039049059069079089099109119129139149159169179189199209219229239249259269279289299309319329339349359369379389399409419429439449459469479489499509519529539549559569579589599609619629639649659669679689699709719729739749759769779789799809819829839849859869879889899909919929939949959969979989991000100110021003100410051006100710081009101010111012101310141015101610171018101910201021102210231024102510261027102810291030103110321033103410351036103710381039104010411042104310441045104610471048104910501051105210531054105510561057105810591060106110621063106410651066106710681069
  1. # Bytecode56.pm
  2. #
  3. # Copyright (c) 1996-1998 Malcolm Beattie
  4. #
  5. # You may distribute under the terms of either the GNU General Public
  6. # License or the Artistic License, as specified in the README file.
  7. #
  8. package B::Bytecode56;
  9. # The original 5.6 Bytecode compiler. Unused, not installed. Just for reference.
  10. use strict;
  11. use Carp;
  12. use B qw(main_cv main_root main_start comppadlist
  13. class peekop walkoptree svref_2object cstring walksymtable
  14. init_av begin_av end_av
  15. SVf_POK SVp_POK SVf_IOK SVp_IOK SVf_NOK SVp_NOK
  16. SVf_READONLY GVf_IMPORTED_AV GVf_IMPORTED_CV GVf_IMPORTED_HV
  17. GVf_IMPORTED_SV SVTYPEMASK
  18. );
  19. use B::Asmdata qw(@optype @specialsv_name);
  20. use B::Assembler qw(newasm endasm assemble);
  21. my %optype_enum;
  22. my $i;
  23. for ( $i = 0 ; $i < @optype ; $i++ ) {
  24. $optype_enum{ $optype[$i] } = $i;
  25. }
  26. # Following is SVf_POK|SVp_POK
  27. # XXX Shouldn't be hardwired
  28. sub POK () { SVf_POK | SVp_POK }
  29. # Following is SVf_IOK|SVp_IOK
  30. # XXX Shouldn't be hardwired
  31. sub IOK () { SVf_IOK | SVp_IOK }
  32. # Following is SVf_NOK|SVp_NOK
  33. # XXX Shouldn't be hardwired
  34. sub NOK () { SVf_NOK | SVp_NOK }
  35. # nonexistant flags (see B::GV::bytecode for usage)
  36. sub GVf_IMPORTED_IO () { 0; }
  37. sub GVf_IMPORTED_FORM () { 0; }
  38. my ( $verbose, $no_assemble, $debug_bc, $debug_cv );
  39. my @packages; # list of packages to compile
  40. sub asm (@) { # print replacement that knows about assembling
  41. if ($no_assemble) {
  42. print @_;
  43. }
  44. else {
  45. my $buf = join '', @_;
  46. assemble($_) for ( split /\n/, $buf );
  47. }
  48. }
  49. sub asmf (@) { # printf replacement that knows about assembling
  50. if ($no_assemble) {
  51. printf shift(), @_;
  52. }
  53. else {
  54. my $format = shift;
  55. my $buf = sprintf $format, @_;
  56. assemble($_) for ( split /\n/, $buf );
  57. }
  58. }
  59. # Optimisation options. On the command line, use hyphens instead of
  60. # underscores for compatibility with gcc-style options. We use
  61. # underscores here because they are OK in (strict) barewords.
  62. my ( $compress_nullops, $omit_seq, $bypass_nullops );
  63. my %optimise = (
  64. compress_nullops => \$compress_nullops,
  65. omit_sequence_numbers => \$omit_seq,
  66. bypass_nullops => \$bypass_nullops
  67. );
  68. my $strip_syntree; # this is left here in case stripping the
  69. # syntree ever becomes safe again
  70. # -- BKS, June 2000
  71. my $nextix = 0;
  72. my %symtable; # maps object addresses to object indices.
  73. # Filled in at allocation (newsv/newop) time.
  74. my %saved; # maps object addresses (for SVish classes) to "saved yet?"
  75. # flag. Set at FOO::bytecode time usually by SV::bytecode.
  76. # Manipulated via saved(), mark_saved(), unmark_saved().
  77. my %strtable; # maps shared strings to object indices
  78. # Filled in at allocation (pvix) time
  79. my $svix = -1; # we keep track of when the sv register contains an element
  80. # of the object table to avoid unnecessary repeated
  81. # consecutive ldsv instructions.
  82. my $opix = -1; # Ditto for the op register.
  83. sub ldsv {
  84. my $ix = shift;
  85. if ( $ix != $svix ) {
  86. asm "ldsv $ix\n";
  87. $svix = $ix;
  88. }
  89. }
  90. sub stsv {
  91. my $ix = shift;
  92. asm "stsv $ix\n";
  93. $svix = $ix;
  94. }
  95. sub set_svix {
  96. $svix = shift;
  97. }
  98. sub ldop {
  99. my $ix = shift;
  100. if ( $ix != $opix ) {
  101. asm "ldop $ix\n";
  102. $opix = $ix;
  103. }
  104. }
  105. sub stop {
  106. my $ix = shift;
  107. asm "stop $ix\n";
  108. $opix = $ix;
  109. }
  110. sub set_opix {
  111. $opix = shift;
  112. }
  113. sub pvstring {
  114. my $str = shift;
  115. if ( defined($str) ) {
  116. return cstring( $str . "\0" );
  117. }
  118. else {
  119. return '""';
  120. }
  121. }
  122. sub nv {
  123. # print full precision
  124. my $str = sprintf "%.40f", $_[0];
  125. $str =~ s/0+$//; # remove trailing zeros
  126. $str =~ s/\.$/.0/;
  127. return $str;
  128. }
  129. sub saved { $saved{ ${ $_[0] } } }
  130. sub mark_saved { $saved{ ${ $_[0] } } = 1 }
  131. sub unmark_saved { $saved{ ${ $_[0] } } = 0 }
  132. sub debug { $debug_bc = shift }
  133. sub pvix { # save a shared PV (mainly for COPs)
  134. return $strtable{ $_[0] } if defined( $strtable{ $_[0] } );
  135. asmf "newpv %s\n", pvstring( $_[0] );
  136. my $ix = $nextix++;
  137. $strtable{ $_[0] } = $ix;
  138. asmf "stpv %d\n", $ix;
  139. return $ix;
  140. }
  141. sub B::OBJECT::nyi {
  142. my $obj = shift;
  143. warn sprintf( "bytecode save method for %s (0x%x) not yet implemented\n",
  144. class($obj), $$obj );
  145. }
  146. #
  147. # objix may stomp on the op register (for op objects)
  148. # or the sv register (for SV objects)
  149. #
  150. sub B::OBJECT::objix {
  151. my $obj = shift;
  152. my $ix = $symtable{$$obj};
  153. if ( defined($ix) ) {
  154. return $ix;
  155. }
  156. else {
  157. $obj->newix($nextix);
  158. return $symtable{$$obj} = $nextix++;
  159. }
  160. }
  161. sub B::SV::newix {
  162. my ( $sv, $ix ) = @_;
  163. asmf "newsv %d\t# %s\n", $sv->FLAGS & SVTYPEMASK, class($sv);
  164. stsv($ix);
  165. }
  166. sub B::GV::newix {
  167. my ( $gv, $ix ) = @_;
  168. my $gvname = $gv->NAME;
  169. my $name = cstring( $gv->STASH->NAME . "::" . $gvname );
  170. asm "gv_fetchpv $name\n";
  171. stsv($ix);
  172. }
  173. sub B::HV::newix {
  174. my ( $hv, $ix ) = @_;
  175. my $name = $hv->NAME;
  176. if ($name) {
  177. # It's a stash
  178. asmf "gv_stashpv %s\n", cstring($name);
  179. stsv($ix);
  180. }
  181. else {
  182. # It's an ordinary HV. Fall back to ordinary newix method
  183. $hv->B::SV::newix($ix);
  184. }
  185. }
  186. sub B::SPECIAL::newix {
  187. my ( $sv, $ix ) = @_;
  188. # Special case. $$sv is not the address of the SV but an
  189. # index into svspecialsv_list.
  190. asmf "ldspecsv $$sv\t# %s\n", $specialsv_name[$$sv];
  191. stsv($ix);
  192. }
  193. sub B::OP::newix {
  194. my ( $op, $ix ) = @_;
  195. my $class = class($op);
  196. my $typenum = $optype_enum{$class};
  197. croak("OP::newix: can't understand class $class") unless defined($typenum);
  198. asm "newop $typenum\t# $class\n";
  199. stop($ix);
  200. }
  201. sub B::OP::walkoptree_debug {
  202. my $op = shift;
  203. warn( sprintf( "walkoptree: %s\n", peekop($op) ) );
  204. }
  205. sub B::OP::bytecode {
  206. my $op = shift;
  207. my $next = $op->next;
  208. my $nextix;
  209. my $sibix = $op->sibling->objix unless $strip_syntree;
  210. my $ix = $op->objix;
  211. my $type = $op->type;
  212. if ($bypass_nullops) {
  213. $next = $next->next while $$next && $next->type == 0;
  214. }
  215. $nextix = $next->objix;
  216. asmf "# %s\n", peekop($op) if $debug_bc;
  217. ldop($ix);
  218. asm "op_next $nextix\n";
  219. asm "op_sibling $sibix\n" unless $strip_syntree;
  220. asmf "op_type %s\t# %d\n", "pp_" . $op->name, $type;
  221. asmf( "op_seq %d\n", $op->seq ) unless $omit_seq;
  222. if ( $type || !$compress_nullops ) {
  223. asmf "op_targ %d\nop_flags 0x%x\nop_private 0x%x\n",
  224. $op->targ, $op->flags, $op->private;
  225. }
  226. }
  227. sub B::UNOP::bytecode {
  228. my $op = shift;
  229. my $firstix = $op->first->objix unless $strip_syntree;
  230. $op->B::OP::bytecode;
  231. if ( ( $op->type || !$compress_nullops ) && !$strip_syntree ) {
  232. asm "op_first $firstix\n";
  233. }
  234. }
  235. sub B::LOGOP::bytecode {
  236. my $op = shift;
  237. my $otherix = $op->other->objix;
  238. $op->B::UNOP::bytecode;
  239. asm "op_other $otherix\n";
  240. }
  241. sub B::SVOP::bytecode {
  242. my $op = shift;
  243. my $sv = $op->sv;
  244. my $svix = $sv->objix;
  245. $op->B::OP::bytecode;
  246. asm "op_sv $svix\n";
  247. $sv->bytecode;
  248. }
  249. sub B::PADOP::bytecode {
  250. my $op = shift;
  251. my $padix = $op->padix;
  252. $op->B::OP::bytecode;
  253. asm "op_padix $padix\n";
  254. }
  255. sub B::PVOP::bytecode {
  256. my $op = shift;
  257. my $pv = $op->pv;
  258. $op->B::OP::bytecode;
  259. #
  260. # This would be easy except that OP_TRANS uses a PVOP to store an
  261. # endian-dependent array of 256 shorts instead of a plain string.
  262. #
  263. if ( $op->name eq "trans" ) {
  264. my @shorts = unpack( "s256", $pv ); # assembler handles endianness
  265. asm "op_pv_tr ", join( ",", @shorts ), "\n";
  266. }
  267. else {
  268. asmf "newpv %s\nop_pv\n", pvstring($pv);
  269. }
  270. }
  271. sub B::BINOP::bytecode {
  272. my $op = shift;
  273. my $lastix = $op->last->objix unless $strip_syntree;
  274. $op->B::UNOP::bytecode;
  275. if ( ( $op->type || !$compress_nullops ) && !$strip_syntree ) {
  276. asm "op_last $lastix\n";
  277. }
  278. }
  279. sub B::LOOP::bytecode {
  280. my $op = shift;
  281. my $redoopix = $op->redoop->objix;
  282. my $nextopix = $op->nextop->objix;
  283. my $lastopix = $op->lastop->objix;
  284. $op->B::LISTOP::bytecode;
  285. asm "op_redoop $redoopix\nop_nextop $nextopix\nop_lastop $lastopix\n";
  286. }
  287. sub B::COP::bytecode {
  288. my $op = shift;
  289. my $file = $op->file;
  290. my $line = $op->line;
  291. if ($debug_bc) { # do this early to aid debugging
  292. asmf "# line %s:%d\n", $file, $line;
  293. }
  294. my $stashpv = $op->stashpv;
  295. my $warnings = $op->warnings;
  296. my $warningsix = $warnings->objix;
  297. my $labelix = pvix( $op->label );
  298. my $stashix = pvix($stashpv);
  299. my $fileix = pvix($file);
  300. $warnings->bytecode;
  301. $op->B::OP::bytecode;
  302. asmf <<"EOT", $labelix, $stashix, $op->cop_seq, $fileix, $op->arybase;
  303. cop_label %d
  304. cop_stashpv %d
  305. cop_seq %d
  306. cop_file %d
  307. cop_arybase %d
  308. cop_line $line
  309. cop_warnings $warningsix
  310. EOT
  311. }
  312. sub B::PMOP::bytecode {
  313. my $op = shift;
  314. my $replroot = $op->pmreplroot;
  315. my $replrootix = $replroot->objix;
  316. my $replstartix = $op->pmreplstart->objix;
  317. my $opname = $op->name;
  318. # pmnext is corrupt in some PMOPs (see misc.t for example)
  319. #my $pmnextix = $op->pmnext->objix;
  320. if ($$replroot) {
  321. # OP_PUSHRE (a mutated version of OP_MATCH for the regexp
  322. # argument to a split) stores a GV in op_pmreplroot instead
  323. # of a substitution syntax tree. We don't want to walk that...
  324. if ( $opname eq "pushre" ) {
  325. $replroot->bytecode;
  326. }
  327. else {
  328. walkoptree( $replroot, "bytecode" );
  329. }
  330. }
  331. $op->B::LISTOP::bytecode;
  332. if ( $opname eq "pushre" ) {
  333. asmf "op_pmreplrootgv $replrootix\n";
  334. }
  335. else {
  336. asm "op_pmreplroot $replrootix\nop_pmreplstart $replstartix\n";
  337. }
  338. my $re = pvstring( $op->precomp );
  339. # op_pmnext omitted since a perl bug means it's sometime corrupt
  340. asmf <<"EOT", $op->pmflags, $op->pmpermflags;
  341. op_pmflags 0x%x
  342. op_pmpermflags 0x%x
  343. newpv $re
  344. pregcomp
  345. EOT
  346. }
  347. sub B::SV::bytecode {
  348. my $sv = shift;
  349. return if saved($sv);
  350. my $ix = $sv->objix;
  351. my $refcnt = $sv->REFCNT;
  352. my $flags = sprintf( "0x%x", $sv->FLAGS );
  353. ldsv($ix);
  354. asm "sv_refcnt $refcnt\nsv_flags $flags\n";
  355. mark_saved($sv);
  356. }
  357. sub B::PV::bytecode {
  358. my $sv = shift;
  359. return if saved($sv);
  360. $sv->B::SV::bytecode;
  361. asmf( "newpv %s\nxpv\n", pvstring( $sv->PV ) ) if $sv->FLAGS & POK;
  362. }
  363. sub B::IV::bytecode {
  364. my $sv = shift;
  365. return if saved($sv);
  366. my $iv = $sv->IVX;
  367. $sv->B::SV::bytecode;
  368. asmf "%s $iv\n", $sv->needs64bits ? "xiv64" : "xiv32"
  369. if $sv->FLAGS & IOK; # could be PVNV
  370. }
  371. sub B::NV::bytecode {
  372. my $sv = shift;
  373. return if saved($sv);
  374. $sv->B::SV::bytecode;
  375. asmf "xnv %s\n", nv( $sv->NVX );
  376. }
  377. sub B::RV::bytecode {
  378. my $sv = shift;
  379. return if saved($sv);
  380. my $rv = $sv->RV;
  381. my $rvix = $rv->objix;
  382. $rv->bytecode;
  383. $sv->B::SV::bytecode;
  384. asm "xrv $rvix\n";
  385. }
  386. sub B::PVIV::bytecode {
  387. my $sv = shift;
  388. return if saved($sv);
  389. my $iv = $sv->IVX;
  390. $sv->B::PV::bytecode;
  391. asmf "%s $iv\n", $sv->needs64bits ? "xiv64" : "xiv32";
  392. }
  393. sub B::PVNV::bytecode {
  394. my $sv = shift;
  395. my $flag = shift || 0;
  396. # The $flag argument is passed through PVMG::bytecode by BM::bytecode
  397. # and AV::bytecode and indicates special handling. $flag = 1 is used by
  398. # BM::bytecode and means that we should ensure we save the whole B-M
  399. # table. It consists of 257 bytes (256 char array plus a final \0)
  400. # which follow the ordinary PV+\0 and the 257 bytes are *not* reflected
  401. # in SvCUR. $flag = 2 is used by AV::bytecode and means that we only
  402. # call SV::bytecode instead of saving PV and calling NV::bytecode since
  403. # PV/NV/IV stuff is different for AVs.
  404. return if saved($sv);
  405. if ( $flag == 2 ) {
  406. $sv->B::SV::bytecode;
  407. }
  408. else {
  409. my $pv = $sv->PV;
  410. $sv->B::IV::bytecode;
  411. asmf "xnv %s\n", nv( $sv->NVX );
  412. if ( $flag == 1 ) {
  413. $pv .= "\0" . $sv->TABLE;
  414. asmf "newpv %s\npv_cur %d\nxpv\n", pvstring($pv), length($pv) - 257;
  415. }
  416. else {
  417. asmf( "newpv %s\nxpv\n", pvstring($pv) ) if $sv->FLAGS & POK;
  418. }
  419. }
  420. }
  421. sub B::PVMG::bytecode {
  422. my ( $sv, $flag ) = @_;
  423. # See B::PVNV::bytecode for an explanation of $flag.
  424. return if saved($sv);
  425. # XXX We assume SvSTASH is already saved and don't save it later ourselves
  426. my $stashix = $sv->SvSTASH->objix;
  427. my @mgchain = $sv->MAGIC;
  428. my ( @mgobjix, $mg );
  429. #
  430. # We need to traverse the magic chain and get objix for each OBJ
  431. # field *before* we do B::PVNV::bytecode since objix overwrites
  432. # the sv register. However, we need to write the magic-saving
  433. # bytecode *after* B::PVNV::bytecode since sv isn't initialised
  434. # to refer to $sv until then.
  435. #
  436. @mgobjix = map( $_->OBJ->objix, @mgchain );
  437. $sv->B::PVNV::bytecode($flag);
  438. asm "xmg_stash $stashix\n";
  439. foreach $mg (@mgchain) {
  440. asmf "sv_magic %s\nmg_obj %d\nnewpv %s\nmg_pv\n",
  441. cstring( $mg->TYPE ), shift(@mgobjix), pvstring( $mg->PTR );
  442. }
  443. }
  444. sub B::PVLV::bytecode {
  445. my $sv = shift;
  446. return if saved($sv);
  447. $sv->B::PVMG::bytecode;
  448. asmf <<'EOT', $sv->TARGOFF, $sv->TARGLEN, cstring( $sv->TYPE );
  449. xlv_targoff %d
  450. xlv_targlen %d
  451. xlv_type %s
  452. EOT
  453. }
  454. sub B::BM::bytecode {
  455. my $sv = shift;
  456. return if saved($sv);
  457. # See PVNV::bytecode for an explanation of what the argument does
  458. $sv->B::PVMG::bytecode(1);
  459. asmf "xbm_useful %d\nxbm_previous %d\nxbm_rare %d\n",
  460. $sv->USEFUL, $sv->PREVIOUS, $sv->RARE;
  461. }
  462. sub empty_gv { # is a GV empty except for imported stuff?
  463. my $gv = shift;
  464. return 0 if ( $gv->SV->FLAGS & SVTYPEMASK ); # sv not SVt_NULL
  465. my @subfield_names = qw(AV HV CV FORM IO);
  466. @subfield_names = grep {
  467. ;
  468. no strict 'refs';
  469. !( $gv->GvFLAGS & ${ \"GVf_IMPORTED_$_" }->() ) && ${ $gv->$_() };
  470. } @subfield_names;
  471. return scalar @subfield_names;
  472. }
  473. sub B::GV::bytecode {
  474. my $gv = shift;
  475. return if saved($gv);
  476. return unless grep { $_ eq $gv->STASH->NAME; } @packages;
  477. return if $gv->NAME =~ m/^\(/; # ignore overloads - they'll be rebuilt
  478. my $ix = $gv->objix;
  479. mark_saved($gv);
  480. ldsv($ix);
  481. asmf <<"EOT", $gv->FLAGS, $gv->GvFLAGS;
  482. sv_flags 0x%x
  483. xgv_flags 0x%x
  484. EOT
  485. my $refcnt = $gv->REFCNT;
  486. asmf( "sv_refcnt_add %d\n", $refcnt - 1 ) if $refcnt > 1;
  487. return if $gv->is_empty;
  488. asmf <<"EOT", $gv->LINE, pvix( $gv->FILE );
  489. gp_line %d
  490. gp_file %d
  491. EOT
  492. my $gvname = $gv->NAME;
  493. my $name = cstring( $gv->STASH->NAME . "::" . $gvname );
  494. my $egv = $gv->EGV;
  495. my $egvix = $egv->objix;
  496. my $gvrefcnt = $gv->GvREFCNT;
  497. asmf( "gp_refcnt_add %d\n", $gvrefcnt - 1 ) if $gvrefcnt > 1;
  498. if ( $gvrefcnt > 1 && $ix != $egvix ) {
  499. asm "gp_share $egvix\n";
  500. }
  501. else {
  502. if ( $gvname !~ /^([^A-Za-z]|STDIN|STDOUT|STDERR|ARGV|SIG|ENV)$/ ) {
  503. my $i;
  504. my @subfield_names = qw(SV AV HV CV FORM IO);
  505. @subfield_names = grep {
  506. ;
  507. no strict 'refs';
  508. !( $gv->GvFLAGS & ${ \"GVf_IMPORTED_$_" }->() );
  509. } @subfield_names;
  510. my @subfields = map( $gv->$_(), @subfield_names );
  511. my @ixes = map( $_->objix, @subfields );
  512. # Reset sv register for $gv
  513. ldsv($ix);
  514. for ( $i = 0 ; $i < @ixes ; $i++ ) {
  515. asmf "gp_%s %d\n", lc( $subfield_names[$i] ), $ixes[$i];
  516. }
  517. # Now save all the subfields
  518. my $sv;
  519. foreach $sv (@subfields) {
  520. $sv->bytecode;
  521. }
  522. }
  523. }
  524. }
  525. sub B::HV::bytecode {
  526. my $hv = shift;
  527. return if saved($hv);
  528. mark_saved($hv);
  529. my $name = $hv->NAME;
  530. my $ix = $hv->objix;
  531. if ( !$name ) {
  532. # It's an ordinary HV. Stashes have NAME set and need no further
  533. # saving beyond the gv_stashpv that $hv->objix already ensures.
  534. my @contents = $hv->ARRAY;
  535. my ( $i, @ixes );
  536. for ( $i = 1 ; $i < @contents ; $i += 2 ) {
  537. push( @ixes, $contents[$i]->objix );
  538. }
  539. for ( $i = 1 ; $i < @contents ; $i += 2 ) {
  540. $contents[$i]->bytecode;
  541. }
  542. ldsv($ix);
  543. for ( $i = 0 ; $i < @contents ; $i += 2 ) {
  544. asmf(
  545. "newpv %s\nhv_store %d\n",
  546. pvstring( $contents[$i] ),
  547. $ixes[ $i / 2 ]
  548. );
  549. }
  550. asmf "sv_refcnt %d\nsv_flags 0x%x\n", $hv->REFCNT, $hv->FLAGS;
  551. }
  552. }
  553. sub B::AV::bytecode {
  554. my $av = shift;
  555. return if saved($av);
  556. my $ix = $av->objix;
  557. my $fill = $av->FILL;
  558. my $max = $av->MAX;
  559. my ( @array, @ixes );
  560. if ( $fill > -1 ) {
  561. @array = $av->ARRAY;
  562. @ixes = map( $_->objix, @array );
  563. my $sv;
  564. foreach $sv (@array) {
  565. $sv->bytecode;
  566. }
  567. }
  568. # See PVNV::bytecode for the meaning of the flag argument of 2.
  569. $av->B::PVMG::bytecode(2);
  570. # Recover sv register and set AvMAX and AvFILL to -1 (since we
  571. # create an AV with NEWSV and SvUPGRADE rather than doing newAV
  572. # which is what sets AvMAX and AvFILL.
  573. ldsv($ix);
  574. asmf "sv_flags 0x%x\n",
  575. $av->FLAGS & ~SVf_READONLY; # SvREADONLY_off($av) in case PADCONST
  576. asmf "xav_flags 0x%x\nxav_max -1\nxav_fill -1\n", $av->AvFLAGS;
  577. if ( $fill > -1 ) {
  578. my $elix;
  579. foreach $elix (@ixes) {
  580. asm "av_push $elix\n";
  581. }
  582. }
  583. else {
  584. if ( $max > -1 ) {
  585. asm "av_extend $max\n";
  586. }
  587. }
  588. asmf "sv_flags 0x%x\n", $av->FLAGS; # restore flags from above
  589. }
  590. sub B::CV::bytecode {
  591. my $cv = shift;
  592. return if saved($cv);
  593. return if ${ $cv->GV } && ( $cv->GV->GvFLAGS & GVf_IMPORTED_CV );
  594. my $fileix = pvix( $cv->FILE );
  595. my $ix = $cv->objix;
  596. $cv->B::PVMG::bytecode;
  597. my $i;
  598. my @subfield_names = qw(ROOT START STASH GV PADLIST OUTSIDE);
  599. my @subfields = map( $cv->$_(), @subfield_names );
  600. my @ixes = map( $_->objix, @subfields );
  601. # Save OP tree from CvROOT (first element of @subfields)
  602. my $root = shift @subfields;
  603. if ($$root) {
  604. walkoptree( $root, "bytecode" );
  605. }
  606. # Reset sv register for $cv (since above ->objix calls stomped on it)
  607. ldsv($ix);
  608. for ( $i = 0 ; $i < @ixes ; $i++ ) {
  609. asmf "xcv_%s %d\n", lc( $subfield_names[$i] ), $ixes[$i];
  610. }
  611. asmf "xcv_depth %d\nxcv_flags 0x%x\n", $cv->DEPTH, $cv->CvFLAGS;
  612. asmf "xcv_file %d\n", $fileix;
  613. # Now save all the subfields (except for CvROOT which was handled
  614. # above) and CvSTART (now the initial element of @subfields).
  615. shift @subfields; # bye-bye CvSTART
  616. my $sv;
  617. foreach $sv (@subfields) {
  618. $sv->bytecode;
  619. }
  620. }
  621. sub B::IO::bytecode {
  622. my $io = shift;
  623. return if saved($io);
  624. my $ix = $io->objix;
  625. my $top_gv = $io->TOP_GV;
  626. my $top_gvix = $top_gv->objix;
  627. my $fmt_gv = $io->FMT_GV;
  628. my $fmt_gvix = $fmt_gv->objix;
  629. my $bottom_gv = $io->BOTTOM_GV;
  630. my $bottom_gvix = $bottom_gv->objix;
  631. $io->B::PVMG::bytecode;
  632. ldsv($ix);
  633. asm "xio_top_gv $top_gvix\n";
  634. asm "xio_fmt_gv $fmt_gvix\n";
  635. asm "xio_bottom_gv $bottom_gvix\n";
  636. my $field;
  637. foreach $field (qw(TOP_NAME FMT_NAME BOTTOM_NAME)) {
  638. asmf "newpv %s\nxio_%s\n", pvstring( $io->$field() ), lc($field);
  639. }
  640. foreach $field (qw(LINES PAGE PAGE_LEN LINES_LEFT SUBPROCESS)) {
  641. asmf "xio_%s %d\n", lc($field), $io->$field();
  642. }
  643. asmf "xio_type %s\nxio_flags 0x%x\n", cstring( $io->IoTYPE ), $io->IoFLAGS;
  644. $top_gv->bytecode;
  645. $fmt_gv->bytecode;
  646. $bottom_gv->bytecode;
  647. }
  648. sub B::SPECIAL::bytecode {
  649. # nothing extra needs doing
  650. }
  651. sub bytecompile_object {
  652. for my $sv (@_) {
  653. svref_2object($sv)->bytecode;
  654. }
  655. }
  656. sub B::GV::bytecodecv {
  657. my $gv = shift;
  658. my $cv = $gv->CV;
  659. if ( $$cv && !saved($cv) && !( $gv->FLAGS & GVf_IMPORTED_CV ) ) {
  660. if ($debug_cv) {
  661. warn sprintf( "saving extra CV &%s::%s (0x%x) from GV 0x%x\n",
  662. $gv->STASH->NAME, $gv->NAME, $$cv, $$gv );
  663. }
  664. $gv->bytecode;
  665. }
  666. }
  667. sub save_call_queues {
  668. if ( begin_av()->isa("B::AV") ) { # this is just to save 'use Foo;' calls
  669. for my $cv ( begin_av()->ARRAY ) {
  670. next unless grep { $_ eq $cv->STASH->NAME; } @packages;
  671. my $op = $cv->START;
  672. OPLOOP:
  673. while ($$op) {
  674. if ( $op->name eq 'require' ) { # save any BEGIN that does a require
  675. $cv->bytecode;
  676. asmf "push_begin %d\n", $cv->objix;
  677. last OPLOOP;
  678. }
  679. $op = $op->next;
  680. }
  681. }
  682. }
  683. if ( init_av()->isa("B::AV") ) {
  684. for my $cv ( init_av()->ARRAY ) {
  685. next unless grep { $_ eq $cv->STASH->NAME; } @packages;
  686. $cv->bytecode;
  687. asmf "push_init %d\n", $cv->objix;
  688. }
  689. }
  690. if ( end_av()->isa("B::AV") ) {
  691. for my $cv ( end_av()->ARRAY ) {
  692. next unless grep { $_ eq $cv->STASH->NAME; } @packages;
  693. $cv->bytecode;
  694. asmf "push_end %d\n", $cv->objix;
  695. }
  696. }
  697. }
  698. sub symwalk {
  699. no strict 'refs';
  700. my $ok = 1
  701. if grep { ( my $name = $_[0] ) =~ s/::$//; $_ eq $name; } @packages;
  702. if ( grep { /^$_[0]/; } @packages ) {
  703. walksymtable( \%{"$_[0]"}, "bytecodecv", \&symwalk, $_[0] );
  704. }
  705. warn "considering $_[0] ... " . ( $ok ? "accepted\n" : "rejected\n" )
  706. if $debug_bc;
  707. $ok;
  708. }
  709. sub bytecompile_main {
  710. my $curpad = ( comppadlist->ARRAY )[1];
  711. my $curpadix = $curpad->objix;
  712. $curpad->bytecode;
  713. save_call_queues();
  714. walkoptree( main_root, "bytecode" ) unless ref(main_root) eq "B::NULL";
  715. warn "done main program, now walking symbol table\n" if $debug_bc;
  716. if (@packages) {
  717. no strict qw(refs);
  718. walksymtable( \%{"main::"}, "bytecodecv", \&symwalk );
  719. }
  720. else {
  721. die "No packages requested for compilation!\n";
  722. }
  723. asmf "main_root %d\n", main_root->objix;
  724. asmf "main_start %d\n", main_start->objix;
  725. asmf "curpad $curpadix\n";
  726. # XXX Do min_intro_pending and max_intro_pending matter?
  727. }
  728. sub compile {
  729. my @options = @_;
  730. my ( $option, $opt, $arg );
  731. open( OUT, ">&STDOUT" );
  732. binmode OUT;
  733. select OUT;
  734. OPTION:
  735. while ( $option = shift @options ) {
  736. if ( $option =~ /^-(.)(.*)/ ) {
  737. $opt = $1;
  738. $arg = $2;
  739. }
  740. else {
  741. unshift @options, $option;
  742. last OPTION;
  743. }
  744. if ( $opt eq "-" && $arg eq "-" ) {
  745. shift @options;
  746. last OPTION;
  747. }
  748. elsif ( $opt eq "o" ) {
  749. $arg ||= shift @options;
  750. open( OUT, ">$arg" ) or return "$arg: $!\n";
  751. binmode OUT;
  752. }
  753. elsif ( $opt eq "a" ) {
  754. $arg ||= shift @options;
  755. open( OUT, ">>$arg" ) or return "$arg: $!\n";
  756. binmode OUT;
  757. }
  758. elsif ( $opt eq "D" ) {
  759. $arg ||= shift @options;
  760. foreach $arg ( split( //, $arg ) ) {
  761. if ( $arg eq "b" ) {
  762. $| = 1;
  763. debug(1);
  764. }
  765. elsif ( $arg eq "o" ) {
  766. B->debug(1);
  767. }
  768. elsif ( $arg eq "a" ) {
  769. B::Assembler::debug(1);
  770. }
  771. elsif ( $arg eq "C" ) {
  772. $debug_cv = 1;
  773. }
  774. }
  775. }
  776. elsif ( $opt eq "v" ) {
  777. $verbose = 1;
  778. }
  779. elsif ( $opt eq "S" ) {
  780. $no_assemble = 1;
  781. }
  782. elsif ( $opt eq "f" ) {
  783. $arg ||= shift @options;
  784. my $value = $arg !~ s/^no-//;
  785. $arg =~ s/-/_/g;
  786. my $ref = $optimise{$arg};
  787. if ( defined($ref) ) {
  788. $$ref = $value;
  789. }
  790. else {
  791. warn qq(ignoring unknown optimisation option "$arg"\n);
  792. }
  793. }
  794. elsif ( $opt eq "O" ) {
  795. $arg = 1 if $arg eq "";
  796. my $ref;
  797. foreach $ref ( values %optimise ) {
  798. $$ref = 0;
  799. }
  800. if ( $arg >= 2 ) {
  801. $bypass_nullops = 1;
  802. }
  803. if ( $arg >= 1 ) {
  804. $compress_nullops = 1;
  805. $omit_seq = 1;
  806. }
  807. }
  808. elsif ( $opt eq "u" ) {
  809. $arg ||= shift @options;
  810. push @packages, $arg;
  811. }
  812. else {
  813. warn qq(ignoring unknown option "$opt$arg"\n);
  814. }
  815. }
  816. if ( !@packages ) {
  817. warn "No package specified for compilation, assuming main::\n";
  818. @packages = qw(main);
  819. }
  820. if (@options) {
  821. die "Extraneous options left on B::Bytecode commandline: @options\n";
  822. }
  823. else {
  824. return sub {
  825. newasm( \&apr ) unless $no_assemble;
  826. bytecompile_main();
  827. endasm() unless $no_assemble;
  828. };
  829. }
  830. }
  831. sub apr { print @_; }
  832. 1;
  833. __END__
  834. =head1 NAME
  835. B::Bytecode56 - Perl 5.6 compiler's bytecode backend
  836. =head1 SYNOPSIS
  837. perl -MO=Bytecode[,OPTIONS] foo.pl
  838. =head1 DESCRIPTION
  839. This compiler backend takes Perl source and generates a
  840. platform-independent bytecode encapsulating code to load the
  841. internal structures perl uses to run your program. When the
  842. generated bytecode is loaded in, your program is ready to run,
  843. reducing the time which perl would have taken to load and parse
  844. your program into its internal semi-compiled form. That means that
  845. compiling with this backend will not help improve the runtime
  846. execution speed of your program but may improve the start-up time.
  847. Depending on the environment in which your program runs this may
  848. or may not be a help.
  849. The resulting bytecode can be run with a special byteperl executable
  850. or (for non-main programs) be loaded via the C<byteload_fh> function
  851. in the F<B> module.
  852. =head1 OPTIONS
  853. If there are any non-option arguments, they are taken to be names of
  854. objects to be saved (probably doesn't work properly yet). Without
  855. extra arguments, it saves the main program.
  856. =over 4
  857. =item B<-ofilename>
  858. Output to filename instead of STDOUT.
  859. =item B<-afilename>
  860. Append output to filename.
  861. =item B<-->
  862. Force end of options.
  863. =item B<-f>
  864. Force optimisations on or off one at a time. Each can be preceded
  865. by B<no-> to turn the option off (e.g. B<-fno-compress-nullops>).
  866. =item B<-fcompress-nullops>
  867. Only fills in the necessary fields of ops which have
  868. been optimised away by perl's internal compiler.
  869. =item B<-fomit-sequence-numbers>
  870. Leaves out code to fill in the op_seq field of all ops
  871. which is only used by perl's internal compiler.
  872. =item B<-fbypass-nullops>
  873. If op->op_next ever points to a NULLOP, replaces the op_next field
  874. with the first non-NULLOP in the path of execution.
  875. =item B<-On>
  876. Optimisation level (n = 0, 1, 2, ...). B<-O> means B<-O1>.
  877. B<-O1> sets B<-fcompress-nullops> B<-fomit-sequence numbers>.
  878. B<-O2> adds B<-fbypass-nullops>.
  879. =item B<-D>
  880. Debug options (concatenated or separate flags like C<perl -D>).
  881. =item B<-Do>
  882. Prints each OP as it's processed.
  883. =item B<-Db>
  884. Print debugging information about bytecompiler progress.
  885. =item B<-Da>
  886. Tells the (bytecode) assembler to include source assembler lines
  887. in its output as bytecode comments.
  888. =item B<-DC>
  889. Prints each CV taken from the final symbol tree walk.
  890. =item B<-S>
  891. Output (bytecode) assembler source rather than piping it
  892. through the assembler and outputting bytecode.
  893. =item B<-upackage>
  894. Stores package in the output.
  895. =back
  896. =head1 EXAMPLES
  897. perl -MO=Bytecode,-O6,-ofoo.plc,-umain foo.pl
  898. perl -MO=Bytecode,-S,-umain foo.pl > foo.S
  899. assemble foo.S > foo.plc
  900. Note that C<assemble> lives in the C<B> subdirectory of your perl
  901. library directory. The utility called perlcc may also be used to
  902. help make use of this compiler.
  903. perl -MO=Bytecode,-uFoo,-oFoo.pmc Foo.pm
  904. =head1 BUGS
  905. Output is still huge and there are still occasional crashes during
  906. either compilation or ByteLoading. Current status: experimental.
  907. =head1 AUTHORS
  908. Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
  909. Benjamin Stuhl, C<sho_pi@hotmail.com>
  910. =cut
  911. # Local Variables:
  912. # mode: cperl
  913. # cperl-indent-level: 2
  914. # fill-column: 100
  915. # End:
  916. # vim: expandtab shiftwidth=2: