Stackobj.pm 12 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548
  1. # Stackobj.pm
  2. #
  3. # Copyright (c) 1996 Malcolm Beattie
  4. # Copyright (c) 2010 Reini Urban
  5. # Copyright (c) 2012, 2013 cPanel Inc
  6. #
  7. # You may distribute under the terms of either the GNU General Public
  8. # License or the Artistic License, as specified in the README file.
  9. #
  10. package B::Stackobj;
  11. our $VERSION = '1.11';
  12. use Exporter ();
  13. @ISA = qw(Exporter);
  14. @EXPORT_OK = qw(set_callback T_UNKNOWN T_NUM T_INT T_STR VALID_UNSIGNED
  15. VALID_INT VALID_NUM VALID_STR VALID_SV REGISTER TEMPORARY);
  16. %EXPORT_TAGS = (
  17. types => [qw(T_UNKNOWN T_NUM T_INT T_STR)],
  18. flags => [
  19. qw(VALID_INT VALID_NUM VALID_STR VALID_SV
  20. VALID_UNSIGNED REGISTER TEMPORARY)
  21. ]
  22. );
  23. use Carp qw(confess);
  24. use strict;
  25. use B qw(class SVf_IOK SVf_NOK SVf_IVisUV SVf_ROK SVf_POK);
  26. use B::C qw(ivx nvx);
  27. use Config;
  28. # Types
  29. sub T_UNKNOWN () { 0 }
  30. sub T_INT () { 1 }
  31. sub T_NUM () { 2 }
  32. sub T_STR () { 3 }
  33. sub T_SPECIAL () { 4 }
  34. # Flags
  35. sub VALID_INT () { 0x01 }
  36. sub VALID_UNSIGNED () { 0x02 }
  37. sub VALID_NUM () { 0x04 }
  38. sub VALID_STR () { 0x08 }
  39. sub VALID_SV () { 0x10 }
  40. sub REGISTER () { 0x20 } # no implicit write-back when calling subs
  41. sub TEMPORARY () { 0x40 } # no implicit write-back needed at all
  42. sub SAVE_INT () { 0x80 } # if int part needs to be saved at all
  43. sub SAVE_NUM () { 0x100 } # if num part needs to be saved at all
  44. sub SAVE_STR () { 0x200 } # if str part needs to be saved at all
  45. #
  46. # Callback for runtime code generation
  47. #
  48. my $runtime_callback = sub { confess "set_callback not yet called" };
  49. sub set_callback (&) { $runtime_callback = shift }
  50. sub runtime { &$runtime_callback(@_) }
  51. #
  52. # Methods
  53. #
  54. # The stack holds generally only the string ($sv->save) representation of the B object,
  55. # for the types sv, int, double, numeric and sometimes bool.
  56. # Special subclasses keep the B obj, like Const
  57. sub write_back { confess "stack object does not implement write_back" }
  58. sub invalidate {
  59. shift->{flags} &= ~( VALID_INT | VALID_UNSIGNED | VALID_NUM | VALID_STR );
  60. }
  61. sub invalidate_int {
  62. shift->{flags} &= ~( VALID_INT | VALID_UNSIGNED );
  63. }
  64. sub invalidate_double {
  65. shift->{flags} &= ~( VALID_NUM );
  66. }
  67. sub invalidate_str {
  68. shift->{flags} &= ~( VALID_STR );
  69. }
  70. sub as_sv {
  71. my $obj = shift;
  72. if ( !( $obj->{flags} & VALID_SV ) ) {
  73. $obj->write_back;
  74. $obj->{flags} |= VALID_SV;
  75. }
  76. return $obj->{sv};
  77. }
  78. sub as_obj {
  79. return shift->{obj};
  80. }
  81. sub as_int {
  82. my $obj = shift;
  83. if ( !( $obj->{flags} & VALID_INT ) ) {
  84. $obj->load_int;
  85. $obj->{flags} |= VALID_INT | SAVE_INT;
  86. }
  87. return $obj->{iv};
  88. }
  89. sub as_double {
  90. my $obj = shift;
  91. if ( !( $obj->{flags} & VALID_NUM ) ) {
  92. $obj->load_double;
  93. $obj->{flags} |= VALID_NUM | SAVE_NUM;
  94. }
  95. return $obj->{nv};
  96. }
  97. sub as_str {
  98. my $obj = shift;
  99. if ( !( $obj->{flags} & VALID_STR ) ) {
  100. $obj->load_str;
  101. $obj->{flags} |= VALID_STR | SAVE_STR;
  102. }
  103. return $obj->{sv};
  104. }
  105. sub as_numeric {
  106. my $obj = shift;
  107. return $obj->{type} == T_INT ? $obj->as_int : $obj->as_double;
  108. }
  109. sub as_bool {
  110. my $obj = shift;
  111. if ( $obj->{flags} & VALID_INT ) {
  112. return $obj->{iv};
  113. }
  114. if ( $obj->{flags} & VALID_NUM ) {
  115. return $obj->{nv};
  116. }
  117. return sprintf( "(SvTRUE(%s))", $obj->as_sv );
  118. }
  119. #
  120. # Debugging methods
  121. #
  122. sub peek {
  123. my $obj = shift;
  124. my $type = $obj->{type};
  125. my $flags = $obj->{flags};
  126. my @flags;
  127. if ( $type == T_UNKNOWN ) {
  128. $type = "T_UNKNOWN";
  129. }
  130. elsif ( $type == T_INT ) {
  131. $type = "T_INT";
  132. }
  133. elsif ( $type == T_NUM ) {
  134. $type = "T_NUM";
  135. }
  136. elsif ( $type == T_STR ) {
  137. $type = "T_STR";
  138. }
  139. else {
  140. $type = "(illegal type $type)";
  141. }
  142. push( @flags, "VALID_INT" ) if $flags & VALID_INT;
  143. push( @flags, "VALID_NUM" ) if $flags & VALID_NUM;
  144. push( @flags, "VALID_STR" ) if $flags & VALID_STR;
  145. push( @flags, "VALID_SV" ) if $flags & VALID_SV;
  146. push( @flags, "REGISTER" ) if $flags & REGISTER;
  147. push( @flags, "TEMPORARY" ) if $flags & TEMPORARY;
  148. @flags = ("none") unless @flags;
  149. return sprintf( "%s type=$type flags=%s sv=$obj->{sv} iv=$obj->{iv} nv=$obj->{nv}",
  150. class($obj), join( "|", @flags ) );
  151. }
  152. sub minipeek {
  153. my $obj = shift;
  154. my $type = $obj->{type};
  155. my $flags = $obj->{flags};
  156. if ( $type == T_INT || $flags & VALID_INT ) {
  157. return $obj->{iv};
  158. }
  159. elsif ( $type == T_NUM || $flags & VALID_NUM ) {
  160. return $obj->{nv};
  161. }
  162. else {
  163. return $obj->{sv};
  164. }
  165. }
  166. #
  167. # Caller needs to ensure that set_int, set_double,
  168. # set_numeric and set_sv are only invoked on legal lvalues.
  169. #
  170. sub set_int {
  171. my ( $obj, $expr, $unsigned ) = @_;
  172. my $sval;
  173. # bullshit detector for non numeric expr, expr 'lnv0 + rnv0'
  174. if ($expr =~ /[ a-dfzA-DF-Z]/) { # looks not like number
  175. $sval = $expr;
  176. } else {
  177. $sval = B::C::ivx($expr);
  178. $sval = $expr if $sval eq '0' and $expr;
  179. }
  180. runtime("$obj->{iv} = $sval;");
  181. $obj->{flags} &= ~( VALID_SV | VALID_NUM );
  182. $obj->{flags} |= VALID_INT | SAVE_INT;
  183. $obj->{flags} |= VALID_UNSIGNED if $unsigned;
  184. }
  185. sub set_double {
  186. my ( $obj, $expr ) = @_;
  187. my $sval;
  188. # bullshit detector for non numeric expr, expr 'lnv0 + rnv0'
  189. if ($expr =~ /[ a-dfzA-DF-Z]/) { # looks not like number
  190. $sval = $expr;
  191. } else {
  192. $sval = B::C::nvx($expr);
  193. $sval = $expr if $sval eq '0' and $expr;
  194. }
  195. runtime("$obj->{nv} = $sval;");
  196. $obj->{flags} &= ~( VALID_SV | VALID_INT );
  197. $obj->{flags} |= VALID_NUM | SAVE_NUM;
  198. }
  199. sub set_numeric {
  200. my ( $obj, $expr ) = @_;
  201. if ( $obj->{type} == T_INT ) {
  202. $obj->set_int($expr);
  203. }
  204. else {
  205. $obj->set_double($expr);
  206. }
  207. }
  208. sub set_sv {
  209. my ( $obj, $expr ) = @_;
  210. runtime("SvSetSV($obj->{sv}, $expr);");
  211. $obj->invalidate;
  212. $obj->{flags} |= VALID_SV;
  213. }
  214. #
  215. # Stackobj::Padsv
  216. #
  217. @B::Stackobj::Padsv::ISA = 'B::Stackobj';
  218. sub B::Stackobj::Padsv::new {
  219. my ( $class, $type, $extra_flags, $ix, $iname, $dname ) = @_;
  220. $extra_flags |= SAVE_INT if $extra_flags & VALID_INT;
  221. $extra_flags |= SAVE_NUM if $extra_flags & VALID_NUM;
  222. bless {
  223. type => $type,
  224. flags => VALID_SV | $extra_flags,
  225. targ => $ix,
  226. sv => "PL_curpad[$ix]",
  227. iv => "$iname",
  228. nv => "$dname",
  229. }, $class;
  230. }
  231. sub B::Stackobj::Padsv::as_obj {
  232. my $obj = shift;
  233. my @c = comppadlist->ARRAY;
  234. my @p = $c[1]->ARRAY;
  235. return $p[ $obj->{targ} ];
  236. }
  237. sub B::Stackobj::Padsv::load_int {
  238. my $obj = shift;
  239. if ( $obj->{flags} & VALID_NUM ) {
  240. runtime("$obj->{iv} = $obj->{nv};");
  241. }
  242. else {
  243. runtime("$obj->{iv} = SvIV($obj->{sv});");
  244. }
  245. $obj->{flags} |= VALID_INT | SAVE_INT;
  246. }
  247. sub B::Stackobj::Padsv::load_double {
  248. my $obj = shift;
  249. $obj->write_back;
  250. runtime("$obj->{nv} = SvNV($obj->{sv});");
  251. $obj->{flags} |= VALID_NUM | SAVE_NUM;
  252. }
  253. sub B::Stackobj::Padsv::load_str {
  254. my $obj = shift;
  255. $obj->write_back;
  256. $obj->{flags} |= VALID_STR | SAVE_STR;
  257. }
  258. sub B::Stackobj::Padsv::save_int {
  259. my $obj = shift;
  260. return $obj->{flags} & SAVE_INT;
  261. }
  262. sub B::Stackobj::Padsv::save_double {
  263. my $obj = shift;
  264. return $obj->{flags} & SAVE_NUM;
  265. }
  266. sub B::Stackobj::Padsv::save_str {
  267. my $obj = shift;
  268. return $obj->{flags} & SAVE_STR;
  269. }
  270. sub B::Stackobj::Padsv::write_back {
  271. my $obj = shift;
  272. my $flags = $obj->{flags};
  273. return if $flags & VALID_SV;
  274. if ( $flags & VALID_INT ) {
  275. if ( $flags & VALID_UNSIGNED ) {
  276. runtime("sv_setuv($obj->{sv}, $obj->{iv});");
  277. }
  278. else {
  279. runtime("sv_setiv($obj->{sv}, $obj->{iv});");
  280. }
  281. }
  282. elsif ( $flags & VALID_NUM ) {
  283. runtime("sv_setnv($obj->{sv}, $obj->{nv});");
  284. }
  285. elsif ( $flags & VALID_STR ) {
  286. ;
  287. }
  288. else {
  289. confess "write_back failed for lexical @{[$obj->peek]}\n";
  290. }
  291. $obj->{flags} |= VALID_SV;
  292. }
  293. #
  294. # Stackobj::Const
  295. #
  296. @B::Stackobj::Const::ISA = 'B::Stackobj';
  297. sub B::Stackobj::Const::new {
  298. my ( $class, $sv ) = @_;
  299. my $obj = bless {
  300. flags => 0,
  301. sv => $sv, # holds the SV object until write_back happens
  302. obj => $sv
  303. }, $class;
  304. if ( ref($sv) eq "B::SPECIAL" ) {
  305. $obj->{type} = T_SPECIAL;
  306. }
  307. else {
  308. my $svflags = $sv->FLAGS;
  309. if ( $svflags & SVf_IOK ) {
  310. $obj->{flags} = VALID_INT | VALID_NUM;
  311. $obj->{type} = T_INT;
  312. if ( $svflags & SVf_IVisUV ) {
  313. $obj->{flags} |= VALID_UNSIGNED;
  314. $obj->{nv} = $obj->{iv} = $sv->UVX;
  315. }
  316. else {
  317. $obj->{nv} = $obj->{iv} = $sv->IV;
  318. }
  319. }
  320. elsif ( $svflags & SVf_NOK ) {
  321. $obj->{flags} = VALID_INT | VALID_NUM;
  322. $obj->{type} = T_NUM;
  323. $obj->{iv} = $obj->{nv} = $sv->NV;
  324. }
  325. elsif ( $svflags & SVf_POK ) {
  326. $obj->{flags} = VALID_STR;
  327. $obj->{type} = T_STR;
  328. $obj->{sv} = $sv;
  329. }
  330. else {
  331. $obj->{type} = T_UNKNOWN;
  332. }
  333. }
  334. return $obj;
  335. }
  336. sub B::Stackobj::Const::write_back {
  337. my $obj = shift;
  338. return if $obj->{flags} & VALID_SV;
  339. # Save the SV object and replace $obj->{sv} by its C source code name
  340. $obj->{sv} = $obj->{obj}->save;
  341. $obj->{flags} |= VALID_SV | VALID_INT | VALID_NUM;
  342. }
  343. sub B::Stackobj::Const::load_int {
  344. my $obj = shift;
  345. if ( ref( $obj->{obj} ) eq "B::RV" or ($] >= 5.011 and $obj->{obj}->FLAGS & SVf_ROK)) {
  346. $obj->{iv} = int( $obj->{obj}->RV->PV );
  347. }
  348. else {
  349. $obj->{iv} = int( $obj->{obj}->PV );
  350. }
  351. $obj->{flags} |= VALID_INT;
  352. }
  353. sub B::Stackobj::Const::load_double {
  354. my $obj = shift;
  355. if ( ref( $obj->{obj} ) eq "B::RV" ) {
  356. $obj->{nv} = $obj->{obj}->RV->PV + 0.0;
  357. }
  358. else {
  359. $obj->{nv} = $obj->{obj}->PV + 0.0;
  360. }
  361. $obj->{flags} |= VALID_NUM;
  362. }
  363. sub B::Stackobj::Const::load_str {
  364. my $obj = shift;
  365. if ( ref( $obj->{obj} ) eq "B::RV" ) {
  366. $obj->{sv} = $obj->{obj}->RV;
  367. }
  368. else {
  369. $obj->{sv} = $obj->{obj};
  370. }
  371. $obj->{flags} |= VALID_STR;
  372. }
  373. sub B::Stackobj::Const::invalidate { }
  374. #
  375. # Stackobj::Bool
  376. #
  377. ;
  378. @B::Stackobj::Bool::ISA = 'B::Stackobj';
  379. sub B::Stackobj::Bool::new {
  380. my ( $class, $preg ) = @_;
  381. my $obj = bless {
  382. type => T_INT,
  383. flags => VALID_INT | VALID_NUM,
  384. iv => $$preg,
  385. nv => $$preg,
  386. obj => $preg # this holds our ref to the pseudo-reg
  387. }, $class;
  388. return $obj;
  389. }
  390. sub B::Stackobj::Bool::write_back {
  391. my $obj = shift;
  392. return if $obj->{flags} & VALID_SV;
  393. $obj->{sv} = "($obj->{iv} ? &PL_sv_yes : &PL_sv_no)";
  394. $obj->{flags} |= VALID_SV;
  395. }
  396. # XXX Might want to handle as_double/set_double/load_double?
  397. sub B::Stackobj::Bool::invalidate { }
  398. #
  399. # Stackobj::Aelem
  400. #
  401. @B::Stackobj::Aelem::ISA = 'B::Stackobj';
  402. sub B::Stackobj::Aelem::new {
  403. my ( $class, $av, $ix, $lvalue ) = @_;
  404. my $sv;
  405. # pop ix before av
  406. if ($av eq 'POPs' and $ix eq 'POPi') {
  407. $sv = "({ int _ix = POPi; _ix >= 0 ? AvARRAY(POPs)[_ix] : *av_fetch((AV*)POPs, _ix, $lvalue); })";
  408. } elsif ($ix =~ /^-?[\d\.]+$/) {
  409. $sv = "AvARRAY($av)[$ix]";
  410. } else {
  411. $sv = "($ix >= 0 ? AvARRAY($av)[$ix] : *av_fetch((AV*)$av, $ix, $lvalue))";
  412. }
  413. my $obj = bless {
  414. type => T_UNKNOWN,
  415. flags => VALID_INT | VALID_NUM | VALID_SV,
  416. iv => "SvIVX($sv)",
  417. nv => "SvNVX($sv)",
  418. sv => "$sv",
  419. lvalue => $lvalue,
  420. }, $class;
  421. return $obj;
  422. }
  423. sub B::Stackobj::Aelem::write_back {
  424. my $obj = shift;
  425. $obj->{flags} |= VALID_SV | VALID_INT | VALID_NUM | VALID_STR;
  426. }
  427. sub B::Stackobj::Aelem::invalidate { }
  428. 1;
  429. __END__
  430. =head1 NAME
  431. B::Stackobj - Stack and type annotation helper module for the CC backend
  432. =head1 SYNOPSIS
  433. use B::Stackobj;
  434. =head1 DESCRIPTION
  435. A simple representation of pp stacks and lexical pads for the B::CC compiler.
  436. All locals and function arguments get type annotated, for all B::CC ops which
  437. can be optimized.
  438. For lexical pads (i.e. my or better our variables) we currently can force the type of
  439. variables according to a magic naming scheme in L<B::CC/load_pad>.
  440. my $<name>_i; IV integer
  441. my $<name>_ir; IV integer in a pseudo register
  442. my $<name>_d; NV double
  443. Future ideas are B<type qualifiers> as attributes
  444. B<num>, B<int>, B<register>, B<temp>, B<unsigned>, B<ro>
  445. such as in
  446. our int $i : unsigned : ro;
  447. our num $d;
  448. Type attributes for sub definitions are not spec'ed yet.
  449. L<Ctypes> attributes and objects should also be recognized, such as
  450. C<c_int> and C<c_double>.
  451. B<my vs our>: Note that only B<our> attributes are resolved at B<compile-time>,
  452. B<my> attributes are resolved at B<run-time>. So the compiler will only see
  453. type attributes for our variables.
  454. See L<B::CC/load_pad> and L<types>.
  455. TODO: Represent on this stack not only PADs,SV,IV,PV,NV,BOOL,Special
  456. and a SV const, but also GV,CV,RV,AV,HV, esp. AELEM and HELEM.
  457. Use B::Stackobj::Const.
  458. =head1 AUTHOR
  459. Malcolm Beattie C<MICB at cpan.org> I<(retired)>,
  460. Reini Urban C<rurban at cpan.org>
  461. =cut
  462. # Local Variables:
  463. # mode: cperl
  464. # cperl-indent-level: 2
  465. # fill-column: 78
  466. # End:
  467. # vim: expandtab shiftwidth=2: