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