Mercurial > hg > Others > Rakudo

comparison src/perl6-debug.nqp @ 0:c341f82e7ad7 default tip

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Rakudo branch in cr.ie.u-ryukyu.ac.jp
author Shinji KONO <kono@ie.u-ryukyu.ac.jp>
date Thu, 26 Dec 2019 16:50:27 +0900
parents
children
comparison
equal deleted inserted replaced
-1:000000000000 0:c341f82e7ad7
1 use Perl6::Grammar;
2 use Perl6::Actions;
3 use Perl6::Compiler;
4
5 class Perl6::DebugHooks {
6 has %!hooks;
7 has $!suspended;
8
9 method set_hook($name, $callback) {
10 $*W.add_object($callback);
11 %!hooks{$name} := $callback;
12 }
13
14 method has_hook($name) {
15 !$!suspended && nqp::existskey(%!hooks, $name)
16 }
17
18 method get_hook($name) {
19 %!hooks{$name}
20 }
21
22 method suspend() {
23 $!suspended := 1
24 }
25
26 method unsuspend() {
27 $!suspended := 0
28 }
29 }
30
31 sub ps_qast() {
32 QAST::Op.new(
33 :op('callmethod'), :name('new'),
34 QAST::WVal.new( :value($*W.find_symbol(['PseudoStash'])) )
35 )
36 }
37
38 grammar Perl6::HookRegexGrammar is Perl6::RegexGrammar {
39 method nibbler() {
40 my $*RX_TOP_LEVEL_NIBBLER := 0;
41 unless %*RX<DEBUGGER_SEEN> {
42 %*RX<DEBUGGER_SEEN> := 1;
43 $*RX_TOP_LEVEL_NIBBLER := 1;
44 }
45 Perl6::RegexGrammar.HOW.find_method(Perl6::RegexGrammar, 'nibbler')(self)
46 }
47 }
48
49 class Perl6::HookRegexActions is Perl6::RegexActions {
50 method nibbler($/) {
51 if $*RX_TOP_LEVEL_NIBBLER && $*DEBUG_HOOKS.has_hook('regex_region') {
52 my $file := nqp::getlexcaller('$?FILES') // $*ANON_CODE_NAME;
53 $*DEBUG_HOOKS.get_hook('regex_region')($file, $/.from, $/.to);
54 }
55 Perl6::RegexActions.nibbler($/);
56 }
57
58 method quantified_atom($/) {
59 Perl6::RegexActions.quantified_atom($/);
60 my $qa := $/.ast;
61 if $qa && !(~$/ ~~ /^\s*$/) && $*DEBUG_HOOKS.has_hook('regex_atom') {
62 $/.make(QAST::Regex.new(
63 :rxtype('concat'),
64 QAST::Regex.new(
65 :rxtype('qastnode'),
66 :subtype('declarative'),
67 QAST::Stmts.new(
68 QAST::Op.new(
69 :op('p6store'),
70 QAST::Var.new( :name('$/'), :scope<lexical> ),
71 QAST::Op.new(
72 QAST::Var.new( :name('$¢'), :scope<lexical> ),
73 :name('MATCH'),
74 :op('callmethod')
75 )
76 ),
77 QAST::Op.new(
78 :op('call'),
79 QAST::WVal.new( :value($*DEBUG_HOOKS.get_hook('regex_atom')) ),
80 $*W.add_string_constant(nqp::getlexcaller('$?FILES') // $*ANON_CODE_NAME),
81 ps_qast(),
82 $*W.add_numeric_constant($/, 'Int', $/.from),
83 $*W.add_numeric_constant($/, 'Int', $/.to)
84 )
85 )
86 ),
87 $qa
88 ));
89 }
90 }
91 }
92
93 grammar QRegex::P5Regex::HookGrammar is Perl6::P5RegexGrammar {
94 method nibbler() {
95 my $*RX_TOP_LEVEL_NIBBLER := 0;
96 unless %*RX<DEBUGGER_SEEN> {
97 %*RX<DEBUGGER_SEEN> := 1;
98 $*RX_TOP_LEVEL_NIBBLER := 1;
99 }
100 QRegex::P5Regex::Grammar.HOW.find_method(QRegex::P5Regex::Grammar, 'nibbler')(self)
101 }
102 }
103
104 class QRegex::P5Regex::HookActions is Perl6::P5RegexActions {
105 method nibbler($/) {
106 if $*RX_TOP_LEVEL_NIBBLER && $*DEBUG_HOOKS.has_hook('regex_region') {
107 my $file := nqp::getlexcaller('$?FILES') // $*ANON_CODE_NAME;
108 $*DEBUG_HOOKS.get_hook('regex_region')($file, $/.from, $/.to);
109 }
110 QRegex::P5Regex::Actions.nibbler($/);
111 }
112
113 method quantified_atom($/) {
114 QRegex::P5Regex::Actions.quantified_atom($/);
115 my $qa := $/.ast;
116 if $qa && !(~$/ ~~ /^\s*$/) && $*DEBUG_HOOKS.has_hook('regex_atom') {
117 $/.make(QAST::Regex.new(
118 :rxtype('concat'),
119 QAST::Regex.new(
120 :rxtype('qastnode'),
121 :subtype('declarative'),
122 QAST::Op.new(
123 :op('call'),
124 QAST::WVal.new( :value($*DEBUG_HOOKS.get_hook('regex_atom')) ),
125 $*W.add_string_constant(nqp::getlexcaller('$?FILES') // $*ANON_CODE_NAME),
126 ps_qast(),
127 $*W.add_numeric_constant($/, 'Int', $/.from),
128 $*W.add_numeric_constant($/, 'Int', $/.to)
129 )
130 ),
131 $qa
132 ));
133 }
134 }
135 }
136
137 class Perl6::HookActions is Perl6::Actions {
138 my %uninteresting := nqp::hash(
139 'package_declarator', 1,
140 'routine_declarator', 1,
141 'multi_declarator', 1,
142 'type_declarator', 1,
143 'regex_declarator', 1,
144 'statement_prefix', 1
145 );
146 sub interesting_expr($e) {
147 my $accept := 1;
148 for $e.hash {
149 my $key := $_.key;
150 my $value := $_.value;
151 if %uninteresting{$key} {
152 $accept := 0;
153 last;
154 }
155 if $key eq 'scope_declarator' && $value<sym> eq 'has' {
156 $accept := 0;
157 last;
158 }
159 if $key eq 'scope_declarator' && ($value<sym> eq 'my' || $value<sym> eq 'our') {
160 if $value<scoped><declarator> -> $decl {
161 # Skip plain, boring declarations with no assignment.
162 if $decl<variable_declarator> && !$decl<initializer> {
163 $accept := 0;
164 last;
165 }
166 }
167 }
168 if $key eq 'circumfix' && $e<circumfix><pblock> {
169 $accept := 0;
170 last;
171 }
172 }
173 $accept
174 }
175
176 method statement($/) {
177 Perl6::Actions.statement($/);
178 if $*ST_DEPTH <= 1 && $<EXPR> && interesting_expr($<EXPR>) {
179 my $stmt := $/.ast;
180 my $pot_hash := nqp::istype($stmt, QAST::Op) &&
181 ($stmt.name eq '&infix:<,>' || $stmt.name eq '&infix:«=>»');
182 my $nil := nqp::istype($stmt, QAST::Var) && $stmt.name eq 'Nil';
183 if !$pot_hash && !$nil && $*DEBUG_HOOKS.has_hook('statement_simple') {
184 $/.make(QAST::Stmts.new(
185 QAST::Op.new(
186 :op('call'),
187 QAST::WVal.new( :value($*DEBUG_HOOKS.get_hook('statement_simple')) ),
188 $*W.add_string_constant(nqp::getlexcaller('$?FILES') // $*ANON_CODE_NAME),
189 ps_qast(),
190 $*W.add_numeric_constant($/, 'Int', $/.from),
191 $*W.add_numeric_constant($/, 'Int', $/.to)
192 ),
193 $stmt
194 ));
195 }
196 }
197 }
198
199 method statement_control:sym<if>($/) {
200 if $*DEBUG_HOOKS.has_hook('statement_cond') {
201 my $from := $<sym>[0].from;
202 for $<xblock> {
203 my $ast := $_.ast;
204 $ast[0] := QAST::Stmts.new(
205 QAST::Op.new(
206 :op('call'),
207 QAST::WVal.new( :value($*DEBUG_HOOKS.get_hook('statement_cond')) ),
208 $*W.add_string_constant(nqp::getlexcaller('$?FILES') // $*ANON_CODE_NAME),
209 ps_qast(),
210 $*W.add_string_constant('if'),
211 $*W.add_numeric_constant($/, 'Int', $from),
212 $*W.add_numeric_constant($/, 'Int', $_<pblock>.from - 1)
213 ),
214 $ast[0]
215 );
216 $from := $_<pblock>.to + 1;
217 }
218 }
219 Perl6::Actions.statement_control:sym<if>($/);
220 }
221
222 sub simple_xblock_hook($/) {
223 if $*DEBUG_HOOKS.has_hook('statement_cond') {
224 my $stmt := $/.ast;
225 $stmt[0] := QAST::Stmts.new(
226 QAST::Op.new(
227 :op('call'),
228 QAST::WVal.new( :value($*DEBUG_HOOKS.get_hook('statement_cond')) ),
229 $*W.add_string_constant(nqp::getlexcaller('$?FILES') // $*ANON_CODE_NAME),
230 ps_qast(),
231 $*W.add_string_constant(~$<sym>),
232 $*W.add_numeric_constant($/, 'Int', $<sym>.from),
233 $*W.add_numeric_constant($/, 'Int', $<xblock><pblock>.from - 1)
234 ),
235 $stmt[0]
236 );
237 }
238 }
239
240 method statement_control:sym<unless>($/) {
241 Perl6::Actions.statement_control:sym<unless>($/);
242 simple_xblock_hook($/);
243 }
244
245 method statement_control:sym<while>($/) {
246 Perl6::Actions.statement_control:sym<while>($/);
247 simple_xblock_hook($/);
248 }
249
250 method statement_control:sym<repeat>($/) {
251 Perl6::Actions.statement_control:sym<repeat>($/);
252 if $*DEBUG_HOOKS.has_hook('statement_cond') {
253 my $stmt := $/.ast;
254 $stmt[0] := QAST::Stmts.new(
255 QAST::Op.new(
256 :op('call'),
257 QAST::WVal.new( :value($*DEBUG_HOOKS.get_hook('statement_cond')) ),
258 $*W.add_string_constant(nqp::getlexcaller('$?FILES') // $*ANON_CODE_NAME),
259 ps_qast(),
260 $*W.add_string_constant(~$<wu>),
261 $*W.add_numeric_constant($/, 'Int', $<wu>.from),
262 $*W.add_numeric_constant($/, 'Int', $<xblock>
263 ?? $<xblock><pblock>.from - 1
264 !! $/.to)
265 ),
266 $stmt[0]
267 );
268 }
269 }
270
271 method statement_control:sym<loop>($/) {
272 if $*DEBUG_HOOKS.has_hook('statement_cond') {
273 for <e1 e2 e3> -> $expr {
274 if $/{$expr} -> $m {
275 $m[0].make(QAST::Stmts.new(
276 QAST::Op.new(
277 :op('call'),
278 QAST::WVal.new( :value($*DEBUG_HOOKS.get_hook('statement_cond')) ),
279 $*W.add_string_constant(nqp::getlexcaller('$?FILES') // $*ANON_CODE_NAME),
280 ps_qast(),
281 $*W.add_string_constant('loop'),
282 $*W.add_numeric_constant($/, 'Int', widen_expr_from($m[0])),
283 $*W.add_numeric_constant($/, 'Int', widen_expr_to($m[0]))
284 ),
285 $m[0].ast
286 ));
287 }
288 }
289 }
290 Perl6::Actions.statement_control:sym<loop>($/);
291 }
292
293 sub widen_expr_from($e) {
294 my $from := $e.from;
295 for @($e) {
296 if $_.from < $from {
297 $from := $_.from;
298 }
299 }
300 $from
301 }
302
303 sub widen_expr_to($e) {
304 my $to := $e.to;
305 for @($e) {
306 if $_.to > $to {
307 $to := $_.to;
308 }
309 }
310 $to
311 }
312
313 method statement_control:sym<for>($/) {
314 Perl6::Actions.statement_control:sym<for>($/);
315 simple_xblock_hook($/);
316 }
317
318 method statement_control:sym<given>($/) {
319 Perl6::Actions.statement_control:sym<given>($/);
320 simple_xblock_hook($/);
321 }
322
323 method statement_control:sym<when>($/) {
324 Perl6::Actions.statement_control:sym<when>($/);
325 simple_xblock_hook($/);
326 }
327
328 method statement_control:sym<require>($/) {
329 Perl6::Actions.statement_control:sym<require>($/);
330 if $*DEBUG_HOOKS.has_hook('statement_simple') {
331 $/.make(QAST::Stmts.new(
332 QAST::Op.new(
333 :op('call'),
334 QAST::WVal.new( :value($*DEBUG_HOOKS.get_hook('statement_simple')) ),
335 $*W.add_string_constant(nqp::getlexcaller('$?FILES') // $*ANON_CODE_NAME),
336 ps_qast(),
337 $*W.add_numeric_constant($/, 'Int', $/.from),
338 $*W.add_numeric_constant($/, 'Int', $/.to)
339 ),
340 $/.ast
341 ));
342 }
343 }
344
345 sub routine_hook($/, $body, $type, $name) {
346 if $*DEBUG_HOOKS.has_hook('routine_region') {
347 my $file := nqp::getlexcaller('$?FILES') // $*ANON_CODE_NAME;
348 $*DEBUG_HOOKS.get_hook('routine_region')($file, $/.from, $/.to, $type, $name);
349 }
350 }
351
352 method routine_declarator:sym<sub>($/) {
353 Perl6::Actions.routine_declarator:sym<sub>($/);
354 routine_hook($/, $<routine_def>, 'sub',
355 $<routine_def><deflongname> ?? ~$<routine_def><deflongname>[0] !! '');
356 }
357 method routine_declarator:sym<method>($/) {
358 Perl6::Actions.routine_declarator:sym<method>($/);
359 routine_hook($/, $<method_def>, 'method',
360 $<method_def><longname> ?? ~$<method_def><longname> !! '');
361 }
362 method routine_declarator:sym<submethod>($/) {
363 Perl6::Actions.routine_declarator:sym<submethod>($/);
364 routine_hook($/, $<method_def>, 'submethod',
365 $<method_def><longname> ?? ~$<method_def><longname> !! '');
366 }
367 method routine_declarator:sym<macro>($/) {
368 #Perl6::Actions.routine_declarator:sym<macro>($/);
369 routine_hook($/, $<macro_def>, 'macro',
370 $<macro_def><deflongname> ?? ~$<macro_def><deflongname>[0] !! '');
371 }
372 }
373
374 class Perl6::HookGrammar is Perl6::Grammar {
375 my %seen_files;
376
377 method statementlist($*statement_level = 0) {
378 my $file := nqp::getlexcaller('$?FILES') // $*ANON_CODE_NAME;
379 unless nqp::existskey(%*SEEN_FILES, $file) {
380 if $*DEBUG_HOOKS.has_hook('new_file') {
381 # First time we've seen this file; register it.
382 $*DEBUG_HOOKS.get_hook('new_file')($file, self.MATCH.orig);
383 }
384 %*SEEN_FILES{$file} := 1;
385 }
386 my $cur_st_depth := $*ST_DEPTH;
387 {
388 my $*ST_DEPTH := $cur_st_depth + 1;
389 Perl6::Grammar.HOW.find_method(Perl6::Grammar, 'statementlist')(self, $*statement_level)
390 }
391 }
392
393 method comp_unit() {
394 my $*ST_DEPTH := 0;
395 my %*SEEN_FILES;
396
397 # Fiddle the %*LANG for the appropriate actions.
398 %*LANG<Regex> := Perl6::HookRegexGrammar;
399 %*LANG<Regex-actions> := Perl6::HookRegexActions;
400 %*LANG<P5Regex> := QRegex::P5Regex::HookGrammar;
401 %*LANG<P5Regex-actions> := QRegex::P5Regex::HookActions;
402 %*LANG<MAIN> := Perl6::HookGrammar;
403 %*LANG<MAIN-actions> := Perl6::HookActions;
404
405 Perl6::Grammar.HOW.find_method(Perl6::Grammar, 'comp_unit')(self)
406 }
407
408 method blockoid() {
409 my $*ST_DEPTH := 0;
410 Perl6::Grammar.HOW.find_method(Perl6::Grammar, 'blockoid')(self)
411 }
412
413 method semilist() {
414 my $cur_st_depth := $*ST_DEPTH;
415 {
416 my $*ST_DEPTH := $cur_st_depth + 1;
417 Perl6::Grammar.HOW.find_method(Perl6::Grammar, 'semilist')(self)
418 }
419 }
420
421 method comment:sym<#>() {
422 my $c := Perl6::Grammar.HOW.find_method(Perl6::Grammar, 'comment:sym<#>')(self);
423 if $c {
424 my $comment := $c.MATCH.Str;
425 if $comment ~~ /'#?BREAK'/ {
426 if $*DEBUG_HOOKS.has_hook('new_breakpoint') {
427 my $file := nqp::getlexcaller('$?FILES') // $*ANON_CODE_NAME;
428 $*DEBUG_HOOKS.get_hook('new_breakpoint')($file, $c.MATCH().from());
429 }
430 }
431 }
432 $c
433 }
434 }
435
436 class Perl6::Debugger is Perl6::Compiler {
437 my $repl_code := 1;
438 method eval(*@pos, *%named) {
439 my $*ANON_CODE_NAME := "<REPL {$repl_code++}>";
440 if $*DEBUG_HOOKS.has_hook('reset') {
441 $*DEBUG_HOOKS.get_hook('reset')();
442 }
443 nqp::findmethod(Perl6::Compiler, 'eval')(self, |@pos, |%named)
444 }
445 }
446
447 sub MAIN(*@ARGS) {
448 # XXX Parrot compat hack.
449 if nqp::islist(@ARGS[0]) {
450 @ARGS := @ARGS[0];
451 }
452
453 # Initialize dynops.
454 nqp::p6init();
455
456 # Create and configure compiler object.
457 my $comp := Perl6::Debugger.new();
458
459 $comp.language('perl6');
460 $comp.parsegrammar(Perl6::HookGrammar);
461 $comp.parseactions(Perl6::HookActions);
462 $comp.addstage('syntaxcheck', :before<ast>);
463 $comp.addstage('optimize', :after<ast>);
464 hll-config($comp.config);
465 my $COMPILER_CONFIG := $comp.config;
466 nqp::bindhllsym('perl6', '$COMPILER_CONFIG', $comp.config);
467
468
469 # Determine Perl6 and NQP dirs.
470 my $config := nqp::backendconfig();
471 my $sep := $config<osname> eq 'MSWin32' ?? '\\' !! '/';
472 #?if jvm
473 my $execname := nqp::atkey(nqp::jvmgetproperties,'perl6.execname');
474 #?endif
475 #?if !jvm
476 my $execname := nqp::execname();
477 #?endif
478 my $install-dir := $execname eq ''
479 ?? $comp.config<prefix>
480 !! nqp::substr($execname, 0, nqp::rindex($execname, $sep, nqp::rindex($execname, $sep) - 1));
481
482 my $rakudo-home := $comp.config<static_rakudo_home>
483 // nqp::getenvhash()<PERL6_HOME>
484 // nqp::getenvhash()<RAKUDO_HOME>
485 // $install-dir ~ '/share/perl6';
486 if nqp::substr($rakudo-home, nqp::chars($rakudo-home) - 1) eq $sep {
487 $rakudo-home := nqp::substr($rakudo-home, 0, nqp::chars($rakudo-home) - 1);
488 }
489
490 my $nqp-home := $comp.config<static_nqp_home>
491 // nqp::getenvhash()<NQP_HOME>
492 // $install-dir ~ '/share/nqp';
493 if nqp::substr($nqp-home, nqp::chars($nqp-home) - 1) eq $sep {
494 $nqp-home := nqp::substr($nqp-home, 0, nqp::chars($nqp-home) - 1);
495 }
496
497 nqp::bindhllsym('perl6', '$RAKUDO_HOME', $rakudo-home);
498 nqp::bindhllsym('perl6', '$NQP_HOME', $nqp-home);
499
500
501 # Add extra command line options.
502 my @clo := $comp.commandline_options();
503 @clo.push('setting=s');
504 @clo.push('c');
505 @clo.push('I=s');
506 @clo.push('M=s');
507 @clo.push('nqp-lib=s');
508
509 # Set up module loading trace
510 my @*MODULES := [];
511
512 # Set up END block list, which we'll run at exit.
513 nqp::bindhllsym('perl6', '@END_PHASERS', []);
514
515 # Force loading of the debugger module.
516 my $debugger;
517 my $i := 1;
518 while @ARGS[$i] ~~ /^\-/ {
519 if @ARGS[$i] ~~ /^\-D/ {
520 $debugger := "-M" ~ nqp::substr(@ARGS[$i], 2);
521 nqp::splice(@ARGS, [], $i, 1);
522 last;
523 }
524 $i++;
525 }
526
527 if !(nqp::defined($debugger)) {
528 $debugger := '-MDebugger::UI::CommandLine';
529 }
530
531 my $pname := @ARGS.shift();
532 @ARGS.unshift('-Ilib');
533 @ARGS.unshift($debugger);
534 @ARGS.unshift($pname);
535
536 # Set up debug hooks object.
537 my $*DEBUG_HOOKS := Perl6::DebugHooks.new();
538
539 # Enter the compiler.
540 $comp.command_line(@ARGS, :encoding('utf8'), :transcode('ascii iso-8859-1'));
541
542 # Run any END blocks before exiting.
543 for nqp::gethllsym('perl6', '@END_PHASERS') {
544 my $result := $_();
545 nqp::isfalse(nqp::isnull($result))
546 && nqp::can($result, 'sink') && $result.sink;
547 }
548 }