diff --git a/module/language/cps/intmap.scm b/module/language/cps/intmap.scm index d45373147..cb56cb31e 100644 --- a/module/language/cps/intmap.scm +++ b/module/language/cps/intmap.scm @@ -629,10 +629,44 @@ (define (intmap->alist intmap) (reverse (intmap-fold acons intmap '()))) +(define (intmap-key-ranges intmap) + (call-with-values + (lambda () + (intmap-fold (lambda (k v start end closed) + (cond + ((not start) (values k k closed)) + ((= k (1+ end)) (values start k closed)) + (else (values k k (acons start end closed))))) + intmap #f #f '())) + (lambda (start end closed) + (reverse (if start (acons start end closed) closed))))) + +(define (range-string ranges) + (string-join (map (match-lambda + ((start . start) + (format #f "~a" start)) + ((start . end) + (format #f "~a-~a" start end))) + ranges) + ",")) + +(define (print-helper port tag intmap) + (let ((ranges (intmap-key-ranges intmap))) + (match ranges + (() + (format port "#<~a>" tag)) + (((0 . _) . _) + (format port "#<~a ~a>" tag (range-string ranges))) + (((min . end) . ranges) + (let ((ranges (map (match-lambda + ((start . end) (cons (- start min) (- end min)))) + (acons min end ranges)))) + (format port "#<~a ~a+~a>" tag min (range-string ranges))))))) + (define (print-intmap intmap port) - (format port "#" (intmap->alist intmap))) + (print-helper port "intmap" intmap)) (define (print-transient-intmap intmap port) - (format port "#" (intmap->alist intmap))) + (print-helper port "transient-intmap" intmap)) (set-record-type-printer! print-intmap) (set-record-type-printer! print-transient-intmap) diff --git a/module/language/cps/intset.scm b/module/language/cps/intset.scm index 327624646..3d207975e 100644 --- a/module/language/cps/intset.scm +++ b/module/language/cps/intset.scm @@ -27,6 +27,7 @@ (define-module (language cps intset) #:use-module (rnrs bytevectors) #:use-module (srfi srfi-9) + #:use-module (srfi srfi-9 gnu) #:use-module (ice-9 match) #:export (empty-intset intset? @@ -731,3 +732,45 @@ (let ((min* (round-down pos *leaf-bits*))) (lp (finish-tail out min tail) min* pos (ash 1 (- pos min*))))))))) + +(define (intset-key-ranges intset) + (call-with-values + (lambda () + (intset-fold (lambda (k start end closed) + (cond + ((not start) (values k k closed)) + ((= k (1+ end)) (values start k closed)) + (else (values k k (acons start end closed))))) + intset #f #f '())) + (lambda (start end closed) + (reverse (if start (acons start end closed) closed))))) + +(define (range-string ranges) + (string-join (map (match-lambda + ((start . start) + (format #f "~a" start)) + ((start . end) + (format #f "~a-~a" start end))) + ranges) + ",")) + +(define (print-helper port tag intset) + (let ((ranges (intset-key-ranges intset))) + (match ranges + (() + (format port "#<~a>" tag)) + (((0 . _) . _) + (format port "#<~a ~a>" tag (range-string ranges))) + (((min . end) . ranges) + (let ((ranges (map (match-lambda + ((start . end) (cons (- start min) (- end min)))) + (acons min end ranges)))) + (format port "#<~a ~a+~a>" tag min (range-string ranges))))))) + +(define (print-intset intset port) + (print-helper port "intset" intset)) +(define (print-transient-intset intset port) + (print-helper port "transient-intset" intset)) + +(set-record-type-printer! print-intset) +(set-record-type-printer! print-transient-intset)