ref: 00b0398b4fb4da73a959649fc3fb8ba81f13a2ae
dir: /src/plan9/lsd.lsp/
#!/bin/sl
(defstruct reg name type addr size)
(defstruct symbol name type addr)
(defstruct global text data)
(defstruct frame loc retpc sp locals)
(def coref NIL)
(def textf NIL)
(def regsf NIL)
(def fpregsf NIL)
(def proc-stdin NIL)
(def pids ())
(def bptbl (table))
(def (procfile s . flags)
(if (< pid 0) (error "no active pid"))
(let ((path (str "/proc/" pid "/" s)))
(apply file (cons path flags))))
(def (writectl msg)
(let ((ctlf (procfile 'ctl :write)))
(io-write ctlf msg)
(io-close ctlf)))
(def (exited)
(if (< pid 0) (error "no active pid"))
(princ "process " pid " exited\n")
(set! pids (cdr pids))
(set! pid (if pids (car pids) -1))
(detach))
(def (readnote)
(trycatch
(let* ((notef (procfile 'note :read))
(note (io-readall notef)))
(io-close notef)
note)
(λ (e) (if (and (eq? (car e) 'io-error)
(= (str-find (cadr e) "could not open") 0))
(exited)
(raise e)))))
(def (start) (writectl "start"))
(def (startstop) (writectl "startstop") (readnote))
(def (stop) (writectl "stop") (readnote))
(def (follow addr) (reverse (lsd-follow addr)))
(def (io-pread f off rest)
(io-seek f off)
(apply io-read (cons f rest)))
(def (io-pwrite f off rest)
(io-seek f off)
(apply io-write (cons f rest))
(io-flush f))
(def (readcore addr . rest)
(unless coref (error "not attached to proc"))
(io-pread coref addr rest))
(def (readtext addr . rest)
(unless textf (error "not attached to proc"))
(io-pread textf addr rest))
(def (writecore addr . rest)
(unless coref (error "not attached to proc"))
(io-pwrite coref addr rest))
(def (readreg reg)
(unless regsf (error "not attached to proc"))
(let ((f (case (reg-type reg)
((:gpreg) regsf)
((:fpreg) fpregsf))))
(io-pread f (reg-addr reg) (list (reg-size reg)))))
(def (readsym symbol . rest)
(unless coref (error "not attached to proc"))
(apply readcore (cons (symbol-addr symbol) rest)))
(let ((bp_init (λ (loc)
(if (< pid 0) (error "no running process"))
(unless (eq? (status) 'Stopped)
(begin (princ "Waiting... " status "\n")
(stop)))
(cond ((sym? loc) (unless (has? (global-text globals) loc)
(error "symbol " loc " not found"))
(symbol-addr (get (global-text globals) loc)))
((num? loc) (u64 loc))
(else (error "symbol or number"))))))
(set! bpset (λ (loc)
(let ((addr (bp_init loc)))
(if (has? bptbl addr)
(error "breakpoint already set at " loc))
(put! bptbl addr (readcore addr 'byte (length bpinst)))
(writecore addr bpinst))))
(set! bpdel (λ (loc)
(let ((addr (bp_init loc)))
(unless (has? bptbl addr)
(error "breakpoint not set at " loc))
(writecore addr (get bptbl addr))
(del! bptbl addr)))))
(def (detach)
(if regsf (io-close regsf))
(if fpregsf (io-close fpregsf))
(if coref (io-close coref))
(if textf (io-close textf))
(void))
(def (attach)
(detach)
(set! regsf (procfile 'regs :read :write))
(set! fpregsf (procfile 'fpregs :read :write))
(set! coref (procfile 'mem :read :write))
(set! textf (procfile 'text :read))
(void))
(def (new . args)
(let ((v (apply lsd-new args)))
(if proc-stdin (io-close proc-stdin))
(set! bptbl (table))
(set! pid (aref v 0))
(set! proc-stdin (aref v 1))
(attach)
(bpset (car (follow (symbol-addr (get (global-text globals) 'main)))))
(startstop)
(set! pids (cons pid pids))
pid))
(def (lsd a)
(let* ((v (lsd-load a))
(f (λ (symbol tbl) (put! tbl (sym (symbol-name symbol)) symbol)))
(text (foldl f (table) (aref v 3)))
(data (foldl f (table) (aref v 4))))
(set! pid (aref v 0))
(set! registers (aref v 1))
(set! bpinst (aref v 2))
(set! globals (make-global :text text :data data)))
(if (>= pid 0) (attach)))
(def (status)
(let* ((sf (procfile 'status))
(stats (read-all sf)))
(io-close sf)
(caddr stats)))
(def tracers (table
"amd64" (λ () (lsd-ctrace (readreg PC) (readreg SP) (u64 0)))
"arm64" (λ () (lsd-ctrace (readreg PC) (readreg SP) (readreg R30)))))
(def _stk (get tracers (os-getenv "objtype")))
(def (curPC) (if (>= pid 0) (readreg PC)))
(def (step)
(let* ((addr (readreg PC))
(on-bp (has? bptbl addr)))
(if on-bp (writecore addr (get bptbl addr)))
(let* ((f (follow addr))
(o (map (λ (a) (readcore a 'byte (length bpinst))) f)))
(for-each (λ (a) (writecore a bpinst)) f)
(startstop)
(map writecore f o)
(if on-bp (writecore addr bpinst))
(or (curPC) (void)))))
(def (cont)
(let ((addr (readreg PC)))
(if (has? bptbl addr) (step))
(startstop)
(or (curPC) (void))))
(def (asm addr (n 5))
"Print the next n disassembled instructions at addr.
By default n is 5 and it returns the following instruction
so it can be called again.
Examples:
(asm (readreg PC)) ; print out 5 from current program instruction.
(asm (readreg PC) 10) ; print out 10 from current program instruction.
(asm (step)) ; step and then print out 5.
(asm (asm (readreg PC)) 3) ; print 3 more."
(if (<= n 0)
addr
(let ((on-bp (has? bptbl addr)))
(if on-bp (writecore addr (get bptbl addr)))
(let* ((a (lsd-asm addr))
(next (car a))
(instr (cadr a)))
(princ instr "\n")
(if on-bp (writecore addr bpinst))
(asm (+ addr next) (1- n))))))
(def (at-exit s)
(if proc-stdin (io-close proc-stdin))
(detach)
(lsd-cleanup)
(for-each (λ (p) (princ "echo kill > /proc/" p "/ctl\n")) pids))
(add-exit-hook at-exit)
(let* ((proc (cadr *argv*))
(pid (str->num proc)))
(if pid (lsd pid) (lsd proc)))
(repl)