Checkpoint self-hosting

Bunch of different steps toward self-hosting:

+ Rework source code to be within language supported by compiler.

+ Lots of work toward implementing `read`.

+ Simplified version of a86 library, which is compilable.

+ Expanded standard library.

+ Add libunistring for some Unicode support.

Author: dvanhorn

langs/outlaw/Makefile

@@ -1,3 +1,8 @@
+# NOTES:
+# - You will need a static version of libunistring to link against; on Mac
+#   ld will always choose .dylib over .a to link, so either rename or remove
+#   the .dylib versions.
+
 UNAME := $(shell uname)
 .PHONY: test
 
@@ -20,7 +25,7 @@ objs = \
 default: runtime.o
 
 runtime.o: $(objs)
-	ld -r $(objs) -o runtime.o
+	ld -r $(objs) -lunistring -o runtime.o
 
 %.run: %.o runtime.o
 	gcc runtime.o $< -o $@
@@ -32,10 +37,10 @@ runtime.o: $(objs)
 	nasm -g -f $(format) -o $@ $<
 
 stdlib.s: stdlib.rkt
-	racket -t compile-library.rkt -m stdlib.rkt > stdlib.s
+	cat stdlib.rkt | racket -t compile-library.rkt > stdlib.s
 
 %.s: %.rkt
-	racket -t compile-file.rkt -m $< > $@
+	cat $< | racket -t compile-stdin.rkt > $@
 
 clean:
 	rm *.o *.s *.run

langs/outlaw/a86/ast.rkt

@@ -0,0 +1,100 @@
+#lang racket
+(provide (all-defined-out))
+
+(struct Text   ())
+(struct Data   ())
+
+(struct Global (x))
+(struct Label  (x))
+(struct Call   (x))
+(struct Ret    ())
+(struct Mov    (dst src))
+(struct Add    (dst src))
+(struct Sub    (dst src))
+(struct Cmp    (a1 a2))
+(struct Jmp    (x))
+(struct Je     (x))
+(struct Jne    (x))
+(struct Jl     (x))
+(struct Jle    (x))
+(struct Jg     (x))
+(struct Jge    (x))
+(struct And    (dst src))
+(struct Or     (dst src))
+(struct Xor    (dst src))
+(struct Sal    (dst i))
+(struct Sar    (dst i))
+(struct Push   (a1))
+(struct Pop    (a1))
+(struct Lea    (dst x))
+(struct Div    (den))
+
+(struct Offset (r i))
+(struct Extern (x))
+
+(struct Equ    (x v))
+(struct Const  (x))
+(struct Dd (x))
+(struct Dq (x))
+(struct Plus (e1 e2))
+
+;; (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))
+
+(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 (exp? x)
+  (or (Offset? x)
+      (and (Plus? x)
+           (exp? (Plus-e1 x))
+           (exp? (Plus-e2 x)))
+      (symbol? x)
+      (integer? x)))
+
+(define offset? Offset?)
+
+(define (label? x)
+  (and (symbol? x)
+       (not (register? x))))
+
+(define (instruction? x)
+  (or (Text? x)
+      (Data? x)
+      (Global? x)
+      (Label? x)
+      (Extern? x)
+      (Call? x)
+      (Ret? x)
+      (Mov? x)
+      (Add? x)
+      (Sub? x)
+      (Cmp? x)
+      (Jmp? x)
+      (Je? x)
+      (Jne? x)
+      (Jl? x)
+      (Jle? x)
+      (Jg? x)
+      (Jge? x)
+      (And? x)
+      (Or? x)
+      (Xor? x)
+      (Sal? x)
+      (Sar? x)
+      (Push? x)
+      (Pop? x)
+      (Lea? x)
+      (Div? x)
+      ;(Comment? x)
+      (Equ? x)
+      (Dd? x)
+      (Dq? x)))

langs/outlaw/a86/callback.rkt

@@ -0,0 +1,46 @@
+#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))))

langs/outlaw/a86/interp.rkt

@@ -0,0 +1,191 @@
+#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)])
+
+(require "printer.rkt" "ast.rkt" "callback.rkt"
+         (rename-in ffi/unsafe [-> _->]))
+
+
+;; 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))
+
+;; 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)
+  (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))
+      (displayln (asm-string 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))))
+
+
+  (define current-heap #f)
+
+  ;; allocate a heap
+  (when (ffi-obj-ref "heap" libt.so (thunk #f))
+    (set! current-heap (make-c-parameter "heap" libt.so _pointer))
+
+    (if (ffi-obj-ref "from" libt.so (thunk #f))
+        (begin
+          (current-heap
+           ; IMPROVE ME: hard-coded heap size
+           (malloc _int64 20000 'raw))
+          (set-ffi-obj! "from" libt.so _pointer (current-heap))
+          (set-ffi-obj! "to" libt.so _pointer (ptr-add (current-heap) 10000 _int64))
+          (set-ffi-obj! "types" libt.so _pointer (malloc _int32 10000)))
+        (current-heap
+         ; IMPROVE ME: hard-coded heap size
+         (malloc _int64 10000 'raw))))
+
+  (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
+          (begin0
+            (with-handlers ((symbol? identity))
+              (guard-foreign-escape
+               (if current-heap
+                   (cons (current-heap) (entry (current-heap)))
+                   (entry #f))))
+            #;
+            (when current-heap
+              (free (current-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))
+
+      (begin0
+        (with-handlers ((symbol? identity))
+          (guard-foreign-escape
+           (if current-heap
+               (cons (current-heap) (entry (current-heap)))
+               (entry #f))))
+        #;
+        (when current-heap
+          (free (current-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))])))