CC.pm 110 KB

12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788899091929394959697989910010110210310410510610710810911011111211311411511611711811912012112212312412512612712812913013113213313413513613713813914014114214314414514614714814915015115215315415515615715815916016116216316416516616716816917017117217317417517617717817918018118218318418518618718818919019119219319419519619719819920020120220320420520620720820921021121221321421521621721821922022122222322422522622722822923023123223323423523623723823924024124224324424524624724824925025125225325425525625725825926026126226326426526626726826927027127227327427527627727827928028128228328428528628728828929029129229329429529629729829930030130230330430530630730830931031131231331431531631731831932032132232332432532632732832933033133233333433533633733833934034134234334434534634734834935035135235335435535635735835936036136236336436536636736836937037137237337437537637737837938038138238338438538638738838939039139239339439539639739839940040140240340440540640740840941041141241341441541641741841942042142242342442542642742842943043143243343443543643743843944044144244344444544644744844945045145245345445545645745845946046146246346446546646746846947047147247347447547647747847948048148248348448548648748848949049149249349449549649749849950050150250350450550650750850951051151251351451551651751851952052152252352452552652752852953053153253353453553653753853954054154254354454554654754854955055155255355455555655755855956056156256356456556656756856957057157257357457557657757857958058158258358458558658758858959059159259359459559659759859960060160260360460560660760860961061161261361461561661761861962062162262362462562662762862963063163263363463563663763863964064164264364464564664764864965065165265365465565665765865966066166266366466566666766866967067167267367467567667767867968068168268368468568668768868969069169269369469569669769869970070170270370470570670770870971071171271371471571671771871972072172272372472572672772872973073173273373473573673773873974074174274374474574674774874975075175275375475575675775875976076176276376476576676776876977077177277377477577677777877978078178278378478578678778878979079179279379479579679779879980080180280380480580680780880981081181281381481581681781881982082182282382482582682782882983083183283383483583683783883984084184284384484584684784884985085185285385485585685785885986086186286386486586686786886987087187287387487587687787887988088188288388488588688788888989089189289389489589689789889990090190290390490590690790890991091191291391491591691791891992092192292392492592692792892993093193293393493593693793893994094194294394494594694794894995095195295395495595695795895996096196296396496596696796896997097197297397497597697797897998098198298398498598698798898999099199299399499599699799899910001001100210031004100510061007100810091010101110121013101410151016101710181019102010211022102310241025102610271028102910301031103210331034103510361037103810391040104110421043104410451046104710481049105010511052105310541055105610571058105910601061106210631064106510661067106810691070107110721073107410751076107710781079108010811082108310841085108610871088108910901091109210931094109510961097109810991100110111021103110411051106110711081109111011111112111311141115111611171118111911201121112211231124112511261127112811291130113111321133113411351136113711381139114011411142114311441145114611471148114911501151115211531154115511561157115811591160116111621163116411651166116711681169117011711172117311741175117611771178117911801181118211831184118511861187118811891190119111921193119411951196119711981199120012011202120312041205120612071208120912101211121212131214121512161217121812191220122112221223122412251226122712281229123012311232123312341235123612371238123912401241124212431244124512461247124812491250125112521253125412551256125712581259126012611262126312641265126612671268126912701271127212731274127512761277127812791280128112821283128412851286128712881289129012911292129312941295129612971298129913001301130213031304130513061307130813091310131113121313131413151316131713181319132013211322132313241325132613271328132913301331133213331334133513361337133813391340134113421343134413451346134713481349135013511352135313541355135613571358135913601361136213631364136513661367136813691370137113721373137413751376137713781379138013811382138313841385138613871388138913901391139213931394139513961397139813991400140114021403140414051406140714081409141014111412141314141415141614171418141914201421142214231424142514261427142814291430143114321433143414351436143714381439144014411442144314441445144614471448144914501451145214531454145514561457145814591460146114621463146414651466146714681469147014711472147314741475147614771478147914801481148214831484148514861487148814891490149114921493149414951496149714981499150015011502150315041505150615071508150915101511151215131514151515161517151815191520152115221523152415251526152715281529153015311532153315341535153615371538153915401541154215431544154515461547154815491550155115521553155415551556155715581559156015611562156315641565156615671568156915701571157215731574157515761577157815791580158115821583158415851586158715881589159015911592159315941595159615971598159916001601160216031604160516061607160816091610161116121613161416151616161716181619162016211622162316241625162616271628162916301631163216331634163516361637163816391640164116421643164416451646164716481649165016511652165316541655165616571658165916601661166216631664166516661667166816691670167116721673167416751676167716781679168016811682168316841685168616871688168916901691169216931694169516961697169816991700170117021703170417051706170717081709171017111712171317141715171617171718171917201721172217231724172517261727172817291730173117321733173417351736173717381739174017411742174317441745174617471748174917501751175217531754175517561757175817591760176117621763176417651766176717681769177017711772177317741775177617771778177917801781178217831784178517861787178817891790179117921793179417951796179717981799180018011802180318041805180618071808180918101811181218131814181518161817181818191820182118221823182418251826182718281829183018311832183318341835183618371838183918401841184218431844184518461847184818491850185118521853185418551856185718581859186018611862186318641865186618671868186918701871187218731874187518761877187818791880188118821883188418851886188718881889189018911892189318941895189618971898189919001901190219031904190519061907190819091910191119121913191419151916191719181919192019211922192319241925192619271928192919301931193219331934193519361937193819391940194119421943194419451946194719481949195019511952195319541955195619571958195919601961196219631964196519661967196819691970197119721973197419751976197719781979198019811982198319841985198619871988198919901991199219931994199519961997199819992000200120022003200420052006200720082009201020112012201320142015201620172018201920202021202220232024202520262027202820292030203120322033203420352036203720382039204020412042204320442045204620472048204920502051205220532054205520562057205820592060206120622063206420652066206720682069207020712072207320742075207620772078207920802081208220832084208520862087208820892090209120922093209420952096209720982099210021012102210321042105210621072108210921102111211221132114211521162117211821192120212121222123212421252126212721282129213021312132213321342135213621372138213921402141214221432144214521462147214821492150215121522153215421552156215721582159216021612162216321642165216621672168216921702171217221732174217521762177217821792180218121822183218421852186218721882189219021912192219321942195219621972198219922002201220222032204220522062207220822092210221122122213221422152216221722182219222022212222222322242225222622272228222922302231223222332234223522362237223822392240224122422243224422452246224722482249225022512252225322542255225622572258225922602261226222632264226522662267226822692270227122722273227422752276227722782279228022812282228322842285228622872288228922902291229222932294229522962297229822992300230123022303230423052306230723082309231023112312231323142315231623172318231923202321232223232324232523262327232823292330233123322333233423352336233723382339234023412342234323442345234623472348234923502351235223532354235523562357235823592360236123622363236423652366236723682369237023712372237323742375237623772378237923802381238223832384238523862387238823892390239123922393239423952396239723982399240024012402240324042405240624072408240924102411241224132414241524162417241824192420242124222423242424252426242724282429243024312432243324342435243624372438243924402441244224432444244524462447244824492450245124522453245424552456245724582459246024612462246324642465246624672468246924702471247224732474247524762477247824792480248124822483248424852486248724882489249024912492249324942495249624972498249925002501250225032504250525062507250825092510251125122513251425152516251725182519252025212522252325242525252625272528252925302531253225332534253525362537253825392540254125422543254425452546254725482549255025512552255325542555255625572558255925602561256225632564256525662567256825692570257125722573257425752576257725782579258025812582258325842585258625872588258925902591259225932594259525962597259825992600260126022603260426052606260726082609261026112612261326142615261626172618261926202621262226232624262526262627262826292630263126322633263426352636263726382639264026412642264326442645264626472648264926502651265226532654265526562657265826592660266126622663266426652666266726682669267026712672267326742675267626772678267926802681268226832684268526862687268826892690269126922693269426952696269726982699270027012702270327042705270627072708270927102711271227132714271527162717271827192720272127222723272427252726272727282729273027312732273327342735273627372738273927402741274227432744274527462747274827492750275127522753275427552756275727582759276027612762276327642765276627672768276927702771277227732774277527762777277827792780278127822783278427852786278727882789279027912792279327942795279627972798279928002801280228032804280528062807280828092810281128122813281428152816281728182819282028212822282328242825282628272828282928302831283228332834283528362837283828392840284128422843284428452846284728482849285028512852285328542855285628572858285928602861286228632864286528662867286828692870287128722873287428752876287728782879288028812882288328842885288628872888288928902891289228932894289528962897289828992900290129022903290429052906290729082909291029112912291329142915291629172918291929202921292229232924292529262927292829292930293129322933293429352936293729382939294029412942294329442945294629472948294929502951295229532954295529562957295829592960296129622963296429652966296729682969297029712972297329742975297629772978297929802981298229832984298529862987298829892990299129922993299429952996299729982999300030013002300330043005300630073008300930103011301230133014301530163017301830193020302130223023302430253026302730283029303030313032303330343035303630373038303930403041304230433044304530463047304830493050305130523053305430553056305730583059306030613062306330643065306630673068306930703071307230733074307530763077307830793080308130823083308430853086308730883089309030913092309330943095309630973098309931003101310231033104310531063107310831093110311131123113311431153116311731183119312031213122312331243125312631273128312931303131313231333134313531363137313831393140314131423143314431453146314731483149315031513152315331543155315631573158315931603161316231633164316531663167316831693170317131723173317431753176317731783179318031813182318331843185318631873188318931903191319231933194319531963197319831993200320132023203320432053206320732083209321032113212321332143215321632173218321932203221322232233224322532263227322832293230323132323233323432353236323732383239324032413242324332443245324632473248324932503251325232533254325532563257325832593260326132623263326432653266326732683269327032713272327332743275327632773278327932803281328232833284328532863287328832893290329132923293329432953296329732983299330033013302330333043305330633073308330933103311331233133314331533163317331833193320332133223323332433253326332733283329333033313332333333343335333633373338333933403341334233433344334533463347334833493350335133523353335433553356335733583359336033613362336333643365336633673368336933703371337233733374337533763377337833793380338133823383338433853386338733883389339033913392339333943395339633973398339934003401340234033404340534063407340834093410341134123413341434153416341734183419342034213422342334243425342634273428342934303431343234333434343534363437343834393440344134423443344434453446344734483449345034513452345334543455345634573458345934603461346234633464346534663467346834693470347134723473347434753476347734783479348034813482348334843485348634873488348934903491349234933494349534963497349834993500350135023503350435053506350735083509351035113512351335143515351635173518351935203521352235233524352535263527352835293530353135323533353435353536353735383539354035413542354335443545354635473548354935503551355235533554355535563557355835593560356135623563356435653566356735683569357035713572357335743575357635773578357935803581358235833584358535863587358835893590359135923593359435953596359735983599360036013602360336043605360636073608360936103611361236133614361536163617361836193620362136223623362436253626362736283629363036313632363336343635363636373638363936403641364236433644364536463647364836493650365136523653365436553656365736583659366036613662366336643665366636673668366936703671367236733674367536763677367836793680368136823683368436853686368736883689369036913692369336943695369636973698369937003701370237033704370537063707370837093710371137123713371437153716371737183719372037213722372337243725372637273728372937303731373237333734373537363737373837393740374137423743374437453746
  1. # CC.pm
  2. #
  3. # Copyright (c) 1996, 1997, 1998 Malcolm Beattie
  4. # Copyright (c) 2009, 2010, 2011 Reini Urban
  5. # Copyright (c) 2010 Heinz Knutzen
  6. # Copyright (c) 2012-2015 cPanel Inc
  7. #
  8. # You may distribute under the terms of either the GNU General Public
  9. # License or the Artistic License, as specified in the README file.
  10. =head1 NAME
  11. B::CC - Perl compiler's optimized C translation backend
  12. =head1 SYNOPSIS
  13. perl -MO=CC[,OPTIONS] foo.pl
  14. =head1 DESCRIPTION
  15. This compiler backend takes Perl source and generates C source code
  16. corresponding to the flow of your program with unrolled ops and optimised
  17. stack handling and lexicals variable types. In other words, this backend is
  18. somewhat a "real" compiler in the sense that many people think about
  19. compilers. Note however that, currently, it is a very poor compiler in that
  20. although it generates (mostly, or at least sometimes) correct code, it
  21. performs relatively few optimisations. This will change as the compiler and
  22. the types develops. The result is that running an executable compiled with
  23. this backend may start up more quickly than running the original Perl program
  24. (a feature shared by the B<C> compiler backend--see L<B::C>) and may also
  25. execute slightly faster. This is by no means a good optimising compiler--yet.
  26. =head1 OPTIONS
  27. If there are any non-option arguments, they are taken to be
  28. names of objects to be saved (probably doesn't work properly yet).
  29. Without extra arguments, it saves the main program.
  30. =over 4
  31. =item B<-ofilename>
  32. Output to filename instead of STDOUT
  33. =item B<-c>
  34. Check and abort.
  35. Compiles and prints only warnings, but does not emit C code.
  36. =item B<-v>
  37. Verbose compilation (prints a few compilation stages).
  38. =item B<-->
  39. Force end of options
  40. =item B<-uPackname>
  41. Force apparently unused subs from package Packname to be compiled.
  42. This allows programs to use eval "foo()" even when sub foo is never
  43. seen to be used at compile time. The down side is that any subs which
  44. really are never used also have code generated. This option is
  45. necessary, for example, if you have a signal handler foo which you
  46. initialise with C<$SIG{BAR} = "foo">. A better fix, though, is just
  47. to change it to C<$SIG{BAR} = \&foo>. You can have multiple B<-u>
  48. options. The compiler tries to figure out which packages may possibly
  49. have subs in which need compiling but the current version doesn't do
  50. it very well. In particular, it is confused by nested packages (i.e.
  51. of the form C<A::B>) where package C<A> does not contain any subs.
  52. =item B<-UPackname> "unuse" skip Package
  53. Ignore all subs from Package to be compiled.
  54. Certain packages might not be needed at run-time, even if the pessimistic
  55. walker detects it.
  56. =item B<-mModulename>
  57. Instead of generating source for a runnable executable, generate
  58. source for an XSUB module. The boot_Modulename function (which
  59. DynaLoader can look for) does the appropriate initialisation and runs
  60. the main part of the Perl source that is being compiled.
  61. =item B<-nInitname>
  62. Provide a different init name for additional objects added via cmdline.
  63. =item B<-strict>
  64. With a DEBUGGING perl compile-time errors for range and flip without
  65. compile-time context are only warnings.
  66. With C<-strict> these warnings are fatal, otherwise only run-time errors occur.
  67. =item B<-On>
  68. Optimisation level (n = 0, 1, 2). B<-O> means B<-O1>.
  69. The following L<B::C> optimisations are applied automatically:
  70. optimize_warn_sv save_data_fh av-init2|av_init save_sig destruct
  71. pv_copy_on_grow
  72. B<-O1> sets B<-ffreetmps-each-bblock>.
  73. B<-O2> adds B<-ffreetmps-each-loop>, C<-faelem> and B<-fno-destruct> from L<B::C>.
  74. The following options must be set explicitly:
  75. B<-fno-taint> or B<-fomit-taint>,
  76. B<-fslow-signals>,
  77. B<-no-autovivify>,
  78. B<-fno-magic>.
  79. =item B<-f>C<OPTIM>
  80. Force optimisations on or off one at a time.
  81. Unknown optimizations are passed down to L<B::C>.
  82. =item B<-ffreetmps-each-bblock>
  83. Delays FREETMPS from the end of each statement to the end of the each
  84. basic block.
  85. Enabled with B<-O1>.
  86. =item B<-ffreetmps-each-loop>
  87. Delays FREETMPS from the end of each statement to the end of the group
  88. of basic blocks forming a loop. At most one of the freetmps-each-*
  89. options can be used.
  90. Enabled with B<-O2>.
  91. =item B<-faelem>
  92. Enable array element access optimizations, allowing unchecked
  93. fast access under certain circumstances.
  94. Enabled with B<-O2> and not-threaded perls only.
  95. =item B<-fno-inline-ops>
  96. Do not inline calls to certain small pp ops.
  97. Most of the inlinable ops were already inlined.
  98. Turns off inlining for some new ops.
  99. AUTOMATICALLY inlined:
  100. pp_null pp_stub pp_unstack pp_and pp_andassign pp_or pp_orassign pp_cond_expr
  101. pp_padsv pp_const pp_nextstate pp_dbstate pp_rv2gv pp_sort pp_gv pp_gvsv
  102. pp_aelemfast pp_ncmp pp_add pp_subtract pp_multiply pp_divide pp_modulo
  103. pp_left_shift pp_right_shift pp_i_add pp_i_subtract pp_i_multiply pp_i_divide
  104. pp_i_modulo pp_eq pp_ne pp_lt pp_gt pp_le pp_ge pp_i_eq pp_i_ne pp_i_lt
  105. pp_i_gt pp_i_le pp_i_ge pp_scmp pp_slt pp_sgt pp_sle pp_sge pp_seq pp_sne
  106. pp_sassign pp_preinc pp_pushmark pp_list pp_entersub pp_formline pp_goto
  107. pp_enterwrite pp_leavesub pp_leavewrite pp_entergiven pp_leavegiven
  108. pp_entereval pp_dofile pp_require pp_entertry pp_leavetry pp_grepstart
  109. pp_mapstart pp_grepwhile pp_mapwhile pp_return pp_range pp_flip pp_flop
  110. pp_enterloop pp_enteriter pp_leaveloop pp_next pp_redo pp_last pp_subst
  111. pp_substcont
  112. DONE with -finline-ops:
  113. pp_enter pp_reset pp_regcreset pp_stringify
  114. TODO with -finline-ops:
  115. pp_anoncode pp_wantarray pp_srefgen pp_refgen pp_ref pp_trans pp_schop pp_chop
  116. pp_schomp pp_chomp pp_not pp_sprintf pp_anonlist pp_shift pp_once pp_lock
  117. pp_rcatline pp_close pp_time pp_alarm pp_av2arylen: no lvalue, pp_length: no
  118. magic
  119. =item B<-fomit-taint>
  120. Omits generating code for handling perl's tainting mechanism.
  121. =item B<-fslow-signals>
  122. Add PERL_ASYNC_CHECK after every op as in the old Perl runloop before 5.13.
  123. perl "Safe signals" check the state of incoming signals after every op.
  124. See L<http://perldoc.perl.org/perlipc.html#Deferred-Signals-(Safe-Signals)>
  125. We trade safety for more speed and delay the execution of non-IO signals
  126. (IO signals are already handled in PerlIO) from after every single Perl op
  127. to the same ops as used in 5.14.
  128. Only with -fslow-signals we get the old slow and safe behaviour.
  129. =item B<-fno-name-magic>
  130. With the default C<-fname-magic> we infer the SCALAR type for specially named
  131. locals vars and most ops use C vars then, not the perl vars.
  132. Arithmetic and comparison is inlined. Scalar magic is bypassed.
  133. With C<-fno-name-magic> do not infer a local variable type from its name:
  134. B<_i> suffix for int, B<_d> for double/num, B<_ir> for register int
  135. See the experimental C<-ftype-attr> type attributes.
  136. Currently supported are B<int> and B<num> only. See </load_pad>.
  137. =item B<-ftype-attr> (DOES NOT WORK YET)
  138. Experimentally support B<type attributes> for B<int> and B<num>,
  139. SCALAR only so far.
  140. For most ops new C vars are used then, not the fat perl vars.
  141. Very awkward to use until the basic type classes are supported from
  142. within core or use types.
  143. Enabled with B<-O2>. See L<TYPES> and </load_pad>.
  144. =item B<-fno-autovivify>
  145. Do not vivify array and soon also hash elements when accessing them.
  146. Beware: Vivified elements default to undef, unvivified elements are
  147. invalid.
  148. This is the same as the pragma "no autovivification" and allows
  149. very fast array accesses, 4-6 times faster, without the overhead of
  150. L<autovivification>.
  151. =item B<-fno-magic>
  152. Assume certain data being optimized is never tied or is holding other magic.
  153. This mainly holds for arrays being optimized, but in the future hashes also.
  154. =item B<-D>
  155. Debug options (concatenated or separate flags like C<perl -D>).
  156. Verbose debugging options are crucial, because the interactive
  157. debugger L<Od> adds a lot of ballast to the resulting code.
  158. =item B<-Dr>
  159. Writes debugging output to STDERR just as it's about to write to the
  160. program's runtime (otherwise writes debugging info as comments in
  161. its C output).
  162. =item B<-DO>
  163. Outputs each OP as it's compiled
  164. =item B<-DT>
  165. Outputs the contents of the B<stack> at each OP.
  166. Values are B::Stackobj objects.
  167. =item B<-Dc>
  168. Outputs the contents of the loop B<context stack>, the @cxstack.
  169. =item B<-Dw>
  170. Outputs the contents of the B<shadow> stack at each OP.
  171. =item B<-Da>
  172. Outputs the contents of the shadow pad of lexicals as it's loaded for
  173. each sub or the main program.
  174. =item B<-Dq>
  175. Outputs the name of each fake PP function in the queue as it's about
  176. to process it.
  177. =item B<-Dl>
  178. Output the filename and line number of each original line of Perl
  179. code as it's processed (C<pp_nextstate>).
  180. =item B<-Dt>
  181. Outputs timing information of compilation stages.
  182. =item B<-DF>
  183. Add Flags info to the code.
  184. =back
  185. =head1 NOTABLE FUNCTIONS
  186. =cut
  187. package B::CC;
  188. our $VERSION = '1.16_01';
  189. # Start registering the L<types> namespaces.
  190. use strict;
  191. our %Config;
  192. BEGIN {
  193. require B::C::Config;
  194. *Config = \%B::C::Config::Config;
  195. # make it a restricted hash
  196. Internals::SvREADONLY(%Config, 1) if $] >= 5.008004;
  197. }
  198. unless ($Config{usecperl}) {
  199. eval '$main::int::B_CC = $main::num::B_CC = $main::str::B_CC = $main::double::B_CC = $main::string::B_CC = $VERSION;';
  200. }
  201. #use 5.008;
  202. use B qw(main_start main_root class comppadlist peekop svref_2object
  203. timing_info init_av end_av sv_undef
  204. OPf_WANT_VOID OPf_WANT_SCALAR OPf_WANT_LIST OPf_WANT
  205. OPf_MOD OPf_STACKED OPf_SPECIAL OPpLVAL_DEFER OPpLVAL_INTRO
  206. OPpASSIGN_BACKWARDS OPpLVAL_INTRO OPpDEREF_AV OPpDEREF_HV
  207. OPpDEREF OPpFLIP_LINENUM G_VOID G_SCALAR G_ARRAY);
  208. #CXt_NULL CXt_SUB CXt_EVAL CXt_SUBST CXt_BLOCK
  209. use B::C qw(save_unused_subs objsym init_sections mark_unused mark_skip
  210. output_all output_boilerplate output_main output_main_rest fixup_ppaddr save_sig
  211. svop_or_padop_pv inc_cleanup curcv set_curcv);
  212. use B::Bblock qw(find_leaders);
  213. use B::Stackobj qw(:types :flags);
  214. use B::C::Config;
  215. # use attributes qw(get reftype);
  216. @B::OP::ISA = qw(B); # support -Do
  217. @B::LISTOP::ISA = qw(B::BINOP B); # support -Do
  218. push @B::OP::ISA, 'B::NULLOP' if exists $main::B::{'NULLOP'};
  219. # These should probably be elsewhere
  220. # Flags for $op->flags
  221. my $module; # module name (when compiled with -m)
  222. my %done; # hash keyed by $$op of leaders of basic blocks
  223. # which have already been done.
  224. my $leaders; # ref to hash of basic block leaders. Keys are $$op
  225. # addresses, values are the $op objects themselves.
  226. my @bblock_todo; # list of leaders of basic blocks that need visiting
  227. # sometime.
  228. my @cc_todo; # list of tuples defining what PP code needs to be
  229. # saved (e.g. CV, main or PMOP repl code). Each tuple
  230. # is [$name, $root, $start, @padlist]. PMOP repl code
  231. # tuples inherit padlist.
  232. my %cc_pp_sub; # hashed names of pp_sub functions already saved
  233. my @stack; # shadows perl's stack when contents are known.
  234. # Values are objects derived from class B::Stackobj
  235. my @pad; # Lexicals in current pad as Stackobj-derived objects
  236. my @padlist; # Copy of current padlist so PMOP repl code can find it
  237. my @cxstack; # Shadows the (compile-time) cxstack for next,last,redo
  238. # This covers only a small part of the perl cxstack
  239. my $labels; # hashref to array of op labels
  240. my %constobj; # OP_CONST constants as Stackobj-derived objects
  241. # keyed by $$sv.
  242. my $need_freetmps = 0; # We may postpone FREETMPS to the end of each basic
  243. # block or even to the end of each loop of blocks,
  244. # depending on optimisation options.
  245. my $know_op = 0; # Set when C variable op already holds the right op
  246. # (from an immediately preceding DOOP(ppname)).
  247. my $errors = 0; # Number of errors encountered
  248. my $op_count = 0; # for B::compile_stats on verbose
  249. my %no_stack; # PP names which don't need save pp restore stack
  250. my %skip_stack; # PP names which don't need write_back_stack (empty)
  251. my %skip_lexicals; # PP names which don't need write_back_lexicals
  252. my %skip_invalidate; # PP names which don't need invalidate_lexicals
  253. my %ignore_op; # ops which do nothing except returning op_next
  254. my %need_curcop; # ops which need PL_curcop
  255. my $package_pv; # sv->pv of previous op for method_named
  256. my %lexstate; # state of padsvs at the start of a bblock
  257. my ( $verbose, $check );
  258. my ( $entertry_defined, $vivify_ref_defined );
  259. my ( $init_name, %debug, $strict );
  260. # Optimisation options. On the command line, use hyphens instead of
  261. # underscores for compatibility with gcc-style options. We use
  262. # underscores here because they are OK in (strict) barewords.
  263. # Disable with -fno-
  264. my ( $freetmps_each_bblock, $freetmps_each_loop, $inline_ops, $opt_taint, $opt_omit_taint,
  265. $opt_slow_signals, $opt_name_magic, $opt_type_attr, $opt_autovivify, $opt_magic,
  266. $opt_aelem, %c_optimise );
  267. $inline_ops = 1 unless $^O eq 'MSWin32'; # Win32 cannot link to unexported pp_op() XXX
  268. $opt_name_magic = 1;
  269. my %optimise = (
  270. freetmps_each_bblock => \$freetmps_each_bblock, # -O1
  271. freetmps_each_loop => \$freetmps_each_loop, # -O2
  272. aelem => \$opt_aelem, # -O2
  273. inline_ops => \$inline_ops, # not on Win32
  274. omit_taint => \$opt_omit_taint,
  275. taint => \$opt_taint,
  276. slow_signals => \$opt_slow_signals,
  277. name_magic => \$opt_name_magic,
  278. type_attr => \$opt_type_attr,
  279. autovivify => \$opt_autovivify,
  280. magic => \$opt_magic,
  281. );
  282. my %async_signals = map { $_ => 1 } # 5.14 ops which do PERL_ASYNC_CHECK
  283. qw(wait waitpid nextstate and cond_expr unstack or subst dorassign);
  284. $async_signals{$_} = 1 for # more 5.16 ops which do PERL_ASYNC_CHECK
  285. qw(substcont next redo goto leavewhen);
  286. # perl patchlevel to generate code for (defaults to current patchlevel)
  287. my $patchlevel = int( 0.5 + 1000 * ( $] - 5 ) ); # XXX unused?
  288. my $MULTI = $Config{usemultiplicity};
  289. my $ITHREADS = $Config{useithreads};
  290. my $PERL510 = ( $] >= 5.009005 );
  291. my $PERL512 = ( $] >= 5.011 );
  292. my $SVt_PVLV = $PERL510 ? 10 : 9;
  293. my $SVt_PVAV = $PERL510 ? 11 : 10;
  294. # use sub qw(CXt_LOOP_PLAIN CXt_LOOP);
  295. BEGIN {
  296. if ($PERL512) {
  297. sub CXt_LOOP_PLAIN {5} # CXt_LOOP_FOR CXt_LOOP_LAZYSV CXt_LOOP_LAZYIV
  298. } else {
  299. sub CXt_LOOP {3}
  300. }
  301. sub CxTYPE_no_LOOP {
  302. $PERL512
  303. ? ( $_[0]->{type} < 4 or $_[0]->{type} > 7 )
  304. : $_[0]->{type} != 3
  305. }
  306. if ($] < 5.008) {
  307. eval "sub SVs_RMG {0x8000};";
  308. } else {
  309. B->import('SVs_RMG');
  310. }
  311. if ($] <= 5.010) {
  312. eval "sub PMf_ONCE() {0xff}; # unused";
  313. } elsif ($] >= 5.018) { # PMf_ONCE not exported
  314. eval q[sub PMf_ONCE(){ 0x10000 }];
  315. } elsif ($] >= 5.014) {
  316. eval q[sub PMf_ONCE(){ 0x8000 }];
  317. } elsif ($] >= 5.012) {
  318. eval q[sub PMf_ONCE(){ 0x0080 }];
  319. } else { # 5.10. not used with <= 5.8
  320. eval q[sub PMf_ONCE(){ 0x0002 }];
  321. }
  322. }
  323. # Could rewrite push_runtime() and output_runtime() to use a
  324. # temporary file if memory is at a premium.
  325. my $ppname; # name of current fake PP function
  326. my $runtime_list_ref;
  327. my $declare_ref; # Hash ref keyed by C variable type of declarations.
  328. my @pp_list; # list of [$ppname, $runtime_list_ref, $declare_ref]
  329. # tuples to be written out.
  330. my ( $init, $decl );
  331. sub init_hash {
  332. map { $_ => 1 } @_;
  333. }
  334. # Initialise the hashes for the default PP functions where we can avoid
  335. # either stack save/restore,write_back_stack, write_back_lexicals or invalidate_lexicals.
  336. # XXX We should really take some of this info from Opcodes (was: CORE opcode.pl)
  337. #
  338. # no args and no return value = Opcodes::argnum 0
  339. %no_stack = init_hash qw(pp_unstack pp_break pp_continue);
  340. # pp_enter pp_leave, use/change global stack.
  341. #skip write_back_stack (no args)
  342. %skip_stack = init_hash qw(pp_enter pp_leave pp_nextstate pp_dbstate);
  343. # which ops do not read pad vars
  344. %skip_lexicals = init_hash qw(pp_enter pp_enterloop pp_leave pp_nextstate pp_dbstate);
  345. # which ops no not write to pad vars
  346. %skip_invalidate = init_hash qw(pp_enter pp_enterloop pp_leave pp_nextstate pp_dbstate
  347. pp_return pp_leavesub pp_list pp_pushmark
  348. pp_anonlist
  349. );
  350. %need_curcop = init_hash qw(pp_rv2gv pp_bless pp_repeat pp_sort pp_caller
  351. pp_reset pp_rv2cv pp_entereval pp_require pp_dofile
  352. pp_entertry pp_enterloop pp_enteriter pp_entersub pp_entergiven
  353. pp_enter pp_method);
  354. %ignore_op = init_hash qw(pp_scalar pp_regcmaybe pp_lineseq pp_scope pp_null);
  355. { # block necessary for caller to work
  356. my $caller = caller;
  357. if ( $caller eq 'O' ) {
  358. require XSLoader;
  359. XSLoader::load('B::C'); # for r-magic only
  360. }
  361. }
  362. sub debug {
  363. if ( $debug{runtime} ) {
  364. # TODO: fix COP to callers line number
  365. warn(@_) if $verbose;
  366. }
  367. else {
  368. my @tmp = @_;
  369. runtime( map { chomp; "/* $_ */" } @tmp );
  370. }
  371. }
  372. sub declare {
  373. my ( $type, $var ) = @_;
  374. push( @{ $declare_ref->{$type} }, $var );
  375. }
  376. sub push_runtime {
  377. push( @$runtime_list_ref, @_ );
  378. warn join( "\n", @_ ) . "\n" if $debug{runtime};
  379. }
  380. sub save_runtime {
  381. push( @pp_list, [ $ppname, $runtime_list_ref, $declare_ref ] );
  382. }
  383. sub output_runtime {
  384. my $ppdata;
  385. print qq(\n#include "cc_runtime.h"\n);
  386. # CC coverage: 12, 32
  387. # Perls >=5.8.9 have a broken PP_ENTERTRY. See PERL_FLEXIBLE_EXCEPTIONS in cop.h
  388. # Fixed in CORE with 5.11.4
  389. print'
  390. #undef PP_ENTERTRY
  391. #define PP_ENTERTRY(label) \
  392. STMT_START { \
  393. dJMPENV; \
  394. int ret; \
  395. JMPENV_PUSH(ret); \
  396. switch (ret) { \
  397. case 1: JMPENV_POP; JMPENV_JUMP(1);\
  398. case 2: JMPENV_POP; JMPENV_JUMP(2);\
  399. case 3: JMPENV_POP; SPAGAIN; goto label;\
  400. } \
  401. } STMT_END'
  402. if $entertry_defined and $] < 5.011004;
  403. # XXX need to find out when PERL_FLEXIBLE_EXCEPTIONS were actually active.
  404. # 5.6.2 not, 5.8.9 not. coverage 32
  405. # test 12. Used by entereval + dofile
  406. if ($PERL510 or $MULTI) {
  407. # Threads error Bug#55302: too few arguments to function
  408. # CALLRUNOPS()=>CALLRUNOPS(aTHX)
  409. # fixed with 5.11.4
  410. print '
  411. #undef PP_EVAL
  412. #define PP_EVAL(ppaddr, nxt) do { \
  413. dJMPENV; \
  414. int ret; \
  415. PUTBACK; \
  416. JMPENV_PUSH(ret); \
  417. switch (ret) { \
  418. case 0: \
  419. PL_op = ppaddr(aTHX); \\';
  420. if ($PERL510) {
  421. # pp_leaveeval sets: retop = cx->blk_eval.retop
  422. print '
  423. cxstack[cxstack_ix].blk_eval.retop = Nullop; \\';
  424. } else {
  425. # up to 5.8 pp_entereval did set the retstack to next.
  426. # nullify that so that we can now exec the rest of this bblock.
  427. # (nextstate .. leaveeval)
  428. print '
  429. PL_retstack[PL_retstack_ix - 1] = Nullop; \\';
  430. }
  431. print '
  432. if (PL_op != nxt) CALLRUNOPS(aTHX); \
  433. JMPENV_POP; \
  434. break; \
  435. case 1: JMPENV_POP; JMPENV_JUMP(1); \
  436. case 2: JMPENV_POP; JMPENV_JUMP(2); \
  437. case 3: \
  438. JMPENV_POP; \
  439. if (PL_restartop && PL_restartop != nxt) \
  440. JMPENV_JUMP(3); \
  441. } \
  442. PL_op = nxt; \
  443. SPAGAIN; \
  444. } while (0)
  445. ';
  446. }
  447. # Perl_vivify_ref not exported on MSWin32
  448. # coverage: 18
  449. if ($PERL510 and $^O eq 'MSWin32') {
  450. # CC coverage: 18, 29
  451. print << '__EOV' if $vivify_ref_defined;
  452. /* Code to take a scalar and ready it to hold a reference */
  453. # ifndef SVt_RV
  454. # define SVt_RV SVt_IV
  455. # endif
  456. # define prepare_SV_for_RV(sv) \
  457. STMT_START { \
  458. if (SvTYPE(sv) < SVt_RV) \
  459. sv_upgrade(sv, SVt_RV); \
  460. else if (SvPVX_const(sv)) { \
  461. SvPV_free(sv); \
  462. SvLEN_set(sv, 0); \
  463. SvCUR_set(sv, 0); \
  464. } \
  465. } STMT_END
  466. #if (PERL_VERSION > 15) || ((PERL_VERSION == 15) && (PERL_SUBVERSION >= 2))
  467. SV*
  468. #else
  469. void
  470. #endif
  471. Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
  472. {
  473. SvGETMAGIC(sv);
  474. if (!SvOK(sv)) {
  475. if (SvREADONLY(sv))
  476. Perl_croak(aTHX_ "%s", PL_no_modify);
  477. prepare_SV_for_RV(sv);
  478. switch (to_what) {
  479. case OPpDEREF_SV:
  480. SvRV_set(sv, newSV(0));
  481. break;
  482. case OPpDEREF_AV:
  483. SvRV_set(sv, newAV());
  484. break;
  485. case OPpDEREF_HV:
  486. SvRV_set(sv, newHV());
  487. break;
  488. }
  489. SvROK_on(sv);
  490. SvSETMAGIC(sv);
  491. }
  492. }
  493. __EOV
  494. }
  495. print '
  496. OP *Perl_pp_aelem_nolval(pTHXx);
  497. #ifndef SVfARG
  498. # define SVfARG(x) (void *)x
  499. #endif
  500. #ifndef MUTABLE_AV
  501. # define MUTABLE_AV(av) av
  502. #endif
  503. PP(pp_aelem_nolval)
  504. {
  505. dSP;
  506. SV** svp;
  507. SV* const elemsv = POPs;
  508. IV elem = SvIV(elemsv);
  509. AV *const av = MUTABLE_AV(POPs);
  510. SV *sv;
  511. #if PERL_VERSION > 6
  512. if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
  513. Perl_warner(aTHX_ packWARN(WARN_MISC),
  514. "Use of reference \"%"SVf"\" as array index",
  515. SVfARG(elemsv));
  516. #endif
  517. if (SvTYPE(av) != SVt_PVAV) RETPUSHUNDEF;
  518. svp = av_fetch(av, elem, 0);
  519. sv = (svp ? *svp : &PL_sv_undef);
  520. if (SvRMAGICAL(av) && SvGMAGICAL(sv)) mg_get(sv);
  521. PUSHs(sv);
  522. RETURN;
  523. }
  524. ' if 0;
  525. foreach $ppdata (@pp_list) {
  526. my ( $name, $runtime, $declare ) = @$ppdata;
  527. print "\nstatic\nCCPP($name)\n{\n";
  528. my ( $type, $varlist, $line );
  529. while ( ( $type, $varlist ) = each %$declare ) {
  530. $varlist = $declare->{$type};
  531. print "\t$type ", join( ", ", @$varlist ), ";\n";
  532. }
  533. foreach $line (@$runtime) {
  534. print $line, "\n";
  535. }
  536. print "}\n";
  537. }
  538. }
  539. sub runtime {
  540. my $line;
  541. foreach $line (@_) {
  542. push_runtime("\t$line");
  543. }
  544. }
  545. sub init_pp {
  546. $ppname = shift;
  547. $runtime_list_ref = [];
  548. $declare_ref = {};
  549. runtime("dSP;");
  550. declare( "I32", "oldsave" );
  551. map { declare( "SV", "*$_" ) } qw(sv src dst left right);
  552. declare( "MAGIC", "*mg" );
  553. $decl->add( "#undef cxinc", "#define cxinc() Perl_cxinc(aTHX)")
  554. if $] < 5.011001 and $inline_ops;
  555. declare( "PERL_CONTEXT", "*cx" );
  556. declare( "I32", "gimme");
  557. $decl->add("static OP * $ppname (pTHX);");
  558. debug "init_pp: $ppname\n" if $debug{queue};
  559. }
  560. # Initialise runtime_callback function for Stackobj class
  561. BEGIN { B::Stackobj::set_callback( \&runtime ) }
  562. =head2 cc_queue
  563. Creates a new ccpp optree.
  564. Initialised by saveoptree_callback in L<B::C>, replaces B::C::walk_and_save_optree.
  565. Called by every C<CV::save> if ROOT.
  566. B<blocksort> also creates its block closure with cc_queue.
  567. =cut
  568. # coverage: test 18, 28 (fixed with B-C-1.30 r971)
  569. sub cc_queue {
  570. my ( $name, $root, $start, @pl ) = @_;
  571. debug "cc_queue: name $name, root $root, start $start, padlist (@pl)\n"
  572. if $debug{queue};
  573. if ( $name eq "*ignore*" or $name =~ /^pp_sub_.*(FETCH|MODIFY)_SCALAR_ATTRIBUTES$/) {
  574. $name = '';
  575. } else {
  576. push( @cc_todo, [ $name, $root, $start, ( @pl ? @pl : @padlist ) ] );
  577. }
  578. my $fakeop_next = 0;
  579. if ($name =~ /^pp_sub_.*DESTROY$/) {
  580. # curse in sv_clean_objs() checks for ->op_next->op_type
  581. $fakeop_next = $start->next->save;
  582. }
  583. my $fakeop = B::FAKEOP->new( "next" => $fakeop_next, sibling => 0, ppaddr => $name,
  584. targ=>0, type=>0, flags=>0, private=>0);
  585. $start = $fakeop->save;
  586. debug "cc_queue: name $name returns $start\n" if $debug{queue};
  587. return $start;
  588. }
  589. BEGIN { B::C::set_callback( \&cc_queue ) }
  590. sub valid_int { $_[0]->{flags} & VALID_INT }
  591. sub valid_double { $_[0]->{flags} & VALID_NUM }
  592. sub valid_numeric { $_[0]->{flags} & ( VALID_INT | VALID_NUM ) }
  593. sub valid_str { $_[0]->{flags} & VALID_STR }
  594. sub valid_sv { $_[0]->{flags} & VALID_SV }
  595. sub top_int { @stack ? $stack[-1]->as_int : "TOPi" }
  596. sub top_double { @stack ? $stack[-1]->as_double : "TOPn" }
  597. sub top_numeric { @stack ? $stack[-1]->as_numeric : "TOPn" }
  598. sub top_sv { @stack ? $stack[-1]->as_sv : "TOPs" }
  599. sub top_str { @stack ? $stack[-1]->as_str : "TOPs" }
  600. sub top_bool { @stack ? $stack[-1]->as_bool : "SvTRUE(TOPs)" }
  601. sub pop_int { @stack ? ( pop @stack )->as_int : "POPi" }
  602. sub pop_double { @stack ? ( pop @stack )->as_double : "POPn" }
  603. sub pop_numeric { @stack ? ( pop @stack )->as_numeric : "POPn" }
  604. sub pop_str { @stack ? ( pop @stack )->as_str : "POPs" }
  605. sub pop_sv { @stack ? ( pop @stack )->as_sv : "POPs" }
  606. sub pop_bool {
  607. if (@stack) {
  608. return ( ( pop @stack )->as_bool );
  609. }
  610. else {
  611. # Careful: POPs has an auto-decrement and SvTRUE evaluates
  612. # its argument more than once.
  613. runtime("sv = POPs;");
  614. return "SvTRUE(sv)";
  615. }
  616. }
  617. sub write_back_lexicals {
  618. my $avoid = shift || 0;
  619. debug "write_back_lexicals($avoid) called from @{[(caller(1))[3]]}\n"
  620. if $debug{shadow};
  621. my $lex;
  622. foreach $lex (@pad) {
  623. next unless ref($lex);
  624. $lex->write_back unless $lex->{flags} & $avoid;
  625. }
  626. }
  627. =head1 save_or_restore_lexical_state
  628. The compiler tracks state of lexical variables in @pad to generate optimised
  629. code. But multiple execution paths lead to the entry point of a basic block.
  630. The state of the first execution path is saved and all other execution
  631. paths are restored to the state of the first one.
  632. Missing flags are regenerated by loading values.
  633. Added flags must are removed; otherwise the compiler would be too optimistic,
  634. hence generating code which doesn't match state of the other execution paths.
  635. =cut
  636. sub save_or_restore_lexical_state {
  637. my $bblock = shift;
  638. unless ( exists $lexstate{$bblock} ) {
  639. foreach my $lex (@pad) {
  640. next unless ref($lex);
  641. ${ $lexstate{$bblock} }{ $lex->{iv} } = $lex->{flags};
  642. }
  643. }
  644. else {
  645. foreach my $lex (@pad) {
  646. next unless ref($lex);
  647. my $old_flags = ${ $lexstate{$bblock} }{ $lex->{iv} };
  648. next if ( $old_flags eq $lex->{flags} );
  649. my $changed = $old_flags ^ $lex->{flags};
  650. if ( $changed & VALID_SV ) {
  651. ( $old_flags & VALID_SV ) ? $lex->write_back : $lex->invalidate;
  652. }
  653. if ( $changed & VALID_NUM ) {
  654. ( $old_flags & VALID_NUM ) ? $lex->load_double : $lex->invalidate_double;
  655. }
  656. if ( $changed & VALID_INT ) {
  657. ( $old_flags & VALID_INT ) ? $lex->load_int : $lex->invalidate_int;
  658. }
  659. if ( $changed & VALID_STR ) {
  660. ( $old_flags & VALID_STR ) ? $lex->load_str : $lex->invalidate_str;
  661. }
  662. }
  663. }
  664. }
  665. sub write_back_stack {
  666. debug "write_back_stack() ".scalar(@stack)." called from @{[(caller(1))[3]]}\n"
  667. if $debug{shadow};
  668. return unless @stack;
  669. runtime( sprintf( "EXTEND(sp, %d);", scalar(@stack) ) );
  670. foreach my $obj (@stack) {
  671. runtime( sprintf( "PUSHs((SV*)%s);", $obj->as_sv ) );
  672. }
  673. @stack = ();
  674. }
  675. sub invalidate_lexicals {
  676. my $avoid = shift || 0;
  677. debug "invalidate_lexicals($avoid) called from @{[(caller(1))[3]]}\n"
  678. if $debug{shadow};
  679. my $lex;
  680. foreach $lex (@pad) {
  681. next unless ref($lex);
  682. $lex->invalidate unless $lex->{flags} & $avoid;
  683. }
  684. }
  685. sub reload_lexicals {
  686. my $lex;
  687. foreach $lex (@pad) {
  688. next unless ref($lex);
  689. my $type = $lex->{type};
  690. if ( $type == T_INT ) {
  691. $lex->as_int;
  692. }
  693. elsif ( $type == T_NUM ) {
  694. $lex->as_double;
  695. }
  696. elsif ( $type == T_STR ) {
  697. $lex->as_str;
  698. }
  699. else {
  700. $lex->as_sv;
  701. }
  702. }
  703. }
  704. {
  705. package B::Pseudoreg;
  706. #
  707. # This class allocates pseudo-registers (OK, so they're C variables).
  708. #
  709. my %alloc; # Keyed by variable name. A value of 1 means the
  710. # variable has been declared. A value of 2 means
  711. # it's in use.
  712. sub new_scope { %alloc = () }
  713. sub new ($$$) {
  714. my ( $class, $type, $prefix ) = @_;
  715. my ( $ptr, $i, $varname, $status, $obj );
  716. $prefix =~ s/^(\**)//;
  717. $ptr = $1;
  718. $i = 0;
  719. do {
  720. $varname = "$prefix$i";
  721. $status = exists $alloc{$varname} ? $alloc{$varname} : 0;
  722. } while $status == 2;
  723. if ( $status != 1 ) {
  724. # Not declared yet
  725. B::CC::declare( $type, "$ptr$varname" );
  726. $alloc{$varname} = 2; # declared and in use
  727. }
  728. $obj = bless \$varname, $class;
  729. return $obj;
  730. }
  731. sub DESTROY {
  732. my $obj = shift;
  733. $alloc{$$obj} = 1; # no longer in use but still declared
  734. }
  735. }
  736. {
  737. package B::Shadow;
  738. #
  739. # This class gives a standard API for a perl object to shadow a
  740. # C variable and only generate reloads/write-backs when necessary.
  741. #
  742. # Use $obj->load($foo) instead of runtime("shadowed_c_var = foo").
  743. # Use $obj->write_back whenever shadowed_c_var needs to be up to date.
  744. # Use $obj->invalidate whenever an unknown function may have
  745. # set shadow itself.
  746. sub new {
  747. my ( $class, $write_back ) = @_;
  748. # Object fields are perl shadow variable, validity flag
  749. # (for *C* variable) and callback sub for write_back
  750. # (passed perl shadow variable as argument).
  751. bless [ undef, 1, $write_back ], $class;
  752. }
  753. sub load {
  754. my ( $obj, $newval ) = @_;
  755. $obj->[1] = 0; # C variable no longer valid
  756. $obj->[0] = $newval;
  757. }
  758. sub value {
  759. return $_[0]->[0];
  760. }
  761. sub write_back {
  762. my $obj = shift;
  763. if ( !( $obj->[1] ) ) {
  764. $obj->[1] = 1; # C variable will now be valid
  765. &{ $obj->[2] }( $obj->[0] );
  766. }
  767. }
  768. sub invalidate { $_[0]->[1] = 0 } # force C variable to be invalid
  769. }
  770. my $curcop = B::Shadow->new(
  771. sub {
  772. my $op = shift;
  773. my $opsym = $op->save;
  774. runtime("PL_curcop = (COP*)$opsym;");
  775. }
  776. );
  777. #
  778. # Context stack shadowing. Mimics stuff in pp_ctl.c, cop.h and so on.
  779. #
  780. sub dopoptoloop {
  781. my $cxix = $#cxstack;
  782. while ( $cxix >= 0 && CxTYPE_no_LOOP( $cxstack[$cxix] ) ) {
  783. $cxix--;
  784. }
  785. debug "dopoptoloop: returning $cxix" if $debug{cxstack};
  786. return $cxix;
  787. }
  788. sub dopoptolabel {
  789. my $label = shift;
  790. my $cxix = $#cxstack;
  791. while (
  792. $cxix >= 0
  793. && ( CxTYPE_no_LOOP( $cxstack[$cxix] )
  794. || $cxstack[$cxix]->{label} ne $label )
  795. )
  796. {
  797. $cxix--;
  798. }
  799. debug "dopoptolabel: returning $cxix\n" if $debug{cxstack};
  800. if ($cxix < 0 and $debug{cxstack}) {
  801. for my $cx (0 .. $#cxstack) {
  802. debug "$cx: ",$cxstack[$cx]->{label},"\n";
  803. }
  804. for my $op (keys %{$labels->{label}}) {
  805. debug $labels->{label}->{$op},"\n";
  806. }
  807. }
  808. return $cxix;
  809. }
  810. sub push_label {
  811. my $op = shift;
  812. my $type = shift;
  813. push @{$labels->{$type}}, ( $op );
  814. }
  815. sub pop_label {
  816. my $type = shift;
  817. my $op = pop @{$labels->{$type}};
  818. write_label ($op); # avoids duplicate labels
  819. }
  820. sub error {
  821. my $format = shift;
  822. my $file = $curcop->[0]->file;
  823. my $line = $curcop->[0]->line;
  824. $errors++;
  825. if (@_) {
  826. warn sprintf( "ERROR at %s:%d: $format\n", $file, $line, @_ );
  827. }
  828. else {
  829. warn sprintf( "ERROR at %s:%d: %s\n", $file, $line, $format );
  830. }
  831. }
  832. # run-time eval is too late for attrs being checked by perlcore. BEGIN does not help.
  833. # use types is the right approach. But until types is fixed we use this hack.
  834. # Note that we also need a new CHECK_SCALAR_ATTRIBUTES hook, starting with v5.22.
  835. sub init_type_attrs {
  836. eval q[
  837. our $valid_attr = '^(int|num|str|double|string|unsigned|register|temporary|ro|readonly|const)$';
  838. sub MODIFY_SCALAR_ATTRIBUTES {
  839. my $pkg = shift;
  840. my $v = shift;
  841. my $attr = $B::CC::valid_attr;
  842. $attr =~ s/\b$pkg\b//;
  843. if (my @bad = grep !/$attr/, @_) {
  844. return @bad;
  845. } else {
  846. no strict 'refs';
  847. push @{"$pkg\::$v\::attributes"}, @_; # create a magic glob
  848. return ();
  849. }
  850. }
  851. sub FETCH_SCALAR_ATTRIBUTES {
  852. my ($pkg, $v) = @_;
  853. no strict 'refs';
  854. return @{"$pkg\::$v\::attributes"};
  855. }
  856. # pollute our callers namespace for attributes to be accepted with -MB::CC
  857. *main::MODIFY_SCALAR_ATTRIBUTES = \&B::CC::MODIFY_SCALAR_ATTRIBUTES;
  858. *main::FETCH_SCALAR_ATTRIBUTES = \&B::CC::FETCH_SCALAR_ATTRIBUTES;
  859. # my int $i : register : ro;
  860. *int::MODIFY_SCALAR_ATTRIBUTES = \&B::CC::MODIFY_SCALAR_ATTRIBUTES;
  861. *int::FETCH_SCALAR_ATTRIBUTES = \&B::CC::FETCH_SCALAR_ATTRIBUTES;
  862. # my double $d : ro;
  863. *num::MODIFY_SCALAR_ATTRIBUTES = \&B::CC::MODIFY_SCALAR_ATTRIBUTES;
  864. *num::FETCH_SCALAR_ATTRIBUTES = \&B::CC::FETCH_SCALAR_ATTRIBUTES;
  865. *str::MODIFY_SCALAR_ATTRIBUTES = \&B::CC::MODIFY_SCALAR_ATTRIBUTES;
  866. *str::FETCH_SCALAR_ATTRIBUTES = \&B::CC::FETCH_SCALAR_ATTRIBUTES;
  867. # deprecated:
  868. *double::MODIFY_SCALAR_ATTRIBUTES = \&B::CC::MODIFY_SCALAR_ATTRIBUTES;
  869. *double::FETCH_SCALAR_ATTRIBUTES = \&B::CC::FETCH_SCALAR_ATTRIBUTES;
  870. *string::MODIFY_SCALAR_ATTRIBUTES = \&B::CC::MODIFY_SCALAR_ATTRIBUTES;
  871. *string::FETCH_SCALAR_ATTRIBUTES = \&B::CC::FETCH_SCALAR_ATTRIBUTES;
  872. ];
  873. }
  874. =head2 load_pad
  875. Load pad takes (the elements of) a PADLIST as arguments and loads up @pad
  876. with Stackobj-derived objects which represent those lexicals.
  877. If/when perl itself can generate type information C<(my int $foo; my $foo : int)> then we'll
  878. take advantage of that here. Until then, we'll use the L<-fname-magic/-fno-name-magic>
  879. hack to tell the compiler when we want a lexical to be a particular type or to be a register.
  880. =cut
  881. sub load_pad {
  882. my ( $namelistav, $valuelistav ) = @_;
  883. @padlist = @_;
  884. my @namelist = $namelistav->ARRAY;
  885. my @valuelist = $valuelistav->ARRAY;
  886. my $ix;
  887. @pad = ();
  888. debug "load_pad: $#namelist names, $#valuelist values\n" if $debug{pad};
  889. # Temporary lexicals don't get named so it's possible for @valuelist
  890. # to be strictly longer than @namelist. We count $ix up to the end of
  891. # @valuelist but index into @namelist for the name. Any temporaries which
  892. # run off the end of @namelist will make $namesv undefined and we treat
  893. # that the same as having an explicit SPECIAL sv_undef object in @namelist.
  894. # [XXX If/when @_ becomes a lexical, we must start at 0 here.]
  895. for ( $ix = 1 ; $ix < @valuelist ; $ix++ ) {
  896. my $namesv = $namelist[$ix];
  897. my $type = T_UNKNOWN;
  898. my $flags = 0;
  899. my $name = "tmp";
  900. my $class = class($namesv);
  901. if ( !defined($namesv) || $class eq "SPECIAL" ) {
  902. # temporaries have &PL_sv_undef instead of a PVNV for a name
  903. $flags = VALID_SV | TEMPORARY | REGISTER;
  904. }
  905. else {
  906. my ($nametry) = $namesv->PV =~ /^\$(.+)$/ if $namesv->PV;
  907. $name = $nametry if $nametry;
  908. # my int $i; my num $d; compiled code only, unless the source provides the int and num packages.
  909. # With Ctypes it is easier. my c_int $i; defines an external Ctypes int, which can be efficiently
  910. # compiled in Perl also.
  911. # XXX Better use attributes, like my $i:int; my $d:num; which works un-compiled also.
  912. if (ref($namesv) eq 'B::PVMG' and ref($namesv->SvSTASH) eq 'B::HV') { # my int
  913. $class = $namesv->SvSTASH->NAME;
  914. if ($class eq 'int') {
  915. $type = T_INT;
  916. $flags = VALID_SV | VALID_INT;
  917. }
  918. elsif ($class eq 'num' or $class eq 'double') { # my num
  919. $type = T_NUM;
  920. $flags = VALID_SV | VALID_NUM;
  921. }
  922. elsif ($class eq 'str' or $class eq 'string') { # my str
  923. $type = T_STR;
  924. $flags = VALID_SV | VALID_STR;
  925. }
  926. #elsif ($class eq 'c_int') { # use Ctypes;
  927. # $type = T_INT;
  928. # $flags = VALID_SV | VALID_INT;
  929. #}
  930. #elsif ($class eq 'c_double') {
  931. # $type = T_NUM;
  932. # $flags = VALID_SV | VALID_NUM;
  933. #}
  934. # TODO: MooseX::Types
  935. }
  936. # Valid scalar type attributes:
  937. # int num str ro readonly const unsigned
  938. # Note: PVMG from above also.
  939. # Typed arrays and hashes later.
  940. if (0 and $class =~ /^(I|P|S|N)V/
  941. and $opt_type_attr
  942. and UNIVERSAL::can($class,"CHECK_SCALAR_ATTRIBUTES")) # with 5.18
  943. {
  944. require attributes;
  945. #my $svtype = uc reftype ($namesv);
  946. # test 105
  947. my @attr = attributes::get(\$namesv); # how to get em from B? see optimize
  948. warn "\$$name attrs: ".@attr if $verbose or $debug{pad};
  949. #my $valid_types = ${"$class\::valid_attr"}; # They ARE valid, parser checked already.
  950. }
  951. # XXX We should try Devel::TypeCheck for type inference also
  952. # magic names: my $i_ir, my $d_d. without -fno-name-magic cmdline option only
  953. if ( $type == T_UNKNOWN and $opt_name_magic and $name =~ /^(.*)_([dis])(r?)$/ ) {
  954. $name = $1;
  955. if ( $2 eq "i" ) {
  956. $type = T_INT;
  957. $flags = VALID_SV | VALID_INT;
  958. }
  959. elsif ( $2 eq "d" ) {
  960. $type = T_NUM;
  961. $flags = VALID_SV | VALID_NUM;
  962. }
  963. elsif ( $2 eq "s" ) {
  964. $type = T_STR;
  965. $flags = VALID_SV | VALID_STR;
  966. }
  967. $flags |= REGISTER if $3;
  968. }
  969. }
  970. $name = "${ix}_$name";
  971. # comppadname bug with overlong strings
  972. if ($] < 5.008008 and length($name) > 100 and $name =~ /\0\0/) {
  973. my $i = index($name,"\0");
  974. $name = substr($name,0,$i) if $i > -1;
  975. }
  976. $pad[$ix] =
  977. B::Stackobj::Padsv->new( $type, $flags, $ix, "i$name", "d$name" );
  978. debug sprintf( "PL_curpad[$ix] = %s\n", $pad[$ix]->peek ) if $debug{pad};
  979. }
  980. }
  981. sub declare_pad {
  982. my $ix;
  983. for ( $ix = 1 ; $ix <= $#pad ; $ix++ ) {
  984. my $type = $pad[$ix]->{type};
  985. declare( "IV",
  986. $type == T_INT ? sprintf( "%s=0", $pad[$ix]->{iv} ) : $pad[$ix]->{iv} )
  987. if $pad[$ix]->save_int;
  988. declare( "NV",
  989. $type == T_NUM
  990. ? sprintf( "%s = 0", $pad[$ix]->{nv} )
  991. : $pad[$ix]->{nv} )
  992. if $pad[$ix]->save_double;
  993. declare( "PV",
  994. $type == T_STR
  995. ? sprintf( "%s = 0", $pad[$ix]->{sv} )
  996. : $pad[$ix]->{sv} )
  997. if $pad[$ix]->save_str;
  998. }
  999. }
  1000. # for cc: unique ascii representation of an utf8 string, for labels
  1001. sub encode_utf8($) {
  1002. my $l = shift;
  1003. if ($] > 5.006 and utf8::is_utf8($l)) {
  1004. # utf8::encode($l);
  1005. # $l =~ s/([\x{0100}-\x{ffff}])/sprintf("u%x", $1)/ge;
  1006. #$l = substr(B::cstring($l), 1, -1);
  1007. #$l =~ s/\\/u/g;
  1008. $l = join('', map { $_ < 127 ? $_ : sprintf("u_%x_", $_) } unpack("U*", $l));
  1009. }
  1010. return $l;
  1011. }
  1012. #
  1013. # Debugging stuff
  1014. #
  1015. sub peek_stack {
  1016. sprintf "stack = %s\n", join( " ", map( $_->minipeek, @stack ) );
  1017. }
  1018. #
  1019. # OP stuff
  1020. #
  1021. =head2 label
  1022. We not only mark named labels in C as such - with prefix "label_".
  1023. We also have to mark each known (back jumps) and yet unknown branch targets
  1024. (forward jumps) for compile-time generated branch points, with the "lab_"
  1025. prefix.
  1026. =cut
  1027. sub label {
  1028. my $op = shift;
  1029. # Preserve original label name for "real" labels
  1030. if ($op->can("label") and $op->label) {
  1031. my $l = encode_utf8 $op->label;
  1032. # cc should error on duplicate named labels
  1033. return sprintf( "label_%s_%x", $l, $$op);
  1034. } else {
  1035. return sprintf( "lab_%x", $$op );
  1036. }
  1037. }
  1038. sub write_label {
  1039. my $op = shift;
  1040. $op->save if $$op;
  1041. # debug sprintf("lab_%x:?\n", $$op) if $debug{cxstack};
  1042. unless ($labels->{label}->{$$op}) {
  1043. my $l = label($op);
  1044. # named label but op not yet known?
  1045. if ( $op->can("label") and $op->label ) {
  1046. $l = "label_" . encode_utf8 $op->label;
  1047. # only print first such label. test 21
  1048. push_runtime(sprintf( " %s:", $l))
  1049. unless $labels->{label}->{$l};
  1050. $labels->{label}->{$l} = $$op;
  1051. }
  1052. if ($verbose) {
  1053. push_runtime(sprintf( " %s:\t/* %s */", label($op), $op->name ));
  1054. } else {
  1055. push_runtime(sprintf( " %s:", label($op) ));
  1056. }
  1057. # avoid printing duplicate jump labels
  1058. $labels->{label}->{$$op} = $l;
  1059. if ($op->can("label") and $op->label ) {
  1060. push(@cxstack, {
  1061. type => 0,
  1062. op => $op,
  1063. nextop => ((ref($op) eq 'B::LOOP') && $op->nextop) ? $op->nextop : $op,
  1064. redoop => ((ref($op) eq 'B::LOOP') && $op->redoop) ? $op->redoop : $op,
  1065. lastop => ((ref($op) eq 'B::LOOP') && $op->lastop) ? $op->lastop : $op,
  1066. 'label' => $op->can("label") && $op->label ? $op->label : $l
  1067. });
  1068. }
  1069. }
  1070. }
  1071. sub loadop {
  1072. my $op = shift;
  1073. my $opsym = $op->save;
  1074. $op_count++; # for statistics
  1075. runtime("PL_op = $opsym;") unless $know_op;
  1076. return $opsym;
  1077. }
  1078. sub doop {
  1079. my $op = shift;
  1080. my $ppaddr = $op->ppaddr;
  1081. my $sym = loadop($op);
  1082. my $ppname = "pp_" . $op->name;
  1083. if ($inline_ops) {
  1084. # inlining direct calls is safe, just CALLRUNOPS for macros not
  1085. $ppaddr = "Perl_".$ppname;
  1086. $no_stack{$ppname}
  1087. ? runtime("PL_op = $ppaddr(aTHX);")
  1088. : runtime("PUTBACK; PL_op = $ppaddr(aTHX); SPAGAIN;");
  1089. } else {
  1090. $no_stack{$ppname}
  1091. ? runtime("PL_op = $ppaddr(aTHX);")
  1092. : runtime("DOOP($ppaddr);");
  1093. }
  1094. $know_op = 1;
  1095. return $sym;
  1096. }
  1097. sub gimme {
  1098. my $op = shift;
  1099. my $want = $op->flags & OPf_WANT;
  1100. return ( $want == OPf_WANT_VOID ? G_VOID :
  1101. $want == OPf_WANT_SCALAR ? G_SCALAR :
  1102. $want == OPf_WANT_LIST ? G_ARRAY :
  1103. undef );
  1104. }
  1105. #
  1106. # Code generation for PP code
  1107. #
  1108. # coverage: 18,19,25,...
  1109. sub pp_null {
  1110. my $op = shift;
  1111. $B::C::nullop_count++;
  1112. return $op->next;
  1113. }
  1114. # coverage: 102
  1115. sub pp_stub {
  1116. my $op = shift;
  1117. my $gimme = gimme($op);
  1118. if ( not defined $gimme ) {
  1119. write_back_stack();
  1120. runtime("if (block_gimme() == G_SCALAR)",
  1121. "\tXPUSHs(&PL_sv_undef);");
  1122. } elsif ( $gimme == G_SCALAR ) {
  1123. my $obj = B::Stackobj::Const->new(sv_undef);
  1124. push( @stack, $obj );
  1125. }
  1126. return $op->next;
  1127. }
  1128. # coverage: 2,21,28,30
  1129. sub pp_unstack {
  1130. my $op = shift;
  1131. @stack = ();
  1132. runtime("PP_UNSTACK;");
  1133. return $op->next;
  1134. }
  1135. # coverage: 2,21,27,28,30
  1136. sub pp_and {
  1137. my $op = shift;
  1138. my $next = $op->next;
  1139. reload_lexicals();
  1140. unshift( @bblock_todo, $next );
  1141. if ( @stack >= 1 ) {
  1142. my $obj = pop @stack;
  1143. my $bool = $obj->as_bool;
  1144. write_back_stack();
  1145. save_or_restore_lexical_state($$next);
  1146. if ($bool =~ /POPs/) {
  1147. runtime("sv = $bool;",
  1148. sprintf("if (!sv) { PUSHs(sv); goto %s;}", label($next)));
  1149. } else {
  1150. runtime(sprintf(
  1151. "if (!$bool) { PUSHs((SV*)%s); goto %s;}", $obj->as_sv, label($next)
  1152. ));
  1153. }
  1154. }
  1155. else {
  1156. save_or_restore_lexical_state($$next);
  1157. runtime( sprintf( "if (!%s) goto %s;", top_bool(), label($next) ),
  1158. "sp--;" );
  1159. }
  1160. return $op->other;
  1161. }
  1162. # Nearly identical to pp_and, but leaves stack unchanged.
  1163. sub pp_andassign {
  1164. my $op = shift;
  1165. my $next = $op->next;
  1166. reload_lexicals();
  1167. unshift( @bblock_todo, $next );
  1168. if ( @stack >= 1 ) {
  1169. my $obj = pop @stack;
  1170. my $bool = $obj->as_bool;
  1171. write_back_stack();
  1172. save_or_restore_lexical_state($$next);
  1173. if ($bool =~ /POPs/) {
  1174. runtime("sv = $bool;",
  1175. sprintf("PUSHs((SV*)%s); if (!$bool) { goto %s;}",
  1176. $obj->as_sv, label($next)));
  1177. } else {
  1178. runtime(
  1179. sprintf("PUSHs((SV*)%s); if (!$bool) { goto %s;}",
  1180. $obj->as_sv, label($next)));
  1181. }
  1182. }
  1183. else {
  1184. save_or_restore_lexical_state($$next);
  1185. runtime( sprintf( "if (!%s) goto %s;", top_bool(), label($next) ) );
  1186. }
  1187. return $op->other;
  1188. }
  1189. # coverage: 28
  1190. sub pp_or {
  1191. my $op = shift;
  1192. my $next = $op->next;
  1193. reload_lexicals();
  1194. unshift( @bblock_todo, $next );
  1195. if ( @stack >= 1 ) {
  1196. my $obj = pop @stack;
  1197. my $bool = $obj->as_bool;
  1198. write_back_stack();
  1199. save_or_restore_lexical_state($$next);
  1200. if ($bool =~ /POPs/) {
  1201. runtime("sv = $bool;",
  1202. sprintf("if (sv) { PUSHs(sv); goto %s;}", label($next)));
  1203. } else {
  1204. runtime(
  1205. sprintf("if ($bool) { PUSHs((SV*)%s); goto %s; }", $obj->as_sv, label($next)));
  1206. }
  1207. }
  1208. else {
  1209. save_or_restore_lexical_state($$next);
  1210. runtime( sprintf( "if (%s) goto %s;", top_bool(), label($next) ),
  1211. "sp--;" );
  1212. }
  1213. return $op->other;
  1214. }
  1215. # Nearly identical to pp_or, but leaves stack unchanged.
  1216. sub pp_orassign {
  1217. my $op = shift;
  1218. my $next = $op->next;
  1219. reload_lexicals();
  1220. unshift( @bblock_todo, $next );
  1221. if ( @stack >= 1 ) {
  1222. my $obj = pop @stack;
  1223. my $bool = $obj->as_bool;
  1224. write_back_stack();
  1225. save_or_restore_lexical_state($$next);
  1226. runtime(
  1227. sprintf(
  1228. "PUSHs((SV*)%s); if ($bool) { goto %s; }", $obj->as_sv, label($next)
  1229. )
  1230. );
  1231. }
  1232. else {
  1233. save_or_restore_lexical_state($$next);
  1234. runtime( sprintf( "if (%s) goto %s;", top_bool(), label($next) ) );
  1235. }
  1236. return $op->other;
  1237. }
  1238. # coverage: issue 45 (1,2)
  1239. # in CORE aliased to pp_defined
  1240. # default dor is okay issue 45 (3,4)
  1241. sub pp_dorassign {
  1242. my $op = shift;
  1243. my $next = $op->next;
  1244. reload_lexicals();
  1245. unshift( @bblock_todo, $next );
  1246. my $sv = pop @stack;
  1247. write_back_stack();
  1248. save_or_restore_lexical_state($$next);
  1249. runtime( sprintf( "PUSHs(%s); if (%s && SvANY(%s)) goto %s;\t/* dorassign */",
  1250. $sv->as_sv, $sv->as_sv, $sv->as_sv, label($next)) ) if $sv;
  1251. return $op->other;
  1252. }
  1253. # coverage: 102
  1254. sub pp_cond_expr {
  1255. my $op = shift;
  1256. my $false = $op->next;
  1257. unshift( @bblock_todo, $false );
  1258. reload_lexicals();
  1259. my $bool = pop_bool();
  1260. write_back_stack();
  1261. save_or_restore_lexical_state($$false);
  1262. runtime( sprintf( "if (!$bool) goto %s;\t/* cond_expr */", label($false) ) );
  1263. return $op->other;
  1264. }
  1265. # coverage: 9,10,12,17,18,22,28,32
  1266. sub pp_padsv {
  1267. my $op = shift;
  1268. my $ix = $op->targ;
  1269. push( @stack, $pad[$ix] ) if $pad[$ix];
  1270. if ( $op->flags & OPf_MOD ) {
  1271. my $private = $op->private;
  1272. if ( $private & OPpLVAL_INTRO ) {
  1273. # coverage: 9,10,12,17,18,19,20,22,27,28,31,32
  1274. runtime("SAVECLEARSV(PL_curpad[$ix]);");
  1275. }
  1276. elsif ( $private & OPpDEREF ) {
  1277. # coverage: 18
  1278. if ($] >= 5.015002) {
  1279. runtime(sprintf( "PL_curpad[%d] = Perl_vivify_ref(aTHX_ PL_curpad[%d], %d);",
  1280. $ix, $ix, $private & OPpDEREF ));
  1281. } else {
  1282. runtime(sprintf( "Perl_vivify_ref(aTHX_ PL_curpad[%d], %d);",
  1283. $ix, $private & OPpDEREF ));
  1284. }
  1285. $vivify_ref_defined++;
  1286. $pad[$ix]->invalidate if $pad[$ix];
  1287. }
  1288. }
  1289. return $op->next;
  1290. }
  1291. # coverage: 1-5,7-14,18-23,25,27-32
  1292. sub pp_const {
  1293. my $op = shift;
  1294. my $sv = $op->sv;
  1295. my $obj;
  1296. # constant could be in the pad (under useithreads)
  1297. if ($$sv) {
  1298. $obj = $constobj{$$sv};
  1299. if ( !defined($obj) ) {
  1300. $obj = $constobj{$$sv} = B::Stackobj::Const->new($sv);
  1301. }
  1302. }
  1303. else {
  1304. $obj = $pad[ $op->targ ];
  1305. }
  1306. # XXX looks like method_named has only const as prev op
  1307. if ($op->next
  1308. and $op->next->can('name')
  1309. and $op->next->name eq 'method_named'
  1310. ) {
  1311. $package_pv = svop_or_padop_pv($op);
  1312. debug "save package_pv \"$package_pv\" for method_name\n" if $debug{op};
  1313. }
  1314. push( @stack, $obj );
  1315. return $op->next;
  1316. }
  1317. # coverage: 1-39, fails in 33
  1318. sub pp_nextstate {
  1319. my $op = shift;
  1320. if ($labels->{'nextstate'}->[-1] and $labels->{'nextstate'}->[-1] == $op) {
  1321. debug sprintf("pop_label nextstate: cxstack label %s\n", $curcop->[0]->label) if $debug{cxstack};
  1322. pop_label 'nextstate';
  1323. } else {
  1324. write_label($op);
  1325. }
  1326. $curcop->load($op);
  1327. loadop($op);
  1328. #testcc 48: protect CopFILE_free and CopSTASH_free in END block (#296)
  1329. if ($ppname =~ /^pp_sub_END(_\d+)?$/ and $ITHREADS) {
  1330. runtime("#ifdef USE_ITHREADS",
  1331. "CopFILE((COP*)PL_op) = NULL;");
  1332. if ($] >= 5.018) {
  1333. runtime("CopSTASH_set((COP*)PL_op, NULL);");
  1334. } elsif ($] >= 5.016 and $] <= 5.017) {
  1335. runtime("CopSTASHPV_set((COP*)PL_op, NULL, 0);");
  1336. } else {
  1337. runtime("CopSTASHPV_set((COP*)PL_op, NULL);");
  1338. }
  1339. runtime("#endif");
  1340. }
  1341. @stack = ();
  1342. debug( sprintf( "%s:%d\n", $op->file, $op->line ) ) if $debug{lineno};
  1343. debug( sprintf( "CopLABEL %s\n", $op->label ) ) if $op->label and $debug{cxstack};
  1344. runtime("TAINT_NOT;") if $opt_taint; # TODO Not always needed (resets PL_taint = 0)
  1345. runtime("sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;"); # TODO reset sp not needed always
  1346. if ( $freetmps_each_bblock || $freetmps_each_loop ) {
  1347. $need_freetmps = 1;
  1348. }
  1349. else {
  1350. runtime("FREETMPS;"); # TODO Not always needed
  1351. }
  1352. return $op->next;
  1353. }
  1354. # Like pp_nextstate, but used instead when the debugger is active.
  1355. sub pp_dbstate { pp_nextstate(@_) }
  1356. #default_pp will handle this:
  1357. #sub pp_bless { $curcop->write_back; default_pp(@_) }
  1358. #sub pp_repeat { $curcop->write_back; default_pp(@_) }
  1359. # The following subs need $curcop->write_back if we decide to support arybase:
  1360. # pp_pos, pp_substr, pp_index, pp_rindex, pp_aslice, pp_lslice, pp_splice
  1361. #sub pp_caller { $curcop->write_back; default_pp(@_) }
  1362. # coverage: ny
  1363. sub bad_pp_reset {
  1364. if ($inline_ops) {
  1365. my $op = shift;
  1366. warn "inlining reset\n" if $debug{op};
  1367. $curcop->write_back if $curcop;
  1368. runtime '{ /* pp_reset */';
  1369. runtime ' const char * const tmps = (MAXARG < 1) ? (const char *)"" : POPpconstx;';
  1370. runtime ' sv_reset(tmps, CopSTASH(PL_curcop));}';
  1371. runtime 'PUSHs(&PL_sv_yes);';
  1372. return $op->next;
  1373. } else {
  1374. default_pp(@_);
  1375. }
  1376. }
  1377. # coverage: 20
  1378. sub pp_regcreset {
  1379. if ($inline_ops) {
  1380. my $op = shift;
  1381. warn "inlining regcreset\n" if $debug{op};
  1382. $curcop->write_back if $curcop;
  1383. runtime 'PL_reginterp_cnt = 0; /* pp_regcreset */';
  1384. runtime 'TAINT_NOT;' if $opt_taint;
  1385. return $op->next;
  1386. } else {
  1387. default_pp(@_);
  1388. }
  1389. }
  1390. # coverage: 103
  1391. sub pp_stringify {
  1392. if ($inline_ops and $] >= 5.008) {
  1393. my $op = shift;
  1394. warn "inlining stringify\n" if $debug{op};
  1395. my $sv = top_sv();
  1396. my $ix = $op->targ;
  1397. my $targ = $pad[$ix];
  1398. runtime "sv_copypv(PL_curpad[$ix], $sv);\t/* pp_stringify */";
  1399. $stack[-1] = $targ if @stack;
  1400. return $op->next;
  1401. } else {
  1402. default_pp(@_);
  1403. }
  1404. }
  1405. # coverage: 9,10,27
  1406. sub bad_pp_anoncode {
  1407. if ($inline_ops) {
  1408. my $op = shift;
  1409. warn "inlining anoncode\n" if $debug{op};
  1410. my $ix = $op->targ;
  1411. my $ppname = "pp_" . $op->name;
  1412. write_back_lexicals() unless $skip_lexicals{$ppname};
  1413. write_back_stack() unless $skip_stack{$ppname};
  1414. # XXX finish me. this works only with >= 5.10
  1415. runtime '{ /* pp_anoncode */',
  1416. ' CV *cv = MUTABLE_CV(PAD_SV(PL_op->op_targ));',
  1417. ' if (CvCLONE(cv))',
  1418. ' cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(Perl_cv_clone(aTHX_ cv))));',
  1419. ' EXTEND(SP,1);',
  1420. ' PUSHs(MUTABLE_SV(cv));',
  1421. '}';
  1422. invalidate_lexicals() unless $skip_invalidate{$ppname};
  1423. return $op->next;
  1424. } else {
  1425. default_pp(@_);
  1426. }
  1427. }
  1428. # coverage: 35
  1429. # XXX TODO get prev op. For now saved in pp_const.
  1430. sub pp_method_named {
  1431. my ( $op ) = @_;
  1432. my $name = svop_or_padop_pv($op);
  1433. # The pkg PV is at [PL_stack_base+TOPMARK+1], the previous op->sv->PV.
  1434. my $stash = $package_pv ? $package_pv."::" : "main::";
  1435. $name = $stash . $name;
  1436. if (exists &$name) {
  1437. debug "save method_name \"$name\"\n" if $debug{op};
  1438. svref_2object( \&{$name} )->save;
  1439. } else {
  1440. debug "skip saving non-existing method_name \"$name\"\n" if $debug{op}; #CC 50
  1441. }
  1442. default_pp(@_);
  1443. }
  1444. # inconsequence: gvs are not passed around on the stack
  1445. # coverage: 26,103
  1446. sub bad_pp_srefgen {
  1447. if ($inline_ops) {
  1448. my $op = shift;
  1449. warn "inlining srefgen\n" if $debug{op};
  1450. #my $ppname = "pp_" . $op->name;
  1451. #$curcop->write_back;
  1452. #write_back_lexicals() unless $skip_lexicals{$ppname};
  1453. #write_back_stack() unless $skip_stack{$ppname};
  1454. my $svobj = $stack[-1]->as_sv;
  1455. my $sv = pop_sv();
  1456. # XXX fix me
  1457. runtime "{ /* pp_srefgen */
  1458. SV* rv;
  1459. SV* sv = $sv;";
  1460. # sv = POPs
  1461. #B::svref_2object(\$sv);
  1462. if (($svobj->flags & 0xff) == $SVt_PVLV
  1463. and B::PVLV::LvTYPE($svobj) eq ord('y'))
  1464. {
  1465. runtime 'if (LvTARGLEN(sv))
  1466. vivify_defelem(sv);
  1467. if (!(sv = LvTARG(sv)))
  1468. sv = &PL_sv_undef;
  1469. else
  1470. SvREFCNT_inc_void_NN(sv);';
  1471. }
  1472. elsif (($svobj->flags & 0xff) == $SVt_PVAV) {
  1473. runtime 'if (!AvREAL((const AV *)sv) && AvREIFY((const AV *)sv))
  1474. av_reify(MUTABLE_AV(sv));
  1475. SvTEMP_off(sv);
  1476. SvREFCNT_inc_void_NN(sv);';
  1477. }
  1478. #elsif ($sv->SvPADTMP && !IS_PADGV(sv)) {
  1479. # runtime 'sv = newSVsv(sv);';
  1480. #}
  1481. else {
  1482. runtime 'SvTEMP_off(sv);
  1483. SvREFCNT_inc_void_NN(sv);';
  1484. }
  1485. runtime 'rv = sv_newmortal();
  1486. sv_upgrade(rv, SVt_IV);
  1487. SvRV_set(rv, sv);
  1488. SvROK_on(rv);
  1489. PUSHBACK;
  1490. }';
  1491. return $op->next;
  1492. } else {
  1493. default_pp(@_);
  1494. }
  1495. }
  1496. # coverage: 9,10,27
  1497. #sub pp_refgen
  1498. # coverage: 28, 14
  1499. sub pp_rv2gv {
  1500. my $op = shift;
  1501. $curcop->write_back if $curcop;
  1502. my $ppname = "pp_" . $op->name;
  1503. write_back_lexicals() unless $skip_lexicals{$ppname};
  1504. write_back_stack() unless $skip_stack{$ppname};
  1505. my $sym = doop($op);
  1506. if ( $op->private & OPpDEREF ) {
  1507. $init->add( sprintf("((UNOP *)$sym)->op_first = $sym;") );
  1508. $init->add( sprintf( "((UNOP *)$sym)->op_type = %d;", $op->first->type ) );
  1509. }
  1510. return $op->next;
  1511. }
  1512. # coverage: 18,19,25
  1513. sub pp_sort {
  1514. my $op = shift;
  1515. #my $ppname = $op->ppaddr;
  1516. if ( $op->flags & OPf_SPECIAL && $op->flags & OPf_STACKED ) {
  1517. # blocksort is awful. E.g. we need to the leading NULL op, invalidates -fcop
  1518. # Ugly surgery required. sort expects as block: pushmark rv2gv leave => enter
  1519. # pp_sort() OP *kid = cLISTOP->op_first->op_sibling;/* skip over pushmark 4 to null */
  1520. # kid = cUNOPx(kid)->op_first; /* pass rv2gv (null'ed) */
  1521. # kid = cUNOPx(kid)->op_first; /* pass leave */
  1522. #
  1523. #3 <0> pushmark s ->4
  1524. #8 <@> sort lKS* ->9
  1525. #4 <0> pushmark s ->5
  1526. #- <1> null sK/1 ->5
  1527. #- <1> ex-leave sKP ->-
  1528. #- <0> enter s ->-
  1529. # some code doing cmp or ncmp
  1530. # Example with 3 const args: print sort { bla; $b <=> $a } 1,4,3
  1531. #5 <$> const[IV 1] s ->6
  1532. #6 <$> const[IV 4] s ->7
  1533. #7 <$> const[IV 3] s ->8 => sort
  1534. #
  1535. my $root = $op->first->sibling->first; #leave or null
  1536. my $start = $root->first; #enter
  1537. warn "blocksort: root=",$root->name,", start=",$start->name,"\n" if $debug{op};
  1538. my $pushmark = $op->first->save; #pushmark sibling to null
  1539. $op->first->sibling->save; #null->first to leave
  1540. $root->save; #ex-leave
  1541. my $sym = $start->save; #enter
  1542. my $fakeop = cc_queue( "pp_sort" . sprintf("%x",abs($$op)), $root, $start );
  1543. $init->add( sprintf( "(%s)->op_next = %s;", $sym, $fakeop ) );
  1544. }
  1545. $curcop->write_back;
  1546. write_back_lexicals();
  1547. write_back_stack();
  1548. doop($op);
  1549. return $op->next;
  1550. }
  1551. # coverage: 2-4,6,7,13,15,21,24,26,27,30,31
  1552. sub pp_gv {
  1553. my $op = shift;
  1554. my $gvsym;
  1555. if ($ITHREADS) {
  1556. $gvsym = $pad[ $op->padix ]->as_sv;
  1557. #push @stack, ($pad[$op->padix]);
  1558. }
  1559. else {
  1560. $gvsym = $op->gv->save;
  1561. # XXX
  1562. #my $obj = new B::Stackobj::Const($op->gv);
  1563. #push( @stack, $obj );
  1564. }
  1565. write_back_stack();
  1566. runtime("XPUSHs((SV*)$gvsym);");
  1567. return $op->next;
  1568. }
  1569. # coverage: 2,3,4,9,11,14,20,21,23,28
  1570. sub pp_gvsv {
  1571. my $op = shift;
  1572. my $gvsym;
  1573. if ($ITHREADS) {
  1574. #debug(sprintf("OP name=%s, class=%s\n",$op->name,class($op))) if $debug{pad};
  1575. debug( sprintf( "GVSV->padix = %d\n", $op->padix ) ) if $debug{pad};
  1576. $gvsym = $pad[ $op->padix ]->as_sv;
  1577. debug( sprintf( "GVSV->private = 0x%x\n", $op->private ) ) if $debug{pad};
  1578. }
  1579. else {
  1580. $gvsym = $op->gv->save;
  1581. }
  1582. # Expects GV*, not SV* PL_curpad
  1583. $gvsym = "(GV*)$gvsym" if $gvsym =~ /PL_curpad/;
  1584. write_back_stack();
  1585. if ( $op->private & OPpLVAL_INTRO ) {
  1586. runtime("XPUSHs(save_scalar($gvsym));");
  1587. #my $obj = new B::Stackobj::Const($op->gv);
  1588. #push( @stack, $obj );
  1589. }
  1590. else {
  1591. $PERL510
  1592. ? runtime("XPUSHs(GvSVn($gvsym));")
  1593. : runtime("XPUSHs(GvSV($gvsym));");
  1594. }
  1595. return $op->next;
  1596. }
  1597. # Check for faster fetch calls. Returns 0 if the fast 'no' is in effect.
  1598. sub autovivification {
  1599. if (!$opt_autovivify) {
  1600. return 0;
  1601. } elsif ($INC{'autovivification.pm'}) {
  1602. return _autovivification($curcop->[0]);
  1603. } else {
  1604. return 1;
  1605. }
  1606. }
  1607. # coverage: 16, issue44
  1608. sub pp_aelemfast {
  1609. my $op = shift;
  1610. my ($av, $rmg);
  1611. if ($op->flags & OPf_SPECIAL) {
  1612. my $sv = $pad[ $op->targ ]->as_sv;
  1613. my @c = comppadlist->ARRAY;
  1614. my @p = $c[1]->ARRAY;
  1615. my $lex = $p[ $op->targ ];
  1616. $rmg = ($lex and ref $lex eq 'B::AV' and ($lex->MAGICAL & SVs_RMG or !$lex->ARRAY)) ? 1 : 0;
  1617. # MUTABLE_AV is only needed to catch compiler const loss
  1618. # $av = $] > 5.01000 ? "MUTABLE_AV($sv)" : $sv;
  1619. $av = "(AV*)$sv";
  1620. } else {
  1621. my $gvsym;
  1622. if ($ITHREADS) { #padop XXX if it's only a OP, no PADOP? t/CORE/op/ref.t test 36
  1623. if ($op->can('padix')) {
  1624. #warn "padix\n";
  1625. $gvsym = $pad[ $op->padix ]->as_sv;
  1626. my @c = comppadlist->ARRAY; # XXX curpad, not comppad!!
  1627. my @p = $c[1]->ARRAY;
  1628. my $lex = $p[ $op->padix ];
  1629. $rmg = ($lex and ref $lex eq 'B::AV' and ($lex->MAGICAL & SVs_RMG or !$lex->ARRAY)) ? 1 : 0;
  1630. } else {
  1631. $gvsym = 'PL_incgv'; # XXX passes, but need to investigate why. cc test 43 5.10.1
  1632. #write_back_stack();
  1633. #runtime("PUSHs(&PL_sv_undef);");
  1634. #return $op->next;
  1635. }
  1636. }
  1637. else { #svop
  1638. my $gv = $op->gv;
  1639. $gvsym = $gv->save;
  1640. my $gvav = $gv->AV; # test 16, tied gvav
  1641. $rmg = $] < 5.007 ? 0 : ($gvav and ($gvav->MAGICAL & SVs_RMG or !$gvav->ARRAY)) ? 1 : 0;
  1642. }
  1643. $av = "GvAV($gvsym)";
  1644. }
  1645. my $ix = $op->private;
  1646. my $lval = $op->flags & OPf_MOD;
  1647. my $vivify = !$rmg ? autovivification() : 1; # no need to call if $rmg
  1648. debug "aelemfast: vivify=$vivify, rmg=$rmg, lval=$lval, -fautovivify=$opt_autovivify -faelem=$opt_aelem\n" if $debug{pad};
  1649. return _aelem($op, $av, $ix, $lval, $rmg, $vivify);
  1650. }
  1651. sub _aelem {
  1652. my ($op, $av, $ix, $lval, $rmg, $vivify) = @_;
  1653. if ($opt_aelem and !$rmg and !$vivify and $ix >= 0) {
  1654. push @stack, B::Stackobj::Aelem->new($av, $ix, $lval);
  1655. } else {
  1656. write_back_stack();
  1657. runtime(
  1658. "{ AV* av = (AV*)$av;",
  1659. " SV** const svp = av_fetch(av, $ix, $lval);",
  1660. " SV *sv = (svp ? *svp : &PL_sv_undef);",
  1661. (!$lval and $rmg) ? " if (SvRMAGICAL(av) && SvGMAGICAL(sv)) mg_get(sv);" : "",
  1662. " PUSHs(sv);",
  1663. "}"
  1664. );
  1665. }
  1666. return $op->next;
  1667. }
  1668. # coverage: ?
  1669. sub pp_aelem {
  1670. my $op = shift;
  1671. my ($ix, $av);
  1672. my $lval = ($op->flags & OPf_MOD or $op->private & (OPpLVAL_DEFER || OPpLVAL_INTRO)) ? 1 : 0;
  1673. my $vivify = autovivification();
  1674. my $rmg = $opt_magic; # use -fno-magic for the av (2nd stack arg)
  1675. if (@stack >= 1) { # at least ix
  1676. $ix = pop_int(); # TODO: substract CopARYBASE from ix
  1677. if (@stack >= 1) {
  1678. my $avobj = $stack[-1]->as_obj;
  1679. $rmg = ($avobj and $avobj->MAGICAL & SVs_RMG) ? 1 : 0;
  1680. }
  1681. $av = pop_sv();
  1682. debug "aelem: vivify = $vivify, rmg = $rmg, lval = $lval\n" if $debug{pad};
  1683. return _aelem($op, $av, $ix, $lval, $rmg, $vivify);
  1684. } else {
  1685. if ($lval or $rmg) { # always
  1686. return default_pp($op);
  1687. } else {
  1688. $ix = pop_int(); # TODO: substract CopARYBASE from ix
  1689. $av = pop_sv();
  1690. debug "aelem: vivify = $vivify, rmg = $rmg, lval = $lval\n" if $debug{pad};
  1691. return _aelem($op, $av, $ix, $lval, $rmg, $vivify);
  1692. }
  1693. }
  1694. }
  1695. # coverage: ?
  1696. sub int_binop {
  1697. my ( $op, $operator, $unsigned ) = @_;
  1698. if ( $op->flags & OPf_STACKED ) {
  1699. my $right = pop_int();
  1700. if ( @stack >= 1 ) {
  1701. my $left = top_int();
  1702. $stack[-1]->set_int( &$operator( $left, $right ), $unsigned );
  1703. }
  1704. else {
  1705. my $sv_setxv = $unsigned ? 'sv_setuv' : 'sv_setiv';
  1706. runtime( sprintf( "$sv_setxv(TOPs, %s);", &$operator( "TOPi", $right ) ) );
  1707. }
  1708. }
  1709. else {
  1710. my $targ = $pad[ $op->targ ];
  1711. my $right = B::Pseudoreg->new( "IV", "riv" );
  1712. my $left = B::Pseudoreg->new( "IV", "liv" );
  1713. runtime( sprintf( "$$right = %s; $$left = %s;", pop_int(), pop_int ) );
  1714. $targ->set_int( &$operator( $$left, $$right ), $unsigned );
  1715. push( @stack, $targ );
  1716. }
  1717. return $op->next;
  1718. }
  1719. sub INTS_CLOSED () { 0x1 }
  1720. sub INT_RESULT () { 0x2 }
  1721. sub NUMERIC_RESULT () { 0x4 }
  1722. # coverage: 101
  1723. sub numeric_binop {
  1724. my ( $op, $operator, $flags ) = @_;
  1725. my $force_int = 0;
  1726. $flags = 0 unless $flags;
  1727. $force_int ||= ( $flags & INT_RESULT );
  1728. $force_int ||=
  1729. ( $flags & INTS_CLOSED
  1730. && @stack >= 2
  1731. && valid_int( $stack[-2] )
  1732. && valid_int( $stack[-1] ) );
  1733. if ( $op->flags & OPf_STACKED ) {
  1734. runtime(sprintf("/* %s */", $op->name)) if $verbose;
  1735. my $right = pop_numeric();
  1736. if ( @stack >= 1 ) {
  1737. my $left = top_numeric();
  1738. if ($force_int) {
  1739. $stack[-1]->set_int( &$operator( $left, $right ) );
  1740. }
  1741. else {
  1742. $stack[-1]->set_numeric( &$operator( $left, $right ) );
  1743. }
  1744. }
  1745. else {
  1746. if ($force_int) {
  1747. my $rightruntime = B::Pseudoreg->new( "IV", "riv" );
  1748. runtime( sprintf( "$$rightruntime = %s;", $right ) );
  1749. runtime(
  1750. sprintf(
  1751. "sv_setiv(TOPs, %s);", &$operator( "TOPi", $$rightruntime )
  1752. )
  1753. );
  1754. }
  1755. else {
  1756. my $rightruntime = B::Pseudoreg->new( "NV", "rnv" );
  1757. runtime( sprintf( "$$rightruntime = %s;\t/* %s */", $right, $op->name ) );
  1758. runtime(
  1759. sprintf(
  1760. "sv_setnv(TOPs, %s);", &$operator( "TOPn", $$rightruntime )
  1761. )
  1762. );
  1763. }
  1764. }
  1765. }
  1766. else {
  1767. my $targ = $pad[ $op->targ ];
  1768. $force_int ||= ( $targ->{type} == T_INT );
  1769. if ($force_int) {
  1770. my $right = B::Pseudoreg->new( "IV", "riv" );
  1771. my $left = B::Pseudoreg->new( "IV", "liv" );
  1772. runtime(
  1773. sprintf( "$$right = %s;", pop_numeric()),
  1774. sprintf( "$$left = %s;\t/* %s */", pop_numeric(), pop_numeric(), $op->name ) );
  1775. $targ->set_int( &$operator( $$left, $$right ) );
  1776. }
  1777. else {
  1778. my $right = B::Pseudoreg->new( "NV", "rnv" );
  1779. my $left = B::Pseudoreg->new( "NV", "lnv" );
  1780. runtime(
  1781. sprintf( "$$right = %s;", pop_numeric()),
  1782. sprintf( "$$left = %s;\t/* %s */", pop_numeric(), $op->name ) );
  1783. $targ->set_numeric( &$operator( $$left, $$right ) );
  1784. }
  1785. push( @stack, $targ );
  1786. }
  1787. return $op->next;
  1788. }
  1789. sub numeric_unop {
  1790. my ( $op, $operator, $flags ) = @_;
  1791. my $force_int = 0;
  1792. $force_int ||= ( $flags & INT_RESULT );
  1793. $force_int ||=
  1794. ( $flags & INTS_CLOSED
  1795. && @stack >= 1
  1796. && valid_int( $stack[-1] ) );
  1797. my $targ = $pad[ $op->targ ];
  1798. $force_int ||= ( $targ->{type} == T_INT );
  1799. if ($force_int) {
  1800. my $arg = B::Pseudoreg->new( "IV", "liv" );
  1801. runtime(sprintf( "$$arg = %s;\t/* %s */",
  1802. pop_numeric, $op->name ) );
  1803. # XXX set targ?
  1804. $targ->set_int( &$operator( $$arg ) );
  1805. }
  1806. else {
  1807. my $arg = B::Pseudoreg->new( "NV", "lnv" );
  1808. runtime(sprintf( "$$arg = %s;\t/* %s */",
  1809. pop_numeric, $op->name ) );
  1810. # XXX set targ?
  1811. $targ->set_numeric( &$operator( $$arg ) );
  1812. }
  1813. push( @stack, $targ );
  1814. return $op->next;
  1815. }
  1816. # coverage: 18
  1817. sub pp_ncmp {
  1818. my ($op) = @_;
  1819. if ( $op->flags & OPf_STACKED ) {
  1820. my $right = pop_numeric();
  1821. if ( @stack >= 1 ) {
  1822. my $left = top_numeric();
  1823. runtime sprintf( "if (%s > %s){\t/* %s */", $left, $right, $op->name );
  1824. $stack[-1]->set_int(1);
  1825. $stack[-1]->write_back();
  1826. runtime sprintf( "}else if (%s < %s ) {", $left, $right );
  1827. $stack[-1]->set_int(-1);
  1828. $stack[-1]->write_back();
  1829. runtime sprintf( "}else if (%s == %s) {", $left, $right );
  1830. $stack[-1]->set_int(0);
  1831. $stack[-1]->write_back();
  1832. runtime sprintf("}else {");
  1833. $stack[-1]->set_sv("&PL_sv_undef");
  1834. runtime "}";
  1835. }
  1836. else {
  1837. my $rightruntime = B::Pseudoreg->new( "NV", "rnv" );
  1838. runtime( sprintf( "$$rightruntime = %s;\t/* %s */", $right, $op->name ) );
  1839. runtime sprintf( qq/if ("TOPn" > %s){/, $rightruntime );
  1840. runtime sprintf(" sv_setiv(TOPs,1);");
  1841. runtime sprintf( qq/}else if ( "TOPn" < %s ) {/, $$rightruntime );
  1842. runtime sprintf(" sv_setiv(TOPs,-1);");
  1843. runtime sprintf( qq/} else if ("TOPn" == %s) {/, $$rightruntime );
  1844. runtime sprintf(" sv_setiv(TOPs,0);");
  1845. runtime sprintf(qq/}else {/);
  1846. runtime sprintf(" sv_setiv(TOPs,&PL_sv_undef;");
  1847. runtime "}";
  1848. }
  1849. }
  1850. else {
  1851. my $targ = $pad[ $op->targ ];
  1852. my $right = B::Pseudoreg->new( "NV", "rnv" );
  1853. my $left = B::Pseudoreg->new( "NV", "lnv" );
  1854. runtime(
  1855. sprintf( "$$right = %s; $$left = %s;\t/* %s */",
  1856. pop_numeric(), pop_numeric, $op->name ) );
  1857. runtime sprintf( "if (%s > %s){ /*targ*/", $$left, $$right );
  1858. $targ->set_int(1);
  1859. $targ->write_back();
  1860. runtime sprintf( "}else if (%s < %s ) {", $$left, $$right );
  1861. $targ->set_int(-1);
  1862. $targ->write_back();
  1863. runtime sprintf( "}else if (%s == %s) {", $$left, $$right );
  1864. $targ->set_int(0);
  1865. $targ->write_back();
  1866. runtime sprintf("}else {");
  1867. $targ->set_sv("&PL_sv_undef");
  1868. runtime "}";
  1869. push( @stack, $targ );
  1870. }
  1871. #runtime "return NULL;";
  1872. return $op->next;
  1873. }
  1874. # coverage: ?
  1875. sub sv_binop {
  1876. my ( $op, $operator, $flags ) = @_;
  1877. if ( $op->flags & OPf_STACKED ) {
  1878. my $right = pop_sv();
  1879. if ( @stack >= 1 ) {
  1880. my $left = top_sv();
  1881. if ( $flags & INT_RESULT ) {
  1882. $stack[-1]->set_int( &$operator( $left, $right ) );
  1883. }
  1884. elsif ( $flags & NUMERIC_RESULT ) {
  1885. $stack[-1]->set_numeric( &$operator( $left, $right ) );
  1886. }
  1887. else {
  1888. # XXX Does this work?
  1889. runtime(
  1890. sprintf( "sv_setsv($left, %s);\t/* %s */",
  1891. &$operator( $left, $right ), $op->name ) );
  1892. $stack[-1]->invalidate;
  1893. }
  1894. }
  1895. else {
  1896. my $f;
  1897. if ( $flags & INT_RESULT ) {
  1898. $f = "sv_setiv";
  1899. }
  1900. elsif ( $flags & NUMERIC_RESULT ) {
  1901. $f = "sv_setnv";
  1902. }
  1903. else {
  1904. $f = "sv_setsv";
  1905. }
  1906. runtime( sprintf( "%s(TOPs, %s);\t/* %s */",
  1907. $f, &$operator( "TOPs", $right ), $op->name ) );
  1908. }
  1909. }
  1910. else {
  1911. my $targ = $pad[ $op->targ ];
  1912. runtime( sprintf( "right = %s; left = %s;\t/* %s */",
  1913. pop_sv(), pop_sv, $op->name ) );
  1914. if ( $flags & INT_RESULT ) {
  1915. $targ->set_int( &$operator( "left", "right" ) );
  1916. }
  1917. elsif ( $flags & NUMERIC_RESULT ) {
  1918. $targ->set_numeric( &$operator( "left", "right" ) );
  1919. }
  1920. else {
  1921. # XXX Does this work?
  1922. runtime(sprintf("sv_setsv(%s, %s);",
  1923. $targ->as_sv, &$operator( "left", "right" ) ));
  1924. $targ->invalidate;
  1925. }
  1926. push( @stack, $targ );
  1927. }
  1928. return $op->next;
  1929. }
  1930. # coverage: ?
  1931. sub bool_int_binop {
  1932. my ( $op, $operator ) = @_;
  1933. my $right = B::Pseudoreg->new( "IV", "riv" );
  1934. my $left = B::Pseudoreg->new( "IV", "liv" );
  1935. runtime( sprintf( "$$right = %s; $$left = %s;\t/* %s */",
  1936. pop_int(), pop_int(), $op->name ) );
  1937. my $bool = B::Stackobj::Bool->new( B::Pseudoreg->new( "int", "b" ) );
  1938. $bool->set_int( &$operator( $$left, $$right ) );
  1939. push( @stack, $bool );
  1940. return $op->next;
  1941. }
  1942. # coverage: ?
  1943. sub bool_numeric_binop {
  1944. my ( $op, $operator ) = @_;
  1945. my $right = B::Pseudoreg->new( "NV", "rnv" );
  1946. my $left = B::Pseudoreg->new( "NV", "lnv" );
  1947. runtime(
  1948. sprintf( "$$right = %s; $$left = %s;\t/* %s */",
  1949. pop_numeric(), pop_numeric(), $op->name ) );
  1950. my $bool = B::Stackobj::Bool->new( B::Pseudoreg->new( "int", "b" ) );
  1951. $bool->set_numeric( &$operator( $$left, $$right ) );
  1952. push( @stack, $bool );
  1953. return $op->next;
  1954. }
  1955. # coverage: ?
  1956. sub bool_sv_binop {
  1957. my ( $op, $operator ) = @_;
  1958. runtime( sprintf( "right = %s; left = %s;\t/* %s */",
  1959. pop_sv(), pop_sv(), $op->name ) );
  1960. my $bool = B::Stackobj::Bool->new( B::Pseudoreg->new( "int", "b" ) );
  1961. $bool->set_numeric( &$operator( "left", "right" ) );
  1962. push( @stack, $bool );
  1963. return $op->next;
  1964. }
  1965. # coverage: ?
  1966. sub infix_op {
  1967. my $opname = shift;
  1968. return sub { "$_[0] $opname $_[1]" }
  1969. }
  1970. # coverage: ?
  1971. sub prefix_op {
  1972. my $opname = shift;
  1973. return sub { sprintf( "%s(%s)", $opname, join( ", ", @_ ) ) }
  1974. }
  1975. BEGIN {
  1976. my $plus_op = infix_op("+");
  1977. my $minus_op = infix_op("-");
  1978. my $multiply_op = infix_op("*");
  1979. my $divide_op = infix_op("/");
  1980. my $modulo_op = infix_op("%");
  1981. my $lshift_op = infix_op("<<");
  1982. my $rshift_op = infix_op(">>");
  1983. my $scmp_op = prefix_op("sv_cmp");
  1984. my $seq_op = prefix_op("sv_eq");
  1985. my $sne_op = prefix_op("!sv_eq");
  1986. my $slt_op = sub { "sv_cmp($_[0], $_[1]) < 0" };
  1987. my $sgt_op = sub { "sv_cmp($_[0], $_[1]) > 0" };
  1988. my $sle_op = sub { "sv_cmp($_[0], $_[1]) <= 0" };
  1989. my $sge_op = sub { "sv_cmp($_[0], $_[1]) >= 0" };
  1990. my $eq_op = infix_op("==");
  1991. my $ne_op = infix_op("!=");
  1992. my $lt_op = infix_op("<");
  1993. my $gt_op = infix_op(">");
  1994. my $le_op = infix_op("<=");
  1995. my $ge_op = infix_op(">=");
  1996. #
  1997. # XXX The standard perl PP code has extra handling for
  1998. # some special case arguments of these operators.
  1999. #
  2000. sub pp_add { numeric_binop( $_[0], $plus_op ) }
  2001. sub pp_subtract { numeric_binop( $_[0], $minus_op ) }
  2002. sub pp_multiply { numeric_binop( $_[0], $multiply_op ) }
  2003. sub pp_divide { numeric_binop( $_[0], $divide_op ) }
  2004. sub pp_modulo { int_binop( $_[0], $modulo_op ) } # differs from perl's
  2005. # http://perldoc.perl.org/perlop.html#Shift-Operators:
  2006. # If use integer is in force then signed C integers are used,
  2007. # else unsigned C integers are used.
  2008. sub pp_left_shift { int_binop( $_[0], $lshift_op, VALID_UNSIGNED ) }
  2009. sub pp_right_shift { int_binop( $_[0], $rshift_op, VALID_UNSIGNED ) }
  2010. sub pp_i_add { int_binop( $_[0], $plus_op ) }
  2011. sub pp_i_subtract { int_binop( $_[0], $minus_op ) }
  2012. sub pp_i_multiply { int_binop( $_[0], $multiply_op ) }
  2013. sub pp_i_divide { int_binop( $_[0], $divide_op ) }
  2014. sub pp_i_modulo { int_binop( $_[0], $modulo_op ) }
  2015. sub pp_eq { bool_numeric_binop( $_[0], $eq_op ) }
  2016. sub pp_ne { bool_numeric_binop( $_[0], $ne_op ) }
  2017. # coverage: 21
  2018. sub pp_lt { bool_numeric_binop( $_[0], $lt_op ) }
  2019. # coverage: 28
  2020. sub pp_gt { bool_numeric_binop( $_[0], $gt_op ) }
  2021. sub pp_le { bool_numeric_binop( $_[0], $le_op ) }
  2022. sub pp_ge { bool_numeric_binop( $_[0], $ge_op ) }
  2023. sub pp_i_eq { bool_int_binop( $_[0], $eq_op ) }
  2024. sub pp_i_ne { bool_int_binop( $_[0], $ne_op ) }
  2025. sub pp_i_lt { bool_int_binop( $_[0], $lt_op ) }
  2026. sub pp_i_gt { bool_int_binop( $_[0], $gt_op ) }
  2027. sub pp_i_le { bool_int_binop( $_[0], $le_op ) }
  2028. sub pp_i_ge { bool_int_binop( $_[0], $ge_op ) }
  2029. sub pp_scmp { sv_binop( $_[0], $scmp_op, INT_RESULT ) }
  2030. sub pp_slt { bool_sv_binop( $_[0], $slt_op ) }
  2031. sub pp_sgt { bool_sv_binop( $_[0], $sgt_op ) }
  2032. sub pp_sle { bool_sv_binop( $_[0], $sle_op ) }
  2033. sub pp_sge { bool_sv_binop( $_[0], $sge_op ) }
  2034. sub pp_seq { bool_sv_binop( $_[0], $seq_op ) }
  2035. sub pp_sne { bool_sv_binop( $_[0], $sne_op ) }
  2036. # sub pp_sin { numeric_unop( $_[0], prefix_op("Perl_sin"), NUMERIC_RESULT ) }
  2037. # sub pp_cos { numeric_unop( $_[0], prefix_op("Perl_cos"), NUMERIC_RESULT ) }
  2038. # sub pp_exp { numeric_unop( $_[0], prefix_op("Perl_exp"), NUMERIC_RESULT ) }
  2039. # sub pp_abs { numeric_unop( $_[0], prefix_op("abs") ) }
  2040. # sub pp_negate { numeric_unop( $_[0], sub { "- $_[0]" }; ) }
  2041. # pow has special perl logic
  2042. ## sub pp_pow { numeric_binop( $_[0], prefix_op("Perl_pow"), NUMERIC_RESULT ) }
  2043. #XXX log and sqrt need to check negative args
  2044. # sub pp_sqrt { numeric_unop( $_[0], prefix_op("Perl_sqrt"), NUMERIC_RESULT ) }
  2045. # sub pp_log { numeric_unop( $_[0], prefix_op("Perl_log"), NUMERIC_RESULT ) }
  2046. # sub pp_atan2 { numeric_binop( $_[0], prefix_op("Perl_atan2"), NUMERIC_RESULT ) }
  2047. }
  2048. # coverage: 3,4,9,10,11,12,17,18,20,21,23
  2049. sub pp_sassign {
  2050. my $op = shift;
  2051. my $backwards = $op->private & OPpASSIGN_BACKWARDS;
  2052. debug( sprintf( "sassign->private=0x%x\n", $op->private ) ) if $debug{op};
  2053. my ( $dst, $src );
  2054. runtime("/* pp_sassign */") if $verbose;
  2055. if ( @stack >= 2 ) {
  2056. $dst = pop @stack;
  2057. $src = pop @stack;
  2058. ( $src, $dst ) = ( $dst, $src ) if $backwards;
  2059. my $type = $src->{type};
  2060. if ( $type == T_INT ) {
  2061. $dst->set_int( $src->as_int, $src->{flags} & VALID_UNSIGNED );
  2062. }
  2063. elsif ( $type == T_NUM ) {
  2064. $dst->set_numeric( $src->as_numeric );
  2065. }
  2066. else {
  2067. $dst->set_sv( $src->as_sv );
  2068. }
  2069. push( @stack, $dst );
  2070. }
  2071. elsif ( @stack == 1 ) {
  2072. if ($backwards) {
  2073. my $src = pop @stack;
  2074. my $type = $src->{type};
  2075. runtime("if (PL_tainting && PL_tainted) TAINT_NOT;") if $opt_taint;
  2076. if ( $type == T_INT ) {
  2077. if ( $src->{flags} & VALID_UNSIGNED ) {
  2078. runtime sprintf( "sv_setuv(TOPs, %s);", $src->as_int );
  2079. }
  2080. else {
  2081. runtime sprintf( "sv_setiv(TOPs, %s);", $src->as_int );
  2082. }
  2083. }
  2084. elsif ( $type == T_NUM ) {
  2085. runtime sprintf( "sv_setnv(TOPs, %s);", $src->as_double );
  2086. }
  2087. else {
  2088. runtime sprintf( "sv_setsv(TOPs, %s);", $src->as_sv );
  2089. }
  2090. runtime("SvSETMAGIC(TOPs);") if $opt_magic;
  2091. }
  2092. else {
  2093. my $dst = $stack[-1];
  2094. my $type = $dst->{type};
  2095. runtime("sv = POPs;");
  2096. runtime("MAYBE_TAINT_SASSIGN_SRC(sv);") if $opt_taint;
  2097. if ( $type == T_INT ) {
  2098. $dst->set_int("SvIV(sv)");
  2099. }
  2100. elsif ( $type == T_NUM ) {
  2101. $dst->set_double("SvNV(sv)");
  2102. }
  2103. else {
  2104. $opt_magic
  2105. ? runtime("SvSetMagicSV($dst->{sv}, sv);")
  2106. : runtime("SvSetSV($dst->{sv}, sv);");
  2107. $dst->invalidate;
  2108. }
  2109. }
  2110. }
  2111. else {
  2112. # empty perl stack, both at run-time
  2113. if ($backwards) {
  2114. runtime("src = POPs; dst = TOPs;");
  2115. }
  2116. else {
  2117. runtime("dst = POPs; src = TOPs;");
  2118. }
  2119. runtime(
  2120. $opt_taint ? "MAYBE_TAINT_SASSIGN_SRC(src);" : "",
  2121. "SvSetSV(dst, src);",
  2122. $opt_magic ? "SvSETMAGIC(dst);" : "",
  2123. "SETs(dst);"
  2124. );
  2125. }
  2126. return $op->next;
  2127. }
  2128. # coverage: ny
  2129. sub pp_preinc {
  2130. my $op = shift;
  2131. if ( @stack >= 1 ) {
  2132. my $obj = $stack[-1];
  2133. my $type = $obj->{type};
  2134. if ( $type == T_INT || $type == T_NUM ) {
  2135. $obj->set_int( $obj->as_int . " + 1" );
  2136. }
  2137. else {
  2138. runtime sprintf( "PP_PREINC(%s);", $obj->as_sv );
  2139. $obj->invalidate();
  2140. }
  2141. }
  2142. else {
  2143. runtime sprintf("PP_PREINC(TOPs);");
  2144. }
  2145. return $op->next;
  2146. }
  2147. # coverage: 1-32,35
  2148. sub pp_pushmark {
  2149. my $op = shift;
  2150. # runtime(sprintf("/* %s */", $op->name)) if $verbose;
  2151. write_back_stack();
  2152. runtime("PUSHMARK(sp);");
  2153. return $op->next;
  2154. }
  2155. # coverage: 28
  2156. sub pp_list {
  2157. my $op = shift;
  2158. runtime(sprintf("/* %s */", $op->name)) if $verbose;
  2159. write_back_stack();
  2160. my $gimme = gimme($op);
  2161. if ( not defined $gimme ) {
  2162. runtime("PP_LIST(block_gimme());");
  2163. } elsif ( $gimme == G_ARRAY ) { # sic
  2164. runtime("POPMARK;"); # need this even though not a "full" pp_list
  2165. }
  2166. else {
  2167. runtime("PP_LIST($gimme);");
  2168. }
  2169. return $op->next;
  2170. }
  2171. # coverage: 6,8,9,10,24,26,27,31,35
  2172. sub pp_entersub {
  2173. my $op = shift;
  2174. runtime(sprintf("/* %s */", $op->name)) if $verbose;
  2175. $curcop->write_back if $curcop;
  2176. write_back_lexicals( REGISTER | TEMPORARY );
  2177. write_back_stack();
  2178. my $sym = doop($op);
  2179. $op->next->save if ${$op->next};
  2180. $op->first->save if ${$op->first} and $op->first->type;
  2181. # sometimes needs an additional check
  2182. my $ck_next = ${$op->next} ? "PL_op != ($sym)->op_next && " : "";
  2183. runtime("while ($ck_next PL_op != (OP*)0 ){",
  2184. "\tPL_op = (*PL_op->op_ppaddr)(aTHX);",
  2185. "\tSPAGAIN;}");
  2186. $know_op = 0;
  2187. invalidate_lexicals( REGISTER | TEMPORARY );
  2188. # B::C::check_entersub($op);
  2189. return $op->next;
  2190. }
  2191. # coverage: 16,26,35,51,72,73
  2192. sub pp_bless {
  2193. my $op = shift;
  2194. $curcop->write_back if $curcop;
  2195. # B::C::check_bless($op);
  2196. default_pp($op);
  2197. }
  2198. # coverage: ny
  2199. sub pp_formline {
  2200. my $op = shift;
  2201. my $ppname = "pp_" . $op->name;
  2202. runtime(sprintf("/* %s */", $ppname)) if $verbose;
  2203. write_back_lexicals() unless $skip_lexicals{$ppname};
  2204. write_back_stack() unless $skip_stack{$ppname};
  2205. my $sym = doop($op);
  2206. # See comment in pp_grepwhile to see why!
  2207. $init->add("((LISTOP*)$sym)->op_first = $sym;");
  2208. runtime("if (PL_op == ((LISTOP*)($sym))->op_first) {");
  2209. save_or_restore_lexical_state( ${ $op->first } );
  2210. runtime( sprintf( "goto %s;", label( $op->first ) ),
  2211. "}");
  2212. return $op->next;
  2213. }
  2214. # coverage: 2,17,21,28,30
  2215. sub pp_goto {
  2216. my $op = shift;
  2217. my $ppname = "pp_" . $op->name;
  2218. runtime(sprintf("/* %s */", $ppname)) if $verbose;
  2219. write_back_lexicals() unless $skip_lexicals{$ppname};
  2220. write_back_stack() unless $skip_stack{$ppname};
  2221. my $sym = doop($op);
  2222. runtime("if (PL_op != ($sym)->op_next && PL_op != (OP*)0){return PL_op;}");
  2223. invalidate_lexicals() unless $skip_invalidate{$ppname};
  2224. return $op->next;
  2225. }
  2226. # coverage: 1-39, c_argv.t 2
  2227. sub pp_enter {
  2228. # XXX fails with simple c_argv.t 2. no cxix. Disabled for now
  2229. if (0 and $inline_ops) {
  2230. my $op = shift;
  2231. runtime(sprintf("/* %s */", $op->name)) if $verbose;
  2232. warn "inlining enter\n" if $debug{op};
  2233. $curcop->write_back if $curcop;
  2234. if (!($op->flags & OPf_WANT)) {
  2235. my $cxix = $#cxstack;
  2236. if ( $cxix >= 0 ) {
  2237. if ( $op->flags & OPf_SPECIAL ) {
  2238. runtime "gimme = block_gimme();";
  2239. } else {
  2240. runtime "gimme = cxstack[cxstack_ix].blk_gimme;";
  2241. }
  2242. } else {
  2243. runtime "gimme = G_SCALAR;";
  2244. }
  2245. } else {
  2246. runtime "gimme = OP_GIMME(PL_op, -1);";
  2247. }
  2248. runtime($] >= 5.011001 and $] < 5.011004
  2249. ? 'ENTER_with_name("block");' : 'ENTER;',
  2250. "SAVETMPS;",
  2251. "PUSHBLOCK(cx, CXt_BLOCK, SP);");
  2252. return $op->next;
  2253. } else {
  2254. return default_pp(@_);
  2255. }
  2256. }
  2257. # coverage: ny
  2258. sub pp_enterwrite { pp_entersub(@_) }
  2259. # coverage: 6,8,9,10,24,26,27,31
  2260. sub pp_leavesub {
  2261. my $op = shift;
  2262. my $ppname = "pp_" . $op->name;
  2263. write_back_lexicals() unless $skip_lexicals{$ppname};
  2264. write_back_stack() unless $skip_stack{$ppname};
  2265. runtime("if (PL_curstackinfo->si_type == PERLSI_SORT){",
  2266. "\tPUTBACK;return 0;",
  2267. "}");
  2268. doop($op);
  2269. return $op->next;
  2270. }
  2271. # coverage: ny
  2272. sub pp_leavewrite {
  2273. my $op = shift;
  2274. write_back_lexicals( REGISTER | TEMPORARY );
  2275. write_back_stack();
  2276. my $sym = doop($op);
  2277. # XXX Is this the right way to distinguish between it returning
  2278. # CvSTART(cv) (via doform) and pop_return()?
  2279. #runtime("if (PL_op) PL_op = (*PL_op->op_ppaddr)(aTHX);");
  2280. runtime("SPAGAIN;");
  2281. $know_op = 0;
  2282. invalidate_lexicals( REGISTER | TEMPORARY );
  2283. return $op->next;
  2284. }
  2285. # coverage: ny
  2286. sub pp_entergiven { pp_enterwrite(@_) }
  2287. # coverage: ny
  2288. sub pp_leavegiven { pp_leavewrite(@_) }
  2289. sub doeval {
  2290. my $op = shift;
  2291. $curcop->write_back;
  2292. write_back_lexicals( REGISTER | TEMPORARY );
  2293. write_back_stack();
  2294. my $sym = loadop($op);
  2295. my $ppaddr = $op->ppaddr;
  2296. runtime("PP_EVAL($ppaddr, ($sym)->op_next);");
  2297. $know_op = 1;
  2298. invalidate_lexicals( REGISTER | TEMPORARY );
  2299. return $op->next;
  2300. }
  2301. # coverage: 12
  2302. sub pp_entereval { doeval(@_) }
  2303. # coverage: ny
  2304. sub pp_dofile { doeval(@_) }
  2305. # coverage: 28
  2306. #pp_require is protected by pp_entertry, so no protection for it.
  2307. sub pp_require {
  2308. my $op = shift;
  2309. $curcop->write_back;
  2310. write_back_lexicals( REGISTER | TEMPORARY );
  2311. write_back_stack();
  2312. my $sym = doop($op);
  2313. # sometimes needs an additional check
  2314. my $ck_next = ${$op->next} ? "PL_op != ($sym)->op_next && " : "";
  2315. runtime("while ($ck_next PL_op != (OP*)0 ) {", #(test 28).
  2316. " PL_op = (*PL_op->op_ppaddr)(aTHX);",
  2317. " SPAGAIN;",
  2318. "}");
  2319. $know_op = 1;
  2320. invalidate_lexicals( REGISTER | TEMPORARY );
  2321. # B::C::check_require($op); # mark package
  2322. return $op->next;
  2323. }
  2324. # coverage: 32
  2325. sub pp_entertry {
  2326. my $op = shift;
  2327. $curcop->write_back;
  2328. write_back_lexicals( REGISTER | TEMPORARY );
  2329. write_back_stack();
  2330. my $sym = doop($op);
  2331. $entertry_defined = 1;
  2332. my $next = $op->next; # broken in 5.12, fixed in B::C by upgrading BASEOP
  2333. # jump past leavetry
  2334. $next = $op->other->next if $op->can("other"); # before 5.11.4 and after 5.13.8
  2335. my $l = label( $next );
  2336. debug "ENTERTRY label=$l (".ref($op).") ->".$next->name."(".ref($next).")\n";
  2337. runtime(sprintf( "PP_ENTERTRY(%s);", $l));
  2338. if ($next->isa('B::COP')) {
  2339. push_label($next, 'nextstate');
  2340. } else {
  2341. push_label($op->other, 'leavetry') if $op->can("other");
  2342. }
  2343. invalidate_lexicals( REGISTER | TEMPORARY );
  2344. return $op->next;
  2345. }
  2346. # coverage: 32
  2347. sub pp_leavetry {
  2348. my $op = shift;
  2349. pop_label 'leavetry' if $labels->{'leavetry'}->[-1] and $labels->{'leavetry'}->[-1] == $op;
  2350. default_pp($op);
  2351. runtime("PP_LEAVETRY;");
  2352. write_label($op->next);
  2353. return $op->next;
  2354. }
  2355. # coverage: ny
  2356. sub pp_grepstart {
  2357. my $op = shift;
  2358. if ( $need_freetmps && $freetmps_each_loop ) {
  2359. runtime("FREETMPS;"); # otherwise the grepwhile loop messes things up
  2360. $need_freetmps = 0;
  2361. }
  2362. write_back_stack();
  2363. my $sym = doop($op);
  2364. my $next = $op->next;
  2365. $next->save;
  2366. my $nexttonext = $next->next;
  2367. $nexttonext->save;
  2368. save_or_restore_lexical_state($$nexttonext);
  2369. runtime(
  2370. sprintf( "if (PL_op == (($sym)->op_next)->op_next) goto %s;",
  2371. label($nexttonext) )
  2372. );
  2373. return $op->next->other;
  2374. }
  2375. # coverage: ny
  2376. sub pp_mapstart {
  2377. my $op = shift;
  2378. if ( $need_freetmps && $freetmps_each_loop ) {
  2379. runtime("FREETMPS;"); # otherwise the mapwhile loop messes things up
  2380. $need_freetmps = 0;
  2381. }
  2382. write_back_stack();
  2383. # pp_mapstart can return either op_next->op_next or op_next->op_other and
  2384. # we need to be able to distinguish the two at runtime.
  2385. my $sym = doop($op);
  2386. my $next = $op->next;
  2387. $next->save;
  2388. my $nexttonext = $next->next;
  2389. $nexttonext->save;
  2390. save_or_restore_lexical_state($$nexttonext);
  2391. runtime(
  2392. sprintf( "if (PL_op == (($sym)->op_next)->op_next) goto %s;",
  2393. label($nexttonext) )
  2394. );
  2395. return $op->next->other;
  2396. }
  2397. # coverage: ny
  2398. sub pp_grepwhile {
  2399. my $op = shift;
  2400. my $next = $op->next;
  2401. unshift( @bblock_todo, $next );
  2402. write_back_lexicals();
  2403. write_back_stack();
  2404. my $sym = doop($op);
  2405. # pp_grepwhile can return either op_next or op_other and we need to
  2406. # be able to distinguish the two at runtime. Since it's possible for
  2407. # both ops to be "inlined", the fields could both be zero. To get
  2408. # around that, we hack op_next to be our own op (purely because we
  2409. # know it's a non-NULL pointer and can't be the same as op_other).
  2410. $init->add("((LOGOP*)$sym)->op_next = $sym;");
  2411. save_or_restore_lexical_state($$next);
  2412. runtime( sprintf( "if (PL_op == ($sym)->op_next) goto %s;", label($next) ) );
  2413. $know_op = 0;
  2414. return $op->other;
  2415. }
  2416. # coverage: ny
  2417. sub pp_mapwhile { pp_grepwhile(@_) }
  2418. # coverage: 24
  2419. sub pp_return {
  2420. my $op = shift;
  2421. write_back_lexicals( REGISTER | TEMPORARY );
  2422. write_back_stack();
  2423. doop($op);
  2424. runtime( "PUTBACK;", "return PL_op;" );
  2425. $know_op = 0;
  2426. return $op->next;
  2427. }
  2428. sub nyi {
  2429. my $op = shift;
  2430. warn sprintf( "Warning: %s not yet implemented properly\n", $op->ppaddr );
  2431. return default_pp($op);
  2432. }
  2433. # coverage: 17
  2434. sub pp_range {
  2435. my $op = shift;
  2436. my $flags = $op->flags;
  2437. if ( !( $flags & OPf_WANT ) ) {
  2438. if ($strict) {
  2439. error("context of range unknown at compile-time\n");
  2440. } else {
  2441. warn("Warning: context of range unknown at compile-time\n");
  2442. runtime('warn("context of range unknown at compile-time");');
  2443. }
  2444. return default_pp($op);
  2445. }
  2446. write_back_lexicals();
  2447. write_back_stack();
  2448. unless ( ( $flags & OPf_WANT ) == OPf_WANT_LIST ) {
  2449. # We need to save our UNOP structure since pp_flop uses
  2450. # it to find and adjust out targ. We don't need it ourselves.
  2451. $op->save;
  2452. save_or_restore_lexical_state( ${ $op->other } );
  2453. runtime sprintf( "if (SvTRUE(PL_curpad[%d])) goto %s;",
  2454. $op->targ, label( $op->other ) );
  2455. unshift( @bblock_todo, $op->other );
  2456. }
  2457. return $op->next;
  2458. }
  2459. # coverage: 17, 30
  2460. sub pp_flip {
  2461. my $op = shift;
  2462. my $flags = $op->flags;
  2463. if ( !( $flags & OPf_WANT ) ) {
  2464. if ($strict) {
  2465. error("context of flip unknown at compile-time\n");
  2466. } else {
  2467. warn("Warning: context of flip unknown at compile-time\n");
  2468. runtime('warn("context of flip unknown at compile-time");');
  2469. }
  2470. return default_pp($op);
  2471. }
  2472. if ( ( $flags & OPf_WANT ) == OPf_WANT_LIST ) {
  2473. return $op->first->other;
  2474. }
  2475. write_back_lexicals();
  2476. write_back_stack();
  2477. # We need to save our UNOP structure since pp_flop uses
  2478. # it to find and adjust out targ. We don't need it ourselves.
  2479. $op->save;
  2480. my $ix = $op->targ;
  2481. my $rangeix = $op->first->targ;
  2482. runtime(
  2483. ( $op->private & OPpFLIP_LINENUM )
  2484. ? "if (PL_last_in_gv && SvIV(TOPs) == IoLINES(GvIOp(PL_last_in_gv))) {"
  2485. : "if (SvTRUE(TOPs)) {"
  2486. );
  2487. runtime("\tsv_setiv(PL_curpad[$rangeix], 1);");
  2488. if ( $op->flags & OPf_SPECIAL ) {
  2489. runtime("sv_setiv(PL_curpad[$ix], 1);");
  2490. }
  2491. else {
  2492. save_or_restore_lexical_state( ${ $op->first->other } );
  2493. runtime( "\tsv_setiv(PL_curpad[$ix], 0);",
  2494. "\tsp--;", sprintf( "\tgoto %s;", label( $op->first->other ) ) );
  2495. }
  2496. runtime( "}", qq{sv_setpv(PL_curpad[$ix], "");}, "SETs(PL_curpad[$ix]);" );
  2497. $know_op = 0;
  2498. return $op->next;
  2499. }
  2500. # coverage: 17
  2501. sub pp_flop {
  2502. my $op = shift;
  2503. default_pp($op);
  2504. $know_op = 0;
  2505. return $op->next;
  2506. }
  2507. sub enterloop {
  2508. my $op = shift;
  2509. my $nextop = $op->nextop;
  2510. my $lastop = $op->lastop;
  2511. my $redoop = $op->redoop;
  2512. $curcop->write_back if $curcop;
  2513. debug "enterloop: pushing on cxstack\n" if $debug{cxstack};
  2514. push(
  2515. @cxstack,
  2516. {
  2517. type => $PERL512 ? CXt_LOOP_PLAIN : CXt_LOOP,
  2518. op => $op,
  2519. "label" => $curcop->[0]->label,
  2520. nextop => $nextop,
  2521. lastop => $lastop,
  2522. redoop => $redoop
  2523. }
  2524. );
  2525. debug sprintf("enterloop: cxstack label %s\n", $curcop->[0]->label) if $debug{cxstack};
  2526. $nextop->save;
  2527. $lastop->save;
  2528. $redoop->save;
  2529. # We need to compile the corresponding pp_leaveloop even if it's
  2530. # never executed. This is needed to get @cxstack right.
  2531. # Use case: while(1) { .. }
  2532. unshift @bblock_todo, ($lastop);
  2533. if (0 and $inline_ops and $op->name eq 'enterloop') {
  2534. warn "inlining enterloop\n" if $debug{op};
  2535. # XXX = GIMME_V fails on freebsd7 5.8.8 (28)
  2536. # = block_gimme() fails on the rest, but passes on freebsd7
  2537. runtime "gimme = GIMME_V;"; # XXX
  2538. if ($PERL512) {
  2539. runtime('ENTER_with_name("loop1");',
  2540. 'SAVETMPS;',
  2541. 'ENTER_with_name("loop2");',
  2542. 'PUSHBLOCK(cx, CXt_LOOP_PLAIN, SP);',
  2543. 'PUSHLOOP_PLAIN(cx, SP);');
  2544. } else {
  2545. runtime('ENTER;',
  2546. 'SAVETMPS;',
  2547. 'ENTER;',
  2548. 'PUSHBLOCK(cx, CXt_LOOP, SP);',
  2549. 'PUSHLOOP(cx, 0, SP);');
  2550. }
  2551. return $op->next;
  2552. } else {
  2553. return default_pp($op);
  2554. }
  2555. }
  2556. # coverage: 6,21,28,30
  2557. sub pp_enterloop { enterloop(@_) }
  2558. # coverage: 2
  2559. sub pp_enteriter { enterloop(@_) }
  2560. # coverage: 6,21,28,30
  2561. sub pp_leaveloop {
  2562. my $op = shift;
  2563. if ( !@cxstack ) {
  2564. die "panic: leaveloop, no cxstack";
  2565. }
  2566. debug "leaveloop: popping from cxstack\n" if $debug{cxstack};
  2567. pop(@cxstack);
  2568. return default_pp($op);
  2569. }
  2570. # coverage: ?
  2571. sub pp_next {
  2572. my $op = shift;
  2573. my $cxix;
  2574. if ( $op->flags & OPf_SPECIAL ) {
  2575. $cxix = dopoptoloop();
  2576. if ( $cxix < 0 ) {
  2577. warn "Warning: \"next\" used outside loop\n";
  2578. return default_pp($op); # no optimization
  2579. }
  2580. }
  2581. else {
  2582. my $label = $op->pv;
  2583. if ($label) {
  2584. $cxix = dopoptolabel( $label );
  2585. if ( $cxix < 0 ) {
  2586. # coverage: t/testcc 21
  2587. warn(sprintf("Warning: Label not found at compile time for \"next %s\"\n", $label ));
  2588. $labels->{nlabel}->{$label} = $$op;
  2589. return $op->next;
  2590. }
  2591. }
  2592. # Add support to leave non-loop blocks.
  2593. if ( CxTYPE_no_LOOP( $cxstack[$cxix] ) ) {
  2594. if (!$cxstack[$cxix]->{'nextop'} or !$cxstack[$cxix]->{'label'}) {
  2595. error("Use of \"next\" for non-loop and non-label blocks not yet implemented\n");
  2596. }
  2597. }
  2598. }
  2599. default_pp($op);
  2600. my $nextop = $cxstack[$cxix]->{nextop};
  2601. if ($nextop) {
  2602. push( @bblock_todo, $nextop );
  2603. save_or_restore_lexical_state($$nextop);
  2604. runtime( sprintf( "goto %s;", label($nextop) ) );
  2605. }
  2606. return $op->next;
  2607. }
  2608. # coverage: ?
  2609. sub pp_redo {
  2610. my $op = shift;
  2611. my $cxix;
  2612. if ( $op->flags & OPf_SPECIAL ) {
  2613. $cxix = dopoptoloop();
  2614. if ( $cxix < 0 ) {
  2615. #warn("Warning: \"redo\" used outside loop\n");
  2616. return default_pp($op); # no optimization
  2617. }
  2618. }
  2619. else {
  2620. my $label = $op->pv;
  2621. if ($label) {
  2622. $cxix = dopoptolabel( $label );
  2623. if ( $cxix < 0 ) {
  2624. warn(sprintf("Warning: Label not found at compile time for \"redo %s\"\n", $label ));
  2625. $labels->{nlabel}->{$label} = $$op;
  2626. return $op->next;
  2627. }
  2628. }
  2629. # Add support to leave non-loop blocks.
  2630. if ( CxTYPE_no_LOOP( $cxstack[$cxix] ) ) {
  2631. if (!$cxstack[$cxix]->{'redoop'} or !$cxstack[$cxix]->{'label'}) {
  2632. error("Use of \"redo\" for non-loop and non-label blocks not yet implemented\n");
  2633. }
  2634. }
  2635. }
  2636. default_pp($op);
  2637. my $redoop = $cxstack[$cxix]->{redoop};
  2638. if ($redoop) {
  2639. push( @bblock_todo, $redoop );
  2640. save_or_restore_lexical_state($$redoop);
  2641. runtime( sprintf( "goto %s;", label($redoop) ) );
  2642. }
  2643. return $op->next;
  2644. }
  2645. # coverage: issue36, cc_last.t
  2646. sub pp_last {
  2647. my $op = shift;
  2648. my $cxix;
  2649. if ( $op->flags & OPf_SPECIAL ) {
  2650. $cxix = dopoptoloop();
  2651. if ( $cxix < 0 ) {
  2652. #warn("Warning: \"last\" used outside loop\n");
  2653. return default_pp($op); # no optimization
  2654. }
  2655. }
  2656. elsif (ref($op) eq 'B::PVOP') { # !OPf_STACKED
  2657. my $label = $op->pv;
  2658. if ($label) {
  2659. $cxix = dopoptolabel( $label );
  2660. if ( $cxix < 0 ) {
  2661. # coverage: cc_last.t 2 (ok) 4 (ok)
  2662. warn( sprintf("Warning: Label not found at compile time for \"last %s\"\n", $label ));
  2663. # last does not jump into the future, by name without $$op
  2664. # instead it should jump to the block afterwards
  2665. $labels->{nlabel}->{$label} = $$op;
  2666. return $op->next;
  2667. }
  2668. }
  2669. # Add support to leave non-loop blocks. label fixed with 1.11
  2670. if ( CxTYPE_no_LOOP( $cxstack[$cxix] ) ) {
  2671. if (!$cxstack[$cxix]->{'lastop'} or !$cxstack[$cxix]->{'label'}) {
  2672. error("Use of \"last\" for non-loop and non-label blocks not yet implemented\n");
  2673. }
  2674. }
  2675. }
  2676. default_pp($op);
  2677. if ($cxstack[$cxix]->{lastop} and $cxstack[$cxix]->{lastop}->next) {
  2678. my $lastop = $cxstack[$cxix]->{lastop}->next;
  2679. push( @bblock_todo, $lastop );
  2680. save_or_restore_lexical_state($$lastop);
  2681. runtime( sprintf( "goto %s;", label($lastop) ) );
  2682. }
  2683. return $op->next;
  2684. }
  2685. # coverage: 3,4
  2686. sub pp_subst {
  2687. my $op = shift;
  2688. write_back_lexicals();
  2689. write_back_stack();
  2690. my $sym = doop($op);
  2691. my $replroot = $op->pmreplroot;
  2692. if ($$replroot) {
  2693. save_or_restore_lexical_state($$replroot);
  2694. runtime sprintf(
  2695. "if (PL_op == ((PMOP*)(%s))%s) goto %s;",
  2696. $sym, $PERL510 ? "->op_pmreplrootu.op_pmreplroot" : "->op_pmreplroot",
  2697. label($replroot)
  2698. );
  2699. $op->pmreplstart->save;
  2700. push( @bblock_todo, $replroot );
  2701. }
  2702. invalidate_lexicals();
  2703. return $op->next;
  2704. }
  2705. # coverage: 3
  2706. sub pp_substcont {
  2707. my $op = shift;
  2708. write_back_lexicals();
  2709. write_back_stack();
  2710. doop($op);
  2711. my $pmop = $op->other;
  2712. #warn sprintf( "substcont: op = %s, pmop = %s\n", peekop($op), peekop($pmop) ) if $verbose;
  2713. # my $pmopsym = objsym($pmop);
  2714. my $pmopsym = $pmop->save; # XXX can this recurse?
  2715. # warn "pmopsym = $pmopsym\n" if $verbose;
  2716. save_or_restore_lexical_state( ${ $pmop->pmreplstart } );
  2717. runtime sprintf(
  2718. "if (PL_op == ((PMOP*)(%s))%s) goto %s;",
  2719. $pmopsym,
  2720. $PERL510 ? "->op_pmstashstartu.op_pmreplstart" : "->op_pmreplstart",
  2721. label( $pmop->pmreplstart )
  2722. );
  2723. push( @bblock_todo, $pmop->pmreplstart );
  2724. invalidate_lexicals();
  2725. return $pmop->next;
  2726. }
  2727. # coverage: issue24
  2728. # resolve the DBM library at compile-time, not at run-time
  2729. sub pp_dbmopen {
  2730. my $op = shift;
  2731. require AnyDBM_File;
  2732. my $dbm = $AnyDBM_File::ISA[0];
  2733. svref_2object( \&{"$dbm\::bootstrap"} )->save;
  2734. return default_pp($op);
  2735. }
  2736. sub default_pp {
  2737. my $op = shift;
  2738. my $ppname = "pp_" . $op->name;
  2739. # runtime(sprintf("/* %s */", $ppname)) if $verbose;
  2740. if ( $curcop and $need_curcop{$ppname} ) {
  2741. $curcop->write_back;
  2742. }
  2743. write_back_lexicals() unless $skip_lexicals{$ppname};
  2744. write_back_stack() unless $skip_stack{$ppname};
  2745. doop($op);
  2746. # XXX If the only way that ops can write to a TEMPORARY lexical is
  2747. # when it's named in $op->targ then we could call
  2748. # invalidate_lexicals(TEMPORARY) and avoid having to write back all
  2749. # the temporaries. For now, we'll play it safe and write back the lot.
  2750. invalidate_lexicals() unless $skip_invalidate{$ppname};
  2751. return $op->next;
  2752. }
  2753. sub compile_op {
  2754. my $op = shift;
  2755. my $ppname = "pp_" . $op->name;
  2756. if ( exists $ignore_op{$ppname} ) {
  2757. return $op->next;
  2758. }
  2759. debug peek_stack() if $debug{stack};
  2760. if ( $debug{op} ) {
  2761. debug sprintf( "%s [%s]\n",
  2762. peekop($op), $op->flags & OPf_STACKED ? "OPf_STACKED" : $op->targ );
  2763. }
  2764. no strict 'refs';
  2765. if ( defined(&$ppname) ) {
  2766. $know_op = 0;
  2767. return &$ppname($op);
  2768. }
  2769. else {
  2770. return default_pp($op);
  2771. }
  2772. }
  2773. sub compile_bblock {
  2774. my $op = shift;
  2775. warn "compile_bblock: ", peekop($op), "\n" if $debug{bblock};
  2776. save_or_restore_lexical_state($$op);
  2777. write_label($op);
  2778. $know_op = 0;
  2779. do {
  2780. $op = compile_op($op);
  2781. if ($] < 5.013 and ($opt_slow_signals or ($$op and $async_signals{$op->name}))) {
  2782. runtime("PERL_ASYNC_CHECK();");
  2783. }
  2784. } while ( defined($op) && $$op && !exists( $leaders->{$$op} ) );
  2785. write_back_stack(); # boo hoo: big loss
  2786. reload_lexicals();
  2787. return $op;
  2788. }
  2789. sub cc {
  2790. my ( $name, $root, $start, @padlist ) = @_;
  2791. my $op;
  2792. if ( $done{$$start} ) {
  2793. warn "repeat=>" . ref($start) . " $name,\n" if $verbose;
  2794. $decl->add( sprintf( "#define $name %s", $done{$$start} ) );
  2795. return;
  2796. }
  2797. return if ref($padlist[0]) !~ /^B::(AV|PADNAMELIST)$/ or ref($padlist[1]) ne 'B::AV';
  2798. warn "cc $name\n" if $verbose;
  2799. init_pp($name);
  2800. load_pad(@padlist);
  2801. %lexstate = ();
  2802. B::Pseudoreg->new_scope;
  2803. @cxstack = ();
  2804. if ( $debug{timings} ) {
  2805. warn sprintf( "Basic block analysis at %s\n", timing_info );
  2806. }
  2807. $leaders = find_leaders( $root, $start );
  2808. my @leaders = keys %$leaders;
  2809. if ( $#leaders > -1 ) {
  2810. # Don't add basic blocks of dead code.
  2811. # It would produce errors when processing $cxstack.
  2812. # @bblock_todo = ( values %$leaders );
  2813. # Instead, save $root (pp_leavesub) separately,
  2814. # because it will not get compiled if located in dead code.
  2815. $root->save;
  2816. unshift @bblock_todo, ($start) if $$start;
  2817. }
  2818. else {
  2819. runtime("return PL_op?PL_op->op_next:0;");
  2820. }
  2821. if ( $debug{timings} ) {
  2822. warn sprintf( "Compilation at %s\n", timing_info );
  2823. }
  2824. while (@bblock_todo) {
  2825. $op = shift @bblock_todo;
  2826. warn sprintf( "Considering basic block %s\n", peekop($op) ) if $debug{bblock};
  2827. next if !defined($op) || !$$op || $done{$$op};
  2828. warn "...compiling it\n" if $debug{bblock};
  2829. do {
  2830. $done{$$op} = $name;
  2831. $op = compile_bblock($op);
  2832. if ( $need_freetmps && $freetmps_each_bblock ) {
  2833. runtime("FREETMPS;");
  2834. $need_freetmps = 0;
  2835. }
  2836. } while defined($op) && $$op && !$done{$$op};
  2837. if ( $need_freetmps && $freetmps_each_loop ) {
  2838. runtime("FREETMPS;");
  2839. $need_freetmps = 0;
  2840. }
  2841. if ( !$$op ) {
  2842. runtime( "PUTBACK;",
  2843. "return NULL;" );
  2844. }
  2845. elsif ( $done{$$op} ) {
  2846. save_or_restore_lexical_state($$op);
  2847. runtime( sprintf( "goto %s;", label($op) ) );
  2848. }
  2849. }
  2850. if ( $debug{timings} ) {
  2851. warn sprintf( "Saving runtime at %s\n", timing_info );
  2852. }
  2853. declare_pad(@padlist);
  2854. save_runtime();
  2855. }
  2856. sub cc_recurse {
  2857. my ($ccinfo);
  2858. my $start = cc_queue(@_) if @_;
  2859. while ( $ccinfo = shift @cc_todo ) {
  2860. if ($ccinfo->[0] eq 'pp_sub_warnings__register_categories') {
  2861. # patch broken PADLIST
  2862. #warn "cc $ccinfo->[0] patch broken PADLIST (inc-i340)\n" if $verbose;
  2863. #debug "cc(ccinfo): @$ccinfo skipped (inc-i340)\n" if $debug{queue};
  2864. #$ccinfo->[0] = 'NULL';
  2865. my @empty = ();
  2866. #$ccinfo->[3] = $ccinfo->[4] = svref_2object(\@empty);
  2867. }
  2868. if ($DB::deep and $ccinfo->[0] =~ /^pp_sub_(DB|Term__ReadLine)_/) {
  2869. warn "cc $ccinfo->[0] skipped (debugging)\n" if $verbose;
  2870. debug "cc(ccinfo): @$ccinfo skipped (debugging)\n" if $debug{queue};
  2871. }
  2872. elsif (exists $cc_pp_sub{$ccinfo->[0]}) { # skip duplicates
  2873. warn "cc $ccinfo->[0] already defined\n" if $verbose;
  2874. debug "cc(ccinfo): @$ccinfo already defined\n" if $debug{queue};
  2875. while (exists $cc_pp_sub{$ccinfo->[0]}) {
  2876. if ($ccinfo->[0] =~ /^(pp_(?:lex)?sub_.*_)(\d*)$/) {
  2877. my $s = $2;
  2878. $s++;
  2879. $ccinfo->[0] = $1 . $s;
  2880. } else {
  2881. $ccinfo->[0] .= '_0';
  2882. }
  2883. }
  2884. warn "cc renamed to $ccinfo->[0]\n" if $verbose;
  2885. cc(@$ccinfo);
  2886. $cc_pp_sub{$ccinfo->[0]}++;
  2887. } else {
  2888. debug "cc(ccinfo): @$ccinfo\n" if $debug{queue};
  2889. cc(@$ccinfo);
  2890. $cc_pp_sub{$ccinfo->[0]}++;
  2891. }
  2892. }
  2893. return $start;
  2894. }
  2895. sub cc_obj {
  2896. my ( $name, $cvref ) = @_;
  2897. my $cv = svref_2object($cvref);
  2898. my @padlist = $cv->PADLIST->ARRAY;
  2899. my $curpad_sym = $padlist[1]->save;
  2900. set_curcv $cv;
  2901. cc_recurse( $name, $cv->ROOT, $cv->START, @padlist );
  2902. }
  2903. sub cc_main {
  2904. my @comppadlist = comppadlist->ARRAY;
  2905. my $curpad_nam = $comppadlist[0]->save('curpad_name');
  2906. my $curpad_sym = $comppadlist[1]->save('curpad_syms');;
  2907. my $init_av = init_av->save('INIT');
  2908. set_curcv B::main_cv;
  2909. my $start = cc_recurse( "pp_main", main_root, main_start, @comppadlist );
  2910. # Do save_unused_subs before saving inc_hv
  2911. B::C::module($module) if $module;
  2912. save_unused_subs();
  2913. my $warner = $SIG{__WARN__};
  2914. save_sig($warner);
  2915. my($inc_hv, $inc_av, $end_av);
  2916. if ( !defined($module) ) {
  2917. # forbid run-time extends of curpad syms, names and INC
  2918. warn "save context:\n" if $verbose;
  2919. $init->add("/* save context */");
  2920. $init->add('/* %INC */');
  2921. inc_cleanup();
  2922. my $inc_gv = svref_2object( \*main::INC );
  2923. $inc_hv = $inc_gv->HV->save('main::INC');
  2924. $init->add( sprintf( "GvHV(%s) = s\\_%x;",
  2925. $inc_gv->save('main::INC'), $inc_gv->HV ) );
  2926. local ($B::C::const_strings);
  2927. $B::C::const_strings = 1 if $B::C::ro_inc;
  2928. $inc_hv = $inc_gv->HV->save('main::INC');
  2929. $inc_av = $inc_gv->AV->save('main::INC');
  2930. }
  2931. {
  2932. # >=5.10 needs to defer nullifying of all vars in END, not only new ones.
  2933. local ($B::C::const_strings);
  2934. $B::C::in_endav = 1;
  2935. $end_av = end_av->save('END');
  2936. }
  2937. cc_recurse();
  2938. return if $errors or $check;
  2939. if ( !defined($module) ) {
  2940. # XXX TODO push BEGIN/END blocks to modules code.
  2941. $init->add(
  2942. sprintf( "PL_main_root = s\\_%x;", ${ main_root() } ),
  2943. "PL_main_start = $start;",
  2944. "PL_curpad = AvARRAY($curpad_sym);",
  2945. "PL_comppad = $curpad_sym;");
  2946. if ($] < 5.017005) {
  2947. $init->add(
  2948. "av_store((AV*)CvPADLIST(PL_main_cv), 0, SvREFCNT_inc($curpad_nam)); /* namepad */",
  2949. "av_store((AV*)CvPADLIST(PL_main_cv), 1, SvREFCNT_inc($curpad_sym)); /* curpad */");
  2950. } else {
  2951. $init->add(
  2952. "PadlistARRAY(CvPADLIST(PL_main_cv))[0] = (PAD*)SvREFCNT_inc($curpad_nam); /* namepad */",
  2953. "PadlistARRAY(CvPADLIST(PL_main_cv))[1] = (PAD*)SvREFCNT_inc($curpad_sym); /* curpad */");
  2954. }
  2955. $init->add(
  2956. "GvHV(PL_incgv) = $inc_hv;",
  2957. "GvAV(PL_incgv) = $inc_av;",
  2958. "PL_initav = (AV*)$init_av;",
  2959. "PL_endav = (AV*)$end_av;");
  2960. if ($] < 5.017) {
  2961. my $amagic_generate = B::amagic_generation;
  2962. $init->add("PL_amagic_generation = $amagic_generate;");
  2963. };
  2964. }
  2965. seek( STDOUT, 0, 0 ); #prevent print statements from BEGIN{} into the output
  2966. fixup_ppaddr();
  2967. print "/* using B::CC $B::CC::VERSION backend */\n";
  2968. output_boilerplate();
  2969. print "\n";
  2970. output_all("perl_init");
  2971. output_runtime();
  2972. print "\n";
  2973. output_main_rest();
  2974. if ( defined($module) ) {
  2975. my $cmodule = $module ||= 'main';
  2976. $cmodule =~ s/::/__/g;
  2977. print <<"EOT";
  2978. #include "XSUB.h"
  2979. XS(boot_$cmodule)
  2980. {
  2981. dXSARGS;
  2982. perl_init();
  2983. ENTER;
  2984. SAVETMPS;
  2985. SAVEVPTR(PL_curpad);
  2986. SAVEVPTR(PL_op);
  2987. PL_curpad = AvARRAY($curpad_sym);
  2988. PL_op = $start;
  2989. pp_main(aTHX);
  2990. FREETMPS;
  2991. LEAVE;
  2992. ST(0) = &PL_sv_yes;
  2993. XSRETURN(1);
  2994. }
  2995. EOT
  2996. } else {
  2997. output_main();
  2998. }
  2999. if ( $debug{timings} ) {
  3000. warn sprintf( "Done at %s\n", timing_info );
  3001. }
  3002. }
  3003. sub compile_stats {
  3004. my $s = "Total number of OPs processed: $op_count\n";
  3005. $s .= "Total number of unresolved symbols: $B::C::unresolved_count\n"
  3006. if $B::C::unresolved_count;
  3007. return $s;
  3008. }
  3009. # Accessible via use B::CC '-ftype-attr'; in user code, or -MB::CC=-O2 on the cmdline
  3010. sub import {
  3011. my @options = @_;
  3012. # Allow debugging in CHECK blocks without Od
  3013. $DB::single = 1 if defined &DB::DB;
  3014. my ( $option, $opt, $arg );
  3015. # init with -O0
  3016. foreach my $ref ( values %optimise ) {
  3017. $$ref = 0;
  3018. }
  3019. $B::C::fold = 0 if $] >= 5.013009; # utf8::Cased tables
  3020. $B::C::warnings = 0 if $] >= 5.013005; # Carp warnings categories and B
  3021. $B::C::destruct = 0 unless $] < 5.008; # fast_destruct
  3022. $opt_taint = 1;
  3023. $opt_magic = 1; # only makes sense with -fno-magic
  3024. $opt_autovivify = 1; # only makes sense with -fno-autovivify
  3025. OPTION:
  3026. while ( $option = shift @options ) {
  3027. if ( $option =~ /^-(.)(.*)/ ) {
  3028. $opt = $1;
  3029. $arg = $2;
  3030. }
  3031. else {
  3032. unshift @options, $option;
  3033. last OPTION;
  3034. }
  3035. if ( $opt eq "-" && $arg eq "-" ) {
  3036. shift @options;
  3037. last OPTION;
  3038. }
  3039. elsif ( $opt eq "o" ) {
  3040. $arg ||= shift @options;
  3041. open( STDOUT, ">$arg" ) or return "open '>$arg': $!\n";
  3042. }
  3043. elsif ( $opt eq "c" ) {
  3044. $check = 1;
  3045. $B::C::check = 1;
  3046. }
  3047. elsif ( $opt eq "v" ) {
  3048. $verbose = 1;
  3049. B::C::verbose(1); # crashed in C _save_common_middle(B::FAKEOP)
  3050. }
  3051. elsif ( $opt eq "u" ) {
  3052. $arg ||= shift @options;
  3053. eval "require $arg;";
  3054. mark_unused( $arg, 1 );
  3055. }
  3056. elsif ( $opt eq "U" ) {
  3057. $arg ||= shift @options;
  3058. mark_skip( $arg );
  3059. }
  3060. elsif ( $opt eq "strict" ) {
  3061. $arg ||= shift @options;
  3062. $strict++;
  3063. }
  3064. elsif ( $opt eq "f" ) {
  3065. $arg ||= shift @options;
  3066. my $value = $arg !~ s/^no-//;
  3067. $arg =~ s/-/_/g;
  3068. my $ref = $optimise{$arg};
  3069. if ( defined($ref) ) {
  3070. $$ref = $value;
  3071. }
  3072. else {
  3073. # Pass down to B::C
  3074. my $ref = $B::C::option_map{$arg};
  3075. if ( defined($ref) ) {
  3076. $$ref = $value;
  3077. $c_optimise{$ref}++;
  3078. }
  3079. else {
  3080. warn qq(Warning: ignoring unknown optimisation "$arg"\n);
  3081. }
  3082. }
  3083. }
  3084. elsif ( $opt eq "O" ) {
  3085. $arg = 1 if $arg eq "";
  3086. foreach my $ref ( values %optimise ) {
  3087. $$ref = 0;
  3088. }
  3089. if ($arg >= 2) {
  3090. $freetmps_each_loop = 1;
  3091. if (!$ITHREADS) {
  3092. #warn qq(Warning: ignoring -faelem with threaded perl\n);
  3093. $opt_aelem = 1; # unstable, test: 68 pp_padhv targ assert
  3094. }
  3095. }
  3096. if ( $arg >= 1 ) {
  3097. $opt_type_attr = 1;
  3098. $freetmps_each_bblock = 1 unless $freetmps_each_loop;
  3099. }
  3100. }
  3101. elsif ( $opt eq "n" ) {
  3102. $arg ||= shift @options;
  3103. $init_name = $arg;
  3104. }
  3105. elsif ( $opt eq "m" ) {
  3106. $module = $arg;
  3107. mark_unused( $arg, undef );
  3108. }
  3109. #elsif ( $opt eq "p" ) {
  3110. # $arg ||= shift @options;
  3111. # $patchlevel = $arg;
  3112. #}
  3113. elsif ( $opt eq "D" ) {
  3114. $arg ||= shift @options;
  3115. $verbose++;
  3116. # note that we should not clash too much with the B::C debug map
  3117. # because we set theirs also
  3118. my %debug_map = (O => 'op',
  3119. T => 'stack', # was S
  3120. c => 'cxstack',
  3121. a => 'pad', # was p
  3122. r => 'runtime',
  3123. w => 'shadow', # was s
  3124. q => 'queue',
  3125. l => 'lineno',
  3126. t => 'timings',
  3127. b => 'bblock');
  3128. $arg = join('',keys %debug_map).'Fsp' if $arg eq 'full';
  3129. foreach $arg ( split( //, $arg ) ) {
  3130. if ( $arg eq "o" ) {
  3131. B->debug(1);
  3132. }
  3133. elsif ( $debug_map{$arg} ) {
  3134. $debug{ $debug_map{$arg} }++;
  3135. }
  3136. elsif ( $arg eq "F" and eval "require B::Flags;" ) {
  3137. $debug{flags}++;
  3138. $B::C::debug{flags}++;
  3139. }
  3140. elsif ( exists $B::C::debug_map{$arg} ) {
  3141. $B::C::verbose++;
  3142. $B::C::debug{ $B::C::debug_map{$arg} }++;
  3143. }
  3144. else {
  3145. warn qq(Warning: ignoring unknown -D option "$arg"\n);
  3146. }
  3147. }
  3148. }
  3149. }
  3150. $strict++ if !$strict and $Config{ccflags} !~ m/-DDEBUGGING/;
  3151. if ($opt_omit_taint) {
  3152. $opt_taint = 0;
  3153. warn "Warning: -fomit_taint is deprecated. Use -fno-taint instead.\n";
  3154. }
  3155. # rgs didn't want opcodes to be added to Opcode. So I had to add it to a
  3156. # seperate Opcodes package.
  3157. eval { require Opcodes; };
  3158. if (!$@ and $Opcodes::VERSION) {
  3159. my $MAXO = Opcodes::opcodes();
  3160. for (0..$MAXO-1) {
  3161. no strict 'refs';
  3162. my $ppname = "pp_".Opcodes::opname($_);
  3163. # opflags n: no args, no return values. don't need save/restore stack
  3164. # But pp_enter, pp_leave use/change global stack.
  3165. next if $ppname eq 'pp_enter' || $ppname eq 'pp_leave';
  3166. $no_stack{$ppname} = 1
  3167. if Opcodes::opflags($_) & 512;
  3168. # XXX More Opcodes options to be added later
  3169. }
  3170. }
  3171. #if ($debug{op}) {
  3172. # warn "no_stack: ",join(" ",sort keys %no_stack),"\n";
  3173. #}
  3174. mark_skip(qw(B::C B::C::Config B::CC B::Asmdata B::FAKEOP
  3175. B::Pseudoreg B::Shadow B::C::InitSection
  3176. O B::Stackobj B::Stackobj::Bool B::Stackobj::Padsv
  3177. B::Stackobj::Const B::Stackobj::Aelem B::Bblock));
  3178. $B::C::all_bc_deps{$_}++ for qw(Opcodes Opcode B::Concise attributes double int num str string subs);
  3179. mark_skip(qw(DB Term::ReadLine)) if defined &DB::DB;
  3180. # Set some B::C optimizations.
  3181. # optimize_ppaddr is not needed with B::CC as CC does it even better.
  3182. for (qw(optimize_warn_sv save_data_fh av_init save_sig destruct const_strings)) {
  3183. no strict 'refs';
  3184. ${"B::C::$_"} = 1 unless $c_optimise{$_};
  3185. }
  3186. $B::C::destruct = 0 unless $c_optimise{destruct} and $] > 5.008;
  3187. $B::C::stash = 0 unless $c_optimise{stash};
  3188. if (!$B::C::Config::have_independent_comalloc) {
  3189. $B::C::av_init = 1 unless $c_optimise{av_init};
  3190. $B::C::av_init2 = 0 unless $c_optimise{av_init2};
  3191. } else {
  3192. $B::C::av_init = 0 unless $c_optimise{av_init};
  3193. $B::C::av_init2 = 1 unless $c_optimise{av_init2};
  3194. }
  3195. init_type_attrs() if $opt_type_attr; # but too late for -MB::CC=-O2 on import. attrs are checked before
  3196. @options;
  3197. }
  3198. # -MO=CC entry point
  3199. sub compile {
  3200. my @options = @_;
  3201. @options = import(@options);
  3202. init_sections();
  3203. $init = B::C::Section->get("init");
  3204. $decl = B::C::Section->get("decl");
  3205. # just some subs or main?
  3206. if (@options) {
  3207. return sub {
  3208. my ( $objname, $ppname );
  3209. foreach $objname (@options) {
  3210. $objname = "main::$objname" unless $objname =~ /::/;
  3211. ( $ppname = $objname ) =~ s/^.*?:://;
  3212. eval "cc_obj(qq(pp_sub_$ppname), \\&$objname)";
  3213. die "cc_obj(qq(pp_sub_$ppname, \\&$objname) failed: $@" if $@;
  3214. return if $errors;
  3215. }
  3216. my $warner = $SIG{__WARN__};
  3217. save_sig($warner);
  3218. fixup_ppaddr();
  3219. return if $check;
  3220. output_boilerplate();
  3221. print "\n";
  3222. output_all( $init_name || "init_module" );
  3223. output_runtime();
  3224. output_main_rest();
  3225. }
  3226. }
  3227. else {
  3228. return sub { cc_main() };
  3229. }
  3230. }
  3231. 1;
  3232. __END__
  3233. =head1 EXAMPLES
  3234. perl -MO=CC,-O2,-ofoo.c foo.pl
  3235. perl cc_harness -o foo foo.c
  3236. Note that C<cc_harness> lives in the C<B> subdirectory of your perl
  3237. library directory. The utility called C<perlcc> may also be used to
  3238. help make use of this compiler.
  3239. # create a shared XS module
  3240. perl -MO=CC,-mFoo,-oFoo.c Foo.pm
  3241. perl cc_harness -shared -c -o Foo.so Foo.c
  3242. # side-effects just for the types and attributes
  3243. perl -MB::CC -e'my int $i:unsigned; ...'
  3244. =head1 TYPES
  3245. Implemented type classes are B<int> and B<num>.
  3246. Planned is B<str> also.
  3247. Implemented are only SCALAR types yet.
  3248. Typed arrays and hashes and perfect hashes need L<coretypes>, L<types> and
  3249. proper C<const> support first.
  3250. Deprecated are inferred types via the names of locals, with '_i', '_d' suffix
  3251. and an optional 'r' suffix for register allocation.
  3252. C<my ($i_i, $j_ir, $num_d);>
  3253. Planned type attributes are B<int>, B<num>, B<str>, B<unsigned>, B<ro> / B<const>.
  3254. The attributes are perl attributes, and C<int|num|str> are either
  3255. compiler classes or hints for more allowed types.
  3256. C<my int $i :num;> declares a NV with SVf_IOK. Same as C<my $i:int:double;>
  3257. C<my int $i;> declares an IV. Same as C<my $i:int;>
  3258. C<my int $i :str;> declares a PVIV. Same as C<my $i:int:string;>
  3259. C<my int @array :unsigned = (0..4);> will be used as c var in faster arithmetic and cmp.
  3260. With :const or :ro even more.
  3261. C<my str %hash :const
  3262. = (foo => 'foo', bar => 'bar');> declare string values,
  3263. generate as read-only perfect hash.
  3264. B<:unsigned> is valid for int only and declares an UV.
  3265. B<:register> denotes optionally a short and hot life-time.
  3266. B<:temporary> are usually generated internally, nameless lexicals.
  3267. They are more aggressivly destroyed and ignored.
  3268. B<:ro> or B<:const> throw a compile-time error on write access and may optimize
  3269. the internal structure of the variable. We don't need to write back the variable
  3270. to perl (lexical write_back).
  3271. STATUS
  3272. OK (classes only):
  3273. my int $i;
  3274. my num $d;
  3275. NOT YET OK (attributes):
  3276. my int $i :register;
  3277. my $i :int;
  3278. my $const :int:const;
  3279. my $uv :int:unsigned;
  3280. ISSUES
  3281. This does not work with pure perl, unless you C<use B::CC> or C<use types> or
  3282. implement the classes and attribute type stubs in your code,
  3283. C<sub Mypkg::MODIFY_SCALAR_ATTRIBUTES {}> and C<sub Mypkg::FETCH_SCALAR_ATTRIBUTES {}>.
  3284. (TODO: empty should be enough to be detected by the compiler.)
  3285. Compiled code pulls in the magic MODIFY_SCALAR_ATTRIBUTES and FETCH_SCALAR_ATTRIBUTES
  3286. functions, even if they are used at compile time only.
  3287. Using attributes adds an import block to your code.
  3288. Up until 5.20 only B<our> variable attributes are checked at compile-time,
  3289. B<my> variables attributes at run-time only, which is too late for the compiler.
  3290. Perl attributes need to be fixed for types hints by adding C<CHECK_SCALAR_ATTRIBUTES>.
  3291. FUTURE
  3292. We should be able to support types on ARRAY and HASH.
  3293. For arrays also sizes to omit bounds-checking.
  3294. my int @array; # array of ints, faster magic-less access esp. in inlined arithmetic and cmp.
  3295. my str @array : const = qw(foo bar); # compile-time error on write. no lexical write_back
  3296. my int $hash = {"1" => 1, "2" => 2}; # int values, type-checked on write my
  3297. str %hash1 : const = (foo => 'bar'); # string keys only => maybe gperf
  3298. # compile-time error on write
  3299. Typed hash keys are always strings, as array keys are always int. Only the values are typed.
  3300. We should be also able to add type attributes for functions and methods,
  3301. i.e. for argument and return types. See L<types> and
  3302. L<http://blogs.perl.org/users/rurban/2011/02/use-types.html>
  3303. =head1 BUGS
  3304. Plenty. Current status: experimental.
  3305. =head1 DIFFERENCES
  3306. These aren't really bugs but they are constructs which are heavily
  3307. tied to perl's compile-and-go implementation and with which this
  3308. compiler backend cannot cope.
  3309. =head2 Loops
  3310. Standard perl calculates the target of "next", "last", and "redo"
  3311. at run-time. The compiler calculates the targets at compile-time.
  3312. For example, the program
  3313. sub skip_on_odd { next NUMBER if $_[0] % 2 }
  3314. NUMBER: for ($i = 0; $i < 5; $i++) {
  3315. skip_on_odd($i);
  3316. print $i;
  3317. }
  3318. produces the output
  3319. 024
  3320. with standard perl but calculates with the compiler the
  3321. goto label_NUMBER wrong, producing 01234.
  3322. =head2 Context of ".."
  3323. The context (scalar or array) of the ".." operator determines whether
  3324. it behaves as a range or a flip/flop. Standard perl delays until
  3325. runtime the decision of which context it is in but the compiler needs
  3326. to know the context at compile-time. For example,
  3327. @a = (4,6,1,0,0,1);
  3328. sub range { (shift @a)..(shift @a) }
  3329. print range();
  3330. while (@a) { print scalar(range()) }
  3331. generates the output
  3332. 456123E0
  3333. with standard Perl but gives a run-time warning with compiled Perl.
  3334. If the option B<-strict> is used it gives a compile-time error.
  3335. =head2 Arithmetic
  3336. Compiled Perl programs use native C arithmetic much more frequently
  3337. than standard perl. Operations on large numbers or on boundary
  3338. cases may produce different behaviour.
  3339. In doubt B::CC code behaves more like with C<use integer>.
  3340. =head2 Deprecated features
  3341. Features of standard perl such as C<$[> which have been deprecated
  3342. in standard perl since Perl5 was released have not been implemented
  3343. in the optimizing compiler.
  3344. =head1 AUTHORS
  3345. Malcolm Beattie C<MICB at cpan.org> I<(1996-1998, retired)>,
  3346. Vishal Bhatia <vishal at deja.com> I(1999),
  3347. Gurusamy Sarathy <gsar at cpan.org> I(1998-2001),
  3348. Reini Urban C<perl-compiler at googlegroups.com> I(2008-now),
  3349. Heinz Knutzen C<heinz.knutzen at gmx.de> I(2010)
  3350. Will Braswell C<wbraswell at hush.com> I(2012)
  3351. =cut
  3352. # Local Variables:
  3353. # mode: cperl
  3354. # cperl-indent-level: 2
  3355. # fill-column: 78
  3356. # End:
  3357. # vim: expandtab shiftwidth=2: