ref: 55c93fc3d47f608104839dbb21b8339a95df4d82
parent: d170d141ad95660edfdd8dca4bebe9d7b4485197
author: Sigrid Solveig Haflínudóttir <sigrid@ftrv.se>
date: Sat Nov 9 14:06:50 EST 2024
provide instruction pointers in stacktrace; disassemble when dumping exceptions
--- a/compiler.lsp
+++ b/compiler.lsp
@@ -601,10 +601,9 @@
(define (hex5 n)
(string-lpad (number->string n 16) 5 #\0))
-(define (disassemble f . lev?)
+(define (disassemble f (ip #f) . lev?)
(if (null? lev?)
- (begin (disassemble f 0)
- (newline)
+ (begin (disassemble f ip 0)
(return #t)))
(let ((lev (car lev?))
(code (function:code f))
@@ -612,10 +611,15 @@
(define (print-val v)
(if (and (function? v) (not (builtin? v)))
(begin (princ "\n")
- (disassemble v (+ lev 1)))
+ (disassemble v #f (+ lev 1)))
(print v)))
+ (define (print-inst inst s sz) (princ (if (and ip (= lev 0) (>= ip (1- s)) (< ip (+ s sz)))
+ " >"
+ " ")
+ (hex5 (- s 5)) ": "
+ (string inst) "\t"))
(dotimes (xx lev) (princ "\t"))
- (princ "maxstack " (ref-int32-LE code 0) "\n")
+ ;(princ "maxstack " (ref-int32-LE code 0) "\n")
(let ((i 4)
(N (length code)))
(while (< i N)
@@ -626,28 +630,31 @@
#f Instructions)))
(if (> i 4) (newline))
(dotimes (xx lev) (princ "\t"))
- (princ (hex5 (- i 4)) ": "
- (string inst) "\t")
(set! i (+ i 1))
(case inst
((loadv.l loadg.l setg.l)
+ (print-inst inst i 4)
(print-val (aref vals (ref-int32-LE code i)))
(set! i (+ i 4)))
((loadv loadg setg)
+ (print-inst inst i 1)
(print-val (aref vals (aref code i)))
(set! i (+ i 1)))
((loada seta call tcall list + - * / vector
argc vargc loadi8 apply tapply)
+ (print-inst inst i 1)
(princ (number->string (aref code i)))
(set! i (+ i 1)))
((loada.l seta.l largc lvargc call.l tcall.l)
+ (print-inst inst i 4)
(princ (number->string (ref-int32-LE code i)))
(set! i (+ i 4)))
((loadc setc)
+ (print-inst inst i 2)
(princ (number->string (aref code i)) " ")
(set! i (+ i 1))
(princ (number->string (aref code i)))
@@ -654,6 +661,7 @@
(set! i (+ i 1)))
((loadc.l setc.l optargs keyargs)
+ (print-inst inst i (+ 8 (if (eq? inst 'keyargs) 4 0)))
(princ (number->string (ref-int32-LE code i)) " ")
(set! i (+ i 4))
(princ (number->string (ref-int32-LE code i)))
@@ -665,18 +673,21 @@
(set! i (+ i 4)))))
((brbound)
+ (print-inst inst i 4)
(princ (number->string (ref-int32-LE code i)) " ")
(set! i (+ i 4)))
((jmp brf brt brne brnn brn)
+ (print-inst inst i 2)
(princ "@" (hex5 (+ i -4 (ref-int16-LE code i))))
(set! i (+ i 2)))
((jmp.l brf.l brt.l brne.l brnn.l brn.l)
+ (print-inst inst i 4)
(princ "@" (hex5 (+ i -4 (ref-int32-LE code i))))
(set! i (+ i 4)))
- (else #f)))))))
+ (else (print-inst inst i 1))))))))
; From SRFI 89 by Marc Feeley (http://srfi.schemers.org/srfi-89/srfi-89.html)
; Copyright (C) Marc Feeley 2006. All Rights Reserved.
--- a/flisp.boot
+++ b/flisp.boot
@@ -197,12 +197,13 @@
#fn("8000n120>D51Aq62:" #(#fn("6000n120>?040:" #(#fn("9000n20H38070161:219100<52390A0=162:229100<D534A0=0<1P62:" #(reverse! #fn(has?) #fn(put!))))))) #fn(table) #fn("8000n270015238071161:071151P:" #(memberdelete-duplicates))) delete-duplicates)
- disassemble #fn("=000|11JC0700E52471504D:@30D4221<230512405163:" #(disassemble- newline #fn("7000n320>D61:" #(#fn(":000n120>?04EAK\x8021~4722374FE522553426>r427F5162:" #(#fn("9000n10\\;36040[S3D07021514720910KM62:73061:" #(princ- "\n" disassemble print) print-val) #fn("7000n1702161:" #(princ "\t")) princ- "maxstack " ref-int32-LE "\n" #fn(":000n2D01L3E0420>2122>O735351@\x19/:" #(#fn(";000n170Ar4523907150@30D4E920K\x8022~47374Ar4\x8051252605127544AKMz00428>061:" #(>- newline #fn("7000n1702161:" #(princ "\t")) princ hex5 ": " #fn(string) "\t"- #fn("=000n120021523P09209327293191052G514910r4Mz10:20023523L0920932931910GG514910KMz10:20024523K07526931910G51514910KMz10:20027523O07526729319105251514910r4Mz10:20028523f07526931910G5129524910KMz1047526931910G51514910KMz10:2002:523\x9c0752672931910525129524910r4Mz1047526729319105251514910r4Mz104A2;CX07529514752672931910525129524910r4Mz10:D:02<c3Q0752672931910525129524910r4Mz10:2002=523X0752>7?910r,7@93191052g351524910r2Mz10:2002A523X0752>7?910r,7293191052g351524910r4Mz10:O:" #(#fn(memq)+ disassemble #fn("?000\x891000.///\x8a1000I60O?14|282J?07001E534D:@30D421>82<220512305163:" #(disassemble+ #fn("8000n320>DD62:" #(#fn(":000n220>?0421>?14EAK\x8022~423>r424F5162:" #(#fn(":000n10\\;36040[S3E07021514720O910KM63:73061:" #(princ+ "\n" disassemble print) print-val) #fn("<000n370921;3V04910El;3L04719217215152;3;04921182ML37023@4024751r5\x805126270512865:" #(princ+ >= 1- " >" " " hex5 ": " #fn(string) "\t") print-inst)
+ #fn("7000n1702161:" #(princ "\t")) #fn(":000n2D01L3E0420>2122>O735351@\x19/:" #(#fn(";000n170Ar4523907150@30D4E920K\x8022~4AKMz00423>061:" #(>+ newline #fn("7000n1702161:" #(princ "\t"))+ #fn(">000n120021523\\0921A910r45349209327293191052G514910r4Mz10:20023523W0921A910K534920932931910GG514910KMz10:20024523V0921A910K5347526931910G51514910KMz10:20027523[0921A910r45347526729319105251514910r4Mz10:20028523r0921A910r25347526931910G5129524910KMz1047526931910G51514910KMz10:2002:523\xb50921A910r8A2;C70r4@30EM534752672931910525129524910r4Mz1047526729319105251514910r4Mz104A2;CX07529514752672931910525129524910r4Mz10:D:02<c3]0921A910r4534752672931910525129524910r4Mz10:2002=523d0921A910r2534752>7?910r,7@93191052g351524910r2Mz10:2002A523d0921A910r4534752>7?910r,7293191052g351524910r4Mz10:921A910K63:" #(#fn(memq)(loadv.l loadg.l setg.l) ref-int32-LE (loadv loadg setg)
(loada seta call tcall list + - * / vector argc vargc loadi8 apply tapply)
princ #fn(number->string) (loada.l seta.l largc lvargc call.l tcall.l) (loadc
@@ -372,9 +373,9 @@
string-join #fn(map) #fn(string) reverse! "/" λ))
#fn("8000n07021>F524O:" #(for-each #fn("9000n19100Aq63:" #()))) #fn("7000n10B;3B040<20Q;38040T21Q38072061:23061:" #(thrown-value- ffound caddr #fn(raise)))) fn-name) #fn("8000n37021>062:" #(for-each #fn("9000n1702190222534739110EGF5274051=P51475504902KMz02:" #(princ- "#" " " print vector->list newline)))) reverse! length> list-tail
- *interactive* filter closure? #fn(map) #fn("7000n10Z;380420061:" #(#fn(top-level-value)))+ ffound caddr #fn(raise)))) fn-name) #fn("8000n37021>062:" #(for-each #fn("9000n1709110KGF5271051==P51472504730KG0EG524902KMz02:" #(print+ vector->list newline disassemble)))) reverse! length> list-tail *interactive*
+ filter closure? #fn(map) #fn("7000n10Z;380420061:" #(#fn(top-level-value)))#fn(environment)))) print-stack-trace)
print-to-string #fn("7000n120>215061:" #(#fn("8000n120A052421061:" #(#fn(write)#fn(iostream->string))) #fn(buffer)) print-to-string)
--- a/flisp.c
+++ b/flisp.c
@@ -1784,19 +1784,24 @@
fl_gc_handle(&lst);
while(top > 0){+ const uint8_t *ip1 = (void*)fl->Stack[top-2];
uint32_t sz = fl->Stack[top-3]+1;
uint32_t bp = top-5-sz;
- value_t v = alloc_vector(sz, 0);
+ value_t func = fl->Stack[bp];
+ const uint8_t *ip0 = cv_data((cvalue_t*)ptr(fn_bcode(func)));
+ value_t ip = ip1 - ip0 - 1; /* -1: ip1 is *after* the one that was being executed */
+ value_t v = alloc_vector(sz+1, 0);
+ vector_elt(v, 0) = fixnum(ip);
+ vector_elt(v, 1) = func;
if(fl->Stack[top-1] /*captured*/){- vector_elt(v, 0) = fl->Stack[bp];
- memmove(&vector_elt(v, 1),
+ memmove(&vector_elt(v, 2),
&vector_elt(fl->Stack[bp+1], 0), (sz-1)*sizeof(value_t));
}else{- for(uint32_t i = 0; i < sz; i++){+ for(uint32_t i = 1; i < sz; i++){value_t si = fl->Stack[bp+i];
// if there's an error evaluating argument defaults some slots
// might be left set to UNBOUND (issue #22)
- vector_elt(v, i) = si == UNBOUND ? fl->FL_UNSPECIFIED : si;
+ vector_elt(v, i+1) = si == UNBOUND ? fl->FL_UNSPECIFIED : si;
}
}
lst = fl_cons(v, lst);
--- a/system.lsp
+++ b/system.lsp
@@ -941,10 +941,10 @@
(n 0))
(for-each
(λ (f)
- (princ "#" n " ")
- (print (cons (fn-name (aref f 0) e)
- (cdr (vector->list f))))
+ (print (cons (fn-name (aref f 1) e)
+ (cdr (cdr (vector->list f)))))
(newline)
+ (disassemble (aref f 1) (aref f 0))
(set! n (+ n 1)))
st)))