From 2c91a156c1f344d306da2f3f853e29f368877192 Mon Sep 17 00:00:00 2001 From: David Van Horn Date: Sat, 11 May 2024 10:01:36 -0400 Subject: [PATCH] Split a86 into own repo. --- a86/ast.rkt | 427 -------------------------------------------- a86/callback.rkt | 46 ----- a86/check-nasm.rkt | 39 ---- a86/interp.rkt | 293 ------------------------------ a86/main.rkt | 7 - a86/printer.rkt | 315 -------------------------------- a86/stepper.rkt | 42 ----- a86/test/errors.rkt | 31 ---- info.rkt | 2 +- 9 files changed, 1 insertion(+), 1201 deletions(-) delete mode 100644 a86/ast.rkt delete mode 100644 a86/callback.rkt delete mode 100644 a86/check-nasm.rkt delete mode 100644 a86/interp.rkt delete mode 100644 a86/main.rkt delete mode 100644 a86/printer.rkt delete mode 100644 a86/stepper.rkt delete mode 100644 a86/test/errors.rkt diff --git a/a86/ast.rkt b/a86/ast.rkt deleted file mode 100644 index 60076b2..0000000 --- a/a86/ast.rkt +++ /dev/null @@ -1,427 +0,0 @@ -#lang racket - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Guards - -;; These are used to guard the instruction constructors to reject bad inputs -;; with decent error messages. - -(define check:label-symbol - (λ (a x n) - (when (register? x) - (error n "cannot use register as label name; given ~v" x)) - (unless (symbol? x) - (error n "expects symbol; given ~v" x)) - (unless (label? x) - (error n "label names must conform to nasm restrictions")) - (values a x))) - -(define check:label-symbol+integer - (λ (a x c n) - (check:label-symbol x n) - (unless (integer? c) - (error n "expects integer constant; given ~v" c)) - (values a x c))) - -(define check:target - (λ (a x n) - (unless (or (symbol? x) (offset? x)); either register or label - (error n "expects symbol; given ~v" x)) - (values a x))) - -(define check:cmov - (λ (a a1 a2 n) - (unless (register? a1) - (error n "expects register; given ~v" a1)) - (unless (or (register? a2) (offset? a2)) - (error n "expects register or offset; given ~v" a2)) - (values a a1 a2))) - -(define check:arith - (λ (a a1 a2 n) - (unless (register? a1) - (error n "expects register; given ~v" a1)) - (unless (or (exact-integer? a2) (register? a2) (offset? a2)) - (error n "expects exact integer, register, or offset; given ~v" a2)) - (when (and (exact-integer? a2) (> (integer-length a2) 32)) - (error n "literal must not exceed 32-bits; given ~v (~v bits); go through a register instead" a2 (integer-length a2))) - (values a a1 a2))) - -(define check:register - (λ (a a1 n) - (unless (register? a1) - (error n "expects register; given ~v" a1)) - (values a a1))) - -(define check:src-dest - (λ (a a1 a2 n) - (unless (or (register? a1) (offset? a1)) - (error n "expects register or offset; given ~v" a1)) - (unless (or (register? a2) (offset? a2) (exact-integer? a2) (Const? a2)) - (error n "expects register, offset, exact integer, or defined constant; given ~v" a2)) - (when (and (offset? a1) (offset? a2)) - (error n "cannot use two memory locations; given ~v, ~v" a1 a2)) - (when (and (exact-integer? a2) (> (integer-length a2) 32)) - (error n "literal must not exceed 32-bits; given ~v (~v bits); go through a register instead" a2 (integer-length a2))) - (when (and (offset? a1) (exact-integer? a2)) - (error n "cannot use a memory locations and literal; given ~v, ~v; go through a register instead" a1 a2)) - (values a a1 a2))) - -(define check:mov - (λ (a a1 a2 n) - (unless (or (register? a1) (offset? a1)) - (error n "expects register or offset; given ~v" a1)) - (unless (or (register? a2) (offset? a2) (exact-integer? a2) (Const? a2)) - (error n "expects register, offset, exact integer, or defined constant; given ~v" a2)) - (when (and (offset? a1) (offset? a2)) - (error n "cannot use two memory locations; given ~v, ~v" a1 a2)) - (when (and (exact-integer? a2) (> (integer-length a2) 64)) - (error n "literal must not exceed 64-bits; given ~v (~v bits)" a2 (integer-length a2))) - (when (and (offset? a1) (exact-integer? a2)) - (error n "cannot use a memory locations and literal; given ~v, ~v; go through a register instead" a1 a2)) - (values a a1 a2))) - -(define check:shift - (λ (a a1 a2 n) - (unless (register? a1) - (error n "expects register; given ~v" a1)) - (unless (or (and (exact-integer? a2) (<= 0 a2 63)) - (eq? 'cl a2)) - (error n "expects exact integer in [0,63]; given ~v" a2)) - (values a a1 a2))) - -(define check:offset - (λ (a r i n) - (unless (or (register? r) (label? r)) - (error n "expects register or label as first argument; given ~v" r)) - (unless (exact-integer? i) - (error n "expects exact integer as second argument; given ~v" i)) - (values a r i))) - -(define check:push - (λ (a a1 n) - (unless (or (exact-integer? a1) (register? a1)) - (error n "expects exact integer or register; given ~v" a1)) - (when (and (exact-integer? a1) (> (integer-length a1) 32)) - (error n "literal must not exceed 32-bits; given ~v (~v bits); go through a register instead" a1 (integer-length a1))) - (values a a1))) - -(define check:lea - (λ (a dst x n) - (unless (or (register? dst) (offset? dst)) - (error n "expects register or offset; given ~v" dst)) - (unless (or (label? x) (offset? x) (exp? x)) - (error n "expects label, offset, or expression; given ~v" x)) - (values a dst x))) - -(define check:none - (λ (a n) (values a))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Comments - -(provide (struct-out %) - (struct-out %%) - (struct-out %%%) - Comment?) - -(struct Comment (str) - #:transparent - #:guard - (λ (s n) - (unless (string? s) - (error n "expects string; given ~v" s)) - s)) - -(struct % Comment () #:transparent) -(struct %% Comment () #:transparent) -(struct %%% Comment () #:transparent) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Instructions - -(require racket/struct) -(define current-annotation (make-parameter #f)) -(provide instruction-annotation current-annotation) - -(struct instruction (annotation)) - -(define-syntax (instruct stx) - (syntax-case stx () - [(instruct Name (x ...) guard) - (with-syntax ([Name? (datum->syntax stx (string->symbol (string-append (symbol->string (syntax->datum #'Name)) "?")))]) - #'(begin (provide Name Name?) - (define-match-expander Name - (lambda (stx) - (syntax-case stx () - [(_ elts (... ...)) - #'(%Name _ elts (... ...))])) - (lambda (stx) - (syntax-case stx () - [m (identifier? #'m) #'(λ (x ...) (%Name (current-annotation) x ...))] - [(m x ...) #'(%Name (current-annotation) x ...)]))) - (struct %Name instruction (x ...) - #:reflection-name 'Name - #:transparent - #:guard guard - #:methods gen:equal+hash - [(define equal-proc (λ (i1 i2 equal?) - (equal? (struct->vector i1) - (struct->vector i2)))) - (define hash-proc (λ (i hash) (hash (struct->vector i)))) - (define hash2-proc (λ (i hash) (hash (struct->vector i))))] - - #:property prop:custom-print-quotable 'never - #:methods gen:custom-write - [(define write-proc - (instr-print 'Name) - #;(make-constructor-style-printer - (lambda (obj) 'Name) - (lambda (obj) - (rest (rest (vector->list (struct->vector obj)))))))]) - (define Name? %Name?)))])) - -(define (instr-print type) - (lambda (instr port mode) - (if (number? mode) - (write-string "(" port) - (write-string "#(struct:" port)) - (write-string (symbol->string type) port) - (let ([recur (case mode - [(#t) write] - [(#f) display] - [else (lambda (p port) (print p port mode))])]) - (for-each (lambda (e) - (write-string " " port) - (recur e port)) - (rest (rest (vector->list (struct->vector instr)))))) - (if (number? mode) - (write-string ")" port) - (write-string ")" port)))) - - -(instruct Text () check:none) -(instruct Data () check:none) - -(instruct Global (x) check:label-symbol) -(instruct Label (x) check:label-symbol) -(instruct Call (x) check:target) -(instruct Ret () check:none) -(instruct Mov (dst src) check:mov) -(instruct Add (dst src) check:arith) -(instruct Sub (dst src) check:arith) -(instruct Cmp (a1 a2) check:src-dest) -(instruct Jmp (x) check:target) -(instruct Jz (x) check:target) -(instruct Jnz (x) check:target) -(instruct Je (x) check:target) -(instruct Jne (x) check:target) -(instruct Jl (x) check:target) -(instruct Jle (x) check:target) -(instruct Jg (x) check:target) -(instruct Jge (x) check:target) -(instruct Jo (x) check:target) -(instruct Jno (x) check:target) -(instruct Jc (x) check:target) -(instruct Jnc (x) check:target) -(instruct Cmovz (dst src) check:cmov) -(instruct Cmovnz (dst src) check:cmov) -(instruct Cmove (dst src) check:cmov) -(instruct Cmovne (dst src) check:cmov) -(instruct Cmovl (dst src) check:cmov) -(instruct Cmovle (dst src) check:cmov) -(instruct Cmovg (dst src) check:cmov) -(instruct Cmovge (dst src) check:cmov) -(instruct Cmovo (dst src) check:cmov) -(instruct Cmovno (dst src) check:cmov) -(instruct Cmovc (dst src) check:cmov) -(instruct Cmovnc (dst src) check:cmov) -(instruct And (dst src) check:src-dest) -(instruct Or (dst src) check:src-dest) -(instruct Xor (dst src) check:src-dest) -(instruct Sal (dst i) check:shift) -(instruct Sar (dst i) check:shift) -(instruct Shl (dst i) check:shift) -(instruct Shr (dst i) check:shift) -(instruct Push (a1) check:push) -(instruct Pop (a1) check:register) -(instruct Pushf () check:none) -(instruct Popf () check:none) -(instruct Lea (dst x) check:lea) -(instruct Not (x) check:register) -(instruct Div (den) check:register) - -(instruct Offset (r i) check:offset) ;; May need to make this not an instruction -(instruct Extern (x) check:label-symbol) - -(instruct Equ (x v) check:label-symbol+integer) -(instruct Const (x) check:label-symbol) - -;; IMPROVE: do more checking -(instruct Db (x) (lambda (a x n) (values a x))) -(instruct Dw (x) (lambda (a x n) (values a x))) -(instruct Dd (x) (lambda (a x n) (values a x))) -(instruct Dq (x) (lambda (a x n) (values a x))) - -(provide (struct-out Plus)) -(struct Plus (e1 e2) #:transparent) - -(provide exp?) -(define (exp? x) - (or (Offset? x) - (and (Plus? x) - (exp? (Plus-e1 x)) - (exp? (Plus-e2 x))) - (symbol? x) - (integer? x))) - -(provide offset? register? label? 64-bit-integer? 32-bit-integer?) - -(define offset? Offset?) - -(define (register? x) - (and (memq x '(cl eax rax rbx rcx rdx rbp rsp rsi rdi r8 r9 r10 r11 r12 r13 r14 r15)) - #t)) - -(define (64-bit-integer? x) - (and (exact-integer? x) - (<= (integer-length x) 64))) - -(define (32-bit-integer? x) - (and (exact-integer? x) - (<= (integer-length x) 32))) - -(define (label? x) - (and (symbol? x) - (nasm-label? x) - (not (register? x)))) - -(provide (rename-out [a86:instruction? instruction?])) -(define (a86:instruction? x) - (or (instruction? x) - (Comment? x))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Instruction sequencing and program error checking - -(provide/contract - [seq (-> (or/c a86:instruction? (listof a86:instruction?)) ... - (listof a86:instruction?))] - [prog (-> (or/c a86:instruction? (listof a86:instruction?)) ... - (listof a86:instruction?))]) - -;; (U Instruction Asm) ... -> Asm -;; Convenient for sequencing instructions or groups of instructions -(define (seq . xs) - (foldr (λ (x is) - (if (list? x) - (append x is) - (cons x is))) - '() - xs)) - -;; (U Instruction Asm) ... -> Asm -;; Construct a "program", does some global well-formedness checking to help -;; prevent confusing error messages as the nasm level -(define (prog . xs) - (let ((p (apply seq xs))) - (check-unique-label-decls p) - (check-label-targets-declared p) - (check-has-initial-label p) - (check-initial-label-global p) - ;; anything else? - p)) - -;; Asm -> Void -(define (check-unique-label-decls xs) - (let ((r (check-duplicates (label-decls xs)))) - (when r - (error 'prog "duplicate label declaration found: ~v" r)))) - -;; Asm -> (Listof Symbol) -;; Compute all declared label names -(define (label-decls asm) - (match asm - ['() '()] - [(cons (Label s) asm) - (cons s (label-decls asm))] - [(cons (Extern s) asm) - (cons s (label-decls asm))] - [(cons _ asm) - (label-decls asm)])) - -;; Symbol -> Boolean -(define (nasm-label? s) - (regexp-match #rx"^[a-zA-Z._?][a-zA-Z0-9_$#@~.?]*$" (symbol->string s))) - -;; Asm -> (Listof Symbol) -;; Compute all uses of label names -(define (label-uses asm) - (match asm - ['() '()] - [(cons (Jmp (? label? s)) asm) - (cons s (label-uses asm))] - [(cons (Je (? label? s)) asm) - (cons s (label-uses asm))] - [(cons (Jne (? label? s)) asm) - (cons s (label-uses asm))] - [(cons (Jg (? label? s)) asm) - (cons s (label-uses asm))] - [(cons (Jge (? label? s)) asm) - (cons s (label-uses asm))] - [(cons (Jl (? label? s)) asm) - (cons s (label-uses asm))] - [(cons (Jle (? label? s)) asm) - (cons s (label-uses asm))] - [(cons (Call (? label? s)) asm) - (cons s (label-uses asm))] - [(cons (Lea _ (? label? s)) asm) - (cons s (label-uses asm))] - [(cons _ asm) - (label-uses asm)])) - - -;; Asm -> Void -(define (check-label-targets-declared asm) - (let ((ds (apply set (label-decls asm))) - (us (apply set (label-uses asm)))) - - (let ((undeclared (set-subtract us ds))) - (unless (set-empty? undeclared) - (error 'prog "undeclared labels found: ~v" (set->list undeclared)))))) - -;; Asm -> Void -(define (check-has-initial-label asm) - (unless (findf Label? asm) - (error 'prog "no initial label found"))) - -;; Asm -> Void -(define (check-initial-label-global asm) - (match (findf Label? asm) - [(Label init) - (unless (member init (map (lambda (i) (match i [(Global l) l])) - (filter Global? asm))) - (error 'prog "initial label undeclared as global: ~v" init))])) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Symbol to Label - -;; Symbol -> Label -;; Produce a symbol that is a valid Nasm label -;; Guarantees that (eq? s1 s2) <=> (eq? (symbol->label s1) (symbol->label s1)) -(provide symbol->label) -(define (symbol->label s) - (string->symbol - (string-append - "label_" - (list->string - (map (λ (c) - (if (or (char<=? #\a c #\z) - (char<=? #\A c #\Z) - (char<=? #\0 c #\9) - (memq c '(#\_ #\$ #\# #\@ #\~ #\. #\?))) - c - #\_)) - (string->list (symbol->string s)))) - "_" - (number->string (eq-hash-code s) 16)))) diff --git a/a86/callback.rkt b/a86/callback.rkt deleted file mode 100644 index c7ff5af..0000000 --- a/a86/callback.rkt +++ /dev/null @@ -1,46 +0,0 @@ -#lang racket -;; based on racket/draw/unsafe/callback -(provide guard-foreign-escape) -(require ffi/unsafe - ffi/unsafe/atomic) - -(define callback-atomic? (eq? 'chez-scheme (system-type 'vm))) - -(define-syntax-rule (guard-foreign-escape e0 e ...) - (call-guarding-foreign-escape (lambda () e0 e ...))) - -(define (call-guarding-foreign-escape thunk) - (if callback-atomic? - ((call-with-c-return - (lambda () - (with-handlers ([(lambda (x) #t) - (lambda (x) - ;; Deliver an exception re-raise after returning back - ;; from `call-with-c-return`: - (lambda () - (when (in-atomic-mode?) - (end-atomic)) ; error happened during atomic mode - ;(enable-interrupts) ; ... with interrupts disabled - (void/reference-sink call-with-c-return-box) - (raise x)))]) - (let ([vs (call-with-values thunk list)]) - ;; Deliver successful values after returning back from - ;; `call-with-c-return`: - (lambda () - (void/reference-sink call-with-c-return-box) - (apply values vs))))))) - (thunk))) - -(define call-with-c-return-box (box #f)) - -;; `call-with-c-return` looks like a foreign function, due to a cast -;; to and from a callback, so returning from `call-with-c-return` will -;; pop and C frame stacks (via longjmp internally) that were pushed -;; since `call-with-c-return` was called. -(define call-with-c-return - (and callback-atomic? - (cast (lambda (thunk) (thunk)) - (_fun #:atomic? #t - #:keep call-with-c-return-box - _racket -> _racket) - (_fun _racket -> _racket)))) \ No newline at end of file diff --git a/a86/check-nasm.rkt b/a86/check-nasm.rkt deleted file mode 100644 index aec72cc..0000000 --- a/a86/check-nasm.rkt +++ /dev/null @@ -1,39 +0,0 @@ -#lang racket -(provide check-nasm-available) -(require racket/gui/dynamic) - -(define nasm-msg - #<path "/") (find-system-path 'orig-dir))) - -(define (drracket?) - (gui-available?)) - -(define (check-nasm-available) - (unless (parameterize ([current-output-port (open-output-string)] - [current-error-port (open-output-string)]) - (system "nasm -v")) - (error (format nasm-msg - (getenv "PATH") - (if (and (drracket?) (macos?) (launched-with-finder?)) macosx-msg ""))))) \ No newline at end of file diff --git a/a86/interp.rkt b/a86/interp.rkt deleted file mode 100644 index 295876d..0000000 --- a/a86/interp.rkt +++ /dev/null @@ -1,293 +0,0 @@ -#lang racket -(provide/contract - [current-objs (parameter/c (listof path-string?))] - [asm-interp (-> (listof instruction?) any/c)] - [asm-interp/io (-> (listof instruction?) string? any/c)]) - -(define-logger a86) - -(require "printer.rkt" "ast.rkt" "callback.rkt" "check-nasm.rkt" - (rename-in ffi/unsafe [-> _->])) -(require (submod "printer.rkt" private)) - -;; Check NASM availability when required to fail fast. -(check-nasm-available) - -(define *debug*? - (let ((r (getenv "PLTSTDERR"))) - (and r - (string=? r "info@a86")))) - -;; Assembly code is linked with object files in this parameter -(define current-objs - (make-parameter '())) - -;; Asm -> Value -;; Interpret (by assemblying, linking, and loading) x86-64 code -;; Assume: entry point is "entry" -(define (asm-interp a) - (asm-interp/io a #f)) - -(define fopen - (get-ffi-obj "fopen" (ffi-lib #f) (_fun _path _string/utf-8 _-> _pointer))) - -(define fflush - (get-ffi-obj "fflush" (ffi-lib #f) (_fun _pointer _-> _void))) - -(define fclose - (get-ffi-obj "fclose" (ffi-lib #f) (_fun _pointer _-> _void))) - -(define fmt (if (eq? (system-type 'os) 'macosx) 'macho64 'elf64)) - -;; WARNING: The heap is re-used, so make sure you're done with it -;; before calling asm-interp again -(define *heap* - ; IMPROVE ME: hard-coded heap size - (malloc _int64 20000 'raw)) - - -;; Integer64 -> String -(define (int64->binary-string n) - (format "#b~a" - (~r n #:base 2 #:min-width 64 #:pad-string "0"))) - -;; Integer64 -> String -(define (int64->octal-string n) - (format "#o~a" - (~r n #:base 8 #:min-width 22 #:pad-string "0"))) - -;; Integer64 -(define (int64->hex-string n) - (format "#x~a" - (~r n #:base 16 #:min-width 16 #:pad-string "0"))) - -(define (show-state . regs) - (format "\n~a" - (map (lambda (r v) - (format "(~a ~a)" r (int64->hex-string v))) - '(rax rbx rcx rdx rbp rsp rsi rdi - r8 r9 r10 r11 r12 r13 r14 r15 instr flags) - regs))) - -;; Asm String -> (cons Value String) -;; Like asm-interp, but uses given string for input and returns -;; result with string output -(define (asm-interp/io a input) - - (log-a86-info (~v a)) - - (define t.s (make-temporary-file "nasm~a.s")) - (define t.o (path-replace-extension t.s #".o")) - (define t.so (path-replace-extension t.s #".so")) - (define t.in (path-replace-extension t.s #".in")) - (define t.out (path-replace-extension t.s #".out")) - - (with-output-to-file t.s - #:exists 'truncate - (λ () - (parameterize ((current-shared? #t)) - (asm-display (if *debug*? - (debug-transform a) - a))))) - - (nasm t.s t.o) - (ld t.o t.so) - - (define libt.so (ffi-lib t.so)) - - (define init-label - (match (findf Label? a) - [(Label l) l] - [_ (error "no initial label found")])) - - (define entry - (get-ffi-obj init-label libt.so (_fun _pointer _-> _int64))) - - ;; install our own `error_handler` procedure to prevent `exit` calls - ;; from interpreted code bringing down the parent process. All of - ;; these hooks into the runtime need a better API and documentation, - ;; but this is a rough hack to make Extort work for now. - (when (ffi-obj-ref "error_handler" libt.so (thunk #f)) - (set-ffi-obj! "error_handler" libt.so _pointer - (function-ptr (λ () (raise 'err)) (_fun _-> _void)))) - - (when *debug*? - (define log (ffi-obj-ref log-label libt.so (thunk #f))) - (when log - (set-ffi-obj! log-label libt.so _pointer - (function-ptr - (λ () (log-a86-info - (apply show-state - (build-list 18 (lambda (i) (ptr-ref log _int64 (add1 i))))))) - (_fun _-> _void))))) - - (define has-heap? #f) - - (when (ffi-obj-ref "heap" libt.so (thunk #f)) - (set! has-heap? #t) - - ;; This is a GC-enabled run-time so set from, to, and types space - (when (ffi-obj-ref "from" libt.so (thunk #f)) - ;; FIXME: leaks types memory - (set-ffi-obj! "from" libt.so _pointer *heap*) - (set-ffi-obj! "to" libt.so _pointer (ptr-add *heap* 10000 _int64)) - (set-ffi-obj! "types" libt.so _pointer (malloc _int32 10000)))) - - (delete-file t.s) - (delete-file t.o) - (delete-file t.so) - (if input - (let () - (unless (and (ffi-obj-ref "in" libt.so (thunk #f)) - (ffi-obj-ref "out" libt.so (thunk #f))) - (error "asm-interp/io: running in IO mode without IO linkage")) - - (with-output-to-file t.in #:exists 'truncate - (thunk (display input))) - - (define current-in - (make-c-parameter "in" libt.so _pointer)) - (define current-out - (make-c-parameter "out" libt.so _pointer)) - - (current-in (fopen t.in "r")) - (current-out (fopen t.out "w")) - - (define result - (with-handlers ((symbol? identity)) - (guard-foreign-escape - (entry *heap*)))) - - (fflush (current-out)) - (fclose (current-in)) - (fclose (current-out)) - - (define output (file->string t.out)) - (delete-file t.in) - (delete-file t.out) - (cons result output)) - - (with-handlers ((symbol? identity)) - (guard-foreign-escape - (entry *heap*))))) - - -(define (string-splice xs) - (apply string-append - (add-between (map (lambda (s) (string-append "\"" s "\"")) xs) - " "))) - -;;; Utilities for calling nasm and linker with informative error messages - -(struct exn:nasm exn:fail:user ()) -(define nasm-msg - (string-append - "assembly error: make sure to use `prog` to construct an assembly program\n" - "if you did and still get this error; please share with course staff.")) - -(define (nasm:error msg) - (raise (exn:nasm (format "~a\n\n~a" nasm-msg msg) - (current-continuation-marks)))) - -;; run nasm on t.s to create t.o -(define (nasm t.s t.o) - (define err-port (open-output-string)) - (unless (parameterize ((current-error-port err-port)) - (system (format "nasm -f ~a ~a -o ~a" fmt t.s t.o))) - (nasm:error (get-output-string err-port)))) - -(struct exn:ld exn:fail:user ()) -(define (ld:error msg) - (raise (exn:ld (format "link error: ~a" msg) - (current-continuation-marks)))) - -(define (ld:undef-symbol s) - (ld:error - (string-append - (format "symbol ~a not defined in linked objects: ~a\n" s (current-objs)) - "use `current-objs` to link in object containing symbol definition."))) - -;; link together t.o with current-objs to create shared t.so -(define (ld t.o t.so) - (define err-port (open-output-string)) - (define objs (string-splice (current-objs))) - (define -z-defs-maybe - (if (eq? (system-type 'os) 'macosx) - "" - "-z defs ")) - (unless (parameterize ((current-error-port err-port)) - (system (format "gcc ~a-v -shared ~a ~a -o ~a" - -z-defs-maybe - t.o objs t.so))) - (define err-msg - (get-output-string err-port)) - (match (or (regexp-match #rx"Undefined.*\"(.*)\"" err-msg) ; mac - (regexp-match #rx"undefined reference to `(.*)'" err-msg)) ; linux - [(list _ symbol) (ld:undef-symbol symbol)] - [_ (ld:error (format "unknown link error.\n\n~a" err-msg))]))) - - - -;; Debugging facilities - -(define log-label (symbol->label (gensym 'log))) - -(define (Log i) - (seq (save-registers) - (Pushf) - (Mov 'rax i) - (Mov (Offset log-label (* 8 17)) 'rax) - (Mov 'rax (Offset 'rsp 0)) - (Mov (Offset log-label (* 8 18)) 'rax) - (Call (Offset log-label 0)) - (Popf) - (restore-registers))) - -(define (instrument is) - (for/fold ([ls '()] - #:result (reverse ls)) - ([idx (in-naturals)] - [ins (in-list is)]) - (if (serious-instruction? ins) - (seq ins (reverse (Log idx)) ls) - (seq ins ls)))) - -(define (serious-instruction? ins) - (match ins - [(Label _) #f] - [(Global _) #f] - [(? Comment?) #f] - [_ #t])) - -(define (debug-transform is) - (seq (instrument is) - ;; End of user program - (Data) - (Global log-label) - (Label log-label) - (Dq 0) ; callback placeholder - (static-alloc-registers) - (Dq 0) ; index of instruction - (Dq 0) ; flags - )) - -(define registers - '(rax rbx rcx rdx rbp rsp rsi rdi - r8 r9 r10 r11 r12 r13 r14 r15)) - -(define (static-alloc-registers) - (apply seq - (map (λ (r) (seq (Dq 0) (% (~a r)))) - registers))) - -(define (save-registers) - (apply seq - (map (λ (r i) (seq (Mov (Offset log-label (* 8 i)) r))) - registers - (build-list (length registers) add1)))) - -(define (restore-registers) - (apply seq - (map (λ (r i) (seq (Mov r (Offset log-label (* 8 i))))) - registers - (build-list (length registers) add1)))) diff --git a/a86/main.rkt b/a86/main.rkt deleted file mode 100644 index 4a9df6d..0000000 --- a/a86/main.rkt +++ /dev/null @@ -1,7 +0,0 @@ -#lang racket -(require "ast.rkt" - "interp.rkt" - "printer.rkt") -(provide (all-from-out "ast.rkt" - "interp.rkt" - "printer.rkt")) diff --git a/a86/printer.rkt b/a86/printer.rkt deleted file mode 100644 index f5217b4..0000000 --- a/a86/printer.rkt +++ /dev/null @@ -1,315 +0,0 @@ -#lang racket -(provide/contract - [asm-string (-> (listof instruction?) string?)] ; deprecated - [asm-display (-> (listof instruction?) any)]) - -(define current-shared? - (make-parameter #f)) - -(module* private #f - (provide current-shared?)) - -(require "ast.rkt") - -;; Any -> Boolean -(define (reg? x) - (register? x)) - -;; Reg -> String -(define (reg->string r) - (symbol->string r)) - -;; Asm -> String -(define (asm-string a) - (with-output-to-string (lambda () (asm-display a)))) - -;; Asm -> Void -(define (asm-display a) - (define external-labels '()) - - ;; Label -> String - ;; prefix with _ for Mac - (define label-symbol->string - (match (system-type 'os) - ['macosx - (λ (s) (string-append "_" (symbol->string s)))] - [_ - (if (current-shared?) - (λ (s) - (if (memq s external-labels) - ; hack for ELF64 shared libraries in service of - ; calling external functions in asm-interp - (string-append (symbol->string s) " wrt ..plt") - (symbol->string s))) - symbol->string)])) - - ;; (U Label Reg) -> String - (define (jump-target->string t) - (match t - [(? reg?) (reg->string t)] - [(Offset (? reg? r) i) - (string-append "[" (reg->string r) " + " (number->string i) "]")] - [(Offset (? label? l) i) - (string-append "[" (label-symbol->string l) " + " (number->string i) "]")] - [_ (label-symbol->string t)])) - - ;; Arg -> String - (define (arg->string a) - (match a - [(? reg?) (reg->string a)] - [(? integer?) (number->string a)] - [(Offset (? reg? r) i) - (string-append "[" (reg->string r) " + " (number->string i) "]")] - [(Offset (? label? l) i) - (string-append "[" (label-symbol->string l) " + " (number->string i) "]")] - [(Const l) - (symbol->string l)] - [(? exp?) (exp->string a)])) - - ;; Exp -> String - (define (exp->string e) - (match e - [(? integer?) (number->string e)] - [(Plus e1 e2) - (string-append "(" (exp->string e1) " + " (exp->string e2) ")")] - [_ (label-symbol->string e)])) - - (define tab (make-string 8 #\space)) - - ;; Instruction -> String - (define (fancy-instr->string i) - (let ((s (simple-instr->string i))) - (if (instruction-annotation i) - (if (< (string-length s) 40) - (format "~a~a; ~.s" s (make-string (- 40 (string-length s)) #\space) (instruction-annotation i)) - (format "~a ; ~.s" s (instruction-annotation i))) - s))) - - - ;; Instruction -> String - (define (simple-instr->string i) - (match i - [(Text) (string-append tab "section .text")] - [(Data) (string-append tab "section .data align=8")] ; 8-byte aligned data - [(Ret) (string-append tab "ret")] - [(Label l) (string-append (label-symbol->string l) ":")] - [(Global x) (string-append tab "global " (label-symbol->string x))] - [(Extern l) (begin0 (string-append tab "extern " (label-symbol->string l)) - (set! external-labels (cons l external-labels)))] - [(Mov a1 a2) - (string-append tab "mov " - (arg->string a1) ", " - (arg->string a2))] - [(Add a1 a2) - (string-append tab "add " - (arg->string a1) ", " - (arg->string a2))] - [(Sub a1 a2) - (string-append tab "sub " - (arg->string a1) ", " - (arg->string a2))] - [(Cmp a1 a2) - (string-append tab "cmp " - (arg->string a1) ", " - (arg->string a2))] - [(Sal a1 a2) - (string-append tab "sal " - (arg->string a1) ", " - (arg->string a2))] - [(Sar a1 a2) - (string-append tab "sar " - (arg->string a1) ", " - (arg->string a2))] - [(Shl a1 a2) - (string-append tab "shl " - (arg->string a1) ", " - (arg->string a2))] - [(Shr a1 a2) - (string-append tab "shr " - (arg->string a1) ", " - (arg->string a2))] - [(And a1 a2) - (string-append tab "and " - (arg->string a1) ", " - (arg->string a2))] - [(Or a1 a2) - (string-append tab "or " - (arg->string a1) ", " - (arg->string a2))] - [(Xor a1 a2) - (string-append tab "xor " - (arg->string a1) ", " - (arg->string a2))] - [(Jmp l) - (string-append tab "jmp " - (jump-target->string l))] - [(Jz l) - (string-append tab "jz " - (jump-target->string l))] - [(Jnz l) - (string-append tab "jnz " - (jump-target->string l))] - [(Je l) - (string-append tab "je " - (jump-target->string l))] - [(Jne l) - (string-append tab "jne " - (jump-target->string l))] - [(Jl l) - (string-append tab "jl " - (jump-target->string l))] - [(Jle l) - (string-append tab "jle " - (jump-target->string l))] - [(Jg l) - (string-append tab "jg " - (jump-target->string l))] - [(Jge l) - (string-append tab "jge " - (jump-target->string l))] - [(Jo l) - (string-append tab "jo " - (jump-target->string l))] - [(Jno l) - (string-append tab "jno " - (jump-target->string l))] - [(Jc l) - (string-append tab "jc " - (jump-target->string l))] - [(Jnc l) - (string-append tab "jnc " - (jump-target->string l))] - [(Cmovz dst src) - (string-append tab "cmovz " - (reg->string dst) ", " - (arg->string src))] - [(Cmovnz dst src) - (string-append tab "cmovnz " - (reg->string dst) ", " - (arg->string src))] - [(Cmove dst src) - (string-append tab "cmove " - (reg->string dst) ", " - (arg->string src))] - [(Cmovne dst src) - (string-append tab "cmovne " - (reg->string dst) ", " - (arg->string src))] - [(Cmovl dst src) - (string-append tab "cmovl " - (reg->string dst) ", " - (arg->string src))] - [(Cmovle dst src) - (string-append tab "cmovle " - (reg->string dst) ", " - (arg->string src))] - [(Cmovg dst src) - (string-append tab "cmovg " - (reg->string dst) ", " - (arg->string src))] - [(Cmovge dst src) - (string-append tab "cmovge " - (reg->string dst) ", " - (arg->string src))] - [(Cmovo dst src) - (string-append tab "cmovo " - (reg->string dst) ", " - (arg->string src))] - [(Cmovno dst src) - (string-append tab "cmovno " - (reg->string dst) ", " - (arg->string src))] - [(Cmovc dst src) - (string-append tab "cmovc " - (reg->string dst) ", " - (arg->string src))] - [(Cmovnc dst src) - (string-append tab "cmovnc " - (reg->string dst) ", " - (arg->string src))] - [(Call l) - (string-append tab "call " - (jump-target->string l))] - [(Push a) - (string-append tab "push " - (arg->string a))] - [(Pop r) - (string-append tab "pop " - (reg->string r))] - [(Pushf) - (string-append tab "pushf")] - [(Popf) - (string-append tab "popf")] - [(Lea d (? offset? x)) - (string-append tab "lea " - (arg->string d) ", " - (arg->string x))] - [(Lea d x) - (string-append tab "lea " - (arg->string d) ", [rel " - (exp->string x) "]")] - [(Not r) - (string-append tab "not " - (reg->string r))] - [(Div r) - (string-append tab "div " - (arg->string r))] - [(Equ x c) - (string-append tab - (symbol->string x) - " equ " - (number->string c))] - - [(Db (? bytes? bs)) - (apply string-append tab "db " (add-between (map number->string (bytes->list bs)) ", "))] - [(Db x) - (string-append tab "db " (arg->string x))] - [(Dw x) - (string-append tab "dw " (arg->string x))] - [(Dd x) - (string-append tab "dd " (arg->string x))] - [(Dq x) - (string-append tab "dq " (arg->string x))] - )) - - (define (comment->string c) - (match c - [(% s) (string-append (make-string 32 #\space) "; " s)] - [(%% s) (string-append tab ";; " s)] - [(%%% s) (string-append ";;; " s)])) - - (define (line-comment i s) - (let ((i-str (simple-instr->string i))) - (let ((pad (make-string (max 1 (- 32 (string-length i-str))) #\space))) - (string-append i-str pad "; " s)))) - - ;; [Listof Instr] -> Void - (define (instrs-display a) - (match a - ['() (void)] - [(cons (? Comment? c) a) - (begin (write-string (comment->string c)) - (write-char #\newline) - (instrs-display a))] - [(cons i (cons (% s) a)) - (begin (write-string (line-comment i s)) ; a line comment trumps an annotation - (write-char #\newline) - (instrs-display a))] - [(cons i a) - (begin (write-string (fancy-instr->string i)) - (write-char #\newline) - (instrs-display a))])) - - ;; entry point will be first label - (match (findf Label? a) - [(Label g) - (begin - (write-string (string-append - ; tab "global " (label-symbol->string g) "\n" - tab "default rel\n" - tab "section .text\n")) - (instrs-display a))] - [_ - (instrs-display a) - #; - (error "program does not have an initial label")])) diff --git a/a86/stepper.rkt b/a86/stepper.rkt deleted file mode 100644 index 5d29724..0000000 --- a/a86/stepper.rkt +++ /dev/null @@ -1,42 +0,0 @@ -#lang racket -(provide main) - -(require redex) - -(define-language L) - -;; A reduction relation that just relates elements -;; of the list to their successors -(define (r ls) - (define i 0) - (reduction-relation L - (--> any_i - any_j - (where any_j - ,(begin - (set! i (add1 i)) - (list-ref ls (min i (sub1 (length ls))))))))) - - -;; reads log file from stdin -(define (main) - (define ls - (let loop () - (if (eof-object? (read)) - '() - (cons (read) (loop))))) - - ;; replace instr indices with their instructions - (define ls1 - (map (λ (s) - (map (λ (p) - (match p - [(list 'instr i) - (list 'instr (list-ref (list-ref ls 0) - (add1 i)))] - [_ p])) - s)) - ls)) - - ;; run the stepper - (stepper (r (rest ls1)) (first (rest ls1)))) diff --git a/a86/test/errors.rkt b/a86/test/errors.rkt deleted file mode 100644 index c88bc32..0000000 --- a/a86/test/errors.rkt +++ /dev/null @@ -1,31 +0,0 @@ -#lang racket -(require rackunit "../ast.rkt") -(check-exn exn:fail? - (thunk (Mov (Offset 'rax 0) 100))) - -;; Checking literal widths -(check-exn exn:fail? (thunk (Mov 'rax (expt 2 64)))) -(check-not-exn (thunk (Mov 'rax (sub1 (expt 2 64))))) -(check-exn exn:fail? (thunk (Cmp 'rax (expt 2 32)))) -(check-not-exn (thunk (Cmp 'rax (sub1 (expt 2 32))))) -(check-exn exn:fail? (thunk (And 'rax (expt 2 32)))) -(check-not-exn (thunk (And 'rax (sub1 (expt 2 32))))) -(check-exn exn:fail? (thunk (Or 'rax (expt 2 32)))) -(check-not-exn (thunk (Or 'rax (sub1 (expt 2 32))))) -(check-exn exn:fail? (thunk (Xor 'rax (expt 2 32)))) -(check-not-exn (thunk (Xor 'rax (sub1 (expt 2 32))))) -(check-exn exn:fail? (thunk (Push (expt 2 32)))) -(check-not-exn (thunk (Push (sub1 (expt 2 32))))) -(check-exn exn:fail? (thunk (Add 'rax (expt 2 32)))) -(check-not-exn (thunk (Add 'rax (sub1 (expt 2 32))))) -(check-exn exn:fail? (thunk (Sub 'rax (expt 2 32)))) -(check-not-exn (thunk (Sub 'rax (sub1 (expt 2 32))))) - -;; Check prog -(check-exn exn:fail? (thunk (prog (Ret)))) -(check-exn exn:fail? (thunk (prog (Label 'start) (Ret)))) -(check-exn exn:fail? (thunk (prog (Global 'foo) (Label 'start) (Label 'foo) (Ret)))) -(check-not-exn (thunk (prog (Global 'start) (Label 'start) (Ret)))) -(check-not-exn (thunk (prog (Label 'start) (Ret) (Global 'start)))) - - diff --git a/info.rkt b/info.rkt index bbd781e..f57e694 100644 --- a/info.rkt +++ b/info.rkt @@ -3,7 +3,7 @@ (define collection 'multi) (define deps (list "base" "rackunit" "redex-lib")) (define build-deps - (list "https://github.com/cmsc430/www.git?path=ziggy#main")) + (list "https://github.com/cmsc430/a86.git?path=#main")) ;; Outlaw is omitted here because it depends on libraries that are a pain ;; to ensure are set up properly and we don't want students to see failing