From db58f43065c3b397754bb9efcb4a7376b2538131 Mon Sep 17 00:00:00 2001 From: LLLL Colonq Date: Fri, 23 Oct 2026 20:47:43 -0400 Subject: pit: Add tests, fix binding bug --- asm/.dir-locals.el | 0 asm/.envrc | 1 + asm/Makefile | 72 ++++++ asm/include/lcq/asm/library.h | 8 + asm/lisp/test.pit | 29 +++ asm/lisp/x86.pit | 490 ++++++++++++++++++++++++++++++++++++++++ asm/packages.nix | 16 ++ asm/src/library.c | 302 +++++++++++++++++++++++++ asm/src/main.c | 24 ++ asm/x86_64.pdf | Bin 0 -> 11185300 bytes pit/Makefile | 5 +- pit/examples/6502.pit | 174 ++++++++++++++ pit/examples/array.pit | 2 + pit/examples/backtrace.pit | 2 + pit/examples/bif.pit | 12 + pit/examples/broken.pit | 5 + pit/examples/compile.pit | 6 + pit/examples/error.pit | 1 + pit/examples/error2.pit | 4 + pit/examples/fold.pit | 12 + pit/examples/gc.pit | 13 ++ pit/examples/infinite.pit | 4 + pit/examples/int.pit | 1 + pit/examples/loadpath.pit | 2 + pit/examples/nonbroken.pit | 2 + pit/examples/recurse.pit | 5 + pit/examples/struct.pit | 11 + pit/examples/test.pit | 22 ++ pit/examples/test10.pit | 5 + pit/examples/test11.pit | 4 + pit/examples/test2.pit | 1 + pit/examples/test3.pit | 7 + pit/examples/test4.pit | 6 + pit/examples/test5.pit | 6 + pit/examples/test6.pit | 6 + pit/examples/test7.pit | 1 + pit/examples/test8.pit | 2 + pit/examples/test9.pit | 2 + pit/examples/thebug.pit | 9 + pit/examples/thebug2.pit | 13 ++ pit/examples/x86.pit | 451 ++++++++++++++++++++++++++++++++++++ pit/examples/y.pit | 5 + pit/src/native.c | 12 + pit/src/parser.c | 14 +- pit/src/runtime/eval.c | 2 +- pit/test/6502.pit | 174 -------------- pit/test/array.pit | 2 - pit/test/backtrace.pit | 2 - pit/test/bif.pit | 12 - pit/test/broken.pit | 5 - pit/test/compile.pit | 6 - pit/test/core.pit | 1 + pit/test/error.pit | 1 - pit/test/error2.pit | 4 - pit/test/fold.pit | 12 - pit/test/gc.pit | 13 -- pit/test/horriblebindingbug.pit | 6 + pit/test/int.pit | 1 - pit/test/loadpath.pit | 2 - pit/test/nonbroken.pit | 2 - pit/test/recurse.pit | 5 - pit/test/struct.pit | 11 - pit/test/test.pit | 22 -- pit/test/test10.pit | 5 - pit/test/test11.pit | 4 - pit/test/test2.pit | 1 - pit/test/test3.pit | 7 - pit/test/test4.pit | 6 - pit/test/test5.pit | 6 - pit/test/test6.pit | 6 - pit/test/test7.pit | 1 - pit/test/test8.pit | 2 - pit/test/test9.pit | 2 - pit/test/thebug.pit | 9 - pit/test/thebug2.pit | 13 -- pit/test/x86.pit | 451 ------------------------------------ pit/test/y.pit | 5 - 77 files changed, 1771 insertions(+), 799 deletions(-) create mode 100644 asm/.dir-locals.el create mode 100644 asm/.envrc create mode 100644 asm/Makefile create mode 100644 asm/include/lcq/asm/library.h create mode 100644 asm/lisp/test.pit create mode 100644 asm/lisp/x86.pit create mode 100644 asm/packages.nix create mode 100644 asm/src/library.c create mode 100644 asm/src/main.c create mode 100644 asm/x86_64.pdf create mode 100644 pit/examples/6502.pit create mode 100644 pit/examples/array.pit create mode 100644 pit/examples/backtrace.pit create mode 100644 pit/examples/bif.pit create mode 100644 pit/examples/broken.pit create mode 100644 pit/examples/compile.pit create mode 100644 pit/examples/error.pit create mode 100644 pit/examples/error2.pit create mode 100644 pit/examples/fold.pit create mode 100644 pit/examples/gc.pit create mode 100644 pit/examples/infinite.pit create mode 100644 pit/examples/int.pit create mode 100644 pit/examples/loadpath.pit create mode 100644 pit/examples/nonbroken.pit create mode 100644 pit/examples/recurse.pit create mode 100644 pit/examples/struct.pit create mode 100644 pit/examples/test.pit create mode 100644 pit/examples/test10.pit create mode 100644 pit/examples/test11.pit create mode 100644 pit/examples/test2.pit create mode 100644 pit/examples/test3.pit create mode 100644 pit/examples/test4.pit create mode 100644 pit/examples/test5.pit create mode 100644 pit/examples/test6.pit create mode 100644 pit/examples/test7.pit create mode 100644 pit/examples/test8.pit create mode 100644 pit/examples/test9.pit create mode 100644 pit/examples/thebug.pit create mode 100644 pit/examples/thebug2.pit create mode 100644 pit/examples/x86.pit create mode 100644 pit/examples/y.pit delete mode 100644 pit/test/6502.pit delete mode 100644 pit/test/array.pit delete mode 100644 pit/test/backtrace.pit delete mode 100644 pit/test/bif.pit delete mode 100644 pit/test/broken.pit delete mode 100644 pit/test/compile.pit create mode 100644 pit/test/core.pit delete mode 100644 pit/test/error.pit delete mode 100644 pit/test/error2.pit delete mode 100644 pit/test/fold.pit delete mode 100644 pit/test/gc.pit create mode 100644 pit/test/horriblebindingbug.pit delete mode 100644 pit/test/int.pit delete mode 100644 pit/test/loadpath.pit delete mode 100644 pit/test/nonbroken.pit delete mode 100644 pit/test/recurse.pit delete mode 100644 pit/test/struct.pit delete mode 100644 pit/test/test.pit delete mode 100644 pit/test/test10.pit delete mode 100644 pit/test/test11.pit delete mode 100644 pit/test/test2.pit delete mode 100644 pit/test/test3.pit delete mode 100644 pit/test/test4.pit delete mode 100644 pit/test/test5.pit delete mode 100644 pit/test/test6.pit delete mode 100644 pit/test/test7.pit delete mode 100644 pit/test/test8.pit delete mode 100644 pit/test/test9.pit delete mode 100644 pit/test/thebug.pit delete mode 100644 pit/test/thebug2.pit delete mode 100644 pit/test/x86.pit delete mode 100644 pit/test/y.pit diff --git a/asm/.dir-locals.el b/asm/.dir-locals.el new file mode 100644 index 0000000..e69de29 diff --git a/asm/.envrc b/asm/.envrc new file mode 100644 index 0000000..fed67eb --- /dev/null +++ b/asm/.envrc @@ -0,0 +1 @@ +use_flake ..#asm diff --git a/asm/Makefile b/asm/Makefile new file mode 100644 index 0000000..bede40e --- /dev/null +++ b/asm/Makefile @@ -0,0 +1,72 @@ +EXE ?= asm + +CC ?= gcc +AR ?= ar +override CPPFLAGS += -MMD -MP +override CFLAGS += -O2 -fPIC --std=c99 -g -Ideps/ -Isrc/ -Iinclude/ -Wall -Wextra -Wpedantic -Wconversion -Wformat-security -Wshadow -Wpointer-arith -Wstrict-prototypes -Wmissing-prototypes -Wnull-dereference -Wfloat-equal -Wundef -Wpointer-arith -Wbad-function-cast -Wlogical-op -Wmissing-braces -Wcast-align -Wstrict-overflow=5 -fwrapv # -ftrapv +override LDFLAGS += -g -static -lcolonq-pit-native -lcolonq-pit -lcolonq-elf + +BUILD = build_$(CC) + +SRCS := \ + src/library.c \ + src/main.c +OBJECTS := $(SRCS:src/%.c=$(BUILD)/%.o) +LIB := libcolonq-asm.a + +CHK_SOURCES ?= $(SRCS) + +prefix ?= /usr/local +exec_prefix ?= $(prefix) +bindir ?= $(exec_prefix)/bin +includedir ?= $(prefix)/include +libdir ?= $(exec_prefix)/lib + +GDBFLAGS ?= + +.PHONY: all clean install install-bin install-headers install-lib check-syntax gdb + +all: $(EXE) $(LIB) + +$(EXE): $(BUILD)/main.o $(LIB) + $(CC) -o $@ $^ $(LDFLAGS) + +$(LIB): $(OBJECTS) + $(AR) rcs $@ $^ + +$(BUILD): + mkdir $(BUILD)/ + +$(BUILD)/%.o: src/%.c | $(BUILD) + $(CC) $(CPPFLAGS) $(CFLAGS) -o $@ -c $< + +clean: + -rm $(EXE) + -rm $(LIB) + -rm -r $(BUILD)/ + +tags: $(SRCS) + @ctags --kinds-all=* --fields=* --extras=* --recurse src/ include/ + +install: install-bin install-headers install-lib + +install-bin: $(EXE) + mkdir -p $(DESTDIR)$(bindir) $(DESTDIR)$(libdir) $(DESTDIR)$(includedir) + install $(EXE) $(DESTDIR)$(bindir)/$(EXE) + +install-headers: + mkdir -p $(DESTDIR)$(bindir) $(DESTDIR)$(libdir) $(DESTDIR)$(includedir) + cp -r include/* $(DESTDIR)$(includedir) + +install-lib: $(LIB) + mkdir -p $(DESTDIR)$(bindir) $(DESTDIR)$(libdir) $(DESTDIR)$(includedir) + install $(LIB) $(DESTDIR)$(libdir)/$(LIB) + +check-syntax: tags + gcc $(CFLAGS) -fsyntax-only $(CHK_SOURCES) + +gdb: $(EXE) + gdb $(GDBFLAGS) $(EXE) + +-include $(BUILD)/main.d +-include $(OBJECTS:.o=.d) diff --git a/asm/include/lcq/asm/library.h b/asm/include/lcq/asm/library.h new file mode 100644 index 0000000..8e2f311 --- /dev/null +++ b/asm/include/lcq/asm/library.h @@ -0,0 +1,8 @@ +#ifndef LCOLONQ_ASM_LIBRARY_H +#define LCOLONQ_ASM_LIBRARY_H + +#include + +void asm_install_library_elf(pit_runtime *rt); + +#endif diff --git a/asm/lisp/test.pit b/asm/lisp/test.pit new file mode 100644 index 0000000..cafa8f4 --- /dev/null +++ b/asm/lisp/test.pit @@ -0,0 +1,29 @@ +(let ( (elf (elf/new!)) + (entrypoint 0x696000) + (toff 0x1000) + (phdroff 0x2000)) + (elf/write-bytes! elf toff + '( 0xb8 0x3c 0x00 0x00 0x00 ;; mov rax, 60 + 0xbf 0x2a 0x00 0x00 0x00 ;; mov rdi, 42 + 0x0f 0x05 ;; syscall + )) + (elf/write-program-header! elf (+ phdroff elf/64_PROGRAM_HEADER_SIZE) + :type elf/PROGRAM_HEADER_TYPE_LOAD + :offset toff + :virtual-addr entrypoint + :file-size 0x100 + :mem-size 0x100 + :flags (bitwise/or elf/PROGRAM_HEADER_FLAG_R elf/PROGRAM_HEADER_FLAG_X) + ) + (elf/write-header! elf + :type elf/TYPE_EXEC + :machine elf/MACHINE_AMD64 + :program-header-offset phdroff + :program-header-entry-size elf/64_PROGRAM_HEADER_SIZE + :program-header-entries 2 + :section-header-offset 0 + :section-header-entry-size elf/64_SECTION_HEADER_SIZE + :section-header-entries 0 + :entry entrypoint + ) + (elf/spit! "test.elf" elf)) diff --git a/asm/lisp/x86.pit b/asm/lisp/x86.pit new file mode 100644 index 0000000..b06a9c2 --- /dev/null +++ b/asm/lisp/x86.pit @@ -0,0 +1,490 @@ +(defun! x86/split16le (w) + "Split the 16-bit W16 into a little-endian list of 8-bit integers." + (list + (bitwise/and 0xff w) + (bitwise/and 0xff (bitwise/rshift w 8)))) + +(defun! x86/split32le (w) + "Split the 32-bit W32 into a little-endian list of 8-bit integers." + (list + (bitwise/and 0xff w) + (bitwise/and 0xff (bitwise/rshift w 8)) + (bitwise/and 0xff (bitwise/rshift w 16)) + (bitwise/and 0xff (bitwise/rshift w 24)))) + +(defun! x86/register-1byte? (r) + "Return the register index for 1-byte register R." + (case r + (al 0) (cl 1) (dl 2) (bl 3) + (ah 4) (ch 5) (dh 6) (bh 7) + (r8b 8) (r9b 9) (r10b 10) (r11b 11) + (r12b 12) (r13b 13) (r14b 14) (r15b 15))) + +(defun! x86/register-2byte? (r) + "Return the register index for 2-byte register R." + (case r + (ax 0) (cx 1) (dx 2) (bx 3) + (sp 4) (bp 5) (si 6) (di 7) + (r8w 8) (r9w 9) (r10w 10) (r11w 11) + (r12w 12) (r13w 13) (r14w 14) (r15w 15))) + +(defun! x86/register-4byte? (r) + "Return the register index for 4-byte register R." + (case r + (eax 0) (ecx 1) (edx 2) (ebx 3) + (esp 4) (ebp 5) (esi 6) (edi 7) + (r8d 8) (r9d 9) (r10d 10) (r11d 11) + (r12d 12) (r13d 13) (r14d 14) (r15d 15))) + +(defun! x86/register-8byte? (r) + "Return the register index for 8-byte register R." + (case r + (rax 0) (rcx 1) (rdx 2) (rbx 3) + (rsp 4) (rbp 5) (rsi 6) (rdi 7) + (r8 8) (r9 9) (r10 10) (r11 11) + (r12 12) (r13 13) (r14 14) (r15 15))) + +(defun! x86/register? (r) + "Return the register index of R." + (or + (x86/register-1byte? r) + (x86/register-2byte? r) + (x86/register-4byte? r) + (x86/register-8byte? r))) + +(defun! x86/register-extended? (r) + "Return non-nil if R is an extended register." + (list/contains? r + '( r8b r9b r10b r11b r12b r13b r14b r15b + r8w r9w r10w r11w r12w r13w r14w r15w + r8d r9d r10d r11d r12d r13d r14d r15d + r8 r9 r10 r11 r12 r13 r14 r15))) + +(defun! x86/integer-fits-in-bits? (bits x) + "Determine if X fits in BITS." + (if (integer? x) + (let ((leftover (bitwise/rshift x bits))) + (eq? leftover 0)))) +(defun! x86/operand-immediate-fits? (sz x) + "Determine if immediate operand X fits in SZ." + (let + ((bits + (or + (case sz + ("b" 8) ("c" 16) ("d" 32) ("i" 16) + ("j" 32) ("q" 64) ("v" 64) ("w" 16) + ("y" 64) ("z" 32)) + (error! "unknown operand pattern size")))) + (x86/integer-fits-in-bits? bits x))) + +(defun! x86/operand-register-fits? (sz r) + "Determine if register operand R fits in SZ." + (case sz + ("b" (x86/register-1byte? r)) + ("c" (or (x86/register-1byte? r) (x86/register-2byte? r))) + ("d" (x86/register-4byte? r)) + ("i" (x86/register-2byte? r)) + ("j" (x86/register-4byte? r)) + ("q" (x86/register-8byte? r)) + ("v" (or (x86/register-2byte? r) (x86/register-4byte? r) (x86/register-8byte? r))) + ("w" (x86/register-2byte? r)) + ("y" (or (x86/register-4byte? r) (x86/register-8byte? r))) + ("z" (or (x86/register-2byte? r) (x86/register-4byte? r))))) + +(defun! x86/memory-operand-base (m) + (and + (eq? (car m) 'mem) + (car (cdr m)))) +(defun! x86/memory-operand-off (m) + (and + (eq? (car m) 'mem) + (or (car (cdr (cdr m))) 0))) + +(defun! x86/operand-memory-location? (op) + "Return non-nil if OP represents a memory location." + (let ( (base (x86/memory-operand-base op)) + (off (x86/memory-operand-off op))) + (and + (or (x86/register-4byte? base) (x86/register-8byte? base)) + (integer? off)))) + +(defun! x86/operand-match? (pat op) + "Determine if operand OP matches PAT." + (cond + ((symbol? pat) (eq? pat op)) + ((cons? pat) (list/contains? op pat)) + ((bytes? pat) + (let ( (loc (bytes/range 0 1 pat)) + (sz (bytes/range 1 (bytes/len pat) pat))) + (cond + ((or (equal? loc "I") (equal? loc "J")) (x86/operand-immediate-fits? sz op)) + ((or (equal? loc "G") (equal? loc "R")) (x86/operand-register-fits? sz op)) + ((equal? loc "M") (x86/operand-memory-location? op)) + ((equal? loc "E") + (or (x86/operand-register-fits? sz op) (x86/operand-memory-location? op))) + (t (error! "unknown operand pattern location"))))))) + +(defun! x86/operand-size (op) + "Return the minimum power-of-2 size in bytes that contains OP." + (cond + ((symbol? op) + (cond + ((x86/register-1byte? op) 1) + ((x86/register-2byte? op) 2) + ((x86/register-4byte? op) 4) + ((x86/register-8byte? op) 8) + (t (error! "attempted to take size of unknown register")))) + ((integer? op) + (cond + ((x86/integer-fits-in-bits? 8 op) 1) + ((x86/integer-fits-in-bits? 16 op) 2) + ((x86/integer-fits-in-bits? 32 op) 4) + ((x86/integer-fits-in-bits? 64 op) 8) + (t (error! "attempted to take size of too-large immediate")))) + ((x86/operand-memory-location? op) 1) + (t (error! "attempted to take size of unknown operand")))) + +(defstruct! x86/ins + operand-size-prefix + address-size-prefix + rex-w + rex-r + rex-x + rex-b + opcode + modrm-mod + modrm-reg + modrm-rm + disp ;; pair of size and value + imm ;; pair of size and value + ) + +(defun! x86/ins-bytes (ins) + "Return a list of bytes encoding INS." + (let ( (opcode (x86/ins/get-opcode ins)) + (rex-w (x86/ins/get-rex-w ins)) + (rex-r (x86/ins/get-rex-r ins)) + (rex-x (x86/ins/get-rex-x ins)) + (rex-b (x86/ins/get-rex-b ins)) + (modrm-mod (x86/ins/get-modrm-mod ins)) + (modrm-reg (x86/ins/get-modrm-reg ins)) + (modrm-rm (x86/ins/get-modrm-rm ins)) + (disp (x86/ins/get-disp ins)) + (imm (x86/ins/get-imm ins))) + (list/append + (if (x86/ins/get-operand-size-prefix ins) '(0x66)) + (if (x86/ins/get-address-size-prefix ins) '(0x67)) + (if (or rex-w rex-r rex-x rex-b) + (list + (bitwise/or + 0x40 + (if rex-w 0b1000 0) + (if rex-r 0b0100 0) + (if rex-x 0b0010 0) + (if rex-b 0b0001 0)))) + (cond + ((not opcode) (error! "no opcode for instruction")) + ((cons? opcode) opcode) + ((integer? opcode) (list opcode)) + (t (error! "malformed opcode for instruction"))) + (if (or modrm-mod modrm-reg modrm-rm) + (list + (bitwise/or + (bitwise/lshift (or modrm-mod 0) 6) + (bitwise/lshift (or modrm-reg 0) 3) + (or modrm-rm 0)))) + (if disp + (cond + ((eq? (car disp) 1) (list (cdr disp))) + ((eq? (car disp) 4) (x86/split32le (cdr disp))) + (t (error! "malformed displacement for instruction")))) + (if imm + (cond + ((eq? (car imm) 1) (list (cdr imm))) + ((eq? (car imm) 2) (x86/split16le (cdr imm))) + ((eq? (car imm) 4) (x86/split32le (cdr imm))) + (t (error! "malformed immediate for instruction"))))))) + +(defun! x86/instruction-update-sizes (ins ops default-size) + "Update INS to account for the sizes of OPS. +DEFAULT-SIZE is the default operand size." + (let ((defsz (or default-size 4))) + (if (> (list/len ops) 0) + (let ((regs (list/uniq (list/map 'x86/operand-size (list/filter 'x86/register? ops))))) + (if (> (list/len regs) 1) + (error! "invalid mix of register sizes in operands")) + (let ((sz (if (eq? (list/len regs) 0) defsz (car regs)))) + (cond + ((eq? sz 1) nil) + ((eq? defsz sz) nil) + ((and (not (eq? defsz 2)) (eq? sz 2)) (x86/ins/set-operand-size-prefix! ins t)) + ((and (not (eq? defsz 8)) (eq? sz 8)) (x86/ins/set-rex-w! ins t)) + (t (error! "unable to encode operands with default size"))) + sz))))) + +(defun! x86/instruction-update-operand (esz ins pat op) + "Update INS to account for an operand OP according to PAT. +The effective operand size is ESZ." + (cond + ((bytes? pat) + (let ((loc (bytes/range 0 1 pat))) + (cond + ((equal? loc "I") + (let ((immsz (if (>= esz 4) 4 esz))) + (if (not (x86/integer-fits-in-bits? (* 8 immsz) op)) + (error! "Immediate too large" op)) + (x86/ins/set-imm! ins (cons immsz op)))) + ((equal? loc "J") + (let ((immsz (if (eq? esz 1) 1 4))) + (if (not (x86/integer-fits-in-bits? (* 8 immsz) op)) + (error! "jump displacement too large")) + (x86/ins/set-disp! ins (cons immsz op)))) + ((equal? loc "G") + (x86/ins/set-modrm-reg! ins + (or (x86/register? op) (error "Invalid register: %s" op)))) + ((or (equal? loc "R") (and (equal? loc "E") (x86/register? op))) + (x86/ins/set-modrm-mod! ins 0b11) + (x86/ins/set-modrm-rm! ins + (or (x86/register? op) (error "Invalid register: %s" op)))) + ((or (equal? loc "M") (and (equal? loc "E") (x86/operand-memory-location? op))) + (let ( (base (x86/memory-operand-base op)) + (off (x86/memory-operand-off op))) + (cond + ((eq? base 'eip) + (x86/ins/set-modrm-rm! ins 0b101) + (x86/ins/set-modrm-mod! ins 0b00) + (x86/ins/set-disp! ins (cons 4 off)) + (x86/ins/set-address-size-prefix! ins t)) + ((eq? base 'rip) + (x86/ins/set-modrm-rm! ins 0b101) + (x86/ins/set-modrm-mod! ins 0b00) + (x86/ins/set-disp! ins (cons 4 off))) + (t + (x86/ins/set-modrm-rm! ins + (or + (x86/register-4byte? base) + (x86/register-8byte? base) + (error! "invalid base register"))) + (if (x86/register-4byte? base) + (x86/ins/set-address-size-prefix! ins t)) + (cond + ((x86/integer-fits-in-bits? 8 off) + (x86/ins/set-disp! ins (cons 1 off)) + (x86/ins/set-modrm-mod! ins 0b01)) + ((x86/integer-fits-in-bits? 32 off) + (x86/ins/set-disp! ins (cons 4 off)) + (x86/ins/set-modrm-mod! ins 0b10)) + (t (error! "invalid offset"))))))) + (t (error! "invalid operand location code"))))))) + +(defun! x86/default-instruction-handler (opcode & kwargs) + "Return an instruction handler for OPCODE. +The instruction handler will run POSTHOOK on the instruction at the end. +DEFAULT-SIZE is the default operand size." + (let ( (posthook (plist/get :posthook kwargs)) + (default-size (plist/get :default-size kwargs))) + (lambda (pats ops) + (let ((ret (x86/ins/new :opcode opcode))) + (let ((esz + (or (x86/instruction-update-sizes ret ops default-size) + (error! "malformed size for operands")))) + (list/zip-with + (lambda (it other) + (x86/instruction-update-operand esz ret it other)) + pats + ops)) + (if posthook + (funcall posthook ret ops)) + ret)))) + +(defun! x86/instruction-handler-jcc (opcode immsz) + "Return an instruction handler for a Jcc instruction at OPCODE. +IMMSZ is the size of the displacement from RIP." + (lambda (_pats ops) + (let ((ret (x86/ins/new :opcode opcode))) + (x86/ins/set-disp! ret (cons immsz (car ops))) + ret))) + +(defun! x86/generate-handlers-arith (opbase group1reg) + "Return handlers for an arithmetic mnemonic starting at OPBASE. +The REG value in ModR/M is indicated by GROUP1REG." + (list + (cons '("Eb" "Gb") (x86/default-instruction-handler (+ opbase 0))) + (cons '("Ev" "Gv") (x86/default-instruction-handler (+ opbase 1))) + (cons '("Gb" "Eb") (x86/default-instruction-handler (+ opbase 2))) + (cons '("Gv" "Ev") (x86/default-instruction-handler (+ opbase 3))) + (cons '(al "Ib") (x86/default-instruction-handler (+ opbase 4))) + (cons '((ax eax rax) "Iz") (x86/default-instruction-handler (+ opbase 5))) + (cons '("Eb" "Ib") + (x86/default-instruction-handler 0x80 + :posthook (lambda (ins _) (x86/ins/set-modrm-reg! ins group1reg)))) + (cons '("Ev" "Iz") + (x86/default-instruction-handler 0x81 + :posthook (lambda (ins _) (x86/ins/set-modrm-reg! ins group1reg)))) + (cons '("Ev" "Ib") + (x86/default-instruction-handler 0x83 + :posthook (lambda (ins _) (setf (x86/ins-modrm-reg ins) group1reg)))))) + +(setq! x86/registers-+reg-base + '( (+rb . (al cl dl bl ah ch dh bh)) + (+rw . (ax cx dx bx sp bp si di)) + (+rd . (eax ecx edx ebx esp ebp esi edi)) + (+rq . (rax rcx rdx rbx rsp rbp rsi rdi)))) +(setq! x86/registers-+reg-extended + '( (+rw . (r8b r9b r10b r11b r12b r13b r14b r15b)) + (+rw . (r8w r9w r10w r11w r12w r13w r14w r15w)) + (+rd . (r8d r9d r10d r11d r12d r13d r14d r15d)) + (+rq . (r8 r9 r10 r11 r12 r13 r14 r15)))) +(defun! x86/generate-handlers-opcode-+reg (opbase extraops addends & args) + "Generate handlers for a family of opcodes that uses the +reg encoding. +OPBASE is the base opcode. +EXTRAOPS are additional operands after the register operand. +ADDENDS is a list of symbols like +rw, +rq etc. that denote allowed registers. +ARGS are passed verbatim to `u/x86/default-instruction-handler." + (list/map + (lambda (it) + (let ( (abase (list/map (lambda (a) (list/nth it (alist/get a x86/registers-+reg-base))) addends)) + (aext (list/map (lambda (a) (list/nth it (alist/get a x86/registers-+reg-extended))) addends))) + (cons + (cons (list/append abase aext) extraops) + (apply 'x86/default-instruction-handler (cons (+ opbase it) args))))) + (list/iota 8))) + +(setq! + x86/mnemonic-table + (list + (cons 'add (x86/generate-handlers-arith 0x00 0)) + (cons 'or (x86/generate-handlers-arith 0x08 1)) + (cons 'adc (x86/generate-handlers-arith 0x10 2)) + (cons 'sbb (x86/generate-handlers-arith 0x18 3)) + (cons 'and (x86/generate-handlers-arith 0x20 4)) + (cons 'sub (x86/generate-handlers-arith 0x28 5)) + (cons 'xor (x86/generate-handlers-arith 0x30 6)) + (cons 'cmp (x86/generate-handlers-arith 0x38 7)) + (cons 'push + (x86/generate-handlers-opcode-+reg 0x50 '() '(+rw +rq) + :default-size 8 + :posthook (lambda (ins ops) (x86/ins/set-rex-b! ins (x86/register-extended? (car ops)))))) + (cons 'pop + (x86/generate-handlers-opcode-+reg 0x58 '() '(+rw +rq) + :default-size 8 + :posthook (lambda (ins ops) (x86/ins/set-rex-b! ins (x86/register-extended? (car ops)))))) + (list 'jo + (cons '("Jb") (x86/instruction-handler-jcc 0x70 1)) + (cons '("Jz") (x86/instruction-handler-jcc '(0x0f 0x80) 4))) + (list 'jno + (cons '("Jb") (x86/instruction-handler-jcc 0x71 1)) + (cons '("Jz") (x86/instruction-handler-jcc '(0x0f 0x81) 4))) + (list 'jb + (cons '("Jb") (x86/instruction-handler-jcc 0x72 1)) + (cons '("Jz") (x86/instruction-handler-jcc '(0x0f 0x82) 4))) + (list 'jnb + (cons '("Jb") (x86/instruction-handler-jcc 0x73 1)) + (cons '("Jz") (x86/instruction-handler-jcc '(0x0f 0x83) 4))) + (list 'jz + (cons '("Jb") (x86/instruction-handler-jcc 0x74 1)) + (cons '("Jz") (x86/instruction-handler-jcc '(0x0f 0x84) 4))) + (list 'jnz + (cons '("Jb") (x86/instruction-handler-jcc 0x75 1)) + (cons '("Jz") (x86/instruction-handler-jcc '(0x0f 0x85) 4))) + (list 'jbe + (cons '("Jb") (x86/instruction-handler-jcc 0x76 1)) + (cons '("Jz") (x86/instruction-handler-jcc '(0x0f 0x86) 4))) + (list 'jnbe + (cons '("Jb") (x86/instruction-handler-jcc 0x77 1)) + (cons '("Jz") (x86/instruction-handler-jcc '(0x0f 0x87) 4))) + (list 'js + (cons '("Jb") (x86/instruction-handler-jcc 0x78 1)) + (cons '("Jz") (x86/instruction-handler-jcc '(0x0f 0x88) 4))) + (list 'jns + (cons '("Jb") (x86/instruction-handler-jcc 0x79 1)) + (cons '("Jz") (x86/instruction-handler-jcc '(0x0f 0x89) 4))) + (list 'jp + (cons '("Jb") (x86/instruction-handler-jcc 0x7a 1)) + (cons '("Jz") (x86/instruction-handler-jcc '(0x0f 0x8a) 4))) + (list 'jnp + (cons '("Jb") (x86/instruction-handler-jcc 0x7b 1)) + (cons '("Jz") (x86/instruction-handler-jcc '(0x0f 0x8b) 4))) + (list 'jl + (cons '("Jb") (x86/instruction-handler-jcc 0x7c 1)) + (cons '("Jz") (x86/instruction-handler-jcc '(0x0f 0x8c) 4))) + (list 'jnl + (cons '("Jb") (x86/instruction-handler-jcc 0x7d 1)) + (cons '("Jz") (x86/instruction-handler-jcc '(0x0f 0x8d) 4))) + (list 'jle + (cons '("Jb") (x86/instruction-handler-jcc 0x7e 1)) + (cons '("Jz") (x86/instruction-handler-jcc '(0x0f 0x8e) 4))) + (list 'jnle + (cons '("Jb") (x86/instruction-handler-jcc 0x7f 1)) + (cons '("Jz") (x86/instruction-handler-jcc '(0x0f 0x8f) 4))) + (cons 'mov + (list/append + (x86/generate-handlers-opcode-+reg 0xb0 '("Ib") '(+rb) + :posthook (lambda (ins ops) (x86/ins/set-rex-b! ins (x86/register-extended? (car ops))))) + (x86/generate-handlers-opcode-+reg 0xb8 '("Iv") '(+rw +rd +rq) + :posthook (lambda (ins ops) (x86/ins/set-rex-b! ins (x86/register-extended? (car ops))))))) + (list 'jmp + (cons '("Ev") + (x86/default-instruction-handler 0xff + :default-size 8 + :posthook (lambda (ins _) (setf (u/x86/ins-modrm-reg ins) 4))))) + (list 'syscall + (cons '() (lambda (_ _) (x86/ins/new :opcode '(0x0f 0x05))))) + )) + +(defun! x86/asm (op) + "Assemble OP to an instruction." + (let ((mnem (car op)) (operands (cdr op))) + (let ((variants (or (alist/get mnem x86/mnemonic-table) (error! "unknown mnemonic")))) + (let ((v + (list/find + (lambda (it) + (and (eq? (list/len (car it)) (list/len operands)) + (list/all? (lambda (x) x) (list/zip-with 'x86/operand-match? (car it) operands)))) + variants))) + (if (and v (function? (cdr v))) + (funcall (cdr v) (car v) operands) + (error! "could not identify instruction")))))) + +(defun! x86/assemble (elf addr inss) + (print! inss) + (if inss + (let ((ins (x86/asm (car inss)))) + (let ((bs (x86/ins-bytes ins))) + (elf/write-bytes! elf addr bs) + (x86/assemble elf (+ addr (list/len bs)) (cdr inss)))) + addr)) + +(let ( (elf (elf/new!)) + (entrypoint 0x696000) + (toff 0x1000) + (phdroff 0x2000)) + ;; (elf/write-bytes! elf toff + ;; '( 0xb8 0x3c 0x00 0x00 0x00 ;; mov rax, 60 + ;; 0xbf 0x2a 0x00 0x00 0x00 ;; mov rdi, 42 + ;; 0x0f 0x05 ;; syscall + ;; )) + (x86/assemble elf toff + '( (mov eax 60) + (mov edi 42) + (syscall))) + (elf/write-program-header! elf (+ phdroff elf/64_PROGRAM_HEADER_SIZE) + :type elf/PROGRAM_HEADER_TYPE_LOAD + :offset toff + :virtual-addr entrypoint + :file-size 0x100 + :mem-size 0x100 + :flags (bitwise/or elf/PROGRAM_HEADER_FLAG_R elf/PROGRAM_HEADER_FLAG_X) + ) + (elf/write-header! elf + :type elf/TYPE_EXEC + :machine elf/MACHINE_AMD64 + :program-header-offset phdroff + :program-header-entry-size elf/64_PROGRAM_HEADER_SIZE + :program-header-entries 2 + :section-header-offset 0 + :section-header-entry-size elf/64_SECTION_HEADER_SIZE + :section-header-entries 0 + :entry entrypoint + ) + (elf/spit! "test.elf" elf)) diff --git a/asm/packages.nix b/asm/packages.nix new file mode 100644 index 0000000..75154ae --- /dev/null +++ b/asm/packages.nix @@ -0,0 +1,16 @@ +pkgs: lcq: { + native = pkgs.pkgsMusl.stdenv.mkDerivation { + pname = "libcolonq-asm"; + version = "git"; + src = ./.; + hardeningDisable = ["all"]; + buildInputs = [ + lcq.prelude.native + lcq.pit.native + lcq.elf.native + ]; + installPhase = '' + make prefix=$out install + ''; + }; +} diff --git a/asm/src/library.c b/asm/src/library.c new file mode 100644 index 0000000..c1342f9 --- /dev/null +++ b/asm/src/library.c @@ -0,0 +1,302 @@ +#include +#include +#include + +#include +#include + +#include + +struct elf_builder { + i64 cap; + elf_ctx ctx; +}; + +static void builder_ensure_size(struct elf_builder *e, i64 sz) { + i64 cur = e->ctx.len; + i64 cap = e->cap; + if (sz <= cur) return; + while (cap < sz) cap <<= 1; + e->ctx.buf = realloc(e->ctx.buf, (size_t) cap); + memset(e->ctx.buf + e->cap, 0, (size_t) (cap - e->cap)); + e->ctx.len = sz; + e->cap = cap; +} + +static i64 get_kwargs_i64(pit_runtime *rt, i64 def, pit_value kwargs, char *kw) { + pit_value v = pit_value_list_plist_get(rt, pit_symtab_intern_cstr(rt, kw), kwargs); + if (v != PIT_NIL && pit_value_is_integer(rt, v)) { + return pit_value_as_integer(rt, v); + } else { + return def; + } +} +static pit_value impl_elf_new(pit_runtime *rt, pit_value kwargs, void *data) { + (void) data; + i64 vclass = get_kwargs_i64(rt, ELF_CLASS_64, kwargs, ":class"); + i64 vendianness = get_kwargs_i64(rt, ELF_ENDIANNESS_LITTLE, kwargs, ":endianness"); + struct elf_builder *ret = malloc(sizeof(struct elf_builder)); + i64 len = 256; + u8 *buf = calloc((size_t) len, 1); + ret->cap = len; + ret->ctx = elf_ctx_new(buf, len, vclass, vendianness); + return pit_value_nativedata_new(rt, pit_symtab_intern_cstr(rt, "elf"), (void *) ret); +} +static pit_value impl_elf_write_header(pit_runtime *rt, pit_value args, void *data) { + (void) data; + pit_value velf = pit_value_cons_car(rt, args); + pit_value kwargs = pit_value_cons_cdr(rt, args); + struct elf_builder *e = pit_value_nativedata_get(rt, pit_symtab_intern_cstr(rt, "elf"), velf); + elf_header h = {0}; + if (!e) return PIT_NIL; + builder_ensure_size(e, elf_header_size(&e->ctx)); + h.type = get_kwargs_i64(rt, ELF_TYPE_EXEC, kwargs, ":type"); + h.machine = get_kwargs_i64(rt, ELF_MACHINE_AMD64, kwargs, ":machine"); + h.version = (u32) get_kwargs_i64(rt, 1, kwargs, ":version"); + h.entry = (u64) get_kwargs_i64(rt, 0x401000, kwargs, ":entry"); + h.program_header_offset = (u64) get_kwargs_i64(rt, 0, kwargs, ":program-header-offset"); + h.program_header_entry_size = (u16) get_kwargs_i64(rt, elf_program_header_size(&e->ctx), kwargs, ":program-header-entry-size"); + h.program_header_entries = (u16) get_kwargs_i64(rt, 1, kwargs, ":program-header-entries"); + h.section_header_offset = (u64) get_kwargs_i64(rt, 0, kwargs, ":section-header-offset"); + h.section_header_entry_size = (u16) get_kwargs_i64(rt, elf_section_header_size(&e->ctx), kwargs, ":section-header-entry-size"); + h.section_header_entries = (u16) get_kwargs_i64(rt, 0, kwargs, ":section-header-entries"); + h.section_name_table_index = (u16) get_kwargs_i64(rt, 1, kwargs, ":section-name-table-index"); + elf_write_header(&h, &e->ctx); + return PIT_NIL; +} +static pit_value impl_elf_write_section_header(pit_runtime *rt, pit_value args, void *data) { + (void) data; + pit_value velf = pit_value_cons_car(rt, args); + pit_value voff = pit_value_cons_car(rt, pit_value_cons_cdr(rt, args)); + i64 off = pit_value_as_integer(rt, voff); + pit_value kwargs = pit_value_cons_cdr(rt, pit_value_cons_cdr(rt, args)); + struct elf_builder *e = pit_value_nativedata_get(rt, pit_symtab_intern_cstr(rt, "elf"), velf); + elf_section_header h = {0}; + if (!e) return PIT_NIL; + if (off < 0) { pit_error(rt, "negative offset: %d", off); return PIT_NIL; } + builder_ensure_size(e, off + elf_header_size(&e->ctx)); + h.name_index = (u32) get_kwargs_i64(rt, 0, kwargs, ":name-index"); + h.type = (u32) get_kwargs_i64(rt, ELF_SECTION_TYPE_NULL, kwargs, ":type"); + h.flags = (u64) get_kwargs_i64(rt, 0, kwargs, ":flags"); + h.addr = (u64) get_kwargs_i64(rt, 0, kwargs, ":addr"); + h.offset = (u64) get_kwargs_i64(rt, 0, kwargs, ":offset"); + h.size = (u64) get_kwargs_i64(rt, 0, kwargs, ":size"); + h.link = (u32) get_kwargs_i64(rt, 0, kwargs, ":link"); + h.info = (u32) get_kwargs_i64(rt, 0, kwargs, ":info"); + h.addr_alignment = (u64) get_kwargs_i64(rt, 0, kwargs, ":addr-alignment"); + h.entry_size = (u64) get_kwargs_i64(rt, 0, kwargs, ":entry-size"); + elf_write_section_header(&h, &e->ctx, (u64) off); + return PIT_NIL; +} +static pit_value impl_elf_write_symbol(pit_runtime *rt, pit_value args, void *data) { + (void) data; + pit_value velf = pit_value_cons_car(rt, args); + pit_value voff = pit_value_cons_car(rt, pit_value_cons_cdr(rt, args)); + i64 off = pit_value_as_integer(rt, voff); + pit_value kwargs = pit_value_cons_cdr(rt, pit_value_cons_cdr(rt, args)); + elf_symbol h = {0}; + struct elf_builder *e = pit_value_nativedata_get(rt, pit_symtab_intern_cstr(rt, "elf"), velf); + if (!e) return PIT_NIL; + if (off < 0) { pit_error(rt, "negative offset: %d", off); return PIT_NIL; } + builder_ensure_size(e, off + elf_symbol_size(&e->ctx)); + h.size = (u64) get_kwargs_i64(rt, 0, kwargs, ":size"); + h.value = (u64) get_kwargs_i64(rt, 0, kwargs, ":value"); + h.name_index = (u32) get_kwargs_i64(rt, 0, kwargs, ":name_index"); + h.bind = get_kwargs_i64(rt, ELF_SYMBOL_BINDING_LOCAL, kwargs, ":bind"); + h.type = get_kwargs_i64(rt, ELF_SYMBOL_TYPE_NOTYPE, kwargs, ":type"); + h.visibility = get_kwargs_i64(rt, ELF_SYMBOL_VISIBILITY_DEFAULT, kwargs, ":visibility"); + h.section_header_index = (u16) get_kwargs_i64(rt, 0, kwargs, ":section-header-index"); + elf_write_symbol(&h, &e->ctx, (u64) off); + return PIT_NIL; +} +static pit_value impl_elf_write_program_header(pit_runtime *rt, pit_value args, void *data) { + (void) data; + pit_value velf = pit_value_cons_car(rt, args); + pit_value voff = pit_value_cons_car(rt, pit_value_cons_cdr(rt, args)); + i64 off = pit_value_as_integer(rt, voff); + pit_value kwargs = pit_value_cons_cdr(rt, pit_value_cons_cdr(rt, args)); + elf_program_header h = {0}; + struct elf_builder *e = pit_value_nativedata_get(rt, pit_symtab_intern_cstr(rt, "elf"), velf); + if (!e) return PIT_NIL; + if (off < 0) { pit_error(rt, "negative offset: %d", off); return PIT_NIL; } + builder_ensure_size(e, off + elf_program_header_size(&e->ctx)); + h.type = (u32) get_kwargs_i64(rt, ELF_PROGRAM_HEADER_TYPE_NULL, kwargs, ":type"); + h.offset = (u64) get_kwargs_i64(rt, 0, kwargs, ":offset"); + h.virtual_addr = (u64) get_kwargs_i64(rt, 0, kwargs, ":virtual-addr"); + h.physical_addr = (u64) get_kwargs_i64(rt, 0, kwargs, ":physical-addr"); + h.file_size = (u64) get_kwargs_i64(rt, 0, kwargs, ":file-size"); + h.mem_size = (u64) get_kwargs_i64(rt, 0, kwargs, ":mem-size"); + h.flags = (u32) get_kwargs_i64(rt, 0, kwargs, ":flags"); + h.align = (u64) get_kwargs_i64(rt, 0, kwargs, ":align"); + elf_write_program_header(&h, &e->ctx, (u64) off); + return PIT_NIL; +} +static pit_value impl_elf_write_bytes(pit_runtime *rt, pit_value args, void *data) { + (void) data; + pit_value velf = pit_value_cons_car(rt, args); + pit_value voff = pit_value_cons_car(rt, pit_value_cons_cdr(rt, args)); + pit_value vbytes = pit_value_cons_car(rt, pit_value_cons_cdr(rt, pit_value_cons_cdr(rt, args))); + pit_value_heavy *hbytes = NULL; + i64 off = 0; + struct elf_builder *e = pit_value_nativedata_get(rt, pit_symtab_intern_cstr(rt, "elf"), velf); + if (!e) return PIT_NIL; + if (!pit_value_is_integer(rt, voff)) { + pit_error(rt, "offset is not integer"); + return PIT_NIL; + } + off = pit_value_as_integer(rt, voff); + if (off < 0) { + pit_error(rt, "negative offset"); + return PIT_NIL; + } + if (pit_value_is_bytes(rt, vbytes)) { + if (pit_value_sort(vbytes) != PIT_VALUE_SORT_REF) { + pit_error(rt, "bytes are not a reference"); + return PIT_NIL; + } + hbytes = pit_value_ref_deref(rt, pit_value_as_ref(rt, vbytes)); + if (!hbytes) { pit_error(rt, "bad ref"); return PIT_NIL; } + if (hbytes->hsort != PIT_VALUE_HEAVY_SORT_BYTES) { + pit_error(rt, "invalid use of value as bytes"); + return PIT_NIL; + } + builder_ensure_size(e, off + hbytes->in.bytes.len); + elf_write_bytes(&e->ctx, (u64 *) &off, hbytes->in.bytes.data, hbytes->in.bytes.len); + } else if (pit_value_is_cons(rt, vbytes)) { + while (vbytes != PIT_NIL) { + pit_value x = pit_value_cons_car(rt, vbytes); + i64 v = 0; + u8 byte = 0; + if (!pit_value_is_integer(rt, x)) { + pit_error(rt, "byte is not integer"); + return PIT_NIL; + } + v = pit_value_as_integer(rt, x); + if (v < 0 || v > 255) { + pit_error(rt, "byte out of range"); + return PIT_NIL; + } + byte = (u8) v; + builder_ensure_size(e, off + 1); + if (elf_write_bytes(&e->ctx, (u64 *) &off, (u8 *) &byte, 1) < 0) { + pit_error(rt, "failed to write byte at offset: %ld\n", off); + return PIT_NIL; + } + vbytes = pit_value_cons_cdr(rt, vbytes); + } + } + return PIT_T; +} +static pit_value impl_elf_spit(pit_runtime *rt, pit_value args, void *data) { + (void) data; + char pathbuf[1024] = {0}; + i64 len = 0, actual = 0; + FILE *f = NULL; + struct elf_builder *e = NULL; + pit_value path = pit_value_cons_car(rt, args); + pit_value velf = pit_value_cons_car(rt, pit_value_cons_cdr(rt, args)); + len = pit_value_bytes_copy(rt, path, (u8 *) pathbuf, sizeof(pathbuf) - 1); + if (len < 0) { pit_error(rt, "path was not a string"); return PIT_NIL; } + pathbuf[len] = 0; + e = pit_value_nativedata_get(rt, pit_symtab_intern_cstr(rt, "elf"), velf); + if (!e) return PIT_NIL; + f = fopen(pathbuf, "w+"); + if (!f) { + pit_error(rt, "failed to open file: %s", pathbuf); + return PIT_NIL; + } + actual = (i64) fwrite(e->ctx.buf, 1, (size_t) e->ctx.len, f); + fclose(f); + if (e->ctx.len != actual) { + pit_error(rt, "failed to write ELF file"); + return PIT_NIL; + } + return velf; +} + +void asm_install_library_elf(pit_runtime *rt) { + /* sizes */ + pit_symtab_set(rt, pit_symtab_intern_cstr(rt, "elf/HEADER_IDENT_SIZE"), pit_value_integer_new(rt, ELF_HEADER_IDENT_SIZE)); + pit_symtab_set(rt, pit_symtab_intern_cstr(rt, "elf/32_HEADER_SIZE"), pit_value_integer_new(rt, ELF32_HEADER_SIZE)); + pit_symtab_set(rt, pit_symtab_intern_cstr(rt, "elf/64_HEADER_SIZE"), pit_value_integer_new(rt, ELF64_HEADER_SIZE)); + pit_symtab_set(rt, pit_symtab_intern_cstr(rt, "elf/32_SECTION_HEADER_SIZE"), pit_value_integer_new(rt, ELF32_SECTION_HEADER_SIZE)); + pit_symtab_set(rt, pit_symtab_intern_cstr(rt, "elf/64_SECTION_HEADER_SIZE"), pit_value_integer_new(rt, ELF64_SECTION_HEADER_SIZE)); + pit_symtab_set(rt, pit_symtab_intern_cstr(rt, "elf/32_PROGRAM_HEADER_SIZE"), pit_value_integer_new(rt, ELF32_PROGRAM_HEADER_SIZE)); + pit_symtab_set(rt, pit_symtab_intern_cstr(rt, "elf/64_PROGRAM_HEADER_SIZE"), pit_value_integer_new(rt, ELF64_PROGRAM_HEADER_SIZE)); + /* enums */ + pit_symtab_set(rt, pit_symtab_intern_cstr(rt, "elf/CLASS_INVALID"), pit_value_integer_new(rt, ELF_CLASS_INVALID)); + pit_symtab_set(rt, pit_symtab_intern_cstr(rt, "elf/CLASS_32"), pit_value_integer_new(rt, ELF_CLASS_32)); + pit_symtab_set(rt, pit_symtab_intern_cstr(rt, "elf/CLASS_64"), pit_value_integer_new(rt, ELF_CLASS_64)); + pit_symtab_set(rt, pit_symtab_intern_cstr(rt, "elf/ENDIANNESS_INVALID"), pit_value_integer_new(rt, ELF_ENDIANNESS_INVALID)); + pit_symtab_set(rt, pit_symtab_intern_cstr(rt, "elf/ENDIANNESS_LITTLE"), pit_value_integer_new(rt, ELF_ENDIANNESS_LITTLE)); + pit_symtab_set(rt, pit_symtab_intern_cstr(rt, "elf/ENDIANNESS_BIG"), pit_value_integer_new(rt, ELF_ENDIANNESS_BIG)); + pit_symtab_set(rt, pit_symtab_intern_cstr(rt, "elf/TYPE_NONE"), pit_value_integer_new(rt, ELF_TYPE_NONE)); + pit_symtab_set(rt, pit_symtab_intern_cstr(rt, "elf/TYPE_REL"), pit_value_integer_new(rt, ELF_TYPE_REL)); + pit_symtab_set(rt, pit_symtab_intern_cstr(rt, "elf/TYPE_EXEC"), pit_value_integer_new(rt, ELF_TYPE_EXEC)); + pit_symtab_set(rt, pit_symtab_intern_cstr(rt, "elf/TYPE_DYN"), pit_value_integer_new(rt, ELF_TYPE_DYN)); + pit_symtab_set(rt, pit_symtab_intern_cstr(rt, "elf/TYPE_CORE"), pit_value_integer_new(rt, ELF_TYPE_CORE)); + pit_symtab_set(rt, pit_symtab_intern_cstr(rt, "elf/MACHINE_NONE"), pit_value_integer_new(rt, ELF_MACHINE_NONE)); + pit_symtab_set(rt, pit_symtab_intern_cstr(rt, "elf/MACHINE_X86"), pit_value_integer_new(rt, ELF_MACHINE_X86)); + pit_symtab_set(rt, pit_symtab_intern_cstr(rt, "elf/MACHINE_AMD64"), pit_value_integer_new(rt, ELF_MACHINE_AMD64)); + pit_symtab_set(rt, pit_symtab_intern_cstr(rt, "elf/SECTION_TYPE_NULL"), pit_value_integer_new(rt, ELF_SECTION_TYPE_NULL)); + pit_symtab_set(rt, pit_symtab_intern_cstr(rt, "elf/SECTION_TYPE_PROGBITS"), pit_value_integer_new(rt, ELF_SECTION_TYPE_PROGBITS)); + pit_symtab_set(rt, pit_symtab_intern_cstr(rt, "elf/SECTION_TYPE_SYMTAB"), pit_value_integer_new(rt, ELF_SECTION_TYPE_SYMTAB)); + pit_symtab_set(rt, pit_symtab_intern_cstr(rt, "elf/SECTION_TYPE_STRTAB"), pit_value_integer_new(rt, ELF_SECTION_TYPE_STRTAB)); + pit_symtab_set(rt, pit_symtab_intern_cstr(rt, "elf/SECTION_TYPE_RELA"), pit_value_integer_new(rt, ELF_SECTION_TYPE_RELA)); + pit_symtab_set(rt, pit_symtab_intern_cstr(rt, "elf/SECTION_TYPE_HASH"), pit_value_integer_new(rt, ELF_SECTION_TYPE_HASH)); + pit_symtab_set(rt, pit_symtab_intern_cstr(rt, "elf/SECTION_TYPE_DYNAMIC"), pit_value_integer_new(rt, ELF_SECTION_TYPE_DYNAMIC)); + pit_symtab_set(rt, pit_symtab_intern_cstr(rt, "elf/SECTION_TYPE_NOTE"), pit_value_integer_new(rt, ELF_SECTION_TYPE_NOTE)); + pit_symtab_set(rt, pit_symtab_intern_cstr(rt, "elf/SECTION_TYPE_NOBITS"), pit_value_integer_new(rt, ELF_SECTION_TYPE_NOBITS)); + pit_symtab_set(rt, pit_symtab_intern_cstr(rt, "elf/SECTION_TYPE_REL"), pit_value_integer_new(rt, ELF_SECTION_TYPE_REL)); + pit_symtab_set(rt, pit_symtab_intern_cstr(rt, "elf/SECTION_TYPE_SHLIB"), pit_value_integer_new(rt, ELF_SECTION_TYPE_SHLIB)); + pit_symtab_set(rt, pit_symtab_intern_cstr(rt, "elf/SECTION_TYPE_DYNSYM"), pit_value_integer_new(rt, ELF_SECTION_TYPE_DYNSYM)); + pit_symtab_set(rt, pit_symtab_intern_cstr(rt, "elf/SECTION_TYPE_INIT_ARRAY"), pit_value_integer_new(rt, ELF_SECTION_TYPE_INIT_ARRAY)); + pit_symtab_set(rt, pit_symtab_intern_cstr(rt, "elf/SECTION_TYPE_FINI_ARRAY"), pit_value_integer_new(rt, ELF_SECTION_TYPE_FINI_ARRAY)); + pit_symtab_set(rt, pit_symtab_intern_cstr(rt, "elf/SECTION_TYPE_PREINIT_ARRAY"), pit_value_integer_new(rt, ELF_SECTION_TYPE_PREINIT_ARRAY)); + pit_symtab_set(rt, pit_symtab_intern_cstr(rt, "elf/SECTION_TYPE_GROUP"), pit_value_integer_new(rt, ELF_SECTION_TYPE_GROUP)); + pit_symtab_set(rt, pit_symtab_intern_cstr(rt, "elf/SECTION_TYPE_SYMTAB_SHNDX"), pit_value_integer_new(rt, ELF_SECTION_TYPE_SYMTAB_SHNDX)); + pit_symtab_set(rt, pit_symtab_intern_cstr(rt, "elf/SECTION_FLAG_WRITE"), pit_value_integer_new(rt, ELF_SECTION_FLAG_WRITE)); + pit_symtab_set(rt, pit_symtab_intern_cstr(rt, "elf/SECTION_FLAG_ALLOC"), pit_value_integer_new(rt, ELF_SECTION_FLAG_ALLOC)); + pit_symtab_set(rt, pit_symtab_intern_cstr(rt, "elf/SECTION_FLAG_EXECINSTR"), pit_value_integer_new(rt, ELF_SECTION_FLAG_EXECINSTR)); + pit_symtab_set(rt, pit_symtab_intern_cstr(rt, "elf/SECTION_FLAG_MERGE"), pit_value_integer_new(rt, ELF_SECTION_FLAG_MERGE)); + pit_symtab_set(rt, pit_symtab_intern_cstr(rt, "elf/SECTION_FLAG_STRINGS"), pit_value_integer_new(rt, ELF_SECTION_FLAG_STRINGS)); + pit_symtab_set(rt, pit_symtab_intern_cstr(rt, "elf/SECTION_FLAG_INFO_LINK"), pit_value_integer_new(rt, ELF_SECTION_FLAG_INFO_LINK)); + pit_symtab_set(rt, pit_symtab_intern_cstr(rt, "elf/SECTION_FLAG_LINK_ORDER"), pit_value_integer_new(rt, ELF_SECTION_FLAG_LINK_ORDER)); + pit_symtab_set(rt, pit_symtab_intern_cstr(rt, "elf/SECTION_FLAG_OS_NONCOMFORMING"), pit_value_integer_new(rt, ELF_SECTION_FLAG_OS_NONCOMFORMING)); + pit_symtab_set(rt, pit_symtab_intern_cstr(rt, "elf/SECTION_FLAG_GROUP"), pit_value_integer_new(rt, ELF_SECTION_FLAG_GROUP)); + pit_symtab_set(rt, pit_symtab_intern_cstr(rt, "elf/SECTION_FLAG_TLS"), pit_value_integer_new(rt, ELF_SECTION_FLAG_TLS)); + pit_symtab_set(rt, pit_symtab_intern_cstr(rt, "elf/SECTION_FLAG_COMPRESSED"), pit_value_integer_new(rt, ELF_SECTION_FLAG_COMPRESSED)); + pit_symtab_set(rt, pit_symtab_intern_cstr(rt, "elf/SYMBOL_BINDING_LOCAL"), pit_value_integer_new(rt, ELF_SYMBOL_BINDING_LOCAL)); + pit_symtab_set(rt, pit_symtab_intern_cstr(rt, "elf/SYMBOL_BINDING_GLOBAL"), pit_value_integer_new(rt, ELF_SYMBOL_BINDING_GLOBAL)); + pit_symtab_set(rt, pit_symtab_intern_cstr(rt, "elf/SYMBOL_BINDING_WEAK"), pit_value_integer_new(rt, ELF_SYMBOL_BINDING_WEAK)); + pit_symtab_set(rt, pit_symtab_intern_cstr(rt, "elf/SYMBOL_TYPE_NOTYPE"), pit_value_integer_new(rt, ELF_SYMBOL_TYPE_NOTYPE)); + pit_symtab_set(rt, pit_symtab_intern_cstr(rt, "elf/SYMBOL_TYPE_OBJECT"), pit_value_integer_new(rt, ELF_SYMBOL_TYPE_OBJECT)); + pit_symtab_set(rt, pit_symtab_intern_cstr(rt, "elf/SYMBOL_TYPE_FUNC"), pit_value_integer_new(rt, ELF_SYMBOL_TYPE_FUNC)); + pit_symtab_set(rt, pit_symtab_intern_cstr(rt, "elf/SYMBOL_TYPE_SECTION"), pit_value_integer_new(rt, ELF_SYMBOL_TYPE_SECTION)); + pit_symtab_set(rt, pit_symtab_intern_cstr(rt, "elf/SYMBOL_TYPE_FILE"), pit_value_integer_new(rt, ELF_SYMBOL_TYPE_FILE)); + pit_symtab_set(rt, pit_symtab_intern_cstr(rt, "elf/SYMBOL_TYPE_COMMON"), pit_value_integer_new(rt, ELF_SYMBOL_TYPE_COMMON)); + pit_symtab_set(rt, pit_symtab_intern_cstr(rt, "elf/SYMBOL_TYPE_TLS"), pit_value_integer_new(rt, ELF_SYMBOL_TYPE_TLS)); + pit_symtab_set(rt, pit_symtab_intern_cstr(rt, "elf/SYMBOL_VISIBILITY_DEFAULT"), pit_value_integer_new(rt, ELF_SYMBOL_VISIBILITY_DEFAULT)); + pit_symtab_set(rt, pit_symtab_intern_cstr(rt, "elf/SYMBOL_VISIBILITY_INTERNAL"), pit_value_integer_new(rt, ELF_SYMBOL_VISIBILITY_INTERNAL)); + pit_symtab_set(rt, pit_symtab_intern_cstr(rt, "elf/SYMBOL_VISIBILITY_HIDDEN"), pit_value_integer_new(rt, ELF_SYMBOL_VISIBILITY_HIDDEN)); + pit_symtab_set(rt, pit_symtab_intern_cstr(rt, "elf/SYMBOL_VISIBILITY_PROTECTED"), pit_value_integer_new(rt, ELF_SYMBOL_VISIBILITY_PROTECTED)); + pit_symtab_set(rt, pit_symtab_intern_cstr(rt, "elf/PROGRAM_HEADER_TYPE_NULL"), pit_value_integer_new(rt, ELF_PROGRAM_HEADER_TYPE_NULL)); + pit_symtab_set(rt, pit_symtab_intern_cstr(rt, "elf/PROGRAM_HEADER_TYPE_LOAD"), pit_value_integer_new(rt, ELF_PROGRAM_HEADER_TYPE_LOAD)); + pit_symtab_set(rt, pit_symtab_intern_cstr(rt, "elf/PROGRAM_HEADER_TYPE_DYNAMIC"), pit_value_integer_new(rt, ELF_PROGRAM_HEADER_TYPE_DYNAMIC)); + pit_symtab_set(rt, pit_symtab_intern_cstr(rt, "elf/PROGRAM_HEADER_TYPE_INTERP"), pit_value_integer_new(rt, ELF_PROGRAM_HEADER_TYPE_INTERP)); + pit_symtab_set(rt, pit_symtab_intern_cstr(rt, "elf/PROGRAM_HEADER_TYPE_NOTE"), pit_value_integer_new(rt, ELF_PROGRAM_HEADER_TYPE_NOTE)); + pit_symtab_set(rt, pit_symtab_intern_cstr(rt, "elf/PROGRAM_HEADER_TYPE_SHLIB"), pit_value_integer_new(rt, ELF_PROGRAM_HEADER_TYPE_SHLIB)); + pit_symtab_set(rt, pit_symtab_intern_cstr(rt, "elf/PROGRAM_HEADER_TYPE_PHDR"), pit_value_integer_new(rt, ELF_PROGRAM_HEADER_TYPE_PHDR)); + pit_symtab_set(rt, pit_symtab_intern_cstr(rt, "elf/PROGRAM_HEADER_TYPE_TLS"), pit_value_integer_new(rt, ELF_PROGRAM_HEADER_TYPE_TLS)); + pit_symtab_set(rt, pit_symtab_intern_cstr(rt, "elf/PROGRAM_HEADER_FLAG_X"), pit_value_integer_new(rt, ELF_PROGRAM_HEADER_FLAG_X)); + pit_symtab_set(rt, pit_symtab_intern_cstr(rt, "elf/PROGRAM_HEADER_FLAG_W"), pit_value_integer_new(rt, ELF_PROGRAM_HEADER_FLAG_W)); + pit_symtab_set(rt, pit_symtab_intern_cstr(rt, "elf/PROGRAM_HEADER_FLAG_R"), pit_value_integer_new(rt, ELF_PROGRAM_HEADER_FLAG_R)); + + pit_symtab_fset(rt, pit_symtab_intern_cstr(rt, "elf/new!"), pit_value_nativefunc_new(rt, impl_elf_new)); + pit_symtab_fset(rt, pit_symtab_intern_cstr(rt, "elf/write-header!"), pit_value_nativefunc_new(rt, impl_elf_write_header)); + pit_symtab_fset(rt, pit_symtab_intern_cstr(rt, "elf/write-section-header!"), pit_value_nativefunc_new(rt, impl_elf_write_section_header)); + pit_symtab_fset(rt, pit_symtab_intern_cstr(rt, "elf/write-symbol!"), pit_value_nativefunc_new(rt, impl_elf_write_symbol)); + pit_symtab_fset(rt, pit_symtab_intern_cstr(rt, "elf/write-program-header!"), pit_value_nativefunc_new(rt, impl_elf_write_program_header)); + pit_symtab_fset(rt, pit_symtab_intern_cstr(rt, "elf/write-bytes!"), pit_value_nativefunc_new(rt, impl_elf_write_bytes)); + pit_symtab_fset(rt, pit_symtab_intern_cstr(rt, "elf/spit!"), pit_value_nativefunc_new(rt, impl_elf_spit)); +} diff --git a/asm/src/main.c b/asm/src/main.c new file mode 100644 index 0000000..2d25274 --- /dev/null +++ b/asm/src/main.c @@ -0,0 +1,24 @@ +#include +#include + +#include + +#include + +int main(int argc, char **argv) { + i64 sz = 256 * 1024 * 1024; + u8 *buf = malloc((size_t) sz); + pit_runtime *rt = pit_runtime_new(buf, sz); + rt->fuel = 10000000; + pit_install_library_essential(rt); + pit_install_library_io(rt); + pit_install_library_plist(rt); + pit_install_library_alist(rt); + pit_install_library_bytestring(rt); + asm_install_library_elf(rt); + if (argc < 2) { + pit_repl(rt); + } else { + pit_load_file(rt, argv[1]); + } +} diff --git a/asm/x86_64.pdf b/asm/x86_64.pdf new file mode 100644 index 0000000..24fa420 Binary files /dev/null and b/asm/x86_64.pdf differ diff --git a/pit/Makefile b/pit/Makefile index 2eeb084..388044a 100644 --- a/pit/Makefile +++ b/pit/Makefile @@ -37,10 +37,13 @@ libdir ?= $(exec_prefix)/lib GDBFLAGS ?= -.PHONY: all clean install install-bin install-headers install-core install-native check-syntax gdb +.PHONY: all test clean install install-bin install-headers install-core install-native check-syntax gdb all: $(EXE) $(LIB_CORE) $(LIB_NATIVE) +test: $(EXE) + @find test/ -type f -exec ./$(EXE) {} \; + $(EXE): $(BUILD)/main.o $(LIB_NATIVE) $(LIB_CORE) $(CC) -o $@ $^ $(LDFLAGS) diff --git a/pit/examples/6502.pit b/pit/examples/6502.pit new file mode 100644 index 0000000..eb5a4e8 --- /dev/null +++ b/pit/examples/6502.pit @@ -0,0 +1,174 @@ +;; (implicit ) +;; (accumulator ) +;; (immediate ) +;; (zeropage ) +;; (zeropage-x ) +;; (zeropage-y ) +;; (relative ) +;; (absolute ) +;; (absolute-x ) +;; (absolute-y ) +;; (indirect ) +;; (indexed-indirect ) +;; (indirect-indexed ) + +(defun! 6502/ensure-u8 (x) + (if (and (>= x 0) (<= x 0xff)) + (list x) + (error! "operand out of range"))) + +(defun! 6502/ensure-i8 (x) + (cond + ((and (>= x 0) (<= x 127)) (list x)) + ((and (>= x -128) (< x 0)) (list (+ 0xff x))) + (error! "operand out of range"))) + +(defun! 6502/ensure-u16 (x) + (if (and (>= (car x) 0) (<= (car x) 0xffff)) + (list (bitwise/and 0xff x) (bitwise/and 0xff (bitwise/rshift x 8))) + (error! "operand out of range"))) + +(defun! 6502/identify-operand (x) + (cond + ((equal? x nil) (cons 'implicit nil)) ;; ( ) + ((equal? x '(a)) (cons 'accumulator nil)) ;; ( a) + ((integer? (car x)) (cons 'immediate (6502/ensure-u8 (car x)))) ;; ( 0x0f) + ((equal? (caar x) 'zeropage) ;; ( (zeropage 0x0f x)) + (let ((zp (car x))) + (let ((a (6502/ensure-u8 (cadr zp)))) + (case (caddr zp) + (x (cons 'zeropage-x a)) + (y (cons 'zeropage-y a)) + (nil (cons 'zeropage a)) + (t (error! "unknown zeropage offset register")))))) + ((equal? (caar x) 'relative) ;; ( (relative 0x0f)) + (cons 'relative (6502/ensure-i8 (cadar x)))) + ((equal? (caar x) 'absolute) ;; ( (absolute 0x0f x)) + (let ((ab (car x))) + (let ((a (6502/ensure-u16 (cadr ab)))) + (case (caddr ab) + (x (cons 'absolute-x a)) + (y (cons 'absolute-y a)) + (nil (cons 'absolute a)) + (t (error! "unknown absolute offset register")))))) + ((equal? (caar x) 'indirect) + (cons 'indirect (6502/ensure-u16 (cadar x)))) + ((and (equal? (caar x) 'indexed-indirect) (equal? (caddar x) 'x)) + (cons 'indexed-indirect (6502/ensure-u16 (cadar x)))) + ((and (equal? (caar x) 'indirect-indexed) (equal? (caddar x) 'y)) + (cons 'indexed-indirect (6502/ensure-u16 (cadar y)))) + (t (error! "unknown operand")))) + +(defun! 6502/single (op) + (case op + ;; conditional branches + (bpl 0x10) + (bmi 0x30) + (bvc 0x50) + (bvs 0x70) + (bcc 0x90) + (bcs 0xb0) + (bne 0xd0) + (beq 0xf0) + ;; other instructions + (brk 0x00) + (jsr 0x20) + (rti 0x40) + (rts 0x60) + ;; other single-byte instructions + (php 0x08) + (clc 0x18) + (plp 0x28) + (sec 0x38) + (pha 0x48) + (cli 0x58) + (pla 0x68) + (sei 0x78) + (dey 0x88) + (tya 0x98) + (tay 0xa8) + (clv 0xb8) + (iny 0xc8) + (cld 0xd8) + (inx 0xe8) + (sed 0xf8) + (txa 0x8a) + (txs 0x9a) + (tax 0xaa) + (tsx 0xba) + (dex 0xca) + (nop 0xea) + (t (error! "invalid single-byte instruction")))) + +(defun! 6502/grouped (group opbits amodebits) + (bitwise/or + (bitwise/lshift (bitwise/and 0b111 opbits) 5) + (bitwise/lshift (bitwise/and 0b111 amodebits) 2) + group)) + +(defun! 6502/group1 (op amode) + (6502/grouped 0b01 + (case op + (ora 0b000) + (and 0b001) + (eor 0b010) + (adc 0b011) + (sta 0b100) + (lda 0b101) + (cmp 0b110) + (sbc 0b111) + (t (error! "invalid group 1 opcode"))) + (case amode + (indexed-indirect 0b000) + (zeropage 0b001) + (immediate 0b010) + (absolute 0b011) + (indirect-indexed 0b100) + (zeropage-x 0b101) + (absolute-y 0b110) + (absolute-x 0b111) + (t (error! "invalid addressing mode for group 1"))))) + +(defun! 6502/group2 (op amode) + (6502/grouped 0b10 + (case op + (asl 0b000) + (rol 0b001) + (lsr 0b010) + (ror 0b011) + (stx 0b100) + (ldx 0b101) + (dec 0b110) + (inc 0b111) + (t (error! "invalid group 2 opcode"))) + (cond + ((and (or (equal? op 'stx) (equal? op 'ldx)) (equal? amode 'zeropage-y)) 0b101) + ((and (equal? op 'ldx) (equal? amode 'absolute-y)) 0b111) + (t + (case amode + (immediate 0b000) + (zeropage 0b001) + (accumulator 0b010) + (absolute 0b011) + (zeropage-x 0b101) + (absolute-x 0b111) + (t (error! "invalid addressing mode for group 2"))))))) + +(defun! 6502/group3 (op amode) + (6502/grouped 0b00 + (case op + (bit 0b001) + (jmp 0b010) + (jmp-abs 0b011) + (sty 0b100) + (ldy 0b101) + (cpy 0b110) + (cpx 0b111) + (t (error! "invalid group 3 opcode"))) + (case amode + (immediate 0b000) + (zeropage 0b001) + (absolute 0b011) + (zeropage-x 0b101) + (absolute-x 0b111) + (t (error! "invalid addressing mode for group 3"))))) diff --git a/pit/examples/array.pit b/pit/examples/array.pit new file mode 100644 index 0000000..976f70d --- /dev/null +++ b/pit/examples/array.pit @@ -0,0 +1,2 @@ +(print! (array/repeat 'foo 1000)) +(array/repeat 'foo 10000) diff --git a/pit/examples/backtrace.pit b/pit/examples/backtrace.pit new file mode 100644 index 0000000..8a44951 --- /dev/null +++ b/pit/examples/backtrace.pit @@ -0,0 +1,2 @@ +(defun! foo (x) (* x 2)) +(foo "bar") \ No newline at end of file diff --git a/pit/examples/bif.pit b/pit/examples/bif.pit new file mode 100644 index 0000000..81a1248 --- /dev/null +++ b/pit/examples/bif.pit @@ -0,0 +1,12 @@ +(print! nil) +(print! nil) +(print! t) +(print! (eq? 1 1)) +(diagnostics!) +(defun! bif (x) + (cons x x)) +(diagnostics!) +(setq! foo (print! (bif (bif (bif 67))))) +(print! (eq? (car foo) (cdr foo))) +(diagnostics!) +(print! foo) diff --git a/pit/examples/broken.pit b/pit/examples/broken.pit new file mode 100644 index 0000000..09f4afc --- /dev/null +++ b/pit/examples/broken.pit @@ -0,0 +1,5 @@ +;; (let ((foo (+ 1 1))) +;; (print! foo)) +((lambda (foo) + (print! foo)) + (+ 1 1)) diff --git a/pit/examples/compile.pit b/pit/examples/compile.pit new file mode 100644 index 0000000..37d7f57 --- /dev/null +++ b/pit/examples/compile.pit @@ -0,0 +1,6 @@ +(defmacro! foo () + (setq! bar (lambda (x) (foo) (+ x 1))) + '(print 'hi)) + +(foo) +(print (funcall bar 1)) \ No newline at end of file diff --git a/pit/examples/error.pit b/pit/examples/error.pit new file mode 100644 index 0000000..58b7d99 --- /dev/null +++ b/pit/examples/error.pit @@ -0,0 +1 @@ +(print! "hello") diff --git a/pit/examples/error2.pit b/pit/examples/error2.pit new file mode 100644 index 0000000..63ab173 --- /dev/null +++ b/pit/examples/error2.pit @@ -0,0 +1,4 @@ +(defun! foo () + (error! "yuck")) + +(foo) diff --git a/pit/examples/fold.pit b/pit/examples/fold.pit new file mode 100644 index 0000000..89031d0 --- /dev/null +++ b/pit/examples/fold.pit @@ -0,0 +1,12 @@ +(defun! foo (x) + (+ x 1)) +(print! (foo 1)) +(print! (funcall 'foo 1)) +(print! (list/map 'foo '(1 2 3))) +(print! (list/foldl '+ 0 '(1 2 3))) +(print! (list/take 2 '(1 2 3))) +(print! (list/take 0 '(1 2 3))) +(print! (list/take 100 '(1 2 3))) +(print! (list/drop 2 '(1 2 3))) +(print! (list/drop 10 '(1 2 3))) +(print! (list/filter 'integer? '(1 foo 2 bar baz 3 quux))) diff --git a/pit/examples/gc.pit b/pit/examples/gc.pit new file mode 100644 index 0000000..28eed50 --- /dev/null +++ b/pit/examples/gc.pit @@ -0,0 +1,13 @@ +(diagnostics!) +(setq! foo (cons 1 2)) +(setq! bar (cons foo 3)) +(setq! baz (cons bar foo)) +(diagnostics!) +(print! foo) +(setcar! foo baz) +(print! (cdr (car (car foo)))) +(diagnostics!) +(setq! foo nil) +(setq! bar nil) +(setq! baz nil) +(diagnostics!) diff --git a/pit/examples/infinite.pit b/pit/examples/infinite.pit new file mode 100644 index 0000000..f815821 --- /dev/null +++ b/pit/examples/infinite.pit @@ -0,0 +1,4 @@ +(progn + (defun! foo () + (foo)) + foo) \ No newline at end of file diff --git a/pit/examples/int.pit b/pit/examples/int.pit new file mode 100644 index 0000000..65646af --- /dev/null +++ b/pit/examples/int.pit @@ -0,0 +1 @@ +(print! 0x10) diff --git a/pit/examples/loadpath.pit b/pit/examples/loadpath.pit new file mode 100644 index 0000000..5f8bcf8 --- /dev/null +++ b/pit/examples/loadpath.pit @@ -0,0 +1,2 @@ +;; (setq! *load-path* (list "test/")) +(load! "test.pit") \ No newline at end of file diff --git a/pit/examples/nonbroken.pit b/pit/examples/nonbroken.pit new file mode 100644 index 0000000..350f64f --- /dev/null +++ b/pit/examples/nonbroken.pit @@ -0,0 +1,2 @@ +(+ 1 + (fwefwfwfwe 1 1)) diff --git a/pit/examples/recurse.pit b/pit/examples/recurse.pit new file mode 100644 index 0000000..8e1f784 --- /dev/null +++ b/pit/examples/recurse.pit @@ -0,0 +1,5 @@ +(defun! foo () + (print! 'hi) + (foo)) + +(foo) \ No newline at end of file diff --git a/pit/examples/struct.pit b/pit/examples/struct.pit new file mode 100644 index 0000000..9e35654 --- /dev/null +++ b/pit/examples/struct.pit @@ -0,0 +1,11 @@ +(defstruct! foo + x + y + z) + +(setq! x (foo/new :y 10 :x 5 :z 111)) +(print! x) +(print! (foo/get-y x)) +(foo/set-y! x 42) +(print! (foo/get-y x)) +(print! (foo/get-z x)) diff --git a/pit/examples/test.pit b/pit/examples/test.pit new file mode 100644 index 0000000..ef13abb --- /dev/null +++ b/pit/examples/test.pit @@ -0,0 +1,22 @@ +(print! (list/map (lambda (x) (+ x 1)) (list 1 2 3 4 5))) +(print! (eval! '(cons 1 2))) +(defun! say-hi () + (princ! "hello computer")) +(say-hi) +(setq! counter 42) +(let ((counter 0)) + (print! counter) + (fset! 'count (lambda () (setq! counter (+ counter 1)))) + (fset! 'query (lambda () counter))) +(print! (count)) (print! (query)) +(print! (count)) (print! (query)) +(defun! bar (x & xs) + (print! x) + (print! xs)) +(bar 1 2 3 4 5) +(defun! baz (& kwargs) + (print! kwargs) + (let ((foo (plist/get :foo kwargs)) + (bar (plist/get :bar kwargs))) + bar)) +(print! (baz :foo 10 :bar 5 :baz 3)) diff --git a/pit/examples/test10.pit b/pit/examples/test10.pit new file mode 100644 index 0000000..0eea605 --- /dev/null +++ b/pit/examples/test10.pit @@ -0,0 +1,5 @@ +(list/find + (lambda (y) + (and (eq? (list/len y) 3) + (list/all? (lambda (x) (equal? x 2)) y))) + '((1 2 3) (2 2 2 2) (2 3 4) (2 2 2))) \ No newline at end of file diff --git a/pit/examples/test11.pit b/pit/examples/test11.pit new file mode 100644 index 0000000..83d4816 --- /dev/null +++ b/pit/examples/test11.pit @@ -0,0 +1,4 @@ +(print! 'here) +(list/foldl '+ 0 '(1 2 3)) +(print! 'there) +(print! (list/foldl '+ 0 '(1 2 3))) \ No newline at end of file diff --git a/pit/examples/test2.pit b/pit/examples/test2.pit new file mode 100644 index 0000000..a86f8d2 --- /dev/null +++ b/pit/examples/test2.pit @@ -0,0 +1 @@ +(print! "hello from test2") diff --git a/pit/examples/test3.pit b/pit/examples/test3.pit new file mode 100644 index 0000000..1964242 --- /dev/null +++ b/pit/examples/test3.pit @@ -0,0 +1,7 @@ +(let ((bs (bs/new!))) + (print! bs) + ;; (bs/grow! 1 bs) + (bs/write8! bs 0 67) + (bs/spit! "test3.bin" bs) + ;; (bs/delete! bs) + ) diff --git a/pit/examples/test4.pit b/pit/examples/test4.pit new file mode 100644 index 0000000..ef8e04c --- /dev/null +++ b/pit/examples/test4.pit @@ -0,0 +1,6 @@ +(print! + (or + (case 'baz + (foo 1) + (bar 2)) + 3)) \ No newline at end of file diff --git a/pit/examples/test5.pit b/pit/examples/test5.pit new file mode 100644 index 0000000..2ad3675 --- /dev/null +++ b/pit/examples/test5.pit @@ -0,0 +1,6 @@ +(defun! foo (x) + (if (equal? 0 (% x 10000)) + (print! x)) + (foo (+ x 1))) + +(foo 0) \ No newline at end of file diff --git a/pit/examples/test6.pit b/pit/examples/test6.pit new file mode 100644 index 0000000..cb04f22 --- /dev/null +++ b/pit/examples/test6.pit @@ -0,0 +1,6 @@ +(print! + ((case 'baz + (foo (lambda (x) (+ x 1))) + (bar (lambda (x) (+ x 2)))) + 3)) + \ No newline at end of file diff --git a/pit/examples/test7.pit b/pit/examples/test7.pit new file mode 100644 index 0000000..48d2c2c --- /dev/null +++ b/pit/examples/test7.pit @@ -0,0 +1 @@ +(print! (list/map (lambda (x) (+ x 1)) '(1 2 3))) \ No newline at end of file diff --git a/pit/examples/test8.pit b/pit/examples/test8.pit new file mode 100644 index 0000000..3b41d7a --- /dev/null +++ b/pit/examples/test8.pit @@ -0,0 +1,2 @@ +(defun! foo (x) (+ x 1)) +(foo 2) \ No newline at end of file diff --git a/pit/examples/test9.pit b/pit/examples/test9.pit new file mode 100644 index 0000000..daf1686 --- /dev/null +++ b/pit/examples/test9.pit @@ -0,0 +1,2 @@ +(defun! foo (x) x) +(foo 1) \ No newline at end of file diff --git a/pit/examples/thebug.pit b/pit/examples/thebug.pit new file mode 100644 index 0000000..ad87bd7 --- /dev/null +++ b/pit/examples/thebug.pit @@ -0,0 +1,9 @@ +(defun! foo (x) + (lambda (y) + (+ x y))) + +(setq! bar (foo 10)) +(setq! baz (foo 100)) + +(print! (funcall bar 4)) + diff --git a/pit/examples/thebug2.pit b/pit/examples/thebug2.pit new file mode 100644 index 0000000..2376ff8 --- /dev/null +++ b/pit/examples/thebug2.pit @@ -0,0 +1,13 @@ + +(setq! z 40) +(setq! f + (lambda (x) + (lambda (y) + (lambda (w) + (+ + (funcall (lambda (z) (+ x y z)) 3) + w + z))))) +(let ((z 20)) + (print! (funcall (funcall (funcall f 1) 2) 3))) + diff --git a/pit/examples/x86.pit b/pit/examples/x86.pit new file mode 100644 index 0000000..2aa8d89 --- /dev/null +++ b/pit/examples/x86.pit @@ -0,0 +1,451 @@ +(defun! x86/split16le (w) + "Split the 16-bit W16 into a little-endian list of 8-bit integers." + (list + (bitwise/and 0xff w) + (bitwise/and 0xff (bitwise/rshift w 8)))) + +(defun! x86/split32le (w) + "Split the 32-bit W32 into a little-endian list of 8-bit integers." + (list + (bitwise/and 0xff w) + (bitwise/and 0xff (bitwise/rshift w 8)) + (bitwise/and 0xff (bitwise/rshift w 16)) + (bitwise/and 0xff (bitwise/rshift w 24)))) + +(defun! x86/register-1byte? (r) + "Return the register index for 1-byte register R." + (case r + (al 0) (cl 1) (dl 2) (bl 3) + (ah 4) (ch 5) (dh 6) (bh 7) + (r8b 8) (r9b 9) (r10b 10) (r11b 11) + (r12b 12) (r13b 13) (r14b 14) (r15b 15))) + +(defun! x86/register-2byte? (r) + "Return the register index for 2-byte register R." + (case r + (ax 0) (cx 1) (dx 2) (bx 3) + (sp 4) (bp 5) (si 6) (di 7) + (r8w 8) (r9w 9) (r10w 10) (r11w 11) + (r12w 12) (r13w 13) (r14w 14) (r15w 15))) + +(defun! x86/register-4byte? (r) + "Return the register index for 4-byte register R." + (case r + (eax 0) (ecx 1) (edx 2) (ebx 3) + (esp 4) (ebp 5) (esi 6) (edi 7) + (r8d 8) (r9d 9) (r10d 10) (r11d 11) + (r12d 12) (r13d 13) (r14d 14) (r15d 15))) + +(defun! x86/register-8byte? (r) + "Return the register index for 8-byte register R." + (case r + (rax 0) (rcx 1) (rdx 2) (rbx 3) + (rsp 4) (rbp 5) (rsi 6) (rdi 7) + (r8 8) (r9 9) (r10 10) (r11 11) + (r12 12) (r13 13) (r14 14) (r15 15))) + +(defun! x86/register? (r) + "Return the register index of R." + (or + (x86/register-1byte? r) + (x86/register-2byte? r) + (x86/register-4byte? r) + (x86/register-8byte? r))) + +(defun! x86/register-extended? (r) + "Return non-nil if R is an extended register." + (list/contains? r + '( r8b r9b r10b r11b r12b r13b r14b r15b + r8w r9w r10w r11w r12w r13w r14w r15w + r8d r9d r10d r11d r12d r13d r14d r15d + r8 r9 r10 r11 r12 r13 r14 r15))) + +(defun! x86/integer-fits-in-bits? (bits x) + "Determine if X fits in BITS." + (if (integer? x) + (let ((leftover (bitwise/rshift x bits))) + (eq? leftover 0)))) +(defun! x86/operand-immediate-fits? (sz x) + "Determine if immediate operand X fits in SZ." + (let + ((bits + (or + (case sz + ("b" 8) ("c" 16) ("d" 32) ("i" 16) + ("j" 32) ("q" 64) ("v" 64) ("w" 16) + ("y" 64) ("z" 32)) + (error! "unknown operand pattern size")))) + (x86/integer-fits-in-bits? bits x))) + +(defun! x86/operand-register-fits? (sz r) + "Determine if register operand R fits in SZ." + (case sz + ("b" (x86/register-1byte? r)) + ("c" (or (x86/register-1byte? r) (x86/register-2byte? r))) + ("d" (x86/register-4byte? r)) + ("i" (x86/register-2byte? r)) + ("j" (x86/register-4byte? r)) + ("q" (x86/register-8byte? r)) + ("v" (or (x86/register-2byte? r) (x86/register-4byte? r) (x86/register-8byte? r))) + ("w" (x86/register-2byte? r)) + ("y" (or (x86/register-4byte? r) (x86/register-8byte? r))) + ("z" (or (x86/register-2byte? r) (x86/register-4byte? r))))) + +(defun! x86/memory-operand-base (m) + (and + (eq? (car m) 'mem) + (car (cdr m)))) +(defun! x86/memory-operand-off (m) + (and + (eq? (car m) 'mem) + (or (car (cdr (cdr m))) 0))) + +(defun! x86/operand-memory-location? (op) + "Return non-nil if OP represents a memory location." + (let ( (base (x86/memory-operand-base op)) + (off (x86/memory-operand-off op))) + (and + (or (x86/register-4byte? base) (x86/register-8byte? base)) + (integer? off)))) + +(defun! x86/operand-match? (pat op) + "Determine if operand OP matches PAT." + (cond + ((symbol? pat) (eq? pat op)) + ((cons? pat) (list/contains? op pat)) + ((bytes? pat) + (let ( (loc (bytes/range 0 1 pat)) + (sz (bytes/range 1 (bytes/len pat) pat))) + (cond + ((or (equal? loc "I") (equal? loc "J")) (x86/operand-immediate-fits? sz op)) + ((or (equal? loc "G") (equal? loc "R")) (x86/operand-register-fits? sz op)) + ((equal? loc "M") (x86/operand-memory-location? op)) + ((equal? loc "E") + (or (x86/operand-register-fits? sz op) (x86/operand-memory-location? op))) + (t (error! "unknown operand pattern location"))))))) + +(defun! x86/operand-size (op) + "Return the minimum power-of-2 size in bytes that contains OP." + (cond + ((symbol? op) + (cond + ((x86/register-1byte? op) 1) + ((x86/register-2byte? op) 2) + ((x86/register-4byte? op) 4) + ((x86/register-8byte? op) 8) + (t (error! "attempted to take size of unknown register")))) + ((integer? op) + (cond + ((x86/integer-fits-in-bits? 8 op) 1) + ((x86/integer-fits-in-bits? 16 op) 2) + ((x86/integer-fits-in-bits? 32 op) 4) + ((x86/integer-fits-in-bits? 64 op) 8) + (t (error! "attempted to take size of too-large immediate")))) + ((x86/operand-memory-location? op) 1) + (t (error! "attempted to take size of unknown operand")))) + +(defstruct! x86/ins + operand-size-prefix + address-size-prefix + rex-w + rex-r + rex-x + rex-b + opcode + modrm-mod + modrm-reg + modrm-rm + disp ;; pair of size and value + imm ;; pair of size and value + ) + +(defun! x86/ins-bytes (ins) + "Return a list of bytes encoding INS." + (let ( (opcode (x86/ins/get-opcode ins)) + (rex-w (x86/ins/get-rex-w ins)) + (rex-r (x86/ins/get-rex-r ins)) + (rex-x (x86/ins/get-rex-x ins)) + (rex-b (x86/ins/get-rex-b ins)) + (modrm-mod (x86/ins/get-modrm-mod ins)) + (modrm-reg (x86/ins/get-modrm-reg ins)) + (modrm-rm (x86/ins/get-modrm-rm ins)) + (disp (x86/ins/get-disp ins)) + (imm (x86/ins/get-imm ins))) + (list/append + (if (x86/ins/get-operand-size-prefix ins) '(0x66)) + (if (x86/ins/get-address-size-prefix ins) '(0x67)) + (if (or rex-w rex-r rex-x rex-b) + (list + (bitwise/or + 0x40 + (if rex-w 0b1000 0) + (if rex-r 0b0100 0) + (if rex-x 0b0010 0) + (if rex-b 0b0001 0)))) + (cond + ((not opcode) (error! "no opcode for instruction")) + ((cons? opcode) opcode) + ((integer? opcode) (list opcode)) + (t (error! "malformed opcode for instruction"))) + (if (or modrm-mod modrm-reg modrm-rm) + (list + (bitwise/or + (bitwise/lshift (or modrm-mod 0) 6) + (bitwise/lshift (or modrm-reg 0) 3) + (or modrm-rm 0)))) + (if disp + (cond + ((eq? (car disp) 1) (list (cdr disp))) + ((eq? (car disp) 4) (x86/split32le (cdr disp))) + (t (error! "malformed displacement for instruction")))) + (if imm + (cond + ((eq? (car imm) 1) (list (cdr imm))) + ((eq? (car imm) 2) (x86/split16le (cdr imm))) + ((eq? (car imm) 4) (x86/split32le (cdr imm))) + (t (error! "malformed immediate for instruction"))))))) + +(defun! x86/instruction-update-sizes (ins ops default-size) + "Update INS to account for the sizes of OPS. +DEFAULT-SIZE is the default operand size." + (let ((defsz (or default-size 4))) + (if (> (list/len ops) 0) + (let ((regs (list/uniq (list/map 'x86/operand-size (list/filter 'x86/register? ops))))) + (if (> (list/len regs) 1) + (error! "invalid mix of register sizes in operands")) + (let ((sz (if (eq? (list/len regs) 0) defsz (car regs)))) + (cond + ((eq? sz 1) nil) + ((eq? defsz sz) nil) + ((and (not (eq? defsz 2)) (eq? sz 2)) (x86/ins/set-operand-size-prefix! ins t)) + ((and (not (eq? defsz 8)) (eq? sz 8)) (x86/ins/set-rex-w! ins t)) + (t (error! "unable to encode operands with default size"))) + sz))))) + +(defun! x86/instruction-update-operand (esz ins pat op) + "Update INS to account for an operand OP according to PAT. +The effective operand size is ESZ." + (cond + ((bytes? pat) + (let ((loc (bytes/range 0 1 pat))) + (cond + ((equal? loc "I") + (let ((immsz (if (>= esz 4) 4 esz))) + (if (not (x86/integer-fits-in-bits? (* 8 immsz) op)) + (error! "Immediate too large" op)) + (x86/ins/set-imm! ins (cons immsz op)))) + ((equal? loc "J") + (let ((immsz (if (eq? esz 1) 1 4))) + (if (not (x86/integer-fits-in-bits? (* 8 immsz) op)) + (error! "jump displacement too large")) + (x86/ins/set-disp! ins (cons immsz op)))) + ((equal? loc "G") + (x86/ins/set-modrm-reg! ins + (or (x86/register? op) (error "Invalid register: %s" op)))) + ((or (equal? loc "R") (and (equal? loc "E") (x86/register? op))) + (x86/ins/set-modrm-mod! ins 0b11) + (x86/ins/set-modrm-rm! ins + (or (x86/register? op) (error "Invalid register: %s" op)))) + ((or (equal? loc "M") (and (equal? loc "E") (x86/operand-memory-location? op))) + (let ( (base (x86/memory-operand-base op)) + (off (x86/memory-operand-off op))) + (cond + ((eq? base 'eip) + (x86/ins/set-modrm-rm! ins 0b101) + (x86/ins/set-modrm-mod! ins 0b00) + (x86/ins/set-disp! ins (cons 4 off)) + (x86/ins/set-address-size-prefix! ins t)) + ((eq? base 'rip) + (x86/ins/set-modrm-rm! ins 0b101) + (x86/ins/set-modrm-mod! ins 0b00) + (x86/ins/set-disp! ins (cons 4 off))) + (t + (x86/ins/set-modrm-rm! ins + (or + (x86/register-4byte? base) + (x86/register-8byte? base) + (error! "invalid base register"))) + (if (x86/register-4byte? base) + (x86/ins/set-address-size-prefix! ins t)) + (cond + ((x86/integer-fits-in-bits? 8 off) + (x86/ins/set-disp! ins (cons 1 off)) + (x86/ins/set-modrm-mod! ins 0b01)) + ((x86/integer-fits-in-bits? 32 off) + (x86/ins/set-disp! ins (cons 4 off)) + (x86/ins/set-modrm-mod! ins 0b10)) + (t (error! "invalid offset"))))))) + (t (error! "invalid operand location code"))))))) + +(defun! x86/default-instruction-handler (opcode & kwargs) + "Return an instruction handler for OPCODE. +The instruction handler will run POSTHOOK on the instruction at the end. +DEFAULT-SIZE is the default operand size." + (let ( (posthook (plist/get :posthook kwargs)) + (default-size (plist/get :default-size kwargs))) + (lambda (pats ops) + (let ((ret (x86/ins/new :opcode opcode))) + (let ((esz + (or (x86/instruction-update-sizes ret ops default-size) + (error! "malformed size for operands")))) + (list/zip-with + (lambda (it other) + (x86/instruction-update-operand esz ret it other)) + pats + ops)) + (if posthook + (funcall posthook ret ops)) + ret)))) + +(defun! x86/instruction-handler-jcc (opcode immsz) + "Return an instruction handler for a Jcc instruction at OPCODE. +IMMSZ is the size of the displacement from RIP." + (lambda (_pats ops) + (let ((ret (x86/ins/new :opcode opcode))) + (x86/ins/set-disp! ret (cons immsz (car ops))) + ret))) + +(defun! x86/generate-handlers-arith (opbase group1reg) + "Return handlers for an arithmetic mnemonic starting at OPBASE. +The REG value in ModR/M is indicated by GROUP1REG." + (list + (cons '("Eb" "Gb") (x86/default-instruction-handler (+ opbase 0))) + (cons '("Ev" "Gv") (x86/default-instruction-handler (+ opbase 1))) + (cons '("Gb" "Eb") (x86/default-instruction-handler (+ opbase 2))) + (cons '("Gv" "Ev") (x86/default-instruction-handler (+ opbase 3))) + (cons '(al "Ib") (x86/default-instruction-handler (+ opbase 4))) + (cons '((ax eax rax) "Iz") (x86/default-instruction-handler (+ opbase 5))) + (cons '("Eb" "Ib") + (x86/default-instruction-handler 0x80 + :posthook (lambda (ins _) (x86/ins/set-modrm-reg! ins group1reg)))) + (cons '("Ev" "Iz") + (x86/default-instruction-handler 0x81 + :posthook (lambda (ins _) (x86/ins/set-modrm-reg! ins group1reg)))) + (cons '("Ev" "Ib") + (x86/default-instruction-handler 0x83 + :posthook (lambda (ins _) (setf (x86/ins-modrm-reg ins) group1reg)))))) + +(setq! x86/registers-+reg-base + '( (+rb . (al cl dl bl ah ch dh bh)) + (+rw . (ax cx dx bx sp bp si di)) + (+rd . (eax ecx edx ebx esp ebp esi edi)) + (+rq . (rax rcx rdx rbx rsp rbp rsi rdi)))) +(setq! x86/registers-+reg-extended + '( (+rw . (r8b r9b r10b r11b r12b r13b r14b r15b)) + (+rw . (r8w r9w r10w r11w r12w r13w r14w r15w)) + (+rd . (r8d r9d r10d r11d r12d r13d r14d r15d)) + (+rq . (r8 r9 r10 r11 r12 r13 r14 r15)))) +(defun! x86/generate-handlers-opcode-+reg (opbase extraops addends & args) + "Generate handlers for a family of opcodes that uses the +reg encoding. +OPBASE is the base opcode. +EXTRAOPS are additional operands after the register operand. +ADDENDS is a list of symbols like +rw, +rq etc. that denote allowed registers. +ARGS are passed verbatim to `u/x86/default-instruction-handler." + (list/map + (lambda (it) + (let ( (abase (list/map (lambda (a) (list/nth it (alist/get a x86/registers-+reg-base))) addends)) + (aext (list/map (lambda (a) (list/nth it (alist/get a x86/registers-+reg-extended))) addends))) + (cons + (cons (list/append abase aext) extraops) + (apply 'x86/default-instruction-handler (cons (+ opbase it) args))))) + (list/iota 8))) + +(setq! + x86/mnemonic-table + (list + (cons 'add (x86/generate-handlers-arith 0x00 0)) + (cons 'or (x86/generate-handlers-arith 0x08 1)) + (cons 'adc (x86/generate-handlers-arith 0x10 2)) + (cons 'sbb (x86/generate-handlers-arith 0x18 3)) + (cons 'and (x86/generate-handlers-arith 0x20 4)) + (cons 'sub (x86/generate-handlers-arith 0x28 5)) + (cons 'xor (x86/generate-handlers-arith 0x30 6)) + (cons 'cmp (x86/generate-handlers-arith 0x38 7)) + (cons 'push + (x86/generate-handlers-opcode-+reg 0x50 '() '(+rw +rq) + :default-size 8 + :posthook (lambda (ins ops) (x86/ins/set-rex-b! ins (x86/register-extended? (car ops)))))) + (cons 'pop + (x86/generate-handlers-opcode-+reg 0x58 '() '(+rw +rq) + :default-size 8 + :posthook (lambda (ins ops) (x86/ins/set-rex-b! ins (x86/register-extended? (car ops)))))) + (list 'jo + (cons '("Jb") (x86/instruction-handler-jcc 0x70 1)) + (cons '("Jz") (x86/instruction-handler-jcc '(0x0f 0x80) 4))) + (list 'jno + (cons '("Jb") (x86/instruction-handler-jcc 0x71 1)) + (cons '("Jz") (x86/instruction-handler-jcc '(0x0f 0x81) 4))) + (list 'jb + (cons '("Jb") (x86/instruction-handler-jcc 0x72 1)) + (cons '("Jz") (x86/instruction-handler-jcc '(0x0f 0x82) 4))) + (list 'jnb + (cons '("Jb") (x86/instruction-handler-jcc 0x73 1)) + (cons '("Jz") (x86/instruction-handler-jcc '(0x0f 0x83) 4))) + (list 'jz + (cons '("Jb") (x86/instruction-handler-jcc 0x74 1)) + (cons '("Jz") (x86/instruction-handler-jcc '(0x0f 0x84) 4))) + (list 'jnz + (cons '("Jb") (x86/instruction-handler-jcc 0x75 1)) + (cons '("Jz") (x86/instruction-handler-jcc '(0x0f 0x85) 4))) + (list 'jbe + (cons '("Jb") (x86/instruction-handler-jcc 0x76 1)) + (cons '("Jz") (x86/instruction-handler-jcc '(0x0f 0x86) 4))) + (list 'jnbe + (cons '("Jb") (x86/instruction-handler-jcc 0x77 1)) + (cons '("Jz") (x86/instruction-handler-jcc '(0x0f 0x87) 4))) + (list 'js + (cons '("Jb") (x86/instruction-handler-jcc 0x78 1)) + (cons '("Jz") (x86/instruction-handler-jcc '(0x0f 0x88) 4))) + (list 'jns + (cons '("Jb") (x86/instruction-handler-jcc 0x79 1)) + (cons '("Jz") (x86/instruction-handler-jcc '(0x0f 0x89) 4))) + (list 'jp + (cons '("Jb") (x86/instruction-handler-jcc 0x7a 1)) + (cons '("Jz") (x86/instruction-handler-jcc '(0x0f 0x8a) 4))) + (list 'jnp + (cons '("Jb") (x86/instruction-handler-jcc 0x7b 1)) + (cons '("Jz") (x86/instruction-handler-jcc '(0x0f 0x8b) 4))) + (list 'jl + (cons '("Jb") (x86/instruction-handler-jcc 0x7c 1)) + (cons '("Jz") (x86/instruction-handler-jcc '(0x0f 0x8c) 4))) + (list 'jnl + (cons '("Jb") (x86/instruction-handler-jcc 0x7d 1)) + (cons '("Jz") (x86/instruction-handler-jcc '(0x0f 0x8d) 4))) + (list 'jle + (cons '("Jb") (x86/instruction-handler-jcc 0x7e 1)) + (cons '("Jz") (x86/instruction-handler-jcc '(0x0f 0x8e) 4))) + (list 'jnle + (cons '("Jb") (x86/instruction-handler-jcc 0x7f 1)) + (cons '("Jz") (x86/instruction-handler-jcc '(0x0f 0x8f) 4))) + (cons 'mov + (x86/generate-handlers-opcode-+reg 0xb0 '("Ib") '(+rb) + :posthook (lambda (ins ops) (x86/ins/set-rex-b! ins (x86/register-extended? (car ops)))))) + (cons 'mov + (x86/generate-handlers-opcode-+reg 0xb8 '("Iv") '(+rw +rd +rq) + :posthook (lambda (ins ops) (x86/ins/set-rex-b! ins (x86/register-extended? (car ops)))))) + (list 'jmp + (cons '("Ev") + (x86/default-instruction-handler 0xff + :default-size 8 + :posthook (lambda (ins _) (setf (u/x86/ins-modrm-reg ins) 4))))) + (list 'syscall + (cons '() (lambda (_ _) (x86/ins/new :opcode '(0x0f 0x05))))) + )) + +(defun! x86/asm (op) + "Assemble OP to an instruction." + (let ((mnem (car op)) (operands (cdr op))) + (let ((variants (or (alist/get mnem x86/mnemonic-table) (error! "unknown mnemonic")))) + (let ((v + (list/find + (lambda (it) + (and (eq? (list/len (car it)) (list/len operands)) + (list/all? (lambda (x) x) (list/zip-with 'x86/operand-match? (car it) operands)))) + variants))) + (if (and v (function? (cdr v))) + (funcall (cdr v) (car v) operands) + (error! "could not identify instruction")))))) + +(setq! test-ins (x86/asm '(syscall))) +(print! test-ins) +(print! (x86/ins-bytes test-ins)) diff --git a/pit/examples/y.pit b/pit/examples/y.pit new file mode 100644 index 0000000..5e9218b --- /dev/null +++ b/pit/examples/y.pit @@ -0,0 +1,5 @@ +(setq! Y + (lambda (f) + (funcall + (lambda (x) (funcall f (funcall x x))) + (lambda (x) (funcall f (funcall x x)))))) diff --git a/pit/src/native.c b/pit/src/native.c index 7d61a50..e776f38 100644 --- a/pit/src/native.c +++ b/pit/src/native.c @@ -188,6 +188,17 @@ static pit_value impl_diagnostics(pit_runtime *rt, pit_value args, void *data) { fprintf(stderr, "value allocs: %ld\n", rt->heap->next); return PIT_NIL; } +static pit_value impl_assert(pit_runtime *rt, pit_value args, void *data) { + (void) data; + pit_value msg = pit_value_cons_car(rt, args); args = pit_value_cons_cdr(rt, args); + pit_value expected = pit_value_cons_car(rt, args); args = pit_value_cons_cdr(rt, args); + pit_value actual = pit_value_cons_car(rt, args); args = pit_value_cons_cdr(rt, args); + if (!pit_value_equal(rt, expected, actual)) { + pit_fprintf(rt, stderr, "assertion %v failed!\nexpected: %v\nactual: %v\n", msg, expected, actual); + exit(1); + } + return actual; +} static pit_value impl_print(pit_runtime *rt, pit_value args, void *data) { (void) data; pit_value x = pit_value_cons_car(rt, args); @@ -259,6 +270,7 @@ void pit_install_library_io(pit_runtime *rt) { pit_symtab_set(rt, pit_symtab_intern_cstr(rt, "*load-path*"), load_path); /* diagnostics */ pit_symtab_fset(rt, pit_symtab_intern_cstr(rt, "diagnostics!"), pit_value_nativefunc_new(rt, impl_diagnostics)); + pit_symtab_fset(rt, pit_symtab_intern_cstr(rt, "assert!"), pit_value_nativefunc_new(rt, impl_assert)); /* stream IO */ pit_symtab_fset(rt, pit_symtab_intern_cstr(rt, "print!"), pit_value_nativefunc_new(rt, impl_print)); pit_symtab_fset(rt, pit_symtab_intern_cstr(rt, "princ!"), pit_value_nativefunc_new(rt, impl_princ)); diff --git a/pit/src/parser.c b/pit/src/parser.c index 6c633c9..2541344 100644 --- a/pit/src/parser.c +++ b/pit/src/parser.c @@ -80,9 +80,10 @@ pit_value pit_parse(pit_runtime *rt, pit_parser *st, bool *eof) { return PIT_NIL; case PIT_LEX_TOKEN_LPAREN: { pit_value ret = PIT_NIL; + pit_value term = PIT_NIL; while (!match(st, PIT_LEX_TOKEN_RPAREN)) { if (match(st, PIT_LEX_TOKEN_DOT)) { - ret = pit_parse(rt, st, eof); + term = pit_parse(rt, st, eof); if (match(st, PIT_LEX_TOKEN_RPAREN)) { break; } else { @@ -97,14 +98,17 @@ pit_value pit_parse(pit_runtime *rt, pit_parser *st, bool *eof) { return PIT_NIL; /* if we hit an error, stop!*/ } } - ret = pit_value_list_reverse(rt, ret); - if (pit_value_sort(ret) == PIT_VALUE_SORT_REF) { + while (ret != PIT_NIL) { + term = pit_value_cons(rt, pit_value_cons_car(rt, ret), term); + ret = pit_value_cons_cdr(rt, ret); + } + if (pit_value_sort(term) == PIT_VALUE_SORT_REF) { pit_annotation a = {0}; a.line = rt->source_line; a.column = rt->source_column; - pit_annotation_set(rt, pit_value_as_ref(rt, ret), a); + pit_annotation_set(rt, pit_value_as_ref(rt, term), a); } - return ret; + return term; } case PIT_LEX_TOKEN_LSQUARE: { pit_value ret = PIT_NIL; diff --git a/pit/src/runtime/eval.c b/pit/src/runtime/eval.c index 3cd1c1f..43c8998 100644 --- a/pit/src/runtime/eval.c +++ b/pit/src/runtime/eval.c @@ -38,7 +38,7 @@ static pit_value vm_pop(pit_runtime *rt) { } static pit_value vm_bind_or_replace(pit_runtime *rt, pit_value nm, pit_value cell, pit_value bound) { - if (pit_value_list_contains_eq(rt, nm, bound)) { + if (pit_value_list_contains_eq(rt, nm, bound) != PIT_NIL) { /* if we're already responsible for unbinding this symbol (e.g. in a tail call), */ /* simply replace the old binding - this keeps the binding stack from growing for TCO purposes */ pit_symtab_replace(rt, nm, cell); diff --git a/pit/test/6502.pit b/pit/test/6502.pit deleted file mode 100644 index eb5a4e8..0000000 --- a/pit/test/6502.pit +++ /dev/null @@ -1,174 +0,0 @@ -;; (implicit ) -;; (accumulator ) -;; (immediate ) -;; (zeropage ) -;; (zeropage-x ) -;; (zeropage-y ) -;; (relative ) -;; (absolute ) -;; (absolute-x ) -;; (absolute-y ) -;; (indirect ) -;; (indexed-indirect ) -;; (indirect-indexed ) - -(defun! 6502/ensure-u8 (x) - (if (and (>= x 0) (<= x 0xff)) - (list x) - (error! "operand out of range"))) - -(defun! 6502/ensure-i8 (x) - (cond - ((and (>= x 0) (<= x 127)) (list x)) - ((and (>= x -128) (< x 0)) (list (+ 0xff x))) - (error! "operand out of range"))) - -(defun! 6502/ensure-u16 (x) - (if (and (>= (car x) 0) (<= (car x) 0xffff)) - (list (bitwise/and 0xff x) (bitwise/and 0xff (bitwise/rshift x 8))) - (error! "operand out of range"))) - -(defun! 6502/identify-operand (x) - (cond - ((equal? x nil) (cons 'implicit nil)) ;; ( ) - ((equal? x '(a)) (cons 'accumulator nil)) ;; ( a) - ((integer? (car x)) (cons 'immediate (6502/ensure-u8 (car x)))) ;; ( 0x0f) - ((equal? (caar x) 'zeropage) ;; ( (zeropage 0x0f x)) - (let ((zp (car x))) - (let ((a (6502/ensure-u8 (cadr zp)))) - (case (caddr zp) - (x (cons 'zeropage-x a)) - (y (cons 'zeropage-y a)) - (nil (cons 'zeropage a)) - (t (error! "unknown zeropage offset register")))))) - ((equal? (caar x) 'relative) ;; ( (relative 0x0f)) - (cons 'relative (6502/ensure-i8 (cadar x)))) - ((equal? (caar x) 'absolute) ;; ( (absolute 0x0f x)) - (let ((ab (car x))) - (let ((a (6502/ensure-u16 (cadr ab)))) - (case (caddr ab) - (x (cons 'absolute-x a)) - (y (cons 'absolute-y a)) - (nil (cons 'absolute a)) - (t (error! "unknown absolute offset register")))))) - ((equal? (caar x) 'indirect) - (cons 'indirect (6502/ensure-u16 (cadar x)))) - ((and (equal? (caar x) 'indexed-indirect) (equal? (caddar x) 'x)) - (cons 'indexed-indirect (6502/ensure-u16 (cadar x)))) - ((and (equal? (caar x) 'indirect-indexed) (equal? (caddar x) 'y)) - (cons 'indexed-indirect (6502/ensure-u16 (cadar y)))) - (t (error! "unknown operand")))) - -(defun! 6502/single (op) - (case op - ;; conditional branches - (bpl 0x10) - (bmi 0x30) - (bvc 0x50) - (bvs 0x70) - (bcc 0x90) - (bcs 0xb0) - (bne 0xd0) - (beq 0xf0) - ;; other instructions - (brk 0x00) - (jsr 0x20) - (rti 0x40) - (rts 0x60) - ;; other single-byte instructions - (php 0x08) - (clc 0x18) - (plp 0x28) - (sec 0x38) - (pha 0x48) - (cli 0x58) - (pla 0x68) - (sei 0x78) - (dey 0x88) - (tya 0x98) - (tay 0xa8) - (clv 0xb8) - (iny 0xc8) - (cld 0xd8) - (inx 0xe8) - (sed 0xf8) - (txa 0x8a) - (txs 0x9a) - (tax 0xaa) - (tsx 0xba) - (dex 0xca) - (nop 0xea) - (t (error! "invalid single-byte instruction")))) - -(defun! 6502/grouped (group opbits amodebits) - (bitwise/or - (bitwise/lshift (bitwise/and 0b111 opbits) 5) - (bitwise/lshift (bitwise/and 0b111 amodebits) 2) - group)) - -(defun! 6502/group1 (op amode) - (6502/grouped 0b01 - (case op - (ora 0b000) - (and 0b001) - (eor 0b010) - (adc 0b011) - (sta 0b100) - (lda 0b101) - (cmp 0b110) - (sbc 0b111) - (t (error! "invalid group 1 opcode"))) - (case amode - (indexed-indirect 0b000) - (zeropage 0b001) - (immediate 0b010) - (absolute 0b011) - (indirect-indexed 0b100) - (zeropage-x 0b101) - (absolute-y 0b110) - (absolute-x 0b111) - (t (error! "invalid addressing mode for group 1"))))) - -(defun! 6502/group2 (op amode) - (6502/grouped 0b10 - (case op - (asl 0b000) - (rol 0b001) - (lsr 0b010) - (ror 0b011) - (stx 0b100) - (ldx 0b101) - (dec 0b110) - (inc 0b111) - (t (error! "invalid group 2 opcode"))) - (cond - ((and (or (equal? op 'stx) (equal? op 'ldx)) (equal? amode 'zeropage-y)) 0b101) - ((and (equal? op 'ldx) (equal? amode 'absolute-y)) 0b111) - (t - (case amode - (immediate 0b000) - (zeropage 0b001) - (accumulator 0b010) - (absolute 0b011) - (zeropage-x 0b101) - (absolute-x 0b111) - (t (error! "invalid addressing mode for group 2"))))))) - -(defun! 6502/group3 (op amode) - (6502/grouped 0b00 - (case op - (bit 0b001) - (jmp 0b010) - (jmp-abs 0b011) - (sty 0b100) - (ldy 0b101) - (cpy 0b110) - (cpx 0b111) - (t (error! "invalid group 3 opcode"))) - (case amode - (immediate 0b000) - (zeropage 0b001) - (absolute 0b011) - (zeropage-x 0b101) - (absolute-x 0b111) - (t (error! "invalid addressing mode for group 3"))))) diff --git a/pit/test/array.pit b/pit/test/array.pit deleted file mode 100644 index 976f70d..0000000 --- a/pit/test/array.pit +++ /dev/null @@ -1,2 +0,0 @@ -(print! (array/repeat 'foo 1000)) -(array/repeat 'foo 10000) diff --git a/pit/test/backtrace.pit b/pit/test/backtrace.pit deleted file mode 100644 index 8a44951..0000000 --- a/pit/test/backtrace.pit +++ /dev/null @@ -1,2 +0,0 @@ -(defun! foo (x) (* x 2)) -(foo "bar") \ No newline at end of file diff --git a/pit/test/bif.pit b/pit/test/bif.pit deleted file mode 100644 index 81a1248..0000000 --- a/pit/test/bif.pit +++ /dev/null @@ -1,12 +0,0 @@ -(print! nil) -(print! nil) -(print! t) -(print! (eq? 1 1)) -(diagnostics!) -(defun! bif (x) - (cons x x)) -(diagnostics!) -(setq! foo (print! (bif (bif (bif 67))))) -(print! (eq? (car foo) (cdr foo))) -(diagnostics!) -(print! foo) diff --git a/pit/test/broken.pit b/pit/test/broken.pit deleted file mode 100644 index 09f4afc..0000000 --- a/pit/test/broken.pit +++ /dev/null @@ -1,5 +0,0 @@ -;; (let ((foo (+ 1 1))) -;; (print! foo)) -((lambda (foo) - (print! foo)) - (+ 1 1)) diff --git a/pit/test/compile.pit b/pit/test/compile.pit deleted file mode 100644 index 37d7f57..0000000 --- a/pit/test/compile.pit +++ /dev/null @@ -1,6 +0,0 @@ -(defmacro! foo () - (setq! bar (lambda (x) (foo) (+ x 1))) - '(print 'hi)) - -(foo) -(print (funcall bar 1)) \ No newline at end of file diff --git a/pit/test/core.pit b/pit/test/core.pit new file mode 100644 index 0000000..51e28a7 --- /dev/null +++ b/pit/test/core.pit @@ -0,0 +1 @@ +(assert! 'cons '(1 . 2) (cons 1 2)) diff --git a/pit/test/error.pit b/pit/test/error.pit deleted file mode 100644 index 58b7d99..0000000 --- a/pit/test/error.pit +++ /dev/null @@ -1 +0,0 @@ -(print! "hello") diff --git a/pit/test/error2.pit b/pit/test/error2.pit deleted file mode 100644 index 63ab173..0000000 --- a/pit/test/error2.pit +++ /dev/null @@ -1,4 +0,0 @@ -(defun! foo () - (error! "yuck")) - -(foo) diff --git a/pit/test/fold.pit b/pit/test/fold.pit deleted file mode 100644 index 89031d0..0000000 --- a/pit/test/fold.pit +++ /dev/null @@ -1,12 +0,0 @@ -(defun! foo (x) - (+ x 1)) -(print! (foo 1)) -(print! (funcall 'foo 1)) -(print! (list/map 'foo '(1 2 3))) -(print! (list/foldl '+ 0 '(1 2 3))) -(print! (list/take 2 '(1 2 3))) -(print! (list/take 0 '(1 2 3))) -(print! (list/take 100 '(1 2 3))) -(print! (list/drop 2 '(1 2 3))) -(print! (list/drop 10 '(1 2 3))) -(print! (list/filter 'integer? '(1 foo 2 bar baz 3 quux))) diff --git a/pit/test/gc.pit b/pit/test/gc.pit deleted file mode 100644 index 28eed50..0000000 --- a/pit/test/gc.pit +++ /dev/null @@ -1,13 +0,0 @@ -(diagnostics!) -(setq! foo (cons 1 2)) -(setq! bar (cons foo 3)) -(setq! baz (cons bar foo)) -(diagnostics!) -(print! foo) -(setcar! foo baz) -(print! (cdr (car (car foo)))) -(diagnostics!) -(setq! foo nil) -(setq! bar nil) -(setq! baz nil) -(diagnostics!) diff --git a/pit/test/horriblebindingbug.pit b/pit/test/horriblebindingbug.pit new file mode 100644 index 0000000..7f48b69 --- /dev/null +++ b/pit/test/horriblebindingbug.pit @@ -0,0 +1,6 @@ +(defun! broken (ops) nil) +(defun! test (ops) + (let ((oldops ops)) + (broken 'foo) + (assert! 'horriblebindingbug oldops ops))) +(test '(1 2 3)) diff --git a/pit/test/int.pit b/pit/test/int.pit deleted file mode 100644 index 65646af..0000000 --- a/pit/test/int.pit +++ /dev/null @@ -1 +0,0 @@ -(print! 0x10) diff --git a/pit/test/loadpath.pit b/pit/test/loadpath.pit deleted file mode 100644 index 5f8bcf8..0000000 --- a/pit/test/loadpath.pit +++ /dev/null @@ -1,2 +0,0 @@ -;; (setq! *load-path* (list "test/")) -(load! "test.pit") \ No newline at end of file diff --git a/pit/test/nonbroken.pit b/pit/test/nonbroken.pit deleted file mode 100644 index 350f64f..0000000 --- a/pit/test/nonbroken.pit +++ /dev/null @@ -1,2 +0,0 @@ -(+ 1 - (fwefwfwfwe 1 1)) diff --git a/pit/test/recurse.pit b/pit/test/recurse.pit deleted file mode 100644 index 8e1f784..0000000 --- a/pit/test/recurse.pit +++ /dev/null @@ -1,5 +0,0 @@ -(defun! foo () - (print! 'hi) - (foo)) - -(foo) \ No newline at end of file diff --git a/pit/test/struct.pit b/pit/test/struct.pit deleted file mode 100644 index 9e35654..0000000 --- a/pit/test/struct.pit +++ /dev/null @@ -1,11 +0,0 @@ -(defstruct! foo - x - y - z) - -(setq! x (foo/new :y 10 :x 5 :z 111)) -(print! x) -(print! (foo/get-y x)) -(foo/set-y! x 42) -(print! (foo/get-y x)) -(print! (foo/get-z x)) diff --git a/pit/test/test.pit b/pit/test/test.pit deleted file mode 100644 index ef13abb..0000000 --- a/pit/test/test.pit +++ /dev/null @@ -1,22 +0,0 @@ -(print! (list/map (lambda (x) (+ x 1)) (list 1 2 3 4 5))) -(print! (eval! '(cons 1 2))) -(defun! say-hi () - (princ! "hello computer")) -(say-hi) -(setq! counter 42) -(let ((counter 0)) - (print! counter) - (fset! 'count (lambda () (setq! counter (+ counter 1)))) - (fset! 'query (lambda () counter))) -(print! (count)) (print! (query)) -(print! (count)) (print! (query)) -(defun! bar (x & xs) - (print! x) - (print! xs)) -(bar 1 2 3 4 5) -(defun! baz (& kwargs) - (print! kwargs) - (let ((foo (plist/get :foo kwargs)) - (bar (plist/get :bar kwargs))) - bar)) -(print! (baz :foo 10 :bar 5 :baz 3)) diff --git a/pit/test/test10.pit b/pit/test/test10.pit deleted file mode 100644 index 0eea605..0000000 --- a/pit/test/test10.pit +++ /dev/null @@ -1,5 +0,0 @@ -(list/find - (lambda (y) - (and (eq? (list/len y) 3) - (list/all? (lambda (x) (equal? x 2)) y))) - '((1 2 3) (2 2 2 2) (2 3 4) (2 2 2))) \ No newline at end of file diff --git a/pit/test/test11.pit b/pit/test/test11.pit deleted file mode 100644 index 83d4816..0000000 --- a/pit/test/test11.pit +++ /dev/null @@ -1,4 +0,0 @@ -(print! 'here) -(list/foldl '+ 0 '(1 2 3)) -(print! 'there) -(print! (list/foldl '+ 0 '(1 2 3))) \ No newline at end of file diff --git a/pit/test/test2.pit b/pit/test/test2.pit deleted file mode 100644 index a86f8d2..0000000 --- a/pit/test/test2.pit +++ /dev/null @@ -1 +0,0 @@ -(print! "hello from test2") diff --git a/pit/test/test3.pit b/pit/test/test3.pit deleted file mode 100644 index 1964242..0000000 --- a/pit/test/test3.pit +++ /dev/null @@ -1,7 +0,0 @@ -(let ((bs (bs/new!))) - (print! bs) - ;; (bs/grow! 1 bs) - (bs/write8! bs 0 67) - (bs/spit! "test3.bin" bs) - ;; (bs/delete! bs) - ) diff --git a/pit/test/test4.pit b/pit/test/test4.pit deleted file mode 100644 index ef8e04c..0000000 --- a/pit/test/test4.pit +++ /dev/null @@ -1,6 +0,0 @@ -(print! - (or - (case 'baz - (foo 1) - (bar 2)) - 3)) \ No newline at end of file diff --git a/pit/test/test5.pit b/pit/test/test5.pit deleted file mode 100644 index 2ad3675..0000000 --- a/pit/test/test5.pit +++ /dev/null @@ -1,6 +0,0 @@ -(defun! foo (x) - (if (equal? 0 (% x 10000)) - (print! x)) - (foo (+ x 1))) - -(foo 0) \ No newline at end of file diff --git a/pit/test/test6.pit b/pit/test/test6.pit deleted file mode 100644 index cb04f22..0000000 --- a/pit/test/test6.pit +++ /dev/null @@ -1,6 +0,0 @@ -(print! - ((case 'baz - (foo (lambda (x) (+ x 1))) - (bar (lambda (x) (+ x 2)))) - 3)) - \ No newline at end of file diff --git a/pit/test/test7.pit b/pit/test/test7.pit deleted file mode 100644 index 48d2c2c..0000000 --- a/pit/test/test7.pit +++ /dev/null @@ -1 +0,0 @@ -(print! (list/map (lambda (x) (+ x 1)) '(1 2 3))) \ No newline at end of file diff --git a/pit/test/test8.pit b/pit/test/test8.pit deleted file mode 100644 index 3b41d7a..0000000 --- a/pit/test/test8.pit +++ /dev/null @@ -1,2 +0,0 @@ -(defun! foo (x) (+ x 1)) -(foo 2) \ No newline at end of file diff --git a/pit/test/test9.pit b/pit/test/test9.pit deleted file mode 100644 index daf1686..0000000 --- a/pit/test/test9.pit +++ /dev/null @@ -1,2 +0,0 @@ -(defun! foo (x) x) -(foo 1) \ No newline at end of file diff --git a/pit/test/thebug.pit b/pit/test/thebug.pit deleted file mode 100644 index ad87bd7..0000000 --- a/pit/test/thebug.pit +++ /dev/null @@ -1,9 +0,0 @@ -(defun! foo (x) - (lambda (y) - (+ x y))) - -(setq! bar (foo 10)) -(setq! baz (foo 100)) - -(print! (funcall bar 4)) - diff --git a/pit/test/thebug2.pit b/pit/test/thebug2.pit deleted file mode 100644 index 2376ff8..0000000 --- a/pit/test/thebug2.pit +++ /dev/null @@ -1,13 +0,0 @@ - -(setq! z 40) -(setq! f - (lambda (x) - (lambda (y) - (lambda (w) - (+ - (funcall (lambda (z) (+ x y z)) 3) - w - z))))) -(let ((z 20)) - (print! (funcall (funcall (funcall f 1) 2) 3))) - diff --git a/pit/test/x86.pit b/pit/test/x86.pit deleted file mode 100644 index 2aa8d89..0000000 --- a/pit/test/x86.pit +++ /dev/null @@ -1,451 +0,0 @@ -(defun! x86/split16le (w) - "Split the 16-bit W16 into a little-endian list of 8-bit integers." - (list - (bitwise/and 0xff w) - (bitwise/and 0xff (bitwise/rshift w 8)))) - -(defun! x86/split32le (w) - "Split the 32-bit W32 into a little-endian list of 8-bit integers." - (list - (bitwise/and 0xff w) - (bitwise/and 0xff (bitwise/rshift w 8)) - (bitwise/and 0xff (bitwise/rshift w 16)) - (bitwise/and 0xff (bitwise/rshift w 24)))) - -(defun! x86/register-1byte? (r) - "Return the register index for 1-byte register R." - (case r - (al 0) (cl 1) (dl 2) (bl 3) - (ah 4) (ch 5) (dh 6) (bh 7) - (r8b 8) (r9b 9) (r10b 10) (r11b 11) - (r12b 12) (r13b 13) (r14b 14) (r15b 15))) - -(defun! x86/register-2byte? (r) - "Return the register index for 2-byte register R." - (case r - (ax 0) (cx 1) (dx 2) (bx 3) - (sp 4) (bp 5) (si 6) (di 7) - (r8w 8) (r9w 9) (r10w 10) (r11w 11) - (r12w 12) (r13w 13) (r14w 14) (r15w 15))) - -(defun! x86/register-4byte? (r) - "Return the register index for 4-byte register R." - (case r - (eax 0) (ecx 1) (edx 2) (ebx 3) - (esp 4) (ebp 5) (esi 6) (edi 7) - (r8d 8) (r9d 9) (r10d 10) (r11d 11) - (r12d 12) (r13d 13) (r14d 14) (r15d 15))) - -(defun! x86/register-8byte? (r) - "Return the register index for 8-byte register R." - (case r - (rax 0) (rcx 1) (rdx 2) (rbx 3) - (rsp 4) (rbp 5) (rsi 6) (rdi 7) - (r8 8) (r9 9) (r10 10) (r11 11) - (r12 12) (r13 13) (r14 14) (r15 15))) - -(defun! x86/register? (r) - "Return the register index of R." - (or - (x86/register-1byte? r) - (x86/register-2byte? r) - (x86/register-4byte? r) - (x86/register-8byte? r))) - -(defun! x86/register-extended? (r) - "Return non-nil if R is an extended register." - (list/contains? r - '( r8b r9b r10b r11b r12b r13b r14b r15b - r8w r9w r10w r11w r12w r13w r14w r15w - r8d r9d r10d r11d r12d r13d r14d r15d - r8 r9 r10 r11 r12 r13 r14 r15))) - -(defun! x86/integer-fits-in-bits? (bits x) - "Determine if X fits in BITS." - (if (integer? x) - (let ((leftover (bitwise/rshift x bits))) - (eq? leftover 0)))) -(defun! x86/operand-immediate-fits? (sz x) - "Determine if immediate operand X fits in SZ." - (let - ((bits - (or - (case sz - ("b" 8) ("c" 16) ("d" 32) ("i" 16) - ("j" 32) ("q" 64) ("v" 64) ("w" 16) - ("y" 64) ("z" 32)) - (error! "unknown operand pattern size")))) - (x86/integer-fits-in-bits? bits x))) - -(defun! x86/operand-register-fits? (sz r) - "Determine if register operand R fits in SZ." - (case sz - ("b" (x86/register-1byte? r)) - ("c" (or (x86/register-1byte? r) (x86/register-2byte? r))) - ("d" (x86/register-4byte? r)) - ("i" (x86/register-2byte? r)) - ("j" (x86/register-4byte? r)) - ("q" (x86/register-8byte? r)) - ("v" (or (x86/register-2byte? r) (x86/register-4byte? r) (x86/register-8byte? r))) - ("w" (x86/register-2byte? r)) - ("y" (or (x86/register-4byte? r) (x86/register-8byte? r))) - ("z" (or (x86/register-2byte? r) (x86/register-4byte? r))))) - -(defun! x86/memory-operand-base (m) - (and - (eq? (car m) 'mem) - (car (cdr m)))) -(defun! x86/memory-operand-off (m) - (and - (eq? (car m) 'mem) - (or (car (cdr (cdr m))) 0))) - -(defun! x86/operand-memory-location? (op) - "Return non-nil if OP represents a memory location." - (let ( (base (x86/memory-operand-base op)) - (off (x86/memory-operand-off op))) - (and - (or (x86/register-4byte? base) (x86/register-8byte? base)) - (integer? off)))) - -(defun! x86/operand-match? (pat op) - "Determine if operand OP matches PAT." - (cond - ((symbol? pat) (eq? pat op)) - ((cons? pat) (list/contains? op pat)) - ((bytes? pat) - (let ( (loc (bytes/range 0 1 pat)) - (sz (bytes/range 1 (bytes/len pat) pat))) - (cond - ((or (equal? loc "I") (equal? loc "J")) (x86/operand-immediate-fits? sz op)) - ((or (equal? loc "G") (equal? loc "R")) (x86/operand-register-fits? sz op)) - ((equal? loc "M") (x86/operand-memory-location? op)) - ((equal? loc "E") - (or (x86/operand-register-fits? sz op) (x86/operand-memory-location? op))) - (t (error! "unknown operand pattern location"))))))) - -(defun! x86/operand-size (op) - "Return the minimum power-of-2 size in bytes that contains OP." - (cond - ((symbol? op) - (cond - ((x86/register-1byte? op) 1) - ((x86/register-2byte? op) 2) - ((x86/register-4byte? op) 4) - ((x86/register-8byte? op) 8) - (t (error! "attempted to take size of unknown register")))) - ((integer? op) - (cond - ((x86/integer-fits-in-bits? 8 op) 1) - ((x86/integer-fits-in-bits? 16 op) 2) - ((x86/integer-fits-in-bits? 32 op) 4) - ((x86/integer-fits-in-bits? 64 op) 8) - (t (error! "attempted to take size of too-large immediate")))) - ((x86/operand-memory-location? op) 1) - (t (error! "attempted to take size of unknown operand")))) - -(defstruct! x86/ins - operand-size-prefix - address-size-prefix - rex-w - rex-r - rex-x - rex-b - opcode - modrm-mod - modrm-reg - modrm-rm - disp ;; pair of size and value - imm ;; pair of size and value - ) - -(defun! x86/ins-bytes (ins) - "Return a list of bytes encoding INS." - (let ( (opcode (x86/ins/get-opcode ins)) - (rex-w (x86/ins/get-rex-w ins)) - (rex-r (x86/ins/get-rex-r ins)) - (rex-x (x86/ins/get-rex-x ins)) - (rex-b (x86/ins/get-rex-b ins)) - (modrm-mod (x86/ins/get-modrm-mod ins)) - (modrm-reg (x86/ins/get-modrm-reg ins)) - (modrm-rm (x86/ins/get-modrm-rm ins)) - (disp (x86/ins/get-disp ins)) - (imm (x86/ins/get-imm ins))) - (list/append - (if (x86/ins/get-operand-size-prefix ins) '(0x66)) - (if (x86/ins/get-address-size-prefix ins) '(0x67)) - (if (or rex-w rex-r rex-x rex-b) - (list - (bitwise/or - 0x40 - (if rex-w 0b1000 0) - (if rex-r 0b0100 0) - (if rex-x 0b0010 0) - (if rex-b 0b0001 0)))) - (cond - ((not opcode) (error! "no opcode for instruction")) - ((cons? opcode) opcode) - ((integer? opcode) (list opcode)) - (t (error! "malformed opcode for instruction"))) - (if (or modrm-mod modrm-reg modrm-rm) - (list - (bitwise/or - (bitwise/lshift (or modrm-mod 0) 6) - (bitwise/lshift (or modrm-reg 0) 3) - (or modrm-rm 0)))) - (if disp - (cond - ((eq? (car disp) 1) (list (cdr disp))) - ((eq? (car disp) 4) (x86/split32le (cdr disp))) - (t (error! "malformed displacement for instruction")))) - (if imm - (cond - ((eq? (car imm) 1) (list (cdr imm))) - ((eq? (car imm) 2) (x86/split16le (cdr imm))) - ((eq? (car imm) 4) (x86/split32le (cdr imm))) - (t (error! "malformed immediate for instruction"))))))) - -(defun! x86/instruction-update-sizes (ins ops default-size) - "Update INS to account for the sizes of OPS. -DEFAULT-SIZE is the default operand size." - (let ((defsz (or default-size 4))) - (if (> (list/len ops) 0) - (let ((regs (list/uniq (list/map 'x86/operand-size (list/filter 'x86/register? ops))))) - (if (> (list/len regs) 1) - (error! "invalid mix of register sizes in operands")) - (let ((sz (if (eq? (list/len regs) 0) defsz (car regs)))) - (cond - ((eq? sz 1) nil) - ((eq? defsz sz) nil) - ((and (not (eq? defsz 2)) (eq? sz 2)) (x86/ins/set-operand-size-prefix! ins t)) - ((and (not (eq? defsz 8)) (eq? sz 8)) (x86/ins/set-rex-w! ins t)) - (t (error! "unable to encode operands with default size"))) - sz))))) - -(defun! x86/instruction-update-operand (esz ins pat op) - "Update INS to account for an operand OP according to PAT. -The effective operand size is ESZ." - (cond - ((bytes? pat) - (let ((loc (bytes/range 0 1 pat))) - (cond - ((equal? loc "I") - (let ((immsz (if (>= esz 4) 4 esz))) - (if (not (x86/integer-fits-in-bits? (* 8 immsz) op)) - (error! "Immediate too large" op)) - (x86/ins/set-imm! ins (cons immsz op)))) - ((equal? loc "J") - (let ((immsz (if (eq? esz 1) 1 4))) - (if (not (x86/integer-fits-in-bits? (* 8 immsz) op)) - (error! "jump displacement too large")) - (x86/ins/set-disp! ins (cons immsz op)))) - ((equal? loc "G") - (x86/ins/set-modrm-reg! ins - (or (x86/register? op) (error "Invalid register: %s" op)))) - ((or (equal? loc "R") (and (equal? loc "E") (x86/register? op))) - (x86/ins/set-modrm-mod! ins 0b11) - (x86/ins/set-modrm-rm! ins - (or (x86/register? op) (error "Invalid register: %s" op)))) - ((or (equal? loc "M") (and (equal? loc "E") (x86/operand-memory-location? op))) - (let ( (base (x86/memory-operand-base op)) - (off (x86/memory-operand-off op))) - (cond - ((eq? base 'eip) - (x86/ins/set-modrm-rm! ins 0b101) - (x86/ins/set-modrm-mod! ins 0b00) - (x86/ins/set-disp! ins (cons 4 off)) - (x86/ins/set-address-size-prefix! ins t)) - ((eq? base 'rip) - (x86/ins/set-modrm-rm! ins 0b101) - (x86/ins/set-modrm-mod! ins 0b00) - (x86/ins/set-disp! ins (cons 4 off))) - (t - (x86/ins/set-modrm-rm! ins - (or - (x86/register-4byte? base) - (x86/register-8byte? base) - (error! "invalid base register"))) - (if (x86/register-4byte? base) - (x86/ins/set-address-size-prefix! ins t)) - (cond - ((x86/integer-fits-in-bits? 8 off) - (x86/ins/set-disp! ins (cons 1 off)) - (x86/ins/set-modrm-mod! ins 0b01)) - ((x86/integer-fits-in-bits? 32 off) - (x86/ins/set-disp! ins (cons 4 off)) - (x86/ins/set-modrm-mod! ins 0b10)) - (t (error! "invalid offset"))))))) - (t (error! "invalid operand location code"))))))) - -(defun! x86/default-instruction-handler (opcode & kwargs) - "Return an instruction handler for OPCODE. -The instruction handler will run POSTHOOK on the instruction at the end. -DEFAULT-SIZE is the default operand size." - (let ( (posthook (plist/get :posthook kwargs)) - (default-size (plist/get :default-size kwargs))) - (lambda (pats ops) - (let ((ret (x86/ins/new :opcode opcode))) - (let ((esz - (or (x86/instruction-update-sizes ret ops default-size) - (error! "malformed size for operands")))) - (list/zip-with - (lambda (it other) - (x86/instruction-update-operand esz ret it other)) - pats - ops)) - (if posthook - (funcall posthook ret ops)) - ret)))) - -(defun! x86/instruction-handler-jcc (opcode immsz) - "Return an instruction handler for a Jcc instruction at OPCODE. -IMMSZ is the size of the displacement from RIP." - (lambda (_pats ops) - (let ((ret (x86/ins/new :opcode opcode))) - (x86/ins/set-disp! ret (cons immsz (car ops))) - ret))) - -(defun! x86/generate-handlers-arith (opbase group1reg) - "Return handlers for an arithmetic mnemonic starting at OPBASE. -The REG value in ModR/M is indicated by GROUP1REG." - (list - (cons '("Eb" "Gb") (x86/default-instruction-handler (+ opbase 0))) - (cons '("Ev" "Gv") (x86/default-instruction-handler (+ opbase 1))) - (cons '("Gb" "Eb") (x86/default-instruction-handler (+ opbase 2))) - (cons '("Gv" "Ev") (x86/default-instruction-handler (+ opbase 3))) - (cons '(al "Ib") (x86/default-instruction-handler (+ opbase 4))) - (cons '((ax eax rax) "Iz") (x86/default-instruction-handler (+ opbase 5))) - (cons '("Eb" "Ib") - (x86/default-instruction-handler 0x80 - :posthook (lambda (ins _) (x86/ins/set-modrm-reg! ins group1reg)))) - (cons '("Ev" "Iz") - (x86/default-instruction-handler 0x81 - :posthook (lambda (ins _) (x86/ins/set-modrm-reg! ins group1reg)))) - (cons '("Ev" "Ib") - (x86/default-instruction-handler 0x83 - :posthook (lambda (ins _) (setf (x86/ins-modrm-reg ins) group1reg)))))) - -(setq! x86/registers-+reg-base - '( (+rb . (al cl dl bl ah ch dh bh)) - (+rw . (ax cx dx bx sp bp si di)) - (+rd . (eax ecx edx ebx esp ebp esi edi)) - (+rq . (rax rcx rdx rbx rsp rbp rsi rdi)))) -(setq! x86/registers-+reg-extended - '( (+rw . (r8b r9b r10b r11b r12b r13b r14b r15b)) - (+rw . (r8w r9w r10w r11w r12w r13w r14w r15w)) - (+rd . (r8d r9d r10d r11d r12d r13d r14d r15d)) - (+rq . (r8 r9 r10 r11 r12 r13 r14 r15)))) -(defun! x86/generate-handlers-opcode-+reg (opbase extraops addends & args) - "Generate handlers for a family of opcodes that uses the +reg encoding. -OPBASE is the base opcode. -EXTRAOPS are additional operands after the register operand. -ADDENDS is a list of symbols like +rw, +rq etc. that denote allowed registers. -ARGS are passed verbatim to `u/x86/default-instruction-handler." - (list/map - (lambda (it) - (let ( (abase (list/map (lambda (a) (list/nth it (alist/get a x86/registers-+reg-base))) addends)) - (aext (list/map (lambda (a) (list/nth it (alist/get a x86/registers-+reg-extended))) addends))) - (cons - (cons (list/append abase aext) extraops) - (apply 'x86/default-instruction-handler (cons (+ opbase it) args))))) - (list/iota 8))) - -(setq! - x86/mnemonic-table - (list - (cons 'add (x86/generate-handlers-arith 0x00 0)) - (cons 'or (x86/generate-handlers-arith 0x08 1)) - (cons 'adc (x86/generate-handlers-arith 0x10 2)) - (cons 'sbb (x86/generate-handlers-arith 0x18 3)) - (cons 'and (x86/generate-handlers-arith 0x20 4)) - (cons 'sub (x86/generate-handlers-arith 0x28 5)) - (cons 'xor (x86/generate-handlers-arith 0x30 6)) - (cons 'cmp (x86/generate-handlers-arith 0x38 7)) - (cons 'push - (x86/generate-handlers-opcode-+reg 0x50 '() '(+rw +rq) - :default-size 8 - :posthook (lambda (ins ops) (x86/ins/set-rex-b! ins (x86/register-extended? (car ops)))))) - (cons 'pop - (x86/generate-handlers-opcode-+reg 0x58 '() '(+rw +rq) - :default-size 8 - :posthook (lambda (ins ops) (x86/ins/set-rex-b! ins (x86/register-extended? (car ops)))))) - (list 'jo - (cons '("Jb") (x86/instruction-handler-jcc 0x70 1)) - (cons '("Jz") (x86/instruction-handler-jcc '(0x0f 0x80) 4))) - (list 'jno - (cons '("Jb") (x86/instruction-handler-jcc 0x71 1)) - (cons '("Jz") (x86/instruction-handler-jcc '(0x0f 0x81) 4))) - (list 'jb - (cons '("Jb") (x86/instruction-handler-jcc 0x72 1)) - (cons '("Jz") (x86/instruction-handler-jcc '(0x0f 0x82) 4))) - (list 'jnb - (cons '("Jb") (x86/instruction-handler-jcc 0x73 1)) - (cons '("Jz") (x86/instruction-handler-jcc '(0x0f 0x83) 4))) - (list 'jz - (cons '("Jb") (x86/instruction-handler-jcc 0x74 1)) - (cons '("Jz") (x86/instruction-handler-jcc '(0x0f 0x84) 4))) - (list 'jnz - (cons '("Jb") (x86/instruction-handler-jcc 0x75 1)) - (cons '("Jz") (x86/instruction-handler-jcc '(0x0f 0x85) 4))) - (list 'jbe - (cons '("Jb") (x86/instruction-handler-jcc 0x76 1)) - (cons '("Jz") (x86/instruction-handler-jcc '(0x0f 0x86) 4))) - (list 'jnbe - (cons '("Jb") (x86/instruction-handler-jcc 0x77 1)) - (cons '("Jz") (x86/instruction-handler-jcc '(0x0f 0x87) 4))) - (list 'js - (cons '("Jb") (x86/instruction-handler-jcc 0x78 1)) - (cons '("Jz") (x86/instruction-handler-jcc '(0x0f 0x88) 4))) - (list 'jns - (cons '("Jb") (x86/instruction-handler-jcc 0x79 1)) - (cons '("Jz") (x86/instruction-handler-jcc '(0x0f 0x89) 4))) - (list 'jp - (cons '("Jb") (x86/instruction-handler-jcc 0x7a 1)) - (cons '("Jz") (x86/instruction-handler-jcc '(0x0f 0x8a) 4))) - (list 'jnp - (cons '("Jb") (x86/instruction-handler-jcc 0x7b 1)) - (cons '("Jz") (x86/instruction-handler-jcc '(0x0f 0x8b) 4))) - (list 'jl - (cons '("Jb") (x86/instruction-handler-jcc 0x7c 1)) - (cons '("Jz") (x86/instruction-handler-jcc '(0x0f 0x8c) 4))) - (list 'jnl - (cons '("Jb") (x86/instruction-handler-jcc 0x7d 1)) - (cons '("Jz") (x86/instruction-handler-jcc '(0x0f 0x8d) 4))) - (list 'jle - (cons '("Jb") (x86/instruction-handler-jcc 0x7e 1)) - (cons '("Jz") (x86/instruction-handler-jcc '(0x0f 0x8e) 4))) - (list 'jnle - (cons '("Jb") (x86/instruction-handler-jcc 0x7f 1)) - (cons '("Jz") (x86/instruction-handler-jcc '(0x0f 0x8f) 4))) - (cons 'mov - (x86/generate-handlers-opcode-+reg 0xb0 '("Ib") '(+rb) - :posthook (lambda (ins ops) (x86/ins/set-rex-b! ins (x86/register-extended? (car ops)))))) - (cons 'mov - (x86/generate-handlers-opcode-+reg 0xb8 '("Iv") '(+rw +rd +rq) - :posthook (lambda (ins ops) (x86/ins/set-rex-b! ins (x86/register-extended? (car ops)))))) - (list 'jmp - (cons '("Ev") - (x86/default-instruction-handler 0xff - :default-size 8 - :posthook (lambda (ins _) (setf (u/x86/ins-modrm-reg ins) 4))))) - (list 'syscall - (cons '() (lambda (_ _) (x86/ins/new :opcode '(0x0f 0x05))))) - )) - -(defun! x86/asm (op) - "Assemble OP to an instruction." - (let ((mnem (car op)) (operands (cdr op))) - (let ((variants (or (alist/get mnem x86/mnemonic-table) (error! "unknown mnemonic")))) - (let ((v - (list/find - (lambda (it) - (and (eq? (list/len (car it)) (list/len operands)) - (list/all? (lambda (x) x) (list/zip-with 'x86/operand-match? (car it) operands)))) - variants))) - (if (and v (function? (cdr v))) - (funcall (cdr v) (car v) operands) - (error! "could not identify instruction")))))) - -(setq! test-ins (x86/asm '(syscall))) -(print! test-ins) -(print! (x86/ins-bytes test-ins)) diff --git a/pit/test/y.pit b/pit/test/y.pit deleted file mode 100644 index 5e9218b..0000000 --- a/pit/test/y.pit +++ /dev/null @@ -1,5 +0,0 @@ -(setq! Y - (lambda (f) - (funcall - (lambda (x) (funcall f (funcall x x))) - (lambda (x) (funcall f (funcall x x)))))) -- cgit v1.3.1