1. my class Exception { ... }
  2. my class Backtrace { ... }
  3. my class CompUnit::RepositoryRegistry is repr('Uninstantiable') { ... }
  4. my $RAKUDO-VERBOSE-STACKFRAME;
  5. my class Backtrace::Frame {
  6. has Str $.file;
  7. has Int $.line;
  8. has Mu $.code;
  9. has Str $.subname;
  10. method !SET-SELF($!file,$!line,\code,$!subname) {
  11. $!code := code;
  12. self
  13. }
  14. multi method new(Backtrace::Frame: \file,\line,\code,\subname) {
  15. nqp::create(self)!SET-SELF(file,line,code,subname)
  16. }
  17. multi method new(Backtrace::Frame: |c) {
  18. self.bless(|c)
  19. }
  20. method subtype(Backtrace::Frame:D:) {
  21. my $s = $!code.^name.lc.split('+', 2).cache[0];
  22. $s eq 'mu' ?? '' !! $s;
  23. }
  24. method package(Backtrace::Frame:D:) {
  25. $.code.package;
  26. }
  27. multi method Str(Backtrace::Frame:D:) {
  28. my $s = self.subtype;
  29. $s ~= ' ' if $s.chars;
  30. my $text = " in {$s}$.subname at {$.file} line $.line\n";
  31. if $RAKUDO-VERBOSE-STACKFRAME -> $extra {
  32. my $io = $!file.IO;
  33. if $io.e {
  34. my @lines = $io.lines;
  35. my $from = max $!line - $extra, 1;
  36. my $to = min $!line + $extra, +@lines;
  37. for $from..$to -> $line {
  38. my $star = $line == $!line ?? '*' !! ' ';
  39. $text ~= "$line.fmt('%5d')$star @lines[$line - 1]\n";
  40. }
  41. $text ~= "\n";
  42. }
  43. }
  44. $text;
  45. }
  46. method is-hidden(Backtrace::Frame:D:) {
  47. ?$!code.?is-hidden-from-backtrace
  48. }
  49. method is-routine(Backtrace::Frame:D:) {
  50. nqp::p6bool(nqp::istype($!code,Routine))
  51. }
  52. method is-setting(Backtrace::Frame:D:) {
  53. $!file.starts-with("SETTING::")
  54. || $!file.ends-with("CORE.setting." ~ Rakudo::Internals.PRECOMP-EXT)
  55. || $!file.ends-with(".nqp")
  56. }
  57. }
  58. my class Backtrace {
  59. has Mu $!bt;
  60. has Mu $!frames;
  61. has Int $!bt-next; # next bt index to vivify
  62. method !SET-SELF($!bt,$!bt-next) {
  63. once $RAKUDO-VERBOSE-STACKFRAME =
  64. +(%*ENV<RAKUDO_VERBOSE_STACKFRAME> // 0);
  65. $!frames := nqp::list;
  66. self
  67. }
  68. multi method new() {
  69. try X::AdHoc.new(:payload("Died")).throw;
  70. nqp::create(self)!SET-SELF(
  71. nqp::backtrace(nqp::getattr(nqp::decont($!),Exception,'$!ex')),
  72. 1)
  73. }
  74. multi method new(Int:D $offset) {
  75. try X::AdHoc.new(:payload("Died")).throw;
  76. nqp::create(self)!SET-SELF(
  77. nqp::backtrace(nqp::getattr(nqp::decont($!),Exception,'$!ex')),
  78. 1 + $offset)
  79. }
  80. multi method new(Mu \ex) {
  81. nqp::create(self)!SET-SELF(
  82. ex.^name eq 'BOOTException'
  83. ?? nqp::backtrace(nqp::decont(ex))
  84. !! nqp::backtrace(nqp::getattr(nqp::decont(ex),Exception,'$!ex')),
  85. 0)
  86. }
  87. multi method new(Mu \ex, Int:D $offset) {
  88. nqp::create(self)!SET-SELF(
  89. ex.^name eq 'BOOTException'
  90. ?? nqp::backtrace(nqp::decont(ex))
  91. !! nqp::backtrace(nqp::getattr(nqp::decont(ex),Exception,'$!ex')),
  92. $offset)
  93. }
  94. # note that backtraces are nqp::list()s, marshalled to us as a List
  95. multi method new(List:D $bt) {
  96. nqp::create(self)!SET-SELF($bt,0)
  97. }
  98. multi method new(List:D $bt, Int:D $offset) {
  99. nqp::create(self)!SET-SELF($bt,$offset)
  100. }
  101. method AT-POS($pos) {
  102. return nqp::atpos($!frames,$pos) if nqp::existspos($!frames,$pos);
  103. my int $elems = $!bt.elems;
  104. return Nil if $!bt-next >= $elems; # bt-next can init > elems
  105. my int $todo = $pos - nqp::elems($!frames) + 1;
  106. return Nil if $todo < 1; # in case absurd $pos passed
  107. while $!bt-next < $elems {
  108. my $frame := $!bt.AT-POS($!bt-next++);
  109. my $sub := $frame<sub>;
  110. next unless defined $sub;
  111. my Mu $do := nqp::getattr(nqp::decont($sub), ForeignCode, '$!do');
  112. next if nqp::isnull($do);
  113. my $annotations := $frame<annotations>;
  114. next unless $annotations;
  115. my $file := $annotations<file>;
  116. next unless $file;
  117. if CompUnit::RepositoryRegistry.file-for-spec($file) -> $path {
  118. $file := $path.abspath;
  119. }
  120. # now *that's* an evil hack
  121. next if $file.ends-with('BOOTSTRAP.nqp')
  122. || $file.ends-with('QRegex.nqp')
  123. || $file.ends-with('Perl6/Ops.nqp');
  124. if $file.ends-with('NQPHLL.nqp') || $file.ends-with('NQPHLL.moarvm') {
  125. # This could mean we're at the end of the interesting backtrace,
  126. # or it could mean that we're in something like sprintf (which
  127. # uses an NQP grammar to parse the format string).
  128. while $!bt-next < $elems {
  129. my $frame := $!bt.AT-POS($!bt-next++);
  130. my $annotations := $frame<annotations>;
  131. next unless $annotations;
  132. my $file := $annotations<file>;
  133. next unless $file;
  134. if $file.ends-with('.setting') {
  135. $!bt-next--; # re-visit this frame
  136. last;
  137. }
  138. }
  139. next;
  140. }
  141. my $line := $annotations<line>;
  142. next unless $line;
  143. my $name := nqp::p6box_s(nqp::getcodename($do));
  144. if $name eq 'handle-begin-time-exceptions' {
  145. $!bt-next = $elems;
  146. last;
  147. }
  148. my $code;
  149. try {
  150. $code := nqp::getcodeobj($do);
  151. $code := Any unless nqp::istype($code, Mu);
  152. };
  153. nqp::push($!frames,
  154. Backtrace::Frame.new(
  155. $file,
  156. $line.Int,
  157. $code,
  158. $name.starts-with("_block") ?? '<anon>' !! $name,
  159. )
  160. );
  161. last unless $todo = $todo - 1;
  162. }
  163. # found something
  164. if nqp::existspos($!frames,$pos) {
  165. nqp::atpos($!frames,$pos);
  166. }
  167. # we've reached the end, don't show the last <unit-outer> if there is one
  168. else {
  169. nqp::pop($!frames) if $!frames;
  170. Nil;
  171. }
  172. }
  173. method next-interesting-index(Backtrace:D:
  174. Int $idx is copy = 0, :$named, :$noproto, :$setting) {
  175. ++$idx;
  176. while self.AT-POS($idx++) -> $cand {
  177. next if $cand.is-hidden; # hidden is never interesting
  178. next if $noproto # no proto's please
  179. && $cand.code.?is_dispatcher; # if a dispatcher
  180. next if !$setting # no settings please
  181. && $cand.is-setting; # and in setting
  182. my $n := $cand.subname;
  183. next if $named && !$n; # only want named ones and no name
  184. next if $n eq '<unit-outer>'; # outer calling context
  185. return $idx - 1;
  186. }
  187. Nil;
  188. }
  189. method outer-caller-idx(Backtrace:D: Int $startidx) {
  190. if self.AT-POS($startidx).code -> $start {
  191. my %outers;
  192. my $current = $start.outer;
  193. while $current.DEFINITE {
  194. %outers{$current.static_id} = $start;
  195. $current = $current.outer;
  196. }
  197. my @outers;
  198. my $i = $startidx;
  199. while self.AT-POS($i++) -> $cand {
  200. my $code = $cand.code;
  201. next unless $code.DEFINITE && %outers{$code.static_id}.DEFINITE;
  202. @outers.push: $i - 1;
  203. last if $cand.is-routine;
  204. }
  205. @outers;
  206. }
  207. else {
  208. $startidx.list;
  209. }
  210. }
  211. method nice(Backtrace:D: :$oneline) {
  212. my $setting = %*ENV<RAKUDO_BACKTRACE_SETTING>;
  213. try {
  214. my @frames;
  215. my Int $i = self.next-interesting-index(-1);
  216. while $i.defined {
  217. $i = self.next-interesting-index($i, :$setting) if $oneline;
  218. last unless $i.defined;
  219. my $prev = self.AT-POS($i);
  220. if $prev.is-routine {
  221. @frames.push: $prev;
  222. } else {
  223. my @outer_callers := self.outer-caller-idx($i);
  224. my $target_idx = @outer_callers.keys.grep({self.AT-POS($i).code.^isa(Routine)})[0];
  225. $target_idx ||= @outer_callers[0] || $i;
  226. my $current = self.AT-POS($target_idx);
  227. @frames.append: $current.clone(line => $prev.line);
  228. $i = $target_idx;
  229. }
  230. last if $oneline;
  231. $i = self.next-interesting-index($i, :$setting);
  232. }
  233. CATCH {
  234. default {
  235. return "<Internal error while creating backtrace: $_.message() $_.backtrace.full().\n"
  236. ~ "Please report this as a bug (mail to rakudobug@perl.org)\n",
  237. ~ "and re-run with the --ll-exception command line option\n"
  238. ~ "to get more information about your error>";
  239. }
  240. }
  241. @frames.join;
  242. }
  243. }
  244. multi method Str(Backtrace:D:) { self.nice }
  245. multi method flat(Backtrace:D:) { self.list }
  246. multi method map(Backtrace:D: &block) {
  247. my $pos = 0;
  248. gather while self.AT-POS($pos++) -> $cand {
  249. take block($cand);
  250. }
  251. }
  252. multi method first(Backtrace:D: Mu $test) {
  253. my $pos = 0;
  254. while self.AT-POS($pos++) -> $cand {
  255. return-rw $cand if $cand ~~ $test;
  256. }
  257. Nil;
  258. }
  259. multi method list(Backtrace:D:) {
  260. self.AT-POS(100); # will stop when done, do we need more than 100???
  261. nqp::p6bindattrinvres(nqp::create(List), List, '$!reified', $!frames)
  262. }
  263. method first-none-setting-line(Backtrace:D:) {
  264. (self.first({ !.is-hidden && !.is-setting }) // "\n").Str;
  265. }
  266. method concise(Backtrace:D:) {
  267. (self.grep({ !.is-hidden && .is-routine && !.is-setting }) // "\n").join;
  268. }
  269. method full(Backtrace:D:) { self.list.join }
  270. method summary(Backtrace:D:) {
  271. (self.grep({ !.is-hidden && (.is-routine || !.is-setting)}) // "\n").join;
  272. }
  273. method is-runtime (Backtrace:D:) {
  274. my $bt = $!bt;
  275. for $bt.keys {
  276. my $p6sub := $bt[$_]<sub>;
  277. if nqp::istype($p6sub, ForeignCode) {
  278. try {
  279. my Mu $sub := nqp::getattr(nqp::decont($p6sub), ForeignCode, '$!do');
  280. my str $name = nqp::getcodename($sub);
  281. return True if nqp::iseq_s($name, 'THREAD-ENTRY');
  282. return True if nqp::iseq_s($name, 'eval');
  283. return True if nqp::iseq_s($name, 'print_control');
  284. return False if nqp::iseq_s($name, 'compile');
  285. }
  286. }
  287. }
  288. False;
  289. }
  290. }