mimi/mimi.asm

   1 ;;; Copyright (C) 2018 Keziah Wesley
   2 ;;;
   3 ;;; You can redistribute and/or modify this file under the terms of the
   4 ;;; GNU Affero General Public License as published by the Free Software
   5 ;;; Foundation, either version 3 of the License, or (at your option) any
   6 ;;; later version.
   7 ;;;
   8 ;;; This file is distributed in the hope that it will be useful, but
   9 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  10 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
  11 ;;; Affero General Public License for more details.
  12 ;;;
  13 ;;; You should have received a copy of the GNU Affero General Public
  14 ;;; License along with this file. If not, see
  15 ;;; <http://www.gnu.org/licenses/>.
  16
  17 global _start
  18 default rel
  19
  20 %macro doj 3
  21         dw %1, %2
  22         dd %3
  23 %endmacro
  24
  25 %macro dop 4
  26         db ((ops.%1 - ops)>>3), %2, %3, %4
  27 %endmacro
  28 %macro dop 3
  29         db ((ops.%1 - ops)>>3), %2
  30         dw %3
  31 %endmacro
  32
  33 %macro defop 1
  34         .%1: dq op_%1
  35 %endmacro
  36
  37 ;;; tracing: abort if not primtype match (XXX: actual tests usu. more complex...)
  38 %macro tr_guard_pt 1
  39 %endmacro
  40
  41 ;;; tracing: abort if not fulltype match
  42 %macro tr_guard_tt 1
  43 %endmacro
  44
  45 %macro tr_guard_bounds 0
  46 %endmacro
  47
  48 ;;; profiling: count jumps if offset negative.
  49 %macro pr_j 2
  50 %endmacro
  51
  52 ;;; log if tracing. record if profiling and offset negative.
  53 %macro tr_br_taken 2
  54 %endmacro
  55
  56 ;;; tracing: log road not taken.
  57 %macro tr_br_fallthrough 2
  58 %endmacro
  59
  60 %define PT_FIX 1h
  61 %define PT_BYTES 2h
  62 %define PT_STRING 3h
  63 %define PT_UBLOCK 4h
  64 %define PT_DOPE 5h
  65 %define PT_RECORD 6h
  66 %define PT_BYTES 7h
  67
  68 %define TT_MSUBR (PT_RECORD | 0100h) ; aka RVECTOR
  69 %define TT_CODE (PT_UBLOCK | 0100h)
  70 %define TT_DOPE_UB (PT_DOPE | (PT_UBLOCK << 8))
  71
  72 ;%macro leafcall 1
  73 ;       lea r14, [.leaf_ret]
  74 ;       jmp %1
  75 ;       .leaf_ret:
  76 ;%endmacro
  77
  78 section .rodata
  79 align 8
  80 ops:
  81         defop error
  82         defop applyb
  83         defop return
  84         defop nthrb
  85         defop princ
  86         defop constb
  87         defop halt
  88         defop adj
  89         defop subb
  90         defop grtrb
  91         defop mull
  92         defop jump
  93         defop andb
  94         defop lshb
  95         defop addb
  96         defop newyl
  97         defop putyl
  98         defop restyl
  99
 100 errStr  db 'An error has occurred.',0xA
 101 errLen  equ $-errStr
 102
 103 byeStr  db 0xA,'Goodbye!',0xA
 104 byeLen  equ $-byeStr
 105
 106 section .data
 107
 108         ;<destrucr? 1 # =>
 109         ;<destrucxn 1 start..end>
 110
 111 ;reqs:  ;<destrucr? 1 opts local1>
 112         ;<destrucr? 1 opts local2>
 113         ;<error NEED-MORE-ARGS>
 114 ;opt1:  ;<destrucr? 1 opt2 local3>
 115         ;<... =local2>
 116 ;opt2:  ;<destrucr? 1 chk local4>
 117         ;<... =local3>
 118 ;chk:   ;<empr? 1 body>
 119         ;<error TOO-MANY-ARGS>
 120 ;body:
 121
 122 ;reqs:  ;<destrucxn local1..local2>
 123 ;opt1:  ;<destrucr? 1 opt2 local3>
 124         ;<... =local2>
 125 ;opt2:  ;<destrucr? 1 chk local4>
 126         ;<... =local3>
 127 ;chk:   ;<empr? 1 body>
 128         ;<error TOO-MANY-ARGS>
 129 ;body:
 130
 131 ;; <MAPF ,STRING <FUNCTION (x) ...>>
 132
 133 unparse_code:
 134         ;; implicit locals (0-1):
 135         ;; 0: RVECTOR
 136         ;; 1: ARGS TUPLE
 137         ;; reserved locals (2-2):
 138         ;; 2: N (arg)
 139         ;; 3: buf
 140         ;; 4: x
 141         ;; 5: i
 142         ;; stack (4-):
 143         dop adj, 3, 0
 144         dop nthrb, 0, 1, 2
 145         dop constb, 12, 5, 0
 146         dop newyl, 5, ' ', 3
 147
 148         dop andb, 7, 2, 4
 149         dop lshb, -3, 2, 2
 150         dop addb, '0', 4, 4
 151         dop putyl, 5, 4, 3
 152         dop subb, 1, 5, 5
 153         dop grtrb, 0, -6, 2
 154
 155         dop restyl, 5, 3, 3
 156         dop return, 3, 0
 157         .len equ ($-unparse_code) >> 2
 158         align 8
 159         doj TT_DOPE_UB, 0, .len
 160 unparse_rv:
 161         doj TT_CODE, unparse_code.len, unparse_code
 162         doj TT_MSUBR, unparse_rv.len, unparse_rv
 163         .len equ ($-unparse_rv) >> 3
 164
 165 fact_code:
 166         ;; implicit locals (0-1):
 167         ;; 0: RVECTOR
 168         ;; 1: ARGS TUPLE
 169         ;; reserved locals (2-3):
 170         ;; 2: N (arg)
 171         ;; 3: FACT
 172         ;; 4: tmp0
 173         ;; stack (5-):
 174         dop adj, 3, 0
 175
 176         dop nthrb, 0, 1, 2
 177         dop nthrb, 1, 0, 3
 178
 179         dop grtrb, 1, 2, 2
 180         dop constb, 1, 2, 0
 181         dop return, 2, 0
 182
 183         dop subb, 1, 2, 5
 184         dop applyb, 1, 3, 4
 185         dop mull, 2, 4, 4
 186         dop return, 4, 0
 187         .len equ ($-fact_code) >> 2
 188         align 8
 189         doj TT_DOPE_UB, 0, .len
 190 fact_rv:
 191         doj TT_CODE, fact_code.len, fact_code
 192         doj TT_MSUBR, fact_rv.len, fact_rv
 193         .len equ ($-fact_rv) >> 3
 194
 195 toplevel_code:
 196         ;; implicit locals (0-1):
 197         ;; 0: RVECTOR
 198         ;; 1: ARGS TUPLE
 199         ;; reserved locals (2-2):
 200         ;; 2: tmp0
 201         ;; 3: MSUBR unparse
 202         ;; stack (4-):
 203         dop adj, 2, 0
 204
 205         dop constb, 5, 4, 0
 206         dop nthrb, 1, 0, 2
 207         dop applyb, 1, 2, 4
 208
 209         dop adj, 1, 0
 210         dop nthrb, 2, 0, 3
 211         dop applyb, 1, 3, 3
 212         dop princ, 3, 0
 213
 214         dop constb, 0, 0, 2
 215         dop halt, 2, 0
 216         .len equ ($-toplevel_code) >> 2
 217         align 8
 218         doj TT_DOPE_UB, 0, .len
 219 toplevel_rv:
 220         doj TT_CODE, toplevel_code.len, toplevel_code
 221         doj TT_MSUBR, fact_rv.len, fact_rv
 222         doj TT_MSUBR, unparse_rv.len, unparse_rv
 223         .len equ ($-toplevel_rv) >> 3
 224 oj_toplevel doj TT_MSUBR, toplevel_rv.len, toplevel_rv
 225
 226 section .bss
 227
 228 ;; state:
 229 ;;   esi: ip
 230 ;;   ebp: bp [nonnegative idxes are locals, neg are cur FRAME's fields]
 231 ;;   esp: sp [top of stack. starts at end of locals. grows UP.]
 232 ;;   edi: next free heap pos [grows up.]
 233 ;; on entry into an op:
 234 ;;   rbx: B
 235 ;;   rax: CD
 236
 237 section .text
 238 ;; inline this for "release mode", but it's a useful breakpoint
 239 dispatch:
 240         lodsd
 241         movzx edx, al
 242         movzx ebx, ah
 243         shr eax, 16
 244         jmp [ops + 8*rdx]
 245
 246 %macro dispatch 0
 247         jmp dispatch
 248 %endmacro
 249
 250 _start:
 251 ;; Setup memory layout:
 252         mov edx, 1|2            ; int prot = PROT_READ | PROT_WRITE
 253         mov r10d, 2|32|64       ; int flags = MAP_PRIVATE | MAP_ANONYMOUS | MAP_32BIT
 254         mov r8d, -1             ; int fd = -1
 255         xor edi, edi            ; void *addr = NULL
 256         xor r9d, r9d            ; off_t offset = 0
 257 ;; initial stack (1MB)
 258         mov esi, 100000h        ; size_t length
 259         mov eax, 9              ; mmap
 260         syscall
 261         mov esp, eax
 262 ;; major heap...
 263 ;; (large-alloc space)...
 264 ;; FFI stack pool...
 265 ;; minor heap (default: 8MB)
 266         mov esi, 800000h        ; size_t length
 267         mov eax, 9              ; mmap
 268         syscall
 269         mov edi, eax
 270
 271 ;; Load some builtins into the heap
 272
 273 ;; Setup a PROCESS for the GC...
 274
 275 ;; boot:
 276         ;; point locals to a static MSUBR object for the toplevel MSUBR
 277         mov ebp, oj_toplevel
 278         ;; set eax,ebx as if we'd just read <APPLY 0 0 0>
 279         xor eax, eax
 280         xor ebx, ebx
 281         xor esi, esi            ; toplevel must not return
 282         jmp op_applyb
 283
 284 op_princ:                       ; PRINC [B]:STRING
 285         mov rax, [rbp + 8*rbx]
 286         cmp al, PT_STRING
 287         je .string
 288         cmp al, PT_BYTES
 289         jne error
 290 .bytes:
 291 .string:
 292         mov r8, rsi
 293         mov r9, rdi
 294
 295         mov edx, eax            ; size_t
 296         shr edx, 16             ;        count
 297         shr rax, 32             ; const void *
 298         mov esi, eax            ;             buf
 299         mov eax, 1              ; write(2)
 300         mov edi, eax            ; int fd = stdout
 301         syscall
 302
 303         mov rsi, r8
 304         mov rdi, r9
 305
 306         cmp eax, edx
 307         jne error
 308
 309         dispatch
 310
 311 op_halt:                        ; HALT [B]:FIX
 312         mov edx, byeLen         ; size_t count
 313         mov esi, byeStr         ; const void *buf
 314         mov eax, 1              ; write(2)
 315         lea edi, [rax+rax]      ; int fd = stderr
 316         syscall
 317
 318         mov rax, [rbp + 8*rbx]
 319         cmp al, PT_FIX
 320         ;jne error
 321         shr rax, 32
 322         mov edi, eax            ; int status
 323         mov eax, 60             ; exit(2)
 324         syscall
 325
 326 op_applyb:                      ; <APPLY nargs:byte local:msubr =>
 327         ; ignore [=] for now. we'll re-decode this insn in op_return
 328         movzx eax, al
 329         mov rax, [rbp + 8*rax]
 330         cmp ax, TT_MSUBR
 331         jne error
 332         mov rdx, rax
 333
 334 %ifdef DEBUG
 335         test eax, 0ffff0000h
 336         jz error
 337 %endif
 338
 339         shr rax, 32
 340         mov rax, [rax]
 341
 342 %ifdef DEBUG
 343         cmp ax, TT_CODE
 344         jne error
 345         test eax, 0ffff0000h
 346         jz error
 347 %endif
 348
 349         mov ecx, ebx
 350         ;; save a FRAME of state to return to:
 351         neg rbx
 352         lea ebx, [rsp+8*rbx]
 353         add esp, 16
 354         mov r8d, ebp
 355         mov ebp, esp
 356         ;; FRAME:
 357         ;mov [rbp-16], e--      ; padding
 358         mov [rbp-12], ebx       ; start of args on stack
 359         mov [rbp-8], esi        ; return-to ip
 360         mov [rbp-4], r8d        ; prev FRAME/locals boundary
 361         ;; implicit locals:
 362         shl rbx, 32
 363         shl ecx, 16
 364         lea rbx, [rbx+rcx+PT_RECORD]
 365         mov [rbp], rdx          ; 0: MSUBR (RVECTOR)
 366         mov [rbp+8], rbx        ; 1: ARGS TUPLE
 367
 368         add esp, 24
 369
 370         shr rax, 32
 371         mov esi, eax
 372
 373         dispatch
 374
 375 op_return:                      ; <RETURN any:local>
 376         mov rbx, [rbp+8*rbx]
 377
 378         mov esp, [rbp-12]
 379         mov esi, [rbp-8]
 380         mov ebp, [rbp-4]
 381
 382         mov eax, [rsi-4]
 383         shr eax, 24
 384         mov [rbp+8*rax], rbx
 385
 386         dispatch
 387
 388 op_nthrb:                       ; <NTH index:byte record:local =>
 389         movzx ecx, al
 390         movzx edx, ah
 391         mov rax, [rbp + 8*rcx]
 392         cmp al, PT_RECORD
 393         ;; TODO: fallback to pmorphic
 394         jne error
 395
 396         mov ecx, eax
 397         shr ecx, 16
 398         cmp ebx, ecx
 399         jge error
 400
 401         shr rax, 32
 402         mov rax, [rax+8*rbx]
 403         mov [rbp+8*rdx], rax
 404
 405         dispatch
 406
 407         ;; BodyLnTP
 408
 409 op_restyl:                      ; <RESTYL index:local bytes:local =>
 410         movzx ecx, al
 411         movzx edx, ah
 412         mov rax, [rbp + 8*rcx]
 413         cmp al, PT_BYTES
 414         ;; TODO: fallback to pmorphic
 415         jne error
 416
 417         mov rbx, [rbp + 8*rbx]
 418         sub rbx, PT_FIX         ; (dec rbx) if PT_FIX==1
 419         test bx, bx
 420         jnz error
 421
 422         add rax, rbx
 423         rol rax, 32
 424         rol rbx, 16
 425         sub rax, rbx
 426         jo error
 427         ror rax, 32
 428         mov [rbp+8*rdx], rax
 429
 430         dispatch
 431
 432 op_putyl:                       ; <PUTYL local:index value:local local:bytes>
 433         movzx edx, al
 434
 435         mov rcx, [rbp + 8*rbx]
 436         cmp cl, PT_FIX
 437         jne error
 438         shr rcx, 32
 439         jz error
 440         ;; rcx = offset
 441
 442         movzx eax, ah
 443         mov rax, [rbp + 8*rax]
 444         cmp al, PT_BYTES
 445         ;; TODO: fallback to pmorphic
 446         jne error
 447         ;; rax = bytes
 448
 449         mov rdx, [rbp + 8*rdx]
 450         cmp dx, PT_FIX
 451         jne error
 452         shr rdx, 32
 453         ;; rdx = val
 454
 455         shr rax, 16
 456         cmp cx, ax
 457         jg error
 458         shr rax, 16
 459         mov [rax + rcx - 1], dl
 460
 461         dispatch
 462
 463 op_constb:                      ; <CONSTB byte = hitype:byte>
 464         movzx edx, al
 465         sub eax, edx
 466         or eax, PT_FIX
 467         shl rbx, 32
 468         or rbx, rax
 469         mov [rbp+8*rdx], rbx
 470
 471         dispatch
 472
 473 op_adj:                         ; <ADJ byte>
 474         lea esp, [rsp+8*rbx]
 475
 476         dispatch
 477
 478 op_subb:                        ; <SUBB rhs:byte in:fix =>
 479         movzx edx, ah
 480         movzx eax, al
 481         mov rax, [rbp+8*rax]
 482         cmp ax, PT_FIX
 483         setne cl
 484         shl rbx, 32
 485         sub rax, rbx
 486         seto bl
 487         or cl, bl
 488         jnz error
 489         mov [rbp+8*rdx], rax
 490
 491         dispatch
 492
 493 op_addb:                        ; <ADDB ubyte local:fix =>
 494         movzx edx, ah
 495         movzx eax, al
 496         mov rax, [rbp+8*rax]
 497         cmp ax, PT_FIX
 498         setne cl
 499         shl rbx, 32
 500         add rax, rbx
 501         seto bl
 502         or cl, bl
 503         jnz error
 504         mov [rbp+8*rdx], rax
 505
 506         dispatch
 507
 508 op_andb:                        ; <ANDB byte local:fix =>
 509         movzx edx, ah
 510         movzx eax, al
 511         mov rax, [rbp+8*rax]
 512         cmp ax, PT_FIX
 513         jne error
 514         shl rbx, 32
 515         and rax, rbx
 516         or rax, PT_FIX
 517         mov [rbp+8*rdx], rax
 518
 519         dispatch
 520
 521 op_lshb:                        ; <LSHB byte local:fix =>
 522         movzx edx, ah
 523         movzx eax, al
 524         mov rax, [rbp+8*rax]
 525         cmp ax, PT_FIX
 526         jne error
 527         lea ecx, [rbx-32]
 528         neg ecx
 529         shr rax, cl
 530         shl rax, 32
 531         or rax, PT_FIX
 532         mov [rbp+8*rdx], rax
 533
 534         dispatch
 535
 536 op_newyl:                       ; <NEWYB len:local initial:byte =>
 537         movzx edx, ah
 538
 539         mov rbx, [rbp+8*rbx]
 540         cmp bx, PT_FIX
 541         jne error
 542         shr rbx, 32
 543
 544         movzx eax, al           ; "       a"
 545         mov ecx, eax
 546         shl ecx, 8
 547         or eax, ecx             ; "      aa"
 548         mov ecx, eax
 549         shl ecx, 16
 550         or eax, ecx             ; "    aaaa"
 551         mov ecx, eax
 552         shl rcx, 32
 553         or rax, rcx             ; "aaaaaaaa"
 554
 555         mov ecx, ebx
 556
 557         ;; write object
 558         shl rbx, 48
 559         or rbx, rdi
 560         rol rbx, 32
 561         or rbx, PT_BYTES
 562         mov [rbp+8*rdx], rbx
 563
 564         ;jmp blitheap_op
 565 blitheap_op:                    ; rax=init ecx=len (dword [rdx]: rewritten if base != edi)
 566         add ecx, 7
 567         shr ecx, 3
 568         lea ecx, [rdi + rcx]
 569 .init:
 570         stosq
 571         cmp edi, ecx
 572         jl .init
 573
 574         dispatch
 575
 576 op_mull:                        ; <MULL b:fix c:fix =>
 577         movzx edx, ah
 578         movzx eax, al
 579         mov rbx, [rbp+8*rbx]
 580         mov rax, [rbp+8*rax]
 581         cmp bx, PT_FIX
 582         setne cl
 583         cmp ax, bx
 584         setne ch
 585         or cl, ch
 586         shr rbx, 32
 587         shr rax, 32
 588         imul eax, ebx
 589         seto ch
 590         or cl, ch
 591         jnz error
 592         shl rax, 32
 593         or rax, PT_FIX
 594         mov [rbp+8*rdx], rax
 595
 596         dispatch
 597
 598 op_grtrb:                       ; <GRTRB? rhs:byte tgt in:fix>
 599         movsx rdx, al
 600         movzx eax, ah
 601         mov rax, [rbp+8*rax]
 602         cmp ax, PT_FIX
 603         jne error
 604         shr rax, 32
 605         cmp eax, ebx
 606         jle .done
 607         lea esi, [rsi+4*rdx]
 608 .done:
 609         dispatch
 610
 611 op_jump:                        ; <JUMP . ##>
 612         movsx eax, ax
 613         lea esi, [esi+4*eax]
 614         dispatch
 615
 616 op_error:                       ; ERROR local:atom local:any local:any
 617 error:
 618         mov r8d, esi
 619         mov r9d, edi
 620
 621         mov edx, errLen         ; size_t count
 622         mov esi, errStr         ; const void *buf
 623         mov eax, 1              ; write(2)
 624         lea edi, [rax+rax]      ; int fd = stderr
 625         syscall
 626
 627         mov esi, r8d
 628         mov edi, r9d
 629
 630         mov edi, -1             ; int status
 631         mov eax, 60             ; exit(2)
 632         syscall