util.scm (9389B)
1 ;; cc/util.scm — leaf helpers. Depends only on the scheme1 prelude. 2 ;; 3 ;; Realization of docs/CC-INTERNALS.md §util.scm. Engineers may add 4 ;; helpers here freely; the listed signatures are the load-bearing 5 ;; surface other modules call. 6 7 ;; -------------------------------------------------------------------- 8 ;; bytevector helpers (scheme1 strings ARE bytevectors) 9 ;; -------------------------------------------------------------------- 10 (define (bv= a b) (bytevector=? a b)) 11 12 (define (bv-prefix? p s) 13 ;; Is s a bv that starts with the bytes of p? 14 (let ((plen (bytevector-length p)) 15 (slen (bytevector-length s))) 16 (if (< slen plen) 17 #f 18 (let loop ((i 0)) 19 (cond ((= i plen) #t) 20 ((= (bytevector-u8-ref p i) (bytevector-u8-ref s i)) 21 (loop (+ i 1))) 22 (else #f)))))) 23 24 (define (bv-find bv byte from) 25 ;; Linear scan for the first byte == `byte` at index >= from. 26 ;; Returns the index, or #f if not found. 27 (let ((n (bytevector-length bv))) 28 (let loop ((i from)) 29 (cond ((>= i n) #f) 30 ((= (bytevector-u8-ref bv i) byte) i) 31 (else (loop (+ i 1))))))) 32 33 (define (bv-slice bv start end) 34 ;; Fresh copy of bytes in [start, end). bytevector-copy already does 35 ;; this in scheme1 (3-arg form returns a fresh bv). 36 (bytevector-copy bv start end)) 37 38 (define (bv-of-byte b) (make-bytevector 1 b)) 39 40 (define (bv-cat lst-of-bv) 41 ;; Concat a list of bytevectors with one allocation. bytevector-append 42 ;; is variadic, so apply does this in a single linear pass. 43 (apply bytevector-append lst-of-bv)) 44 45 (define (bv->fixnum bv radix) 46 ;; (ok . val) per CC-INTERNALS: (#t . val) on parse, (#f . #f) on fail. 47 ;; string->number is pure and returns #f on parse failure (not the 48 ;; (ok . val) convention, since it's not a syscall). 49 (let ((n (string->number bv radix))) 50 (if n (cons #t n) (cons #f #f)))) 51 52 (define (fixnum->bv n radix) (number->string n radix)) 53 54 ;; -------------------------------------------------------------------- 55 ;; lists / alists 56 ;; -------------------------------------------------------------------- 57 (define (alist-ref key al) 58 ;; equal? compare (intended for bv keys). The prelude's `assoc` uses 59 ;; eq?, so we roll our own for the equal? case. 60 (cond ((null? al) #f) 61 ((equal? (car (car al)) key) (cdr (car al))) 62 (else (alist-ref key (cdr al))))) 63 64 (define (alist-ref/eq key al) 65 ;; eq? compare (for symbol keys). Reuses the prelude's assoc, which 66 ;; is eq?-based. 67 (let ((p (assoc key al))) 68 (if p (cdr p) #f))) 69 70 (define (alist-set key val al) (cons (cons key val) al)) 71 72 (define (alist-update key f al) 73 ;; Functional update by equal? key. If found, replace its value with 74 ;; (f old-val). If not found, prepend (cons key (f #f)) so callers 75 ;; can use this as upsert-with-default. 76 (let loop ((xs al) (acc '())) 77 (cond ((null? xs) 78 (cons (cons key (f #f)) (reverse acc))) 79 ((equal? (car (car xs)) key) 80 (append (reverse acc) 81 (cons (cons key (f (cdr (car xs)))) 82 (cdr xs)))) 83 (else (loop (cdr xs) (cons (car xs) acc)))))) 84 85 (define (any p xs) 86 (cond ((null? xs) #f) 87 ((p (car xs)) #t) 88 (else (any p (cdr xs))))) 89 90 (define (every p xs) 91 (cond ((null? xs) #t) 92 ((p (car xs)) (every p (cdr xs))) 93 (else #f))) 94 95 (define (count p xs) 96 (let loop ((xs xs) (n 0)) 97 (cond ((null? xs) n) 98 ((p (car xs)) (loop (cdr xs) (+ n 1))) 99 (else (loop (cdr xs) n))))) 100 101 ;; -------------------------------------------------------------------- 102 ;; ints 103 ;; -------------------------------------------------------------------- 104 (define (min3 a b c) (min a (min b c))) 105 (define (align-up n k) 106 ;; round n up to the nearest multiple of k (k must be a power of 2) 107 (let ((mask (- k 1))) 108 (bit-and (+ n mask) (bit-not mask)))) 109 110 ;; -------------------------------------------------------------------- 111 ;; output buffer (reversed list of bv chunks; flush concats once) 112 ;; -------------------------------------------------------------------- 113 (define-record-type buf 114 (%buf chunks) 115 buf? 116 (chunks buf-chunks buf-chunks-set!)) 117 118 (define (make-buf) (%buf '())) 119 120 (define (buf-push! b bv) 121 (buf-chunks-set! b (cons bv (buf-chunks b)))) 122 123 (define (buf-flush b) 124 ;; Reverse the chunk list once, then concat in one allocation. 125 (bv-cat (reverse (buf-chunks b)))) 126 127 ;; -------------------------------------------------------------------- 128 ;; diagnostics + I/O 129 ;; -------------------------------------------------------------------- 130 (define (die loc msg . irritants) 131 ;; Format per CC-CONTRACTS §2.3: 132 ;; <file>:<line>:<col>: error: <msg>: <irritant> <irritant> ... 133 ;; When loc is #f, the "<file>:<line>:<col>: " prefix is omitted. 134 ;; irritants are written via display semantics (no quoting); format's 135 ;; ~a handles bv/fixnum/pair/symbol the same way display does. 136 ;; 137 ;; All output is built into a single bv and sent to fd 2 with one 138 ;; sys-write loop, so a partial write doesn't interleave fragments 139 ;; from a concurrent process. 140 (let* ((prefix (if loc 141 (format "~a:~d:~d: error: " 142 (loc-file loc) (loc-line loc) (loc-col loc)) 143 "error: ")) 144 (head (bytevector-append prefix (format "~a" msg))) 145 ;; Irritants get ": " before the first and " " between the rest. 146 (tail (if (null? irritants) 147 (list NL-BV) 148 (let walk ((xs irritants) (sep ": ") (acc '())) 149 (if (null? xs) 150 (reverse (cons NL-BV acc)) 151 (walk (cdr xs) 152 " " 153 (cons (format "~a" (car xs)) 154 (cons sep acc))))))) 155 (out (bv-cat (cons head tail)))) 156 (write-bv-fd 2 out) 157 (sys-exit 1))) 158 159 (define (slurp-fd fd) 160 ;; Read fd to EOF. Uses BUFSIZE chunks (same constant the prelude's 161 ;; port layer uses); bv-concat-reverse builds the result in one 162 ;; allocation so a multi-MB tcc.c stays linear. 163 (let ((buf (make-bytevector BUFSIZE))) 164 (let loop ((acc '())) 165 (let ((r (sys-read fd buf BUFSIZE))) 166 (cond ((not (car r)) 167 (die #f "slurp-fd: sys-read failed" (cdr r))) 168 ((zero? (cdr r)) 169 (bv-concat-reverse acc)) 170 (else 171 (loop (cons (bytevector-copy buf 0 (cdr r)) acc)))))))) 172 173 (define (write-bv-fd fd bv) 174 ;; Full write or die. sys-write may write fewer bytes than requested; 175 ;; loop until everything is written. Avoid the slice copy when a 176 ;; single sys-write completes the whole bv (the common case). 177 ;; 178 ;; On failure we sys-exit directly instead of routing through `die` 179 ;; — `die` itself uses write-bv-fd, so a write failure to fd 2 must 180 ;; not recurse infinitely. Status 1 matches the contract for `die`. 181 (let ((len (bytevector-length bv))) 182 (let loop ((off 0)) 183 (if (= off len) 184 #t 185 (let* ((rem (- len off)) 186 (chunk (if (zero? off) bv (bytevector-copy bv off len))) 187 (r (sys-write fd chunk rem))) 188 (cond ((not (car r)) (sys-exit 1)) 189 ((zero? (cdr r)) (sys-exit 1)) 190 (else (loop (+ off (cdr r)))))))))) 191 192 ;; -------------------------------------------------------------------- 193 ;; debug logging 194 ;; 195 ;; Cheap sticky on/off: the cc compiler is single-threaded and short- 196 ;; lived, so a top-level mutable flag is fine. Toggle via 197 ;; (debug-log-on!) / (debug-log-off!). When on, (debug-log msg . irr) 198 ;; writes one line to fd 2 in the same display-style format as `die`, 199 ;; but doesn't abort. The intent is to trace heap usage between cc 200 ;; phases (lex/pp/parse/cg-finish) without compile-time conditionals. 201 ;; -------------------------------------------------------------------- 202 (define %debug-log-enabled #f) 203 (define (debug-log-on!) (set! %debug-log-enabled #t)) 204 (define (debug-log-off!) (set! %debug-log-enabled #f)) 205 (define (debug-log? ) %debug-log-enabled) 206 207 (define (debug-log msg . irritants) 208 (cond 209 (%debug-log-enabled 210 (let* ((head (bytevector-append "[cc] " (format "~a" msg))) 211 (tail (if (null? irritants) 212 (list NL-BV) 213 (let walk ((xs irritants) (sep ": ") (acc '())) 214 (if (null? xs) 215 (reverse (cons NL-BV acc)) 216 (walk (cdr xs) 217 " " 218 (cons (format "~a" (car xs)) 219 (cons sep acc))))))) 220 (out (bv-cat (cons head tail)))) 221 (write-bv-fd 2 out))) 222 (else #t))) 223 224 ;; -------------------------------------------------------------------- 225 ;; fresh-name generator (used for cg label counters, etc.) 226 ;; -------------------------------------------------------------------- 227 (define (make-namer prefix) 228 ;; Returns a thunk; each call yields prefix0, prefix1, ... as a fresh 229 ;; bv. The counter lives in the closure's lexical environment; scheme1 230 ;; closures heap-capture by reference, so set! on ctr is sticky. 231 (let ((ctr 0)) 232 (lambda () 233 (let ((s (bytevector-append prefix (number->string ctr 10)))) 234 (set! ctr (+ ctr 1)) 235 s))))