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).Num;
  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.absolute;
  119. }
  120. next if $file.ends-with('BOOTSTRAP.nqp')
  121. || $file.ends-with('QRegex.nqp')
  122. || $file.ends-with('Perl6/Ops.nqp');
  123. if $file.ends-with('NQPHLL.nqp') || $file.ends-with('NQPHLL.moarvm') {
  124. # This could mean we're at the end of the interesting backtrace,
  125. # or it could mean that we're in something like sprintf (which
  126. # uses an NQP grammar to parse the format string).
  127. while $!bt-next < $elems {
  128. my $frame := $!bt.AT-POS($!bt-next++);
  129. my $annotations := $frame<annotations>;
  130. next unless $annotations;
  131. my $file := $annotations<file>;
  132. next unless $file;
  133. if $file.starts-with('SETTING::') {
  134. $!bt-next--; # re-visit this frame
  135. last;
  136. }
  137. }
  138. next;
  139. }
  140. my $line := $annotations<line>;
  141. next unless $line;
  142. my $name := nqp::p6box_s(nqp::getcodename($do));
  143. if $name eq 'handle-begin-time-exceptions' {
  144. $!bt-next = $elems;
  145. last;
  146. }
  147. my $code;
  148. try {
  149. $code := nqp::getcodeobj($do);
  150. $code := Any unless nqp::istype($code, Mu);
  151. };
  152. nqp::push($!frames,
  153. Backtrace::Frame.new(
  154. $file,
  155. $line.Int,
  156. $code,
  157. $name.starts-with("_block") ?? '<anon>' !! $name,
  158. )
  159. );
  160. last unless $todo = $todo - 1;
  161. }
  162. # found something
  163. if nqp::existspos($!frames,$pos) {
  164. nqp::atpos($!frames,$pos);
  165. }
  166. # we've reached the end, don't show the last <unit-outer> if there is one
  167. else {
  168. nqp::pop($!frames) if $!frames;
  169. Nil;
  170. }
  171. }
  172. method next-interesting-index(Backtrace:D:
  173. Int $idx is copy = 0, :$named, :$noproto, :$setting) {
  174. ++$idx;
  175. while self.AT-POS($idx++) -> $cand {
  176. next if $cand.is-hidden; # hidden is never interesting
  177. next if $noproto # no proto's please
  178. && $cand.code.?is_dispatcher; # if a dispatcher
  179. next if !$setting # no settings please
  180. && $cand.is-setting; # and in setting
  181. my $n := $cand.subname;
  182. next if $named && !$n; # only want named ones and no name
  183. next if $n eq '<unit-outer>'; # outer calling context
  184. return $idx - 1;
  185. }
  186. Nil;
  187. }
  188. method outer-caller-idx(Backtrace:D: Int $startidx) {
  189. if self.AT-POS($startidx).code -> $start {
  190. my %outers;
  191. my $current = $start.outer;
  192. while $current.DEFINITE {
  193. %outers{$current.static_id} = $start;
  194. $current = $current.outer;
  195. }
  196. my @outers;
  197. my $i = $startidx;
  198. while self.AT-POS($i++) -> $cand {
  199. my $code = $cand.code;
  200. next unless $code.DEFINITE && %outers{$code.static_id}.DEFINITE;
  201. @outers.push: $i - 1;
  202. last if $cand.is-routine;
  203. }
  204. @outers;
  205. }
  206. else {
  207. $startidx.list;
  208. }
  209. }
  210. method nice(Backtrace:D: :$oneline) {
  211. my $setting = %*ENV<RAKUDO_BACKTRACE_SETTING>;
  212. try {
  213. my @frames;
  214. my Int $i = self.next-interesting-index(-1);
  215. while $i.defined {
  216. $i = self.next-interesting-index($i, :$setting) if $oneline;
  217. last unless $i.defined;
  218. my $prev = self.AT-POS($i);
  219. if $prev.is-routine {
  220. @frames.push: $prev;
  221. } else {
  222. my @outer_callers := self.outer-caller-idx($i);
  223. my $target_idx = @outer_callers.keys.grep({self.AT-POS($i).code.^isa(Routine)})[0];
  224. $target_idx ||= @outer_callers[0] || $i;
  225. my $current = self.AT-POS($target_idx);
  226. @frames.append: $current.clone(line => $prev.line);
  227. $i = $target_idx;
  228. }
  229. last if $oneline;
  230. $i = self.next-interesting-index($i, :$setting);
  231. }
  232. CATCH {
  233. default {
  234. return "<Internal error while creating backtrace: $_.message() $_.backtrace.full().\n"
  235. ~ "Please report this as a bug (mail to rakudobug@perl.org)\n",
  236. ~ "and re-run with the --ll-exception command line option\n"
  237. ~ "to get more information about your error>";
  238. }
  239. }
  240. @frames.join;
  241. }
  242. }
  243. multi method gist(Backtrace:D:) {
  244. my $els := +self.list;
  245. 'Backtrace(' ~ $els ~ ' frame' ~ 's' x ($els != 1) ~ ')'
  246. }
  247. multi method Str(Backtrace:D:) { self.nice }
  248. multi method flat(Backtrace:D:) { self.list }
  249. multi method map(Backtrace:D: &block) {
  250. my $pos = 0;
  251. gather while self.AT-POS($pos++) -> $cand {
  252. take block($cand);
  253. }
  254. }
  255. multi method first(Backtrace:D: Mu $test) {
  256. my $pos = 0;
  257. while self.AT-POS($pos++) -> $cand {
  258. return-rw $cand if $cand ~~ $test;
  259. }
  260. Nil;
  261. }
  262. multi method list(Backtrace:D:) {
  263. self.AT-POS(100); # will stop when done, do we need more than 100???
  264. nqp::p6bindattrinvres(nqp::create(List), List, '$!reified', $!frames)
  265. }
  266. method first-none-setting-line(Backtrace:D:) {
  267. (self.first({ !.is-hidden && !.is-setting }) // "\n").Str;
  268. }
  269. method concise(Backtrace:D:) {
  270. (self.grep({ !.is-hidden && .is-routine && !.is-setting }) // "\n").join;
  271. }
  272. method full(Backtrace:D:) { self.list.join }
  273. method summary(Backtrace:D:) {
  274. (self.grep({ !.is-hidden && (.is-routine || !.is-setting)}) // "\n").join;
  275. }
  276. method is-runtime (Backtrace:D:) {
  277. my $bt = $!bt;
  278. for $bt.keys {
  279. my $p6sub := $bt[$_]<sub>;
  280. if nqp::istype($p6sub, ForeignCode) {
  281. try {
  282. my Mu $sub := nqp::getattr(nqp::decont($p6sub), ForeignCode, '$!do');
  283. my str $name = nqp::getcodename($sub);
  284. return True if nqp::iseq_s($name, 'THREAD-ENTRY');
  285. return True if nqp::iseq_s($name, 'eval');
  286. return True if nqp::iseq_s($name, 'print_control');
  287. return False if nqp::iseq_s($name, 'compile');
  288. }
  289. }
  290. }
  291. False;
  292. }
  293. }