On 3/14/20 7:19 AM, Christopher Howard wrote:
I think there are others here better qualified to answer your question,
but maybe one helpful thing: have you read the Guile Implementation
section of the Guile Reference Manual? In subsection "A Virtual Machine
for Guile" there is this paragraph:
'''
Note that once a value in a local variable slot is no longer needed,
Guile is free to re-use that slot. This applies to the slots that were
initially used for the callee and arguments, too. For this reason,
backtraces in Guile aren’t always able to show all of the arguments: it
could be that the slot corresponding to that argument was re-used by
some other variable.
'''
I do not know if there is a way to disable slot reuse, for debugging
purposes. Anyone...?
I started looking into this a while back but gave up for now.
What I tried was
1) Add a debug flag "-g" to guild compile. In interactive mode
I think it's possible to set the optimization flags, this would
be '(debug . #t)
2) In the cps conversion add a hook to un-reuse slots.
It didn't work. I think the return value(s) need to be in the first
slots. Back to the drawing board. Below is the patch.
Below is a patch reflecting the changes I made to guile-2.2.4 to try:
--- module/scripts/compile.scm-orig 2018-08-07 03:34:55.000000000 -0700
+++ module/scripts/compile.scm 2019-06-01 16:47:37.586223675 -0700
@@ -84,6 +84,12 @@
(cons (string->symbol arg) warnings)
(alist-delete 'warnings result))))))
+ (option '(#\g "debug") #f #f
+ (lambda (opt name arg result)
+ (alist-cons 'optimizations
+ (cons* #:debug #t (optimizations-for-level 0))
+ result)))
+
(option '(#\O "optimize") #t #f
(lambda (opt name arg result)
(define (return val)
--- module/language/cps/compile-bytecode.scm-orig 2018-10-03
13:55:11.000000000 -0700
+++ module/language/cps/compile-bytecode.scm 2019-06-02
11:49:31.812374598 -0700
@@ -41,6 +41,12 @@
#:use-module (system base types internal)
#:export (compile-bytecode))
+(define-public cps-debug-1 #f)
+(define-public cps-debug-2 #f)
+(define-public cps-debug-3 #f)
+(define-public cps-debug-4 #f)
+(define-public cps-debug-5 #f)
+
(define (kw-arg-ref args kw default)
(match (memq kw args)
((_ val . _) val)
@@ -84,6 +90,9 @@
(define (compile-function cps asm opts)
(let* ((allocation (allocate-slots cps #:precolor-calls?
(kw-arg-ref opts
#:precolor-calls? #t)))
+ (allocation (if (kw-arg-ref opts #:debug #f)
+ (expand-slots allocation cps)
+ allocation))
(forwarding-labels (compute-forwarding-labels cps allocation))
(frame-size (lookup-nlocals allocation)))
(define (forward-label k)
@@ -655,6 +664,8 @@
(emit-end-arity asm)
(emit-end-program asm))))
+ (set! cps-debug-1 cps)
+ (set! cps-debug-2 allocation)
(intmap-for-each compile-cont cps)))
(define (emit-bytecode exp env opts)
--- module/language/cps/slot-allocation.scm-orig 2019-06-01
16:47:37.586223675 -0700
+++ module/language/cps/slot-allocation.scm 2019-06-02
19:46:49.473749251 -0700
@@ -998,3 +998,35 @@
(shuffles (compute-shuffles cps slots calls live-in))
(frame-size (compute-frame-size cps slots calls shuffles)))
(make-allocation slots representations calls shuffles
frame-size))))))
+
+;;(use-modules (ice-9 pretty-print))
+;;(define (pp exp) (pretty-print exp #:per-line-prefix " "))
+(define (find-return-slots cps)
+ (let* ((kt (match (intmap-ref cps 0) (($ $kfun _ m s t c) t))))
+ (intmap-fold
+ (lambda (ix iv kv)
+ (match iv
+ (($ $kargs _ _ ($ $continue kx _ ($ $values vals)))
+ (if (= kx kt) vals kv))
+ (_ kv)))
+ cps #f)))
+
+(define (expand-slots allocation cps)
+ (display "expanding slots\n")
+ (let* ((rs (find-return-slots cps))
+ (nr (length rs))
+ (rm (map cons rs (iota nr))))
+ (match allocation
+ (($ $allocation slots representations call-allocs shuffles
frame-size)
+ (call-with-values
+ (lambda ()
+ (intmap-fold
+ (lambda (ix iv im n)
+ (if (assq-ref rm ix)
+ (values (intmap-add im ix (assq-ref rm ix)) n)
+ (values (intmap-add im ix n) (1+ n))))
+ slots empty-intmap nr))
+ (lambda (xslots xframe-size)
+ (make-allocation xslots representations call-allocs shuffles
+ xframe-size)))))))
+(export expand-slots)
