cg.scm (50336B)
1 ;; cc/cg.scm — codegen state and emission API. 2 ;; Realization of docs/CC-INTERNALS.md §cg.scm. 3 ;; Conversion split per CC-CONTRACTS §4: parse owns promotion etc; 4 ;; cg owns sign extension, signed/unsigned dispatch, pointer scaling. 5 ;; 6 ;; Output uses libp1pp's structured macros (%fn, %ifelse_nez, 7 ;; %loop_tag, %break, %continue) per docs/LIBP1PP.md. 8 ;; 9 ;; Frame layout (CC-CONTRACTS §3): 10 ;; [sp + 0 .. staging*8) outgoing-arg staging 11 ;; [sp + staging*8 ..) locals + spilled vstack values 12 ;; Slot offsets are emitted symbolically as `(+ %<fn>__SO N)` so the 13 ;; staging size, only known at fn-end, can be filled in via a 0-arg 14 ;; M1pp macro `<fn>__SO` defined just before the `%fn(...)` block. 15 16 (define (%cg-emit-buf cg) 17 (let ((fb (cg-fn-buf cg))) (if fb fb (cg-text cg)))) 18 19 (define (%cg-emit cg bv) 20 (buf-push! (%cg-emit-buf cg) bv)) 21 22 (define (%cg-emit-many cg bvs) 23 (for-each (lambda (b) (%cg-emit cg b)) bvs)) 24 25 (define (%n n) (number->string n 10)) 26 27 ;; Per-fn metadata (name, ret-slot, ret-type) is stashed on cg-globals 28 ;; under symbol keys that don't collide with bv name keys. 29 (define (%cg-fn-set! cg key val) 30 (cg-globals-set! cg (alist-update key (lambda (_) val) (cg-globals cg)))) 31 32 (define (%cg-fn-get cg key) (alist-ref/eq key (cg-globals cg))) 33 34 (define (%cg-fresh-label cg prefix) 35 (let* ((n (cg-label-ctr cg)) 36 (bv (bytevector-append prefix (%n n)))) 37 (cg-label-ctr-set! cg (+ n 1)) 38 bv)) 39 40 (define (%cg-fresh-loop-tag cg) (%cg-fresh-label cg "L")) 41 (define (%cg-fresh-lbl cg) (%cg-fresh-label cg "lbl_")) 42 43 (define (%cg-bump-outgoing! cg n) 44 (if (< (cg-max-outgoing cg) n) (cg-max-outgoing-set! cg n) 0)) 45 46 (define (%cg-slot-expr cg logical-off) 47 (let ((nm (%cg-fn-get cg '%fn-name))) 48 (bv-cat (list "(+ %" nm "__SO " (%n logical-off) ")")))) 49 50 (define (%cg-mangle-global name-bv) 51 (bytevector-append "cc__" name-bv)) 52 53 (define (%cg-reg->bv r) (symbol->string r)) 54 55 (define (%cg-emit-li cg reg n) 56 (%cg-emit-many cg (list "%li(" (%cg-reg->bv reg) ", " (%n n) ")\n"))) 57 58 (define (%cg-emit-la cg reg label-bv) 59 (%cg-emit-many cg (list "%la(" (%cg-reg->bv reg) ", &" label-bv ")\n"))) 60 61 (define (%cg-emit-ld-slot cg reg logical-off) 62 (%cg-emit-many cg (list "%ld(" (%cg-reg->bv reg) ", sp, " 63 (%cg-slot-expr cg logical-off) ")\n"))) 64 65 (define (%cg-emit-st-slot cg reg logical-off) 66 (%cg-emit-many cg (list "%st(" (%cg-reg->bv reg) ", sp, " 67 (%cg-slot-expr cg logical-off) ")\n"))) 68 69 (define (%cg-emit-ld cg reg base off) 70 (%cg-emit-many cg (list "%ld(" (%cg-reg->bv reg) ", " 71 (%cg-reg->bv base) ", " (%n off) ")\n"))) 72 73 (define (%cg-emit-st cg reg base off) 74 (%cg-emit-many cg (list "%st(" (%cg-reg->bv reg) ", " 75 (%cg-reg->bv base) ", " (%n off) ")\n"))) 76 77 ;; Width-aware load/store. Dispatches on ctype-size: 78 ;; 1: %lb / %sb (LB zero-extends; for signed i8 we sign-extend by 79 ;; shli/sari 56 to materialize the canonical 64-bit form). 80 ;; 2/4: byte-decomposed (P1 has only 1-byte and 8-byte memory ops, 81 ;; and word ops require natural alignment which we can't promise 82 ;; for struct fields or non-word-aligned local slots). Loads 83 ;; gather bytes via %lb + shli/or; stores scatter via shri/%sb. 84 ;; Signed loads (i16/i32) sign-extend via shli/sari to canonical 85 ;; 64-bit form. 86 ;; 8 (or anything else for now): %ld / %st. 87 ;; Scratch convention: helpers may clobber t1; callers never pass 88 ;; reg=t1. 89 90 (define (%cg-emit-ldN-bytes cg reg base-bv off-expr-fn n-bytes) 91 ;; Emit n-bytes %lb gathers into reg with shift+OR. byte 0 is low. 92 ;; off-expr-fn is a procedure: (off-expr-fn k) returns the bv 93 ;; expression for offset k. 94 (%cg-emit-many cg (list "%lb(" (%cg-reg->bv reg) ", " base-bv ", " 95 (off-expr-fn 0) ")\n")) 96 (let loop ((k 1)) 97 (cond 98 ((= k n-bytes) 0) 99 (else 100 (%cg-emit-many cg (list 101 "%lb(t1, " base-bv ", " (off-expr-fn k) ")\n" 102 "%shli(t1, t1, " (%n (* 8 k)) ")\n" 103 "%or(" (%cg-reg->bv reg) ", " (%cg-reg->bv reg) ", t1)\n")) 104 (loop (+ k 1)))))) 105 106 (define (%cg-emit-stN-bytes cg reg base-bv off-expr-fn n-bytes) 107 ;; Emit n-bytes %sb scatters from reg via shri-shifted t1. 108 (%cg-emit-many cg (list "%sb(" (%cg-reg->bv reg) ", " base-bv ", " 109 (off-expr-fn 0) ")\n")) 110 (let loop ((k 1)) 111 (cond 112 ((= k n-bytes) 0) 113 (else 114 (%cg-emit-many cg (list 115 "%shri(t1, " (%cg-reg->bv reg) ", " (%n (* 8 k)) ")\n" 116 "%sb(t1, " base-bv ", " (off-expr-fn k) ")\n")) 117 (loop (+ k 1)))))) 118 119 (define (%cg-emit-sext cg reg shift-amount) 120 (%cg-emit-many cg (list 121 "%shli(" (%cg-reg->bv reg) ", " (%cg-reg->bv reg) ", " 122 (%n shift-amount) ")\n" 123 "%sari(" (%cg-reg->bv reg) ", " (%cg-reg->bv reg) ", " 124 (%n shift-amount) ")\n"))) 125 126 (define (%cg-emit-ld-slot-typed cg reg ctype logical-off) 127 (let* ((sz (ctype-size ctype)) (kind (ctype-kind ctype)) 128 (off-fn (lambda (k) (%cg-slot-expr cg (+ logical-off k))))) 129 (cond 130 ((= sz 1) 131 (%cg-emit-many cg (list "%lb(" (%cg-reg->bv reg) ", sp, " 132 (off-fn 0) ")\n")) 133 (cond ((eq? kind 'i8) (%cg-emit-sext cg reg 56)))) 134 ((= sz 2) 135 (%cg-emit-ldN-bytes cg reg "sp" off-fn 2) 136 (cond ((eq? kind 'i16) (%cg-emit-sext cg reg 48)))) 137 ((= sz 4) 138 (%cg-emit-ldN-bytes cg reg "sp" off-fn 4) 139 (cond ((eq? kind 'i32) (%cg-emit-sext cg reg 32)))) 140 (else (%cg-emit-ld-slot cg reg logical-off))))) 141 142 (define (%cg-emit-st-slot-typed cg reg ctype logical-off) 143 (let* ((sz (ctype-size ctype)) 144 (off-fn (lambda (k) (%cg-slot-expr cg (+ logical-off k))))) 145 (cond 146 ((= sz 1) 147 (%cg-emit-many cg (list "%sb(" (%cg-reg->bv reg) ", sp, " 148 (off-fn 0) ")\n"))) 149 ((= sz 2) (%cg-emit-stN-bytes cg reg "sp" off-fn 2)) 150 ((= sz 4) (%cg-emit-stN-bytes cg reg "sp" off-fn 4)) 151 (else (%cg-emit-st-slot cg reg logical-off))))) 152 153 (define (%cg-emit-ld-typed cg reg ctype base off) 154 (let* ((sz (ctype-size ctype)) (kind (ctype-kind ctype)) 155 (base-bv (%cg-reg->bv base)) 156 (off-fn (lambda (k) (%n (+ off k))))) 157 (cond 158 ((= sz 1) 159 (%cg-emit-many cg (list "%lb(" (%cg-reg->bv reg) ", " 160 base-bv ", " (off-fn 0) ")\n")) 161 (cond ((eq? kind 'i8) (%cg-emit-sext cg reg 56)))) 162 ((= sz 2) 163 (%cg-emit-ldN-bytes cg reg base-bv off-fn 2) 164 (cond ((eq? kind 'i16) (%cg-emit-sext cg reg 48)))) 165 ((= sz 4) 166 (%cg-emit-ldN-bytes cg reg base-bv off-fn 4) 167 (cond ((eq? kind 'i32) (%cg-emit-sext cg reg 32)))) 168 (else (%cg-emit-ld cg reg base off))))) 169 170 (define (%cg-emit-st-typed cg reg ctype base off) 171 (let* ((sz (ctype-size ctype)) 172 (base-bv (%cg-reg->bv base)) 173 (off-fn (lambda (k) (%n (+ off k))))) 174 (cond 175 ((= sz 1) 176 (%cg-emit-many cg (list "%sb(" (%cg-reg->bv reg) ", " 177 base-bv ", " (off-fn 0) ")\n"))) 178 ((= sz 2) (%cg-emit-stN-bytes cg reg base-bv off-fn 2)) 179 ((= sz 4) (%cg-emit-stN-bytes cg reg base-bv off-fn 4)) 180 (else (%cg-emit-st cg reg base off))))) 181 182 (define (%cg-load-opnd-into cg op reg) 183 (let ((kind (opnd-kind op)) (lv? (opnd-lval? op)) 184 (ext (opnd-ext op)) (ty (opnd-type op))) 185 (cond 186 ((eq? kind 'imm) (%cg-emit-li cg reg ext)) 187 ;; frame lval: load value at type width. frame rval is a spilled 188 ;; word (alloc-slot 8 8 in %cg-spill-reg) — always 8-byte load. 189 ((eq? kind 'frame) 190 (cond (lv? (%cg-emit-ld-slot-typed cg reg ty ext)) 191 (else (%cg-emit-ld-slot cg reg ext)))) 192 ((eq? kind 'global) 193 (cond 194 ((not lv?) (%cg-emit-la cg reg ext)) 195 (else 196 ;; Width > 1 byte-gathers must not alias dest with base — 197 ;; the first %lb would otherwise clobber the address before 198 ;; subsequent byte loads. Stage the address in t2. 199 (%cg-emit-la cg 't2 ext) 200 (%cg-emit-ld-typed cg reg ty 't2 0)))) 201 (else (die #f "cg internal: unknown opnd-kind" kind))))) 202 203 (define (%cg-spill-reg cg reg ty) 204 (let* ((off (cg-alloc-slot cg 8 8)) 205 (op (%opnd 'frame ty off #f))) 206 (%cg-emit-st-slot cg reg off) 207 (cg-vstack-set! cg (cons op (cg-vstack cg))) 208 op)) 209 210 (define (%ctype-ptr? t) 211 (let ((k (ctype-kind t))) 212 (if (eq? k 'ptr) #t (eq? k 'arr)))) 213 214 (define (%ctype-pointee t) 215 (cond ((eq? (ctype-kind t) 'ptr) (ctype-ext t)) 216 ((eq? (ctype-kind t) 'arr) (car (ctype-ext t))) 217 (else #f))) 218 219 (define (%ctype-unsigned? t) 220 (let ((k (ctype-kind t))) 221 (cond ((eq? k 'u8) #t) ((eq? k 'u16) #t) ((eq? k 'u32) #t) 222 ((eq? k 'u64) #t) ((eq? k 'bool) #t) 223 ((eq? k 'ptr) #t) ((eq? k 'arr) #t) ((eq? k 'fn) #t) 224 (else #f)))) 225 226 (define (%ctype-size t) (ctype-size t)) 227 228 (define (%reg-by-idx i) 229 (cond ((= i 0) 'a0) ((= i 1) 'a1) ((= i 2) 'a2) ((= i 3) 'a3) 230 (else (die #f "cg: param idx > 3 needs ldarg path" i)))) 231 232 ;; -------------------------------------------------------------------- 233 ;; Lifecycle 234 ;; -------------------------------------------------------------------- 235 236 (define (cg-init) 237 (%cg (make-buf) (make-buf) (make-buf) '() 0 0 '() '() #f #f 0)) 238 239 (define (cg-finish cg) 240 ;; Entry stub. P1's program-entry contract (docs/P1.md §Program Entry) 241 ;; delivers argc in a0 and argv in a1 at p1_main. %call doesn't 242 ;; clobber a0/a1, so falling straight through to cc__main forwards 243 ;; them unchanged. The 16-byte frame is just enough for %enter's 244 ;; saved-fp/lr to fit; cc__main builds its own frame on top. 245 ;; (CC-CONTRACTS §J.1, §5.4.) 246 (let ((stub (bv-cat (list 247 "# entry stub: forwards argc=a0, argv=a1 to cc__main\n" 248 "%fn(p1_main, 16, {\n" 249 "%call(&cc__main)\n" 250 "})\n")))) 251 (buf-push! (cg-text cg) stub)) 252 ;; Every P1pp translation unit must end with :ELF_end so the ELF 253 ;; header can compute file-size and ph_memsz boundaries. 254 (bv-cat (list (buf-flush (cg-text cg)) 255 (buf-flush (cg-data cg)) 256 (buf-flush (cg-bss cg)) 257 ":ELF_end\n"))) 258 259 (define (cg-fn-begin cg name params return-type) 260 (cg-fn-begin/v cg name params return-type #f)) 261 262 ;; Variadic-aware variant. variadic? = #t reserves 16 contiguous 8-byte 263 ;; slots covering incoming arg indices 0..15, populating each from the 264 ;; appropriate source: a-register for idx 0..3, LDARG slot (idx-4) for 265 ;; idx 4..15. va_start computes the address of the slot at index = 266 ;; named-arg count, so va_arg walks linearly through the rest. 267 ;; Indices 4..15 may be garbage when the caller passed fewer args; user 268 ;; code stops walking based on a count or sentinel before those slots 269 ;; are read. Limit of 15 variadic args (after named) is enough for 270 ;; tcc.c's logging shapes; bump VARARG_WINDOW if you need more. 271 (define (cg-fn-begin/v cg name params return-type variadic?) 272 (cg-fn-buf-set! cg (make-buf)) 273 (cg-prologue-buf-set! cg (make-buf)) 274 (cg-vstack-set! cg '()) 275 (cg-frame-hi-set! cg 0) 276 (cg-label-ctr-set! cg 0) 277 (cg-max-outgoing-set! cg 0) 278 (%cg-fn-set! cg '%fn-name name) 279 (%cg-fn-set! cg '%fn-ret-type return-type) 280 (%cg-fn-set! cg '%indirect-slots '()) 281 (%cg-fn-set! cg '%fn-variadic? variadic?) 282 (let ((ret-slot (cg-alloc-slot cg 8 8))) 283 (%cg-fn-set! cg '%fn-ret-slot ret-slot) 284 (cond 285 ((not (eq? (ctype-kind return-type) 'void)) 286 (buf-push! (cg-prologue-buf cg) 287 (bv-cat (list "%li(t0, 0)\n" 288 "%st(t0, sp, " 289 (%cg-slot-expr cg ret-slot) ")\n")))))) 290 ;; params per CC-CONTRACTS §3.1: list of (name-bv . ctype). We 291 ;; return an alist (name-bv . sym) the parser binds into scope. 292 (let walk ((ps params) (idx 0) (out '()) (first-slot #f)) 293 (cond 294 ((null? ps) 295 (cond 296 (variadic? 297 ;; Pad the incoming-arg window out to 16 slots. For idx 0..3 298 ;; the slot is filled from a-register; for idx 4..15 from 299 ;; LDARG slot (idx-4). va_start points at the slot whose 300 ;; index equals the named-arg count, and va_arg walks 301 ;; linearly from there through the rest of the window. 302 (let pad ((i idx) (vfirst #f) (fs first-slot)) 303 (cond 304 ((>= i 16) 305 ;; If named-arg count was 0, vfirst is the very first 306 ;; slot of the save area (= fs). 307 (%cg-fn-set! cg '%fn-vararg-first-slot 308 (or vfirst fs)) 309 (reverse out)) 310 (else 311 (let ((off (cg-alloc-slot cg 8 8))) 312 (cond 313 ((< i 4) 314 (let ((ar (%reg-by-idx i))) 315 (buf-push! (cg-prologue-buf cg) 316 (bv-cat (list "%st(" (%cg-reg->bv ar) 317 ", sp, " 318 (%cg-slot-expr cg off) ")\n"))))) 319 (else 320 (buf-push! (cg-prologue-buf cg) 321 (bv-cat (list "%ldarg(t0, " (%n (- i 4)) ")\n" 322 "%st(t0, sp, " 323 (%cg-slot-expr cg off) ")\n"))))) 324 (pad (+ i 1) 325 (or vfirst off) 326 (or fs off))))))) 327 (else (reverse out)))) 328 (else 329 (let* ((p (car ps)) 330 (nm (car p)) 331 (ty (cdr p)) 332 (off (cg-alloc-slot cg 8 8)) 333 (psym (%sym nm 'param #f ty off))) 334 (cond 335 ((< idx 4) 336 (let ((ar (%reg-by-idx idx))) 337 (buf-push! (cg-prologue-buf cg) 338 (bv-cat (list "%st(" (%cg-reg->bv ar) 339 ", sp, " (%cg-slot-expr cg off) ")\n"))))) 340 (else 341 (buf-push! (cg-prologue-buf cg) 342 (bv-cat (list "%ldarg(t0, " (%n (- idx 4)) ")\n" 343 "%st(t0, sp, " (%cg-slot-expr cg off) ")\n"))))) 344 (walk (cdr ps) (+ idx 1) (cons (cons nm psym) out) 345 (or first-slot off))))))) 346 347 (define (cg-fn-end cg) 348 (let* ((name (%cg-fn-get cg '%fn-name)) 349 (ret-slot (%cg-fn-get cg '%fn-ret-slot)) 350 (ret-type (%cg-fn-get cg '%fn-ret-type)) 351 (locals-hi (cg-frame-hi cg)) 352 (staging-bytes (* 8 (cg-max-outgoing cg))) 353 (raw-size (+ staging-bytes locals-hi)) 354 (frame-size (align-up raw-size 16)) 355 (ret-block 356 (cond 357 ((eq? (ctype-kind ret-type) 'void) 358 (bv-cat (list "::ret\n%li(a0, 0)\n"))) 359 (else 360 (bv-cat (list "::ret\n%ld(a0, sp, " 361 (%cg-slot-expr cg ret-slot) ")\n"))))) 362 (so-macro 363 (bv-cat (list "%macro " name "__SO()\n" 364 (%n staging-bytes) "\n%endm\n"))) 365 (prologue (buf-flush (cg-prologue-buf cg))) 366 (body (buf-flush (cg-fn-buf cg))) 367 (mangled (%cg-mangle-global name)) 368 (fn-block (bv-cat (list 369 so-macro 370 "%fn(" mangled ", " (%n frame-size) ", {\n" 371 prologue body ret-block 372 "})\n")))) 373 (buf-push! (cg-text cg) fn-block) 374 (cg-fn-buf-set! cg #f) 375 (cg-prologue-buf-set! cg #f) 376 (cg-vstack-set! cg '()) 377 (cg-frame-hi-set! cg 0) 378 (cg-max-outgoing-set! cg 0) 379 0)) 380 381 ;; -------------------------------------------------------------------- 382 ;; Vstack 383 ;; -------------------------------------------------------------------- 384 (define (cg-push cg op) 385 (cg-vstack-set! cg (cons op (cg-vstack cg))) 386 op) 387 388 (define (cg-pop cg) 389 (let ((s (cg-vstack cg))) 390 (cond ((null? s) (die #f "cg-pop: empty vstack")) 391 (else (cg-vstack-set! cg (cdr s)) (car s))))) 392 393 (define (cg-top cg) 394 (let ((s (cg-vstack cg))) 395 (cond ((null? s) (die #f "cg-top: empty vstack")) (else (car s))))) 396 397 (define (cg-depth cg) (length (cg-vstack cg))) 398 399 ;; Duplicate the top vstack entry. For lvals this is safe — the slot 400 ;; (or label, or indirect-marked frame) backing the lval keeps existing 401 ;; until the function ends. For rvals it duplicates the descriptor of 402 ;; the spilled value; both copies refer to the same already-emitted 403 ;; storage. CC-CONTRACTS §4.1: used for `lhs += rhs` and `++lhs` to 404 ;; preserve the lhs across a `cg-load` so the subsequent `cg-assign` 405 ;; still has its address. 406 (define (cg-dup cg) 407 (let ((p (cg-top cg))) (cg-push cg p) p)) 408 409 ;; -------------------------------------------------------------------- 410 ;; Materialize 411 ;; -------------------------------------------------------------------- 412 (define (cg-push-imm cg ctype value) 413 (cg-push cg (%opnd 'imm ctype value #f))) 414 415 (define (cg-push-string cg bv-content) 416 (let* ((label (cg-intern-string cg bv-content)) 417 (cp-ty (%ctype 'ptr 8 8 %t-i8))) 418 (cg-push cg (%opnd 'global cp-ty label #f)))) 419 420 (define (cg-push-sym cg sym) 421 (let ((k (sym-kind sym)) (ty (sym-type sym))) 422 (cond 423 ((eq? k 'fn) 424 (cg-push cg (%opnd 'global ty (%cg-mangle-global (sym-name sym)) #f))) 425 ((eq? k 'enum-const) 426 (cg-push cg (%opnd 'imm ty (sym-slot sym) #f))) 427 ((eq? k 'var) 428 (let ((stg (sym-storage sym))) 429 (cond 430 ((eq? stg 'extern) 431 (cg-push cg (%opnd 'global ty (%cg-mangle-global (sym-name sym)) #t))) 432 ((eq? stg 'static) 433 (cg-push cg (%opnd 'global ty (%cg-mangle-global (sym-name sym)) #t))) 434 (else 435 (cg-push cg (%opnd 'frame ty (sym-slot sym) #t)))))) 436 ((eq? k 'param) 437 (cg-push cg (%opnd 'frame ty (sym-slot sym) #t))) 438 (else (die #f "cg-push-sym: unsupported sym-kind" k))))) 439 440 ;; A cg-push-deref result is a frame-lval whose slot HOLDS THE ADDRESS 441 ;; (not the value). To distinguish from ordinary frame-lvals (whose 442 ;; slot holds the value directly), we tag indirect slots in 443 ;; %indirect-slots so cg-load and cg-assign can do the extra 444 ;; indirection. 445 (define (%cg-mark-indirect! cg off) 446 (let ((cur (or (%cg-fn-get cg '%indirect-slots) '()))) 447 (%cg-fn-set! cg '%indirect-slots (cons off cur)))) 448 449 (define (%cg-indirect? cg off) 450 (let ((cur (or (%cg-fn-get cg '%indirect-slots) '()))) 451 (let loop ((xs cur)) 452 (cond ((null? xs) #f) ((= (car xs) off) #t) (else (loop (cdr xs))))))) 453 454 (define (cg-push-deref cg) 455 (let* ((p (cg-pop cg)) 456 (pt (opnd-type p)) 457 (pe (cond ((eq? (ctype-kind pt) 'ptr) (ctype-ext pt)) 458 ((eq? (ctype-kind pt) 'arr) (car (ctype-ext pt))) 459 (else #f)))) 460 (cond 461 ((not pe) (die #f "cg-push-deref: not a pointer" pt)) 462 (else 463 (%cg-load-opnd-into cg p 't0) 464 (let ((off (cg-alloc-slot cg 8 8))) 465 (%cg-emit-st-slot cg 't0 off) 466 (%cg-mark-indirect! cg off) 467 (cg-push cg (%opnd 'frame pe off #t))))))) 468 469 ;; -------------------------------------------------------------------- 470 ;; Aggregate field access (§D.1–D.4) 471 ;; -------------------------------------------------------------------- 472 ;; cg-push-field cg fname: 473 ;; pop a struct/union lval; look up `fname` in the struct's fields 474 ;; list (data.scm: ext = (tag complete? fields), where each field 475 ;; is (name-bv ctype offset)); push a new lval at the field's 476 ;; offset with the field's ctype. 477 ;; 478 ;; Three input cases: 479 ;; - direct frame lval at slot `off` -> frame lval at off+fo 480 ;; - indirect frame lval (slot holds addr) -> new indirect slot for 481 ;; addr+fo 482 ;; - global lval at label L -> indirect slot for 483 ;; la(L)+fo 484 ;; In all cases the resulting lval has the field's ctype. 485 486 (define (%cg-find-field fields fname) 487 (let loop ((xs fields)) 488 (cond 489 ((null? xs) #f) 490 ((bv= (car (car xs)) fname) (car xs)) 491 (else (loop (cdr xs)))))) 492 493 (define (cg-push-field cg fname) 494 (let* ((s (cg-pop cg)) 495 (sty (opnd-type s)) 496 (k (ctype-kind sty))) 497 (cond 498 ((not (or (eq? k 'struct) (eq? k 'union))) 499 (die #f "cg-push-field: not a struct/union" k)) 500 ((not (opnd-lval? s)) 501 (die #f "cg-push-field: not an lvalue" k)) 502 (else 503 (let* ((fields (car (cddr (ctype-ext sty)))) 504 (f (%cg-find-field fields fname))) 505 (cond 506 ((not f) (die #f "cg-push-field: no such field" fname)) 507 (else 508 (let* ((fty (cadr f)) (fo (car (cddr f)))) 509 (cond 510 ;; direct frame lval: just shift the slot offset. 511 ((and (eq? (opnd-kind s) 'frame) 512 (not (%cg-indirect? cg (opnd-ext s)))) 513 (cg-push cg (%opnd 'frame fty (+ (opnd-ext s) fo) #t))) 514 ;; indirect frame lval: addr lives in the slot. Compute 515 ;; addr+fo into a new indirect slot. 516 ((eq? (opnd-kind s) 'frame) 517 (%cg-emit-ld-slot cg 't0 (opnd-ext s)) 518 (cond 519 ((> fo 0) 520 (%cg-emit-many cg (list "%addi(t0, t0, " (%n fo) ")\n")))) 521 (let ((no (cg-alloc-slot cg 8 8))) 522 (%cg-emit-st-slot cg 't0 no) 523 (%cg-mark-indirect! cg no) 524 (cg-push cg (%opnd 'frame fty no #t)))) 525 ;; global lval: load addr, add offset, indirect slot. 526 ((eq? (opnd-kind s) 'global) 527 (%cg-emit-la cg 't0 (opnd-ext s)) 528 (cond 529 ((> fo 0) 530 (%cg-emit-many cg (list "%addi(t0, t0, " (%n fo) ")\n")))) 531 (let ((no (cg-alloc-slot cg 8 8))) 532 (%cg-emit-st-slot cg 't0 no) 533 (%cg-mark-indirect! cg no) 534 (cg-push cg (%opnd 'frame fty no #t)))) 535 (else 536 (die #f "cg-push-field: unsupported lval kind" 537 (opnd-kind s)))))))))))) 538 539 ;; cg-decay-array: 540 ;; if top of vstack is an arr-typed lval, replace it with a ptr-rval 541 ;; to the first element. C arrays decay to T* in most contexts; 542 ;; parse calls this before rval-style operations. No-op otherwise. 543 (define (cg-decay-array cg) 544 (let ((tp (cg-top cg))) 545 (cond 546 ((and (opnd-lval? tp) (eq? (ctype-kind (opnd-type tp)) 'arr)) 547 (let* ((p (cg-pop cg)) 548 (et (car (ctype-ext (opnd-type p)))) 549 (pty (%ctype 'ptr 8 8 et))) 550 (cond 551 ;; direct frame lval: address is sp+off. 552 ((and (eq? (opnd-kind p) 'frame) 553 (not (%cg-indirect? cg (opnd-ext p)))) 554 (%cg-emit-many cg (list "%mov(t0, sp)\n" 555 "%addi(t0, t0, " 556 (%cg-slot-expr cg (opnd-ext p)) ")\n")) 557 (%cg-spill-reg cg 't0 pty)) 558 ;; indirect frame lval (rare for arrays, but support it): 559 ;; the slot holds the address already. 560 ((eq? (opnd-kind p) 'frame) 561 (%cg-emit-ld-slot cg 't0 (opnd-ext p)) 562 (%cg-spill-reg cg 't0 pty)) 563 ;; global array: la(label) is the address. 564 ((eq? (opnd-kind p) 'global) 565 (%cg-emit-la cg 't0 (opnd-ext p)) 566 (%cg-spill-reg cg 't0 pty)) 567 (else (die #f "cg-decay-array: unsupported lval kind" 568 (opnd-kind p)))))) 569 (else tp)))) 570 571 ;; -------------------------------------------------------------------- 572 ;; Address & deref 573 ;; -------------------------------------------------------------------- 574 (define (cg-take-addr cg) 575 (let* ((p (cg-pop cg)) 576 (ty (opnd-type p)) 577 ;; &arr yields T(*)[N] per strict C. Pointer arithmetic on 578 ;; the result scales by sizeof(T[N]) (the whole array), so 579 ;; &arr + 1 is one-past-end. Array-to-pointer decay happens 580 ;; on use via cg-decay-array, not at the & operator. 581 (pty (%ctype 'ptr 8 8 ty))) 582 (cond 583 ((not (opnd-lval? p)) 584 (die #f "cg-take-addr: not an lvalue")) 585 ((eq? (opnd-kind p) 'frame) 586 (cond 587 ((%cg-indirect? cg (opnd-ext p)) 588 ;; The address itself lives at sp+slot — &*p degenerates to p. 589 (%cg-emit-ld-slot cg 't0 (opnd-ext p)) 590 (%cg-spill-reg cg 't0 pty)) 591 (else 592 ;; %mov(rd, sp) gives the portable-sp pointer (the backend 593 ;; handles any hidden frame-header offset). Then add slot. 594 (%cg-emit-many cg (list "%mov(t0, sp)\n" 595 "%addi(t0, t0, " 596 (%cg-slot-expr cg (opnd-ext p)) ")\n")) 597 (%cg-spill-reg cg 't0 pty)))) 598 ((eq? (opnd-kind p) 'global) 599 (%cg-emit-la cg 't0 (opnd-ext p)) 600 (%cg-spill-reg cg 't0 pty)) 601 (else (die #f "cg-take-addr: non-addressable" (opnd-kind p)))))) 602 603 (define (cg-load cg) 604 (let* ((p (cg-pop cg)) (ty (opnd-type p))) 605 (cond 606 ((not (opnd-lval? p)) (die #f "cg-load: not an lvalue")) 607 ;; Array lvalues decay to a ptr-rval addressing the first 608 ;; element (C array-to-pointer decay). We push the lval back 609 ;; and route through cg-decay-array for a single source of truth. 610 ((eq? (ctype-kind ty) 'arr) 611 (cg-push cg p) (cg-decay-array cg)) 612 ((and (eq? (opnd-kind p) 'frame) 613 (%cg-indirect? cg (opnd-ext p))) 614 ;; Indirect frame-lval: slot holds the address. Stage the 615 ;; address in t2 so multi-byte gathers don't alias dest with 616 ;; base. 617 (%cg-emit-ld-slot cg 't2 (opnd-ext p)) 618 (%cg-emit-ld-typed cg 't0 ty 't2 0) 619 (%cg-spill-reg cg 't0 ty)) 620 (else (%cg-load-opnd-into cg p 't0) (%cg-spill-reg cg 't0 ty))))) 621 622 ;; -------------------------------------------------------------------- 623 ;; Type conversions 624 ;; -------------------------------------------------------------------- 625 (define (cg-cast cg to-type) 626 (let* ((p (cg-pop cg)) 627 (from-ty (opnd-type p)) 628 (from-sz (%ctype-size from-ty)) 629 (to-sz (%ctype-size to-type)) 630 (to-kind (ctype-kind to-type))) 631 (cond 632 ((eq? to-kind 'bool) 633 (%cg-load-opnd-into cg p 't0) 634 (%cg-emit-many cg (list 635 "%ifelse_eqz(t0, { %li(t0, 0) }, { %li(t0, 1) })\n")) 636 (%cg-spill-reg cg 't0 to-type)) 637 ((or (eq? to-kind 'ptr) 638 (and (or (eq? to-kind 'i64) (eq? to-kind 'u64)) 639 (or (eq? (ctype-kind from-ty) 'ptr) 640 (eq? (ctype-kind from-ty) 'arr)))) 641 (cg-push cg (%opnd (opnd-kind p) to-type (opnd-ext p) (opnd-lval? p)))) 642 ((>= to-sz from-sz) 643 (cg-push cg (%opnd (opnd-kind p) to-type (opnd-ext p) (opnd-lval? p)))) 644 (else 645 ;; Narrowing cast. Signed targets (i8/i16/i32) shli/sari to 646 ;; truncate-and-sign-extend in one step, so the slot holds the 647 ;; canonical 64-bit form and a subsequent widening cast (which 648 ;; is relabel-only) restores the value. Unsigned targets mask 649 ;; off high bits to zero-extend. 650 (%cg-load-opnd-into cg p 't0) 651 (cond 652 ((eq? to-kind 'i8) (%cg-emit-sext cg 't0 56)) 653 ((eq? to-kind 'i16) (%cg-emit-sext cg 't0 48)) 654 ((eq? to-kind 'i32) (%cg-emit-sext cg 't0 32)) 655 ((= to-sz 1) (%cg-emit-many cg (list "%andi(t0, t0, 255)\n"))) 656 ((= to-sz 2) 657 (%cg-emit-many cg (list "%li(t1, 65535)\n%and(t0, t0, t1)\n"))) 658 ((= to-sz 4) 659 (%cg-emit-many cg (list "%li(t1, 4294967295)\n%and(t0, t0, t1)\n"))) 660 (else 0)) 661 (%cg-spill-reg cg 't0 to-type))))) 662 663 (define (cg-promote cg) 664 (let* ((p (cg-pop cg)) 665 (ty (opnd-type p)) 666 (sz (%ctype-size ty))) 667 (cond 668 ((< sz 4) 669 (cond 670 ((%ctype-unsigned? ty) 671 (cg-push cg (%opnd (opnd-kind p) %t-u32 (opnd-ext p) (opnd-lval? p)))) 672 (else 673 (cg-push cg (%opnd (opnd-kind p) %t-i32 (opnd-ext p) (opnd-lval? p)))))) 674 (else (cg-push cg p))))) 675 676 (define (cg-arith-conv cg) 677 ;; Usual arithmetic conversions. CC-CONTRACTS §4.2: applies to 678 ;; arithmetic operands. When either operand is a pointer (or array, 679 ;; which behaves as a pointer in arithmetic), the pair is a 680 ;; pointer-arith case — leave the types alone so cg-binop can detect 681 ;; the ptr operand and apply the right scaling. 682 (let* ((b (cg-pop cg)) 683 (a (cg-pop cg)) 684 (ta (opnd-type a)) 685 (tb (opnd-type b)) 686 (sa (%ctype-size ta)) 687 (sb (%ctype-size tb))) 688 (cond 689 ;; Pointer/array arithmetic: leave types alone so cg-binop's 690 ;; ptr-aware add/sub branch fires with the correct pointee type 691 ;; (and doesn't see two pointers, which would skip scaling). 692 ((or (%ctype-ptr? ta) (%ctype-ptr? tb)) 693 (cg-push cg a) 694 (cg-push cg b)) 695 (else 696 (let ((common (cond 697 ((> sa sb) ta) 698 ((> sb sa) tb) 699 ((%ctype-unsigned? ta) ta) 700 ((%ctype-unsigned? tb) tb) 701 (else ta)))) 702 (cg-push cg (%opnd (opnd-kind a) common (opnd-ext a) (opnd-lval? a))) 703 (cg-push cg (%opnd (opnd-kind b) common (opnd-ext b) (opnd-lval? b)))))))) 704 705 ;; -------------------------------------------------------------------- 706 ;; Operators 707 ;; -------------------------------------------------------------------- 708 (define (%cg-emit-rrr cg op rd ra rb) 709 (%cg-emit-many cg (list "%" op "(" (%cg-reg->bv rd) ", " 710 (%cg-reg->bv ra) ", " (%cg-reg->bv rb) ")\n"))) 711 712 (define (%cg-emit-cmp cg cc ra rb rd) 713 (%cg-emit-many cg (list "%ifelse_" cc "(" 714 (%cg-reg->bv ra) ", " (%cg-reg->bv rb) 715 ", { %li(" (%cg-reg->bv rd) ", 1) }, " 716 "{ %li(" (%cg-reg->bv rd) ", 0) })\n"))) 717 718 (define (cg-binop cg op) 719 (let* ((b (cg-pop cg)) 720 (a (cg-pop cg)) 721 (ta (opnd-type a)) 722 (tb (opnd-type b)) 723 (unsigned? (or (%ctype-unsigned? ta) (%ctype-unsigned? tb))) 724 (a-ptr? (%ctype-ptr? ta)) 725 (b-ptr? (%ctype-ptr? tb)) 726 (result-ty 727 (cond 728 ((or (eq? op 'eq) (eq? op 'ne) 729 (eq? op 'lt) (eq? op 'le) (eq? op 'gt) (eq? op 'ge)) 730 %t-i32) 731 ((and a-ptr? b-ptr? (eq? op 'sub)) %t-i64) 732 (a-ptr? ta) 733 (b-ptr? tb) 734 (else ta)))) 735 (cond 736 ((and a-ptr? (or (eq? op 'add) (eq? op 'sub)) (not b-ptr?)) 737 (%cg-load-opnd-into cg a 'a0) 738 (%cg-load-opnd-into cg b 'a1) 739 (let ((sz (%ctype-size (%ctype-pointee ta)))) 740 (cond ((> sz 1) (%cg-emit-many cg (list "%li(t0, " (%n sz) ")\n")) 741 (%cg-emit-rrr cg "mul" 'a1 'a1 't0)) 742 (else 0))) 743 (%cg-emit-rrr cg (if (eq? op 'add) "add" "sub") 't0 'a0 'a1) 744 (%cg-spill-reg cg 't0 result-ty)) 745 ((and b-ptr? (eq? op 'add) (not a-ptr?)) 746 (%cg-load-opnd-into cg a 'a0) 747 (%cg-load-opnd-into cg b 'a1) 748 (let ((sz (%ctype-size (%ctype-pointee tb)))) 749 (cond ((> sz 1) (%cg-emit-many cg (list "%li(t0, " (%n sz) ")\n")) 750 (%cg-emit-rrr cg "mul" 'a0 'a0 't0)) 751 (else 0))) 752 (%cg-emit-rrr cg "add" 't0 'a0 'a1) 753 (%cg-spill-reg cg 't0 result-ty)) 754 ((and a-ptr? b-ptr? (eq? op 'sub)) 755 (%cg-load-opnd-into cg a 'a0) 756 (%cg-load-opnd-into cg b 'a1) 757 (%cg-emit-rrr cg "sub" 't0 'a0 'a1) 758 (let ((sz (%ctype-size (%ctype-pointee ta)))) 759 (cond ((> sz 1) (%cg-emit-many cg (list "%li(t1, " (%n sz) ")\n")) 760 (%cg-emit-rrr cg "div" 't0 't0 't1)) 761 (else 0))) 762 (%cg-spill-reg cg 't0 result-ty)) 763 (else 764 (%cg-load-opnd-into cg a 'a0) 765 (%cg-load-opnd-into cg b 'a1) 766 (cond 767 ((eq? op 'add) (%cg-emit-rrr cg "add" 't0 'a0 'a1)) 768 ((eq? op 'sub) (%cg-emit-rrr cg "sub" 't0 'a0 'a1)) 769 ((eq? op 'mul) (%cg-emit-rrr cg "mul" 't0 'a0 'a1)) 770 ((eq? op 'and) (%cg-emit-rrr cg "and" 't0 'a0 'a1)) 771 ((eq? op 'or) (%cg-emit-rrr cg "or" 't0 'a0 'a1)) 772 ((eq? op 'xor) (%cg-emit-rrr cg "xor" 't0 'a0 'a1)) 773 ((eq? op 'shl) (%cg-emit-rrr cg "shl" 't0 'a0 'a1)) 774 ((eq? op 'shr) 775 (if unsigned? (%cg-emit-rrr cg "shr" 't0 'a0 'a1) 776 (%cg-emit-rrr cg "sar" 't0 'a0 'a1))) 777 ((eq? op 'div) (%cg-emit-rrr cg "div" 't0 'a0 'a1)) 778 ((eq? op 'rem) (%cg-emit-rrr cg "rem" 't0 'a0 'a1)) 779 ((eq? op 'eq) (%cg-emit-cmp cg "eq" 'a0 'a1 't0)) 780 ((eq? op 'ne) (%cg-emit-cmp cg "ne" 'a0 'a1 't0)) 781 ((eq? op 'lt) (%cg-emit-cmp cg (if unsigned? "ltu" "lt") 'a0 'a1 't0)) 782 ((eq? op 'gt) (%cg-emit-cmp cg (if unsigned? "ltu" "lt") 'a1 'a0 't0)) 783 ((eq? op 'le) 784 (%cg-emit-cmp cg (if unsigned? "ltu" "lt") 'a1 'a0 't0) 785 (%cg-emit-many cg (list "%li(t1, 1)\n%xor(t0, t0, t1)\n"))) 786 ((eq? op 'ge) 787 (%cg-emit-cmp cg (if unsigned? "ltu" "lt") 'a0 'a1 't0) 788 (%cg-emit-many cg (list "%li(t1, 1)\n%xor(t0, t0, t1)\n"))) 789 (else (die #f "cg-binop: unknown op" op))) 790 (%cg-spill-reg cg 't0 result-ty))))) 791 792 ;; Post-increment / post-decrement on the top-of-vstack lval. 793 ;; Pushes the OLD value (per C semantics) and emits the +1 / -1 store. 794 ;; Uses cg-dup + cg-load to capture the old rval (which is then in a 795 ;; never-reused spill slot), then runs the regular dup+load+add+assign 796 ;; pattern for the store. Pointer scaling falls out of cg-binop add. 797 (define (%cg-post-inc-dec cg op) 798 (cg-dup cg) 799 (cg-load cg) 800 (let ((old (cg-pop cg))) 801 (cg-dup cg) 802 (cg-load cg) 803 (cg-push-imm cg %t-i32 1) 804 (cg-binop cg op) 805 (cg-assign cg) 806 (cg-pop cg) 807 (cg-push cg old))) 808 809 (define (cg-postinc cg) (%cg-post-inc-dec cg 'add)) 810 (define (cg-postdec cg) (%cg-post-inc-dec cg 'sub)) 811 812 (define (cg-unop cg op) 813 (let* ((p (cg-pop cg)) (ty (opnd-type p))) 814 (%cg-load-opnd-into cg p 't0) 815 (cond 816 ((eq? op 'neg) 817 (%cg-emit-many cg (list "%li(t1, 0)\n%sub(t0, t1, t0)\n")) 818 (%cg-spill-reg cg 't0 ty)) 819 ((eq? op 'bnot) 820 (%cg-emit-many cg (list "%li(t1, -1)\n%xor(t0, t0, t1)\n")) 821 (%cg-spill-reg cg 't0 ty)) 822 ((eq? op 'lnot) 823 (%cg-emit-many cg (list "%ifelse_eqz(t0, { %li(t0, 1) }, { %li(t0, 0) })\n")) 824 (%cg-spill-reg cg 't0 %t-i32)) 825 (else (die #f "cg-unop: unknown op" op))))) 826 827 (define (cg-assign cg) 828 ;; Pops rhs, pops lhs, casts rhs to lhs's type (parser cannot peek 829 ;; deeper than vstack top to do this itself — CC-CONTRACTS §4.2), 830 ;; emits the store, pushes the assigned value as the result rval. 831 (let* ((rhs0 (cg-pop cg)) 832 (lhs (cg-pop cg)) 833 (ty (opnd-type lhs))) 834 (cond ((not (opnd-lval? lhs)) (die #f "cg-assign: lhs not lvalue"))) 835 ;; Cast rhs to lhs's type (no-op when the types already match). 836 (cg-push cg rhs0) 837 (cg-cast cg ty) 838 (let ((rhs (cg-pop cg))) 839 (%cg-load-opnd-into cg rhs 'a0) 840 (cond 841 ((eq? (opnd-kind lhs) 'frame) 842 (cond 843 ((%cg-indirect? cg (opnd-ext lhs)) 844 (%cg-emit-ld-slot cg 't0 (opnd-ext lhs)) 845 (%cg-emit-st-typed cg 'a0 ty 't0 0)) 846 (else 847 (%cg-emit-st-slot-typed cg 'a0 ty (opnd-ext lhs))))) 848 ((eq? (opnd-kind lhs) 'global) 849 (%cg-emit-la cg 't0 (opnd-ext lhs)) 850 (%cg-emit-st-typed cg 'a0 ty 't0 0)) 851 (else (die #f "cg-assign: unsupported lhs kind" (opnd-kind lhs)))) 852 (%cg-spill-reg cg 'a0 ty)))) 853 854 ;; -------------------------------------------------------------------- 855 ;; Calls 856 ;; -------------------------------------------------------------------- 857 (define (cg-call cg arity has-result?) 858 (let* ((args (let loop ((i 0) (acc '())) 859 (cond ((= i arity) acc) 860 (else (loop (+ i 1) (cons (cg-pop cg) acc)))))) 861 (fn-op (cg-pop cg))) 862 (let stage ((xs args) (idx 0)) 863 (cond 864 ((null? xs) 0) 865 ((< idx 4) 866 (%cg-load-opnd-into cg (car xs) (%reg-by-idx idx)) 867 (stage (cdr xs) (+ idx 1))) 868 (else 869 (%cg-load-opnd-into cg (car xs) 't0) 870 (%cg-emit-st cg 't0 'sp (* 8 (- idx 4))) 871 (stage (cdr xs) (+ idx 1))))) 872 (cond ((> arity 4) (%cg-bump-outgoing! cg (- arity 4))) (else 0)) 873 (cond 874 ((and (eq? (opnd-kind fn-op) 'global) (not (opnd-lval? fn-op))) 875 (%cg-emit-many cg (list "%call(&" (opnd-ext fn-op) ")\n"))) 876 (else 877 (%cg-load-opnd-into cg fn-op 't0) 878 (%cg-emit-many cg (list "%callr(t0)\n")))) 879 (cond 880 (has-result? 881 (let* ((fty (opnd-type fn-op)) 882 (rty (cond 883 ((eq? (ctype-kind fty) 'fn) (car (ctype-ext fty))) 884 ((eq? (ctype-kind fty) 'ptr) 885 (let ((p (ctype-ext fty))) 886 (if (eq? (ctype-kind p) 'fn) (car (ctype-ext p)) %t-i64))) 887 (else %t-i64)))) 888 (%cg-spill-reg cg 'a0 rty))) 889 (else #f)))) 890 891 ;; -------------------------------------------------------------------- 892 ;; Return 893 ;; -------------------------------------------------------------------- 894 (define (cg-return cg) 895 (let ((ret-slot (%cg-fn-get cg '%fn-ret-slot)) 896 (ret-type (%cg-fn-get cg '%fn-ret-type))) 897 (cond 898 ((eq? (ctype-kind ret-type) 'void) 899 (%cg-emit-many cg (list "%b(&::ret)\n"))) 900 (else 901 (let ((p (cg-pop cg))) 902 (%cg-load-opnd-into cg p 'a0) 903 (%cg-emit-st-slot cg 'a0 ret-slot) 904 (%cg-emit-many cg (list "%b(&::ret)\n"))))))) 905 906 ;; -------------------------------------------------------------------- 907 ;; Structured control flow 908 ;; -------------------------------------------------------------------- 909 (define (cg-if cg then-thunk) 910 (let ((p (cg-pop cg))) 911 (%cg-load-opnd-into cg p 't0) 912 (%cg-emit-many cg (list "%if_nez(t0, {\n")) 913 (then-thunk) 914 (%cg-emit-many cg (list "})\n")))) 915 916 (define (cg-ifelse cg then-thunk else-thunk) 917 (let ((p (cg-pop cg))) 918 (%cg-load-opnd-into cg p 't0) 919 (%cg-emit-many cg (list "%ifelse_nez(t0, {\n")) 920 (then-thunk) 921 (%cg-emit-many cg (list "}, {\n")) 922 (else-thunk) 923 (%cg-emit-many cg (list "})\n")))) 924 925 ;; Conditionals-as-values: `cg-ifelse` is correct for if-statements 926 ;; (thunks push nothing) but each thunk for ternary / `&&` / `||` ends 927 ;; with one rval on top of the vstack — and after both branches run, 928 ;; we'd be left with TWO opnds, which breaks the type contract for 929 ;; the surrounding expression. `cg-ifelse-merge` solves that: pop the 930 ;; cond, allocate one result slot, and after each thunk runs, pop its 931 ;; rval and store into the slot. Push the slot as one frame rval. 932 ;; Both branches must push exactly one opnd; the result type is the 933 ;; type of the first thunk's pushed opnd (parser must arrange for 934 ;; both branches to push compatible types — either by passing 935 ;; pre-coerced operands or by injecting a `cg-cast` inside the thunk). 936 (define (cg-ifelse-merge cg then-thunk else-thunk) 937 (let* ((cond-op (cg-pop cg)) 938 (slot (cg-alloc-slot cg 8 8))) 939 (%cg-load-opnd-into cg cond-op 't0) 940 (%cg-emit-many cg (list "%ifelse_nez(t0, {\n")) 941 (then-thunk) 942 (let* ((p (cg-pop cg)) 943 (rty (opnd-type p))) 944 (%cg-load-opnd-into cg p 'a0) 945 (%cg-emit-st-slot cg 'a0 slot) 946 (%cg-emit-many cg (list "}, {\n")) 947 (else-thunk) 948 (let ((q (cg-pop cg))) 949 (%cg-load-opnd-into cg q 'a0) 950 (%cg-emit-st-slot cg 'a0 slot)) 951 (%cg-emit-many cg (list "})\n")) 952 (cg-push cg (%opnd 'frame rty slot #f))))) 953 954 (define (cg-loop cg head-thunk body-thunk) 955 ;; body-thunk receives the loop tag as its argument; parser uses 956 ;; that tag for cg-break / cg-continue inside the body. CC-CONTRACTS 957 ;; §1.9 / §3.3. 958 (let ((tag (%cg-fresh-loop-tag cg))) 959 (%cg-emit-many cg (list "%loop_tag(" tag ", {\n")) 960 (head-thunk) 961 (cond 962 ((zero? (cg-depth cg)) 0) 963 (else 964 (let ((c (cg-pop cg))) 965 (%cg-load-opnd-into cg c 't0) 966 (%cg-emit-many cg (list "%if_eqz(t0, { %break(" tag ") })\n"))))) 967 (body-thunk tag) 968 (%cg-emit-many cg (list "})\n")) 969 tag)) 970 971 (define (cg-break cg tag) 972 (%cg-emit-many cg (list "%break(" tag ")\n"))) 973 974 (define (cg-continue cg tag) 975 (%cg-emit-many cg (list "%continue(" tag ")\n"))) 976 977 ;; -------------------------------------------------------------------- 978 ;; Variadic receive (§G.2). Layout: cg-fn-begin/v reserves a 4-slot 979 ;; saved-register area at known frame offsets; va_start sets ap to the 980 ;; address of the first slot past the named-arg count; va_arg reads 981 ;; *ap, advances ap by 8, and pushes the value as the requested type. 982 ;; 983 ;; ap is an lval (typically a `va_list` local). cg-va-start pops it, 984 ;; computes the address, stores into *ap (or the slot directly), and 985 ;; pushes nothing. cg-va-arg pops ap-lval, loads ap, dereferences for 986 ;; the value, advances ap, stores back, pushes the loaded value. 987 ;; 988 ;; Limitation: only first 4 incoming args (named + variadic) live in 989 ;; the save area; variadic args at index >= 4 need LDARG and are not 990 ;; yet supported. See punchlist §G.2 for the gap. 991 ;; -------------------------------------------------------------------- 992 (define (%cg-vararg-first-slot cg) 993 (let ((s (%cg-fn-get cg '%fn-vararg-first-slot))) 994 (cond ((not s) (die #f "cg-va-start: not a variadic function")) 995 (else s)))) 996 997 (define (cg-va-start cg) 998 ;; Pop ap-lval. Materialize "&sp + vararg-first-slot" into a0, 999 ;; store through ap-lval. Pushes nothing. 1000 (let* ((ap-lv (cg-pop cg)) 1001 (vsl (%cg-vararg-first-slot cg))) 1002 (cond ((not (opnd-lval? ap-lv)) 1003 (die #f "cg-va-start: ap not lvalue"))) 1004 ;; Compute address into a0. 1005 (%cg-emit-many cg (list "%mov(a0, sp)\n" 1006 "%addi(a0, a0, " 1007 (%cg-slot-expr cg vsl) ")\n")) 1008 ;; Store a0 at ap-lval. 1009 (cond 1010 ((eq? (opnd-kind ap-lv) 'frame) 1011 (cond 1012 ((%cg-indirect? cg (opnd-ext ap-lv)) 1013 (%cg-emit-ld-slot cg 't0 (opnd-ext ap-lv)) 1014 (%cg-emit-st cg 'a0 't0 0)) 1015 (else (%cg-emit-st-slot cg 'a0 (opnd-ext ap-lv))))) 1016 ((eq? (opnd-kind ap-lv) 'global) 1017 (%cg-emit-la cg 't0 (opnd-ext ap-lv)) 1018 (%cg-emit-st cg 'a0 't0 0)) 1019 (else (die #f "cg-va-start: bad ap kind" (opnd-kind ap-lv)))))) 1020 1021 (define (cg-va-arg cg ctype) 1022 ;; Pop ap-lval. Load ap into a0. Read 8 bytes at [a0] into a1. 1023 ;; Advance a0 by 8 and store back through ap-lval. Push a1 as rval 1024 ;; of type ctype (caller cg-cast's if needed). 1025 (let* ((ap-lv (cg-pop cg))) 1026 (cond ((not (opnd-lval? ap-lv)) 1027 (die #f "cg-va-arg: ap not lvalue"))) 1028 ;; Load ap into a0. 1029 (cond 1030 ((eq? (opnd-kind ap-lv) 'frame) 1031 (cond 1032 ((%cg-indirect? cg (opnd-ext ap-lv)) 1033 (%cg-emit-ld-slot cg 't0 (opnd-ext ap-lv)) 1034 (%cg-emit-ld cg 'a0 't0 0)) 1035 (else (%cg-emit-ld-slot cg 'a0 (opnd-ext ap-lv))))) 1036 ((eq? (opnd-kind ap-lv) 'global) 1037 (%cg-emit-la cg 't0 (opnd-ext ap-lv)) 1038 (%cg-emit-ld cg 'a0 't0 0)) 1039 (else (die #f "cg-va-arg: bad ap kind" (opnd-kind ap-lv)))) 1040 ;; Load value at [a0] into a1 (full 8 bytes; cg-cast on the rval 1041 ;; the caller pushes will narrow if needed). 1042 (%cg-emit-ld cg 'a1 'a0 0) 1043 ;; Advance ap by 8. 1044 (%cg-emit-many cg (list "%addi(a0, a0, 8)\n")) 1045 ;; Store advanced ap back. 1046 (cond 1047 ((eq? (opnd-kind ap-lv) 'frame) 1048 (cond 1049 ((%cg-indirect? cg (opnd-ext ap-lv)) 1050 (%cg-emit-ld-slot cg 't0 (opnd-ext ap-lv)) 1051 (%cg-emit-st cg 'a0 't0 0)) 1052 (else (%cg-emit-st-slot cg 'a0 (opnd-ext ap-lv))))) 1053 ((eq? (opnd-kind ap-lv) 'global) 1054 (%cg-emit-la cg 't0 (opnd-ext ap-lv)) 1055 (%cg-emit-st cg 'a0 't0 0)) 1056 (else 0)) 1057 ;; Spill the loaded value (a1) to a fresh frame slot under ctype. 1058 (%cg-spill-reg cg 'a1 ctype))) 1059 1060 (define (cg-va-end cg) 1061 ;; va_end is a no-op in this design. Pop and discard ap-lval. 1062 (cg-pop cg) 1063 0) 1064 1065 ;; -------------------------------------------------------------------- 1066 ;; Labels and unconditional goto (§F.4 / CC-CONTRACTS §5.3). 1067 ;; user_<name> namespace keeps the user's label space disjoint from 1068 ;; the compiler-internal ::ret and ::lbl_<n>. Labels resolve through 1069 ;; libp1pp's %scope mechanism, so forward references inside the same 1070 ;; %fn block work without explicit forward declaration. 1071 ;; -------------------------------------------------------------------- 1072 (define (cg-emit-label cg name-bv) 1073 (%cg-emit-many cg (list "::user_" name-bv "\n"))) 1074 1075 (define (cg-goto cg name-bv) 1076 (%cg-emit-many cg (list "%b(&::user_" name-bv ")\n"))) 1077 1078 ;; -------------------------------------------------------------------- 1079 ;; switch 1080 ;; -------------------------------------------------------------------- 1081 (define-record-type swctx 1082 (%swctx ctrl-slot end-tag default-lbl) 1083 swctx? 1084 (ctrl-slot swctx-ctrl-slot) 1085 (end-tag swctx-end-tag) 1086 (default-lbl swctx-default-lbl swctx-default-lbl-set!)) 1087 1088 (define (cg-switch-begin cg) 1089 (let* ((p (cg-pop cg)) 1090 (off (cg-alloc-slot cg 8 8)) 1091 (tag (%cg-fresh-loop-tag cg)) 1092 (disp-lbl (bytevector-append "sw_disp_" tag))) 1093 (%cg-load-opnd-into cg p 't0) 1094 (%cg-emit-st-slot cg 't0 off) 1095 (%cg-emit-many cg (list "%loop_tag(" tag ", {\n" 1096 "%b(&::" disp-lbl ")\n")) 1097 (%swctx off tag #f))) 1098 1099 (define (cg-switch-case cg sw const-int) 1100 (let* ((lbl (%cg-fresh-lbl cg)) 1101 (key (string->symbol 1102 (bytevector-append "%sw_cases__" (swctx-end-tag sw)))) 1103 (cur (or (alist-ref/eq key (cg-globals cg)) '())) 1104 (entry (cons const-int lbl))) 1105 (%cg-fn-set! cg key (cons entry cur)) 1106 (%cg-emit-many cg (list "::" lbl "\n")))) 1107 1108 (define (cg-switch-default cg sw) 1109 (let ((lbl (%cg-fresh-lbl cg))) 1110 (swctx-default-lbl-set! sw lbl) 1111 (%cg-emit-many cg (list "::" lbl "\n")))) 1112 1113 (define (cg-switch-end cg sw) 1114 (let* ((tag (swctx-end-tag sw)) 1115 (key (string->symbol (bytevector-append "%sw_cases__" tag))) 1116 (cases (reverse (or (alist-ref/eq key (cg-globals cg)) '()))) 1117 (default-lbl (swctx-default-lbl sw)) 1118 (disp-lbl (bytevector-append "sw_disp_" tag))) 1119 (%cg-emit-many cg (list "%break(" tag ")\n" 1120 "::" disp-lbl "\n")) 1121 (%cg-emit-many cg (list "%ld(t0, sp, " 1122 (%cg-slot-expr cg (swctx-ctrl-slot sw)) ")\n")) 1123 (for-each 1124 (lambda (c) 1125 (%cg-emit-many cg (list "%li(t1, " (%n (car c)) ")\n" 1126 "%beq(t0, t1, &::" (cdr c) ")\n"))) 1127 cases) 1128 (cond 1129 (default-lbl (%cg-emit-many cg (list "%b(&::" default-lbl ")\n"))) 1130 (else 0)) 1131 (%cg-emit-many cg (list "%break(" tag ")\n" 1132 "})\n")))) 1133 1134 ;; -------------------------------------------------------------------- 1135 ;; Globals and data 1136 ;; -------------------------------------------------------------------- 1137 ;; cg-emit-global: emit a global symbol into either .data (initialized) 1138 ;; or .bss (zero-init). 1139 ;; 1140 ;; init can be: 1141 ;; #f — zero-init in .bss (size from sym's ctype). 1142 ;; (piece ...) — initialized in .data; pieces concatenated. 1143 ;; 1144 ;; Each piece is either: 1145 ;; <bytevector> — raw bytes; emitted as N×!(byte) entries. 1146 ;; (label-ref . <label-bv>) — 8-byte pointer slot containing &label; 1147 ;; emitted as `&<label> %(0)` (4B label ref + 1148 ;; 4B zero pad). 1149 (define (%cg-init-piece->bv piece) 1150 (cond 1151 ((bytevector? piece) 1152 (let ((n (bytevector-length piece))) 1153 (let loop ((i 0) (acc '())) 1154 (cond 1155 ((= i n) (bv-cat (reverse acc))) 1156 (else 1157 (loop (+ i 1) 1158 (cons (bv-cat (list "!(" 1159 (number->string 1160 (bytevector-u8-ref piece i) 10) 1161 ")\n")) 1162 acc))))))) 1163 ((and (pair? piece) (eq? (car piece) 'label-ref)) 1164 (bv-cat (list "&" (cdr piece) " %(0)\n"))) 1165 (else (die #f "cg-emit-global: bad init piece" piece)))) 1166 1167 (define (cg-emit-global cg sym init) 1168 (let* ((nm (sym-name sym)) 1169 (lbl (%cg-mangle-global nm)) 1170 (sz (ctype-size (sym-type sym))) 1171 (size (if (< sz 0) 8 sz))) 1172 (cond 1173 (init 1174 (buf-push! (cg-data cg) (bv-cat (list "\n:" lbl "\n"))) 1175 (let walk ((ps init)) 1176 (cond 1177 ((null? ps) 0) 1178 (else 1179 (buf-push! (cg-data cg) (%cg-init-piece->bv (car ps))) 1180 (walk (cdr ps)))))) 1181 (else 1182 (buf-push! (cg-bss cg) 1183 (bv-cat (list "\n:" lbl "\n" 1184 (let zero-loop ((rem size) (acc '())) 1185 (cond 1186 ((<= rem 0) (bv-cat (reverse acc))) 1187 ((>= rem 8) 1188 (zero-loop (- rem 8) (cons "$(0)\n" acc))) 1189 (else 1190 (zero-loop (- rem 1) (cons "!(0)\n" acc)))))))))) 1191 (cg-globals-set! cg (alist-set (sym-name sym) sym (cg-globals cg))) 1192 0)) 1193 1194 (define (cg-emit-extern cg sym) 1195 (cg-globals-set! cg (alist-set (sym-name sym) sym (cg-globals cg))) 1196 0) 1197 1198 (define (cg-intern-string cg bv-content) 1199 (let ((p (alist-ref bv-content (cg-str-pool cg)))) 1200 (cond 1201 (p p) 1202 (else 1203 (let* ((n (length (cg-str-pool cg))) 1204 (lbl (bytevector-append "cc__str_" (%n n)))) 1205 (cg-str-pool-set! cg 1206 (alist-set bv-content lbl (cg-str-pool cg))) 1207 (buf-push! (cg-data cg) 1208 (bv-cat (list "\n:" lbl "\n" 1209 "\"" bv-content "\"\n" 1210 "!(0)\n"))) 1211 lbl))))) 1212 1213 ;; -------------------------------------------------------------------- 1214 ;; Frame 1215 ;; -------------------------------------------------------------------- 1216 (define (cg-alloc-slot cg bytes align) 1217 (let* ((aligned (align-up (cg-frame-hi cg) align)) 1218 (new-hi (+ aligned bytes))) 1219 (cg-frame-hi-set! cg new-hi) 1220 aligned))