scheme1.P1pp (185996B)
1 # scheme1.P1pp -- Phase 1 minimal Scheme interpreter on P1. 2 # 3 # Build chain: 4 # catm P1-<arch>.M1pp P1.M1pp P1pp.P1pp scheme1/scheme1.P1pp \ 5 # | m1pp -> hex2pp -> ELF 6 # 7 # Run chain: 8 # catm scheme1/prelude.scm prog.scm | scheme1 9 10 # ========================================================================= 11 # Constants 12 # ========================================================================= 13 14 %enum TAG { FIXNUM PAIR SYM HEAP IMM } 15 %enum IMM { FALSE TRUE NIL UNSPEC UNBOUND EOF } 16 %enum HDR { BV CLOSURE PRIM TD REC MV } 17 %enum GCKIND { FREE PAIR HEAP RAW } 18 19 # Each managed block begins with two machine words. The first word is 20 # (total_block_bytes << 8) | kind | mark 21 # and the second is an intrusive link, reused by the free list and mark 22 # worklist. Payloads retain their historical layouts and tags. 23 %macro GC_HEADER_BYTES() 16 %endm 24 %macro GC_MARK_BIT() 128 %endm 25 %macro GC_KIND_MASK() 7 %endm 26 27 # imm_val(idx) -> integer-expression for the tagged immediate at IMM index 28 # `idx`. Used both at %li sites (loaded into a register) and at $() emission 29 # sites (baked into a static word). 30 %macro imm_val(idx) (| (<< idx 3) %TAG.IMM) %endm 31 32 # Layout helpers. %struct stride is 8 bytes per field. 33 %struct PAIR { car cdr } # .SIZE = 16 34 %struct SYMENT { name_ptr name_len global_val pad } # .SIZE = 32 35 %struct PRIM { hdr entry_w data } # .SIZE = 24 36 %struct CLOSURE { hdr params body env } # .SIZE = 32 37 %struct TD { hdr name nfields fields } # .SIZE = 32 38 %struct BV { hdr data } # .SIZE = 16 39 %struct REC { hdr td } # .SIZE = 16 (header) 40 # Records are variable width: header + td slot + N field slots. 41 42 # BSS arenas anchored past :ELF_end. readbuf is 1 MiB (sized to fit 43 # the catm'd cc compiler source incl. prelude), followed by the symbol 44 # table, the exact-root frame stack, and one 256 MiB managed heap. 45 46 %macro SYMTAB_CAP_SLOTS() 8192 %endm 47 %macro READBUF_CAP_BYTES() 1048576 %endm 48 %macro HEAP_CAP_BYTES() 0x10000000 %endm 49 %macro GC_ROOT_CAP_FRAMES() 8192 %endm 50 %macro GC_ROOT_FRAME_BYTES() 24 %endm 51 52 # ========================================================================= 53 # Tag idioms 54 # ========================================================================= 55 56 %macro tagof(rd, rs) %andi(rd, rs, 7) %endm 57 %macro mkfix(rd, rs) %shli(rd, rs, 3) %endm 58 %macro untag_fix(rd, rs) %sari(rd, rs, 3) %endm 59 %macro untag_sym(rd, rs) %sari(rd, rs, 3) %endm 60 %macro car(rd, rs) %ld(rd, rs, -1) %endm 61 %macro cdr(rd, rs) %ld(rd, rs, 7) %endm 62 %macro set_car(rs, pair_tagged) %st(rs, pair_tagged, -1) %endm 63 %macro set_cdr(rs, pair_tagged) %st(rs, pair_tagged, 7) %endm 64 %macro hdr_type(rd, rs) %lb(rd, rs, -3) %endm 65 66 # Field access through a tagged HEAP pointer (tag = 3). `field` is a 67 # constant byte offset from the underlying raw object (e.g. %PRIM.data, 68 # %CLOSURE.env). Reader is %ld; writer is %heap_st. 69 %macro heap_ld(rd, rs, field) %ld(rd, rs, (- field 3)) %endm 70 %macro heap_st(rs, rt, field) %st(rs, rt, (- field 3)) %endm 71 72 # ========================================================================= 73 # Scheme1-local helpers 74 # ========================================================================= 75 76 # Load the byte at readbuf_buf[off_reg] into rd. Clobbers rd. `rd` must 77 # be the destination register; the macro reuses it as a scratch pointer 78 # during the la / ld / add chain before the final lb writes the byte. 79 %macro readbuf_byte(rd, off_reg) 80 %ld_global(rd, &readbuf_buf_ptr) 81 %add(rd, rd, off_reg) 82 %lb(rd, rd, 0) 83 %endm 84 85 # Increment cursor and store it back. `addr_reg` is the address of 86 # readbuf_pos as returned by %lda_global (the second output register). 87 %macro readbuf_advance(pos_reg, addr_reg) 88 %addi(pos_reg, pos_reg, 1) 89 %st(pos_reg, addr_reg, 0) 90 %endm 91 92 # Load readbuf_len into len_reg and branch to target if cursor is at EOF. 93 %macro readbuf_at_eof(pos_reg, len_reg, target) 94 %ld_global(len_reg, &readbuf_len) 95 %beq(pos_reg, len_reg, target) 96 %endm 97 98 # Branch character equal/not-equal: if (c == expect) / (c != expect) goto target. 99 # expect passed as -(char_code). scratch is clobbered. 100 %macro bceq(c, neg_cv, target, scratch) 101 %addi(scratch, c, neg_cv) 102 %beqz(scratch, target) 103 %endm 104 105 %macro bcne(c, neg_cv, target, scratch) 106 %addi(scratch, c, neg_cv) 107 %bnez(scratch, target) 108 %endm 109 110 # Branch immediate equal/not-equal: if (reg == value) / (reg != value) goto target. 111 # scratch is clobbered. 112 %macro bieq(reg, value, target, scratch) 113 %li(scratch, value) 114 %beq(reg, scratch, target) 115 %endm 116 117 %macro bine(reg, value, target, scratch) 118 %li(scratch, value) 119 %bne(reg, scratch, target) 120 %endm 121 122 # Branch to `target` if `ch_reg` holds an ASCII whitespace byte (space, 123 # tab, LF, CR). `scratch` is clobbered. 124 %macro is_ws_branch(scratch, ch_reg, target) 125 %bceq(ch_reg, -32, target, scratch) ; SP 126 %bceq(ch_reg, -9, target, scratch) ; HT 127 %bceq(ch_reg, -10, target, scratch) ; LF 128 %bceq(ch_reg, -13, target, scratch) ; CR 129 %endm 130 131 # Branch to `target` if lo_neg <= c < lo_neg+count (unsigned). Both 132 # scratch and count_scratch are clobbered. 133 %macro brange(c, lo_neg, count, scratch, count_scratch, target) 134 %addi(scratch, c, lo_neg) 135 %li(count_scratch, count) 136 %bltu(scratch, count_scratch, target) 137 %endm 138 139 # Compute &symtab_buf + idx_reg * SYMENT.SIZE into rd. `scratch` is 140 # clobbered. 141 %macro symtab_entry(rd, idx_reg, scratch) 142 %ld_global(rd, &symtab_buf_ptr) 143 %shli(scratch, idx_reg, 5) 144 %add(rd, rd, scratch) 145 %endm 146 147 # Print msg_label and abort. Never returns. Routes through runtime_error 148 # so every error path lands in one place (stderr + exit 1). 149 %macro die(msg) 150 %la(a0, & ## msg) 151 %call(&runtime_error) 152 %endm 153 154 # Emit an 8-aligned NUL-terminated string. 155 %macro cstr8(str) 156 str 157 00 158 .align 8 159 %endm 160 161 # Intern `str` into `slot` and declare its padded string data inline. 162 # `key` is the label suffix; the data label :name_##key is emitted here. 163 %macro intern_form(key, str, slot) 164 %la(a0, &name_ ## key) 165 %li(a1, (strlen str)) 166 %call(&intern) 167 %st_global(a0, slot, t0) 168 %b(&@end) 169 :name_ ## key 170 %cstr8(str) 171 :@end 172 %endm 173 174 # Special-form dispatch: pointer-compare the head symbol against `slot`'s 175 # cached value (in t0) and branch to `target` on hit. Caller has already 176 # loaded head into t0. 177 %macro dispatch_form(slot, target) 178 %ld_global(t1, slot) 179 %beq(t0, t1, target) 180 %endm 181 182 # Tail-jump from a special-form dispatch label to its handler. Handlers 183 # uniformly take (rest=cdr(expr), env) -> value; expr lives at sp[0], 184 # env at sp[8] in eval's frame. 185 %macro tail_to_handler(handler) 186 %ld(a0, sp, 0) 187 %cdr(a0, a0) 188 %ld(a1, sp, 8) 189 %gctail(handler) 190 %endm 191 192 # Branch to `target` if `val` holds the NIL immediate. `scratch` is 193 # clobbered. 194 %macro if_nil(scratch, val, target) 195 %li(scratch, %imm_val(%IMM.NIL)) 196 %beq(val, scratch, target) 197 %endm 198 199 # Advance a named list-cursor local to its cdr. t0 is the implicit scratch 200 # register; callers must ensure it's free. 201 %macro advance_walk(name) 202 %ldl(t0, name) 203 %cdr(t0, t0) 204 %stl(t0, name) 205 %endm 206 207 # Set a global binding. sym is a tagged symbol, val is the new value. 208 # Untags sym into the idx ABI position and calls sym_set_global. 209 %macro set_global(sym, val) 210 %mov(a1, val) 211 %untag_sym(a0, sym) 212 %call(&sym_set_global) 213 %endm 214 215 # Exact shadow-root frames. Every frame records the native frame pointer 216 # plus two bitmaps: tagged Scheme-reference slots and temporarily live raw 217 # managed-allocation pointers. Bit N describes native local slot N. The 218 # collector dereferences only those described slots; ordinary machine 219 # locals and the native P1 stack are never scanned. 220 %macro gc_frame_push(scheme_mask, raw_mask) 221 %ld_global(t0, &gc_root_next) 222 %addi(t1, t0, %GC_ROOT_FRAME_BYTES) 223 %ld_global(t2, &gc_root_end) 224 %bltu(t2, t1, &@overflow) 225 %addi(t2, sp, 16) 226 %st(t2, t0, 0) 227 %li(t2, scheme_mask) 228 %st(t2, t0, 8) 229 %li(t2, raw_mask) 230 %st(t2, t0, 16) 231 %st_global(t1, &gc_root_next, t2) 232 %b(&@done) 233 :@overflow 234 %die(msg_gc_roots_full) 235 :@done 236 %endm 237 238 %macro gc_frame_pop() 239 %ld_global(t0, &gc_root_next) 240 %addi(t0, t0, (- %GC_ROOT_FRAME_BYTES)) 241 # Clear popped descriptors so debugging an overflow never exposes 242 # stale native-stack addresses as apparently active slots. 243 %li(t1, 0) 244 %st(t1, t0, 0) 245 %st(t1, t0, 8) 246 %st(t1, t0, 16) 247 %st_global(t0, &gc_root_next, t1) 248 %endm 249 250 %macro gc_frame_clear(frame_size) 251 %addi(t0, sp, 16) 252 %li(t1, frame_size) 253 %li(t2, 0) 254 :@loop 255 %beqz(t1, &@done) 256 %st(t2, t0, 0) 257 %addi(t0, t0, 8) 258 %addi(t1, t1, -8) 259 %b(&@loop) 260 :@done 261 %endm 262 263 %macro gceret() 264 %gc_frame_pop 265 %eret 266 %endm 267 268 %macro gctail(target) 269 %gc_frame_pop 270 %tail(target) 271 %endm 272 273 %macro gctailr(target_reg) 274 %mov(a3, target_reg) 275 %gc_frame_pop 276 %tailr(a3) 277 %endm 278 279 # GC-aware counterpart of P1pp's %fn2. Functions using this form must 280 # use %gceret / %gctail / %gctailr for explicit exits; fallthrough runs 281 # the epilogue emitted here. 282 %macro gcfn2(name, locals, scheme_mask, raw_mask, body) 283 %struct name ## _FRAME { locals } 284 : ## name 285 .scope 286 %frame name 287 %enter(% ## name ## _FRAME.SIZE) 288 %gc_frame_clear(% ## name ## _FRAME.SIZE) 289 %gc_frame_push(scheme_mask, raw_mask) 290 body 291 %gc_frame_pop 292 %eret 293 %endframe 294 .endscope 295 %endm 296 297 # car-and-untag-fixnum: rd = car(list) >> 3. 298 %macro car_fix(rd, list) 299 %car(rd, list) 300 %sari(rd, rd, 3) 301 %endm 302 303 # car-then-load-bytevector-data-pointer: rd = (car(list)).data_ptr. 304 %macro car_bvdata(rd, list) 305 %car(rd, list) 306 %ld(rd, rd, 5) 307 %endm 308 309 # Positional list-arg extraction. r_n receives the nth element of `list`; 310 # the last destination register doubles as the in-flight rest cursor 311 # during extraction (its final value is the last argument). 312 %macro args2(r0, r1, list) 313 %car(r0, list) 314 %cdr(r1, list) 315 %car(r1, r1) 316 %endm 317 318 %macro args3(r0, r1, r2, list) 319 %car(r0, list) 320 %cdr(r2, list) 321 %car(r1, r2) 322 %cdr(r2, r2) 323 %car(r2, r2) 324 %endm 325 326 %macro args4(r0, r1, r2, r3, list) 327 %car(r0, list) 328 %cdr(r3, list) 329 %car(r1, r3) 330 %cdr(r3, r3) 331 %car(r2, r3) 332 %cdr(r3, r3) 333 %car(r3, r3) 334 %endm 335 336 # ========================================================================= 337 # p1_main -- runtime spine 338 # ========================================================================= 339 340 %fn(p1_main, 0, { 341 # Stash argc/argv 342 %st_global(a0, &saved_argc, t0) 343 %st_global(a1, &saved_argv, t0) 344 345 # if argc < 2 goto usage 346 %li(t0, 2) 347 %bltu(a0, t0, &.usage) 348 349 # Initialize 350 %la(a0, &ELF_end) 351 %la(a1, &arena_table) 352 %la(a2, &arena_table_end) 353 %call(&init_arenas) 354 %call(&heap_init) 355 %call(&intern_special_forms) 356 %call(®ister_primitives) 357 %call(®ister_globals) 358 359 # load_source(argv[1]) 360 %ld_global(a0, &saved_argv) 361 %ld(a0, a0, 8) 362 %call(&load_source) 363 364 # read-eval loop 365 %loop_scoped({ 366 # eof = skip_ws() 367 %call(&skip_ws) 368 # if eof break 369 %if_nez(a0, { %break }) 370 # expr = parse_one() 371 %call(&parse_one) 372 # eval(expr, env=nil) 373 %li(a1, %imm_val(%IMM.NIL)) 374 %call(&eval) 375 }) 376 377 # return 0 378 %li(a0, 0) 379 %eret 380 381 :.usage 382 %la(a0, &msg_usage) 383 %call(&print_cstr) 384 %li(a0, 2) 385 }) 386 387 # ========================================================================= 388 # Reader -- parse_one over readbuf with a single byte cursor 389 # ========================================================================= 390 # 391 # Cursor lives in &readbuf_pos; readbuf_len holds the slurped byte count. 392 # The reader is called recursively from parse_list, so every state goes 393 # through frame slots, not s-registers. 394 395 # Skip whitespace (ASCII 32, 9, 10, 13) and `;`-to-LF comments. Returns 396 # a0 = 1 if readbuf_pos >= readbuf_len after skipping (caller hit EOF), 397 # else 0. Leaf. 398 :skip_ws 399 .scope 400 %lda_global(t0, t2, &readbuf_pos) 401 %ld_global(t1, &readbuf_len) 402 :.loop 403 %beq(t0, t1, &.done) 404 %readbuf_byte(a0, t0) 405 %is_ws_branch(a1, a0, &.step) 406 %bceq(a0, -59, &.comment, a1) ; ';' 407 %b(&.done) 408 :.comment 409 # Consume up to and including the next LF, or to EOF. 410 %addi(t0, t0, 1) 411 %beq(t0, t1, &.done) 412 %readbuf_byte(a0, t0) 413 %bcne(a0, -10, &.comment, a1) ; LF 414 :.step 415 %addi(t0, t0, 1) 416 %b(&.loop) 417 :.done 418 419 %st(t0, t2, 0) 420 %li(a0, 1) 421 %beq(t0, t1, &.ret) 422 %li(a0, 0) 423 :.ret 424 %ret 425 .endscope 426 427 # parse_one() -> tagged value in a0 428 %fn(parse_one, 0, { 429 %call(&skip_ws) 430 %bnez(a0, &.eof) 431 432 %ld_global(t0, &readbuf_pos) 433 %readbuf_byte(a0, t0) 434 435 %bceq(a0, -40, &.lparen, a1) 436 %bceq(a0, -41, &.rparen, a1) 437 %bceq(a0, -35, &.hash, a1) 438 %bceq(a0, -39, &.quote, a1) 439 %bceq(a0, -44, &.comma, a1) 440 %bceq(a0, -34, &.string, a1) 441 442 %tail(&parse_atom) 443 444 :.lparen 445 # Consume '(' and read items until ')'. 446 %lda_global(t1, t0, &readbuf_pos) 447 %readbuf_advance(t1, t0) 448 %tail(&parse_list) 449 450 :.rparen 451 %die(msg_unexp_rparen) 452 453 :.string 454 # Consume opening '"' and tail to parse_string. parse_string scans 455 # through the matching '"' (consuming it) and returns a tagged bv. 456 %lda_global(t1, t0, &readbuf_pos) 457 %readbuf_advance(t1, t0) 458 %tail(&parse_string) 459 460 :.hash 461 # Consume '#' plus its type byte; dispatch on the type byte. 462 %lda_global(t0, t2, &readbuf_pos) 463 %addi(t0, t0, 1) 464 %readbuf_at_eof(t0, t1, &.eof) 465 %readbuf_byte(a0, t0) 466 %readbuf_advance(t0, t2) 467 %bceq(a0, -116, &.true_lit, a1) ; 't' 468 %bceq(a0, -102, &.false_lit, a1) ; 'f' 469 %bceq(a0, -120, &.hex_lit, a1) ; 'x' 470 %bceq(a0, -88, &.hex_lit, a1) ; 'X' 471 %bceq(a0, -92, &.char_lit, a1) ; '\\' 472 %bceq(a0, -117, &.u8_lit, a1) ; 'u' 473 %die(msg_bad_hash) 474 475 :.true_lit 476 %li(a0, %imm_val(%IMM.TRUE)) 477 %eret 478 479 :.false_lit 480 %li(a0, %imm_val(%IMM.FALSE)) 481 %eret 482 483 :.hex_lit 484 # t0 sits at the first hex digit; t1 = readbuf_len. Scan to ws/paren/EOF, 485 # then parse_hex over the slice (with optional leading '-'). 486 %mov(a3, t0) 487 :.hex_scan 488 %beq(t0, t1, &.hex_end) 489 %readbuf_byte(a0, t0) 490 %is_ws_branch(a1, a0, &.hex_end) 491 %bceq(a0, -40, &.hex_end, a1) 492 %bceq(a0, -41, &.hex_end, a1) 493 %addi(t0, t0, 1) 494 %b(&.hex_scan) 495 :.hex_end 496 497 %st_global(t0, &readbuf_pos, t2) 498 %ld_global(a0, &readbuf_buf_ptr) 499 %add(a0, a0, a3) 500 %sub(a1, t0, a3) 501 %lb(t2, a0, 0) 502 %addi(t2, t2, -45) ; '-' 503 %beqz(t2, &.hex_neg) 504 %call(&parse_hex) 505 %mkfix(a0, a0) 506 %eret 507 :.hex_neg 508 %addi(a0, a0, 1) 509 %addi(a1, a1, -1) 510 %call(&parse_hex) 511 %li(t0, 0) 512 %sub(a0, t0, a0) 513 %mkfix(a0, a0) 514 %eret 515 516 :.quote 517 # Consume the leading '\''; recurse into parse_one for the datum; 518 # then build (quote <datum>). 519 %lda_global(t0, t2, &readbuf_pos) 520 %readbuf_advance(t0, t2) 521 %call(&parse_one) 522 %li(a1, %imm_val(%IMM.NIL)) 523 %call(&cons) 524 %ld_global(t0, &sym_quote) 525 %mov(a1, a0) 526 %mov(a0, t0) 527 %tail(&cons) 528 529 :.comma 530 # Consume the leading ','; recurse into parse_one for the datum; 531 # build (unquote <datum>). The comma sugar exists so pmatch 532 # patterns can be written as `,ident`. Outside pmatch 533 # `(unquote x)` reaches eval as an application of the unbound 534 # `unquote` and dies through the standard unbound-variable path. 535 %lda_global(t0, t2, &readbuf_pos) 536 %readbuf_advance(t0, t2) 537 %call(&parse_one) 538 %li(a1, %imm_val(%IMM.NIL)) 539 %call(&cons) 540 %ld_global(t0, &sym_unquote) 541 %mov(a1, a0) 542 %mov(a0, t0) 543 %tail(&cons) 544 545 :.char_lit 546 # Cursor is already past '#\\'; parse_char scans the body and returns 547 # a tagged fixnum (the u8 char value). 548 %tail(&parse_char) 549 550 :.u8_lit 551 # Cursor is past '#u'. Demand '8' then '('; consume both and tail to 552 # parse_u8_body, which reads the element list and packs it into a bv. 553 %lda_global(t0, t2, &readbuf_pos) 554 %readbuf_at_eof(t0, t1, &.u8_bad) 555 %readbuf_byte(a0, t0) 556 %bcne(a0, -56, &.u8_bad, a1) ; '8' 557 %addi(t0, t0, 1) 558 %beq(t0, t1, &.u8_bad) 559 %readbuf_byte(a0, t0) 560 %bcne(a0, -40, &.u8_bad, a1) ; '(' 561 %readbuf_advance(t0, t2) 562 %tail(&parse_u8_body) 563 564 :.u8_bad 565 %die(msg_bad_hash) 566 567 :.eof 568 %die(msg_unexp_eof) 569 }) 570 571 # parse_list() -> tagged list value in a0. Cursor sits past '(' on entry; 572 # returns once ')' is consumed. 573 # 574 # Locals: 575 # head NIL until first item 576 # tail most recent cons (set-cdr! target) 577 %gcfn2(parse_list, {head tail}, 3, 0, { 578 %li(t0, %imm_val(%IMM.NIL)) 579 %stl(t0, head) 580 %stl(t0, tail) 581 582 :.loop 583 %call(&skip_ws) 584 %bnez(a0, &.eof) 585 %ld_global(t0, &readbuf_pos) 586 %ld_global(t1, &readbuf_len) 587 588 %readbuf_byte(a0, t0) 589 %bceq(a0, -41, &.close, a1) 590 591 # Dotted-pair separator: '.' followed by ws/paren/EOF (otherwise the 592 # '.' is part of an identifier and parse_atom handles it). 593 %bcne(a0, -46, &.not_dot, a1) ; '.' 594 %addi(a2, t0, 1) 595 %beq(a2, t1, &.do_dot) 596 %readbuf_byte(a3, a2) 597 %is_ws_branch(a1, a3, &.do_dot) 598 %bceq(a3, -40, &.do_dot, a1) 599 %bceq(a3, -41, &.do_dot, a1) 600 :.not_dot 601 602 # Not ')': parse one item, append. 603 %call(&parse_one) 604 %li(a1, %imm_val(%IMM.NIL)) 605 %call(&cons) 606 607 # If head is NIL, both head and tail = new cons; else set-cdr! tail = new. 608 %ldl(t0, head) 609 %bine(t0, %imm_val(%IMM.NIL), &.link, t1) 610 %stl(a0, head) 611 %stl(a0, tail) 612 %b(&.loop) 613 614 :.link 615 %ldl(t0, tail) 616 # set-cdr! tail = a0 -> store a0 at [tail + 7] (raw + 8) 617 %set_cdr(a0, t0) 618 %stl(a0, tail) 619 %b(&.loop) 620 621 :.do_dot 622 # Consume the '.', read one datum, splice it in as the cdr of the 623 # tail cons. Then expect a closing ')' (with optional ws). 624 %lda_global(t0, t1, &readbuf_pos) 625 %readbuf_advance(t0, t1) 626 %call(&parse_one) 627 %ldl(t0, tail) 628 %set_cdr(a0, t0) 629 %call(&skip_ws) 630 %bnez(a0, &.eof) 631 %lda_global(t0, t1, &readbuf_pos) 632 %readbuf_byte(a0, t0) 633 %bcne(a0, -41, &.eof, a1) ; ')' 634 %readbuf_advance(t0, t1) 635 %ldl(a0, head) 636 %gceret 637 638 :.close 639 # Consume ')' and return head. 640 %lda_global(t1, t0, &readbuf_pos) 641 %readbuf_advance(t1, t0) 642 %ldl(a0, head) 643 %gceret 644 645 :.eof 646 %die(msg_unterm_list) 647 }) 648 649 # parse_u8_body() -> tagged HDR.BV in a0. Cursor sits past '#u8(' on 650 # entry. Reads elements via parse_list (each must be a fixnum byte 0..255; 651 # range is unchecked, matching make-bytevector's lax stance) and packs 652 # them into a fresh bytevector. 653 # 654 # Locals: 655 # list parsed element list (cursor during fill pass) 656 # result freshly allocated bv 657 %gcfn2(parse_u8_body, {list result}, 3, 0, { 658 %call(&parse_list) 659 %stl(a0, list) 660 661 %call(&list_length) ; clobbers a0 -> count 662 %call(&bv_alloc) ; a0 = bv 663 %stl(a0, result) 664 665 %heap_ld(t0, a0, %BV.data) 666 %ldl(a0, list) ; list cursor 667 668 :.loop 669 %if_nil(t1, a0, &.done) 670 %car(t1, a0) 671 %untag_fix(t1, t1) 672 %sb(t1, t0, 0) 673 %addi(t0, t0, 1) 674 %cdr(a0, a0) 675 %b(&.loop) 676 :.done 677 %ldl(a0, result) 678 }) 679 680 # is_ident_byte(c=a0) -> a1 (1 if c is a valid identifier byte, else 0). 681 # Leaf. Allowed bytes are R7RS-Small's identifier set: ASCII letters, 682 # digits, and the extended chars ! $ % & * + - . / : < = > ? @ ^ _ ~ . 683 # Clobbers t0, t1, a1. 684 :is_ident_byte 685 .scope 686 %brange(a0, -48, 10, t0, t1, &.ok) ; '0'..'9' 687 %brange(a0, -65, 26, t0, t1, &.ok) ; 'A'..'Z' 688 %brange(a0, -97, 26, t0, t1, &.ok) ; 'a'..'z' 689 690 %bceq(a0, -33, &.ok, t0) ; '!' 691 %bceq(a0, -36, &.ok, t0) ; '$' 692 %bceq(a0, -37, &.ok, t0) ; '%' 693 %bceq(a0, -38, &.ok, t0) ; '&' 694 %bceq(a0, -42, &.ok, t0) ; '*' 695 %bceq(a0, -43, &.ok, t0) ; '+' 696 %bceq(a0, -45, &.ok, t0) ; '-' 697 %bceq(a0, -46, &.ok, t0) ; '.' 698 %bceq(a0, -47, &.ok, t0) ; '/' 699 %bceq(a0, -58, &.ok, t0) ; ':' 700 %bceq(a0, -60, &.ok, t0) ; '<' 701 %bceq(a0, -61, &.ok, t0) ; '=' 702 %bceq(a0, -62, &.ok, t0) ; '>' 703 %bceq(a0, -63, &.ok, t0) ; '?' 704 %bceq(a0, -64, &.ok, t0) ; '@' 705 %bceq(a0, -94, &.ok, t0) ; '^' 706 %bceq(a0, -95, &.ok, t0) ; '_' 707 %bceq(a0, -126, &.ok, t0) ; '~' 708 709 %li(a1, 0) 710 %ret 711 712 :.ok 713 %li(a1, 1) 714 %ret 715 .endscope 716 717 # parse_atom() -> tagged value (fixnum or symbol) in a0. 718 # Reads until whitespace or paren or EOF, then dispatches by first byte. 719 # A token whose first byte is a digit (or sign-then-digit) commits to 720 # parse_dec and any non-numeric byte aborts; otherwise the token is a 721 # symbol and every byte is checked against is_ident_byte before intern. 722 # 723 # Locals: 724 # start cursor (byte offset) 725 # end cursor (byte offset) 726 # cursor (scratch slot for the symbol-validation loop) 727 %fn2(parse_atom, {start end cursor}, { 728 %lda_global(t1, t0, &readbuf_pos) 729 %stl(t1, start) 730 731 %ld_global(t2, &readbuf_len) 732 733 :.scan 734 %beq(t1, t2, &.end) 735 %readbuf_byte(a0, t1) 736 737 %is_ws_branch(a1, a0, &.end) 738 %bceq(a0, -40, &.end, a1) ; '(' 739 %bceq(a0, -41, &.end, a1) ; ')' 740 741 %addi(t1, t1, 1) 742 %b(&.scan) 743 744 :.end 745 %stl(t1, end) 746 %st(t1, t0, 0) 747 748 # Dispatch on the first byte. 749 %ldl(t0, start) 750 %ld_global(a0, &readbuf_buf_ptr) 751 %add(a0, a0, t0) 752 %lb(t1, a0, 0) 753 754 # '0'..'9' -> int 755 %addi(a1, t1, -48) 756 %li(a2, 10) 757 %bltu(a1, a2, &.is_int) 758 # '-' or '+' followed by digit -> int. A lone '+' or '-' falls 759 # through to is_sym (those tokens stay valid identifiers). 760 %bceq(t1, -45, &.sign, a1) ; '-' 761 %bceq(t1, -43, &.sign, a1) ; '+' 762 %b(&.is_sym) 763 :.sign 764 %ldl(t2, end) 765 %addi(t0, t0, 1) 766 %beq(t0, t2, &.is_sym) 767 %readbuf_byte(a0, t0) 768 %addi(a1, a0, -48) 769 %bltu(a1, a2, &.is_int) 770 # fall through to is_sym 771 772 :.is_sym 773 # Validate every byte; abort on the first non-ident byte. 774 %ldl(t0, start) 775 %stl(t0, cursor) 776 :.sym_loop 777 %ldl(t0, cursor) 778 %ldl(t1, end) 779 %beq(t0, t1, &.sym_intern) 780 %readbuf_byte(a0, t0) 781 %call(&is_ident_byte) 782 %beqz(a1, &.sym_bad) 783 %ldl(t0, cursor) 784 %addi(t0, t0, 1) 785 %stl(t0, cursor) 786 %b(&.sym_loop) 787 788 :.sym_bad 789 %die(msg_bad_ident) 790 791 :.sym_intern 792 %ldl(a0, start) 793 %ld_global(t0, &readbuf_buf_ptr) 794 %add(a0, t0, a0) 795 %ldl(t1, end) 796 %ldl(t2, start) 797 %sub(a1, t1, t2) 798 %tail(&intern) 799 800 :.is_int 801 %ldl(t0, start) 802 %ldl(t1, end) 803 %ld_global(a0, &readbuf_buf_ptr) 804 %add(a0, a0, t0) 805 %sub(a1, t1, t0) ; len = end - start 806 # P1pp's parse_dec handles '-' but not '+'; strip '+' here. 807 %lb(t2, a0, 0) 808 %bcne(t2, -43, &.no_plus, t2) ; '+' 809 %addi(a0, a0, 1) 810 %addi(a1, a1, -1) 811 :.no_plus 812 %stl(a1, cursor) ; save adjusted len (cursor slot is free on int path) 813 %call(&parse_dec) ; P1pp: -> (raw_val=a0, consumed=a1) 814 %ldl(t0, cursor) 815 %bne(a1, t0, &.int_bad) ; partial parse -> bad 816 %mkfix(a0, a0) 817 %eret 818 :.int_bad 819 %die(msg_bad_number) 820 }) 821 822 # parse_string() -> tagged bytevector in a0. Cursor sits past the 823 # opening '"' (consumed by parse_one). Two-pass: pass 1 walks the body, 824 # counting decoded bytes in a0 and locating the closing '"'; pass 2 825 # allocates the bv and decodes into its data buffer. Each named escape 826 # (\n \t \r \\ \") yields one byte; an inline-hex escape \xHEX; (1+ 827 # hex digits, value 0..255, terminated by ';') also yields one byte. 828 # 829 # Locals: 830 # start cursor (first content byte) 831 # end cursor (closing '"' position) 832 # bv wrapper (saved across the data fill loop) 833 # spill slot (write ptr saved across parse_hex in \x escape) 834 %fn2(parse_string, {start end bv spill}, { 835 %ld_global(t1, &readbuf_pos) 836 %stl(t1, start) 837 838 %ld_global(t2, &readbuf_len) 839 840 %li(a0, 0) 841 :.scan 842 %beq(t1, t2, &.eof) 843 %readbuf_byte(a3, t1) 844 %bceq(a3, -34, &.scan_done, a1) ; '"' 845 %bceq(a3, -92, &.scan_esc, a1) ; '\\' 846 %addi(t1, t1, 1) 847 %addi(a0, a0, 1) 848 %b(&.scan) 849 850 :.scan_esc 851 # Backslash plus the next byte yield one decoded byte. \xHEX; runs 852 # until the terminating ';' (validated in pass 2); every other escape 853 # is exactly two source bytes. 854 %addi(t1, t1, 1) 855 %beq(t1, t2, &.eof) 856 %readbuf_byte(a3, t1) 857 %bceq(a3, -120, &.scan_hex, a1) ; 'x' 858 %addi(t1, t1, 1) 859 %addi(a0, a0, 1) 860 %b(&.scan) 861 862 :.scan_hex 863 # Skip past 'x' and scan to the terminating ';'. EOF before ';' 864 # falls into the unterminated-string path below, matching how an 865 # unterminated body is reported. 866 %addi(t1, t1, 1) 867 :.scan_hex_loop 868 %beq(t1, t2, &.eof) 869 %readbuf_byte(a3, t1) 870 %bceq(a3, -59, &.scan_hex_done, a1) ; ';' 871 %addi(t1, t1, 1) 872 %b(&.scan_hex_loop) 873 :.scan_hex_done 874 %addi(t1, t1, 1) ; consume ';' 875 %addi(a0, a0, 1) ; +1 output byte 876 %b(&.scan) 877 :.scan_done 878 879 %stl(t1, end) 880 %call(&str_alloc) 881 %stl(a0, bv) 882 883 # Pass 2: decode into the freshly allocated data buffer. 884 %ldl(t1, start) 885 %ldl(t2, end) 886 %heap_ld(a3, a0, %BV.data) 887 888 :.fill 889 %beq(t1, t2, &.fill_done) 890 %readbuf_byte(a1, t1) 891 %bceq(a1, -92, &.fill_esc, a2) ; '\\' 892 %sb(a1, a3, 0) 893 %addi(a3, a3, 1) 894 %addi(t1, t1, 1) 895 %b(&.fill) 896 897 :.fill_esc 898 %addi(t1, t1, 1) ; consume backslash 899 %readbuf_byte(a1, t1) 900 %bceq(a1, -110, &.esc_n, a2) ; 'n' 901 %bceq(a1, -116, &.esc_t, a2) ; 't' 902 %bceq(a1, -114, &.esc_r, a2) ; 'r' 903 %bceq(a1, -92, &.write_byte, a2) ; '\\' 904 %bceq(a1, -34, &.write_byte, a2) ; '"' 905 %bceq(a1, -120, &.esc_hex, a2) ; 'x' 906 %die(msg_bad_escape) 907 908 :.esc_n 909 %li(a1, 10) 910 %b(&.write_byte) 911 :.esc_t 912 %li(a1, 9) 913 %b(&.write_byte) 914 :.esc_r 915 %li(a1, 13) 916 :.write_byte 917 %sb(a1, a3, 0) 918 %addi(a3, a3, 1) 919 %addi(t1, t1, 1) 920 %b(&.fill) 921 922 :.esc_hex 923 # Skip past 'x'. parse_hex consumes hex digits; demand at least one, 924 # value <= 255, and an immediate ';' terminator. parse_hex clobbers 925 # t0/t1/t2 and a2/a3, so spill the cursor (t1) and write ptr (a3) 926 # across the call. sp+0 is free once pass 1 finishes. 927 %addi(t1, t1, 1) ; t1 -> first hex digit 928 %stl(t1, start) 929 %stl(a3, spill) 930 %ld_global(t0, &readbuf_buf_ptr) 931 %add(a0, t0, t1) ; ptr to first hex digit 932 %sub(a1, t2, t1) ; max len (bytes left in body) 933 %call(&parse_hex) ; -> (a0=value, a1=consumed) 934 %beqz(a1, &.hex_bad) 935 %li(t0, 255) 936 %bltu(t0, a0, &.hex_bad) 937 %ldl(t1, start) 938 %add(t1, t1, a1) ; t1 = position of expected ';' 939 %ldl(t2, end) 940 %beq(t1, t2, &.hex_bad) 941 %readbuf_byte(t0, t1) 942 %bcne(t0, -59, &.hex_bad, t0) ; ';' 943 %addi(t1, t1, 1) ; consume ';' 944 %ldl(a3, spill) 945 %sb(a0, a3, 0) 946 %addi(a3, a3, 1) 947 %b(&.fill) 948 949 :.hex_bad 950 %die(msg_bad_escape) 951 952 :.fill_done 953 %addi(t1, t1, 1) ; consume closing '"' 954 %st_global(t1, &readbuf_pos, t0) 955 %ldl(a0, bv) 956 %eret 957 958 :.eof 959 %die(msg_unterm_string) 960 }) 961 962 # Emit one named-char arm inside parse_char's multi-byte dispatch. t2 963 # must hold the slice pointer; ::bad must be in scope. name_label is a 964 # full label reference (e.g. &name_ch_tab). 965 %macro match_named_char(name_label, len, value) 966 %mov(a0, t2) 967 %la(a1, name_label) 968 %li(a2, len) 969 %call(&memcmp) 970 %bnez(a0, &.bad) 971 %li(a0, value) 972 %mkfix(a0, a0) 973 %eret 974 %endm 975 976 # parse_char() -> tagged fixnum (the u8 char value) in a0. Cursor sits 977 # past '#\\' (consumed by parse_one's hash dispatch). Always consumes 978 # at least one byte; then continues until ws/paren/EOF. Single-byte 979 # bodies yield that byte; multi-byte bodies dispatch to hex (#\xNN) or 980 # named (#\space, #\newline, #\tab, #\return, #\null) forms. 981 # 982 # Locals: 983 # start cursor 984 # end cursor 985 %fn2(parse_char, {start end}, { 986 %lda_global(t1, t0, &readbuf_pos) 987 %stl(t1, start) 988 989 %ld_global(t2, &readbuf_len) 990 991 %beq(t1, t2, &.short) 992 993 # Always consume the first byte unconditionally — it might itself be 994 # a delimiter (e.g., '(' in `#\(`) and is still the character value. 995 %addi(t1, t1, 1) 996 997 :.scan 998 %beq(t1, t2, &.scan_done) 999 %readbuf_byte(a0, t1) 1000 %is_ws_branch(a1, a0, &.scan_done) 1001 %bceq(a0, -40, &.scan_done, a1) ; '(' 1002 %bceq(a0, -41, &.scan_done, a1) ; ')' 1003 %addi(t1, t1, 1) 1004 %b(&.scan) 1005 1006 :.scan_done 1007 %stl(t1, end) 1008 %st(t1, t0, 0) 1009 1010 %ldl(t0, start) 1011 %ldl(t1, end) 1012 %sub(a2, t1, t0) ; length 1013 1014 %bieq(a2, 1, &.single, a3) 1015 1016 %ld_global(t2, &readbuf_buf_ptr) 1017 %add(t2, t2, t0) ; t2 = slice ptr 1018 1019 # Hex form: first byte is 'x'. 1020 %lb(a0, t2, 0) 1021 %addi(a1, a0, -120) ; 'x' 1022 %beqz(a1, &.hex_form) 1023 1024 # Named form: dispatch on length. 1025 %bieq(a2, 3, &.try_tab, a3) 1026 %bieq(a2, 4, &.try_null, a3) 1027 %bieq(a2, 5, &.try_space, a3) 1028 %bieq(a2, 6, &.try_return, a3) 1029 %bieq(a2, 7, &.try_newline, a3) 1030 %b(&.bad) 1031 1032 :.single 1033 %ld_global(t2, &readbuf_buf_ptr) 1034 %add(t2, t2, t0) 1035 %lb(a0, t2, 0) 1036 %mkfix(a0, a0) 1037 %eret 1038 1039 :.hex_form 1040 %addi(a0, t2, 1) 1041 %addi(a1, a2, -1) 1042 %call(&parse_hex) 1043 %mkfix(a0, a0) 1044 %eret 1045 1046 :.try_tab 1047 %match_named_char(&name_ch_tab, 3, 9) 1048 1049 :.try_null 1050 %match_named_char(&name_ch_null, 4, 0) 1051 1052 :.try_space 1053 %match_named_char(&name_ch_space, 5, 32) 1054 1055 :.try_return 1056 %match_named_char(&name_ch_return, 6, 13) 1057 1058 :.try_newline 1059 %match_named_char(&name_ch_newline, 7, 10) 1060 1061 :.bad 1062 %die(msg_bad_char) 1063 1064 :.short 1065 %die(msg_bad_char) 1066 }) 1067 1068 1069 # ========================================================================= 1070 # eval / apply 1071 # ========================================================================= 1072 1073 # eval(expr=a0, env=a1) -> value (a0) 1074 # 1075 # Locals: 1076 # expr 1077 # env 1078 # fn (head value, while args are being evaluated) 1079 # pad 1080 %gcfn2(eval, {expr env fn pad}, 7, 0, { 1081 %stl(a0, expr) 1082 %stl(a1, env) 1083 1084 %tagof(t0, a0) 1085 %bieq(t0, %TAG.SYM, &.sym, t1) 1086 %bieq(t0, %TAG.PAIR, &.pair, t1) 1087 # FIXNUM, HEAP, IMM all self-evaluate. 1088 %gceret 1089 1090 :.sym 1091 # Walk the env alist. Each cell is ((sym . val) . rest). On hit, 1092 # return cdr(binding); on NIL, fall back to the symbol's global slot. 1093 # a0 still holds the tagged sym; a1 still holds env. 1094 :.env_walk 1095 %if_nil(t0, a1, &.env_miss) 1096 %car(t1, a1) ; t1 = (sym . val) 1097 %car(t2, t1) ; t2 = sym in binding 1098 %beq(t2, a0, &.env_hit) 1099 %cdr(a1, a1) 1100 %b(&.env_walk) 1101 1102 :.env_hit 1103 %cdr(a0, t1) 1104 %gceret 1105 1106 :.env_miss 1107 %untag_sym(a0, a0) 1108 %call(&sym_global) 1109 %bieq(a0, %imm_val(%IMM.UNBOUND), &.unbound, t0) 1110 %gceret 1111 1112 :.unbound 1113 %die(msg_unbound) 1114 1115 1116 :.pair 1117 1118 # Special-form dispatch: pointer-compare head against the cached 1119 # special-form symbol values. SYM is a distinct tag, so a head that 1120 # isn't a symbol cannot collide with any sym_* slot. 1121 %ldl(t0, expr) 1122 %car(t0, t0) ; t0 = head 1123 %dispatch_form(&sym_quote, &.do_quote) 1124 %dispatch_form(&sym_if, &.do_if) 1125 %dispatch_form(&sym_lambda, &.do_lambda) 1126 %dispatch_form(&sym_define, &.do_define) 1127 %dispatch_form(&sym_begin, &.do_begin) 1128 %dispatch_form(&sym_cond, &.do_cond) 1129 %dispatch_form(&sym_let, &.do_let) 1130 %dispatch_form(&sym_letstar, &.do_letstar) 1131 %dispatch_form(&sym_let_values, &.do_let_values) 1132 %dispatch_form(&sym_letstar_values, &.do_letstar_values) 1133 %dispatch_form(&sym_and, &.do_and) 1134 %dispatch_form(&sym_or, &.do_or) 1135 %dispatch_form(&sym_when, &.do_when) 1136 %dispatch_form(&sym_case, &.do_case) 1137 %dispatch_form(&sym_setbang, &.do_setbang) 1138 %dispatch_form(&sym_define_record_type, &.do_define_record_type) 1139 %dispatch_form(&sym_pmatch, &.do_pmatch) 1140 %dispatch_form(&sym_do, &.do_do) 1141 1142 # Apply car to cdr 1143 # fn = eval(car(expr), env) 1144 %ldl(a0, expr) 1145 %car(a0, a0) 1146 %ldl(a1, env) 1147 %call(&eval) 1148 %stl(a0, fn) 1149 # args = eval_args(cdr(expr), env) 1150 %ldl(a0, expr) 1151 %cdr(a0, a0) 1152 %ldl(a1, env) 1153 %call(&eval_args) 1154 # apply(fn, args) -- tail call 1155 %mov(a1, a0) 1156 %ldl(a0, fn) 1157 %gctail(&apply) 1158 1159 :.do_quote 1160 %tail_to_handler(&eval_quote) 1161 :.do_if 1162 %tail_to_handler(&eval_if) 1163 :.do_lambda 1164 %tail_to_handler(&eval_lambda) 1165 :.do_define 1166 %tail_to_handler(&eval_define) 1167 :.do_begin 1168 %tail_to_handler(&eval_body) 1169 :.do_cond 1170 %tail_to_handler(&eval_cond) 1171 :.do_let 1172 %tail_to_handler(&eval_let) 1173 :.do_letstar 1174 %tail_to_handler(&eval_letstar) 1175 :.do_let_values 1176 %tail_to_handler(&eval_let_values) 1177 :.do_letstar_values 1178 %tail_to_handler(&eval_letstar_values) 1179 :.do_and 1180 %tail_to_handler(&eval_and) 1181 :.do_or 1182 %tail_to_handler(&eval_or) 1183 :.do_when 1184 %tail_to_handler(&eval_when) 1185 :.do_case 1186 %tail_to_handler(&eval_case) 1187 :.do_setbang 1188 %tail_to_handler(&eval_setbang) 1189 :.do_define_record_type 1190 %tail_to_handler(&eval_define_record_type) 1191 :.do_pmatch 1192 %tail_to_handler(&eval_pmatch) 1193 :.do_do 1194 %tail_to_handler(&eval_do) 1195 }) 1196 1197 # eval_args(args=a0, env=a1) -> evaluated args list (cons-built). 1198 # Iterative head/tail-cdr build: each iteration evals one arg, allocates 1199 # a (val . NIL) cell, and either seeds head/tail or set-cdr!s onto the 1200 # previous tail. Host stack stays O(1) regardless of arg-list length; 1201 # eval order is left-to-right. 1202 # 1203 # Locals: 1204 # args (advances) 1205 # env 1206 # head (NIL until first val is appended) 1207 # tail (most recent cell; set-cdr! target) 1208 %gcfn2(eval_args, {args env head tail}, 15, 0, { 1209 %stl(a0, args) 1210 %stl(a1, env) 1211 %li(t0, %imm_val(%IMM.NIL)) 1212 %stl(t0, head) 1213 %stl(t0, tail) 1214 1215 :.loop 1216 %ldl(t0, args) 1217 %if_nil(t1, t0, &.done) 1218 1219 # val = eval(car(args), env) 1220 %car(a0, t0) 1221 %ldl(a1, env) 1222 %call(&eval) 1223 1224 # cell = cons(val, NIL); append to head/tail. 1225 %li(a1, %imm_val(%IMM.NIL)) 1226 %call(&cons) 1227 1228 %ldl(t0, head) 1229 %if_nil(t1, t0, &.first) 1230 %ldl(t0, tail) 1231 %set_cdr(a0, t0) 1232 %stl(a0, tail) 1233 %b(&.advance) 1234 1235 :.first 1236 %stl(a0, head) 1237 %stl(a0, tail) 1238 1239 :.advance 1240 %advance_walk(args) 1241 %b(&.loop) 1242 :.done 1243 1244 %ldl(a0, head) 1245 }) 1246 1247 1248 # apply(fn=a0, args=a1) -> result (a0) 1249 # 1250 # Locals: 1251 # args 1252 # body (saved across bind_params for the closure path) 1253 %gcfn2(apply, {args body}, 3, 0, { 1254 %stl(a1, args) 1255 1256 %hdr_type(t0, a0) 1257 %bieq(t0, %HDR.PRIM, &.prim, t1) 1258 %bieq(t0, %HDR.CLOSURE, &.closure, t1) 1259 1260 :.prim 1261 # Primitive calling convention: 1262 # a0 = args list (proper list of evaluated args) 1263 # a1 = the PRIM object itself (HEAP-tagged) 1264 # Parameterized PRIMs (e.g. the per-field record accessors built 1265 # by define-record-type) read their closed-over datum from 1266 # a1+13. Plain PRIMs ignore a1. A primitive that needs a1 as a 1267 # working register must save it first; this convention is shared 1268 # across every entry in prim_table and is not negotiable per 1269 # primitive. prim_apply_entry maintains the same contract when it 1270 # tail-calls back into apply. 1271 %mov(a1, a0) 1272 %heap_ld(t0, a0, %PRIM.entry_w) 1273 %ldl(a0, args) 1274 %gctailr(t0) 1275 1276 :.closure 1277 # Closure layout (HEAP-tagged): [hdr][params][body][env] 1278 %heap_ld(t0, a0, %CLOSURE.params) 1279 %heap_ld(t1, a0, %CLOSURE.body) 1280 %heap_ld(t2, a0, %CLOSURE.env) 1281 %stl(t1, body) ; persist body past bind_params 1282 1283 # bind_params(params, args, env) 1284 %mov(a0, t0) 1285 %ldl(a1, args) 1286 %mov(a2, t2) 1287 %call(&bind_params) 1288 1289 # eval_body(body, new_env) -- tail call 1290 %mov(a1, a0) 1291 %ldl(a0, body) 1292 %gctail(&eval_body) 1293 }) 1294 1295 # ========================================================================= 1296 # Special forms 1297 # ========================================================================= 1298 # 1299 # intern_special_forms runs at startup, before register_primitives, so 1300 # the symbols `if`, ... occupy the first sym_idx slots (per LISP-C.md 1301 # §Reservation convention). For now we just cache each one's tagged 1302 # value in a labeled slot; eval's pair branch compares head against 1303 # these slots before falling through to ordinary application. 1304 1305 %fn(intern_special_forms, 0, { 1306 %intern_form(quote, "quote", &sym_quote) 1307 %intern_form(if, "if", &sym_if) 1308 %intern_form(lambda, "lambda", &sym_lambda) 1309 %intern_form(define, "define", &sym_define) 1310 %intern_form(begin, "begin", &sym_begin) 1311 %intern_form(cond, "cond", &sym_cond) 1312 %intern_form(else, "else", &sym_else) 1313 %intern_form(arrow, "=>", &sym_arrow) 1314 %intern_form(let, "let", &sym_let) 1315 %intern_form(letstar, "let*", &sym_letstar) 1316 %intern_form(let_values, "let-values", &sym_let_values) 1317 %intern_form(letstar_values, "let*-values", &sym_letstar_values) 1318 %intern_form(and, "and", &sym_and) 1319 %intern_form(or, "or", &sym_or) 1320 %intern_form(when, "when", &sym_when) 1321 %intern_form(case, "case", &sym_case) 1322 %intern_form(setbang, "set!", &sym_setbang) 1323 %intern_form(define_record_type, "define-record-type", &sym_define_record_type) 1324 %intern_form(pmatch, "pmatch", &sym_pmatch) 1325 %intern_form(do, "do", &sym_do) 1326 %intern_form(unquote, "unquote", &sym_unquote) 1327 %intern_form(guard, "guard", &sym_guard) 1328 %intern_form(underscore, "_", &sym_underscore) 1329 %intern_form(dollar, "$", &sym_dollar) 1330 }) 1331 1332 # eval_quote(rest=a0, env=a1) -> value (a0). rest is (datum); return datum. 1333 %fn(eval_quote, 0, { 1334 %car(a0, a0) 1335 }) 1336 1337 # eval_if(rest=a0, env=a1) -> value (a0). `rest` is (test then) or 1338 # (test then else). Single-arm form returns UNSPEC when test is #f. 1339 # No arity check beyond that -- spec policy: malformed special forms 1340 # are UB. 1341 # 1342 # Locals: 1343 # rest 1344 # env 1345 %gcfn2(eval_if, {rest env}, 3, 0, { 1346 %stl(a0, rest) 1347 %stl(a1, env) 1348 1349 # val = eval(car(rest), env) 1350 %car(a0, a0) 1351 %call(&eval) 1352 1353 %bieq(a0, %imm_val(%IMM.FALSE), &.else_branch, t0) 1354 1355 # then-branch: tail-eval(cadr(rest), env) 1356 %ldl(a0, rest) 1357 %cdr(a0, a0) 1358 %car(a0, a0) 1359 %ldl(a1, env) 1360 %gctail(&eval) 1361 1362 :.else_branch 1363 # If cddr(rest) is NIL, this is single-arm `if` -> UNSPEC. 1364 %ldl(t0, rest) 1365 %cdr(t0, t0) 1366 %cdr(t0, t0) 1367 %if_nil(t1, t0, &.no_else) 1368 1369 # else-branch: tail-eval(car(cddr(rest)), env) 1370 %car(a0, t0) 1371 %ldl(a1, env) 1372 %gctail(&eval) 1373 1374 :.no_else 1375 %li(a0, %imm_val(%IMM.UNSPEC)) 1376 }) 1377 1378 # eval_lambda(rest=a0, env=a1) -> closure (a0). 1379 # rest is (params . body). Allocates a 32-byte CLOSURE on the heap 1380 # and stores params, body, and the captured env directly. 1381 # 1382 # Locals: 1383 # rest 1384 # env 1385 # closure ptr (HEAP-tagged) 1386 %gcfn2(eval_lambda, {rest env closure}, 7, 0, { 1387 %stl(a0, rest) 1388 %stl(a1, env) 1389 1390 %li(a0, %CLOSURE.SIZE) 1391 %li(a1, %HDR.CLOSURE) 1392 %call(&alloc_hdr) 1393 %stl(a0, closure) 1394 1395 # closure[params] = car(rest) 1396 %ldl(t0, rest) 1397 %car(t1, t0) 1398 %ldl(t0, closure) 1399 %heap_st(t1, t0, %CLOSURE.params) 1400 1401 # closure[body] = cdr(rest) 1402 %ldl(t1, rest) 1403 %cdr(t1, t1) 1404 %heap_st(t1, t0, %CLOSURE.body) 1405 1406 # closure[env] = captured env 1407 %ldl(t1, env) 1408 %heap_st(t1, t0, %CLOSURE.env) 1409 1410 %ldl(a0, closure) 1411 }) 1412 1413 # eval_define(rest=a0, env=a1) -> UNSPEC (a0). 1414 # Top-level only. Two surface forms: 1415 # (define <sym> <expr>) ; head of rest is a SYM 1416 # (define (<sym> . <params>) . body) ; head of rest is a PAIR; sugar for 1417 # (define <sym> (lambda <params> . body)) 1418 # Internal `define` is rejected by eval_body before this entry is reached 1419 # (every internal body context routes through eval_body); see the check 1420 # at the head of eval_body's loop. 1421 # 1422 # Locals: 1423 # rest 1424 # env 1425 %gcfn2(eval_define, {rest env}, 3, 0, { 1426 %stl(a0, rest) 1427 %stl(a1, env) 1428 1429 # If car(rest) is a pair, this is the lambda-sugar form. 1430 %car(t0, a0) 1431 %tagof(t1, t0) 1432 %bieq(t1, %TAG.PAIR, &.sugar, t2) 1433 1434 # Plain define: value = eval(car(cdr(rest)), env) 1435 %ldl(t0, rest) 1436 %cdr(a0, t0) 1437 %car(a0, a0) 1438 %ldl(a1, env) 1439 %call(&eval) 1440 1441 %ldl(t0, rest) 1442 %car(t0, t0) 1443 %set_global(t0, a0) 1444 %li(a0, %imm_val(%IMM.UNSPEC)) 1445 %gceret 1446 1447 :.sugar 1448 # rest = ((name . params) . body); build (params . body) for eval_lambda. 1449 %ldl(t0, rest) 1450 %car(t0, t0) 1451 %cdr(a0, t0) ; params 1452 %ldl(t0, rest) 1453 %cdr(a1, t0) ; body 1454 %call(&cons) 1455 %ldl(a1, env) 1456 %call(&eval_lambda) 1457 1458 %ldl(t0, rest) 1459 %car(t0, t0) 1460 %car(t0, t0) ; name 1461 %set_global(t0, a0) 1462 %li(a0, %imm_val(%IMM.UNSPEC)) 1463 }) 1464 1465 # eval_setbang(rest=a0, env=a1) -> UNSPEC (a0). 1466 # rest = (sym value-expr). Evaluates value-expr in env, then walks the 1467 # env alist looking for a binding cell whose car is the target sym; 1468 # on hit, mutates the cell's cdr (offset 7, same as set-cdr!). On miss, 1469 # falls back to the global slot via sym_set_global -- the shape used 1470 # by define for top-level rebind. Spec: behavior on a truly unbound 1471 # name follows the primitive-failure policy. 1472 # 1473 # Locals: 1474 # rest (sym . (value-expr . ())) 1475 # env 1476 # saved value (eval'd value-expr) 1477 %gcfn2(eval_setbang, {rest env saved}, 7, 0, { 1478 %stl(a0, rest) 1479 %stl(a1, env) 1480 1481 # value = eval(cadr(rest), env) 1482 %cdr(a0, a0) 1483 %car(a0, a0) 1484 %ldl(a1, env) 1485 %call(&eval) 1486 %stl(a0, saved) 1487 1488 # Walk env looking for a binding cell whose car == target sym. 1489 # Only t0..t2 are available: t0 scratch, t1 target sym, t2 env cursor. 1490 %ldl(t1, rest) 1491 %car(t1, t1) ; target sym 1492 1493 :.loop 1494 %ldl(t2, env) 1495 %if_nil(t0, t2, &.miss) 1496 %car(t0, t2) 1497 %car(t0, t0) ; cell sym 1498 %beq(t0, t1, &.hit) 1499 %cdr(t2, t2) 1500 %stl(t2, env) 1501 %b(&.loop) 1502 1503 :.hit 1504 %car(t0, t2) ; re-fetch binding cell 1505 %ldl(a0, saved) 1506 %set_cdr(a0, t0) ; mutate cell's cdr 1507 %li(a0, %imm_val(%IMM.UNSPEC)) 1508 %gceret 1509 1510 :.miss 1511 # Miss: rebind global. 1512 %ldl(a0, saved) 1513 %ldl(t0, rest) 1514 %car(t0, t0) 1515 %set_global(t0, a0) 1516 %li(a0, %imm_val(%IMM.UNSPEC)) 1517 }) 1518 1519 # eval_cond(clauses=a0, env=a1) -> value (a0). 1520 # Clause shapes: (else body...), (test body...), (test => proc-expr). 1521 # else / => are literal symbols matched by pointer equality. The => 1522 # arrow is only recognized in non-else clauses; an empty body after a 1523 # truthy test returns UNSPEC (spec policy: malformed-form UB). 1524 # 1525 # Locals: 1526 # clauses (advances) 1527 # env 1528 # test value (live across the => eval/cons calls) 1529 # proc (live across the => cons call) 1530 %gcfn2(eval_cond, {clauses env test proc}, 15, 0, { 1531 %stl(a0, clauses) 1532 %stl(a1, env) 1533 1534 :.loop 1535 %ldl(t0, clauses) 1536 %if_nil(t1, t0, &.no_match) 1537 1538 %car(t1, t0) ; clause 1539 %car(t2, t1) ; test_expr 1540 1541 %ld_global(a0, &sym_else) 1542 %beq(t2, a0, &.else_clause) 1543 1544 %mov(a0, t2) 1545 %ldl(a1, env) 1546 %call(&eval) 1547 %li(t0, %imm_val(%IMM.FALSE)) 1548 %beq(a0, t0, &.next) 1549 1550 # Truthy. Spill test value and inspect cdr(clause): empty -> UNSPEC, 1551 # car == => -> arrow path, else regular body. 1552 %stl(a0, test) 1553 %ldl(t0, clauses) 1554 %car(t0, t0) 1555 %cdr(t0, t0) 1556 %if_nil(t1, t0, &.no_match) 1557 %car(t1, t0) 1558 %ld_global(t2, &sym_arrow) 1559 %beq(t1, t2, &.arrow) 1560 1561 %mov(a0, t0) ; regular body 1562 %ldl(a1, env) 1563 %gctail(&eval_body) 1564 1565 :.arrow 1566 %cdr(t0, t0) 1567 %car(a0, t0) ; proc-expr 1568 %ldl(a1, env) 1569 %call(&eval) 1570 %stl(a0, proc) 1571 %ldl(a0, test) 1572 %li(a1, %imm_val(%IMM.NIL)) 1573 %call(&cons) 1574 %mov(a1, a0) 1575 %ldl(a0, proc) 1576 %gctail(&apply) 1577 1578 :.else_clause 1579 %ldl(t0, clauses) 1580 %car(t0, t0) 1581 %cdr(a0, t0) 1582 %ldl(a1, env) 1583 %gctail(&eval_body) 1584 1585 :.next 1586 %advance_walk(clauses) 1587 %b(&.loop) 1588 1589 :.no_match 1590 %li(a0, %imm_val(%IMM.UNSPEC)) 1591 }) 1592 1593 # eval_let(rest=a0, env=a1) -> value (a0). 1594 # Two surface forms: 1595 # (let ((p v) ...) body...) 1596 # (let name ((p v) ...) body...) ; named let, dispatches to eval_let_named 1597 # Standard `let` evaluates every init in `env`, then extends env with all 1598 # bindings simultaneously and tail-evaluates the body. 1599 # 1600 # Locals: 1601 # rest 1602 # env (original) 1603 # walk (bindings, advances) 1604 # new_env (built up) 1605 %gcfn2(eval_let, {rest env walk new_env}, 15, 0, { 1606 %stl(a0, rest) 1607 %stl(a1, env) 1608 1609 # Named let? 1610 %car(t0, a0) 1611 %tagof(t1, t0) 1612 %bieq(t1, %TAG.SYM, &.named, t2) 1613 1614 %ldl(t0, rest) 1615 %car(t0, t0) ; bindings 1616 %stl(t0, walk) 1617 %ldl(t0, env) 1618 %stl(t0, new_env) ; new_env = env 1619 1620 :.loop 1621 %ldl(t0, walk) 1622 %if_nil(t1, t0, &.done) 1623 1624 %car(t1, t0) ; pair = (name init) 1625 %cdr(t2, t1) 1626 %car(t2, t2) ; init 1627 1628 # val = eval(init, env_orig) 1629 %mov(a0, t2) 1630 %ldl(a1, env) 1631 %call(&eval) 1632 1633 # binding = cons(name, val) 1634 %ldl(t0, walk) 1635 %car(t1, t0) 1636 %car(t2, t1) 1637 %mov(a1, a0) 1638 %mov(a0, t2) 1639 %call(&cons) 1640 1641 # new_env = cons(binding, new_env) 1642 %ldl(a1, new_env) 1643 %call(&cons) 1644 %stl(a0, new_env) 1645 1646 %advance_walk(walk) 1647 %b(&.loop) 1648 1649 :.done 1650 %ldl(a0, rest) 1651 %cdr(a0, a0) ; body 1652 %ldl(a1, new_env) 1653 %gctail(&eval_body) 1654 1655 :.named 1656 %ldl(a0, rest) 1657 %ldl(a1, env) 1658 %gctail(&eval_let_named) 1659 }) 1660 1661 # eval_letstar(rest=a0, env=a1) -> value (a0). 1662 # Like let, but each init is evaluated in the env extended by all prior 1663 # bindings of the same let* form (left-to-right shadowing). 1664 # 1665 # Locals: 1666 # rest 1667 # env 1668 # walk 1669 # new_env 1670 %gcfn2(eval_letstar, {rest env walk new_env}, 15, 0, { 1671 %stl(a0, rest) 1672 %stl(a1, env) 1673 1674 %ldl(t0, rest) 1675 %car(t0, t0) 1676 %stl(t0, walk) 1677 %ldl(t0, env) 1678 %stl(t0, new_env) 1679 1680 :.loop 1681 %ldl(t0, walk) 1682 %if_nil(t1, t0, &.done) 1683 1684 %car(t1, t0) 1685 %cdr(t2, t1) 1686 %car(t2, t2) 1687 1688 # val = eval(init, new_env) 1689 %mov(a0, t2) 1690 %ldl(a1, new_env) 1691 %call(&eval) 1692 1693 %ldl(t0, walk) 1694 %car(t1, t0) 1695 %car(t2, t1) 1696 %mov(a1, a0) 1697 %mov(a0, t2) 1698 %call(&cons) 1699 1700 %ldl(a1, new_env) 1701 %call(&cons) 1702 %stl(a0, new_env) 1703 1704 %advance_walk(walk) 1705 %b(&.loop) 1706 :.done 1707 1708 %ldl(a0, rest) 1709 %cdr(a0, a0) 1710 %ldl(a1, new_env) 1711 %gctail(&eval_body) 1712 }) 1713 1714 # eval_let_values(rest=a0, env=a1) -> value (a0). 1715 # rest = (((formals init) ...) body...). Each init is evaluated in the 1716 # OUTER env; mv_to_list normalizes its result so bind_params can drive 1717 # both list-style and dotted/rest formals identically. Then bodies run 1718 # in the env extended by all clauses. 1719 # 1720 # Locals: 1721 # rest 1722 # env (original) 1723 # walk (clauses, advances) 1724 # new_env (built up) 1725 %gcfn2(eval_let_values, {rest env walk new_env}, 15, 0, { 1726 %stl(a0, rest) 1727 %stl(a1, env) 1728 1729 %ldl(t0, rest) 1730 %car(t0, t0) ; clauses 1731 %stl(t0, walk) 1732 %ldl(t0, env) 1733 %stl(t0, new_env) ; new_env = env 1734 1735 :.loop 1736 %ldl(t0, walk) 1737 %if_nil(t1, t0, &.done) 1738 1739 %car(t1, t0) ; clause = (formals init) 1740 %cdr(t2, t1) 1741 %car(t2, t2) ; init 1742 1743 # val = eval(init, env_orig) 1744 %mov(a0, t2) 1745 %ldl(a1, env) 1746 %call(&eval) 1747 1748 # vals = mv_to_list(val) 1749 %call(&mv_to_list) 1750 1751 # new_env = bind_params(formals, vals, new_env) 1752 %ldl(t0, walk) 1753 %car(t1, t0) 1754 %car(t1, t1) ; formals 1755 %mov(a1, a0) 1756 %mov(a0, t1) 1757 %ldl(a2, new_env) 1758 %call(&bind_params) 1759 %stl(a0, new_env) 1760 1761 %advance_walk(walk) 1762 %b(&.loop) 1763 :.done 1764 1765 %ldl(a0, rest) 1766 %cdr(a0, a0) ; body 1767 %ldl(a1, new_env) 1768 %gctail(&eval_body) 1769 }) 1770 1771 # eval_letstar_values(rest=a0, env=a1) -> value (a0). 1772 # Like let-values but each init is evaluated in new_env (the env extended 1773 # by all prior clauses' bindings), giving sequential / shadowing semantics. 1774 # 1775 # Locals: 1776 # rest 1777 # env 1778 # walk 1779 # new_env 1780 %gcfn2(eval_letstar_values, {rest env walk new_env}, 15, 0, { 1781 %stl(a0, rest) 1782 %stl(a1, env) 1783 1784 %ldl(t0, rest) 1785 %car(t0, t0) 1786 %stl(t0, walk) 1787 %ldl(t0, env) 1788 %stl(t0, new_env) 1789 1790 :.loop 1791 %ldl(t0, walk) 1792 %if_nil(t1, t0, &.done) 1793 1794 %car(t1, t0) 1795 %cdr(t2, t1) 1796 %car(t2, t2) ; init 1797 1798 # val = eval(init, new_env) 1799 %mov(a0, t2) 1800 %ldl(a1, new_env) 1801 %call(&eval) 1802 1803 %call(&mv_to_list) 1804 1805 %ldl(t0, walk) 1806 %car(t1, t0) 1807 %car(t1, t1) ; formals 1808 %mov(a1, a0) 1809 %mov(a0, t1) 1810 %ldl(a2, new_env) 1811 %call(&bind_params) 1812 %stl(a0, new_env) 1813 1814 %advance_walk(walk) 1815 %b(&.loop) 1816 :.done 1817 1818 %ldl(a0, rest) 1819 %cdr(a0, a0) 1820 %ldl(a1, new_env) 1821 %gctail(&eval_body) 1822 }) 1823 1824 # eval_and(rest=a0, env=a1) -> value (a0). 1825 # (and) is #t. Otherwise eval forms left-to-right, short-circuiting to #f 1826 # the moment one yields #f. The last form is tail-evaluated so a tail call 1827 # inside `and` doesn't grow the host stack. 1828 # 1829 # Locals: 1830 # rest 1831 # env 1832 %gcfn2(eval_and, {rest env}, 3, 0, { 1833 %li(t0, %imm_val(%IMM.TRUE)) 1834 %if_nil(t1, a0, &.done_imm) 1835 1836 :.loop 1837 %stl(a0, rest) 1838 %stl(a1, env) 1839 1840 # If cdr(rest) is NIL, the head is the last form -> tail-eval. 1841 %cdr(t0, a0) 1842 %if_nil(t1, t0, &.last) 1843 1844 # Non-last: eval, short-circuit on #f, otherwise advance. 1845 %car(a0, a0) 1846 %call(&eval) 1847 %li(t0, %imm_val(%IMM.FALSE)) 1848 %beq(a0, t0, &.done) 1849 %ldl(a0, rest) 1850 %cdr(a0, a0) 1851 %ldl(a1, env) 1852 %b(&.loop) 1853 1854 :.last 1855 %ldl(a0, rest) 1856 %car(a0, a0) 1857 %ldl(a1, env) 1858 %gctail(&eval) 1859 :.done 1860 1861 %gceret 1862 1863 :.done_imm 1864 %mov(a0, t0) 1865 }) 1866 1867 # eval_or(rest=a0, env=a1) -> value (a0). 1868 # (or) is #f. Otherwise eval forms left-to-right and return the first 1869 # non-#f value; if every form was #f, return #f. The last form is 1870 # tail-evaluated. 1871 # 1872 # Locals: 1873 # rest 1874 # env 1875 %gcfn2(eval_or, {rest env}, 3, 0, { 1876 %li(t0, %imm_val(%IMM.FALSE)) 1877 %if_nil(t1, a0, &.done_imm) 1878 1879 :.loop 1880 %stl(a0, rest) 1881 %stl(a1, env) 1882 1883 %cdr(t0, a0) 1884 %if_nil(t1, t0, &.last) 1885 1886 %car(a0, a0) 1887 %call(&eval) 1888 %bine(a0, %imm_val(%IMM.FALSE), &.done, t0) 1889 %ldl(a0, rest) 1890 %cdr(a0, a0) 1891 %ldl(a1, env) 1892 %b(&.loop) 1893 1894 :.last 1895 %ldl(a0, rest) 1896 %car(a0, a0) 1897 %ldl(a1, env) 1898 %gctail(&eval) 1899 :.done 1900 1901 %gceret 1902 1903 :.done_imm 1904 %mov(a0, t0) 1905 }) 1906 1907 # eval_when(rest=a0, env=a1) -> value (a0). 1908 # (when test body...) -- if test evaluates non-#f, tail-eval body and 1909 # return its last value; otherwise return UNSPEC. Body never enters a 1910 # new scope. 1911 # 1912 # Locals: 1913 # rest 1914 # env 1915 %gcfn2(eval_when, {rest env}, 3, 0, { 1916 %stl(a0, rest) 1917 %stl(a1, env) 1918 1919 %car(a0, a0) ; test 1920 %call(&eval) 1921 1922 %bieq(a0, %imm_val(%IMM.FALSE), &.skip, t0) 1923 1924 %ldl(a0, rest) 1925 %cdr(a0, a0) ; body 1926 %ldl(a1, env) 1927 %gctail(&eval_body) 1928 1929 :.skip 1930 %li(a0, %imm_val(%IMM.UNSPEC)) 1931 }) 1932 1933 # eval_case(rest=a0, env=a1) -> value (a0). 1934 # rest is (key-expr clause...). The key is evaluated once; clauses are 1935 # tried in order. Clause shape: 1936 # ((datum...) body...) ; datums are literal, eq?-compared to key 1937 # (else body...) ; matches unconditionally 1938 # Matching uses pointer equality (eq?), which is correct for fixnums, 1939 # symbols, chars, and booleans -- the values case is meant for. The 1940 # matched clause's body is tail-evaluated via eval_body. No-match (and 1941 # no else) returns UNSPEC, mirroring eval_cond's no-match policy. 1942 # 1943 # Locals: 1944 # subject (evaluated key) 1945 # env 1946 # clauses (advances) 1947 # datums (advances within a clause) 1948 %gcfn2(eval_case, {subject env clauses datums}, 15, 0, { 1949 %stl(a1, env) 1950 1951 # subject = eval(car(rest), env); clauses = cdr(rest). 1952 %mov(t0, a0) 1953 %cdr(t1, t0) 1954 %stl(t1, clauses) 1955 %car(a0, t0) 1956 %ldl(a1, env) 1957 %call(&eval) 1958 %stl(a0, subject) 1959 1960 :.loop 1961 %ldl(t0, clauses) 1962 %if_nil(t1, t0, &.no_match) 1963 1964 %car(t1, t0) ; clause 1965 %car(t2, t1) ; head: datum-list or `else` 1966 1967 %ld_global(a3, &sym_else) 1968 %beq(t2, a3, &.do_else) 1969 1970 # Walk the datum list, eq?-compare each against subject. 1971 %stl(t2, datums) 1972 %ldl(a0, subject) 1973 :.scan 1974 %ldl(t0, datums) 1975 %if_nil(t1, t0, &.next_clause) 1976 %car(t1, t0) ; datum 1977 %beq(t1, a0, &.do_body) 1978 %cdr(t0, t0) 1979 %stl(t0, datums) 1980 %b(&.scan) 1981 1982 :.do_body 1983 %ldl(t0, clauses) 1984 %car(t0, t0) 1985 %cdr(a0, t0) ; body 1986 %ldl(a1, env) 1987 %gctail(&eval_body) 1988 1989 :.do_else 1990 %ldl(t0, clauses) 1991 %car(t0, t0) 1992 %cdr(a0, t0) ; body 1993 %ldl(a1, env) 1994 %gctail(&eval_body) 1995 1996 :.next_clause 1997 %ldl(t0, clauses) 1998 %cdr(t0, t0) 1999 %stl(t0, clauses) 2000 %b(&.loop) 2001 2002 :.no_match 2003 %li(a0, %imm_val(%IMM.UNSPEC)) 2004 }) 2005 2006 # eval_pmatch(rest=a0, env=a1) -> value (a0). 2007 # rest is (subject-expr . clauses). The subject is evaluated once; each 2008 # clause is then tried in order against the same subject value, restarting 2009 # from the outer env per clause. Clause shape: 2010 # (<pat> <body>...) 2011 # (<pat> (guard <g>...) <body>...) 2012 # (else <body>...) 2013 # An `else` clause always matches with no bindings; a guarded clause is 2014 # selected only if every guard expression evaluates non-#f. The matched 2015 # clause's body is tail-evaluated via eval_body so the last form keeps 2016 # tail position. No-match (and no else) dies via runtime_error. 2017 # 2018 # Locals: 2019 # subject 2020 # env_outer (per-clause restart point) 2021 # clauses (current cursor; advances on miss / failed guard) 2022 # env_ext (env extended with the matched clause's bindings) 2023 # guard cursor (advances during the guard AND-fold) 2024 # body (saved across guard evals, tail-evaluated on success) 2025 %gcfn2(eval_pmatch, {subject env_outer clauses env_ext guard body}, 63, 0, { 2026 %stl(a1, env_outer) 2027 2028 # subject = eval(car(rest), env_outer); clauses = cdr(rest). 2029 %mov(t0, a0) 2030 %cdr(t1, t0) 2031 %stl(t1, clauses) 2032 %car(a0, t0) 2033 %ldl(a1, env_outer) 2034 %call(&eval) 2035 %stl(a0, subject) 2036 2037 :.loop 2038 %ldl(t0, clauses) 2039 %if_nil(t1, t0, &.no_match) 2040 2041 %car(t1, t0) ; clause 2042 %car(t2, t1) ; pat 2043 2044 %ld_global(a3, &sym_else) 2045 %beq(t2, a3, &.do_else) 2046 2047 # pmatch_match(pat, subject, env_outer) -> (a0=env_ext, a1=ok) 2048 %mov(a0, t2) 2049 %ldl(a1, subject) 2050 %ldl(a2, env_outer) 2051 %call(&pmatch_match) 2052 %beqz(a1, &.next) 2053 2054 %stl(a0, env_ext) ; env_ext 2055 2056 # tail = cdr(clause) 2057 %ldl(t0, clauses) 2058 %car(t0, t0) 2059 %cdr(t0, t0) ; tail = (body...) or ((guard ...) body...) 2060 2061 # Guard form? tail is a pair, car(tail) is a pair, head of car(tail) 2062 # eq? sym_guard. 2063 %tagof(t1, t0) 2064 %bine(t1, %TAG.PAIR, &.body_simple, t2) 2065 %car(t1, t0) ; first form of tail 2066 %tagof(t2, t1) 2067 %bine(t2, %TAG.PAIR, &.body_simple, a0) 2068 %car(a0, t1) ; head of first form 2069 %ld_global(a1, &sym_guard) 2070 %bne(a0, a1, &.body_simple) 2071 2072 # Guard clause. guards = cdr(car(tail)); body = cdr(tail). 2073 %cdr(a0, t1) 2074 %stl(a0, guard) 2075 %cdr(t0, t0) 2076 %stl(t0, body) 2077 2078 :.g_loop 2079 %ldl(t0, guard) 2080 %if_nil(t1, t0, &.body_run) 2081 2082 %car(a0, t0) ; guard expr 2083 %ldl(a1, env_ext) ; env_ext 2084 %call(&eval) 2085 %bieq(a0, %imm_val(%IMM.FALSE), &.next, t0) 2086 2087 %ldl(t0, guard) 2088 %cdr(t0, t0) 2089 %stl(t0, guard) 2090 %b(&.g_loop) 2091 2092 :.body_run 2093 %ldl(a0, body) 2094 %ldl(a1, env_ext) 2095 %gctail(&eval_body) 2096 2097 :.body_simple 2098 # tail itself is the body (no guard wrapper). Tail-call eval_body 2099 # with the extended env; tail position of the matched clause's body 2100 # is preserved. 2101 %mov(a0, t0) 2102 %ldl(a1, env_ext) 2103 %gctail(&eval_body) 2104 2105 :.do_else 2106 %ldl(t0, clauses) 2107 %car(t0, t0) 2108 %cdr(a0, t0) ; body 2109 %ldl(a1, env_outer) ; env_outer (no bindings introduced) 2110 %gctail(&eval_body) 2111 2112 :.next 2113 %ldl(t0, clauses) 2114 %cdr(t0, t0) 2115 %stl(t0, clauses) 2116 %b(&.loop) 2117 2118 :.no_match 2119 %die(msg_pmatch_no_match) 2120 }) 2121 2122 # eval_do(rest=a0, env=a1) -> value (a0). 2123 # rest = (((var init step?) ...) (test result?...) body...). 2124 # 2125 # Phase 1 (init): walk binding-specs in order, eval each `init` in the 2126 # outer env, build new_env by consing (var . val) pairs onto it. A 2127 # parallel list `pairs_head` records the binding pairs in spec order so 2128 # the iteration can mutate them by set-cdr!. A second parallel list 2129 # `vals_head` is preallocated (one cell per spec) to hold each iteration's 2130 # computed step values without per-iteration cell allocation. 2131 # 2132 # Phase 2 (loop): eval test in new_env. Truthy -> tail-eval result body 2133 # (UNSPEC if no result forms). Falsy -> eval each command form in 2134 # new_env (discard), collect new step values into vals_head (parallel 2135 # semantics: every step is evaluated against the iteration's pre-update 2136 # bindings; specs without a step keep their current value), then walk 2137 # pairs_head/vals_head together and set-cdr! each binding pair to its 2138 # new value. Loop. 2139 # 2140 # Locals: 2141 # rest original rest pointer 2142 # env outer env 2143 # new_env env extended with binding pairs (mutated each iter) 2144 # walk generic cdr-cursor (binding-specs / commands / steps) 2145 # pairs_head list of binding-pair refs in spec order 2146 # pairs_tail append point during init 2147 # vals_head parallel list of cells holding each iteration's step vals 2148 # vals_tail append point during init 2149 # body body command-forms (cddr of rest) 2150 # pair_walk cdr-cursor over pairs_head during step/update 2151 # val_walk cdr-cursor over vals_head during step/update 2152 %gcfn2(eval_do, {rest env new_env walk pairs_head pairs_tail vals_head vals_tail body pair_walk val_walk}, 2047, 0, { 2153 %stl(a0, rest) 2154 %stl(a1, env) 2155 2156 %ldl(t0, rest) 2157 %car(t0, t0) 2158 %stl(t0, walk) 2159 %ldl(t0, env) 2160 %stl(t0, new_env) 2161 %li(t0, %imm_val(%IMM.NIL)) 2162 %stl(t0, pairs_head) 2163 %stl(t0, pairs_tail) 2164 %stl(t0, vals_head) 2165 %stl(t0, vals_tail) 2166 2167 :.init_loop 2168 %ldl(t0, walk) 2169 %if_nil(t1, t0, &.init_done) 2170 2171 # spec = car(walk); init-expr = car(cdr(spec)). 2172 %car(t1, t0) 2173 %cdr(a0, t1) 2174 %car(a0, a0) ; init expression 2175 2176 # val = eval(init, env) 2177 %ldl(a1, env) 2178 %call(&eval) 2179 2180 # binding pair = cons(var, val); var = car(car(walk)). 2181 %ldl(t0, walk) 2182 %car(t1, t0) 2183 %car(t2, t1) ; var 2184 %mov(a1, a0) 2185 %mov(a0, t2) 2186 %call(&cons) ; a0 = binding pair 2187 2188 # new_env = cons(pair, new_env). cons clobbers t0/t1/t2 so we don't 2189 # spill pair into a t-reg; recover it as car(new_env) afterwards. 2190 %ldl(a1, new_env) 2191 %call(&cons) 2192 %stl(a0, new_env) 2193 2194 # pcell = cons(pair, NIL). pair = car(new_env), and a0 still holds 2195 # the new_env list pointer from the cons above. 2196 %car(a0, a0) 2197 %li(a1, %imm_val(%IMM.NIL)) 2198 %call(&cons) 2199 2200 %ldl(t0, pairs_head) 2201 %if_nil(t1, t0, &.pairs_first) 2202 %ldl(t0, pairs_tail) 2203 %set_cdr(a0, t0) 2204 %stl(a0, pairs_tail) 2205 %b(&.vals_alloc) 2206 2207 :.pairs_first 2208 %stl(a0, pairs_head) 2209 %stl(a0, pairs_tail) 2210 2211 :.vals_alloc 2212 # vcell = cons(NIL, NIL). Append onto vals list. 2213 %li(a0, %imm_val(%IMM.NIL)) 2214 %li(a1, %imm_val(%IMM.NIL)) 2215 %call(&cons) 2216 2217 %ldl(t0, vals_head) 2218 %if_nil(t1, t0, &.vals_first) 2219 %ldl(t0, vals_tail) 2220 %set_cdr(a0, t0) 2221 %stl(a0, vals_tail) 2222 %b(&.init_advance) 2223 2224 :.vals_first 2225 %stl(a0, vals_head) 2226 %stl(a0, vals_tail) 2227 2228 :.init_advance 2229 %advance_walk(walk) 2230 %b(&.init_loop) 2231 :.init_done 2232 2233 # body = cddr(rest). 2234 %ldl(t0, rest) 2235 %cdr(t0, t0) 2236 %cdr(t0, t0) 2237 %stl(t0, body) 2238 2239 :.iter_loop 2240 # test = car(car(cdr(rest))). Eval in new_env. 2241 %ldl(t0, rest) 2242 %cdr(t0, t0) 2243 %car(t0, t0) ; (test result?...) 2244 %car(a0, t0) ; test 2245 %ldl(a1, new_env) 2246 %call(&eval) 2247 2248 %bieq(a0, %imm_val(%IMM.FALSE), &.commands, t0) 2249 2250 # Truthy: results = cdr(car(cdr(rest))). 2251 %ldl(t0, rest) 2252 %cdr(t0, t0) 2253 %car(t0, t0) 2254 %cdr(t0, t0) ; results 2255 %if_nil(t1, t0, &.no_results) 2256 %mov(a0, t0) 2257 %ldl(a1, new_env) 2258 %gctail(&eval_body) 2259 2260 :.no_results 2261 %li(a0, %imm_val(%IMM.UNSPEC)) 2262 %gceret 2263 2264 :.commands 2265 %ldl(t0, body) 2266 %stl(t0, walk) 2267 2268 :.cmd_loop 2269 %ldl(t0, walk) 2270 %if_nil(t1, t0, &.step_phase) 2271 %car(a0, t0) 2272 %ldl(a1, new_env) 2273 %call(&eval) 2274 %advance_walk(walk) 2275 %b(&.cmd_loop) 2276 2277 :.step_phase 2278 # Compute new step values. walk = specs, pair_walk = pairs_head, 2279 # val_walk = vals_head. For each spec: if spec has step (cddr non-NIL), 2280 # val = eval(step, new_env); else val = cdr(binding_pair) (current). 2281 # Store val into car(val_walk). 2282 %ldl(t0, rest) 2283 %car(t0, t0) 2284 %stl(t0, walk) 2285 %ldl(t0, pairs_head) 2286 %stl(t0, pair_walk) 2287 %ldl(t0, vals_head) 2288 %stl(t0, val_walk) 2289 2290 :.step_loop 2291 %ldl(t0, walk) 2292 %if_nil(t1, t0, &.update_phase) 2293 2294 %car(t1, t0) ; spec 2295 %cdr(t2, t1) 2296 %cdr(t2, t2) ; (step?) or NIL 2297 %if_nil(t1, t2, &.no_step) 2298 2299 %car(a0, t2) ; step 2300 %ldl(a1, new_env) 2301 %call(&eval) 2302 %b(&.store_val) 2303 2304 :.no_step 2305 %ldl(t0, pair_walk) 2306 %car(t0, t0) ; binding pair 2307 %cdr(a0, t0) ; current val 2308 2309 :.store_val 2310 %ldl(t0, val_walk) 2311 %set_car(a0, t0) 2312 2313 %advance_walk(walk) 2314 %advance_walk(pair_walk) 2315 %advance_walk(val_walk) 2316 %b(&.step_loop) 2317 2318 :.update_phase 2319 # Walk pairs_head and vals_head; set-cdr!(pair, val) for each. 2320 %ldl(t0, pairs_head) 2321 %stl(t0, pair_walk) 2322 %ldl(t0, vals_head) 2323 %stl(t0, val_walk) 2324 2325 :.update_loop 2326 %ldl(t0, pair_walk) 2327 %if_nil(t1, t0, &.iter_loop) 2328 %car(t1, t0) ; binding pair 2329 %ldl(t0, val_walk) 2330 %car(t2, t0) ; new val 2331 %set_cdr(t2, t1) 2332 %advance_walk(pair_walk) 2333 %advance_walk(val_walk) 2334 %b(&.update_loop) 2335 }) 2336 2337 # pmatch_match(pat=a0, subj=a1, env=a2) -> (env=a0, ok=a1) 2338 # 2339 # Walks pat and subj structurally. On success returns the (possibly 2340 # extended) env in a0 and 1 in a1; on failure returns 0 in a1 (a0 is 2341 # undefined and callers must not use it). Pattern shapes: 2342 # 2343 # - pair (car eq? sym_unquote): binder `,ident` or wildcard `,_`. The 2344 # pattern must be exactly (unquote <sym>) — any other shape dies 2345 # with msg_bad_unquote_pattern (the only carve-out from the spec's 2346 # primitive-failure UB policy, since pattern shape is a syntax 2347 # error in the user's source). 2348 # - pair (car eq? sym_dollar): record pattern `($ pred (f1 p1) ...)`. 2349 # Looks up `pred` in the current env; expects a record predicate 2350 # PRIM (the one bound by define-record-type). The TD pulled from 2351 # PRIM.data drives the type check on subj and the field-name -> idx 2352 # lookup. Each clause matches recursively. Listed fields only; 2353 # missing fields are unconstrained. Malformed pattern shape, an 2354 # unknown field name, a non-record subject, or a TD mismatch fall 2355 # through as ::no. 2356 # - pair (otherwise): subj must be a pair; recurse on car, then cdr. 2357 # - atomic (fixnum, sym, immediate, identical heap pointer): raw 2358 # word equality. 2359 # - HEAP-tagged HDR.BV: structural byte-for-byte equality via 2360 # bv_equal_check; only when both pat and subj are HDR.BV. 2361 # 2362 # Locals: 2363 # pat 2364 # subj 2365 # env 2366 # td (record-pattern: TD pulled from the predicate PRIM) 2367 # flw (record-pattern: cursor over remaining (fname pat) clauses) 2368 %gcfn2(pmatch_match, {pat subj env td flw}, 31, 0, { 2369 %stl(a0, pat) 2370 %stl(a1, subj) 2371 %stl(a2, env) 2372 2373 %tagof(t0, a0) 2374 %li(t1, %TAG.PAIR) 2375 %beq(t0, t1, &.pair_pat) 2376 2377 # Atomic pattern. Identity covers fixnum / symbol / immediate / same 2378 # heap pointer. 2379 %beq(a0, a1, &.ok) 2380 2381 # HDR.BV equality. 2382 %bine(t0, %TAG.HEAP, &.no, t1) 2383 %hdr_type(t1, a0) 2384 %bine(t1, %HDR.BV, &.no, t2) 2385 %tagof(t1, a1) 2386 %bine(t1, %TAG.HEAP, &.no, t2) 2387 %hdr_type(t1, a1) 2388 %bine(t1, %HDR.BV, &.no, t2) 2389 %call(&bv_equal_check) 2390 %bieq(a0, %imm_val(%IMM.TRUE), &.ok, t0) 2391 %b(&.no) 2392 2393 :.pair_pat 2394 %car(t0, a0) ; phead 2395 %ld_global(t1, &sym_unquote) 2396 %beq(t0, t1, &.binder) 2397 %ld_global(t1, &sym_dollar) 2398 %beq(t0, t1, &.record_pat) 2399 2400 # Structural pair. subj must be a pair too. 2401 %tagof(t0, a1) 2402 %bine(t0, %TAG.PAIR, &.no, t1) 2403 2404 # Recurse on the cars; on success, recurse on the cdrs as a tail call. 2405 %ldl(t0, pat) 2406 %car(a0, t0) 2407 %ldl(t0, subj) 2408 %car(a1, t0) 2409 %ldl(a2, env) 2410 %call(&pmatch_match) 2411 %beqz(a1, &.no) 2412 2413 %mov(a2, a0) ; env_after_car 2414 %ldl(t0, pat) 2415 %cdr(a0, t0) 2416 %ldl(t0, subj) 2417 %cdr(a1, t0) 2418 %gctail(&pmatch_match) 2419 2420 :.binder 2421 # Validate (unquote <sym>): cdr(pat) is a pair, cdr(cdr(pat)) is NIL, 2422 # car(cdr(pat)) is a symbol. 2423 %ldl(t0, pat) 2424 %cdr(t1, t0) ; cdr(pat) 2425 %tagof(t0, t1) 2426 %bine(t0, %TAG.PAIR, &.bad, t2) 2427 %cdr(t0, t1) ; cdr(cdr(pat)) 2428 %bine(t0, %imm_val(%IMM.NIL), &.bad, t2) 2429 %car(t0, t1) ; pident (kept in t0) 2430 %tagof(t2, t0) 2431 %bine(t2, %TAG.SYM, &.bad, a3) 2432 2433 # Wildcard? Compare against sym_underscore; if so, no binding. 2434 %ld_global(t1, &sym_underscore) 2435 %beq(t0, t1, &.ok) 2436 2437 # Bind: env' = cons(cons(pident, subj), env). pident lives in t0; 2438 # cons clobbers t0..t2, so move it into a0 right away. 2439 %mov(a0, t0) 2440 %ldl(a1, subj) 2441 %call(&cons) 2442 %ldl(a1, env) 2443 %call(&cons) 2444 %li(a1, 1) 2445 %gceret 2446 2447 :.record_pat 2448 # pat = ($ pred-sym (f1 p1) (f2 p2) ...). Resolve pred-sym -> PRIM via 2449 # eval, pull TD from PRIM.data, type-check subj, then iterate the 2450 # (fname pat_i) clauses. Clobbers `pat` local once we begin the loop: 2451 # we stash each pat_i there before recursing so the recursion has the 2452 # right argument and the local stays usable as scratch. 2453 %ldl(t0, pat) 2454 %cdr(t1, t0) ; (pred-sym . clauses) 2455 %tagof(t0, t1) 2456 %bine(t0, %TAG.PAIR, &.no, t2) 2457 %car(t0, t1) ; t0 = pred-sym 2458 %tagof(t2, t0) 2459 %bine(t2, %TAG.SYM, &.no, a3) 2460 %cdr(t2, t1) ; t2 = clauses 2461 %stl(t2, flw) 2462 2463 # eval(pred-sym, env) -> a0 = pred PRIM (or dies "unbound"). 2464 %mov(a0, t0) 2465 %ldl(a1, env) 2466 %call(&eval) 2467 2468 # Verify HEAP / HDR.PRIM, entry == &prim_predicate_entry; extract TD 2469 # from PRIM.data; sanity-check TD is HEAP / HDR.TD. 2470 %tagof(t0, a0) 2471 %bine(t0, %TAG.HEAP, &.no, t1) 2472 %hdr_type(t0, a0) 2473 %bine(t0, %HDR.PRIM, &.no, t1) 2474 %heap_ld(t1, a0, %PRIM.entry_w) 2475 %la(t2, &prim_predicate_entry) 2476 %bne(t1, t2, &.no) 2477 %heap_ld(t1, a0, %PRIM.data) ; t1 = TD 2478 %tagof(t0, t1) 2479 %li(t2, %TAG.HEAP) 2480 %bne(t0, t2, &.no) 2481 %hdr_type(t0, t1) 2482 %li(t2, %HDR.TD) 2483 %bne(t0, t2, &.no) 2484 %stl(t1, td) 2485 2486 # Verify subj is HDR.REC with REC.td == TD. 2487 %ldl(a0, subj) 2488 %tagof(t0, a0) 2489 %li(t1, %TAG.HEAP) 2490 %bne(t0, t1, &.no) 2491 %hdr_type(t0, a0) 2492 %li(t1, %HDR.REC) 2493 %bne(t0, t1, &.no) 2494 %heap_ld(t0, a0, %REC.td) 2495 %ldl(t1, td) 2496 %bne(t0, t1, &.no) 2497 2498 :.record_field_loop 2499 # flw points at remaining (fname pat_i) clauses; NIL ends the loop. 2500 %ldl(t0, flw) 2501 %if_nil(t1, t0, &.ok) 2502 %car(t1, t0) ; t1 = clause 2503 %tagof(t0, t1) 2504 %bine(t0, %TAG.PAIR, &.no, t2) 2505 %car(t2, t1) ; t2 = fname 2506 %cdr(t1, t1) ; t1 = (pat_i) 2507 %tagof(t0, t1) 2508 %bine(t0, %TAG.PAIR, &.no, a3) 2509 %car(a3, t1) ; a3 = pat_i 2510 %stl(a3, pat) ; reuse `pat` local for pat_i across recursion 2511 2512 # Linear scan of TD.fields for fname; idx accumulated in t1. t2 holds 2513 # fname (still live); a3 is scratch (since we no longer need pat_i in 2514 # a register — it's in the local). 2515 %ldl(t0, td) 2516 %heap_ld(t0, t0, %TD.fields) 2517 %li(t1, 0) 2518 :.record_field_idx_loop 2519 %if_nil(a3, t0, &.no) 2520 %car(a3, t0) 2521 %beq(a3, t2, &.record_field_found) 2522 %cdr(t0, t0) 2523 %addi(t1, t1, 1) 2524 %b(&.record_field_idx_loop) 2525 2526 :.record_field_found 2527 # val = ld(subj_tagged + (idx<<3) + 13). Same offset arithmetic as 2528 # prim_accessor_entry. Compute the address into a1 directly so the 2529 # recursive call's val arg is in place. 2530 %ldl(a1, subj) 2531 %shli(t1, t1, 3) 2532 %add(a1, a1, t1) 2533 %ld(a1, a1, 13) 2534 2535 # Recurse: pmatch_match(pat_i, val, env). pat_i is in `pat` local. 2536 %ldl(a0, pat) 2537 %ldl(a2, env) 2538 %call(&pmatch_match) 2539 %beqz(a1, &.no) 2540 %stl(a0, env) 2541 2542 %ldl(t0, flw) 2543 %cdr(t0, t0) 2544 %stl(t0, flw) 2545 %b(&.record_field_loop) 2546 2547 :.ok 2548 %ldl(a0, env) 2549 %li(a1, 1) 2550 %gceret 2551 2552 :.no 2553 %li(a1, 0) 2554 %gceret 2555 2556 :.bad 2557 %die(msg_bad_unquote_pattern) 2558 }) 2559 2560 # eval_let_named(rest=a0, env=a1) -> value (a0). 2561 # rest = (name bindings . body). Builds a closure whose captured env 2562 # contains a self-binding that resolves `name` to the closure itself 2563 # (set after the closure is allocated, via set-cdr! on the placeholder 2564 # pair). Inits are evaluated in the *original* env (matches let 2565 # semantics), then we apply the closure. 2566 # 2567 # Locals: 2568 # rest 2569 # env_orig 2570 # self_binding (the (name . UNSPEC) placeholder, patched at the end) 2571 # self_env (cons(self_binding, env_orig)) 2572 # walk (advances; reset between passes) 2573 # head (current pass's list head — params, then args) 2574 # tail (current pass's list tail) 2575 # params (saved between passes) 2576 %gcfn2(eval_let_named, {rest env_orig self_binding self_env walk head tail params}, 255, 0, { 2577 %stl(a0, rest) 2578 %stl(a1, env_orig) 2579 2580 # 1. self_binding = (name . UNSPEC); self_env = cons(self_binding, env) 2581 %car(t0, a0) 2582 %mov(a0, t0) 2583 %li(a1, %imm_val(%IMM.UNSPEC)) 2584 %call(&cons) 2585 %stl(a0, self_binding) 2586 %ldl(a1, env_orig) 2587 %call(&cons) 2588 %stl(a0, self_env) 2589 2590 # 2. Pass 1: build params list (cdr-tail trick) by walking bindings. 2591 %li(t0, %imm_val(%IMM.NIL)) 2592 %stl(t0, head) 2593 %stl(t0, tail) 2594 %ldl(t0, rest) 2595 %cdr(t0, t0) 2596 %car(t0, t0) ; bindings 2597 %stl(t0, walk) 2598 2599 :.p1_loop 2600 %ldl(t0, walk) 2601 %if_nil(t1, t0, &.p1_done) 2602 2603 %car(t1, t0) 2604 %car(t2, t1) ; name 2605 %mov(a0, t2) 2606 %li(a1, %imm_val(%IMM.NIL)) 2607 %call(&cons) ; cell = (name . NIL) 2608 2609 %ldl(t0, head) 2610 %if_nil(t1, t0, &.p1_first) 2611 %ldl(t0, tail) 2612 %set_cdr(a0, t0) 2613 %stl(a0, tail) 2614 %b(&.p1_advance) 2615 2616 :.p1_first 2617 %stl(a0, head) 2618 %stl(a0, tail) 2619 2620 :.p1_advance 2621 %advance_walk(walk) 2622 %b(&.p1_loop) 2623 2624 :.p1_done 2625 %ldl(t0, head) 2626 %stl(t0, params) ; save params 2627 2628 # 3. Pass 2: build args list (eval inits in env_orig). 2629 %li(t0, %imm_val(%IMM.NIL)) 2630 %stl(t0, head) 2631 %stl(t0, tail) 2632 %ldl(t0, rest) 2633 %cdr(t0, t0) 2634 %car(t0, t0) 2635 %stl(t0, walk) 2636 2637 :.p2_loop 2638 %ldl(t0, walk) 2639 %if_nil(t1, t0, &.p2_done) 2640 2641 %car(t1, t0) 2642 %cdr(t2, t1) 2643 %car(t2, t2) ; init 2644 %mov(a0, t2) 2645 %ldl(a1, env_orig) 2646 %call(&eval) ; val 2647 2648 %li(a1, %imm_val(%IMM.NIL)) 2649 %call(&cons) ; cell = (val . NIL) 2650 2651 %ldl(t0, head) 2652 %if_nil(t1, t0, &.p2_first) 2653 %ldl(t0, tail) 2654 %set_cdr(a0, t0) 2655 %stl(a0, tail) 2656 %b(&.p2_advance) 2657 2658 :.p2_first 2659 %stl(a0, head) 2660 %stl(a0, tail) 2661 2662 :.p2_advance 2663 %advance_walk(walk) 2664 %b(&.p2_loop) 2665 2666 :.p2_done 2667 # 4. Closure: eval_lambda((params . body), self_env). 2668 %ldl(a0, params) ; params 2669 %ldl(t0, rest) 2670 %cdr(t0, t0) 2671 %cdr(a1, t0) ; body 2672 %call(&cons) 2673 %ldl(a1, self_env) 2674 %call(&eval_lambda) 2675 2676 # 5. Patch self_binding cdr to closure. 2677 %ldl(t0, self_binding) 2678 %set_cdr(a0, t0) 2679 2680 # 6. apply(closure, args). 2681 %ldl(a1, head) 2682 %gctail(&apply) 2683 }) 2684 2685 # bind_params(params=a0, args=a1, env=a2) -> extended env (a0). 2686 # Walks params and args in lockstep, prepending (param . arg) to env. 2687 # Variadic `.`-tail: when params terminates with a SYM (rather than NIL), 2688 # bind it to the remaining args list and stop. 2689 # 2690 # Locals: 2691 # params (advanced each iteration) 2692 # args (advanced each iteration) 2693 # env (extended each iteration) 2694 %gcfn2(bind_params, {params args env}, 7, 0, { 2695 %stl(a0, params) 2696 %stl(a1, args) 2697 %stl(a2, env) 2698 2699 :.loop 2700 %ldl(t0, params) 2701 %tagof(t1, t0) 2702 %li(t2, %TAG.PAIR) 2703 %beq(t1, t2, &.pair) 2704 %li(t2, %TAG.SYM) 2705 %beq(t1, t2, &.rest_bind) 2706 %b(&.done) 2707 2708 :.pair 2709 # binding = cons(car(params), car(args)) 2710 %ldl(t0, params) 2711 %car(a0, t0) 2712 %ldl(t0, args) 2713 %car(a1, t0) 2714 %call(&cons) 2715 2716 # env = cons(binding, env) 2717 %ldl(a1, env) 2718 %call(&cons) 2719 %stl(a0, env) 2720 2721 # advance params and args 2722 %advance_walk(params) 2723 %advance_walk(args) 2724 %b(&.loop) 2725 2726 :.rest_bind 2727 # binding = cons(params_sym, args_list); env = cons(binding, env) 2728 %ldl(a0, params) 2729 %ldl(a1, args) 2730 %call(&cons) 2731 %ldl(a1, env) 2732 %call(&cons) 2733 %stl(a0, env) 2734 2735 :.done 2736 %ldl(a0, env) 2737 }) 2738 2739 # eval_body(body=a0, env=a1) -> value of last form (a0). 2740 # Evaluates each non-last form for effect; tail-evaluates the last so 2741 # that closures used in tail position do not grow the host stack. 2742 # 2743 # Internal `define` is rejected here (this is the single chokepoint for 2744 # every body context: closure body via apply, let / letrec / named-let 2745 # bodies, cond clause bodies, begin's body). Per-form check is one 2746 # tagof + one symbol compare, regardless of body length. 2747 # 2748 # Locals: 2749 # body 2750 # env 2751 %gcfn2(eval_body, {body env}, 3, 0, { 2752 :.loop 2753 %stl(a0, body) 2754 %stl(a1, env) 2755 2756 # Reject internal `define`. Detect (define ...) at the head of any 2757 # form before dispatching to eval; top-level-only. 2758 %car(t0, a0) ; form 2759 %tagof(t1, t0) 2760 %li(t2, %TAG.PAIR) 2761 %bne(t1, t2, &.not_define) 2762 %car(t1, t0) ; head sym 2763 %ld_global(t2, &sym_define) 2764 %beq(t1, t2, &.internal_define) 2765 2766 :.not_define 2767 # If cdr(body) is NIL, body's car is the last form. 2768 %ldl(a0, body) 2769 %cdr(t0, a0) 2770 %if_nil(t1, t0, &.last) 2771 2772 # Non-last form: eval and discard, advance. 2773 %car(a0, a0) 2774 %ldl(a1, env) 2775 %call(&eval) 2776 %ldl(a0, body) 2777 %cdr(a0, a0) 2778 %ldl(a1, env) 2779 %b(&.loop) 2780 2781 :.last 2782 %ldl(a0, body) 2783 %car(a0, a0) 2784 %ldl(a1, env) 2785 %gctail(&eval) 2786 2787 :.internal_define 2788 %die(msg_internal_define) 2789 }) 2790 2791 # ========================================================================= 2792 # Runtime error -- single abort entry point 2793 # ========================================================================= 2794 # 2795 # runtime_error(msg_cstr=a0) -> never returns. Every overflow / bounds / 2796 # unbound / type-failure path lands here so error reporting (and the 2797 # eventual user-facing `error` primitive) only have to be implemented 2798 # once. Today we tail into libp1pp's `panic`, which writes msg + LF to 2799 # stderr and sys_exits 1. 2800 :runtime_error 2801 %tail(&panic) 2802 2803 # ========================================================================= 2804 # Source loading -- argv[1] -> readbuf, length stored in readbuf_len 2805 # ========================================================================= 2806 2807 %fn(load_source, 0, { 2808 %ld_global(a1, &readbuf_buf_ptr) 2809 %li(a2, %READBUF_CAP_BYTES) 2810 %call(&read_file) 2811 %bltz(a0, &.fail) 2812 2813 # If the read filled (or would have filled) the buffer, the source 2814 # is at least cap bytes; refuse rather than silently truncate. 2815 # read_file does a single sys_read so n == cap is the only saturation 2816 # signal we have. We treat n >= cap as overflow defensively. 2817 %li(t0, %READBUF_CAP_BYTES) 2818 %bltu(a0, t0, &.ok) 2819 %die(msg_readbuf_full) 2820 2821 :.ok 2822 %st_global(a0, &readbuf_len, t0) 2823 %li(a0, 0) 2824 %st_global(a0, &readbuf_pos, t0) 2825 %eret 2826 2827 :.fail 2828 %die(msg_load_fail) 2829 }) 2830 2831 # ========================================================================= 2832 # Mark-and-sweep collector 2833 # ========================================================================= 2834 # 2835 # Marking never allocates. A marked allocation header is linked through 2836 # word 1 onto gc_mark_worklist. Only exact shadow-frame slots and explicit 2837 # symbol-table roots seed the traversal. 2838 2839 # gc_mark_payload(raw_payload=a0, expected_kind=a1). Invalid, interior, 2840 # free, or already-marked addresses are ignored. 2841 :gc_mark_payload 2842 .scope 2843 %beqz(a0, &.done) 2844 %andi(t2, a0, 7) 2845 %bnez(t2, &.done) 2846 %ld_global(t0, &heap_base) 2847 %addi(t0, t0, %GC_HEADER_BYTES) 2848 %bltu(a0, t0, &.done) 2849 %ld_global(t1, &heap_tail) 2850 %bltu(a0, t1, &.in_heap) 2851 # A zero-length RAW allocation has its payload exactly at heap_tail; 2852 # its 16-byte header is still a real managed block. 2853 %beq(a0, t1, &.in_heap) 2854 %b(&.done) 2855 :.in_heap 2856 %addi(t0, a0, (- %GC_HEADER_BYTES)) 2857 %ld(t1, t0, 0) 2858 %andi(t2, t1, %GC_KIND_MASK) 2859 %bne(t2, a1, &.done) 2860 # Validate the candidate header before putting it on the worklist. 2861 # Exact roots should always name object starts; these checks reject 2862 # malformed, truncated, and implausible interior candidates safely. 2863 %shri(a2, t1, 8) 2864 %li(a3, %GC_HEADER_BYTES) 2865 %bltu(a2, a3, &.done) 2866 %andi(a3, a2, 7) 2867 %bnez(a3, &.done) 2868 %add(a3, t0, a2) 2869 %ld_global(t2, &heap_tail) 2870 %bltu(t2, a3, &.done) 2871 %andi(t2, t1, %GC_MARK_BIT) 2872 %bnez(t2, &.done) 2873 # An unmarked allocated block keeps its own header address in the 2874 # intrusive word. This canary distinguishes a real object start from 2875 # an aligned interior word without a quadratic physical-chain walk. 2876 %ld(t2, t0, 8) 2877 %bne(t2, t0, &.done) 2878 %ori(t1, t1, %GC_MARK_BIT) 2879 %st(t1, t0, 0) 2880 %ld_global(t1, &gc_mark_worklist) 2881 %st(t1, t0, 8) 2882 %st_global(t0, &gc_mark_worklist, t1) 2883 :.done 2884 %ret 2885 .endscope 2886 2887 # gc_mark_scheme(value=a0). Tags select the exact managed allocation 2888 # kind; fixnums, symbols, and immediates are not heap roots. 2889 :gc_mark_scheme 2890 .scope 2891 %tagof(t0, a0) 2892 %li(t1, %TAG.PAIR) 2893 %beq(t0, t1, &.pair) 2894 %li(t1, %TAG.HEAP) 2895 %beq(t0, t1, &.heap) 2896 %ret 2897 :.pair 2898 %addi(a0, a0, (- %TAG.PAIR)) 2899 %li(a1, %GCKIND.PAIR) 2900 %b(&gc_mark_payload) 2901 :.heap 2902 %addi(a0, a0, (- %TAG.HEAP)) 2903 %li(a1, %GCKIND.HEAP) 2904 %b(&gc_mark_payload) 2905 .endscope 2906 2907 :gc_mark_raw 2908 %li(a1, %GCKIND.RAW) 2909 %b(&gc_mark_payload) 2910 2911 # Mark all described native-frame slots. 2912 %fn2(gc_mark_shadow_roots, {frame end native scheme_mask raw_mask slot}, { 2913 %ld_global(t0, &gc_root_buf_ptr) 2914 %stl(t0, frame) 2915 %ld_global(t0, &gc_root_next) 2916 %stl(t0, end) 2917 :.frame_loop 2918 %ldl(t0, frame) 2919 %ldl(t1, end) 2920 %beq(t0, t1, &.done) 2921 %ld(t1, t0, 0) 2922 %stl(t1, native) 2923 %stl(t1, slot) 2924 %ld(t1, t0, 8) 2925 %stl(t1, scheme_mask) 2926 %ld(t1, t0, 16) 2927 %stl(t1, raw_mask) 2928 :.slot_loop 2929 %ldl(t0, scheme_mask) 2930 %ldl(t1, raw_mask) 2931 %or(t2, t0, t1) 2932 %beqz(t2, &.next_frame) 2933 %andi(t2, t0, 1) 2934 %beqz(t2, &.maybe_raw) 2935 %ldl(t2, slot) 2936 %ld(a0, t2, 0) 2937 %call(&gc_mark_scheme) 2938 :.maybe_raw 2939 %ldl(t0, raw_mask) 2940 %andi(t1, t0, 1) 2941 %beqz(t1, &.advance_slot) 2942 %ldl(t1, slot) 2943 %ld(a0, t1, 0) 2944 %call(&gc_mark_raw) 2945 :.advance_slot 2946 %ldl(t0, scheme_mask) 2947 %shri(t0, t0, 1) 2948 %stl(t0, scheme_mask) 2949 %ldl(t0, raw_mask) 2950 %shri(t0, t0, 1) 2951 %stl(t0, raw_mask) 2952 %ldl(t0, slot) 2953 %addi(t0, t0, 8) 2954 %stl(t0, slot) 2955 %b(&.slot_loop) 2956 :.next_frame 2957 %ldl(t0, frame) 2958 %addi(t0, t0, %GC_ROOT_FRAME_BYTES) 2959 %stl(t0, frame) 2960 %b(&.frame_loop) 2961 :.done 2962 }) 2963 2964 # Symbol entries are permanent roots: the stable RAW name buffers and 2965 # every Scheme value installed in a global binding. 2966 %fn2(gc_mark_symbol_roots, {idx count entry}, { 2967 %li(t0, 0) 2968 %stl(t0, idx) 2969 %ld_global(t0, &symtab_count) 2970 %stl(t0, count) 2971 :.loop 2972 %ldl(t0, idx) 2973 %ldl(t1, count) 2974 %beq(t0, t1, &.done) 2975 %symtab_entry(t1, t0, t2) 2976 %stl(t1, entry) 2977 %ld(a0, t1, %SYMENT.name_ptr) 2978 %call(&gc_mark_raw) 2979 %ldl(t1, entry) 2980 %ld(a0, t1, %SYMENT.global_val) 2981 %call(&gc_mark_scheme) 2982 %ldl(t0, idx) 2983 %addi(t0, t0, 1) 2984 %stl(t0, idx) 2985 %b(&.loop) 2986 :.done 2987 }) 2988 2989 # Trace one marked allocation header. The header remains marked while it 2990 # is off the worklist, so cycles terminate naturally. 2991 %fn2(gc_trace_header, {header payload object_hdr count cursor td}, { 2992 %stl(a0, header) 2993 %addi(t0, a0, %GC_HEADER_BYTES) 2994 %stl(t0, payload) 2995 %ld(t1, a0, 0) 2996 %andi(t1, t1, %GC_KIND_MASK) 2997 %li(t2, %GCKIND.PAIR) 2998 %beq(t1, t2, &.pair) 2999 %li(t2, %GCKIND.HEAP) 3000 %beq(t1, t2, &.heap) 3001 %eret ; RAW has no outgoing references 3002 3003 :.pair 3004 %ld(a0, t0, %PAIR.car) 3005 %call(&gc_mark_scheme) 3006 %ldl(t0, payload) 3007 %ld(a0, t0, %PAIR.cdr) 3008 %tail(&gc_mark_scheme) 3009 3010 :.heap 3011 %ld(t1, t0, 0) 3012 %stl(t1, object_hdr) 3013 %andi(t1, t1, 255) 3014 %li(t2, %HDR.BV) 3015 %beq(t1, t2, &.bv) 3016 %li(t2, %HDR.CLOSURE) 3017 %beq(t1, t2, &.closure) 3018 %li(t2, %HDR.PRIM) 3019 %beq(t1, t2, &.prim) 3020 %li(t2, %HDR.TD) 3021 %beq(t1, t2, &.td) 3022 %li(t2, %HDR.REC) 3023 %beq(t1, t2, &.record) 3024 %li(t2, %HDR.MV) 3025 %beq(t1, t2, &.mv) 3026 %eret 3027 3028 :.bv 3029 %ld(a0, t0, %BV.data) 3030 %tail(&gc_mark_raw) 3031 3032 :.closure 3033 %ld(a0, t0, %CLOSURE.params) 3034 %call(&gc_mark_scheme) 3035 %ldl(t0, payload) 3036 %ld(a0, t0, %CLOSURE.body) 3037 %call(&gc_mark_scheme) 3038 %ldl(t0, payload) 3039 %ld(a0, t0, %CLOSURE.env) 3040 %tail(&gc_mark_scheme) 3041 3042 :.prim 3043 # Plain primitives contain zero in data; parameterized primitives 3044 # contain their TD or tagged field index. 3045 %ld(a0, t0, %PRIM.data) 3046 %tail(&gc_mark_scheme) 3047 3048 :.td 3049 %ld(a0, t0, %TD.fields) 3050 %tail(&gc_mark_scheme) 3051 3052 :.record 3053 %ld(t1, t0, %REC.td) 3054 %stl(t1, td) 3055 %mov(a0, t1) 3056 %call(&gc_mark_scheme) 3057 # A freshly published record may still have its cleared TD slot while 3058 # its constructor is filling fields. In that state it has no outgoing 3059 # references yet and is safe to revisit after construction. 3060 %ldl(t0, td) 3061 %tagof(t1, t0) 3062 %li(t2, %TAG.HEAP) 3063 %bne(t1, t2, &.done) 3064 %hdr_type(t1, t0) 3065 %li(t2, %HDR.TD) 3066 %bne(t1, t2, &.done) 3067 %heap_ld(t1, t0, %TD.nfields) 3068 %stl(t1, count) 3069 %ldl(t0, payload) 3070 %addi(t0, t0, 16) 3071 %stl(t0, cursor) 3072 %b(&.slots) 3073 3074 :.mv 3075 %ldl(t0, object_hdr) 3076 %shri(t0, t0, 8) 3077 %stl(t0, count) 3078 %ldl(t0, payload) 3079 %addi(t0, t0, 8) 3080 %stl(t0, cursor) 3081 3082 :.slots 3083 %ldl(t0, count) 3084 %beqz(t0, &.done) 3085 %ldl(t1, cursor) 3086 %ld(a0, t1, 0) 3087 %call(&gc_mark_scheme) 3088 %ldl(t0, cursor) 3089 %addi(t0, t0, 8) 3090 %stl(t0, cursor) 3091 %ldl(t0, count) 3092 %addi(t0, t0, -1) 3093 %stl(t0, count) 3094 %b(&.slots) 3095 :.done 3096 }) 3097 3098 # Sweep the physical block chain, rebuild an address-ordered free list, 3099 # coalesce adjacent garbage, clear survivor marks, and return a trailing 3100 # free run to the unused tail. 3101 %fn2(gc_sweep, {cursor end free_head list_last list_prev run_free allocated size}, { 3102 %ld_global(t0, &heap_base) 3103 %stl(t0, cursor) 3104 %ld_global(t0, &heap_tail) 3105 %stl(t0, end) 3106 %li(t0, 0) 3107 %stl(t0, free_head) 3108 %stl(t0, list_last) 3109 %stl(t0, list_prev) 3110 %stl(t0, run_free) 3111 %stl(t0, allocated) 3112 :.loop 3113 %ldl(t0, cursor) 3114 %ldl(t1, end) 3115 %beq(t0, t1, &.finish) 3116 %ld(t1, t0, 0) 3117 %shri(t2, t1, 8) 3118 %li(a0, %GC_HEADER_BYTES) 3119 %bltu(t2, a0, &.corrupt) 3120 %andi(a0, t2, 7) 3121 %bnez(a0, &.corrupt) 3122 %add(a0, t0, t2) 3123 %ldl(a1, end) 3124 %bltu(a1, a0, &.corrupt) 3125 %stl(t2, size) 3126 %andi(a0, t1, %GC_KIND_MASK) 3127 %beqz(a0, &.garbage) 3128 %andi(a0, t1, %GC_MARK_BIT) 3129 %beqz(a0, &.garbage) 3130 3131 # Survivor: clear mark and break any adjacent-free run. 3132 %li(a0, -129) 3133 %and(t1, t1, a0) 3134 %st(t1, t0, 0) 3135 %st(t0, t0, 8) ; restore allocated-block start canary 3136 %ldl(a0, allocated) 3137 %add(a0, a0, t2) 3138 %stl(a0, allocated) 3139 %li(a0, 0) 3140 %stl(a0, run_free) 3141 %b(&.advance) 3142 3143 :.garbage 3144 %ldl(a0, run_free) 3145 %beqz(a0, &.new_run) 3146 # Extend the preceding physical free run. 3147 # Invalidate the absorbed block's old header so a stale exact slot 3148 # cannot mistake this interior address for an allocated object start. 3149 %li(a1, 0) 3150 %st(a1, t0, 0) 3151 %st(a1, t0, 8) 3152 %ld(a1, a0, 0) 3153 %shri(a1, a1, 8) 3154 %add(a1, a1, t2) 3155 %shli(a1, a1, 8) 3156 %st(a1, a0, 0) 3157 %b(&.advance) 3158 3159 :.new_run 3160 %shli(t1, t2, 8) ; FREE kind, mark clear 3161 %st(t1, t0, 0) 3162 %li(t1, 0) 3163 %st(t1, t0, 8) 3164 %ldl(t1, list_last) 3165 %stl(t1, list_prev) 3166 %beqz(t1, &.first_free) 3167 %st(t0, t1, 8) 3168 %b(&.linked) 3169 :.first_free 3170 %stl(t0, free_head) 3171 :.linked 3172 %stl(t0, list_last) 3173 %stl(t0, run_free) 3174 3175 :.advance 3176 %ldl(t0, cursor) 3177 %ldl(t1, size) 3178 %add(t0, t0, t1) 3179 %stl(t0, cursor) 3180 %b(&.loop) 3181 3182 :.finish 3183 # A final free run is outside the physical chain after trimming. 3184 %ldl(t0, run_free) 3185 %beqz(t0, &.publish) 3186 %st_global(t0, &heap_tail, t1) 3187 %ldl(t1, list_prev) 3188 %beqz(t1, &.trim_only) 3189 %li(t2, 0) 3190 %st(t2, t1, 8) 3191 %b(&.publish) 3192 :.trim_only 3193 %li(t1, 0) 3194 %stl(t1, free_head) 3195 3196 :.publish 3197 %ldl(t0, free_head) 3198 %st_global(t0, &gc_free_list, t1) 3199 %ldl(t0, allocated) 3200 %st_global(t0, &heap_allocated, t1) 3201 %eret 3202 :.corrupt 3203 %die(msg_heap_corrupt) 3204 }) 3205 3206 %fn(gc_collect, 0, { 3207 %li(t0, 0) 3208 %st_global(t0, &gc_mark_worklist, t1) 3209 %call(&gc_mark_shadow_roots) 3210 %call(&gc_mark_symbol_roots) 3211 :.drain 3212 %ld_global(t0, &gc_mark_worklist) 3213 %beqz(t0, &.sweep) 3214 %ld(t1, t0, 8) 3215 %st_global(t1, &gc_mark_worklist, t2) 3216 %mov(a0, t0) 3217 %call(&gc_trace_header) 3218 %b(&.drain) 3219 :.sweep 3220 %tail(&gc_sweep) 3221 }) 3222 3223 # ========================================================================= 3224 # Managed heap allocation 3225 # ========================================================================= 3226 # 3227 # gc_alloc_try performs coalesced-free-list first fit, then uses the 3228 # untouched heap tail. It never collects and returns raw payload 0 on 3229 # failure. gc_alloc collects once and retries. All managed payloads are 3230 # 8-byte aligned; the two-word allocation header is not visible through 3231 # existing Scheme object pointers. 3232 3233 %fn2(gc_alloc_try, {total kind prev cur block_size next}, { 3234 %alignup(a0, a0, 8, t0) 3235 %addi(a0, a0, %GC_HEADER_BYTES) 3236 %stl(a0, total) 3237 %stl(a1, kind) 3238 %li(t0, 0) 3239 %stl(t0, prev) 3240 %ld_global(t0, &gc_free_list) 3241 %stl(t0, cur) 3242 3243 :.free_loop 3244 %ldl(t0, cur) 3245 %beqz(t0, &.tail) 3246 %ld(t1, t0, 0) 3247 %shri(t1, t1, 8) 3248 %stl(t1, block_size) 3249 %ldl(t2, total) 3250 %bltu(t1, t2, &.free_next) 3251 3252 # Found first fit. Split only when the remainder can hold a header 3253 # plus at least one aligned payload word. 3254 %ld(t1, t0, 8) 3255 %stl(t1, next) 3256 %ldl(t1, block_size) 3257 %ldl(t2, total) 3258 %sub(t1, t1, t2) ; remainder bytes 3259 %li(t2, (+ %GC_HEADER_BYTES 8)) 3260 %bltu(t1, t2, &.consume) 3261 3262 # remainder_header = current + requested_total 3263 %ldl(t0, cur) 3264 %ldl(t2, total) 3265 %add(t2, t0, t2) 3266 %shli(t1, t1, 8) ; FREE kind is zero 3267 %st(t1, t2, 0) 3268 %ldl(t1, next) 3269 %st(t1, t2, 8) 3270 %ldl(t1, prev) 3271 %beqz(t1, &.split_head) 3272 %st(t2, t1, 8) 3273 %b(&.split_done) 3274 :.split_head 3275 %st_global(t2, &gc_free_list, t1) 3276 :.split_done 3277 %ldl(t1, total) 3278 %stl(t1, block_size) 3279 %b(&.prepare) 3280 3281 :.consume 3282 %ldl(t1, prev) 3283 %ldl(t2, next) 3284 %beqz(t1, &.consume_head) 3285 %st(t2, t1, 8) 3286 %b(&.prepare) 3287 :.consume_head 3288 %st_global(t2, &gc_free_list, t1) 3289 %b(&.prepare) 3290 3291 :.free_next 3292 %ldl(t0, cur) 3293 %stl(t0, prev) 3294 %ld(t0, t0, 8) 3295 %stl(t0, cur) 3296 %b(&.free_loop) 3297 3298 :.tail 3299 %ld_global(t0, &heap_tail) 3300 %ldl(t1, total) 3301 %add(t2, t0, t1) 3302 %ld_global(a3, &heap_end) 3303 %bltu(a3, t2, &.fail) 3304 %st_global(t2, &heap_tail, a3) 3305 %stl(t0, cur) 3306 %stl(t1, block_size) 3307 3308 :.prepare 3309 # Install the allocated header and account for the entire physical 3310 # block (including header and any unsplittable tail fragment). 3311 %ldl(t0, cur) 3312 %ldl(t1, block_size) 3313 %shli(t2, t1, 8) 3314 %ldl(a1, kind) 3315 %or(t2, t2, a1) 3316 %st(t2, t0, 0) 3317 %st(t0, t0, 8) ; allocated-block start canary 3318 %ld_global(a3, &heap_allocated) 3319 %add(a3, a3, t1) 3320 %st_global(a3, &heap_allocated, t2) 3321 3322 # Clear traced payloads before publishing them. This makes a 3323 # partially constructed HEAP object safe if a later field-setting 3324 # step allocates and triggers collection. 3325 %ldl(a1, kind) 3326 %li(t1, %GCKIND.RAW) 3327 %beq(a1, t1, &.return) 3328 %addi(t1, t0, %GC_HEADER_BYTES) 3329 %ldl(t2, block_size) 3330 %addi(t2, t2, (- %GC_HEADER_BYTES)) 3331 :.clear_loop 3332 %beqz(t2, &.return) 3333 %li(a0, 0) 3334 %st(a0, t1, 0) 3335 %addi(t1, t1, 8) 3336 %addi(t2, t2, -8) 3337 %b(&.clear_loop) 3338 3339 :.return 3340 %addi(a0, t0, %GC_HEADER_BYTES) 3341 %eret 3342 3343 :.fail 3344 %li(a0, 0) 3345 }) 3346 3347 %fn2(gc_alloc, {bytes kind}, { 3348 %stl(a0, bytes) 3349 %stl(a1, kind) 3350 %call(&gc_alloc_try) 3351 %bnez(a0, &.done) 3352 %call(&gc_collect) 3353 %ldl(a0, bytes) 3354 %ldl(a1, kind) 3355 %call(&gc_alloc_try) 3356 %beqz(a0, &.oom) 3357 :.done 3358 %eret 3359 :.oom 3360 %die(msg_heap_full) 3361 }) 3362 3363 # cons roots both arguments inside the allocator frame because gc_alloc 3364 # may synchronously collect before returning a payload. 3365 %gcfn2(cons, {car_value cdr_value}, 3, 0, { 3366 %stl(a0, car_value) 3367 %stl(a1, cdr_value) 3368 %li(a0, %PAIR.SIZE) 3369 %li(a1, %GCKIND.PAIR) 3370 %call(&gc_alloc) 3371 %ldl(t0, car_value) 3372 %st(t0, a0, %PAIR.car) 3373 %ldl(t0, cdr_value) 3374 %st(t0, a0, %PAIR.cdr) 3375 %addi(a0, a0, %TAG.PAIR) 3376 }) 3377 3378 # alloc_hdr(bytes=a0, hdr_word=a1) -> tagged HEAP object. 3379 %fn2(alloc_hdr, {bytes hdr_word}, { 3380 %stl(a0, bytes) 3381 %stl(a1, hdr_word) 3382 %li(a1, %GCKIND.HEAP) 3383 %call(&gc_alloc) 3384 %ldl(t0, hdr_word) 3385 %st(t0, a0, 0) 3386 %addi(a0, a0, %TAG.HEAP) 3387 }) 3388 3389 # list_length(list=a0) -> count (a0). Linear walk; clobbers a0 (used as 3390 # the cursor). Callers that need the list afterward must save it first. 3391 :list_length 3392 .scope 3393 %li(t0, 0) 3394 :.loop 3395 %if_nil(t1, a0, &.done) 3396 %addi(t0, t0, 1) 3397 %cdr(a0, a0) 3398 %b(&.loop) 3399 :.done 3400 %mov(a0, t0) 3401 %ret 3402 .endscope 3403 3404 # ========================================================================= 3405 # Multiple-values protocol 3406 # ========================================================================= 3407 # 3408 # An MV-pack is a HEAP-tagged object with header (count << 8) | HDR.MV 3409 # followed by `count` slot words (raw +8, +16, ...). The R7RS protocol 3410 # below treats single values and MV-packs uniformly: a 1-value yield is 3411 # returned as the bare value, while 0 or 2+ values are materialized as 3412 # an MV-pack. mv_to_list normalizes either form to a list so let-values / 3413 # call-with-values can reuse the existing destructuring machinery. 3414 3415 # list_to_mv(list=a0) -> tagged MV-pack (a0). 3416 # Walks `list` to count it, allocates (count+1)*8 bytes with header 3417 # (count<<8)|HDR.MV, then copies elements into consecutive slots in 3418 # order. An empty list yields a 0-pack. 3419 # 3420 # Locals: 3421 # list (preserved across list_length + alloc_hdr) 3422 # count 3423 # mv (tagged MV-pack) 3424 %gcfn2(list_to_mv, {list count mv pad}, 5, 0, { 3425 %stl(a0, list) 3426 %call(&list_length) ; clobbers a0; returns count 3427 %stl(a0, count) 3428 3429 # alloc_hdr((count+1)*8, (count<<8)|HDR.MV) 3430 %addi(a0, a0, 1) 3431 %shli(a0, a0, 3) 3432 %ldl(t0, count) 3433 %shli(t0, t0, 8) 3434 %ori(a1, t0, %HDR.MV) 3435 %call(&alloc_hdr) 3436 %stl(a0, mv) 3437 3438 # Walk list, store at consecutive slots. The first slot's raw byte 3439 # offset from a tagged HEAP pointer is +5 (= raw+8 - 3). 3440 %ldl(t0, list) 3441 %addi(t1, a0, 5) 3442 3443 :.loop 3444 %if_nil(t2, t0, &.done) 3445 %car(t2, t0) 3446 %st(t2, t1, 0) 3447 %addi(t1, t1, 8) 3448 %cdr(t0, t0) 3449 %b(&.loop) 3450 3451 :.done 3452 %ldl(a0, mv) 3453 }) 3454 3455 # mv_to_list(val=a0) -> list (a0). 3456 # If val is HEAP-tagged with HDR.MV, build a fresh list of its slots in 3457 # order. Any other value is wrapped as a single-element list, so callers 3458 # can uniformly reuse list-shaped destructuring. 3459 # 3460 # Locals: 3461 # mv original MV-pack, rooted while fresh list cells are allocated 3462 # ptr (raw cursor into MV slots, walked backward) 3463 # count (remaining slot count) 3464 %gcfn2(mv_to_list, {mv ptr count}, 1, 0, { 3465 %stl(a0, mv) 3466 %tagof(t0, a0) 3467 %bine(t0, %TAG.HEAP, &.single, t1) 3468 %hdr_type(t0, a0) 3469 %bine(t0, %HDR.MV, &.single, t1) 3470 3471 # MV-pack: count = (hdr >> 8); header sits at raw+0 = tagged-3. 3472 %ld(t0, a0, -3) 3473 %shri(t0, t0, 8) 3474 %stl(t0, count) 3475 3476 # Walk slots back-to-front so each cons prepends, yielding original 3477 # left-to-right order. Cursor = (tagged+5) + (count-1)*8. 3478 %addi(t1, a0, 5) 3479 %shli(t2, t0, 3) 3480 %add(t1, t1, t2) 3481 %addi(t1, t1, -8) 3482 %stl(t1, ptr) 3483 3484 %li(a0, %imm_val(%IMM.NIL)) 3485 3486 :.loop 3487 %ldl(t0, count) 3488 %beqz(t0, &.done) 3489 3490 %ldl(t1, ptr) 3491 %ld(t2, t1, 0) 3492 %mov(a1, a0) 3493 %mov(a0, t2) 3494 %call(&cons) 3495 3496 %ldl(t1, ptr) 3497 %addi(t1, t1, -8) 3498 %stl(t1, ptr) 3499 %ldl(t0, count) 3500 %addi(t0, t0, -1) 3501 %stl(t0, count) 3502 %b(&.loop) 3503 3504 :.done 3505 %gceret 3506 3507 :.single 3508 # Non-MV: return (val . NIL). 3509 %li(a1, %imm_val(%IMM.NIL)) 3510 %gctail(&cons) 3511 }) 3512 3513 # ========================================================================= 3514 # Symbol intern -- linear scan, append on miss 3515 # ========================================================================= 3516 # 3517 # Locals: 3518 # name_ptr (input) 3519 # name_len (input) 3520 # idx (loop counter / found index) 3521 # entry_ptr (spilled across memcmp) 3522 %gcfn2(intern, {name_ptr name_len idx entry_ptr}, 0, 1, { 3523 %stl(a0, name_ptr) 3524 %stl(a1, name_len) 3525 3526 %li(t0, 0) 3527 %stl(t0, idx) 3528 3529 :.scan 3530 # idx >= count? -> append 3531 %ldl(t0, idx) 3532 %ld_global(t1, &symtab_count) 3533 %bltu(t0, t1, &.probe) 3534 %b(&.append) 3535 3536 :.probe 3537 %symtab_entry(t1, t0, t2) 3538 %stl(t1, entry_ptr) 3539 3540 # entry.name_len == name_len ? 3541 %ld(t2, t1, %SYMENT.name_len) 3542 %ldl(a2, name_len) 3543 %bne(t2, a2, &.next) 3544 3545 # memcmp(entry.name_ptr, name_ptr, len) 3546 %ld(a0, t1, %SYMENT.name_ptr) 3547 %ldl(a1, name_ptr) 3548 %ldl(a2, name_len) 3549 %call(&memcmp) 3550 %beqz(a0, &.found) 3551 3552 :.next 3553 %ldl(t0, idx) 3554 %addi(t0, t0, 1) 3555 %stl(t0, idx) 3556 %b(&.scan) 3557 3558 :.append 3559 # Bounds check; on overflow exit 5 with a message. 3560 %ldl(t0, idx) 3561 %li(t1, %SYMTAB_CAP_SLOTS) 3562 %bltu(t0, t1, &.append_ok) 3563 %die(msg_symtab_full) 3564 3565 :.append_ok 3566 # Copy the name into a stable managed RAW buffer. The caller-provided 3567 # ptr may live in readbuf_buf (parse_atom), so symtab names must 3568 # outlive source-buffer reuse. The collector roots each name explicitly. 3569 %ldl(a0, name_len) 3570 %call(&alloc_bytes) 3571 %ldl(a1, name_ptr) 3572 %ldl(a2, name_len) 3573 %call(&memcpy) ; returns dst in a0 = stable copy 3574 3575 %ldl(t0, idx) 3576 %symtab_entry(t1, t0, t2) 3577 %st(a0, t1, %SYMENT.name_ptr) ; stable copy 3578 %ldl(a0, name_len) 3579 %st(a0, t1, %SYMENT.name_len) 3580 %li(a0, %imm_val(%IMM.UNBOUND)) 3581 %st(a0, t1, %SYMENT.global_val) 3582 %li(a0, 0) 3583 %st(a0, t1, %SYMENT.pad) 3584 3585 # symtab_count = idx + 1 3586 %addi(a0, t0, 1) 3587 %st_global(a0, &symtab_count, t2) 3588 3589 # fall through with idx in t0 = sp[16] 3590 3591 :.found 3592 %ldl(t0, idx) 3593 %shli(a0, t0, 3) 3594 %ori(a0, a0, %TAG.SYM) 3595 }) 3596 3597 # Lookup by sym_idx (untagged, in a0). Returns symtab[idx].global_val in a0. 3598 # Leaf. 3599 :sym_global 3600 %ld_global(t0, &symtab_buf_ptr) 3601 %ld_array(a0, t0, %SYMENT.SIZE, a0, %SYMENT.global_val, t1) 3602 %ret 3603 3604 # sym_set_global(idx=a0, val=a1). Leaf. 3605 :sym_set_global 3606 %ld_global(t0, &symtab_buf_ptr) 3607 %st_array(a1, t0, %SYMENT.SIZE, a0, %SYMENT.global_val, t1) 3608 %ret 3609 3610 # ========================================================================= 3611 # Primitives 3612 # ========================================================================= 3613 # 3614 # PRIM objects live on the heap so the bump allocator's 8-byte alignment 3615 # is what makes (heap_ptr & 7 == 0) hold; that's what lets `+3` encode 3616 # the HEAP tag cleanly. (A static :prim_sys_exit emitted in the data 3617 # section was at the mercy of preceding code length and could land at 3618 # any 4-byte alignment, producing tag bits 5 or 7 instead of 3.) 3619 # 3620 # register_primitives walks prim_table at startup. Each table entry is 3621 # 24 bytes: 8-byte name_ptr (4-byte label ref + 4 pad), 8-byte name_len, 3622 # 8-byte entry_label (4 ref + 4 pad). For each entry we alloc a 16-byte 3623 # PRIM, write the entry-label into the prim header's entry slot, intern 3624 # the surface name, and bind the symbol's global slot to the HEAP-tagged 3625 # prim pointer. 3626 # 3627 # Locals: 3628 # prim ptr (HEAP-tagged; spilled across intern + sym_set_global) 3629 # walk (current table cursor) 3630 # end (table_end) 3631 %gcfn2(register_primitives, {prim walk end}, 1, 0, { 3632 %la(t0, &prim_table) 3633 %stl(t0, walk) 3634 %la(t0, &prim_table_end) 3635 %stl(t0, end) 3636 3637 :.loop 3638 %ldl(t0, walk) 3639 %ldl(t1, end) 3640 %beq(t0, t1, &.done) 3641 3642 # alloc_hdr(24, HDR.PRIM) -> HEAP-tagged a0. The third slot (offset 13 3643 # from tagged) holds per-instance data and stays zero for the 3644 # primitives registered here -- only parameterized prims (record 3645 # ctor/predicate/accessor/mutator) read it. 3646 %li(a0, 24) 3647 %li(a1, %HDR.PRIM) 3648 %call(&alloc_hdr) 3649 %stl(a0, prim) 3650 3651 # Write entry-label into prim's entry slot. 3652 %ldl(t0, walk) 3653 %ld(t1, t0, 16) 3654 %ldl(t2, prim) 3655 %heap_st(t1, t2, %PRIM.entry_w) 3656 3657 # Intern surface name; bind global to prim ptr. 3658 %ldl(t0, walk) 3659 %ld(a0, t0, 0) 3660 %ld(a1, t0, 8) 3661 %call(&intern) 3662 %untag_sym(a0, a0) 3663 %ldl(a1, prim) 3664 %call(&sym_set_global) 3665 3666 %ldl(t0, walk) 3667 %addi(t0, t0, 24) 3668 %stl(t0, walk) 3669 %b(&.loop) 3670 3671 :.done 3672 }) 3673 3674 %fn(register_globals, 0, { 3675 # Bind `eof` as a direct global -> IMM.EOF value. (Predicate is `eof?`, 3676 # registered via prim_table.) Cheaper and shorter than a 0-arg thunk. 3677 %la(a0, &name_eof) 3678 %li(a1, 3) 3679 %call(&intern) 3680 %untag_sym(a0, a0) 3681 %li(a1, %imm_val(%IMM.EOF)) 3682 %call(&sym_set_global) 3683 }) 3684 3685 # Each primitive is a leaf reached via apply's %tailr: args list is in a0, 3686 # and the result goes back in a0. Most use no frame at all; the few that 3687 # need recursion (apply) carry a small one via %fn. 3688 # 3689 # Arithmetic / compare / bitwise primitives on tagged fixnums take 3690 # advantage of the (n << 3) representation: + / - / signed compare / 3691 # bit-and / bit-or / bit-xor all work directly on the tagged words, so 3692 # the variadic fold loop preserves the tag at every step. Only * has to 3693 # untag each incoming operand to avoid a stray <<6. 3694 3695 # (sys-exit code) -- libp1pp's sys_exit doesn't return; %b, not %call. 3696 :prim_sys_exit_entry 3697 %car(a0, a0) 3698 %untag_fix(a0, a0) 3699 %b(&sys_exit) 3700 3701 # (cons a b) -> tagged pair. 3702 :prim_cons_entry 3703 %car(t0, a0) 3704 %cdr(t1, a0) 3705 %car(t1, t1) 3706 %mov(a0, t0) 3707 %mov(a1, t1) 3708 %b(&cons) 3709 3710 # (car p), (cdr p) 3711 :prim_car_entry 3712 %car(a0, a0) 3713 %car(a0, a0) 3714 %ret 3715 3716 :prim_cdr_entry 3717 %car(a0, a0) 3718 %cdr(a0, a0) 3719 %ret 3720 3721 # Predicate primitives. Same shape: extract the arg, compare, return one 3722 # of the two boolean immediates. 3723 3724 :prim_nullq_entry 3725 .scope 3726 %car(t0, a0) 3727 %li(a0, %imm_val(%IMM.TRUE)) 3728 %if_nil(t1, t0, &.end) 3729 %li(a0, %imm_val(%IMM.FALSE)) 3730 :.end 3731 %ret 3732 .endscope 3733 3734 :prim_pairq_entry 3735 .scope 3736 %car(t0, a0) 3737 %tagof(t1, t0) 3738 %li(t2, %TAG.PAIR) 3739 %li(a0, %imm_val(%IMM.FALSE)) 3740 %bne(t1, t2, &.end) 3741 %li(a0, %imm_val(%IMM.TRUE)) 3742 :.end 3743 %ret 3744 .endscope 3745 3746 # (string? x) -- #t iff x is a HEAP-tagged HDR.BV. Bytevectors back the 3747 # string type until characters get a distinct repr; this prim is also 3748 # the bytevector? predicate. 3749 :prim_stringq_entry 3750 .scope 3751 %car(t0, a0) 3752 %li(a0, %imm_val(%IMM.FALSE)) 3753 %tagof(t1, t0) 3754 %li(t2, %TAG.HEAP) 3755 %bne(t1, t2, &.end) 3756 %hdr_type(t1, t0) 3757 %li(t2, %HDR.BV) 3758 %bne(t1, t2, &.end) 3759 %li(a0, %imm_val(%IMM.TRUE)) 3760 :.end 3761 %ret 3762 .endscope 3763 3764 # (set-car! pair val) / (set-cdr! pair val) -- in-place pair mutation. 3765 # No type check (matches car/cdr's lax stance); both return UNSPEC. 3766 :prim_set_car_entry 3767 %args2(t0, t1, a0) 3768 %set_car(t1, t0) 3769 %li(a0, %imm_val(%IMM.UNSPEC)) 3770 %ret 3771 3772 :prim_set_cdr_entry 3773 %args2(t0, t1, a0) 3774 %set_cdr(t1, t0) 3775 %li(a0, %imm_val(%IMM.UNSPEC)) 3776 %ret 3777 3778 # (length xs) -- count of pairs in a proper list. Forwards to the 3779 # list_length helper (which clobbers a0 as the cursor) and tags the 3780 # resulting count as a fixnum. Needs a frame because %call(&list_length) 3781 # would otherwise clobber lr and the trailing %ret would loop. 3782 %fn(prim_length_entry, 0, { 3783 %car(a0, a0) 3784 %call(&list_length) 3785 %mkfix(a0, a0) 3786 %eret 3787 }) 3788 3789 # (list-ref xs n) -- 0-indexed nth element. n is a fixnum; we untag, 3790 # advance via cdr, then car. Out-of-range is undefined behavior, same 3791 # as car/cdr on '(). 3792 :prim_list_ref_entry 3793 .scope 3794 %args2(t0, t1, a0) 3795 %sari(t1, t1, 3) 3796 :.loop 3797 %beqz(t1, &.done) 3798 %cdr(t0, t0) 3799 %addi(t1, t1, -1) 3800 %b(&.loop) 3801 :.done 3802 %car(a0, t0) 3803 %ret 3804 .endscope 3805 3806 # (assq key alist) -> matching pair or #f. Walks alist, comparing 3807 # car of each pair to key by identity (eq?); first match wins. Pure 3808 # leaf -- no allocation, no calls. Replaces the interpreted prelude 3809 # define so file-scope alist lookups (e.g. cc.scm scope-bind!'s 3810 # redecl check) don't pay bind_params env-cons cost per step. 3811 :prim_assq_entry 3812 .scope 3813 %args2(t0, t1, a0) ; t0=key, t1=alist 3814 :.loop 3815 %if_nil(t2, t1, &.miss) 3816 %car(t2, t1) ; pair = (car alist) 3817 %car(a0, t2) ; (car pair) 3818 %beq(a0, t0, &.hit) 3819 %cdr(t1, t1) 3820 %b(&.loop) 3821 :.hit 3822 %mov(a0, t2) 3823 %ret 3824 :.miss 3825 %li(a0, %imm_val(%IMM.FALSE)) 3826 %ret 3827 .endscope 3828 3829 # (assoc key alist) -> matching pair or #f. Same shape as assq but 3830 # the key compare goes through equal_recurse, which means we need a 3831 # frame to preserve the key/cursor/current-pair across the call. 3832 # 3833 # Locals: 3834 # key 3835 # cursor 3836 # pair (saved across equal_recurse so we can return it on hit) 3837 %fn2(prim_assoc_entry, {key cursor pair}, { 3838 %args2(t0, t1, a0) 3839 %stl(t0, key) 3840 %stl(t1, cursor) 3841 3842 :.loop 3843 %ldl(t1, cursor) 3844 %if_nil(t2, t1, &.miss) 3845 %car(t2, t1) ; pair = (car cursor) 3846 %stl(t2, pair) 3847 %car(a0, t2) ; (car pair) 3848 %ldl(a1, key) 3849 %call(&equal_recurse) 3850 %bieq(a0, %imm_val(%IMM.FALSE), &.next, t0) 3851 %ldl(a0, pair) 3852 %eret 3853 3854 :.next 3855 %ldl(t1, cursor) 3856 %cdr(t1, t1) 3857 %stl(t1, cursor) 3858 %b(&.loop) 3859 3860 :.miss 3861 %li(a0, %imm_val(%IMM.FALSE)) 3862 }) 3863 3864 # (reverse list) -> fresh reversed list. Walks the input forward, 3865 # consing each element onto an accumulator; result is the accumulator. 3866 # One fresh PAIR per input element, no intermediates. Frame needed 3867 # because cons is a leaf and %call clobbers lr. 3868 # 3869 # Locals: 3870 # xs (cursor; advanced each iteration) 3871 # acc 3872 %gcfn2(prim_reverse_entry, {xs acc}, 3, 0, { 3873 %car(t0, a0) ; t0 = list arg 3874 %stl(t0, xs) 3875 %li(t0, %imm_val(%IMM.NIL)) 3876 %stl(t0, acc) 3877 3878 :.loop 3879 %ldl(t0, xs) 3880 %if_nil(t1, t0, &.done) 3881 %car(a0, t0) 3882 %ldl(a1, acc) 3883 %call(&cons) 3884 %stl(a0, acc) 3885 %ldl(t0, xs) 3886 %cdr(t0, t0) 3887 %stl(t0, xs) 3888 %b(&.loop) 3889 3890 :.done 3891 %ldl(a0, acc) 3892 }) 3893 3894 # (bytevector-append bv ...) -- variadic concatenation. Two passes: 3895 # the first sums the bv lengths so we can size the result up front; the 3896 # second walks the args again and memcpy's each src into the result. 3897 # The args list head is saved at +0 because pass 1 walks a separate 3898 # cursor (t1) and pass 2 needs to re-read the head. memcpy clobbers 3899 # t-regs, so the running write offset and remaining-args cursor live 3900 # in the frame across each call. 3901 # 3902 # Locals: 3903 # args list head (re-read for pass 2; cursor during pass 2) 3904 # total length (raw) 3905 # result bv 3906 # write offset (raw, into result.data) 3907 %gcfn2(prim_bv_append_entry, {args total result write}, 5, 0, { 3908 %stl(a0, args) 3909 3910 %li(t0, 0) 3911 %mov(t1, a0) 3912 :.sum_loop 3913 %if_nil(t2, t1, &.sum_done) 3914 %car(t2, t1) 3915 %heap_ld(a0, t2, %BV.hdr) 3916 %shri(a0, a0, 8) 3917 %add(t0, t0, a0) 3918 %cdr(t1, t1) 3919 %b(&.sum_loop) 3920 :.sum_done 3921 %stl(t0, total) 3922 3923 %mov(a0, t0) 3924 %call(&bv_alloc) 3925 %stl(a0, result) 3926 3927 %li(t0, 0) 3928 %stl(t0, write) 3929 3930 :.copy_loop 3931 %ldl(t0, args) 3932 %if_nil(t1, t0, &.copy_done) 3933 %car(t1, t0) ; src bv 3934 %heap_ld(t2, t1, %BV.hdr) 3935 %shri(t2, t2, 8) ; src length 3936 3937 %ldl(a0, result) 3938 %heap_ld(a0, a0, %BV.data) ; result.data 3939 %ldl(a3, write) 3940 %add(a0, a0, a3) ; dst = result.data + offset 3941 %heap_ld(a1, t1, %BV.data) ; src.data 3942 %mov(a2, t2) ; count 3943 3944 %add(a3, a3, t2) 3945 %stl(a3, write) 3946 %cdr(t0, t0) 3947 %stl(t0, args) 3948 3949 %call(&memcpy) 3950 %b(&.copy_loop) 3951 :.copy_done 3952 3953 %ldl(a0, result) 3954 }) 3955 3956 # (string->symbol bv) -- intern the bytes and return the SYM-tagged 3957 # value. intern copies the name into stable heap storage if it has to 3958 # append, so the bv's data buffer is safe to relocate afterwards. 3959 :prim_string_to_symbol_entry 3960 %car(t0, a0) 3961 %heap_ld(a0, t0, %BV.data) 3962 %heap_ld(a1, t0, %BV.hdr) 3963 %shri(a1, a1, 8) ; length 3964 %b(&intern) 3965 3966 # (symbol->string sym) -- fresh bv copy of the symtab name. sym_name 3967 # returns (ptr, len); str_alloc gives us a NUL-terminated wrapper; 3968 # memcpy fills the data. Frame holds the (ptr, len) pair across 3969 # str_alloc and the resulting bv across memcpy. 3970 3971 %gcfn2(prim_symbol_to_string_entry, {ptr len bv}, 4, 0, { 3972 %car(a0, a0) 3973 %sari(a0, a0, 3) ; raw sym idx 3974 %call(&sym_name) ; -> ptr (a0), len (a1) 3975 %stl(a0, ptr) 3976 %stl(a1, len) 3977 %mov(a0, a1) 3978 %call(&str_alloc) ; tagged bv in a0 3979 %stl(a0, bv) 3980 %ldl(a1, ptr) ; src ptr 3981 %ldl(a2, len) ; len 3982 %heap_ld(t0, a0, %BV.data) ; dst = bv.data 3983 %mov(a0, t0) 3984 %call(&memcpy) 3985 %ldl(a0, bv) 3986 }) 3987 3988 # (number->string n [radix]) -- fresh bv with the integer's text form. 3989 # Radix 16 selects str_puthex (lowercase, leading '-' for negatives); 3990 # any other radix (or omitted) selects decimal. str_alloc(0) gives an 3991 # empty NUL-terminated wrapper that the str_put* helper grows in place. 3992 3993 %fn2(prim_number_to_string_entry, {value radix}, { 3994 %car(t0, a0) 3995 %sari(t0, t0, 3) ; raw value 3996 %stl(t0, value) 3997 3998 # Default radix = 10. If a second arg is present, untag it. 3999 %li(t0, 10) 4000 %stl(t0, radix) 4001 %cdr(t1, a0) 4002 %if_nil(t0, t1, &.have_radix) 4003 %car(t0, t1) 4004 %sari(t0, t0, 3) 4005 %stl(t0, radix) 4006 :.have_radix 4007 4008 %li(a0, 0) 4009 %call(&str_alloc) 4010 %ldl(a1, value) 4011 %ldl(t0, radix) 4012 %bieq(t0, 16, &.hex, t1) 4013 %tail(&str_putint) 4014 :.hex 4015 %tail(&str_puthex) 4016 }) 4017 4018 # (string->number bv [radix]) -- decimal goes through parse_dec; radix 4019 # 16 strips an optional leading '-' and calls parse_hex over the 4020 # remainder, demanding it consume every byte. Returns #f on 4021 # non-bytevector input, empty string, lone "-", or any non-recognized 4022 # byte. Other radices are not pinned by LISP.md and currently fall 4023 # through to the decimal path. 4024 %fn2(prim_string_to_number_entry, {args ptr len sign}, { 4025 %stl(a0, args) 4026 4027 %car(t2, a0) 4028 %tagof(t0, t2) 4029 %bine(t0, %TAG.HEAP, &.fail, t1) 4030 %hdr_type(t0, t2) 4031 %bine(t0, %HDR.BV, &.fail, t1) 4032 4033 %heap_ld(t0, t2, %BV.data) 4034 %heap_ld(t1, t2, %BV.hdr) 4035 %shri(t1, t1, 8) ; length 4036 %stl(t0, ptr) 4037 %stl(t1, len) 4038 4039 # Inspect the optional radix arg. 4040 %ldl(t0, args) 4041 %cdr(t0, t0) 4042 %if_nil(t1, t0, &.dec) 4043 %car(t1, t0) 4044 %sari(t1, t1, 3) 4045 %bieq(t1, 16, &.hex, t2) 4046 4047 :.dec 4048 %ldl(a0, ptr) 4049 %ldl(a1, len) 4050 %beqz(a1, &.fail) 4051 %lb(t0, a0, 0) 4052 %bcne(t0, -43, &.dec_no_plus, t0) ; '+' 4053 %addi(a0, a0, 1) 4054 %addi(a1, a1, -1) 4055 %beqz(a1, &.fail) 4056 :.dec_no_plus 4057 %stl(a1, len) ; save adjusted len 4058 %call(&parse_dec) ; P1pp: -> (raw_val=a0, consumed=a1) 4059 %ldl(t0, len) 4060 %bne(a1, t0, &.fail) ; partial parse -> fail 4061 %mkfix(a0, a0) 4062 %b(&.end) 4063 4064 :.hex 4065 # Strip optional leading '+' / '-'. 4066 %li(t0, 0) 4067 %stl(t0, sign) 4068 %ldl(t0, len) 4069 %beqz(t0, &.fail) 4070 %ldl(t1, ptr) 4071 %lb(t2, t1, 0) 4072 %addi(t0, t2, -45) ; '-' 4073 %beqz(t0, &.hex_neg) 4074 %addi(t0, t2, -43) ; '+' 4075 %beqz(t0, &.hex_skip_sign) 4076 %b(&.hex_parse) 4077 :.hex_neg 4078 %li(t0, 1) 4079 %stl(t0, sign) 4080 :.hex_skip_sign 4081 %ldl(t0, ptr) 4082 %addi(t0, t0, 1) 4083 %stl(t0, ptr) 4084 %ldl(t0, len) 4085 %addi(t0, t0, -1) 4086 %stl(t0, len) 4087 %beqz(t0, &.fail) 4088 4089 :.hex_parse 4090 %ldl(a0, ptr) 4091 %ldl(a1, len) 4092 %call(&parse_hex) ; -> (a0=value, a1=consumed) 4093 %ldl(t0, len) 4094 %bne(a1, t0, &.fail) ; demand full consumption 4095 %ldl(t0, sign) 4096 %beqz(t0, &.hex_pos) 4097 %li(t1, 0) 4098 %sub(a0, t1, a0) 4099 :.hex_pos 4100 %mkfix(a0, a0) 4101 %b(&.end) 4102 4103 :.fail 4104 %li(a0, %imm_val(%IMM.FALSE)) 4105 :.end 4106 }) 4107 4108 # (boolean? x) -- #t iff x is the IMM.FALSE or IMM.TRUE singleton. 4109 :prim_booleanq_entry 4110 .scope 4111 %car(t0, a0) 4112 %li(a0, %imm_val(%IMM.TRUE)) 4113 %li(t1, %imm_val(%IMM.FALSE)) 4114 %beq(t0, t1, &.end) 4115 %li(t1, %imm_val(%IMM.TRUE)) 4116 %beq(t0, t1, &.end) 4117 %li(a0, %imm_val(%IMM.FALSE)) 4118 :.end 4119 %ret 4120 .endscope 4121 4122 # (integer? x) -- #t iff x is a fixnum (low 3 tag bits == TAG.FIXNUM == 0). 4123 :prim_integerq_entry 4124 .scope 4125 %car(t0, a0) 4126 %tagof(t1, t0) 4127 %li(a0, %imm_val(%IMM.FALSE)) 4128 %bnez(t1, &.end) 4129 %li(a0, %imm_val(%IMM.TRUE)) 4130 :.end 4131 %ret 4132 .endscope 4133 4134 # (symbol? x) -- #t iff x is TAG.SYM (interned symbol index, not a heap obj). 4135 :prim_symbolq_entry 4136 .scope 4137 %car(t0, a0) 4138 %tagof(t1, t0) 4139 %li(t2, %TAG.SYM) 4140 %li(a0, %imm_val(%IMM.FALSE)) 4141 %bne(t1, t2, &.end) 4142 %li(a0, %imm_val(%IMM.TRUE)) 4143 :.end 4144 %ret 4145 .endscope 4146 4147 # (procedure? x) -- #t iff x is HEAP-tagged with header HDR.CLOSURE or HDR.PRIM. 4148 :prim_procedureq_entry 4149 .scope 4150 %car(t0, a0) 4151 %tagof(t1, t0) 4152 %li(t2, %TAG.HEAP) 4153 %li(a0, %imm_val(%IMM.FALSE)) 4154 %bne(t1, t2, &.end) 4155 %hdr_type(t1, t0) 4156 %li(t2, %HDR.CLOSURE) 4157 %beq(t1, t2, &.yes) 4158 %li(t2, %HDR.PRIM) 4159 %beq(t1, t2, &.yes) 4160 %b(&.end) 4161 :.yes 4162 %li(a0, %imm_val(%IMM.TRUE)) 4163 :.end 4164 %ret 4165 .endscope 4166 4167 :prim_zeroq_entry 4168 .scope 4169 %car(t0, a0) 4170 %li(a0, %imm_val(%IMM.FALSE)) 4171 %bnez(t0, &.end) 4172 %li(a0, %imm_val(%IMM.TRUE)) 4173 :.end 4174 %ret 4175 .endscope 4176 4177 :prim_not_entry 4178 .scope 4179 %car(t0, a0) 4180 %li(t1, %imm_val(%IMM.FALSE)) 4181 %li(a0, %imm_val(%IMM.FALSE)) 4182 %bne(t0, t1, &.end) 4183 %li(a0, %imm_val(%IMM.TRUE)) 4184 :.end 4185 %ret 4186 .endscope 4187 4188 :prim_eqq_entry 4189 .scope 4190 %car(t0, a0) 4191 %cdr(t1, a0) 4192 %car(t1, t1) 4193 %li(a0, %imm_val(%IMM.FALSE)) 4194 %bne(t0, t1, &.end) 4195 %li(a0, %imm_val(%IMM.TRUE)) 4196 :.end 4197 %ret 4198 .endscope 4199 4200 # Variadic arithmetic. (+ ...) folds with identity 0; (* ...) folds with 4201 # identity 1; (- x) is unary negate, (- x y z ...) folds left. 4202 4203 :prim_plus_entry 4204 .scope 4205 %li(t0, 0) ; tagged 0; tag bits stay 0 across %add 4206 :.loop 4207 %if_nil(t1, a0, &.done) 4208 %car(t1, a0) 4209 %add(t0, t0, t1) 4210 %cdr(a0, a0) 4211 %b(&.loop) 4212 :.done 4213 %mov(a0, t0) 4214 %ret 4215 .endscope 4216 4217 # (- x) -> -x; (- x y ...) -> x - y - ... . (-) is undefined behavior 4218 # per the primitive-failure policy. 4219 :prim_minus_entry 4220 .scope 4221 %car(t0, a0) ; seed = first arg (tagged) 4222 %cdr(a0, a0) 4223 %if_nil(t1, a0, &.neg) 4224 :.loop 4225 %if_nil(t1, a0, &.done) 4226 %car(t1, a0) 4227 %sub(t0, t0, t1) 4228 %cdr(a0, a0) 4229 %b(&.loop) 4230 :.neg 4231 %li(t1, 0) ; unary: 0 - seed 4232 %sub(t0, t1, t0) 4233 :.done 4234 %mov(a0, t0) 4235 %ret 4236 .endscope 4237 4238 # Multiply keeps the accumulator tagged and untags each incoming arg: 4239 # (a<<3) * b == (a*b)<<3, so the loop preserves the fixnum tag. 4240 :prim_mult_entry 4241 .scope 4242 %li(t0, 8) ; tagged 1 = mkfix(1) 4243 :.loop 4244 %if_nil(t1, a0, &.done) 4245 %car(t1, a0) 4246 %untag_fix(t1, t1) 4247 %mul(t0, t0, t1) 4248 %cdr(a0, a0) 4249 %b(&.loop) 4250 :.done 4251 %mov(a0, t0) 4252 %ret 4253 .endscope 4254 4255 # Variadic chained comparisons: (op a b c ...) ⇔ (a op b) ∧ (b op c) ∧ ... 4256 # Walks the tail with a single live `prev` register; a0 is reused as the 4257 # args cursor and finally as the result. <2 args is undefined behavior. 4258 :prim_eq_entry 4259 .scope 4260 %car(t0, a0) ; prev = first 4261 %cdr(a0, a0) 4262 :.loop 4263 %if_nil(t1, a0, &.true) 4264 %car(t1, a0) ; curr 4265 %bne(t0, t1, &.false) 4266 %mov(t0, t1) 4267 %cdr(a0, a0) 4268 %b(&.loop) 4269 :.true 4270 %li(a0, %imm_val(%IMM.TRUE)) 4271 %ret 4272 :.false 4273 %li(a0, %imm_val(%IMM.FALSE)) 4274 %ret 4275 .endscope 4276 4277 :prim_lt_entry 4278 .scope 4279 %car(t0, a0) 4280 %cdr(a0, a0) 4281 :.loop 4282 %if_nil(t1, a0, &.true) 4283 %car(t1, a0) 4284 %blt(t0, t1, &.ok) ; prev < curr -> continue 4285 %li(a0, %imm_val(%IMM.FALSE)) 4286 %ret 4287 :.ok 4288 %mov(t0, t1) 4289 %cdr(a0, a0) 4290 %b(&.loop) 4291 :.true 4292 %li(a0, %imm_val(%IMM.TRUE)) 4293 %ret 4294 .endscope 4295 4296 :prim_gt_entry 4297 .scope 4298 %car(t0, a0) 4299 %cdr(a0, a0) 4300 :.loop 4301 %if_nil(t1, a0, &.true) 4302 %car(t1, a0) 4303 %blt(t1, t0, &.ok) ; curr < prev <=> prev > curr -> continue 4304 %li(a0, %imm_val(%IMM.FALSE)) 4305 %ret 4306 :.ok 4307 %mov(t0, t1) 4308 %cdr(a0, a0) 4309 %b(&.loop) 4310 :.true 4311 %li(a0, %imm_val(%IMM.TRUE)) 4312 %ret 4313 .endscope 4314 4315 # (quotient x y) -- truncating integer division. Both fixnums are tagged 4316 # (real << 3); div(tagged, tagged) yields the raw quotient (the shifts 4317 # cancel), which mkfix retags. UB on y == 0. 4318 :prim_quotient_entry 4319 %args2(t0, t1, a0) 4320 %div(a0, t0, t1) 4321 %mkfix(a0, a0) 4322 %ret 4323 4324 # (remainder x y) -- truncating remainder, sign of dividend. rem(tagged, 4325 # tagged) = 8 * (real_x rem real_y), already in tagged form. 4326 :prim_remainder_entry 4327 %args2(t0, t1, a0) 4328 %rem(a0, t0, t1) 4329 %ret 4330 4331 # Variadic bitwise folds. Tagged fixnums have low 3 bits = 0, so AND/OR/ 4332 # XOR with another tagged fixnum preserves the tag in the accumulator. 4333 # Identities: bit-and -> -1 (tagged -8), bit-or -> 0, bit-xor -> 0. 4334 :prim_bit_and_entry 4335 .scope 4336 %li(t0, -8) ; tagged -1; AND-identity preserves the tag 4337 :.loop 4338 %if_nil(t1, a0, &.done) 4339 %car(t1, a0) 4340 %and(t0, t0, t1) 4341 %cdr(a0, a0) 4342 %b(&.loop) 4343 :.done 4344 %mov(a0, t0) 4345 %ret 4346 .endscope 4347 4348 :prim_bit_or_entry 4349 .scope 4350 %li(t0, 0) 4351 :.loop 4352 %if_nil(t1, a0, &.done) 4353 %car(t1, a0) 4354 %or(t0, t0, t1) 4355 %cdr(a0, a0) 4356 %b(&.loop) 4357 :.done 4358 %mov(a0, t0) 4359 %ret 4360 .endscope 4361 4362 :prim_bit_xor_entry 4363 .scope 4364 %li(t0, 0) 4365 :.loop 4366 %if_nil(t1, a0, &.done) 4367 %car(t1, a0) 4368 %xor(t0, t0, t1) 4369 %cdr(a0, a0) 4370 %b(&.loop) 4371 :.done 4372 %mov(a0, t0) 4373 %ret 4374 .endscope 4375 4376 # (bit-not n) -- bitwise complement. Untag, XOR with -1 (= ~n), retag. 4377 # Can't XOR the tagged value directly: that would flip the low 3 tag bits. 4378 :prim_bit_not_entry 4379 %car(t0, a0) 4380 %untag_fix(t0, t0) 4381 %li(t1, -1) 4382 %xor(t0, t0, t1) 4383 %mkfix(a0, t0) 4384 %ret 4385 4386 # (arithmetic-shift n k): k > 0 means left shift; k < 0 means arith right. 4387 # Untag both, branch on sign of k, retag. 4388 :prim_arith_shift_entry 4389 .scope 4390 %car(t0, a0) 4391 %cdr(t1, a0) 4392 %car(t1, t1) 4393 %untag_fix(t0, t0) 4394 %untag_fix(t1, t1) 4395 %bltz(t1, &.right) 4396 %shl(a0, t0, t1) 4397 %mkfix(a0, a0) 4398 %ret 4399 :.right 4400 %li(t2, 0) 4401 %sub(t1, t2, t1) 4402 %sar(a0, t0, t1) 4403 %mkfix(a0, a0) 4404 %ret 4405 .endscope 4406 4407 # Bytevectors are 24-byte HEAP-tagged wrappers pointing at a separately 4408 # allocated data buffer; this gives them dynamic-array semantics — capacity 4409 # can grow in place by reallocating just the data buffer (no need to find 4410 # and patch every reference to the wrapper). 4411 # 4412 # word 0 :: (length << 8) | HDR.BV ; length = hdr >> 8 4413 # word 1 :: data_ptr (raw heap address) 4414 # word 2 :: capacity in bytes 4415 # 4416 # Tagged-pointer offsets into the wrapper: 4417 # hdr = ld(bv, -3) 4418 # data_ptr = ld(bv, 5) 4419 # capacity = ld(bv, 13) 4420 # 4421 # bv_capacity_for(n) returns the smallest power-of-two ≥ max(n, 16); bv_grow 4422 # then doubles by repeatedly shifting until cap ≥ requested. Bytevectors 4423 # are raw u8[] and need no headroom for a NUL terminator -- callers that 4424 # build "strings" use the str_* writers, which reserve cap > len AND 4425 # explicitly zero data[len] (reused GC blocks are not assumed zeroed). 4426 4427 # alloc_bytes(size=a0) -> managed RAW payload address (a0). 4428 :alloc_bytes 4429 %li(a1, %GCKIND.RAW) 4430 %b(&gc_alloc) 4431 4432 # bv_capacity_for(n=a0) -> smallest power-of-two ≥ n, minimum 16. Pure 4433 # bytevector sizing -- no NUL slack. Callers building "strings" call 4434 # bv_capacity_for(raw_len + 1) to reserve room for the trailing NUL. 4435 :bv_capacity_for 4436 .scope 4437 %li(t0, 16) 4438 :.loop 4439 %bltu(t0, a0, &.shift) ; t0 < a0: keep doubling 4440 %mov(a0, t0) ; t0 >= a0: done 4441 %ret 4442 :.shift 4443 %shli(t0, t0, 1) 4444 %b(&.loop) 4445 .endscope 4446 4447 # bv_alloc(raw_len=a0) -> tagged bv (a0). Length = raw_len, capacity from 4448 # bv_capacity_for, data buffer uninitialized. data_ptr lives in a frame 4449 # slot because alloc_hdr's alignup clobbers t-regs. 4450 # 4451 # Locals: 4452 # raw_len 4453 # capacity 4454 # data_ptr (raw) 4455 %gcfn2(bv_alloc, {raw_len capacity data_ptr}, 0, 4, { 4456 %stl(a0, raw_len) 4457 4458 %call(&bv_capacity_for) 4459 %stl(a0, capacity) 4460 %call(&alloc_bytes) 4461 %stl(a0, data_ptr) 4462 4463 %ldl(a1, raw_len) 4464 %shli(a1, a1, 8) ; hdr = (raw_len << 8) | HDR.BV (BV == 0) 4465 %li(a0, 24) 4466 %call(&alloc_hdr) 4467 4468 %ldl(t0, data_ptr) 4469 %heap_st(t0, a0, %BV.data) 4470 %ldl(t1, capacity) 4471 %st(t1, a0, 13) ; bv.cap (raw offset 16; not in BV struct) 4472 }) 4473 4474 # bv_grow(bv=a0, min_cap=a1) -> bv (a0). Doubles capacity until ≥ min_cap; 4475 # allocates a fresh data buffer, copies the live bytes (length, not 4476 # capacity), and patches the wrapper's data_ptr/capacity slots in place. 4477 # A no-op when current capacity already satisfies min_cap. 4478 # 4479 # Locals: 4480 # bv 4481 # min_cap (input) / new_cap (during loop) 4482 # new_data_ptr 4483 # raw length 4484 %gcfn2(bv_grow, {bv min_cap new_data_ptr raw}, 1, 4, { 4485 %stl(a0, bv) 4486 %stl(a1, min_cap) 4487 4488 %ld(t0, a0, 13) ; bv.cap (raw offset 16; not in BV struct) 4489 %bltu(t0, a1, &.need) 4490 %ldl(a0, bv) 4491 %gceret 4492 4493 :.need 4494 :.loop 4495 %shli(t0, t0, 1) 4496 %ldl(t1, min_cap) 4497 %bltu(t0, t1, &.loop) 4498 %stl(t0, min_cap) 4499 4500 %mov(a0, t0) 4501 %call(&alloc_bytes) 4502 %stl(a0, new_data_ptr) 4503 4504 %ldl(t0, bv) 4505 %heap_ld(t1, t0, %BV.hdr) 4506 %shri(t1, t1, 8) ; raw length 4507 %stl(t1, raw) 4508 %ldl(a0, new_data_ptr) 4509 %heap_ld(a1, t0, %BV.data) ; old data ptr 4510 %ldl(a2, raw) 4511 %call(&memcpy) 4512 4513 %ldl(t0, bv) 4514 %ldl(t1, new_data_ptr) 4515 %heap_st(t1, t0, %BV.data) 4516 %ldl(t1, min_cap) 4517 %st(t1, t0, 13) ; bv.cap (raw offset 16; not in BV struct) 4518 %ldl(a0, bv) 4519 }) 4520 4521 # (make-bytevector len) or (make-bytevector len fill) 4522 4523 %gcfn2(prim_make_bytevector_entry, {args fill wrapper}, 5, 0, { 4524 %stl(a0, args) 4525 4526 %li(t2, 0) 4527 %cdr(t0, a0) 4528 %if_nil(t1, t0, &.no_fill) 4529 %car(t0, t0) 4530 %sari(t2, t0, 3) 4531 :.no_fill 4532 %stl(t2, fill) 4533 4534 %ldl(a0, args) 4535 %car_fix(a0, a0) 4536 %bltz(a0, &.bad_len) 4537 %call(&bv_alloc) 4538 %stl(a0, wrapper) 4539 4540 %ldl(t0, args) 4541 %car_fix(t0, t0) ; raw_len 4542 %ldl(t1, fill) ; fill 4543 %ldl(a1, wrapper) 4544 %heap_ld(t2, a1, %BV.data) 4545 %li(a1, 0) 4546 4547 :.fill_loop 4548 %beq(a1, t0, &.fill_done) 4549 %sb(t1, t2, 0) 4550 %addi(t2, t2, 1) 4551 %addi(a1, a1, 1) 4552 %b(&.fill_loop) 4553 :.fill_done 4554 4555 %ldl(a0, wrapper) 4556 %gceret 4557 4558 :.bad_len 4559 %die(msg_bv_oob) 4560 }) 4561 4562 :prim_bv_length_entry 4563 %car(t0, a0) 4564 %heap_ld(t1, t0, %BV.hdr) 4565 %shri(a0, t1, 5) 4566 %ret 4567 4568 # (string-length s) -- assumes s is a NUL-terminated bv (a "string"); 4569 # returns strlen(data_ptr). Mirrors bytevector-length but uses the NUL 4570 # terminator instead of the bv header. For a well-formed string built 4571 # via str_alloc / str_putn / etc the two agree; for a raw bytevector 4572 # without a NUL the result is unspecified (strlen may walk past the 4573 # data buffer). 4574 %fn(prim_string_length_entry, 0, { 4575 %car(t0, a0) 4576 %heap_ld(a0, t0, %BV.data) 4577 %call(&libp1pp__strlen) 4578 %mkfix(a0, a0) 4579 %eret 4580 }) 4581 4582 :prim_bv_u8_ref_entry 4583 .scope 4584 %args2(t0, t1, a0) ; bv, tagged idx 4585 %sari(t1, t1, 3) ; raw idx 4586 %bltz(t1, &.oob) 4587 %heap_ld(a0, t0, %BV.hdr) 4588 %shri(a0, a0, 8) ; length 4589 %bltu(t1, a0, &.ok) 4590 :.oob 4591 %die(msg_bv_oob) 4592 :.ok 4593 %heap_ld(t2, t0, %BV.data) 4594 %add(t2, t2, t1) 4595 %lb(a0, t2, 0) 4596 %mkfix(a0, a0) 4597 %ret 4598 .endscope 4599 4600 :prim_bv_u8_set_entry 4601 .scope 4602 %args3(t0, t2, t1, a0) ; bv, idx, val 4603 %sari(t2, t2, 3) ; raw idx 4604 %sari(t1, t1, 3) ; raw val 4605 %bltz(t2, &.oob) 4606 %heap_ld(a0, t0, %BV.hdr) 4607 %shri(a0, a0, 8) ; length 4608 %bltu(t2, a0, &.ok) 4609 :.oob 4610 %die(msg_bv_oob) 4611 :.ok 4612 %heap_ld(a0, t0, %BV.data) 4613 %add(a0, a0, t2) 4614 %sb(t1, a0, 0) 4615 %li(a0, %imm_val(%IMM.UNSPEC)) 4616 %ret 4617 .endscope 4618 4619 # (bytevector-copy src start end) -> fresh bv of length end-start. 4620 # Bounds: 0 <= start <= end <= src.length. 4621 # 4622 # Locals: 4623 # args 4624 # src tagged 4625 # wrapper (saved after bv_alloc) 4626 %gcfn2(prim_bv_copy_entry, {args src wrapper}, 7, 0, { 4627 %stl(a0, args) 4628 4629 %args3(t0, t2, t1, a0) ; src, start, end 4630 %stl(t0, src) 4631 %sari(t2, t2, 3) ; raw start 4632 %sari(t1, t1, 3) ; raw end 4633 4634 # Bounds: start >= 0; end >= start (signed catches negative end since 4635 # start is now non-negative); src.length >= end. 4636 %bltz(t2, &.oob) 4637 %blt(t1, t2, &.oob) 4638 %heap_ld(a0, t0, %BV.hdr) 4639 %shri(a0, a0, 8) ; src.length 4640 %blt(a0, t1, &.oob) 4641 4642 %sub(a0, t1, t2) ; count 4643 %call(&bv_alloc) 4644 %stl(a0, wrapper) 4645 4646 # Recompute src ptr at start; dst ptr at 0; count from new bv's hdr. 4647 %ldl(t0, args) 4648 %cdr(t0, t0) 4649 %car_fix(t0, t0) ; raw start 4650 %ldl(t1, src) 4651 %heap_ld(t2, t1, %BV.data) 4652 %add(t2, t2, t0) ; src ptr 4653 %ldl(a3, wrapper) 4654 %heap_ld(a2, a3, %BV.data) ; dst ptr 4655 %heap_ld(a1, a3, %BV.hdr) 4656 %shri(a1, a1, 8) ; count 4657 4658 :.copy_loop 4659 %beqz(a1, &.copy_done) 4660 %lb(t0, t2, 0) 4661 %sb(t0, a2, 0) 4662 %addi(t2, t2, 1) 4663 %addi(a2, a2, 1) 4664 %addi(a1, a1, -1) 4665 %b(&.copy_loop) 4666 4667 :.copy_done 4668 %ldl(a0, wrapper) 4669 %gceret 4670 4671 :.oob 4672 %die(msg_bv_oob) 4673 }) 4674 4675 # (bytevector-copy! dst dst-start src src-start src-end). Bounds: 4676 # 0 <= src-start <= src-end <= src.length and 4677 # 0 <= dst-start && dst-start + (src-end-src-start) <= dst.length. 4678 # 4679 # Locals: 4680 # dst -start (raw) 4681 # dst_start 4682 # src -end (raw) 4683 # src_start 4684 # src_end 4685 %fn2(prim_bv_copy_bang_entry, {dst dst_start src src_start src_end}, { 4686 %car(t0, a0) 4687 %stl(t0, dst) ; dst 4688 %cdr(a0, a0) 4689 %car(t0, a0) 4690 %sari(t0, t0, 3) 4691 %stl(t0, dst_start) ; dst-start 4692 %cdr(a0, a0) 4693 %car(t0, a0) 4694 %stl(t0, src) ; src 4695 %cdr(a0, a0) 4696 %car(t0, a0) 4697 %sari(t0, t0, 3) 4698 %stl(t0, src_start) ; src-start 4699 %cdr(a0, a0) 4700 %car(t0, a0) 4701 %sari(t0, t0, 3) 4702 %stl(t0, src_end) ; src-end 4703 4704 # src-start >= 0 4705 %ldl(t0, src_start) 4706 %bltz(t0, &.oob) 4707 # src-end >= src-start (signed catches negative src-end) 4708 %ldl(t1, src_end) 4709 %blt(t1, t0, &.oob) 4710 # src-end <= src.length 4711 %ldl(t2, src) 4712 %heap_ld(a0, t2, %BV.hdr) 4713 %shri(a0, a0, 8) 4714 %blt(a0, t1, &.oob) 4715 # dst-start >= 0 4716 %ldl(t2, dst_start) 4717 %bltz(t2, &.oob) 4718 # dst-start + count <= dst.length 4719 %sub(a0, t1, t0) ; count = src-end - src-start 4720 %add(a0, a0, t2) ; dst-start + count 4721 %ldl(t1, dst) 4722 %heap_ld(t2, t1, %BV.hdr) 4723 %shri(t2, t2, 8) 4724 %blt(t2, a0, &.oob) 4725 4726 # Set up copy. dst ptr = dst.data + dst-start; src ptr = src.data + 4727 # src-start; count = src-end - src-start. 4728 %ldl(t0, dst) 4729 %heap_ld(t0, t0, %BV.data) 4730 %ldl(a1, dst_start) 4731 %add(t0, t0, a1) ; dst ptr 4732 %ldl(a1, src) 4733 %heap_ld(a1, a1, %BV.data) 4734 %ldl(a2, src_start) 4735 %add(a1, a1, a2) ; src ptr 4736 %ldl(a3, src_end) 4737 %sub(a3, a3, a2) ; count 4738 4739 :.loop 4740 %beqz(a3, &.done) 4741 %lb(t1, a1, 0) 4742 %sb(t1, t0, 0) 4743 %addi(t0, t0, 1) 4744 %addi(a1, a1, 1) 4745 %addi(a3, a3, -1) 4746 %b(&.loop) 4747 4748 :.done 4749 %li(a0, %imm_val(%IMM.UNSPEC)) 4750 %eret 4751 4752 :.oob 4753 %die(msg_bv_oob) 4754 }) 4755 4756 # bv_equal_check(a=a0, b=a1) -> a0 (IMM.TRUE / IMM.FALSE). Leaf. Both 4757 # arguments are assumed to be HEAP-tagged HDR.BV values; callers do the 4758 # type check (either bytevector=?'s prim entry or equal_recurse's BV 4759 # branch). Compares lengths first, then walks bytes; %lb is zero-extending 4760 # on every backend, so a single %bne is enough for the byte test. 4761 :bv_equal_check 4762 .scope 4763 %heap_ld(t0, a0, %BV.hdr) 4764 %shri(t0, t0, 8) ; len_a 4765 %heap_ld(t1, a1, %BV.hdr) 4766 %shri(t1, t1, 8) ; len_b 4767 %bne(t0, t1, &.false) 4768 4769 %heap_ld(a2, a0, %BV.data) 4770 %heap_ld(a3, a1, %BV.data) 4771 4772 :.loop 4773 %beqz(t0, &.true) 4774 %lb(t1, a2, 0) 4775 %lb(t2, a3, 0) 4776 %bne(t1, t2, &.false) 4777 %addi(a2, a2, 1) 4778 %addi(a3, a3, 1) 4779 %addi(t0, t0, -1) 4780 %b(&.loop) 4781 4782 :.true 4783 %li(a0, %imm_val(%IMM.TRUE)) 4784 %ret 4785 4786 :.false 4787 %li(a0, %imm_val(%IMM.FALSE)) 4788 %ret 4789 .endscope 4790 4791 # (bytevector=? a b) -- structural equality on bytevectors. Non-bv 4792 # inputs return #f rather than aborting, matching the lax stance the 4793 # other predicates take until LISP.md pins a stricter policy. 4794 :prim_bytevector_eq_entry 4795 .scope 4796 %args2(t0, t1, a0) 4797 %tagof(t2, t0) 4798 %li(a0, %TAG.HEAP) 4799 %bne(t2, a0, &.false) 4800 %tagof(t2, t1) 4801 %bne(t2, a0, &.false) 4802 %hdr_type(t2, t0) 4803 %li(a0, %HDR.BV) 4804 %bne(t2, a0, &.false) 4805 %hdr_type(t2, t1) 4806 %bne(t2, a0, &.false) 4807 %mov(a0, t0) 4808 %mov(a1, t1) 4809 %b(&bv_equal_check) 4810 :.false 4811 %li(a0, %imm_val(%IMM.FALSE)) 4812 %ret 4813 .endscope 4814 4815 # equal_recurse(a=a0, b=a1) -> a0 (IMM.TRUE / IMM.FALSE). Identity covers 4816 # fixnums, symbols, immediates, and any case where both arguments are the 4817 # same heap or pair pointer. For non-identical pair pointers we recurse 4818 # into car then cdr; for non-identical heap pointers we structural-equal 4819 # only when both are HDR.BV (closures, prims, records, and TDs are 4820 # identity-only). Tail-calls the cdr-side recursion and the BV check. 4821 # 4822 # Locals: 4823 # a 4824 # b 4825 %fn2(equal_recurse, {a b}, { 4826 %stl(a0, a) 4827 %stl(a1, b) 4828 4829 %beq(a0, a1, &.true) 4830 4831 %tagof(t0, a0) 4832 %tagof(t1, a1) 4833 %bne(t0, t1, &.false) 4834 4835 %bieq(t0, %TAG.PAIR, &.pair, t1) 4836 %bieq(t0, %TAG.HEAP, &.heap, t1) 4837 %b(&.false) 4838 4839 :.pair 4840 %ldl(t0, a) 4841 %ldl(t1, b) 4842 %car(a0, t0) 4843 %car(a1, t1) 4844 %call(&equal_recurse) 4845 %bieq(a0, %imm_val(%IMM.FALSE), &.done, t0) 4846 %ldl(t0, a) 4847 %ldl(t1, b) 4848 %cdr(a0, t0) 4849 %cdr(a1, t1) 4850 %tail(&equal_recurse) 4851 4852 :.heap 4853 %ldl(t0, a) 4854 %ldl(t1, b) 4855 %hdr_type(t2, t0) 4856 %hdr_type(a0, t1) 4857 %bne(t2, a0, &.false) ; differing heap classes -> #f 4858 %li(a0, %HDR.BV) 4859 %beq(t2, a0, &.heap_bv) 4860 %li(a0, %HDR.REC) 4861 %beq(t2, a0, &.heap_rec) 4862 %b(&.false) ; CLOSURE/PRIM/TD: identity-only 4863 4864 :.heap_bv 4865 %mov(a0, t0) 4866 %mov(a1, t1) 4867 %tail(&bv_equal_check) 4868 4869 :.heap_rec 4870 %mov(a0, t0) 4871 %mov(a1, t1) 4872 %tail(&rec_equal_check) 4873 4874 :.true 4875 %li(a0, %imm_val(%IMM.TRUE)) 4876 %b(&.done) 4877 4878 :.false 4879 %li(a0, %imm_val(%IMM.FALSE)) 4880 4881 :.done 4882 }) 4883 4884 # rec_equal_check(a=a0, b=a1) -> a0 (IMM.TRUE / IMM.FALSE). Both args 4885 # are HEAP-tagged HDR.REC. Records are equal iff their TDs are eq? and 4886 # every field is equal? (recursing through equal_recurse). Field i sits 4887 # at tagged + 13 + 8*i; nfields lives at the TD's offset 13 (raw). 4888 # 4889 # Locals: 4890 # a (rec, tagged) 4891 # b (rec, tagged) 4892 # i (raw counter) 4893 # nfields (raw) 4894 %fn2(rec_equal_check, {a b i nfields}, { 4895 %stl(a0, a) 4896 %stl(a1, b) 4897 4898 %heap_ld(t0, a0, %REC.td) ; td_a 4899 %heap_ld(t1, a1, %REC.td) ; td_b 4900 %bne(t0, t1, &.false) 4901 4902 %heap_ld(t1, t0, %TD.nfields) 4903 %stl(t1, nfields) 4904 %li(t0, 0) 4905 %stl(t0, i) ; i = 0 4906 4907 :.loop 4908 %ldl(t0, i) 4909 %ldl(t1, nfields) 4910 %beq(t0, t1, &.true) 4911 4912 %shli(t2, t0, 3) 4913 %addi(t2, t2, 13) ; field offset = 13 + 8*i 4914 %ldl(t1, a) 4915 %add(t1, t1, t2) 4916 %ld(a0, t1, 0) ; a's field i 4917 %ldl(t1, b) 4918 %add(t1, t1, t2) 4919 %ld(a1, t1, 0) ; b's field i 4920 %call(&equal_recurse) 4921 %bieq(a0, %imm_val(%IMM.FALSE), &.done, t0) 4922 4923 %ldl(t0, i) 4924 %addi(t0, t0, 1) 4925 %stl(t0, i) 4926 %b(&.loop) 4927 4928 :.true 4929 %li(a0, %imm_val(%IMM.TRUE)) 4930 %b(&.done) 4931 4932 :.false 4933 %li(a0, %imm_val(%IMM.FALSE)) 4934 4935 :.done 4936 }) 4937 4938 # (equal? a b) -- thin prim wrapper that unpacks the args list and falls 4939 # into equal_recurse. equal_recurse owns the frame; this entry stays a 4940 # leaf so the prim-dispatch tailr lands directly into the frame setup. 4941 :prim_equal_entry 4942 %args2(t0, t1, a0) 4943 %mov(a0, t0) 4944 %mov(a1, t1) 4945 %b(&equal_recurse) 4946 4947 # (apply fn rest...) -- the trailing element of `rest` is a list; any 4948 # leading elements get prepended to it. apply_build_args walks `rest` and 4949 # returns the assembled args list; prim_apply_entry then tail-calls apply. 4950 # 4951 # `apply` is itself a primitive, so on entry here a0 holds (fn . rest) 4952 # and a1 holds the apply PRIM ptr (per the convention documented at 4953 # `apply::prim`). a1 is dead from this primitive's point of view; we 4954 # clobber it freely while assembling args, then tail-call apply, which 4955 # re-derives a1 from the callee fn it dispatches on. Outer convention 4956 # stays intact end-to-end. 4957 4958 %gcfn2(prim_apply_entry, {args pad}, 1, 0, { 4959 %stl(a0, args) 4960 %cdr(a0, a0) 4961 %call(&apply_build_args) 4962 %mov(t0, a0) 4963 %ldl(a0, args) 4964 %car(a0, a0) 4965 %mov(a1, t0) 4966 %gctail(&apply) 4967 }) 4968 4969 # apply_build_args(rest=a0) -> assembled args list. 4970 # `rest` is (a1 a2 ... aN listargs); the trailing element is itself a list 4971 # whose elements get appended after the leading aâ‚–'s. Iterative 4972 # head/tail-cdr build: walk every cell whose cdr isn't NIL into a fresh 4973 # (aâ‚– . NIL) cons; the final element (the trailing list) becomes the 4974 # tail's cdr (or the result itself if there are no leading elements). 4975 # 4976 # Locals: 4977 # walk (advances; current cell of rest) 4978 # head (NIL until first leading arg appended) 4979 # tail (most recent cell; set-cdr! target) 4980 %gcfn2(apply_build_args, {walk head tail}, 7, 0, { 4981 %stl(a0, walk) 4982 %li(t0, %imm_val(%IMM.NIL)) 4983 %stl(t0, head) 4984 %stl(t0, tail) 4985 4986 :.loop 4987 %ldl(t0, walk) 4988 %cdr(t1, t0) 4989 %if_nil(t2, t1, &.last) 4990 4991 # cell = cons(car(walk), NIL); append to head/tail. 4992 %car(a0, t0) 4993 %li(a1, %imm_val(%IMM.NIL)) 4994 %call(&cons) 4995 4996 %ldl(t0, head) 4997 %if_nil(t1, t0, &.first) 4998 %ldl(t0, tail) 4999 %set_cdr(a0, t0) 5000 %stl(a0, tail) 5001 %b(&.advance) 5002 5003 :.first 5004 %stl(a0, head) 5005 %stl(a0, tail) 5006 5007 :.advance 5008 %advance_walk(walk) 5009 %b(&.loop) 5010 5011 :.last 5012 # car(walk) is the trailing list. If head is NIL there were no leading 5013 # args -- return the trailing list directly. Otherwise splice it onto 5014 # the tail and return head. 5015 %car(a0, t0) 5016 %ldl(t1, head) 5017 %if_nil(t2, t1, &.done) 5018 %ldl(t1, tail) 5019 %set_cdr(a0, t1) 5020 %ldl(a0, head) 5021 5022 :.done 5023 }) 5024 5025 # Records: TDs (type descriptors) and instances. A TD is a 24-byte heap 5026 # object [HDR.TD][name_sym][nfields_raw]. A record is a variable-width 5027 # heap object [HDR.REC][td][field_0]...[field_{n-1}], so field i lives at 5028 # tagged + 13 + 8*i. define-record-type allocates one TD plus one 5029 # parameterized PRIM per ctor/predicate/accessor/mutator, all pointing 5030 # into the same TD via the prim's data slot. 5031 5032 # make_param_prim(entry=a0, data=a1) -> prim (a0). Allocates a 24-byte 5033 # PRIM and sets the entry label and data word. Generated primitives stay 5034 # reachable through their global bindings. 5035 5036 %gcfn2(make_param_prim, {entry data}, 2, 0, { 5037 %stl(a0, entry) 5038 %stl(a1, data) 5039 5040 %li(a0, 24) 5041 %li(a1, %HDR.PRIM) 5042 %call(&alloc_hdr) 5043 5044 %ldl(t0, entry) 5045 %heap_st(t0, a0, %PRIM.entry_w) 5046 %ldl(t1, data) 5047 %heap_st(t1, a0, %PRIM.data) 5048 }) 5049 5050 # Parameterized PRIM entries used by define-record-type. Each receives 5051 # args in a0 and the prim itself in a1; the prim's data slot (offset 13 5052 # from tagged) holds either the TD or a tagged field index. The 5053 # constructor inlines record allocation; predicate / accessor / mutator 5054 # inline what would otherwise be %record-is-a? / %record-ref / 5055 # %record-set! bodies. None of these primitives are exposed at the 5056 # user level — R7RS define-record-type binds only ctor / pred / 5057 # accessor / mutator names. 5058 5059 # ctor: prim.data = TD (HEAP); args = (f0 f1 ...). Inlines the 5060 # %make-record body so we don't have to cons (TD . args) first. 5061 5062 %gcfn2(prim_ctor_entry, {args td record}, 7, 0, { 5063 %stl(a0, args) 5064 %heap_ld(t0, a1, %PRIM.data) 5065 %stl(t0, td) 5066 5067 # Count = length(args). 5068 %call(&list_length) 5069 %shli(a0, a0, 3) 5070 %addi(a0, a0, 16) 5071 %li(a1, %HDR.REC) 5072 %call(&alloc_hdr) 5073 %stl(a0, record) 5074 5075 %ldl(t0, td) 5076 %heap_st(t0, a0, %REC.td) 5077 5078 %ldl(t0, args) 5079 %addi(t1, a0, 13) 5080 5081 :.fill_loop 5082 %if_nil(t2, t0, &.fill_done) 5083 %car(t2, t0) 5084 %st(t2, t1, 0) 5085 %addi(t1, t1, 8) 5086 %cdr(t0, t0) 5087 %b(&.fill_loop) 5088 :.fill_done 5089 5090 %ldl(a0, record) 5091 }) 5092 5093 # predicate: prim.data = TD; args = (rec). 5094 :prim_predicate_entry 5095 .scope 5096 %car(t0, a0) 5097 %heap_ld(t1, a1, %PRIM.data) 5098 %tagof(t2, t0) 5099 %li(a0, %imm_val(%IMM.FALSE)) 5100 %bine(t2, %TAG.HEAP, &.end, a2) 5101 %hdr_type(t2, t0) 5102 %bine(t2, %HDR.REC, &.end, a2) 5103 %heap_ld(t2, t0, %REC.td) 5104 %bne(t2, t1, &.end) 5105 %li(a0, %imm_val(%IMM.TRUE)) 5106 :.end 5107 %ret 5108 .endscope 5109 5110 # accessor: prim.data = tagged field index; args = (rec). 5111 :prim_accessor_entry 5112 %car(t0, a0) 5113 %heap_ld(t1, a1, %PRIM.data) 5114 %addi(t1, t1, 13) 5115 %add(t1, t1, t0) 5116 %ld(a0, t1, 0) 5117 %ret 5118 5119 # mutator: prim.data = tagged field index; args = (rec val). 5120 :prim_mutator_entry 5121 .scope 5122 %car(t0, a0) 5123 %cdr(t1, a0) 5124 %car(t1, t1) 5125 %heap_ld(t2, a1, %PRIM.data) 5126 %addi(t2, t2, 13) 5127 %add(t2, t2, t0) 5128 %st(t1, t2, 0) 5129 %li(a0, %imm_val(%IMM.UNSPEC)) 5130 %ret 5131 .endscope 5132 5133 # eval_define_record_type(rest=a0, env=a1) -> UNSPEC. 5134 # rest = (name (ctor f1 ...) pred clause1 clause2 ...) 5135 # Each clause is (field-name accessor) or (field-name accessor mutator). 5136 # Allocates one TD + one parameterized PRIM per name introduced (ctor, 5137 # predicate, accessor, mutator) and binds each to the symbol's global. 5138 # The TD also stores a list of field-name symbols in declaration order; 5139 # pmatch's ($ pred (field pat) ...) record pattern uses this to map 5140 # field names to indices at match time. 5141 # 5142 # Locals: 5143 # rest 5144 # env (unused, but the dispatcher passes it) 5145 # td 5146 # walk (clauses, advancing) 5147 # idx (raw counter) 5148 # nfields 5149 # fl_head (head of field-name list under construction) 5150 # fl_tail (tail cell of field-name list under construction) 5151 # fl_cur (cursor walking clauses for field-name pre-pass) 5152 %gcfn2(eval_define_record_type, {rest env td walk idx nfields fl_head fl_tail fl_cur}, 463, 0, { 5153 %stl(a0, rest) 5154 %stl(a1, env) 5155 5156 # clauses = cdddr(rest); count them via list_length. 5157 %ldl(a0, rest) 5158 %cdr(a0, a0) 5159 %cdr(a0, a0) 5160 %cdr(a0, a0) 5161 %stl(a0, walk) 5162 %call(&list_length) 5163 %stl(a0, nfields) 5164 5165 # td = alloc_hdr(TD.SIZE, HDR.TD); td.name = type-name; 5166 # td.nfields = nfields; td.fields = NIL (filled below). 5167 %li(a0, %TD.SIZE) 5168 %li(a1, %HDR.TD) 5169 %call(&alloc_hdr) 5170 %stl(a0, td) 5171 %ldl(t0, rest) 5172 %car(t0, t0) 5173 %heap_st(t0, a0, %TD.name) 5174 %ldl(t1, nfields) 5175 %heap_st(t1, a0, %TD.nfields) 5176 %li(t1, %imm_val(%IMM.NIL)) 5177 %heap_st(t1, a0, %TD.fields) 5178 5179 # Pre-pass: build (field-name-1 ... field-name-N) in declaration order 5180 # via head/tail accumulator, then store at td.fields. Each clause's 5181 # car is the field-name symbol. Uses fl_cur as a separate cursor so 5182 # walk is left intact for the accessor-binding loop below. 5183 %li(t0, %imm_val(%IMM.NIL)) 5184 %stl(t0, fl_head) 5185 %stl(t0, fl_tail) 5186 %ldl(t0, walk) 5187 %stl(t0, fl_cur) 5188 5189 :.fl_loop 5190 %ldl(t0, fl_cur) 5191 %if_nil(t1, t0, &.fl_done) 5192 # cell = cons(car(car(fl_cur)), NIL) 5193 %car(t1, t0) 5194 %car(a0, t1) 5195 %li(a1, %imm_val(%IMM.NIL)) 5196 %call(&cons) 5197 # Splice into list: if head is NIL, head = tail = cell. 5198 # Else set-cdr!(tail, cell); tail = cell. 5199 %ldl(t1, fl_head) 5200 %bine(t1, %imm_val(%IMM.NIL), &.fl_append, t2) 5201 %stl(a0, fl_head) 5202 %stl(a0, fl_tail) 5203 %b(&.fl_next) 5204 :.fl_append 5205 %ldl(t1, fl_tail) 5206 %set_cdr(a0, t1) 5207 %stl(a0, fl_tail) 5208 :.fl_next 5209 %ldl(t0, fl_cur) 5210 %cdr(t0, t0) 5211 %stl(t0, fl_cur) 5212 %b(&.fl_loop) 5213 5214 :.fl_done 5215 %ldl(t0, td) 5216 %ldl(t1, fl_head) 5217 %heap_st(t1, t0, %TD.fields) 5218 5219 # ctor-prim = make_param_prim(prim_ctor_entry, td); bind ctor-name. 5220 %la(a0, &prim_ctor_entry) 5221 %ldl(a1, td) 5222 %call(&make_param_prim) 5223 %ldl(t0, rest) 5224 %cdr(t0, t0) 5225 %car(t0, t0) 5226 %car(t0, t0) 5227 %set_global(t0, a0) 5228 5229 # pred-prim = make_param_prim(prim_predicate_entry, td); bind pred. 5230 %la(a0, &prim_predicate_entry) 5231 %ldl(a1, td) 5232 %call(&make_param_prim) 5233 %ldl(t0, rest) 5234 %cdr(t0, t0) 5235 %cdr(t0, t0) 5236 %car(t0, t0) 5237 %set_global(t0, a0) 5238 5239 # Iterate clauses: bind accessor + optional mutator per clause. 5240 %li(t0, 0) 5241 %stl(t0, idx) 5242 5243 :.clause_loop 5244 %ldl(t0, walk) 5245 %if_nil(t1, t0, &.done) 5246 5247 # accessor-prim with data = tagged idx; bind cadr(clause). 5248 %ldl(a1, idx) 5249 %mkfix(a1, a1) 5250 %la(a0, &prim_accessor_entry) 5251 %call(&make_param_prim) 5252 5253 %ldl(t0, walk) 5254 %car(t0, t0) 5255 %cdr(t0, t0) 5256 %car(t0, t0) 5257 %set_global(t0, a0) 5258 5259 # Mutator? If cddr(clause) is a pair, bind it. 5260 %ldl(t0, walk) 5261 %car(t0, t0) 5262 %cdr(t0, t0) 5263 %cdr(t0, t0) 5264 %if_nil(t1, t0, &.no_mutator) 5265 5266 %ldl(a1, idx) 5267 %mkfix(a1, a1) 5268 %la(a0, &prim_mutator_entry) 5269 %call(&make_param_prim) 5270 5271 %ldl(t0, walk) 5272 %car(t0, t0) 5273 %cdr(t0, t0) 5274 %cdr(t0, t0) 5275 %car(t0, t0) 5276 %set_global(t0, a0) 5277 5278 :.no_mutator 5279 %advance_walk(walk) 5280 %ldl(t0, idx) 5281 %addi(t0, t0, 1) 5282 %stl(t0, idx) 5283 %b(&.clause_loop) 5284 5285 :.done 5286 %li(a0, %imm_val(%IMM.UNSPEC)) 5287 }) 5288 5289 # ========================================================================= 5290 # Writer -- display, write, format, error 5291 # ========================================================================= 5292 # 5293 # All four entry points walk values through a single recursive writer 5294 # that appends bytes into an output bytevector. display / write call the 5295 # writer once, then sys_write the resulting bytes to stdout. error 5296 # prepends `scheme1: error: `, joins irritants with spaces, and tails 5297 # into runtime_error so the prefix stays consistent with every other 5298 # abort path. format walks a template bv, emitting raw bytes verbatim 5299 # and dispatching ~a (display), ~s (write), ~d (decimal), ~% (newline), 5300 # and ~~ (literal '~') against successive args. 5301 # 5302 # Mode flag for write_to_bv: 0 = display (bytevectors emit raw), 1 = 5303 # write (bytevectors emit "..." with a leading and trailing double quote; 5304 # escapes are not handled because string literals are not yet supported). 5305 # 5306 # bv_putn / bv_putc / bv_putint append raw bytes to a bv and return the 5307 # (same wrapper, possibly-grown) bv. They do NOT maintain a trailing NUL 5308 # -- callers building "strings" must use the str_* family below. 5309 # bv_grow patches data_ptr/capacity in place, so the wrapper pointer 5310 # never changes -- callers can keep a stable handle in a single frame 5311 # slot. 5312 5313 # bv_putn(bv=a0, src=a1, n=a2) -> bv (a0). Append n bytes from src to bv, 5314 # growing the data buffer when capacity falls short. Raw u8[] semantics: 5315 # the byte at index `length` after append is unspecified. 5316 5317 %gcfn2(bv_putn, {bv src n old_len}, 1, 2, { 5318 %stl(a0, bv) 5319 %stl(a1, src) 5320 %stl(a2, n) 5321 5322 %heap_ld(t0, a0, %BV.hdr) 5323 %shri(t0, t0, 8) ; old_len 5324 %stl(t0, old_len) 5325 5326 # bv_grow ensures cap >= old_len + n. 5327 %add(a1, t0, a2) 5328 %call(&bv_grow) 5329 5330 %ldl(t0, bv) 5331 %heap_ld(a0, t0, %BV.data) 5332 %ldl(t1, old_len) 5333 %add(a0, a0, t1) ; dst = data + old_len 5334 %ldl(a1, src) 5335 %ldl(a2, n) 5336 %call(&memcpy) 5337 5338 # hdr = (old_len + n) << 8 | HDR.BV. HDR.BV is 0. 5339 %ldl(t0, old_len) 5340 %ldl(t1, n) 5341 %add(t0, t0, t1) 5342 %shli(t0, t0, 8) 5343 %ldl(t1, bv) 5344 %heap_st(t0, t1, %BV.hdr) 5345 5346 %ldl(a0, bv) 5347 }) 5348 5349 # bv_putc(bv=a0, byte=a1) -> bv (a0). Append a single byte (low 8 bits 5350 # of a1). Same growth + length-update protocol as bv_putn; no NUL. 5351 5352 %gcfn2(bv_putc, {bv byte}, 1, 0, { 5353 %stl(a0, bv) 5354 %stl(a1, byte) 5355 5356 %heap_ld(t0, a0, %BV.hdr) 5357 %shri(t0, t0, 8) ; old_len 5358 %addi(a1, t0, 1) ; min_cap = old_len + 1 5359 %call(&bv_grow) 5360 5361 %ldl(t0, bv) 5362 %heap_ld(t1, t0, %BV.hdr) 5363 %shri(t1, t1, 8) ; old_len (re-read after grow) 5364 %heap_ld(t2, t0, %BV.data) 5365 %add(t2, t2, t1) 5366 %ldl(a0, byte) 5367 %sb(a0, t2, 0) 5368 5369 %addi(t1, t1, 1) 5370 %shli(t1, t1, 8) 5371 %heap_st(t1, t0, %BV.hdr) 5372 5373 %ldl(a0, bv) 5374 }) 5375 5376 # bv_putint(bv=a0, value=a1) -> bv (a0). Append decimal repr of (raw, 5377 # untagged) value. Uses :writer_num_buf as a 24-byte scratch buffer 5378 # (fmt_dec writes at most 20 bytes for a 64-bit signed integer). 5379 5380 %gcfn2(bv_putint, {bv pad}, 1, 0, { 5381 %stl(a0, bv) 5382 5383 %la(a0, &writer_num_buf) 5384 %call(&fmt_dec) ; n_bytes (a0) 5385 5386 %mov(a2, a0) 5387 %la(a1, &writer_num_buf) 5388 %ldl(a0, bv) 5389 %gctail(&bv_putn) 5390 }) 5391 5392 # String writers: identical to bv_putn / bv_putc / bv_putint except they 5393 # guarantee cap > length AND data[length] == 0 on return. Required for 5394 # any bv whose data_ptr is later read as a C string (syscall paths, 5395 # runtime_error). The explicit zero is necessary because a fresh data 5396 # buffer may come from a reused block carrying stale bytes. 5397 5398 # str_alloc(raw_len=a0) -> tagged bv (a0). Like bv_alloc, but cap > 5399 # raw_len and data[raw_len] = 0. 5400 %gcfn2(str_alloc, {raw_len bv}, 2, 0, { 5401 %stl(a0, raw_len) 5402 %addi(a0, a0, 1) ; reserve a NUL slot 5403 %call(&bv_alloc) 5404 %stl(a0, bv) 5405 5406 # Patch hdr length back down to raw_len. 5407 %ldl(t0, raw_len) 5408 %shli(t0, t0, 8) ; HDR.BV is 0 5409 %heap_st(t0, a0, %BV.hdr) 5410 5411 # Zero data[raw_len]. 5412 %heap_ld(t1, a0, %BV.data) 5413 %ldl(t2, raw_len) 5414 %add(t1, t1, t2) 5415 %li(t0, 0) 5416 %sb(t0, t1, 0) 5417 5418 %ldl(a0, bv) 5419 }) 5420 5421 # str_putn(bv=a0, src=a1, n=a2) -> bv (a0). Append n bytes; on return 5422 # cap > new_len and data[new_len] == 0. 5423 %gcfn2(str_putn, {bv src n}, 1, 2, { 5424 %stl(a0, bv) 5425 %stl(a1, src) 5426 %stl(a2, n) 5427 5428 # Pre-grow so the post-append buffer has a NUL slot. 5429 %heap_ld(t0, a0, %BV.hdr) 5430 %shri(t0, t0, 8) ; old_len 5431 %add(a1, t0, a2) 5432 %addi(a1, a1, 1) ; min_cap = old_len + n + 1 5433 %call(&bv_grow) 5434 5435 %ldl(a0, bv) 5436 %ldl(a1, src) 5437 %ldl(a2, n) 5438 %call(&bv_putn) ; appends + updates length 5439 5440 # Zero data[new_len]. bv_putn left cap and data_ptr alone, so the 5441 # NUL slot reserved above is still ours. 5442 %heap_ld(t0, a0, %BV.hdr) 5443 %shri(t0, t0, 8) ; new_len 5444 %heap_ld(t1, a0, %BV.data) 5445 %add(t1, t1, t0) 5446 %li(t2, 0) 5447 %sb(t2, t1, 0) 5448 }) 5449 5450 # str_putc(bv=a0, byte=a1) -> bv (a0). Append one byte; cap > new_len 5451 # and data[new_len] == 0 on return. 5452 %gcfn2(str_putc, {bv byte}, 1, 0, { 5453 %stl(a0, bv) 5454 %stl(a1, byte) 5455 5456 %heap_ld(t0, a0, %BV.hdr) 5457 %shri(t0, t0, 8) ; old_len 5458 %addi(a1, t0, 2) ; min_cap = old_len + 1 + 1 5459 %call(&bv_grow) 5460 5461 %ldl(a0, bv) 5462 %ldl(a1, byte) 5463 %call(&bv_putc) 5464 5465 %heap_ld(t0, a0, %BV.hdr) 5466 %shri(t0, t0, 8) ; new_len 5467 %heap_ld(t1, a0, %BV.data) 5468 %add(t1, t1, t0) 5469 %li(t2, 0) 5470 %sb(t2, t1, 0) 5471 }) 5472 5473 # str_putint(bv=a0, value=a1) -> bv (a0). Like bv_putint but tails into 5474 # str_putn, so the result is NUL-terminated. 5475 %gcfn2(str_putint, {bv pad}, 1, 0, { 5476 %stl(a0, bv) 5477 5478 %la(a0, &writer_num_buf) 5479 %call(&fmt_dec) ; n_bytes (a0) 5480 5481 %mov(a2, a0) 5482 %la(a1, &writer_num_buf) 5483 %ldl(a0, bv) 5484 %gctail(&str_putn) 5485 }) 5486 5487 # str_puthex(bv=a0, value=a1) -> bv (a0). Signed hex: emits a leading 5488 # '-' for negatives, then unsigned hex of |value| via fmt_hex. The bv 5489 # wrapper pointer is stable across str_putc / str_putn (only the 5490 # internal data buffer can move), so we reload it from the local. 5491 %gcfn2(str_puthex, {bv value}, 1, 0, { 5492 %stl(a0, bv) 5493 %stl(a1, value) 5494 5495 %bltz(a1, &.neg) 5496 %b(&.pos) 5497 5498 :.neg 5499 %ldl(a0, bv) 5500 %li(a1, 45) ; '-' 5501 %call(&str_putc) 5502 %ldl(t0, value) 5503 %li(t1, 0) 5504 %sub(t0, t1, t0) 5505 %stl(t0, value) 5506 5507 :.pos 5508 %la(a0, &writer_num_buf) 5509 %ldl(a1, value) 5510 %call(&fmt_hex) ; n_bytes (a0) 5511 5512 %mov(a2, a0) 5513 %la(a1, &writer_num_buf) 5514 %ldl(a0, bv) 5515 %gctail(&str_putn) 5516 }) 5517 5518 # sym_name(idx=a0) -> (ptr=a0, len=a1). Leaf. idx is the untagged sym 5519 # slot index; both fields come straight out of the symtab entry. 5520 :sym_name 5521 %ld_global(t0, &symtab_buf_ptr) 5522 %lda_array(a1, t1, t0, %SYMENT.SIZE, a0, %SYMENT.name_len) 5523 %ld(a0, t1, %SYMENT.name_ptr) 5524 %ret 5525 5526 # write_to_bv(val=a0, bv=a1, mode=a2) -> bv (a0). Recursively appends 5527 # val's printed representation to bv. mode = 0 emits bytevectors as raw 5528 # bytes (display); mode = 1 emits them as `"..."` (write). Pairs are 5529 # delegated to write_pair_to_bv so the recursion through PAIR has its 5530 # own frame. 5531 # 5532 # Output is treated as a string by callers (display / write / error / 5533 # format), so all internal append calls go through the str_* family -- 5534 # the result has cap > length and a trailing NUL. 5535 5536 %gcfn2(write_to_bv, {val bv mode pad}, 3, 0, { 5537 %stl(a0, val) 5538 %stl(a1, bv) 5539 %stl(a2, mode) 5540 5541 %tagof(t0, a0) 5542 %bieq(t0, %TAG.PAIR, &.pair, t1) 5543 %bieq(t0, %TAG.SYM, &.sym, t1) 5544 %bieq(t0, %TAG.HEAP, &.heap, t1) 5545 %bieq(t0, %TAG.IMM, &.imm, t1) 5546 5547 # Fall-through: FIXNUM (the only remaining tag). 5548 %ldl(a0, bv) 5549 %ldl(a1, val) 5550 %sari(a1, a1, 3) 5551 %gctail(&str_putint) 5552 5553 :.sym 5554 %ldl(a0, val) 5555 %sari(a0, a0, 3) 5556 %call(&sym_name) 5557 %mov(a2, a1) 5558 %mov(a1, a0) 5559 %ldl(a0, bv) 5560 %gctail(&str_putn) 5561 5562 :.pair 5563 %ldl(a0, val) 5564 %ldl(a1, bv) 5565 %ldl(a2, mode) 5566 %gctail(&write_pair_to_bv) 5567 5568 :.heap 5569 %hdr_type(t0, a0) 5570 %bieq(t0, %HDR.BV, &.heap_bv, t1) 5571 %bieq(t0, %HDR.CLOSURE, &.heap_closure, t1) 5572 %bieq(t0, %HDR.PRIM, &.heap_prim, t1) 5573 %bieq(t0, %HDR.TD, &.heap_td, t1) 5574 %bieq(t0, %HDR.REC, &.heap_rec, t1) 5575 %b(&.heap_unknown) 5576 5577 :.heap_bv 5578 %ldl(t0, mode) 5579 %beqz(t0, &.heap_bv_raw) 5580 # write mode: emit `"`, then the raw bytes, then `"`. 5581 %ldl(a0, bv) 5582 %li(a1, 34) 5583 %call(&str_putc) 5584 %ldl(t0, val) 5585 %heap_ld(a1, t0, %BV.data) 5586 %heap_ld(a2, t0, %BV.hdr) 5587 %shri(a2, a2, 8) 5588 %call(&str_putn) 5589 %li(a1, 34) 5590 %gctail(&str_putc) 5591 5592 :.heap_bv_raw 5593 %ldl(t0, val) 5594 %heap_ld(a1, t0, %BV.data) 5595 %heap_ld(a2, t0, %BV.hdr) 5596 %shri(a2, a2, 8) 5597 %ldl(a0, bv) 5598 %gctail(&str_putn) 5599 5600 :.heap_closure 5601 %la(a1, &str_closure) 5602 %li(a2, 10) 5603 %ldl(a0, bv) 5604 %gctail(&str_putn) 5605 5606 :.heap_prim 5607 %la(a1, &str_prim) 5608 %li(a2, 7) 5609 %ldl(a0, bv) 5610 %gctail(&str_putn) 5611 5612 :.heap_td 5613 %la(a1, &str_td) 5614 %li(a2, 11) 5615 %ldl(a0, bv) 5616 %gctail(&str_putn) 5617 5618 :.heap_rec 5619 %la(a1, &str_rec) 5620 %li(a2, 9) 5621 %ldl(a0, bv) 5622 %gctail(&str_putn) 5623 5624 :.heap_unknown 5625 %la(a1, &str_unknown) 5626 %li(a2, 10) 5627 %ldl(a0, bv) 5628 %gctail(&str_putn) 5629 5630 :.imm 5631 %ldl(a0, val) 5632 %sari(a0, a0, 3) 5633 %beqz(a0, &.imm_false) 5634 %addi(t0, a0, -1) 5635 %beqz(t0, &.imm_true) 5636 %addi(t0, a0, -2) 5637 %beqz(t0, &.imm_nil) 5638 %addi(t0, a0, -3) 5639 %beqz(t0, &.imm_unspec) 5640 %addi(t0, a0, -4) 5641 %beqz(t0, &.imm_unbound) 5642 # EOF (idx == 5) is the only remaining IMM. 5643 %la(a1, &str_eof) 5644 %li(a2, 5) 5645 %ldl(a0, bv) 5646 %gctail(&str_putn) 5647 5648 :.imm_false 5649 %la(a1, &str_false) 5650 %li(a2, 2) 5651 %ldl(a0, bv) 5652 %gctail(&str_putn) 5653 5654 :.imm_true 5655 %la(a1, &str_true) 5656 %li(a2, 2) 5657 %ldl(a0, bv) 5658 %gctail(&str_putn) 5659 5660 :.imm_nil 5661 %la(a1, &str_nil) 5662 %li(a2, 2) 5663 %ldl(a0, bv) 5664 %gctail(&str_putn) 5665 5666 :.imm_unspec 5667 %la(a1, &str_unspec) 5668 %li(a2, 8) 5669 %ldl(a0, bv) 5670 %gctail(&str_putn) 5671 5672 :.imm_unbound 5673 %la(a1, &str_unbound) 5674 %li(a2, 9) 5675 %ldl(a0, bv) 5676 %gctail(&str_putn) 5677 }) 5678 5679 # write_pair_to_bv(pair=a0, bv=a1, mode=a2) -> bv (a0). Emits `(elt elt 5680 # ...)` form, with `( . )` for non-list cdrs (dotted pair). The walker 5681 # advances `pair` along the spine; cdr's tag determines whether we emit 5682 # a separator and continue, emit ` . val)` for a dotted tail, or just 5683 # emit `)` for a proper-list NIL. 5684 # 5685 # Locals: 5686 # pair walk 5687 # bv (stable wrapper; reused across recursive calls) 5688 # mode 5689 # pad 5690 %gcfn2(write_pair_to_bv, {pair bv mode pad}, 3, 0, { 5691 %stl(a0, pair) 5692 %stl(a1, bv) 5693 %stl(a2, mode) 5694 5695 %ldl(a0, bv) 5696 %li(a1, 40) 5697 %call(&str_putc) 5698 5699 :.loop 5700 %ldl(t0, pair) 5701 %car(a0, t0) 5702 %ldl(a1, bv) 5703 %ldl(a2, mode) 5704 %call(&write_to_bv) 5705 5706 %ldl(t0, pair) 5707 %cdr(t0, t0) 5708 %stl(t0, pair) 5709 5710 %if_nil(t1, t0, &.done) 5711 %tagof(t1, t0) 5712 %li(t2, %TAG.PAIR) 5713 %beq(t1, t2, &.cont) 5714 5715 # Dotted tail: emit ` . ` then write_to_bv(cdr). 5716 %ldl(a0, bv) 5717 %li(a1, 32) 5718 %call(&str_putc) 5719 %ldl(a0, bv) 5720 %li(a1, 46) 5721 %call(&str_putc) 5722 %ldl(a0, bv) 5723 %li(a1, 32) 5724 %call(&str_putc) 5725 %ldl(a0, pair) 5726 %ldl(a1, bv) 5727 %ldl(a2, mode) 5728 %call(&write_to_bv) 5729 %b(&.done) 5730 5731 :.cont 5732 %ldl(a0, bv) 5733 %li(a1, 32) 5734 %call(&str_putc) 5735 %b(&.loop) 5736 5737 :.done 5738 %ldl(a0, bv) 5739 %li(a1, 41) 5740 %gctail(&str_putc) 5741 }) 5742 5743 # value_to_bv(val=a0, mode=a1) -> bv (a0). Allocate an empty NUL- 5744 # terminated bv and delegate to write_to_bv; helper for display / write 5745 # / error / format. write_to_bv internally uses str_*, so the result 5746 # has cap > length and a trailing NUL -- safe to hand to syscalls or 5747 # runtime_error as a C string. 5748 5749 %gcfn2(value_to_bv, {val mode}, 1, 0, { 5750 %stl(a0, val) 5751 %stl(a1, mode) 5752 %li(a0, 0) 5753 %call(&str_alloc) 5754 %mov(a1, a0) 5755 %ldl(a0, val) 5756 %ldl(a2, mode) 5757 %gctail(&write_to_bv) 5758 }) 5759 5760 # (display val) and (write val): build the printed representation in a 5761 # fresh bv, sys_write the raw bytes to fd 1, return UNSPEC. Partial 5762 # writes are not retried -- libp1pp's wrapper streams its own buffer 5763 # but the kernel may chunk a giant single write; in practice 5764 # scheme1 outputs are short and we accept the simple path. 5765 %fn(prim_display_entry, 0, { 5766 %car(a0, a0) 5767 %li(a1, 0) 5768 %call(&value_to_bv) 5769 %heap_ld(a1, a0, %BV.data) 5770 %heap_ld(a2, a0, %BV.hdr) 5771 %shri(a2, a2, 8) 5772 %li(a0, 1) 5773 %call(&sys_write) 5774 %li(a0, %imm_val(%IMM.UNSPEC)) 5775 }) 5776 5777 %fn(prim_write_entry, 0, { 5778 %car(a0, a0) 5779 %li(a1, 1) 5780 %call(&value_to_bv) 5781 %heap_ld(a1, a0, %BV.data) 5782 %heap_ld(a2, a0, %BV.hdr) 5783 %shri(a2, a2, 8) 5784 %li(a0, 1) 5785 %call(&sys_write) 5786 %li(a0, %imm_val(%IMM.UNSPEC)) 5787 }) 5788 5789 # (error msg-bv irritant ...). Builds `scheme1: error: <msg> <irr> ...` 5790 # in a string-bv (irritants joined by single spaces, all rendered with 5791 # display semantics) and tails into runtime_error. str_alloc + str_* 5792 # guarantee cap > length and a trailing NUL, making the bv's data_ptr 5793 # a valid C string for panic's eprint_cstr. 5794 # 5795 # Locals: 5796 # walk (initially args; advances over irritants) 5797 # bv 5798 %gcfn2(prim_error_entry, {walk bv}, 3, 0, { 5799 %stl(a0, walk) 5800 5801 %li(a0, 0) 5802 %call(&str_alloc) 5803 %stl(a0, bv) 5804 5805 %la(a1, &str_error_prefix) 5806 %li(a2, 16) 5807 %ldl(a0, bv) 5808 %call(&str_putn) 5809 5810 # First arg (the message) goes through write_to_bv with display mode. 5811 %ldl(t0, walk) 5812 %car(a0, t0) 5813 %ldl(a1, bv) 5814 %li(a2, 0) 5815 %call(&write_to_bv) 5816 5817 %ldl(t0, walk) 5818 %cdr(t0, t0) 5819 %stl(t0, walk) 5820 5821 :.loop 5822 %ldl(t0, walk) 5823 %if_nil(t1, t0, &.done) 5824 5825 %ldl(a0, bv) 5826 %li(a1, 32) 5827 %call(&str_putc) 5828 5829 %ldl(t0, walk) 5830 %car(a0, t0) 5831 %ldl(a1, bv) 5832 %li(a2, 0) 5833 %call(&write_to_bv) 5834 5835 %ldl(t0, walk) 5836 %cdr(t0, t0) 5837 %stl(t0, walk) 5838 %b(&.loop) 5839 5840 :.done 5841 %ldl(t0, bv) 5842 %heap_ld(a0, t0, %BV.data) 5843 %gctail(&runtime_error) 5844 }) 5845 5846 # (format template-bv arg ...). Walks the template bv byte by byte; 5847 # `~X` consumes the next byte as a directive: a (display), s (write), 5848 # d (decimal fixnum), x (lowercase hex fixnum, signed), % (newline), 5849 # ~ (literal tilde). Unknown specs pass through verbatim. Returns the 5850 # assembled bv; the caller decides how to consume it (e.g. 5851 # (display (format ...))). 5852 # 5853 # Locals: 5854 # out bv 5855 # template bv 5856 # args walk 5857 # idx (current byte offset into template) 5858 %gcfn2(prim_format_entry, {out template args idx}, 7, 0, { 5859 %stl(a0, args) ; spill incoming args while we set up 5860 5861 %li(a0, 0) 5862 %call(&str_alloc) 5863 %stl(a0, out) 5864 5865 %ldl(t0, args) 5866 %car(t1, t0) 5867 %stl(t1, template) 5868 %cdr(t0, t0) 5869 %stl(t0, args) 5870 5871 %li(t0, 0) 5872 %stl(t0, idx) 5873 5874 :.loop 5875 %ldl(t1, template) 5876 %heap_ld(t2, t1, %BV.hdr) 5877 %shri(t2, t2, 8) ; template length 5878 %ldl(t0, idx) 5879 %beq(t0, t2, &.done) 5880 5881 %heap_ld(a3, t1, %BV.data) 5882 %add(a3, a3, t0) 5883 %lb(a3, a3, 0) ; byte = template.data[idx] 5884 5885 %addi(t1, a3, -126) ; '~' 5886 %beqz(t1, &.tilde) 5887 5888 # Plain byte: emit and advance. 5889 %ldl(a0, out) 5890 %mov(a1, a3) 5891 %call(&str_putc) 5892 %ldl(t0, idx) 5893 %addi(t0, t0, 1) 5894 %stl(t0, idx) 5895 %b(&.loop) 5896 5897 :.tilde 5898 %ldl(t0, idx) 5899 %addi(t0, t0, 1) 5900 %ldl(t1, template) 5901 %heap_ld(t2, t1, %BV.hdr) 5902 %shri(t2, t2, 8) 5903 %beq(t0, t2, &.tilde_lit) 5904 5905 %heap_ld(t1, t1, %BV.data) 5906 %add(t1, t1, t0) 5907 %lb(a3, t1, 0) ; spec 5908 5909 %addi(t0, t0, 1) ; advance past spec 5910 %stl(t0, idx) 5911 5912 %addi(t1, a3, -97) ; 'a' 5913 %beqz(t1, &.spec_a) 5914 %addi(t1, a3, -115) ; 's' 5915 %beqz(t1, &.spec_s) 5916 %addi(t1, a3, -100) ; 'd' 5917 %beqz(t1, &.spec_d) 5918 %addi(t1, a3, -120) ; 'x' 5919 %beqz(t1, &.spec_x) 5920 %addi(t1, a3, -37) ; '%' 5921 %beqz(t1, &.spec_pct) 5922 %addi(t1, a3, -126) ; '~' 5923 %beqz(t1, &.spec_tilde) 5924 5925 # Unknown directive: emit `~` then the spec byte verbatim. Re-read 5926 # the spec byte from the template since str_putc may clobber a3. 5927 %ldl(a0, out) 5928 %li(a1, 126) 5929 %call(&str_putc) 5930 %ldl(t0, template) 5931 %heap_ld(t1, t0, %BV.data) 5932 %ldl(t0, idx) 5933 %addi(t0, t0, -1) 5934 %add(t1, t1, t0) 5935 %lb(a1, t1, 0) 5936 %ldl(a0, out) 5937 %call(&str_putc) 5938 %b(&.loop) 5939 5940 :.tilde_lit 5941 # `~` at end of template: emit literal `~` and finish next iter. 5942 %ldl(a0, out) 5943 %li(a1, 126) 5944 %call(&str_putc) 5945 %ldl(t0, idx) 5946 %addi(t0, t0, 1) 5947 %stl(t0, idx) 5948 %b(&.loop) 5949 5950 :.spec_a 5951 %ldl(t0, args) 5952 %car(a0, t0) 5953 %cdr(t0, t0) 5954 %stl(t0, args) 5955 %ldl(a1, out) 5956 %li(a2, 0) 5957 %call(&write_to_bv) 5958 %b(&.loop) 5959 5960 :.spec_s 5961 %ldl(t0, args) 5962 %car(a0, t0) 5963 %cdr(t0, t0) 5964 %stl(t0, args) 5965 %ldl(a1, out) 5966 %li(a2, 1) 5967 %call(&write_to_bv) 5968 %b(&.loop) 5969 5970 :.spec_d 5971 %ldl(t0, args) 5972 %car(t1, t0) 5973 %cdr(t0, t0) 5974 %stl(t0, args) 5975 %sari(a1, t1, 3) 5976 %ldl(a0, out) 5977 %call(&str_putint) 5978 %b(&.loop) 5979 5980 :.spec_x 5981 %ldl(t0, args) 5982 %car(t1, t0) 5983 %cdr(t0, t0) 5984 %stl(t0, args) 5985 %sari(a1, t1, 3) 5986 %ldl(a0, out) 5987 %call(&str_puthex) 5988 %b(&.loop) 5989 5990 :.spec_pct 5991 %ldl(a0, out) 5992 %li(a1, 10) 5993 %call(&str_putc) 5994 %b(&.loop) 5995 5996 :.spec_tilde 5997 %ldl(a0, out) 5998 %li(a1, 126) 5999 %call(&str_putc) 6000 %b(&.loop) 6001 6002 :.done 6003 %ldl(a0, out) 6004 }) 6005 6006 # ========================================================================= 6007 # Syscall primitives 6008 # ========================================================================= 6009 # 6010 # Each syscall primitive untags the args list, calls a thin libp1pp- or 6011 # scheme1-local syscall wrapper, and routes the raw return through 6012 # wrap_syscall_result: r >= 0 -> (#t . r), r < 0 -> (#f . -r). 6013 # 6014 # Bytevector args (paths, buffers) are passed by their raw data_ptr (slot 6015 # +5 from the tagged wrapper). For syscalls that read data_ptr as a C 6016 # string (paths, argv elements), the caller must produce the bv via the 6017 # str_* family so cap > length and data[length] == 0. Callers that only 6018 # expose the bv as a (data_ptr, count) pair (sys-read, sys-write buffers) 6019 # can pass plain bytevectors -- no NUL needed. 6020 6021 # wrap_syscall_result(raw=a0) -> (#t . r) or (#f . errno). 6022 6023 %fn2(wrap_syscall_result, {raw pad}, { 6024 %stl(a0, raw) 6025 %bltz(a0, &.err) 6026 %mkfix(a1, a0) 6027 %li(a0, %imm_val(%IMM.TRUE)) 6028 %tail(&cons) 6029 6030 :.err 6031 %ldl(t0, raw) 6032 %li(t1, 0) 6033 %sub(t0, t1, t0) 6034 %mkfix(a1, t0) 6035 %li(a0, %imm_val(%IMM.FALSE)) 6036 %tail(&cons) 6037 }) 6038 6039 # sys_openat(dirfd=a0, path=a1, flags=a2, mode=a3) -> r (a0). Leaf. 6040 :sys_openat 6041 %mov(t0, a3) 6042 %mov(a3, a2) 6043 %mov(a2, a1) 6044 %mov(a1, a0) 6045 %li(a0, %p1_sys_openat) 6046 %syscall 6047 %ret 6048 6049 # sys_clone() -> r (a0). Linux clone(SIGCHLD, 0, 0, 0, 0) -- fork-style. 6050 # Saves and restores s0 around the syscall because %p1_syscall reads s0 6051 # as the 5th OS-syscall argument. 6052 6053 %fn2(sys_clone, {saved_s0 pad}, { 6054 %stl(s0, saved_s0) 6055 %li(s0, 0) 6056 6057 %li(a1, 17) 6058 %li(a2, 0) 6059 %li(a3, 0) 6060 %li(t0, 0) 6061 %li(a0, %p1_sys_clone) 6062 %syscall 6063 6064 %ldl(s0, saved_s0) 6065 }) 6066 6067 # sys_execve(path=a0, argv=a1, envp=a2) -> -errno (a0). Only returns on 6068 # failure; on success the new image takes over. 6069 :sys_execve 6070 %mov(a3, a2) 6071 %mov(a2, a1) 6072 %mov(a1, a0) 6073 %li(a0, %p1_sys_execve) 6074 %syscall 6075 %ret 6076 6077 # sys_spawn(path=a0, argv=a1) -> r (a0). Atomic clone+execve, single 6078 # syscall: kernel saves parent state, swaps user pool with no copy, 6079 # loads the ELF, builds the user stack, and erets into the child. The 6080 # parent's spawn() returns child_pid only after the child exit_groups. 6081 # Provided by the seed kernel (private syscall 1024). On Linux this 6082 # number is unmapped so the kernel returns -ENOSYS, which the prelude 6083 # uses to detect environment and fall back to sys_clone+sys_execve. 6084 :sys_spawn 6085 %mov(a2, a1) 6086 %mov(a1, a0) 6087 %li(a0, %p1_sys_spawn) 6088 %syscall 6089 %ret 6090 6091 # sys_waitid(idtype=a0, id=a1, infop=a2, options=a3) -> r (a0). Leaf. 6092 :sys_waitid 6093 %mov(t0, a3) 6094 %mov(a3, a2) 6095 %mov(a2, a1) 6096 %mov(a1, a0) 6097 %li(a0, %p1_sys_waitid) 6098 %syscall 6099 %ret 6100 6101 # build_execve_argv(list=a0) -> raw NULL-terminated array (a0). 6102 # Walks `list` (cons-list of bytevectors), allocates (count+1)*8 bytes, 6103 # writes each bv's data_ptr, terminates with NULL. 6104 # 6105 # Locals: 6106 # list 6107 # count 6108 # array ptr (raw) 6109 %gcfn2(build_execve_argv, {list count array}, 1, 0, { 6110 %stl(a0, list) 6111 %call(&list_length) ; clobbers a0 -> count 6112 %stl(a0, count) 6113 6114 %addi(a0, a0, 1) 6115 %shli(a0, a0, 3) 6116 %call(&alloc_bytes) 6117 %stl(a0, array) 6118 6119 %ldl(t0, list) 6120 %ldl(t1, array) 6121 6122 :.fill_loop 6123 %if_nil(t2, t0, &.fill_done) 6124 %car(a3, t0) 6125 %heap_ld(a2, a3, %BV.data) 6126 %st(a2, t1, 0) 6127 %addi(t1, t1, 8) 6128 %cdr(t0, t0) 6129 %b(&.fill_loop) 6130 6131 :.fill_done 6132 %li(t2, 0) 6133 %st(t2, t1, 0) 6134 6135 %ldl(a0, array) 6136 }) 6137 6138 # (sys-read fd buf offset count). Passes (buf.data_ptr + offset) to the 6139 # kernel; offset lets callers read into the middle of a bv without first 6140 # slicing/copying. 6141 %fn(prim_sys_read_entry, 0, { 6142 %args4(t0, t1, t2, a3, a0) 6143 %sari(t0, t0, 3) ; fd 6144 %heap_ld(t1, t1, %BV.data) ; buf data ptr 6145 %sari(t2, t2, 3) ; offset 6146 %add(t1, t1, t2) ; data_ptr + offset 6147 %sari(t2, a3, 3) ; count 6148 %mov(a0, t0) 6149 %mov(a1, t1) 6150 %mov(a2, t2) 6151 %call(&sys_read) 6152 %tail(&wrap_syscall_result) 6153 }) 6154 6155 # (sys-write fd buf offset count). Passes (buf.data_ptr + offset) to the 6156 # kernel; offset lets callers retry the unwritten tail of a partial 6157 # write without bytevector-copy. 6158 %fn(prim_sys_write_entry, 0, { 6159 %args4(t0, t1, t2, a3, a0) 6160 %sari(t0, t0, 3) ; fd 6161 %heap_ld(t1, t1, %BV.data) ; buf data ptr 6162 %sari(t2, t2, 3) ; offset 6163 %add(t1, t1, t2) ; data_ptr + offset 6164 %sari(t2, a3, 3) ; count 6165 %mov(a0, t0) 6166 %mov(a1, t1) 6167 %mov(a2, t2) 6168 %call(&sys_write) 6169 %tail(&wrap_syscall_result) 6170 }) 6171 6172 # (sys-close fd) 6173 %fn(prim_sys_close_entry, 0, { 6174 %car_fix(a0, a0) 6175 %call(&sys_close) 6176 %tail(&wrap_syscall_result) 6177 }) 6178 6179 # (sys-openat dirfd path flags mode) 6180 %fn(prim_sys_openat_entry, 0, { 6181 %args4(t0, t1, t2, a3, a0) 6182 %sari(t0, t0, 3) ; dirfd 6183 %heap_ld(t1, t1, %BV.data) ; path data_ptr 6184 %sari(t2, t2, 3) ; flags 6185 %sari(a3, a3, 3) ; mode 6186 %mov(a0, t0) 6187 %mov(a1, t1) 6188 %mov(a2, t2) 6189 %call(&sys_openat) 6190 %tail(&wrap_syscall_result) 6191 }) 6192 6193 # (sys-clone). Linux POSIX-style fork; only used as a fallback path on 6194 # Linux since the seed kernel doesn't implement clone (it offers 6195 # sys-spawn instead). 6196 %fn(prim_sys_clone_entry, 0, { 6197 %call(&sys_clone) 6198 %tail(&wrap_syscall_result) 6199 }) 6200 6201 # (sys-execve path argv-list) 6202 6203 %gcfn2(prim_sys_execve_entry, {path pad}, 1, 0, { 6204 %args2(t0, a0, a0) ; t0 = path bv, a0 = argv-list 6205 %stl(t0, path) 6206 %call(&build_execve_argv) 6207 %mov(a1, a0) 6208 %ldl(a0, path) 6209 %heap_ld(a0, a0, %BV.data) ; path data ptr 6210 %li(a2, 0) 6211 %call(&sys_execve) 6212 %gctail(&wrap_syscall_result) 6213 }) 6214 6215 # (sys-spawn path argv-list). Same calling convention as sys-execve, but 6216 # wraps the seed kernel's atomic spawn syscall: returns (#t . child-pid) 6217 # after the child has exit_grouped (the kernel suspends the parent for 6218 # the lifetime of the child), or (#f . -errno) on failure (notably 6219 # -ENOSYS=38 on Linux, which the prelude probes for at init time). 6220 %gcfn2(prim_sys_spawn_entry, {path pad}, 1, 0, { 6221 %args2(t0, a0, a0) ; t0 = path bv, a0 = argv-list 6222 %stl(t0, path) 6223 %call(&build_execve_argv) 6224 %mov(a1, a0) 6225 %ldl(a0, path) 6226 %heap_ld(a0, a0, %BV.data) ; path data ptr 6227 %call(&sys_spawn) 6228 %gctail(&wrap_syscall_result) 6229 }) 6230 6231 # (sys-waitid idtype id infop options) 6232 %fn(prim_sys_waitid_entry, 0, { 6233 %args4(t0, t1, t2, a3, a0) 6234 %sari(t0, t0, 3) ; idtype 6235 %sari(t1, t1, 3) ; id 6236 %heap_ld(t2, t2, %BV.data) ; infop bv data ptr 6237 %sari(a3, a3, 3) ; options 6238 %mov(a0, t0) 6239 %mov(a1, t1) 6240 %mov(a2, t2) 6241 %call(&sys_waitid) 6242 %tail(&wrap_syscall_result) 6243 }) 6244 6245 # (sys-argv) -> list of bytevectors. Walks saved_argv, strlen-ing each 6246 # NUL-terminated entry into a fresh bytevector and consing them in order 6247 # via the head/tail trick. 6248 # 6249 # Locals: 6250 # argv ptr (advancing 8 bytes per iteration) 6251 # count remaining (decrementing from saved_argc) 6252 # head 6253 # tail 6254 # bv 6255 %gcfn2(prim_sys_argv_entry, {argv count head tail bv}, 28, 0, { 6256 %ld_global(t0, &saved_argv) 6257 %stl(t0, argv) 6258 %ld_global(t0, &saved_argc) 6259 %stl(t0, count) 6260 %li(t0, %imm_val(%IMM.NIL)) 6261 %stl(t0, head) 6262 %stl(t0, tail) 6263 6264 :.loop 6265 %ldl(t0, count) 6266 %beqz(t0, &.done) 6267 6268 # len = strlen(*argv) 6269 %ldl(t0, argv) 6270 %ld(a0, t0, 0) 6271 %call(&libp1pp__strlen) 6272 6273 # bv = str_alloc(len). argv entries flow into syscalls (sys-openat, 6274 # sys-execve) that read data_ptr as a C string, so the trailing NUL 6275 # is required. 6276 %call(&str_alloc) 6277 %stl(a0, bv) 6278 6279 # memcpy(bv.data_ptr, *argv, len-from-bv-hdr). 6280 %ldl(t0, bv) 6281 %heap_ld(a0, t0, %BV.data) 6282 %ldl(t1, argv) 6283 %ld(a1, t1, 0) 6284 %heap_ld(t1, t0, %BV.hdr) 6285 %shri(a2, t1, 8) 6286 %call(&memcpy) 6287 6288 # cell = cons(bv, NIL); append to list head/tail. 6289 %ldl(a0, bv) 6290 %li(a1, %imm_val(%IMM.NIL)) 6291 %call(&cons) 6292 6293 %ldl(t0, head) 6294 %if_nil(t1, t0, &.first) 6295 %ldl(t0, tail) 6296 %set_cdr(a0, t0) 6297 %stl(a0, tail) 6298 %b(&.advance) 6299 6300 :.first 6301 %stl(a0, head) 6302 %stl(a0, tail) 6303 6304 :.advance 6305 %ldl(t0, argv) 6306 %addi(t0, t0, 8) 6307 %stl(t0, argv) 6308 %ldl(t0, count) 6309 %addi(t0, t0, -1) 6310 %stl(t0, count) 6311 %b(&.loop) 6312 6313 :.done 6314 %ldl(a0, head) 6315 }) 6316 6317 # (eof? x). The `eof` value itself is bound at startup in p1_main as a 6318 # direct global -> IMM.EOF, not via a primitive thunk. 6319 :prim_eofq_entry 6320 .scope 6321 %car(t0, a0) 6322 %li(t1, %imm_val(%IMM.EOF)) 6323 %li(a0, %imm_val(%IMM.FALSE)) 6324 %bne(t0, t1, &.end) 6325 %li(a0, %imm_val(%IMM.TRUE)) 6326 :.end 6327 %ret 6328 .endscope 6329 6330 # (heap-usage) -> tagged fixnum: currently allocated managed bytes, 6331 # including the 16-byte header of every live allocation. 6332 :prim_heap_usage_entry 6333 %ld_global(a0, &heap_allocated) 6334 %mkfix(a0, a0) 6335 %ret 6336 6337 # (collect-garbage) -> unspecified. The primitive's argument list is 6338 # intentionally ignored, so it does not retain otherwise unreachable data. 6339 %fn(prim_collect_garbage_entry, 0, { 6340 %call(&gc_collect) 6341 %li(a0, %imm_val(%IMM.UNSPEC)) 6342 }) 6343 6344 # Record introspection. Surfaces the unsafe %record-* helpers (heap 6345 # layout: [HDR.REC][td][f0..fN-1], field i at tagged + 13 + 8*i; 6346 # nfields lives at TD's offset 13 raw). All primitives below trust 6347 # their inputs -- no bounds check, no kind check on record-ref / 6348 # record-set! / record-td. 6349 6350 # (record? obj) -> bool. True iff obj is HEAP-tagged with HDR.REC. 6351 :prim_recordq_entry 6352 .scope 6353 %car(t0, a0) 6354 %li(a0, %imm_val(%IMM.FALSE)) 6355 %tagof(t1, t0) 6356 %li(t2, %TAG.HEAP) 6357 %bne(t1, t2, &.end) 6358 %hdr_type(t1, t0) 6359 %li(t2, %HDR.REC) 6360 %bne(t1, t2, &.end) 6361 %li(a0, %imm_val(%IMM.TRUE)) 6362 :.end 6363 %ret 6364 .endscope 6365 6366 # (record-td rec) -> td. Reads the TD slot from the record header. No 6367 # kind check; caller is expected to gate with record? if needed. 6368 :prim_record_td_entry 6369 %car(t0, a0) 6370 %heap_ld(a0, t0, %REC.td) 6371 %ret 6372 6373 # (record-ref rec idx) -> field value. idx is a tagged fixnum; since 6374 # tagged_fixnum = raw_idx * 8 (fixnum tag bits are 0), the byte offset 6375 # is exactly idx + 13 from the tagged record pointer. No bounds check. 6376 :prim_record_ref_entry 6377 %args2(t0, t1, a0) ; t0=rec, t1=idx (tagged fixnum = raw*8) 6378 %addi(t0, t0, 13) 6379 %add(t0, t0, t1) 6380 %ld(a0, t0, 0) 6381 %ret 6382 6383 # (record-set! rec idx val) -> unspec. In-place store at slot idx. 6384 :prim_record_set_bang_entry 6385 .scope 6386 %car(t0, a0) ; rec 6387 %cdr(a0, a0) 6388 %car(t1, a0) ; idx (tagged fixnum) 6389 %cdr(a0, a0) 6390 %car(t2, a0) ; val 6391 %addi(t0, t0, 13) 6392 %add(t0, t0, t1) 6393 %st(t2, t0, 0) 6394 %li(a0, %imm_val(%IMM.UNSPEC)) 6395 %ret 6396 .endscope 6397 6398 # (make-record/td td) -> fresh record allocated in the current heap. 6399 # Reads td.nfields, allocates 16 + nfields*8 bytes with HDR.REC, sets 6400 # the td slot, and zero-fills field slots to IMM.UNSPEC. Mirrors 6401 # eval_define_record_type's ctor allocation but driven by the TD's 6402 # nfields rather than a runtime args list. Used by deep-copy as a 6403 # pre-fill stand-in before recursive slot promotion. 6404 # 6405 # Locals: 6406 # td (the TD pointer; saved across alloc_hdr) 6407 # record (the new record pointer) 6408 %gcfn2(prim_make_record_td_entry, {td record}, 3, 0, { 6409 %car(t0, a0) ; td 6410 %stl(t0, td) 6411 6412 %heap_ld(a0, t0, %TD.nfields) ; raw nfields 6413 %shli(a0, a0, 3) ; nfields * 8 6414 %addi(a0, a0, 16) ; + REC header (hdr + td slot) 6415 %li(a1, %HDR.REC) 6416 %call(&alloc_hdr) 6417 %stl(a0, record) 6418 6419 %ldl(t0, td) 6420 %heap_st(t0, a0, %REC.td) 6421 6422 # Zero-fill field slots to IMM.UNSPEC. Cursor starts at first slot 6423 # (tagged + 13); count = nfields read again from the TD. 6424 %heap_ld(t0, t0, %TD.nfields) 6425 %addi(t1, a0, 13) 6426 %li(t2, %imm_val(%IMM.UNSPEC)) 6427 6428 :.fill_loop 6429 %beqz(t0, &.fill_done) 6430 %st(t2, t1, 0) 6431 %addi(t1, t1, 8) 6432 %addi(t0, t0, -1) 6433 %b(&.fill_loop) 6434 6435 :.fill_done 6436 %ldl(a0, record) 6437 }) 6438 6439 # (td-nfields td) -> tagged fixnum count of fields. 6440 :prim_td_nfields_entry 6441 %car(t0, a0) 6442 %heap_ld(a0, t0, %TD.nfields) ; raw count 6443 %mkfix(a0, a0) 6444 %ret 6445 6446 # (td-name td) -> symbol bound at define-record-type time. 6447 :prim_td_name_entry 6448 %car(t0, a0) 6449 %heap_ld(a0, t0, %TD.name) 6450 %ret 6451 6452 # Debug primitives. UNSAFE: peek-u8 dereferences arbitrary addresses. 6453 # Intended for diagnosing heap-layout bugs from scheme1 user code; not 6454 # part of the surface contract. 6455 6456 # (tagged-value obj) -> fixnum. Returns the raw byte address of obj 6457 # with tag bits masked off, encoded as a tagged fixnum so format / 6458 # display can print it. Pass the result back into peek-u8 to read raw 6459 # bytes. For non-pointer values (fixnums, immediates, syms) the masked 6460 # value is small but still encodable; the result is meaningful only for 6461 # heap-tagged inputs. 6462 :prim_tagged_value_entry 6463 %car(t0, a0) 6464 %li(t1, -8) 6465 %and(t0, t0, t1) 6466 %mkfix(a0, t0) 6467 %ret 6468 6469 # (peek-u8 addr) -> fixnum. Reads one byte at the given raw byte 6470 # address (tagged fixnum input, untagged inside). UNSAFE: no bounds 6471 # check; a wild address segfaults the process. 6472 :prim_peek_u8_entry 6473 %car(t0, a0) 6474 %sari(t0, t0, 3) 6475 %lb(a0, t0, 0) 6476 %mkfix(a0, a0) 6477 %ret 6478 6479 # (values . xs) -- multiple-values producer. Single-arg case returns the 6480 # arg unchanged so (values x) is interchangeable with x in any 1-value 6481 # context; 0 or 2+ args materialize an MV-pack. 6482 :prim_values_entry 6483 .scope 6484 %if_nil(t0, a0, &.pack) 6485 %cdr(t0, a0) 6486 %if_nil(t1, t0, &.single) 6487 :.pack 6488 %b(&list_to_mv) 6489 :.single 6490 %car(a0, a0) 6491 %ret 6492 .endscope 6493 6494 # (call-with-values producer consumer) -- apply producer to no args, then 6495 # normalize its result (via mv_to_list) and tail-apply the consumer to the 6496 # resulting argument list. 6497 # 6498 # Locals: 6499 # consumer (saved across apply(producer) and mv_to_list) 6500 %gcfn2(prim_call_with_values_entry, {consumer pad}, 1, 0, { 6501 %args2(t0, t1, a0) ; t0 = producer, t1 = consumer 6502 %stl(t1, consumer) 6503 6504 %mov(a0, t0) 6505 %li(a1, %imm_val(%IMM.NIL)) 6506 %call(&apply) 6507 6508 %call(&mv_to_list) 6509 6510 %mov(a1, a0) 6511 %ldl(a0, consumer) 6512 %gctail(&apply) 6513 }) 6514 6515 # ========================================================================= 6516 # Startup -- heap_init 6517 # ========================================================================= 6518 6519 # heap_init() -> none. Initializes the physical heap chain, free list, 6520 # accounting, and bounded exact-root stack. Leaf. 6521 :heap_init 6522 %ld_global(t0, &heap_buf_ptr) 6523 %alignup(t0, t0, 8, t1) 6524 %st_global(t0, &heap_base, t1) 6525 %st_global(t0, &heap_tail, t1) 6526 6527 %ld_global(t0, &heap_buf_ptr) 6528 %li(t1, %HEAP_CAP_BYTES) 6529 %add(t0, t0, t1) 6530 %st_global(t0, &heap_end, t1) 6531 6532 %li(t0, 0) 6533 %st_global(t0, &gc_free_list, t1) 6534 %st_global(t0, &gc_mark_worklist, t1) 6535 %st_global(t0, &heap_allocated, t1) 6536 6537 %ld_global(t0, &gc_root_buf_ptr) 6538 %st_global(t0, &gc_root_next, t1) 6539 %li(t1, (* %GC_ROOT_CAP_FRAMES %GC_ROOT_FRAME_BYTES)) 6540 %add(t0, t0, t1) 6541 %st_global(t0, &gc_root_end, t1) 6542 6543 %ret 6544 6545 # Sentinel: marks the boundary between executable text and rodata. 6546 # Read by scripts/disasm-elf.sh (via scripts/m1-symbols.py) to bound 6547 # disassembly so trailing strings don't decode as bogus instructions. 6548 :_text_end 6549 6550 .align 8 6551 6552 # Primitive surface names. 6553 :name_sys_exit %cstr8("sys-exit") 6554 :name_cons %cstr8("cons") 6555 :name_car %cstr8("car") 6556 :name_cdr %cstr8("cdr") 6557 :name_nullq %cstr8("null?") 6558 :name_pairq %cstr8("pair?") 6559 :name_stringq %cstr8("string?") 6560 :name_set_car %cstr8("set-car!") 6561 :name_set_cdr %cstr8("set-cdr!") 6562 :name_length %cstr8("length") 6563 :name_list_ref %cstr8("list-ref") 6564 :name_assq %cstr8("assq") 6565 :name_assoc %cstr8("assoc") 6566 :name_reverse %cstr8("reverse") 6567 :name_str_to_sym %cstr8("string->symbol") 6568 :name_sym_to_str %cstr8("symbol->string") 6569 :name_num_to_str %cstr8("number->string") 6570 :name_str_to_num %cstr8("string->number") 6571 :name_bv_append %cstr8("bytevector-append") 6572 :name_booleanq %cstr8("boolean?") 6573 :name_integerq %cstr8("integer?") 6574 :name_symbolq %cstr8("symbol?") 6575 :name_procedureq %cstr8("procedure?") 6576 :name_zeroq %cstr8("zero?") 6577 :name_not %cstr8("not") 6578 :name_eqq %cstr8("eq?") 6579 :name_equal %cstr8("equal?") 6580 :name_plus %cstr8("+") 6581 :name_minus %cstr8("-") 6582 :name_mult %cstr8("*") 6583 :name_eq %cstr8("=") 6584 :name_lt %cstr8("<") 6585 :name_gt %cstr8(">") 6586 :name_quotient %cstr8("quotient") 6587 :name_remainder %cstr8("remainder") 6588 :name_bit_and %cstr8("bit-and") 6589 :name_bit_or %cstr8("bit-or") 6590 :name_bit_xor %cstr8("bit-xor") 6591 :name_bit_not %cstr8("bit-not") 6592 :name_arith_shift %cstr8("arithmetic-shift") 6593 :name_apply %cstr8("apply") 6594 :name_make_bv %cstr8("make-bytevector") 6595 :name_bv_length %cstr8("bytevector-length") 6596 :name_string_length %cstr8("string-length") 6597 :name_bv_u8_ref %cstr8("bytevector-u8-ref") 6598 :name_bv_u8_set %cstr8("bytevector-u8-set!") 6599 :name_bv_copy %cstr8("bytevector-copy") 6600 :name_bv_copy_b %cstr8("bytevector-copy!") 6601 :name_bv_eq %cstr8("bytevector=?") 6602 6603 :name_sys_read %cstr8("sys-read") 6604 :name_sys_write %cstr8("sys-write") 6605 :name_sys_close %cstr8("sys-close") 6606 :name_sys_openat %cstr8("sys-openat") 6607 :name_sys_clone %cstr8("sys-clone") 6608 :name_sys_execve %cstr8("sys-execve") 6609 :name_sys_spawn %cstr8("sys-spawn") 6610 :name_sys_waitid %cstr8("sys-waitid") 6611 :name_sys_argv %cstr8("sys-argv") 6612 :name_eof %cstr8("eof") 6613 :name_eofq %cstr8("eof?") 6614 :name_values %cstr8("values") 6615 :name_call_with_values %cstr8("call-with-values") 6616 :name_display %cstr8("display") 6617 :name_write %cstr8("write") 6618 :name_error %cstr8("error") 6619 :name_format %cstr8("format") 6620 :name_heap_usage %cstr8("heap-usage") 6621 :name_collect_garbage %cstr8("collect-garbage") 6622 :name_recordq %cstr8("record?") 6623 :name_record_td %cstr8("record-td") 6624 :name_record_ref %cstr8("record-ref") 6625 :name_record_set_bang %cstr8("record-set!") 6626 :name_make_record_td %cstr8("make-record/td") 6627 :name_td_nfields %cstr8("td-nfields") 6628 :name_td_name %cstr8("td-name") 6629 :name_tagged_value %cstr8("tagged-value") 6630 :name_peek_u8 %cstr8("peek-u8") 6631 6632 # Writer string constants. Lengths are hard-coded at the str_putn call 6633 # sites (write_to_bv branches). They are emitted through cstr8 so the 6634 # labels remain aligned and are also safe as C strings if reused later. 6635 :str_false %cstr8("#f") 6636 :str_true %cstr8("#t") 6637 :str_nil %cstr8("()") 6638 :str_unspec %cstr8("#!unspec") 6639 :str_unbound %cstr8("#!unbound") 6640 :str_eof %cstr8("#!eof") 6641 :str_closure %cstr8("#<closure>") 6642 :str_prim %cstr8("#<prim>") 6643 :str_td %cstr8("#<rec-type>") 6644 :str_rec %cstr8("#<record>") 6645 :str_unknown %cstr8("#<unknown>") 6646 :str_error_prefix %cstr8("scheme1: error: ") 6647 6648 # Primitive registration table. Each entry: 8-byte name_ptr (4-byte label 6649 # ref + 4 pad), 8-byte name_len, 8-byte entry_label (4 ref + 4 pad). 6650 :prim_table 6651 &name_sys_exit %(0) $(8) &prim_sys_exit_entry %(0) 6652 &name_cons %(0) $(4) &prim_cons_entry %(0) 6653 &name_car %(0) $(3) &prim_car_entry %(0) 6654 &name_cdr %(0) $(3) &prim_cdr_entry %(0) 6655 &name_nullq %(0) $(5) &prim_nullq_entry %(0) 6656 &name_pairq %(0) $(5) &prim_pairq_entry %(0) 6657 &name_stringq %(0) $(7) &prim_stringq_entry %(0) 6658 &name_set_car %(0) $(8) &prim_set_car_entry %(0) 6659 &name_set_cdr %(0) $(8) &prim_set_cdr_entry %(0) 6660 &name_length %(0) $(6) &prim_length_entry %(0) 6661 &name_list_ref %(0) $(8) &prim_list_ref_entry %(0) 6662 &name_assq %(0) $(4) &prim_assq_entry %(0) 6663 &name_assoc %(0) $(5) &prim_assoc_entry %(0) 6664 &name_reverse %(0) $(7) &prim_reverse_entry %(0) 6665 &name_str_to_sym %(0) $(14) &prim_string_to_symbol_entry %(0) 6666 &name_sym_to_str %(0) $(14) &prim_symbol_to_string_entry %(0) 6667 &name_num_to_str %(0) $(14) &prim_number_to_string_entry %(0) 6668 &name_str_to_num %(0) $(14) &prim_string_to_number_entry %(0) 6669 &name_bv_append %(0) $(17) &prim_bv_append_entry %(0) 6670 &name_booleanq %(0) $(8) &prim_booleanq_entry %(0) 6671 &name_integerq %(0) $(8) &prim_integerq_entry %(0) 6672 &name_symbolq %(0) $(7) &prim_symbolq_entry %(0) 6673 &name_procedureq %(0) $(10) &prim_procedureq_entry %(0) 6674 &name_zeroq %(0) $(5) &prim_zeroq_entry %(0) 6675 &name_not %(0) $(3) &prim_not_entry %(0) 6676 &name_eqq %(0) $(3) &prim_eqq_entry %(0) 6677 &name_equal %(0) $(6) &prim_equal_entry %(0) 6678 &name_plus %(0) $(1) &prim_plus_entry %(0) 6679 &name_minus %(0) $(1) &prim_minus_entry %(0) 6680 &name_mult %(0) $(1) &prim_mult_entry %(0) 6681 &name_eq %(0) $(1) &prim_eq_entry %(0) 6682 &name_lt %(0) $(1) &prim_lt_entry %(0) 6683 &name_gt %(0) $(1) &prim_gt_entry %(0) 6684 &name_quotient %(0) $(8) &prim_quotient_entry %(0) 6685 &name_remainder %(0) $(9) &prim_remainder_entry %(0) 6686 &name_bit_and %(0) $(7) &prim_bit_and_entry %(0) 6687 &name_bit_or %(0) $(6) &prim_bit_or_entry %(0) 6688 &name_bit_xor %(0) $(7) &prim_bit_xor_entry %(0) 6689 &name_bit_not %(0) $(7) &prim_bit_not_entry %(0) 6690 &name_arith_shift %(0) $(16) &prim_arith_shift_entry %(0) 6691 &name_apply %(0) $(5) &prim_apply_entry %(0) 6692 &name_make_bv %(0) $(15) &prim_make_bytevector_entry %(0) 6693 &name_bv_length %(0) $(17) &prim_bv_length_entry %(0) 6694 &name_string_length %(0) $(13) &prim_string_length_entry %(0) 6695 &name_bv_u8_ref %(0) $(17) &prim_bv_u8_ref_entry %(0) 6696 &name_bv_u8_set %(0) $(18) &prim_bv_u8_set_entry %(0) 6697 &name_bv_copy %(0) $(15) &prim_bv_copy_entry %(0) 6698 &name_bv_copy_b %(0) $(16) &prim_bv_copy_bang_entry %(0) 6699 &name_bv_eq %(0) $(12) &prim_bytevector_eq_entry %(0) 6700 &name_sys_read %(0) $(8) &prim_sys_read_entry %(0) 6701 &name_sys_write %(0) $(9) &prim_sys_write_entry %(0) 6702 &name_sys_close %(0) $(9) &prim_sys_close_entry %(0) 6703 &name_sys_openat %(0) $(10) &prim_sys_openat_entry %(0) 6704 &name_sys_clone %(0) $(9) &prim_sys_clone_entry %(0) 6705 &name_sys_execve %(0) $(10) &prim_sys_execve_entry %(0) 6706 &name_sys_spawn %(0) $(9) &prim_sys_spawn_entry %(0) 6707 &name_sys_waitid %(0) $(10) &prim_sys_waitid_entry %(0) 6708 &name_sys_argv %(0) $(8) &prim_sys_argv_entry %(0) 6709 &name_eofq %(0) $(4) &prim_eofq_entry %(0) 6710 &name_display %(0) $(7) &prim_display_entry %(0) 6711 &name_write %(0) $(5) &prim_write_entry %(0) 6712 &name_error %(0) $(5) &prim_error_entry %(0) 6713 &name_format %(0) $(6) &prim_format_entry %(0) 6714 &name_heap_usage %(0) $(10) &prim_heap_usage_entry %(0) 6715 &name_collect_garbage %(0) $(15) &prim_collect_garbage_entry %(0) 6716 &name_recordq %(0) $(7) &prim_recordq_entry %(0) 6717 &name_record_td %(0) $(9) &prim_record_td_entry %(0) 6718 &name_record_ref %(0) $(10) &prim_record_ref_entry %(0) 6719 &name_record_set_bang %(0) $(11) &prim_record_set_bang_entry %(0) 6720 &name_make_record_td %(0) $(14) &prim_make_record_td_entry %(0) 6721 &name_td_nfields %(0) $(10) &prim_td_nfields_entry %(0) 6722 &name_td_name %(0) $(7) &prim_td_name_entry %(0) 6723 &name_tagged_value %(0) $(12) &prim_tagged_value_entry %(0) 6724 &name_peek_u8 %(0) $(7) &prim_peek_u8_entry %(0) 6725 &name_values %(0) $(6) &prim_values_entry %(0) 6726 &name_call_with_values %(0) $(16) &prim_call_with_values_entry %(0) 6727 :prim_table_end 6728 6729 ;; Error messages are NUL-terminated C strings. The embedded newline 6730 ;; keeps the old stderr formatting; runtime_error's panic path appends 6731 ;; another newline, which shell command substitution trims in tests. 6732 :msg_usage %cstr8("scheme1: usage: scheme1 SOURCE.scm\n") 6733 :msg_load_fail %cstr8("scheme1: failed to read source\n") 6734 :msg_symtab_full %cstr8("scheme1: symbol table full\n") 6735 :msg_unexp_rparen %cstr8("scheme1: unexpected ')'\n") 6736 :msg_bad_hash %cstr8("scheme1: bad #-syntax\n") 6737 :msg_unexp_eof %cstr8("scheme1: unexpected EOF in form\n") 6738 :msg_unterm_list %cstr8("scheme1: unterminated list\n") 6739 :msg_unbound %cstr8("scheme1: unbound variable\n") 6740 :msg_not_proc %cstr8("scheme1: not a procedure\n") 6741 :msg_heap_full %cstr8("scheme1: heap exhausted\n") 6742 :msg_heap_corrupt %cstr8("scheme1: corrupt managed heap\n") 6743 :msg_gc_roots_full %cstr8("scheme1: shadow root stack overflow\n") 6744 :msg_readbuf_full %cstr8("scheme1: source buffer overflow\n") 6745 :msg_bv_oob %cstr8("scheme1: bytevector index out of range\n") 6746 :msg_unterm_string %cstr8("scheme1: unterminated string literal\n") 6747 :msg_bad_escape %cstr8("scheme1: bad string escape\n") 6748 :msg_bad_char %cstr8("scheme1: bad #\\ character literal\n") 6749 :msg_bad_number %cstr8("scheme1: bad number literal\n") 6750 :msg_bad_ident %cstr8("scheme1: bad identifier\n") 6751 :msg_internal_define %cstr8("scheme1: internal define is not supported\n") 6752 :msg_pmatch_no_match %cstr8("scheme1: pmatch: no clause matched\n") 6753 :msg_bad_unquote_pattern %cstr8("scheme1: pmatch: malformed ,-pattern\n") 6754 6755 :name_ch_tab %cstr8("tab") 6756 :name_ch_null %cstr8("null") 6757 :name_ch_space %cstr8("space") 6758 :name_ch_return %cstr8("return") 6759 :name_ch_newline %cstr8("newline") 6760 6761 # ========================================================================= 6762 # BSS arena table 6763 # ========================================================================= 6764 # 6765 # (slot, size) rows for libp1pp's init_arenas, walked once at startup. 6766 # init_arenas threads a running offset, so each arena starts where the 6767 # previous one ended. 6768 :arena_table 6769 %arena_entry(&readbuf_buf_ptr, %READBUF_CAP_BYTES) 6770 %arena_entry(&symtab_buf_ptr, (* %SYMTAB_CAP_SLOTS %SYMENT.SIZE)) 6771 %arena_entry(&gc_root_buf_ptr, (* %GC_ROOT_CAP_FRAMES %GC_ROOT_FRAME_BYTES)) 6772 %arena_entry(&heap_buf_ptr, %HEAP_CAP_BYTES) 6773 :arena_table_end 6774 6775 # ========================================================================= 6776 # Scalar BSS (file-resident, zero-initialized) 6777 # ========================================================================= 6778 6779 # Managed-heap physical chain and accounting. 6780 :heap_base $(0) 6781 :heap_tail $(0) 6782 :heap_end $(0) 6783 :heap_allocated $(0) 6784 :gc_free_list $(0) 6785 :gc_mark_worklist $(0) 6786 6787 # Exact shadow-root frame stack. 6788 :gc_root_next $(0) 6789 :gc_root_end $(0) 6790 6791 # Source-buffer cursor and slurped length. 6792 :readbuf_pos $(0) 6793 :readbuf_len $(0) 6794 6795 # Symbol table count (number of entries used). 6796 :symtab_count $(0) 6797 6798 # Cached tagged-symbol values for special forms (filled by 6799 # intern_special_forms at startup). 6800 :sym_quote $(0) 6801 :sym_if $(0) 6802 :sym_lambda $(0) 6803 :sym_define $(0) 6804 :sym_begin $(0) 6805 :sym_cond $(0) 6806 :sym_else $(0) 6807 :sym_arrow $(0) 6808 :sym_let $(0) 6809 :sym_letstar $(0) 6810 :sym_let_values $(0) 6811 :sym_letstar_values $(0) 6812 :sym_and $(0) 6813 :sym_or $(0) 6814 :sym_when $(0) 6815 :sym_case $(0) 6816 :sym_setbang $(0) 6817 :sym_define_record_type $(0) 6818 :sym_pmatch $(0) 6819 :sym_do $(0) 6820 :sym_unquote $(0) 6821 :sym_guard $(0) 6822 :sym_underscore $(0) 6823 :sym_dollar $(0) 6824 6825 # Process startup state, captured by p1_main and read by sys-argv. 6826 :saved_argc $(0) 6827 :saved_argv $(0) 6828 6829 # Scratch buffer for bv_putint / str_putint -> fmt_dec. fmt_dec writes 6830 # at most 20 bytes for a 64-bit signed integer; 24 bytes (three words) 6831 # is comfortable room and keeps following slots word-aligned. 6832 :writer_num_buf $(0) $(0) $(0) 6833 6834 # Pointer slots for the past-:ELF_end arenas. 6835 :readbuf_buf_ptr $(0) 6836 :heap_buf_ptr $(0) 6837 :symtab_buf_ptr $(0) 6838 :gc_root_buf_ptr $(0) 6839 6840 :ELF_end