diff --git a/.github/workflows/langs.yml b/.github/workflows/langs.yml index ed199a00..73a4b137 100644 --- a/.github/workflows/langs.yml +++ b/.github/workflows/langs.yml @@ -8,7 +8,7 @@ jobs: matrix: os: [ubuntu-20.04, ubuntu-22.04] racket-variant: ['BC', 'CS'] - racket-version: ['7.8', '8.0', '8.6', '8.8'] + racket-version: ['8.6', '8.8'] name: Test on Racket ${{ matrix.racket-variant }} ${{ matrix.racket-version }} on ${{ matrix.os }} steps: - name: Checkout @@ -31,8 +31,11 @@ jobs: nasm --version gcc --version - name: Install langs package - run: raco pkg install langs/ + run: | + raco pkg install --auto ziggy/ + raco pkg install langs/ - name: Run tests run: | - raco test -p langs + raco test -p ziggy + xvfb-run raco test -p langs raco test -c outlaw diff --git a/langs/a86/ast.rkt b/langs/a86/ast.rkt index 162312af..cb4ddea1 100644 --- a/langs/a86/ast.rkt +++ b/langs/a86/ast.rkt @@ -238,6 +238,8 @@ (instruct Sal (dst i) check:shift) (instruct Sar (dst i) check:shift) (instruct Push (a1) check:push) +(instruct Pushf () check:none) +(instruct Popf () check:none) (instruct Pop (a1) check:register) (instruct Lea (dst x) check:lea) (instruct Not (x) check:register) @@ -250,6 +252,8 @@ (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))) @@ -392,3 +396,26 @@ (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/langs/a86/interp.rkt b/langs/a86/interp.rkt index 5334265a..295876d0 100644 --- a/langs/a86/interp.rkt +++ b/langs/a86/interp.rkt @@ -4,6 +4,8 @@ [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)) @@ -11,6 +13,11 @@ ;; 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 '())) @@ -32,10 +39,43 @@ (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")) @@ -46,7 +86,9 @@ #:exists 'truncate (λ () (parameterize ((current-shared? #t)) - (asm-display a)))) + (asm-display (if *debug*? + (debug-transform a) + a))))) (nasm t.s t.o) (ld t.o t.so) @@ -69,24 +111,27 @@ (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 current-heap #f) + (define has-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)))) + (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) @@ -109,15 +154,9 @@ (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))))) + (with-handlers ((symbol? identity)) + (guard-foreign-escape + (entry *heap*)))) (fflush (current-out)) (fclose (current-in)) @@ -128,15 +167,9 @@ (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)))))) + (with-handlers ((symbol? identity)) + (guard-foreign-escape + (entry *heap*))))) (define (string-splice xs) @@ -192,3 +225,69 @@ (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/langs/a86/printer.rkt b/langs/a86/printer.rkt index 724722f7..f6e9a4bc 100644 --- a/langs/a86/printer.rkt +++ b/langs/a86/printer.rkt @@ -49,6 +49,8 @@ [(? 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 @@ -209,6 +211,10 @@ [(Push a) (string-append tab "push " (arg->string a))] + [(Pushf) + (string-append tab "pushf")] + [(Popf) + (string-append tab "popf")] [(Pop r) (string-append tab "pop " (reg->string r))] @@ -232,6 +238,12 @@ " 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) diff --git a/langs/a86/stepper.rkt b/langs/a86/stepper.rkt new file mode 100644 index 00000000..5d29724b --- /dev/null +++ b/langs/a86/stepper.rkt @@ -0,0 +1,42 @@ +#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/langs/abscond/Makefile b/langs/abscond/Makefile index 8084e303..3200bc6d 100644 --- a/langs/abscond/Makefile +++ b/langs/abscond/Makefile @@ -35,7 +35,8 @@ runtime.o: $(objs) cat $< | racket -t compile-stdin.rkt -m > $@ clean: - rm *.o *.s *.run + @$(RM) *.o *.s *.run ||: + @echo "$(shell basename $(shell pwd)): cleaned!" %.test: %.run %.rkt @test "$(shell ./$(<))" = "$(shell racket $(word 2,$^))" diff --git a/langs/abscond/ast.rkt b/langs/abscond/ast.rkt index fa3d7869..7e3cda7a 100644 --- a/langs/abscond/ast.rkt +++ b/langs/abscond/ast.rkt @@ -1,5 +1,6 @@ #lang racket -(provide Int) +(provide Lit) -;; type Expr = (Int Integer) -(struct Int (i) #:prefab) +;; type Expr = (Lit Integer) + +(struct Lit (i) #:prefab) diff --git a/langs/abscond/compile-stdin.rkt b/langs/abscond/compile-stdin.rkt index 5fbdbded..532ee0eb 100644 --- a/langs/abscond/compile-stdin.rkt +++ b/langs/abscond/compile-stdin.rkt @@ -1,6 +1,8 @@ #lang racket (provide main) -(require "parse.rkt" "compile.rkt" a86/printer) +(require "parse.rkt") +(require "compile.rkt") +(require a86/printer) ;; -> Void ;; Compile contents of stdin, @@ -8,3 +10,4 @@ (define (main) (read-line) ; ignore #lang racket line (asm-display (compile (parse (read))))) + diff --git a/langs/abscond/compile.rkt b/langs/abscond/compile.rkt index b0410af3..b3212737 100644 --- a/langs/abscond/compile.rkt +++ b/langs/abscond/compile.rkt @@ -1,15 +1,19 @@ #lang racket -(provide compile) -(require "ast.rkt" a86/ast) +(provide (all-defined-out)) +(require "ast.rkt") +(require a86/ast) + +(define rax 'rax) ;; Expr -> Asm -(define (compile e) +(define (compile e) (prog (Global 'entry) (Label 'entry) (compile-e e) - (Ret))) - + (Ret))) + ;; Expr -> Asm (define (compile-e e) (match e - [(Int i) (seq (Mov 'rax i))])) + [(Lit i) (seq (Mov rax i))])) + diff --git a/langs/abscond/info.rkt b/langs/abscond/info.rkt new file mode 100644 index 00000000..73bc196a --- /dev/null +++ b/langs/abscond/info.rkt @@ -0,0 +1,2 @@ +#lang info +#;(define pre-install-collection "../installer.rkt") diff --git a/langs/abscond/interp-stdin.rkt b/langs/abscond/interp-stdin.rkt index 587d81b9..ce4885f7 100644 --- a/langs/abscond/interp-stdin.rkt +++ b/langs/abscond/interp-stdin.rkt @@ -1,6 +1,7 @@ #lang racket (provide main) -(require "parse.rkt" "interp.rkt") +(require "parse.rkt") +(require "interp.rkt") ;; -> Void ;; Parse and interpret contents of stdin, @@ -8,3 +9,4 @@ (define (main) (read-line) ; ignore #lang racket line (println (interp (parse (read))))) + diff --git a/langs/abscond/interp.rkt b/langs/abscond/interp.rkt index 55a7ca2a..c4b71b31 100644 --- a/langs/abscond/interp.rkt +++ b/langs/abscond/interp.rkt @@ -3,7 +3,8 @@ (require "ast.rkt") ;; Expr -> Integer -;; Interpret given expression (define (interp e) (match e - [(Int i) i])) + [(Lit i) i])) + + diff --git a/langs/abscond/main.rkt b/langs/abscond/main.rkt new file mode 100644 index 00000000..e0e38924 --- /dev/null +++ b/langs/abscond/main.rkt @@ -0,0 +1,13 @@ +#lang racket +(require "ast.rkt") +(require "parse.rkt") +(require "interp.rkt") +(require "compile.rkt") +(require "run.rkt") +(provide (all-from-out "ast.rkt")) +(provide (all-from-out "parse.rkt")) +(provide (all-from-out "interp.rkt")) +(provide (all-from-out "compile.rkt")) +(provide (all-from-out "run.rkt")) + + diff --git a/langs/abscond/parse.rkt b/langs/abscond/parse.rkt index 3d00101a..fb1b6198 100644 --- a/langs/abscond/parse.rkt +++ b/langs/abscond/parse.rkt @@ -5,5 +5,5 @@ ;; S-Expr -> Expr (define (parse s) (match s - [(? exact-integer?) (Int s)] + [(? exact-integer?) (Lit s)] [_ (error "Parse error")])) diff --git a/langs/abscond/run-stdin.rkt b/langs/abscond/run-stdin.rkt new file mode 100644 index 00000000..16cf99e0 --- /dev/null +++ b/langs/abscond/run-stdin.rkt @@ -0,0 +1,12 @@ +#lang racket +(provide main) +(require "parse.rkt") +(require "compile.rkt") +(require "run.rkt") + +;; -> Void +;; Compile contents of stdin and use asm-interp to run +(define (main) + (read-line) ; ignore #lang racket line + (run (compile (parse (read))))) + diff --git a/langs/abscond/run.rkt b/langs/abscond/run.rkt new file mode 100644 index 00000000..1191f553 --- /dev/null +++ b/langs/abscond/run.rkt @@ -0,0 +1,8 @@ +#lang racket +(require a86/interp) +(provide run) + +;; Asm -> Integer +(define (run is) + (asm-interp is)) + diff --git a/langs/abscond/test/compile.rkt b/langs/abscond/test/compile.rkt index cbf232ac..560e6f59 100644 --- a/langs/abscond/test/compile.rkt +++ b/langs/abscond/test/compile.rkt @@ -1,9 +1,8 @@ #lang racket -(require "../compile.rkt" a86/interp "../parse.rkt" rackunit) +(require "../compile.rkt") +(require "../parse.rkt") +(require "../run.rkt") +(require "test-runner.rkt") -(define (run e) - (asm-interp (compile (parse e)))) +(test (λ (e) (run (compile (parse e))))) -;; Abscond examples -(check-equal? (run 7) 7) -(check-equal? (run -8) -8) diff --git a/langs/abscond/test/interp.rkt b/langs/abscond/test/interp.rkt new file mode 100644 index 00000000..41aa8c04 --- /dev/null +++ b/langs/abscond/test/interp.rkt @@ -0,0 +1,7 @@ +#lang racket +(require "../interp.rkt") +(require "../parse.rkt") +(require "test-runner.rkt") + +(test (λ (e) (interp (parse e)))) + diff --git a/langs/abscond/test/test-runner.rkt b/langs/abscond/test/test-runner.rkt new file mode 100644 index 00000000..829c996f --- /dev/null +++ b/langs/abscond/test/test-runner.rkt @@ -0,0 +1,10 @@ +#lang racket +(provide test) +(require rackunit) + +(define (test run) + (begin ;; Abscond + (check-equal? (run 7) 7) + (check-equal? (run -8) -8))) + + diff --git a/langs/blackmail/Makefile b/langs/blackmail/Makefile index 8084e303..3200bc6d 100644 --- a/langs/blackmail/Makefile +++ b/langs/blackmail/Makefile @@ -35,7 +35,8 @@ runtime.o: $(objs) cat $< | racket -t compile-stdin.rkt -m > $@ clean: - rm *.o *.s *.run + @$(RM) *.o *.s *.run ||: + @echo "$(shell basename $(shell pwd)): cleaned!" %.test: %.run %.rkt @test "$(shell ./$(<))" = "$(shell racket $(word 2,$^))" diff --git a/langs/blackmail/ast.rkt b/langs/blackmail/ast.rkt index 2531b081..c882e675 100644 --- a/langs/blackmail/ast.rkt +++ b/langs/blackmail/ast.rkt @@ -1,9 +1,11 @@ #lang racket -(provide Int Prim1) +(provide Lit Prim1) -;; type Expr = -;; | (Int Integer) -;; | (Prim1 Op Expr) -;; type Op = 'add1 | 'sub1 -(struct Int (i) #:prefab) +;; type Expr = (Lit Integer) +;; | (Prim1 Op1 Expr) + +;; type Op1 = 'add1 | 'sub1 + +(struct Lit (i) #:prefab) (struct Prim1 (p e) #:prefab) + diff --git a/langs/blackmail/compile-ops.rkt b/langs/blackmail/compile-ops.rkt new file mode 100644 index 00000000..8f6bd44c --- /dev/null +++ b/langs/blackmail/compile-ops.rkt @@ -0,0 +1,13 @@ +#lang racket +(provide compile-op1) +(require "ast.rkt") +(require a86/ast) + +(define rax 'rax) + +;; Op1 -> Asm +(define (compile-op1 p) + (match p + ['add1 (Add rax 1)] + ['sub1 (Sub rax 1)])) + diff --git a/langs/blackmail/compile-stdin.rkt b/langs/blackmail/compile-stdin.rkt index 5fbdbded..532ee0eb 100644 --- a/langs/blackmail/compile-stdin.rkt +++ b/langs/blackmail/compile-stdin.rkt @@ -1,6 +1,8 @@ #lang racket (provide main) -(require "parse.rkt" "compile.rkt" a86/printer) +(require "parse.rkt") +(require "compile.rkt") +(require a86/printer) ;; -> Void ;; Compile contents of stdin, @@ -8,3 +10,4 @@ (define (main) (read-line) ; ignore #lang racket line (asm-display (compile (parse (read))))) + diff --git a/langs/blackmail/compile.rkt b/langs/blackmail/compile.rkt index dfc10aa5..24e9ee1a 100644 --- a/langs/blackmail/compile.rkt +++ b/langs/blackmail/compile.rkt @@ -1,9 +1,13 @@ #lang racket (provide (all-defined-out)) -(require "ast.rkt" a86/ast) +(require "ast.rkt") +(require "compile-ops.rkt") +(require a86/ast) + +(define rax 'rax) ;; Expr -> Asm -(define (compile e) +(define (compile e) (prog (Global 'entry) (Label 'entry) (compile-e e) @@ -12,16 +16,11 @@ ;; Expr -> Asm (define (compile-e e) (match e - [(Prim1 p e) (compile-prim1 p e)] - [(Int i) (compile-integer i)])) + [(Lit i) (seq (Mov rax i))] + [(Prim1 p e) (compile-prim1 p e)])) -;; Op Expr -> Asm +;; Op1 Expr -> Asm (define (compile-prim1 p e) (seq (compile-e e) - (match p - ['add1 (Add 'rax 1)] - ['sub1 (Sub 'rax 1)]))) + (compile-op1 p))) -;; Integer -> Asm -(define (compile-integer i) - (seq (Mov 'rax i))) diff --git a/langs/blackmail/info.rkt b/langs/blackmail/info.rkt new file mode 100644 index 00000000..73bc196a --- /dev/null +++ b/langs/blackmail/info.rkt @@ -0,0 +1,2 @@ +#lang info +#;(define pre-install-collection "../installer.rkt") diff --git a/langs/blackmail/interp-prim.rkt b/langs/blackmail/interp-prim.rkt new file mode 100644 index 00000000..2d3b7ffb --- /dev/null +++ b/langs/blackmail/interp-prim.rkt @@ -0,0 +1,9 @@ +#lang racket +(provide interp-prim1) + +;; Op1 Integer -> Integer +(define (interp-prim1 op i) + (match op + ['add1 (add1 i)] + ['sub1 (sub1 i)])) + diff --git a/langs/blackmail/interp-stdin.rkt b/langs/blackmail/interp-stdin.rkt index 587d81b9..ce4885f7 100644 --- a/langs/blackmail/interp-stdin.rkt +++ b/langs/blackmail/interp-stdin.rkt @@ -1,6 +1,7 @@ #lang racket (provide main) -(require "parse.rkt" "interp.rkt") +(require "parse.rkt") +(require "interp.rkt") ;; -> Void ;; Parse and interpret contents of stdin, @@ -8,3 +9,4 @@ (define (main) (read-line) ; ignore #lang racket line (println (interp (parse (read))))) + diff --git a/langs/blackmail/interp.rkt b/langs/blackmail/interp.rkt index f23a9595..58d2fe6e 100644 --- a/langs/blackmail/interp.rkt +++ b/langs/blackmail/interp.rkt @@ -1,15 +1,13 @@ #lang racket (provide interp) (require "ast.rkt") +(require "interp-prim.rkt") ;; Expr -> Integer (define (interp e) (match e - [(Int i) i] - [(Prim1 p e) (interp-prim1 p (interp e))])) + [(Lit i) i] + [(Prim1 p e) + (interp-prim1 p (interp e))])) + -;; Op Integer -> Integer -(define (interp-prim1 op i) - (match op - ['add1 (add1 i)] - ['sub1 (sub1 i)])) diff --git a/langs/blackmail/main.rkt b/langs/blackmail/main.rkt new file mode 100644 index 00000000..e0e38924 --- /dev/null +++ b/langs/blackmail/main.rkt @@ -0,0 +1,13 @@ +#lang racket +(require "ast.rkt") +(require "parse.rkt") +(require "interp.rkt") +(require "compile.rkt") +(require "run.rkt") +(provide (all-from-out "ast.rkt")) +(provide (all-from-out "parse.rkt")) +(provide (all-from-out "interp.rkt")) +(provide (all-from-out "compile.rkt")) +(provide (all-from-out "run.rkt")) + + diff --git a/langs/blackmail/parse.rkt b/langs/blackmail/parse.rkt index 3169fdeb..0147dc46 100644 --- a/langs/blackmail/parse.rkt +++ b/langs/blackmail/parse.rkt @@ -5,10 +5,10 @@ ;; S-Expr -> Expr (define (parse s) (match s - [(? exact-integer?) (Int s)] + [(? exact-integer?) (Lit s)] [(list (? op1? o) e) (Prim1 o (parse e))] [_ (error "Parse error")])) -;; Any -> Boolean (define (op1? x) (memq x '(add1 sub1))) + diff --git a/langs/blackmail/run-stdin.rkt b/langs/blackmail/run-stdin.rkt new file mode 100644 index 00000000..16cf99e0 --- /dev/null +++ b/langs/blackmail/run-stdin.rkt @@ -0,0 +1,12 @@ +#lang racket +(provide main) +(require "parse.rkt") +(require "compile.rkt") +(require "run.rkt") + +;; -> Void +;; Compile contents of stdin and use asm-interp to run +(define (main) + (read-line) ; ignore #lang racket line + (run (compile (parse (read))))) + diff --git a/langs/blackmail/run.rkt b/langs/blackmail/run.rkt new file mode 100644 index 00000000..1191f553 --- /dev/null +++ b/langs/blackmail/run.rkt @@ -0,0 +1,8 @@ +#lang racket +(require a86/interp) +(provide run) + +;; Asm -> Integer +(define (run is) + (asm-interp is)) + diff --git a/langs/blackmail/test/compile.rkt b/langs/blackmail/test/compile.rkt index 4ba7d48f..560e6f59 100644 --- a/langs/blackmail/test/compile.rkt +++ b/langs/blackmail/test/compile.rkt @@ -1,13 +1,8 @@ #lang racket -(require "../compile.rkt" a86/interp "../parse.rkt" rackunit) +(require "../compile.rkt") +(require "../parse.rkt") +(require "../run.rkt") +(require "test-runner.rkt") -(define (run e) - (asm-interp (compile (parse e)))) +(test (λ (e) (run (compile (parse e))))) -;; Abscond examples -(check-equal? (run 7) 7) -(check-equal? (run -8) -8) - -;; Blackmail examples -(check-equal? (run '(add1 (add1 7))) 9) -(check-equal? (run '(add1 (sub1 7))) 7) diff --git a/langs/blackmail/test/interp.rkt b/langs/blackmail/test/interp.rkt new file mode 100644 index 00000000..41aa8c04 --- /dev/null +++ b/langs/blackmail/test/interp.rkt @@ -0,0 +1,7 @@ +#lang racket +(require "../interp.rkt") +(require "../parse.rkt") +(require "test-runner.rkt") + +(test (λ (e) (interp (parse e)))) + diff --git a/langs/blackmail/test/test-runner.rkt b/langs/blackmail/test/test-runner.rkt new file mode 100644 index 00000000..1e736f48 --- /dev/null +++ b/langs/blackmail/test/test-runner.rkt @@ -0,0 +1,14 @@ +#lang racket +(provide test) +(require rackunit) + +(define (test run) + (begin ;; Abscond + (check-equal? (run 7) 7) + (check-equal? (run -8) -8)) + + (begin ;; Blackmail + (check-equal? (run '(add1 (add1 7))) 9) + (check-equal? (run '(add1 (sub1 7))) 7))) + + diff --git a/langs/con/Makefile b/langs/con/Makefile index 8084e303..3200bc6d 100644 --- a/langs/con/Makefile +++ b/langs/con/Makefile @@ -35,7 +35,8 @@ runtime.o: $(objs) cat $< | racket -t compile-stdin.rkt -m > $@ clean: - rm *.o *.s *.run + @$(RM) *.o *.s *.run ||: + @echo "$(shell basename $(shell pwd)): cleaned!" %.test: %.run %.rkt @test "$(shell ./$(<))" = "$(shell racket $(word 2,$^))" diff --git a/langs/con/ast.rkt b/langs/con/ast.rkt index 5f47c42d..d68c3e6f 100644 --- a/langs/con/ast.rkt +++ b/langs/con/ast.rkt @@ -1,11 +1,13 @@ #lang racket -(provide Int Prim1 IfZero) - -;; type Expr = -;; | (Int Integer) -;; | (Prim1 Op Expr) -;; | (IfZero Expr Expr Expr) -;; type Op = 'add1 | 'sub1 -(struct Int (i) #:prefab) -(struct Prim1 (p e) #:prefab) +(provide Lit Prim1 IfZero) + +;; type Expr = (Lit Integer) +;; | (Prim1 Op1 Expr) +;; | (IfZero Expr Expr Expr) + +;; type Op1 = 'add1 | 'sub1 + +(struct Lit (i) #:prefab) +(struct Prim1 (p e) #:prefab) (struct IfZero (e1 e2 e3) #:prefab) + diff --git a/langs/con/compile-ops.rkt b/langs/con/compile-ops.rkt new file mode 100644 index 00000000..8f6bd44c --- /dev/null +++ b/langs/con/compile-ops.rkt @@ -0,0 +1,13 @@ +#lang racket +(provide compile-op1) +(require "ast.rkt") +(require a86/ast) + +(define rax 'rax) + +;; Op1 -> Asm +(define (compile-op1 p) + (match p + ['add1 (Add rax 1)] + ['sub1 (Sub rax 1)])) + diff --git a/langs/con/compile-prim.rkt b/langs/con/compile-prim.rkt deleted file mode 100644 index 77cb6c4f..00000000 --- a/langs/con/compile-prim.rkt +++ /dev/null @@ -1,10 +0,0 @@ -#lang racket -(provide compile-prim1) -(require "types.rkt" a86/ast) - -;; Op Asm -> Asm -(define (compile-prim1 p c) - (seq c - (match p - ['add1 (Add 'rax (value->bits 1))] - ['sub1 (Sub 'rax (value->bits 1))]))) diff --git a/langs/con/compile-stdin.rkt b/langs/con/compile-stdin.rkt index 5fbdbded..532ee0eb 100644 --- a/langs/con/compile-stdin.rkt +++ b/langs/con/compile-stdin.rkt @@ -1,6 +1,8 @@ #lang racket (provide main) -(require "parse.rkt" "compile.rkt" a86/printer) +(require "parse.rkt") +(require "compile.rkt") +(require a86/printer) ;; -> Void ;; Compile contents of stdin, @@ -8,3 +10,4 @@ (define (main) (read-line) ; ignore #lang racket line (asm-display (compile (parse (read))))) + diff --git a/langs/con/compile.rkt b/langs/con/compile.rkt index 9479064a..59f077a6 100644 --- a/langs/con/compile.rkt +++ b/langs/con/compile.rkt @@ -1,34 +1,39 @@ #lang racket (provide (all-defined-out)) -(require "ast.rkt" a86/ast "compile-prim.rkt") +(require "ast.rkt") +(require "compile-ops.rkt") +(require a86/ast) +(define rax 'rax) ;; Expr -> Asm -(define (compile e) +(define (compile e) (prog (Global 'entry) (Label 'entry) (compile-e e) - (Ret))) + (Ret))) ;; Expr -> Asm (define (compile-e e) (match e - [(Int i) (compile-integer i)] - [(Prim1 p e) (compile-prim1 p (compile-e e))] - [(IfZero e1 e2 e3) (compile-ifzero e1 e2 e3)])) + [(Lit i) (seq (Mov rax i))] + [(Prim1 p e) (compile-prim1 p e)] + [(IfZero e1 e2 e3) + (compile-ifzero e1 e2 e3)])) -;; Integer -> Asm -(define (compile-integer i) - (seq (Mov 'rax i))) +;; Op1 Expr -> Asm +(define (compile-prim1 p e) + (seq (compile-e e) + (compile-op1 p))) ;; Expr Expr Expr -> Asm (define (compile-ifzero e1 e2 e3) - (let ((l1 (gensym 'if)) - (l2 (gensym 'if))) + (let ((l1 (gensym 'ifz)) + (l2 (gensym 'ifz))) (seq (compile-e e1) - (Cmp 'rax 0) - (Je l1) - (compile-e e3) + (Cmp rax 0) + (Jne l1) + (compile-e e2) (Jmp l2) (Label l1) - (compile-e e2) + (compile-e e3) (Label l2)))) diff --git a/langs/con/info.rkt b/langs/con/info.rkt new file mode 100644 index 00000000..73bc196a --- /dev/null +++ b/langs/con/info.rkt @@ -0,0 +1,2 @@ +#lang info +#;(define pre-install-collection "../installer.rkt") diff --git a/langs/con/interp-prim.rkt b/langs/con/interp-prim.rkt index 306e1dbf..2d3b7ffb 100644 --- a/langs/con/interp-prim.rkt +++ b/langs/con/interp-prim.rkt @@ -1,8 +1,9 @@ #lang racket (provide interp-prim1) -;; Op Integer -> Integer +;; Op1 Integer -> Integer (define (interp-prim1 op i) (match op ['add1 (add1 i)] ['sub1 (sub1 i)])) + diff --git a/langs/con/interp-stdin.rkt b/langs/con/interp-stdin.rkt index 587d81b9..ce4885f7 100644 --- a/langs/con/interp-stdin.rkt +++ b/langs/con/interp-stdin.rkt @@ -1,6 +1,7 @@ #lang racket (provide main) -(require "parse.rkt" "interp.rkt") +(require "parse.rkt") +(require "interp.rkt") ;; -> Void ;; Parse and interpret contents of stdin, @@ -8,3 +9,4 @@ (define (main) (read-line) ; ignore #lang racket line (println (interp (parse (read))))) + diff --git a/langs/con/interp.rkt b/langs/con/interp.rkt index ee7bacb2..30fc6e04 100644 --- a/langs/con/interp.rkt +++ b/langs/con/interp.rkt @@ -1,15 +1,16 @@ #lang racket (provide interp) -(require "ast.rkt" "interp-prim.rkt") +(require "ast.rkt") +(require "interp-prim.rkt") ;; Expr -> Integer (define (interp e) (match e - [(Int i) i] - [(Prim1 p e) - (interp-prim1 p (interp e))] + [(Lit i) i] + [(Prim1 p e) (interp-prim1 p (interp e))] [(IfZero e1 e2 e3) (if (zero? (interp e1)) (interp e2) (interp e3))])) + diff --git a/langs/con/main.rkt b/langs/con/main.rkt new file mode 100644 index 00000000..e0e38924 --- /dev/null +++ b/langs/con/main.rkt @@ -0,0 +1,13 @@ +#lang racket +(require "ast.rkt") +(require "parse.rkt") +(require "interp.rkt") +(require "compile.rkt") +(require "run.rkt") +(provide (all-from-out "ast.rkt")) +(provide (all-from-out "parse.rkt")) +(provide (all-from-out "interp.rkt")) +(provide (all-from-out "compile.rkt")) +(provide (all-from-out "run.rkt")) + + diff --git a/langs/con/parse.rkt b/langs/con/parse.rkt index 566531e7..792f883d 100644 --- a/langs/con/parse.rkt +++ b/langs/con/parse.rkt @@ -5,12 +5,13 @@ ;; S-Expr -> Expr (define (parse s) (match s - [(? exact-integer?) (Int s)] - [(list (? op1? o) e) (Prim1 o (parse e))] + [(? exact-integer?) (Lit s)] + [(list (? op1? o) e) (Prim1 o (parse e))] + ;; NEW: [(list 'if (list 'zero? e1) e2 e3) (IfZero (parse e1) (parse e2) (parse e3))] [_ (error "Parse error")])) -;; Any -> Boolean (define (op1? x) (memq x '(add1 sub1))) + diff --git a/langs/con/run-stdin.rkt b/langs/con/run-stdin.rkt new file mode 100644 index 00000000..16cf99e0 --- /dev/null +++ b/langs/con/run-stdin.rkt @@ -0,0 +1,12 @@ +#lang racket +(provide main) +(require "parse.rkt") +(require "compile.rkt") +(require "run.rkt") + +;; -> Void +;; Compile contents of stdin and use asm-interp to run +(define (main) + (read-line) ; ignore #lang racket line + (run (compile (parse (read))))) + diff --git a/langs/con/run.rkt b/langs/con/run.rkt new file mode 100644 index 00000000..1191f553 --- /dev/null +++ b/langs/con/run.rkt @@ -0,0 +1,8 @@ +#lang racket +(require a86/interp) +(provide run) + +;; Asm -> Integer +(define (run is) + (asm-interp is)) + diff --git a/langs/con/test/compile.rkt b/langs/con/test/compile.rkt index 5d0b431c..560e6f59 100644 --- a/langs/con/test/compile.rkt +++ b/langs/con/test/compile.rkt @@ -1,26 +1,8 @@ #lang racket -(require "../compile.rkt" "../parse.rkt" a86/interp rackunit) +(require "../compile.rkt") +(require "../parse.rkt") +(require "../run.rkt") +(require "test-runner.rkt") -(define (run e) - (asm-interp (compile (parse e)))) +(test (λ (e) (run (compile (parse e))))) -;; Abscond examples -(check-equal? (run 7) 7) -(check-equal? (run -8) -8) - -;; Blackmail examples -(check-equal? (run '(add1 (add1 7))) 9) -(check-equal? (run '(add1 (sub1 7))) 7) - -;; Con examples -(check-equal? (run '(if (zero? 0) 1 2)) 1) -(check-equal? (run '(if (zero? 1) 1 2)) 2) -(check-equal? (run '(if (zero? -7) 1 2)) 2) -(check-equal? (run '(if (zero? 0) - (if (zero? 1) 1 2) - 7)) - 2) -(check-equal? (run '(if (zero? (if (zero? 0) 1 0)) - (if (zero? 1) 1 2) - 7)) - 7) diff --git a/langs/con/test/interp.rkt b/langs/con/test/interp.rkt index 08ac65dc..41aa8c04 100644 --- a/langs/con/test/interp.rkt +++ b/langs/con/test/interp.rkt @@ -1,26 +1,7 @@ #lang racket -(require "../interp.rkt" "../parse.rkt" rackunit) +(require "../interp.rkt") +(require "../parse.rkt") +(require "test-runner.rkt") + +(test (λ (e) (interp (parse e)))) -(define (run e) - (interp (parse e))) - -;; Abscond examples -(check-equal? (run 7) 7) -(check-equal? (run -8) -8) - -;; Blackmail examples -(check-equal? (run '(add1 (add1 7))) 9) -(check-equal? (run '(add1 (sub1 7))) 7) - -;; Con examples -(check-equal? (run '(if (zero? 0) 1 2)) 1) -(check-equal? (run '(if (zero? 1) 1 2)) 2) -(check-equal? (run '(if (zero? -7) 1 2)) 2) -(check-equal? (run '(if (zero? 0) - (if (zero? 1) 1 2) - 7)) - 2) -(check-equal? (run '(if (zero? (if (zero? 0) 1 0)) - (if (zero? 1) 1 2) - 7)) - 7) diff --git a/langs/con/test/test-runner.rkt b/langs/con/test/test-runner.rkt new file mode 100644 index 00000000..4428c634 --- /dev/null +++ b/langs/con/test/test-runner.rkt @@ -0,0 +1,27 @@ +#lang racket +(provide test) +(require rackunit) + +(define (test run) + (begin ;; Abscond + (check-equal? (run 7) 7) + (check-equal? (run -8) -8)) + + (begin ;; Blackmail + (check-equal? (run '(add1 (add1 7))) 9) + (check-equal? (run '(add1 (sub1 7))) 7)) + + (begin ;; Con + (check-equal? (run '(if (zero? 0) 1 2)) 1) + (check-equal? (run '(if (zero? 1) 1 2)) 2) + (check-equal? (run '(if (zero? -7) 1 2)) 2) + (check-equal? (run '(if (zero? 0) + (if (zero? 1) 1 2) + 7)) + 2) + (check-equal? (run '(if (zero? (if (zero? 0) 1 0)) + (if (zero? 1) 1 2) + 7)) + 7))) + + diff --git a/langs/dodger/Makefile b/langs/dodger/Makefile index 17e67120..4555cee7 100644 --- a/langs/dodger/Makefile +++ b/langs/dodger/Makefile @@ -36,7 +36,8 @@ runtime.o: $(objs) cat $< | racket -t compile-stdin.rkt -m > $@ clean: - rm *.o *.s *.run + @$(RM) *.o *.s *.run ||: + @echo "$(shell basename $(shell pwd)): cleaned!" %.test: %.run %.rkt @test "$(shell ./$(<))" = "$(shell racket $(word 2,$^))" diff --git a/langs/dodger/ast.rkt b/langs/dodger/ast.rkt deleted file mode 100644 index 0a546fba..00000000 --- a/langs/dodger/ast.rkt +++ /dev/null @@ -1,16 +0,0 @@ -#lang racket -(provide Int Bool Char Prim1 If) - -;; type Expr = -;; | (Int Integer) -;; | (Bool Boolean) -;; | (Char Character) -;; | (Prim1 Op Expr) -;; | (If Expr Expr Expr) -;; type Op = 'add1 | 'sub1 | 'zero? -;; | 'char? | 'integer->char | 'char->integer -(struct Int (i) #:prefab) -(struct Bool (b) #:prefab) -(struct Char (c) #:prefab) -(struct Prim1 (p e) #:prefab) -(struct If (e1 e2 e3) #:prefab) diff --git a/langs/dodger/compile-ops.rkt b/langs/dodger/compile-ops.rkt deleted file mode 100644 index 5c8a8dd3..00000000 --- a/langs/dodger/compile-ops.rkt +++ /dev/null @@ -1,30 +0,0 @@ -#lang racket -(provide (all-defined-out)) -(require "ast.rkt" "types.rkt" a86/ast) - -(define rax 'rax) -(define r9 'r9) ; scratch - -;; Op1 -> Asm -(define (compile-op1 p) - (match p - ['add1 (Add rax (value->bits 1))] - ['sub1 (Sub rax (value->bits 1))] - ['zero? - (seq (Cmp rax 0) - (Mov rax val-false) - (Mov r9 val-true) - (Cmove rax r9))] - ['char? - (seq (And rax mask-char) - (Cmp rax type-char) - (Mov rax val-false) - (Mov r9 val-true) - (Cmove rax r9))] - ['char->integer - (seq (Sar rax char-shift) - (Sal rax int-shift))] - ['integer->char - (seq (Sar rax int-shift) - (Sal rax char-shift) - (Xor rax type-char))])) diff --git a/langs/dodger/compile-stdin.rkt b/langs/dodger/compile-stdin.rkt deleted file mode 100644 index 5fbdbded..00000000 --- a/langs/dodger/compile-stdin.rkt +++ /dev/null @@ -1,10 +0,0 @@ -#lang racket -(provide main) -(require "parse.rkt" "compile.rkt" a86/printer) - -;; -> Void -;; Compile contents of stdin, -;; emit asm code on stdout -(define (main) - (read-line) ; ignore #lang racket line - (asm-display (compile (parse (read))))) diff --git a/langs/dodger/compile.rkt b/langs/dodger/compile.rkt deleted file mode 100644 index 3310c5f3..00000000 --- a/langs/dodger/compile.rkt +++ /dev/null @@ -1,43 +0,0 @@ -#lang racket -(provide (all-defined-out)) -(require "ast.rkt" "types.rkt" "compile-ops.rkt" a86/ast) - -(define rax 'rax) - -;; Expr -> Asm -(define (compile e) - (prog (Global 'entry) - (Label 'entry) - (compile-e e) - (Ret))) - -;; Expr -> Asm -(define (compile-e e) - (match e - [(Int i) (compile-value i)] - [(Bool b) (compile-value b)] - [(Char c) (compile-value c)] - [(Prim1 p e) (compile-prim1 p e)] - [(If e1 e2 e3) (compile-if e1 e2 e3)])) - -;; Value -> Asm -(define (compile-value v) - (seq (Mov rax (value->bits v)))) - -;; Op1 Expr -> Asm -(define (compile-prim1 p e) - (seq (compile-e e) - (compile-op1 p))) - -;; Expr Expr Expr -> Asm -(define (compile-if e1 e2 e3) - (let ((l1 (gensym 'if)) - (l2 (gensym 'if))) - (seq (compile-e e1) - (Cmp rax val-false) - (Je l1) - (compile-e e2) - (Jmp l2) - (Label l1) - (compile-e e3) - (Label l2)))) diff --git a/langs/dodger/info.rkt b/langs/dodger/info.rkt new file mode 100644 index 00000000..41ec40bb --- /dev/null +++ b/langs/dodger/info.rkt @@ -0,0 +1,2 @@ +#lang info +(define pre-install-collection "../installer.rkt") diff --git a/langs/dodger/interp-bits.rkt b/langs/dodger/interp-bits.rkt index 660841e9..6f65d551 100644 --- a/langs/dodger/interp-bits.rkt +++ b/langs/dodger/interp-bits.rkt @@ -16,21 +16,15 @@ ;; Expr -> Bits (define (interp-bits e) (match e - [(Int i) (value->bits i)] - [(Char c) (value->bits c)] - [(Bool b) (value->bits b)] + [(Lit d) (value->bits d)] [(Prim1 'add1 e0) (+ (interp-bits e0) (value->bits 1))] [(Prim1 'sub1 e0) (- (interp-bits e0) (value->bits 1))] [(Prim1 'zero? e) - (if (zero? (interp-bits e)) - val-true - val-false)] + (value->bits (zero? (interp-bits e)))] [(Prim1 'char? e0) - (if (= type-char (bitwise-and (interp-bits e0) #b11)) - val-true - val-false)] + (value->bits (char-bits? (interp-bits e0)))] [(Prim1 'char->integer e0) (arithmetic-shift (arithmetic-shift (interp-bits e0) (- char-shift)) @@ -42,6 +36,6 @@ char-shift) type-char)] [(If e1 e2 e3) - (if (= (interp-bits e1) val-false) + (if (= (interp-bits e1) (value->bits #f)) (interp-bits e3) (interp-bits e2))])) diff --git a/langs/dodger/interp-prim.rkt b/langs/dodger/interp-prim.rkt deleted file mode 100644 index 38633e47..00000000 --- a/langs/dodger/interp-prim.rkt +++ /dev/null @@ -1,12 +0,0 @@ -#lang racket -(provide interp-prim1) - -;; Op1 Value -> Value -(define (interp-prim1 op v) - (match op - ['add1 (add1 v)] - ['sub1 (sub1 v)] - ['zero? (zero? v)] - ['char? (char? v)] - ['integer->char (integer->char v)] - ['char->integer (char->integer v)])) diff --git a/langs/dodger/interp-stdin.rkt b/langs/dodger/interp-stdin.rkt deleted file mode 100644 index 587d81b9..00000000 --- a/langs/dodger/interp-stdin.rkt +++ /dev/null @@ -1,10 +0,0 @@ -#lang racket -(provide main) -(require "parse.rkt" "interp.rkt") - -;; -> Void -;; Parse and interpret contents of stdin, -;; print result on stdout -(define (main) - (read-line) ; ignore #lang racket line - (println (interp (parse (read))))) diff --git a/langs/dodger/interp.rkt b/langs/dodger/interp.rkt deleted file mode 100644 index 7feaef77..00000000 --- a/langs/dodger/interp.rkt +++ /dev/null @@ -1,21 +0,0 @@ -#lang racket -(provide interp) -(require "ast.rkt" "interp-prim.rkt") - -;; type Value = -;; | Integer -;; | Boolean -;; | Character - -;; Expr -> Value -(define (interp e) - (match e - [(Int i) i] - [(Bool b) b] - [(Char c) c] - [(Prim1 p e) - (interp-prim1 p (interp e))] - [(If e1 e2 e3) - (if (interp e1) - (interp e2) - (interp e3))])) diff --git a/langs/dodger/parse.rkt b/langs/dodger/parse.rkt deleted file mode 100644 index e9a00b05..00000000 --- a/langs/dodger/parse.rkt +++ /dev/null @@ -1,18 +0,0 @@ -#lang racket -(provide parse) -(require "ast.rkt") - -;; S-Expr -> Expr -(define (parse s) - (match s - [(? exact-integer?) (Int s)] - [(? boolean?) (Bool s)] - [(? char?) (Char s)] - [(list (? op1? o) e) (Prim1 o (parse e))] - [(list 'if e1 e2 e3) - (If (parse e1) (parse e2) (parse e3))] - [_ (error "Parse error")])) - -;; Any -> Boolean -(define (op1? x) - (memq x '(add1 sub1 zero? char? integer->char char->integer))) diff --git a/langs/dodger/types.rkt b/langs/dodger/types.rkt deleted file mode 100644 index 933fdd31..00000000 --- a/langs/dodger/types.rkt +++ /dev/null @@ -1,28 +0,0 @@ -#lang racket -(provide (all-defined-out)) - -(define int-shift 1) -(define char-shift 2) -(define type-int #b0) -(define type-char #b01) -(define mask-char #b11) -(define val-true #b011) -(define val-false #b111) - -(define (bits->value b) - (cond [(= type-int (bitwise-and b #b1)) - (arithmetic-shift b (- int-shift))] - [(= type-char (bitwise-and b #b11)) - (integer->char (arithmetic-shift b (- char-shift)))] - [(= b val-true) #t] - [(= b val-false) #f] - [else (error "invalid bits")])) - -(define (value->bits v) - (cond [(integer? v) (arithmetic-shift v int-shift)] - [(char? v) - (bitwise-ior type-char - (arithmetic-shift (char->integer v) char-shift))] - [(eq? v #t) val-true] - [(eq? v #f) val-false])) - diff --git a/langs/dupe/Makefile b/langs/dupe/Makefile index 17e67120..4555cee7 100644 --- a/langs/dupe/Makefile +++ b/langs/dupe/Makefile @@ -36,7 +36,8 @@ runtime.o: $(objs) cat $< | racket -t compile-stdin.rkt -m > $@ clean: - rm *.o *.s *.run + @$(RM) *.o *.s *.run ||: + @echo "$(shell basename $(shell pwd)): cleaned!" %.test: %.run %.rkt @test "$(shell ./$(<))" = "$(shell racket $(word 2,$^))" diff --git a/langs/dupe/ast.rkt b/langs/dupe/ast.rkt index 00a2eb83..50183b13 100644 --- a/langs/dupe/ast.rkt +++ b/langs/dupe/ast.rkt @@ -1,13 +1,16 @@ #lang racket -(provide Int Bool Prim1 If) - -;; type Expr = -;; | (Int Integer) -;; | (Bool Boolean) -;; | (Prim1 Op Expr) -;; | (If Expr Expr Expr) -;; type Op = 'add1 | 'sub1 | 'zero? -(struct Int (i) #:prefab) -(struct Bool (b) #:prefab) -(struct Prim1 (p e) #:prefab) +(provide Lit Prim1 If) + +;; type Expr = (Lit Datum) +;; | (Prim1 Op1 Expr) +;; | (If Expr Expr Expr) + +;; type Datum = Integer +;; | Boolean + +;; type Op1 = 'add1 | 'sub1 +;; | 'zero? + +(struct Lit (d) #:prefab) +(struct Prim1 (p e) #:prefab) (struct If (e1 e2 e3) #:prefab) diff --git a/langs/dupe/compile-ops.rkt b/langs/dupe/compile-ops.rkt index 33befad7..0ef4ebc8 100644 --- a/langs/dupe/compile-ops.rkt +++ b/langs/dupe/compile-ops.rkt @@ -1,9 +1,11 @@ #lang racket -(provide (all-defined-out)) -(require "ast.rkt" "types.rkt" a86/ast) +(provide compile-op1) +(require "ast.rkt") +(require "types.rkt") +(require a86/ast) (define rax 'rax) -(define r9 'r9) ; scratch +(define r9 'r9) ;; Op1 -> Asm (define (compile-op1 p) @@ -15,3 +17,4 @@ (Mov rax (value->bits #f)) (Mov r9 (value->bits #t)) (Cmove rax r9))])) + diff --git a/langs/dupe/compile-stdin.rkt b/langs/dupe/compile-stdin.rkt index 5fbdbded..532ee0eb 100644 --- a/langs/dupe/compile-stdin.rkt +++ b/langs/dupe/compile-stdin.rkt @@ -1,6 +1,8 @@ #lang racket (provide main) -(require "parse.rkt" "compile.rkt" a86/printer) +(require "parse.rkt") +(require "compile.rkt") +(require a86/printer) ;; -> Void ;; Compile contents of stdin, @@ -8,3 +10,4 @@ (define (main) (read-line) ; ignore #lang racket line (asm-display (compile (parse (read))))) + diff --git a/langs/dupe/compile.rkt b/langs/dupe/compile.rkt index 15fc8ad4..fa817ac1 100644 --- a/langs/dupe/compile.rkt +++ b/langs/dupe/compile.rkt @@ -1,11 +1,14 @@ #lang racket (provide (all-defined-out)) -(require "ast.rkt" "types.rkt" "compile-ops.rkt" a86/ast) +(require "ast.rkt") +(require "compile-ops.rkt") +(require "types.rkt") +(require a86/ast) (define rax 'rax) ;; Expr -> Asm -(define (compile e) +(define (compile e) (prog (Global 'entry) (Label 'entry) (compile-e e) @@ -14,10 +17,10 @@ ;; Expr -> Asm (define (compile-e e) (match e - [(Int i) (compile-value i)] - [(Bool b) (compile-value b)] - [(Prim1 p e) (compile-prim1 p e)] - [(If e1 e2 e3) (compile-if e1 e2 e3)])) + [(Lit d) (compile-value d)] + [(Prim1 p e) (compile-prim1 p e)] + [(If e1 e2 e3) + (compile-if e1 e2 e3)])) ;; Value -> Asm (define (compile-value v) @@ -40,3 +43,4 @@ (Label l1) (compile-e e3) (Label l2)))) + diff --git a/langs/dupe/info.rkt b/langs/dupe/info.rkt new file mode 100644 index 00000000..73bc196a --- /dev/null +++ b/langs/dupe/info.rkt @@ -0,0 +1,2 @@ +#lang info +#;(define pre-install-collection "../installer.rkt") diff --git a/langs/dupe/interp-bits-wrap.rkt b/langs/dupe/interp-bits-wrap.rkt index ce788f27..6c71a47a 100644 --- a/langs/dupe/interp-bits-wrap.rkt +++ b/langs/dupe/interp-bits-wrap.rkt @@ -1,6 +1,6 @@ #lang racket (provide interp-wrap interp-bits-wrap) -(require "ast.rkt") +(require "ast.rkt" "types.rkt") ;; type Value = ;; | Integer @@ -9,41 +9,27 @@ (define word-size 64) (define shift 1) -(define type-int #b0) -(define val-true #b01) -(define val-false #b11) ;; type Bits = Integer ;; Expr -> Bits (define (interp-bits-wrap e) (match e - [(Int i) (arithmetic-shift i shift)] - [(Bool b) (if b val-true val-false)] + [(Lit i) (value->bits i)] [(Prim1 'add1 e0) (wrap (add1 (interp-bits-wrap e0)))] [(Prim1 'sub1 e0) (wrap (sub1 (interp-bits-wrap e0)))] [(Prim1 'zero? e) - (if (zero? (interp-bits-wrap e)) - val-true - val-false)] + (value->bits (zero? (interp-bits-wrap e)))] [(If e1 e2 e3) - (if (= (interp-bits-wrap e1) val-false) + (if (= (interp-bits-wrap e1) (value->bits #f)) (interp-bits-wrap e3) (interp-bits-wrap e2))])) (define (interp-wrap e) (bits->value (interp-bits-wrap e))) -(define (bits->value b) - (if (even? b) - (arithmetic-shift b (- shift)) - (cond [(= b val-true) #t] - [(= b val-false) #f] - [else (error "invalid bits")]))) - - (define (wrap n) (if (>= (integer-length n) (- word-size shift)) (- (truncate n)) diff --git a/langs/dupe/interp-bits.rkt b/langs/dupe/interp-bits.rkt index 4f5035da..9d475632 100644 --- a/langs/dupe/interp-bits.rkt +++ b/langs/dupe/interp-bits.rkt @@ -9,11 +9,10 @@ ;; Expr -> Bits (define (interp-bits e) (match e - [(Int i) (value->bits i)] - [(Bool b) (value->bits b)] + [(Lit d) (value->bits d)] [(Prim1 p e) (interp-prim1-bits p (interp-bits e))] [(If e1 e2 e3) - (if (= (interp-bits e1) val-false) + (if (= (interp-bits e1) (value->bits #f)) (interp-bits e3) (interp-bits e2))])) diff --git a/langs/dupe/interp-prim.rkt b/langs/dupe/interp-prim.rkt index 5cc032d3..e0ea0720 100644 --- a/langs/dupe/interp-prim.rkt +++ b/langs/dupe/interp-prim.rkt @@ -1,9 +1,9 @@ #lang racket (provide interp-prim1) -;; Op Value -> Value +;; Op1 Value -> Value (define (interp-prim1 op v) (match op - ['add1 (add1 v)] - ['sub1 (sub1 v)] + ['add1 (add1 v)] + ['sub1 (sub1 v)] ['zero? (zero? v)])) diff --git a/langs/dupe/interp-stdin.rkt b/langs/dupe/interp-stdin.rkt index 587d81b9..ce4885f7 100644 --- a/langs/dupe/interp-stdin.rkt +++ b/langs/dupe/interp-stdin.rkt @@ -1,6 +1,7 @@ #lang racket (provide main) -(require "parse.rkt" "interp.rkt") +(require "parse.rkt") +(require "interp.rkt") ;; -> Void ;; Parse and interpret contents of stdin, @@ -8,3 +9,4 @@ (define (main) (read-line) ; ignore #lang racket line (println (interp (parse (read))))) + diff --git a/langs/dupe/interp.rkt b/langs/dupe/interp.rkt index c9aadb75..920f0920 100644 --- a/langs/dupe/interp.rkt +++ b/langs/dupe/interp.rkt @@ -1,6 +1,7 @@ #lang racket (provide interp) -(require "ast.rkt" "interp-prim.rkt") +(require "ast.rkt") +(require "interp-prim.rkt") ;; type Value = ;; | Integer @@ -9,8 +10,7 @@ ;; Expr -> Value (define (interp e) (match e - [(Int i) i] - [(Bool b) b] + [(Lit d) d] [(Prim1 p e) (interp-prim1 p (interp e))] [(If e1 e2 e3) diff --git a/langs/dupe/main.rkt b/langs/dupe/main.rkt new file mode 100644 index 00000000..e0e38924 --- /dev/null +++ b/langs/dupe/main.rkt @@ -0,0 +1,13 @@ +#lang racket +(require "ast.rkt") +(require "parse.rkt") +(require "interp.rkt") +(require "compile.rkt") +(require "run.rkt") +(provide (all-from-out "ast.rkt")) +(provide (all-from-out "parse.rkt")) +(provide (all-from-out "interp.rkt")) +(provide (all-from-out "compile.rkt")) +(provide (all-from-out "run.rkt")) + + diff --git a/langs/dupe/parse.rkt b/langs/dupe/parse.rkt index 2be39cd3..673a0266 100644 --- a/langs/dupe/parse.rkt +++ b/langs/dupe/parse.rkt @@ -5,13 +5,17 @@ ;; S-Expr -> Expr (define (parse s) (match s - [(? exact-integer?) (Int s)] - [(? boolean?) (Bool s)] - [(list (? op1? o) e) (Prim1 o (parse e))] + [(? datum?) (Lit s)] + [(list (? op1? o) e) (Prim1 o (parse e))] [(list 'if e1 e2 e3) (If (parse e1) (parse e2) (parse e3))] [_ (error "Parse error")])) ;; Any -> Boolean +(define (datum? x) + (or (exact-integer? x) + (boolean? x))) + (define (op1? x) (memq x '(add1 sub1 zero?))) + diff --git a/langs/dupe/run-stdin.rkt b/langs/dupe/run-stdin.rkt new file mode 100644 index 00000000..16cf99e0 --- /dev/null +++ b/langs/dupe/run-stdin.rkt @@ -0,0 +1,12 @@ +#lang racket +(provide main) +(require "parse.rkt") +(require "compile.rkt") +(require "run.rkt") + +;; -> Void +;; Compile contents of stdin and use asm-interp to run +(define (main) + (read-line) ; ignore #lang racket line + (run (compile (parse (read))))) + diff --git a/langs/dupe/run.rkt b/langs/dupe/run.rkt new file mode 100644 index 00000000..227703c1 --- /dev/null +++ b/langs/dupe/run.rkt @@ -0,0 +1,7 @@ +#lang racket +(require a86/interp) +(require "types.rkt") +(provide run);; Asm -> Value +(define (run is) + (bits->value (asm-interp is))) + diff --git a/langs/dupe/test/compile.rkt b/langs/dupe/test/compile.rkt new file mode 100644 index 00000000..560e6f59 --- /dev/null +++ b/langs/dupe/test/compile.rkt @@ -0,0 +1,8 @@ +#lang racket +(require "../compile.rkt") +(require "../parse.rkt") +(require "../run.rkt") +(require "test-runner.rkt") + +(test (λ (e) (run (compile (parse e))))) + diff --git a/langs/dupe/test/interp.rkt b/langs/dupe/test/interp.rkt new file mode 100644 index 00000000..41aa8c04 --- /dev/null +++ b/langs/dupe/test/interp.rkt @@ -0,0 +1,7 @@ +#lang racket +(require "../interp.rkt") +(require "../parse.rkt") +(require "test-runner.rkt") + +(test (λ (e) (interp (parse e)))) + diff --git a/langs/dupe/test/test-runner.rkt b/langs/dupe/test/test-runner.rkt new file mode 100644 index 00000000..7dcac9f1 --- /dev/null +++ b/langs/dupe/test/test-runner.rkt @@ -0,0 +1,39 @@ +#lang racket +(provide test) +(require rackunit) + +(define (test run) + (begin ;; Abscond + (check-equal? (run 7) 7) + (check-equal? (run -8) -8)) + + (begin ;; Blackmail + (check-equal? (run '(add1 (add1 7))) 9) + (check-equal? (run '(add1 (sub1 7))) 7)) + + (begin ;; Con + (check-equal? (run '(if (zero? 0) 1 2)) 1) + (check-equal? (run '(if (zero? 1) 1 2)) 2) + (check-equal? (run '(if (zero? -7) 1 2)) 2) + (check-equal? (run '(if (zero? 0) + (if (zero? 1) 1 2) + 7)) + 2) + (check-equal? (run '(if (zero? (if (zero? 0) 1 0)) + (if (zero? 1) 1 2) + 7)) + 7)) + + (begin ;; Dupe + (check-equal? (run #t) #t) + (check-equal? (run #f) #f) + (check-equal? (run '(if #t 1 2)) 1) + (check-equal? (run '(if #f 1 2)) 2) + (check-equal? (run '(if 0 1 2)) 1) + (check-equal? (run '(if #t 3 4)) 3) + (check-equal? (run '(if #f 3 4)) 4) + (check-equal? (run '(if 0 3 4)) 3) + (check-equal? (run '(zero? 4)) #f) + (check-equal? (run '(zero? 0)) #t))) + + diff --git a/langs/dupe/types.rkt b/langs/dupe/types.rkt index 2bf8a5f0..0ba82665 100644 --- a/langs/dupe/types.rkt +++ b/langs/dupe/types.rkt @@ -1,29 +1,21 @@ #lang racket (provide (all-defined-out)) - -;; type Value = -;; | Integer -;; | Boolean - -;; type Bits = Integer - (define int-shift 1) +(define mask-int #b1) (define type-int #b0) -(define type-bool #b1) -(define val-true #b01) -(define val-false #b11) -;; Bits -> Value (define (bits->value b) - (cond [(= type-int (bitwise-and b #b1)) + (cond [(= b (value->bits #t)) #t] + [(= b (value->bits #f)) #f] + [(int-bits? b) (arithmetic-shift b (- int-shift))] - [(= b val-true) #t] - [(= b val-false) #f] [else (error "invalid bits")])) -;; Value -> Bits (define (value->bits v) - (match v - [(? integer?) (arithmetic-shift v int-shift)] - [#t val-true] - [#f val-false])) + (cond [(eq? v #t) #b01] + [(eq? v #f) #b11] + [(integer? v) (arithmetic-shift v int-shift)])) + +(define (int-bits? v) + (= type-int (bitwise-and v mask-int))) + diff --git a/langs/evildoer/Makefile b/langs/evildoer/Makefile index 9055c88f..db6ac44a 100644 --- a/langs/evildoer/Makefile +++ b/langs/evildoer/Makefile @@ -37,7 +37,8 @@ runtime.o: $(objs) cat $< | racket -t compile-stdin.rkt -m > $@ clean: - rm *.o *.s *.run + @$(RM) *.o *.s *.run ||: + @echo "$(shell basename $(shell pwd)): cleaned!" %.test: %.run %.rkt @test "$(shell ./$(<))" = "$(shell racket $(word 2,$^))" diff --git a/langs/evildoer/ast.rkt b/langs/evildoer/ast.rkt deleted file mode 100644 index adfb4ba9..00000000 --- a/langs/evildoer/ast.rkt +++ /dev/null @@ -1,24 +0,0 @@ -#lang racket -(provide Eof Int Bool Char Prim0 Prim1 If Begin) - -;; type Expr = -;; | (Eof) -;; | (Int Integer) -;; | (Bool Boolean) -;; | (Char Character) -;; | (Prim0 Op0) -;; | (Prim1 Op1 Expr) -;; | (If Expr Expr Expr) -;; | (Begin Expr Expr) -;; type Op0 = 'read-byte | 'peek-byte | 'void -;; type Op1 = 'add1 | 'sub1 | 'zero? -;; | 'char? | 'integer->char | 'char->integer -;; | 'write-byte | 'eof-object? -(struct Eof () #:prefab) -(struct Int (i) #:prefab) -(struct Bool (b) #:prefab) -(struct Char (c) #:prefab) -(struct Prim0 (p) #:prefab) -(struct Prim1 (p e) #:prefab) -(struct If (e1 e2 e3) #:prefab) -(struct Begin (e1 e2) #:prefab) diff --git a/langs/evildoer/build-runtime.rkt b/langs/evildoer/build-runtime.rkt deleted file mode 100644 index 1cc4da53..00000000 --- a/langs/evildoer/build-runtime.rkt +++ /dev/null @@ -1,12 +0,0 @@ -#lang racket -(provide runtime-path) - -(require racket/runtime-path) -(define-runtime-path here ".") - -(system (string-append "make -C '" - (path->string (normalize-path here)) - "' runtime.o")) - -(define runtime-path - (normalize-path (build-path here "runtime.o"))) \ No newline at end of file diff --git a/langs/evildoer/compile-ops.rkt b/langs/evildoer/compile-ops.rkt deleted file mode 100644 index 2fed4add..00000000 --- a/langs/evildoer/compile-ops.rkt +++ /dev/null @@ -1,47 +0,0 @@ -#lang racket -(provide (all-defined-out)) -(require "ast.rkt" "types.rkt" a86/ast) - -(define rax 'rax) ; return -(define rdi 'rdi) ; arg -(define r9 'r9) ; scratch - -;; Op0 -> Asm -(define (compile-op0 p) - (match p - ['void (seq (Mov rax (value->bits (void))))] - ['read-byte (seq (Call 'read_byte))] - ['peek-byte (seq (Call 'peek_byte))])) - -;; Op1 -> Asm -(define (compile-op1 p) - (match p - ['add1 (Add rax (value->bits 1))] - ['sub1 (Sub rax (value->bits 1))] - ['zero? - (seq (Cmp rax 0) - (if-equal))] - ['char? - (seq (And rax mask-char) - (Cmp rax type-char) - (if-equal))] - ['char->integer - (seq (Sar rax char-shift) - (Sal rax int-shift))] - ['integer->char - (seq (Sar rax int-shift) - (Sal rax char-shift) - (Xor rax type-char))] - ['eof-object? - (seq (Cmp rax (value->bits eof)) - (if-equal))] - ['write-byte - (seq (Mov rdi rax) - (Call 'write_byte))])) - -;; -> Asm -;; set rax to #t or #f if comparison flag is equal -(define (if-equal) - (seq (Mov rax (value->bits #f)) - (Mov r9 (value->bits #t)) - (Cmove rax r9))) diff --git a/langs/evildoer/compile-stdin.rkt b/langs/evildoer/compile-stdin.rkt deleted file mode 100644 index 5fbdbded..00000000 --- a/langs/evildoer/compile-stdin.rkt +++ /dev/null @@ -1,10 +0,0 @@ -#lang racket -(provide main) -(require "parse.rkt" "compile.rkt" a86/printer) - -;; -> Void -;; Compile contents of stdin, -;; emit asm code on stdout -(define (main) - (read-line) ; ignore #lang racket line - (asm-display (compile (parse (read))))) diff --git a/langs/evildoer/compile.rkt b/langs/evildoer/compile.rkt deleted file mode 100644 index 56e53ae4..00000000 --- a/langs/evildoer/compile.rkt +++ /dev/null @@ -1,62 +0,0 @@ -#lang racket -(provide (all-defined-out)) -(require "ast.rkt" "types.rkt" "compile-ops.rkt" a86/ast) - -;; Registers used -(define rax 'rax) -(define rsp 'rsp) - -;; Expr -> Asm -(define (compile e) - (prog (Extern 'peek_byte) - (Extern 'read_byte) - (Extern 'write_byte) - (Global 'entry) - (Label 'entry) - (Sub rsp 8) - (compile-e e) - (Add rsp 8) - (Ret))) - -;; Expr -> Asm -(define (compile-e e) - (match e - [(Int i) (compile-value i)] - [(Bool b) (compile-value b)] - [(Char c) (compile-value c)] - [(Eof) (compile-value eof)] - [(Prim0 p) (compile-prim0 p)] - [(Prim1 p e) (compile-prim1 p e)] - [(If e1 e2 e3) (compile-if e1 e2 e3)] - [(Begin e1 e2) (compile-begin e1 e2)])) - -;; Value -> Asm -(define (compile-value v) - (seq (Mov rax (value->bits v)))) - -;; Op0 -> Asm -(define (compile-prim0 p) - (compile-op0 p)) - -;; Op1 Expr -> Asm -(define (compile-prim1 p e) - (seq (compile-e e) - (compile-op1 p))) - -;; Expr Expr Expr -> Asm -(define (compile-if e1 e2 e3) - (let ((l1 (gensym 'if)) - (l2 (gensym 'if))) - (seq (compile-e e1) - (Cmp rax (value->bits #f)) - (Je l1) - (compile-e e2) - (Jmp l2) - (Label l1) - (compile-e e3) - (Label l2)))) - -;; Expr Expr -> Asm -(define (compile-begin e1 e2) - (seq (compile-e e1) - (compile-e e2))) diff --git a/langs/evildoer/info.rkt b/langs/evildoer/info.rkt new file mode 100644 index 00000000..41ec40bb --- /dev/null +++ b/langs/evildoer/info.rkt @@ -0,0 +1,2 @@ +#lang info +(define pre-install-collection "../installer.rkt") diff --git a/langs/evildoer/interp-io.rkt b/langs/evildoer/interp-io.rkt deleted file mode 100644 index ff74f010..00000000 --- a/langs/evildoer/interp-io.rkt +++ /dev/null @@ -1,12 +0,0 @@ -#lang racket -(provide interp/io) -(require "interp.rkt") - -;; Expr String -> (Cons Value String) -;; Interpret e with given string as input, -;; return value and collected output as string -(define (interp/io e input) - (parameterize ((current-output-port (open-output-string)) - (current-input-port (open-input-string input))) - (cons (interp e) - (get-output-string (current-output-port))))) diff --git a/langs/evildoer/interp-prim.rkt b/langs/evildoer/interp-prim.rkt deleted file mode 100644 index 088e3235..00000000 --- a/langs/evildoer/interp-prim.rkt +++ /dev/null @@ -1,21 +0,0 @@ -#lang racket -(provide interp-prim0 interp-prim1) - -;; Op0 -> Value -(define (interp-prim0 op) - (match op - ['read-byte (read-byte)] - ['peek-byte (peek-byte)] - ['void (void)])) - -;; Op1 Value -> Value -(define (interp-prim1 op v) - (match op - ['add1 (add1 v)] - ['sub1 (sub1 v)] - ['zero? (zero? v)] - ['char? (char? v)] - ['integer->char (integer->char v)] - ['char->integer (char->integer v)] - ['write-byte (write-byte v)] - ['eof-object? (eof-object? v)])) diff --git a/langs/evildoer/interp-stdin.rkt b/langs/evildoer/interp-stdin.rkt deleted file mode 100644 index 8026d746..00000000 --- a/langs/evildoer/interp-stdin.rkt +++ /dev/null @@ -1,12 +0,0 @@ -#lang racket -(provide main) -(require "parse.rkt" "interp.rkt") - -;; -> Void -;; Parse and interpret contents of stdin, -;; print result on stdout -(define (main) - (read-line) ; ignore #lang racket line - (let ((r (interp (parse (read))))) - (unless (void? r) - (println r)))) diff --git a/langs/evildoer/interp.rkt b/langs/evildoer/interp.rkt deleted file mode 100644 index 39778c6b..00000000 --- a/langs/evildoer/interp.rkt +++ /dev/null @@ -1,29 +0,0 @@ -#lang racket -(provide interp) -(require "ast.rkt" "interp-prim.rkt") - -;; type Value = -;; | Integer -;; | Boolean -;; | Character -;; | Eof -;; | Void - -;; Expr -> Value -(define (interp e) - (match e - [(Int i) i] - [(Bool b) b] - [(Char c) c] - [(Eof) eof] - [(Prim0 p) - (interp-prim0 p)] - [(Prim1 p e0) - (interp-prim1 p (interp e0))] - [(If e1 e2 e3) - (if (interp e1) - (interp e2) - (interp e3))] - [(Begin e1 e2) - (begin (interp e1) - (interp e2))])) diff --git a/langs/evildoer/io.c b/langs/evildoer/io.c index 7ef82281..8a417c91 100644 --- a/langs/evildoer/io.c +++ b/langs/evildoer/io.c @@ -7,14 +7,14 @@ val_t read_byte(void) { char c = getc(in); - return (c == EOF) ? val_wrap_eof() : val_wrap_int(c); + return (c == EOF) ? val_wrap_eof() : val_wrap_byte(c); } val_t peek_byte(void) { char c = getc(in); ungetc(c, in); - return (c == EOF) ? val_wrap_eof() : val_wrap_int(c); + return (c == EOF) ? val_wrap_eof() : val_wrap_byte(c); } diff --git a/langs/evildoer/parse.rkt b/langs/evildoer/parse.rkt deleted file mode 100644 index 76a905bb..00000000 --- a/langs/evildoer/parse.rkt +++ /dev/null @@ -1,24 +0,0 @@ -#lang racket -(provide parse) -(require "ast.rkt") - -;; S-Expr -> Expr -(define (parse s) - (match s - ['eof (Eof)] - [(? exact-integer?) (Int s)] - [(? boolean?) (Bool s)] - [(? char?) (Char s)] - [(list (? op0? o)) (Prim0 o)] - [(list (? op1? o) e) (Prim1 o (parse e))] - [(list 'begin e1 e2) (Begin (parse e1) (parse e2))] - [(list 'if e1 e2 e3) - (If (parse e1) (parse e2) (parse e3))] - [_ (error "Parse error")])) - -;; Any -> Boolean -(define (op0? x) - (memq x '(read-byte peek-byte void))) -(define (op1? x) - (memq x '(add1 sub1 zero? char? integer->char char->integer - write-byte eof-object?))) diff --git a/langs/evildoer/types.rkt b/langs/evildoer/types.rkt deleted file mode 100644 index 28a5c69e..00000000 --- a/langs/evildoer/types.rkt +++ /dev/null @@ -1,34 +0,0 @@ -#lang racket -(provide (all-defined-out)) - -(define int-shift 1) -(define char-shift 2) -(define type-int #b0) -(define type-char #b01) -(define mask-char #b11) -(define val-true #b0011) -(define val-false #b0111) -(define val-eof #b1011) -(define val-void #b1111) - -(define (bits->value b) - (cond [(= type-int (bitwise-and b #b1)) - (arithmetic-shift b (- int-shift))] - [(= type-char (bitwise-and b #b11)) - (integer->char (arithmetic-shift b (- char-shift)))] - [(= b val-true) #t] - [(= b val-false) #f] - [(= b val-eof) eof] - [(= b val-void) (void)] - [else (error "invalid bits")])) - -(define (value->bits v) - (cond [(eof-object? v) val-eof] - [(integer? v) (arithmetic-shift v int-shift)] - [(char? v) - (bitwise-ior type-char - (arithmetic-shift (char->integer v) char-shift))] - [(eq? v #t) val-true] - [(eq? v #f) val-false] - [(void? v) val-void])) - diff --git a/langs/evildoer/values.c b/langs/evildoer/values.c index 9bd2a704..bfdcf630 100644 --- a/langs/evildoer/values.c +++ b/langs/evildoer/values.c @@ -29,6 +29,10 @@ val_t val_wrap_int(int64_t i) { return (i << int_shift) | int_type_tag; } +val_t val_wrap_byte(unsigned char b) +{ + return (b << int_shift) | int_type_tag; +} int val_unwrap_bool(val_t x) { diff --git a/langs/evildoer/values.h b/langs/evildoer/values.h index 39cc43df..44f1c536 100644 --- a/langs/evildoer/values.h +++ b/langs/evildoer/values.h @@ -28,6 +28,7 @@ type_t val_typeof(val_t x); */ int64_t val_unwrap_int(val_t x); val_t val_wrap_int(int64_t i); +val_t val_wrap_byte(unsigned char b); int val_unwrap_bool(val_t x); val_t val_wrap_bool(int b); diff --git a/langs/extort/Makefile b/langs/extort/Makefile index 05d677a9..4c6bde9a 100644 --- a/langs/extort/Makefile +++ b/langs/extort/Makefile @@ -37,7 +37,8 @@ runtime.o: $(objs) cat $< | racket -t compile-stdin.rkt -m > $@ clean: - rm *.o *.s *.run + @$(RM) *.o *.s *.run ||: + @echo "$(shell basename $(shell pwd)): cleaned!" %.test: %.run %.rkt @test "$(shell ./$(<))" = "$(shell racket $(word 2,$^))" diff --git a/langs/extort/ast.rkt b/langs/extort/ast.rkt deleted file mode 100644 index adfb4ba9..00000000 --- a/langs/extort/ast.rkt +++ /dev/null @@ -1,24 +0,0 @@ -#lang racket -(provide Eof Int Bool Char Prim0 Prim1 If Begin) - -;; type Expr = -;; | (Eof) -;; | (Int Integer) -;; | (Bool Boolean) -;; | (Char Character) -;; | (Prim0 Op0) -;; | (Prim1 Op1 Expr) -;; | (If Expr Expr Expr) -;; | (Begin Expr Expr) -;; type Op0 = 'read-byte | 'peek-byte | 'void -;; type Op1 = 'add1 | 'sub1 | 'zero? -;; | 'char? | 'integer->char | 'char->integer -;; | 'write-byte | 'eof-object? -(struct Eof () #:prefab) -(struct Int (i) #:prefab) -(struct Bool (b) #:prefab) -(struct Char (c) #:prefab) -(struct Prim0 (p) #:prefab) -(struct Prim1 (p e) #:prefab) -(struct If (e1 e2 e3) #:prefab) -(struct Begin (e1 e2) #:prefab) diff --git a/langs/extort/build-runtime.rkt b/langs/extort/build-runtime.rkt deleted file mode 100644 index 1cc4da53..00000000 --- a/langs/extort/build-runtime.rkt +++ /dev/null @@ -1,12 +0,0 @@ -#lang racket -(provide runtime-path) - -(require racket/runtime-path) -(define-runtime-path here ".") - -(system (string-append "make -C '" - (path->string (normalize-path here)) - "' runtime.o")) - -(define runtime-path - (normalize-path (build-path here "runtime.o"))) \ No newline at end of file diff --git a/langs/extort/compile-ops.rkt b/langs/extort/compile-ops.rkt deleted file mode 100644 index dbc4ff22..00000000 --- a/langs/extort/compile-ops.rkt +++ /dev/null @@ -1,97 +0,0 @@ -#lang racket -(provide (all-defined-out)) -(require "ast.rkt" "types.rkt" a86/ast) - -(define rax 'rax) ; return -(define rdi 'rdi) ; arg -(define r9 'r9) ; scratch - -;; Op0 -> Asm -(define (compile-op0 p) - (match p - ['void (seq (Mov rax (value->bits (void))))] - ['read-byte (seq (Call 'read_byte))] - ['peek-byte (seq (Call 'peek_byte))])) - -;; Op1 -> Asm -(define (compile-op1 p) - (match p - ['add1 - (seq (assert-integer rax) - (Add rax (value->bits 1)))] - ['sub1 - (seq (assert-integer rax) - (Sub rax (value->bits 1)))] - ['zero? - (seq (assert-integer rax) - (Cmp rax 0) - (if-equal))] - ['char? - (type-pred mask-char type-char)] - ['char->integer - (seq (assert-char rax) - (Sar rax char-shift) - (Sal rax int-shift))] - ['integer->char - (seq (assert-codepoint) - (Sar rax int-shift) - (Sal rax char-shift) - (Xor rax type-char))] - ['eof-object? (eq-value eof)] - ['write-byte - (seq (assert-byte) - (Mov rdi rax) - (Call 'write_byte))])) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define (assert-type mask type) - (λ (arg) - (seq (Mov r9 arg) - (And r9 mask) - (Cmp r9 type) - (Jne 'err)))) - -(define (type-pred mask type) - (seq (And rax mask) - (Cmp rax type) - (if-equal))) - -(define assert-integer - (assert-type mask-int type-int)) -(define assert-char - (assert-type mask-char type-char)) - -(define (assert-codepoint) - (let ((ok (gensym))) - (seq (assert-integer rax) - (Cmp rax (value->bits 0)) - (Jl 'err) - (Cmp rax (value->bits 1114111)) - (Jg 'err) - (Cmp rax (value->bits 55295)) - (Jl ok) - (Cmp rax (value->bits 57344)) - (Jg ok) - (Jmp 'err) - (Label ok)))) - -(define (assert-byte) - (seq (assert-integer rax) - (Cmp rax (value->bits 0)) - (Jl 'err) - (Cmp rax (value->bits 255)) - (Jg 'err))) - -;; -> Asm -;; set rax to #t or #f if comparison flag is equal -(define (if-equal) - (seq (Mov rax (value->bits #f)) - (Mov r9 (value->bits #t)) - (Cmove rax r9))) - -;; Value -> Asm -(define (eq-value v) - (seq (Cmp rax (value->bits v)) - (if-equal))) diff --git a/langs/extort/compile-stdin.rkt b/langs/extort/compile-stdin.rkt deleted file mode 100644 index 5fbdbded..00000000 --- a/langs/extort/compile-stdin.rkt +++ /dev/null @@ -1,10 +0,0 @@ -#lang racket -(provide main) -(require "parse.rkt" "compile.rkt" a86/printer) - -;; -> Void -;; Compile contents of stdin, -;; emit asm code on stdout -(define (main) - (read-line) ; ignore #lang racket line - (asm-display (compile (parse (read))))) diff --git a/langs/extort/compile.rkt b/langs/extort/compile.rkt deleted file mode 100644 index 9b8cad02..00000000 --- a/langs/extort/compile.rkt +++ /dev/null @@ -1,66 +0,0 @@ -#lang racket -(provide (all-defined-out)) -(require "ast.rkt" "types.rkt" "compile-ops.rkt" a86/ast) - -;; Registers used -(define rax 'rax) ; return -(define rsp 'rsp) ; stack - -;; Expr -> Asm -(define (compile e) - (prog (Extern 'peek_byte) - (Extern 'read_byte) - (Extern 'write_byte) - (Extern 'raise_error) - (Global 'entry) - (Label 'entry) - (Sub 'rsp 8) - (compile-e e) - (Add 'rsp 8) - (Ret) - ;; Error handler - (Label 'err) - (Call 'raise_error))) - -;; Expr -> Asm -(define (compile-e e) - (match e - [(Int i) (compile-value i)] - [(Bool b) (compile-value b)] - [(Char c) (compile-value c)] - [(Eof) (compile-value eof)] - [(Prim0 p) (compile-prim0 p)] - [(Prim1 p e) (compile-prim1 p e)] - [(If e1 e2 e3) (compile-if e1 e2 e3)] - [(Begin e1 e2) (compile-begin e1 e2)])) - -;; Value -> Asm -(define (compile-value v) - (seq (Mov rax (value->bits v)))) - -;; Op0 -> Asm -(define (compile-prim0 p) - (compile-op0 p)) - -;; Op1 Expr -> Asm -(define (compile-prim1 p e) - (seq (compile-e e) - (compile-op1 p))) - -;; Expr Expr Expr -> Asm -(define (compile-if e1 e2 e3) - (let ((l1 (gensym 'if)) - (l2 (gensym 'if))) - (seq (compile-e e1) - (Cmp rax (value->bits #f)) - (Je l1) - (compile-e e2) - (Jmp l2) - (Label l1) - (compile-e e3) - (Label l2)))) - -;; Expr Expr -> Asm -(define (compile-begin e1 e2) - (seq (compile-e e1) - (compile-e e2))) diff --git a/langs/extort/info.rkt b/langs/extort/info.rkt new file mode 100644 index 00000000..41ec40bb --- /dev/null +++ b/langs/extort/info.rkt @@ -0,0 +1,2 @@ +#lang info +(define pre-install-collection "../installer.rkt") diff --git a/langs/extort/interp-io.rkt b/langs/extort/interp-io.rkt deleted file mode 100644 index 12da1b4b..00000000 --- a/langs/extort/interp-io.rkt +++ /dev/null @@ -1,12 +0,0 @@ -#lang racket -(provide interp/io) -(require "interp.rkt") - -;; Expr String -> (Cons Value String) -;; Interpret e with given string as input, -;; collect output as string (including printed result) -(define (interp/io e input) - (parameterize ((current-output-port (open-output-string)) - (current-input-port (open-input-string input))) - (cons (interp e) - (get-output-string (current-output-port))))) diff --git a/langs/extort/interp-prim.rkt b/langs/extort/interp-prim.rkt deleted file mode 100644 index e0ac5dac..00000000 --- a/langs/extort/interp-prim.rkt +++ /dev/null @@ -1,27 +0,0 @@ -#lang racket -(provide interp-prim0 interp-prim1) - -;; Op0 -> Answer -(define (interp-prim0 op) - (match op - ['read-byte (read-byte)] - ['peek-byte (peek-byte)] - ['void (void)])) - -;; Op1 Value -> Answer -(define (interp-prim1 op v) - (match op - ['add1 (if (integer? v) (add1 v) 'err)] - ['sub1 (if (integer? v) (sub1 v) 'err)] - ['zero? (if (integer? v) (zero? v) 'err)] - ['char? (char? v)] - ['char->integer (if (char? v) (char->integer v) 'err)] - ['integer->char (if (codepoint? v) (integer->char v) 'err)] - ['eof-object? (eof-object? v)] - ['write-byte (if (byte? v) (write-byte v) 'err)])) - -;; Any -> Boolean -(define (codepoint? v) - (and (integer? v) - (or (<= 0 v 55295) - (<= 57344 v 1114111)))) diff --git a/langs/extort/interp-stdin.rkt b/langs/extort/interp-stdin.rkt deleted file mode 100644 index 8026d746..00000000 --- a/langs/extort/interp-stdin.rkt +++ /dev/null @@ -1,12 +0,0 @@ -#lang racket -(provide main) -(require "parse.rkt" "interp.rkt") - -;; -> Void -;; Parse and interpret contents of stdin, -;; print result on stdout -(define (main) - (read-line) ; ignore #lang racket line - (let ((r (interp (parse (read))))) - (unless (void? r) - (println r)))) diff --git a/langs/extort/interp.rkt b/langs/extort/interp.rkt deleted file mode 100644 index 86836693..00000000 --- a/langs/extort/interp.rkt +++ /dev/null @@ -1,37 +0,0 @@ -#lang racket -(provide interp) -(require "ast.rkt" "interp-prim.rkt") - -;; type Answer = Value | 'err - -;; type Value = -;; | Integer -;; | Boolean -;; | Character -;; | Eof -;; | Void - -;; Expr -> Answer -(define (interp e) - (match e - [(Int i) i] - [(Bool b) b] - [(Char c) c] - [(Eof) eof] - [(Prim0 p) - (interp-prim0 p)] - [(Prim1 p e0) - (match (interp e0) - ['err 'err] - [v (interp-prim1 p v)])] - [(If e1 e2 e3) - (match (interp e1) - ['err 'err] - [v - (if v - (interp e2) - (interp e3))])] - [(Begin e1 e2) - (match (interp e1) - ['err 'err] - [_ (interp e2)])])) diff --git a/langs/extort/io.c b/langs/extort/io.c index 7ef82281..8a417c91 100644 --- a/langs/extort/io.c +++ b/langs/extort/io.c @@ -7,14 +7,14 @@ val_t read_byte(void) { char c = getc(in); - return (c == EOF) ? val_wrap_eof() : val_wrap_int(c); + return (c == EOF) ? val_wrap_eof() : val_wrap_byte(c); } val_t peek_byte(void) { char c = getc(in); ungetc(c, in); - return (c == EOF) ? val_wrap_eof() : val_wrap_int(c); + return (c == EOF) ? val_wrap_eof() : val_wrap_byte(c); } diff --git a/langs/extort/parse.rkt b/langs/extort/parse.rkt deleted file mode 100644 index 65503e24..00000000 --- a/langs/extort/parse.rkt +++ /dev/null @@ -1,26 +0,0 @@ -#lang racket -(provide parse) -(require "ast.rkt") - -;; S-Expr -> Expr -(define (parse s) - (match s - [(? exact-integer? s) (Int s)] - [(? boolean? s) (Bool s)] - [(? char? s) (Char s)] - ['eof (Eof)] - [(list (? op0? o)) (Prim0 o)] - [(list (? op1? o) e) (Prim1 o (parse e))] - [(list 'begin e1 e2) (Begin (parse e1) (parse e2))] - [(list 'if e1 e2 e3) - (If (parse e1) (parse e2) (parse e3))] - [_ (error "Parse error")])) - -;; Any -> Boolean -(define (op0? x) - (memq x '(read-byte peek-byte void))) - -;; Any -> Boolean -(define (op1? x) - (memq x '(add1 sub1 zero? char? integer->char char->integer - write-byte eof-object?))) diff --git a/langs/extort/types.rkt b/langs/extort/types.rkt deleted file mode 100644 index 18a1415a..00000000 --- a/langs/extort/types.rkt +++ /dev/null @@ -1,35 +0,0 @@ -#lang racket -(provide (all-defined-out)) - -(define int-shift 1) -(define char-shift 2) -(define type-int #b0) -(define mask-int #b1) -(define type-char #b01) -(define mask-char #b11) -(define val-true #b0011) -(define val-false #b0111) -(define val-eof #b1011) -(define val-void #b1111) - -(define (bits->value b) - (cond [(= type-int (bitwise-and b #b1)) - (arithmetic-shift b (- int-shift))] - [(= type-char (bitwise-and b #b11)) - (integer->char (arithmetic-shift b (- char-shift)))] - [(= b val-true) #t] - [(= b val-false) #f] - [(= b val-eof) eof] - [(= b val-void) (void)] - [else (error "invalid bits")])) - -(define (value->bits v) - (cond [(eof-object? v) val-eof] - [(integer? v) (arithmetic-shift v int-shift)] - [(char? v) - (bitwise-ior type-char - (arithmetic-shift (char->integer v) char-shift))] - [(eq? v #t) val-true] - [(eq? v #f) val-false] - [(void? v) val-void])) - diff --git a/langs/extort/values.c b/langs/extort/values.c index 9bd2a704..bfdcf630 100644 --- a/langs/extort/values.c +++ b/langs/extort/values.c @@ -29,6 +29,10 @@ val_t val_wrap_int(int64_t i) { return (i << int_shift) | int_type_tag; } +val_t val_wrap_byte(unsigned char b) +{ + return (b << int_shift) | int_type_tag; +} int val_unwrap_bool(val_t x) { diff --git a/langs/extort/values.h b/langs/extort/values.h index 39cc43df..44f1c536 100644 --- a/langs/extort/values.h +++ b/langs/extort/values.h @@ -28,6 +28,7 @@ type_t val_typeof(val_t x); */ int64_t val_unwrap_int(val_t x); val_t val_wrap_int(int64_t i); +val_t val_wrap_byte(unsigned char b); int val_unwrap_bool(val_t x); val_t val_wrap_bool(int b); diff --git a/langs/fraud/Makefile b/langs/fraud/Makefile index 9055c88f..db6ac44a 100644 --- a/langs/fraud/Makefile +++ b/langs/fraud/Makefile @@ -37,7 +37,8 @@ runtime.o: $(objs) cat $< | racket -t compile-stdin.rkt -m > $@ clean: - rm *.o *.s *.run + @$(RM) *.o *.s *.run ||: + @echo "$(shell basename $(shell pwd)): cleaned!" %.test: %.run %.rkt @test "$(shell ./$(<))" = "$(shell racket $(word 2,$^))" diff --git a/langs/fraud/ast.rkt b/langs/fraud/ast.rkt index 975405a9..d01004f8 100644 --- a/langs/fraud/ast.rkt +++ b/langs/fraud/ast.rkt @@ -1,32 +1,34 @@ #lang racket -(provide Eof Int Bool Char Prim0 Prim1 Prim2 If Begin Let Var) +(provide Lit Prim0 Prim1 Prim2 If Eof Begin Let + Var) +;; +;; type Expr = (Lit Datum) +;; | (Eof) +;; | (Prim0 Op0) +;; | (Prim1 Op1 Expr) +;; | (Prim2 Op2 Expr Expr) +;; | (If Expr Expr Expr) +;; | (Let Id Expr Expr) +;; | (Var Id) -;; type Expr = -;; | (Eof) -;; | (Int Integer) -;; | (Bool Boolean) -;; | (Char Character) -;; | (Prim0 Op0) -;; | (Prim1 Op1 Expr) -;; | (Prim2 Op2 Expr Expr) -;; | (If Expr Expr Expr) -;; | (Begin Expr Expr) -;; | (Let Id Expr Expr) -;; | (Var Id) ;; type Id = Symbol -;; type Op0 = 'read-byte -;; type Op1 = 'add1 | 'sub1 | 'zero? +;; type Datum = Integer +;; | Boolean +;; | Character +;; type Op0 = 'read-byte | 'peek-byte | 'void +;; type Op1 = 'add1 | 'sub1 +;; | 'zero? ;; | 'char? | 'integer->char | 'char->integer ;; | 'write-byte | 'eof-object? ;; type Op2 = '+ | '- | '< | '= -(struct Eof () #:prefab) -(struct Int (i) #:prefab) -(struct Bool (b) #:prefab) -(struct Char (c) #:prefab) -(struct Prim0 (p) #:prefab) -(struct Prim1 (p e) #:prefab) + +(struct Eof () #:prefab) +(struct Lit (d) #:prefab) +(struct Prim0 (p) #:prefab) +(struct Prim1 (p e) #:prefab) (struct Prim2 (p e1 e2) #:prefab) -(struct If (e1 e2 e3) #:prefab) -(struct Begin (e1 e2) #:prefab) -(struct Let (x e1 e2) #:prefab) -(struct Var (x) #:prefab) +(struct If (e1 e2 e3) #:prefab) +(struct Begin (e1 e2) #:prefab) +(struct Let (x e1 e2) #:prefab) +(struct Var (x) #:prefab) + diff --git a/langs/fraud/build-runtime.rkt b/langs/fraud/build-runtime.rkt index 1cc4da53..18431504 100644 --- a/langs/fraud/build-runtime.rkt +++ b/langs/fraud/build-runtime.rkt @@ -4,9 +4,11 @@ (require racket/runtime-path) (define-runtime-path here ".") -(system (string-append "make -C '" - (path->string (normalize-path here)) - "' runtime.o")) +(unless (system (string-append "make -C '" + (path->string (normalize-path here)) + "' runtime.o")) + (error 'build-runtime "could not build runtime")) (define runtime-path - (normalize-path (build-path here "runtime.o"))) \ No newline at end of file + (normalize-path (build-path here "runtime.o"))) + diff --git a/langs/fraud/compile-ops.rkt b/langs/fraud/compile-ops.rkt index 7d07ca16..5db56cd6 100644 --- a/langs/fraud/compile-ops.rkt +++ b/langs/fraud/compile-ops.rkt @@ -1,11 +1,13 @@ #lang racket -(provide (all-defined-out)) -(require "ast.rkt" "types.rkt" a86/ast) +(provide compile-op0 compile-op1 compile-op2 pad-stack) +(require "ast.rkt") +(require "types.rkt") +(require a86/ast) -(define rax 'rax) ; return -(define rdi 'rdi) ; arg -(define r8 'r8) ; scratch in +, - +(define rax 'rax)(define rdi 'rdi) ; arg +(define r8 'r8) ; scratch in op2 (define r9 'r9) ; scratch + (define r15 'r15) ; stack pad (non-volatile) (define rsp 'rsp) ; stack @@ -13,44 +15,45 @@ (define (compile-op0 p) (match p ['void (seq (Mov rax (value->bits (void))))] - ['read-byte (seq pad-stack - (Call 'read_byte) - unpad-stack)] - ['peek-byte (seq pad-stack - (Call 'peek_byte) - unpad-stack)])) + ['read-byte (seq pad-stack (Call 'read_byte) unpad-stack)] + ['peek-byte (seq pad-stack (Call 'peek_byte) unpad-stack)])) ;; Op1 -> Asm (define (compile-op1 p) (match p ['add1 - (seq (assert-integer rax) - (Add rax (value->bits 1)))] + (seq (assert-integer rax) + (Add rax (value->bits 1)))] ['sub1 - (seq (assert-integer rax) - (Sub rax (value->bits 1)))] + (seq (assert-integer rax) + (Sub rax (value->bits 1)))] ['zero? - (seq (assert-integer rax) - (Cmp rax 0) - (if-equal))] + (seq (assert-integer rax) + (Cmp rax 0) + if-equal)] ['char? - (type-pred mask-char type-char)] + (seq (And rax mask-char) + (Cmp rax type-char) + if-equal)] ['char->integer - (seq (assert-char rax) - (Sar rax char-shift) - (Sal rax int-shift))] + (seq (assert-char rax) + (Sar rax char-shift) + (Sal rax int-shift))] ['integer->char - (seq (assert-codepoint rax) - (Sar rax int-shift) - (Sal rax char-shift) - (Xor rax type-char))] - ['eof-object? (eq-value eof)] + (seq (assert-codepoint) + (Sar rax int-shift) + (Sal rax char-shift) + (Xor rax type-char))] + ['eof-object? + (seq (Cmp rax (value->bits eof)) + if-equal)] ['write-byte - (seq (assert-byte rax) - pad-stack - (Mov rdi rax) - (Call 'write_byte) - unpad-stack)])) + (seq assert-byte + pad-stack + (Mov rdi rax) + (Call 'write_byte) + unpad-stack)])) + ;; Op2 -> Asm (define (compile-op2 p) @@ -71,69 +74,66 @@ (assert-integer r8) (assert-integer rax) (Cmp r8 rax) - (if-lt))] + if-lt)] ['= (seq (Pop r8) (assert-integer r8) (assert-integer rax) - (Cmp r8 rax) - (if-equal))])) - + (Cmp r8 rax) + if-equal)])) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; -> Asm +;; set rax to #t or #f if comparison flag is equal +(define if-equal + (seq (Mov rax (value->bits #f)) + (Mov r9 (value->bits #t)) + (Cmove rax r9))) + +;; -> Asm +;; set rax to #t or #f if comparison flag is less than +(define if-lt + (seq (Mov rax (value->bits #f)) + (Mov r9 (value->bits #t)) + (Cmovl rax r9))) (define (assert-type mask type) (λ (arg) (seq (Mov r9 arg) (And r9 mask) (Cmp r9 type) - (Jne 'raise_error_align)))) + (Jne 'err)))) (define (type-pred mask type) (seq (And rax mask) (Cmp rax type) - (if-equal))) + if-equal)) (define assert-integer (assert-type mask-int type-int)) (define assert-char (assert-type mask-char type-char)) -(define (assert-codepoint r) +(define (assert-codepoint) (let ((ok (gensym))) - (seq (assert-integer r) - (Cmp r (value->bits 0)) - (Jl 'raise_error_align) + (seq (assert-integer rax) + (Cmp rax (value->bits 0)) + (Jl 'err) (Cmp rax (value->bits 1114111)) - (Jg 'raise_error_align) + (Jg 'err) (Cmp rax (value->bits 55295)) (Jl ok) (Cmp rax (value->bits 57344)) (Jg ok) - (Jmp 'raise_error_align) + (Jmp 'err) (Label ok)))) -(define (assert-byte r) - (seq (assert-integer r) - (Cmp r (value->bits 0)) - (Jl 'raise_error_align) - (Cmp r (value->bits 255)) - (Jg 'raise_error_align))) - -;; -> Asm -;; set rax to #t or #f based on given comparison -(define (if-compare c) - (seq (Mov rax (value->bits #f)) - (Mov r9 (value->bits #t)) - (c rax r9))) - -(define (if-equal) (if-compare Cmove)) -(define (if-lt) (if-compare Cmovl)) - -;; Value -> Asm -(define (eq-value v) - (seq (Cmp rax (value->bits v)) - (if-equal))) +(define assert-byte + (seq (assert-integer rax) + (Cmp rax (value->bits 0)) + (Jl 'err) + (Cmp rax (value->bits 255)) + (Jg 'err))) ;; Asm ;; Dynamically pad the stack to be aligned for a call @@ -146,3 +146,4 @@ ;; Undo the stack alignment after a call (define unpad-stack (seq (Add rsp r15))) + diff --git a/langs/fraud/compile-stdin.rkt b/langs/fraud/compile-stdin.rkt index 5fbdbded..532ee0eb 100644 --- a/langs/fraud/compile-stdin.rkt +++ b/langs/fraud/compile-stdin.rkt @@ -1,6 +1,8 @@ #lang racket (provide main) -(require "parse.rkt" "compile.rkt" a86/printer) +(require "parse.rkt") +(require "compile.rkt") +(require a86/printer) ;; -> Void ;; Compile contents of stdin, @@ -8,3 +10,4 @@ (define (main) (read-line) ; ignore #lang racket line (asm-display (compile (parse (read))))) + diff --git a/langs/fraud/compile.rkt b/langs/fraud/compile.rkt index 02c8a728..bb9cee39 100644 --- a/langs/fraud/compile.rkt +++ b/langs/fraud/compile.rkt @@ -1,45 +1,46 @@ #lang racket (provide (all-defined-out)) -(require "ast.rkt" "types.rkt" "compile-ops.rkt" a86/ast) +(require "ast.rkt") +(require "compile-ops.rkt") +(require "types.rkt") +(require a86/ast) -;; Registers used -(define rax 'rax) ; return -(define rsp 'rsp) ; stack -(define rdi 'rdi) ; arg +(define rax 'rax)(define rsp 'rsp) ; stack (define r15 'r15) ; stack pad (non-volatile) -;; type CEnv = (Listof [Maybe Id]) - ;; Expr -> Asm (define (compile e) - (prog (Extern 'peek_byte) + (prog (Global 'entry) + (Extern 'peek_byte) (Extern 'read_byte) (Extern 'write_byte) (Extern 'raise_error) - (Global 'entry) (Label 'entry) (Push r15) ; save callee-saved register (compile-e e '()) (Pop r15) ; restore callee-save register (Ret) - (Label 'raise_error_align) + ;; Error handler + (Label 'err) pad-stack (Call 'raise_error))) +;; type CEnv = (Listof [Maybe Id]) ;; Expr CEnv -> Asm (define (compile-e e c) (match e - [(Int i) (compile-value i)] - [(Bool b) (compile-value b)] - [(Char c) (compile-value c)] - [(Eof) (compile-value eof)] - [(Var x) (compile-variable x c)] - [(Prim0 p) (compile-prim0 p c)] - [(Prim1 p e) (compile-prim1 p e c)] - [(Prim2 p e1 e2) (compile-prim2 p e1 e2 c)] - [(If e1 e2 e3) (compile-if e1 e2 e3 c)] - [(Begin e1 e2) (compile-begin e1 e2 c)] - [(Let x e1 e2) (compile-let x e1 e2 c)])) + [(Lit d) (compile-value d)] + [(Eof) (compile-value eof)] + [(Var x) (compile-variable x c)] + [(Prim0 p) (compile-prim0 p)] + [(Prim1 p e) (compile-prim1 p e c)] + [(Prim2 p e1 e2) (compile-prim2 p e1 e2 c)] + [(If e1 e2 e3) + (compile-if e1 e2 e3 c)] + [(Begin e1 e2) + (compile-begin e1 e2 c)] + [(Let x e1 e2) + (compile-let x e1 e2 c)])) ;; Value -> Asm (define (compile-value v) @@ -50,11 +51,9 @@ (let ((i (lookup x c))) (seq (Mov rax (Offset rsp i))))) -;; Op0 CEnv -> Asm -(define (compile-prim0 p c) - (compile-op0 p)) - -;; Op1 Expr CEnv -> Asm +;; Op0 -> Asm +(define (compile-prim0 p) + (compile-op0 p));; Op1 Expr CEnv -> Asm (define (compile-prim1 p e c) (seq (compile-e e c) (compile-op1 p))) @@ -64,9 +63,7 @@ (seq (compile-e e1 c) (Push rax) (compile-e e2 (cons #f c)) - (compile-op2 p))) - -;; Expr Expr Expr CEnv -> Asm + (compile-op2 p)));; Expr Expr Expr CEnv -> Asm (define (compile-if e1 e2 e3 c) (let ((l1 (gensym 'if)) (l2 (gensym 'if))) @@ -77,9 +74,7 @@ (Jmp l2) (Label l1) (compile-e e3 c) - (Label l2)))) - -;; Expr Expr CEnv -> Asm + (Label l2))));; Expr Expr CEnv -> Asm (define (compile-begin e1 e2 c) (seq (compile-e e1 c) (compile-e e2 c))) @@ -99,3 +94,4 @@ (match (eq? x y) [#t 0] [#f (+ 8 (lookup x rest))])])) + diff --git a/langs/fraud/info.rkt b/langs/fraud/info.rkt new file mode 100644 index 00000000..41ec40bb --- /dev/null +++ b/langs/fraud/info.rkt @@ -0,0 +1,2 @@ +#lang info +(define pre-install-collection "../installer.rkt") diff --git a/langs/fraud/interp-io.rkt b/langs/fraud/interp-io.rkt index 12da1b4b..29a82d0b 100644 --- a/langs/fraud/interp-io.rkt +++ b/langs/fraud/interp-io.rkt @@ -2,11 +2,12 @@ (provide interp/io) (require "interp.rkt") -;; Expr String -> (Cons Value String) +;; String Expr -> (Cons Value String) ;; Interpret e with given string as input, -;; collect output as string (including printed result) +;; return value and collected output as string (define (interp/io e input) (parameterize ((current-output-port (open-output-string)) (current-input-port (open-input-string input))) (cons (interp e) (get-output-string (current-output-port))))) + diff --git a/langs/fraud/interp-lexical.rkt b/langs/fraud/interp-lexical.rkt index 88ab41eb..0d121985 100644 --- a/langs/fraud/interp-lexical.rkt +++ b/langs/fraud/interp-lexical.rkt @@ -11,10 +11,8 @@ ;; IExpr VEnv -> Answer (define (interp-env e r) (match e - [(Int i) i] - [(Bool b) b] - [(Char c) c] - [(Eof) eof] + [(Lit d) d] + [(Eof) eof] [(Var a) (list-ref r a)] [(Prim0 p) (interp-prim0 p)] [(Prim1 p e) diff --git a/langs/fraud/interp-prim.rkt b/langs/fraud/interp-prim.rkt index 4393361e..2ef28e0c 100644 --- a/langs/fraud/interp-prim.rkt +++ b/langs/fraud/interp-prim.rkt @@ -1,7 +1,7 @@ #lang racket (provide interp-prim0 interp-prim1 interp-prim2) -;; Op0 -> Answer +;; Op0 -> Value (define (interp-prim0 op) (match op ['read-byte (read-byte)] @@ -10,26 +10,29 @@ ;; Op1 Value -> Answer (define (interp-prim1 op v) - (match op - ['add1 (if (integer? v) (add1 v) 'err)] - ['sub1 (if (integer? v) (sub1 v) 'err)] - ['zero? (if (integer? v) (zero? v) 'err)] - ['char? (char? v)] - ['char->integer (if (char? v) (char->integer v) 'err)] - ['integer->char (if (codepoint? v) (integer->char v) 'err)] - ['eof-object? (eof-object? v)] - ['write-byte (if (byte? v) (write-byte v) 'err)])) + (match (list op v) + [(list 'add1 (? integer?)) (add1 v)] + [(list 'sub1 (? integer?)) (sub1 v)] + [(list 'zero? (? integer?)) (zero? v)] + [(list 'char? v) (char? v)] + [(list 'integer->char (? codepoint?)) (integer->char v)] + [(list 'char->integer (? char?)) (char->integer v)] + [(list 'write-byte (? byte?)) (write-byte v)] + [(list 'eof-object? v) (eof-object? v)] + [_ 'err])) ;; Op2 Value Value -> Answer (define (interp-prim2 op v1 v2) - (match op - ['+ (if (and (integer? v1) (integer? v2)) (+ v1 v2) 'err)] - ['- (if (and (integer? v1) (integer? v2)) (- v1 v2) 'err)] - ['< (if (and (integer? v1) (integer? v2)) (< v1 v2) 'err)] - ['= (if (and (integer? v1) (integer? v2)) (= v1 v2) 'err)])) + (match (list op v1 v2) + [(list '+ (? integer?) (? integer?)) (+ v1 v2)] + [(list '- (? integer?) (? integer?)) (- v1 v2)] + [(list '< (? integer?) (? integer?)) (< v1 v2)] + [(list '= (? integer?) (? integer?)) (= v1 v2)] + [_ 'err])) ;; Any -> Boolean (define (codepoint? v) (and (integer? v) (or (<= 0 v 55295) (<= 57344 v 1114111)))) + diff --git a/langs/fraud/interp-stdin.rkt b/langs/fraud/interp-stdin.rkt index 8026d746..ce4885f7 100644 --- a/langs/fraud/interp-stdin.rkt +++ b/langs/fraud/interp-stdin.rkt @@ -1,12 +1,12 @@ #lang racket (provide main) -(require "parse.rkt" "interp.rkt") +(require "parse.rkt") +(require "interp.rkt") ;; -> Void ;; Parse and interpret contents of stdin, ;; print result on stdout (define (main) (read-line) ; ignore #lang racket line - (let ((r (interp (parse (read))))) - (unless (void? r) - (println r)))) + (println (interp (parse (read))))) + diff --git a/langs/fraud/interp.rkt b/langs/fraud/interp.rkt index a30bc286..9510a8ab 100644 --- a/langs/fraud/interp.rkt +++ b/langs/fraud/interp.rkt @@ -1,8 +1,8 @@ #lang racket -(provide interp interp-env) -(require "ast.rkt" "interp-prim.rkt") - -;; type Answer = Value | 'err +(provide interp) +(provide interp-env) +(require "ast.rkt") +(require "interp-prim.rkt") ;; type Value = ;; | Integer @@ -12,7 +12,6 @@ ;; | Void ;; type Env = (Listof (List Id Value)) - ;; Expr -> Answer (define (interp e) (interp-env e '())) @@ -20,10 +19,8 @@ ;; Expr Env -> Answer (define (interp-env e r) (match e - [(Int i) i] - [(Bool b) b] - [(Char c) c] - [(Eof) eof] + [(Lit d) d] + [(Eof) eof] [(Var x) (lookup r x)] [(Prim0 p) (interp-prim0 p)] [(Prim1 p e) @@ -36,8 +33,8 @@ [v1 (match (interp-env e2 r) ['err 'err] [v2 (interp-prim2 p v1 v2)])])] - [(If p e1 e2) - (match (interp-env p r) + [(If e0 e1 e2) + (match (interp-env e0 r) ['err 'err] [v (if v diff --git a/langs/fraud/io.c b/langs/fraud/io.c index 7ef82281..8a417c91 100644 --- a/langs/fraud/io.c +++ b/langs/fraud/io.c @@ -7,14 +7,14 @@ val_t read_byte(void) { char c = getc(in); - return (c == EOF) ? val_wrap_eof() : val_wrap_int(c); + return (c == EOF) ? val_wrap_eof() : val_wrap_byte(c); } val_t peek_byte(void) { char c = getc(in); ungetc(c, in); - return (c == EOF) ? val_wrap_eof() : val_wrap_int(c); + return (c == EOF) ? val_wrap_eof() : val_wrap_byte(c); } diff --git a/langs/fraud/main.rkt b/langs/fraud/main.rkt new file mode 100644 index 00000000..e0e38924 --- /dev/null +++ b/langs/fraud/main.rkt @@ -0,0 +1,13 @@ +#lang racket +(require "ast.rkt") +(require "parse.rkt") +(require "interp.rkt") +(require "compile.rkt") +(require "run.rkt") +(provide (all-from-out "ast.rkt")) +(provide (all-from-out "parse.rkt")) +(provide (all-from-out "interp.rkt")) +(provide (all-from-out "compile.rkt")) +(provide (all-from-out "run.rkt")) + + diff --git a/langs/fraud/parse.rkt b/langs/fraud/parse.rkt index 2c91a9d1..8ebed102 100644 --- a/langs/fraud/parse.rkt +++ b/langs/fraud/parse.rkt @@ -5,27 +5,34 @@ ;; S-Expr -> Expr (define (parse s) (match s - [(? exact-integer?) (Int s)] - [(? boolean? s) (Bool s)] - [(? char? s) (Char s)] - ['eof (Eof)] - [(? symbol? s) (Var s)] - [(list (? op0? o)) (Prim0 o)] - [(list (? op1? o) e) (Prim1 o (parse e))] + ['eof (Eof)] + [(? datum?) (Lit s)] + [(? symbol?) (Var s)] + [(list (? op0? o)) (Prim0 o)] + [(list (? op1? o) e) (Prim1 o (parse e))] [(list (? op2? o) e1 e2) (Prim2 o (parse e1) (parse e2))] - [(list 'begin e1 e2) (Begin (parse e1) (parse e2))] + [(list 'begin e1 e2) (Begin (parse e1) (parse e2))] [(list 'if e1 e2 e3) (If (parse e1) (parse e2) (parse e3))] [(list 'let (list (list (? symbol? x) e1)) e2) (Let x (parse e1) (parse e2))] - [_ (error "Parse error" s)])) + [_ (error "Parse error")])) +;; Any -> Boolean +(define (datum? x) + (or (exact-integer? x) + (boolean? x) + (char? x))) + ;; Any -> Boolean (define (op0? x) (memq x '(read-byte peek-byte void))) + (define (op1? x) (memq x '(add1 sub1 zero? char? integer->char char->integer write-byte eof-object?))) + (define (op2? x) (memq x '(+ - < =))) + diff --git a/langs/fraud/run-stdin.rkt b/langs/fraud/run-stdin.rkt new file mode 100644 index 00000000..16cf99e0 --- /dev/null +++ b/langs/fraud/run-stdin.rkt @@ -0,0 +1,12 @@ +#lang racket +(provide main) +(require "parse.rkt") +(require "compile.rkt") +(require "run.rkt") + +;; -> Void +;; Compile contents of stdin and use asm-interp to run +(define (main) + (read-line) ; ignore #lang racket line + (run (compile (parse (read))))) + diff --git a/langs/fraud/run.rkt b/langs/fraud/run.rkt new file mode 100644 index 00000000..7745c566 --- /dev/null +++ b/langs/fraud/run.rkt @@ -0,0 +1,19 @@ +#lang racket +(require a86/interp) +(require "types.rkt") +(require "build-runtime.rkt") +(provide run run/io);; Asm -> Answer +(define (run is) + (parameterize ((current-objs (list (path->string runtime-path)))) + (match (asm-interp is) + ['err 'err] + [b (bits->value b)]))) + +;; Asm String -> (cons Answer String) +(define (run/io is in) + (parameterize ((current-objs (list (path->string runtime-path)))) + (match (asm-interp/io is in) + [(cons 'err out) (cons 'err out)] + [(cons b out) + (cons (bits->value b) out)]))) + diff --git a/langs/fraud/test/compile.rkt b/langs/fraud/test/compile.rkt index 64184117..d52b46dd 100644 --- a/langs/fraud/test/compile.rkt +++ b/langs/fraud/test/compile.rkt @@ -1,24 +1,10 @@ #lang racket -(require "../compile.rkt" - "../parse.rkt" - "../types.rkt" - "test-runner.rkt" - a86/interp) +(require "../compile.rkt") +(require "../parse.rkt") +(require "../run.rkt") +(require "test-runner.rkt") -;; link with runtime for IO operations -(unless (file-exists? "../runtime.o") - (system "make -C .. runtime.o")) -(current-objs - (list (path->string (normalize-path "../runtime.o")))) - -(test-runner (λ (e) (match (asm-interp (compile (parse e))) - ['err 'err] - [bs (bits->value bs)]))) - -(test-runner-io (λ (e s) - (match (asm-interp/io (compile (parse e)) s) - [(cons 'err o) (cons 'err o)] - [(cons r o) - (cons (bits->value r) o)]))) +(test (λ (e) (run (compile (parse e))))) +(test/io (λ (in e) (run/io (compile (parse e)) in))) diff --git a/langs/fraud/test/interp.rkt b/langs/fraud/test/interp.rkt index 7ca855b9..74d4a050 100644 --- a/langs/fraud/test/interp.rkt +++ b/langs/fraud/test/interp.rkt @@ -1,8 +1,10 @@ #lang racket -(require "../interp.rkt" - "../interp-io.rkt" - "../parse.rkt" - "test-runner.rkt") +(require "../interp.rkt") +(require "../interp-io.rkt") +(require "../parse.rkt") +(require "test-runner.rkt") + +(test (λ (e) (interp (parse e)))) + +(test/io (λ (in e) (interp/io (parse e) in))) -(test-runner (λ (e) (interp (parse e)))) -(test-runner-io (λ (e s) (interp/io (parse e) s))) diff --git a/langs/fraud/test/test-runner.rkt b/langs/fraud/test/test-runner.rkt index 0cc5713b..7e78f795 100644 --- a/langs/fraud/test/test-runner.rkt +++ b/langs/fraud/test/test-runner.rkt @@ -1,123 +1,130 @@ #lang racket -(provide test-runner test-runner-io) +(provide test test/io) (require rackunit) -(define (test-runner run) - - ;; Abscond examples - (check-equal? (run 7) 7) - (check-equal? (run -8) -8) +(define (test run) + (begin ;; Abscond + (check-equal? (run 7) 7) + (check-equal? (run -8) -8)) - ;; Blackmail examples - (check-equal? (run '(add1 (add1 7))) 9) - (check-equal? (run '(add1 (sub1 7))) 7) + (begin ;; Blackmail + (check-equal? (run '(add1 (add1 7))) 9) + (check-equal? (run '(add1 (sub1 7))) 7)) - ;; Con examples - (check-equal? (run '(if (zero? 0) 1 2)) 1) - (check-equal? (run '(if (zero? 1) 1 2)) 2) - (check-equal? (run '(if (zero? -7) 1 2)) 2) - (check-equal? (run '(if (zero? 0) - (if (zero? 1) 1 2) - 7)) - 2) - (check-equal? (run '(if (zero? (if (zero? 0) 1 0)) - (if (zero? 1) 1 2) - 7)) - 7) + (begin ;; Con + (check-equal? (run '(if (zero? 0) 1 2)) 1) + (check-equal? (run '(if (zero? 1) 1 2)) 2) + (check-equal? (run '(if (zero? -7) 1 2)) 2) + (check-equal? (run '(if (zero? 0) + (if (zero? 1) 1 2) + 7)) + 2) + (check-equal? (run '(if (zero? (if (zero? 0) 1 0)) + (if (zero? 1) 1 2) + 7)) + 7)) - ;; Dupe examples - (check-equal? (run #t) #t) - (check-equal? (run #f) #f) - (check-equal? (run '(if #t 1 2)) 1) - (check-equal? (run '(if #f 1 2)) 2) - (check-equal? (run '(if 0 1 2)) 1) - (check-equal? (run '(if #t 3 4)) 3) - (check-equal? (run '(if #f 3 4)) 4) - (check-equal? (run '(if 0 3 4)) 3) - (check-equal? (run '(zero? 4)) #f) - (check-equal? (run '(zero? 0)) #t) - ;; Dodger examples - (check-equal? (run #\a) #\a) - (check-equal? (run #\b) #\b) - (check-equal? (run '(char? #\a)) #t) - (check-equal? (run '(char? #t)) #f) - (check-equal? (run '(char? 8)) #f) - (check-equal? (run '(char->integer #\a)) (char->integer #\a)) - (check-equal? (run '(integer->char 955)) #\λ) + (begin ;; Dupe + (check-equal? (run #t) #t) + (check-equal? (run #f) #f) + (check-equal? (run '(if #t 1 2)) 1) + (check-equal? (run '(if #f 1 2)) 2) + (check-equal? (run '(if 0 1 2)) 1) + (check-equal? (run '(if #t 3 4)) 3) + (check-equal? (run '(if #f 3 4)) 4) + (check-equal? (run '(if 0 3 4)) 3) + (check-equal? (run '(zero? 4)) #f) + (check-equal? (run '(zero? 0)) #t)) - ;; Evildoer examples - (check-equal? (run '(void)) (void)) - (check-equal? (run '(begin 1 2)) 2) - (check-equal? (run '(eof-object? (void))) #f) + (begin ;; Dodger + (check-equal? (run #\a) #\a) + (check-equal? (run #\b) #\b) + (check-equal? (run '(char? #\a)) #t) + (check-equal? (run '(char? #t)) #f) + (check-equal? (run '(char? 8)) #f) + (check-equal? (run '(char->integer #\a)) (char->integer #\a)) + (check-equal? (run '(integer->char 955)) #\λ)) - ;; Extort examples - (check-equal? (run '(add1 #f)) 'err) - (check-equal? (run '(sub1 #f)) 'err) - (check-equal? (run '(zero? #f)) 'err) - (check-equal? (run '(char->integer #f)) 'err) - (check-equal? (run '(integer->char #f)) 'err) - (check-equal? (run '(integer->char -1)) 'err) - (check-equal? (run '(write-byte #f)) 'err) - (check-equal? (run '(write-byte -1)) 'err) - (check-equal? (run '(write-byte 256)) 'err) - ;; Fraud examples - (check-equal? (run '(let ((x 7)) x)) 7) - (check-equal? (run '(let ((x 7)) 2)) 2) - (check-equal? (run '(let ((x 7)) (add1 x))) 8) - (check-equal? (run '(let ((x (add1 7))) x)) 8) - (check-equal? (run '(let ((x 7)) (let ((y 2)) x))) 7) - (check-equal? (run '(let ((x 7)) (let ((x 2)) x))) 2) - (check-equal? (run '(let ((x 7)) (let ((x (add1 x))) x))) 8) + (begin ;; Evildoer + (check-equal? (run '(void)) (void)) + (check-equal? (run '(begin 1 2)) 2) + (check-equal? (run '(eof-object? (void))) #f)) - (check-equal? (run '(let ((x 0)) - (if (zero? x) 7 8))) - 7) - (check-equal? (run '(let ((x 1)) - (add1 (if (zero? x) 7 8)))) - 9) - (check-equal? (run '(+ 3 4)) 7) - (check-equal? (run '(- 3 4)) -1) - (check-equal? (run '(+ (+ 2 1) 4)) 7) - (check-equal? (run '(+ (+ 2 1) (+ 2 2))) 7) - (check-equal? (run '(let ((x (+ 1 2))) - (let ((z (- 4 x))) - (+ (+ x x) z)))) - 7) + (begin ;; Extort + (check-equal? (run '(add1 #f)) 'err) + (check-equal? (run '(sub1 #f)) 'err) + (check-equal? (run '(zero? #f)) 'err) + (check-equal? (run '(char->integer #f)) 'err) + (check-equal? (run '(integer->char #f)) 'err) + (check-equal? (run '(integer->char -1)) 'err) + (check-equal? (run '(write-byte #f)) 'err) + (check-equal? (run '(write-byte -1)) 'err) + (check-equal? (run '(write-byte 256)) 'err) + (check-equal? (run '(begin (integer->char 97) + (integer->char 98))) + #\b)) - (check-equal? (run '(= 5 5)) #t) - (check-equal? (run '(= 4 5)) #f) - (check-equal? (run '(= (add1 4) 5)) #t) - (check-equal? (run '(< 5 5)) #f) - (check-equal? (run '(< 4 5)) #t) - (check-equal? (run '(< (add1 4) 5)) #f)) + (begin ;; Fraud + (check-equal? (run '(let ((x 7)) x)) 7) + (check-equal? (run '(let ((x 7)) 2)) 2) + (check-equal? (run '(let ((x 7)) (add1 x))) 8) + (check-equal? (run '(let ((x (add1 7))) x)) 8) + (check-equal? (run '(let ((x 7)) (let ((y 2)) x))) 7) + (check-equal? (run '(let ((x 7)) (let ((x 2)) x))) 2) + (check-equal? (run '(let ((x 7)) (let ((x (add1 x))) x))) 8) + (check-equal? (run '(let ((x 0)) + (if (zero? x) 7 8))) + 7) + (check-equal? (run '(let ((x 1)) + (add1 (if (zero? x) 7 8)))) + 9) + (check-equal? (run '(+ 3 4)) 7) + (check-equal? (run '(- 3 4)) -1) + (check-equal? (run '(+ (+ 2 1) 4)) 7) + (check-equal? (run '(+ (+ 2 1) (+ 2 2))) 7) + (check-equal? (run '(let ((x (+ 1 2))) + (let ((z (- 4 x))) + (+ (+ x x) z)))) + 7) -(define (test-runner-io run) - ;; Evildoer examples - (check-equal? (run 7 "") (cons 7 "")) - (check-equal? (run '(write-byte 97) "") (cons (void) "a")) - (check-equal? (run '(read-byte) "a") (cons 97 "")) - (check-equal? (run '(begin (write-byte 97) (read-byte)) "b") - (cons 98 "a")) - (check-equal? (run '(read-byte) "") (cons eof "")) - (check-equal? (run '(eof-object? (read-byte)) "") (cons #t "")) - (check-equal? (run '(eof-object? (read-byte)) "a") (cons #f "")) - (check-equal? (run '(begin (write-byte 97) (write-byte 98)) "") - (cons (void) "ab")) + (check-equal? (run '(= 5 5)) #t) + (check-equal? (run '(= 4 5)) #f) + (check-equal? (run '(= (add1 4) 5)) #t) + (check-equal? (run '(< 5 5)) #f) + (check-equal? (run '(< 4 5)) #t) + (check-equal? (run '(< (add1 4) 5)) #f))) - (check-equal? (run '(peek-byte) "ab") (cons 97 "")) - (check-equal? (run '(begin (peek-byte) (read-byte)) "ab") (cons 97 "")) - ;; Extort examples - (check-equal? (run '(write-byte #t) "") (cons 'err "")) +(define (test/io run) + (begin ;; Evildoer + (check-equal? (run "" 7) (cons 7 "")) + (check-equal? (run "" '(write-byte 97)) (cons (void) "a")) + (check-equal? (run "a" '(read-byte)) (cons 97 "")) + (check-equal? (run "b" '(begin (write-byte 97) (read-byte))) + (cons 98 "a")) + (check-equal? (run "" '(read-byte)) (cons eof "")) + (check-equal? (run "" '(eof-object? (read-byte))) (cons #t "")) + (check-equal? (run "a" '(eof-object? (read-byte))) (cons #f "")) + (check-equal? (run "" '(begin (write-byte 97) (write-byte 98))) + (cons (void) "ab")) + + (check-equal? (run "ab" '(peek-byte)) (cons 97 "")) + (check-equal? (run "ab" '(begin (peek-byte) (read-byte))) (cons 97 "")) + (check-equal? (run "†" '(read-byte)) (cons 226 "")) + (check-equal? (run "†" '(peek-byte)) (cons 226 ""))) + + (begin ;; Extort + (check-equal? (run "" '(write-byte #t)) (cons 'err ""))) + + (begin ;; Fraud + (check-equal? (run "" '(let ((x 97)) (write-byte x))) (cons (void) "a")) + (check-equal? (run "" + '(let ((x 97)) + (begin (write-byte x) + x))) + (cons 97 "a")) + (check-equal? (run "b" '(let ((x 97)) (begin (read-byte) x))) + (cons 97 "")) + (check-equal? (run "b" '(let ((x 97)) (begin (peek-byte) x))) + (cons 97 "")))) - ;; Fraud examples - (check-equal? (run '(let ((x 97)) (write-byte x)) "") (cons (void) "a")) - (check-equal? (run '(let ((x 97)) - (begin (write-byte x) - x)) - "") - (cons 97 "a")) - (check-equal? (run '(let ((x 97)) (begin (read-byte) x)) "b") - (cons 97 "")) - (check-equal? (run '(let ((x 97)) (begin (peek-byte) x)) "b") - (cons 97 ""))) diff --git a/langs/fraud/test/translate.rkt b/langs/fraud/test/translate.rkt index 044a938d..f83844b4 100644 --- a/langs/fraud/test/translate.rkt +++ b/langs/fraud/test/translate.rkt @@ -4,12 +4,12 @@ (require "../ast.rkt") (require rackunit) (check-equal? (translate (parse '(let ((x 0)) x))) - (Let '_ (Int 0) (Var 0))) + (Let '_ (Lit 0) (Var 0))) (check-equal? (translate (parse '(let ((x 0)) (let ((y 1)) x)))) - (Let '_ (Int 0) (Let '_ (Int 1) (Var 1)))) + (Let '_ (Lit 0) (Let '_ (Lit 1) (Var 1)))) (check-equal? (translate (parse '(let ((x 0)) (let ((y 1)) y)))) - (Let '_ (Int 0) (Let '_ (Int 1) (Var 0)))) + (Let '_ (Lit 0) (Let '_ (Lit 1) (Var 0)))) (check-equal? (translate (parse '(let ((x 0)) (let ((y x)) y)))) - (Let '_ (Int 0) (Let '_ (Var 0) (Var 0)))) + (Let '_ (Lit 0) (Let '_ (Var 0) (Var 0)))) diff --git a/langs/fraud/translate.rkt b/langs/fraud/translate.rkt index 1a7e333c..7db32222 100644 --- a/langs/fraud/translate.rkt +++ b/langs/fraud/translate.rkt @@ -3,10 +3,8 @@ (require "ast.rkt") ;; type IExpr = +;; | (Lit Datum) ;; | (Eof) -;; | (Int Integer) -;; | (Bool Boolean) -;; | (Char Character) ;; | (Prim0 Op0) ;; | (Prim1 Op1 IExpr) ;; | (Prim2 Op2 IExpr IExpr) @@ -25,10 +23,8 @@ ;; Expr LEnv -> IExpr (define (translate-e e r) (match e - [(Eof) e] - [(Int i) e] - [(Bool b) e] - [(Char c) e] + [(Eof) e] + [(Lit d) e] [(Prim0 p) e] [(Prim1 p e0) (Prim1 p (translate-e e0 r))] diff --git a/langs/fraud/types.rkt b/langs/fraud/types.rkt index 18a1415a..928a05fe 100644 --- a/langs/fraud/types.rkt +++ b/langs/fraud/types.rkt @@ -1,35 +1,36 @@ #lang racket (provide (all-defined-out)) - -(define int-shift 1) -(define char-shift 2) -(define type-int #b0) -(define mask-int #b1) -(define type-char #b01) -(define mask-char #b11) -(define val-true #b0011) -(define val-false #b0111) -(define val-eof #b1011) -(define val-void #b1111) +(define int-shift 1) +(define mask-int #b1) +(define char-shift 2) +(define type-int #b0) +(define type-char #b01) +(define mask-char #b11) (define (bits->value b) - (cond [(= type-int (bitwise-and b #b1)) + (cond [(= b (value->bits #t)) #t] + [(= b (value->bits #f)) #f] + [(= b (value->bits eof)) eof] + [(= b (value->bits (void))) (void)] + [(int-bits? b) (arithmetic-shift b (- int-shift))] - [(= type-char (bitwise-and b #b11)) + [(char-bits? b) (integer->char (arithmetic-shift b (- char-shift)))] - [(= b val-true) #t] - [(= b val-false) #f] - [(= b val-eof) eof] - [(= b val-void) (void)] [else (error "invalid bits")])) (define (value->bits v) - (cond [(eof-object? v) val-eof] + (cond [(eq? v #t) #b011] + [(eq? v #f) #b111] [(integer? v) (arithmetic-shift v int-shift)] + [(eof-object? v) #b1011] + [(void? v) #b1111] [(char? v) (bitwise-ior type-char - (arithmetic-shift (char->integer v) char-shift))] - [(eq? v #t) val-true] - [(eq? v #f) val-false] - [(void? v) val-void])) + (arithmetic-shift (char->integer v) char-shift))])) + +(define (int-bits? v) + (= type-int (bitwise-and v mask-int))) + +(define (char-bits? v) + (= type-char (bitwise-and v mask-char))) diff --git a/langs/fraud/values.c b/langs/fraud/values.c index 9bd2a704..bfdcf630 100644 --- a/langs/fraud/values.c +++ b/langs/fraud/values.c @@ -29,6 +29,10 @@ val_t val_wrap_int(int64_t i) { return (i << int_shift) | int_type_tag; } +val_t val_wrap_byte(unsigned char b) +{ + return (b << int_shift) | int_type_tag; +} int val_unwrap_bool(val_t x) { diff --git a/langs/fraud/values.h b/langs/fraud/values.h index 39cc43df..44f1c536 100644 --- a/langs/fraud/values.h +++ b/langs/fraud/values.h @@ -28,6 +28,7 @@ type_t val_typeof(val_t x); */ int64_t val_unwrap_int(val_t x); val_t val_wrap_int(int64_t i); +val_t val_wrap_byte(unsigned char b); int val_unwrap_bool(val_t x); val_t val_wrap_bool(int b); diff --git a/langs/hoax/Makefile b/langs/hoax/Makefile index 9055c88f..db6ac44a 100644 --- a/langs/hoax/Makefile +++ b/langs/hoax/Makefile @@ -37,7 +37,8 @@ runtime.o: $(objs) cat $< | racket -t compile-stdin.rkt -m > $@ clean: - rm *.o *.s *.run + @$(RM) *.o *.s *.run ||: + @echo "$(shell basename $(shell pwd)): cleaned!" %.test: %.run %.rkt @test "$(shell ./$(<))" = "$(shell racket $(word 2,$^))" diff --git a/langs/hoax/ast.rkt b/langs/hoax/ast.rkt deleted file mode 100644 index 4d9f978d..00000000 --- a/langs/hoax/ast.rkt +++ /dev/null @@ -1,45 +0,0 @@ -#lang racket -(provide Eof Int Bool Char Str Prim0 Prim1 Prim2 Prim3 If Begin Let Var Empty) - -;; type Expr = (Eof) -;; | (Empty) -;; | (Int Integer) -;; | (Bool Boolean) -;; | (Char Character) -;; | (Str String) -;; | (Prim0 Op0) -;; | (Prim1 Op1 Expr) -;; | (Prim2 Op2 Expr Expr) -;; | (Prim3 Op3 Expr Expr Expr) -;; | (If Expr Expr Expr) -;; | (Begin Expr Expr) -;; | (Let Id Expr Expr) -;; | (Var Id) -;; type Id = Symbol -;; type Op0 = 'read-byte -;; type Op1 = 'add1 | 'sub1 | 'zero? -;; | 'char? | 'integer->char | 'char->integer -;; | 'write-byte | 'eof-object? -;; | 'box | 'car | 'cdr | 'unbox -;; | 'empty? | 'cons? | 'box? -;; | 'vector? | vector-length -;; | 'string? | string-length -;; type Op2 = '+ | '- | '< | '= -;; | 'cons | 'eq? -;; | 'make-vector | 'vector-ref -;; | 'make-string | 'string-ref -;; type Op3 = 'vector-set! -(struct Eof () #:prefab) -(struct Empty () #:prefab) -(struct Int (i) #:prefab) -(struct Bool (b) #:prefab) -(struct Char (c) #:prefab) -(struct Str (s) #:prefab) -(struct Prim0 (p) #:prefab) -(struct Prim1 (p e) #:prefab) -(struct Prim2 (p e1 e2) #:prefab) -(struct Prim3 (p e1 e2 e3) #:prefab) -(struct If (e1 e2 e3) #:prefab) -(struct Begin (e1 e2) #:prefab) -(struct Let (x e1 e2) #:prefab) -(struct Var (x) #:prefab) diff --git a/langs/hoax/build-runtime.rkt b/langs/hoax/build-runtime.rkt deleted file mode 100644 index 1cc4da53..00000000 --- a/langs/hoax/build-runtime.rkt +++ /dev/null @@ -1,12 +0,0 @@ -#lang racket -(provide runtime-path) - -(require racket/runtime-path) -(define-runtime-path here ".") - -(system (string-append "make -C '" - (path->string (normalize-path here)) - "' runtime.o")) - -(define runtime-path - (normalize-path (build-path here "runtime.o"))) \ No newline at end of file diff --git a/langs/hoax/compile-ops.rkt b/langs/hoax/compile-ops.rkt deleted file mode 100644 index 52b84ffd..00000000 --- a/langs/hoax/compile-ops.rkt +++ /dev/null @@ -1,351 +0,0 @@ -#lang racket -(provide (all-defined-out)) -(require "ast.rkt" "types.rkt" a86/ast) - -(define rax 'rax) ; return -(define eax 'eax) ; 32-bit load/store -(define rbx 'rbx) ; heap -(define rdi 'rdi) ; arg -(define r8 'r8) ; scratch -(define r9 'r9) ; scratch -(define r10 'r10) ; scratch -(define r15 'r15) ; stack pad (non-volatile) -(define rsp 'rsp) ; stack - -;; Op0 -> Asm -(define (compile-op0 p) - (match p - ['void (seq (Mov rax (value->bits (void))))] - ['read-byte (seq pad-stack - (Call 'read_byte) - unpad-stack)] - ['peek-byte (seq pad-stack - (Call 'peek_byte) - unpad-stack)])) - -;; Op1 -> Asm -(define (compile-op1 p) - (match p - ['add1 - (seq (assert-integer rax) - (Add rax (value->bits 1)))] - ['sub1 - (seq (assert-integer rax) - (Sub rax (value->bits 1)))] - ['zero? - (seq (assert-integer rax) - (eq-value 0))] - ['char? - (type-pred mask-char type-char)] - ['char->integer - (seq (assert-char rax) - (Sar rax char-shift) - (Sal rax int-shift))] - ['integer->char - (seq (assert-codepoint rax) - (Sar rax int-shift) - (Sal rax char-shift) - (Xor rax type-char))] - ['eof-object? (eq-value eof)] - ['write-byte - (seq (assert-byte rax) - pad-stack - (Mov rdi rax) - (Call 'write_byte) - unpad-stack)] - ['box - (seq (Mov (Offset rbx 0) rax) - (Mov rax rbx) - (Or rax type-box) - (Add rbx 8))] - ['unbox - (seq (assert-box rax) - (Xor rax type-box) - (Mov rax (Offset rax 0)))] - ['car - (seq (assert-cons rax) - (Xor rax type-cons) - (Mov rax (Offset rax 8)))] - ['cdr - (seq (assert-cons rax) - (Xor rax type-cons) - (Mov rax (Offset rax 0)))] - ['empty? (eq-value '())] - ['box? - (type-pred ptr-mask type-box)] - ['cons? - (type-pred ptr-mask type-cons)] - ['vector? - (type-pred ptr-mask type-vect)] - ['string? - (type-pred ptr-mask type-str)] - ['vector-length - (let ((zero (gensym)) - (done (gensym))) - (seq (assert-vector rax) - (Xor rax type-vect) - (Cmp rax 0) - (Je zero) - (Mov rax (Offset rax 0)) - (Sal rax int-shift) - (Jmp done) - (Label zero) - (Mov rax 0) - (Label done)))] - ['string-length - (let ((zero (gensym)) - (done (gensym))) - (seq (assert-string rax) - (Xor rax type-str) - (Cmp rax 0) - (Je zero) - (Mov rax (Offset rax 0)) - (Sal rax int-shift) - (Jmp done) - (Label zero) - (Mov rax 0) - (Label done)))])) - -;; Op2 -> Asm -(define (compile-op2 p) - (match p - ['+ - (seq (Pop r8) - (assert-integer r8) - (assert-integer rax) - (Add rax r8))] - ['- - (seq (Pop r8) - (assert-integer r8) - (assert-integer rax) - (Sub r8 rax) - (Mov rax r8))] - ['< - (seq (Pop r8) - (assert-integer r8) - (assert-integer rax) - (Cmp r8 rax) - (if-lt))] - ['= - (seq (Pop r8) - (assert-integer r8) - (assert-integer rax) - (Cmp r8 rax) - (if-equal))] - ['cons - (seq (Mov (Offset rbx 0) rax) - (Pop rax) - (Mov (Offset rbx 8) rax) - (Mov rax rbx) - (Or rax type-cons) - (Add rbx 16))] - ['eq? - (seq (Pop r8) - (Cmp rax r8) - (if-equal))] - ['make-vector ;; size value - (let ((loop (gensym)) - (done (gensym)) - (empty (gensym))) - (seq (Pop r8) ;; r8 = size - (assert-natural r8) - (Cmp r8 0) ; special case empty vector - (Je empty) - - (Mov r9 rbx) - (Or r9 type-vect) - - (Sar r8 int-shift) - (Mov (Offset rbx 0) r8) - (Add rbx 8) - - (Label loop) - (Mov (Offset rbx 0) rax) - (Add rbx 8) - (Sub r8 1) - (Cmp r8 0) - (Jne loop) - - (Mov rax r9) - (Jmp done) - - (Label empty) - (Mov rax type-vect) - (Label done)))] - - ['vector-ref ; vector index - (seq (Pop r8) - (assert-vector r8) - (assert-integer rax) - (Cmp r8 type-vect) - (Je 'raise_error_align) ; special case for empty vector - (Cmp rax 0) - (Jl 'raise_error_align) - (Xor r8 type-vect) ; r8 = ptr - (Mov r9 (Offset r8 0)) ; r9 = len - (Sar rax int-shift) ; rax = index - (Sub r9 1) - (Cmp r9 rax) - (Jl 'raise_error_align) - (Sal rax 3) - (Add r8 rax) - (Mov rax (Offset r8 8)))] - - ['make-string - (let ((loop (gensym)) - (done (gensym)) - (empty (gensym))) - (seq (Pop r8) - (assert-natural r8) - (assert-char rax) - (Cmp r8 0) ; special case empty string - (Je empty) - - (Mov r9 rbx) - (Or r9 type-str) - - (Sar r8 int-shift) - (Mov (Offset rbx 0) r8) - (Add rbx 8) - - (Sar rax char-shift) - - (Add r8 1) ; adds 1 - (Sar r8 1) ; when - (Sal r8 1) ; len is odd - - (Label loop) - (Mov (Offset rbx 0) eax) - (Add rbx 4) - (Sub r8 1) - (Cmp r8 0) - (Jne loop) - - (Mov rax r9) - (Jmp done) - - (Label empty) - (Mov rax type-str) - (Label done)))] - - ['string-ref - (seq (Pop r8) - (assert-string r8) - (assert-integer rax) - (Cmp r8 type-str) - (Je 'raise_error_align) ; special case for empty string - (Cmp rax 0) - (Jl 'raise_error_align) - (Xor r8 type-str) ; r8 = ptr - (Mov r9 (Offset r8 0)) ; r9 = len - (Sar rax int-shift) ; rax = index - (Sub r9 1) - (Cmp r9 rax) - (Jl 'raise_error_align) - (Sal rax 2) - (Add r8 rax) - (Mov 'eax (Offset r8 8)) - (Sal rax char-shift) - (Or rax type-char))])) - -;; Op3 -> Asm -(define (compile-op3 p) - (match p - ['vector-set! - (seq (Pop r10) - (Pop r8) - (assert-vector r8) - (assert-integer r10) - (Cmp r10 0) - (Jl 'raise_error_align) - (Xor r8 type-vect) ; r8 = ptr - (Mov r9 (Offset r8 0)) ; r9 = len - (Sar r10 int-shift) ; r10 = index - (Sub r9 1) - (Cmp r9 r10) - (Jl 'raise_error_align) - (Sal r10 3) - (Add r8 r10) - (Mov (Offset r8 8) rax) - (Mov rax (value->bits (void))))])) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define (assert-type mask type) - (λ (arg) - (seq (Mov r9 arg) - (And r9 mask) - (Cmp r9 type) - (Jne 'raise_error_align)))) - -(define (type-pred mask type) - (seq (And rax mask) - (Cmp rax type) - (if-equal))) - -(define assert-integer - (assert-type mask-int type-int)) -(define assert-char - (assert-type mask-char type-char)) -(define assert-box - (assert-type ptr-mask type-box)) -(define assert-cons - (assert-type ptr-mask type-cons)) -(define assert-vector - (assert-type ptr-mask type-vect)) -(define assert-string - (assert-type ptr-mask type-str)) - -(define (assert-codepoint r) - (let ((ok (gensym))) - (seq (assert-integer r) - (Cmp r (value->bits 0)) - (Jl 'raise_error_align) - (Cmp r (value->bits 1114111)) - (Jg 'raise_error_align) - (Cmp r (value->bits 55295)) - (Jl ok) - (Cmp r (value->bits 57344)) - (Jg ok) - (Jmp 'raise_error_align) - (Label ok)))) - -(define (assert-byte r) - (seq (assert-integer r) - (Cmp r (value->bits 0)) - (Jl 'raise_error_align) - (Cmp r (value->bits 255)) - (Jg 'raise_error_align))) - -(define (assert-natural r) - (seq (assert-integer r) - (Cmp r (value->bits 0)) - (Jl 'raise_error_align))) - -;; -> Asm -;; set rax to #t or #f based on given comparison -(define (if-compare c) - (seq (Mov rax (value->bits #f)) - (Mov r9 (value->bits #t)) - (c rax r9))) - -(define (if-equal) (if-compare Cmove)) -(define (if-lt) (if-compare Cmovl)) - -;; Value -> Asm -(define (eq-value v) - (seq (Cmp rax (value->bits v)) - (if-equal))) - -;; Asm -;; Dynamically pad the stack to be aligned for a call -(define pad-stack - (seq (Mov r15 rsp) - (And r15 #b1000) - (Sub rsp r15))) - -;; Asm -;; Undo the stack alignment after a call -(define unpad-stack - (seq (Add rsp r15))) diff --git a/langs/hoax/compile-stdin.rkt b/langs/hoax/compile-stdin.rkt deleted file mode 100644 index 5fbdbded..00000000 --- a/langs/hoax/compile-stdin.rkt +++ /dev/null @@ -1,10 +0,0 @@ -#lang racket -(provide main) -(require "parse.rkt" "compile.rkt" a86/printer) - -;; -> Void -;; Compile contents of stdin, -;; emit asm code on stdout -(define (main) - (read-line) ; ignore #lang racket line - (asm-display (compile (parse (read))))) diff --git a/langs/hoax/compile.rkt b/langs/hoax/compile.rkt deleted file mode 100644 index c2e9974e..00000000 --- a/langs/hoax/compile.rkt +++ /dev/null @@ -1,139 +0,0 @@ -#lang racket -(provide (all-defined-out)) -(require "ast.rkt" "types.rkt" "compile-ops.rkt" a86/ast) - -;; Registers used -(define rax 'rax) ; return -(define rbx 'rbx) ; heap -(define rsp 'rsp) ; stack -(define rdi 'rdi) ; arg -(define r15 'r15) ; stack pad (non-volatile) - -;; type CEnv = (Listof [Maybe Id]) - -;; Expr -> Asm -(define (compile e) - (prog (Extern 'peek_byte) - (Extern 'read_byte) - (Extern 'write_byte) - (Extern 'raise_error) - (Global 'entry) - (Label 'entry) - (Push rbx) ; save callee-saved register - (Push r15) - (Mov rbx rdi) ; recv heap pointer - (compile-e e '()) - (Pop r15) ; restore callee-save register - (Pop rbx) - (Ret) - (Label 'raise_error_align) - pad-stack - (Call 'raise_error))) - -;; Expr CEnv -> Asm -(define (compile-e e c) - (match e - [(Int i) (compile-value i)] - [(Bool b) (compile-value b)] - [(Char c) (compile-value c)] - [(Eof) (compile-value eof)] - [(Empty) (compile-value '())] - [(Var x) (compile-variable x c)] - [(Str s) (compile-string s)] - [(Prim0 p) (compile-prim0 p c)] - [(Prim1 p e) (compile-prim1 p e c)] - [(Prim2 p e1 e2) (compile-prim2 p e1 e2 c)] - [(Prim3 p e1 e2 e3) (compile-prim3 p e1 e2 e3 c)] - [(If e1 e2 e3) (compile-if e1 e2 e3 c)] - [(Begin e1 e2) (compile-begin e1 e2 c)] - [(Let x e1 e2) (compile-let x e1 e2 c)])) - -;; Value -> Asm -(define (compile-value v) - (seq (Mov rax (value->bits v)))) - -;; Id CEnv -> Asm -(define (compile-variable x c) - (let ((i (lookup x c))) - (seq (Mov rax (Offset rsp i))))) - -;; String -> Asm -(define (compile-string s) - (let ((len (string-length s))) - (if (zero? len) - (seq (Mov rax type-str)) - (seq (Mov rax len) - (Mov (Offset rbx 0) rax) - (compile-string-chars (string->list s) 8) - (Mov rax rbx) - (Or rax type-str) - (Add rbx - (+ 8 (* 4 (if (odd? len) (add1 len) len)))))))) - -;; [Listof Char] Integer -> Asm -(define (compile-string-chars cs i) - (match cs - ['() (seq)] - [(cons c cs) - (seq (Mov rax (char->integer c)) - (Mov (Offset rbx i) 'eax) - (compile-string-chars cs (+ 4 i)))])) - -;; Op0 CEnv -> Asm -(define (compile-prim0 p c) - (compile-op0 p)) - -;; Op1 Expr CEnv -> Asm -(define (compile-prim1 p e c) - (seq (compile-e e c) - (compile-op1 p))) - -;; Op2 Expr Expr CEnv -> Asm -(define (compile-prim2 p e1 e2 c) - (seq (compile-e e1 c) - (Push rax) - (compile-e e2 (cons #f c)) - (compile-op2 p))) - -;; Op3 Expr Expr Expr CEnv -> Asm -(define (compile-prim3 p e1 e2 e3 c) - (seq (compile-e e1 c) - (Push rax) - (compile-e e2 (cons #f c)) - (Push rax) - (compile-e e3 (cons #f (cons #f c))) - (compile-op3 p))) - -;; Expr Expr Expr CEnv -> Asm -(define (compile-if e1 e2 e3 c) - (let ((l1 (gensym 'if)) - (l2 (gensym 'if))) - (seq (compile-e e1 c) - (Cmp rax (value->bits #f)) - (Je l1) - (compile-e e2 c) - (Jmp l2) - (Label l1) - (compile-e e3 c) - (Label l2)))) - -;; Expr Expr CEnv -> Asm -(define (compile-begin e1 e2 c) - (seq (compile-e e1 c) - (compile-e e2 c))) - -;; Id Expr Expr CEnv -> Asm -(define (compile-let x e1 e2 c) - (seq (compile-e e1 c) - (Push rax) - (compile-e e2 (cons x c)) - (Add rsp 8))) - -;; Id CEnv -> Integer -(define (lookup x cenv) - (match cenv - ['() (error "undefined variable:" x)] - [(cons y rest) - (match (eq? x y) - [#t 0] - [#f (+ 8 (lookup x rest))])])) diff --git a/langs/hoax/info.rkt b/langs/hoax/info.rkt new file mode 100644 index 00000000..41ec40bb --- /dev/null +++ b/langs/hoax/info.rkt @@ -0,0 +1,2 @@ +#lang info +(define pre-install-collection "../installer.rkt") diff --git a/langs/hoax/interp-io.rkt b/langs/hoax/interp-io.rkt deleted file mode 100644 index 12da1b4b..00000000 --- a/langs/hoax/interp-io.rkt +++ /dev/null @@ -1,12 +0,0 @@ -#lang racket -(provide interp/io) -(require "interp.rkt") - -;; Expr String -> (Cons Value String) -;; Interpret e with given string as input, -;; collect output as string (including printed result) -(define (interp/io e input) - (parameterize ((current-output-port (open-output-string)) - (current-input-port (open-input-string input))) - (cons (interp e) - (get-output-string (current-output-port))))) diff --git a/langs/hoax/interp-stdin.rkt b/langs/hoax/interp-stdin.rkt deleted file mode 100644 index 8026d746..00000000 --- a/langs/hoax/interp-stdin.rkt +++ /dev/null @@ -1,12 +0,0 @@ -#lang racket -(provide main) -(require "parse.rkt" "interp.rkt") - -;; -> Void -;; Parse and interpret contents of stdin, -;; print result on stdout -(define (main) - (read-line) ; ignore #lang racket line - (let ((r (interp (parse (read))))) - (unless (void? r) - (println r)))) diff --git a/langs/hoax/interp.rkt b/langs/hoax/interp.rkt deleted file mode 100644 index cab103af..00000000 --- a/langs/hoax/interp.rkt +++ /dev/null @@ -1,72 +0,0 @@ -#lang racket -(provide interp interp-env interp-prim1) -(require "ast.rkt" - "env.rkt" - "interp-prims.rkt") - -;; type Answer = Value | 'err - -;; type Value = -;; | Integer -;; | Boolean -;; | Character -;; | Eof -;; | Void -;; | '() -;; | (cons Value Value) -;; | (box Value) -;; | (vector Value ...) -;; | (string Char ...) - -;; type REnv = (Listof (List Id Value)) - -;; Expr -> Answer -(define (interp e) - (interp-env e '())) - -;; Expr Env -> Answer -(define (interp-env e r) - (match e - [(Int i) i] - [(Bool b) b] - [(Char c) c] - [(Eof) eof] - [(Empty) '()] - [(Var x) (lookup r x)] - [(Str s) s] - [(Prim0 'void) (void)] - [(Prim0 'read-byte) (read-byte)] - [(Prim0 'peek-byte) (peek-byte)] - [(Prim1 p e) - (match (interp-env e r) - ['err 'err] - [v (interp-prim1 p v)])] - [(Prim2 p e1 e2) - (match (interp-env e1 r) - ['err 'err] - [v1 (match (interp-env e2 r) - ['err 'err] - [v2 (interp-prim2 p v1 v2)])])] - [(Prim3 p e1 e2 e3) - (match (interp-env e1 r) - ['err 'err] - [v1 (match (interp-env e2 r) - ['err 'err] - [v2 (match (interp-env e3 r) - ['err 'err] - [v3 (interp-prim3 p v1 v2 v3)])])])] - [(If p e1 e2) - (match (interp-env p r) - ['err 'err] - [v - (if v - (interp-env e1 r) - (interp-env e2 r))])] - [(Begin e1 e2) - (match (interp-env e1 r) - ['err 'err] - [_ (interp-env e2 r)])] - [(Let x e1 e2) - (match (interp-env e1 r) - ['err 'err] - [v (interp-env e2 (ext r x v))])])) diff --git a/langs/hoax/io.c b/langs/hoax/io.c index 7ef82281..8a417c91 100644 --- a/langs/hoax/io.c +++ b/langs/hoax/io.c @@ -7,14 +7,14 @@ val_t read_byte(void) { char c = getc(in); - return (c == EOF) ? val_wrap_eof() : val_wrap_int(c); + return (c == EOF) ? val_wrap_eof() : val_wrap_byte(c); } val_t peek_byte(void) { char c = getc(in); ungetc(c, in); - return (c == EOF) ? val_wrap_eof() : val_wrap_int(c); + return (c == EOF) ? val_wrap_eof() : val_wrap_byte(c); } diff --git a/langs/hoax/parse.rkt b/langs/hoax/parse.rkt deleted file mode 100644 index 85e65360..00000000 --- a/langs/hoax/parse.rkt +++ /dev/null @@ -1,44 +0,0 @@ -#lang racket -(provide parse) -(require "ast.rkt") - -;; S-Expr -> Expr -(define (parse s) - (match s - [(? exact-integer?) (Int s)] - [(? boolean?) (Bool s)] - [(? char?) (Char s)] - [(? string?) (Str s)] - ['eof (Eof)] - [(? symbol?) (Var s)] - [(list 'quote (list)) (Empty)] - [(list (? (op? op0) p0)) (Prim0 p0)] - [(list (? (op? op1) p1) e) (Prim1 p1 (parse e))] - [(list (? (op? op2) p2) e1 e2) (Prim2 p2 (parse e1) (parse e2))] - [(list (? (op? op3) p3) e1 e2 e3) - (Prim3 p3 (parse e1) (parse e2) (parse e3))] - [(list 'begin e1 e2) - (Begin (parse e1) (parse e2))] - [(list 'if e1 e2 e3) - (If (parse e1) (parse e2) (parse e3))] - [(list 'let (list (list (? symbol? x) e1)) e2) - (Let x (parse e1) (parse e2))] - [_ (error "Parse error" s)])) - -(define op0 - '(read-byte peek-byte void)) - -(define op1 - '(add1 sub1 zero? char? write-byte eof-object? - integer->char char->integer - box unbox empty? cons? box? car cdr - vector? vector-length string? string-length)) -(define op2 - '(+ - < = cons eq? make-vector vector-ref make-string string-ref)) -(define op3 - '(vector-set!)) - -(define (op? ops) - (λ (x) - (and (symbol? x) - (memq x ops)))) diff --git a/langs/hoax/test/build-runtime.rkt b/langs/hoax/test/build-runtime.rkt deleted file mode 100644 index 7023ee0b..00000000 --- a/langs/hoax/test/build-runtime.rkt +++ /dev/null @@ -1,8 +0,0 @@ -#lang racket -(require a86/interp) - -;; link with runtime for IO operations -(unless (file-exists? "../runtime.o") - (system "make -C .. runtime.o")) -(current-objs - (list (path->string (normalize-path "../runtime.o")))) diff --git a/langs/hoax/test/compile.rkt b/langs/hoax/test/compile.rkt deleted file mode 100644 index 9e845570..00000000 --- a/langs/hoax/test/compile.rkt +++ /dev/null @@ -1,13 +0,0 @@ -#lang racket -(require "test-runner.rkt" - "build-runtime.rkt" - "../parse.rkt" - "../compile.rkt" - "../unload-bits-asm.rkt" - a86/interp) - -(test-runner (λ (e) (unload/free (asm-interp (compile (parse e)))))) -(test-runner-io (λ (e s) - (match (asm-interp/io (compile (parse e)) s) - ['err 'err] - [(cons r o) (cons (unload/free r) o)]))) diff --git a/langs/hoax/test/interp.rkt b/langs/hoax/test/interp.rkt deleted file mode 100644 index 1eaa5864..00000000 --- a/langs/hoax/test/interp.rkt +++ /dev/null @@ -1,9 +0,0 @@ -#lang racket -(require "test-runner.rkt" - "../parse.rkt" - "../interp.rkt" - "../interp-io.rkt") - -(test-runner (λ (e) (interp (parse e)))) - -(test-runner-io (λ (e s) (interp/io (parse e) s))) diff --git a/langs/hoax/test/test-progs.rkt b/langs/hoax/test/test-progs.rkt index 46769a8e..0eca217e 100644 --- a/langs/hoax/test/test-progs.rkt +++ b/langs/hoax/test/test-progs.rkt @@ -2,5 +2,5 @@ ;; run command line compiler and compare against Racket as refernece implementation (require rackunit "../../test-programs/get-progs.rkt" - "build-runtime.rkt") + "../run.rkt") (for-each test-prog (get-progs "hoax")) diff --git a/langs/hoax/test/test-runner.rkt b/langs/hoax/test/test-runner.rkt deleted file mode 100644 index 87a349d9..00000000 --- a/langs/hoax/test/test-runner.rkt +++ /dev/null @@ -1,215 +0,0 @@ -#lang racket -(provide test-runner test-runner-io) -(require rackunit) - -(define (test-runner run) - ;; Abscond examples - (check-equal? (run 7) 7) - (check-equal? (run -8) -8) - - ;; Blackmail examples - (check-equal? (run '(add1 (add1 7))) 9) - (check-equal? (run '(add1 (sub1 7))) 7) - - ;; Con examples - (check-equal? (run '(if (zero? 0) 1 2)) 1) - (check-equal? (run '(if (zero? 1) 1 2)) 2) - (check-equal? (run '(if (zero? -7) 1 2)) 2) - (check-equal? (run '(if (zero? 0) - (if (zero? 1) 1 2) - 7)) - 2) - (check-equal? (run '(if (zero? (if (zero? 0) 1 0)) - (if (zero? 1) 1 2) - 7)) - 7) - - ;; Dupe examples - (check-equal? (run #t) #t) - (check-equal? (run #f) #f) - (check-equal? (run (if #t 1 2)) 1) - (check-equal? (run (if #f 1 2)) 2) - (check-equal? (run (if 0 1 2)) 1) - (check-equal? (run '(if #t 3 4)) 3) - (check-equal? (run '(if #f 3 4)) 4) - (check-equal? (run '(if 0 3 4)) 3) - (check-equal? (run '(zero? 4)) #f) - (check-equal? (run '(zero? 0)) #t) - - ;; Dodger examples - (check-equal? (run #\a) #\a) - (check-equal? (run #\b) #\b) - (check-equal? (run '(char? #\a)) #t) - (check-equal? (run '(char? #t)) #f) - (check-equal? (run '(char? 8)) #f) - (check-equal? (run '(char->integer #\a)) (char->integer #\a)) - (check-equal? (run '(integer->char 955)) #\λ) - - ;; Evildoer examples - (check-equal? (run '(void)) (void)) - (check-equal? (run '(begin 1 2)) 2) - (check-equal? (run '(eof-object? (void))) #f) - - ;; Extort examples - (check-equal? (run '(add1 #f)) 'err) - (check-equal? (run '(sub1 #f)) 'err) - (check-equal? (run '(zero? #f)) 'err) - (check-equal? (run '(char->integer #f)) 'err) - (check-equal? (run '(integer->char #f)) 'err) - (check-equal? (run '(integer->char -1)) 'err) - (check-equal? (run '(write-byte #f)) 'err) - (check-equal? (run '(write-byte -1)) 'err) - (check-equal? (run '(write-byte 256)) 'err) - - ;; Fraud examples - (check-equal? (run '(let ((x 7)) x)) 7) - (check-equal? (run '(let ((x 7)) 2)) 2) - (check-equal? (run '(let ((x 7)) (add1 x))) 8) - (check-equal? (run '(let ((x (add1 7))) x)) 8) - (check-equal? (run '(let ((x 7)) (let ((y 2)) x))) 7) - (check-equal? (run '(let ((x 7)) (let ((x 2)) x))) 2) - (check-equal? (run '(let ((x 7)) (let ((x (add1 x))) x))) 8) - - (check-equal? (run '(let ((x 0)) - (if (zero? x) 7 8))) - 7) - (check-equal? (run '(let ((x 1)) - (add1 (if (zero? x) 7 8)))) - 9) - (check-equal? (run '(+ 3 4)) 7) - (check-equal? (run '(- 3 4)) -1) - (check-equal? (run '(+ (+ 2 1) 4)) 7) - (check-equal? (run '(+ (+ 2 1) (+ 2 2))) 7) - (check-equal? (run '(let ((x (+ 1 2))) - (let ((z (- 4 x))) - (+ (+ x x) z)))) - 7) - (check-equal? (run '(= 5 5)) #t) - (check-equal? (run '(= 4 5)) #f) - (check-equal? (run '(= (add1 4) 5)) #t) - (check-equal? (run '(< 5 5)) #f) - (check-equal? (run '(< 4 5)) #t) - (check-equal? (run '(< (add1 4) 5)) #f) - - ;; Hustle examples - (check-equal? (run ''()) '()) - (check-equal? (run '(box 1)) (box 1)) - (check-equal? (run '(box -1)) (box -1)) - (check-equal? (run '(cons 1 2)) (cons 1 2)) - (check-equal? (run '(unbox (box 1))) 1) - (check-equal? (run '(car (cons 1 2))) 1) - (check-equal? (run '(cdr (cons 1 2))) 2) - (check-equal? (run '(cons 1 '())) (list 1)) - (check-equal? (run '(box? (box 7))) #t) - (check-equal? (run '(cons? (box 7))) #f) - (check-equal? (run '(box? (cons 7 8))) #f) - (check-equal? (run '(cons? (cons 7 8))) #t) - (check-equal? (run '(empty? '())) #t) - (check-equal? (run '(empty? 7)) #f) - (check-equal? (run '(let ((x (box 2))) (unbox x))) 2) - (check-equal? (run '(let ((x (cons 2 '()))) (car x))) 2) - (check-equal? (run '(let ((x (cons 1 2))) - (begin (cdr x) - (car x)))) - 1) - (check-equal? (run '(let ((x (cons 1 2))) - (let ((y (box 3))) - (unbox y)))) - 3) - (check-equal? (run '(eq? 1 1)) #t) - (check-equal? (run '(eq? 1 2)) #f) - (check-equal? (run '(eq? (cons 1 2) (cons 1 2))) #f) - (check-equal? (run '(let ((x (cons 1 2))) (eq? x x))) #t) - - ;; Hoax examples - (check-equal? (run '(make-vector 0 0)) #()) - (check-equal? (run '(make-vector 1 0)) #(0)) - (check-equal? (run '(make-vector 3 0)) #(0 0 0)) - (check-equal? (run '(make-vector 3 5)) #(5 5 5)) - (check-equal? (run '(vector? (make-vector 0 0))) #t) - (check-equal? (run '(vector? (cons 0 0))) #f) - (check-equal? (run '(vector-ref (make-vector 0 #f) 0)) 'err) - (check-equal? (run '(vector-ref (make-vector 3 5) -1)) 'err) - (check-equal? (run '(vector-ref (make-vector 3 5) 0)) 5) - (check-equal? (run '(vector-ref (make-vector 3 5) 1)) 5) - (check-equal? (run '(vector-ref (make-vector 3 5) 2)) 5) - (check-equal? (run '(vector-ref (make-vector 3 5) 3)) 'err) - (check-equal? (run '(let ((x (make-vector 3 5))) - (begin (vector-set! x 0 4) - x))) - #(4 5 5)) - (check-equal? (run '(let ((x (make-vector 3 5))) - (begin (vector-set! x 1 4) - x))) - #(5 4 5)) - (check-equal? (run '(vector-length (make-vector 3 #f))) 3) - (check-equal? (run '(vector-length (make-vector 0 #f))) 0) - (check-equal? (run '"") "") - (check-equal? (run '"fred") "fred") - (check-equal? (run '"wilma") "wilma") - (check-equal? (run '(make-string 0 #\f)) "") - (check-equal? (run '(make-string 3 #\f)) "fff") - (check-equal? (run '(make-string 3 #\g)) "ggg") - (check-equal? (run '(string-length "")) 0) - (check-equal? (run '(string-length "fred")) 4) - (check-equal? (run '(string-ref "" 0)) 'err) - (check-equal? (run '(string-ref (make-string 0 #\a) 0)) 'err) - (check-equal? (run '(string-ref "fred" 0)) #\f) - (check-equal? (run '(string-ref "fred" 1)) #\r) - (check-equal? (run '(string-ref "fred" 2)) #\e) - (check-equal? (run '(string-ref "fred" 4)) 'err) - (check-equal? (run '(string? "fred")) #t) - (check-equal? (run '(string? (cons 1 2))) #f) - (check-equal? (run '(begin (make-string 3 #\f) - (make-string 3 #\f))) - "fff")) - -(define (test-runner-io run) - ;; Evildoer examples - (check-equal? (run 7 "") (cons 7 "")) - (check-equal? (run '(write-byte 97) "") (cons (void) "a")) - (check-equal? (run '(read-byte) "a") (cons 97 "")) - (check-equal? (run '(begin (write-byte 97) (read-byte)) "b") - (cons 98 "a")) - (check-equal? (run '(read-byte) "") (cons eof "")) - (check-equal? (run '(eof-object? (read-byte)) "") (cons #t "")) - (check-equal? (run '(eof-object? (read-byte)) "a") (cons #f "")) - (check-equal? (run '(begin (write-byte 97) (write-byte 98)) "") - (cons (void) "ab")) - - (check-equal? (run '(peek-byte) "ab") (cons 97 "")) - (check-equal? (run '(begin (peek-byte) (read-byte)) "ab") (cons 97 "")) - ;; Extort examples - (check-equal? (run '(write-byte #t) "") (cons 'err "")) - - ;; Fraud examples - (check-equal? (run '(let ((x 97)) (write-byte x)) "") (cons (void) "a")) - (check-equal? (run '(let ((x 97)) - (begin (write-byte x) - x)) - "") - (cons 97 "a")) - (check-equal? (run '(let ((x 97)) (begin (read-byte) x)) "b") - (cons 97 "")) - (check-equal? (run '(let ((x 97)) (begin (peek-byte) x)) "b") - (cons 97 "")) - - ;; Hustle examples - (check-equal? (run '(let ((x 1)) - (begin (write-byte 97) - 1)) - "") - (cons 1 "a")) - - (check-equal? (run '(let ((x 1)) - (let ((y 2)) - (begin (write-byte 97) - 1))) - "") - (cons 1 "a")) - - (check-equal? (run '(let ((x (cons 1 2))) - (begin (write-byte 97) - (car x))) - "") - (cons 1 "a"))) diff --git a/langs/hoax/types.rkt b/langs/hoax/types.rkt deleted file mode 100644 index d6bc60cd..00000000 --- a/langs/hoax/types.rkt +++ /dev/null @@ -1,67 +0,0 @@ -#lang racket -(provide (all-defined-out)) - -(define imm-shift 3) -(define imm-mask #b111) -(define ptr-mask #b111) -(define type-box #b001) -(define type-cons #b010) -(define type-vect #b011) -(define type-str #b100) -(define int-shift (+ 1 imm-shift)) -(define char-shift (+ 2 imm-shift)) -(define type-int #b0000) -(define mask-int #b1111) -(define type-char #b01000) -(define mask-char #b11111) -(define val-true #b0011000) -(define val-false #b0111000) -(define val-eof #b1011000) -(define val-void #b1111000) -(define val-empty #b10011000) - -(define (bits->value b) - (cond [(= type-int (bitwise-and b mask-int)) - (arithmetic-shift b (- int-shift))] - [(= type-char (bitwise-and b mask-char)) - (integer->char (arithmetic-shift b (- char-shift)))] - [(= b val-true) #t] - [(= b val-false) #f] - [(= b val-eof) eof] - [(= b val-void) (void)] - [(= b val-empty) '()] - [else (error "invalid bits")])) - -(define (value->bits v) - (cond [(eof-object? v) val-eof] - [(integer? v) (arithmetic-shift v int-shift)] - [(char? v) - (bitwise-ior type-char - (arithmetic-shift (char->integer v) char-shift))] - [(eq? v #t) val-true] - [(eq? v #f) val-false] - [(void? v) val-void] - [(empty? v) val-empty] - [else (error "not an immediate value" v)])) - - -(define (imm-bits? v) - (zero? (bitwise-and v imm-mask))) - -(define (int-bits? v) - (zero? (bitwise-and v mask-int))) - -(define (char-bits? v) - (= type-char (bitwise-and v mask-char))) - -(define (cons-bits? v) - (zero? (bitwise-xor (bitwise-and v imm-mask) type-cons))) - -(define (box-bits? v) - (zero? (bitwise-xor (bitwise-and v imm-mask) type-box))) - -(define (vect-bits? v) - (zero? (bitwise-xor (bitwise-and v imm-mask) type-vect))) - -(define (str-bits? v) - (zero? (bitwise-xor (bitwise-and v imm-mask) type-str))) diff --git a/langs/hoax/unload-bits-asm.rkt b/langs/hoax/unload-bits-asm.rkt deleted file mode 100644 index 4f02b0c3..00000000 --- a/langs/hoax/unload-bits-asm.rkt +++ /dev/null @@ -1,43 +0,0 @@ -#lang racket -(provide unload/free unload-value) -(require "types.rkt" - ffi/unsafe) - -;; Answer* -> Answer -(define (unload/free a) - (match a - ['err 'err] - [(cons h v) (begin0 (unload-value v) - (free h))])) - -;; Value* -> Value -(define (unload-value v) - (match v - [(? imm-bits?) (bits->value v)] - [(? box-bits? i) - (box (unload-value (heap-ref i)))] - [(? cons-bits? i) - (cons (unload-value (heap-ref (+ i 8))) - (unload-value (heap-ref i)))] - [(? vect-bits? i) - (if (zero? (untag i)) - (vector) - (build-vector (heap-ref i) - (lambda (j) - (unload-value (heap-ref (+ i (* 8 (add1 j))))))))] - [(? str-bits? i) - (if (zero? (untag i)) - (string) - (build-string (heap-ref i) - (lambda (j) - (char-ref (+ i 8) j))))])) - -(define (untag i) - (arithmetic-shift (arithmetic-shift i (- (integer-length ptr-mask))) - (integer-length ptr-mask))) - -(define (heap-ref i) - (ptr-ref (cast (untag i) _int64 _pointer) _int64)) - -(define (char-ref i j) - (integer->char (ptr-ref (cast (untag i) _int64 _pointer) _uint32 j))) diff --git a/langs/hoax/values.c b/langs/hoax/values.c index a61d65e6..b7e95f40 100644 --- a/langs/hoax/values.c +++ b/langs/hoax/values.c @@ -42,6 +42,10 @@ val_t val_wrap_int(int64_t i) { return (i << int_shift) | int_type_tag; } +val_t val_wrap_byte(unsigned char b) +{ + return (b << int_shift) | int_type_tag; +} int val_unwrap_bool(val_t x) { diff --git a/langs/hoax/values.h b/langs/hoax/values.h index 4cc48bbe..b6ac44f9 100644 --- a/langs/hoax/values.h +++ b/langs/hoax/values.h @@ -49,6 +49,7 @@ type_t val_typeof(val_t x); */ int64_t val_unwrap_int(val_t x); val_t val_wrap_int(int64_t i); +val_t val_wrap_byte(unsigned char b); int val_unwrap_bool(val_t x); val_t val_wrap_bool(int b); diff --git a/langs/hoodwink/Makefile b/langs/hoodwink/Makefile deleted file mode 100644 index 76f979af..00000000 --- a/langs/hoodwink/Makefile +++ /dev/null @@ -1,38 +0,0 @@ -UNAME := $(shell uname) -.PHONY: test - -ifeq ($(UNAME), Darwin) - format=macho64 -else - format=elf64 -endif - -objs = \ - main.o \ - values.o \ - print.o \ - symbol.o \ - io.o - -default: runtime.o - -runtime.o: $(objs) - ld -r $(objs) -o runtime.o - -%.run: %.o runtime.o - gcc runtime.o $< -o $@ - -.c.o: - gcc -fPIC -c -g -o $@ $< - -.s.o: - nasm -g -f $(format) -o $@ $< - -%.s: %.rkt - racket -t compile-file.rkt -m $< > $@ - -clean: - rm *.o *.s *.run - -test: example.run - @test "$(shell ./example.run)" = "$(shell racket example.rkt)" diff --git a/langs/hoodwink/ast.rkt b/langs/hoodwink/ast.rkt deleted file mode 100644 index 3b4aff69..00000000 --- a/langs/hoodwink/ast.rkt +++ /dev/null @@ -1,43 +0,0 @@ -#lang racket -(provide Eof Int Bool Char Str Prim0 Prim1 Prim2 Prim3 If Begin Let Var Empty) - -;; type Expr = (Eof) -;; | (Empty) -;; | (Int Integer) -;; | (Bool Boolean) -;; | (Char Character) -;; | (Str String) -;; | (Prim0 Op0) -;; | (Prim1 Op1 Expr) -;; | (Prim2 Op2 Expr Expr) -;; | (Prim3 Op3 Expr Expr Expr) -;; | (If Expr Expr Expr) -;; | (Begin Expr Expr) -;; | (Let Id Expr Expr) -;; | (Var Id) -;; type Id = Symbol -;; type Op0 = 'read-byte -;; type Op1 = 'add1 | 'sub1 | 'zero? -;; | 'char? | 'integer->char | 'char->integer -;; | 'write-byte | 'eof-object? -;; | 'box | 'car | 'cdr | 'unbox -;; | 'empty? | 'cons? | 'box? -;; | 'vector? | vector-length -;; type Op2 = '+ | '- -;; | 'cons -;; | 'make-vector | 'vector-ref -;; type Op3 = 'vector-set! -(struct Eof () #:prefab) -(struct Empty () #:prefab) -(struct Int (i) #:prefab) -(struct Bool (b) #:prefab) -(struct Char (c) #:prefab) -(struct Str (s) #:prefab) -(struct Prim0 (p) #:prefab) -(struct Prim1 (p e) #:prefab) -(struct Prim2 (p e1 e2) #:prefab) -(struct Prim3 (p e1 e2 e3) #:prefab) -(struct If (e1 e2 e3) #:prefab) -(struct Begin (e1 e2) #:prefab) -(struct Let (x e1 e2) #:prefab) -(struct Var (x) #:prefab) diff --git a/langs/hoodwink/compile-file.rkt b/langs/hoodwink/compile-file.rkt deleted file mode 100644 index ad326c3e..00000000 --- a/langs/hoodwink/compile-file.rkt +++ /dev/null @@ -1,13 +0,0 @@ -#lang racket -(provide main) -(require "parse.rkt" "compile.rkt" a86/printer) - -;; String -> Void -;; Compile contents of given file name, -;; emit asm code on stdout -(define (main fn) - (let ((p (open-input-file fn))) - (begin - (read-line p) ; ignore #lang racket line - (asm-display (compile (parse (read p)))) - (close-input-port p)))) diff --git a/langs/hoodwink/compile-ops.rkt b/langs/hoodwink/compile-ops.rkt deleted file mode 100644 index 2df0ab77..00000000 --- a/langs/hoodwink/compile-ops.rkt +++ /dev/null @@ -1,363 +0,0 @@ -#lang racket -(provide (all-defined-out)) -(require "ast.rkt" "types.rkt" a86/ast) - -(define rax 'rax) ; return -(define eax 'eax) ; 32-bit load/store -(define rbx 'rbx) ; heap -(define rdi 'rdi) ; arg -(define r8 'r8) ; scratch -(define r9 'r9) ; scratch -(define r10 'r10) ; scratch -(define rsp 'rsp) ; stack - -;; Op0 CEnv -> Asm -(define (compile-op0 p c) - (match p - ['void (seq (Mov rax val-void))] - ['read-byte (seq (pad-stack c) - (Call 'read_byte) - (unpad-stack c))] - ['peek-byte (seq (pad-stack c) - (Call 'peek_byte) - (unpad-stack c))] - ['gensym (seq (pad-stack c) - (Call 'gensym) - (unpad-stack c) - (Or rax type-symb))])) - -;; Op1 CEnv -> Asm -(define (compile-op1 p c) - (match p - ['add1 - (seq (assert-integer rax c) - (Add rax (imm->bits 1)))] - ['sub1 - (seq (assert-integer rax c) - (Sub rax (imm->bits 1)))] - ['zero? - (seq (assert-integer rax c) - (eq-imm 0))] - ['char? - (type-pred mask-char type-char)] - ['char->integer - (seq (assert-char rax c) - (Sar rax char-shift) - (Sal rax int-shift))] - ['integer->char - (seq (assert-codepoint c) - (Sar rax int-shift) - (Sal rax char-shift) - (Xor rax type-char))] - ['eof-object? (eq-imm eof)] - ['write-byte - (seq (assert-byte c) - (pad-stack c) - (Mov rdi rax) - (Call 'write_byte) - (unpad-stack c) - (Mov rax val-void))] - ['box - (seq (Mov (Offset rbx 0) rax) - (Mov rax rbx) - (Or rax type-box) - (Add rbx 8))] - ['unbox - (seq (assert-box rax c) - (Xor rax type-box) - (Mov rax (Offset rax 0)))] - ['car - (seq (assert-cons rax c) - (Xor rax type-cons) - (Mov rax (Offset rax 8)))] - ['cdr - (seq (assert-cons rax c) - (Xor rax type-cons) - (Mov rax (Offset rax 0)))] - ['empty? (eq-imm '())] - ['box? - (type-pred ptr-mask type-box)] - ['cons? - (type-pred ptr-mask type-cons)] - ['vector? - (type-pred ptr-mask type-vect)] - ['string? - (type-pred ptr-mask type-str)] - ['vector-length - (let ((zero (gensym)) - (done (gensym))) - (seq (assert-vector rax c) - (Xor rax type-vect) - (Cmp rax 0) - (Je zero) - (Mov rax (Offset rax 0)) - (Sal rax int-shift) - (Jmp done) - (Label zero) - (Mov rax 0) - (Label done)))] - ['string-length - (let ((zero (gensym)) - (done (gensym))) - (seq (assert-string rax c) - (Xor rax type-str) - (Cmp rax 0) - (Je zero) - (Mov rax (Offset rax 0)) - (Sal rax int-shift) - (Jmp done) - (Label zero) - (Mov rax 0) - (Label done)))] - ['symbol? - (type-pred ptr-mask type-symb)] - ['string->symbol - (seq (assert-string rax c) - )] - ['symbol->string - (seq (assert-symbol rax c) - )])) - -;; Op2 CEnv -> Asm -(define (compile-op2 p c) - (match p - ['+ - (seq (Pop r8) - (assert-integer r8 c) - (assert-integer rax c) - (Add rax r8))] - ['- - (seq (Pop r8) - (assert-integer r8 c) - (assert-integer rax c) - (Sub r8 rax) - (Mov rax r8))] - ['cons - (seq (Mov (Offset rbx 0) rax) - (Pop rax) - (Mov (Offset rbx 8) rax) - (Mov rax rbx) - (Or rax type-cons) - (Add rbx 16))] - ['make-vector - (let ((loop (gensym)) - (done (gensym)) - (empty (gensym))) - (seq (Pop r8) - (assert-natural r8 c) - (Cmp r8 0) ; special case empty vector - (Je empty) - - (Mov r9 rbx) - (Or r9 type-vect) - - (Sar r8 int-shift) - (Mov (Offset rbx 0) r8) - (Add rbx 8) - - (Label loop) - (Mov (Offset rbx 0) rax) - (Add rbx 8) - (Sub r8 1) - (Cmp r8 0) - (Jne loop) - - (Mov rax r9) - (Jmp done) - - (Label empty) - (Mov rax type-vect) - (Label done)))] - - ['vector-ref - (seq (Pop r8) - (assert-vector r8 c) - (assert-integer rax c) - (Cmp rax 0) - (Jl (error-label c)) - (Xor r8 type-vect) ; r8 = ptr - (Mov r9 (Offset r8 0)) ; r9 = len - (Sar rax int-shift) ; rax = index - (Sub r9 1) - (Cmp r9 rax) - (Jl (error-label c)) - (Sal rax 3) - (Add r8 rax) - (Mov rax (Offset r8 8)))] - - ['make-string - (let ((loop (gensym)) - (done (gensym)) - (empty (gensym))) - (seq (Pop r8) - (assert-natural r8 c) - (assert-char rax c) - (Cmp r8 0) ; special case empty string - (Je empty) - - (Mov r9 rbx) - (Or r9 type-str) - - (Sar r8 int-shift) - (Mov (Offset rbx 0) r8) - (Add rbx 8) - - (Sar rax char-shift) - - (Add r9 1) ; adds 1 - (Sar r9 1) ; when - (Sal r9 1) ; len is odd - - (Label loop) - (Mov (Offset rbx 0) eax) - (Add rbx 4) - (Sub r8 1) - (Cmp r8 0) - (Jne loop) - - (Mov rax r9) - (Jmp done) - - (Label empty) - (Mov rax type-str) - (Label done)))] - - ['string-ref - (seq (Pop r8) - (assert-string r8 c) - (assert-integer rax c) - (Cmp rax 0) - (Jl (error-label c)) - (Xor r8 type-str) ; r8 = ptr - (Mov r9 (Offset r8 0)) ; r9 = len - (Sar rax int-shift) ; rax = index - (Sub r9 1) - (Cmp r9 rax) - (Jl (error-label c)) - (Sal rax 2) - (Add r8 rax) - (Mov 'eax (Offset r8 8)) - (Sal rax char-shift) - (Or rax type-char))] - - ['eq? - (seq (Pop r8) - (eq r8 rax))] - ['string->symbol - (seq)] - ['symbol->string - (seq)])) - -;; Op3 CEnv -> Asm -(define (compile-op3 p c) - (match p - ['vector-set! - (seq (Pop r10) - (Pop r8) - (assert-vector r8 c) - (assert-integer r10 c) - (Cmp r10 0) - (Jl (error-label c)) - (Xor r8 type-vect) ; r8 = ptr - (Mov r9 (Offset r8 0)) ; r9 = len - (Sar r10 int-shift) ; r10 = index - (Sub r9 1) - (Cmp r9 r10) - (Jl (error-label c)) - (Sal r10 3) - (Add r8 r10) - (Mov (Offset r8 8) rax) - (Mov rax val-void))])) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define (assert-type mask type) - (λ (arg c) - (seq (Mov r9 arg) - (And r9 mask) - (Cmp r9 type) - (Jne (error-label c))))) - -(define (type-pred mask type) - (let ((l (gensym))) - (seq (And rax mask) - (Cmp rax type) - (Mov rax (imm->bits #t)) - (Je l) - (Mov rax (imm->bits #f)) - (Label l)))) - -(define assert-integer - (assert-type mask-int type-int)) -(define assert-char - (assert-type mask-char type-char)) -(define assert-box - (assert-type ptr-mask type-box)) -(define assert-cons - (assert-type ptr-mask type-cons)) -(define assert-vector - (assert-type ptr-mask type-vect)) -(define assert-string - (assert-type ptr-mask type-str)) -(define assert-symbol - (assert-type ptr-mask type-str)) - -(define (assert-codepoint c) - (let ((ok (gensym))) - (seq (assert-integer rax c) - (Cmp rax (imm->bits 0)) - (Jl (error-label c)) - (Cmp rax (imm->bits 1114111)) - (Jg (error-label c)) - (Cmp rax (imm->bits 55295)) - (Jl ok) - (Cmp rax (imm->bits 57344)) - (Jg ok) - (Jmp (error-label c)) - (Label ok)))) - -(define (assert-byte c) - (seq (assert-integer rax c) - (Cmp rax (imm->bits 0)) - (Jl (error-label c)) - (Cmp rax (imm->bits 255)) - (Jg (error-label c)))) - -(define (assert-natural r c) - (seq (assert-integer r c) - (Cmp rax (imm->bits 0)) - (Jl (error-label c)))) - -;; Value -> Asm -(define (eq-imm imm) - (eq rax (imm->bits imm))) - -(define (eq ir1 ir2) - (let ((l1 (gensym))) - (seq (Cmp ir1 ir2) - (Mov rax val-true) - (Je l1) - (Mov rax val-false) - (Label l1)))) - -;; CEnv -> Asm -;; Pad the stack to be aligned for a call -(define (pad-stack c) - (match (even? (length c)) - [#t (seq (Sub rsp 8))] - [#f (seq)])) - -;; CEnv -> Asm -;; Undo the stack alignment after a call -(define (unpad-stack c) - (match (even? (length c)) - [#t (seq (Add rsp 8))] - [#f (seq)])) - -;; CEnv -> Label -;; Determine correct error handler label to jump to. -(define (error-label c) - (match (even? (length c)) - [#t 'raise_error] - [#f 'raise_error_align])) diff --git a/langs/hoodwink/compile.rkt b/langs/hoodwink/compile.rkt deleted file mode 100644 index 0f0baf3e..00000000 --- a/langs/hoodwink/compile.rkt +++ /dev/null @@ -1,135 +0,0 @@ -#lang racket -(provide (all-defined-out)) -(require "ast.rkt" "types.rkt" "compile-ops.rkt" a86/ast) - -;; Registers used -(define rax 'rax) ; return -(define rbx 'rbx) ; heap -(define rsp 'rsp) ; stack -(define rdi 'rdi) ; arg - -;; type CEnv = [Listof Variable] - -;; Expr -> Asm -(define (compile e) - (prog (Extern 'peek_byte) - (Extern 'read_byte) - (Extern 'write_byte) - (Extern 'gensym) - (Extern 'raise_error) - (Global 'entry) - (Label 'entry) - (Mov rbx rdi) ; recv heap pointer - (compile-e e '()) - (Ret) - (Label 'raise_error_align) - (Sub rsp 8) - (Jmp 'raise_error))) - -;; Expr CEnv -> Asm -(define (compile-e e c) - (match e - [(Int i) (compile-value i)] - [(Bool b) (compile-value b)] - [(Char c) (compile-value c)] - [(Eof) (compile-value eof)] - [(Empty) (compile-value '())] - [(Var x) (compile-variable x c)] - [(Str s) (compile-string s)] - [(Prim0 p) (compile-prim0 p c)] - [(Prim1 p e) (compile-prim1 p e c)] - [(Prim2 p e1 e2) (compile-prim2 p e1 e2 c)] - [(Prim3 p e1 e2 e3) (compile-prim3 p e1 e2 e3 c)] - [(If e1 e2 e3) (compile-if e1 e2 e3 c)] - [(Begin e1 e2) (compile-begin e1 e2 c)] - [(Let x e1 e2) (compile-let x e1 e2 c)])) - -;; Value -> Asm -(define (compile-value v) - (seq (Mov rax (imm->bits v)))) - -;; Id CEnv -> Asm -(define (compile-variable x c) - (let ((i (lookup x c))) - (seq (Mov rax (Offset rsp i))))) - -;; String -> Asm -(define (compile-string s) - (let ((len (string-length s))) - (if (zero? len) - (seq (Mov rax type-str)) - (seq (Mov rax len) - (Mov (Offset rbx 0) rax) - (compile-string-chars (string->list s) 8) - (Mov rax rbx) - (Or rax type-str) - (Add rbx - (+ 8 (* 4 (if (odd? len) (add1 len) len)))))))) - -;; [Listof Char] Integer -> Asm -(define (compile-string-chars cs i) - (match cs - ['() (seq)] - [(cons c cs) - (seq (Mov rax (char->integer c)) - (Mov (Offset rbx i) 'eax) - (compile-string-chars cs (+ 4 i)))])) - -;; Op0 CEnv -> Asm -(define (compile-prim0 p c) - (compile-op0 p c)) - -;; Op1 Expr CEnv -> Asm -(define (compile-prim1 p e c) - (seq (compile-e e c) - (compile-op1 p c))) - -;; Op2 Expr Expr CEnv -> Asm -(define (compile-prim2 p e1 e2 c) - (seq (compile-e e1 c) - (Push rax) - (compile-e e2 (cons #f c)) - (compile-op2 p c))) - -;; Op3 Expr Expr Expr CEnv -> Asm -(define (compile-prim3 p e1 e2 e3 c) - (seq (compile-e e1 c) - (Push rax) - (compile-e e2 (cons #f c)) - (Push rax) - (compile-e e3 (cons #f (cons #f c))) - (compile-op3 p c))) - -;; Expr Expr Expr CEnv -> Asm -(define (compile-if e1 e2 e3 c) - (let ((l1 (gensym 'if)) - (l2 (gensym 'if))) - (seq (compile-e e1 c) - (Cmp rax val-false) - (Je l1) - (compile-e e2 c) - (Jmp l2) - (Label l1) - (compile-e e3 c) - (Label l2)))) - -;; Expr Expr CEnv -> Asm -(define (compile-begin e1 e2 c) - (seq (compile-e e1 c) - (compile-e e2 c))) - -;; Id Expr Expr CEnv -> Asm -(define (compile-let x e1 e2 c) - (seq (compile-e e1 c) - (Push rax) - (compile-e e2 (cons x c)) - (Add rsp 8))) - -;; Id CEnv -> Integer -(define (lookup x cenv) - (match cenv - ['() (error "undefined variable:" x)] - [(cons y rest) - (match (eq? x y) - [#t 0] - [#f (+ 8 (lookup x rest))])])) diff --git a/langs/hoodwink/env.rkt b/langs/hoodwink/env.rkt deleted file mode 100644 index c43be9c3..00000000 --- a/langs/hoodwink/env.rkt +++ /dev/null @@ -1,15 +0,0 @@ -#lang racket -(provide lookup ext) - -;; Env Variable -> Answer -(define (lookup env x) - (match env - ['() 'err] - [(cons (list y i) env) - (match (symbol=? x y) - [#t i] - [#f (lookup env x)])])) - -;; Env Variable Value -> Value -(define (ext r x i) - (cons (list x i) r)) \ No newline at end of file diff --git a/langs/hoodwink/example.rkt b/langs/hoodwink/example.rkt deleted file mode 100644 index 2ee62b7b..00000000 --- a/langs/hoodwink/example.rkt +++ /dev/null @@ -1,2 +0,0 @@ -#lang racket -(cons '() '()) diff --git a/langs/hoodwink/interp-file.rkt b/langs/hoodwink/interp-file.rkt deleted file mode 100644 index e6c9b1d3..00000000 --- a/langs/hoodwink/interp-file.rkt +++ /dev/null @@ -1,13 +0,0 @@ -#lang racket -(provide main) -(require "parse.rkt" "interp.rkt") - -;; String -> Void -;; Parse and interpret contents of given filename, -;; print result on stdout -(define (main fn) - (let ((p (open-input-file fn))) - (begin - (read-line p) ; ignore #lang racket line - (println (interp (parse (read p)))) - (close-input-port p)))) diff --git a/langs/hoodwink/interp-io.rkt b/langs/hoodwink/interp-io.rkt deleted file mode 100644 index 12da1b4b..00000000 --- a/langs/hoodwink/interp-io.rkt +++ /dev/null @@ -1,12 +0,0 @@ -#lang racket -(provide interp/io) -(require "interp.rkt") - -;; Expr String -> (Cons Value String) -;; Interpret e with given string as input, -;; collect output as string (including printed result) -(define (interp/io e input) - (parameterize ((current-output-port (open-output-string)) - (current-input-port (open-input-string input))) - (cons (interp e) - (get-output-string (current-output-port))))) diff --git a/langs/hoodwink/interp-prims.rkt b/langs/hoodwink/interp-prims.rkt deleted file mode 100644 index fdbdc591..00000000 --- a/langs/hoodwink/interp-prims.rkt +++ /dev/null @@ -1,66 +0,0 @@ -#lang racket -(require "ast.rkt") -(provide interp-prim1 interp-prim2 interp-prim3) - -;; Op1 Value -> Answer -(define (interp-prim1 p1 v) - (match (list p1 v) - [(list 'add1 (? integer?)) (add1 v)] - [(list 'sub1 (? integer?)) (sub1 v)] - [(list 'zero? (? integer?)) (zero? v)] - [(list 'char? v) (char? v)] - [(list 'char->integer (? char?)) (char->integer v)] - [(list 'integer->char (? codepoint?)) (integer->char v)] - [(list 'eof-object? v) (eof-object? v)] - [(list 'write-byte (? byte?)) (write-byte v)] - [(list 'box v) (box v)] - [(list 'unbox (? box?)) (unbox v)] - [(list 'car (? pair?)) (car v)] - [(list 'cdr (? pair?)) (cdr v)] - [(list 'empty? v) (empty? v)] - [(list 'cons? v) (cons? v)] - [(list 'box? v) (box? v)] - [(list 'vector? v) (vector? v)] - [(list 'vector-length (? vector?)) (vector-length v)] - [(list 'string? v) (string? v)] - [(list 'string-length (? string?)) (string-length v)] - [_ 'err])) - -;; Op2 Value Value -> Answer -(define (interp-prim2 p v1 v2) - (match (list p v1 v2) - [(list '+ (? integer?) (? integer?)) (+ v1 v2)] - [(list '- (? integer?) (? integer?)) (- v1 v2)] - [(list 'cons v1 v2) (cons v1 v2)] - [(list 'make-vector (? integer?) _) - (if (<= 0 v1) - (make-vector v1 v2) - 'err)] - [(list 'vector-ref (? vector?) (? integer?)) - (if (<= 0 v2 (sub1 (vector-length v1))) - (vector-ref v1 v2) - 'err)] - [(list 'make-string (? integer?) (? char?)) - (if (<= 0 v1) - (make-string v1 v2) - 'err)] - [(list 'string-ref (? string?) (? integer?)) - (if (<= 0 v2 (sub1 (string-length v1))) - (string-ref v1 v2) - 'err)] - [_ 'err])) - -;; Op3 Value Value Value -> Answer -(define (interp-prim3 p v1 v2 v3) - (match (list p v1 v2 v3) - [(list 'vector-set! (? vector?) (? integer?) _) - (if (<= 0 v2 (sub1 (vector-length v1))) - (vector-set! v1 v2 v3) - 'err)] - [_ 'err])) - -;; Any -> Boolean -(define (codepoint? v) - (and (integer? v) - (or (<= 0 v 55295) - (<= 57344 v 1114111)))) diff --git a/langs/hoodwink/interp.rkt b/langs/hoodwink/interp.rkt deleted file mode 100644 index 89243152..00000000 --- a/langs/hoodwink/interp.rkt +++ /dev/null @@ -1,72 +0,0 @@ -#lang racket -(provide interp interp-env interp-prim1) -(require "ast.rkt" - "env.rkt" - "interp-prims.rkt") - -;; type Answer = Value | 'err - -;; type Value = -;; | Integer -;; | Boolean -;; | Character -;; | Eof -;; | Void -;; | '() -;; | (cons Value Value) -;; | (box Value) -;; | (vector Value ...) -;; | (string Char ...) - -;; type REnv = (Listof (List Id Value)) - -;; Expr -> Answer -(define (interp e) - (interp-env e '())) - -;; Expr Env -> Answer -(define (interp-env e r) - (match e - [(Int i) i] - [(Bool b) b] - [(Char c) c] - [(Eof) eof] - [(Empty) '()] - [(Var x) (lookup r x)] - [(Str s) (string-copy s)] - [(Prim0 'void) (void)] - [(Prim0 'read-byte) (read-byte)] - [(Prim0 'peek-byte) (peek-byte)] - [(Prim1 p e) - (match (interp-env e r) - ['err 'err] - [v (interp-prim1 p v)])] - [(Prim2 p e1 e2) - (match (interp-env e1 r) - ['err 'err] - [v1 (match (interp-env e2 r) - ['err 'err] - [v2 (interp-prim2 p v1 v2)])])] - [(Prim3 p e1 e2 e3) - (match (interp-env e1 r) - ['err 'err] - [v1 (match (interp-env e2 r) - ['err 'err] - [v2 (match (interp-env e3 r) - ['err 'err] - [v3 (interp-prim3 p v1 v2 v3)])])])] - [(If p e1 e2) - (match (interp-env p r) - ['err 'err] - [v - (if v - (interp-env e1 r) - (interp-env e2 r))])] - [(Begin e1 e2) - (match (interp-env e1 r) - ['err 'err] - [_ (interp-env e2 r)])] - [(Let x e1 e2) - (match (interp-env e1 r) - ['err 'err] - [v (interp-env e2 (ext r x v))])])) diff --git a/langs/hoodwink/io.c b/langs/hoodwink/io.c deleted file mode 100644 index 7ef82281..00000000 --- a/langs/hoodwink/io.c +++ /dev/null @@ -1,25 +0,0 @@ -#include -#include -#include "types.h" -#include "values.h" -#include "runtime.h" - -val_t read_byte(void) -{ - char c = getc(in); - return (c == EOF) ? val_wrap_eof() : val_wrap_int(c); -} - -val_t peek_byte(void) -{ - char c = getc(in); - ungetc(c, in); - return (c == EOF) ? val_wrap_eof() : val_wrap_int(c); - -} - -val_t write_byte(val_t c) -{ - putc((char) val_unwrap_int(c), out); - return val_wrap_void(); -} diff --git a/langs/hoodwink/main.c b/langs/hoodwink/main.c deleted file mode 100644 index 1ca6115f..00000000 --- a/langs/hoodwink/main.c +++ /dev/null @@ -1,40 +0,0 @@ -#include -#include -#include "values.h" -#include "print.h" -#include "runtime.h" - -FILE* in; -FILE* out; -void (*error_handler)(); -val_t *heap; - -void error_exit() -{ - printf("err\n"); - exit(1); -} - -void raise_error() -{ - return error_handler(); -} - -int main(int argc, char** argv) -{ - in = stdin; - out = stdout; - error_handler = &error_exit; - heap = malloc(8 * heap_size); - - val_t result; - - result = entry(heap); - - print_result(result); - if (val_typeof(result) != T_VOID) - putchar('\n'); - - free(heap); - return 0; -} diff --git a/langs/hoodwink/parse.rkt b/langs/hoodwink/parse.rkt deleted file mode 100644 index db4ec746..00000000 --- a/langs/hoodwink/parse.rkt +++ /dev/null @@ -1,46 +0,0 @@ -#lang racket -(provide parse) -(require "ast.rkt") - -;; S-Expr -> Expr -(define (parse s) - (match s - [(? integer?) (Int s)] - [(? boolean?) (Bool s)] - [(? char?) (Char s)] - [(? string?) (Str s)] - ['eof (Eof)] - [(? symbol?) (Var s)] - [(list 'quote (list)) (Empty)] - [(list (? (op? op0) p0)) (Prim0 p0)] - [(list (? (op? op1) p1) e) (Prim1 p1 (parse e))] - [(list (? (op? op2) p2) e1 e2) (Prim2 p2 (parse e1) (parse e2))] - [(list (? (op? op3) p3) e1 e2 e3) - (Prim3 p3 (parse e1) (parse e2) (parse e3))] - [(list 'begin e1 e2) - (Begin (parse e1) (parse e2))] - [(list 'if e1 e2 e3) - (If (parse e1) (parse e2) (parse e3))] - [(list 'let (list (list (? symbol? x) e1)) e2) - (Let x (parse e1) (parse e2))] - [_ (error "Parse error" s)])) - -(define op0 - '(read-byte peek-byte void gensym)) - -(define op1 - '(add1 sub1 zero? char? write-byte eof-object? - integer->char char->integer - box unbox empty? cons? box? car cdr - vector? vector-length string? string-length - symbol? string->symbol symbol->string)) -(define op2 - '(+ - cons make-vector vector-ref make-string string-ref - eq?)) -(define op3 - '(vector-set!)) - -(define (op? ops) - (λ (x) - (and (symbol? x) - (memq x ops)))) diff --git a/langs/hoodwink/print.c b/langs/hoodwink/print.c deleted file mode 100644 index 365357e2..00000000 --- a/langs/hoodwink/print.c +++ /dev/null @@ -1,832 +0,0 @@ -#include -#include -#include "values.h" - -void print_char(val_char_t); -void print_codepoint(val_char_t); -void print_cons(val_cons_t *); -void print_vect(val_vect_t*); -void print_str(val_str_t*); -void print_symb(val_symb_t*); -void print_str_char(val_char_t); -int utf8_encode_char(val_char_t, char *); - -void print_result(val_t x) -{ - switch (val_typeof(x)) { - case T_INT: - printf("%" PRId64, val_unwrap_int(x)); - break; - case T_BOOL: - printf(val_unwrap_bool(x) ? "#t" : "#f"); - break; - case T_CHAR: - print_char(val_unwrap_char(x)); - break; - case T_EOF: - printf("#"); - break; - case T_VOID: - break; - case T_EMPTY: - printf("'()"); - break; - case T_BOX: - printf("#&"); - print_result(val_unwrap_box(x)->val); - break; - case T_CONS: - printf("'("); - print_cons(val_unwrap_cons(x)); - printf(")"); - break; - case T_VECT: - print_vect(val_unwrap_vect(x)); - break; - case T_STR: - putchar('"'); - print_str(val_unwrap_str(x)); - putchar('"'); - break; - case T_SYMB: - print_symb(val_unwrap_symb(x)); - break; - case T_INVALID: - printf("internal error"); - } -} - -void print_symb(val_symb_t *s) -{ - print_str((val_str_t*) s); -} - -void print_vect(val_vect_t *v) -{ - uint64_t i; - - if (!v) { printf("'#()"); return; } - - printf("'#("); - for (i = 0; i < v->len; ++i) { - print_result(v->elems[i]); - - if (i < v->len - 1) - putchar(' '); - } - printf(")"); -} - -void print_cons(val_cons_t *cons) -{ - print_result(cons->fst); - - switch (val_typeof(cons->snd)) { - case T_EMPTY: - // nothing - break; - case T_CONS: - printf(" "); - print_cons(val_unwrap_cons(cons->snd)); - break; - default: - printf(" . "); - print_result(cons->snd); - break; - } -} - -void print_str(val_str_t* s) -{ - if (!s) return; - uint64_t i; - for (i = 0; i < s->len; ++i) - print_str_char(s->codepoints[i]); -} - -void print_str_char_u(val_char_t c) -{ - printf("\\u%04X", c); -} - -void print_str_char_U(val_char_t c) -{ - printf("\\U%08X", c); -} - -void print_str_char(val_char_t c) -{ - switch (c) { - case 0 ... 6: - print_str_char_u(c); - break; - case 7: - printf("\\a"); - break; - case 8: - printf("\\b"); - break; - case 9: - printf("\\t"); - break; - case 10: - printf("\\n"); - break; - case 11: - printf("\\v"); - break; - case 12: - printf("\\f"); - break; - case 13: - printf("\\r"); - break; - case 14 ... 26: - print_str_char_u(c); - break; - case 27: - printf("\\e"); - break; - case 28 ... 31: - print_str_char_u(c); - break; - case 34: - printf("\\\""); - break; - case 39: - printf("'"); - break; - case 92: - printf("\\\\"); - break; - case 127 ... 159: - case 173 ... 173: - case 888 ... 889: - case 896 ... 899: - case 907 ... 907: - case 909 ... 909: - case 930 ... 930: - case 1328 ... 1328: - case 1367 ... 1368: - case 1376 ... 1376: - case 1416 ... 1416: - case 1419 ... 1420: - case 1424 ... 1424: - case 1480 ... 1487: - case 1515 ... 1519: - case 1525 ... 1541: - case 1564 ... 1565: - case 1757 ... 1757: - case 1806 ... 1807: - case 1867 ... 1868: - case 1970 ... 1983: - case 2043 ... 2047: - case 2094 ... 2095: - case 2111 ... 2111: - case 2140 ... 2141: - case 2143 ... 2207: - case 2227 ... 2275: - case 2436 ... 2436: - case 2445 ... 2446: - case 2449 ... 2450: - case 2473 ... 2473: - case 2481 ... 2481: - case 2483 ... 2485: - case 2490 ... 2491: - case 2501 ... 2502: - case 2505 ... 2506: - case 2511 ... 2518: - case 2520 ... 2523: - case 2526 ... 2526: - case 2532 ... 2533: - case 2556 ... 2560: - case 2564 ... 2564: - case 2571 ... 2574: - case 2577 ... 2578: - case 2601 ... 2601: - case 2609 ... 2609: - case 2612 ... 2612: - case 2615 ... 2615: - case 2618 ... 2619: - case 2621 ... 2621: - case 2627 ... 2630: - case 2633 ... 2634: - case 2638 ... 2640: - case 2642 ... 2648: - case 2653 ... 2653: - case 2655 ... 2661: - case 2678 ... 2688: - case 2692 ... 2692: - case 2702 ... 2702: - case 2706 ... 2706: - case 2729 ... 2729: - case 2737 ... 2737: - case 2740 ... 2740: - case 2746 ... 2747: - case 2758 ... 2758: - case 2762 ... 2762: - case 2766 ... 2767: - case 2769 ... 2783: - case 2788 ... 2789: - case 2802 ... 2816: - case 2820 ... 2820: - case 2829 ... 2830: - case 2833 ... 2834: - case 2857 ... 2857: - case 2865 ... 2865: - case 2868 ... 2868: - case 2874 ... 2875: - case 2885 ... 2886: - case 2889 ... 2890: - case 2894 ... 2901: - case 2904 ... 2907: - case 2910 ... 2910: - case 2916 ... 2917: - case 2936 ... 2945: - case 2948 ... 2948: - case 2955 ... 2957: - case 2961 ... 2961: - case 2966 ... 2968: - case 2971 ... 2971: - case 2973 ... 2973: - case 2976 ... 2978: - case 2981 ... 2983: - case 2987 ... 2989: - case 3002 ... 3005: - case 3011 ... 3013: - case 3017 ... 3017: - case 3022 ... 3023: - case 3025 ... 3030: - case 3032 ... 3045: - case 3067 ... 3071: - case 3076 ... 3076: - case 3085 ... 3085: - case 3089 ... 3089: - case 3113 ... 3113: - case 3130 ... 3132: - case 3141 ... 3141: - case 3145 ... 3145: - case 3150 ... 3156: - case 3159 ... 3159: - case 3162 ... 3167: - case 3172 ... 3173: - case 3184 ... 3191: - case 3200 ... 3200: - case 3204 ... 3204: - case 3213 ... 3213: - case 3217 ... 3217: - case 3241 ... 3241: - case 3252 ... 3252: - case 3258 ... 3259: - case 3269 ... 3269: - case 3273 ... 3273: - case 3278 ... 3284: - case 3287 ... 3293: - case 3295 ... 3295: - case 3300 ... 3301: - case 3312 ... 3312: - case 3315 ... 3328: - case 3332 ... 3332: - case 3341 ... 3341: - case 3345 ... 3345: - case 3387 ... 3388: - case 3397 ... 3397: - case 3401 ... 3401: - case 3407 ... 3414: - case 3416 ... 3423: - case 3428 ... 3429: - case 3446 ... 3448: - case 3456 ... 3457: - case 3460 ... 3460: - case 3479 ... 3481: - case 3506 ... 3506: - case 3516 ... 3516: - case 3518 ... 3519: - case 3527 ... 3529: - case 3531 ... 3534: - case 3541 ... 3541: - case 3543 ... 3543: - case 3552 ... 3557: - case 3568 ... 3569: - case 3573 ... 3584: - case 3643 ... 3646: - case 3676 ... 3712: - case 3715 ... 3715: - case 3717 ... 3718: - case 3721 ... 3721: - case 3723 ... 3724: - case 3726 ... 3731: - case 3736 ... 3736: - case 3744 ... 3744: - case 3748 ... 3748: - case 3750 ... 3750: - case 3752 ... 3753: - case 3756 ... 3756: - case 3770 ... 3770: - case 3774 ... 3775: - case 3781 ... 3781: - case 3783 ... 3783: - case 3790 ... 3791: - case 3802 ... 3803: - case 3808 ... 3839: - case 3912 ... 3912: - case 3949 ... 3952: - case 3992 ... 3992: - case 4029 ... 4029: - case 4045 ... 4045: - case 4059 ... 4095: - case 4294 ... 4294: - case 4296 ... 4300: - case 4302 ... 4303: - case 4681 ... 4681: - case 4686 ... 4687: - case 4695 ... 4695: - case 4697 ... 4697: - case 4702 ... 4703: - case 4745 ... 4745: - case 4750 ... 4751: - case 4785 ... 4785: - case 4790 ... 4791: - case 4799 ... 4799: - case 4801 ... 4801: - case 4806 ... 4807: - case 4823 ... 4823: - case 4881 ... 4881: - case 4886 ... 4887: - case 4955 ... 4956: - case 4989 ... 4991: - case 5018 ... 5023: - case 5109 ... 5119: - case 5789 ... 5791: - case 5881 ... 5887: - case 5901 ... 5901: - case 5909 ... 5919: - case 5943 ... 5951: - case 5972 ... 5983: - case 5997 ... 5997: - case 6001 ... 6001: - case 6004 ... 6015: - case 6110 ... 6111: - case 6122 ... 6127: - case 6138 ... 6143: - case 6158 ... 6159: - case 6170 ... 6175: - case 6264 ... 6271: - case 6315 ... 6319: - case 6390 ... 6399: - case 6431 ... 6431: - case 6444 ... 6447: - case 6460 ... 6463: - case 6465 ... 6467: - case 6510 ... 6511: - case 6517 ... 6527: - case 6572 ... 6575: - case 6602 ... 6607: - case 6619 ... 6621: - case 6684 ... 6685: - case 6751 ... 6751: - case 6781 ... 6782: - case 6794 ... 6799: - case 6810 ... 6815: - case 6830 ... 6831: - case 6847 ... 6911: - case 6988 ... 6991: - case 7037 ... 7039: - case 7156 ... 7163: - case 7224 ... 7226: - case 7242 ... 7244: - case 7296 ... 7359: - case 7368 ... 7375: - case 7415 ... 7415: - case 7418 ... 7423: - case 7670 ... 7675: - case 7958 ... 7959: - case 7966 ... 7967: - case 8006 ... 8007: - case 8014 ... 8015: - case 8024 ... 8024: - case 8026 ... 8026: - case 8028 ... 8028: - case 8030 ... 8030: - case 8062 ... 8063: - case 8117 ... 8117: - case 8133 ... 8133: - case 8148 ... 8149: - case 8156 ... 8156: - case 8176 ... 8177: - case 8181 ... 8181: - case 8191 ... 8191: - case 8203 ... 8207: - case 8232 ... 8238: - case 8288 ... 8303: - case 8306 ... 8307: - case 8335 ... 8335: - case 8349 ... 8351: - case 8382 ... 8399: - case 8433 ... 8447: - case 8586 ... 8591: - case 9211 ... 9215: - case 9255 ... 9279: - case 9291 ... 9311: - case 11124 ... 11125: - case 11158 ... 11159: - case 11194 ... 11196: - case 11209 ... 11209: - case 11218 ... 11263: - case 11311 ... 11311: - case 11359 ... 11359: - case 11508 ... 11512: - case 11558 ... 11558: - case 11560 ... 11564: - case 11566 ... 11567: - case 11624 ... 11630: - case 11633 ... 11646: - case 11671 ... 11679: - case 11687 ... 11687: - case 11695 ... 11695: - case 11703 ... 11703: - case 11711 ... 11711: - case 11719 ... 11719: - case 11727 ... 11727: - case 11735 ... 11735: - case 11743 ... 11743: - case 11843 ... 11903: - case 11930 ... 11930: - case 12020 ... 12031: - case 12246 ... 12271: - case 12284 ... 12287: - case 12352 ... 12352: - case 12439 ... 12440: - case 12544 ... 12548: - case 12590 ... 12592: - case 12687 ... 12687: - case 12731 ... 12735: - case 12772 ... 12783: - case 12831 ... 12831: - case 13055 ... 13055: - case 19894 ... 19903: - case 40909 ... 40959: - case 42125 ... 42127: - case 42183 ... 42191: - case 42540 ... 42559: - case 42654 ... 42654: - case 42744 ... 42751: - case 42895 ... 42895: - case 42926 ... 42927: - case 42930 ... 42998: - case 43052 ... 43055: - case 43066 ... 43071: - case 43128 ... 43135: - case 43205 ... 43213: - case 43226 ... 43231: - case 43260 ... 43263: - case 43348 ... 43358: - case 43389 ... 43391: - case 43470 ... 43470: - case 43482 ... 43485: - case 43519 ... 43519: - case 43575 ... 43583: - case 43598 ... 43599: - case 43610 ... 43611: - case 43715 ... 43738: - case 43767 ... 43776: - case 43783 ... 43784: - case 43791 ... 43792: - case 43799 ... 43807: - case 43815 ... 43815: - case 43823 ... 43823: - case 43872 ... 43875: - case 43878 ... 43967: - case 44014 ... 44015: - case 44026 ... 44031: - case 55204 ... 55215: - case 55239 ... 55242: - case 55292 ... 55295: - case 57344 ... 63743: - case 64110 ... 64111: - case 64218 ... 64255: - case 64263 ... 64274: - case 64280 ... 64284: - case 64311 ... 64311: - case 64317 ... 64317: - case 64319 ... 64319: - case 64322 ... 64322: - case 64325 ... 64325: - case 64450 ... 64466: - case 64832 ... 64847: - case 64912 ... 64913: - case 64968 ... 65007: - case 65022 ... 65023: - case 65050 ... 65055: - case 65070 ... 65071: - case 65107 ... 65107: - case 65127 ... 65127: - case 65132 ... 65135: - case 65141 ... 65141: - case 65277 ... 65280: - case 65471 ... 65473: - case 65480 ... 65481: - case 65488 ... 65489: - case 65496 ... 65497: - case 65501 ... 65503: - case 65511 ... 65511: - case 65519 ... 65531: - case 65534 ... 65535: - print_str_char_u(c); - break; - case 65548 ... 65548: - case 65575 ... 65575: - case 65595 ... 65595: - case 65598 ... 65598: - case 65614 ... 65615: - case 65630 ... 65663: - case 65787 ... 65791: - case 65795 ... 65798: - case 65844 ... 65846: - case 65933 ... 65935: - case 65948 ... 65951: - case 65953 ... 65999: - case 66046 ... 66175: - case 66205 ... 66207: - case 66257 ... 66271: - case 66300 ... 66303: - case 66340 ... 66351: - case 66379 ... 66383: - case 66427 ... 66431: - case 66462 ... 66462: - case 66500 ... 66503: - case 66518 ... 66559: - case 66718 ... 66719: - case 66730 ... 66815: - case 66856 ... 66863: - case 66916 ... 66926: - case 66928 ... 67071: - case 67383 ... 67391: - case 67414 ... 67423: - case 67432 ... 67583: - case 67590 ... 67591: - case 67593 ... 67593: - case 67638 ... 67638: - case 67641 ... 67643: - case 67645 ... 67646: - case 67670 ... 67670: - case 67743 ... 67750: - case 67760 ... 67839: - case 67868 ... 67870: - case 67898 ... 67902: - case 67904 ... 67967: - case 68024 ... 68029: - case 68032 ... 68095: - case 68100 ... 68100: - case 68103 ... 68107: - case 68116 ... 68116: - case 68120 ... 68120: - case 68148 ... 68151: - case 68155 ... 68158: - case 68168 ... 68175: - case 68185 ... 68191: - case 68256 ... 68287: - case 68327 ... 68330: - case 68343 ... 68351: - case 68406 ... 68408: - case 68438 ... 68439: - case 68467 ... 68471: - case 68498 ... 68504: - case 68509 ... 68520: - case 68528 ... 68607: - case 68681 ... 69215: - case 69247 ... 69631: - case 69710 ... 69713: - case 69744 ... 69758: - case 69821 ... 69821: - case 69826 ... 69839: - case 69865 ... 69871: - case 69882 ... 69887: - case 69941 ... 69941: - case 69956 ... 69967: - case 70007 ... 70015: - case 70089 ... 70092: - case 70094 ... 70095: - case 70107 ... 70112: - case 70133 ... 70143: - case 70162 ... 70162: - case 70206 ... 70319: - case 70379 ... 70383: - case 70394 ... 70400: - case 70404 ... 70404: - case 70413 ... 70414: - case 70417 ... 70418: - case 70441 ... 70441: - case 70449 ... 70449: - case 70452 ... 70452: - case 70458 ... 70459: - case 70469 ... 70470: - case 70473 ... 70474: - case 70478 ... 70486: - case 70488 ... 70492: - case 70500 ... 70501: - case 70509 ... 70511: - case 70517 ... 70783: - case 70856 ... 70863: - case 70874 ... 71039: - case 71094 ... 71095: - case 71114 ... 71167: - case 71237 ... 71247: - case 71258 ... 71295: - case 71352 ... 71359: - case 71370 ... 71839: - case 71923 ... 71934: - case 71936 ... 72383: - case 72441 ... 73727: - case 74649 ... 74751: - case 74863 ... 74863: - case 74869 ... 77823: - case 78895 ... 92159: - case 92729 ... 92735: - case 92767 ... 92767: - case 92778 ... 92781: - case 92784 ... 92879: - case 92910 ... 92911: - case 92918 ... 92927: - case 92998 ... 93007: - case 93018 ... 93018: - case 93026 ... 93026: - case 93048 ... 93052: - case 93072 ... 93951: - case 94021 ... 94031: - case 94079 ... 94094: - case 94112 ... 110591: - case 110594 ... 113663: - case 113771 ... 113775: - case 113789 ... 113791: - case 113801 ... 113807: - case 113818 ... 113819: - case 113824 ... 118783: - case 119030 ... 119039: - case 119079 ... 119080: - case 119155 ... 119162: - case 119262 ... 119295: - case 119366 ... 119551: - case 119639 ... 119647: - case 119666 ... 119807: - case 119893 ... 119893: - case 119965 ... 119965: - case 119968 ... 119969: - case 119971 ... 119972: - case 119975 ... 119976: - case 119981 ... 119981: - case 119994 ... 119994: - case 119996 ... 119996: - case 120004 ... 120004: - case 120070 ... 120070: - case 120075 ... 120076: - case 120085 ... 120085: - case 120093 ... 120093: - case 120122 ... 120122: - case 120127 ... 120127: - case 120133 ... 120133: - case 120135 ... 120137: - case 120145 ... 120145: - case 120486 ... 120487: - case 120780 ... 120781: - case 120832 ... 124927: - case 125125 ... 125126: - case 125143 ... 126463: - case 126468 ... 126468: - case 126496 ... 126496: - case 126499 ... 126499: - case 126501 ... 126502: - case 126504 ... 126504: - case 126515 ... 126515: - case 126520 ... 126520: - case 126522 ... 126522: - case 126524 ... 126529: - case 126531 ... 126534: - case 126536 ... 126536: - case 126538 ... 126538: - case 126540 ... 126540: - case 126544 ... 126544: - case 126547 ... 126547: - case 126549 ... 126550: - case 126552 ... 126552: - case 126554 ... 126554: - case 126556 ... 126556: - case 126558 ... 126558: - case 126560 ... 126560: - case 126563 ... 126563: - case 126565 ... 126566: - case 126571 ... 126571: - case 126579 ... 126579: - case 126584 ... 126584: - case 126589 ... 126589: - case 126591 ... 126591: - case 126602 ... 126602: - case 126620 ... 126624: - case 126628 ... 126628: - case 126634 ... 126634: - case 126652 ... 126703: - case 126706 ... 126975: - case 127020 ... 127023: - case 127124 ... 127135: - case 127151 ... 127152: - case 127168 ... 127168: - case 127184 ... 127184: - case 127222 ... 127231: - case 127245 ... 127247: - case 127279 ... 127279: - case 127340 ... 127343: - case 127387 ... 127461: - case 127491 ... 127503: - case 127547 ... 127551: - case 127561 ... 127567: - case 127570 ... 127743: - case 127789 ... 127791: - case 127870 ... 127871: - case 127951 ... 127955: - case 127992 ... 127999: - case 128255 ... 128255: - case 128331 ... 128335: - case 128378 ... 128378: - case 128420 ... 128420: - case 128579 ... 128580: - case 128720 ... 128735: - case 128749 ... 128751: - case 128756 ... 128767: - case 128884 ... 128895: - case 128981 ... 129023: - case 129036 ... 129039: - case 129096 ... 129103: - case 129114 ... 129119: - case 129160 ... 129167: - case 129198 ... 131071: - case 173783 ... 173823: - case 177973 ... 177983: - case 178206 ... 194559: - case 195102 ... 917759: - case 918000 ... 1114110: - print_str_char_U(c); - break; - default: - print_codepoint(c); - break; - } -} - -void print_char(val_char_t c) -{ - printf("#\\"); - switch (c) { - case 0: - printf("nul"); break; - case 8: - printf("backspace"); break; - case 9: - printf("tab"); break; - case 10: - printf("newline"); break; - case 11: - printf("vtab"); break; - case 12: - printf("page"); break; - case 13: - printf("return"); break; - case 32: - printf("space"); break; - case 127: - printf("rubout"); break; - default: - print_codepoint(c); - } -} - -void print_codepoint(val_char_t c) -{ - static char buffer[5] = {0}; - utf8_encode_char(c, buffer); - printf("%s", buffer); -} - -int utf8_encode_char(val_char_t c, char *buffer) -{ - // Output to buffer using UTF-8 encoding of codepoint - // https://en.wikipedia.org/wiki/UTF-8 - if (c < 128) { - buffer[0] = (char) c; - return 1; - } else if (c < 2048) { - buffer[0] = (char)(c >> 6) | 192; - buffer[1] = ((char) c & 63) | 128; - return 2; - } else if (c < 65536) { - buffer[0] = (char)(c >> 12) | 224; - buffer[1] = ((char)(c >> 6) & 63) | 128; - buffer[2] = ((char) c & 63) | 128; - return 3; - } else { - buffer[0] = (char)(c >> 18) | 240; - buffer[1] = ((char)(c >> 12) & 63) | 128; - buffer[2] = ((char)(c >> 6) & 63) | 128; - buffer[3] = ((char) c & 63) | 128; - return 4; - } -} diff --git a/langs/hoodwink/print.h b/langs/hoodwink/print.h deleted file mode 100644 index c22081a2..00000000 --- a/langs/hoodwink/print.h +++ /dev/null @@ -1,8 +0,0 @@ -#ifndef PRINT_H -#define PRINT_H - -#include "values.h" - -void print_result(val_t); - -#endif diff --git a/langs/hoodwink/runtime.h b/langs/hoodwink/runtime.h deleted file mode 100644 index 813214d6..00000000 --- a/langs/hoodwink/runtime.h +++ /dev/null @@ -1,15 +0,0 @@ -#ifndef RUNTIME_H -#define RUNTIME_H - -#include "values.h" - -val_t entry(); -extern FILE* in; -extern FILE* out; -extern void (*error_handler)(); - -// in words -#define heap_size 10000 -extern val_t *heap; - -#endif /* RUNTIME_H */ diff --git a/langs/hoodwink/symbol.c b/langs/hoodwink/symbol.c deleted file mode 100644 index ada4d6ea..00000000 --- a/langs/hoodwink/symbol.c +++ /dev/null @@ -1,33 +0,0 @@ -#include -#include -#include -#include -#include "values.h" - -static uint64_t gensym_ctr = 0; - -val_str_t *str_from_cstr(const char *); - -val_symb_t *gensym(void) -{ - char s[100]; // uint64_t has maximum 20 digits - sprintf(s, "g%" PRIu64, gensym_ctr++); - return (val_symb_t*)str_from_cstr(s); // uninterned symbol -} - -val_str_t *str_from_cstr(const char *s) -{ - int64_t len = strlen(s); - val_str_t *str = - malloc(sizeof(val_str_t) + len * sizeof(val_char_t)); - - if (!str) - return NULL; - - str->len = len; - int i; - for (i = 0; i < len; i++) { - str->codepoints[i] = (val_char_t)s[i]; - } - return str; -} diff --git a/langs/hoodwink/test/compile.rkt b/langs/hoodwink/test/compile.rkt deleted file mode 100644 index 00666520..00000000 --- a/langs/hoodwink/test/compile.rkt +++ /dev/null @@ -1,18 +0,0 @@ -#lang racket -(require "test-runner.rkt" - "../parse.rkt" - "../compile.rkt" - "../unload-bits-asm.rkt" - a86/interp) - -;; link with runtime for IO operations -(unless (file-exists? "../runtime.o") - (system "make -C .. runtime.o")) -(current-objs - (list (path->string (normalize-path "../runtime.o")))) - -(test-runner (λ (e) (unload/free (asm-interp (compile (parse e)))))) -(test-runner-io (λ (e s) - (match (asm-interp/io (compile (parse e)) s) - ['err 'err] - [(cons r o) (cons (unload/free r) o)]))) diff --git a/langs/hoodwink/test/interp.rkt b/langs/hoodwink/test/interp.rkt deleted file mode 100644 index 1eaa5864..00000000 --- a/langs/hoodwink/test/interp.rkt +++ /dev/null @@ -1,9 +0,0 @@ -#lang racket -(require "test-runner.rkt" - "../parse.rkt" - "../interp.rkt" - "../interp-io.rkt") - -(test-runner (λ (e) (interp (parse e)))) - -(test-runner-io (λ (e s) (interp/io (parse e) s))) diff --git a/langs/hoodwink/test/test-runner.rkt b/langs/hoodwink/test/test-runner.rkt deleted file mode 100644 index 7b197c86..00000000 --- a/langs/hoodwink/test/test-runner.rkt +++ /dev/null @@ -1,191 +0,0 @@ -#lang racket -(provide test-runner test-runner-io) -(require rackunit) - -(define (test-runner run) - ;; Abscond examples - (check-equal? (run 7) 7) - (check-equal? (run -8) -8) - - ;; Blackmail examples - (check-equal? (run '(add1 (add1 7))) 9) - (check-equal? (run '(add1 (sub1 7))) 7) - - ;; Con examples - (check-equal? (run '(if (zero? 0) 1 2)) 1) - (check-equal? (run '(if (zero? 1) 1 2)) 2) - (check-equal? (run '(if (zero? -7) 1 2)) 2) - (check-equal? (run '(if (zero? 0) - (if (zero? 1) 1 2) - 7)) - 2) - (check-equal? (run '(if (zero? (if (zero? 0) 1 0)) - (if (zero? 1) 1 2) - 7)) - 7) - - ;; Dupe examples - (check-equal? (run #t) #t) - (check-equal? (run #f) #f) - (check-equal? (run (if #t 1 2)) 1) - (check-equal? (run (if #f 1 2)) 2) - (check-equal? (run (if 0 1 2)) 1) - (check-equal? (run '(if #t 3 4)) 3) - (check-equal? (run '(if #f 3 4)) 4) - (check-equal? (run '(if 0 3 4)) 3) - (check-equal? (run '(zero? 4)) #f) - (check-equal? (run '(zero? 0)) #t) - - ;; Dodger examples - (check-equal? (run #\a) #\a) - (check-equal? (run #\b) #\b) - (check-equal? (run '(char? #\a)) #t) - (check-equal? (run '(char? #t)) #f) - (check-equal? (run '(char? 8)) #f) - (check-equal? (run '(char->integer #\a)) (char->integer #\a)) - (check-equal? (run '(integer->char 955)) #\λ) - ;; Extort examples - (check-equal? (run '(add1 #f)) 'err) - (check-equal? (run '(sub1 #f)) 'err) - (check-equal? (run '(zero? #f)) 'err) - (check-equal? (run '(char->integer #f)) 'err) - (check-equal? (run '(integer->char #f)) 'err) - (check-equal? (run '(integer->char -1)) 'err) - (check-equal? (run '(write-byte #f)) 'err) - (check-equal? (run '(write-byte -1)) 'err) - (check-equal? (run '(write-byte 256)) 'err) - - ;; Fraud examples - (check-equal? (run '(let ((x 7)) x)) 7) - (check-equal? (run '(let ((x 7)) 2)) 2) - (check-equal? (run '(let ((x 7)) (add1 x))) 8) - (check-equal? (run '(let ((x (add1 7))) x)) 8) - (check-equal? (run '(let ((x 7)) (let ((y 2)) x))) 7) - (check-equal? (run '(let ((x 7)) (let ((x 2)) x))) 2) - (check-equal? (run '(let ((x 7)) (let ((x (add1 x))) x))) 8) - - (check-equal? (run '(let ((x 0)) - (if (zero? x) 7 8))) - 7) - (check-equal? (run '(let ((x 1)) - (add1 (if (zero? x) 7 8)))) - 9) - (check-equal? (run '(+ 3 4)) 7) - (check-equal? (run '(- 3 4)) -1) - (check-equal? (run '(+ (+ 2 1) 4)) 7) - (check-equal? (run '(+ (+ 2 1) (+ 2 2))) 7) - (check-equal? (run '(let ((x (+ 1 2))) - (let ((z (- 4 x))) - (+ (+ x x) z)))) - 7) - ;; Hustle examples - (check-equal? (run ''()) '()) - (check-equal? (run '(box 1)) (box 1)) - (check-equal? (run '(cons 1 2)) (cons 1 2)) - (check-equal? (run '(unbox (box 1))) 1) - (check-equal? (run '(car (cons 1 2))) 1) - (check-equal? (run '(cdr (cons 1 2))) 2) - (check-equal? (run '(cons 1 '())) (list 1)) - (check-equal? (run '(box? (box 7))) #t) - (check-equal? (run '(cons? (box 7))) #f) - (check-equal? (run '(box? (cons 7 8))) #f) - (check-equal? (run '(cons? (cons 7 8))) #t) - (check-equal? (run '(empty? '())) #t) - (check-equal? (run '(empty? 7)) #f) - (check-equal? (run '(let ((x (box 2))) (unbox x))) 2) - (check-equal? (run '(let ((x (cons 2 '()))) (car x))) 2) - (check-equal? (run '(let ((x (cons 1 2))) - (begin (cdr x) - (car x)))) - 1) - (check-equal? (run '(let ((x (cons 1 2))) - (let ((y (box 3))) - (unbox y)))) - 3) - - ;; Hoax examples - (check-equal? (run '(make-vector 0 0)) #()) - (check-equal? (run '(make-vector 1 0)) #(0)) - (check-equal? (run '(make-vector 3 0)) #(0 0 0)) - (check-equal? (run '(make-vector 3 5)) #(5 5 5)) - (check-equal? (run '(vector? (make-vector 0 0))) #t) - (check-equal? (run '(vector? (cons 0 0))) #f) - (check-equal? (run '(vector-ref (make-vector 3 5) -1)) 'err) - (check-equal? (run '(vector-ref (make-vector 3 5) 0)) 5) - (check-equal? (run '(vector-ref (make-vector 3 5) 1)) 5) - (check-equal? (run '(vector-ref (make-vector 3 5) 2)) 5) - (check-equal? (run '(vector-ref (make-vector 3 5) 3)) 'err) - (check-equal? (run '(let ((x (make-vector 3 5))) - (begin (vector-set! x 0 4) - x))) - #(4 5 5)) - (check-equal? (run '(let ((x (make-vector 3 5))) - (begin (vector-set! x 1 4) - x))) - #(5 4 5)) - (check-equal? (run '(vector-length (make-vector 3 #f))) 3) - (check-equal? (run '(vector-length (make-vector 0 #f))) 0) - (check-equal? (run '"") "") - (check-equal? (run '"fred") "fred") - (check-equal? (run '"wilma") "wilma") - (check-equal? (run '(make-string 0 #\f)) "") - (check-equal? (run '(make-string 3 #\f)) "fff") - (check-equal? (run '(make-string 3 #\g)) "ggg") - (check-equal? (run '(string-length "")) 0) - (check-equal? (run '(string-length "fred")) 4) - (check-equal? (run '(string-ref "fred" 0)) #\f) - (check-equal? (run '(string-ref "fred" 1)) #\r) - (check-equal? (run '(string-ref "fred" 2)) #\e) - (check-equal? (run '(string-ref "fred" 4)) 'err) - (check-equal? (run '(string? "fred")) #t) - (check-equal? (run '(string? (cons 1 2))) #f)) - -(define (test-runner-io run) - ;; Evildoer examples - (check-equal? (run 7 "") (cons 7 "")) - (check-equal? (run '(write-byte 97) "") (cons (void) "a")) - (check-equal? (run '(read-byte) "a") (cons 97 "")) - (check-equal? (run '(begin (write-byte 97) (read-byte)) "b") - (cons 98 "a")) - (check-equal? (run '(read-byte) "") (cons eof "")) - (check-equal? (run '(eof-object? (read-byte)) "") (cons #t "")) - (check-equal? (run '(eof-object? (read-byte)) "a") (cons #f "")) - (check-equal? (run '(begin (write-byte 97) (write-byte 98)) "") - (cons (void) "ab")) - - (check-equal? (run '(peek-byte) "ab") (cons 97 "")) - (check-equal? (run '(begin (peek-byte) (read-byte)) "ab") (cons 97 "")) - ;; Extort examples - (check-equal? (run '(write-byte #t) "") (cons 'err "")) - - ;; Fraud examples - (check-equal? (run '(let ((x 97)) (write-byte x)) "") (cons (void) "a")) - (check-equal? (run '(let ((x 97)) - (begin (write-byte x) - x)) - "") - (cons 97 "a")) - (check-equal? (run '(let ((x 97)) (begin (read-byte) x)) "b") - (cons 97 "")) - (check-equal? (run '(let ((x 97)) (begin (peek-byte) x)) "b") - (cons 97 "")) - - ;; Hustle examples - (check-equal? (run '(let ((x 1)) - (begin (write-byte 97) - 1)) - "") - (cons 1 "a")) - - (check-equal? (run '(let ((x 1)) - (let ((y 2)) - (begin (write-byte 97) - 1))) - "") - (cons 1 "a")) - - (check-equal? (run '(let ((x (cons 1 2))) - (begin (write-byte 97) - (car x))) - "") - (cons 1 "a"))) diff --git a/langs/hoodwink/types.h b/langs/hoodwink/types.h deleted file mode 100644 index e9a5025b..00000000 --- a/langs/hoodwink/types.h +++ /dev/null @@ -1,41 +0,0 @@ -#ifndef TYPES_H -#define TYPES_H - -/* - Bit layout of values - - Values are either: - - Immediates: end in #b000 - - Pointers - - Immediates are either - - Integers: end in #b0 000 - - Characters: end in #b01 000 - - True: #b11 000 - - False: #b1 11 000 - - Eof: #b10 11 000 - - Void: #b11 11 000 - - Empty: #b100 11 000 -*/ -#define imm_shift 3 -#define ptr_type_mask ((1 << imm_shift) - 1) -#define box_type_tag 1 -#define cons_type_tag 2 -#define vect_type_tag 3 -#define str_type_tag 4 -#define symb_type_tag 5 -#define int_shift (1 + imm_shift) -#define int_type_mask ((1 << int_shift) - 1) -#define int_type_tag (0 << (int_shift - 1)) -#define nonint_type_tag (1 << (int_shift - 1)) -#define char_shift (int_shift + 1) -#define char_type_mask ((1 << char_shift) - 1) -#define char_type_tag ((0 << (char_shift - 1)) | nonint_type_tag) -#define nonchar_type_tag ((1 << (char_shift - 1)) | nonint_type_tag) -#define val_true ((0 << char_shift) | nonchar_type_tag) -#define val_false ((1 << char_shift) | nonchar_type_tag) -#define val_eof ((2 << char_shift) | nonchar_type_tag) -#define val_void ((3 << char_shift) | nonchar_type_tag) -#define val_empty ((4 << char_shift) | nonchar_type_tag) - -#endif diff --git a/langs/hoodwink/types.rkt b/langs/hoodwink/types.rkt deleted file mode 100644 index 1ac70167..00000000 --- a/langs/hoodwink/types.rkt +++ /dev/null @@ -1,70 +0,0 @@ -#lang racket -(provide (all-defined-out)) - -(define imm-shift 3) -(define imm-mask #b111) -(define ptr-mask #b111) -(define type-box #b001) -(define type-cons #b010) -(define type-vect #b011) -(define type-str #b100) -(define type-symb #b101) -(define int-shift (+ 1 imm-shift)) -(define char-shift (+ 2 imm-shift)) -(define type-int #b0000) -(define mask-int #b1111) -(define type-char #b01000) -(define mask-char #b11111) -(define val-true #b0011000) -(define val-false #b0111000) -(define val-eof #b1011000) -(define val-void #b1111000) -(define val-empty #b10011000) - -(define (bits->value b) - (cond [(= type-int (bitwise-and b mask-int)) - (arithmetic-shift b (- int-shift))] - [(= type-char (bitwise-and b mask-char)) - (integer->char (arithmetic-shift b (- char-shift)))] - [(= b val-true) #t] - [(= b val-false) #f] - [(= b val-eof) eof] - [(= b val-void) (void)] - [(= b val-empty) '()] - [else (error "invalid bits")])) - -(define (imm->bits v) - (cond [(eof-object? v) val-eof] - [(integer? v) (arithmetic-shift v int-shift)] - [(char? v) - (bitwise-ior type-char - (arithmetic-shift (char->integer v) char-shift))] - [(eq? v #t) val-true] - [(eq? v #f) val-false] - [(void? v) val-void] - [(empty? v) val-empty])) - - -(define (imm-bits? v) - (zero? (bitwise-and v imm-mask))) - -(define (int-bits? v) - (zero? (bitwise-and v mask-int))) - -(define (char-bits? v) - (= type-char (bitwise-and v mask-char))) - -(define (cons-bits? v) - (zero? (bitwise-xor (bitwise-and v ptr-mask) type-cons))) - -(define (box-bits? v) - (zero? (bitwise-xor (bitwise-and v ptr-mask) type-box))) - -(define (vect-bits? v) - (zero? (bitwise-xor (bitwise-and v ptr-mask) type-vect))) - -(define (str-bits? v) - (zero? (bitwise-xor (bitwise-and v ptr-mask) type-str))) - -(define (symb-bits? v) - (zero? (bitwise-xor (bitwise-and v ptr-mask) type-symb))) diff --git a/langs/hoodwink/unload-bits-asm.rkt b/langs/hoodwink/unload-bits-asm.rkt deleted file mode 100644 index be9b50c8..00000000 --- a/langs/hoodwink/unload-bits-asm.rkt +++ /dev/null @@ -1,43 +0,0 @@ -#lang racket -(provide unload/free unload-value) -(require "types.rkt" - ffi/unsafe) - -;; Answer* -> Answer -(define (unload/free a) - (match a - ['err 'err] - [(cons h v) (begin0 (unload-value v) - (free h))])) - -;; Value* -> Value -(define (unload-value v) - (match v - [(? imm-bits?) (bits->value v)] - [(? box-bits? i) - (box (unload-value (heap-ref i)))] - [(? cons-bits? i) - (cons (unload-value (heap-ref (+ i 8))) - (unload-value (heap-ref i)))] - [(? vect-bits? i) - (if (zero? (untag i)) - (vector) - (build-vector (heap-ref i) - (lambda (j) - (unload-value (heap-ref (+ i (* 8 (add1 j))))))))] - [(? str-bits? i) - (if (zero? (untag i)) - (string) - (build-string (heap-ref i) - (lambda (j) - (char-ref (+ i 8) j))))])) - -(define (untag i) - (arithmetic-shift (arithmetic-shift i (- (integer-length ptr-mask))) - (integer-length ptr-mask))) - -(define (heap-ref i) - (ptr-ref (cast (untag i) _int64 _pointer) _uint64)) - -(define (char-ref i j) - (integer->char (ptr-ref (cast (untag i) _int64 _pointer) _uint32 j))) diff --git a/langs/hoodwink/values.c b/langs/hoodwink/values.c deleted file mode 100644 index 5f4df97e..00000000 --- a/langs/hoodwink/values.c +++ /dev/null @@ -1,119 +0,0 @@ -#include "types.h" -#include "values.h" - -type_t val_typeof(val_t x) -{ - switch (x & ptr_type_mask) { - case box_type_tag: - return T_BOX; - case cons_type_tag: - return T_CONS; - case vect_type_tag: - return T_VECT; - case str_type_tag: - return T_STR; - case symb_type_tag: - return T_SYMB; - } - - if ((int_type_mask & x) == int_type_tag) - return T_INT; - if ((char_type_mask & x) == char_type_tag) - return T_CHAR; - - switch (x) { - case val_true: - case val_false: - return T_BOOL; - case val_eof: - return T_EOF; - case val_void: - return T_VOID; - case val_empty: - return T_EMPTY; - } - - return T_INVALID; -} - -int64_t val_unwrap_int(val_t x) -{ - return x >> int_shift; -} -val_t val_wrap_int(int64_t i) -{ - return (i << int_shift) | int_type_tag; -} - -int val_unwrap_bool(val_t x) -{ - return x == val_true; -} -val_t val_wrap_bool(int b) -{ - return b ? val_true : val_false; -} - -val_char_t val_unwrap_char(val_t x) -{ - return (val_char_t)(x >> char_shift); -} -val_t val_wrap_char(val_char_t c) -{ - return (((val_t)c) << char_shift) | char_type_tag; -} - -val_t val_wrap_eof(void) -{ - return val_eof; -} - -val_t val_wrap_void(void) -{ - return val_void; -} - -val_box_t* val_unwrap_box(val_t x) -{ - return (val_box_t *)(x ^ box_type_tag); -} -val_t val_wrap_box(val_box_t* b) -{ - return ((val_t)b) | box_type_tag; -} - -val_cons_t* val_unwrap_cons(val_t x) -{ - return (val_cons_t *)(x ^ cons_type_tag); -} -val_t val_wrap_cons(val_cons_t *c) -{ - return ((val_t)c) | cons_type_tag; -} - -val_vect_t* val_unwrap_vect(val_t x) -{ - return (val_vect_t *)(x ^ vect_type_tag); -} -val_t val_wrap_vect(val_vect_t *v) -{ - return ((val_t)v) | vect_type_tag; -} - -val_str_t* val_unwrap_str(val_t x) -{ - return (val_str_t *)(x ^ str_type_tag); -} -val_t val_wrap_str(val_str_t *v) -{ - return ((val_t)v) | str_type_tag; -} - -val_symb_t* val_unwrap_symb(val_t x) -{ - return (val_symb_t *)(x ^ symb_type_tag); -} -val_t val_wrap_symb(val_symb_t *v) -{ - return ((val_t)v) | symb_type_tag; -} diff --git a/langs/hoodwink/values.h b/langs/hoodwink/values.h deleted file mode 100644 index b3805ddf..00000000 --- a/langs/hoodwink/values.h +++ /dev/null @@ -1,80 +0,0 @@ -#ifndef VALUES_H -#define VALUES_H - -#include - -/* any abstract value */ -typedef int64_t val_t; - -typedef enum type_t { - T_INVALID = -1, - /* immediates */ - T_INT, - T_BOOL, - T_CHAR, - T_EOF, - T_VOID, - T_EMPTY, - /* pointers */ - T_BOX, - T_CONS, - T_VECT, - T_STR, - T_SYMB, -} type_t; - -typedef uint32_t val_char_t; -typedef struct val_box_t { - val_t val; -} val_box_t; -typedef struct val_cons_t { - val_t snd; - val_t fst; -} val_cons_t; -typedef struct val_vect_t { - uint64_t len; - val_t elems[]; -} val_vect_t; -typedef struct val_str_t { - uint64_t len; - val_char_t codepoints[]; -} val_str_t; -typedef val_str_t val_symb_t; - -/* return the type of x */ -type_t val_typeof(val_t x); - -/** - * Wrap/unwrap values - * - * The behavior of unwrap functions are undefined on type mismatch. - */ -int64_t val_unwrap_int(val_t x); -val_t val_wrap_int(int64_t i); - -int val_unwrap_bool(val_t x); -val_t val_wrap_bool(int b); - -val_char_t val_unwrap_char(val_t x); -val_t val_wrap_char(val_char_t b); - -val_t val_wrap_eof(); - -val_t val_wrap_void(); - -val_box_t* val_unwrap_box(val_t x); -val_t val_wrap_box(val_box_t* b); - -val_cons_t* val_unwrap_cons(val_t x); -val_t val_wrap_cons(val_cons_t* c); - -val_vect_t* val_unwrap_vect(val_t x); -val_t val_wrap_vect(val_vect_t* c); - -val_str_t* val_unwrap_str(val_t x); -val_t val_wrap_str(val_str_t* c); - -val_symb_t* val_unwrap_symb(val_t x); -val_t val_wrap_symb(val_symb_t* c); - -#endif diff --git a/langs/hustle/Makefile b/langs/hustle/Makefile index 9055c88f..db6ac44a 100644 --- a/langs/hustle/Makefile +++ b/langs/hustle/Makefile @@ -37,7 +37,8 @@ runtime.o: $(objs) cat $< | racket -t compile-stdin.rkt -m > $@ clean: - rm *.o *.s *.run + @$(RM) *.o *.s *.run ||: + @echo "$(shell basename $(shell pwd)): cleaned!" %.test: %.run %.rkt @test "$(shell ./$(<))" = "$(shell racket $(word 2,$^))" diff --git a/langs/hustle/ast.rkt b/langs/hustle/ast.rkt deleted file mode 100644 index a16cdb21..00000000 --- a/langs/hustle/ast.rkt +++ /dev/null @@ -1,36 +0,0 @@ -#lang racket -(provide Eof Int Bool Char Prim0 Prim1 Prim2 If Begin Let Var Empty) - -;; type Expr = (Eof) -;; | (Empty) -;; | (Int Integer) -;; | (Bool Boolean) -;; | (Char Character) -;; | (Prim0 Op0) -;; | (Prim1 Op1 Expr) -;; | (Prim2 Op2 Expr Expr) -;; | (If Expr Expr Expr) -;; | (Begin Expr Expr) -;; | (Let Id Expr Expr) -;; | (Var Id) -;; type Id = Symbol -;; type Op0 = 'read-byte -;; type Op1 = 'add1 | 'sub1 | 'zero? -;; | 'char? | 'integer->char | 'char->integer -;; | 'write-byte | 'eof-object? -;; | 'box | 'car | 'cdr | 'unbox -;; | 'empty? | 'cons? | 'box? -;; type Op2 = '+ | '- | '< | '= -;; | 'cons -(struct Eof () #:prefab) -(struct Empty () #:prefab) -(struct Int (i) #:prefab) -(struct Bool (b) #:prefab) -(struct Char (c) #:prefab) -(struct Prim0 (p) #:prefab) -(struct Prim1 (p e) #:prefab) -(struct Prim2 (p e1 e2) #:prefab) -(struct If (e1 e2 e3) #:prefab) -(struct Begin (e1 e2) #:prefab) -(struct Let (x e1 e2) #:prefab) -(struct Var (x) #:prefab) diff --git a/langs/hustle/build-runtime.rkt b/langs/hustle/build-runtime.rkt deleted file mode 100644 index 1cc4da53..00000000 --- a/langs/hustle/build-runtime.rkt +++ /dev/null @@ -1,12 +0,0 @@ -#lang racket -(provide runtime-path) - -(require racket/runtime-path) -(define-runtime-path here ".") - -(system (string-append "make -C '" - (path->string (normalize-path here)) - "' runtime.o")) - -(define runtime-path - (normalize-path (build-path here "runtime.o"))) \ No newline at end of file diff --git a/langs/hustle/compile-ops.rkt b/langs/hustle/compile-ops.rkt deleted file mode 100644 index aeed2335..00000000 --- a/langs/hustle/compile-ops.rkt +++ /dev/null @@ -1,182 +0,0 @@ -#lang racket -(provide (all-defined-out)) -(require "ast.rkt" "types.rkt" a86/ast) - -(define rax 'rax) ; return -(define rbx 'rbx) ; heap -(define rdi 'rdi) ; arg -(define r8 'r8) ; scratch in +, - -(define r9 'r9) ; scratch in assert-type -(define r15 'r15) ; stack pad (non-volatile) -(define rsp 'rsp) ; stack - -;; Op0 -> Asm -(define (compile-op0 p) - (match p - ['void (seq (Mov rax (value->bits (void))))] - ['read-byte (seq pad-stack - (Call 'read_byte) - unpad-stack)] - ['peek-byte (seq pad-stack - (Call 'peek_byte) - unpad-stack)])) - -;; Op1 -> Asm -(define (compile-op1 p) - (match p - ['add1 - (seq (assert-integer rax) - (Add rax (value->bits 1)))] - ['sub1 - (seq (assert-integer rax) - (Sub rax (value->bits 1)))] - ['zero? - (seq (assert-integer rax) - (eq-value 0))] - ['char? (type-pred mask-char type-char)] - ['char->integer - (seq (assert-char rax) - (Sar rax char-shift) - (Sal rax int-shift))] - ['integer->char - (seq (assert-codepoint rax) - (Sar rax int-shift) - (Sal rax char-shift) - (Xor rax type-char))] - ['eof-object? (eq-value eof)] - ['write-byte - (seq (assert-byte rax) - pad-stack - (Mov rdi rax) - (Call 'write_byte) - unpad-stack)] - ['box - (seq (Mov (Offset rbx 0) rax) ; memory write - (Mov rax rbx) ; put box in rax - (Or rax type-box) ; tag as a box - (Add rbx 8))] ; move rbx 8 bytes over - ['unbox - (seq (assert-box rax) - (Xor rax type-box) - (Mov rax (Offset rax 0)))] - ['car - (seq (assert-cons rax) - (Xor rax type-cons) - (Mov rax (Offset rax 8)))] - ['cdr - (seq (assert-cons rax) - (Xor rax type-cons) - (Mov rax (Offset rax 0)))] - ['empty? (eq-value '())] - ['cons? (type-pred ptr-mask type-cons)] - ['box? (type-pred ptr-mask type-box)])) - -;; Op2 -> Asm -(define (compile-op2 p) - (match p - ['+ - (seq (Pop r8) - (assert-integer r8) - (assert-integer rax) - (Add rax r8))] - ['- - (seq (Pop r8) - (assert-integer r8) - (assert-integer rax) - (Sub r8 rax) - (Mov rax r8))] - ['< - (seq (Pop r8) - (assert-integer r8) - (assert-integer rax) - (Cmp r8 rax) - (if-lt))] - ['= - (seq (Pop r8) - (assert-integer r8) - (assert-integer rax) - (Cmp r8 rax) - (if-equal))] - ['cons - (seq (Mov (Offset rbx 0) rax) - (Pop rax) - (Mov (Offset rbx 8) rax) - (Mov rax rbx) - (Or rax type-cons) - (Add rbx 16))] - ['eq? - (seq (Pop r8) - (Cmp rax r8) - (if-equal))])) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define (assert-type mask type) - (λ (arg) - (seq (Mov r9 arg) - (And r9 mask) - (Cmp r9 type) - (Jne 'raise_error_align)))) - -(define (type-pred mask type) - (seq (And rax mask) - (Cmp rax type) - (if-equal))) - -(define assert-integer - (assert-type mask-int type-int)) -(define assert-char - (assert-type mask-char type-char)) -(define assert-box - (assert-type ptr-mask type-box)) -(define assert-cons - (assert-type ptr-mask type-cons)) - -(define (assert-codepoint r) - (let ((ok (gensym))) - (seq (assert-integer r) - (Cmp r (value->bits 0)) - (Jl 'raise_error_align) - (Cmp r (value->bits 1114111)) - (Jg 'raise_error_align) - (Cmp r (value->bits 55295)) - (Jl ok) - (Cmp r (value->bits 57344)) - (Jg ok) - (Jmp 'raise_error_align) - (Label ok)))) - -(define (assert-byte r) - (seq (assert-integer r) - (Cmp r (value->bits 0)) - (Jl 'raise_error_align) - (Cmp r (value->bits 255)) - (Jg 'raise_error_align))) - -;; -> Asm -;; set rax to #t or #f based on given comparison -(define (if-compare c) - (seq (Mov rax (value->bits #f)) - (Mov r9 (value->bits #t)) - (c rax r9))) - -(define (if-equal) (if-compare Cmove)) -(define (if-lt) (if-compare Cmovl)) - -;; Value -> Asm -(define (eq-value v) - (seq (Cmp rax (value->bits v)) - (if-equal))) - -;; Asm -;; Dynamically pad the stack to be aligned for a call -(define pad-stack - (seq (Mov r15 rsp) - (And r15 #b1000) - (Sub rsp r15))) - -;; Asm -;; Undo the stack alignment after a call -(define unpad-stack - (seq (Add rsp r15))) diff --git a/langs/hustle/compile-stdin.rkt b/langs/hustle/compile-stdin.rkt deleted file mode 100644 index 5fbdbded..00000000 --- a/langs/hustle/compile-stdin.rkt +++ /dev/null @@ -1,10 +0,0 @@ -#lang racket -(provide main) -(require "parse.rkt" "compile.rkt" a86/printer) - -;; -> Void -;; Compile contents of stdin, -;; emit asm code on stdout -(define (main) - (read-line) ; ignore #lang racket line - (asm-display (compile (parse (read))))) diff --git a/langs/hustle/compile.rkt b/langs/hustle/compile.rkt deleted file mode 100644 index c84a83f5..00000000 --- a/langs/hustle/compile.rkt +++ /dev/null @@ -1,106 +0,0 @@ -#lang racket -(provide (all-defined-out)) -(require "ast.rkt" "types.rkt" "compile-ops.rkt" a86/ast) - -;; Registers used -(define rax 'rax) ; return -(define rbx 'rbx) ; heap -(define rsp 'rsp) ; stack -(define rdi 'rdi) ; arg -(define r15 'r15) ; stack pad (non-volatile) - -;; type CEnv = (Listof [Maybe Id]) - -;; Expr -> Asm -(define (compile e) - (prog (Extern 'peek_byte) - (Extern 'read_byte) - (Extern 'write_byte) - (Extern 'raise_error) - (Global 'entry) - (Label 'entry) - (Push rbx) ; save callee-saved register - (Push r15) - (Mov rbx rdi) ; recv heap pointer - (compile-e e '()) - (Pop r15) ; restore callee-save register - (Pop rbx) - (Ret) - (Label 'raise_error_align) - pad-stack - (Call 'raise_error))) - -;; Expr CEnv -> Asm -(define (compile-e e c) - (match e - [(Int i) (compile-value i)] - [(Bool b) (compile-value b)] - [(Char c) (compile-value c)] - [(Eof) (compile-value eof)] - [(Empty) (compile-value '())] - [(Var x) (compile-variable x c)] - [(Prim0 p) (compile-prim0 p c)] - [(Prim1 p e) (compile-prim1 p e c)] - [(Prim2 p e1 e2) (compile-prim2 p e1 e2 c)] - [(If e1 e2 e3) (compile-if e1 e2 e3 c)] - [(Begin e1 e2) (compile-begin e1 e2 c)] - [(Let x e1 e2) (compile-let x e1 e2 c)])) - -;; Value -> Asm -(define (compile-value v) - (seq (Mov rax (value->bits v)))) - -;; Id CEnv -> Asm -(define (compile-variable x c) - (let ((i (lookup x c))) - (seq (Mov rax (Offset rsp i))))) - -;; Op0 CEnv -> Asm -(define (compile-prim0 p c) - (compile-op0 p)) - -;; Op1 Expr CEnv -> Asm -(define (compile-prim1 p e c) - (seq (compile-e e c) - (compile-op1 p))) - -;; Op2 Expr Expr CEnv -> Asm -(define (compile-prim2 p e1 e2 c) - (seq (compile-e e1 c) - (Push rax) - (compile-e e2 (cons #f c)) - (compile-op2 p))) - -;; Expr Expr Expr CEnv -> Asm -(define (compile-if e1 e2 e3 c) - (let ((l1 (gensym 'if)) - (l2 (gensym 'if))) - (seq (compile-e e1 c) - (Cmp rax (value->bits #f)) - (Je l1) - (compile-e e2 c) - (Jmp l2) - (Label l1) - (compile-e e3 c) - (Label l2)))) - -;; Expr Expr CEnv -> Asm -(define (compile-begin e1 e2 c) - (seq (compile-e e1 c) - (compile-e e2 c))) - -;; Id Expr Expr CEnv -> Asm -(define (compile-let x e1 e2 c) - (seq (compile-e e1 c) - (Push rax) - (compile-e e2 (cons x c)) - (Add rsp 8))) - -;; Id CEnv -> Integer -(define (lookup x cenv) - (match cenv - ['() (error "undefined variable:" x)] - [(cons y rest) - (match (eq? x y) - [#t 0] - [#f (+ 8 (lookup x rest))])])) diff --git a/langs/hustle/correctness.rkt b/langs/hustle/correctness.rkt index 0e5feb83..b117f263 100644 --- a/langs/hustle/correctness.rkt +++ b/langs/hustle/correctness.rkt @@ -4,15 +4,11 @@ "compile.rkt" "types.rkt" "parse.rkt" - "unload-bits-asm.rkt" - a86 rackunit) + "run.rkt" + rackunit) -(unless (file-exists? "runtime.o") - (system "make runtime.o")) -(current-objs - (list (path->string (normalize-path "runtime.o")))) (define (check-compiler e) - (check-equal? (unload/free (asm-interp (compile (parse e)))) + (check-equal? (run (compile (parse e))) (interp (parse e)) e)) diff --git a/langs/hustle/info.rkt b/langs/hustle/info.rkt new file mode 100644 index 00000000..41ec40bb --- /dev/null +++ b/langs/hustle/info.rkt @@ -0,0 +1,2 @@ +#lang info +(define pre-install-collection "../installer.rkt") diff --git a/langs/hustle/interp-heap-bits.rkt b/langs/hustle/interp-heap-bits.rkt index 285da60d..25862ed8 100644 --- a/langs/hustle/interp-heap-bits.rkt +++ b/langs/hustle/interp-heap-bits.rkt @@ -1,6 +1,6 @@ #lang racket (provide interp interp-env-heap) -(require "types.rkt" +(require (except-in "types.rkt" heap-ref) "env.rkt" "heap-bits.rkt" "interp-prims-heap-bits.rkt" @@ -18,9 +18,7 @@ ;; Expr REnv Heap -> Answer (define (interp-env-heap e r h) (match e - [(Int i) (cons h (value->bits i))] - [(Bool b) (cons h (value->bits b))] - [(Char c) (cons h (value->bits c))] + [(Lit d) (cons h (value->bits d))] [(Eof) (cons h (value->bits eof))] [(Empty) (cons h (value->bits '()))] [(Var x) (cons h (lookup r x))] diff --git a/langs/hustle/interp-heap.rkt b/langs/hustle/interp-heap.rkt index 18805f91..69a0527c 100644 --- a/langs/hustle/interp-heap.rkt +++ b/langs/hustle/interp-heap.rkt @@ -29,11 +29,9 @@ ;; Expr REnv Heap -> Answer* (define (interp-env-heap e r h) (match e - [(Int i) (cons h i)] - [(Bool b) (cons h b)] - [(Char c) (cons h c)] - [(Eof) (cons h eof)] + [(Lit d) (cons h d)] [(Empty) (cons h '())] + [(Eof) (cons h eof)] [(Var x) (cons h (lookup r x))] [(Prim0 'void) (cons h (void))] [(Prim0 'peek-byte) (cons h (peek-byte))] diff --git a/langs/hustle/interp-io.rkt b/langs/hustle/interp-io.rkt deleted file mode 100644 index 12da1b4b..00000000 --- a/langs/hustle/interp-io.rkt +++ /dev/null @@ -1,12 +0,0 @@ -#lang racket -(provide interp/io) -(require "interp.rkt") - -;; Expr String -> (Cons Value String) -;; Interpret e with given string as input, -;; collect output as string (including printed result) -(define (interp/io e input) - (parameterize ((current-output-port (open-output-string)) - (current-input-port (open-input-string input))) - (cons (interp e) - (get-output-string (current-output-port))))) diff --git a/langs/hustle/interp-prims-heap-bits.rkt b/langs/hustle/interp-prims-heap-bits.rkt index b9be89d2..a9f26ade 100644 --- a/langs/hustle/interp-prims-heap-bits.rkt +++ b/langs/hustle/interp-prims-heap-bits.rkt @@ -1,6 +1,6 @@ #lang racket (provide interp-prim1 interp-prim2) -(require "types.rkt" +(require (except-in "types.rkt" heap-ref) "heap-bits.rkt") ;; Op1 Value* Heap -> Answer* @@ -12,13 +12,13 @@ [(list 'char? v) (cons h (value->bits (char-bits? v)))] [(list 'char->integer (? char-bits?)) (cons h (value->bits (char->integer (bits->value v))))] [(list 'integer->char (? cp-bits?)) (cons h (value->bits (integer->char (bits->value v))))] - [(list 'eof-object? v) (cons h (if (= v (value->bits eof)) val-true val-false))] - [(list 'write-byte (? byte-bits?)) (cons h (begin (write-byte (bits->value v)) val-void))] + [(list 'eof-object? v) (cons h (value->bits (= v (value->bits eof))))] + [(list 'write-byte (? byte-bits?)) (cons h (begin (write-byte (bits->value v)) (value->bits (void))))] [(list 'box v) (alloc-box v h)] [(list 'unbox (? box-bits? i)) (cons h (heap-ref h i))] [(list 'car (? cons-bits? i)) (cons h (heap-ref h i))] [(list 'cdr (? cons-bits? i)) (cons h (heap-ref h (+ i (arithmetic-shift 1 imm-shift))))] - [(list 'empty? v) (cons h (if (= (value->bits '()) v) val-true val-false))] + [(list 'empty? v) (cons h (value->bits (= (value->bits '()) v)))] [_ 'err])) ;; Op2 Value* Value* Heap -> Answer* diff --git a/langs/hustle/interp-prims.rkt b/langs/hustle/interp-prims.rkt deleted file mode 100644 index 68144d74..00000000 --- a/langs/hustle/interp-prims.rkt +++ /dev/null @@ -1,40 +0,0 @@ -#lang racket -(require "ast.rkt") -(provide interp-prim1 interp-prim2) - -;; Op1 Value -> Answer -(define (interp-prim1 p1 v) - (match (list p1 v) - [(list 'add1 (? integer?)) (add1 v)] - [(list 'sub1 (? integer?)) (sub1 v)] - [(list 'zero? (? integer?)) (zero? v)] - [(list 'char? v) (char? v)] - [(list 'char->integer (? char?)) (char->integer v)] - [(list 'integer->char (? codepoint?)) (integer->char v)] - [(list 'eof-object? v) (eof-object? v)] - [(list 'write-byte (? byte?)) (write-byte v)] - [(list 'box v) (box v)] - [(list 'unbox (? box?)) (unbox v)] - [(list 'car (? pair?)) (car v)] - [(list 'cdr (? pair?)) (cdr v)] - [(list 'empty? v) (empty? v)] - [(list 'cons? v) (cons? v)] - [(list 'box? v) (box? v)] - [_ 'err])) - -;; Op2 Value Value -> Answer -(define (interp-prim2 p v1 v2) - (match (list p v1 v2) - [(list '+ (? integer?) (? integer?)) (+ v1 v2)] - [(list '- (? integer?) (? integer?)) (- v1 v2)] - [(list '< (? integer?) (? integer?)) (< v1 v2)] - [(list '= (? integer?) (? integer?)) (= v1 v2)] - [(list 'cons v1 v2) (cons v1 v2)] - [(list 'eq? v1 v2) (eq? v1 v2)] - [_ 'err])) - -;; Any -> Boolean -(define (codepoint? v) - (and (integer? v) - (or (<= 0 v 55295) - (<= 57344 v 1114111)))) diff --git a/langs/hustle/interp-stdin.rkt b/langs/hustle/interp-stdin.rkt deleted file mode 100644 index 8026d746..00000000 --- a/langs/hustle/interp-stdin.rkt +++ /dev/null @@ -1,12 +0,0 @@ -#lang racket -(provide main) -(require "parse.rkt" "interp.rkt") - -;; -> Void -;; Parse and interpret contents of stdin, -;; print result on stdout -(define (main) - (read-line) ; ignore #lang racket line - (let ((r (interp (parse (read))))) - (unless (void? r) - (println r)))) diff --git a/langs/hustle/interp.rkt b/langs/hustle/interp.rkt deleted file mode 100644 index 016781b9..00000000 --- a/langs/hustle/interp.rkt +++ /dev/null @@ -1,62 +0,0 @@ -#lang racket -(provide interp interp-env interp-prim1) -(require "ast.rkt" - "env.rkt" - "interp-prims.rkt") - -;; type Answer = Value | 'err - -;; type Value = -;; | Integer -;; | Boolean -;; | Character -;; | Eof -;; | Void -;; | '() -;; | (cons Value Value) -;; | (box Value) - -;; type REnv = (Listof (List Id Value)) - -;; Expr -> Answer -(define (interp e) - (interp-env e '())) - -;; Expr Env -> Answer -(define (interp-env e r) - (match e - [(Int i) i] - [(Bool b) b] - [(Char c) c] - [(Eof) eof] - [(Empty) '()] - [(Var x) (lookup r x)] - [(Prim0 'void) (void)] - [(Prim0 'read-byte) (read-byte)] - [(Prim0 'peek-byte) (peek-byte)] - [(Prim1 p e) - (match (interp-env e r) - ['err 'err] - [v (interp-prim1 p v)])] - [(Prim2 p e1 e2) - (match (interp-env e1 r) - ['err 'err] - [v1 (match (interp-env e2 r) - ['err 'err] - [v2 (interp-prim2 p v1 v2)])])] - [(If p e1 e2) - (match (interp-env p r) - ['err 'err] - [v - (if v - (interp-env e1 r) - (interp-env e2 r))])] - [(Begin e1 e2) - (match (interp-env e1 r) - ['err 'err] - [_ (interp-env e2 r)])] - [(Let x e1 e2) - (match (interp-env e1 r) - ['err 'err] - [v (interp-env e2 (ext r x v))])])) - diff --git a/langs/hustle/io.c b/langs/hustle/io.c index 7ef82281..8a417c91 100644 --- a/langs/hustle/io.c +++ b/langs/hustle/io.c @@ -7,14 +7,14 @@ val_t read_byte(void) { char c = getc(in); - return (c == EOF) ? val_wrap_eof() : val_wrap_int(c); + return (c == EOF) ? val_wrap_eof() : val_wrap_byte(c); } val_t peek_byte(void) { char c = getc(in); ungetc(c, in); - return (c == EOF) ? val_wrap_eof() : val_wrap_int(c); + return (c == EOF) ? val_wrap_eof() : val_wrap_byte(c); } diff --git a/langs/hustle/parse.rkt b/langs/hustle/parse.rkt deleted file mode 100644 index 6baa57ce..00000000 --- a/langs/hustle/parse.rkt +++ /dev/null @@ -1,38 +0,0 @@ -#lang racket -(provide parse) -(require "ast.rkt") - -;; S-Expr -> Expr -(define (parse s) - (match s - [(? exact-integer?) (Int s)] - [(? boolean?) (Bool s)] - [(? char?) (Char s)] - ['eof (Eof)] - [(? symbol?) (Var s)] - [(list 'quote (list)) (Empty)] - [(list (? (op? op0) p0)) (Prim0 p0)] - [(list (? (op? op1) p1) e) (Prim1 p1 (parse e))] - [(list (? (op? op2) p2) e1 e2) (Prim2 p2 (parse e1) (parse e2))] - [(list 'begin e1 e2) - (Begin (parse e1) (parse e2))] - [(list 'if e1 e2 e3) - (If (parse e1) (parse e2) (parse e3))] - [(list 'let (list (list (? symbol? x) e1)) e2) - (Let x (parse e1) (parse e2))] - [_ (error "Parse error" s)])) - -(define op0 - '(read-byte peek-byte void)) - -(define op1 - '(add1 sub1 zero? char? write-byte eof-object? - integer->char char->integer - box unbox empty? cons? box? car cdr)) -(define op2 - '(+ - < = cons eq?)) - -(define (op? ops) - (λ (x) - (and (symbol? x) - (memq x ops)))) diff --git a/langs/hustle/test/all.rkt b/langs/hustle/test/all.rkt deleted file mode 100644 index d1a3ec25..00000000 --- a/langs/hustle/test/all.rkt +++ /dev/null @@ -1,154 +0,0 @@ -#lang racket -(require "../compile.rkt" - "../interp.rkt" - "../interp-io.rkt" - "../parse.rkt" - "../types.rkt" - "../unload-bits-asm.rkt" - a86 - rackunit) - -;; link with runtime for IO operations -(unless (file-exists? "../runtime.o") - (system "make -C .. runtime.o")) -(current-objs - (list (path->string (normalize-path "../runtime.o")))) - -(define (test-runner run) - - ;; Abscond examples - (check-equal? (run 7) 7) - (check-equal? (run -8) -8) - - ;; Blackmail examples - (check-equal? (run '(add1 (add1 7))) 9) - (check-equal? (run '(add1 (sub1 7))) 7) - - ;; Con examples - (check-equal? (run '(if (zero? 0) 1 2)) 1) - (check-equal? (run '(if (zero? 1) 1 2)) 2) - (check-equal? (run '(if (zero? -7) 1 2)) 2) - (check-equal? (run '(if (zero? 0) - (if (zero? 1) 1 2) - 7)) - 2) - (check-equal? (run '(if (zero? (if (zero? 0) 1 0)) - (if (zero? 1) 1 2) - 7)) - 7) - - ;; Dupe examples - (check-equal? (run #t) #t) - (check-equal? (run #f) #f) - (check-equal? (run (if #t 1 2)) 1) - (check-equal? (run (if #f 1 2)) 2) - (check-equal? (run (if 0 1 2)) 1) - (check-equal? (run '(if #t 3 4)) 3) - (check-equal? (run '(if #f 3 4)) 4) - (check-equal? (run '(if 0 3 4)) 3) - (check-equal? (run '(zero? 4)) #f) - (check-equal? (run '(zero? 0)) #t) - - ;; Dodger examples - (check-equal? (run #\a) #\a) - (check-equal? (run #\b) #\b) - (check-equal? (run '(char? #\a)) #t) - (check-equal? (run '(char? #t)) #f) - (check-equal? (run '(char? 8)) #f) - (check-equal? (run '(char->integer #\a)) (char->integer #\a)) - (check-equal? (run '(integer->char 955)) #\λ) - - ;; Evildoer examples - (check-equal? (run '(void)) (void)) - (check-equal? (run '(begin 1 2)) 2) - (check-equal? (run '(eof-object? (void))) #f) - - ;; Extort examples - (check-equal? (run '(add1 #f)) 'err) - (check-equal? (run '(sub1 #f)) 'err) - (check-equal? (run '(zero? #f)) 'err) - (check-equal? (run '(char->integer #f)) 'err) - (check-equal? (run '(integer->char #f)) 'err) - (check-equal? (run '(integer->char -1)) 'err) - (check-equal? (run '(write-byte #f)) 'err) - (check-equal? (run '(write-byte -1)) 'err) - (check-equal? (run '(write-byte 256)) 'err) - - ;; Fraud examples - (check-equal? (run '(let ((x 7)) x)) 7) - (check-equal? (run '(let ((x 7)) 2)) 2) - (check-equal? (run '(let ((x 7)) (add1 x))) 8) - (check-equal? (run '(let ((x (add1 7))) x)) 8) - (check-equal? (run '(let ((x 7)) (let ((y 2)) x))) 7) - (check-equal? (run '(let ((x 7)) (let ((x 2)) x))) 2) - (check-equal? (run '(let ((x 7)) (let ((x (add1 x))) x))) 8) - - (check-equal? (run '(let ((x 0)) - (if (zero? x) 7 8))) - 7) - (check-equal? (run '(let ((x 1)) - (add1 (if (zero? x) 7 8)))) - 9) - (check-equal? (run '(+ 3 4)) 7) - (check-equal? (run '(- 3 4)) -1) - (check-equal? (run '(+ (+ 2 1) 4)) 7) - (check-equal? (run '(+ (+ 2 1) (+ 2 2))) 7) - (check-equal? (run '(let ((x (+ 1 2))) - (let ((z (- 4 x))) - (+ (+ x x) z)))) - 7) - - ;; Hustle examples - (check-equal? (run '(unbox (box 7))) 7) - (check-equal? (run '(let ((x (box 2))) (unbox x))) 2) - (check-equal? (run '(let ((x (cons 2 '()))) (car x))) 2) - (check-equal? (run '(box? (box 7))) #t) - (check-equal? (run '(cons? (box 7))) #f) - (check-equal? (run '(box? (cons 7 8))) #f) - (check-equal? (run '(cons? (cons 7 8))) #t) - (check-equal? (run '(empty? '())) #t) - (check-equal? (run '(empty? 7)) #f)) - -(test-runner (λ (e) (interp (parse e)))) -(test-runner (λ (e) (unload/free (asm-interp (compile (parse e)))))) - -(define (test-runner-io run) - ;; Evildoer examples - (check-equal? (run 7 "") (cons 7 "")) - (check-equal? (run '(write-byte 97) "") (cons (void) "a")) - (check-equal? (run '(read-byte) "a") (cons 97 "")) - (check-equal? (run '(begin (write-byte 97) (read-byte)) "b") - (cons 98 "a")) - (check-equal? (run '(read-byte) "") (cons eof "")) - (check-equal? (run '(eof-object? (read-byte)) "") (cons #t "")) - (check-equal? (run '(eof-object? (read-byte)) "a") (cons #f "")) - (check-equal? (run '(begin (write-byte 97) (write-byte 98)) "") - (cons (void) "ab")) - - (check-equal? (run '(peek-byte) "ab") (cons 97 "")) - (check-equal? (run '(begin (peek-byte) (read-byte)) "ab") (cons 97 "")) - ;; Extort examples - (check-equal? (run '(write-byte #t) "") (cons 'err "")) - - ;; Fraud examples - (check-equal? (run '(let ((x 97)) (write-byte x)) "") (cons (void) "a")) - (check-equal? (run '(let ((x 97)) - (begin (write-byte x) - x)) - "") - (cons 97 "a")) - (check-equal? (run '(let ((x 97)) (begin (read-byte) x)) "b") - (cons 97 "")) - (check-equal? (run '(let ((x 97)) (begin (peek-byte) x)) "b") - (cons 97 ""))) - - -(test-runner-io (λ (e s) (interp/io (parse e) s))) -(test-runner-io (λ (e s) - (match (asm-interp/io (compile (parse e)) s) - [(cons 'err o) (cons 'err o)] - [(cons r o) (cons (unload/free r) o)]))) - -;; run command line compiler and compare against Racket as refernece implementation -(require rackunit "../../test-programs/get-progs.rkt") -(for-each test-prog (get-progs "hustle")) diff --git a/langs/hustle/test/compile.rkt b/langs/hustle/test/compile.rkt deleted file mode 100644 index 00666520..00000000 --- a/langs/hustle/test/compile.rkt +++ /dev/null @@ -1,18 +0,0 @@ -#lang racket -(require "test-runner.rkt" - "../parse.rkt" - "../compile.rkt" - "../unload-bits-asm.rkt" - a86/interp) - -;; link with runtime for IO operations -(unless (file-exists? "../runtime.o") - (system "make -C .. runtime.o")) -(current-objs - (list (path->string (normalize-path "../runtime.o")))) - -(test-runner (λ (e) (unload/free (asm-interp (compile (parse e)))))) -(test-runner-io (λ (e s) - (match (asm-interp/io (compile (parse e)) s) - ['err 'err] - [(cons r o) (cons (unload/free r) o)]))) diff --git a/langs/hustle/test/interp-heap-bits.rkt b/langs/hustle/test/interp-heap-bits.rkt index 00fcf6c6..dc527441 100644 --- a/langs/hustle/test/interp-heap-bits.rkt +++ b/langs/hustle/test/interp-heap-bits.rkt @@ -4,6 +4,6 @@ "../interp-heap-bits.rkt" "../interp-io.rkt") -(test-runner (λ (e) (interp (parse e)))) +(test (λ (e) (interp (parse e)))) -(test-runner-io (λ (e s) (interp/io (parse e) s))) +(test/io (λ (s e) (interp/io (parse e) s))) diff --git a/langs/hustle/test/interp-heap.rkt b/langs/hustle/test/interp-heap.rkt index 0955d26b..06f12b82 100644 --- a/langs/hustle/test/interp-heap.rkt +++ b/langs/hustle/test/interp-heap.rkt @@ -4,6 +4,6 @@ "../interp-heap.rkt" "../interp-io.rkt") -(test-runner (λ (e) (interp (parse e)))) +(test (λ (e) (interp (parse e)))) -(test-runner-io (λ (e s) (interp/io (parse e) s))) +(test/io (λ (s e) (interp/io (parse e) s))) diff --git a/langs/hustle/test/interp.rkt b/langs/hustle/test/interp.rkt deleted file mode 100644 index 1eaa5864..00000000 --- a/langs/hustle/test/interp.rkt +++ /dev/null @@ -1,9 +0,0 @@ -#lang racket -(require "test-runner.rkt" - "../parse.rkt" - "../interp.rkt" - "../interp-io.rkt") - -(test-runner (λ (e) (interp (parse e)))) - -(test-runner-io (λ (e s) (interp/io (parse e) s))) diff --git a/langs/hustle/test/test-runner.rkt b/langs/hustle/test/test-runner.rkt deleted file mode 100644 index 0b9bcf5f..00000000 --- a/langs/hustle/test/test-runner.rkt +++ /dev/null @@ -1,156 +0,0 @@ -#lang racket -(provide test-runner test-runner-io) -(require rackunit) - -(define (test-runner run) - ;; Abscond examples - (check-equal? (run 7) 7) - (check-equal? (run -8) -8) - - ;; Blackmail examples - (check-equal? (run '(add1 (add1 7))) 9) - (check-equal? (run '(add1 (sub1 7))) 7) - - ;; Con examples - (check-equal? (run '(if (zero? 0) 1 2)) 1) - (check-equal? (run '(if (zero? 1) 1 2)) 2) - (check-equal? (run '(if (zero? -7) 1 2)) 2) - (check-equal? (run '(if (zero? 0) - (if (zero? 1) 1 2) - 7)) - 2) - (check-equal? (run '(if (zero? (if (zero? 0) 1 0)) - (if (zero? 1) 1 2) - 7)) - 7) - - ;; Dupe examples - (check-equal? (run #t) #t) - (check-equal? (run #f) #f) - (check-equal? (run '(if #t 1 2)) 1) - (check-equal? (run '(if #f 1 2)) 2) - (check-equal? (run '(if 0 1 2)) 1) - (check-equal? (run '(if #t 3 4)) 3) - (check-equal? (run '(if #f 3 4)) 4) - (check-equal? (run '(if 0 3 4)) 3) - (check-equal? (run '(zero? 4)) #f) - (check-equal? (run '(zero? 0)) #t) - ;; Dodger examples - (check-equal? (run #\a) #\a) - (check-equal? (run #\b) #\b) - (check-equal? (run '(char? #\a)) #t) - (check-equal? (run '(char? #t)) #f) - (check-equal? (run '(char? 8)) #f) - (check-equal? (run '(char->integer #\a)) (char->integer #\a)) - (check-equal? (run '(integer->char 955)) #\λ) - ;; Extort examples - (check-equal? (run '(add1 #f)) 'err) - (check-equal? (run '(sub1 #f)) 'err) - (check-equal? (run '(zero? #f)) 'err) - (check-equal? (run '(char->integer #f)) 'err) - (check-equal? (run '(integer->char #f)) 'err) - (check-equal? (run '(integer->char -1)) 'err) - (check-equal? (run '(write-byte #f)) 'err) - (check-equal? (run '(write-byte -1)) 'err) - (check-equal? (run '(write-byte 256)) 'err) - ;; Fraud examples - (check-equal? (run '(let ((x 7)) x)) 7) - (check-equal? (run '(let ((x 7)) 2)) 2) - (check-equal? (run '(let ((x 7)) (add1 x))) 8) - (check-equal? (run '(let ((x (add1 7))) x)) 8) - (check-equal? (run '(let ((x 7)) (let ((y 2)) x))) 7) - (check-equal? (run '(let ((x 7)) (let ((x 2)) x))) 2) - (check-equal? (run '(let ((x 7)) (let ((x (add1 x))) x))) 8) - - (check-equal? (run '(let ((x 0)) - (if (zero? x) 7 8))) - 7) - (check-equal? (run '(let ((x 1)) - (add1 (if (zero? x) 7 8)))) - 9) - (check-equal? (run '(+ 3 4)) 7) - (check-equal? (run '(- 3 4)) -1) - (check-equal? (run '(+ (+ 2 1) 4)) 7) - (check-equal? (run '(+ (+ 2 1) (+ 2 2))) 7) - (check-equal? (run '(let ((x (+ 1 2))) - (let ((z (- 4 x))) - (+ (+ x x) z)))) - 7) - (check-equal? (run '(= 5 5)) #t) - (check-equal? (run '(= 4 5)) #f) - (check-equal? (run '(= (add1 4) 5)) #t) - (check-equal? (run '(< 5 5)) #f) - (check-equal? (run '(< 4 5)) #t) - (check-equal? (run '(< (add1 4) 5)) #f) - - ;; Hustle examples - (check-equal? (run ''()) '()) - (check-equal? (run '(box 1)) (box 1)) - (check-equal? (run '(box -1)) (box -1)) - (check-equal? (run '(cons 1 2)) (cons 1 2)) - (check-equal? (run '(unbox (box 1))) 1) - (check-equal? (run '(car (cons 1 2))) 1) - (check-equal? (run '(cdr (cons 1 2))) 2) - (check-equal? (run '(cons 1 '())) (list 1)) - (check-equal? (run '(let ((x (cons 1 2))) - (begin (cdr x) - (car x)))) - 1) - (check-equal? (run '(let ((x (cons 1 2))) - (let ((y (box 3))) - (unbox y)))) - 3) - (check-equal? (run '(eq? 1 1)) #t) - (check-equal? (run '(eq? 1 2)) #f) - (check-equal? (run '(eq? (cons 1 2) (cons 1 2))) #f) - (check-equal? (run '(let ((x (cons 1 2))) (eq? x x))) #t)) - -(define (test-runner-io run) - ;; Evildoer examples - (check-equal? (run 7 "") (cons 7 "")) - (check-equal? (run '(write-byte 97) "") (cons (void) "a")) - (check-equal? (run '(read-byte) "a") (cons 97 "")) - (check-equal? (run '(begin (write-byte 97) (read-byte)) "b") - (cons 98 "a")) - (check-equal? (run '(read-byte) "") (cons eof "")) - (check-equal? (run '(eof-object? (read-byte)) "") (cons #t "")) - (check-equal? (run '(eof-object? (read-byte)) "a") (cons #f "")) - (check-equal? (run '(begin (write-byte 97) (write-byte 98)) "") - (cons (void) "ab")) - - (check-equal? (run '(peek-byte) "ab") (cons 97 "")) - (check-equal? (run '(begin (peek-byte) (read-byte)) "ab") (cons 97 "")) - ;; Extort examples - (check-equal? (run '(write-byte #t) "") (cons 'err "")) - - ;; Fraud examples - (check-equal? (run '(let ((x 97)) (write-byte x)) "") (cons (void) "a")) - (check-equal? (run '(let ((x 97)) - (begin (write-byte x) - x)) - "") - (cons 97 "a")) - (check-equal? (run '(let ((x 97)) (begin (read-byte) x)) "b") - (cons 97 "")) - (check-equal? (run '(let ((x 97)) (begin (peek-byte) x)) "b") - (cons 97 "")) - - ;; Hustle examples - (check-equal? (run '(let ((x 1)) - (begin (write-byte 97) - 1)) - "") - (cons 1 "a")) - - (check-equal? (run '(let ((x 1)) - (let ((y 2)) - (begin (write-byte 97) - 1))) - "") - (cons 1 "a")) - - (check-equal? (run '(let ((x (cons 1 2))) - (begin (write-byte 97) - (car x))) - "") - (cons 1 "a"))) diff --git a/langs/hustle/types.rkt b/langs/hustle/types.rkt deleted file mode 100644 index c089329e..00000000 --- a/langs/hustle/types.rkt +++ /dev/null @@ -1,59 +0,0 @@ -#lang racket -(provide (all-defined-out)) - -(define imm-shift 3) -(define imm-mask #b111) -(define ptr-mask #b111) -(define type-box #b001) -(define type-cons #b010) -(define int-shift (+ 1 imm-shift)) -(define char-shift (+ 2 imm-shift)) -(define type-int #b0000) -(define mask-int #b1111) -(define type-char #b01000) -(define mask-char #b11111) -(define val-true #b0011000) -(define val-false #b0111000) -(define val-eof #b1011000) -(define val-void #b1111000) -(define val-empty #b10011000) - -(define (bits->value b) - (cond [(= type-int (bitwise-and b mask-int)) - (arithmetic-shift b (- int-shift))] - [(= type-char (bitwise-and b mask-char)) - (integer->char (arithmetic-shift b (- char-shift)))] - [(= b val-true) #t] - [(= b val-false) #f] - [(= b val-eof) eof] - [(= b val-void) (void)] - [(= b val-empty) '()] - [else (error "invalid bits")])) - -(define (value->bits v) - (cond [(eof-object? v) val-eof] - [(integer? v) (arithmetic-shift v int-shift)] - [(char? v) - (bitwise-ior type-char - (arithmetic-shift (char->integer v) char-shift))] - [(eq? v #t) val-true] - [(eq? v #f) val-false] - [(void? v) val-void] - [(empty? v) val-empty] - [else (error "not an immediate value" v)])) - - -(define (imm-bits? v) - (zero? (bitwise-and v imm-mask))) - -(define (int-bits? v) - (zero? (bitwise-and v mask-int))) - -(define (char-bits? v) - (= type-char (bitwise-and v mask-char))) - -(define (cons-bits? v) - (zero? (bitwise-xor (bitwise-and v imm-mask) type-cons))) - -(define (box-bits? v) - (zero? (bitwise-xor (bitwise-and v imm-mask) type-box))) diff --git a/langs/hustle/unload-bits-asm.rkt b/langs/hustle/unload-bits-asm.rkt deleted file mode 100644 index 85a55800..00000000 --- a/langs/hustle/unload-bits-asm.rkt +++ /dev/null @@ -1,28 +0,0 @@ -#lang racket -(provide unload/free unload-value) -(require "types.rkt" - ffi/unsafe) - -;; Answer* -> Answer -(define (unload/free a) - (match a - ['err 'err] - [(cons h v) (begin0 (unload-value v) - (free h))])) - -;; Value* -> Value -(define (unload-value v) - (match v - [(? imm-bits?) (bits->value v)] - [(? box-bits? i) - (box (unload-value (heap-ref i)))] - [(? cons-bits? i) - (cons (unload-value (heap-ref (+ i (arithmetic-shift 1 imm-shift)))) - (unload-value (heap-ref i)))])) - -(define (untag i) - (arithmetic-shift (arithmetic-shift i (- (integer-length ptr-mask))) - (integer-length ptr-mask))) - -(define (heap-ref i) - (ptr-ref (cast (untag i) _int64 _pointer) _int64)) diff --git a/langs/hustle/unload-bits.rkt b/langs/hustle/unload-bits.rkt index 3f850a07..21d084b6 100644 --- a/langs/hustle/unload-bits.rkt +++ b/langs/hustle/unload-bits.rkt @@ -1,6 +1,6 @@ #lang racket (provide unload unload-value) -(require "types.rkt" +(require (except-in "types.rkt" heap-ref) "heap-bits.rkt") ;; Answer* -> Answer diff --git a/langs/hustle/values.c b/langs/hustle/values.c index 3330f8d2..b96fffbf 100644 --- a/langs/hustle/values.c +++ b/langs/hustle/values.c @@ -38,6 +38,10 @@ val_t val_wrap_int(int64_t i) { return (i << int_shift) | int_type_tag; } +val_t val_wrap_byte(unsigned char b) +{ + return (b << int_shift) | int_type_tag; +} int val_unwrap_bool(val_t x) { diff --git a/langs/hustle/values.h b/langs/hustle/values.h index 92e67e5b..ceab2e0a 100644 --- a/langs/hustle/values.h +++ b/langs/hustle/values.h @@ -39,6 +39,7 @@ type_t val_typeof(val_t x); */ int64_t val_unwrap_int(val_t x); val_t val_wrap_int(int64_t i); +val_t val_wrap_byte(unsigned char b); int val_unwrap_bool(val_t x); val_t val_wrap_bool(int b); diff --git a/langs/info.rkt b/langs/info.rkt index 44a4c7de..2a677859 100644 --- a/langs/info.rkt +++ b/langs/info.rkt @@ -1,7 +1,9 @@ #lang info (define version "1.0") (define collection 'multi) -(define deps (list)) +(define deps (list "base" "rackunit" "redex-lib")) +(define build-deps + (list "https://github.com/cmsc430/www.git?path=ziggy#ziggy")) ;; 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 diff --git a/langs/iniquity-gc/Makefile b/langs/iniquity-gc/Makefile index 19272d02..47b2b108 100644 --- a/langs/iniquity-gc/Makefile +++ b/langs/iniquity-gc/Makefile @@ -33,7 +33,8 @@ runtime.o: $(objs) cat $< | racket -t compile-stdin.rkt -m > $@ clean: - rm *.o *.s *.run + @$(RM) *.o *.s *.run ||: + @echo "$(shell basename $(shell pwd)): cleaned!" %.test: %.run %.rkt @test "$(shell ./$(<))" = "$(shell racket $(word 2,$^))" diff --git a/langs/iniquity-gc/build-runtime.rkt b/langs/iniquity-gc/build-runtime.rkt index 5949f18f..66aad89f 100644 --- a/langs/iniquity-gc/build-runtime.rkt +++ b/langs/iniquity-gc/build-runtime.rkt @@ -1,12 +1,14 @@ #lang racket +(require racket/runtime-path) (provide runtime-path) -(require racket/runtime-path) (define-runtime-path here ".") -(system (string-append "make -C " - (path->string (normalize-path here)) - " runtime.o")) +(void + (system (string-append "make -C '" + (path->string (normalize-path here)) + "' runtime.o"))) (define runtime-path - (normalize-path (build-path here "runtime.o"))) \ No newline at end of file + (path->string + (normalize-path (build-path here "runtime.o")))) diff --git a/langs/iniquity-gc/compile-ops.rkt b/langs/iniquity-gc/compile-ops.rkt index 58efc1d1..265e559f 100644 --- a/langs/iniquity-gc/compile-ops.rkt +++ b/langs/iniquity-gc/compile-ops.rkt @@ -20,7 +20,7 @@ ;; Op0 -> Asm (define (compile-op0 p) (match p - ['void (seq (Mov rax val-void))] + ['void (seq (Mov rax (value->bits (void))))] ['read-byte (seq pad-stack (Call 'read_byte) unpad-stack)] @@ -34,7 +34,7 @@ pad-stack (Call 'print_memory) unpad-stack - (Mov rax val-void))] + (Mov rax (value->bits (void))))] ['collect-garbage (seq (Mov rdi rsp) (Mov rsi rbp) @@ -43,17 +43,17 @@ (Call 'collect_garbage) unpad-stack (Mov rbx rax) - (Mov rax val-void))])) + (Mov rax (value->bits (void))))])) ;; Op1 -> Asm (define (compile-op1 p) (match p ['add1 (seq (assert-integer rax) - (Add rax (imm->bits 1)))] + (Add rax (value->bits 1)))] ['sub1 (seq (assert-integer rax) - (Sub rax (imm->bits 1)))] + (Sub rax (value->bits 1)))] ['zero? (seq (assert-integer rax) (eq-imm 0))] @@ -74,8 +74,7 @@ pad-stack (Mov rdi rax) (Call 'write_byte) - unpad-stack - (Mov rax val-void))] + unpad-stack)] ['box (seq (Push rax) (allocate 1) @@ -161,20 +160,20 @@ (assert-integer r8) (assert-integer rax) (Cmp r8 rax) - (Mov rax val-true) + (Mov rax (value->bits #t)) (let ((true (gensym))) (seq (Jl true) - (Mov rax val-false) + (Mov rax (value->bits #f)) (Label true))))] ['= (seq (Pop r8) (assert-integer r8) (assert-integer rax) (Cmp r8 rax) - (Mov rax val-true) + (Mov rax (value->bits #t)) (let ((true (gensym))) (seq (Je true) - (Mov rax val-false) + (Mov rax (value->bits #f)) (Label true))))] ;; tricky: if you have a pointer in a register, GC might collect ;; what it points to and create a dangling reference @@ -317,7 +316,7 @@ (assert-box r8) (Xor r8 type-box) (Mov (Offset r8 0) rax) - (Mov rax val-void))])) + (Mov rax (value->bits (void))))])) ;; Op3 -> Asm (define (compile-op3 p) @@ -338,7 +337,7 @@ (Sal r10 3) (Add r8 r10) (Mov (Offset r8 8) rax) - (Mov rax val-void))])) + (Mov rax (value->bits (void))))])) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -354,9 +353,9 @@ (let ((l (gensym))) (seq (And rax mask) (Cmp rax type) - (Mov rax (imm->bits #t)) + (Mov rax (value->bits #t)) (Je l) - (Mov rax (imm->bits #f)) + (Mov rax (value->bits #f)) (Label l)))) (define assert-integer @@ -375,44 +374,44 @@ (define (assert-codepoint r) (let ((ok (gensym))) (seq (assert-integer r) - (Cmp r (imm->bits 0)) + (Cmp r (value->bits 0)) (Jl 'raise_error_align) - (Cmp r (imm->bits 1114111)) + (Cmp r (value->bits 1114111)) (Jg 'raise_error_align) - (Cmp r (imm->bits 55295)) + (Cmp r (value->bits 55295)) (Jl ok) - (Cmp r (imm->bits 57344)) + (Cmp r (value->bits 57344)) (Jg ok) (Jmp 'raise_error_align) (Label ok)))) (define (assert-byte r) (seq (assert-integer r) - (Cmp r (imm->bits 0)) + (Cmp r (value->bits 0)) (Jl 'raise_error_align) - (Cmp r (imm->bits 255)) + (Cmp r (value->bits 255)) (Jg 'raise_error_align))) (define (assert-natural r) (seq (assert-integer r) - (Cmp r (imm->bits 0)) + (Cmp r (value->bits 0)) (Jl 'raise_error_align))) ;; Value -> Asm (define (eq-imm imm) (let ((l1 (gensym))) - (seq (Cmp rax (imm->bits imm)) - (Mov rax val-true) + (seq (Cmp rax (value->bits imm)) + (Mov rax (value->bits #t)) (Je l1) - (Mov rax val-false) + (Mov rax (value->bits #f)) (Label l1)))) (define (eq ir1 ir2) (let ((l1 (gensym))) (seq (Cmp ir1 ir2) - (Mov rax val-true) + (Mov rax (value->bits #t)) (Je l1) - (Mov rax val-false) + (Mov rax (value->bits #f)) (Label l1)))) ;; Asm diff --git a/langs/iniquity-gc/compile.rkt b/langs/iniquity-gc/compile.rkt index 850d3e77..258e5a6f 100644 --- a/langs/iniquity-gc/compile.rkt +++ b/langs/iniquity-gc/compile.rkt @@ -77,7 +77,7 @@ ;; Value -> Asm (define (compile-value v) - (seq (Mov rax (imm->bits v)))) + (seq (Mov rax (value->bits v)))) ;; Id CEnv -> Asm (define (compile-variable x c) @@ -137,7 +137,7 @@ (let ((l1 (gensym 'if)) (l2 (gensym 'if))) (seq (compile-e e1 c) - (Cmp rax val-false) + (Cmp rax (value->bits #f)) (Je l1) (compile-e e2 c) (Jmp l2) diff --git a/langs/iniquity-gc/run.rkt b/langs/iniquity-gc/run.rkt new file mode 100644 index 00000000..eaa53eb9 --- /dev/null +++ b/langs/iniquity-gc/run.rkt @@ -0,0 +1,18 @@ +#lang racket +(provide run run/io) +(require "types.rkt" "build-runtime.rkt" + a86/interp) + +;; Asm -> Answer +(define (run is) + (parameterize ((current-objs (list runtime-path))) + (match (asm-interp is) + ['err 'err] + [b (bits->value b)]))) + +;; Asm String -> (cons Answer String) +(define (run/io is s) + (parameterize ((current-objs (list runtime-path))) + (match (asm-interp/io is s) + [(cons 'err o) (cons 'err o)] + [(cons b o) (cons (bits->value b) o)]))) diff --git a/langs/iniquity-gc/test/compile.rkt b/langs/iniquity-gc/test/compile.rkt index 81defae6..9a9d707f 100644 --- a/langs/iniquity-gc/test/compile.rkt +++ b/langs/iniquity-gc/test/compile.rkt @@ -2,17 +2,7 @@ (require "test-runner.rkt" "../parse.rkt" "../compile.rkt" - "../unload-bits-asm.rkt" - a86/interp) + "../run.rkt") -;; link with runtime for IO operations -(unless (file-exists? "../runtime.o") - (system "make -C .. runtime.o")) -(current-objs - (list (path->string (normalize-path "../runtime.o")))) - -(test-runner (λ p (unload/free (asm-interp (compile (parse p)))))) -(test-runner-io (λ (s . p) - (match (asm-interp/io (compile (parse p)) s) - ['err 'err] - [(cons r o) (cons (unload/free r) o)]))) +(test-runner (λ p (run (compile (parse p))))) +;(test-runner-io (λ (s . p) (run/io (compile (parse p)) s))) diff --git a/langs/iniquity-gc/types.rkt b/langs/iniquity-gc/types.rkt index 806fd02e..9dbc9d59 100644 --- a/langs/iniquity-gc/types.rkt +++ b/langs/iniquity-gc/types.rkt @@ -1,5 +1,6 @@ #lang racket (provide (all-defined-out)) +(require ffi/unsafe) (define imm-shift 3) (define imm-mask #b111) @@ -14,53 +15,76 @@ (define mask-int #b1111) (define type-char #b01000) (define mask-char #b11111) -(define val-true #b0011000) -(define val-false #b0111000) -(define val-eof #b1011000) -(define val-void #b1111000) -(define val-empty #b10011000) (define (bits->value b) - (cond [(= type-int (bitwise-and b mask-int)) + (cond [(= b (value->bits #t)) #t] + [(= b (value->bits #f)) #f] + [(= b (value->bits eof)) eof] + [(= b (value->bits (void))) (void)] + [(= b (value->bits '())) '()] + [(int-bits? b) (arithmetic-shift b (- int-shift))] - [(= type-char (bitwise-and b mask-char)) + [(char-bits? b) (integer->char (arithmetic-shift b (- char-shift)))] - [(= b val-true) #t] - [(= b val-false) #f] - [(= b val-eof) eof] - [(= b val-void) (void)] - [(= b val-empty) '()] + [(box-bits? b) + (box (bits->value (heap-ref b)))] + [(cons-bits? b) + (cons (bits->value (heap-ref (+ b 8))) + (bits->value (heap-ref b)))] + [(vect-bits? b) + (if (zero? (untag b)) + (vector) + (build-vector (heap-ref b) + (lambda (j) + (bits->value (heap-ref (+ b (* 8 (add1 j))))))))] + [(str-bits? b) + (if (zero? (untag b)) + (string) + (build-string (heap-ref b) + (lambda (j) + (char-ref (+ b 8) j))))] [else (error "invalid bits")])) -(define (imm->bits v) - (cond [(eof-object? v) val-eof] - [(integer? v) (arithmetic-shift v int-shift)] +(define (value->bits v) + (cond [(eq? v #t) #b00011000] + [(eq? v #f) #b00111000] + [(eof-object? v) #b01011000] + [(void? v) #b01111000] + [(empty? v) #b10011000] + [(integer? v) + (arithmetic-shift v int-shift)] [(char? v) (bitwise-ior type-char (arithmetic-shift (char->integer v) char-shift))] - [(eq? v #t) val-true] - [(eq? v #f) val-false] - [(void? v) val-void] - [(empty? v) val-empty])) - + [else (error "not an immediate value")])) (define (imm-bits? v) (zero? (bitwise-and v imm-mask))) (define (int-bits? v) - (zero? (bitwise-and v mask-int))) + (= type-int (bitwise-and v mask-int))) (define (char-bits? v) (= type-char (bitwise-and v mask-char))) (define (cons-bits? v) - (zero? (bitwise-xor (bitwise-and v imm-mask) type-cons))) + (= type-cons (bitwise-and v imm-mask))) (define (box-bits? v) - (zero? (bitwise-xor (bitwise-and v imm-mask) type-box))) + (= type-box (bitwise-and v imm-mask))) (define (vect-bits? v) - (zero? (bitwise-xor (bitwise-and v imm-mask) type-vect))) + (= type-vect (bitwise-and v imm-mask))) (define (str-bits? v) - (zero? (bitwise-xor (bitwise-and v imm-mask) type-str))) + (= type-str (bitwise-and v imm-mask))) + +(define (untag i) + (arithmetic-shift (arithmetic-shift i (- (integer-length ptr-mask))) + (integer-length ptr-mask))) + +(define (heap-ref i) + (ptr-ref (cast (untag i) _int64 _pointer) _int64)) + +(define (char-ref i j) + (integer->char (ptr-ref (cast (untag i) _int64 _pointer) _uint32 j))) diff --git a/langs/iniquity-gc/unload-bits-asm.rkt b/langs/iniquity-gc/unload-bits-asm.rkt deleted file mode 100644 index be9b50c8..00000000 --- a/langs/iniquity-gc/unload-bits-asm.rkt +++ /dev/null @@ -1,43 +0,0 @@ -#lang racket -(provide unload/free unload-value) -(require "types.rkt" - ffi/unsafe) - -;; Answer* -> Answer -(define (unload/free a) - (match a - ['err 'err] - [(cons h v) (begin0 (unload-value v) - (free h))])) - -;; Value* -> Value -(define (unload-value v) - (match v - [(? imm-bits?) (bits->value v)] - [(? box-bits? i) - (box (unload-value (heap-ref i)))] - [(? cons-bits? i) - (cons (unload-value (heap-ref (+ i 8))) - (unload-value (heap-ref i)))] - [(? vect-bits? i) - (if (zero? (untag i)) - (vector) - (build-vector (heap-ref i) - (lambda (j) - (unload-value (heap-ref (+ i (* 8 (add1 j))))))))] - [(? str-bits? i) - (if (zero? (untag i)) - (string) - (build-string (heap-ref i) - (lambda (j) - (char-ref (+ i 8) j))))])) - -(define (untag i) - (arithmetic-shift (arithmetic-shift i (- (integer-length ptr-mask))) - (integer-length ptr-mask))) - -(define (heap-ref i) - (ptr-ref (cast (untag i) _int64 _pointer) _uint64)) - -(define (char-ref i j) - (integer->char (ptr-ref (cast (untag i) _int64 _pointer) _uint32 j))) diff --git a/langs/iniquity/Makefile b/langs/iniquity/Makefile index 9055c88f..db6ac44a 100644 --- a/langs/iniquity/Makefile +++ b/langs/iniquity/Makefile @@ -37,7 +37,8 @@ runtime.o: $(objs) cat $< | racket -t compile-stdin.rkt -m > $@ clean: - rm *.o *.s *.run + @$(RM) *.o *.s *.run ||: + @echo "$(shell basename $(shell pwd)): cleaned!" %.test: %.run %.rkt @test "$(shell ./$(<))" = "$(shell racket $(word 2,$^))" diff --git a/langs/iniquity/ast.rkt b/langs/iniquity/ast.rkt deleted file mode 100644 index 29e4e06d..00000000 --- a/langs/iniquity/ast.rkt +++ /dev/null @@ -1,53 +0,0 @@ -#lang racket -(provide (all-defined-out)) - -;; type Prog = (Prog (Listof Defn) Expr) -(struct Prog (ds e) #:prefab) - -;; type Defn = (Defn Id (Listof Id) Expr) -(struct Defn (f xs e) #:prefab) - -;; type Expr = (Eof) -;; | (Empty) -;; | (Int Integer) -;; | (Bool Boolean) -;; | (Char Character) -;; | (Str String) -;; | (Prim0 Op0) -;; | (Prim1 Op1 Expr) -;; | (Prim2 Op2 Expr Expr) -;; | (Prim3 Op3 Expr Expr Expr) -;; | (If Expr Expr Expr) -;; | (Begin Expr Expr) -;; | (Let Id Expr Expr) -;; | (Var Id) -;; | (App Id (Listof Expr)) -;; type Id = Symbol -;; type Op0 = 'read-byte -;; type Op1 = 'add1 | 'sub1 | 'zero? -;; | 'char? | 'integer->char | 'char->integer -;; | 'write-byte | 'eof-object? -;; | 'box | 'car | 'cdr | 'unbox -;; | 'empty? | 'cons? | 'box? -;; | 'vector? | vector-length -;; | 'string? | string-length -;; type Op2 = '+ | '- | '< | '= -;; | 'cons -;; | 'make-vector | 'vector-ref -;; | 'make-string | 'string-ref -;; type Op3 = 'vector-set! -(struct Eof () #:prefab) -(struct Empty () #:prefab) -(struct Int (i) #:prefab) -(struct Bool (b) #:prefab) -(struct Char (c) #:prefab) -(struct Str (s) #:prefab) -(struct Prim0 (p) #:prefab) -(struct Prim1 (p e) #:prefab) -(struct Prim2 (p e1 e2) #:prefab) -(struct Prim3 (p e1 e2 e3) #:prefab) -(struct If (e1 e2 e3) #:prefab) -(struct Begin (e1 e2) #:prefab) -(struct Let (x e1 e2) #:prefab) -(struct Var (x) #:prefab) -(struct App (f es) #:prefab) diff --git a/langs/iniquity/build-runtime.rkt b/langs/iniquity/build-runtime.rkt deleted file mode 100644 index 1cc4da53..00000000 --- a/langs/iniquity/build-runtime.rkt +++ /dev/null @@ -1,12 +0,0 @@ -#lang racket -(provide runtime-path) - -(require racket/runtime-path) -(define-runtime-path here ".") - -(system (string-append "make -C '" - (path->string (normalize-path here)) - "' runtime.o")) - -(define runtime-path - (normalize-path (build-path here "runtime.o"))) \ No newline at end of file diff --git a/langs/iniquity/compile-ops.rkt b/langs/iniquity/compile-ops.rkt deleted file mode 100644 index 03b21812..00000000 --- a/langs/iniquity/compile-ops.rkt +++ /dev/null @@ -1,355 +0,0 @@ -#lang racket -(provide (all-defined-out)) -(require "ast.rkt" "types.rkt" a86/ast) - -(define rax 'rax) ; return -(define eax 'eax) ; 32-bit load/store -(define rbx 'rbx) ; heap -(define rdi 'rdi) ; arg -(define r8 'r8) ; scratch -(define r9 'r9) ; scratch -(define r10 'r10) ; scratch -(define r15 'r15) ; stack pad (non-volatile) -(define rsp 'rsp) ; stack - -;; Op0 -> Asm -(define (compile-op0 p) - (match p - ['void (seq (Mov rax (value->bits (void))))] - ['read-byte (seq pad-stack - (Call 'read_byte) - unpad-stack)] - ['peek-byte (seq pad-stack - (Call 'peek_byte) - unpad-stack)])) - -;; Op1 -> Asm -(define (compile-op1 p) - (match p - ['add1 - (seq (assert-integer rax) - (Add rax (value->bits 1)))] - ['sub1 - (seq (assert-integer rax) - (Sub rax (value->bits 1)))] - ['zero? - (seq (assert-integer rax) - (eq-value 0))] - ['char? - (type-pred mask-char type-char)] - ['char->integer - (seq (assert-char rax) - (Sar rax char-shift) - (Sal rax int-shift))] - ['integer->char - (seq (assert-codepoint rax) - (Sar rax int-shift) - (Sal rax char-shift) - (Xor rax type-char))] - ['eof-object? (eq-value eof)] - ['write-byte - (seq (assert-byte rax) - pad-stack - (Mov rdi rax) - (Call 'write_byte) - unpad-stack)] - ['box - (seq (Mov (Offset rbx 0) rax) - (Mov rax rbx) - (Or rax type-box) - (Add rbx 8))] - ['unbox - (seq (assert-box rax) - (Xor rax type-box) - (Mov rax (Offset rax 0)))] - ['car - (seq (assert-cons rax) - (Xor rax type-cons) - (Mov rax (Offset rax 8)))] - ['cdr - (seq (assert-cons rax) - (Xor rax type-cons) - (Mov rax (Offset rax 0)))] - ['empty? (eq-value '())] - ['box? - (type-pred ptr-mask type-box)] - ['cons? - (type-pred ptr-mask type-cons)] - ['vector? - (type-pred ptr-mask type-vect)] - ['string? - (type-pred ptr-mask type-str)] - ['vector-length - (let ((zero (gensym)) - (done (gensym))) - (seq (assert-vector rax) - (Xor rax type-vect) - (Cmp rax 0) - (Je zero) - (Mov rax (Offset rax 0)) - (Sal rax int-shift) - (Jmp done) - (Label zero) - (Mov rax 0) - (Label done)))] - ['string-length - (let ((zero (gensym)) - (done (gensym))) - (seq (assert-string rax) - (Xor rax type-str) - (Cmp rax 0) - (Je zero) - (Mov rax (Offset rax 0)) - (Sal rax int-shift) - (Jmp done) - (Label zero) - (Mov rax 0) - (Label done)))])) - -;; Op2 -> Asm -(define (compile-op2 p) - (match p - ['+ - (seq (Pop r8) - (assert-integer r8) - (assert-integer rax) - (Add rax r8))] - ['- - (seq (Pop r8) - (assert-integer r8) - (assert-integer rax) - (Sub r8 rax) - (Mov rax r8))] - ['< - (seq (Pop r8) - (assert-integer r8) - (assert-integer rax) - (Cmp r8 rax) - (if-lt))] - ['= - (seq (Pop r8) - (assert-integer r8) - (assert-integer rax) - (Cmp r8 rax) - (if-equal))] - ['cons - (seq (Mov (Offset rbx 0) rax) - (Pop rax) - (Mov (Offset rbx 8) rax) - (Mov rax rbx) - (Or rax type-cons) - (Add rbx 16))] - ['eq? - (seq (Pop r8) - (Cmp rax r8) - (if-equal))] - ['make-vector - (let ((loop (gensym)) - (done (gensym)) - (empty (gensym))) - (seq (Pop r8) - (assert-natural r8) - (Cmp r8 0) ; special case empty vector - (Je empty) - - (Mov r9 rbx) - (Or r9 type-vect) - - (Sar r8 int-shift) - (Mov (Offset rbx 0) r8) - (Add rbx 8) - - (Label loop) - (Mov (Offset rbx 0) rax) - (Add rbx 8) - (Sub r8 1) - (Cmp r8 0) - (Jne loop) - - (Mov rax r9) - (Jmp done) - - (Label empty) - (Mov rax type-vect) - (Label done)))] - - ['vector-ref - (seq (Pop r8) - (assert-vector r8) - (assert-integer rax) - (Cmp r8 type-vect) - (Je 'raise_error_align) ; special case for empty vector - (Cmp rax 0) - (Jl 'raise_error_align) - (Xor r8 type-vect) ; r8 = ptr - (Mov r9 (Offset r8 0)) ; r9 = len - (Sar rax int-shift) ; rax = index - (Sub r9 1) - (Cmp r9 rax) - (Jl 'raise_error_align) - (Sal rax 3) - (Add r8 rax) - (Mov rax (Offset r8 8)))] - - ['make-string - (let ((loop (gensym)) - (done (gensym)) - (empty (gensym))) - (seq (Pop r8) - (assert-natural r8) - (assert-char rax) - (Cmp r8 0) ; special case empty string - (Je empty) - - (Mov r9 rbx) - (Or r9 type-str) - - (Sar r8 int-shift) - (Mov (Offset rbx 0) r8) - (Add rbx 8) - - (Sar rax char-shift) - - (Add r8 1) ; adds 1 - (Sar r8 1) ; when - (Sal r8 1) ; len is odd - - (Label loop) - (Mov (Offset rbx 0) eax) - (Add rbx 4) - (Sub r8 1) - (Cmp r8 0) - (Jne loop) - - (Mov rax r9) - (Jmp done) - - (Label empty) - (Mov rax type-str) - (Label done)))] - - ['string-ref - (seq (Pop r8) - (assert-string r8) - (assert-integer rax) - (Cmp r8 type-str) - (Je 'raise_error_align) ; special case for empty string - (Cmp rax 0) - (Jl 'raise_error_align) - (Xor r8 type-str) ; r8 = ptr - (Mov r9 (Offset r8 0)) ; r9 = len - (Sar rax int-shift) ; rax = index - (Sub r9 1) - (Cmp r9 rax) - (Jl 'raise_error_align) - (Sal rax 2) - (Add r8 rax) - (Mov 'eax (Offset r8 8)) - (Sal rax char-shift) - (Or rax type-char))])) - -;; Op3 -> Asm -(define (compile-op3 p) - (match p - ['vector-set! - (seq (Pop r10) - (Pop r8) - (assert-vector r8) - (assert-integer r10) - (Cmp r10 0) - (Jl 'raise_error_align) - (Xor r8 type-vect) ; r8 = ptr - (Mov r9 (Offset r8 0)) ; r9 = len - (Sar r10 int-shift) ; r10 = index - (Sub r9 1) - (Cmp r9 r10) - (Jl 'raise_error_align) - (Sal r10 3) - (Add r8 r10) - (Mov (Offset r8 8) rax) - (Mov rax (value->bits (void))))])) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define (assert-type mask type) - (λ (arg) - (seq (Mov r9 arg) - (And r9 mask) - (Cmp r9 type) - (Jne 'raise_error_align)))) - -(define (type-pred mask type) - (let ((l (gensym))) - (seq (And rax mask) - (Cmp rax type) - (Mov rax (value->bits #t)) - (Je l) - (Mov rax (value->bits #f)) - (Label l)))) - -(define assert-integer - (assert-type mask-int type-int)) -(define assert-char - (assert-type mask-char type-char)) -(define assert-box - (assert-type ptr-mask type-box)) -(define assert-cons - (assert-type ptr-mask type-cons)) -(define assert-vector - (assert-type ptr-mask type-vect)) -(define assert-string - (assert-type ptr-mask type-str)) - -(define (assert-codepoint r) - (let ((ok (gensym))) - (seq (assert-integer r) - (Cmp r (value->bits 0)) - (Jl 'raise_error_align) - (Cmp r (value->bits 1114111)) - (Jg 'raise_error_align) - (Cmp r (value->bits 55295)) - (Jl ok) - (Cmp r (value->bits 57344)) - (Jg ok) - (Jmp 'raise_error_align) - (Label ok)))) - -(define (assert-byte r) - (seq (assert-integer r) - (Cmp r (value->bits 0)) - (Jl 'raise_error_align) - (Cmp r (value->bits 255)) - (Jg 'raise_error_align))) - -(define (assert-natural r) - (seq (assert-integer r) - (Cmp r (value->bits 0)) - (Jl 'raise_error_align))) - -;; -> Asm -;; set rax to #t or #f based on given comparison -(define (if-compare c) - (seq (Mov rax (value->bits #f)) - (Mov r9 (value->bits #t)) - (c rax r9))) - -(define (if-equal) (if-compare Cmove)) -(define (if-lt) (if-compare Cmovl)) - -;; Value -> Asm -(define (eq-value v) - (seq (Cmp rax (value->bits v)) - (if-equal))) - -;; Asm -;; Dynamically pad the stack to be aligned for a call -(define pad-stack - (seq (Mov r15 rsp) - (And r15 #b1000) - (Sub rsp r15))) - -;; Asm -;; Undo the stack alignment after a call -(define unpad-stack - (seq (Add rsp r15))) diff --git a/langs/iniquity/compile-stdin.rkt b/langs/iniquity/compile-stdin.rkt deleted file mode 100644 index cfa15106..00000000 --- a/langs/iniquity/compile-stdin.rkt +++ /dev/null @@ -1,10 +0,0 @@ -#lang racket -(provide main) -(require "parse.rkt" "compile.rkt" "read-all.rkt" a86/printer) - -;; -> Void -;; Compile contents of stdin, -;; emit asm code on stdout -(define (main) - (read-line) ; ignore #lang racket line - (asm-display (compile (parse (read-all))))) diff --git a/langs/iniquity/compile.rkt b/langs/iniquity/compile.rkt deleted file mode 100644 index cc750722..00000000 --- a/langs/iniquity/compile.rkt +++ /dev/null @@ -1,201 +0,0 @@ -#lang racket -(provide (all-defined-out)) -(require "ast.rkt" "types.rkt" "compile-ops.rkt" a86/ast) - -;; Registers used -(define rax 'rax) ; return -(define rbx 'rbx) ; heap -(define rsp 'rsp) ; stack -(define rdi 'rdi) ; arg -(define r15 'r15) ; stack pad (non-volatile) - -;; type CEnv = (Listof [Maybe Id]) - -;; Prog -> Asm -(define (compile p) - (match p - [(Prog ds e) - (prog (externs) - (Global 'entry) - (Label 'entry) - (Push rbx) ; save callee-saved register - (Push r15) - (Mov rbx rdi) ; recv heap pointer - (compile-e e '()) - (Pop r15) ; restore callee-save register - (Pop rbx) - (Ret) - (compile-defines ds) - (Label 'raise_error_align) - pad-stack - (Call 'raise_error))])) - -(define (externs) - (seq (Extern 'peek_byte) - (Extern 'read_byte) - (Extern 'write_byte) - (Extern 'raise_error))) - -;; [Listof Defn] -> Asm -(define (compile-defines ds) - (match ds - ['() (seq)] - [(cons d ds) - (seq (compile-define d) - (compile-defines ds))])) - -;; Defn -> Asm -(define (compile-define d) - (match d - [(Defn f xs e) - (seq (Label (symbol->label f)) - (compile-e e (reverse xs)) - (Add rsp (* 8 (length xs))) ; pop args - (Ret))])) - -;; Expr CEnv -> Asm -(define (compile-e e c) - (match e - [(Int i) (compile-value i)] - [(Bool b) (compile-value b)] - [(Char c) (compile-value c)] - [(Eof) (compile-value eof)] - [(Empty) (compile-value '())] - [(Var x) (compile-variable x c)] - [(Str s) (compile-string s)] - [(Prim0 p) (compile-prim0 p c)] - [(Prim1 p e) (compile-prim1 p e c)] - [(Prim2 p e1 e2) (compile-prim2 p e1 e2 c)] - [(Prim3 p e1 e2 e3) (compile-prim3 p e1 e2 e3 c)] - [(If e1 e2 e3) (compile-if e1 e2 e3 c)] - [(Begin e1 e2) (compile-begin e1 e2 c)] - [(Let x e1 e2) (compile-let x e1 e2 c)] - [(App f es) (compile-app f es c)])) - -;; Value -> Asm -(define (compile-value v) - (seq (Mov rax (value->bits v)))) - -;; Id CEnv -> Asm -(define (compile-variable x c) - (let ((i (lookup x c))) - (seq (Mov rax (Offset rsp i))))) - -;; String -> Asm -(define (compile-string s) - (let ((len (string-length s))) - (if (zero? len) - (seq (Mov rax type-str)) - (seq (Mov rax len) - (Mov (Offset rbx 0) rax) - (compile-string-chars (string->list s) 8) - (Mov rax rbx) - (Or rax type-str) - (Add rbx - (+ 8 (* 4 (if (odd? len) (add1 len) len)))))))) - -;; [Listof Char] Integer -> Asm -(define (compile-string-chars cs i) - (match cs - ['() (seq)] - [(cons c cs) - (seq (Mov rax (char->integer c)) - (Mov (Offset rbx i) 'eax) - (compile-string-chars cs (+ 4 i)))])) - -;; Op0 CEnv -> Asm -(define (compile-prim0 p c) - (compile-op0 p)) - -;; Op1 Expr CEnv -> Asm -(define (compile-prim1 p e c) - (seq (compile-e e c) - (compile-op1 p))) - -;; Op2 Expr Expr CEnv -> Asm -(define (compile-prim2 p e1 e2 c) - (seq (compile-e e1 c) - (Push rax) - (compile-e e2 (cons #f c)) - (compile-op2 p))) - -;; Op3 Expr Expr Expr CEnv -> Asm -(define (compile-prim3 p e1 e2 e3 c) - (seq (compile-e e1 c) - (Push rax) - (compile-e e2 (cons #f c)) - (Push rax) - (compile-e e3 (cons #f (cons #f c))) - (compile-op3 p))) - -;; Expr Expr Expr CEnv -> Asm -(define (compile-if e1 e2 e3 c) - (let ((l1 (gensym 'if)) - (l2 (gensym 'if))) - (seq (compile-e e1 c) - (Cmp rax (value->bits #f)) - (Je l1) - (compile-e e2 c) - (Jmp l2) - (Label l1) - (compile-e e3 c) - (Label l2)))) - -;; Expr Expr CEnv -> Asm -(define (compile-begin e1 e2 c) - (seq (compile-e e1 c) - (compile-e e2 c))) - -;; Id Expr Expr CEnv -> Asm -(define (compile-let x e1 e2 c) - (seq (compile-e e1 c) - (Push rax) - (compile-e e2 (cons x c)) - (Add rsp 8))) - -;; Id [Listof Expr] CEnv -> Asm -;; The return address is placed above the arguments, so callee pops -;; arguments and return address is next frame -(define (compile-app f es c) - (let ((r (gensym 'ret))) - (seq (Lea rax r) - (Push rax) - (compile-es es (cons #f c)) - (Jmp (symbol->label f)) - (Label r)))) - -;; [Listof Expr] CEnv -> Asm -(define (compile-es es c) - (match es - ['() '()] - [(cons e es) - (seq (compile-e e c) - (Push rax) - (compile-es es (cons #f c)))])) - -;; Id CEnv -> Integer -(define (lookup x cenv) - (match cenv - ['() (error "undefined variable:" x)] - [(cons y rest) - (match (eq? x y) - [#t 0] - [#f (+ 8 (lookup x rest))])])) - -;; Symbol -> Label -;; Produce a symbol that is a valid Nasm 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/langs/iniquity/info.rkt b/langs/iniquity/info.rkt new file mode 100644 index 00000000..41ec40bb --- /dev/null +++ b/langs/iniquity/info.rkt @@ -0,0 +1,2 @@ +#lang info +(define pre-install-collection "../installer.rkt") diff --git a/langs/iniquity/interp-io.rkt b/langs/iniquity/interp-io.rkt deleted file mode 100644 index 93f7d3c6..00000000 --- a/langs/iniquity/interp-io.rkt +++ /dev/null @@ -1,12 +0,0 @@ -#lang racket -(provide interp/io) -(require "interp.rkt") - -;; (Expr String -> String -;; Interpret e with given string as input, -;; collect output as string (including printed result) -(define (interp/io e in) - (parameterize ((current-output-port (open-output-string)) - (current-input-port (open-input-string in))) - (cons (interp e) - (get-output-string (current-output-port))))) diff --git a/langs/iniquity/interp-stdin.rkt b/langs/iniquity/interp-stdin.rkt deleted file mode 100644 index 965b9cc4..00000000 --- a/langs/iniquity/interp-stdin.rkt +++ /dev/null @@ -1,12 +0,0 @@ -#lang racket -(provide main) -(require "parse.rkt" "interp.rkt" "read-all.rkt") - -;; -> Void -;; Parse and interpret contents of stdin, -;; print result on stdout -(define (main) - (read-line) ; ignore #lang racket line - (let ((r (interp (parse (read-all))))) - (unless (void? r) - (println r)))) diff --git a/langs/iniquity/interp.rkt b/langs/iniquity/interp.rkt deleted file mode 100644 index 55d77c81..00000000 --- a/langs/iniquity/interp.rkt +++ /dev/null @@ -1,108 +0,0 @@ -#lang racket -(provide interp interp-env) -(require "ast.rkt" - "env.rkt" - "interp-prims.rkt") - -;; type Answer = Value | 'err - -;; type Value = -;; | Integer -;; | Boolean -;; | Character -;; | Eof -;; | Void -;; | '() -;; | (cons Value Value) -;; | (box Value) -;; | (vector Value ...) -;; | (string Char ...) - -;; type REnv = (Listof (List Id Value)) -;; type Defns = (Listof Defn) - -;; Prog -> Answer -(define (interp p) - (match p - [(Prog ds e) - (interp-env e '() ds)])) - -;; Expr Env Defns -> Answer -(define (interp-env e r ds) - (match e - [(Int i) i] - [(Bool b) b] - [(Char c) c] - [(Eof) eof] - [(Empty) '()] - [(Var x) (lookup r x)] - [(Str s) s] - [(Prim0 'void) (void)] - [(Prim0 'read-byte) (read-byte)] - [(Prim0 'peek-byte) (peek-byte)] - [(Prim1 p e) - (match (interp-env e r ds) - ['err 'err] - [v (interp-prim1 p v)])] - [(Prim2 p e1 e2) - (match (interp-env e1 r ds) - ['err 'err] - [v1 (match (interp-env e2 r ds) - ['err 'err] - [v2 (interp-prim2 p v1 v2)])])] - [(Prim3 p e1 e2 e3) - (match (interp-env e1 r ds) - ['err 'err] - [v1 (match (interp-env e2 r ds) - ['err 'err] - [v2 (match (interp-env e3 r ds) - ['err 'err] - [v3 (interp-prim3 p v1 v2 v3)])])])] - [(If p e1 e2) - (match (interp-env p r ds) - ['err 'err] - [v - (if v - (interp-env e1 r ds) - (interp-env e2 r ds))])] - [(Begin e1 e2) - (match (interp-env e1 r ds) - ['err 'err] - [_ (interp-env e2 r ds)])] - [(Let x e1 e2) - (match (interp-env e1 r ds) - ['err 'err] - [v (interp-env e2 (ext r x v) ds)])] - [(App f es) - (match (interp-env* es r ds) - ['err 'err] - [vs - (match (defns-lookup ds f) - [(Defn f xs e) - ; check arity matches - (if (= (length xs) (length vs)) - (interp-env e (zip xs vs) ds) - 'err)])])])) - -;; (Listof Expr) REnv Defns -> (Listof Value) | 'err -(define (interp-env* es r ds) - (match es - ['() '()] - [(cons e es) - (match (interp-env e r ds) - ['err 'err] - [v (match (interp-env* es r ds) - ['err 'err] - [vs (cons v vs)])])])) - -;; Defns Symbol -> Defn -(define (defns-lookup ds f) - (findf (match-lambda [(Defn g _ _) (eq? f g)]) - ds)) - -(define (zip xs ys) - (match* (xs ys) - [('() '()) '()] - [((cons x xs) (cons y ys)) - (cons (list x y) - (zip xs ys))])) diff --git a/langs/iniquity/io.c b/langs/iniquity/io.c index 7ef82281..8a417c91 100644 --- a/langs/iniquity/io.c +++ b/langs/iniquity/io.c @@ -7,14 +7,14 @@ val_t read_byte(void) { char c = getc(in); - return (c == EOF) ? val_wrap_eof() : val_wrap_int(c); + return (c == EOF) ? val_wrap_eof() : val_wrap_byte(c); } val_t peek_byte(void) { char c = getc(in); ungetc(c, in); - return (c == EOF) ? val_wrap_eof() : val_wrap_int(c); + return (c == EOF) ? val_wrap_eof() : val_wrap_byte(c); } diff --git a/langs/iniquity/parse.rkt b/langs/iniquity/parse.rkt deleted file mode 100644 index 8814af60..00000000 --- a/langs/iniquity/parse.rkt +++ /dev/null @@ -1,65 +0,0 @@ -#lang racket -(provide parse parse-define parse-e) -(require "ast.rkt") - -;; [Listof S-Expr] -> Prog -(define (parse s) - (match s - [(cons (and (cons 'define _) d) s) - (match (parse s) - [(Prog ds e) - (Prog (cons (parse-define d) ds) e)])] - [(cons e '()) (Prog '() (parse-e e))] - [_ (error "program parse error")])) - -;; S-Expr -> Defn -(define (parse-define s) - (match s - [(list 'define (list-rest (? symbol? f) xs) e) - (if (andmap symbol? xs) - (Defn f xs (parse-e e)) - (error "parse definition error"))] - [_ (error "Parse defn error" s)])) - -;; S-Expr -> Expr -(define (parse-e s) - (match s - [(? exact-integer?) (Int s)] - [(? boolean?) (Bool s)] - [(? char?) (Char s)] - [(? string?) (Str s)] - ['eof (Eof)] - [(? symbol?) (Var s)] - [(list 'quote (list)) (Empty)] - [(list (? (op? op0) p0)) (Prim0 p0)] - [(list (? (op? op1) p1) e) (Prim1 p1 (parse-e e))] - [(list (? (op? op2) p2) e1 e2) (Prim2 p2 (parse-e e1) (parse-e e2))] - [(list (? (op? op3) p3) e1 e2 e3) - (Prim3 p3 (parse-e e1) (parse-e e2) (parse-e e3))] - [(list 'begin e1 e2) - (Begin (parse-e e1) (parse-e e2))] - [(list 'if e1 e2 e3) - (If (parse-e e1) (parse-e e2) (parse-e e3))] - [(list 'let (list (list (? symbol? x) e1)) e2) - (Let x (parse-e e1) (parse-e e2))] - [(cons (? symbol? f) es) - (App f (map parse-e es))] - [_ (error "Parse error" s)])) - -(define op0 - '(read-byte peek-byte void)) - -(define op1 - '(add1 sub1 zero? char? write-byte eof-object? - integer->char char->integer - box unbox empty? cons? box? car cdr - vector? vector-length string? string-length)) -(define op2 - '(+ - < = cons eq? make-vector vector-ref make-string string-ref)) -(define op3 - '(vector-set!)) - -(define (op? ops) - (λ (x) - (and (symbol? x) - (memq x ops)))) diff --git a/langs/iniquity/test/compile.rkt b/langs/iniquity/test/compile.rkt deleted file mode 100644 index 81defae6..00000000 --- a/langs/iniquity/test/compile.rkt +++ /dev/null @@ -1,18 +0,0 @@ -#lang racket -(require "test-runner.rkt" - "../parse.rkt" - "../compile.rkt" - "../unload-bits-asm.rkt" - a86/interp) - -;; link with runtime for IO operations -(unless (file-exists? "../runtime.o") - (system "make -C .. runtime.o")) -(current-objs - (list (path->string (normalize-path "../runtime.o")))) - -(test-runner (λ p (unload/free (asm-interp (compile (parse p)))))) -(test-runner-io (λ (s . p) - (match (asm-interp/io (compile (parse p)) s) - ['err 'err] - [(cons r o) (cons (unload/free r) o)]))) diff --git a/langs/iniquity/test/interp.rkt b/langs/iniquity/test/interp.rkt deleted file mode 100644 index cd7b654e..00000000 --- a/langs/iniquity/test/interp.rkt +++ /dev/null @@ -1,8 +0,0 @@ -#lang racket -(require "test-runner.rkt" - "../parse.rkt" - "../interp.rkt" - "../interp-io.rkt") - -(test-runner (λ p (interp (parse p)))) -(test-runner-io (λ (s . p) (interp/io (parse p) s))) diff --git a/langs/iniquity/test/test-runner.rkt b/langs/iniquity/test/test-runner.rkt deleted file mode 100644 index bd73f29b..00000000 --- a/langs/iniquity/test/test-runner.rkt +++ /dev/null @@ -1,285 +0,0 @@ -#lang racket -(provide test-runner test-runner-io) -(require rackunit) - -(define (test-runner run) - ;; Abscond examples - (check-equal? (run 7) 7) - (check-equal? (run -8) -8) - - ;; Blackmail examples - (check-equal? (run '(add1 (add1 7))) 9) - (check-equal? (run '(add1 (sub1 7))) 7) - - ;; Con examples - (check-equal? (run '(if (zero? 0) 1 2)) 1) - (check-equal? (run '(if (zero? 1) 1 2)) 2) - (check-equal? (run '(if (zero? -7) 1 2)) 2) - (check-equal? (run '(if (zero? 0) - (if (zero? 1) 1 2) - 7)) - 2) - (check-equal? (run '(if (zero? (if (zero? 0) 1 0)) - (if (zero? 1) 1 2) - 7)) - 7) - - ;; Dupe examples - (check-equal? (run #t) #t) - (check-equal? (run #f) #f) - (check-equal? (run '(if #t 1 2)) 1) - (check-equal? (run '(if #f 1 2)) 2) - (check-equal? (run '(if 0 1 2)) 1) - (check-equal? (run '(if #t 3 4)) 3) - (check-equal? (run '(if #f 3 4)) 4) - (check-equal? (run '(if 0 3 4)) 3) - (check-equal? (run '(zero? 4)) #f) - (check-equal? (run '(zero? 0)) #t) - - ;; Dodger examples - (check-equal? (run #\a) #\a) - (check-equal? (run #\b) #\b) - (check-equal? (run '(char? #\a)) #t) - (check-equal? (run '(char? #t)) #f) - (check-equal? (run '(char? 8)) #f) - (check-equal? (run '(char->integer #\a)) (char->integer #\a)) - (check-equal? (run '(integer->char 955)) #\λ) - - ;; Extort examples - (check-equal? (run '(add1 #f)) 'err) - (check-equal? (run '(sub1 #f)) 'err) - (check-equal? (run '(zero? #f)) 'err) - (check-equal? (run '(char->integer #f)) 'err) - (check-equal? (run '(integer->char #f)) 'err) - (check-equal? (run '(integer->char -1)) 'err) - (check-equal? (run '(write-byte #f)) 'err) - (check-equal? (run '(write-byte -1)) 'err) - (check-equal? (run '(write-byte 256)) 'err) - - ;; Fraud examples - (check-equal? (run '(let ((x 7)) x)) 7) - (check-equal? (run '(let ((x 7)) 2)) 2) - (check-equal? (run '(let ((x 7)) (add1 x))) 8) - (check-equal? (run '(let ((x (add1 7))) x)) 8) - (check-equal? (run '(let ((x 7)) (let ((y 2)) x))) 7) - (check-equal? (run '(let ((x 7)) (let ((x 2)) x))) 2) - (check-equal? (run '(let ((x 7)) (let ((x (add1 x))) x))) 8) - - (check-equal? (run '(let ((x 0)) - (if (zero? x) 7 8))) - 7) - (check-equal? (run '(let ((x 1)) - (add1 (if (zero? x) 7 8)))) - 9) - (check-equal? (run '(+ 3 4)) 7) - (check-equal? (run '(- 3 4)) -1) - (check-equal? (run '(+ (+ 2 1) 4)) 7) - (check-equal? (run '(+ (+ 2 1) (+ 2 2))) 7) - (check-equal? (run '(let ((x (+ 1 2))) - (let ((z (- 4 x))) - (+ (+ x x) z)))) - 7) - (check-equal? (run '(= 5 5)) #t) - (check-equal? (run '(= 4 5)) #f) - (check-equal? (run '(= (add1 4) 5)) #t) - (check-equal? (run '(< 5 5)) #f) - (check-equal? (run '(< 4 5)) #t) - (check-equal? (run '(< (add1 4) 5)) #f) - - ;; Hustle examples - (check-equal? (run ''()) '()) - (check-equal? (run '(box 1)) (box 1)) - (check-equal? (run '(box -1)) (box -1)) - (check-equal? (run '(cons 1 2)) (cons 1 2)) - (check-equal? (run '(unbox (box 1))) 1) - (check-equal? (run '(car (cons 1 2))) 1) - (check-equal? (run '(cdr (cons 1 2))) 2) - (check-equal? (run '(cons 1 '())) (list 1)) - (check-equal? (run '(let ((x (cons 1 2))) - (begin (cdr x) - (car x)))) - 1) - (check-equal? (run '(let ((x (cons 1 2))) - (let ((y (box 3))) - (unbox y)))) - 3) - (check-equal? (run '(eq? 1 1)) #t) - (check-equal? (run '(eq? 1 2)) #f) - (check-equal? (run '(eq? (cons 1 2) (cons 1 2))) #f) - (check-equal? (run '(let ((x (cons 1 2))) (eq? x x))) #t) - - ;; Hoax examples - (check-equal? (run '(make-vector 0 0)) #()) - (check-equal? (run '(make-vector 1 0)) #(0)) - (check-equal? (run '(make-vector 3 0)) #(0 0 0)) - (check-equal? (run '(make-vector 3 5)) #(5 5 5)) - (check-equal? (run '(vector? (make-vector 0 0))) #t) - (check-equal? (run '(vector? (cons 0 0))) #f) - (check-equal? (run '(vector-ref (make-vector 0 #f) 0)) 'err) - (check-equal? (run '(vector-ref (make-vector 3 5) -1)) 'err) - (check-equal? (run '(vector-ref (make-vector 3 5) 0)) 5) - (check-equal? (run '(vector-ref (make-vector 3 5) 1)) 5) - (check-equal? (run '(vector-ref (make-vector 3 5) 2)) 5) - (check-equal? (run '(vector-ref (make-vector 3 5) 3)) 'err) - (check-equal? (run '(let ((x (make-vector 3 5))) - (begin (vector-set! x 0 4) - x))) - #(4 5 5)) - (check-equal? (run '(let ((x (make-vector 3 5))) - (begin (vector-set! x 1 4) - x))) - #(5 4 5)) - (check-equal? (run '(vector-length (make-vector 3 #f))) 3) - (check-equal? (run '(vector-length (make-vector 0 #f))) 0) - (check-equal? (run '"") "") - (check-equal? (run '"fred") "fred") - (check-equal? (run '"wilma") "wilma") - (check-equal? (run '(make-string 0 #\f)) "") - (check-equal? (run '(make-string 3 #\f)) "fff") - (check-equal? (run '(make-string 3 #\g)) "ggg") - (check-equal? (run '(string-length "")) 0) - (check-equal? (run '(string-length "fred")) 4) - (check-equal? (run '(string-ref "" 0)) 'err) - (check-equal? (run '(string-ref (make-string 0 #\a) 0)) 'err) - (check-equal? (run '(string-ref "fred" 0)) #\f) - (check-equal? (run '(string-ref "fred" 1)) #\r) - (check-equal? (run '(string-ref "fred" 2)) #\e) - (check-equal? (run '(string-ref "fred" 4)) 'err) - (check-equal? (run '(string? "fred")) #t) - (check-equal? (run '(string? (cons 1 2))) #f) - (check-equal? (run '(begin (make-string 3 #\f) - (make-string 3 #\f))) - "fff") - - ;; Iniquity tests - (check-equal? (run - '(define (f x) x) - '(f 5)) - 5) - (check-equal? (run - '(define (tri x) - (if (zero? x) - 0 - (+ x (tri (sub1 x))))) - '(tri 9)) - 45) - - (check-equal? (run - '(define (even? x) - (if (zero? x) - #t - (odd? (sub1 x)))) - '(define (odd? x) - (if (zero? x) - #f - (even? (sub1 x)))) - '(even? 101)) - #f) - - (check-equal? (run - '(define (map-add1 xs) - (if (empty? xs) - '() - (cons (add1 (car xs)) - (map-add1 (cdr xs))))) - '(map-add1 (cons 1 (cons 2 (cons 3 '()))))) - '(2 3 4)) - (check-equal? (run '(define (f x y) y) - '(f 1 (add1 #f))) - 'err)) - -(define (test-runner-io run) - ;; Evildoer examples - (check-equal? (run "" 7) (cons 7 "")) - (check-equal? (run "" '(write-byte 97)) (cons (void) "a")) - (check-equal? (run "a" '(read-byte)) (cons 97 "")) - (check-equal? (run "b" '(begin (write-byte 97) (read-byte))) - (cons 98 "a")) - (check-equal? (run "" '(read-byte)) (cons eof "")) - (check-equal? (run "" '(eof-object? (read-byte))) (cons #t "")) - (check-equal? (run "a" '(eof-object? (read-byte))) (cons #f "")) - (check-equal? (run "" '(begin (write-byte 97) (write-byte 98))) - (cons (void) "ab")) - - (check-equal? (run "ab" '(peek-byte)) (cons 97 "")) - (check-equal? (run "ab" '(begin (peek-byte) (read-byte))) (cons 97 "")) - ;; Extort examples - (check-equal? (run "" '(write-byte #t)) (cons 'err "")) - - ;; Fraud examples - (check-equal? (run "" '(let ((x 97)) (write-byte x))) (cons (void) "a")) - (check-equal? (run "" - '(let ((x 97)) - (begin (write-byte x) - x))) - (cons 97 "a")) - (check-equal? (run "b" '(let ((x 97)) (begin (read-byte) x))) - (cons 97 "")) - (check-equal? (run "b" '(let ((x 97)) (begin (peek-byte) x))) - (cons 97 "")) - - ;; Hustle examples - (check-equal? (run "" - '(let ((x 1)) - (begin (write-byte 97) - 1))) - (cons 1 "a")) - - (check-equal? (run "" - '(let ((x 1)) - (let ((y 2)) - (begin (write-byte 97) - 1)))) - (cons 1 "a")) - - (check-equal? (run "" - '(let ((x (cons 1 2))) - (begin (write-byte 97) - (car x)))) - (cons 1 "a")) - ;; Iniquity examples - (check-equal? (run "" - '(define (print-alphabet i) - (if (zero? i) - (void) - (begin (write-byte (- 123 i)) - (print-alphabet (sub1 i))))) - '(print-alphabet 26)) - (cons (void) "abcdefghijklmnopqrstuvwxyz")) - - (check-equal? (run "" - '(define (f x) - (write-byte x)) - '(f 97)) - (cons (void) "a")) - (check-equal? (run "" - '(define (f x y) - (write-byte x)) - '(f 97 98)) - (cons (void) "a")) - (check-equal? (run "" - '(define (f x) - (let ((y x)) - (write-byte y))) - '(f 97)) - (cons (void) "a")) - (check-equal? (run "" - '(define (f x y) - (let ((y x)) - (write-byte y))) - '(f 97 98)) - (cons (void) "a")) - (check-equal? (run "" - '(define (f x) - (write-byte x)) - '(let ((z 97)) - (f z))) - (cons (void) "a")) - (check-equal? (run "" - '(define (f x y) - (write-byte x)) - '(let ((z 97)) - (f z 98))) - (cons (void) "a"))) - - diff --git a/langs/iniquity/types.rkt b/langs/iniquity/types.rkt deleted file mode 100644 index 986ebc6c..00000000 --- a/langs/iniquity/types.rkt +++ /dev/null @@ -1,67 +0,0 @@ -#lang racket -(provide (all-defined-out)) - -(define imm-shift 3) -(define imm-mask #b111) -(define ptr-mask #b111) -(define type-box #b001) -(define type-cons #b010) -(define type-vect #b011) -(define type-str #b100) -(define int-shift (+ 1 imm-shift)) -(define char-shift (+ 2 imm-shift)) -(define type-int #b0000) -(define mask-int #b1111) -(define type-char #b01000) -(define mask-char #b11111) -(define val-true #b0011000) -(define val-false #b0111000) -(define val-eof #b1011000) -(define val-void #b1111000) -(define val-empty #b10011000) - -(define (bits->value b) - (cond [(= type-int (bitwise-and b mask-int)) - (arithmetic-shift b (- int-shift))] - [(= type-char (bitwise-and b mask-char)) - (integer->char (arithmetic-shift b (- char-shift)))] - [(= b val-true) #t] - [(= b val-false) #f] - [(= b val-eof) eof] - [(= b val-void) (void)] - [(= b val-empty) '()] - [else (error "invalid bits")])) - -(define (value->bits v) - (cond [(eof-object? v) val-eof] - [(integer? v) (arithmetic-shift v int-shift)] - [(char? v) - (bitwise-ior type-char - (arithmetic-shift (char->integer v) char-shift))] - [(eq? v #t) val-true] - [(eq? v #f) val-false] - [(void? v) val-void] - [(empty? v) val-empty] - [else (error "not an immediate value" v)])) - - -(define (imm-bits? v) - (zero? (bitwise-and v imm-mask))) - -(define (int-bits? v) - (zero? (bitwise-and v mask-int))) - -(define (char-bits? v) - (= type-char (bitwise-and v mask-char))) - -(define (cons-bits? v) - (zero? (bitwise-xor (bitwise-and v imm-mask) type-cons))) - -(define (box-bits? v) - (zero? (bitwise-xor (bitwise-and v imm-mask) type-box))) - -(define (vect-bits? v) - (zero? (bitwise-xor (bitwise-and v imm-mask) type-vect))) - -(define (str-bits? v) - (zero? (bitwise-xor (bitwise-and v imm-mask) type-str))) diff --git a/langs/iniquity/unload-bits-asm.rkt b/langs/iniquity/unload-bits-asm.rkt deleted file mode 100644 index 4f02b0c3..00000000 --- a/langs/iniquity/unload-bits-asm.rkt +++ /dev/null @@ -1,43 +0,0 @@ -#lang racket -(provide unload/free unload-value) -(require "types.rkt" - ffi/unsafe) - -;; Answer* -> Answer -(define (unload/free a) - (match a - ['err 'err] - [(cons h v) (begin0 (unload-value v) - (free h))])) - -;; Value* -> Value -(define (unload-value v) - (match v - [(? imm-bits?) (bits->value v)] - [(? box-bits? i) - (box (unload-value (heap-ref i)))] - [(? cons-bits? i) - (cons (unload-value (heap-ref (+ i 8))) - (unload-value (heap-ref i)))] - [(? vect-bits? i) - (if (zero? (untag i)) - (vector) - (build-vector (heap-ref i) - (lambda (j) - (unload-value (heap-ref (+ i (* 8 (add1 j))))))))] - [(? str-bits? i) - (if (zero? (untag i)) - (string) - (build-string (heap-ref i) - (lambda (j) - (char-ref (+ i 8) j))))])) - -(define (untag i) - (arithmetic-shift (arithmetic-shift i (- (integer-length ptr-mask))) - (integer-length ptr-mask))) - -(define (heap-ref i) - (ptr-ref (cast (untag i) _int64 _pointer) _int64)) - -(define (char-ref i j) - (integer->char (ptr-ref (cast (untag i) _int64 _pointer) _uint32 j))) diff --git a/langs/iniquity/values.c b/langs/iniquity/values.c index a61d65e6..62bca18c 100644 --- a/langs/iniquity/values.c +++ b/langs/iniquity/values.c @@ -38,6 +38,10 @@ int64_t val_unwrap_int(val_t x) { return x >> int_shift; } +val_t val_wrap_byte(unsigned char b) +{ + return (b << int_shift) | int_type_tag; +} val_t val_wrap_int(int64_t i) { return (i << int_shift) | int_type_tag; diff --git a/langs/iniquity/values.h b/langs/iniquity/values.h index 4cc48bbe..b6ac44f9 100644 --- a/langs/iniquity/values.h +++ b/langs/iniquity/values.h @@ -49,6 +49,7 @@ type_t val_typeof(val_t x); */ int64_t val_unwrap_int(val_t x); val_t val_wrap_int(int64_t i); +val_t val_wrap_byte(unsigned char b); int val_unwrap_bool(val_t x); val_t val_wrap_bool(int b); diff --git a/langs/installer.rkt b/langs/installer.rkt new file mode 100644 index 00000000..4c52c1c6 --- /dev/null +++ b/langs/installer.rkt @@ -0,0 +1,28 @@ +#lang racket +(provide pre-installer) +(require crook/pi) + +(define (pre-installer cs own) + + (define lang-name + (let-values ([(b f d?) (split-path own)]) + (path->string f))) + + (main (path->string (collection-file-path "src/" "ziggy")) own + ;; NOTE: To re-enable any disabled languages, you must also un-comment + ;; the [pre-install-collection] definition in the [info.rkt] file in + ;; that language's directory. + (cdr (or (assoc lang-name '(#;("abscond" . "A") + #;("blackmail" . "B") + #;("con" . "C") + #;("dupe" . "D0") + ("dodger" . "D1") + ("evildoer" . "E0") + ("extort" . "E1") + ("fraud" . "F") + ("hustle" . "H0") + ("hoax" . "H1") + ("iniquity" . "I") + ("jig" . "J") + ("knock" . "K"))) + (error 'ziggy-pre-installer (format "unsupported lang: ~s" lang-name)))))) diff --git a/langs/jig/Makefile b/langs/jig/Makefile index 9055c88f..db6ac44a 100644 --- a/langs/jig/Makefile +++ b/langs/jig/Makefile @@ -37,7 +37,8 @@ runtime.o: $(objs) cat $< | racket -t compile-stdin.rkt -m > $@ clean: - rm *.o *.s *.run + @$(RM) *.o *.s *.run ||: + @echo "$(shell basename $(shell pwd)): cleaned!" %.test: %.run %.rkt @test "$(shell ./$(<))" = "$(shell racket $(word 2,$^))" diff --git a/langs/jig/ast.rkt b/langs/jig/ast.rkt deleted file mode 100644 index 29e4e06d..00000000 --- a/langs/jig/ast.rkt +++ /dev/null @@ -1,53 +0,0 @@ -#lang racket -(provide (all-defined-out)) - -;; type Prog = (Prog (Listof Defn) Expr) -(struct Prog (ds e) #:prefab) - -;; type Defn = (Defn Id (Listof Id) Expr) -(struct Defn (f xs e) #:prefab) - -;; type Expr = (Eof) -;; | (Empty) -;; | (Int Integer) -;; | (Bool Boolean) -;; | (Char Character) -;; | (Str String) -;; | (Prim0 Op0) -;; | (Prim1 Op1 Expr) -;; | (Prim2 Op2 Expr Expr) -;; | (Prim3 Op3 Expr Expr Expr) -;; | (If Expr Expr Expr) -;; | (Begin Expr Expr) -;; | (Let Id Expr Expr) -;; | (Var Id) -;; | (App Id (Listof Expr)) -;; type Id = Symbol -;; type Op0 = 'read-byte -;; type Op1 = 'add1 | 'sub1 | 'zero? -;; | 'char? | 'integer->char | 'char->integer -;; | 'write-byte | 'eof-object? -;; | 'box | 'car | 'cdr | 'unbox -;; | 'empty? | 'cons? | 'box? -;; | 'vector? | vector-length -;; | 'string? | string-length -;; type Op2 = '+ | '- | '< | '= -;; | 'cons -;; | 'make-vector | 'vector-ref -;; | 'make-string | 'string-ref -;; type Op3 = 'vector-set! -(struct Eof () #:prefab) -(struct Empty () #:prefab) -(struct Int (i) #:prefab) -(struct Bool (b) #:prefab) -(struct Char (c) #:prefab) -(struct Str (s) #:prefab) -(struct Prim0 (p) #:prefab) -(struct Prim1 (p e) #:prefab) -(struct Prim2 (p e1 e2) #:prefab) -(struct Prim3 (p e1 e2 e3) #:prefab) -(struct If (e1 e2 e3) #:prefab) -(struct Begin (e1 e2) #:prefab) -(struct Let (x e1 e2) #:prefab) -(struct Var (x) #:prefab) -(struct App (f es) #:prefab) diff --git a/langs/jig/build-runtime.rkt b/langs/jig/build-runtime.rkt deleted file mode 100644 index 1cc4da53..00000000 --- a/langs/jig/build-runtime.rkt +++ /dev/null @@ -1,12 +0,0 @@ -#lang racket -(provide runtime-path) - -(require racket/runtime-path) -(define-runtime-path here ".") - -(system (string-append "make -C '" - (path->string (normalize-path here)) - "' runtime.o")) - -(define runtime-path - (normalize-path (build-path here "runtime.o"))) \ No newline at end of file diff --git a/langs/jig/compile-ops.rkt b/langs/jig/compile-ops.rkt deleted file mode 100644 index 03b21812..00000000 --- a/langs/jig/compile-ops.rkt +++ /dev/null @@ -1,355 +0,0 @@ -#lang racket -(provide (all-defined-out)) -(require "ast.rkt" "types.rkt" a86/ast) - -(define rax 'rax) ; return -(define eax 'eax) ; 32-bit load/store -(define rbx 'rbx) ; heap -(define rdi 'rdi) ; arg -(define r8 'r8) ; scratch -(define r9 'r9) ; scratch -(define r10 'r10) ; scratch -(define r15 'r15) ; stack pad (non-volatile) -(define rsp 'rsp) ; stack - -;; Op0 -> Asm -(define (compile-op0 p) - (match p - ['void (seq (Mov rax (value->bits (void))))] - ['read-byte (seq pad-stack - (Call 'read_byte) - unpad-stack)] - ['peek-byte (seq pad-stack - (Call 'peek_byte) - unpad-stack)])) - -;; Op1 -> Asm -(define (compile-op1 p) - (match p - ['add1 - (seq (assert-integer rax) - (Add rax (value->bits 1)))] - ['sub1 - (seq (assert-integer rax) - (Sub rax (value->bits 1)))] - ['zero? - (seq (assert-integer rax) - (eq-value 0))] - ['char? - (type-pred mask-char type-char)] - ['char->integer - (seq (assert-char rax) - (Sar rax char-shift) - (Sal rax int-shift))] - ['integer->char - (seq (assert-codepoint rax) - (Sar rax int-shift) - (Sal rax char-shift) - (Xor rax type-char))] - ['eof-object? (eq-value eof)] - ['write-byte - (seq (assert-byte rax) - pad-stack - (Mov rdi rax) - (Call 'write_byte) - unpad-stack)] - ['box - (seq (Mov (Offset rbx 0) rax) - (Mov rax rbx) - (Or rax type-box) - (Add rbx 8))] - ['unbox - (seq (assert-box rax) - (Xor rax type-box) - (Mov rax (Offset rax 0)))] - ['car - (seq (assert-cons rax) - (Xor rax type-cons) - (Mov rax (Offset rax 8)))] - ['cdr - (seq (assert-cons rax) - (Xor rax type-cons) - (Mov rax (Offset rax 0)))] - ['empty? (eq-value '())] - ['box? - (type-pred ptr-mask type-box)] - ['cons? - (type-pred ptr-mask type-cons)] - ['vector? - (type-pred ptr-mask type-vect)] - ['string? - (type-pred ptr-mask type-str)] - ['vector-length - (let ((zero (gensym)) - (done (gensym))) - (seq (assert-vector rax) - (Xor rax type-vect) - (Cmp rax 0) - (Je zero) - (Mov rax (Offset rax 0)) - (Sal rax int-shift) - (Jmp done) - (Label zero) - (Mov rax 0) - (Label done)))] - ['string-length - (let ((zero (gensym)) - (done (gensym))) - (seq (assert-string rax) - (Xor rax type-str) - (Cmp rax 0) - (Je zero) - (Mov rax (Offset rax 0)) - (Sal rax int-shift) - (Jmp done) - (Label zero) - (Mov rax 0) - (Label done)))])) - -;; Op2 -> Asm -(define (compile-op2 p) - (match p - ['+ - (seq (Pop r8) - (assert-integer r8) - (assert-integer rax) - (Add rax r8))] - ['- - (seq (Pop r8) - (assert-integer r8) - (assert-integer rax) - (Sub r8 rax) - (Mov rax r8))] - ['< - (seq (Pop r8) - (assert-integer r8) - (assert-integer rax) - (Cmp r8 rax) - (if-lt))] - ['= - (seq (Pop r8) - (assert-integer r8) - (assert-integer rax) - (Cmp r8 rax) - (if-equal))] - ['cons - (seq (Mov (Offset rbx 0) rax) - (Pop rax) - (Mov (Offset rbx 8) rax) - (Mov rax rbx) - (Or rax type-cons) - (Add rbx 16))] - ['eq? - (seq (Pop r8) - (Cmp rax r8) - (if-equal))] - ['make-vector - (let ((loop (gensym)) - (done (gensym)) - (empty (gensym))) - (seq (Pop r8) - (assert-natural r8) - (Cmp r8 0) ; special case empty vector - (Je empty) - - (Mov r9 rbx) - (Or r9 type-vect) - - (Sar r8 int-shift) - (Mov (Offset rbx 0) r8) - (Add rbx 8) - - (Label loop) - (Mov (Offset rbx 0) rax) - (Add rbx 8) - (Sub r8 1) - (Cmp r8 0) - (Jne loop) - - (Mov rax r9) - (Jmp done) - - (Label empty) - (Mov rax type-vect) - (Label done)))] - - ['vector-ref - (seq (Pop r8) - (assert-vector r8) - (assert-integer rax) - (Cmp r8 type-vect) - (Je 'raise_error_align) ; special case for empty vector - (Cmp rax 0) - (Jl 'raise_error_align) - (Xor r8 type-vect) ; r8 = ptr - (Mov r9 (Offset r8 0)) ; r9 = len - (Sar rax int-shift) ; rax = index - (Sub r9 1) - (Cmp r9 rax) - (Jl 'raise_error_align) - (Sal rax 3) - (Add r8 rax) - (Mov rax (Offset r8 8)))] - - ['make-string - (let ((loop (gensym)) - (done (gensym)) - (empty (gensym))) - (seq (Pop r8) - (assert-natural r8) - (assert-char rax) - (Cmp r8 0) ; special case empty string - (Je empty) - - (Mov r9 rbx) - (Or r9 type-str) - - (Sar r8 int-shift) - (Mov (Offset rbx 0) r8) - (Add rbx 8) - - (Sar rax char-shift) - - (Add r8 1) ; adds 1 - (Sar r8 1) ; when - (Sal r8 1) ; len is odd - - (Label loop) - (Mov (Offset rbx 0) eax) - (Add rbx 4) - (Sub r8 1) - (Cmp r8 0) - (Jne loop) - - (Mov rax r9) - (Jmp done) - - (Label empty) - (Mov rax type-str) - (Label done)))] - - ['string-ref - (seq (Pop r8) - (assert-string r8) - (assert-integer rax) - (Cmp r8 type-str) - (Je 'raise_error_align) ; special case for empty string - (Cmp rax 0) - (Jl 'raise_error_align) - (Xor r8 type-str) ; r8 = ptr - (Mov r9 (Offset r8 0)) ; r9 = len - (Sar rax int-shift) ; rax = index - (Sub r9 1) - (Cmp r9 rax) - (Jl 'raise_error_align) - (Sal rax 2) - (Add r8 rax) - (Mov 'eax (Offset r8 8)) - (Sal rax char-shift) - (Or rax type-char))])) - -;; Op3 -> Asm -(define (compile-op3 p) - (match p - ['vector-set! - (seq (Pop r10) - (Pop r8) - (assert-vector r8) - (assert-integer r10) - (Cmp r10 0) - (Jl 'raise_error_align) - (Xor r8 type-vect) ; r8 = ptr - (Mov r9 (Offset r8 0)) ; r9 = len - (Sar r10 int-shift) ; r10 = index - (Sub r9 1) - (Cmp r9 r10) - (Jl 'raise_error_align) - (Sal r10 3) - (Add r8 r10) - (Mov (Offset r8 8) rax) - (Mov rax (value->bits (void))))])) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define (assert-type mask type) - (λ (arg) - (seq (Mov r9 arg) - (And r9 mask) - (Cmp r9 type) - (Jne 'raise_error_align)))) - -(define (type-pred mask type) - (let ((l (gensym))) - (seq (And rax mask) - (Cmp rax type) - (Mov rax (value->bits #t)) - (Je l) - (Mov rax (value->bits #f)) - (Label l)))) - -(define assert-integer - (assert-type mask-int type-int)) -(define assert-char - (assert-type mask-char type-char)) -(define assert-box - (assert-type ptr-mask type-box)) -(define assert-cons - (assert-type ptr-mask type-cons)) -(define assert-vector - (assert-type ptr-mask type-vect)) -(define assert-string - (assert-type ptr-mask type-str)) - -(define (assert-codepoint r) - (let ((ok (gensym))) - (seq (assert-integer r) - (Cmp r (value->bits 0)) - (Jl 'raise_error_align) - (Cmp r (value->bits 1114111)) - (Jg 'raise_error_align) - (Cmp r (value->bits 55295)) - (Jl ok) - (Cmp r (value->bits 57344)) - (Jg ok) - (Jmp 'raise_error_align) - (Label ok)))) - -(define (assert-byte r) - (seq (assert-integer r) - (Cmp r (value->bits 0)) - (Jl 'raise_error_align) - (Cmp r (value->bits 255)) - (Jg 'raise_error_align))) - -(define (assert-natural r) - (seq (assert-integer r) - (Cmp r (value->bits 0)) - (Jl 'raise_error_align))) - -;; -> Asm -;; set rax to #t or #f based on given comparison -(define (if-compare c) - (seq (Mov rax (value->bits #f)) - (Mov r9 (value->bits #t)) - (c rax r9))) - -(define (if-equal) (if-compare Cmove)) -(define (if-lt) (if-compare Cmovl)) - -;; Value -> Asm -(define (eq-value v) - (seq (Cmp rax (value->bits v)) - (if-equal))) - -;; Asm -;; Dynamically pad the stack to be aligned for a call -(define pad-stack - (seq (Mov r15 rsp) - (And r15 #b1000) - (Sub rsp r15))) - -;; Asm -;; Undo the stack alignment after a call -(define unpad-stack - (seq (Add rsp r15))) diff --git a/langs/jig/compile-stdin.rkt b/langs/jig/compile-stdin.rkt deleted file mode 100644 index cfa15106..00000000 --- a/langs/jig/compile-stdin.rkt +++ /dev/null @@ -1,10 +0,0 @@ -#lang racket -(provide main) -(require "parse.rkt" "compile.rkt" "read-all.rkt" a86/printer) - -;; -> Void -;; Compile contents of stdin, -;; emit asm code on stdout -(define (main) - (read-line) ; ignore #lang racket line - (asm-display (compile (parse (read-all))))) diff --git a/langs/jig/compile.rkt b/langs/jig/compile.rkt deleted file mode 100644 index eeed7a3b..00000000 --- a/langs/jig/compile.rkt +++ /dev/null @@ -1,223 +0,0 @@ -#lang racket -(provide (all-defined-out)) -(require "ast.rkt" "types.rkt" "compile-ops.rkt" a86/ast) - -;; Registers used -(define rax 'rax) ; return -(define rbx 'rbx) ; heap -(define rsp 'rsp) ; stack -(define rdi 'rdi) ; arg -(define r15 'r15) ; stack pad (non-volatile) - -;; type CEnv = (Listof [Maybe Id]) - -;; Prog -> Asm -(define (compile p) - (match p - [(Prog ds e) - (prog (externs) - (Global 'entry) - (Label 'entry) - (Push rbx) ; save callee-saved register - (Push r15) - (Mov rbx rdi) ; recv heap pointer - (compile-e e '() #f) - (Pop r15) ; restore callee-save register - (Pop rbx) - (Ret) - (compile-defines ds) - (Label 'raise_error_align) - pad-stack - (Call 'raise_error))])) - -(define (externs) - (seq (Extern 'peek_byte) - (Extern 'read_byte) - (Extern 'write_byte) - (Extern 'raise_error))) - -;; [Listof Defn] -> Asm -(define (compile-defines ds) - (match ds - ['() (seq)] - [(cons d ds) - (seq (compile-define d) - (compile-defines ds))])) - -;; Defn -> Asm -(define (compile-define d) - (match d - [(Defn f xs e) - (seq (Label (symbol->label f)) - (compile-e e (reverse xs) #t) - (Add rsp (* 8 (length xs))) ; pop args - (Ret))])) - -;; Expr CEnv Bool -> Asm -(define (compile-e e c t?) - (match e - [(Int i) (compile-value i)] - [(Bool b) (compile-value b)] - [(Char c) (compile-value c)] - [(Eof) (compile-value eof)] - [(Empty) (compile-value '())] - [(Var x) (compile-variable x c)] - [(Str s) (compile-string s)] - [(Prim0 p) (compile-prim0 p c)] - [(Prim1 p e) (compile-prim1 p e c)] - [(Prim2 p e1 e2) (compile-prim2 p e1 e2 c)] - [(Prim3 p e1 e2 e3) (compile-prim3 p e1 e2 e3 c)] - [(If e1 e2 e3) (compile-if e1 e2 e3 c t?)] - [(Begin e1 e2) (compile-begin e1 e2 c t?)] - [(Let x e1 e2) (compile-let x e1 e2 c t?)] - [(App f es) (compile-app f es c t?)])) - -;; Value -> Asm -(define (compile-value v) - (seq (Mov rax (value->bits v)))) - -;; Id CEnv -> Asm -(define (compile-variable x c) - (let ((i (lookup x c))) - (seq (Mov rax (Offset rsp i))))) - -;; String -> Asm -(define (compile-string s) - (let ((len (string-length s))) - (if (zero? len) - (seq (Mov rax type-str)) - (seq (Mov rax len) - (Mov (Offset rbx 0) rax) - (compile-string-chars (string->list s) 8) - (Mov rax rbx) - (Or rax type-str) - (Add rbx - (+ 8 (* 4 (if (odd? len) (add1 len) len)))))))) - -;; [Listof Char] Integer -> Asm -(define (compile-string-chars cs i) - (match cs - ['() (seq)] - [(cons c cs) - (seq (Mov rax (char->integer c)) - (Mov (Offset rbx i) 'eax) - (compile-string-chars cs (+ 4 i)))])) - -;; Op0 CEnv -> Asm -(define (compile-prim0 p c) - (compile-op0 p)) - -;; Op1 Expr CEnv -> Asm -(define (compile-prim1 p e c) - (seq (compile-e e c #f) - (compile-op1 p))) - -;; Op2 Expr Expr CEnv -> Asm -(define (compile-prim2 p e1 e2 c) - (seq (compile-e e1 c #f) - (Push rax) - (compile-e e2 (cons #f c) #f) - (compile-op2 p))) - -;; Op3 Expr Expr Expr CEnv -> Asm -(define (compile-prim3 p e1 e2 e3 c) - (seq (compile-e e1 c #f) - (Push rax) - (compile-e e2 (cons #f c) #f) - (Push rax) - (compile-e e3 (cons #f (cons #f c)) #f) - (compile-op3 p))) - -;; Expr Expr Expr CEnv Bool -> Asm -(define (compile-if e1 e2 e3 c t?) - (let ((l1 (gensym 'if)) - (l2 (gensym 'if))) - (seq (compile-e e1 c #f) - (Cmp rax val-false) - (Je l1) - (compile-e e2 c t?) - (Jmp l2) - (Label l1) - (compile-e e3 c t?) - (Label l2)))) - -;; Expr Expr CEnv Bool -> Asm -(define (compile-begin e1 e2 c t?) - (seq (compile-e e1 c #f) - (compile-e e2 c t?))) - -;; Id Expr Expr CEnv Bool -> Asm -(define (compile-let x e1 e2 c t?) - (seq (compile-e e1 c #f) - (Push rax) - (compile-e e2 (cons x c) t?) - (Add rsp 8))) - -;; Id [Listof Expr] CEnv Bool -> Asm -(define (compile-app f es c t?) - (if t? - (compile-app-tail f es c) - (compile-app-nontail f es c))) - -;; Id [Listof Expr] CEnv -> Asm -(define (compile-app-tail f es c) - (seq (compile-es es c) - (move-args (length es) (length c)) - (Add rsp (* 8 (length c))) - (Jmp (symbol->label f)))) - -;; Integer Integer -> Asm -(define (move-args i off) - (cond [(zero? off) (seq)] - [(zero? i) (seq)] - [else - (seq (Mov r8 (Offset rsp (* 8 (sub1 i)))) - (Mov (Offset rsp (* 8 (+ off (sub1 i)))) r8) - (move-args (sub1 i) off))])) - -;; Id [Listof Expr] CEnv -> Asm -;; The return address is placed above the arguments, so callee pops -;; arguments and return address is next frame -(define (compile-app-nontail f es c) - (let ((r (gensym 'ret))) - (seq (Lea rax r) - (Push rax) - (compile-es es (cons #f c)) - (Jmp (symbol->label f)) - (Label r)))) - -;; [Listof Expr] CEnv -> Asm -(define (compile-es es c) - (match es - ['() '()] - [(cons e es) - (seq (compile-e e c #f) - (Push rax) - (compile-es es (cons #f c)))])) - -;; Id CEnv -> Integer -(define (lookup x cenv) - (match cenv - ['() (error "undefined variable:" x)] - [(cons y rest) - (match (eq? x y) - [#t 0] - [#f (+ 8 (lookup x rest))])])) - -;; Symbol -> Label -;; Produce a symbol that is a valid Nasm 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/langs/jig/info.rkt b/langs/jig/info.rkt new file mode 100644 index 00000000..41ec40bb --- /dev/null +++ b/langs/jig/info.rkt @@ -0,0 +1,2 @@ +#lang info +(define pre-install-collection "../installer.rkt") diff --git a/langs/jig/interp-io.rkt b/langs/jig/interp-io.rkt deleted file mode 100644 index 93f7d3c6..00000000 --- a/langs/jig/interp-io.rkt +++ /dev/null @@ -1,12 +0,0 @@ -#lang racket -(provide interp/io) -(require "interp.rkt") - -;; (Expr String -> String -;; Interpret e with given string as input, -;; collect output as string (including printed result) -(define (interp/io e in) - (parameterize ((current-output-port (open-output-string)) - (current-input-port (open-input-string in))) - (cons (interp e) - (get-output-string (current-output-port))))) diff --git a/langs/jig/interp-stdin.rkt b/langs/jig/interp-stdin.rkt deleted file mode 100644 index 965b9cc4..00000000 --- a/langs/jig/interp-stdin.rkt +++ /dev/null @@ -1,12 +0,0 @@ -#lang racket -(provide main) -(require "parse.rkt" "interp.rkt" "read-all.rkt") - -;; -> Void -;; Parse and interpret contents of stdin, -;; print result on stdout -(define (main) - (read-line) ; ignore #lang racket line - (let ((r (interp (parse (read-all))))) - (unless (void? r) - (println r)))) diff --git a/langs/jig/interp.rkt b/langs/jig/interp.rkt deleted file mode 100644 index 55d77c81..00000000 --- a/langs/jig/interp.rkt +++ /dev/null @@ -1,108 +0,0 @@ -#lang racket -(provide interp interp-env) -(require "ast.rkt" - "env.rkt" - "interp-prims.rkt") - -;; type Answer = Value | 'err - -;; type Value = -;; | Integer -;; | Boolean -;; | Character -;; | Eof -;; | Void -;; | '() -;; | (cons Value Value) -;; | (box Value) -;; | (vector Value ...) -;; | (string Char ...) - -;; type REnv = (Listof (List Id Value)) -;; type Defns = (Listof Defn) - -;; Prog -> Answer -(define (interp p) - (match p - [(Prog ds e) - (interp-env e '() ds)])) - -;; Expr Env Defns -> Answer -(define (interp-env e r ds) - (match e - [(Int i) i] - [(Bool b) b] - [(Char c) c] - [(Eof) eof] - [(Empty) '()] - [(Var x) (lookup r x)] - [(Str s) s] - [(Prim0 'void) (void)] - [(Prim0 'read-byte) (read-byte)] - [(Prim0 'peek-byte) (peek-byte)] - [(Prim1 p e) - (match (interp-env e r ds) - ['err 'err] - [v (interp-prim1 p v)])] - [(Prim2 p e1 e2) - (match (interp-env e1 r ds) - ['err 'err] - [v1 (match (interp-env e2 r ds) - ['err 'err] - [v2 (interp-prim2 p v1 v2)])])] - [(Prim3 p e1 e2 e3) - (match (interp-env e1 r ds) - ['err 'err] - [v1 (match (interp-env e2 r ds) - ['err 'err] - [v2 (match (interp-env e3 r ds) - ['err 'err] - [v3 (interp-prim3 p v1 v2 v3)])])])] - [(If p e1 e2) - (match (interp-env p r ds) - ['err 'err] - [v - (if v - (interp-env e1 r ds) - (interp-env e2 r ds))])] - [(Begin e1 e2) - (match (interp-env e1 r ds) - ['err 'err] - [_ (interp-env e2 r ds)])] - [(Let x e1 e2) - (match (interp-env e1 r ds) - ['err 'err] - [v (interp-env e2 (ext r x v) ds)])] - [(App f es) - (match (interp-env* es r ds) - ['err 'err] - [vs - (match (defns-lookup ds f) - [(Defn f xs e) - ; check arity matches - (if (= (length xs) (length vs)) - (interp-env e (zip xs vs) ds) - 'err)])])])) - -;; (Listof Expr) REnv Defns -> (Listof Value) | 'err -(define (interp-env* es r ds) - (match es - ['() '()] - [(cons e es) - (match (interp-env e r ds) - ['err 'err] - [v (match (interp-env* es r ds) - ['err 'err] - [vs (cons v vs)])])])) - -;; Defns Symbol -> Defn -(define (defns-lookup ds f) - (findf (match-lambda [(Defn g _ _) (eq? f g)]) - ds)) - -(define (zip xs ys) - (match* (xs ys) - [('() '()) '()] - [((cons x xs) (cons y ys)) - (cons (list x y) - (zip xs ys))])) diff --git a/langs/jig/io.c b/langs/jig/io.c index 7ef82281..8a417c91 100644 --- a/langs/jig/io.c +++ b/langs/jig/io.c @@ -7,14 +7,14 @@ val_t read_byte(void) { char c = getc(in); - return (c == EOF) ? val_wrap_eof() : val_wrap_int(c); + return (c == EOF) ? val_wrap_eof() : val_wrap_byte(c); } val_t peek_byte(void) { char c = getc(in); ungetc(c, in); - return (c == EOF) ? val_wrap_eof() : val_wrap_int(c); + return (c == EOF) ? val_wrap_eof() : val_wrap_byte(c); } diff --git a/langs/jig/parse.rkt b/langs/jig/parse.rkt deleted file mode 100644 index 8814af60..00000000 --- a/langs/jig/parse.rkt +++ /dev/null @@ -1,65 +0,0 @@ -#lang racket -(provide parse parse-define parse-e) -(require "ast.rkt") - -;; [Listof S-Expr] -> Prog -(define (parse s) - (match s - [(cons (and (cons 'define _) d) s) - (match (parse s) - [(Prog ds e) - (Prog (cons (parse-define d) ds) e)])] - [(cons e '()) (Prog '() (parse-e e))] - [_ (error "program parse error")])) - -;; S-Expr -> Defn -(define (parse-define s) - (match s - [(list 'define (list-rest (? symbol? f) xs) e) - (if (andmap symbol? xs) - (Defn f xs (parse-e e)) - (error "parse definition error"))] - [_ (error "Parse defn error" s)])) - -;; S-Expr -> Expr -(define (parse-e s) - (match s - [(? exact-integer?) (Int s)] - [(? boolean?) (Bool s)] - [(? char?) (Char s)] - [(? string?) (Str s)] - ['eof (Eof)] - [(? symbol?) (Var s)] - [(list 'quote (list)) (Empty)] - [(list (? (op? op0) p0)) (Prim0 p0)] - [(list (? (op? op1) p1) e) (Prim1 p1 (parse-e e))] - [(list (? (op? op2) p2) e1 e2) (Prim2 p2 (parse-e e1) (parse-e e2))] - [(list (? (op? op3) p3) e1 e2 e3) - (Prim3 p3 (parse-e e1) (parse-e e2) (parse-e e3))] - [(list 'begin e1 e2) - (Begin (parse-e e1) (parse-e e2))] - [(list 'if e1 e2 e3) - (If (parse-e e1) (parse-e e2) (parse-e e3))] - [(list 'let (list (list (? symbol? x) e1)) e2) - (Let x (parse-e e1) (parse-e e2))] - [(cons (? symbol? f) es) - (App f (map parse-e es))] - [_ (error "Parse error" s)])) - -(define op0 - '(read-byte peek-byte void)) - -(define op1 - '(add1 sub1 zero? char? write-byte eof-object? - integer->char char->integer - box unbox empty? cons? box? car cdr - vector? vector-length string? string-length)) -(define op2 - '(+ - < = cons eq? make-vector vector-ref make-string string-ref)) -(define op3 - '(vector-set!)) - -(define (op? ops) - (λ (x) - (and (symbol? x) - (memq x ops)))) diff --git a/langs/jig/read-all.rkt b/langs/jig/read-all.rkt deleted file mode 100644 index 8a3289a5..00000000 --- a/langs/jig/read-all.rkt +++ /dev/null @@ -1,8 +0,0 @@ -#lang racket -(provide read-all) -;; read all s-expression until eof -(define (read-all) - (let ((r (read))) - (if (eof-object? r) - '() - (cons r (read-all))))) diff --git a/langs/jig/test/compile.rkt b/langs/jig/test/compile.rkt deleted file mode 100644 index 81defae6..00000000 --- a/langs/jig/test/compile.rkt +++ /dev/null @@ -1,18 +0,0 @@ -#lang racket -(require "test-runner.rkt" - "../parse.rkt" - "../compile.rkt" - "../unload-bits-asm.rkt" - a86/interp) - -;; link with runtime for IO operations -(unless (file-exists? "../runtime.o") - (system "make -C .. runtime.o")) -(current-objs - (list (path->string (normalize-path "../runtime.o")))) - -(test-runner (λ p (unload/free (asm-interp (compile (parse p)))))) -(test-runner-io (λ (s . p) - (match (asm-interp/io (compile (parse p)) s) - ['err 'err] - [(cons r o) (cons (unload/free r) o)]))) diff --git a/langs/jig/test/interp.rkt b/langs/jig/test/interp.rkt deleted file mode 100644 index cd7b654e..00000000 --- a/langs/jig/test/interp.rkt +++ /dev/null @@ -1,8 +0,0 @@ -#lang racket -(require "test-runner.rkt" - "../parse.rkt" - "../interp.rkt" - "../interp-io.rkt") - -(test-runner (λ p (interp (parse p)))) -(test-runner-io (λ (s . p) (interp/io (parse p) s))) diff --git a/langs/jig/test/test-runner.rkt b/langs/jig/test/test-runner.rkt deleted file mode 100644 index b00392a9..00000000 --- a/langs/jig/test/test-runner.rkt +++ /dev/null @@ -1,268 +0,0 @@ -#lang racket -(provide test-runner test-runner-io) -(require rackunit) - -(define (test-runner run) - ;; Abscond examples - (check-equal? (run 7) 7) - (check-equal? (run -8) -8) - - ;; Blackmail examples - (check-equal? (run '(add1 (add1 7))) 9) - (check-equal? (run '(add1 (sub1 7))) 7) - - ;; Con examples - (check-equal? (run '(if (zero? 0) 1 2)) 1) - (check-equal? (run '(if (zero? 1) 1 2)) 2) - (check-equal? (run '(if (zero? -7) 1 2)) 2) - (check-equal? (run '(if (zero? 0) - (if (zero? 1) 1 2) - 7)) - 2) - (check-equal? (run '(if (zero? (if (zero? 0) 1 0)) - (if (zero? 1) 1 2) - 7)) - 7) - - ;; Dupe examples - (check-equal? (run #t) #t) - (check-equal? (run #f) #f) - (check-equal? (run '(if #t 1 2)) 1) - (check-equal? (run '(if #f 1 2)) 2) - (check-equal? (run '(if 0 1 2)) 1) - (check-equal? (run '(if #t 3 4)) 3) - (check-equal? (run '(if #f 3 4)) 4) - (check-equal? (run '(if 0 3 4)) 3) - (check-equal? (run '(zero? 4)) #f) - (check-equal? (run '(zero? 0)) #t) - - ;; Dodger examples - (check-equal? (run #\a) #\a) - (check-equal? (run #\b) #\b) - (check-equal? (run '(char? #\a)) #t) - (check-equal? (run '(char? #t)) #f) - (check-equal? (run '(char? 8)) #f) - (check-equal? (run '(char->integer #\a)) (char->integer #\a)) - (check-equal? (run '(integer->char 955)) #\λ) - - ;; Extort examples - (check-equal? (run '(add1 #f)) 'err) - (check-equal? (run '(sub1 #f)) 'err) - (check-equal? (run '(zero? #f)) 'err) - (check-equal? (run '(char->integer #f)) 'err) - (check-equal? (run '(integer->char #f)) 'err) - (check-equal? (run '(integer->char -1)) 'err) - (check-equal? (run '(write-byte #f)) 'err) - (check-equal? (run '(write-byte -1)) 'err) - (check-equal? (run '(write-byte 256)) 'err) - - ;; Fraud examples - (check-equal? (run '(let ((x 7)) x)) 7) - (check-equal? (run '(let ((x 7)) 2)) 2) - (check-equal? (run '(let ((x 7)) (add1 x))) 8) - (check-equal? (run '(let ((x (add1 7))) x)) 8) - (check-equal? (run '(let ((x 7)) (let ((y 2)) x))) 7) - (check-equal? (run '(let ((x 7)) (let ((x 2)) x))) 2) - (check-equal? (run '(let ((x 7)) (let ((x (add1 x))) x))) 8) - - (check-equal? (run '(let ((x 0)) - (if (zero? x) 7 8))) - 7) - (check-equal? (run '(let ((x 1)) - (add1 (if (zero? x) 7 8)))) - 9) - (check-equal? (run '(+ 3 4)) 7) - (check-equal? (run '(- 3 4)) -1) - (check-equal? (run '(+ (+ 2 1) 4)) 7) - (check-equal? (run '(+ (+ 2 1) (+ 2 2))) 7) - (check-equal? (run '(let ((x (+ 1 2))) - (let ((z (- 4 x))) - (+ (+ x x) z)))) - 7) - (check-equal? (run '(= 5 5)) #t) - (check-equal? (run '(= 4 5)) #f) - (check-equal? (run '(= (add1 4) 5)) #t) - (check-equal? (run '(< 5 5)) #f) - (check-equal? (run '(< 4 5)) #t) - (check-equal? (run '(< (add1 4) 5)) #f) - - ;; Hustle examples - (check-equal? (run ''()) '()) - (check-equal? (run '(box 1)) (box 1)) - (check-equal? (run '(box -1)) (box -1)) - (check-equal? (run '(cons 1 2)) (cons 1 2)) - (check-equal? (run '(unbox (box 1))) 1) - (check-equal? (run '(car (cons 1 2))) 1) - (check-equal? (run '(cdr (cons 1 2))) 2) - (check-equal? (run '(cons 1 '())) (list 1)) - (check-equal? (run '(let ((x (cons 1 2))) - (begin (cdr x) - (car x)))) - 1) - (check-equal? (run '(let ((x (cons 1 2))) - (let ((y (box 3))) - (unbox y)))) - 3) - (check-equal? (run '(eq? 1 1)) #t) - (check-equal? (run '(eq? 1 2)) #f) - (check-equal? (run '(eq? (cons 1 2) (cons 1 2))) #f) - (check-equal? (run '(let ((x (cons 1 2))) (eq? x x))) #t) - - ;; Hoax examples - (check-equal? (run '(make-vector 0 0)) #()) - (check-equal? (run '(make-vector 1 0)) #(0)) - (check-equal? (run '(make-vector 3 0)) #(0 0 0)) - (check-equal? (run '(make-vector 3 5)) #(5 5 5)) - (check-equal? (run '(vector? (make-vector 0 0))) #t) - (check-equal? (run '(vector? (cons 0 0))) #f) - (check-equal? (run '(vector-ref (make-vector 0 #f) 0)) 'err) - (check-equal? (run '(vector-ref (make-vector 3 5) -1)) 'err) - (check-equal? (run '(vector-ref (make-vector 3 5) 0)) 5) - (check-equal? (run '(vector-ref (make-vector 3 5) 1)) 5) - (check-equal? (run '(vector-ref (make-vector 3 5) 2)) 5) - (check-equal? (run '(vector-ref (make-vector 3 5) 3)) 'err) - (check-equal? (run '(let ((x (make-vector 3 5))) - (begin (vector-set! x 0 4) - x))) - #(4 5 5)) - (check-equal? (run '(let ((x (make-vector 3 5))) - (begin (vector-set! x 1 4) - x))) - #(5 4 5)) - (check-equal? (run '(vector-length (make-vector 3 #f))) 3) - (check-equal? (run '(vector-length (make-vector 0 #f))) 0) - (check-equal? (run '"") "") - (check-equal? (run '"fred") "fred") - (check-equal? (run '"wilma") "wilma") - (check-equal? (run '(make-string 0 #\f)) "") - (check-equal? (run '(make-string 3 #\f)) "fff") - (check-equal? (run '(make-string 3 #\g)) "ggg") - (check-equal? (run '(string-length "")) 0) - (check-equal? (run '(string-length "fred")) 4) - (check-equal? (run '(string-ref "" 0)) 'err) - (check-equal? (run '(string-ref (make-string 0 #\a) 0)) 'err) - (check-equal? (run '(string-ref "fred" 0)) #\f) - (check-equal? (run '(string-ref "fred" 1)) #\r) - (check-equal? (run '(string-ref "fred" 2)) #\e) - (check-equal? (run '(string-ref "fred" 4)) 'err) - (check-equal? (run '(string? "fred")) #t) - (check-equal? (run '(string? (cons 1 2))) #f) - (check-equal? (run '(begin (make-string 3 #\f) - (make-string 3 #\f))) - "fff") - - ;; Iniquity tests - (check-equal? (run - '(define (f x) x) - '(f 5)) - 5) - (check-equal? (run - '(define (tri x) - (if (zero? x) - 0 - (+ x (tri (sub1 x))))) - '(tri 9)) - 45) - - (check-equal? (run - '(define (even? x) - (if (zero? x) - #t - (odd? (sub1 x)))) - '(define (odd? x) - (if (zero? x) - #f - (even? (sub1 x)))) - '(even? 101)) - #f) - - (check-equal? (run - '(define (map-add1 xs) - (if (empty? xs) - '() - (cons (add1 (car xs)) - (map-add1 (cdr xs))))) - '(map-add1 (cons 1 (cons 2 (cons 3 '()))))) - '(2 3 4)) - (check-equal? (run - '(define (f x) - 10) - '(f 1)) - 10) - (check-equal? (run - ' (define (f x) - 10) - '(let ((x 2)) (f 1))) - 10) - (check-equal? (run - '(define (f x y) - 10) - '(f 1 2)) - 10) - (check-equal? (run - '(define (f x y) - 10) - '(let ((z 2)) (f 1 2))) - 10) - (check-equal? (run '(define (f x y) y) - '(f 1 (add1 #f))) - 'err)) - -(define (test-runner-io run) - ;; Evildoer examples - (check-equal? (run "" 7) (cons 7 "")) - (check-equal? (run "" '(write-byte 97)) (cons (void) "a")) - (check-equal? (run "a" '(read-byte)) (cons 97 "")) - (check-equal? (run "b" '(begin (write-byte 97) (read-byte))) - (cons 98 "a")) - (check-equal? (run "" '(read-byte)) (cons eof "")) - (check-equal? (run "" '(eof-object? (read-byte))) (cons #t "")) - (check-equal? (run "a" '(eof-object? (read-byte))) (cons #f "")) - (check-equal? (run "" '(begin (write-byte 97) (write-byte 98))) - (cons (void) "ab")) - - (check-equal? (run "ab" '(peek-byte)) (cons 97 "")) - (check-equal? (run "ab" '(begin (peek-byte) (read-byte))) (cons 97 "")) - ;; Extort examples - (check-equal? (run "" '(write-byte #t)) (cons 'err "")) - - ;; Fraud examples - (check-equal? (run "" '(let ((x 97)) (write-byte x))) (cons (void) "a")) - (check-equal? (run "" - '(let ((x 97)) - (begin (write-byte x) - x))) - (cons 97 "a")) - (check-equal? (run "b" '(let ((x 97)) (begin (read-byte) x))) - (cons 97 "")) - (check-equal? (run "b" '(let ((x 97)) (begin (peek-byte) x))) - (cons 97 "")) - - ;; Hustle examples - (check-equal? (run "" - '(let ((x 1)) - (begin (write-byte 97) - 1))) - (cons 1 "a")) - - (check-equal? (run "" - '(let ((x 1)) - (let ((y 2)) - (begin (write-byte 97) - 1)))) - (cons 1 "a")) - - (check-equal? (run "" - '(let ((x (cons 1 2))) - (begin (write-byte 97) - (car x)))) - (cons 1 "a")) - ;; Iniquity examples - (check-equal? (run "" - '(define (print-alphabet i) - (if (zero? i) - (void) - (begin (write-byte (- 123 i)) - (print-alphabet (sub1 i))))) - '(print-alphabet 26)) - (cons (void) "abcdefghijklmnopqrstuvwxyz"))) diff --git a/langs/jig/types.rkt b/langs/jig/types.rkt deleted file mode 100644 index 986ebc6c..00000000 --- a/langs/jig/types.rkt +++ /dev/null @@ -1,67 +0,0 @@ -#lang racket -(provide (all-defined-out)) - -(define imm-shift 3) -(define imm-mask #b111) -(define ptr-mask #b111) -(define type-box #b001) -(define type-cons #b010) -(define type-vect #b011) -(define type-str #b100) -(define int-shift (+ 1 imm-shift)) -(define char-shift (+ 2 imm-shift)) -(define type-int #b0000) -(define mask-int #b1111) -(define type-char #b01000) -(define mask-char #b11111) -(define val-true #b0011000) -(define val-false #b0111000) -(define val-eof #b1011000) -(define val-void #b1111000) -(define val-empty #b10011000) - -(define (bits->value b) - (cond [(= type-int (bitwise-and b mask-int)) - (arithmetic-shift b (- int-shift))] - [(= type-char (bitwise-and b mask-char)) - (integer->char (arithmetic-shift b (- char-shift)))] - [(= b val-true) #t] - [(= b val-false) #f] - [(= b val-eof) eof] - [(= b val-void) (void)] - [(= b val-empty) '()] - [else (error "invalid bits")])) - -(define (value->bits v) - (cond [(eof-object? v) val-eof] - [(integer? v) (arithmetic-shift v int-shift)] - [(char? v) - (bitwise-ior type-char - (arithmetic-shift (char->integer v) char-shift))] - [(eq? v #t) val-true] - [(eq? v #f) val-false] - [(void? v) val-void] - [(empty? v) val-empty] - [else (error "not an immediate value" v)])) - - -(define (imm-bits? v) - (zero? (bitwise-and v imm-mask))) - -(define (int-bits? v) - (zero? (bitwise-and v mask-int))) - -(define (char-bits? v) - (= type-char (bitwise-and v mask-char))) - -(define (cons-bits? v) - (zero? (bitwise-xor (bitwise-and v imm-mask) type-cons))) - -(define (box-bits? v) - (zero? (bitwise-xor (bitwise-and v imm-mask) type-box))) - -(define (vect-bits? v) - (zero? (bitwise-xor (bitwise-and v imm-mask) type-vect))) - -(define (str-bits? v) - (zero? (bitwise-xor (bitwise-and v imm-mask) type-str))) diff --git a/langs/jig/unload-bits-asm.rkt b/langs/jig/unload-bits-asm.rkt deleted file mode 100644 index 4f02b0c3..00000000 --- a/langs/jig/unload-bits-asm.rkt +++ /dev/null @@ -1,43 +0,0 @@ -#lang racket -(provide unload/free unload-value) -(require "types.rkt" - ffi/unsafe) - -;; Answer* -> Answer -(define (unload/free a) - (match a - ['err 'err] - [(cons h v) (begin0 (unload-value v) - (free h))])) - -;; Value* -> Value -(define (unload-value v) - (match v - [(? imm-bits?) (bits->value v)] - [(? box-bits? i) - (box (unload-value (heap-ref i)))] - [(? cons-bits? i) - (cons (unload-value (heap-ref (+ i 8))) - (unload-value (heap-ref i)))] - [(? vect-bits? i) - (if (zero? (untag i)) - (vector) - (build-vector (heap-ref i) - (lambda (j) - (unload-value (heap-ref (+ i (* 8 (add1 j))))))))] - [(? str-bits? i) - (if (zero? (untag i)) - (string) - (build-string (heap-ref i) - (lambda (j) - (char-ref (+ i 8) j))))])) - -(define (untag i) - (arithmetic-shift (arithmetic-shift i (- (integer-length ptr-mask))) - (integer-length ptr-mask))) - -(define (heap-ref i) - (ptr-ref (cast (untag i) _int64 _pointer) _int64)) - -(define (char-ref i j) - (integer->char (ptr-ref (cast (untag i) _int64 _pointer) _uint32 j))) diff --git a/langs/jig/values.c b/langs/jig/values.c index a61d65e6..62bca18c 100644 --- a/langs/jig/values.c +++ b/langs/jig/values.c @@ -38,6 +38,10 @@ int64_t val_unwrap_int(val_t x) { return x >> int_shift; } +val_t val_wrap_byte(unsigned char b) +{ + return (b << int_shift) | int_type_tag; +} val_t val_wrap_int(int64_t i) { return (i << int_shift) | int_type_tag; diff --git a/langs/jig/values.h b/langs/jig/values.h index 4cc48bbe..b6ac44f9 100644 --- a/langs/jig/values.h +++ b/langs/jig/values.h @@ -49,6 +49,7 @@ type_t val_typeof(val_t x); */ int64_t val_unwrap_int(val_t x); val_t val_wrap_int(int64_t i); +val_t val_wrap_byte(unsigned char b); int val_unwrap_bool(val_t x); val_t val_wrap_bool(int b); diff --git a/langs/knock/Makefile b/langs/knock/Makefile index 9055c88f..db6ac44a 100644 --- a/langs/knock/Makefile +++ b/langs/knock/Makefile @@ -37,7 +37,8 @@ runtime.o: $(objs) cat $< | racket -t compile-stdin.rkt -m > $@ clean: - rm *.o *.s *.run + @$(RM) *.o *.s *.run ||: + @echo "$(shell basename $(shell pwd)): cleaned!" %.test: %.run %.rkt @test "$(shell ./$(<))" = "$(shell racket $(word 2,$^))" diff --git a/langs/knock/ast.rkt b/langs/knock/ast.rkt deleted file mode 100644 index a8cfffa1..00000000 --- a/langs/knock/ast.rkt +++ /dev/null @@ -1,73 +0,0 @@ -#lang racket -(provide (all-defined-out)) - -;; type Prog = (Prog (Listof Defn) Expr) -(struct Prog (ds e) #:prefab) - -;; type Defn = (Defn Id (Listof Id) Expr) -(struct Defn (f xs e) #:prefab) - -;; type Expr = (Eof) -;; | (Empty) -;; | (Int Integer) -;; | (Bool Boolean) -;; | (Char Character) -;; | (Str String) -;; | (Prim0 Op0) -;; | (Prim1 Op1 Expr) -;; | (Prim2 Op2 Expr Expr) -;; | (Prim3 Op3 Expr Expr Expr) -;; | (If Expr Expr Expr) -;; | (Begin Expr Expr) -;; | (Let Id Expr Expr) -;; | (Var Id) -;; | (App Id (Listof Expr)) -;; | (Match Expr (Listof Pat) (Listof Expr)) -;; type Id = Symbol -;; type Op0 = 'read-byte -;; type Op1 = 'add1 | 'sub1 | 'zero? -;; | 'char? | 'integer->char | 'char->integer -;; | 'write-byte | 'eof-object? -;; | 'box | 'car | 'cdr | 'unbox -;; | 'empty? | 'cons? | 'box? -;; | 'vector? | vector-length -;; | 'string? | string-length -;; type Op2 = '+ | '- | '< | '= -;; | 'cons | 'eq? -;; | 'make-vector | 'vector-ref -;; | 'make-string | 'string-ref -;; type Op3 = 'vector-set! -;; type Pat = (PVar Id) -;; | (PWild) -;; | (PLit Lit) -;; | (PBox Pat) -;; | (PCons Pat Pat) -;; | (PAnd Pat Pat) -;; type Lit = Boolean -;; | Character -;; | Integer -;; | '() - -(struct Eof () #:prefab) -(struct Empty () #:prefab) -(struct Int (i) #:prefab) -(struct Bool (b) #:prefab) -(struct Char (c) #:prefab) -(struct Str (s) #:prefab) -(struct Prim0 (p) #:prefab) -(struct Prim1 (p e) #:prefab) -(struct Prim2 (p e1 e2) #:prefab) -(struct Prim3 (p e1 e2 e3) #:prefab) -(struct If (e1 e2 e3) #:prefab) -(struct Begin (e1 e2) #:prefab) -(struct Let (x e1 e2) #:prefab) -(struct Var (x) #:prefab) -(struct App (f es) #:prefab) -(struct Match (e ps es) #:prefab) - -(struct PVar (x) #:prefab) -(struct PWild () #:prefab) -(struct PLit (x) #:prefab) -(struct PBox (p) #:prefab) -(struct PCons (p1 p2) #:prefab) -(struct PAnd (p1 p2) #:prefab) diff --git a/langs/knock/build-runtime.rkt b/langs/knock/build-runtime.rkt deleted file mode 100644 index 1cc4da53..00000000 --- a/langs/knock/build-runtime.rkt +++ /dev/null @@ -1,12 +0,0 @@ -#lang racket -(provide runtime-path) - -(require racket/runtime-path) -(define-runtime-path here ".") - -(system (string-append "make -C '" - (path->string (normalize-path here)) - "' runtime.o")) - -(define runtime-path - (normalize-path (build-path here "runtime.o"))) \ No newline at end of file diff --git a/langs/knock/compile-ops.rkt b/langs/knock/compile-ops.rkt deleted file mode 100644 index 03b21812..00000000 --- a/langs/knock/compile-ops.rkt +++ /dev/null @@ -1,355 +0,0 @@ -#lang racket -(provide (all-defined-out)) -(require "ast.rkt" "types.rkt" a86/ast) - -(define rax 'rax) ; return -(define eax 'eax) ; 32-bit load/store -(define rbx 'rbx) ; heap -(define rdi 'rdi) ; arg -(define r8 'r8) ; scratch -(define r9 'r9) ; scratch -(define r10 'r10) ; scratch -(define r15 'r15) ; stack pad (non-volatile) -(define rsp 'rsp) ; stack - -;; Op0 -> Asm -(define (compile-op0 p) - (match p - ['void (seq (Mov rax (value->bits (void))))] - ['read-byte (seq pad-stack - (Call 'read_byte) - unpad-stack)] - ['peek-byte (seq pad-stack - (Call 'peek_byte) - unpad-stack)])) - -;; Op1 -> Asm -(define (compile-op1 p) - (match p - ['add1 - (seq (assert-integer rax) - (Add rax (value->bits 1)))] - ['sub1 - (seq (assert-integer rax) - (Sub rax (value->bits 1)))] - ['zero? - (seq (assert-integer rax) - (eq-value 0))] - ['char? - (type-pred mask-char type-char)] - ['char->integer - (seq (assert-char rax) - (Sar rax char-shift) - (Sal rax int-shift))] - ['integer->char - (seq (assert-codepoint rax) - (Sar rax int-shift) - (Sal rax char-shift) - (Xor rax type-char))] - ['eof-object? (eq-value eof)] - ['write-byte - (seq (assert-byte rax) - pad-stack - (Mov rdi rax) - (Call 'write_byte) - unpad-stack)] - ['box - (seq (Mov (Offset rbx 0) rax) - (Mov rax rbx) - (Or rax type-box) - (Add rbx 8))] - ['unbox - (seq (assert-box rax) - (Xor rax type-box) - (Mov rax (Offset rax 0)))] - ['car - (seq (assert-cons rax) - (Xor rax type-cons) - (Mov rax (Offset rax 8)))] - ['cdr - (seq (assert-cons rax) - (Xor rax type-cons) - (Mov rax (Offset rax 0)))] - ['empty? (eq-value '())] - ['box? - (type-pred ptr-mask type-box)] - ['cons? - (type-pred ptr-mask type-cons)] - ['vector? - (type-pred ptr-mask type-vect)] - ['string? - (type-pred ptr-mask type-str)] - ['vector-length - (let ((zero (gensym)) - (done (gensym))) - (seq (assert-vector rax) - (Xor rax type-vect) - (Cmp rax 0) - (Je zero) - (Mov rax (Offset rax 0)) - (Sal rax int-shift) - (Jmp done) - (Label zero) - (Mov rax 0) - (Label done)))] - ['string-length - (let ((zero (gensym)) - (done (gensym))) - (seq (assert-string rax) - (Xor rax type-str) - (Cmp rax 0) - (Je zero) - (Mov rax (Offset rax 0)) - (Sal rax int-shift) - (Jmp done) - (Label zero) - (Mov rax 0) - (Label done)))])) - -;; Op2 -> Asm -(define (compile-op2 p) - (match p - ['+ - (seq (Pop r8) - (assert-integer r8) - (assert-integer rax) - (Add rax r8))] - ['- - (seq (Pop r8) - (assert-integer r8) - (assert-integer rax) - (Sub r8 rax) - (Mov rax r8))] - ['< - (seq (Pop r8) - (assert-integer r8) - (assert-integer rax) - (Cmp r8 rax) - (if-lt))] - ['= - (seq (Pop r8) - (assert-integer r8) - (assert-integer rax) - (Cmp r8 rax) - (if-equal))] - ['cons - (seq (Mov (Offset rbx 0) rax) - (Pop rax) - (Mov (Offset rbx 8) rax) - (Mov rax rbx) - (Or rax type-cons) - (Add rbx 16))] - ['eq? - (seq (Pop r8) - (Cmp rax r8) - (if-equal))] - ['make-vector - (let ((loop (gensym)) - (done (gensym)) - (empty (gensym))) - (seq (Pop r8) - (assert-natural r8) - (Cmp r8 0) ; special case empty vector - (Je empty) - - (Mov r9 rbx) - (Or r9 type-vect) - - (Sar r8 int-shift) - (Mov (Offset rbx 0) r8) - (Add rbx 8) - - (Label loop) - (Mov (Offset rbx 0) rax) - (Add rbx 8) - (Sub r8 1) - (Cmp r8 0) - (Jne loop) - - (Mov rax r9) - (Jmp done) - - (Label empty) - (Mov rax type-vect) - (Label done)))] - - ['vector-ref - (seq (Pop r8) - (assert-vector r8) - (assert-integer rax) - (Cmp r8 type-vect) - (Je 'raise_error_align) ; special case for empty vector - (Cmp rax 0) - (Jl 'raise_error_align) - (Xor r8 type-vect) ; r8 = ptr - (Mov r9 (Offset r8 0)) ; r9 = len - (Sar rax int-shift) ; rax = index - (Sub r9 1) - (Cmp r9 rax) - (Jl 'raise_error_align) - (Sal rax 3) - (Add r8 rax) - (Mov rax (Offset r8 8)))] - - ['make-string - (let ((loop (gensym)) - (done (gensym)) - (empty (gensym))) - (seq (Pop r8) - (assert-natural r8) - (assert-char rax) - (Cmp r8 0) ; special case empty string - (Je empty) - - (Mov r9 rbx) - (Or r9 type-str) - - (Sar r8 int-shift) - (Mov (Offset rbx 0) r8) - (Add rbx 8) - - (Sar rax char-shift) - - (Add r8 1) ; adds 1 - (Sar r8 1) ; when - (Sal r8 1) ; len is odd - - (Label loop) - (Mov (Offset rbx 0) eax) - (Add rbx 4) - (Sub r8 1) - (Cmp r8 0) - (Jne loop) - - (Mov rax r9) - (Jmp done) - - (Label empty) - (Mov rax type-str) - (Label done)))] - - ['string-ref - (seq (Pop r8) - (assert-string r8) - (assert-integer rax) - (Cmp r8 type-str) - (Je 'raise_error_align) ; special case for empty string - (Cmp rax 0) - (Jl 'raise_error_align) - (Xor r8 type-str) ; r8 = ptr - (Mov r9 (Offset r8 0)) ; r9 = len - (Sar rax int-shift) ; rax = index - (Sub r9 1) - (Cmp r9 rax) - (Jl 'raise_error_align) - (Sal rax 2) - (Add r8 rax) - (Mov 'eax (Offset r8 8)) - (Sal rax char-shift) - (Or rax type-char))])) - -;; Op3 -> Asm -(define (compile-op3 p) - (match p - ['vector-set! - (seq (Pop r10) - (Pop r8) - (assert-vector r8) - (assert-integer r10) - (Cmp r10 0) - (Jl 'raise_error_align) - (Xor r8 type-vect) ; r8 = ptr - (Mov r9 (Offset r8 0)) ; r9 = len - (Sar r10 int-shift) ; r10 = index - (Sub r9 1) - (Cmp r9 r10) - (Jl 'raise_error_align) - (Sal r10 3) - (Add r8 r10) - (Mov (Offset r8 8) rax) - (Mov rax (value->bits (void))))])) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define (assert-type mask type) - (λ (arg) - (seq (Mov r9 arg) - (And r9 mask) - (Cmp r9 type) - (Jne 'raise_error_align)))) - -(define (type-pred mask type) - (let ((l (gensym))) - (seq (And rax mask) - (Cmp rax type) - (Mov rax (value->bits #t)) - (Je l) - (Mov rax (value->bits #f)) - (Label l)))) - -(define assert-integer - (assert-type mask-int type-int)) -(define assert-char - (assert-type mask-char type-char)) -(define assert-box - (assert-type ptr-mask type-box)) -(define assert-cons - (assert-type ptr-mask type-cons)) -(define assert-vector - (assert-type ptr-mask type-vect)) -(define assert-string - (assert-type ptr-mask type-str)) - -(define (assert-codepoint r) - (let ((ok (gensym))) - (seq (assert-integer r) - (Cmp r (value->bits 0)) - (Jl 'raise_error_align) - (Cmp r (value->bits 1114111)) - (Jg 'raise_error_align) - (Cmp r (value->bits 55295)) - (Jl ok) - (Cmp r (value->bits 57344)) - (Jg ok) - (Jmp 'raise_error_align) - (Label ok)))) - -(define (assert-byte r) - (seq (assert-integer r) - (Cmp r (value->bits 0)) - (Jl 'raise_error_align) - (Cmp r (value->bits 255)) - (Jg 'raise_error_align))) - -(define (assert-natural r) - (seq (assert-integer r) - (Cmp r (value->bits 0)) - (Jl 'raise_error_align))) - -;; -> Asm -;; set rax to #t or #f based on given comparison -(define (if-compare c) - (seq (Mov rax (value->bits #f)) - (Mov r9 (value->bits #t)) - (c rax r9))) - -(define (if-equal) (if-compare Cmove)) -(define (if-lt) (if-compare Cmovl)) - -;; Value -> Asm -(define (eq-value v) - (seq (Cmp rax (value->bits v)) - (if-equal))) - -;; Asm -;; Dynamically pad the stack to be aligned for a call -(define pad-stack - (seq (Mov r15 rsp) - (And r15 #b1000) - (Sub rsp r15))) - -;; Asm -;; Undo the stack alignment after a call -(define unpad-stack - (seq (Add rsp r15))) diff --git a/langs/knock/compile-stdin.rkt b/langs/knock/compile-stdin.rkt deleted file mode 100644 index cfa15106..00000000 --- a/langs/knock/compile-stdin.rkt +++ /dev/null @@ -1,10 +0,0 @@ -#lang racket -(provide main) -(require "parse.rkt" "compile.rkt" "read-all.rkt" a86/printer) - -;; -> Void -;; Compile contents of stdin, -;; emit asm code on stdout -(define (main) - (read-line) ; ignore #lang racket line - (asm-display (compile (parse (read-all))))) diff --git a/langs/knock/compile.rkt b/langs/knock/compile.rkt deleted file mode 100644 index 8840cb36..00000000 --- a/langs/knock/compile.rkt +++ /dev/null @@ -1,319 +0,0 @@ -#lang racket -(provide (all-defined-out)) -(require "ast.rkt" "types.rkt" "compile-ops.rkt" a86/ast) - -;; Registers used -(define rax 'rax) ; return -(define rbx 'rbx) ; heap -(define rsp 'rsp) ; stack -(define rdi 'rdi) ; arg -(define r15 'r15) ; stack pad (non-volatile) - -;; type CEnv = (Listof [Maybe Id]) - -;; Prog -> Asm -(define (compile p) - (match p - [(Prog ds e) - (prog (externs) - (Global 'entry) - (Label 'entry) - (Push rbx) ; save callee-saved register - (Push r15) - (Mov rbx rdi) ; recv heap pointer - (compile-e e '() #f) - (Pop r15) ; restore callee-save register - (Pop rbx) - (Ret) - (compile-defines ds) - (Label 'raise_error_align) - pad-stack - (Call 'raise_error))])) - -(define (externs) - (seq (Extern 'peek_byte) - (Extern 'read_byte) - (Extern 'write_byte) - (Extern 'raise_error))) - -;; [Listof Defn] -> Asm -(define (compile-defines ds) - (match ds - ['() (seq)] - [(cons d ds) - (seq (compile-define d) - (compile-defines ds))])) - -;; Defn -> Asm -(define (compile-define d) - (match d - [(Defn f xs e) - (seq (Label (symbol->label f)) - (compile-e e (reverse xs) #t) - (Add rsp (* 8 (length xs))) ; pop args - (Ret))])) - -;; Expr CEnv Bool -> Asm -(define (compile-e e c t?) - (match e - [(Int i) (compile-value i)] - [(Bool b) (compile-value b)] - [(Char c) (compile-value c)] - [(Eof) (compile-value eof)] - [(Empty) (compile-value '())] - [(Var x) (compile-variable x c)] - [(Str s) (compile-string s)] - [(Prim0 p) (compile-prim0 p c)] - [(Prim1 p e) (compile-prim1 p e c)] - [(Prim2 p e1 e2) (compile-prim2 p e1 e2 c)] - [(Prim3 p e1 e2 e3) (compile-prim3 p e1 e2 e3 c)] - [(If e1 e2 e3) (compile-if e1 e2 e3 c t?)] - [(Begin e1 e2) (compile-begin e1 e2 c t?)] - [(Let x e1 e2) (compile-let x e1 e2 c t?)] - [(App f es) (compile-app f es c t?)] - [(Match e ps es) (compile-match e ps es c t?)])) - -;; Value -> Asm -(define (compile-value v) - (seq (Mov rax (value->bits v)))) - -;; Id CEnv -> Asm -(define (compile-variable x c) - (let ((i (lookup x c))) - (seq (Mov rax (Offset rsp i))))) - -;; String -> Asm -(define (compile-string s) - (let ((len (string-length s))) - (if (zero? len) - (seq (Mov rax type-str)) - (seq (Mov rax len) - (Mov (Offset rbx 0) rax) - (compile-string-chars (string->list s) 8) - (Mov rax rbx) - (Or rax type-str) - (Add rbx - (+ 8 (* 4 (if (odd? len) (add1 len) len)))))))) - -;; [Listof Char] Integer -> Asm -(define (compile-string-chars cs i) - (match cs - ['() (seq)] - [(cons c cs) - (seq (Mov rax (char->integer c)) - (Mov (Offset rbx i) 'eax) - (compile-string-chars cs (+ 4 i)))])) - -;; Op0 CEnv -> Asm -(define (compile-prim0 p c) - (compile-op0 p)) - -;; Op1 Expr CEnv -> Asm -(define (compile-prim1 p e c) - (seq (compile-e e c #f) - (compile-op1 p))) - -;; Op2 Expr Expr CEnv -> Asm -(define (compile-prim2 p e1 e2 c) - (seq (compile-e e1 c #f) - (Push rax) - (compile-e e2 (cons #f c) #f) - (compile-op2 p))) - -;; Op3 Expr Expr Expr CEnv -> Asm -(define (compile-prim3 p e1 e2 e3 c) - (seq (compile-e e1 c #f) - (Push rax) - (compile-e e2 (cons #f c) #f) - (Push rax) - (compile-e e3 (cons #f (cons #f c)) #f) - (compile-op3 p))) - -;; Expr Expr Expr CEnv Bool -> Asm -(define (compile-if e1 e2 e3 c t?) - (let ((l1 (gensym 'if)) - (l2 (gensym 'if))) - (seq (compile-e e1 c #f) - (Cmp rax val-false) - (Je l1) - (compile-e e2 c t?) - (Jmp l2) - (Label l1) - (compile-e e3 c t?) - (Label l2)))) - -;; Expr Expr CEnv Bool -> Asm -(define (compile-begin e1 e2 c t?) - (seq (compile-e e1 c #f) - (compile-e e2 c t?))) - -;; Id Expr Expr CEnv Bool -> Asm -(define (compile-let x e1 e2 c t?) - (seq (compile-e e1 c #f) - (Push rax) - (compile-e e2 (cons x c) t?) - (Add rsp 8))) - -;; Id [Listof Expr] CEnv Bool -> Asm -(define (compile-app f es c t?) - (if t? - (compile-app-tail f es c) - (compile-app-nontail f es c))) - -;; Id [Listof Expr] CEnv -> Asm -(define (compile-app-tail f es c) - (seq (compile-es es c) - (move-args (length es) (length c)) - (Add rsp (* 8 (length c))) - (Jmp (symbol->label f)))) - -;; Integer Integer -> Asm -(define (move-args i off) - (cond [(zero? off) (seq)] - [(zero? i) (seq)] - [else - (seq (Mov r8 (Offset rsp (* 8 (sub1 i)))) - (Mov (Offset rsp (* 8 (+ off (sub1 i)))) r8) - (move-args (sub1 i) off))])) - -;; Id [Listof Expr] CEnv -> Asm -;; The return address is placed above the arguments, so callee pops -;; arguments and return address is next frame -(define (compile-app-nontail f es c) - (let ((r (gensym 'ret))) - (seq (Lea rax r) - (Push rax) - (compile-es es (cons #f c)) - (Jmp (symbol->label f)) - (Label r)))) - -;; [Listof Expr] CEnv -> Asm -(define (compile-es es c) - (match es - ['() '()] - [(cons e es) - (seq (compile-e e c #f) - (Push rax) - (compile-es es (cons #f c)))])) - -;; Expr [Listof Pat] [Listof Expr] CEnv Bool -> Asm -(define (compile-match e ps es c t?) - (let ((done (gensym))) - (seq (compile-e e c #f) - (Push rax) ; save away to be restored by each clause - (compile-match-clauses ps es (cons #f c) done t?) - (Jmp 'raise_error_align) - (Label done) - (Add rsp 8)))) ; pop the saved value being matched - -;; [Listof Pat] [Listof Expr] CEnv Symbol Bool -> Asm -(define (compile-match-clauses ps es c done t?) - (match* (ps es) - [('() '()) (seq)] - [((cons p ps) (cons e es)) - (seq (compile-match-clause p e c done t?) - (compile-match-clauses ps es c done t?))])) - -;; Pat Expr CEnv Symbol Bool -> Asm -(define (compile-match-clause p e c done t?) - (let ((next (gensym))) - (match (compile-pattern p '() next) - [(list i cm) - (seq (Mov rax (Offset rsp 0)) ; restore value being matched - i - (compile-e e (append cm c) t?) - (Add rsp (* 8 (length cm))) - (Jmp done) - (Label next))]))) - -;; Pat CEnv Symbol -> (list Asm CEnv) -(define (compile-pattern p cm next) - (match p - [(PWild) - (list (seq) cm)] - [(PVar x) - (list (seq (Push rax)) (cons x cm))] - [(PLit l) - (let ((ok (gensym))) - (list (seq (Cmp rax (value->bits l)) - (Je ok) - (Add rsp (* 8 (length cm))) - (Jmp next) - (Label ok)) - cm))] - [(PAnd p1 p2) - (match (compile-pattern p1 (cons #f cm) next) - [(list i1 cm1) - (match (compile-pattern p2 cm1 next) - [(list i2 cm2) - (list - (seq (Push rax) - i1 - (Mov rax (Offset rsp (* 8 (- (sub1 (length cm1)) (length cm))))) - i2) - cm2)])])] - [(PBox p) - (match (compile-pattern p cm next) - [(list i1 cm1) - (let ((ok (gensym))) - (list - (seq (Mov r8 rax) - (And r8 ptr-mask) - (Cmp r8 type-box) - (Je ok) - (Add rsp (* 8 (length cm))) ; haven't pushed anything yet - (Jmp next) - (Label ok) - (Xor rax type-box) - (Mov rax (Offset rax 0)) - i1) - cm1))])] - [(PCons p1 p2) - (match (compile-pattern p1 (cons #f cm) next) - [(list i1 cm1) - (match (compile-pattern p2 cm1 next) - [(list i2 cm2) - (let ((ok (gensym))) - (list - (seq (Mov r8 rax) - (And r8 ptr-mask) - (Cmp r8 type-cons) - (Je ok) - (Add rsp (* 8 (length cm))) ; haven't pushed anything yet - (Jmp next) - (Label ok) - (Xor rax type-cons) - (Mov r8 (Offset rax 0)) - (Push r8) ; push cdr - (Mov rax (Offset rax 8)) ; mov rax car - i1 - (Mov rax (Offset rsp (* 8 (- (sub1 (length cm1)) (length cm))))) - i2) - cm2))])])])) - -;; Id CEnv -> Integer -(define (lookup x cenv) - (match cenv - ['() (error "undefined variable:" x)] - [(cons y rest) - (match (eq? x y) - [#t 0] - [#f (+ 8 (lookup x rest))])])) - -;; Symbol -> Label -;; Produce a symbol that is a valid Nasm 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/langs/knock/info.rkt b/langs/knock/info.rkt new file mode 100644 index 00000000..41ec40bb --- /dev/null +++ b/langs/knock/info.rkt @@ -0,0 +1,2 @@ +#lang info +(define pre-install-collection "../installer.rkt") diff --git a/langs/knock/interp-io.rkt b/langs/knock/interp-io.rkt deleted file mode 100644 index 93f7d3c6..00000000 --- a/langs/knock/interp-io.rkt +++ /dev/null @@ -1,12 +0,0 @@ -#lang racket -(provide interp/io) -(require "interp.rkt") - -;; (Expr String -> String -;; Interpret e with given string as input, -;; collect output as string (including printed result) -(define (interp/io e in) - (parameterize ((current-output-port (open-output-string)) - (current-input-port (open-input-string in))) - (cons (interp e) - (get-output-string (current-output-port))))) diff --git a/langs/knock/interp-stdin.rkt b/langs/knock/interp-stdin.rkt deleted file mode 100644 index 965b9cc4..00000000 --- a/langs/knock/interp-stdin.rkt +++ /dev/null @@ -1,12 +0,0 @@ -#lang racket -(provide main) -(require "parse.rkt" "interp.rkt" "read-all.rkt") - -;; -> Void -;; Parse and interpret contents of stdin, -;; print result on stdout -(define (main) - (read-line) ; ignore #lang racket line - (let ((r (interp (parse (read-all))))) - (unless (void? r) - (println r)))) diff --git a/langs/knock/interp.rkt b/langs/knock/interp.rkt deleted file mode 100644 index d57fa7cb..00000000 --- a/langs/knock/interp.rkt +++ /dev/null @@ -1,145 +0,0 @@ -#lang racket -(provide interp interp-env interp-match-pat interp-match) -(require "ast.rkt" - "env.rkt" - "interp-prims.rkt") - -;; type Answer = Value | 'err - -;; type Value = -;; | Integer -;; | Boolean -;; | Character -;; | Eof -;; | Void -;; | '() -;; | (cons Value Value) -;; | (box Value) -;; | (vector Value ...) -;; | (string Char ...) - -;; type REnv = (Listof (List Id Value)) -;; type Defns = (Listof Defn) - -;; Prog -> Answer -(define (interp p) - (match p - [(Prog ds e) - (interp-env e '() ds)])) - -;; Expr Env Defns -> Answer -(define (interp-env e r ds) - (match e - [(Int i) i] - [(Bool b) b] - [(Char c) c] - [(Eof) eof] - [(Empty) '()] - [(Var x) (lookup r x)] - [(Str s) s] - [(Prim0 'void) (void)] - [(Prim0 'read-byte) (read-byte)] - [(Prim0 'peek-byte) (peek-byte)] - [(Prim1 p e) - (match (interp-env e r ds) - ['err 'err] - [v (interp-prim1 p v)])] - [(Prim2 p e1 e2) - (match (interp-env e1 r ds) - ['err 'err] - [v1 (match (interp-env e2 r ds) - ['err 'err] - [v2 (interp-prim2 p v1 v2)])])] - [(Prim3 p e1 e2 e3) - (match (interp-env e1 r ds) - ['err 'err] - [v1 (match (interp-env e2 r ds) - ['err 'err] - [v2 (match (interp-env e3 r ds) - ['err 'err] - [v3 (interp-prim3 p v1 v2 v3)])])])] - [(If p e1 e2) - (match (interp-env p r ds) - ['err 'err] - [v - (if v - (interp-env e1 r ds) - (interp-env e2 r ds))])] - [(Begin e1 e2) - (match (interp-env e1 r ds) - ['err 'err] - [_ (interp-env e2 r ds)])] - [(Let x e1 e2) - (match (interp-env e1 r ds) - ['err 'err] - [v (interp-env e2 (ext r x v) ds)])] - [(App f es) - (match (interp-env* es r ds) - ['err 'err] - [vs - (match (defns-lookup ds f) - [(Defn f xs e) - ; check arity matches - (if (= (length xs) (length vs)) - (interp-env e (zip xs vs) ds) - 'err)])])] - [(Match e ps es) - (match (interp-env e r ds) - ['err 'err] - [v - (interp-match v ps es r ds)])])) - -;; Value [Listof Pat] [Listof Expr] Env Defns -> Answer -(define (interp-match v ps es r ds) - (match* (ps es) - [('() '()) 'err] - [((cons p ps) (cons e es)) - (match (interp-match-pat p v r) - [#f (interp-match v ps es r ds)] - [r (interp-env e r ds)])])) - -;; Pat Value Env -> [Maybe Env] -(define (interp-match-pat p v r) - (match p - [(PWild) r] - [(PVar x) (ext r x v)] - [(PLit l) (and (eqv? l v) r)] - [(PBox p) - (match v - [(box v) - (interp-match-pat p v r)] - [_ #f])] - [(PCons p1 p2) - (match v - [(cons v1 v2) - (match (interp-match-pat p1 v1 r) - [#f #f] - [r1 (interp-match-pat p2 v2 r1)])] - [_ #f])] - [(PAnd p1 p2) - (match (interp-match-pat p1 v r) - [#f #f] - [r1 (interp-match-pat p2 v r1)])])) - -;; (Listof Expr) REnv Defns -> (Listof Value) | 'err -(define (interp-env* es r ds) - (match es - ['() '()] - [(cons e es) - (match (interp-env e r ds) - ['err 'err] - [v (match (interp-env* es r ds) - ['err 'err] - [vs (cons v vs)])])])) - -;; Defns Symbol -> Defn -(define (defns-lookup ds f) - (findf (match-lambda [(Defn g _ _) (eq? f g)]) - ds)) - -(define (zip xs ys) - (match* (xs ys) - [('() '()) '()] - [((cons x xs) (cons y ys)) - (cons (list x y) - (zip xs ys))])) diff --git a/langs/knock/io.c b/langs/knock/io.c index 7ef82281..8a417c91 100644 --- a/langs/knock/io.c +++ b/langs/knock/io.c @@ -7,14 +7,14 @@ val_t read_byte(void) { char c = getc(in); - return (c == EOF) ? val_wrap_eof() : val_wrap_int(c); + return (c == EOF) ? val_wrap_eof() : val_wrap_byte(c); } val_t peek_byte(void) { char c = getc(in); ungetc(c, in); - return (c == EOF) ? val_wrap_eof() : val_wrap_int(c); + return (c == EOF) ? val_wrap_eof() : val_wrap_byte(c); } diff --git a/langs/knock/parse.rkt b/langs/knock/parse.rkt deleted file mode 100644 index 1c6de40a..00000000 --- a/langs/knock/parse.rkt +++ /dev/null @@ -1,93 +0,0 @@ -#lang racket -(provide parse parse-define parse-e) -(require "ast.rkt") - -;; [Listof S-Expr] -> Prog -(define (parse s) - (match s - [(cons (and (cons 'define _) d) s) - (match (parse s) - [(Prog ds e) - (Prog (cons (parse-define d) ds) e)])] - [(cons e '()) (Prog '() (parse-e e))] - [_ (error "program parse error")])) - -;; S-Expr -> Defn -(define (parse-define s) - (match s - [(list 'define (list-rest (? symbol? f) xs) e) - (if (andmap symbol? xs) - (Defn f xs (parse-e e)) - (error "parse definition error"))] - [_ (error "Parse defn error" s)])) - -;; S-Expr -> Expr -(define (parse-e s) - (match s - [(? exact-integer?) (Int s)] - [(? boolean?) (Bool s)] - [(? char?) (Char s)] - [(? string?) (Str s)] - ['eof (Eof)] - [(? symbol?) (Var s)] - [(list 'quote (list)) (Empty)] - [(list (? (op? op0) p0)) (Prim0 p0)] - [(list (? (op? op1) p1) e) (Prim1 p1 (parse-e e))] - [(list (? (op? op2) p2) e1 e2) (Prim2 p2 (parse-e e1) (parse-e e2))] - [(list (? (op? op3) p3) e1 e2 e3) - (Prim3 p3 (parse-e e1) (parse-e e2) (parse-e e3))] - [(list 'begin e1 e2) - (Begin (parse-e e1) (parse-e e2))] - [(list 'if e1 e2 e3) - (If (parse-e e1) (parse-e e2) (parse-e e3))] - [(list 'let (list (list (? symbol? x) e1)) e2) - (Let x (parse-e e1) (parse-e e2))] - [(cons 'match (cons e ms)) - (parse-match (parse-e e) ms)] - [(cons (? symbol? f) es) - (App f (map parse-e es))] - [_ (error "Parse error" s)])) - -(define (parse-match e ms) - (match ms - ['() (Match e '() '())] - [(cons (list p r) ms) - (match (parse-match e ms) - [(Match e ps es) - (Match e - (cons (parse-pat p) ps) - (cons (parse-e r) es))])])) - -(define (parse-pat p) - (match p - [(? boolean?) (PLit p)] - [(? exact-integer?) (PLit p)] - [(? char?) (PLit p)] - ['_ (PWild)] - [(? symbol?) (PVar p)] - [(list 'quote (list)) - (PLit '())] - [(list 'box p) - (PBox (parse-pat p))] - [(list 'cons p1 p2) - (PCons (parse-pat p1) (parse-pat p2))] - [(list 'and p1 p2) - (PAnd (parse-pat p1) (parse-pat p2))])) - -(define op0 - '(read-byte peek-byte void)) - -(define op1 - '(add1 sub1 zero? char? write-byte eof-object? - integer->char char->integer - box unbox empty? cons? box? car cdr - vector? vector-length string? string-length)) -(define op2 - '(+ - < = cons eq? make-vector vector-ref make-string string-ref)) -(define op3 - '(vector-set!)) - -(define (op? ops) - (λ (x) - (and (symbol? x) - (memq x ops)))) diff --git a/langs/knock/read-all.rkt b/langs/knock/read-all.rkt deleted file mode 100644 index 8a3289a5..00000000 --- a/langs/knock/read-all.rkt +++ /dev/null @@ -1,8 +0,0 @@ -#lang racket -(provide read-all) -;; read all s-expression until eof -(define (read-all) - (let ((r (read))) - (if (eof-object? r) - '() - (cons r (read-all))))) diff --git a/langs/knock/test/compile.rkt b/langs/knock/test/compile.rkt deleted file mode 100644 index 81defae6..00000000 --- a/langs/knock/test/compile.rkt +++ /dev/null @@ -1,18 +0,0 @@ -#lang racket -(require "test-runner.rkt" - "../parse.rkt" - "../compile.rkt" - "../unload-bits-asm.rkt" - a86/interp) - -;; link with runtime for IO operations -(unless (file-exists? "../runtime.o") - (system "make -C .. runtime.o")) -(current-objs - (list (path->string (normalize-path "../runtime.o")))) - -(test-runner (λ p (unload/free (asm-interp (compile (parse p)))))) -(test-runner-io (λ (s . p) - (match (asm-interp/io (compile (parse p)) s) - ['err 'err] - [(cons r o) (cons (unload/free r) o)]))) diff --git a/langs/knock/test/interp.rkt b/langs/knock/test/interp.rkt deleted file mode 100644 index cd7b654e..00000000 --- a/langs/knock/test/interp.rkt +++ /dev/null @@ -1,8 +0,0 @@ -#lang racket -(require "test-runner.rkt" - "../parse.rkt" - "../interp.rkt" - "../interp-io.rkt") - -(test-runner (λ p (interp (parse p)))) -(test-runner-io (λ (s . p) (interp/io (parse p) s))) diff --git a/langs/knock/test/test-runner.rkt b/langs/knock/test/test-runner.rkt deleted file mode 100644 index 50a8daf4..00000000 --- a/langs/knock/test/test-runner.rkt +++ /dev/null @@ -1,303 +0,0 @@ -#lang racket -(provide test-runner test-runner-io) -(require rackunit) - -(define (test-runner run) - ;; Abscond examples - (check-equal? (run 7) 7) - (check-equal? (run -8) -8) - - ;; Blackmail examples - (check-equal? (run '(add1 (add1 7))) 9) - (check-equal? (run '(add1 (sub1 7))) 7) - - ;; Con examples - (check-equal? (run '(if (zero? 0) 1 2)) 1) - (check-equal? (run '(if (zero? 1) 1 2)) 2) - (check-equal? (run '(if (zero? -7) 1 2)) 2) - (check-equal? (run '(if (zero? 0) - (if (zero? 1) 1 2) - 7)) - 2) - (check-equal? (run '(if (zero? (if (zero? 0) 1 0)) - (if (zero? 1) 1 2) - 7)) - 7) - - ;; Dupe examples - (check-equal? (run #t) #t) - (check-equal? (run #f) #f) - (check-equal? (run '(if #t 1 2)) 1) - (check-equal? (run '(if #f 1 2)) 2) - (check-equal? (run '(if 0 1 2)) 1) - (check-equal? (run '(if #t 3 4)) 3) - (check-equal? (run '(if #f 3 4)) 4) - (check-equal? (run '(if 0 3 4)) 3) - (check-equal? (run '(zero? 4)) #f) - (check-equal? (run '(zero? 0)) #t) - - ;; Dodger examples - (check-equal? (run #\a) #\a) - (check-equal? (run #\b) #\b) - (check-equal? (run '(char? #\a)) #t) - (check-equal? (run '(char? #t)) #f) - (check-equal? (run '(char? 8)) #f) - (check-equal? (run '(char->integer #\a)) (char->integer #\a)) - (check-equal? (run '(integer->char 955)) #\λ) - - ;; Extort examples - (check-equal? (run '(add1 #f)) 'err) - (check-equal? (run '(sub1 #f)) 'err) - (check-equal? (run '(zero? #f)) 'err) - (check-equal? (run '(char->integer #f)) 'err) - (check-equal? (run '(integer->char #f)) 'err) - (check-equal? (run '(integer->char -1)) 'err) - (check-equal? (run '(write-byte #f)) 'err) - (check-equal? (run '(write-byte -1)) 'err) - (check-equal? (run '(write-byte 256)) 'err) - - ;; Fraud examples - (check-equal? (run '(let ((x 7)) x)) 7) - (check-equal? (run '(let ((x 7)) 2)) 2) - (check-equal? (run '(let ((x 7)) (add1 x))) 8) - (check-equal? (run '(let ((x (add1 7))) x)) 8) - (check-equal? (run '(let ((x 7)) (let ((y 2)) x))) 7) - (check-equal? (run '(let ((x 7)) (let ((x 2)) x))) 2) - (check-equal? (run '(let ((x 7)) (let ((x (add1 x))) x))) 8) - - (check-equal? (run '(let ((x 0)) - (if (zero? x) 7 8))) - 7) - (check-equal? (run '(let ((x 1)) - (add1 (if (zero? x) 7 8)))) - 9) - (check-equal? (run '(+ 3 4)) 7) - (check-equal? (run '(- 3 4)) -1) - (check-equal? (run '(+ (+ 2 1) 4)) 7) - (check-equal? (run '(+ (+ 2 1) (+ 2 2))) 7) - (check-equal? (run '(let ((x (+ 1 2))) - (let ((z (- 4 x))) - (+ (+ x x) z)))) - 7) - (check-equal? (run '(= 5 5)) #t) - (check-equal? (run '(= 4 5)) #f) - (check-equal? (run '(= (add1 4) 5)) #t) - (check-equal? (run '(< 5 5)) #f) - (check-equal? (run '(< 4 5)) #t) - (check-equal? (run '(< (add1 4) 5)) #f) - - ;; Hustle examples - (check-equal? (run ''()) '()) - (check-equal? (run '(box 1)) (box 1)) - (check-equal? (run '(box -1)) (box -1)) - (check-equal? (run '(cons 1 2)) (cons 1 2)) - (check-equal? (run '(unbox (box 1))) 1) - (check-equal? (run '(car (cons 1 2))) 1) - (check-equal? (run '(cdr (cons 1 2))) 2) - (check-equal? (run '(cons 1 '())) (list 1)) - (check-equal? (run '(let ((x (cons 1 2))) - (begin (cdr x) - (car x)))) - 1) - (check-equal? (run '(let ((x (cons 1 2))) - (let ((y (box 3))) - (unbox y)))) - 3) - (check-equal? (run '(eq? 1 1)) #t) - (check-equal? (run '(eq? 1 2)) #f) - (check-equal? (run '(eq? (cons 1 2) (cons 1 2))) #f) - (check-equal? (run '(let ((x (cons 1 2))) (eq? x x))) #t) - - ;; Hoax examples - (check-equal? (run '(make-vector 0 0)) #()) - (check-equal? (run '(make-vector 1 0)) #(0)) - (check-equal? (run '(make-vector 3 0)) #(0 0 0)) - (check-equal? (run '(make-vector 3 5)) #(5 5 5)) - (check-equal? (run '(vector? (make-vector 0 0))) #t) - (check-equal? (run '(vector? (cons 0 0))) #f) - (check-equal? (run '(vector-ref (make-vector 0 #f) 0)) 'err) - (check-equal? (run '(vector-ref (make-vector 3 5) -1)) 'err) - (check-equal? (run '(vector-ref (make-vector 3 5) 0)) 5) - (check-equal? (run '(vector-ref (make-vector 3 5) 1)) 5) - (check-equal? (run '(vector-ref (make-vector 3 5) 2)) 5) - (check-equal? (run '(vector-ref (make-vector 3 5) 3)) 'err) - (check-equal? (run '(let ((x (make-vector 3 5))) - (begin (vector-set! x 0 4) - x))) - #(4 5 5)) - (check-equal? (run '(let ((x (make-vector 3 5))) - (begin (vector-set! x 1 4) - x))) - #(5 4 5)) - (check-equal? (run '(vector-length (make-vector 3 #f))) 3) - (check-equal? (run '(vector-length (make-vector 0 #f))) 0) - (check-equal? (run '"") "") - (check-equal? (run '"fred") "fred") - (check-equal? (run '"wilma") "wilma") - (check-equal? (run '(make-string 0 #\f)) "") - (check-equal? (run '(make-string 3 #\f)) "fff") - (check-equal? (run '(make-string 3 #\g)) "ggg") - (check-equal? (run '(string-length "")) 0) - (check-equal? (run '(string-length "fred")) 4) - (check-equal? (run '(string-ref "" 0)) 'err) - (check-equal? (run '(string-ref (make-string 0 #\a) 0)) 'err) - (check-equal? (run '(string-ref "fred" 0)) #\f) - (check-equal? (run '(string-ref "fred" 1)) #\r) - (check-equal? (run '(string-ref "fred" 2)) #\e) - (check-equal? (run '(string-ref "fred" 4)) 'err) - (check-equal? (run '(string? "fred")) #t) - (check-equal? (run '(string? (cons 1 2))) #f) - (check-equal? (run '(begin (make-string 3 #\f) - (make-string 3 #\f))) - "fff") - - ;; Iniquity tests - (check-equal? (run - '(define (f x) x) - '(f 5)) - 5) - (check-equal? (run - '(define (tri x) - (if (zero? x) - 0 - (+ x (tri (sub1 x))))) - '(tri 9)) - 45) - - (check-equal? (run - '(define (even? x) - (if (zero? x) - #t - (odd? (sub1 x)))) - '(define (odd? x) - (if (zero? x) - #f - (even? (sub1 x)))) - '(even? 101)) - #f) - - (check-equal? (run - '(define (map-add1 xs) - (if (empty? xs) - '() - (cons (add1 (car xs)) - (map-add1 (cdr xs))))) - '(map-add1 (cons 1 (cons 2 (cons 3 '()))))) - '(2 3 4)) - (check-equal? (run - '(define (f x) - 10) - '(f 1)) - 10) - (check-equal? (run - ' (define (f x) - 10) - '(let ((x 2)) (f 1))) - 10) - (check-equal? (run - '(define (f x y) - 10) - '(f 1 2)) - 10) - (check-equal? (run - '(define (f x y) - 10) - '(let ((z 2)) (f 1 2))) - 10) - (check-equal? (run '(define (f x y) y) - '(f 1 (add1 #f))) - 'err) - - ;; Knock examples - (check-equal? (run '(match 1)) 'err) - (check-equal? (run '(match 1 [1 2])) - 2) - (check-equal? (run '(match 1 [2 1] [1 2])) - 2) - (check-equal? (run '(match 1 [2 1] [1 2] [0 3])) - 2) - (check-equal? (run '(match 1 [2 1] [0 3])) - 'err) - (check-equal? (run '(match 1 [_ 2] [_ 3])) - 2) - (check-equal? (run '(match 1 [x 2] [_ 3])) - 2) - (check-equal? (run '(match 1 [x x] [_ 3])) - 1) - (check-equal? (run '(match (cons 1 2) [x x] [_ 3])) - (cons 1 2)) - (check-equal? (run '(match (cons 1 2) [(cons x y) x] [_ 3])) - 1) - (check-equal? (run '(match (cons 1 2) [(cons x 2) x] [_ 3])) - 1) - (check-equal? (run '(match (cons 1 2) [(cons 3 2) 0] [_ 3])) - 3) - (check-equal? (run '(match 1 [(cons x y) x] [_ 3])) - 3) - (check-equal? (run '(match (cons 1 2) [(cons 1 3) 0] [(cons 1 y) y] [_ 3])) - 2) - (check-equal? (run '(match (box 1) [(box 1) 0] [_ 1])) - 0) - (check-equal? (run '(match (box 1) [(box 2) 0] [_ 1])) - 1) - (check-equal? (run '(match (box 1) [(box x) x] [_ 2])) - 1)) - -(define (test-runner-io run) - ;; Evildoer examples - (check-equal? (run "" 7) (cons 7 "")) - (check-equal? (run "" '(write-byte 97)) (cons (void) "a")) - (check-equal? (run "a" '(read-byte)) (cons 97 "")) - (check-equal? (run "b" '(begin (write-byte 97) (read-byte))) - (cons 98 "a")) - (check-equal? (run "" '(read-byte)) (cons eof "")) - (check-equal? (run "" '(eof-object? (read-byte))) (cons #t "")) - (check-equal? (run "a" '(eof-object? (read-byte))) (cons #f "")) - (check-equal? (run "" '(begin (write-byte 97) (write-byte 98))) - (cons (void) "ab")) - - (check-equal? (run "ab" '(peek-byte)) (cons 97 "")) - (check-equal? (run "ab" '(begin (peek-byte) (read-byte))) (cons 97 "")) - ;; Extort examples - (check-equal? (run "" '(write-byte #t)) (cons 'err "")) - - ;; Fraud examples - (check-equal? (run "" '(let ((x 97)) (write-byte x))) (cons (void) "a")) - (check-equal? (run "" - '(let ((x 97)) - (begin (write-byte x) - x))) - (cons 97 "a")) - (check-equal? (run "b" '(let ((x 97)) (begin (read-byte) x))) - (cons 97 "")) - (check-equal? (run "b" '(let ((x 97)) (begin (peek-byte) x))) - (cons 97 "")) - - ;; Hustle examples - (check-equal? (run "" - '(let ((x 1)) - (begin (write-byte 97) - 1))) - (cons 1 "a")) - - (check-equal? (run "" - '(let ((x 1)) - (let ((y 2)) - (begin (write-byte 97) - 1)))) - (cons 1 "a")) - - (check-equal? (run "" - '(let ((x (cons 1 2))) - (begin (write-byte 97) - (car x)))) - (cons 1 "a")) - ;; Iniquity examples - (check-equal? (run "" - '(define (print-alphabet i) - (if (zero? i) - (void) - (begin (write-byte (- 123 i)) - (print-alphabet (sub1 i))))) - '(print-alphabet 26)) - (cons (void) "abcdefghijklmnopqrstuvwxyz"))) diff --git a/langs/knock/types.rkt b/langs/knock/types.rkt deleted file mode 100644 index 986ebc6c..00000000 --- a/langs/knock/types.rkt +++ /dev/null @@ -1,67 +0,0 @@ -#lang racket -(provide (all-defined-out)) - -(define imm-shift 3) -(define imm-mask #b111) -(define ptr-mask #b111) -(define type-box #b001) -(define type-cons #b010) -(define type-vect #b011) -(define type-str #b100) -(define int-shift (+ 1 imm-shift)) -(define char-shift (+ 2 imm-shift)) -(define type-int #b0000) -(define mask-int #b1111) -(define type-char #b01000) -(define mask-char #b11111) -(define val-true #b0011000) -(define val-false #b0111000) -(define val-eof #b1011000) -(define val-void #b1111000) -(define val-empty #b10011000) - -(define (bits->value b) - (cond [(= type-int (bitwise-and b mask-int)) - (arithmetic-shift b (- int-shift))] - [(= type-char (bitwise-and b mask-char)) - (integer->char (arithmetic-shift b (- char-shift)))] - [(= b val-true) #t] - [(= b val-false) #f] - [(= b val-eof) eof] - [(= b val-void) (void)] - [(= b val-empty) '()] - [else (error "invalid bits")])) - -(define (value->bits v) - (cond [(eof-object? v) val-eof] - [(integer? v) (arithmetic-shift v int-shift)] - [(char? v) - (bitwise-ior type-char - (arithmetic-shift (char->integer v) char-shift))] - [(eq? v #t) val-true] - [(eq? v #f) val-false] - [(void? v) val-void] - [(empty? v) val-empty] - [else (error "not an immediate value" v)])) - - -(define (imm-bits? v) - (zero? (bitwise-and v imm-mask))) - -(define (int-bits? v) - (zero? (bitwise-and v mask-int))) - -(define (char-bits? v) - (= type-char (bitwise-and v mask-char))) - -(define (cons-bits? v) - (zero? (bitwise-xor (bitwise-and v imm-mask) type-cons))) - -(define (box-bits? v) - (zero? (bitwise-xor (bitwise-and v imm-mask) type-box))) - -(define (vect-bits? v) - (zero? (bitwise-xor (bitwise-and v imm-mask) type-vect))) - -(define (str-bits? v) - (zero? (bitwise-xor (bitwise-and v imm-mask) type-str))) diff --git a/langs/knock/unload-bits-asm.rkt b/langs/knock/unload-bits-asm.rkt deleted file mode 100644 index 4f02b0c3..00000000 --- a/langs/knock/unload-bits-asm.rkt +++ /dev/null @@ -1,43 +0,0 @@ -#lang racket -(provide unload/free unload-value) -(require "types.rkt" - ffi/unsafe) - -;; Answer* -> Answer -(define (unload/free a) - (match a - ['err 'err] - [(cons h v) (begin0 (unload-value v) - (free h))])) - -;; Value* -> Value -(define (unload-value v) - (match v - [(? imm-bits?) (bits->value v)] - [(? box-bits? i) - (box (unload-value (heap-ref i)))] - [(? cons-bits? i) - (cons (unload-value (heap-ref (+ i 8))) - (unload-value (heap-ref i)))] - [(? vect-bits? i) - (if (zero? (untag i)) - (vector) - (build-vector (heap-ref i) - (lambda (j) - (unload-value (heap-ref (+ i (* 8 (add1 j))))))))] - [(? str-bits? i) - (if (zero? (untag i)) - (string) - (build-string (heap-ref i) - (lambda (j) - (char-ref (+ i 8) j))))])) - -(define (untag i) - (arithmetic-shift (arithmetic-shift i (- (integer-length ptr-mask))) - (integer-length ptr-mask))) - -(define (heap-ref i) - (ptr-ref (cast (untag i) _int64 _pointer) _int64)) - -(define (char-ref i j) - (integer->char (ptr-ref (cast (untag i) _int64 _pointer) _uint32 j))) diff --git a/langs/knock/values.c b/langs/knock/values.c index a61d65e6..62bca18c 100644 --- a/langs/knock/values.c +++ b/langs/knock/values.c @@ -38,6 +38,10 @@ int64_t val_unwrap_int(val_t x) { return x >> int_shift; } +val_t val_wrap_byte(unsigned char b) +{ + return (b << int_shift) | int_type_tag; +} val_t val_wrap_int(int64_t i) { return (i << int_shift) | int_type_tag; diff --git a/langs/knock/values.h b/langs/knock/values.h index 4cc48bbe..b6ac44f9 100644 --- a/langs/knock/values.h +++ b/langs/knock/values.h @@ -49,6 +49,7 @@ type_t val_typeof(val_t x); */ int64_t val_unwrap_int(val_t x); val_t val_wrap_int(int64_t i); +val_t val_wrap_byte(unsigned char b); int val_unwrap_bool(val_t x); val_t val_wrap_bool(int b); diff --git a/langs/loot/Makefile b/langs/loot/Makefile index 9055c88f..db6ac44a 100644 --- a/langs/loot/Makefile +++ b/langs/loot/Makefile @@ -37,7 +37,8 @@ runtime.o: $(objs) cat $< | racket -t compile-stdin.rkt -m > $@ clean: - rm *.o *.s *.run + @$(RM) *.o *.s *.run ||: + @echo "$(shell basename $(shell pwd)): cleaned!" %.test: %.run %.rkt @test "$(shell ./$(<))" = "$(shell racket $(word 2,$^))" diff --git a/langs/loot/build-runtime.rkt b/langs/loot/build-runtime.rkt index 1cc4da53..66aad89f 100644 --- a/langs/loot/build-runtime.rkt +++ b/langs/loot/build-runtime.rkt @@ -1,12 +1,14 @@ #lang racket +(require racket/runtime-path) (provide runtime-path) -(require racket/runtime-path) (define-runtime-path here ".") -(system (string-append "make -C '" - (path->string (normalize-path here)) - "' runtime.o")) +(void + (system (string-append "make -C '" + (path->string (normalize-path here)) + "' runtime.o"))) (define runtime-path - (normalize-path (build-path here "runtime.o"))) \ No newline at end of file + (path->string + (normalize-path (build-path here "runtime.o")))) diff --git a/langs/loot/compile.rkt b/langs/loot/compile.rkt index 37655dde..f571bca6 100644 --- a/langs/loot/compile.rkt +++ b/langs/loot/compile.rkt @@ -174,7 +174,7 @@ (let ((l1 (gensym 'if)) (l2 (gensym 'if))) (seq (compile-e e1 c #f) - (Cmp rax val-false) + (Cmp rax (value->bits #f)) (Je l1) (compile-e e2 c t?) (Jmp l2) diff --git a/langs/loot/run.rkt b/langs/loot/run.rkt new file mode 100644 index 00000000..eaa53eb9 --- /dev/null +++ b/langs/loot/run.rkt @@ -0,0 +1,18 @@ +#lang racket +(provide run run/io) +(require "types.rkt" "build-runtime.rkt" + a86/interp) + +;; Asm -> Answer +(define (run is) + (parameterize ((current-objs (list runtime-path))) + (match (asm-interp is) + ['err 'err] + [b (bits->value b)]))) + +;; Asm String -> (cons Answer String) +(define (run/io is s) + (parameterize ((current-objs (list runtime-path))) + (match (asm-interp/io is s) + [(cons 'err o) (cons 'err o)] + [(cons b o) (cons (bits->value b) o)]))) diff --git a/langs/loot/test/compile.rkt b/langs/loot/test/compile.rkt index 81defae6..ee289de8 100644 --- a/langs/loot/test/compile.rkt +++ b/langs/loot/test/compile.rkt @@ -2,17 +2,7 @@ (require "test-runner.rkt" "../parse.rkt" "../compile.rkt" - "../unload-bits-asm.rkt" - a86/interp) + "../run.rkt") -;; link with runtime for IO operations -(unless (file-exists? "../runtime.o") - (system "make -C .. runtime.o")) -(current-objs - (list (path->string (normalize-path "../runtime.o")))) - -(test-runner (λ p (unload/free (asm-interp (compile (parse p)))))) -(test-runner-io (λ (s . p) - (match (asm-interp/io (compile (parse p)) s) - ['err 'err] - [(cons r o) (cons (unload/free r) o)]))) +(test-runner (λ p (run (compile (parse p))))) +(test-runner-io (λ (s . p) (run/io (compile (parse p)) s))) diff --git a/langs/loot/types.rkt b/langs/loot/types.rkt index 0867a617..19b9df2e 100644 --- a/langs/loot/types.rkt +++ b/langs/loot/types.rkt @@ -1,5 +1,6 @@ #lang racket (provide (all-defined-out)) +(require ffi/unsafe) (define imm-shift 3) (define imm-mask #b111) @@ -15,57 +16,82 @@ (define mask-int #b1111) (define type-char #b01000) (define mask-char #b11111) -(define val-true #b0011000) -(define val-false #b0111000) -(define val-eof #b1011000) -(define val-void #b1111000) -(define val-empty #b10011000) (define (bits->value b) - (cond [(= type-int (bitwise-and b mask-int)) + (cond [(= b (value->bits #t)) #t] + [(= b (value->bits #f)) #f] + [(= b (value->bits eof)) eof] + [(= b (value->bits (void))) (void)] + [(= b (value->bits '())) '()] + [(int-bits? b) (arithmetic-shift b (- int-shift))] - [(= type-char (bitwise-and b mask-char)) + [(char-bits? b) (integer->char (arithmetic-shift b (- char-shift)))] - [(= b val-true) #t] - [(= b val-false) #f] - [(= b val-eof) eof] - [(= b val-void) (void)] - [(= b val-empty) '()] + [(box-bits? b) + (box (bits->value (heap-ref b)))] + [(cons-bits? b) + (cons (bits->value (heap-ref (+ b 8))) + (bits->value (heap-ref b)))] + [(vect-bits? b) + (if (zero? (untag b)) + (vector) + (build-vector (heap-ref b) + (lambda (j) + (bits->value (heap-ref (+ b (* 8 (add1 j))))))))] + [(str-bits? b) + (if (zero? (untag b)) + (string) + (build-string (heap-ref b) + (lambda (j) + (char-ref (+ b 8) j))))] + [(proc-bits? b) + (lambda _ + (error "This function is not callable."))] [else (error "invalid bits")])) (define (value->bits v) - (cond [(eof-object? v) val-eof] - [(integer? v) (arithmetic-shift v int-shift)] + (cond [(eq? v #t) #b00011000] + [(eq? v #f) #b00111000] + [(eof-object? v) #b01011000] + [(void? v) #b01111000] + [(empty? v) #b10011000] + [(integer? v) + (arithmetic-shift v int-shift)] [(char? v) (bitwise-ior type-char (arithmetic-shift (char->integer v) char-shift))] - [(eq? v #t) val-true] - [(eq? v #f) val-false] - [(void? v) val-void] - [(empty? v) val-empty] - [else (error "not an immediate value" v)])) - + [else (error "not an immediate value")])) (define (imm-bits? v) (zero? (bitwise-and v imm-mask))) (define (int-bits? v) - (zero? (bitwise-and v mask-int))) + (= type-int (bitwise-and v mask-int))) (define (char-bits? v) (= type-char (bitwise-and v mask-char))) (define (cons-bits? v) - (zero? (bitwise-xor (bitwise-and v imm-mask) type-cons))) + (= type-cons (bitwise-and v imm-mask))) (define (box-bits? v) - (zero? (bitwise-xor (bitwise-and v imm-mask) type-box))) + (= type-box (bitwise-and v imm-mask))) (define (vect-bits? v) - (zero? (bitwise-xor (bitwise-and v imm-mask) type-vect))) + (= type-vect (bitwise-and v imm-mask))) (define (str-bits? v) - (zero? (bitwise-xor (bitwise-and v imm-mask) type-str))) + (= type-str (bitwise-and v imm-mask))) (define (proc-bits? v) - (zero? (bitwise-xor (bitwise-and v imm-mask) type-proc))) + (= type-proc (bitwise-and v imm-mask))) + +(define (untag i) + (arithmetic-shift (arithmetic-shift i (- (integer-length ptr-mask))) + (integer-length ptr-mask))) + +(define (heap-ref i) + (ptr-ref (cast (untag i) _int64 _pointer) _int64)) + +(define (char-ref i j) + (integer->char (ptr-ref (cast (untag i) _int64 _pointer) _uint32 j))) diff --git a/langs/loot/unload-bits-asm.rkt b/langs/loot/unload-bits-asm.rkt deleted file mode 100644 index 9615cde5..00000000 --- a/langs/loot/unload-bits-asm.rkt +++ /dev/null @@ -1,46 +0,0 @@ -#lang racket -(provide unload/free unload-value) -(require "types.rkt" - ffi/unsafe) - -;; Answer* -> Answer -(define (unload/free a) - (match a - ['err 'err] - [(cons h v) (begin0 (unload-value v) - (free h))])) - -;; Value* -> Value -(define (unload-value v) - (match v - [(? imm-bits?) (bits->value v)] - [(? box-bits? i) - (box (unload-value (heap-ref i)))] - [(? cons-bits? i) - (cons (unload-value (heap-ref (+ i 8))) - (unload-value (heap-ref i)))] - [(? vect-bits? i) - (if (zero? (untag i)) - (vector) - (build-vector (heap-ref i) - (lambda (j) - (unload-value (heap-ref (+ i (* 8 (add1 j))))))))] - [(? str-bits? i) - (if (zero? (untag i)) - (string) - (build-string (heap-ref i) - (lambda (j) - (char-ref (+ i 8) j))))] - [(? proc-bits? i) - (lambda _ - (error "This function is not callable."))])) - -(define (untag i) - (arithmetic-shift (arithmetic-shift i (- (integer-length ptr-mask))) - (integer-length ptr-mask))) - -(define (heap-ref i) - (ptr-ref (cast (untag i) _int64 _pointer) _int64)) - -(define (char-ref i j) - (integer->char (ptr-ref (cast (untag i) _int64 _pointer) _uint32 j))) diff --git a/langs/modules-in-progress/Makefile b/langs/modules-in-progress/Makefile index 1bba6a32..bd832496 100644 --- a/langs/modules-in-progress/Makefile +++ b/langs/modules-in-progress/Makefile @@ -40,6 +40,7 @@ runtime.o: $(objs) make $@ clean: - -rm *.o *.s *.run $(BUILD_DIR)/*.make + @$(RM) *.o *.s *.run $(BUILD_DIR)/*.make ||: + @echo "$(shell basename $(shell pwd)): cleaned!" -include $(wildcard $(BUILD_DIR)/*.make) diff --git a/langs/mountebank/Makefile b/langs/mountebank/Makefile index 7fb41f2a..ed8a85f4 100644 --- a/langs/mountebank/Makefile +++ b/langs/mountebank/Makefile @@ -38,7 +38,8 @@ runtime.o: $(objs) cat $< | racket -t compile-stdin.rkt -m > $@ clean: - rm *.o *.s *.run + @$(RM) *.o *.s *.run ||: + @echo "$(shell basename $(shell pwd)): cleaned!" %.test: %.run %.rkt @test "$(shell ./$(<))" = "$(shell racket $(word 2,$^))" diff --git a/langs/mountebank/build-runtime.rkt b/langs/mountebank/build-runtime.rkt index 1cc4da53..66aad89f 100644 --- a/langs/mountebank/build-runtime.rkt +++ b/langs/mountebank/build-runtime.rkt @@ -1,12 +1,14 @@ #lang racket +(require racket/runtime-path) (provide runtime-path) -(require racket/runtime-path) (define-runtime-path here ".") -(system (string-append "make -C '" - (path->string (normalize-path here)) - "' runtime.o")) +(void + (system (string-append "make -C '" + (path->string (normalize-path here)) + "' runtime.o"))) (define runtime-path - (normalize-path (build-path here "runtime.o"))) \ No newline at end of file + (path->string + (normalize-path (build-path here "runtime.o")))) diff --git a/langs/mountebank/compile-expr.rkt b/langs/mountebank/compile-expr.rkt index 767b3915..ed9bba27 100644 --- a/langs/mountebank/compile-expr.rkt +++ b/langs/mountebank/compile-expr.rkt @@ -68,7 +68,7 @@ (let ((l1 (gensym 'if)) (l2 (gensym 'if))) (seq (compile-e e1 c #f) - (Cmp rax val-false) + (Cmp rax (value->bits #f)) (Je l1) (compile-e e2 c t?) (Jmp l2) diff --git a/langs/mountebank/compile-ops.rkt b/langs/mountebank/compile-ops.rkt index 0aa3bb00..8a52cd49 100644 --- a/langs/mountebank/compile-ops.rkt +++ b/langs/mountebank/compile-ops.rkt @@ -18,7 +18,7 @@ ;; Op0 -> Asm (define (compile-op0 p) (match p - ['void (seq (Mov rax val-void))] + ['void (seq (Mov rax (value->bits (void))))] ['read-byte (seq pad-stack (Call 'read_byte) unpad-stack)] @@ -166,20 +166,20 @@ (assert-integer r8) (assert-integer rax) (Cmp r8 rax) - (Mov rax val-true) + (Mov rax (value->bits #t)) (let ((true (gensym))) (seq (Jl true) - (Mov rax val-false) + (Mov rax (value->bits #f)) (Label true))))] ['= (seq (Pop r8) (assert-integer r8) (assert-integer rax) (Cmp r8 rax) - (Mov rax val-true) + (Mov rax (value->bits #t)) (let ((true (gensym))) (seq (Je true) - (Mov rax val-false) + (Mov rax (value->bits #f)) (Label true))))] ['cons (seq (Mov (Offset rbx 0) rax) @@ -315,7 +315,7 @@ (Sal r10 3) (Add r8 r10) (Mov (Offset r8 8) rax) - (Mov rax val-void))])) + (Mov rax (value->bits (void))))])) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -383,15 +383,15 @@ (define (eq-imm imm) (let ((l1 (gensym))) (seq (Cmp rax (value->bits imm)) - (Mov rax val-true) + (Mov rax (value->bits #t)) (Je l1) - (Mov rax val-false) + (Mov rax (value->bits #f)) (Label l1)))) (define (eq ir1 ir2) (let ((l1 (gensym))) (seq (Cmp ir1 ir2) - (Mov rax val-true) + (Mov rax (value->bits #t)) (Je l1) - (Mov rax val-false) + (Mov rax (value->bits #f)) (Label l1)))) diff --git a/langs/mountebank/run.rkt b/langs/mountebank/run.rkt new file mode 100644 index 00000000..eaa53eb9 --- /dev/null +++ b/langs/mountebank/run.rkt @@ -0,0 +1,18 @@ +#lang racket +(provide run run/io) +(require "types.rkt" "build-runtime.rkt" + a86/interp) + +;; Asm -> Answer +(define (run is) + (parameterize ((current-objs (list runtime-path))) + (match (asm-interp is) + ['err 'err] + [b (bits->value b)]))) + +;; Asm String -> (cons Answer String) +(define (run/io is s) + (parameterize ((current-objs (list runtime-path))) + (match (asm-interp/io is s) + [(cons 'err o) (cons 'err o)] + [(cons b o) (cons (bits->value b) o)]))) diff --git a/langs/mountebank/test/compile.rkt b/langs/mountebank/test/compile.rkt index 81defae6..ee289de8 100644 --- a/langs/mountebank/test/compile.rkt +++ b/langs/mountebank/test/compile.rkt @@ -2,17 +2,7 @@ (require "test-runner.rkt" "../parse.rkt" "../compile.rkt" - "../unload-bits-asm.rkt" - a86/interp) + "../run.rkt") -;; link with runtime for IO operations -(unless (file-exists? "../runtime.o") - (system "make -C .. runtime.o")) -(current-objs - (list (path->string (normalize-path "../runtime.o")))) - -(test-runner (λ p (unload/free (asm-interp (compile (parse p)))))) -(test-runner-io (λ (s . p) - (match (asm-interp/io (compile (parse p)) s) - ['err 'err] - [(cons r o) (cons (unload/free r) o)]))) +(test-runner (λ p (run (compile (parse p))))) +(test-runner-io (λ (s . p) (run/io (compile (parse p)) s))) diff --git a/langs/mountebank/types.rkt b/langs/mountebank/types.rkt index 42c74c95..f4cbf7d8 100644 --- a/langs/mountebank/types.rkt +++ b/langs/mountebank/types.rkt @@ -1,5 +1,6 @@ #lang racket (provide (all-defined-out)) +(require ffi/unsafe) (define imm-shift 3) (define imm-mask #b111) @@ -16,60 +17,93 @@ (define mask-int #b1111) (define type-char #b01000) (define mask-char #b11111) -(define val-true #b0011000) -(define val-false #b0111000) -(define val-eof #b1011000) -(define val-void #b1111000) -(define val-empty #b10011000) (define (bits->value b) - (cond [(= type-int (bitwise-and b mask-int)) + (cond [(= b (value->bits #t)) #t] + [(= b (value->bits #f)) #f] + [(= b (value->bits eof)) eof] + [(= b (value->bits (void))) (void)] + [(= b (value->bits '())) '()] + [(int-bits? b) (arithmetic-shift b (- int-shift))] - [(= type-char (bitwise-and b mask-char)) + [(char-bits? b) (integer->char (arithmetic-shift b (- char-shift)))] - [(= b val-true) #t] - [(= b val-false) #f] - [(= b val-eof) eof] - [(= b val-void) (void)] - [(= b val-empty) '()] + [(box-bits? b) + (box (bits->value (heap-ref b)))] + [(cons-bits? b) + (cons (bits->value (heap-ref (+ b 8))) + (bits->value (heap-ref b)))] + [(vect-bits? b) + (if (zero? (untag b)) + (vector) + (build-vector (heap-ref b) + (lambda (j) + (bits->value (heap-ref (+ b (* 8 (add1 j))))))))] + [(str-bits? b) + (if (zero? (untag b)) + (string) + (build-string (heap-ref b) + (lambda (j) + (char-ref (+ b 8) j))))] + [(symb-bits? b) + (string->symbol + (if (zero? (untag b)) + (string) + (build-string (heap-ref b) + (lambda (j) + (char-ref (+ b 8) j)))))] + [(proc-bits? b) + (lambda _ + (error "This function is not callable."))] [else (error "invalid bits")])) (define (value->bits v) - (cond [(eof-object? v) val-eof] - [(integer? v) (arithmetic-shift v int-shift)] + (cond [(eq? v #t) #b00011000] + [(eq? v #f) #b00111000] + [(eof-object? v) #b01011000] + [(void? v) #b01111000] + [(empty? v) #b10011000] + [(integer? v) + (arithmetic-shift v int-shift)] [(char? v) (bitwise-ior type-char (arithmetic-shift (char->integer v) char-shift))] - [(eq? v #t) val-true] - [(eq? v #f) val-false] - [(void? v) val-void] - [(empty? v) val-empty] - [else (error "not an immediate")])) + [else (error "not an immediate value")])) (define (imm-bits? v) (zero? (bitwise-and v imm-mask))) (define (int-bits? v) - (zero? (bitwise-and v mask-int))) + (= type-int (bitwise-and v mask-int))) (define (char-bits? v) (= type-char (bitwise-and v mask-char))) (define (cons-bits? v) - (zero? (bitwise-xor (bitwise-and v imm-mask) type-cons))) + (= type-cons (bitwise-and v imm-mask))) (define (box-bits? v) - (zero? (bitwise-xor (bitwise-and v imm-mask) type-box))) + (= type-box (bitwise-and v imm-mask))) (define (vect-bits? v) - (zero? (bitwise-xor (bitwise-and v imm-mask) type-vect))) + (= type-vect (bitwise-and v imm-mask))) (define (str-bits? v) - (zero? (bitwise-xor (bitwise-and v imm-mask) type-str))) + (= type-str (bitwise-and v imm-mask))) (define (proc-bits? v) - (zero? (bitwise-xor (bitwise-and v imm-mask) type-proc))) + (= type-proc (bitwise-and v imm-mask))) (define (symb-bits? v) - (zero? (bitwise-xor (bitwise-and v imm-mask) type-symb))) + (= type-symb (bitwise-and v imm-mask))) + +(define (untag i) + (arithmetic-shift (arithmetic-shift i (- (integer-length ptr-mask))) + (integer-length ptr-mask))) + +(define (heap-ref i) + (ptr-ref (cast (untag i) _int64 _pointer) _int64)) + +(define (char-ref i j) + (integer->char (ptr-ref (cast (untag i) _int64 _pointer) _uint32 j))) diff --git a/langs/mountebank/unload-bits-asm.rkt b/langs/mountebank/unload-bits-asm.rkt deleted file mode 100644 index 84529871..00000000 --- a/langs/mountebank/unload-bits-asm.rkt +++ /dev/null @@ -1,53 +0,0 @@ -#lang racket -(provide unload/free unload-value) -(require "types.rkt" - ffi/unsafe) - -;; Answer* -> Answer -(define (unload/free a) - (match a - ['err 'err] - [(cons h v) (begin0 (unload-value v) - (free h))])) - -;; Value* -> Value -(define (unload-value v) - (match v - [(? imm-bits?) (bits->value v)] - [(? box-bits? i) - (box (unload-value (heap-ref i)))] - [(? cons-bits? i) - (cons (unload-value (heap-ref (+ i 8))) - (unload-value (heap-ref i)))] - [(? vect-bits? i) - (if (zero? (untag i)) - (vector) - (build-vector (heap-ref i) - (lambda (j) - (unload-value (heap-ref (+ i (* 8 (add1 j))))))))] - [(? str-bits? i) - (if (zero? (untag i)) - (string) - (build-string (heap-ref i) - (lambda (j) - (char-ref (+ i 8) j))))] - [(? symb-bits? i) - (string->symbol - (if (zero? (untag i)) - (string) - (build-string (heap-ref i) - (lambda (j) - (char-ref (+ i 8) j)))))] - [(? proc-bits? i) - (lambda _ - (error "This function is not callable."))])) - -(define (untag i) - (arithmetic-shift (arithmetic-shift i (- (integer-length ptr-mask))) - (integer-length ptr-mask))) - -(define (heap-ref i) - (ptr-ref (cast (untag i) _int64 _pointer) _int64)) - -(define (char-ref i j) - (integer->char (ptr-ref (cast (untag i) _int64 _pointer) _uint32 j))) diff --git a/langs/mountebank/utils.rkt b/langs/mountebank/utils.rkt index f0b06af6..612b7381 100644 --- a/langs/mountebank/utils.rkt +++ b/langs/mountebank/utils.rkt @@ -1,33 +1,13 @@ #lang racket -(provide symbol->label symbol->data-label lookup pad-stack unpad-stack) +(provide symbol->data-label lookup pad-stack unpad-stack) (require a86/ast) (define rsp 'rsp) (define r15 'r15) -;; Symbol -> Label -;; Produce a symbol that is a valid Nasm label -(define (symbol->label s) - (to-label "label_" s)) - (define (symbol->data-label s) - (to-label "data_" s)) - -(define (to-label prefix s) - (string->symbol - (string-append - prefix - (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)))) + (symbol->label + (string->symbol (string-append "data_" (symbol->string s))))) ;; Id CEnv -> [Maybe Integer] (define (lookup x cenv) diff --git a/langs/mug/Makefile b/langs/mug/Makefile index 7fb41f2a..ed8a85f4 100644 --- a/langs/mug/Makefile +++ b/langs/mug/Makefile @@ -38,7 +38,8 @@ runtime.o: $(objs) cat $< | racket -t compile-stdin.rkt -m > $@ clean: - rm *.o *.s *.run + @$(RM) *.o *.s *.run ||: + @echo "$(shell basename $(shell pwd)): cleaned!" %.test: %.run %.rkt @test "$(shell ./$(<))" = "$(shell racket $(word 2,$^))" diff --git a/langs/mug/build-runtime.rkt b/langs/mug/build-runtime.rkt index 1cc4da53..66aad89f 100644 --- a/langs/mug/build-runtime.rkt +++ b/langs/mug/build-runtime.rkt @@ -1,12 +1,14 @@ #lang racket +(require racket/runtime-path) (provide runtime-path) -(require racket/runtime-path) (define-runtime-path here ".") -(system (string-append "make -C '" - (path->string (normalize-path here)) - "' runtime.o")) +(void + (system (string-append "make -C '" + (path->string (normalize-path here)) + "' runtime.o"))) (define runtime-path - (normalize-path (build-path here "runtime.o"))) \ No newline at end of file + (path->string + (normalize-path (build-path here "runtime.o")))) diff --git a/langs/mug/compile-expr.rkt b/langs/mug/compile-expr.rkt index 2a5758cf..40dee014 100644 --- a/langs/mug/compile-expr.rkt +++ b/langs/mug/compile-expr.rkt @@ -84,7 +84,7 @@ (let ((l1 (gensym 'if)) (l2 (gensym 'if))) (seq (compile-e e1 c #f) - (Cmp rax val-false) + (Cmp rax (value->bits #f)) (Je l1) (compile-e e2 c t?) (Jmp l2) diff --git a/langs/mug/compile-ops.rkt b/langs/mug/compile-ops.rkt index 0aa3bb00..8a52cd49 100644 --- a/langs/mug/compile-ops.rkt +++ b/langs/mug/compile-ops.rkt @@ -18,7 +18,7 @@ ;; Op0 -> Asm (define (compile-op0 p) (match p - ['void (seq (Mov rax val-void))] + ['void (seq (Mov rax (value->bits (void))))] ['read-byte (seq pad-stack (Call 'read_byte) unpad-stack)] @@ -166,20 +166,20 @@ (assert-integer r8) (assert-integer rax) (Cmp r8 rax) - (Mov rax val-true) + (Mov rax (value->bits #t)) (let ((true (gensym))) (seq (Jl true) - (Mov rax val-false) + (Mov rax (value->bits #f)) (Label true))))] ['= (seq (Pop r8) (assert-integer r8) (assert-integer rax) (Cmp r8 rax) - (Mov rax val-true) + (Mov rax (value->bits #t)) (let ((true (gensym))) (seq (Je true) - (Mov rax val-false) + (Mov rax (value->bits #f)) (Label true))))] ['cons (seq (Mov (Offset rbx 0) rax) @@ -315,7 +315,7 @@ (Sal r10 3) (Add r8 r10) (Mov (Offset r8 8) rax) - (Mov rax val-void))])) + (Mov rax (value->bits (void))))])) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -383,15 +383,15 @@ (define (eq-imm imm) (let ((l1 (gensym))) (seq (Cmp rax (value->bits imm)) - (Mov rax val-true) + (Mov rax (value->bits #t)) (Je l1) - (Mov rax val-false) + (Mov rax (value->bits #f)) (Label l1)))) (define (eq ir1 ir2) (let ((l1 (gensym))) (seq (Cmp ir1 ir2) - (Mov rax val-true) + (Mov rax (value->bits #t)) (Je l1) - (Mov rax val-false) + (Mov rax (value->bits #f)) (Label l1)))) diff --git a/langs/mug/run.rkt b/langs/mug/run.rkt new file mode 100644 index 00000000..eaa53eb9 --- /dev/null +++ b/langs/mug/run.rkt @@ -0,0 +1,18 @@ +#lang racket +(provide run run/io) +(require "types.rkt" "build-runtime.rkt" + a86/interp) + +;; Asm -> Answer +(define (run is) + (parameterize ((current-objs (list runtime-path))) + (match (asm-interp is) + ['err 'err] + [b (bits->value b)]))) + +;; Asm String -> (cons Answer String) +(define (run/io is s) + (parameterize ((current-objs (list runtime-path))) + (match (asm-interp/io is s) + [(cons 'err o) (cons 'err o)] + [(cons b o) (cons (bits->value b) o)]))) diff --git a/langs/mug/test/compile.rkt b/langs/mug/test/compile.rkt index 81defae6..ee289de8 100644 --- a/langs/mug/test/compile.rkt +++ b/langs/mug/test/compile.rkt @@ -2,17 +2,7 @@ (require "test-runner.rkt" "../parse.rkt" "../compile.rkt" - "../unload-bits-asm.rkt" - a86/interp) + "../run.rkt") -;; link with runtime for IO operations -(unless (file-exists? "../runtime.o") - (system "make -C .. runtime.o")) -(current-objs - (list (path->string (normalize-path "../runtime.o")))) - -(test-runner (λ p (unload/free (asm-interp (compile (parse p)))))) -(test-runner-io (λ (s . p) - (match (asm-interp/io (compile (parse p)) s) - ['err 'err] - [(cons r o) (cons (unload/free r) o)]))) +(test-runner (λ p (run (compile (parse p))))) +(test-runner-io (λ (s . p) (run/io (compile (parse p)) s))) diff --git a/langs/mug/types.rkt b/langs/mug/types.rkt index 25091a40..1bb4f590 100644 --- a/langs/mug/types.rkt +++ b/langs/mug/types.rkt @@ -1,5 +1,6 @@ #lang racket (provide (all-defined-out)) +(require ffi/unsafe) (define imm-shift 3) (define imm-mask #b111) @@ -16,59 +17,92 @@ (define mask-int #b1111) (define type-char #b01000) (define mask-char #b11111) -(define val-true #b0011000) -(define val-false #b0111000) -(define val-eof #b1011000) -(define val-void #b1111000) -(define val-empty #b10011000) (define (bits->value b) - (cond [(= type-int (bitwise-and b mask-int)) + (cond [(= b (value->bits #t)) #t] + [(= b (value->bits #f)) #f] + [(= b (value->bits eof)) eof] + [(= b (value->bits (void))) (void)] + [(= b (value->bits '())) '()] + [(int-bits? b) (arithmetic-shift b (- int-shift))] - [(= type-char (bitwise-and b mask-char)) + [(char-bits? b) (integer->char (arithmetic-shift b (- char-shift)))] - [(= b val-true) #t] - [(= b val-false) #f] - [(= b val-eof) eof] - [(= b val-void) (void)] - [(= b val-empty) '()] + [(box-bits? b) + (box (bits->value (heap-ref b)))] + [(cons-bits? b) + (cons (bits->value (heap-ref (+ b 8))) + (bits->value (heap-ref b)))] + [(vect-bits? b) + (if (zero? (untag b)) + (vector) + (build-vector (heap-ref b) + (lambda (j) + (bits->value (heap-ref (+ b (* 8 (add1 j))))))))] + [(str-bits? b) + (if (zero? (untag b)) + (string) + (build-string (heap-ref b) + (lambda (j) + (char-ref (+ b 8) j))))] + [(symb-bits? b) + (string->symbol + (if (zero? (untag b)) + (string) + (build-string (heap-ref b) + (lambda (j) + (char-ref (+ b 8) j)))))] + [(proc-bits? b) + (lambda _ + (error "This function is not callable."))] [else (error "invalid bits")])) (define (value->bits v) - (cond [(eof-object? v) val-eof] - [(integer? v) (arithmetic-shift v int-shift)] + (cond [(eq? v #t) #b00011000] + [(eq? v #f) #b00111000] + [(eof-object? v) #b01011000] + [(void? v) #b01111000] + [(empty? v) #b10011000] + [(integer? v) + (arithmetic-shift v int-shift)] [(char? v) (bitwise-ior type-char (arithmetic-shift (char->integer v) char-shift))] - [(eq? v #t) val-true] - [(eq? v #f) val-false] - [(void? v) val-void] - [(empty? v) val-empty])) - + [else (error "not an immediate value")])) (define (imm-bits? v) (zero? (bitwise-and v imm-mask))) (define (int-bits? v) - (zero? (bitwise-and v mask-int))) + (= type-int (bitwise-and v mask-int))) (define (char-bits? v) (= type-char (bitwise-and v mask-char))) (define (cons-bits? v) - (zero? (bitwise-xor (bitwise-and v imm-mask) type-cons))) + (= type-cons (bitwise-and v imm-mask))) (define (box-bits? v) - (zero? (bitwise-xor (bitwise-and v imm-mask) type-box))) + (= type-box (bitwise-and v imm-mask))) (define (vect-bits? v) - (zero? (bitwise-xor (bitwise-and v imm-mask) type-vect))) + (= type-vect (bitwise-and v imm-mask))) (define (str-bits? v) - (zero? (bitwise-xor (bitwise-and v imm-mask) type-str))) + (= type-str (bitwise-and v imm-mask))) (define (proc-bits? v) - (zero? (bitwise-xor (bitwise-and v imm-mask) type-proc))) + (= type-proc (bitwise-and v imm-mask))) (define (symb-bits? v) - (zero? (bitwise-xor (bitwise-and v imm-mask) type-symb))) + (= type-symb (bitwise-and v imm-mask))) + +(define (untag i) + (arithmetic-shift (arithmetic-shift i (- (integer-length ptr-mask))) + (integer-length ptr-mask))) + +(define (heap-ref i) + (ptr-ref (cast (untag i) _int64 _pointer) _int64)) + +(define (char-ref i j) + (integer->char (ptr-ref (cast (untag i) _int64 _pointer) _uint32 j))) diff --git a/langs/mug/unload-bits-asm.rkt b/langs/mug/unload-bits-asm.rkt deleted file mode 100644 index c9fbaf40..00000000 --- a/langs/mug/unload-bits-asm.rkt +++ /dev/null @@ -1,54 +0,0 @@ -#lang racket -(provide unload/free unload-value) -(require "types.rkt" - ffi/unsafe) - -;; Answer* -> Answer -(define (unload/free a) - (match a - ['err 'err] - [(cons h v) (begin0 (unload-value v) - (free h))])) - -;; Value* -> Value -(define (unload-value v) - (match v - [(? imm-bits?) (bits->value v)] - [(? box-bits? i) - (box (unload-value (heap-ref i)))] - [(? cons-bits? i) - (cons (unload-value (heap-ref (+ i 8))) - (unload-value (heap-ref i)))] - [(? vect-bits? i) - (if (zero? (untag i)) - (vector) - (build-vector (heap-ref i) - (lambda (j) - (unload-value (heap-ref (+ i (* 8 (add1 j))))))))] - [(? str-bits? i) - (if (zero? (untag i)) - (string) - (build-string (heap-ref i) - (lambda (j) - (char-ref (+ i 8) j))))] - [(? symb-bits? i) - (string->symbol - (if (zero? (untag i)) - (string) - (build-string (heap-ref i) - (lambda (j) - (char-ref (+ i 8) j)))))] - [(? proc-bits? i) - (lambda _ - (error "This function is not callable."))])) - - -(define (untag i) - (arithmetic-shift (arithmetic-shift i (- (integer-length ptr-mask))) - (integer-length ptr-mask))) - -(define (heap-ref i) - (ptr-ref (cast (untag i) _int64 _pointer) _int64)) - -(define (char-ref i j) - (integer->char (ptr-ref (cast (untag i) _int64 _pointer) _uint32 j))) diff --git a/langs/mug/utils.rkt b/langs/mug/utils.rkt index f0b06af6..612b7381 100644 --- a/langs/mug/utils.rkt +++ b/langs/mug/utils.rkt @@ -1,33 +1,13 @@ #lang racket -(provide symbol->label symbol->data-label lookup pad-stack unpad-stack) +(provide symbol->data-label lookup pad-stack unpad-stack) (require a86/ast) (define rsp 'rsp) (define r15 'r15) -;; Symbol -> Label -;; Produce a symbol that is a valid Nasm label -(define (symbol->label s) - (to-label "label_" s)) - (define (symbol->data-label s) - (to-label "data_" s)) - -(define (to-label prefix s) - (string->symbol - (string-append - prefix - (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)))) + (symbol->label + (string->symbol (string-append "data_" (symbol->string s))))) ;; Id CEnv -> [Maybe Integer] (define (lookup x cenv) diff --git a/langs/neerdowell/Makefile b/langs/neerdowell/Makefile index 7fb41f2a..ed8a85f4 100644 --- a/langs/neerdowell/Makefile +++ b/langs/neerdowell/Makefile @@ -38,7 +38,8 @@ runtime.o: $(objs) cat $< | racket -t compile-stdin.rkt -m > $@ clean: - rm *.o *.s *.run + @$(RM) *.o *.s *.run ||: + @echo "$(shell basename $(shell pwd)): cleaned!" %.test: %.run %.rkt @test "$(shell ./$(<))" = "$(shell racket $(word 2,$^))" diff --git a/langs/neerdowell/build-runtime.rkt b/langs/neerdowell/build-runtime.rkt index 1cc4da53..66aad89f 100644 --- a/langs/neerdowell/build-runtime.rkt +++ b/langs/neerdowell/build-runtime.rkt @@ -1,12 +1,14 @@ #lang racket +(require racket/runtime-path) (provide runtime-path) -(require racket/runtime-path) (define-runtime-path here ".") -(system (string-append "make -C '" - (path->string (normalize-path here)) - "' runtime.o")) +(void + (system (string-append "make -C '" + (path->string (normalize-path here)) + "' runtime.o"))) (define runtime-path - (normalize-path (build-path here "runtime.o"))) \ No newline at end of file + (path->string + (normalize-path (build-path here "runtime.o")))) diff --git a/langs/neerdowell/compile-expr.rkt b/langs/neerdowell/compile-expr.rkt index 600dfb25..e54a789d 100644 --- a/langs/neerdowell/compile-expr.rkt +++ b/langs/neerdowell/compile-expr.rkt @@ -47,7 +47,7 @@ (let ((l1 (gensym 'if)) (l2 (gensym 'if))) (seq (compile-e e1 c #f) - (Cmp rax val-false) + (Cmp rax (value->bits #f)) (Je l1) (compile-e e2 c t?) (Jmp l2) diff --git a/langs/neerdowell/compile-ops.rkt b/langs/neerdowell/compile-ops.rkt index da8c8321..23386fc7 100644 --- a/langs/neerdowell/compile-ops.rkt +++ b/langs/neerdowell/compile-ops.rkt @@ -19,7 +19,7 @@ (define (compile-op p) (match p ;; Op0 - ['void (seq (Mov rax val-void))] + ['void (seq (Mov rax (value->bits (void))))] ['read-byte (seq pad-stack (Call 'read_byte) unpad-stack)] @@ -144,20 +144,20 @@ (assert-integer r8) (assert-integer rax) (Cmp r8 rax) - (Mov rax val-true) + (Mov rax (value->bits #t)) (let ((true (gensym))) (seq (Jl true) - (Mov rax val-false) + (Mov rax (value->bits #f)) (Label true))))] ['= (seq (Pop r8) (assert-integer r8) (assert-integer rax) (Cmp r8 rax) - (Mov rax val-true) + (Mov rax (value->bits #t)) (let ((true (gensym))) (seq (Je true) - (Mov rax val-false) + (Mov rax (value->bits #f)) (Label true))))] ['cons (seq (Mov (Offset rbx 0) rax) @@ -310,7 +310,7 @@ (Sal r10 3) (Add r8 r10) (Mov (Offset r8 8) rax) - (Mov rax val-void))] + (Mov rax (value->bits (void))))] ['struct-ref ; symbol, int, struct (seq (Pop r8) @@ -430,15 +430,15 @@ (define (eq-imm imm) (let ((l1 (gensym))) (seq (Cmp rax (value->bits imm)) - (Mov rax val-true) + (Mov rax (value->bits #t)) (Je l1) - (Mov rax val-false) + (Mov rax (value->bits #f)) (Label l1)))) (define (eq ir1 ir2) (let ((l1 (gensym))) (seq (Cmp ir1 ir2) - (Mov rax val-true) + (Mov rax (value->bits #t)) (Je l1) - (Mov rax val-false) + (Mov rax (value->bits #f)) (Label l1)))) diff --git a/langs/neerdowell/run.rkt b/langs/neerdowell/run.rkt new file mode 100644 index 00000000..eaa53eb9 --- /dev/null +++ b/langs/neerdowell/run.rkt @@ -0,0 +1,18 @@ +#lang racket +(provide run run/io) +(require "types.rkt" "build-runtime.rkt" + a86/interp) + +;; Asm -> Answer +(define (run is) + (parameterize ((current-objs (list runtime-path))) + (match (asm-interp is) + ['err 'err] + [b (bits->value b)]))) + +;; Asm String -> (cons Answer String) +(define (run/io is s) + (parameterize ((current-objs (list runtime-path))) + (match (asm-interp/io is s) + [(cons 'err o) (cons 'err o)] + [(cons b o) (cons (bits->value b) o)]))) diff --git a/langs/neerdowell/test/compile.rkt b/langs/neerdowell/test/compile.rkt index 81defae6..ee289de8 100644 --- a/langs/neerdowell/test/compile.rkt +++ b/langs/neerdowell/test/compile.rkt @@ -2,17 +2,7 @@ (require "test-runner.rkt" "../parse.rkt" "../compile.rkt" - "../unload-bits-asm.rkt" - a86/interp) + "../run.rkt") -;; link with runtime for IO operations -(unless (file-exists? "../runtime.o") - (system "make -C .. runtime.o")) -(current-objs - (list (path->string (normalize-path "../runtime.o")))) - -(test-runner (λ p (unload/free (asm-interp (compile (parse p)))))) -(test-runner-io (λ (s . p) - (match (asm-interp/io (compile (parse p)) s) - ['err 'err] - [(cons r o) (cons (unload/free r) o)]))) +(test-runner (λ p (run (compile (parse p))))) +(test-runner-io (λ (s . p) (run/io (compile (parse p)) s))) diff --git a/langs/neerdowell/types.rkt b/langs/neerdowell/types.rkt index 0a25813c..9375b78d 100644 --- a/langs/neerdowell/types.rkt +++ b/langs/neerdowell/types.rkt @@ -1,5 +1,6 @@ #lang racket (provide (all-defined-out)) +(require ffi/unsafe) (define imm-shift 3) (define imm-mask #b111) @@ -17,63 +18,99 @@ (define mask-int #b1111) (define type-char #b01000) (define mask-char #b11111) -(define val-true #b0011000) -(define val-false #b0111000) -(define val-eof #b1011000) -(define val-void #b1111000) -(define val-empty #b10011000) + +(struct struct-val () #:transparent) (define (bits->value b) - (cond [(= type-int (bitwise-and b mask-int)) + (cond [(= b (value->bits #t)) #t] + [(= b (value->bits #f)) #f] + [(= b (value->bits eof)) eof] + [(= b (value->bits (void))) (void)] + [(= b (value->bits '())) '()] + [(int-bits? b) (arithmetic-shift b (- int-shift))] - [(= type-char (bitwise-and b mask-char)) + [(char-bits? b) (integer->char (arithmetic-shift b (- char-shift)))] - [(= b val-true) #t] - [(= b val-false) #f] - [(= b val-eof) eof] - [(= b val-void) (void)] - [(= b val-empty) '()] + [(box-bits? b) + (box (bits->value (heap-ref b)))] + [(cons-bits? b) + (cons (bits->value (heap-ref (+ b 8))) + (bits->value (heap-ref b)))] + [(vect-bits? b) + (if (zero? (untag b)) + (vector) + (build-vector (heap-ref b) + (lambda (j) + (bits->value (heap-ref (+ b (* 8 (add1 j))))))))] + [(str-bits? b) + (if (zero? (untag b)) + (string) + (build-string (heap-ref b) + (lambda (j) + (char-ref (+ b 8) j))))] + [(symb-bits? b) + (string->symbol + (if (zero? (untag b)) + (string) + (build-string (heap-ref b) + (lambda (j) + (char-ref (+ b 8) j)))))] + [(struct-bits? b) + (struct-val)] + [(proc-bits? b) + (lambda _ + (error "This function is not callable."))] [else (error "invalid bits")])) (define (value->bits v) - (cond [(eof-object? v) val-eof] - [(integer? v) (arithmetic-shift v int-shift)] + (cond [(eq? v #t) #b00011000] + [(eq? v #f) #b00111000] + [(eof-object? v) #b01011000] + [(void? v) #b01111000] + [(empty? v) #b10011000] + [(integer? v) + (arithmetic-shift v int-shift)] [(char? v) (bitwise-ior type-char (arithmetic-shift (char->integer v) char-shift))] - [(eq? v #t) val-true] - [(eq? v #f) val-false] - [(void? v) val-void] - [(empty? v) val-empty] - [else (error "not an immediate")])) - + [else (error "not an immediate value")])) (define (imm-bits? v) (zero? (bitwise-and v imm-mask))) (define (int-bits? v) - (zero? (bitwise-and v mask-int))) + (= type-int (bitwise-and v mask-int))) (define (char-bits? v) (= type-char (bitwise-and v mask-char))) (define (cons-bits? v) - (zero? (bitwise-xor (bitwise-and v imm-mask) type-cons))) + (= type-cons (bitwise-and v imm-mask))) (define (box-bits? v) - (zero? (bitwise-xor (bitwise-and v imm-mask) type-box))) + (= type-box (bitwise-and v imm-mask))) (define (vect-bits? v) - (zero? (bitwise-xor (bitwise-and v imm-mask) type-vect))) + (= type-vect (bitwise-and v imm-mask))) (define (str-bits? v) - (zero? (bitwise-xor (bitwise-and v imm-mask) type-str))) + (= type-str (bitwise-and v imm-mask))) (define (proc-bits? v) - (zero? (bitwise-xor (bitwise-and v imm-mask) type-proc))) + (= type-proc (bitwise-and v imm-mask))) (define (symb-bits? v) - (zero? (bitwise-xor (bitwise-and v imm-mask) type-symb))) + (= type-symb (bitwise-and v imm-mask))) (define (struct-bits? v) - (zero? (bitwise-xor (bitwise-and v imm-mask) type-struct))) + (= type-struct (bitwise-and v imm-mask))) + +(define (untag i) + (arithmetic-shift (arithmetic-shift i (- (integer-length ptr-mask))) + (integer-length ptr-mask))) + +(define (heap-ref i) + (ptr-ref (cast (untag i) _int64 _pointer) _int64)) + +(define (char-ref i j) + (integer->char (ptr-ref (cast (untag i) _int64 _pointer) _uint32 j))) diff --git a/langs/neerdowell/unload-bits-asm.rkt b/langs/neerdowell/unload-bits-asm.rkt deleted file mode 100644 index 3274b657..00000000 --- a/langs/neerdowell/unload-bits-asm.rkt +++ /dev/null @@ -1,57 +0,0 @@ -#lang racket -(provide unload/free unload-value) -(require "types.rkt" - ffi/unsafe) - -(struct struct-val () #:transparent) - -;; Answer* -> Answer -(define (unload/free a) - (match a - ['err 'err] - [(cons h v) (begin0 (unload-value v) - (free h))])) - -;; Value* -> Value -(define (unload-value v) - (match v - [(? imm-bits?) (bits->value v)] - [(? box-bits? i) - (box (unload-value (heap-ref i)))] - [(? cons-bits? i) - (cons (unload-value (heap-ref (+ i 8))) - (unload-value (heap-ref i)))] - [(? vect-bits? i) - (if (zero? (untag i)) - (vector) - (build-vector (heap-ref i) - (lambda (j) - (unload-value (heap-ref (+ i (* 8 (add1 j))))))))] - [(? str-bits? i) - (if (zero? (untag i)) - (string) - (build-string (heap-ref i) - (lambda (j) - (char-ref (+ i 8) j))))] - [(? symb-bits? i) - (string->symbol - (if (zero? (untag i)) - (string) - (build-string (heap-ref i) - (lambda (j) - (char-ref (+ i 8) j)))))] - [(? proc-bits? i) - (lambda _ - (error "This function is not callable."))] - [(? struct-bits? i) - (struct-val)])) - -(define (untag i) - (arithmetic-shift (arithmetic-shift i (- (integer-length ptr-mask))) - (integer-length ptr-mask))) - -(define (heap-ref i) - (ptr-ref (cast (untag i) _int64 _pointer) _int64)) - -(define (char-ref i j) - (integer->char (ptr-ref (cast (untag i) _int64 _pointer) _uint32 j))) diff --git a/langs/neerdowell/utils.rkt b/langs/neerdowell/utils.rkt index f0b06af6..612b7381 100644 --- a/langs/neerdowell/utils.rkt +++ b/langs/neerdowell/utils.rkt @@ -1,33 +1,13 @@ #lang racket -(provide symbol->label symbol->data-label lookup pad-stack unpad-stack) +(provide symbol->data-label lookup pad-stack unpad-stack) (require a86/ast) (define rsp 'rsp) (define r15 'r15) -;; Symbol -> Label -;; Produce a symbol that is a valid Nasm label -(define (symbol->label s) - (to-label "label_" s)) - (define (symbol->data-label s) - (to-label "data_" s)) - -(define (to-label prefix s) - (string->symbol - (string-append - prefix - (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)))) + (symbol->label + (string->symbol (string-append "data_" (symbol->string s))))) ;; Id CEnv -> [Maybe Integer] (define (lookup x cenv) diff --git a/langs/outlaw/Makefile b/langs/outlaw/Makefile index 48c629c0..26a65a57 100644 --- a/langs/outlaw/Makefile +++ b/langs/outlaw/Makefile @@ -78,7 +78,8 @@ stdlib.s: stdlib.rkt cat $< | racket -t compile-stdin.rkt -m > $@ clean: - rm *.o *.s *.run outlaw.rkt + @$(RM) *.o *.s *.run outlaw.rkt ||: + @echo "$(shell basename $(shell pwd)): cleaned!" outlaw2.s: outlaw.rkt outlaw.run cat outlaw.rkt | ./outlaw.run > outlaw2.s diff --git a/langs/shakedown/Makefile b/langs/shakedown/Makefile deleted file mode 100644 index 0fc515c3..00000000 --- a/langs/shakedown/Makefile +++ /dev/null @@ -1,34 +0,0 @@ -UNAME := $(shell uname) -.PHONY: test - -ifeq ($(UNAME), Darwin) - format=macho64 -else ifeq ($(UNAME), Linux) - format=elf64 -else - format=win64 -endif - -%.run: %.o main.o char.o clib.o - gcc main.o char.o clib.o $< -o $@ - -main.o: main.c types.h - gcc -c main.c -o main.o - -char.o: char.c types.h - gcc -c char.c -o char.o - -clib.o: clib.c types.h - gcc -c clib.c -o clib.o - -%.o: %.s - nasm -f $(format) -o $@ $< - -%.s: %.shk - racket -t compile-file.rkt -m $< > $@ - -clean: - rm *.o *.s *.run - -test: 42.run - @test "$(shell ./42.run)" = "42" diff --git a/langs/shakedown/asm/interp.rkt b/langs/shakedown/asm/interp.rkt deleted file mode 100644 index 8e05688f..00000000 --- a/langs/shakedown/asm/interp.rkt +++ /dev/null @@ -1,23 +0,0 @@ -#lang racket -(provide (all-defined-out)) -(require "printer.rkt" racket/runtime-path) -(define-runtime-path dir "..") - -;; Asm -> Integer -;; Interpret (by assemblying, linking, and exec'ing) x86-64 code -;; Assume: starts with entry point run-time expects -(define (asm-interp a) - (let* ((t.s (make-temporary-file "nasm~a.s")) - (t.run (path-replace-extension t.s #".run"))) - (with-output-to-file t.s - #:exists 'truncate - (λ () - (asm-display a))) - (system (format "(cd ~a && make -s ~a) 2>&1 >/dev/null" dir t.run)) - (delete-file t.s) - (with-input-from-string - (with-output-to-string - (λ () - (system (path->string t.run)) - (delete-file t.run))) - read))) diff --git a/langs/shakedown/asm/printer.rkt b/langs/shakedown/asm/printer.rkt deleted file mode 100644 index ba32f33c..00000000 --- a/langs/shakedown/asm/printer.rkt +++ /dev/null @@ -1,83 +0,0 @@ -#lang racket -(provide (all-defined-out)) - -;; Asm -> String -(define (asm->string a) - (foldr (λ (i s) (string-append (instr->string i) s)) "" a)) - -;; Instruction -> String -(define (instr->string i) - (match i - [`(,(? opcode2? o) ,a1 ,a2) - (string-append "\t" - (symbol->string o) " " - (arg->string a1) ", " - (arg->string a2) "\n")] - [`(jmp ,l) - (string-append "\tjmp " (arg->string l) "\n")] - [`(je ,l) - (string-append "\tje " (label->string l) "\n")] - [`(jle ,l) - (string-append "\tjle " (label->string l) "\n")] - [`(jl ,l) - (string-append "\tjl " (label->string l) "\n")] - [`(jg ,l) - (string-append "\tjg " (label->string l) "\n")] - [`(jge ,l) - (string-append "\tjge " (label->string l) "\n")] - [`(jne ,l) - (string-append "\tjne " (label->string l) "\n")] - [`ret "\tret\n"] - [`(neg ,a1) - (string-append "\tneg " (arg->string a1) "\n")] - [`(call ,l) - (string-append "\tcall " (arg->string l) "\n")] - [`(push ,r) - (string-append "\tpush " (reg->string r) "\n")] - [`(extern ,f) - (string-append "\textern " (label->string f) "\n")] - [`(section text) "\tsection .text\n"] - [l (string-append (label->string l) ":\n")])) - -(define (opcode2? x) - (memq x '(mov add sub cmp and cmovl xor or sal sar lea))) - -;; Arg -> String -(define (arg->string a) - (match a - [(? reg?) (reg->string a)] - [`(offset ,r) - (string-append "[" (arg->string r) "]")] - [`(offset ,r ,i) - (string-append "[" (arg->string r) " + " (number->string (* i 8)) "]")] - [(? integer?) (number->string a)] - [(? symbol?) (label->string a)])) - -(define all-regs '(rax rbx rcx rdx rsp rdi rip rbp rsi r8 r9 r10 r11 r12 r13 r14 r15)) - -;; Any -> Boolean -(define (reg? x) - (and (symbol? x) - (memq x all-regs))) - -;; Reg -> String -(define (reg->string r) - (symbol->string r)) - -;; Label -> String -;; prefix with _ for Mac -(define label->string - (match (system-type 'os) - ['macosx - (λ (s) (string-append "_" (symbol->string s)))] - [_ symbol->string])) - -;; Asm -> Void -(define (asm-display a) - ;; entry point will be first label - (let ((g (findf symbol? a))) - (display - (string-append "\tglobal " (label->string g) "\n" - "\tdefault rel\n" - "\textern " (label->string 'error) "\n" - (asm->string a))))) diff --git a/langs/shakedown/ast.rkt b/langs/shakedown/ast.rkt deleted file mode 100644 index 6410a0d7..00000000 --- a/langs/shakedown/ast.rkt +++ /dev/null @@ -1,183 +0,0 @@ -#lang racket -(provide (all-defined-out)) - -;; type Prog = [FunDef] Expr - -;; type FunDef = Variable [Variable] Expr - -;; type Expr = -;; | Integer -;; | Boolean -;; | Character -;; | Variable -;; | Prim1 Expr -;; | Prim2 Expr Expr -;; | Lam Name [Variable] Expr <--- New for Loot -;; | App Expr [Expr] <--- Changed for Loot -;; | If Expr Expr Expr -;; | Let (Binding list) Expr -;; | LetRec (Binding list) Expr <--- New for Loot (See the lecture notes!) -;; | Nil - -;; Note: Fun and Call, from Knock, are gone! -;; They have been made redundant by the combination -;; of Lam (which is new) and App (which has been modified) - -;; type Prim1 = 'add1 | 'sub1 | 'zero? | box | unbox | car | cdr -;; type Prim2 = '+ | '- | cons - -;; type Binding = Variable Expr - -;; type Variable = Symbol (except 'add1 'sub1 'if, etc.) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;;;; The represenation of top-level programs -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(struct prog (ds e) #:transparent) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;;;; The represenation of a function definition -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;; A FunDef has a symbol for the function's name, -;; a list of symbols representing the names of the function's -;; arguments, and one expression that forms the body of the function. -(struct fundef (name args body) #:transparent) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;;;; The Expr data structure -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;; An Expr can be viewed as having 'kinds' of nodes. -;; -;; * The nodes that represnt an expression themselves -;; -;; * The nodes that are part of an expression, but no an expression themselves - -;; The below are the former: - -(struct int-e (i) #:transparent) -(struct bool-e (b) #:transparent) -(struct char-e (c) #:transparent) -(struct var-e (v) #:transparent) -(struct prim-e (p es) #:transparent) -(struct lam-e (vs es) #:transparent) -(struct lam-t (n vs es) #:transparent) -(struct app-e (f es) #:transparent) -(struct ccall-e (f es) #:transparent) ; <- new for Shakedown -(struct if-e (e t f) #:transparent) -(struct let-e (bs b) #:transparent) -(struct letr-e (bs b) #:transparent) -(struct nil-e () #:transparent) - -;; The next is the latter: - -;; A binding holds a symbol representing the bound variable and -;; Expr that represents the value that will be bound to that variable -(struct binding (v e) #:transparent) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;;;; AST nodes for closures (used for pedagogical purposes) -;;;;;; (see interp-defun.rkt) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(struct closure (fs e env) #:transparent) -(struct rec-closure (lam fenv) #:transparent) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;;;; AST utility functions (predicates) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define unops '(add1 sub1 zero? box unbox empty? car cdr)) -(define biops '(+ - cons)) - -;; Any -> Boolean -(define (prim? x) - (and (symbol? x) - (memq x (append unops biops)))) - -;; Any -> Boolean -(define (biop? x) - (and (symbol? x) - (memq x biops))) - -;; Any -> Boolean -(define (unop? x) - (and (symbol? x) - (memq x unops))) - -(define (value? v) - (or (int-e? v) - (bool-e? v))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;;;; AST utility functions (getters) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;; It will sometimes be useful to get the list of all the variables that are -;; introduced by a `let` -;; [Binding] -> [Symbol] -(define (get-vars bs) - (match bs - ['() '()] - [(cons (binding v _) bs) (cons v (get-vars bs))])) - -;; Get all of the _definitions_ from a list of bindings -;; [Binding] -> [Expr] -(define (get-defs bs) - (match bs - ['() '()] - [(cons (binding _ def) bs) (cons def (get-defs bs))])) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;;;; AST utility functions (maps) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define (bindings-map-def f bs) - (match bs - ['() '()] - [(cons (binding n def) bs) - (cons (binding n (f def)) (bindings-map-def f bs))])) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;;;; AST utility functions (printers) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;; We have switched to using `#:transparent` above, so this should only be -;; necessary if you're desperate when debugging :'( - -;; Given a Program, construct an sexpr that has the same shape -(define (prog-debug p) - (match p - [(prog ds e) `(prog ,(map fundef-debug ds) ,(ast-debug e))])) - -;; Given a FunDef, construct an sexpr that has the same shape -(define (fundef-debug def) - (match def - [(fundef name args body) `(fundef ,name ,args ,(ast-debug body))])) - -;; Given an AST, construct an sexpr that has the same shape -(define (ast-debug a) - (match a - [(int-e i) `(int-e ,i)] - [(bool-e b) `(bool-e ,b)] - [(char-e c) `(char-e ,c)] - [(var-e v) `(var-e ,v)] - [(nil-e) ''()] - [(prim-e p es) `(prim-e ,p ,@(map ast-debug es))] - [(lam-t n vs e)`(lam-t ,n ,vs ,(ast-debug e))] - [(lam-e vs e) `(lam-e ,vs ,(ast-debug e))] - [(app-e f es) `(app-e ,(ast-debug f) ,@(map ast-debug es))] - [(if-e e t f) `(if-e ,(ast-debug e) - ,(ast-debug t) - ,(ast-debug f))] - [(let-e bs b) `(let-e ,(binding-debug bs) ,(ast-debug b))] - [(letr-e bs b) `(letr-e ,(binding-debug bs) ,(ast-debug b))])) - -(define (binding-debug bnds) - (match bnds - ['() '()] - [(cons (binding v e) bnds) `((,v ,(ast-debug e)) ,@(binding-debug bnds))])) diff --git a/langs/shakedown/char.c b/langs/shakedown/char.c deleted file mode 100644 index 631e02ea..00000000 --- a/langs/shakedown/char.c +++ /dev/null @@ -1,692 +0,0 @@ -#include -#include -#include "types.h" - -void print_string_char_u(int64_t v) { - printf("\\u%04X", (int)(v >> imm_shift)); -} - -void print_string_char_U(int64_t v) { - printf("\\U%08X", (int)(v >> imm_shift)); -} - -void print_codepoint(int64_t v) { - int64_t codepoint = v >> imm_shift; - // Print using UTF-8 encoding of codepoint - // https://en.wikipedia.org/wiki/UTF-8 - if (codepoint < 128) { - printf("%c", (char) codepoint); - } else if (codepoint < 2048) { - printf("%c%c", - (char)(codepoint >> 6) | 192, - ((char)codepoint & 63) | 128); - } else if (codepoint < 65536) { - printf("%c%c%c", - (char)(codepoint >> 12) | 224, - ((char)(codepoint >> 6) & 63) | 128, - ((char)codepoint & 63) | 128); - } else { - printf("%c%c%c%c", - (char)(codepoint >> 18) | 240, - ((char)(codepoint >> 12) & 63) | 128, - ((char)(codepoint >> 6) & 63) | 128, - ((char)codepoint & 63) | 128); - } -} - -void print_string_char(int64_t v) { - switch (v >> imm_shift) { - case 0 ... 6: - print_string_char_u(v); - break; - case 7: - printf("\\a"); - break; - case 8: - printf("\\b"); - break; - case 9: - printf("\\t"); - break; - case 10: - printf("\\n"); - break; - case 11: - printf("\\v"); - break; - case 12: - printf("\\f"); - break; - case 13: - printf("\\r"); - break; - case 14 ... 26: - print_string_char_u(v); - break; - case 27: - printf("\\e"); - break; - case 28 ... 31: - print_string_char_u(v); - break; - case 34: - printf("\\\""); - break; - case 39: - printf("'"); - break; - case 92: - printf("\\\\"); - break; - case 127 ... 159: - case 173 ... 173: - case 888 ... 889: - case 896 ... 899: - case 907 ... 907: - case 909 ... 909: - case 930 ... 930: - case 1328 ... 1328: - case 1367 ... 1368: - case 1376 ... 1376: - case 1416 ... 1416: - case 1419 ... 1420: - case 1424 ... 1424: - case 1480 ... 1487: - case 1515 ... 1519: - case 1525 ... 1541: - case 1564 ... 1565: - case 1757 ... 1757: - case 1806 ... 1807: - case 1867 ... 1868: - case 1970 ... 1983: - case 2043 ... 2047: - case 2094 ... 2095: - case 2111 ... 2111: - case 2140 ... 2141: - case 2143 ... 2207: - case 2227 ... 2275: - case 2436 ... 2436: - case 2445 ... 2446: - case 2449 ... 2450: - case 2473 ... 2473: - case 2481 ... 2481: - case 2483 ... 2485: - case 2490 ... 2491: - case 2501 ... 2502: - case 2505 ... 2506: - case 2511 ... 2518: - case 2520 ... 2523: - case 2526 ... 2526: - case 2532 ... 2533: - case 2556 ... 2560: - case 2564 ... 2564: - case 2571 ... 2574: - case 2577 ... 2578: - case 2601 ... 2601: - case 2609 ... 2609: - case 2612 ... 2612: - case 2615 ... 2615: - case 2618 ... 2619: - case 2621 ... 2621: - case 2627 ... 2630: - case 2633 ... 2634: - case 2638 ... 2640: - case 2642 ... 2648: - case 2653 ... 2653: - case 2655 ... 2661: - case 2678 ... 2688: - case 2692 ... 2692: - case 2702 ... 2702: - case 2706 ... 2706: - case 2729 ... 2729: - case 2737 ... 2737: - case 2740 ... 2740: - case 2746 ... 2747: - case 2758 ... 2758: - case 2762 ... 2762: - case 2766 ... 2767: - case 2769 ... 2783: - case 2788 ... 2789: - case 2802 ... 2816: - case 2820 ... 2820: - case 2829 ... 2830: - case 2833 ... 2834: - case 2857 ... 2857: - case 2865 ... 2865: - case 2868 ... 2868: - case 2874 ... 2875: - case 2885 ... 2886: - case 2889 ... 2890: - case 2894 ... 2901: - case 2904 ... 2907: - case 2910 ... 2910: - case 2916 ... 2917: - case 2936 ... 2945: - case 2948 ... 2948: - case 2955 ... 2957: - case 2961 ... 2961: - case 2966 ... 2968: - case 2971 ... 2971: - case 2973 ... 2973: - case 2976 ... 2978: - case 2981 ... 2983: - case 2987 ... 2989: - case 3002 ... 3005: - case 3011 ... 3013: - case 3017 ... 3017: - case 3022 ... 3023: - case 3025 ... 3030: - case 3032 ... 3045: - case 3067 ... 3071: - case 3076 ... 3076: - case 3085 ... 3085: - case 3089 ... 3089: - case 3113 ... 3113: - case 3130 ... 3132: - case 3141 ... 3141: - case 3145 ... 3145: - case 3150 ... 3156: - case 3159 ... 3159: - case 3162 ... 3167: - case 3172 ... 3173: - case 3184 ... 3191: - case 3200 ... 3200: - case 3204 ... 3204: - case 3213 ... 3213: - case 3217 ... 3217: - case 3241 ... 3241: - case 3252 ... 3252: - case 3258 ... 3259: - case 3269 ... 3269: - case 3273 ... 3273: - case 3278 ... 3284: - case 3287 ... 3293: - case 3295 ... 3295: - case 3300 ... 3301: - case 3312 ... 3312: - case 3315 ... 3328: - case 3332 ... 3332: - case 3341 ... 3341: - case 3345 ... 3345: - case 3387 ... 3388: - case 3397 ... 3397: - case 3401 ... 3401: - case 3407 ... 3414: - case 3416 ... 3423: - case 3428 ... 3429: - case 3446 ... 3448: - case 3456 ... 3457: - case 3460 ... 3460: - case 3479 ... 3481: - case 3506 ... 3506: - case 3516 ... 3516: - case 3518 ... 3519: - case 3527 ... 3529: - case 3531 ... 3534: - case 3541 ... 3541: - case 3543 ... 3543: - case 3552 ... 3557: - case 3568 ... 3569: - case 3573 ... 3584: - case 3643 ... 3646: - case 3676 ... 3712: - case 3715 ... 3715: - case 3717 ... 3718: - case 3721 ... 3721: - case 3723 ... 3724: - case 3726 ... 3731: - case 3736 ... 3736: - case 3744 ... 3744: - case 3748 ... 3748: - case 3750 ... 3750: - case 3752 ... 3753: - case 3756 ... 3756: - case 3770 ... 3770: - case 3774 ... 3775: - case 3781 ... 3781: - case 3783 ... 3783: - case 3790 ... 3791: - case 3802 ... 3803: - case 3808 ... 3839: - case 3912 ... 3912: - case 3949 ... 3952: - case 3992 ... 3992: - case 4029 ... 4029: - case 4045 ... 4045: - case 4059 ... 4095: - case 4294 ... 4294: - case 4296 ... 4300: - case 4302 ... 4303: - case 4681 ... 4681: - case 4686 ... 4687: - case 4695 ... 4695: - case 4697 ... 4697: - case 4702 ... 4703: - case 4745 ... 4745: - case 4750 ... 4751: - case 4785 ... 4785: - case 4790 ... 4791: - case 4799 ... 4799: - case 4801 ... 4801: - case 4806 ... 4807: - case 4823 ... 4823: - case 4881 ... 4881: - case 4886 ... 4887: - case 4955 ... 4956: - case 4989 ... 4991: - case 5018 ... 5023: - case 5109 ... 5119: - case 5789 ... 5791: - case 5881 ... 5887: - case 5901 ... 5901: - case 5909 ... 5919: - case 5943 ... 5951: - case 5972 ... 5983: - case 5997 ... 5997: - case 6001 ... 6001: - case 6004 ... 6015: - case 6110 ... 6111: - case 6122 ... 6127: - case 6138 ... 6143: - case 6158 ... 6159: - case 6170 ... 6175: - case 6264 ... 6271: - case 6315 ... 6319: - case 6390 ... 6399: - case 6431 ... 6431: - case 6444 ... 6447: - case 6460 ... 6463: - case 6465 ... 6467: - case 6510 ... 6511: - case 6517 ... 6527: - case 6572 ... 6575: - case 6602 ... 6607: - case 6619 ... 6621: - case 6684 ... 6685: - case 6751 ... 6751: - case 6781 ... 6782: - case 6794 ... 6799: - case 6810 ... 6815: - case 6830 ... 6831: - case 6847 ... 6911: - case 6988 ... 6991: - case 7037 ... 7039: - case 7156 ... 7163: - case 7224 ... 7226: - case 7242 ... 7244: - case 7296 ... 7359: - case 7368 ... 7375: - case 7415 ... 7415: - case 7418 ... 7423: - case 7670 ... 7675: - case 7958 ... 7959: - case 7966 ... 7967: - case 8006 ... 8007: - case 8014 ... 8015: - case 8024 ... 8024: - case 8026 ... 8026: - case 8028 ... 8028: - case 8030 ... 8030: - case 8062 ... 8063: - case 8117 ... 8117: - case 8133 ... 8133: - case 8148 ... 8149: - case 8156 ... 8156: - case 8176 ... 8177: - case 8181 ... 8181: - case 8191 ... 8191: - case 8203 ... 8207: - case 8232 ... 8238: - case 8288 ... 8303: - case 8306 ... 8307: - case 8335 ... 8335: - case 8349 ... 8351: - case 8382 ... 8399: - case 8433 ... 8447: - case 8586 ... 8591: - case 9211 ... 9215: - case 9255 ... 9279: - case 9291 ... 9311: - case 11124 ... 11125: - case 11158 ... 11159: - case 11194 ... 11196: - case 11209 ... 11209: - case 11218 ... 11263: - case 11311 ... 11311: - case 11359 ... 11359: - case 11508 ... 11512: - case 11558 ... 11558: - case 11560 ... 11564: - case 11566 ... 11567: - case 11624 ... 11630: - case 11633 ... 11646: - case 11671 ... 11679: - case 11687 ... 11687: - case 11695 ... 11695: - case 11703 ... 11703: - case 11711 ... 11711: - case 11719 ... 11719: - case 11727 ... 11727: - case 11735 ... 11735: - case 11743 ... 11743: - case 11843 ... 11903: - case 11930 ... 11930: - case 12020 ... 12031: - case 12246 ... 12271: - case 12284 ... 12287: - case 12352 ... 12352: - case 12439 ... 12440: - case 12544 ... 12548: - case 12590 ... 12592: - case 12687 ... 12687: - case 12731 ... 12735: - case 12772 ... 12783: - case 12831 ... 12831: - case 13055 ... 13055: - case 19894 ... 19903: - case 40909 ... 40959: - case 42125 ... 42127: - case 42183 ... 42191: - case 42540 ... 42559: - case 42654 ... 42654: - case 42744 ... 42751: - case 42895 ... 42895: - case 42926 ... 42927: - case 42930 ... 42998: - case 43052 ... 43055: - case 43066 ... 43071: - case 43128 ... 43135: - case 43205 ... 43213: - case 43226 ... 43231: - case 43260 ... 43263: - case 43348 ... 43358: - case 43389 ... 43391: - case 43470 ... 43470: - case 43482 ... 43485: - case 43519 ... 43519: - case 43575 ... 43583: - case 43598 ... 43599: - case 43610 ... 43611: - case 43715 ... 43738: - case 43767 ... 43776: - case 43783 ... 43784: - case 43791 ... 43792: - case 43799 ... 43807: - case 43815 ... 43815: - case 43823 ... 43823: - case 43872 ... 43875: - case 43878 ... 43967: - case 44014 ... 44015: - case 44026 ... 44031: - case 55204 ... 55215: - case 55239 ... 55242: - case 55292 ... 55295: - case 57344 ... 63743: - case 64110 ... 64111: - case 64218 ... 64255: - case 64263 ... 64274: - case 64280 ... 64284: - case 64311 ... 64311: - case 64317 ... 64317: - case 64319 ... 64319: - case 64322 ... 64322: - case 64325 ... 64325: - case 64450 ... 64466: - case 64832 ... 64847: - case 64912 ... 64913: - case 64968 ... 65007: - case 65022 ... 65023: - case 65050 ... 65055: - case 65070 ... 65071: - case 65107 ... 65107: - case 65127 ... 65127: - case 65132 ... 65135: - case 65141 ... 65141: - case 65277 ... 65280: - case 65471 ... 65473: - case 65480 ... 65481: - case 65488 ... 65489: - case 65496 ... 65497: - case 65501 ... 65503: - case 65511 ... 65511: - case 65519 ... 65531: - case 65534 ... 65535: - print_string_char_u(v); - break; - case 65548 ... 65548: - case 65575 ... 65575: - case 65595 ... 65595: - case 65598 ... 65598: - case 65614 ... 65615: - case 65630 ... 65663: - case 65787 ... 65791: - case 65795 ... 65798: - case 65844 ... 65846: - case 65933 ... 65935: - case 65948 ... 65951: - case 65953 ... 65999: - case 66046 ... 66175: - case 66205 ... 66207: - case 66257 ... 66271: - case 66300 ... 66303: - case 66340 ... 66351: - case 66379 ... 66383: - case 66427 ... 66431: - case 66462 ... 66462: - case 66500 ... 66503: - case 66518 ... 66559: - case 66718 ... 66719: - case 66730 ... 66815: - case 66856 ... 66863: - case 66916 ... 66926: - case 66928 ... 67071: - case 67383 ... 67391: - case 67414 ... 67423: - case 67432 ... 67583: - case 67590 ... 67591: - case 67593 ... 67593: - case 67638 ... 67638: - case 67641 ... 67643: - case 67645 ... 67646: - case 67670 ... 67670: - case 67743 ... 67750: - case 67760 ... 67839: - case 67868 ... 67870: - case 67898 ... 67902: - case 67904 ... 67967: - case 68024 ... 68029: - case 68032 ... 68095: - case 68100 ... 68100: - case 68103 ... 68107: - case 68116 ... 68116: - case 68120 ... 68120: - case 68148 ... 68151: - case 68155 ... 68158: - case 68168 ... 68175: - case 68185 ... 68191: - case 68256 ... 68287: - case 68327 ... 68330: - case 68343 ... 68351: - case 68406 ... 68408: - case 68438 ... 68439: - case 68467 ... 68471: - case 68498 ... 68504: - case 68509 ... 68520: - case 68528 ... 68607: - case 68681 ... 69215: - case 69247 ... 69631: - case 69710 ... 69713: - case 69744 ... 69758: - case 69821 ... 69821: - case 69826 ... 69839: - case 69865 ... 69871: - case 69882 ... 69887: - case 69941 ... 69941: - case 69956 ... 69967: - case 70007 ... 70015: - case 70089 ... 70092: - case 70094 ... 70095: - case 70107 ... 70112: - case 70133 ... 70143: - case 70162 ... 70162: - case 70206 ... 70319: - case 70379 ... 70383: - case 70394 ... 70400: - case 70404 ... 70404: - case 70413 ... 70414: - case 70417 ... 70418: - case 70441 ... 70441: - case 70449 ... 70449: - case 70452 ... 70452: - case 70458 ... 70459: - case 70469 ... 70470: - case 70473 ... 70474: - case 70478 ... 70486: - case 70488 ... 70492: - case 70500 ... 70501: - case 70509 ... 70511: - case 70517 ... 70783: - case 70856 ... 70863: - case 70874 ... 71039: - case 71094 ... 71095: - case 71114 ... 71167: - case 71237 ... 71247: - case 71258 ... 71295: - case 71352 ... 71359: - case 71370 ... 71839: - case 71923 ... 71934: - case 71936 ... 72383: - case 72441 ... 73727: - case 74649 ... 74751: - case 74863 ... 74863: - case 74869 ... 77823: - case 78895 ... 92159: - case 92729 ... 92735: - case 92767 ... 92767: - case 92778 ... 92781: - case 92784 ... 92879: - case 92910 ... 92911: - case 92918 ... 92927: - case 92998 ... 93007: - case 93018 ... 93018: - case 93026 ... 93026: - case 93048 ... 93052: - case 93072 ... 93951: - case 94021 ... 94031: - case 94079 ... 94094: - case 94112 ... 110591: - case 110594 ... 113663: - case 113771 ... 113775: - case 113789 ... 113791: - case 113801 ... 113807: - case 113818 ... 113819: - case 113824 ... 118783: - case 119030 ... 119039: - case 119079 ... 119080: - case 119155 ... 119162: - case 119262 ... 119295: - case 119366 ... 119551: - case 119639 ... 119647: - case 119666 ... 119807: - case 119893 ... 119893: - case 119965 ... 119965: - case 119968 ... 119969: - case 119971 ... 119972: - case 119975 ... 119976: - case 119981 ... 119981: - case 119994 ... 119994: - case 119996 ... 119996: - case 120004 ... 120004: - case 120070 ... 120070: - case 120075 ... 120076: - case 120085 ... 120085: - case 120093 ... 120093: - case 120122 ... 120122: - case 120127 ... 120127: - case 120133 ... 120133: - case 120135 ... 120137: - case 120145 ... 120145: - case 120486 ... 120487: - case 120780 ... 120781: - case 120832 ... 124927: - case 125125 ... 125126: - case 125143 ... 126463: - case 126468 ... 126468: - case 126496 ... 126496: - case 126499 ... 126499: - case 126501 ... 126502: - case 126504 ... 126504: - case 126515 ... 126515: - case 126520 ... 126520: - case 126522 ... 126522: - case 126524 ... 126529: - case 126531 ... 126534: - case 126536 ... 126536: - case 126538 ... 126538: - case 126540 ... 126540: - case 126544 ... 126544: - case 126547 ... 126547: - case 126549 ... 126550: - case 126552 ... 126552: - case 126554 ... 126554: - case 126556 ... 126556: - case 126558 ... 126558: - case 126560 ... 126560: - case 126563 ... 126563: - case 126565 ... 126566: - case 126571 ... 126571: - case 126579 ... 126579: - case 126584 ... 126584: - case 126589 ... 126589: - case 126591 ... 126591: - case 126602 ... 126602: - case 126620 ... 126624: - case 126628 ... 126628: - case 126634 ... 126634: - case 126652 ... 126703: - case 126706 ... 126975: - case 127020 ... 127023: - case 127124 ... 127135: - case 127151 ... 127152: - case 127168 ... 127168: - case 127184 ... 127184: - case 127222 ... 127231: - case 127245 ... 127247: - case 127279 ... 127279: - case 127340 ... 127343: - case 127387 ... 127461: - case 127491 ... 127503: - case 127547 ... 127551: - case 127561 ... 127567: - case 127570 ... 127743: - case 127789 ... 127791: - case 127870 ... 127871: - case 127951 ... 127955: - case 127992 ... 127999: - case 128255 ... 128255: - case 128331 ... 128335: - case 128378 ... 128378: - case 128420 ... 128420: - case 128579 ... 128580: - case 128720 ... 128735: - case 128749 ... 128751: - case 128756 ... 128767: - case 128884 ... 128895: - case 128981 ... 129023: - case 129036 ... 129039: - case 129096 ... 129103: - case 129114 ... 129119: - case 129160 ... 129167: - case 129198 ... 131071: - case 173783 ... 173823: - case 177973 ... 177983: - case 178206 ... 194559: - case 195102 ... 917759: - case 918000 ... 1114110: - print_string_char_U(v); - break; - default: - print_codepoint(v); - break; - } -} diff --git a/langs/shakedown/clib.c b/langs/shakedown/clib.c deleted file mode 100644 index e4890547..00000000 --- a/langs/shakedown/clib.c +++ /dev/null @@ -1,15 +0,0 @@ -#include -#include -#include -#include "types.h" - -int64_t c_fun() { - puts("Hello, from C!"); - return (42 << imm_shift); -} - -int64_t c_fun1(int64_t x) { - printf("You gave me x = %" PRId64 "\n", x); - int64_t res = x * x; - return (res << imm_shift); -} diff --git a/langs/shakedown/compile-file.rkt b/langs/shakedown/compile-file.rkt deleted file mode 100644 index b993b89d..00000000 --- a/langs/shakedown/compile-file.rkt +++ /dev/null @@ -1,18 +0,0 @@ -#lang racket -(provide (all-defined-out)) -(require "compile.rkt" "syntax.rkt" "asm/printer.rkt") - -;; String -> Void -;; Compile contents of given file name, -;; emit asm code on stdout -(define (main fn) - (with-input-from-file fn - (λ () - (let ((p (read-program))) - ; assumed OK for now - ;(unless (and (prog? p) (closed? p)) - ; (error "syntax error")) - (asm-display (compile (sexpr->prog p))))))) - -(define (read-program) - (read)) diff --git a/langs/shakedown/compile.rkt b/langs/shakedown/compile.rkt deleted file mode 100644 index 5d0fed59..00000000 --- a/langs/shakedown/compile.rkt +++ /dev/null @@ -1,582 +0,0 @@ -#lang racket -(require "syntax.rkt" "ast.rkt") -(provide (all-defined-out)) - -;; An immediate is anything ending in #b000 -;; All other tags in mask #b111 are pointers - -(define result-shift 3) -(define result-type-mask (sub1 (arithmetic-shift 1 result-shift))) -(define type-imm #b000) -(define type-box #b001) -(define type-pair #b010) -(define type-string #b011) -(define type-proc #b100) - -(define imm-shift (+ 2 result-shift)) -(define imm-type-mask (sub1 (arithmetic-shift 1 imm-shift))) -(define imm-type-int (arithmetic-shift #b00 result-shift)) -(define imm-type-bool (arithmetic-shift #b01 result-shift)) -(define imm-type-char (arithmetic-shift #b10 result-shift)) -(define imm-type-empty (arithmetic-shift #b11 result-shift)) -(define imm-val-false imm-type-bool) -(define imm-val-true - (bitwise-ior (arithmetic-shift 1 (add1 imm-shift)) imm-type-bool)) - -;; Allocate in 64-bit (8-byte) increments, so pointers -;; end in #b000 and we tag with #b001 for boxes, etc. - -;; type CEnv = (Listof (Maybe Variable)) -;; type Imm = Integer | Boolean | Char | ''() - -;; type LExpr = -;; .... -;; | `(λ ,Formals ,Label ,Expr) - -;; type Label = (quote Symbol) - -;; Prog -> Asm -(define (compile p) - ; Remove all of the explicit function definitions - (match (desugar-prog p) - [(prog _ e) - (compile-entry (label-λ e))])) - - -;; Expr -> Asm -(define (compile-entry e) - `(,@(make-externs (ffi-calls e)) - (section text) - entry - ,@(compile-tail-e e '()) - ret - ,@(compile-λ-definitions (λs e)) - err - (push rbp) - (call error) - ret)) - -;; (Listof Symbol) -> Asm -(define (make-externs fs) - (map (lambda (s) `(extern ,s)) fs)) - -;; (Listof Lambda) -> Asm -(define (compile-λ-definitions ls) - (apply append (map compile-λ-definition ls))) - -;; Lambda -> Asm -(define (compile-λ-definition l) - (match l - [(lam-t f xs e0) - (let ((c0 (compile-tail-e e0 (reverse (append xs (fvs l)))))) - `(,f - ,@c0 - ret))] - [(lam-e _ _) (error "Lambdas need to be labeled before compiling")])) - -;; LExpr CEnv -> Asm -;; Compile an expression in tail position -(define (compile-tail-e e c) - (match e - [(var-e v) (compile-variable v c)] - [(? imm? i) (compile-imm i)] - [(prim-e (? prim? p) es) (compile-prim p es c)] - [(if-e p t f) (compile-tail-if p t f c)] - [(let-e (list b) body) (compile-tail-let b body c)] - [(letr-e bs body) (compile-tail-letrec (get-vars bs) (get-defs bs) body c)] - [(app-e f es) (compile-tail-call f es c)] - [(lam-t l xs e0) (compile-λ xs l (fvs e) c)])) - - - -;; LExpr CEnv -> Asm -;; Compile an expression in non-tail position -(define (compile-e e c) - (match e - [(var-e v) (compile-variable v c)] - [(? imm? i) (compile-imm i)] - [(prim-e (? prim? p) es) (compile-prim p es c)] - [(if-e p t f) (compile-if p t f c)] - [(let-e (list b) body) (compile-let b body c)] - [(letr-e bs body) (compile-letrec (get-vars bs) (get-defs bs) body c)] - [(ccall-e f es) (compile-ccall f es c)] - [(app-e f es) (compile-call f es c)] - [(lam-t l xs e0) (compile-λ xs l (fvs e) c)])) - -;; Our current set of primitive operations require no function calls, -;; so there's no difference between tail and non-tail call positions -(define (compile-prim p es c) - (match (cons p es) - [`(box ,e0) (compile-box e0 c)] - [`(unbox ,e0) (compile-unbox e0 c)] - [`(cons ,e0 ,e1) (compile-cons e0 e1 c)] - [`(car ,e0) (compile-car e0 c)] - [`(cdr ,e0) (compile-cdr e0 c)] - [`(add1 ,e0) (compile-add1 e0 c)] - [`(sub1 ,e0) (compile-sub1 e0 c)] - [`(zero? ,e0) (compile-zero? e0 c)] - [`(empty? ,e0) (compile-empty? e0 c)] - [`(+ ,e0 ,e1) (compile-+ e0 e1 c)] - [_ (error - (format "prim applied to wrong number of args: ~a ~a" p es))])) - -;; Label (listof Expr) -> Asm -(define (compile-ccall f es c) - (let* ((c0 (store-caller-save caller-saves c)) - (c* (car c0)) - (c1 (compile-es-ffi es c* 0)) - (c2 (cdr (load-caller-save caller-saves c))) - (stack-size (* 8 (length c*)))) - - ; We don't actually have to do all caller-save (that's a lot!) - ; Just the ones that our compiler emits - `(,@(cdr c0) - - ,@c1 - (mov r15 rsp) ; Using the fact that r15 is callee save - - ; change rsp to reflect the top of the stack - (sub rsp ,stack-size) - - ; align rsp to safest 16-byte aligned spot - (and rsp -16) - - ; Actually call the function - (call ,f) - - ; Restore our stack - (mov rsp r15) - - ; Put the caller-saved values back - ,@c2))) - -;; The registers that we can use to pass arguments to C functions -;; (in the right order) -;; -(define arg-regs '(rdi rsi rdx rcx r8 r9)) -(define callee-saves '(rbp rbx r12 r13 r14 r15)) -(define caller-saves '(rcx rdx rdi rsi r8 r9 r10 r11)) - -; Make sure we store every caller-save register that we care about on the stack. -; This is basiclaly a foldMR, but I need to learn more Racket -(define (store-caller-save rs c) - (match rs - ['() (cons c '())] - [(cons r rs) - (match (store-caller-save rs c) - [(cons d asm) - (cons (cons #f d) - (append asm `((mov (offset rsp ,(- (add1 (length d)))) ,r))))])])) - -; Same as above but inverse -(define (load-caller-save rs c) - (match rs - ['() (cons c '())] - [(cons r rs) - (match (load-caller-save rs c) - [(cons d asm) - (cons (cons #f d) - (append asm `((mov ,r (offset rsp ,(- (add1 (length d))))))))])])) - - -;; JMCT: I keep 'programming in Haskell in Racket' and I need to stop that... -;; the above is my monadic habits biting me - -;; (Listof LExpr) CEnv -> Asm -(define (compile-es-ffi es c i) - (match es - ['() '()] - [(cons e es) - (let ((c0 (compile-e e c)) - (cs (compile-es-ffi es c (add1 i)))) - `(,@c0 - (sar rax ,imm-shift) - (mov ,(list-ref arg-regs i) rax) ; Put the result in the appropriate register - ,@cs))])) - - -;; (Listof Variable) Label (Listof Variable) CEnv -> Asm -(define (compile-λ xs f ys c) - ; Save label address - `((lea rax (offset ,f 0)) - (mov (offset rdi 0) rax) - - ; Save the environment - (mov r8 ,(length ys)) - (mov (offset rdi 1) r8) - (mov r9 rdi) - (add r9 16) - ,@(copy-env-to-heap ys c 0) - - ; Return a pointer to the closure - (mov rax rdi) - (or rax ,type-proc) - (add rdi ,(* 8 (+ 2 (length ys)))))) - -;; (Listof Variable) CEnv Natural -> Asm -;; Pointer to beginning of environment in r9 -(define (copy-env-to-heap fvs c i) - (match fvs - ['() '()] - [(cons x fvs) - `((mov r8 (offset rsp ,(- (add1 (lookup x c))))) - (mov (offset r9 ,i) r8) - ,@(copy-env-to-heap fvs c (add1 i)))])) - -;; Natural Natural -> Asm -;; Move i arguments upward on stack by offset off -(define (move-args i off) - (match i - [0 '()] - [_ `(,@(move-args (sub1 i) off) - (mov rbx (offset rsp ,(- off i))) - (mov (offset rsp ,(- i)) rbx))])) - -;; LExpr (Listof LExpr) CEnv -> Asm -(define (compile-call e0 es c) - (let ((cs (compile-es es (cons #f c))) - (c0 (compile-e e0 c)) - (i (- (add1 (length c)))) - (stack-size (* 8 (length c)))) - `(,@c0 - (mov (offset rsp ,i) rax) - ,@cs - (mov rax (offset rsp ,i)) - ,@assert-proc - (xor rax ,type-proc) - (sub rsp ,stack-size) - - (mov rcx rsp) ; start of stack in rcx - (add rcx ,(- (* 8 (+ 2 (length es))))) - ,@(copy-closure-env-to-stack) - - (call (offset rax 0)) - (add rsp ,stack-size)))) - -;; LExpr (Listof LExpr) CEnv -> Asm -(define (compile-tail-call e0 es c) - (let ((cs (compile-es es (cons #f c))) - (c0 (compile-e e0 c)) - (i (- (add1 (length c))))) - `(,@c0 - (mov (offset rsp ,i) rax) - ,@cs - (mov rax (offset rsp ,i)) - ,@(move-args (length es) i) - ,@assert-proc - (xor rax ,type-proc) - - (mov rcx rsp) ; start of stack in rcx - (add rcx ,(- (* 8 (+ 1 (length es))))) - ,@(copy-closure-env-to-stack) - - ;,@(copy-closure-env-to-stack (length es)) - (jmp (offset rax 0))))) - - -;; -> Asm -;; Copy closure's (in rax) env to stack in rcx -(define (copy-closure-env-to-stack) - (let ((copy-loop (gensym 'copy_closure)) - (copy-done (gensym 'copy_done))) - `((mov r8 (offset rax 1)) ; length - (mov r9 rax) - (add r9 16) ; start of env - ,copy-loop - (cmp r8 0) - (je ,copy-done) - (mov rbx (offset r9 0)) - (mov (offset rcx 0) rbx) ; Move val onto stack - (sub r8 1) - (add r9 8) - (sub rcx 8) - (jmp ,copy-loop) - ,copy-done))) - -;; (Listof Variable) (Listof Lambda) Expr CEnv -> Asm -(define (compile-letrec fs ls e c) - (let ((c0 (compile-letrec-λs ls c)) - (c1 (compile-letrec-init fs ls (append (reverse fs) c))) - (c2 (compile-e e (append (reverse fs) c)))) - `(,@c0 - ,@c1 - ,@c2))) - -;; (Listof Variable) (Listof Lambda) Expr CEnv -> Asm -(define (compile-tail-letrec fs ls e c) - (let ((c0 (compile-letrec-λs ls c)) - (c1 (compile-letrec-init fs ls (append (reverse fs) c))) - (c2 (compile-tail-e e (append (reverse fs) c)))) - `(,@c0 - ,@c1 - ,@c2))) - -;; (Listof Lambda) CEnv -> Asm -;; Create a bunch of uninitialized closures and push them on the stack -(define (compile-letrec-λs ls c) - (match ls - ['() '()] - [(cons l ls) - (match l - [(lam-t lab as body) - (let ((cs (compile-letrec-λs ls (cons #f c))) - (ys (fvs l))) - `((lea rax (offset ,lab 0)) - (mov (offset rdi 0) rax) - (mov rax ,(length ys)) - (mov (offset rdi 1) rax) - (mov rax rdi) - (or rax ,type-proc) - (add rdi ,(* 8 (+ 2 (length ys)))) - (mov (offset rsp ,(- (add1 (length c)))) rax) - ,@cs))])])) - -;; (Listof Variable) (Listof Lambda) CEnv -> Asm -(define (compile-letrec-init fs ls c) - (match fs - ['() '()] - [(cons f fs) - (let ((ys (fvs (first ls))) - (cs (compile-letrec-init fs (rest ls) c))) - `((mov r9 (offset rsp ,(- (add1 (lookup f c))))) - (xor r9 ,type-proc) - (add r9 16) ; move past label and length - ,@(copy-env-to-heap ys c 0) - ,@cs))])) - -;; (Listof LExpr) CEnv -> Asm -(define (compile-es es c) - (match es - ['() '()] - [(cons e es) - (let ((c0 (compile-e e c)) - (cs (compile-es es (cons #f c)))) - `(,@c0 - (mov (offset rsp ,(- (add1 (length c)))) rax) - ,@cs))])) - -;; Imm -> Asm -(define (compile-imm i) - `((mov rax ,(imm->bits i)))) - -;; Imm -> Integer -(define (imm->bits i) - (match i - [(int-e i) (arithmetic-shift i imm-shift)] - [(char-e c) (+ (arithmetic-shift (char->integer c) imm-shift) imm-type-char)] - [(bool-e b) (if b imm-val-true imm-val-false)] - [(nil-e) imm-type-empty])) - - -;; Variable CEnv -> Asm -(define (compile-variable x c) - (let ((i (lookup x c))) - `((mov rax (offset rsp ,(- (add1 i))))))) - -;; LExpr CEnv -> Asm -(define (compile-box e0 c) - (let ((c0 (compile-e e0 c))) - `(,@c0 - (mov (offset rdi 0) rax) - (mov rax rdi) - (or rax ,type-box) - (add rdi 8)))) ; allocate 8 bytes - -;; LExpr CEnv -> Asm -(define (compile-unbox e0 c) - (let ((c0 (compile-e e0 c))) - `(,@c0 - ,@assert-box - (xor rax ,type-box) - (mov rax (offset rax 0))))) - -;; LExpr LExpr CEnv -> Asm -(define (compile-cons e0 e1 c) - (let ((c0 (compile-e e0 c)) - (c1 (compile-e e1 (cons #f c)))) - `(,@c0 - (mov (offset rsp ,(- (add1 (length c)))) rax) - ,@c1 - (mov (offset rdi 0) rax) - (mov rax (offset rsp ,(- (add1 (length c))))) - (mov (offset rdi 1) rax) - (mov rax rdi) - (or rax ,type-pair) - (add rdi 16)))) - -;; LExpr CEnv -> Asm -(define (compile-car e0 c) - (let ((c0 (compile-e e0 c))) - `(,@c0 - ,@assert-pair - (xor rax ,type-pair) - (mov rax (offset rax 1))))) - -;; LExpr CEnv -> Asm -(define (compile-cdr e0 c) - (let ((c0 (compile-e e0 c))) - `(,@c0 - ,@assert-pair - (xor rax ,type-pair) - (mov rax (offset rax 0))))) - -;; LExpr CEnv -> Asm -(define (compile-empty? e0 c) - (let ((c0 (compile-e e0 c)) - (l0 (gensym))) - `(,@c0 - (and rax ,imm-type-mask) - (cmp rax ,imm-type-empty) - (mov rax ,imm-val-false) - (jne ,l0) - (mov rax ,imm-val-true) - ,l0))) - -;; LExpr CEnv -> Asm -(define (compile-add1 e0 c) - (let ((c0 (compile-e e0 c))) - `(,@c0 - ,@assert-integer - (add rax ,(arithmetic-shift 1 imm-shift))))) - -;; LExpr CEnv -> Asm -(define (compile-sub1 e0 c) - (let ((c0 (compile-e e0 c))) - `(,@c0 - ,@assert-integer - (sub rax ,(arithmetic-shift 1 imm-shift))))) - -;; LExpr CEnv -> Asm -(define (compile-zero? e0 c) - (let ((c0 (compile-e e0 c)) - (l0 (gensym)) - (l1 (gensym))) - `(,@c0 - ,@assert-integer - (cmp rax 0) - (mov rax ,imm-val-false) - (jne ,l0) - (mov rax ,imm-val-true) - ,l0))) - -;; LExpr LExpr LExpr CEnv -> Asm -(define (compile-if e0 e1 e2 c) - (let ((c0 (compile-e e0 c)) - (c1 (compile-e e1 c)) - (c2 (compile-e e2 c)) - (l0 (gensym)) - (l1 (gensym))) - `(,@c0 - (cmp rax ,imm-val-false) - (je ,l0) - ,@c1 - (jmp ,l1) - ,l0 - ,@c2 - ,l1))) - -;; LExpr LExpr LExpr CEnv -> Asm -(define (compile-tail-if e0 e1 e2 c) - (let ((c0 (compile-e e0 c)) - (c1 (compile-tail-e e1 c)) - (c2 (compile-tail-e e2 c)) - (l0 (gensym)) - (l1 (gensym))) - `(,@c0 - (cmp rax ,imm-val-false) - (je ,l0) - ,@c1 - (jmp ,l1) - ,l0 - ,@c2 - ,l1))) - -;; Variable LExpr LExpr CEnv -> Asm -(define (compile-tail-let b body c) - (match b - [(binding x def) - (let ((c0 (compile-e def c)) - (c1 (compile-tail-e body (cons x c)))) - `(,@c0 - (mov (offset rsp ,(- (add1 (length c)))) rax) - ,@c1))])) - -;; Variable LExpr LExpr CEnv -> Asm -(define (compile-let b body c) - (match b - [(binding x def) - (let ((c0 (compile-e def c)) - (c1 (compile-e body (cons x c)))) - `(,@c0 - (mov (offset rsp ,(- (add1 (length c)))) rax) - ,@c1))])) - -;; LExpr LExpr CEnv -> Asm -(define (compile-+ e0 e1 c) - (let ((c1 (compile-e e1 c)) - (c0 (compile-e e0 (cons #f c)))) - `(,@c1 - ,@assert-integer - (mov (offset rsp ,(- (add1 (length c)))) rax) - ,@c0 - ,@assert-integer - (add rax (offset rsp ,(- (add1 (length c)))))))) - - -(define (type-pred->mask p) - (match p - [(or 'box? 'cons? 'string? 'procedure?) result-type-mask] - [_ imm-type-mask])) - -(define (type-pred->tag p) - (match p - ['box? type-box] - ['cons? type-pair] - ['string? type-string] - ['procedure? type-proc] - ['integer? imm-type-int] - ['empty? imm-type-empty] - ['char? imm-type-char] - ['boolean? imm-type-bool])) - -;; Variable CEnv -> Natural -(define (lookup x cenv) - (match cenv - ['() (error "undefined variable:" x)] - [(cons y cenv) - (match (eq? x y) - [#t (length cenv)] - [#f (lookup x cenv)])])) - -(define (assert-type p) - `((mov rbx rax) - (and rbx ,(type-pred->mask p)) - (cmp rbx ,(type-pred->tag p)) - (jne err))) - -(define assert-integer (assert-type 'integer?)) -(define assert-box (assert-type 'box?)) -(define assert-pair (assert-type 'cons?)) -(define assert-string (assert-type 'string?)) -(define assert-char (assert-type 'char?)) -(define assert-proc (assert-type 'procedure?)) - -;; Asm -(define assert-natural - `(,@assert-integer - (cmp rax -1) - (jle err))) - -;; Asm -(define assert-integer-codepoint - `((mov rbx rax) - (and rbx ,imm-type-mask) - (cmp rbx 0) - (jne err) - (cmp rax ,(arithmetic-shift -1 imm-shift)) - (jle err) - (cmp rax ,(arithmetic-shift #x10FFFF imm-shift)) - (mov rbx rax) - (sar rbx ,(+ 11 imm-shift)) - (cmp rbx #b11011) - (je err))) diff --git a/langs/shakedown/example.shk b/langs/shakedown/example.shk deleted file mode 100644 index 563e3d70..00000000 --- a/langs/shakedown/example.shk +++ /dev/null @@ -1 +0,0 @@ -(let ((y (ccall c_fun1 42))) ((lambda (x) y) 11)) diff --git a/langs/shakedown/interp.rkt b/langs/shakedown/interp.rkt deleted file mode 100644 index adb22d1c..00000000 --- a/langs/shakedown/interp.rkt +++ /dev/null @@ -1,122 +0,0 @@ -#lang racket -(provide (all-defined-out)) -(require "syntax.rkt") - -;; type Expr = -;; ... -;; | `(λ ,(Listof Variable) ,Expr) - -;; type Value = -;; ... -;; | Function - -;; type Function = -;; | (Values ... -> Answer) - -(define (interp e) - (interp-env (desugar e) '())) - -;; Expr REnv -> Answer -(define (interp-env e r) - (match e - [''() '()] - [(? syntactic-value? v) v] - [(list (? prim? p) es ...) - (match (interp-env* es r) - [(list vs ...) (interp-prim p vs)] - [_ 'err])] - [`(if ,e0 ,e1 ,e2) - (match (interp-env e0 r) - ['err 'err] - [v - (if v - (interp-env e1 r) - (interp-env e2 r))])] - [(? symbol? x) - (lookup r x)] - [`(let ((,x ,e0)) ,e1) - (match (interp-env e0 r) - ['err 'err] - [v - (interp-env e1 (ext r x v))])] - [`(letrec ,bs ,e) - (letrec ((r* (λ () - (append - (zip (map first bs) - ;; η-expansion to delay evaluating r* - ;; relies on RHSs being functions - (map (λ (l) (λ vs (apply (interp-env l (r*)) vs))) - (map second bs))) - r)))) - (interp-env e (r*)))] - [`(λ (,xs ...) ,e) - (λ vs - (if (= (length vs) (length xs)) - (interp-env e (append (zip xs vs) r)) - 'err))] - [`(,e . ,es) - (match (interp-env* (cons e es) r) - [(list f vs ...) - (if (procedure? f) - (apply f vs) - 'err)] - [_ 'err])])) - -;; (Listof Expr) REnv -> (Listof Value) | 'err -(define (interp-env* es r) - (match es - ['() '()] - [(cons e es) - (match (interp-env e r) - ['err 'err] - [v (cons v (interp-env* es r))])])) - -;; Any -> Boolean -(define (prim? x) - (and (symbol? x) - (memq x '(add1 sub1 + - zero? - box unbox empty? cons car cdr)))) - -;; Any -> Boolean -(define (syntactic-value? x) - (or (integer? x) - (boolean? x) - (null? x))) - -;; Prim (Listof Value) -> Answer -(define (interp-prim p vs) - (match (cons p vs) - [(list 'add1 (? integer? i0)) (add1 i0)] - [(list 'sub1 (? integer? i0)) (sub1 i0)] - [(list 'zero? (? integer? i0)) (zero? i0)] - [(list 'box v0) (box v0)] - [(list 'unbox (? box? v0)) (unbox v0)] - [(list 'empty? v0) (empty? v0)] - [(list 'cons v0 v1) (cons v0 v1)] - [(list 'car (cons v0 v1)) v0] - [(list 'cdr (cons v0 v1)) v1] - [(list '+ (? integer? i0) (? integer? i1)) - (+ i0 i1)] - [(list '- (? integer? i0) (? integer? i1)) - (- i0 i1)] - [_ 'err])) - -;; Env Variable -> Answer -(define (lookup env x) - (match env - ['() 'err] - [(cons (list y i) env) - (match (symbol=? x y) - [#t i] - [#f (lookup env x)])])) - -;; Env Variable Value -> Value -(define (ext r x i) - (cons (list x i) r)) - -(define (zip xs ys) - (match* (xs ys) - [('() '()) '()] - [((cons x xs) (cons y ys)) - (cons (list x y) - (zip xs ys))])) diff --git a/langs/shakedown/main.c b/langs/shakedown/main.c deleted file mode 100644 index 0c9ffc76..00000000 --- a/langs/shakedown/main.c +++ /dev/null @@ -1,131 +0,0 @@ -#include -#include -#include -#include "types.h" - -// in bytes -#define heap_size 1000000 - -int64_t entry(void *); -void print_result(int64_t); -void print_pair(int64_t); -void print_immediate(int64_t); -void print_char(int64_t); -void print_string(int64_t); -void print_string_char(int64_t); -void print_codepoint(int64_t); - -int main(int argc, char** argv) { - void * heap = malloc(heap_size); - int64_t result = entry(heap); - print_result(result); - printf("\n"); - return 0; -} - -void error() { - printf("err"); - exit(1); -} - -void internal_error() { - printf("internal-error"); - exit(1); -} - -void print_result(int64_t v) { - switch (result_type_mask & v) { - case type_imm: - print_immediate(v); - break; - case type_box: - printf("#&"); - print_result (*((int64_t *)(v ^ type_box))); - break; - case type_pair: - printf("("); - print_pair(v); - printf(")"); - break; - case type_string: - printf("\""); - print_string(v); - printf("\""); - break; - case type_proc: - printf("procedure"); - break; - default: - internal_error(); - } -} - -void print_immediate(int64_t v) { - switch (imm_type_mask & v) { - case imm_type_int: - printf("%" PRId64, v >> imm_shift); - break; - case imm_type_bool: - printf("#%c", v >> imm_shift ? 't' : 'f'); - break; - case imm_type_empty: - printf("()"); - break; - case imm_type_char: - print_char(v); - default: - break; - internal_error(); - } -} - -void print_pair(int64_t v) { - int64_t car = *((int64_t *)((v + 8) ^ type_pair)); - int64_t cdr = *((int64_t *)((v + 0) ^ type_pair)); - print_result(car); - if ((imm_type_mask & cdr) == imm_type_empty) { - // nothing - } else if ((result_type_mask & cdr) == type_pair) { - printf(" "); - print_pair(cdr); - } else { - printf(" . "); - print_result(cdr); - } -} - -void print_char (int64_t v) { - int64_t codepoint = v >> imm_shift; - printf("#\\"); - switch (codepoint) { - case 0: - printf("nul"); break; - case 8: - printf("backspace"); break; - case 9: - printf("tab"); break; - case 10: - printf("newline"); break; - case 11: - printf("vtab"); break; - case 12: - printf("page"); break; - case 13: - printf("return"); break; - case 32: - printf("space"); break; - case 127: - printf("rubout"); break; - default: - print_codepoint(v); - } -} - -void print_string(int64_t v) { - int64_t* str = (int64_t *)(v ^ type_string); - int64_t len = (str[0] >> imm_shift); - - int i; - for (i = 0; i < len; i++) - print_string_char(str[i+1]); -} diff --git a/langs/shakedown/syntax.rkt b/langs/shakedown/syntax.rkt deleted file mode 100644 index 91536339..00000000 --- a/langs/shakedown/syntax.rkt +++ /dev/null @@ -1,137 +0,0 @@ -#lang racket -(provide (all-defined-out)) - -(require "ast.rkt") - -; In order to desugar a program into a single let-rec, we take all of the -; top-level definitions and convert them into bindings for a top-level -; let-rec -(define (desugar-prog p) - (match p - [(prog ds e) (let ((bs (map desugar-def ds))) - (prog '() (letr-e bs e)))])) - -(define (desugar-def d) - (match d - [(fundef n args body) - (binding n (lam-e args body))])) - -;; Expr+ -> Expr -; The only case that is interesting is the `letr-e` case, where bindings -; get turned into lambdas -(define (desugar e+) - (match e+ - [(? imm? i) e+] - [(var-e v) e+] - [(prim-e p es) (prim-e p (map desugar es))] - [(if-e e0 e1 e2) (if-e (desugar e0) (desugar e1) (desugar e2))] - [(let-e bs body) (let-e (bindings-map-def desugar bs) (desugar body))] - [(letr-e bs body) (letr-e (bindings-map-def desugar bs) (desugar body))] - [(lam-e xs e0) (lam-e xs (desugar e0))] - [(ccall-e f es) (ccall-e f (map desugar es))] - [(app-e f es) (app-e (desugar f) (map desugar es))])) - -;; Any -> Boolean -(define (imm? x) - (or (int-e? x) - (bool-e? x) - (char-e? x) - (nil-e? x))) - -;; Expr -> LExpr -(define (label-λ e) - (match e - [(? imm? i) e] - [(var-e v) e] - [(prim-e p es) (prim-e p (map label-λ es))] - [(if-e e0 e1 e2) (if-e (label-λ e0) (label-λ e1) (label-λ e2))] - [(let-e bs body) (let-e (bindings-map-def label-λ bs) (label-λ body))] - [(letr-e bs body) (letr-e (bindings-map-def label-λ bs) (label-λ body))] - [(lam-e xs e0) (lam-t (gensym) xs (label-λ e0))] - [(ccall-e f es) (ccall-e f (map label-λ es))] - [(app-e f es) (app-e (label-λ f) (map label-λ es))])) - -;; LExpr -> (Listof LExpr) -;; Extract all the lambda expressions -(define (λs e) - (match e - [(? imm? i) '()] - [(var-e v) '()] - [(prim-e p es) (apply append (map λs es))] - [(if-e e0 e1 e2) (append (λs e0) (λs e1) (λs e2))] - [(let-e (list (binding v def)) body) - (append (λs def) (λs body))] - [(letr-e bs body) (append (apply append (map λs (get-defs bs))) (λs body))] - [(lam-e xs e0) (cons e (λs e0))] - [(lam-t _ xs e0) (cons e (λs e0))] - [(ccall-e f es) (apply append (map λs es))] - [(app-e f es) (append (λs f) (apply append (map λs es)))])) - -;; LExpr -> (Listof Variable) -(define (fvs e) - (define (fvs e) - (match e - [(? imm? i) '()] - [(var-e v) (list v)] - [(prim-e p es) (apply append (map fvs es))] - [(if-e e0 e1 e2) (append (fvs e0) (fvs e1) (fvs e2))] - [(let-e bs body) (append (apply append (map fvs (get-defs bs))) - (remq* (get-vars bs) (fvs body)))] - [(letr-e bs body) (remq* (get-vars bs) (append (apply append (map fvs (get-defs bs))) (fvs body)))] - [(lam-t _ xs e0) (remq* xs (fvs e0))] - [(lam-e xs e0) (remq* xs (fvs e0))] - [(ccall-e f es) (apply append (map fvs es))] - [(app-e f es) (append (fvs f) (apply append (map fvs es)))])) - (remove-duplicates (fvs e))) - -;; LExpr -> (Listof Symbol) -;; Extract all the calls to C Functions -(define (ffi-calls e) - (match e - [(? imm? i) '()] - [(var-e v) '()] - [(prim-e p es) (apply append (map ffi-calls es))] - [(if-e e0 e1 e2) (append (ffi-calls e0) (ffi-calls e1) (ffi-calls e2))] - [(let-e (list (binding v def)) body) - (append (ffi-calls def) (ffi-calls body))] - [(letr-e bs body) (append (apply append (map ffi-calls (get-defs bs))) (ffi-calls body))] - [(lam-e xs e0) (ffi-calls e0)] - [(lam-t _ xs e0) (ffi-calls e0)] - [(ccall-e f es) (cons f (apply append (map ffi-calls es)))] - [(app-e f es) (append (ffi-calls f) (apply append (map ffi-calls es)))])) - -; SExpr -> Prog -(define (sexpr->prog s) - (match s - [(list 'begin defs ... e) (prog (map sexpr->fundef defs) (sexpr->expr e))] - [e (prog '() (sexpr->expr e))])) - -; SExpr -> FunDef -(define (sexpr->fundef def) - (match def - [`(define (,f . ,as) ,body) (fundef f as (sexpr->expr body))])) - -; SExpr -> Expr -; Parse the s-expr into our Expr AST -; This should be a one-to-one mapping for now. -(define (sexpr->expr s) - (match s - [(? symbol? v) (var-e v)] - [(? integer? s) (int-e s)] - [(? boolean? b) (bool-e b)] - [(? char? c) (char-e c)] - [''() (nil-e)] - [`(if ,p ,t ,f) (if-e (sexpr->expr p) (sexpr->expr t) (sexpr->expr f))] - [`(let ((,bnd ,def)) ,body) - (let-e (list (binding bnd (sexpr->expr def))) (sexpr->expr body))] - [`(letrec ,bs ,body) - (letr-e (map (lambda (b) (binding (first b) (sexpr->expr (second b)))) bs) (sexpr->expr body))] - [`(,(? unop? p) ,e) - (prim-e p (list (sexpr->expr e)))] - [`(,(? biop? p) ,e1 ,e2) - (prim-e p (list (sexpr->expr e1) (sexpr->expr e2)))] - [`(λ ,xs ,e0) (lam-e xs (sexpr->expr e0))] - [`(lambda ,a ,e) (lam-e a (sexpr->expr e))] - [`(ccall ,f . ,es) (ccall-e f (map sexpr->expr es))] - [`(,f . ,as) (app-e (sexpr->expr f) (map sexpr->expr as))] - [_ (error "operation not supported")])) diff --git a/langs/shakedown/test/compile.rkt b/langs/shakedown/test/compile.rkt deleted file mode 100644 index bbf1c24c..00000000 --- a/langs/shakedown/test/compile.rkt +++ /dev/null @@ -1,164 +0,0 @@ -#lang racket -(require "../compile.rkt" - "../syntax.rkt" - "../asm/interp.rkt" - rackunit - redex/reduction-semantics) - -(define (run e) - (asm-interp (compile (sexpr->prog e)))) - -(check-equal? (run 7) 7) -(check-equal? (run -8) -8) -(check-equal? (run '(add1 (add1 7))) 9) -(check-equal? (run '(add1 (sub1 7))) 7) - -;; Examples from the notes -(check-equal? (run '(let ((x 7)) x)) 7) -(check-equal? (run '(let ((x 7)) 2)) 2) -(check-equal? (run '(let ((x 7)) (add1 x))) 8) -(check-equal? (run '(let ((x (add1 7))) x)) 8) -(check-equal? (run '(let ((x 7)) (let ((y 2)) x))) 7) -(check-equal? (run '(let ((x 7)) (let ((x 2)) x))) 2) -(check-equal? (run '(let ((x 7)) (let ((x (add1 x))) x))) 8) - -; (check-equal? (run 'x) 'err) ;; Not a valid program -(check-equal? (run '(add1 #f)) 'err) -(check-equal? (run '(+ 1 2)) 3) -(check-equal? (run '(zero? 0)) #t) -(check-equal? (run '(zero? 1)) #f) - - -;; Hustle tests -(check-equal? (run '(box 8)) (box 8)) -(check-equal? (run '(unbox (box 8))) 8) -(check-equal? (run '(unbox 8)) 'err) - -;; Iniquity tests -(check-equal? (run - '(begin (define (f x) x) - (f 5))) - 5) -(check-equal? (run - '(begin (define (tri x) - (if (zero? x) - 0 - (+ x (tri (sub1 x))))) - (tri 9))) - 45) -(check-equal? (run - '(begin (define (even? x) - (if (zero? x) - #t - (odd? (sub1 x)))) - (define (odd? x) - (if (zero? x) - #f - (even? (sub1 x)))) - (even? 101))) - #f) -(check-equal? (run - '(begin (define (map-add1 xs) - (if (empty? xs) - '() - (cons (add1 (car xs)) - (map-add1 (cdr xs))))) - (map-add1 (cons 1 (cons 2 (cons 3 '())))))) - '(2 3 4)) -(check-equal? (run '(begin (define (f x) x) - f)) - 'procedure) -(check-equal? (run '(begin (define (f x) x) - (f 5))) - 5) - -;; Loot tests -(check-equal? (run '((λ (x) x) 7)) 7) -(check-equal? (run '(((λ (x) (λ (y) x)) 7) 8)) 7) -(check-equal? (run '((λ (f) (f 0)) (λ (x) (add1 x)))) 1) -(check-equal? (run '((λ (f) (f (f 0))) (λ (x) (add1 x)))) 2) -(check-equal? (run '((let ((y 8)) (car (cons (λ (x) y) '()))) 2)) 8) -(check-equal? (run '(let ((y 8)) ((car (cons (λ (x) y) '())) 2))) 8) -(check-equal? - (run - '(((λ (t) - ((λ (f) (t (λ (z) ((f f) z)))) - (λ (f) (t (λ (z) ((f f) z)))))) - (λ (tri) - (λ (n) - (if (zero? n) - 1 - (+ n (tri (sub1 n))))))) - 10)) - 56) - -(check-equal? - (run - '(begin (define (map f ls) - (if (empty? ls) - '() - (cons (f (car ls)) (map f (cdr ls))))) - - (map (λ (f) (f 0)) - (cons (λ (x) (add1 x)) - (cons (λ (x) (sub1 x)) - '()))))) - '(1 -1)) - -(check-equal? - (run - '(begin (define (map f ls) - (letrec ((mapper (λ (ls) - (if (empty? ls) - '() - (cons (f (car ls)) (mapper (cdr ls))))))) - (mapper ls))) - (map (λ (f) (f 0)) - (cons (λ (x) (add1 x)) - (cons (λ (x) (sub1 x)) - '()))))) - '(1 -1)) - -;(check-equal? -; (run -; '(begin (define (map f ls) -; (begin (define (mapper ls) -; (if (empty? ls) -; '() -; (cons (f (car ls)) (mapper (cdr ls))))) -; (mapper ls))) -; (map (λ (f) (f 0)) -; (cons (λ (x) (add1 x)) -; (cons (λ (x) (sub1 x)) -; '()))))) -; '(1 -1)) - -(check-equal? (run - '(let ((id (λ (x) x))) - (letrec ((even? - (λ (x) - (if (zero? x) - #t - (id (odd? (sub1 x)))))) - (odd? - (λ (x) - (if (zero? x) - #f - (id (even? (sub1 x))))))) - (even? 101)))) - #f) - -(check-equal? (run - '(let ((id (λ (x) x))) - (id (letrec ((even? - (λ (x) - (if (zero? x) - #t - (odd? (sub1 x))))) - (odd? - (λ (x) - (if (zero? x) - #f - (even? (sub1 x)))))) - (even? 101))))) - #f) diff --git a/langs/shakedown/test/interp.rkt b/langs/shakedown/test/interp.rkt deleted file mode 100644 index afa3523a..00000000 --- a/langs/shakedown/test/interp.rkt +++ /dev/null @@ -1,157 +0,0 @@ -#lang racket -(require "../interp.rkt" - ;(only-in "../semantics.rkt" H 𝑯 convert) - rackunit - redex/reduction-semantics) - -(define (test-suite run) - (check-equal? (run 7) 7) - (check-equal? (run -8) -8) - (check-equal? (run '(add1 (add1 7))) 9) - (check-equal? (run '(add1 (sub1 7))) 7) - - ;; Examples from the notes - (check-equal? (run '(let ((x 7)) x)) 7) - (check-equal? (run '(let ((x 7)) 2)) 2) - (check-equal? (run '(let ((x 7)) (add1 x))) 8) - (check-equal? (run '(let ((x (add1 7))) x)) 8) - (check-equal? (run '(let ((x 7)) (let ((y 2)) x))) 7) - (check-equal? (run '(let ((x 7)) (let ((x 2)) x))) 2) - (check-equal? (run '(let ((x 7)) (let ((x (add1 x))) x))) 8) - - - (check-equal? (run 'x) 'err) - (check-equal? (run '(add1 #f)) 'err) - (check-equal? (run '(+ 1 2)) 3) - (check-equal? (run '(zero? 0)) #t) - (check-equal? (run '(zero? 1)) #f) - - - ;; Hustle tests - (check-equal? (run '(box 8)) (box 8)) - (check-equal? (run '(unbox (box 8))) 8) - (check-equal? (run '(unbox 8)) 'err) - - ;; Iniquity tests - (check-equal? (run - '(begin (define (f x) x) - (f 5))) - 5) - - (check-equal? (run - '(begin (define (tri x) - (if (zero? x) - 0 - (+ x (tri (sub1 x))))) - (tri 9))) - 45) - - (check-equal? (run - '(begin (define (even? x) - (if (zero? x) - #t - (odd? (sub1 x)))) - (define (odd? x) - (if (zero? x) - #f - (even? (sub1 x)))) - (even? 101))) - #f) - - (check-equal? (run - '(begin (define (map-add1 xs) - (if (empty? xs) - '() - (cons (add1 (car xs)) - (map-add1 (cdr xs))))) - (map-add1 (cons 1 (cons 2 (cons 3 '())))))) - '(2 3 4)) - - - ;; Loot examples - - (check-equal? (run '((λ (x) x) 5)) 5) - (check-equal? (run '((λ (x y) x) 5 7)) 5) - (check-equal? (run '((λ (x y) y) 5 7)) 7) - (check-equal? (run '(((λ (x) (λ (y) y)) 5) 7)) 7) - (check-equal? (run '(((λ (x) (λ (y) x)) 5) 7)) 5) - (check-equal? (run '(((λ (t) - ((λ (f) (t (λ (z) ((f f) z)))) - (λ (f) (t (λ (z) ((f f) z)))))) - (λ (tri) - (λ (n) - (if (zero? n) - 1 - (+ n (tri (sub1 n))))))) - 10)) - 56) - - - (check-equal? (run - '(begin (define (map-add1 xs) - (if (empty? xs) - '() - (cons (add1 (car xs)) - (map-add1 (cdr xs))))) - (map-add1 (cons 1 (cons 2 (cons 3 '())))))) - '(2 3 4)) - (check-equal? (run '(begin (define (f x) x) - f)) - 'procedure) - (check-equal? (run '(begin (define (f x) x) - (f 5))) - 5) - - (check-equal? (run '((λ (f) (f 0)) (λ (x) (add1 x)))) 1) - (check-equal? (run '((λ (f) (f (f 0))) (λ (x) (add1 x)))) 2) - (check-equal? (run '((let ((y 8)) (car (cons (λ (x) y) '()))) 2)) 8) - (check-equal? (run '(let ((y 8)) ((car (cons (λ (x) y) '())) 2))) 8) - - (check-equal? - (run - '(begin (define (map f ls) - (if (empty? ls) - '() - (cons (f (car ls)) (map f (cdr ls))))) - - (map (λ (f) (f 0)) - (cons (λ (x) (add1 x)) - (cons (λ (x) (sub1 x)) - '()))))) - '(1 -1)) - - (check-equal? - (run - '(begin (define (map f ls) - (letrec ((mapper (λ (ls) - (if (empty? ls) - '() - (cons (f (car ls)) (mapper (cdr ls))))))) - (mapper ls))) - (map (λ (f) (f 0)) - (cons (λ (x) (add1 x)) - (cons (λ (x) (sub1 x)) - '()))))) - '(1 -1)) - - (check-equal? - (run - '(begin (define (map f ls) - (begin (define (mapper ls) - (if (empty? ls) - '() - (cons (f (car ls)) (mapper (cdr ls))))) - (mapper ls))) - (map (λ (f) (f 0)) - (cons (λ (x) (add1 x)) - (cons (λ (x) (sub1 x)) - '()))))) - '(1 -1))) - -; TODO: Not sure if I actually want to write an interpreter for this as it's -; mostly about the System V calling convention -;(test-suite -; (λ (e) -; (match (interp e) -; [(? procedure?) 'procedure] -; [v v]))) diff --git a/langs/shakedown/types.h b/langs/shakedown/types.h deleted file mode 100644 index c494821d..00000000 --- a/langs/shakedown/types.h +++ /dev/null @@ -1,14 +0,0 @@ -#define result_shift 3 -#define result_type_mask ((1 << result_shift) - 1) -#define type_imm 0 -#define type_box 1 -#define type_pair 2 -#define type_string 3 -#define type_proc 4 - -#define imm_shift (2 + result_shift) -#define imm_type_mask ((1 << imm_shift) - 1) -#define imm_type_int (0 << result_shift) -#define imm_type_bool (1 << result_shift) -#define imm_type_char (2 << result_shift) -#define imm_type_empty (3 << result_shift) diff --git a/www/Makefile b/www/Makefile index b396413d..0d14b871 100644 --- a/www/Makefile +++ b/www/Makefile @@ -32,7 +32,7 @@ scribble: $(course).scrbl push: - rsync -rvzp main/ dvanhorn@junkfood.cs.umd.edu:/fs/www/class/summer2023/cmsc430/ + rsync -rvzp main/ dvanhorn@junkfood.cs.umd.edu:/fs/www/class/spring2024/cmsc430/ clean: rm -rf $(course) diff --git a/www/assignments.scrbl b/www/assignments.scrbl index f491b014..4ad05e98 100644 --- a/www/assignments.scrbl +++ b/www/assignments.scrbl @@ -4,11 +4,11 @@ @local-table-of-contents[#:style 'immediate-only] @include-section{assignments/1.scrbl} -@include-section{assignments/2.scrbl} -@include-section{assignments/3.scrbl} -@include-section{assignments/4.scrbl} -@include-section{assignments/5.scrbl} -@include-section{assignments/6.scrbl} +@;include-section{assignments/2.scrbl} +@;include-section{assignments/3.scrbl} +@;include-section{assignments/4.scrbl} +@;include-section{assignments/5.scrbl} +@;include-section{assignments/6.scrbl} @;;include-section{assignments/7.scrbl} @;{assignment 8: quote in general, and quasiquote} diff --git a/www/assignments/1.scrbl b/www/assignments/1.scrbl index 949dde49..5d50cfdb 100644 --- a/www/assignments/1.scrbl +++ b/www/assignments/1.scrbl @@ -4,7 +4,7 @@ @title[#:tag "Assignment 1" #:style 'unnumbered]{Assignment 1: Learning about Programming Languages} -@bold{Due: Friday, June 2, 11:59PM} +@bold{Due: Wednesday, January 31, 11:59PM} Find two programming languages that are new to you, and answer the following questions: @@ -34,10 +34,11 @@ Racket, Ruby, Scheme, SML, Visual Basic. @section[#:style 'unnumbered]{What to turn in} -@;{Submit this assignment via @link[@gradescope]{Gradescope}.} +Submit a PDF or plain text file containing your write-up via +@link[@gradescope]{Gradescope}. -Until this assignment is officially assigned (see the due date), submissions -will not be accepted. +@;{Until this assignment is officially assigned (see the due date), submissions +will not be accepted.} @;{We will be using GitHub Classroom. This means you will work with git repositories and turning in your work consists of pushing the diff --git a/www/assignments/2.scrbl b/www/assignments/2.scrbl index d224133f..87ffc0b1 100644 --- a/www/assignments/2.scrbl +++ b/www/assignments/2.scrbl @@ -1,7 +1,7 @@ #lang scribble/manual @title[#:tag "Assignment 2" #:style 'unnumbered]{Assignment 2: Racket Primer} -@bold{Due: Monday, June 5, 11:59PM} +@bold{Due: Wednesday, September 13, 11:59PM} The goal of this assignment is to gain practice programming in Racket. diff --git a/www/assignments/3.scrbl b/www/assignments/3.scrbl index 7f5175aa..1368efdf 100644 --- a/www/assignments/3.scrbl +++ b/www/assignments/3.scrbl @@ -5,7 +5,8 @@ @(require "../../langs/con-plus/semantics.rkt") @(require redex/pict) -@bold{Due: Monday, June 12, 11:59PM} +@bold{Due: @elem[#:style "strike"]{Friday, September 29, 11:59PM} + Monday, October 2, 11:59PM} The goal of this assignment is to extend the parser, interpreter, and compiler with some simple unary numeric and boolean operations and two diff --git a/www/assignments/4.scrbl b/www/assignments/4.scrbl index a51ce293..a5d5fbfd 100644 --- a/www/assignments/4.scrbl +++ b/www/assignments/4.scrbl @@ -7,7 +7,7 @@ @(require "../notes/ev.rkt") -@bold{Due: Tuesday, June 20, 11:59PM EST} +@bold{Due: Wednesday, November 1, 11:59PM EST} The goal of this assignment is to extend a compiler with binding forms and primitives that can take any number of arguments. diff --git a/www/defns.rkt b/www/defns.rkt index 06cb1672..29f8eb7a 100644 --- a/www/defns.rkt +++ b/www/defns.rkt @@ -2,39 +2,61 @@ (provide (all-defined-out)) (require scribble/core scribble/html-properties scribble/manual) -(define prof (link "https://www.cs.umd.edu/~dvanhorn/" "David Van Horn")) -(define prof-pronouns "he/him") -(define prof-email "dvanhorn@cs.umd.edu") -(define prof-initials "DVH") - -(define semester "summer") -(define year "2023") +;(define prof1 (link "https://jmct.cc" "José Manuel Calderón Trilla")) +;(define prof1-pronouns "he/him") +;(define prof1-email "jmct@cs.umd.edu") +;(define prof1-initials "JMCT") + +(define prof1 (link "https://www.cs.umd.edu/~dvanhorn/" "David Van Horn")) +(define prof1-pronouns "he/him") +(define prof1-email "dvanhorn@cs.umd.edu") +(define prof1-initials "DVH") + +(define semester "spring") +(define year "2024") (define courseno "CMSC 430") -(define lecture-dates "May 30 -- July 7, 2023") +(define lecture-dates "" #;"May 30 -- July 7, 2023") (define IRB "IRB") (define AVW "AVW") (define KEY "KEY") -(define m1-date "June 14") -(define m2-date "June 29") -(define midterm-hours "24") ; for summer -(define final-date "July 7") -(define elms-url "https://umd.instructure.com/courses/1345891/") +(define m1-date "TBD") +(define m2-date "TBD") +(define midterm-hours "24") +(define final-date "TBD") +(define elms-url "https://umd.instructure.com/courses/1359023") -(define racket-version "8.7") +(define racket-version "8.11") (define staff - (list (list "William Wegand" "wwegand@terpmail.umd.edu" "3:00-4:00PM MTWThF") - (list "Pierce Darragh" "pdarragh@umd.edu" "10:30-11:30AM MTWTh") + (list (list "William Wegand" "wwegand@terpmail.umd.edu") + (list "Pierce Darragh" "pdarragh@umd.edu") + (list "Henry Blanchette" "blancheh@umd.edu") + (list "Deena Postol" "dpostol@umd.edu") + (list "Kazi Tasnim Zinat" "kzintas@umd.edu") + #;(list "Fuxiao Liu" "fl3es@umd.edu") + #;(list "Vivian Chen" "vchen8@terpmail.umd.edu") + #;(list "Ian Morrill" "imorrill@terpmail.umd.edu") + #;(list "Matthew Schneider" "mgl@umd.edu") + #;(list "Rhea Jajodia" "rjajodia@terpmail.umd.edu") + #;(list "Syed Zaidi" "szaidi@umd.edu") + #;(list "William Wegand" "wfweg@verizon.net") + #;(list "Wilson Smith" "smith@umd.edu") + #;(list "Yuhwan Lee" "ylee9251@terpmail.umd.edu") )) -(define lecture-schedule "Weekdays, 12:30pm - 1:50pm") -(define classroom (link "https://umd.zoom.us/j/99876119693?pwd=d0h3aWRML2dka3dzbElVSHdMeVBEZz09" "Zoom")) +;(define lecture-schedule1 "MW, 2:00-3:15pm") +(define lecture-schedule1 "MW, 3:30-4:45pm") + +(define classroom1 "HJP 0226") + +;(define discord "TBD") +(define piazza "https://piazza.com/class/lrs6masma6h2o1/") +(define gradescope "https://www.gradescope.com/") ; FIXME -(define discord "https://discord.gg/Me7XFYC8") -(define gradescope "https://www.gradescope.com/courses/533338") +(define feedback "https://docs.google.com/forms/d/e/1FAIpQLSc80xQELhHb_Ef-tn0DkpH2b6pYadQiT3aYSEJFNqEqBjzdGg/viewform?usp=sf_link") \ No newline at end of file diff --git a/www/main.scrbl b/www/main.scrbl index 35445b48..50eb11f0 100644 --- a/www/main.scrbl +++ b/www/main.scrbl @@ -21,9 +21,10 @@ @emph{@string-titlecase[semester], @year} -@emph{Lectures: @lecture-schedule, @classroom} +@emph{Lecture}: @lecture-schedule1, @classroom1 + +@emph{Professor}: @prof1 -@emph{Professor: @prof (@prof-pronouns)} CMSC 430 is an introduction to compilers. Its major goal is to arm students with the ability to design, implement, and extend a @@ -31,14 +32,39 @@ programming language. Throughout the course, students will design and implement several related languages. -@tabular[#:style 'boxed +@tabular[#:style 'boxed #:row-properties '(bottom-border ()) - (list* (list @bold{Staff} 'cont 'cont) - (list @bold{Name} @elem{@bold{E-mail}} @elem{@bold{Hours}}) - (list prof prof-email "By appt.") + (list* (list @bold{Staff} 'cont) + (list @bold{Name} @elem{@bold{E-mail}}) + (list prof1 prof1-email) + #;(list prof2 prof2-email) staff)] -@bold{Communications:} @link[@elms-url]{ELMS}, @link[@discord]{Discord} +@bold{Office hours:} AVW 4140 + +Schedule, TBD. + +@;{ +@tabular[#:style 'boxed + #:row-properties '(bottom-border ()) + (list (list @bold{Time} @bold{Monday} @bold{Tuesday} @bold{Wednesday} @bold{Thursday} @bold{Friday}) + (list "9 AM" "William" 'cont "William" 'cont 'cont) + (list "10 AM" "William" 'cont "Ian, William" 'cont 'cont) + (list "11 AM" 'cont "Pierce" "Ian" 'cont 'cont) + (list "12 PM" "Dalton, Fuxiao" "Pierce" "Dalton" 'cont 'cont) + (list "1 PM" "Dalton, Fuxiao, Ian" 'cont "Matthew, Wilson" "Fuxiao" "Wilson") + (list "" "Wilson" 'cont 'cont 'cont 'cont) + (list "2 PM" "Ian, Wilson" "Pierce" "Matthew" "Fuxiao" 'cont) + (list "" 'cont 'cont 'cont "Pierce" 'cont) + (list "3 PM" "Matthew, Yuhwan" "Pierce" "Matthew, Yuhwan" "Pierce" "Vivian") + (list "4 PM" "Yuhwan" 'cont "Yuhwan, Dalton" 'cont 'cont) + (list "5 PM" 'cont "Vivian" 'cont "Vivian" 'cont) + (list "6 PM" 'cont 'cont 'cont "Vivian" 'cont))] +} + + + +@bold{Communications:} @link[@elms-url]{ELMS}, @link[@piazza]{Piazza} @bold{Assumptions:} This course assumes you know the material in CMSC 330 and CMSC 216. In particular, you need to know how to program in a functional @@ -51,7 +77,7 @@ change. Any substantive change will be accompanied with an announcement to the class via ELMS. @bold{Feedback:} We welcome anonymous feedback on the course and its -staff using this @link["https://docs.google.com/forms/d/e/1FAIpQLSdUNNY5Vun42xATeByf_V9JLce1hbDZuCd0Qj_YJo4z_e5vcA/viewform?usp=sf_link"]{form}. +staff using this @link[feedback]{form}. @include-section{syllabus.scrbl} @include-section{texts.scrbl} diff --git a/www/midterms/1.scrbl b/www/midterms/1.scrbl index 1de96f45..e72491d3 100644 --- a/www/midterms/1.scrbl +++ b/www/midterms/1.scrbl @@ -10,6 +10,7 @@ Midterm 1 will be released at least @midterm-hours hours prior to its due date. +@;{ @section{Instructions} The midterm will be released as a zip file @tt{m1.zip} on ELMS. @@ -46,4 +47,4 @@ If you fail these tests, we will not be able to grade your submission. Passing these tests only means your submission is well-formed. Your actual grade will be computed after the deadline. -You are encouraged to check your own work. \ No newline at end of file +You are encouraged to check your own work.} \ No newline at end of file diff --git a/www/midterms/2.scrbl b/www/midterms/2.scrbl index f464a3f5..6d3f5788 100644 --- a/www/midterms/2.scrbl +++ b/www/midterms/2.scrbl @@ -12,6 +12,7 @@ Midterm 2 will be released at least @midterm-hours hours prior to its due date. +@;{ @section{Instructions} The midterm will be released as a zip file @tt{m2.zip} on ELMS. @@ -40,3 +41,4 @@ You should submit your work as a single zip file of this directory on Gradescope. Unlike past assignments, Gradescope will not provide feedback on the correctness of your solutions so you are encouraged to check your own work. +} \ No newline at end of file diff --git a/www/notes/a86.scrbl b/www/notes/a86.scrbl index 166b6c1b..1e4ee76f 100644 --- a/www/notes/a86.scrbl +++ b/www/notes/a86.scrbl @@ -2,9 +2,9 @@ @(require (for-label (except-in racket compile) a86)) - + @(require scribble/examples - redex/reduction-semantics + redex/reduction-semantics redex/pict (only-in pict scale) (only-in racket system) @@ -67,7 +67,7 @@ int gcd(int n1, int n2) { } HERE ) - + (parameterize ([current-directory (build-path notes "a86")]) (save-file "tri.s" (asm-string (tri 36))) (save-file "main.c" main.c) @@ -178,7 +178,7 @@ Suppose we start executing at @tt{entry}. rbx} to zero. Executing this instruction sets a flag in the CPU, which affects subsequent ``conditional'' instructions. In this program, the next instruction is a conditional jump.} - + @item{@tt{je done} either jumps to the instruction following label @tt{done} or proceeds to the next instruction, based on the state of the comparison flag. The @@ -192,7 +192,7 @@ Suppose we start executing at @tt{entry}. (register @tt{rsp}).} @item{@tt{sub rbx, 1} decrements @tt{rbx} by 1.} - + @item{@tt{call tri} performs something like a function call; it uses memory as a stack to save the current location in the code (which is where control should return to after @@ -222,7 +222,7 @@ Suppose we start executing at @tt{entry}. ``output'') is 0.} @item{@tt{ret} does a ``return,'' either to a prior call to - @tt{tri} or the caller of @tt{entry}.} + @tt{tri} or the caller of @tt{entry}.} ] Despite the lower-level mechanisms, this code computes in a @@ -535,7 +535,7 @@ save the result of @racket['f]: (ex (eg (seq (Call 'f) (Mov 'rbx 'rax) - (Call 'g) + (Call 'g) (Add 'rax 'rbx))) ) @@ -634,13 +634,13 @@ address to jump to, we could've also written it as: (ex (eg (seq (Sub 'rsp 8) ; allocate a frame on the stack ; load address of 'fret label into top of stack - (Lea (Offset 'rsp 0) 'fret) + (Lea (Offset 'rsp 0) 'fret) (Jmp 'f) ; jump to 'f (Label 'fret) ; <-- return point for "call" to 'f (Push 'rax) ; save result (like before) (Sub 'rsp 8) ; allocate a frame on the stack ; load address of 'gret label into top of stack - (Lea (Offset 'rsp 0) 'gret) + (Lea (Offset 'rsp 0) 'gret) (Jmp 'g) ; jump to 'g (Label 'gret) ; <-- return point for "call" to 'g (Pop 'rbx) ; pop saved result from calling 'f @@ -706,7 +706,7 @@ Each register plays the same role as in x86, so for example @tt{?}. The only characters which may be used as the first character of an identifier are letters, @tt{.} (with special meaning), @tt{_} and @tt{?}." - + @ex[ (label? 'foo) (label? "foo") @@ -782,7 +782,7 @@ Each register plays the same role as in x86, so for example outermost level of a function that produces a86 code and not nested. - @ex[ + @ex[ (prog (Global 'foo) (Label 'foo)) (eval:error (prog (Label 'foo))) (eval:error (prog (list (Label 'foo)))) @@ -796,6 +796,17 @@ Each register plays the same role as in x86, so for example ] } +@defproc[(symbol->label [s symbol?]) label?]{ + + Returns a modified form of a symbol that follows NASM label conventions. + + @ex[ + (let ([l (symbol->label 'my-great-label)]) + (seq (Label l) + (Jmp l))) + ] +} + @deftogether[(@defstruct*[% ([s string?])] @defstruct*[%% ([s string?])] @defstruct*[%%% ([s string?])])]{ @@ -810,7 +821,7 @@ Each register plays the same role as in x86, so for example (ex (asm-display (prog (Global 'foo) - (%%% "Start of foo") + (%%% "Start of foo") (Label 'foo) ; Racket comments won't appear (%% "Inputs one argument in rdi") @@ -820,7 +831,7 @@ Each register plays the same role as in x86, so for example (%% "we're done!") (Ret)))) } - + @defstruct*[Offset ([r register?] [i exact-integer?])]{ Creates an memory offset from a register. Offsets are used @@ -865,7 +876,7 @@ Each register plays the same role as in x86, so for example @defstruct*[Extern ([x label?])]{ Declares an external label. - + } @defstruct*[Global ([x label?])]{ @@ -909,7 +920,7 @@ Each register plays the same role as in x86, so for example } @defstruct*[Mov ([dst (or/c register? offset?)] [src (or/c register? offset? 64-bit-integer?)])]{ - + A move instruction. Moves @racket[src] to @racket[dst]. Either @racket[dst] or @racket[src] may be offsets, but not both. @@ -918,7 +929,7 @@ Each register plays the same role as in x86, so for example (asm-interp (prog (Global 'entry) - (Label 'entry) + (Label 'entry) (Mov 'rbx 42) (Mov 'rax 'rbx) (Ret))) @@ -931,12 +942,12 @@ Each register plays the same role as in x86, so for example An addition instruction. Adds @racket[src] to @racket[dst] and writes the result to @racket[dst]. - + @ex[ (asm-interp (prog (Global 'entry) - (Label 'entry) + (Label 'entry) (Mov 'rax 32) (Add 'rax 10) (Ret))) @@ -952,14 +963,14 @@ Each register plays the same role as in x86, so for example (asm-interp (prog (Global 'entry) - (Label 'entry) + (Label 'entry) (Mov 'rax 32) (Sub 'rax 10) (Ret))) ] } -@defstruct*[Cmp ([a1 (or/c register? offset?)] [a2 (or/c register? offset? 32-bit-integer?)])]{ +@defstruct*[Cmp ([a1 (or/c register? offset?)] [a2 (or/c register? offset? 32-bit-integer?)])]{ Compare @racket[a1] to @racket[a2]. Doing a comparison sets the status flags that affect the conditional instructions like @racket[Je], @racket[Jl], etc. @@ -972,14 +983,14 @@ Each register plays the same role as in x86, so for example (Cmp 'rax 2) (Jg 'l1) (Mov 'rax 0) - (Label 'l1) + (Label 'l1) (Ret))) - ] + ] } @defstruct*[Jmp ([x (or/c label? register?)])]{ Jump to label @racket[x]. - + @ex[ (asm-interp (prog @@ -996,15 +1007,15 @@ Each register plays the same role as in x86, so for example (Global 'entry) (Label 'entry) (Mov 'rax 42) - (Pop 'rbx) + (Pop 'rbx) (Jmp 'rbx))) ] - + } @defstruct*[Je ([x (or/c label? register?)])]{ Jump to label @racket[x] if the conditional flag is set to ``equal.'' - + @ex[ (asm-interp (prog @@ -1014,14 +1025,14 @@ Each register plays the same role as in x86, so for example (Cmp 'rax 2) (Je 'l1) (Mov 'rax 0) - (Label 'l1) + (Label 'l1) (Ret))) ] } @defstruct*[Jne ([x (or/c label? register?)])]{ Jump to label @racket[x] if the conditional flag is set to ``not equal.'' - + @ex[ (asm-interp (prog @@ -1031,14 +1042,14 @@ Each register plays the same role as in x86, so for example (Cmp 'rax 2) (Jne 'l1) (Mov 'rax 0) - (Label 'l1) + (Label 'l1) (Ret))) ] } @defstruct*[Jl ([x (or/c label? register?)])]{ Jump to label @racket[x] if the conditional flag is set to ``less than.'' - + @ex[ (asm-interp (prog @@ -1048,14 +1059,14 @@ Each register plays the same role as in x86, so for example (Cmp 'rax 2) (Jl 'l1) (Mov 'rax 0) - (Label 'l1) + (Label 'l1) (Ret))) ] } @defstruct*[Jle ([x (or/c label? register?)])]{ Jump to label @racket[x] if the conditional flag is set to ``less than or equal.'' - + @ex[ (asm-interp (prog @@ -1065,14 +1076,14 @@ Each register plays the same role as in x86, so for example (Cmp 'rax 42) (Jle 'l1) (Mov 'rax 0) - (Label 'l1) + (Label 'l1) (Ret))) ] } @defstruct*[Jg ([x (or/c label? register?)])]{ Jump to label @racket[x] if the conditional flag is set to ``greater than.'' - + @ex[ (asm-interp (prog @@ -1082,14 +1093,14 @@ Each register plays the same role as in x86, so for example (Cmp 'rax 2) (Jg 'l1) (Mov 'rax 0) - (Label 'l1) + (Label 'l1) (Ret))) ] } @defstruct*[Jge ([x (or/c label? register?)])]{ Jump to label @racket[x] if the conditional flag is set to ``greater than or equal.'' - + @ex[ (asm-interp (prog @@ -1099,7 +1110,7 @@ Each register plays the same role as in x86, so for example (Cmp 'rax 42) (Jg 'l1) (Mov 'rax 0) - (Label 'l1) + (Label 'l1) (Ret))) ] } @@ -1523,13 +1534,13 @@ Each register plays the same role as in x86, so for example Decrements the stack pointer and then stores the source operand on the top of the stack. - + @ex[ (asm-interp (prog (Global 'entry) (Label 'entry) - (Mov 'rax 42) + (Mov 'rax 42) (Push 'rax) (Mov 'rax 0) (Pop 'rax) @@ -1539,13 +1550,13 @@ Each register plays the same role as in x86, so for example @defstruct*[Pop ([a1 register?])]{ Loads the value from the top of the stack to the destination operand and then increments the stack pointer. - + @ex[ (asm-interp (prog (Global 'entry) (Label 'entry) - (Mov 'rax 42) + (Mov 'rax 42) (Push 'rax) (Mov 'rax 0) (Pop 'rax) @@ -1569,7 +1580,7 @@ Perform bitwise not operation (each 1 is set to 0, and each 0 is set to 1) on th @defstruct*[Lea ([dst (or/c register? offset?)] [x label?])]{ Loads the address of the given label into @racket[dst]. - + @ex[ (asm-interp (prog @@ -1584,6 +1595,14 @@ Perform bitwise not operation (each 1 is set to 0, and each 0 is set to 1) on th ] } +@defstruct*[Db ([d integer?])]{ + Psuedo-instruction for declaring 8-bits of initialized static memory. +} + +@defstruct*[Dw ([d integer?])]{ + Psuedo-instruction for declaring 16-bits of initialized static memory. +} + @defstruct*[Dd ([d integer?])]{ Psuedo-instruction for declaring 32-bits of initialized static memory. } @@ -1606,12 +1625,12 @@ Perform bitwise not operation (each 1 is set to 0, and each 0 is set to 1) on th (Mov 'rax 42) (Ret))) ] - + } @defproc[(asm-string [is (listof instruction?)]) string?]{ - Converts an a86 program to a string in nasm syntax. + Converts an a86 program to a string in nasm syntax. @ex[ (asm-string (prog (Global 'entry) @@ -1619,7 +1638,7 @@ Perform bitwise not operation (each 1 is set to 0, and each 0 is set to 1) on th (Mov 'rax 42) (Ret))) ] - + } @section{An Interpreter for a86} @@ -1677,7 +1696,7 @@ The simplest form of interpreting an a86 program is to use (Mov 'rax 0) (Jmp 'rax)))) ] - + } It is often the case that we want our assembly programs to @@ -1724,7 +1743,7 @@ code: (Sub 'rsp 8) (Call 'gcd) (Add 'rsp 8) - (Ret))))] + (Ret))))] This will be particularly relevant for writing a compiler where emitted code will make use of functionality defined in @@ -1750,8 +1769,5 @@ linking error saying a symbol is undefined: Like @racket[asm-interp], but uses @racket[in] for input and produce the result along with any output as a string. - -} - - +} diff --git a/www/notes/abscond.scrbl b/www/notes/abscond.scrbl index fd05d9f8..c635faec 100644 --- a/www/notes/abscond.scrbl +++ b/www/notes/abscond.scrbl @@ -150,10 +150,10 @@ parse the concrete expression as an s-expression. While not terribly useful for a language as overly simplistic as Abscond, we use an AST datatype for representing expressions and another syntactic categories. For each category, we will have an appropriate constructor. In the case of Abscond -all expressions are integers, so we have a single constructor, @racket[Int]. +all expressions are integers, so we have a single constructor, @racket[Lit]. @(define-language A-concrete - (e ::= (Int i)) + (e ::= (Lit i)) (i ::= integer)) @centered{@render-language[A-concrete]} @@ -171,7 +171,7 @@ it is, otherwise it signals an error: @section{Meaning of Abscond programs} The meaning of an Abscond program is simply the number itself. So -@racket[(Int 42)] evaluates to @racket[42]. +@racket[(Lit 42)] evaluates to @racket[42]. We can write an ``interpreter'' that consumes an expression and produces it's meaning: @@ -180,8 +180,8 @@ produces it's meaning: @#reader scribble/comment-reader (examples #:eval ev -(interp (Int 42)) -(interp (Int -8)) +(interp (Lit 42)) +(interp (Lit -8)) ) We can add a command line wrapper program for interpreting Abscond @@ -213,15 +213,15 @@ language, just a single inference rule suffices: #:mode (𝑨 I O) #:contract (𝑨 e i) [---------- - (𝑨 (Int i) i)]) + (𝑨 (Lit i) i)]) @(centered (render-judgment-form 𝑨)) Here, we are defining a binary relation, called @render-term[A 𝑨], and saying every integer literal expression is paired with the integer itself in the -relation. So @math{((Int 2),2)} is in @render-term[A 𝑨], -@math{((Int 5),5)} is in @render-term[A 𝑨], and so on. +relation. So @math{((Lit 2),2)} is in @render-term[A 𝑨], +@math{((Lit 5),5)} is in @render-term[A 𝑨], and so on. The inference rules define the binary relation by defining the @emph{evidence} for being in the relation. The rule makes use of @@ -419,8 +419,8 @@ Writing the @racket[compile] function is easy: @#reader scribble/comment-reader (examples #:eval ev -(compile (Int 42)) -(compile (Int 38)) +(compile (Lit 42)) +(compile (Lit 38)) ) To convert back to the concrete NASM syntax, we use @@ -432,7 +432,7 @@ appropriately.} @#reader scribble/comment-reader (examples #:eval ev -(asm-display (compile (Int 42)))) +(asm-display (compile (Lit 42)))) Putting it all together, we can write a command line compiler much like the command line interpreter before, except now we emit assembly @@ -533,17 +533,17 @@ compilation within Racket: @examples[#:eval ev -(asm-interp (compile (Int 42))) -(asm-interp (compile (Int 37))) -(asm-interp (compile (Int -8))) +(asm-interp (compile (Lit 42))) +(asm-interp (compile (Lit 37))) +(asm-interp (compile (Lit -8))) ] This of course agrees with what we will get from the interpreter: @examples[#:eval ev -(interp (Int 42)) -(interp (Int 37)) -(interp (Int -8)) +(interp (Lit 42)) +(interp (Lit 37)) +(interp (Lit -8)) ] We can turn this in a @bold{property-based test}, i.e. a function that @@ -554,9 +554,9 @@ correctness claim: (check-eqv? (interp e) (asm-interp (compile e)))) -(check-compiler (Int 42)) -(check-compiler (Int 37)) -(check-compiler (Int -8)) +(check-compiler (Lit 42)) +(check-compiler (Lit 37)) +(check-compiler (Lit -8)) ] This is a powerful testing technique when combined with random @@ -565,11 +565,11 @@ Abscond programs, we can randomly generate @emph{any} Abscond program and check that it holds. @examples[#:eval ev -(check-compiler (Int (random 100))) +(check-compiler (Lit (random 100))) ; test 10 random programs (for ([i (in-range 10)]) - (check-compiler (Int (random 10000)))) + (check-compiler (Lit (random 10000)))) ] The last expression is taking 10 samples from the space of Abscond diff --git a/www/notes/blackmail.scrbl b/www/notes/blackmail.scrbl index c2561966..a9c0ccfa 100644 --- a/www/notes/blackmail.scrbl +++ b/www/notes/blackmail.scrbl @@ -77,10 +77,10 @@ The grammar of abstract Backmail expressions is: @centered{@render-language[B]} -So, @racket[(Int 0)], @racket[(Int 120)], and -@racket[(Int -42)] are Blackmail AST expressions, but so are -@racket[(Prim1 'add1 (Int 0))], @racket[(Sub1 (Int 120))], -@racket[(Prim1 'add1 (Prim1 'add1 (Prim1 'add1 (Int -42))))]. +So, @racket[(Lit 0)], @racket[(Lit 120)], and +@racket[(Lit -42)] are Blackmail AST expressions, but so are +@racket[(Prim1 'add1 (Lit 0))], @racket[(Sub1 (Lit 120))], +@racket[(Prim1 'add1 (Prim1 'add1 (Prim1 'add1 (Lit -42))))]. A datatype for representing expressions can be defined as: @@ -129,7 +129,7 @@ contrast to the first rule, which applies unconditionally. We can understand these rules as saying the following: @itemlist[ -@item{For all integers @math{i}, @math{((Int i),i)} is in @render-term[B 𝑩].} +@item{For all integers @math{i}, @math{((Lit i),i)} is in @render-term[B 𝑩].} @item{For expressions @math{e_0} and all integers @math{i_0} and @math{i_1}, if @math{(e_0,i_0)} is in @render-term[B 𝑩] and @math{i_1 @@ -157,11 +157,11 @@ interpreter, one for each form of expression: @codeblock-include["blackmail/interp.rkt"] @examples[#:eval ev -(interp (Int 42)) -(interp (Int -7)) -(interp (Prim1 'add1 (Int 42))) -(interp (Prim1 'sub1 (Int 8))) -(interp (Prim1 'add1 (Prim1 'add1 (Prim1 'add1 (Int 8))))) +(interp (Lit 42)) +(interp (Lit -7)) +(interp (Prim1 'add1 (Lit 42))) +(interp (Prim1 'sub1 (Lit 8))) +(interp (Prim1 'add1 (Prim1 'add1 (Prim1 'add1 (Lit 8))))) ] Here's how to connect the dots between the semantics and interpreter: @@ -172,7 +172,7 @@ expression, which determines which rule of the semantics applies. @itemlist[ -@item{if @math{e} is an integer @math{(Int i)}, then we're done: this is the +@item{if @math{e} is an integer @math{(Lit i)}, then we're done: this is the right-hand-side of the pair @math{(e,i)} in @render-term[B 𝑩].} @item{if @math{e} is an expression @RACKET[(Prim1 'add1 (UNSYNTAX @@ -241,9 +241,9 @@ recursion, much like the interpreter. We can now try out a few examples: @ex[ -(compile (Prim1 'add1 (Prim1 'add1 (Int 40)))) -(compile (Prim1 'sub1 (Int 8))) -(compile (Prim1 'add1 (Prim1 'add1 (Prim1 'sub1 (Prim1 'add1 (Int -8)))))) +(compile (Prim1 'add1 (Prim1 'add1 (Lit 40)))) +(compile (Prim1 'sub1 (Lit 8))) +(compile (Prim1 'add1 (Prim1 'add1 (Prim1 'sub1 (Prim1 'add1 (Lit -8)))))) ] And give a command line wrapper for parsing, checking, and compiling @@ -264,9 +264,9 @@ the same @racket[asm-interp] function to encapsulate running assembly code: @ex[ -(asm-interp (compile (Prim1 'add1 (Prim1 'add1 (Int 40))))) -(asm-interp (compile (Prim1 'sub1 (Int 8)))) -(asm-interp (compile (Prim1 'add1 (Prim1 'add1 (Prim1 'add1 (Prim1 'add1 (Int -8))))))) +(asm-interp (compile (Prim1 'add1 (Prim1 'add1 (Lit 40))))) +(asm-interp (compile (Prim1 'sub1 (Lit 8)))) +(asm-interp (compile (Prim1 'add1 (Prim1 'add1 (Prim1 'add1 (Prim1 'add1 (Lit -8))))))) ] @section{Correctness and random testing} @@ -332,10 +332,10 @@ x86 does. Let's see: @ex[ (define max-int (sub1 (expt 2 63))) (define min-int (- (expt 2 63))) -(asm-interp (compile (Int max-int))) -(asm-interp (compile (Prim1 'add1 (Int max-int)))) -(asm-interp (compile (Int min-int))) -(asm-interp (compile (Prim1 'sub1 (Int min-int))))] +(asm-interp (compile (Lit max-int))) +(asm-interp (compile (Prim1 'add1 (Lit max-int)))) +(asm-interp (compile (Lit min-int))) +(asm-interp (compile (Prim1 'sub1 (Lit min-int))))] Now there's a fact you didn't learn in grade school: in the first example, adding 1 to a number made it smaller; in the @@ -344,18 +344,18 @@ second, subtracting 1 made it bigger! This problem doesn't exist in the interpreter: @ex[ -(interp (Int max-int)) -(interp (Prim1 'add1 (Int max-int))) -(interp (Int min-int)) -(interp (Prim1 'sub1 (Int min-int))) +(interp (Lit max-int)) +(interp (Prim1 'add1 (Lit max-int))) +(interp (Lit min-int)) +(interp (Prim1 'sub1 (Lit min-int))) ] So we have found a counter-example to the claim of compiler correctness: @ex[ -(check-compiler (Prim1 'add1 (Int max-int))) -(check-compiler (Prim1 'sub1 (Int min-int))) +(check-compiler (Prim1 'add1 (Lit max-int))) +(check-compiler (Prim1 'sub1 (Lit min-int))) ] What can we do? This is the basic problem of a program not diff --git a/www/notes/con.scrbl b/www/notes/con.scrbl index d1148b6f..bad4700b 100644 --- a/www/notes/con.scrbl +++ b/www/notes/con.scrbl @@ -269,7 +269,7 @@ The complete compiler code is: Mirroring the change we made to the interpreter, we separate out a module for compiling primitives: -@codeblock-include["con/compile-prim.rkt"] +@codeblock-include["con/compile-ops.rkt"] Let's take a look at a few examples: @ex[ diff --git a/www/notes/dodger.scrbl b/www/notes/dodger.scrbl index 36bf0756..bb11c8ea 100644 --- a/www/notes/dodger.scrbl +++ b/www/notes/dodger.scrbl @@ -114,19 +114,19 @@ The meaning of characters and their operations are just lifted from Racket. We can try out some examples: @ex[ -(interp (Char #\a)) -(interp (Char #\b)) -(interp (Prim1 'char? (Char #\a))) -(interp (Prim1 'char? (Bool #t))) -(interp (Prim1 'char->integer (Char #\a))) -(interp (Prim1 'integer->char (Prim1 'char->integer (Char #\a)))) +(interp (Lit #\a)) +(interp (Lit #\b)) +(interp (Prim1 'char? (Lit #\a))) +(interp (Prim1 'char? (Lit #t))) +(interp (Prim1 'char->integer (Lit #\a))) +(interp (Prim1 'integer->char (Prim1 'char->integer (Lit #\a)))) ] Just as in Dupe, type errors result in the interpreter crashing: @ex[ -(eval:error (interp (Prim1 'char->integer (Bool #f)))) +(eval:error (interp (Prim1 'char->integer (Lit #f)))) ] Also, not every integer corresponds to a character, so when @@ -134,7 +134,7 @@ Also, not every integer corresponds to a character, so when (more on this in a minute): @ex[ -(eval:error (interp (Prim1 'integer->char (Int -1)))) +(eval:error (interp (Prim1 'integer->char (Lit -1)))) ] @section{Ex uno plures iterum: Out of One, Many... Again} diff --git a/www/notes/dupe.scrbl b/www/notes/dupe.scrbl index 6b4f9022..47a3cf09 100644 --- a/www/notes/dupe.scrbl +++ b/www/notes/dupe.scrbl @@ -170,14 +170,14 @@ rule essentially defers the work to a new metafunction, (render-metafunction 𝑫-𝒑𝒓𝒊𝒎 #:contract? #t))) Returning to the issue of type mismatches, what does the -semantics say about @racket[(Prim1 'add1 (Bool #f))]? +semantics say about @racket[(Prim1 'add1 (Lit #f))]? What it says is: nothing. These programs are simply not in the semantic relation for this language. There's only one rule for giving meaning to an @racket[(Prim1 'add1 _e0)] expression and it's premise is that @racket[_e] means some @emph{integer} @racket[_i0]. But -@math{(@racket[(Bool #f)], i) ∉ 𝑫} for any @math{i}. So there's no value -@math{v} such that @math{(@racket[(Prim1 'add1 (Bool #f))], v) ∈ 𝑫}. This +@math{(@racket[(Lit #f)], i) ∉ 𝑫} for any @math{i}. So there's no value +@math{v} such that @math{(@racket[(Prim1 'add1 (Lit #f))], v) ∈ 𝑫}. This expression is @bold{undefined} according to the semantics. @@ -194,13 +194,13 @@ We can confirm the interpreter computes the right result for the examples given earlier: @ex[ -(interp (Bool #t)) -(interp (Bool #f)) -(interp (If (Bool #f) (Int 1) (Int 2))) -(interp (If (Bool #t) (Int 1) (Int 2))) -(interp (If (Int 0) (Int 1) (Int 2))) -(interp (If (Int 7) (Int 1) (Int 2))) -(interp (If (Prim1 'zero? (Int 7)) (Int 1) (Int 2))) +(interp (Lit #t)) +(interp (Lit #f)) +(interp (If (Lit #f) (Lit 1) (Lit 2))) +(interp (If (Lit #t) (Lit 1) (Lit 2))) +(interp (If (Lit 0) (Lit 1) (Lit 2))) +(interp (If (Lit 7) (Lit 1) (Lit 2))) +(interp (If (Prim1 'zero? (Lit 7)) (Lit 1) (Lit 2))) ] Correctness follows the same pattern as before, although it is worth @@ -222,7 +222,7 @@ which results in the @racket[interp] program crashing and Racket signalling an error: @ex[ -(eval:error (interp (Prim1 'add1 (Bool #f)))) +(eval:error (interp (Prim1 'add1 (Lit #f)))) ] This isn't a concern for correctness, because the interpreter is free @@ -280,7 +280,7 @@ to represent the value itself, either true, false, or some integer. Let's use the least significant bit to indicate the type and let's use @binary[type-int] for integer and -@binary[type-bool] for boolean. These are arbitrary choices +@binary[(value->bits #t)] for boolean. These are arbitrary choices (more or less). The number @racket[1] would be represented as @@ -290,10 +290,10 @@ The number @racket[1] would be represented as number is no longer the number itself: the Dupe value @racket[1] is represented by the number @racket[2] (@binary[2]). The Dupe value @racket[#t] -is represented by the number @racket[#,val-true] -(@binary[val-true 2]); the Dupe value @racket[#f] -is represented by the number @racket[#,val-false] -(@binary[val-false 2]). +is represented by the number @racket[#,(value->bits #t)] +(@binary[(value->bits #t) 2]); the Dupe value @racket[#f] +is represented by the number @racket[#,(value->bits #f)] +(@binary[(value->bits #f) 2]). One nice thing about our choice of encoding: @racket[0] is represented as @racket[0] (@binary[0 2]). @@ -310,8 +310,7 @@ encoding: @codeblock-include["dupe/types.rkt"] @#reader scribble/comment-reader -(ex - +(ex (bits->value #b000) (bits->value #b001) (bits->value #b010) @@ -320,7 +319,6 @@ encoding: (eval:error (bits->value #b101)) (bits->value #b110) (eval:error (bits->value #b111)) - ) Notice that not all bits represent a value; name any odd number that's @@ -417,8 +415,7 @@ the use of @racket[interp] with it's definition: (define (interp-bits e) (value->bits (match e - [(Int i) i] - [(Bool b) b] + [(Lit l) l] [(Prim1 p e) (interp-prim1 p (interp e))] [(If e1 e2 e3) @@ -443,8 +440,7 @@ So we get: ;; Expr -> Bits (define (interp-bits e) (match e - [(Int i) (value->bits i)] - [(Bool b) (value->bits b)] + [(Lit l) (value->bits l)] [(Prim1 p e) (value->bits (interp-prim1 p (interp e)))] @@ -470,8 +466,8 @@ So we can replace the RHS of the first case with We can do similar reasoning on the second case with @racket[(value->bits b)] where @racket[b] is a boolean. From the definition of @racket[value->bits], we can replace the RHS with -@racket[(match b [#t val-true] [#f val-false])], which can be written -more succinctly as @racket[(if b val-true val-false)]. +@racket[(match b [#t (value->bits #t)] [#f (value->bits #f)])], which can be written +more succinctly as @racket[(if b (value->bits #t) (value->bits #f))]. In the third case, let's suppose there is an analog of @racket[interp-prim1] called @racket[interp-prim1-bits] that operates @@ -513,11 +509,11 @@ Of course, @racket[(value->bits (interp e1))] is just what ] Now observe that @racket[(interp e0)] produces @racket[#f] if and only -if @racket[(interp-bits e0)] produces @racket[val-false]. We can therefore +if @racket[(interp-bits e0)] produces @racket[(value->bits #f)]. We can therefore eliminate the use of @racket[interp] by replacing this conditional with: @racketblock[ -(if (eq? val-false (interp-bits e0)) +(if (eq? (value->bits #f) (interp-bits e0)) (interp-bits e2) (interp-bits e1)) ] @@ -532,12 +528,11 @@ We've now arrived at the following @racket[interp]-free definition of ;; Expr -> Bits (define (interp-bits e) (match e - [(Int i) (arithmetic-shift i int-shift)] - [(Bool b) (if b val-true val-false)] + [(Lit l) (value->bits l)] [(Prim1 p e) (interp-prim1-bits p (interp-bits e))] [(If e1 e2 e3) - (if (eq? val-false (interp-bits e1)) + (if (eq? (value->bits #f) (interp-bits e1)) (interp-bits e3) (interp-bits e2))]))) @@ -580,7 +575,7 @@ Now notice the following: @item{@racket[(value->bits (sub1 (bits->value b)))] ≡ @racket[(- b (value->bits 1))] ≡ @racket[(- b (arithmetic-shift 1 int-shift))]} -@item{@racket[(value->bits (zero? (bits->value b)))] ≡ @racket[(value->bits (zero? b))] ≡ @racket[(if (zero? b) val-true val-false)]} +@item{@racket[(value->bits (zero? (bits->value b)))] ≡ @racket[(value->bits (zero? b))] ≡ @racket[(if (zero? b) (value->bits #t) (value->bits #f))]} ] @@ -593,7 +588,7 @@ So we can define @racket[interp-prim1-bits] as: (match op ['add1 (+ b (arithmetic-shift 1 int-shift))] ['sub1 (- b (arithmetic-shift 1 int-shift))] - ['zero? (if (zero? b) val-true val-false)]))) + ['zero? (if (zero? b) (value->bits #t) (value->bits #f))]))) @;{ @@ -601,7 +596,7 @@ So we can define @racket[interp-prim1-bits] as: In the first two cases, we know that @racket[i] and @racket[b] are integers and booleans, respectively. So we know @racket[(values->bits -i) = (* 2 i)] and @racket[(values->bits b) = (if b #,val-true #,val-false)]. We can +i) = (* 2 i)] and @racket[(values->bits b) = (if b #,(value->bits #t) #,(value->bits #f))]. We can rewrite the code as: @;{the #:escape identity thing is a cute solution to the @@ -611,8 +606,7 @@ rewrite the code as: @code:comment{Expr -> Bits} (define (interp-bits e) (match e - [(Int i) (* 2 i)] - [(Bool b) (if b (identity val-true) (identity val-false))] + [(Lit l) (value->bits l)] [(Prim1 'add1 e0) (value->bits (add1 (interp e0)))] [(Prim1 'sub1 e0) @@ -640,8 +634,8 @@ We can rewrite the last case by the following equation: @code:comment{Expr -> Bits} (define (interp-bits e) (match e - [(Int i) (* 2 i)] - [(Bool b) (if b (identity val-true) (identity val-false))] + [(Lit i) (* 2 i)] + [(Lit b) (if b (identity (value->bits #t)) (identity (value->bits #f)))] [(Prim1 'add1 e0) (value->bits (add1 (interp e0)))] [(Prim1 'sub1 e0) @@ -674,8 +668,8 @@ to get: @code:comment{Expr -> Bits} (define (interp-bits e) (match e - [(Int i) (* 2 i)] - [(Bool b) (if b (identity val-true) (identity val-false))] + [(Lit i) (* 2 i)] + [(Lit b) (if b (identity (value->bits #t)) (identity (value->bits #f)))] [(Prim1 'add1 e0) (+ (value->bits (interp e0)) (value->bits 1))] [(Prim1 'sub1 e0) @@ -704,8 +698,8 @@ We can now rewrite by the equation of our specification: @code:comment{Expr -> Bits} (define (interp-bits e) (match e - [(Int i) (* 2 i)] - [(Bool b) (if b (identity val-true) (identity val-false))] + [(Lit i) (* 2 i)] + [(Lit b) (if b (identity (value->bits #t)) (identity (value->bits #f)))] [(Prim1 'add1 e0) (+ (interp-bits e0) (identity (value->bits 1)))] [(Prim1 'sub1 e0) @@ -730,16 +724,16 @@ and inline @racket[value->bits] specialized to a boolean argument: @code:comment{Expr -> Bits} (define (interp-bits e) (match e - [(Int i) (* 2 i)] - [(Bool b) (if b (identity val-true) (identity val-false))] + [(Lit i) (* 2 i)] + [(Lit b) (if b (identity (value->bits #t)) (identity (value->bits #f)))] [(Prim1 'add1 e0) (+ (interp-bits e0) (identity (value->bits 1)))] [(Prim1 'sub1 e0) (- (interp-bits e0) (identity (value->bits 1)))] [(Prim1 'zero? e0) (match (zero? (interp-bits e0)) - [#t (identity val-true)] - [#f (identity val-false)])] + [#t (identity (value->bits #t))] + [#f (identity (value->bits #f))])] [(If e0 e1 e2) (if (interp e0) (interp-bits e1) @@ -753,24 +747,27 @@ Still correct: Finally, in the last case, all that matters in @racket[(if (interp e0) ...)] is whether @racket[(interp e0)] returns @racket[#f] or something else. So we can rewrite in terms of whether @racket[(interp-bits e0)] -produces the representation of @racket[#f] (@binary[val-false 2]): +produces the representation of @racket[#f] (@binary[(value->bits #f) 2]): @ex[#:escape identity #:no-prompt @code:comment{Expr -> Bits} (define (interp-bits e) (match e - [(Int i) (* 2 i)] - [(Bool b) (if b (identity val-true) (identity val-false))] + [(Lit l) + (cond + [(integer? l) (* 2 l)] + [(boolean? l) + (if l (identity (value->bits #t)) (identity (value->bits #f)))])] [(Prim1 'add1 e0) (+ (interp-bits e0) (identity (value->bits 1)))] [(Prim1 'sub1 e0) (- (interp-bits e0) (identity (value->bits 1)))] [(Prim1 'zero? e0) (match (zero? (interp-bits e0)) - [#t (identity val-true)] - [#f (identity val-false)])] + [#t (identity (value->bits #t))] + [#f (identity (value->bits #f))])] [(If e0 e1 e2) - (if (= (interp-bits e0) (identity val-false)) + (if (= (interp-bits e0) (identity (value->bits #f))) (interp-bits e2) (interp-bits e1))])) ] @@ -804,8 +801,8 @@ interpreter in a final conversion: (define (interp.v2 e) (bits->value (interp-bits e))) -(interp.v2 (Bool #t)) -(interp.v2 (Bool #f)) +(interp.v2 (Lit #t)) +(interp.v2 (Lit #f)) (interp.v2 (parse '(if #f 1 2))) (interp.v2 (parse '(if #t 1 2))) (interp.v2 (parse '(if 0 1 2))) @@ -836,9 +833,9 @@ Let's consider some simple examples: before, but needs to use the new representation, i.e. the compiler should produce @racket[(Mov 'rax 84)], which is @racket[(* 42 2)].} -@item{@racket[#f]: this should produce @racket[(Mov 'rax #,val-false)].} +@item{@racket[#f]: this should produce @racket[(Mov 'rax #,(value->bits #f))].} -@item{@racket[#t]: this should produce @racket[(Mov 'rax #,val-true)].} +@item{@racket[#t]: this should produce @racket[(Mov 'rax #,(value->bits #t))].} @item{@racket[(add1 _e)]: this should produce the instructions for @racket[_e] followed by an instruction to add @racket[#,(value->bits 1)], which is @@ -850,8 +847,8 @@ subtracting @racket[#,(value->bits 1)].} @item{@racket[(zero? _e)]: this should produce the instructions for @racket[_e] followed by instructions that compare @racket['rax] to 0 and set @racket['rax] to - @racket[#t] (i.e. @binary[val-true 2]) if true and - @racket[#f] (i.e. @binary[val-false 2]) otherwise. + @racket[#t] (i.e. @binary[(value->bits #t) 2]) if true and + @racket[#f] (i.e. @binary[(value->bits #f) 2]) otherwise. This is a bit different from what we saw with Con, which combined conditional execution with testing for equality to @racket[0]. Here @@ -867,14 +864,14 @@ of instruction, the @bold{conditional move} instruction: @racket[Cmov]. compiling each subexpression, generating some labels and the appropriate comparison and conditional jump. The only difference is we now want to compare the result of executing @racket[_e0] with -@racket[#f] (i.e. @binary[val-false 2]) and jumping to the code for @racket[_e2] when +@racket[#f] (i.e. @binary[(value->bits #f) 2]) and jumping to the code for @racket[_e2] when they are equal.} ] @ex[ -(compile-e (Int 42)) -(compile-e (Bool #t)) -(compile-e (Bool #f)) +(compile-e (Lit 42)) +(compile-e (Lit #t)) +(compile-e (Lit #f)) (compile-e (parse '(zero? 0))) (compile-e (parse '(if #t 1 2))) (compile-e (parse '(if #f 1 2))) @@ -896,8 +893,8 @@ We can try out the compiler with the help of @racket[asm-interp], but you'll notice the results are a bit surprising: @ex[ -(asm-interp (compile (Bool #t))) -(asm-interp (compile (Bool #f))) +(asm-interp (compile (Lit #t))) +(asm-interp (compile (Lit #f))) (asm-interp (compile (parse '(zero? 0)))) (asm-interp (compile (parse '(zero? -7)))) (asm-interp (compile (parse '(if #t 1 2)))) @@ -917,8 +914,8 @@ values: (define (interp-compile e) (bits->value (asm-interp (compile e)))) -(interp-compile (Bool #t)) -(interp-compile (Bool #f)) +(interp-compile (Lit #t)) +(interp-compile (Lit #f)) (interp-compile (parse '(zero? 0))) (interp-compile (parse '(zero? -7))) (interp-compile (parse '(if #t 1 2))) @@ -948,7 +945,7 @@ integer, to recover the number being represented, we need to divide by 2, which can be done efficiently with a right-shift of 1 bit. Likewise with a boolean, if we shift right by 1 bit there are two possible results: -@racket[#,val-false] for false and @racket[#,val-true] for +@racket[#,(value->bits #f)] for false and @racket[#,(value->bits #t)] for true. We use the following interface for values in the runtime system: diff --git a/www/notes/extort.scrbl b/www/notes/extort.scrbl index e094c72b..0ea0ec4f 100644 --- a/www/notes/extort.scrbl +++ b/www/notes/extort.scrbl @@ -124,9 +124,9 @@ We can confirm the interpreter computes the right result for the examples given earlier: @ex[ -(interp (Prim1 'add1 (Bool #f))) -(interp (Prim1 'zero? (Bool #t))) -(interp (If (Prim1 'zero? (Bool #f)) (Int 1) (Int 2))) +(interp (Prim1 'add1 (Lit #f))) +(interp (Prim1 'zero? (Lit #t))) +(interp (If (Prim1 'zero? (Lit #f)) (Lit 1) (Lit 2))) ] The statement of correctness stays the same, but now observe that @@ -203,7 +203,7 @@ usual way again: (interp e) e)) -(check-correctness (Prim1 'add1 (Int 7))) -(check-correctness (Prim1 'add1 (Bool #f))) +(check-correctness (Prim1 'add1 (Lit 7))) +(check-correctness (Prim1 'add1 (Lit #f))) ] diff --git a/www/notes/fraud.scrbl b/www/notes/fraud.scrbl index 39ac32e5..24b39041 100644 --- a/www/notes/fraud.scrbl +++ b/www/notes/fraud.scrbl @@ -464,24 +464,24 @@ variable name either. The idea is that we will translate expression (@tt{Expr}) like: @racketblock[ -(Let 'x (Int 7) (Var 'x))] +(Let 'x (Lit 7) (Var 'x))] into intermediate expressions (@tt{IExpr}) like: @racketblock[ -(Let '_ (Int 7) (Var 0)) +(Let '_ (Lit 7) (Var 0)) ] And: @racketblock[ -(Let 'x (Int 7) (Let 'y (Int 9) (Var 'x))) +(Let 'x (Lit 7) (Let 'y (Lit 9) (Var 'x))) ] into: @racketblock[ -(Let '_ (Int 7) (Let '_ (Int 9) (Var 1))) +(Let '_ (Lit 7) (Let '_ (Lit 9) (Var 1))) ] @@ -507,8 +507,8 @@ by raising a (compile-time) error in the case of unbound variables. We can try out some examples to confirm it works as expected. @ex[ - (translate (Let 'x (Int 7) (Var 'x))) - (translate (Let 'x (Int 7) (Let 'y (Int 9) (Var 'x)))) + (translate (Let 'x (Lit 7) (Var 'x))) + (translate (Let 'x (Lit 7) (Let 'y (Lit 9) (Var 'x)))) ] The interpreter for @tt{IExpr}s will still have an diff --git a/www/notes/hustle.scrbl b/www/notes/hustle.scrbl index 9f82d30f..9673e740 100644 --- a/www/notes/hustle.scrbl +++ b/www/notes/hustle.scrbl @@ -141,10 +141,10 @@ primitives: (render-metafunction 𝑯-𝒑𝒓𝒊𝒎 #:contract? #t)) ] -The interpreter similarly has an update to the @racket[interp-prims] +The interpreter similarly has an update to the @racket[interp-prim] module: -@codeblock-include["hustle/interp-prims.rkt"] +@codeblock-include["hustle/interp-prim.rkt"] Inductively defined data is easy to model in the semantics and interpreter because we can rely on inductively defined data at the diff --git a/www/notes/iniquity.scrbl b/www/notes/iniquity.scrbl index 037888d6..938c378a 100644 --- a/www/notes/iniquity.scrbl +++ b/www/notes/iniquity.scrbl @@ -15,7 +15,7 @@ @(ev `(current-directory ,(path->string (build-path notes "iniquity")))) @(void (ev '(with-output-to-string (thunk (system "make runtime.o"))))) @(for-each (λ (f) (ev `(require (file ,f)))) - '("interp.rkt" "compile.rkt" "ast.rkt" "parse.rkt" "types.rkt" "unload-bits-asm.rkt")) + '("interp.rkt" "compile.rkt" "ast.rkt" "parse.rkt" "types.rkt")) @(define (shellbox . s) (parameterize ([current-directory (build-path notes "iniquity")]) @@ -160,8 +160,8 @@ We can try it out: @ex[ (interp (parse - '[(define (double x) (+ x x)) - (double 5) ])) + '(define (double x) (+ x x)) + '(double 5))) ] We can see it works with recursive functions, too. Here's a recursive @@ -170,12 +170,12 @@ function for computing triangular numbers: @ex[ (interp (parse - '[(define (tri x) - (if (zero? x) - 0 - (+ x (tri (sub1 x))))) + '(define (tri x) + (if (zero? x) + 0 + (+ x (tri (sub1 x))))) - (tri 9)])) + '(tri 9))) ] We can even define mutually recursive functions such as @racket[even?] @@ -184,16 +184,16 @@ and @racket[odd?]: @ex[ (interp (parse - '[(define (even? x) - (if (zero? x) - #t - (odd? (sub1 x)))) + '(define (even? x) + (if (zero? x) + #t + (odd? (sub1 x)))) - (define (odd? x) - (if (zero? x) - #f - (even? (sub1 x)))) - (even? 101)]))] + '(define (odd? x) + (if (zero? x) + #f + (even? (sub1 x)))) + '(even? 101)))] And the utility for interpreting programs in files works as well: @@ -654,7 +654,7 @@ Here's an example of the code this compiler emits: @ex[ (asm-display (compile - (parse '[(define (double x) (+ x x)) (double 5)]))) + (parse '(define (double x) (+ x x)) '(double 5)))) ] And we can confirm running the code produces results consistent with @@ -662,27 +662,27 @@ the interpreter: @ex[ (current-objs '("runtime.o")) -(define (run p) - (unload/free (asm-interp (compile (parse p))))) - -(run '[(define (double x) (+ x x)) - (double 5)]) - -(run '[(define (tri x) - (if (zero? x) - 0 - (+ x (tri (sub1 x))))) - (tri 9)]) - -(run '[(define (even? x) - (if (zero? x) - #t - (odd? (sub1 x)))) - (define (odd? x) - (if (zero? x) - #f - (even? (sub1 x)))) - (even? 101)]) +(define (run . p) + (bits->value (asm-interp (compile (apply parse p))))) + +(run '(define (double x) (+ x x)) + '(double 5)) + +(run '(define (tri x) + (if (zero? x) + 0 + (+ x (tri (sub1 x))))) + '(tri 9)) + +(run '(define (even? x) + (if (zero? x) + #t + (odd? (sub1 x)))) + '(define (odd? x) + (if (zero? x) + #f + (even? (sub1 x)))) + '(even? 101)) ] The complete compiler code: diff --git a/www/notes/jig.scrbl b/www/notes/jig.scrbl index 1e6e01b6..f5be1158 100644 --- a/www/notes/jig.scrbl +++ b/www/notes/jig.scrbl @@ -212,7 +212,7 @@ Here's what this code will compile to, roughly: (asm-interp (seq (Global 'entry) (Label 'entry) - + ;; calling (f 100), so set up return address, ;; push argument, then jump (Lea 'rax 'r1) @@ -221,20 +221,20 @@ Here's what this code will compile to, roughly: (Push 'rax) (Jmp 'f) (Label 'r1) - + ;; done with (f 100), return (Ret) - + ;; (define (f x) ...) (Label 'f) (Mov 'rax (Offset 'rsp 0)) (Cmp 'rax 0) (Jne 'if_false) - + ;; if-then branch (Mov 'rax 42) (Jmp 'done) - + ;; if-else branch (Label 'if_false) ;; calling (f (sub1 x)), so set up return address, @@ -246,7 +246,7 @@ Here's what this code will compile to, roughly: (Push 'rax) (Jmp 'f) (Label 'r2) - + (Label 'done) (Add 'rsp 8) ; pop x (Ret))) @@ -348,11 +348,11 @@ You can see where this is going. | . | | . | | . | - +----------------------+ + +----------------------+ | return to r2 | +----------------------+ | x : 1 | - +----------------------+ + +----------------------+ | return to r2 | +----------------------+ rsp ---> | x : 0 | @@ -422,7 +422,7 @@ We can modify the code to embody these ideas: (asm-interp (seq (Global 'entry) (Label 'entry) - + ;; calling (f 100), so set up return address, ;; push argument, then jump (Lea 'rax 'r1) @@ -431,20 +431,20 @@ We can modify the code to embody these ideas: (Push 'rax) (Jmp 'f) (Label 'r1) - + ;; done with (f 100), return (Ret) - + ;; (define (f x) ...) (Label 'f) (Mov 'rax (Offset 'rsp 0)) (Cmp 'rax 0) (Jne 'if_false) - + ;; if-then branch (Mov 'rax 42) (Jmp 'done) - + ;; if-else branch (Label 'if_false) ;; TAIL calling (f (sub1 x)), @@ -456,7 +456,7 @@ We can modify the code to embody these ideas: (Add 'rsp 8) ; pop x (Push 'rax) ; push arg (Jmp 'f) - + (Label 'done) (Add 'rsp 8) ; pop x (Ret))) @@ -550,17 +550,17 @@ call: ;; No need for this since we never come back: ;; (Ret) - + ;; (define (f x) ...) (Label 'f) (Mov 'rax (Offset 'rsp 0)) (Cmp 'rax 0) (Jne 'if_false) - + ;; if-then branch (Mov 'rax 42) (Jmp 'done) - + ;; if-else branch (Label 'if_false) ;; TAIL calling (f (sub1 x)), @@ -572,7 +572,7 @@ call: (Add 'rsp 8) ; pop x (Push 'rax) ; push arg (Jmp 'f) - + (Label 'done) (Add 'rsp 8) ; pop x (Ret))) @@ -637,7 +637,7 @@ ready to be made, the stack will look like: | 3 | +----------------------+ rsp ---> | 5 | - +----------------------+ + +----------------------+ }| At which point we need to remove the @racket[x] and @racket[y] part, @@ -651,7 +651,7 @@ below the return address, i.e. we want: | 3 | +----------------------+ rsp ---> | 5 | - +----------------------+ + +----------------------+ }| To accomplish, we rely on the following helper function for generating @@ -732,6 +732,7 @@ There are two important places where @racket[t?] is seeded to @racket[#t]: @item{The body of every function is in tail position.} ] + The complete compiler: @codeblock-include["jig/compile.rkt"] diff --git a/www/notes/knock.scrbl b/www/notes/knock.scrbl index e75598b9..3fac688a 100644 --- a/www/notes/knock.scrbl +++ b/www/notes/knock.scrbl @@ -22,7 +22,7 @@ @(void (ev '(with-output-to-string (thunk (system "make runtime.o"))))) @(ev '(current-objs '("runtime.o"))) @(for-each (λ (f) (ev `(require (file ,f)))) - '("interp.rkt" "compile.rkt" "ast.rkt" "parse.rkt" "types.rkt" "unload-bits-asm.rkt")) + '("interp.rkt" "compile.rkt" "ast.rkt" "parse.rkt" "types.rkt")) @(define this-lang "Knock") @@ -207,52 +207,52 @@ communicates the binding of the pattern variables to values. Let's consider some examples: @ex[ -(interp-match-pat (PWild) 99 '()) +(interp-match-pat (Var '_) 99 '()) ] Here the pattern matches, but binds no variables so the result is the same environment as given. @ex[ -(interp-match-pat (PVar 'x) 99 '()) +(interp-match-pat (Var 'x) 99 '()) ] Here the pattern matches and binds @racket[x] to @racket[99], which is reflected in the output environment. @ex[ -(interp-match-pat (PLit 99) 99 '()) +(interp-match-pat (Lit 99) 99 '()) ] Here the pattern matches but binds nothing. @ex[ -(interp-match-pat (PLit 100) 99 '()) +(interp-match-pat (Lit 100) 99 '()) ] Here the pattern doesn't match. @ex[ -(interp-match-pat (PAnd (PLit 99) (PVar 'x)) 99 '()) +(interp-match-pat (Conj (Lit 99) (Var 'x)) 99 '()) ] Here the pattern matches and binds @racket[x] to @racket[99]. @ex[ -(interp-match-pat (PAnd (PLit 100) (PVar 'x)) 99 '()) +(interp-match-pat (Conj (Lit 100) (Var 'x)) 99 '()) ] Here the pattern doesn't match. @ex[ -(interp-match-pat (PCons (PVar 'x) (PVar 'y)) 99 '()) +(interp-match-pat (Cons (Var 'x) (Var 'y)) 99 '()) ] Here the pattern doesn't match. @ex[ -(interp-match-pat (PCons (PVar 'x) (PVar 'y)) (cons 99 100) '()) +(interp-match-pat (Cons (Var 'x) (Var 'y)) (cons 99 100) '()) ] Here the pattern matches and binds @racket[x] to @racket[99] and @@ -263,8 +263,8 @@ environment produced will bind each variable to the appropriate sub-part of the given value: @ex[ -(interp-match-pat (PCons (PCons (PVar 'x) (PVar 'y)) - (PCons (PVar 'p) (PVar 'q))) +(interp-match-pat (Cons (Cons (Var 'x) (Var 'y)) + (Cons (Var 'p) (Var 'q))) (cons (cons 99 100) (cons #t #f)) '()) @@ -277,22 +277,22 @@ The complete code for @racket[interp-match-pat] is: ;; Pat Value Env -> [Maybe Env] (define (interp-match-pat p v r) (match p - [(PWild) r] - [(PVar x) (ext r x v)] - [(PLit l) (and (eqv? l v) r)] - [(PBox p) + [(Var '_) r] + [(Var x) (ext r x v)] + [(Lit l) (and (eqv? l v) r)] + [(Box p) (match v [(box v) (interp-match-pat p v r)] [_ #f])] - [(PCons p1 p2) + [(Cons p1 p2) (match v [(cons v1 v2) (match (interp-match-pat p1 v1 r) [#f #f] [r1 (interp-match-pat p2 v2 r1)])] [_ #f])] - [(PAnd p1 p2) + [(Conj p1 p2) (match (interp-match-pat p1 v r) [#f #f] [r1 (interp-match-pat p2 v r1)])])) @@ -353,12 +353,12 @@ to what we've been using all semester: @ex[ (interp (parse - '[(define (length xs) - (match xs - ['() 0] - [(cons x xs) - (add1 (length xs))])) - (length (cons 7 (cons 8 (cons 9 '()))))])) + '(define (length xs) + (match xs + ['() 0] + [(cons x xs) + (add1 (length xs))])) + '(length (cons 7 (cons 8 (cons 9 '())))))) ] @@ -414,7 +414,7 @@ in case it matches.} Let's look at some examples. First, consider the wildcard pattern: @ex[ -(compile-pattern (PWild) '() 'next) +(compile-pattern (Var '_) '() 'next) ] When the pattern is a wildcard, it produces an empty sequence of @@ -428,7 +428,7 @@ given because it doesn't bind anything. Now pattern variables: @ex[ -(compile-pattern (PVar 'x) '() 'next) +(compile-pattern (Var 'x) '() 'next) ] A pattern variable always matches and binds the value to @racket[x], @@ -443,7 +443,7 @@ pattern binds @racket[x] when it matches. Pattern literals: @ex[ -(compile-pattern (PLit 0) '() 'next) +(compile-pattern (Lit 0) '() 'next) ] In the ``determine and bind'' part, we compare the value in @@ -458,10 +458,10 @@ The environment stays the same because a literal doesn't bind anything. Supposing we had changed the example to: @ex[ -(compile-pattern (PLit 0) '(x y z) 'next) +(compile-pattern (Lit 0) '(x y z) 'next) ] -This is essentially saying ``compile the pattern @racket[(PLit 0)] +This is essentially saying ``compile the pattern @racket[(Lit 0)] assuming it occurs in the context of a surrounding pattern that binds @racket[x], @racket[y], and @racket[z] before getting to this point.'' If it fails, it needs to pop all three bindings of the stack, hence @@ -472,7 +472,7 @@ Now we get to the inductive patterns, which will be more interesting. Let's start with the @racket[box]-pattern. @ex[ -(compile-pattern (PBox (PWild)) '() 'next) +(compile-pattern (Box (Var '_)) '() 'next) ] This ``determine and bind'' part moves the value to a temporary @@ -488,7 +488,7 @@ so no changes in the output environment. Let's change the wild card to a literal: @ex[ -(compile-pattern (PBox (PLit 0)) '() 'next) +(compile-pattern (Box (Lit 0)) '() 'next) ] This works just like before but now in the ``determine and bind'' @@ -521,7 +521,7 @@ values: push it on the stack and fetch it later. With this in mind, consider the following example for matching @racket[(cons 0 0)]: @ex[ -(compile-pattern (PCons (PLit 0) (PLit 0)) '() 'next) +(compile-pattern (Cons (Lit 0) (Lit 0)) '() 'next) ] This starts off like the @racket[box] pattern checking the tag bits of @@ -542,7 +542,7 @@ push a value on the stack in order to restore it after matching the first subpattern: @ex[ -(compile-pattern (PAnd (PLit 0) (PLit 0)) '() 'next) +(compile-pattern (Conj (Lit 0) (Lit 0)) '() 'next) ] The @racket[compile-pattern] function is used by @@ -573,7 +573,7 @@ this it emits the code for what to do if the pattern doesn't fail Consider a match clause like @racket[[_ #t]]: @ex[ -(compile-match-clause (PWild) (Bool #t) '() 'done #f) +(compile-match-clause (Var '_) (Lit #t) '() 'done #f) ] Here we can see the value being matched is fetched from the top of the @@ -587,7 +587,7 @@ order to try matching the next clause. Let's look at a literal; consider a clause @racket[[0 #t]]: @ex[ -(compile-match-clause (PLit 0) (Bool #t) '() 'done #f) +(compile-match-clause (Lit 0) (Lit #t) '() 'done #f) ] As always, it starts by fetching the top of the stack and putting the @@ -606,7 +606,7 @@ e.g. @racket[[x x]]. Here we're going to reference the variable bound in the pattern in the right-hand-side: @ex[ -(compile-match-clause (PVar 'x) (Var 'x) '() 'done #f) +(compile-match-clause (Var 'x) (Var 'x) '() 'done #f) ] The value being matched is fetched from the stack. It's immediately @@ -618,7 +618,7 @@ stack, then pops this off and jumps to @racket[done]. OK, now let's try something like @racket[[(box x) x]]: @ex[ -(compile-match-clause (PBox (PVar 'x)) (Var 'x) '() 'done #f) +(compile-match-clause (Box (Var 'x)) (Var 'x) '() 'done #f) ] The value being matched is fetched from the stack. It's checked for @@ -678,15 +678,15 @@ expression: We can check that the compiler works for a complete example: @ex[ -(define (run p) - (unload/free (asm-interp (compile (parse p))))) +(define (run . p) + (bits->value (asm-interp (compile (apply parse p))))) (run - '[(define (length xs) - (match xs - ['() 0] - [(cons x xs) (add1 (length xs))])) - (length (cons 7 (cons 8 (cons 9 '()))))]) + '(define (length xs) + (match xs + ['() 0] + [(cons x xs) (add1 (length xs))])) + '(length (cons 7 (cons 8 (cons 9 '()))))) ] diff --git a/www/notes/mountebank.scrbl b/www/notes/mountebank.scrbl index ae855cea..98105505 100644 --- a/www/notes/mountebank.scrbl +++ b/www/notes/mountebank.scrbl @@ -16,7 +16,7 @@ @(void (ev '(with-output-to-string (thunk (system "make runtime.o"))))) @(void (ev '(current-objs '("runtime.o")))) @(for-each (λ (f) (ev `(require (file ,f)))) - '("interp.rkt" "compile.rkt" "compile-expr.rkt" "compile-literals.rkt" "compile-datum.rkt" "utils.rkt" "ast.rkt" "parse.rkt" "types.rkt" "unload-bits-asm.rkt")) + '("interp.rkt" "compile.rkt" "compile-expr.rkt" "compile-literals.rkt" "compile-datum.rkt" "utils.rkt" "ast.rkt" "parse.rkt" "types.rkt")) @(define this-lang "Mountebank") @@ -298,7 +298,7 @@ examples behave as expected: @ex[ (current-objs '("runtime.o")) (define (run . p) - (unload/free (asm-interp (compile (parse p))))) + (bits->value (asm-interp (compile (parse p))))) (run '#t) (run ''#t) diff --git a/www/notes/mug.scrbl b/www/notes/mug.scrbl index d82ec3f1..d1b2036c 100644 --- a/www/notes/mug.scrbl +++ b/www/notes/mug.scrbl @@ -16,7 +16,7 @@ @(void (ev '(with-output-to-string (thunk (system "make runtime.o"))))) @(void (ev '(current-objs '("runtime.o")))) @(for-each (λ (f) (ev `(require (file ,f)))) - '("interp.rkt" "compile.rkt" "compile-expr.rkt" "compile-literals.rkt" "utils.rkt" "ast.rkt" "parse.rkt" "types.rkt" "unload-bits-asm.rkt")) + '("interp.rkt" "compile.rkt" "compile-expr.rkt" "compile-literals.rkt" "utils.rkt" "ast.rkt" "parse.rkt" "types.rkt")) @(define this-lang "Mug") @@ -80,7 +80,7 @@ that returns @racket["Hello!"]: We can run it just to make sure: @ex[ -(unload/free +(bits->value (asm-interp (seq (Global 'entry) (Label 'entry) @@ -142,7 +142,7 @@ So to write a similar program that returns @racket["Hello!"] but following: @ex[ -(unload/free +(bits->value (asm-interp (seq (Global 'entry) (Label 'entry) @@ -191,7 +191,7 @@ Here is a version of the same program that avoids the @racket[Or] instruction, instead computing that type tagging at link time: @ex[ -(unload/free +(bits->value (asm-interp (seq (Global 'entry) (Label 'entry) @@ -226,7 +226,7 @@ efficient to evaluate string literals. We could replace the old (compile-string "Hello!") -(unload/free +(bits->value (asm-interp (seq (Global 'entry) (Label 'entry) @@ -475,7 +475,7 @@ We can try it out to confirm some examples. @ex[ (define (run . p) - (unload/free (asm-interp (compile (parse p))))) + (bits->value (asm-interp (compile (parse p))))) (run "Hello!") diff --git a/www/notes/neerdowell.scrbl b/www/notes/neerdowell.scrbl index 12a50e59..275fe60e 100644 --- a/www/notes/neerdowell.scrbl +++ b/www/notes/neerdowell.scrbl @@ -16,7 +16,7 @@ @(void (ev '(with-output-to-string (thunk (system "make runtime.o"))))) @(void (ev '(current-objs '("runtime.o")))) @(for-each (λ (f) (ev `(require (file ,f)))) - '("interp.rkt" "compile.rkt" "compile-expr.rkt" "compile-literals.rkt" "compile-datum.rkt" "utils.rkt" "ast.rkt" "parse.rkt" "types.rkt" "unload-bits-asm.rkt")) + '("interp.rkt" "compile.rkt" "compile-expr.rkt" "compile-literals.rkt" "compile-datum.rkt" "utils.rkt" "ast.rkt" "parse.rkt" "types.rkt")) @(define this-lang "Neerdowell") @@ -320,11 +320,11 @@ and @racket[struct-ref]: (Xor rax type-struct) ; untag the structure pointer (Mov rax (Offset rax 0)) ; get the structure type symbol (Cmp r8 rax) ; compare it to the type argument - (Mov rax (imm->bits #t)) + (Mov rax (value->bits #t)) (Jne f) ; a structure, but not this kind (Jmp t) ; a structure of the same kind (Label f) - (Mov rax (imm->bits #f)) + (Mov rax (value->bits #f)) (Label t)))] ['struct-ref @@ -396,7 +396,7 @@ We can now see structures in action: @ex[ (define (run . p) - (unload/free (asm-interp (compile (parse p))))) + (bits->value (asm-interp (compile (parse p))))) (run '(struct posn (x y)) '(posn? (posn 3 4))) diff --git a/www/notes/outlaw.scrbl b/www/notes/outlaw.scrbl index 29c79065..540afb3d 100644 --- a/www/notes/outlaw.scrbl +++ b/www/notes/outlaw.scrbl @@ -32,7 +32,7 @@ @(void (ev '(with-output-to-string (thunk (system "make runtime.o"))))) @(void (ev '(current-objs '("runtime.o")))) @(for-each (λ (f) (ev `(require (file ,f)))) - '(#;"interp.rkt" "compile.rkt" "compile-expr.rkt" "compile-literals.rkt" "compile-datum.rkt" "utils.rkt" "ast.rkt" "parse.rkt" "types.rkt" "unload-bits-asm.rkt")) + '(#;"interp.rkt" "compile.rkt" "compile-expr.rkt" "compile-literals.rkt" "compile-datum.rkt" "utils.rkt" "ast.rkt" "parse.rkt" "types.rkt")) @(define this-lang "Outlaw") @@ -250,12 +250,12 @@ which would emit the following code: (loop (gensym 'loop))) (seq (Mov r8 0) ; count = 0 (Label loop) - (Cmp rax (imm->bits '())) ; if empty, done + (Cmp rax (value->bits '())) ; if empty, done (Je done) (assert-cons rax) ; otherwise, should be a cons (Xor rax type-cons) (Mov rax (Offset rax 0)) ; move cdr into rax - (Add r8 (imm->bits 1)) ; increment count + (Add r8 (value->bits 1)) ; increment count (Jmp loop) ; loop (Label done) (Mov rax r8))) ; return count @@ -287,12 +287,12 @@ computing the length of the list in @racket['rax]: (loop (gensym 'loop))) (seq (Mov r8 0) ; count = 0 (Label loop) - (Cmp rax (imm->bits '())) ; if empty, done + (Cmp rax (value->bits '())) ; if empty, done (Je done) (assert-cons rax) ; otherwise, should be a cons (Xor rax type-cons) (Mov rax (Offset rax 0)) ; move cdr into rax - (Add r8 (imm->bits 1)) ; increment count + (Add r8 (value->bits 1)) ; increment count (Jmp loop) ; loop (Label done) (Mov rax r8))) ; return count diff --git a/www/project.scrbl b/www/project.scrbl index 5c5e9220..fce2d36f 100644 --- a/www/project.scrbl +++ b/www/project.scrbl @@ -9,6 +9,10 @@ The final assessment for this course consists of an individually completed project. +Details to be released later in the semester. + +@;{ + Final deliverables are due on the last day of class, July 7. @elem[#:style "strike"]{There are several projects to choose from, @@ -656,3 +660,4 @@ The @tt{} should be @tt{iniquity}, @tt{loot}, etc. and should be the same as the directory that contains the implementation. +} \ No newline at end of file diff --git a/www/schedule.scrbl b/www/schedule.scrbl index c87e0350..b2defa19 100644 --- a/www/schedule.scrbl +++ b/www/schedule.scrbl @@ -14,6 +14,99 @@ @(define (day s) @elem[s]) +@tabular[#:style 'boxed + #:sep @hspace[1] + #:row-properties '(bottom-border) + (list (list @bold{Week} + @bold{Due} + @bold{Monday} + @bold{Wednesday}) + + (list @wk{1/22} + "" + "No class" + @secref["Intro"]) + + + (list @wk{1/29} + @seclink["Assignment 1"]{A1} + @elem{@secref["OCaml to Racket"]} + @elem{@secref["OCaml to Racket"]}) +#| + (list @wk{9/11} + @seclink["Assignment 2"]{A2} + @elem{@secref["a86"]} + @elem{@secref["Abscond"]}) + + (list @wk{9/18} + "" + @itemlist[@item{@secref["Blackmail"]} + @item{@secref["Con"]}] + @itemlist[@item{@secref["Dupe"]} + @item{@secref{Dodger}}]) + + (list @wk{9/25} + @seclink["Assignment 3"]{A3} + @secref["Evildoer"] + @secref["Extort"]) + + (list @wk{10/2} + "" + @secref["Fraud"] + @elem{@secref["Fraud"] (cont.)}) + + (list @wk{10/9} + "" + @elem{@secref["Fraud"] (cont.)} + @secref["Midterm_1"]) + + (list @wk{10/16} + "" + @elem{@secref["Fraud"] (cont.)} + @elem{@secref["Hustle"]}) + + (list @wk{10/23} + "" + @elem{@secref["Hustle"] (cont.)} + @elem{@secref["Hoax"]}) + + (list @wk{10/30} + @seclink["Assignment 4"]{A4} + @elem{@secref["Iniquity"]} + @elem{@secref["Jig"]}) + + (list @wk{11/6} + "" + @elem{@secref["Knock"]} + @elem{@secref["Knock"] (cont.)}) + + (list @wk{11/13} + "" + "" + "") + + (list @wk{11/20} + "" + @secref["Midterm_2"] + "Thanksgiving break (no lecture)") + + (list @wk{11/27} + "" + "" + "") + + (list @wk{12/4} + "" + "" + "") + + (list @wk{12/11} + "" + "" + "") + |# +)] +@;{ @tabular[#:style 'boxed #:sep @hspace[1] #:row-properties '(bottom-border) @@ -41,14 +134,14 @@ (list @day{6/27} @elem{GC} @seclink["Assignment 5"]{A5}) (list @day{6/28} @secref["Mug"] "") (list @day{6/29} "Midterm 2" @secref["Midterm_2"]) -(list @day{6/30} @secref["Mountebank"] "") -(list @day{7/3} @secref["Neerdowell"] @seclink["Assignment 6"]{A6}) +(list @day{6/30} @secref["Mountebank"] "") +(list @day{7/3} @secref["Neerdowell"] @seclink["Assignment 6"]{A6}) (list @day{7/4} "Independence Day Holiday" "") (list @day{7/5} @secref["Outlaw"] "") (list @day{7/6} @elem{@secref["Outlaw"], cont.} "") (list @day{7/7} "Slack" @secref{Project}) ) ] - +} @bold{Final project assessment: @|final-date|.} diff --git a/www/software.scrbl b/www/software.scrbl index e3a262e5..0b8583f7 100644 --- a/www/software.scrbl +++ b/www/software.scrbl @@ -146,7 +146,7 @@ You will also want to make sure your Racket installation is visible from your @tt{PATH} environment variable. Assuming Racket was installed in the usual location, you can run: -@verbatim|{ export PATH=$PATH:"/Applications/Racket v8.9/bin"}| +@verbatim|{ export PATH=$PATH:"/Applications/Racket v|@|racket-version|/bin"}| NOTE: You'll need to know what version of Racket you installed and use that version's name in the above command. For example, if you install Racket 8.6, diff --git a/www/syllabus.scrbl b/www/syllabus.scrbl index 8e936517..ce33f611 100644 --- a/www/syllabus.scrbl +++ b/www/syllabus.scrbl @@ -24,11 +24,11 @@ @bold{Term:} @string-titlecase[semester], @year -@bold{Professor:} @prof (@prof-pronouns) +@bold{Professor:} @prof1 (@prof1-pronouns) -@bold{Email:} @prof-email +@bold{Email:} @prof1-email -@bold{Office Hours:} By appointment. Send email or Discord DM to set +@bold{Office Hours:} By appointment. Send email or ELMS message to set up. @bold{Prerequisite:} a grade of C or better in CMSC330; and permission @@ -36,11 +36,10 @@ of department; or CMSC graduate student. @bold{Credits:} 3. -@bold{Lecture dates:} @lecture-dates +@;{@bold{Lecture dates:} @lecture-dates} -@bold{Lecture Times:} @lecture-schedule - -@bold{Classroom:} @classroom +@bold{Lectures:} +@lecture-schedule1, @classroom1 (@prof1-initials) @bold{Course Description:} @courseno is an introduction to compilers. Its major goal is to arm students with the ability to design, @@ -54,8 +53,8 @@ OCaml from CMSC 330, and, to a lesser extent, imperative programming in C and Assembly as covered in CMSC 216. -@bold{Course Structure:} The course will consist of synchronous -@bold{zoom} lectures, which will be recorded and available on ELMS +@bold{Course Structure:} The course will consist of +in-person lectures, which will be recorded and available on ELMS immediately after each lecture. There are two midterms, a final project, which counts as the final assessment for the class, several assignments, and several quizes and surveys. Midterms are take-home @@ -107,11 +106,12 @@ and we ask you to do the same for all of your fellow Terps. @bold{Communication with Instructor:} -Email: If you need to reach out and communicate with @prof, please -email at @|prof-email|. Please DO NOT email questions that are easily -found in the syllabus or on ELMS (i.e. When is this assignment due? -How much is it worth? etc.) but please DO reach out about personal, -academic, and intellectual concerns/questions. +Email: If you need to reach out and communicate with @prof1, +please email at @|prof1-email|. Please DO NOT email +questions that are easily found in the syllabus or on ELMS (i.e. When +is this assignment due? How much is it worth? etc.) but please DO +reach out about personal, academic, and intellectual +concerns/questions. ELMS: IMPORTANT announcements will be sent via ELMS messaging. You must make sure that your email & announcement notifications (including @@ -147,9 +147,7 @@ hindered by the learning environment. @section{Office Hours} -Office hours will be held on @link[@discord]{this discord -server}. Make sure that your 'nickname' is set to something appropriate for -class. +Office hours will be held online and in-person. Details TBD. @;{Please make sure that you fill out @link["https://docs.google.com/spreadsheets/d/1sDCpekBHIGjVSuGDsabPb74wZ5nHA_sTLvIPOzTUQ4k/edit?usp=sharing"]{ @@ -162,7 +160,7 @@ up repeatedly, the staff can make an announcement that addresses the concern for the entire class. Lastly, it helps the course staff keep an eye on what topics might need more attention.} -The discord server is there for you to organize as a class, ask questions of +@;{The discord server is there for you to organize as a class, ask questions of each other, and to get help from staff. Its main purpose is as a vehicle for office hours. That said, feel free to use the discord for discussion. I (@prof-initials) will check periodically, but if you would like to ask a question directly to @@ -172,7 +170,7 @@ communication. There is a channel '#course-discussion' that is meant for discussion/questions/help regarding the material of the course, make sure that you keep that channel free from noise so that other students and course staff -can easily see what issues are being brought up. +can easily see what issues are being brought up.} @section{Topics} @@ -305,7 +303,7 @@ will be provided during office hours. Office hours for the instructional staff will be posted on the course web page. Additional assistance will provided via discussion on -@link[@discord]{Discord}. You may use this forum to ask general +@link[@piazza]{Piazza}. You may use this forum to ask general questions of interest to the class as a whole, e.g., administrative issues or problem set clarification questions. The course staff will monitor it on a daily basis, but do not expect immediate answers to @@ -313,15 +311,15 @@ questions. Please do not post publicly any information that would violate the university academic integrity policy (e.g., problem set code). -Discord allows students to send private questions that are only +@;{Discord allows students to send private questions that are only visible to instructors. Please use this feature if you wish to ask -specific questions concerning your assignment solutions. +specific questions concerning your assignment solutions.} Personal e-mail to TAs should be reserved for issues that cannot be handled by the above methods. Important announcements will be made in class or on the class web -page, and via Discord. +page, and via Piazza. @section{Excused Absences} diff --git a/ziggy/info.rkt b/ziggy/info.rkt new file mode 100644 index 00000000..9866a55e --- /dev/null +++ b/ziggy/info.rkt @@ -0,0 +1,8 @@ +#lang info +(define version "1.0") +(define collection 'use-pkg-name) +(define compile-omit-paths (list "src")) +(define test-omit-paths (list "src/test")) +(define deps (list "base" "rackunit" + "git+https://github.com/dvanhorn/crook.git?path=#main")) + diff --git a/ziggy/src/Makefile b/ziggy/src/Makefile new file mode 100644 index 00000000..f482f0f8 --- /dev/null +++ b/ziggy/src/Makefile @@ -0,0 +1,2 @@ +runtime.o: + touch runtime.o # this is a dummy runtime for Ziggy diff --git a/ziggy/src/ast.rkt b/ziggy/src/ast.rkt new file mode 100644 index 00000000..6de4c2de --- /dev/null +++ b/ziggy/src/ast.rkt @@ -0,0 +1,84 @@ +#lang crook +{:= A B C D0 D0.A D1 E0 E1 F H0 H1 I J K} +(provide {:> A} Lit {:> E0} Prim0 {:> B} Prim1 {:> F} Prim2 {:> H1} Prim3 + {:> C D0} IfZero {:> D0} If {:> E0} Eof {:> E0} Begin {:> F} Let + {:> F} Var {:> H0} Empty {:> I} Prog {:> I} Defn {:> I} App + {:> K} Match {:> K} Box {:> K} Cons {:> K} Conj) +;; + +{:> I} ;; type Prog = (Prog (Listof Defn) Expr) +{:> I} (struct Prog (ds e) #:prefab) + +{:> I} ;; type Defn = (Defn Id (Listof Id) Expr) +{:> I} (struct Defn (f xs e) #:prefab) + +{:> A D0} ;; type Expr = (Lit Integer) +{:> D0} ;; type Expr = (Lit Datum) +{:> E0} ;; | (Eof) +{:> H0} ;; | (Empty) +{:> E0} ;; | (Prim0 Op0) +{:> B} ;; | (Prim1 Op1 Expr) +{:> F} ;; | (Prim2 Op2 Expr Expr) +{:> H1} ;; | (Prim3 Op3 Expr Expr Expr) +{:> C D0} ;; | (IfZero Expr Expr Expr) +{:> D0} ;; | (If Expr Expr Expr) +{:> D0.A D1} + ;; | (Cond [Listof CondClause] Expr) +{:> D0.A D1} + ;; | (Case Expr [Listof CaseClause] Expr) +{:> F} ;; | (Let Id Expr Expr) +{:> F} ;; | (Var Id) +{:> I} ;; | (App Id (Listof Expr)) +{:> K} ;; | (Match Expr (Listof Pat) (Listof Expr)) + +{:> D0.A D1} +;; type CondClause = (Clause Expr Expr) +{:> D0.A D1} +;; type CaseClause = (Clause [Listof Datum] Expr) + +{:> F} ;; type Id = Symbol +{:> D0} ;; type Datum = Integer +{:> D0} ;; | Boolean +{:> D1} ;; | Character +{:> H1} ;; | String +{:> E0} ;; type Op0 = 'read-byte | 'peek-byte | 'void +{:> B} ;; type Op1 = 'add1 | 'sub1 +{:> D0} ;; | 'zero? +{:> D0.A D1} + ;; | 'abs | '- | 'not +{:> D1} ;; | 'char? | 'integer->char | 'char->integer +{:> E0} ;; | 'write-byte | 'eof-object? +{:> H0} ;; | 'box | 'car | 'cdr | 'unbox +{:> H0} ;; | 'empty? | 'cons? | 'box? +{:> H1} ;; | 'vector? | vector-length +{:> H1} ;; | 'string? | string-length +{:> F} ;; type Op2 = '+ | '- | '< | '= +{:> H0} ;; | eq? | 'cons +{:> H1} ;; | 'make-vector | 'vector-ref +{:> H1} ;; | 'make-string | 'string-ref +{:> H1} ;; type Op3 = 'vector-set! +{:> K} ;; type Pat = (Var Id) +{:> K} ;; | (Lit Datum) +{:> K} ;; | (Box Pat) +{:> K} ;; | (Cons Pat Pat) +{:> K} ;; | (Conj Pat Pat) + +{:> E0} (struct Eof () #:prefab) +{:> H0} (struct Empty () #:prefab) +{:> A D0} (struct Lit (i) #:prefab) +{:> D0} (struct Lit (d) #:prefab) +{:> E0} (struct Prim0 (p) #:prefab) +{:> B} (struct Prim1 (p e) #:prefab) +{:> F} (struct Prim2 (p e1 e2) #:prefab) +{:> H1} (struct Prim3 (p e1 e2 e3) #:prefab) +{:> C D0} (struct IfZero (e1 e2 e3) #:prefab) +{:> D0} (struct If (e1 e2 e3) #:prefab) +{:> E0} (struct Begin (e1 e2) #:prefab) +{:> F} (struct Let (x e1 e2) #:prefab) +{:> F} (struct Var (x) #:prefab) +{:> I} (struct App (f es) #:prefab) +{:> K} (struct Match (e ps es) #:prefab) + +{:> K} (struct Box (p) #:prefab) +{:> K} (struct Cons (p1 p2) #:prefab) +{:> K} (struct Conj (p1 p2) #:prefab) diff --git a/ziggy/src/build-runtime.rkt b/ziggy/src/build-runtime.rkt new file mode 100644 index 00000000..33284803 --- /dev/null +++ b/ziggy/src/build-runtime.rkt @@ -0,0 +1,14 @@ +#lang crook +{:= E0 E1 F H0 H1 I J K} +(provide runtime-path) + +(require racket/runtime-path) +(define-runtime-path here ".") + +(unless (system (string-append "make -C '" + (path->string (normalize-path here)) + "' runtime.o")) + (error 'build-runtime "could not build runtime")) + +(define runtime-path + (normalize-path (build-path here "runtime.o"))) diff --git a/ziggy/src/compile-ops.rkt b/ziggy/src/compile-ops.rkt new file mode 100644 index 00000000..5bd6f864 --- /dev/null +++ b/ziggy/src/compile-ops.rkt @@ -0,0 +1,385 @@ +#lang crook +{:= B C D0 D0.A D1 E0 E1 F H0 H1 I J K} +(provide {:> E0} compile-op0 compile-op1 {:> F} compile-op2 {:> H1} compile-op3 {:> F} pad-stack) +(require "ast.rkt") +{:> D0} (require "types.rkt") +(require a86/ast) + +(define rax 'rax) +{:> H1} (define eax 'eax) {:> H1} ; 32-bit load/store +{:> H0} (define rbx 'rbx) {:> H0} ; heap +{:> E0} (define rdi 'rdi) {:> E0} ; arg +{:> F} (define r8 'r8) {:> F} ; scratch in op2 +{:> D0} (define r9 'r9) {:> E0} ; scratch +{:> H1} (define r10 'r10) {:> H1} ; scratch + +{:> F} (define r15 'r15) {:> F} ; stack pad (non-volatile) +{:> F} (define rsp 'rsp) {:> F} ; stack + +{:> E0} ;; Op0 -> Asm +{:> E0} +(define (compile-op0 p) + (match p + ['void (seq (Mov rax (value->bits (void))))] + ['read-byte (seq {:> F} pad-stack (Call 'read_byte) {:> F} unpad-stack)] + ['peek-byte (seq {:> F} pad-stack (Call 'peek_byte) {:> F} unpad-stack)])) + +;; Op1 -> Asm +(define (compile-op1 p) + (match p + {:> B D0} ['add1 (Add rax 1)] + {:> B D0} ['sub1 (Sub rax 1)] + {:> D0 E1} ['add1 (Add rax (value->bits 1))] + {:> E1} ['add1 + (seq (assert-integer rax) + (Add rax (value->bits 1)))] + {:> D0 E1} ['sub1 (Sub rax (value->bits 1))] + {:> E1} ['sub1 + (seq (assert-integer rax) + (Sub rax (value->bits 1)))] + {:> D0} ['zero? + {:> D0 D1} + (seq (Cmp rax 0) + (Mov rax (value->bits #f)) + (Mov r9 (value->bits #t)) + (Cmove rax r9)) + {:> D1} + (seq {:> E1} (assert-integer rax) + (Cmp rax 0) + if-equal)] + {:> D1} ['char? + (seq (And rax mask-char) + (Cmp rax type-char) + if-equal)] + {:> D1} ['char->integer + (seq {:> E1} (assert-char rax) + (Sar rax char-shift) + (Sal rax int-shift))] + {:> D1} ['integer->char + (seq {:> E1} (assert-codepoint) + (Sar rax int-shift) + (Sal rax char-shift) + (Xor rax type-char))] + {:> E0} ['eof-object? + (seq (Cmp rax (value->bits eof)) + if-equal)] + {:> E0} ['write-byte + (seq {:> E1} assert-byte + {:> F} pad-stack + (Mov rdi rax) + (Call 'write_byte) + {:> F} unpad-stack)] + + {:> H0} ['box + (seq (Mov (Offset rbx 0) rax) ; memory write + (Mov rax rbx) ; put box in rax + (Or rax type-box) ; tag as a box + (Add rbx 8))] + + {:> H0} ['unbox + (seq (assert-box rax) + (Xor rax type-box) + (Mov rax (Offset rax 0)))] + {:> H0} ['car + (seq (assert-cons rax) + (Xor rax type-cons) + (Mov rax (Offset rax 8)))] + {:> H0} ['cdr + (seq (assert-cons rax) + (Xor rax type-cons) + (Mov rax (Offset rax 0)))] + + {:> H0} ['empty? (seq (Cmp rax (value->bits '())) if-equal)] + {:> H0} ['cons? (type-pred ptr-mask type-cons)] + {:> H0} ['box? (type-pred ptr-mask type-box)] + {:> H1} ['vector? (type-pred ptr-mask type-vect)] + {:> H1} ['string? (type-pred ptr-mask type-str)] + {:> H1} ['vector-length + (let ((zero (gensym)) + (done (gensym))) + (seq (assert-vector rax) + (Xor rax type-vect) + (Cmp rax 0) + (Je zero) + (Mov rax (Offset rax 0)) + (Sal rax int-shift) + (Jmp done) + (Label zero) + (Mov rax 0) + (Label done)))] + {:> H1} + ['string-length + (let ((zero (gensym)) + (done (gensym))) + (seq (assert-string rax) + (Xor rax type-str) + (Cmp rax 0) + (Je zero) + (Mov rax (Offset rax 0)) + (Sal rax int-shift) + (Jmp done) + (Label zero) + (Mov rax 0) + (Label done)))])) + + +{:> F} ;; Op2 -> Asm +{:> F} +(define (compile-op2 p) + (match p + ['+ + (seq (Pop r8) + (assert-integer r8) + (assert-integer rax) + (Add rax r8))] + ['- + (seq (Pop r8) + (assert-integer r8) + (assert-integer rax) + (Sub r8 rax) + (Mov rax r8))] + ['< + (seq (Pop r8) + (assert-integer r8) + (assert-integer rax) + (Cmp r8 rax) + if-lt)] + ['= + (seq (Pop r8) + (assert-integer r8) + (assert-integer rax) + (Cmp r8 rax) + if-equal)] + {:> H0} + ['cons + (seq (Mov (Offset rbx 0) rax) + (Pop rax) + (Mov (Offset rbx 8) rax) + (Mov rax rbx) + (Or rax type-cons) + (Add rbx 16))] + {:> H0} + ['eq? + (seq (Pop r8) + (Cmp rax r8) + if-equal)] + {:> H1} + ['make-vector ;; size value + (let ((loop (gensym)) + (done (gensym)) + (empty (gensym))) + (seq (Pop r8) ;; r8 = size + (assert-natural r8) + (Cmp r8 0) ; special case empty vector + (Je empty) + + (Mov r9 rbx) + (Or r9 type-vect) + + (Sar r8 int-shift) + (Mov (Offset rbx 0) r8) + (Add rbx 8) + + (Label loop) + (Mov (Offset rbx 0) rax) + (Add rbx 8) + (Sub r8 1) + (Cmp r8 0) + (Jne loop) + + (Mov rax r9) + (Jmp done) + + (Label empty) + (Mov rax type-vect) + (Label done)))] + {:> H1} + ['vector-ref ; vector index + (seq (Pop r8) + (assert-vector r8) + (assert-integer rax) + (Cmp r8 type-vect) + (Je 'err) ; special case for empty vector + (Cmp rax 0) + (Jl 'err) + (Xor r8 type-vect) ; r8 = ptr + (Mov r9 (Offset r8 0)) ; r9 = len + (Sar rax int-shift) ; rax = index + (Sub r9 1) + (Cmp r9 rax) + (Jl 'err) + (Sal rax 3) + (Add r8 rax) + (Mov rax (Offset r8 8)))] + {:> H1} + ['make-string + (let ((loop (gensym)) + (done (gensym)) + (empty (gensym))) + (seq (Pop r8) + (assert-natural r8) + (assert-char rax) + (Cmp r8 0) ; special case empty string + (Je empty) + + (Mov r9 rbx) + (Or r9 type-str) + + (Sar r8 int-shift) + (Mov (Offset rbx 0) r8) + (Add rbx 8) + + (Sar rax char-shift) + + (Add r8 1) ; adds 1 + (Sar r8 1) ; when + (Sal r8 1) ; len is odd + + (Label loop) + (Mov (Offset rbx 0) eax) + (Add rbx 4) + (Sub r8 1) + (Cmp r8 0) + (Jne loop) + + (Mov rax r9) + (Jmp done) + + (Label empty) + (Mov rax type-str) + (Label done)))] + {:> H1} + ['string-ref + (seq (Pop r8) + (assert-string r8) + (assert-integer rax) + (Cmp r8 type-str) + (Je 'err) ; special case for empty string + (Cmp rax 0) + (Jl 'err) + (Xor r8 type-str) ; r8 = ptr + (Mov r9 (Offset r8 0)) ; r9 = len + (Sar rax int-shift) ; rax = index + (Sub r9 1) + (Cmp r9 rax) + (Jl 'err) + (Sal rax 2) + (Add r8 rax) + (Mov 'eax (Offset r8 8)) + (Sal rax char-shift) + (Or rax type-char))])) + +{:> H1} ;; Op3 -> Asm +{:> H1} +(define (compile-op3 p) + (match p + ['vector-set! + (seq (Pop r10) + (Pop r8) + (assert-vector r8) + (assert-integer r10) + (Cmp r10 0) + (Jl 'err) + (Xor r8 type-vect) ; r8 = ptr + (Mov r9 (Offset r8 0)) ; r9 = len + (Sar r10 int-shift) ; r10 = index + (Sub r9 1) + (Cmp r9 r10) + (Jl 'err) + (Sal r10 3) + (Add r8 r10) + (Mov (Offset r8 8) rax) + (Mov rax (value->bits (void))))])) + + +{:> D1} ;; -> Asm +{:> D1} ;; set rax to #t or #f if comparison flag is equal +{:> D1} +(define if-equal + (seq (Mov rax (value->bits #f)) + (Mov r9 (value->bits #t)) + (Cmove rax r9))) + +{:> F} ;; -> Asm +{:> F} ;; set rax to #t or #f if comparison flag is less than +{:> F} +(define if-lt + (seq (Mov rax (value->bits #f)) + (Mov r9 (value->bits #t)) + (Cmovl rax r9))) + +{:> E1} +(define (assert-type mask type) + (λ (arg) + (seq (Mov r9 arg) + (And r9 mask) + (Cmp r9 type) + (Jne 'err)))) + +{:> E1} +(define (type-pred mask type) + (seq (And rax mask) + (Cmp rax type) + if-equal)) + +{:> E1} +(define assert-integer + (assert-type mask-int type-int)) +{:> E1} +(define assert-char + (assert-type mask-char type-char)) +{:> H0} +(define assert-box + (assert-type ptr-mask type-box)) +{:> H0} +(define assert-cons + (assert-type ptr-mask type-cons)) +{:> H1} +(define assert-vector + (assert-type ptr-mask type-vect)) +{:> H1} +(define assert-string + (assert-type ptr-mask type-str)) + +{:> E1} +(define (assert-codepoint) + (let ((ok (gensym))) + (seq (assert-integer rax) + (Cmp rax (value->bits 0)) + (Jl 'err) + (Cmp rax (value->bits 1114111)) + (Jg 'err) + (Cmp rax (value->bits 55295)) + (Jl ok) + (Cmp rax (value->bits 57344)) + (Jg ok) + (Jmp 'err) + (Label ok)))) + +{:> E1} +(define assert-byte + (seq (assert-integer rax) + (Cmp rax (value->bits 0)) + (Jl 'err) + (Cmp rax (value->bits 255)) + (Jg 'err))) + +{:> H1} +(define (assert-natural r) + (seq (assert-integer r) + (Cmp r (value->bits 0)) + (Jl 'err))) + +{:> F} ;; Asm +{:> F} ;; Dynamically pad the stack to be aligned for a call +{:> F} +(define pad-stack + (seq (Mov r15 rsp) + (And r15 #b1000) + (Sub rsp r15))) + +{:> F} ;; Asm +{:> F} ;; Undo the stack alignment after a call +{:> F} +(define unpad-stack + (seq (Add rsp r15))) diff --git a/ziggy/src/compile-stdin.rkt b/ziggy/src/compile-stdin.rkt new file mode 100644 index 00000000..1662cdd6 --- /dev/null +++ b/ziggy/src/compile-stdin.rkt @@ -0,0 +1,14 @@ +#lang crook +{:= A B C D0 D0.A D1 E0 E1 F H0 H1 I J K} +(provide main) +(require "parse.rkt") +(require "compile.rkt") +{:> I} (require "read-all.rkt") +(require a86/printer) + +;; -> Void +;; Compile contents of stdin, +;; emit asm code on stdout +(define (main) + (read-line) ; ignore #lang racket line + (asm-display (compile {:> A I} (parse (read)) {:> I} (apply parse (read-all))))) diff --git a/ziggy/src/compile.rkt b/ziggy/src/compile.rkt new file mode 100644 index 00000000..32ddfbe8 --- /dev/null +++ b/ziggy/src/compile.rkt @@ -0,0 +1,406 @@ +#lang crook +{:= A B C D0 D0.A D1 E0 E1 F H0 H1 I J K} +(provide (all-defined-out)) +(require "ast.rkt") +{:> B} (require "compile-ops.rkt") +{:> D0} (require "types.rkt") +(require a86/ast) + +(define rax 'rax) +{:> H0} (define rbx 'rbx) {:> H0} ; heap +{:> E0} (define rsp 'rsp) {:> E0} ; stack +{:> H0} (define rdi 'rdi) {:> H0} ; arg +{:> J} (define r8 'r8) {:> J} ; scratch +{:> F} (define r15 'r15) {:> F} ; stack pad (non-volatile) + +{:> A I} ;; Expr -> Asm +{:> A I} +(define (compile e) + (prog (Global 'entry) + {:> E0} (Extern 'peek_byte) + {:> E0} (Extern 'read_byte) + {:> E0} (Extern 'write_byte) + {:> E1} (Extern 'raise_error) + (Label 'entry) + {:> E0 F} (Sub rsp 8) + {:> A F} (compile-e e) + {:> E0 F} (Add rsp 8) + {:> F} (Push r15) {:> F} ; save callee-saved register + {:> H0} (Push rbx) + {:> H0} (Mov rbx rdi) {:> H0} ; recv heap pointer + {:> F} (compile-e e '()) + {:> H0} (Pop rbx) + {:> F} (Pop r15) {:> F} ; restore callee-save register + (Ret) + {:> E1} ;; Error handler + {:> E1} (Label 'err) + {:> F} pad-stack + {:> E1} (Call 'raise_error))) + +{:> I} ;; Prog -> Asm +{:> I} +(define (compile p) + (match p + [(Prog ds e) + (prog (Global 'entry) + (Extern 'peek_byte) + (Extern 'read_byte) + (Extern 'write_byte) + (Extern 'raise_error) + (Label 'entry) + (Push rbx) ; save callee-saved register + (Push r15) + (Mov rbx rdi) ; recv heap pointer + (compile-e e '() {:> J} #f) + (Pop r15) ; restore callee-save register + (Pop rbx) + (Ret) + (compile-defines ds) + (Label 'err) + pad-stack + (Call 'raise_error))])) + +{:> I} ;; [Listof Defn] -> Asm +{:> I} +(define (compile-defines ds) + (match ds + ['() (seq)] + [(cons d ds) + (seq (compile-define d) + (compile-defines ds))])) + +{:> I} ;; Defn -> Asm +{:> I} +(define (compile-define d) + (match d + [(Defn f xs e) + (seq (Label (symbol->label f)) + (compile-e e (reverse xs) {:> J} #t) + (Add rsp (* 8 (length xs))) ; pop args + (Ret))])) + +{:> F} ;; type CEnv = (Listof [Maybe Id]) + +{:> A F} ;; Expr -> Asm +{:> F J} ;; Expr CEnv -> Asm +{:> J} ;; Expr CEnv Boolean -> Asm +(define (compile-e e {:> F} c {:> J} t?) + (match e + {:> A D0} + [(Lit i) (seq (Mov rax i))] + {:> D0} + [(Lit d) (compile-value d)] + {:> E0} + [(Eof) (compile-value eof)] + {:> H0} + [(Empty) (compile-value '())] + {:> F} + [(Var x) (compile-variable x c)] + {:> E0} + [(Prim0 p) (compile-prim0 p)] + {:> B} + [(Prim1 p e) (compile-prim1 p e {:> F} c)] + {:> F} + [(Prim2 p e1 e2) (compile-prim2 p e1 e2 c)] + {:> H1} + [(Prim3 p e1 e2 e3) (compile-prim3 p e1 e2 e3 c)] + {:> C D0} + [(IfZero e1 e2 e3) + (compile-ifzero e1 e2 e3)] + {:> D0} + [(If e1 e2 e3) + (compile-if e1 e2 e3 {:> F} c {:> J} t?)] + {:> E0} + [(Begin e1 e2) + (compile-begin e1 e2 {:> F} c {:> J} t?)] + {:> F} + [(Let x e1 e2) + (compile-let x e1 e2 c {:> J} t?)] + {:> I} + [(App f es) + (compile-app f es c {:> J} t?)] + {:> K} + [(Match e ps es) (compile-match e ps es c t?)])) + +{:> D0} ;; Value -> Asm +{:> D0} +(define (compile-value v) + {:> D0 H1} + (seq (Mov rax (value->bits v))) + {:> H1} + (cond [(string? v) (compile-string v)] + [else (Mov rax (value->bits v))])) + +{:> F} ;; Id CEnv -> Asm +{:> F} +(define (compile-variable x c) + (let ((i (lookup x c))) + (seq (Mov rax (Offset rsp i))))) + +{:> H1} ;; String -> Asm +{:> H1} +(define (compile-string s) + (let ((len (string-length s))) + (if (zero? len) + (seq (Mov rax type-str)) + (seq (Mov rax len) + (Mov (Offset rbx 0) rax) + (compile-string-chars (string->list s) 8) + (Mov rax rbx) + (Or rax type-str) + (Add rbx + (+ 8 (* 4 (if (odd? len) (add1 len) len)))))))) + +{:> H1} ;; [Listof Char] Integer -> Asm +{:> H1} +(define (compile-string-chars cs i) + (match cs + ['() (seq)] + [(cons c cs) + (seq (Mov rax (char->integer c)) + (Mov (Offset rbx i) 'eax) + (compile-string-chars cs (+ 4 i)))])) + +{:> E0} ;; Op0 -> Asm +{:> E0} +(define (compile-prim0 p) + (compile-op0 p)) + +{:> B F} ;; Op1 Expr -> Asm +{:> F} ;; Op1 Expr CEnv -> Asm +{:> B} +(define (compile-prim1 p e {:> F} c) + (seq (compile-e e {:> F} c {:> J} #f) + (compile-op1 p))) + +{:> F} ;; Op2 Expr Expr CEnv -> Asm +{:> F} +(define (compile-prim2 p e1 e2 c) + (seq (compile-e e1 c {:> J} #f) + (Push rax) + (compile-e e2 (cons #f c) {:> J} #f) + (compile-op2 p))) + +{:> H1} ;; Op3 Expr Expr Expr CEnv -> Asm +{:> H1} +(define (compile-prim3 p e1 e2 e3 c) + (seq (compile-e e1 c {:> J} #f) + (Push rax) + (compile-e e2 (cons #f c) {:> J} #f) + (Push rax) + (compile-e e3 (cons #f (cons #f c)) {:> J} #f) + (compile-op3 p))) + + +{:> C D0} ;; Expr Expr Expr -> Asm +{:> C D0} +(define (compile-ifzero e1 e2 e3) + (let ((l1 (gensym 'ifz)) + (l2 (gensym 'ifz))) + (seq (compile-e e1) + (Cmp rax 0) + (Jne l1) + (compile-e e2) + (Jmp l2) + (Label l1) + (compile-e e3) + (Label l2)))) + +{:> D0 F} ;; Expr Expr Expr -> Asm +{:> F J} ;; Expr Expr Expr CEnv -> Asm +{:> J} ;; Expr Expr Expr CEnv Boolean -> Asm +{:> D0} +(define (compile-if e1 e2 e3 {:> F} c {:> J} t?) + (let ((l1 (gensym 'if)) + (l2 (gensym 'if))) + (seq (compile-e e1 {:> F} c {:> J} #f) + (Cmp rax (value->bits #f)) + (Je l1) + (compile-e e2 {:> F} c {:> J} t?) + (Jmp l2) + (Label l1) + (compile-e e3 {:> F} c {:> J} t?) + (Label l2)))) + +{:> E0 F} ;; Expr Expr -> Asm +{:> F J} ;; Expr Expr CEnv -> Asm +{:> J} ;; Expr Expr CEnv Boolean -> Asm +{:> E0} +(define (compile-begin e1 e2 {:> F} c {:> J} t?) + (seq (compile-e e1 {:> F} c {:> J} #f) + (compile-e e2 {:> F} c {:> J} t?))) + +{:> F J} ;; Id Expr Expr CEnv -> Asm +{:> J} ;; Id Expr Expr CEnv Boolean -> Asm +{:> F} +(define (compile-let x e1 e2 c {:> J} t?) + (seq (compile-e e1 c {:> J} #f) + (Push rax) + (compile-e e2 (cons x c) {:> J} t?) + (Add rsp 8))) + +{:> J} ;; Id [Listof Expr] CEnv Boolean -> Asm +{:> J} +(define (compile-app f es c t?) + (if t? + (compile-app-tail f es c) + (compile-app-nontail f es c))) + +{:> J} ;; Id [Listof Expr] CEnv -> Asm +{:> J} +(define (compile-app-tail f es c) + (seq (compile-es es c) + (move-args (length es) (length c)) + (Add rsp (* 8 (length c))) + (Jmp (symbol->label f)))) + +{:> J} ;; Integer Integer -> Asm +{:> J} +(define (move-args i off) + (cond [(zero? off) (seq)] + [(zero? i) (seq)] + [else + (seq (Mov r8 (Offset rsp (* 8 (sub1 i)))) + (Mov (Offset rsp (* 8 (+ off (sub1 i)))) r8) + (move-args (sub1 i) off))])) + +{:> I} ;; Id [Listof Expr] CEnv -> Asm +{:> I} ;; The return address is placed above the arguments, so callee pops +{:> I} ;; arguments and return address is next frame +{:> I J} +(define (compile-app f es c) + (let ((r (gensym 'ret))) + (seq (Lea rax r) + (Push rax) + (compile-es es (cons #f c)) + (Jmp (symbol->label f)) + (Label r)))) + +{:> Z:FIXME} ;; eats previous paren if we do ({:> I J} compile-app {:> J} compile-app-nontail ...) +{:> J} +(define (compile-app-nontail f es c) + (let ((r (gensym 'ret))) + (seq (Lea rax r) + (Push rax) + (compile-es es (cons #f c)) + (Jmp (symbol->label f)) + (Label r)))) + +{:> I} ;; [Listof Expr] CEnv -> Asm +{:> I} +(define (compile-es es c) + (match es + ['() '()] + [(cons e es) + (seq (compile-e e c {:> J} #f) + (Push rax) + (compile-es es (cons #f c)))])) + +{:> K} ;; Expr [Listof Pat] [Listof Expr] CEnv Bool -> Asm +{:> K} +(define (compile-match e ps es c t?) + (let ((done (gensym))) + (seq (compile-e e c #f) + (Push rax) ; save away to be restored by each clause + (compile-match-clauses ps es (cons #f c) done t?) + (Jmp 'err) + (Label done) + (Add rsp 8)))) {:> K} ; pop the saved value being matched + +{:> K} ;; [Listof Pat] [Listof Expr] CEnv Symbol Bool -> Asm +{:> K} +(define (compile-match-clauses ps es c done t?) + (match* (ps es) + [('() '()) (seq)] + [((cons p ps) (cons e es)) + (seq (compile-match-clause p e c done t?) + (compile-match-clauses ps es c done t?))])) + +{:> K} ;; Pat Expr CEnv Symbol Bool -> Asm +{:> K} +(define (compile-match-clause p e c done t?) + (let ((next (gensym))) + (match (compile-pattern p '() next) + [(list i cm) + (seq (Mov rax (Offset rsp 0)) ; restore value being matched + i + (compile-e e (append cm c) t?) + (Add rsp (* 8 (length cm))) + (Jmp done) + (Label next))]))) + +{:> K} ;; Pat CEnv Symbol -> (list Asm CEnv) +{:> K} +(define (compile-pattern p cm next) + (match p + [(Var '_) + (list (seq) cm)] + [(Var x) + (list (seq (Push rax)) (cons x cm))] + [(Lit l) + (let ((ok (gensym))) + (list (seq (Cmp rax (value->bits l)) + (Je ok) + (Add rsp (* 8 (length cm))) + (Jmp next) + (Label ok)) + cm))] + [(Conj p1 p2) + (match (compile-pattern p1 (cons #f cm) next) + [(list i1 cm1) + (match (compile-pattern p2 cm1 next) + [(list i2 cm2) + (list + (seq (Push rax) + i1 + (Mov rax (Offset rsp (* 8 (- (sub1 (length cm1)) (length cm))))) + i2) + cm2)])])] + [(Box p) + (match (compile-pattern p cm next) + [(list i1 cm1) + (let ((ok (gensym))) + (list + (seq (Mov r8 rax) + (And r8 ptr-mask) + (Cmp r8 type-box) + (Je ok) + (Add rsp (* 8 (length cm))) ; haven't pushed anything yet + (Jmp next) + (Label ok) + (Xor rax type-box) + (Mov rax (Offset rax 0)) + i1) + cm1))])] + [(Cons p1 p2) + (match (compile-pattern p1 (cons #f cm) next) + [(list i1 cm1) + (match (compile-pattern p2 cm1 next) + [(list i2 cm2) + (let ((ok (gensym))) + (list + (seq (Mov r8 rax) + (And r8 ptr-mask) + (Cmp r8 type-cons) + (Je ok) + (Add rsp (* 8 (length cm))) ; haven't pushed anything yet + (Jmp next) + (Label ok) + (Xor rax type-cons) + (Mov r8 (Offset rax 0)) + (Push r8) ; push cdr + (Mov rax (Offset rax 8)) ; mov rax car + i1 + (Mov rax (Offset rsp (* 8 (- (sub1 (length cm1)) (length cm))))) + i2) + cm2))])])])) + +{:> F} ;; Id CEnv -> Integer +{:> F} +(define (lookup x cenv) + (match cenv + ['() (error "undefined variable:" x)] + [(cons y rest) + (match (eq? x y) + [#t 0] + [#f (+ 8 (lookup x rest))])])) diff --git a/ziggy/src/interp-io.rkt b/ziggy/src/interp-io.rkt new file mode 100644 index 00000000..7e3340fc --- /dev/null +++ b/ziggy/src/interp-io.rkt @@ -0,0 +1,15 @@ +#lang crook +{:= E0 E1 F H0 H1 I J K} +(provide interp/io) +(require "interp.rkt") + +{:> E0 I} ;; String Expr -> (Cons Value String) +{:> I} ;; String Prog -> (Cons Value String) +{:> E0 I} ;; Interpret e with given string as input, +{:> I} ;; Interpret p with given string as input, +;; return value and collected output as string +(define (interp/io {:> E0 I} e {:> I} p input) + (parameterize ((current-output-port (open-output-string)) + (current-input-port (open-input-string input))) + (cons (interp {:> E0 I} e {:> I} p) + (get-output-string (current-output-port))))) diff --git a/ziggy/src/interp-prim.rkt b/ziggy/src/interp-prim.rkt new file mode 100644 index 00000000..84e85c47 --- /dev/null +++ b/ziggy/src/interp-prim.rkt @@ -0,0 +1,110 @@ +#lang crook +{:= B C D0 D0.A D1 E0 E1 F H0 H1 I J K} +(provide {:> E0} interp-prim0 {:> B} interp-prim1 {:> F} interp-prim2 {:> H1} interp-prim3) + +{:> E0} ;; Op0 -> Value +{:> E0} +(define (interp-prim0 op) + (match op + ['read-byte (read-byte)] + ['peek-byte (peek-byte)] + ['void (void)])) + +{:> B D0} ;; Op1 Integer -> Integer +{:> B D0} +(define (interp-prim1 op i) + (match op + ['add1 (add1 i)] + ['sub1 (sub1 i)])) + +{:> D0 E1} ;; Op1 Value -> Value +{:> D0 E1} +(define (interp-prim1 op v) + (match op + ['add1 (add1 v)] + ['sub1 (sub1 v)] + ['zero? (zero? v)] + {:> D1} + ['char? (char? v)] + {:> D1} + ['integer->char (integer->char v)] + {:> D1} + ['char->integer (char->integer v)] + {:> E0} + ['write-byte (write-byte v)] + {:> E0} + ['eof-object? (eof-object? v)])) + +{:> E1} ;; Op1 Value -> Answer +{:> E1} +(define (interp-prim1 op v) + (match (list op v) + [(list 'add1 (? integer?)) (add1 v)] + [(list 'sub1 (? integer?)) (sub1 v)] + [(list 'zero? (? integer?)) (zero? v)] + [(list 'char? v) (char? v)] + [(list 'integer->char (? codepoint?)) (integer->char v)] + [(list 'char->integer (? char?)) (char->integer v)] + [(list 'write-byte (? byte?)) (write-byte v)] + [(list 'eof-object? v) (eof-object? v)] + {:> H0} [(list 'box v) (box v)] + {:> H0} [(list 'unbox (? box?)) (unbox v)] + {:> H0} [(list 'car (? pair?)) (car v)] + {:> H0} [(list 'cdr (? pair?)) (cdr v)] + {:> H0} [(list 'empty? v) (empty? v)] + {:> H0} [(list 'cons? v) (cons? v)] + {:> H1} [(list 'box? v) (box? v)] + {:> H1} [(list 'vector? v) (vector? v)] + {:> H1} [(list 'vector-length (? vector?)) (vector-length v)] + {:> H1} [(list 'string? v) (string? v)] + {:> H1} [(list 'string-length (? string?)) (string-length v)] + [_ 'err])) + +{:> F} ;; Op2 Value Value -> Answer +{:> F} +(define (interp-prim2 op v1 v2) + (match (list op v1 v2) + [(list '+ (? integer?) (? integer?)) (+ v1 v2)] + [(list '- (? integer?) (? integer?)) (- v1 v2)] + [(list '< (? integer?) (? integer?)) (< v1 v2)] + [(list '= (? integer?) (? integer?)) (= v1 v2)] + {:> H0} [(list 'eq? v1 v2) (eq? v1 v2)] + {:> H0} [(list 'cons v1 v2) (cons v1 v2)] + {:> H1} + [(list 'make-vector (? integer?) _) + (if (<= 0 v1) + (make-vector v1 v2) + 'err)] + {:> H1} + [(list 'vector-ref (? vector?) (? integer?)) + (if (<= 0 v2 (sub1 (vector-length v1))) + (vector-ref v1 v2) + 'err)] + {:> H1} + [(list 'make-string (? integer?) (? char?)) + (if (<= 0 v1) + (make-string v1 v2) + 'err)] + {:> H1} + [(list 'string-ref (? string?) (? integer?)) + (if (<= 0 v2 (sub1 (string-length v1))) + (string-ref v1 v2) + 'err)] + [_ 'err])) + +{:> H1} ;; Op3 Value Value Value -> Answer +{:> H1} +(define (interp-prim3 p v1 v2 v3) + (match (list p v1 v2 v3) + [(list 'vector-set! (? vector?) (? integer?) _) + (if (<= 0 v2 (sub1 (vector-length v1))) + (vector-set! v1 v2 v3) + 'err)] + [_ 'err])) + +{:> E1} ;; Any -> Boolean +{:> E1} +(define (codepoint? v) + (and (integer? v) + (or (<= 0 v 55295) + (<= 57344 v 1114111)))) diff --git a/ziggy/src/interp-stdin.rkt b/ziggy/src/interp-stdin.rkt new file mode 100644 index 00000000..d5eb5dd0 --- /dev/null +++ b/ziggy/src/interp-stdin.rkt @@ -0,0 +1,13 @@ +#lang crook +{:= A B C D0 D0.A D1 E0 E1 F H0 H1 I J K} +(provide main) +(require "parse.rkt") +(require "interp.rkt") +{:> I} (require "read-all.rkt") + +;; -> Void +;; Parse and interpret contents of stdin, +;; print result on stdout +(define (main) + (read-line) ; ignore #lang racket line + (println (interp {:> A I} (parse (read)) {:> I} (apply parse (read-all))))) diff --git a/ziggy/src/interp.rkt b/ziggy/src/interp.rkt new file mode 100644 index 00000000..d28e7cef --- /dev/null +++ b/ziggy/src/interp.rkt @@ -0,0 +1,204 @@ +#lang crook +{:= A B C D0 D0.A D1 E0 E1 F H0 H1 I J K} +(provide interp) +{:> F} (provide interp-env) +{:> K} (provide interp-match-pat) +(require "ast.rkt") +{:> B} (require "interp-prim.rkt") + +{:> D0} ;; type Value = +{:> D0} ;; | Integer +{:> D0} ;; | Boolean +{:> D1} ;; | Character +{:> E0} ;; | Eof +{:> E0} ;; | Void +{:> H0} ;; | '() +{:> H0} ;; | (cons Value Value) +{:> H0} ;; | (box Value) +{:> H1} ;; | (string Character ...) +{:> H1} ;; | (vector Value ...) + +{:> F} ;; type Env = (Listof (List Id Value)) + +{:> A D0} ;; Expr -> Integer +{:> D0 E1} ;; Expr -> Value +{:> E1 I} ;; Expr -> Answer +{:> I} ;; Prog -> Answer +(define (interp {:> A I} e {:> I} p) + {:> A F} + (match e + {:> A D0} [(Lit i) i] + {:> D0} [(Lit d) d] + {:> E0} [(Eof) eof] + {:> E0} [(Prim0 p) + (interp-prim0 p)] + {:> B E1} [(Prim1 p e) + (interp-prim1 p (interp e))] + {:> E1} [(Prim1 p e) + (match (interp e) + ['err 'err] + [v (interp-prim1 p v)])] + {:> C D0} [(IfZero e1 e2 e3) + (if (zero? (interp e1)) + (interp e2) + (interp e3))] + {:> D0 E1} [(If e1 e2 e3) + (if (interp e1) + (interp e2) + (interp e3))] + {:> E1} [(If e1 e2 e3) + (match (interp e1) + ['err 'err] + [v (if v + (interp e2) + (interp e3))])] + {:> E0 E1} [(Begin e1 e2) + (begin (interp e1) + (interp e2))] + {:> E1} [(Begin e1 e2) + (match (interp e1) + ['err 'err] + [v (interp e2)])]) + {:> F I} + (interp-env e '()) + {:> I} + (match p + [(Prog ds e) + (interp-env e '() ds)])) + +{:> F} ;; Expr Env -> Answer +{:> F} +(define (interp-env e r {:> I} ds) + (match e + [(Lit d) d] + [(Eof) eof] + {:> H0} + [(Empty) '()] + [(Var x) (lookup r x)] + [(Prim0 p) (interp-prim0 p)] + [(Prim1 p e) + (match (interp-env e r {:> I} ds) + ['err 'err] + [v (interp-prim1 p v)])] + [(Prim2 p e1 e2) + (match (interp-env e1 r {:> I} ds) + ['err 'err] + [v1 (match (interp-env e2 r {:> I} ds) + ['err 'err] + [v2 (interp-prim2 p v1 v2)])])] + {:> H1} + [(Prim3 p e1 e2 e3) + (match (interp-env e1 r {:> I} ds) + ['err 'err] + [v1 (match (interp-env e2 r {:> I} ds) + ['err 'err] + [v2 (match (interp-env e3 r {:> I} ds) + ['err 'err] + [v3 (interp-prim3 p v1 v2 v3)])])])] + [(If e0 e1 e2) + (match (interp-env e0 r {:> I} ds) + ['err 'err] + [v + (if v + (interp-env e1 r {:> I} ds) + (interp-env e2 r {:> I} ds))])] + [(Begin e1 e2) + (match (interp-env e1 r {:> I} ds) + ['err 'err] + [v (interp-env e2 r {:> I} ds)])] + [(Let x e1 e2) + (match (interp-env e1 r {:> I} ds) + ['err 'err] + [v (interp-env e2 (ext r x v) {:> I} ds)])] + {:> I} + [(App f es) + (match (interp-env* es r ds) + ['err 'err] + [vs + (match (defns-lookup ds f) + [(Defn f xs e) + ; check arity matches + (if (= (length xs) (length vs)) + (interp-env e (zip xs vs) ds) + 'err)])])] + + {:> K} + [(Match e ps es) + (match (interp-env e r ds) + ['err 'err] + [v + (interp-match v ps es r ds)])])) + +{:> I} ;; (Listof Expr) REnv Defns -> (Listof Value) | 'err +{:> I} +(define (interp-env* es r ds) + (match es + ['() '()] + [(cons e es) + (match (interp-env e r ds) + ['err 'err] + [v (match (interp-env* es r ds) + ['err 'err] + [vs (cons v vs)])])])) + +{:> K} ;; Value [Listof Pat] [Listof Expr] Env Defns -> Answer +{:> K} +(define (interp-match v ps es r ds) + (match* (ps es) + [('() '()) 'err] + [((cons p ps) (cons e es)) + (match (interp-match-pat p v r) + [#f (interp-match v ps es r ds)] + [r (interp-env e r ds)])])) + +{:> K} ;; Pat Value Env -> [Maybe Env] +{:> K} +(define (interp-match-pat p v r) + (match p + [(Var '_) r] + [(Var x) (ext r x v)] + [(Lit l) (and (eqv? l v) r)] + [(Box p) + (match v + [(box v) + (interp-match-pat p v r)] + [_ #f])] + [(Cons p1 p2) + (match v + [(cons v1 v2) + (match (interp-match-pat p1 v1 r) + [#f #f] + [r1 (interp-match-pat p2 v2 r1)])] + [_ #f])] + [(Conj p1 p2) + (match (interp-match-pat p1 v r) + [#f #f] + [r1 (interp-match-pat p2 v r1)])])) + +{:> I} ;; Defns Symbol -> Defn +{:> I} +(define (defns-lookup ds f) + (findf (match-lambda [(Defn g _ _) (eq? f g)]) + ds)) + +{:> I} +(define (zip xs ys) + (match* (xs ys) + [('() '()) '()] + [((cons x xs) (cons y ys)) + (cons (list x y) + (zip xs ys))])) + +{:> F} ;; Env Id -> Value +{:> F} +(define (lookup r x) + (match r + [(cons (list y val) r) + (if (symbol=? x y) + val + (lookup r x))])) + +{:> F} ;; Env Id Value -> Env +{:> F} +(define (ext r x v) + (cons (list x v) r)) diff --git a/ziggy/src/main.rkt b/ziggy/src/main.rkt new file mode 100644 index 00000000..f819fc92 --- /dev/null +++ b/ziggy/src/main.rkt @@ -0,0 +1,13 @@ +#lang crook +{:= A B C D0 D1 E0 E1 F H0 H1 I J} +(require "ast.rkt") +(require "parse.rkt") +(require "interp.rkt") +(require "compile.rkt") +(require "run.rkt") +(provide (all-from-out "ast.rkt")) +(provide (all-from-out "parse.rkt")) +(provide (all-from-out "interp.rkt")) +(provide (all-from-out "compile.rkt")) +(provide (all-from-out "run.rkt")) + diff --git a/ziggy/src/parse.rkt b/ziggy/src/parse.rkt new file mode 100644 index 00000000..d337873f --- /dev/null +++ b/ziggy/src/parse.rkt @@ -0,0 +1,145 @@ +#lang crook +{:= A B C D0 D0.A D1 E0 E1 F H0 H1 I J K} +(provide parse {:> I} parse-e {:> I} parse-define) +(require "ast.rkt") + +{:> A I} ;; S-Expr -> Expr +{:> A I} +(define (parse s) + (match s + {:> E0} + ['eof (Eof)] + {:> A D0} + [(? exact-integer?) (Lit s)] + {:> D0} + [(? datum?) (Lit s)] + {:> F} + [(? symbol?) (Var s)] + {:> H0} + [(list 'quote (list)) (Empty)] + {:> E0} + [(list (? op0? o)) (Prim0 o)] + {:> B} + [(list (? op1? o) e) (Prim1 o (parse e))] + {:> F} + [(list (? op2? o) e1 e2) (Prim2 o (parse e1) (parse e2))] + {:> H1} + [(list (? op3? o) e1 e2 e3) (Prim3 o (parse e1) (parse e2) (parse e3))] + {:> E0} + [(list 'begin e1 e2) (Begin (parse e1) (parse e2))] + {:> C D0} + [(list 'if (list 'zero? e1) e2 e3) + (IfZero (parse e1) (parse e2) (parse e3))] + {:> D0} + [(list 'if e1 e2 e3) + (If (parse e1) (parse e2) (parse e3))] + {:> F} + [(list 'let (list (list (? symbol? x) e1)) e2) + (Let x (parse e1) (parse e2))] + [_ (error "Parse error")])) + +{:> I} ;; S-Expr ... -> Prog +{:> I} +(define (parse . s) + (match s + [(cons (and (cons 'define _) d) s) + (match (apply parse s) + [(Prog ds e) + (Prog (cons (parse-define d) ds) e)])] + [(cons e '()) (Prog '() (parse-e e))] + [_ (error "program parse error")])) + +{:> I} ;; S-Expr -> Defn +{:> I} +(define (parse-define s) + (match s + [(list 'define (list-rest (? symbol? f) xs) e) + (if (andmap symbol? xs) + (Defn f xs (parse-e e)) + (error "parse definition error"))] + [_ (error "Parse defn error" s)])) + +{:> I} ;; S-Expr -> Expr +{:> I} +(define (parse-e s) + (match s + [(? datum?) (Lit s)] + ['eof (Eof)] + [(? symbol?) (Var s)] + [(list 'quote (list)) (Empty)] + [(list (? op0? p0)) (Prim0 p0)] + [(list (? op1? p1) e) (Prim1 p1 (parse-e e))] + [(list (? op2? p2) e1 e2) (Prim2 p2 (parse-e e1) (parse-e e2))] + [(list (? op3? p3) e1 e2 e3) + (Prim3 p3 (parse-e e1) (parse-e e2) (parse-e e3))] + [(list 'begin e1 e2) + (Begin (parse-e e1) (parse-e e2))] + [(list 'if e1 e2 e3) + (If (parse-e e1) (parse-e e2) (parse-e e3))] + [(list 'let (list (list (? symbol? x) e1)) e2) + (Let x (parse-e e1) (parse-e e2))] + {:> K} + [(cons 'match (cons e ms)) + (parse-match (parse-e e) ms)] + [(cons (? symbol? f) es) + (App f (map parse-e es))] + [_ (error "Parse error" s)])) + +{:> K} ;; Expr [Listof S-Expr] +{:> K} +(define (parse-match e ms) + (match ms + ['() (Match e '() '())] + [(cons (list p r) ms) + (match (parse-match e ms) + [(Match e ps es) + (Match e + (cons (parse-pat p) ps) + (cons (parse-e r) es))])] + [_ (error "Parse match error" e ms)])) + +{:> K} ;; S-Expr -> Pat +{:> K} +(define (parse-pat p) + (match p + [(? datum?) (Lit p)] + [(? symbol?) (Var p)] + [(list 'quote (list)) (Lit '())] + [(list 'box p) + (Box (parse-pat p))] + [(list 'cons p1 p2) + (Cons (parse-pat p1) (parse-pat p2))] + [(list 'and p1 p2) + (Conj (parse-pat p1) (parse-pat p2))])) + + +{:> D0} ;; Any -> Boolean +{:> D0} +(define (datum? x) + (or (exact-integer? x) + (boolean? x) + {:> D1} + (char? x) + {:> H1} + (string? x))) + +{:> E0} ;; Any -> Boolean +{:> E0} +(define (op0? x) + (memq x '(read-byte peek-byte void))) + +{:> B} +(define (op1? x) + (memq x '(add1 sub1 {:> D0} zero? {:> D1} char? {:> D1} integer->char {:> D1} char->integer + {:> E0} write-byte {:> E0} eof-object? + {:> H0} box {:> H0} unbox {:> H0} empty? {:> H0} cons? {:> H0} box? {:> H0} car {:> H0} cdr + {:> H1} vector? {:> H1} vector-length {:> H1} string? {:> H1} string-length))) + +{:> F} +(define (op2? x) + (memq x '(+ - < = {:> H0} eq? {:> H0} cons + {:> H1} make-vector {:> H1} vector-ref {:> H1} make-string {:> H1} string-ref))) + +{:> H1} +(define (op3? x) + (memq x '(vector-set!))) diff --git a/langs/iniquity/read-all.rkt b/ziggy/src/read-all.rkt similarity index 87% rename from langs/iniquity/read-all.rkt rename to ziggy/src/read-all.rkt index 8a3289a5..a0a6fe31 100644 --- a/langs/iniquity/read-all.rkt +++ b/ziggy/src/read-all.rkt @@ -1,4 +1,5 @@ -#lang racket +#lang crook +{:= I J K} (provide read-all) ;; read all s-expression until eof (define (read-all) diff --git a/ziggy/src/run-stdin.rkt b/ziggy/src/run-stdin.rkt new file mode 100644 index 00000000..12f97ba9 --- /dev/null +++ b/ziggy/src/run-stdin.rkt @@ -0,0 +1,12 @@ +#lang crook +{:= A B C D0 D1 E0 E1 F H0 H1 J K} +(provide main) +(require "parse.rkt") +(require "compile.rkt") +(require "run.rkt") + +;; -> Void +;; Compile contents of stdin and use asm-interp to run +(define (main) + (read-line) ; ignore #lang racket line + (run (compile (parse (read))))) diff --git a/ziggy/src/run.rkt b/ziggy/src/run.rkt new file mode 100644 index 00000000..88f38e1f --- /dev/null +++ b/ziggy/src/run.rkt @@ -0,0 +1,33 @@ +#lang crook +{:= A B C D0 D0.A D1 E0 E1 F H0 H1 I J K} +(require a86/interp) +{:> D0} (require "types.rkt") +{:> E0} (require "build-runtime.rkt") +(provide run {:> E0} run/io) + +{:> A D0} ;; Asm -> Integer +{:> D0 E1} ;; Asm -> Value +{:> E1} ;; Asm -> Answer +(define (run is) + {:> A D0} + (asm-interp is) + {:> D0 E0} + (bits->value (asm-interp is)) + {:> E0} + (parameterize ((current-objs (list (path->string runtime-path)))) + {:> E0 E1} + (bits->value (asm-interp is)) + {:> E1} + (match (asm-interp is) + ['err 'err] + [b (bits->value b)]))) + +{:> E0} ;; Asm String -> (cons Answer String) +{:> E0} +(define (run/io is in) + (parameterize ((current-objs (list (path->string runtime-path)))) + (match (asm-interp/io is in) + {:> E1} + [(cons 'err out) (cons 'err out)] + [(cons b out) + (cons (bits->value b) out)]))) diff --git a/ziggy/src/test/compile.rkt b/ziggy/src/test/compile.rkt new file mode 100644 index 00000000..4be3ba97 --- /dev/null +++ b/ziggy/src/test/compile.rkt @@ -0,0 +1,16 @@ +#lang crook +{:= A B C D0 D0.A D1 E0 E1 F H0 H1 I J K} +(require "../compile.rkt") +(require "../parse.rkt") +(require "../run.rkt") +(require "test-runner.rkt") + +{:> A I} +(test (λ (e) (run (compile (parse e))))) +{:> I} +(test (λ p (run (compile (apply parse p))))) + +{:> E0 I} +(test/io (λ (in e) (run/io (compile (parse e)) in))) +{:> I} +(test/io (λ (in . p) (run/io (compile (apply parse p)) in))) diff --git a/ziggy/src/test/interp.rkt b/ziggy/src/test/interp.rkt new file mode 100644 index 00000000..e5e6d9b5 --- /dev/null +++ b/ziggy/src/test/interp.rkt @@ -0,0 +1,16 @@ +#lang crook +{:= A B C D0 D0.A D1 E0 E1 F H0 H1 I J K} +(require "../interp.rkt") +{:> E0} (require "../interp-io.rkt") +(require "../parse.rkt") +(require "test-runner.rkt") + +{:> A I} +(test (λ (e) (interp (parse e)))) +{:> I} +(test (λ p (interp (apply parse p)))) + +{:> E0 I} +(test/io (λ (in e) (interp/io (parse e) in))) +{:> I} +(test/io (λ (in . p) (interp/io (apply parse p) in))) diff --git a/ziggy/src/test/test-runner.rkt b/ziggy/src/test/test-runner.rkt new file mode 100644 index 00000000..a1dadde8 --- /dev/null +++ b/ziggy/src/test/test-runner.rkt @@ -0,0 +1,360 @@ +#lang crook +{:= A B C D0 D0.A D1 E0 E1 F H0 H1 I J K} +(provide test {:> E0} test/io) +(require rackunit) + +(define (test run) + {:> A} + (begin ;; Abscond + (check-equal? (run 7) 7) + (check-equal? (run -8) -8)) + + {:> B} + (begin ;; Blackmail + (check-equal? (run '(add1 (add1 7))) 9) + (check-equal? (run '(add1 (sub1 7))) 7)) + + {:> C} + (begin ;; Con + (check-equal? (run '(if (zero? 0) 1 2)) 1) + (check-equal? (run '(if (zero? 1) 1 2)) 2) + (check-equal? (run '(if (zero? -7) 1 2)) 2) + (check-equal? (run '(if (zero? 0) + (if (zero? 1) 1 2) + 7)) + 2) + (check-equal? (run '(if (zero? (if (zero? 0) 1 0)) + (if (zero? 1) 1 2) + 7)) + 7)) + + {:> D0} + (begin ;; Dupe + (check-equal? (run #t) #t) + (check-equal? (run #f) #f) + (check-equal? (run '(if #t 1 2)) 1) + (check-equal? (run '(if #f 1 2)) 2) + (check-equal? (run '(if 0 1 2)) 1) + (check-equal? (run '(if #t 3 4)) 3) + (check-equal? (run '(if #f 3 4)) 4) + (check-equal? (run '(if 0 3 4)) 3) + (check-equal? (run '(zero? 4)) #f) + (check-equal? (run '(zero? 0)) #t)) + + {:> D0.A D0.A} + (begin ;; Dupe+ + (check-equal? (run '(not #t)) #f) + (check-equal? (run '(not #f)) #t) + (check-equal? (run '(not 7)) #f) + (check-equal? (run '(cond [else #t])) #t) + (check-equal? (run '(cond [(not #t) 2] [else 3])) 3) + (check-equal? (run '(cond [(if #t #t #f) 2] [else 3])) 2) + (check-equal? (run '(cond [(zero? 1) 2] [(if (not (zero? (sub1 2))) #t #f) 4] [else 3])) 4) + (check-equal? (run '(cond [#t 1] [else 2])) 1) + (check-equal? (run '(cond [1 1] [else 2])) 1) + (check-equal? (run '(case 2 [else 1])) 1) + (check-equal? (run '(case 2 [() 3] [else 1])) 1) + (check-equal? (run '(case 2 [(2) 3] [else 1])) 3) + (check-equal? (run '(case 4 [(2) 3] [else 1])) 1) + (check-equal? (run '(case 2 [(7 2) 3] [else 1])) 3) + (check-equal? (run '(case 4 [(7 2) 3] [else 1])) 1) + (check-equal? (run '(case 2 [(7 2 #t) 3] [else 1])) 3) + (check-equal? (run '(case 4 [(7 2 #t) 3] [else 1])) 1) + (check-equal? (run '(case #t [(7 2 #t) 3] [else 1])) 3) + (check-equal? (run '(case #f [(7 2 #t) 3] [else 1])) 1)) + + {:> D1} + (begin ;; Dodger + (check-equal? (run #\a) #\a) + (check-equal? (run #\b) #\b) + (check-equal? (run '(char? #\a)) #t) + (check-equal? (run '(char? #t)) #f) + (check-equal? (run '(char? 8)) #f) + (check-equal? (run '(char->integer #\a)) (char->integer #\a)) + (check-equal? (run '(integer->char 955)) #\λ)) + + {:> E0} + (begin ;; Evildoer + (check-equal? (run '(void)) (void)) + (check-equal? (run '(begin 1 2)) 2) + (check-equal? (run '(eof-object? (void))) #f)) + + {:> E1} + (begin ;; Extort + (check-equal? (run '(add1 #f)) 'err) + (check-equal? (run '(sub1 #f)) 'err) + (check-equal? (run '(zero? #f)) 'err) + (check-equal? (run '(char->integer #f)) 'err) + (check-equal? (run '(integer->char #f)) 'err) + (check-equal? (run '(integer->char -1)) 'err) + (check-equal? (run '(write-byte #f)) 'err) + (check-equal? (run '(write-byte -1)) 'err) + (check-equal? (run '(write-byte 256)) 'err) + (check-equal? (run '(begin (integer->char 97) + (integer->char 98))) + #\b)) + + {:> F} + (begin ;; Fraud + (check-equal? (run '(let ((x 7)) x)) 7) + (check-equal? (run '(let ((x 7)) 2)) 2) + (check-equal? (run '(let ((x 7)) (add1 x))) 8) + (check-equal? (run '(let ((x (add1 7))) x)) 8) + (check-equal? (run '(let ((x 7)) (let ((y 2)) x))) 7) + (check-equal? (run '(let ((x 7)) (let ((x 2)) x))) 2) + (check-equal? (run '(let ((x 7)) (let ((x (add1 x))) x))) 8) + + (check-equal? (run '(let ((x 0)) + (if (zero? x) 7 8))) + 7) + (check-equal? (run '(let ((x 1)) + (add1 (if (zero? x) 7 8)))) + 9) + (check-equal? (run '(+ 3 4)) 7) + (check-equal? (run '(- 3 4)) -1) + (check-equal? (run '(+ (+ 2 1) 4)) 7) + (check-equal? (run '(+ (+ 2 1) (+ 2 2))) 7) + (check-equal? (run '(let ((x (+ 1 2))) + (let ((z (- 4 x))) + (+ (+ x x) z)))) + 7) + + (check-equal? (run '(= 5 5)) #t) + (check-equal? (run '(= 4 5)) #f) + (check-equal? (run '(= (add1 4) 5)) #t) + (check-equal? (run '(< 5 5)) #f) + (check-equal? (run '(< 4 5)) #t) + (check-equal? (run '(< (add1 4) 5)) #f)) + + {:> H0} + (begin ;; Hustle + (check-equal? (run ''()) '()) + (check-equal? (run '(empty? '())) #t) + (check-equal? (run '(empty? 3)) #f) + (check-equal? (run '(empty? (cons 1 2))) #f) + (check-equal? (run '(box 1)) (box 1)) + (check-equal? (run '(box -1)) (box -1)) + (check-equal? (run '(cons 1 2)) (cons 1 2)) + (check-equal? (run '(unbox (box 1))) 1) + (check-equal? (run '(car (cons 1 2))) 1) + (check-equal? (run '(cdr (cons 1 2))) 2) + (check-equal? (run '(cons 1 '())) (list 1)) + (check-equal? (run '(let ((x (cons 1 2))) + (begin (cdr x) + (car x)))) + 1) + (check-equal? (run '(let ((x (cons 1 2))) + (let ((y (box 3))) + (unbox y)))) + 3) + (check-equal? (run '(eq? 1 1)) #t) + (check-equal? (run '(eq? 1 2)) #f) + (check-equal? (run '(eq? (cons 1 2) (cons 1 2))) #f) + (check-equal? (run '(let ((x (cons 1 2))) (eq? x x))) #t)) + + {:> H1} + (begin ;; Hoax + (check-equal? (run '(make-vector 0 0)) #()) + (check-equal? (run '(make-vector 1 0)) #(0)) + (check-equal? (run '(make-vector 3 0)) #(0 0 0)) + (check-equal? (run '(make-vector 3 5)) #(5 5 5)) + (check-equal? (run '(vector? (make-vector 0 0))) #t) + (check-equal? (run '(vector? (cons 0 0))) #f) + (check-equal? (run '(vector-ref (make-vector 0 #f) 0)) 'err) + (check-equal? (run '(vector-ref (make-vector 3 5) -1)) 'err) + (check-equal? (run '(vector-ref (make-vector 3 5) 0)) 5) + (check-equal? (run '(vector-ref (make-vector 3 5) 1)) 5) + (check-equal? (run '(vector-ref (make-vector 3 5) 2)) 5) + (check-equal? (run '(vector-ref (make-vector 3 5) 3)) 'err) + (check-equal? (run '(let ((x (make-vector 3 5))) + (begin (vector-set! x 0 4) + x))) + #(4 5 5)) + (check-equal? (run '(let ((x (make-vector 3 5))) + (begin (vector-set! x 1 4) + x))) + #(5 4 5)) + (check-equal? (run '(vector-length (make-vector 3 #f))) 3) + (check-equal? (run '(vector-length (make-vector 0 #f))) 0) + (check-equal? (run '"") "") + (check-equal? (run '"fred") "fred") + (check-equal? (run '"wilma") "wilma") + (check-equal? (run '(make-string 0 #\f)) "") + (check-equal? (run '(make-string 3 #\f)) "fff") + (check-equal? (run '(make-string 3 #\g)) "ggg") + (check-equal? (run '(string-length "")) 0) + (check-equal? (run '(string-length "fred")) 4) + (check-equal? (run '(string-ref "" 0)) 'err) + (check-equal? (run '(string-ref (make-string 0 #\a) 0)) 'err) + (check-equal? (run '(string-ref "fred" 0)) #\f) + (check-equal? (run '(string-ref "fred" 1)) #\r) + (check-equal? (run '(string-ref "fred" 2)) #\e) + (check-equal? (run '(string-ref "fred" 4)) 'err) + (check-equal? (run '(string? "fred")) #t) + (check-equal? (run '(string? (cons 1 2))) #f) + (check-equal? (run '(begin (make-string 3 #\f) + (make-string 3 #\f))) + "fff")) + + {:> I} + (begin ;; Iniquity + (check-equal? (run + '(define (f x) x) + '(f 5)) + 5) + (check-equal? (run + '(define (tri x) + (if (zero? x) + 0 + (+ x (tri (sub1 x))))) + '(tri 9)) + 45) + + (check-equal? (run + '(define (even? x) + (if (zero? x) + #t + (odd? (sub1 x)))) + '(define (odd? x) + (if (zero? x) + #f + (even? (sub1 x)))) + '(even? 101)) + #f) + + (check-equal? (run + '(define (map-add1 xs) + (if (empty? xs) + '() + (cons (add1 (car xs)) + (map-add1 (cdr xs))))) + '(map-add1 (cons 1 (cons 2 (cons 3 '()))))) + '(2 3 4)) + (check-equal? (run '(define (f x y) y) + '(f 1 (add1 #f))) + 'err)) + + {:> K} + (begin ;; Knock + (check-equal? (run '(match 1)) 'err) + (check-equal? (run '(match 1 [1 2])) + 2) + (check-equal? (run '(match 1 [2 1] [1 2])) + 2) + (check-equal? (run '(match 1 [2 1] [1 2] [0 3])) + 2) + (check-equal? (run '(match 1 [2 1] [0 3])) + 'err) + (check-equal? (run '(match 1 [_ 2] [_ 3])) + 2) + (check-equal? (run '(match 1 [x 2] [_ 3])) + 2) + (check-equal? (run '(match 1 [x x] [_ 3])) + 1) + (check-equal? (run '(match (cons 1 2) [x x] [_ 3])) + (cons 1 2)) + (check-equal? (run '(match (cons 1 2) [(cons x y) x] [_ 3])) + 1) + (check-equal? (run '(match (cons 1 2) [(cons x 2) x] [_ 3])) + 1) + (check-equal? (run '(match (cons 1 2) [(cons 3 2) 0] [_ 3])) + 3) + (check-equal? (run '(match 1 [(cons x y) x] [_ 3])) + 3) + (check-equal? (run '(match (cons 1 2) [(cons 1 3) 0] [(cons 1 y) y] [_ 3])) + 2) + (check-equal? (run '(match (box 1) [(box 1) 0] [_ 1])) + 0) + (check-equal? (run '(match (box 1) [(box 2) 0] [_ 1])) + 1) + (check-equal? (run '(match (box 1) [(box x) x] [_ 2])) + 1))) + +{:> E0} +(define (test/io run) + (begin ;; Evildoer + (check-equal? (run "" 7) (cons 7 "")) + (check-equal? (run "" '(write-byte 97)) (cons (void) "a")) + (check-equal? (run "a" '(read-byte)) (cons 97 "")) + (check-equal? (run "b" '(begin (write-byte 97) (read-byte))) + (cons 98 "a")) + (check-equal? (run "" '(read-byte)) (cons eof "")) + (check-equal? (run "" '(eof-object? (read-byte))) (cons #t "")) + (check-equal? (run "a" '(eof-object? (read-byte))) (cons #f "")) + (check-equal? (run "" '(begin (write-byte 97) (write-byte 98))) + (cons (void) "ab")) + + (check-equal? (run "ab" '(peek-byte)) (cons 97 "")) + (check-equal? (run "ab" '(begin (peek-byte) (read-byte))) (cons 97 "")) + (check-equal? (run "†" '(read-byte)) (cons 226 "")) + (check-equal? (run "†" '(peek-byte)) (cons 226 ""))) + + {:> E1} + (begin ;; Extort + (check-equal? (run "" '(write-byte #t)) (cons 'err ""))) + + {:> F} + (begin ;; Fraud + (check-equal? (run "" '(let ((x 97)) (write-byte x))) (cons (void) "a")) + (check-equal? (run "" + '(let ((x 97)) + (begin (write-byte x) + x))) + (cons 97 "a")) + (check-equal? (run "b" '(let ((x 97)) (begin (read-byte) x))) + (cons 97 "")) + (check-equal? (run "b" '(let ((x 97)) (begin (peek-byte) x))) + (cons 97 ""))) + + {:> I} + (begin ;; Iniquity + (check-equal? (run "" + '(define (print-alphabet i) + (if (zero? i) + (void) + (begin (write-byte (- 123 i)) + (print-alphabet (sub1 i))))) + '(print-alphabet 26)) + (cons (void) "abcdefghijklmnopqrstuvwxyz")) + + (check-equal? (run "" + '(define (f x) + (write-byte x)) + '(f 97)) + (cons (void) "a")) + (check-equal? (run "" + '(define (f x y) + (write-byte x)) + '(f 97 98)) + (cons (void) "a")) + (check-equal? (run "" + '(define (f x) + (let ((y x)) + (write-byte y))) + '(f 97)) + (cons (void) "a")) + (check-equal? (run "" + '(define (f x y) + (let ((y x)) + (write-byte y))) + '(f 97 98)) + (cons (void) "a")) + (check-equal? (run "" + '(define (f x) + (write-byte x)) + '(let ((z 97)) + (f z))) + (cons (void) "a")) + (check-equal? (run "" + '(define (f x y) + (write-byte x)) + '(let ((z 97)) + (f z 98))) + (cons (void) "a"))) + + {:> K} + (begin ;; Knock + (check-equal? (run "" + '(match (write-byte 97) + [_ 1])) + (cons 1 "a")))) diff --git a/ziggy/src/types.rkt b/ziggy/src/types.rkt new file mode 100644 index 00000000..35b97c3b --- /dev/null +++ b/ziggy/src/types.rkt @@ -0,0 +1,112 @@ +#lang crook +{:= D0 D0.A D1 E0 E1 F H0 H1 I J K} +(provide (all-defined-out)) +{:> H0} (require ffi/unsafe) + +{:> H0} (define imm-shift 3) +{:> H0} (define imm-mask #b111) +{:> H0} (define ptr-mask #b111) +{:> H0} (define type-box #b001) +{:> H0} (define type-cons #b010) +{:> H1} (define type-vect #b011) +{:> H1} (define type-str #b100) +(define int-shift {:> D0 H0} 1 {:> H0} (+ 1 imm-shift)) +(define mask-int {:> D0 H0} #b1 {:> H0} #b1111) +{:> D1} +(define char-shift {:> D1 H0} 2 {:> H0} (+ 2 imm-shift)) +(define type-int {:> D0 H0} #b0 {:> H0} #b0000) +{:> D1} +(define type-char {:> D0 H0} #b01 {:> H0} #b01000) +{:> D1} +(define mask-char {:> D0 H0} #b11 {:> H0} #b11111) + +(define (bits->value b) + (cond [(= b (value->bits #t)) #t] + [(= b (value->bits #f)) #f] + {:> E0} + [(= b (value->bits eof)) eof] + {:> E0} + [(= b (value->bits (void))) (void)] + {:> H0} + [(= b (value->bits '())) '()] + [(int-bits? b) + (arithmetic-shift b (- int-shift))] + {:> D1} + [(char-bits? b) + (integer->char (arithmetic-shift b (- char-shift)))] + {:> H0} + [(box-bits? b) + (box (bits->value (heap-ref b)))] + {:> H0} + [(cons-bits? b) + (cons (bits->value (heap-ref (+ b 8))) + (bits->value (heap-ref b)))] + {:> H1} + [(vect-bits? b) + (if (zero? (untag b)) + (vector) + (build-vector (heap-ref b) + (lambda (j) + (bits->value (heap-ref (+ b (* 8 (add1 j))))))))] + {:> H1} + [(str-bits? b) + (if (zero? (untag b)) + (string) + (build-string (heap-ref b) + (lambda (j) + (char-ref (+ b 8) j))))] + [else (error "invalid bits")])) + +(define (value->bits v) + (cond [(eq? v #t) {:> D0 H0} #b011 {:> H0} #b00011000] + [(eq? v #f) {:> D0 H0} #b111 {:> H0} #b00111000] + [(integer? v) (arithmetic-shift v int-shift)] + {:> E0} [(eof-object? v) {:> E0 H0} #b1011 {:> H0} #b01011000] + {:> E0} [(void? v) {:> E0 H0} #b1111 {:> H0} #b01111000] + {:> H0} [(empty? v) #b10011000] + {:> D1} + [(char? v) + (bitwise-ior type-char + (arithmetic-shift (char->integer v) char-shift))] + {:> H0} + [else (error "not an immediate value" v)])) + +(define (int-bits? v) + (= type-int (bitwise-and v mask-int))) + +{:> D1} +(define (char-bits? v) + (= type-char (bitwise-and v mask-char))) + +{:> H0} +(define (imm-bits? v) + (zero? (bitwise-and v imm-mask))) + +{:> H0} +(define (cons-bits? v) + (= type-cons (bitwise-and v imm-mask))) + +{:> H0} +(define (box-bits? v) + (= type-box (bitwise-and v imm-mask))) + +{:> H1} +(define (vect-bits? v) + (= type-vect (bitwise-and v imm-mask))) + +{:> H1} +(define (str-bits? v) + (= type-str (bitwise-and v imm-mask))) + +{:> H0} +(define (untag i) + (arithmetic-shift (arithmetic-shift i (- (integer-length ptr-mask))) + (integer-length ptr-mask))) + +{:> H0} +(define (heap-ref i) + (ptr-ref (cast (untag i) _int64 _pointer) _int64)) + +{:> H1} +(define (char-ref i j) + (integer->char (ptr-ref (cast (untag i) _int64 _pointer) _uint32 j)))