From 07d34c0cd87c61ebe120fac198218c89c242b3e8 Mon Sep 17 00:00:00 2001 From: jmug Date: Fri, 24 Jan 2025 20:53:24 -0800 Subject: [PATCH] Modified hw3 to newer version Signed-off-by: jmug --- hw3/.ocamlformat | 2 + hw3/.ocamlinit | 1 + hw3/Makefile | 38 ++++++++------ hw3/README | 76 --------------------------- hw3/README.md | 66 ++++++++++++++++++++++++ hw3/{ => bin}/backend.ml | 59 ++++++++++++++++----- hw3/bin/cinterop.c | 64 +++++++++++++++++++++++ hw3/{ => bin}/driver.ml | 43 ++++++++-------- hw3/bin/dune | 24 +++++++++ hw3/{ => bin}/main.ml | 11 ++-- hw3/bin/timeout3 | 91 +++++++++++++++++++++++++++++++++ hw3/cinterop.c | 32 ------------ hw3/dune-project | 3 ++ hw3/hw3.opam | 0 hw3/lib/ll/dune | 7 +++ hw3/lib/ll/ll-original.ml | 81 +++++++++++++++++++++++++++++ hw3/{ => lib}/ll/ll.ml | 6 ++- hw3/{ => lib}/ll/llinterp.ml | 42 +++++++++------ hw3/{ => lib}/ll/lllexer.mll | 9 ++-- hw3/{ => lib}/ll/llparser.mly | 11 +++- hw3/lib/ll/llruntime.c | 38 ++++++++++++++ hw3/{ => lib}/ll/llutil.ml | 60 ++++++++++++++-------- hw3/{ => lib}/util/assert.ml | 17 +++--- hw3/{ => lib}/util/assert.mli | 2 +- hw3/lib/util/dune | 3 ++ hw3/{ => lib}/util/platform.ml | 39 +++++++++++--- hw3/lib/util/range.ml | 56 ++++++++++++++++++++ hw3/lib/util/range.mli | 53 +++++++++++++++++++ hw3/lib/x86/dune | 3 ++ hw3/{ => lib}/x86/x86.ml | 10 ++-- hw3/llprograms/c_weighted_sum.c | 15 ++++++ hw3/llprograms/example.ll | 37 ++++++++++++++ hw3/llprograms/funptr.ll | 14 +++++ hw3/llprograms/printf1.ll | 9 ++++ hw3/llprograms/printf2.ll | 10 ++++ hw3/submit_zip_contents.txt | 2 + hw3/test/dune | 18 +++++++ hw3/{ => test}/gradedtests.ml | 35 +++++++++---- hw3/{ => test}/studenttests.ml | 6 ++- hw3/x86/testX86.ml | 34 ------------ 40 files changed, 856 insertions(+), 271 deletions(-) create mode 100644 hw3/.ocamlformat create mode 100644 hw3/.ocamlinit delete mode 100644 hw3/README create mode 100644 hw3/README.md rename hw3/{ => bin}/backend.ml (82%) create mode 100644 hw3/bin/cinterop.c rename hw3/{ => bin}/driver.ml (85%) create mode 100644 hw3/bin/dune rename hw3/{ => bin}/main.ml (91%) create mode 100644 hw3/bin/timeout3 delete mode 100644 hw3/cinterop.c create mode 100644 hw3/dune-project create mode 100644 hw3/hw3.opam create mode 100644 hw3/lib/ll/dune create mode 100644 hw3/lib/ll/ll-original.ml rename hw3/{ => lib}/ll/ll.ml (90%) rename hw3/{ => lib}/ll/llinterp.ml (92%) rename hw3/{ => lib}/ll/lllexer.mll (91%) rename hw3/{ => lib}/ll/llparser.mly (96%) create mode 100644 hw3/lib/ll/llruntime.c rename hw3/{ => lib}/ll/llutil.ml (74%) rename hw3/{ => lib}/util/assert.ml (89%) rename hw3/{ => lib}/util/assert.mli (95%) create mode 100644 hw3/lib/util/dune rename hw3/{ => lib}/util/platform.ml (82%) create mode 100644 hw3/lib/util/range.ml create mode 100644 hw3/lib/util/range.mli create mode 100644 hw3/lib/x86/dune rename hw3/{ => lib}/x86/x86.ml (95%) create mode 100644 hw3/llprograms/c_weighted_sum.c create mode 100644 hw3/llprograms/example.ll create mode 100644 hw3/llprograms/funptr.ll create mode 100644 hw3/llprograms/printf1.ll create mode 100644 hw3/llprograms/printf2.ll create mode 100644 hw3/submit_zip_contents.txt create mode 100644 hw3/test/dune rename hw3/{ => test}/gradedtests.ml (87%) rename hw3/{ => test}/studenttests.ml (61%) delete mode 100644 hw3/x86/testX86.ml diff --git a/hw3/.ocamlformat b/hw3/.ocamlformat new file mode 100644 index 0000000..fd111e4 --- /dev/null +++ b/hw3/.ocamlformat @@ -0,0 +1,2 @@ +profile = janestreet +version = 0.26.1 diff --git a/hw3/.ocamlinit b/hw3/.ocamlinit new file mode 100644 index 0000000..576e012 --- /dev/null +++ b/hw3/.ocamlinit @@ -0,0 +1 @@ +#use_output "dune top";; diff --git a/hw3/Makefile b/hw3/Makefile index 7e30842..424e07f 100644 --- a/hw3/Makefile +++ b/hw3/Makefile @@ -1,22 +1,30 @@ -all: main.native +SUBMIT := $(shell cat submit_zip_contents.txt) +HWNAME := hw3 +TIMESTAMP := $(shell /bin/date "+%Y-%m-%d-%H:%M:%S") +ZIPNAME := $(HWNAME)-submit-$(TIMESTAMP).zip -.PHONY: test -test: main.native - ./main.native --test +.PHONY: all oatc test clean zip -main.native: - ocamlbuild -Is util,x86,ll,grading -libs unix,str,nums main.native -use-menhir +all: oatc -main.byte: - ocamlbuild -Is util,x86,ll,grading -libs unix,str,nums main.byte -use-menhir +dev: + dune build --watch --terminal-persistence=clear-on-rebuild -.PHONY: utop repl -utop: main.byte - utop -require unix,str,num +oatc: + dune build + @cp bin/main.exe oatc -repl: utop +test: oatc + ./oatc --test + +utop: + dune utop + +zip: $(SUBMIT) + zip '$(ZIPNAME)' $(SUBMIT) -.PHONY: clean clean: - ocamlbuild -clean - rm -rf output a.out + dune clean + rm -rf oatc ocamlbin bin/main.exe + +# diff --git a/hw3/README b/hw3/README deleted file mode 100644 index 0ad0ac0..0000000 --- a/hw3/README +++ /dev/null @@ -1,76 +0,0 @@ -Using main.native: - -main.native acts like the clang compiler. Given several .ll, .c, and .o files, -it will compile the .ll files to .s files (using the compilerdesign backend) and then combine -the results with the .c and .o files to produce an executable named a.out. You can -also compile the .ll files using clang instead of the compilerdesign backend, which can -be useful for testing purposes. - - -* To run the automated test harness do: - ./main.native --test - -* To compile ll files using the compilerdesign backend: - ./main.native path/to/foo.ll - - - creates output/foo.s backend assembly code - - creates output/foo.o assembled object file - - creates a.out linked executable - - NOTE: by default the .s and .o files are created in - a directory called output, and the filenames are - chosen so that multiple runs of the compiler will - not overwrite previous outputs. foo.ll will be - compiled first to foo.s then foo_1.s, foo_2.s, etc. - - -* To compile ll files using the clang backend: - ./main.native --clang path/to/foo.ll - -* Useful flags: - - --print-ll - echoes the ll program to the terminal - - --print-x86 - echoes the resulting .s file to the terminal - - --interpret-ll - runs the ll file through the reference interpreter - and outputs the results to the console - - --simulate-x86 - runs the resulting .s file through the reference - x86 simulator and outputs the result to the console - - --execute-x86 - runs the resulting a.out file natively - (applies to either the compilerdesign backend or clang-compiled code) - - -v - generates verbose output, showing which commands are used - for linking, etc. - - -op - change the output path [DEFAULT=output] - - -o - change the generated executable's name [DEFAULT=a.out] - - -S - stop after generating .s files - - -c - stop after generating .o files - - -h or --help - display the list of options - -* Example uses: - -Run the test case /programs/factrect.ll using the compilerdesign backend: - - -./main.native --execute-x86 programs/factrect.ll ---------------------------------------------------------------- Executing: a.out -* a.out returned 120 diff --git a/hw3/README.md b/hw3/README.md new file mode 100644 index 0000000..89a993c --- /dev/null +++ b/hw3/README.md @@ -0,0 +1,66 @@ +# HW3: LLVMlite backend + +Quick Start: + +1. open the folder in VSCode +2. start an OCaml sandbox terminal +3. run `make test` from the command line +4. open `bin/backend.ml` + +See the general toolchain and project instructions on the course web site. The +course web pages have a link to the html version of the homework instructions. + +Using ``oatc`` +-------------- +oatc acts like the clang compiler. Given several .ll, .c, and .o +files, it will compile the .ll files to .s files (using the cs131 +backend) and then combine the results with the .c and .o files to +produce an executable named a.out. You can also compile the .ll files +using clang instead of the cs131 backend, which can be useful for +testing purposes. + + +* To run the automated test harness do: + + ./oatc --test + +* To compile ll files using the 131 backend: + + ./oatc path/to/foo.ll + + - creates output/foo.s backend assembly code + - creates output/foo.o assembled object file + - creates a.out linked executable + + NOTE: by default the .s and .o files are created in a directory + called output, and the filenames are chosen so that multiple runs of + the compiler will not overwrite previous outputs. foo.ll will be + compiled first to foo.s then foo\_1.s, foo\_2.s, etc. + +* To compile ll files using the clang backend: + + ./oatc --clang path/to/foo.ll + +* Useful flags: + + | Flag | Description | + |-------------------|---------------------------------------------------------------------------------------------------| + | --print-ll | echoes the ll program to the terminal | + | --print-x86 | echoes the resulting .s file to the terminal | + | --interpret-ll | runs the ll file through the reference interpreter and outputs the results to the console | + | --execute-x86 | runs the resulting a.out file natively (applies to either the 131 backend or clang-compiled code) | + | -v | generates verbose output, showing which commands are used for linking, etc. | + | -op ```` | change the output path [DEFAULT=output] | + | -o | change the generated executable's name [DEFAULT=a.out] | + | -S | stop after generating .s files | + | -c | stop after generating .o files | + | -h or --help | display the list of options | + +* Example uses: + + Run the test case llprograms/factrect.ll using the 131 backend: + + + ./oatc --execute-x86 llprograms/factrect.ll + --------------------------------------------------------------- Executing: a.out + * a.out returned 120 diff --git a/hw3/backend.ml b/hw3/bin/backend.ml similarity index 82% rename from hw3/backend.ml rename to hw3/bin/backend.ml index fda53eb..48d9c71 100644 --- a/hw3/backend.ml +++ b/hw3/bin/backend.ml @@ -3,6 +3,8 @@ open Ll open X86 +module Platform = Util.Platform + (* Overview ----------------------------------------------------------------- *) (* We suggest that you spend some time understanding this entire file and @@ -80,7 +82,7 @@ let lookup m x = List.assoc x m That is, the X86 code: movq _gid %rax which looks like it should put the address denoted by _gid into %rax is not allowed. Instead, you need to compute an %rip-relative address using the - leaq instruction: leaq _gid(%rip). + leaq instruction: leaq _gid(%rip) %rax. One strategy for compiling instruction operands is to use a designated register (or registers) for holding the values being @@ -106,12 +108,43 @@ let compile_operand (ctxt:ctxt) (dest:X86.operand) : Ll.operand -> ins = operands will always be placed in registers. (See the notes about compiling fdecl below.) - [ NOTE: It is the caller's responsibility to clean up arguments - pushed onto the stack, so you must free the stack space after the - call returns. ] + [ NOTE: Don't forget to preserve caller-save registers (only if needed). ] - [ NOTE: Don't forget to preserve caller-save registers (only if - needed). ] + [ NOTE: Remember, call can use labels as immediates! You shouldn't need to + perform any RIP-relative addressing for this one. ] + + [ NOTE: It is the caller's responsibility to clean up arguments pushed onto + the stack, so you must free the stack space after the call returns. (But + see below about alignment.) ] + + [ NOTE: One important detail about the ABI besides the conventions is that, + at the time the [callq] instruction is invoked, %rsp *must* be 16-byte aligned. + However, because LLVM IR provides the Alloca instruction, which can dynamically + allocate space on the stack, it is hard to know statically whether %rsp meets + this alignment requirement. Moroever: since, according to the calling + conventions, stack arguments numbered > 6 are pushed to the stack, we must take + that into account when enforcing the alignment property. + + We suggest that, for a first pass, you *ignore* %rsp alignment -- only a few of + the test cases rely on this behavior. Once you have everything else working, + you can enforce proper stack alignment at the call instructions by doing + these steps: + 1. *before* pushing any arguments of the call to the stack, ensure that the + %rsp is 16-byte aligned. You can achieve that with the x86 instruction: + `andq $-16, %rsp` (which zeros out the lower 4 bits of %rsp, possibly + "allocating" unused padding space on the stack) + + 2. if there are an *odd* number of arguments that will be pushed to the stack + (which would break the 16-byte alignment because stack slots are 8 bytes), + allocate an extra 8 bytes of padding on the stack. + + 3. follow the usual calling conventions - any stack arguments will still leave + %rsp 16-byte aligned + + 4. after the call returns, in addition to freeing up the stack slots used by + arguments, if there were an odd number of slots, also free the extra padding. + + ] *) @@ -243,10 +276,12 @@ let compile_lbl_block fn lbl ctxt blk : elem = (* compile_fdecl ------------------------------------------------------------ *) -(* This helper function computes the location of the nth incoming +(* Complete this helper function, which computes the location of the nth incoming function argument: either in a register or relative to %rbp, - according to the calling conventions. You might find it useful for - compile_fdecl. + according to the calling conventions. We will test this function as part of + the hidden test cases. + + You might find it useful for compile_fdecl. [ NOTE: the first six arguments are numbered 0 .. 5 ] *) @@ -282,7 +317,7 @@ failwith "stack_layout not implemented" - the function entry code should allocate the stack storage needed to hold all of the local stack slots. *) -let compile_fdecl (tdecls:(tid * ty) list) (name:string) ({ f_ty; f_param; f_cfg }:fdecl) : prog = +let compile_fdecl (tdecls:(tid * ty) list) (name:string) ({ f_param; f_cfg; _ }:fdecl) : prog = failwith "compile_fdecl unimplemented" @@ -297,13 +332,13 @@ let rec compile_ginit : ginit -> X86.data list = function | GInt c -> [Quad (Lit c)] | GString s -> [Asciz s] | GArray gs | GStruct gs -> List.map compile_gdecl gs |> List.flatten - | GBitcast (t1,g,t2) -> compile_ginit g + | GBitcast (_t1,g,_t2) -> compile_ginit g and compile_gdecl (_, g) = compile_ginit g (* compile_prog ------------------------------------------------------------- *) -let compile_prog {tdecls; gdecls; fdecls} : X86.prog = +let compile_prog {tdecls; gdecls; fdecls; _} : X86.prog = let g = fun (lbl, gdecl) -> Asm.data (Platform.mangle lbl) (compile_gdecl gdecl) in let f = fun (name, fdecl) -> compile_fdecl tdecls name fdecl in (List.map g gdecls) @ (List.map f fdecls |> List.flatten) diff --git a/hw3/bin/cinterop.c b/hw3/bin/cinterop.c new file mode 100644 index 0000000..f331b42 --- /dev/null +++ b/hw3/bin/cinterop.c @@ -0,0 +1,64 @@ +#include +#include +#include +#include +#include + +void ll_puts(int8_t *s) { + puts((char *)s); +} + +int8_t* ll_strcat(int8_t* s1, int8_t* s2) { + int l1 = strlen((char*)s1); + int l2 = strlen((char*)s2); + char* buf = (char*)calloc(l1 + l2 + 1, sizeof(char)); + strncpy(buf, (char*)s1, l1); + strncpy(buf + l1, (char*)s2, l2+1); + return (int8_t*) buf; +} + +int64_t ll_callback(int64_t (*fun)(int64_t, int64_t)) { + int64_t x = 19L; + return fun(x, x); +} + +int8_t* ll_ltoa(int64_t i) { + // Safety: INT64_MIN is -9223372036854775808, which has 20 characters when + // represented as a string. After including the null terminator, we need to + // allocate a buffer of size 21. + char* buf = (char*)calloc(21, sizeof(char)); + int t = 0; + if (i == 0) { + buf[t++] = '0'; + return (int8_t*) buf; + } + + bool negative = i < 0; + if (!negative) { + // Normalize to negative number to avoid overflow + i = -i; + } + + // Generate the digits in reverse order, from [0..t) + while (i < 0) { + char last_digit = '0' + -(i % 10); + buf[t++] = last_digit; + i /= 10; + } + if (negative) { + buf[t++] = '-'; + } + + // Reverse the buffer + for (int j = 0, r = t - 1; j < r; j++, r--) { + char temp = buf[j]; + buf[j] = buf[r]; + buf[r] = temp; + } + + return (int8_t*) buf; +} + +void *ll_malloc(int64_t n, int64_t size) { + return calloc(n, size); +} diff --git a/hw3/driver.ml b/hw3/bin/driver.ml similarity index 85% rename from hw3/driver.ml rename to hw3/bin/driver.ml index 0637456..b7e6571 100644 --- a/hw3/driver.ml +++ b/hw3/bin/driver.ml @@ -1,5 +1,6 @@ open Printf -open Platform + +module Platform = Util.Platform (* configuration flags ------------------------------------------------------ *) let interpret_ll = ref false (* run the ll interpreter? *) @@ -21,7 +22,7 @@ let add_link_file path = (* terminal output ---------------------------------------------------------- *) - + let print_banner s = let rec dashes n = if n = 0 then "" else "-"^(dashes (n-1)) in printf "%s %s\n%!" (dashes (79 - (String.length s))) s @@ -60,27 +61,29 @@ let interpret program args : string = let string_of_file (f:in_channel) : string = let rec _string_of_file (stream:string list) (f:in_channel) : string list= - try + try let s = input_line f in _string_of_file (s::stream) f with | End_of_file -> stream - in + in String.concat "\n" (List.rev (_string_of_file [] f)) -let run_executable arg pr = - let cmd = sprintf "%s%s %s" dot_path pr arg in - sh cmd (fun _ i -> i) - -let run_executable_to_tmpfile arg pr tmp = - let cmd = sprintf "%s%s %d > %s 2>&1" dot_path pr arg tmp in - sh cmd ignore_error +let run_executable timeout arg pr = + let cmd = sprintf "%s%s %s" Platform.dot_path pr arg in + Platform.timeout_sh timeout cmd (fun _ i -> i) + +let run_executable_to_tmpfile timeout arg pr tmp = + let cmd = sprintf "%s%s %d > %s 2>&1" Platform.dot_path pr arg tmp in + Platform.timeout_sh timeout cmd Platform.ignore_error let run_program (args:string) (executable:string) (tmp_out:string) : string = - let _ = - let cmd = sprintf "%s%s %s > %s 2>&1" dot_path executable args tmp_out in - sh cmd ignore_error + let _ = + let cmd = + sprintf "%s%s %s > %s 2>&1" Platform.dot_path executable args tmp_out + in + Platform.sh cmd Platform.ignore_error in let fi = open_in tmp_out in let result = string_of_file fi in @@ -91,12 +94,12 @@ let run_program (args:string) (executable:string) (tmp_out:string) : string = (* compiler pipeline -------------------------------------------------------- *) (* These functions implement the compiler pipeline for a single ll file: - - parse the file + - parse the file - compile to a .s file using either clang or backend.ml - assemble the .s to a .o file using clang *) let parse_ll_file filename = - let program = read_file filename |> + let program = read_file filename |> Lexing.from_string |> Llparser.prog Lllexer.token in @@ -106,7 +109,7 @@ let parse_ll_file filename = let process_ll_ast path file ll_ast = let _ = if !print_ll_flag then print_ll file ll_ast in - (* Optionally interpret it using the compilerdesign reference interperter. *) + (* Optionally interpret it using the cs131 reference interperter. *) let _ = if !interpret_ll then let result = interpret ll_ast [] in Printf.printf "Interpreter Result: %s\n" result @@ -125,7 +128,7 @@ let process_ll_ast path file ll_ast = Platform.sh (Printf.sprintf "cat %s" dot_s_file) Platform.raise_error end end else begin - Platform.verb "* compiling with compilerdesign backend"; + Platform.verb "* compiling with cs131 backend"; let asm_ast = Backend.compile_prog ll_ast in let asm_str = X86.string_of_prog asm_ast in let _ = if !print_x86_flag then print_x86 dot_s_file asm_str in @@ -134,7 +137,7 @@ let process_ll_ast path file ll_ast = end in let _ = if !assemble then Platform.assemble dot_s_file dot_o_file in - let _ = add_link_file dot_o_file in + let _ = add_link_file dot_o_file in () let process_ll_file path file = @@ -163,7 +166,7 @@ let process_files files = Platform.link (List.rev !link_files) !executable_filename ); ( if !assemble && !link && !execute_x86 then - let ret = run_executable "" !executable_filename in + let ret = run_executable 10 "" !executable_filename in print_banner @@ Printf.sprintf "Executing: %s" !executable_filename; Printf.printf "* %s returned %d\n" !executable_filename ret ) end diff --git a/hw3/bin/dune b/hw3/bin/dune new file mode 100644 index 0000000..14c5eaf --- /dev/null +++ b/hw3/bin/dune @@ -0,0 +1,24 @@ +(library + (name llbackend) + (modules backend driver) + (libraries str num util x86 ll)) + +(env + (dev + (flags (:standard -warn-error -A)))) + +(executable + (public_name main) + (name main) + (modules main) + (promote (until-clean)) + (libraries +; OCaml standard libraries +; project libraries + str + num + util + x86 + ll + studenttests + gradedtests)) diff --git a/hw3/main.ml b/hw3/bin/main.ml similarity index 91% rename from hw3/main.ml rename to hw3/bin/main.ml index 72eefe9..d69ea69 100644 --- a/hw3/main.ml +++ b/hw3/bin/main.ml @@ -1,7 +1,6 @@ -open Ll open Arg -open Assert -open Driver +open Util.Assert +open Llbackend.Driver (* testing harness ---------------------------------------------------------- *) exception Ran_tests @@ -23,7 +22,7 @@ let args = ; ("--interpret-ll", Set interpret_ll, "runs each LL program through the LL interpreter") ; ("--print-ll", Set print_ll_flag, "prints the program LL code") ; ("--print-x86", Set print_x86_flag, "prints the program's assembly code") - ; ("--clang", Set clang, "compiles to assembly using clang, not the compilerdesign backend") + ; ("--clang", Set clang, "compiles to assembly using clang, not the 131 backend") ; ("--execute-x86", Set execute_x86, "run the resulting executable file") ; ("-v", Unit Platform.enable_verbose, "enables more verbose compilation output") ] @@ -37,8 +36,8 @@ let main () = Platform.create_output_dir (); try Arg.parse args (fun filename -> files := filename :: !files) - "Compiler Design main test harness\n\ - USAGE: ./main.native [options] \n\ + "cs131 main test harness\n\ + USAGE: ./oatc [options] \n\ see README for details about using the compiler"; process_files !files diff --git a/hw3/bin/timeout3 b/hw3/bin/timeout3 new file mode 100644 index 0000000..5c19d2e --- /dev/null +++ b/hw3/bin/timeout3 @@ -0,0 +1,91 @@ +#!/bin/bash +# +# The Bash shell script executes a command with a time-out. +# Upon time-out expiration SIGTERM (15) is sent to the process. If the signal +# is blocked, then the subsequent SIGKILL (9) terminates it. +# +# Based on the Bash documentation example. + +# Hello Chet, +# please find attached a "little easier" :-) to comprehend +# time-out example. If you find it suitable, feel free to include +# anywhere: the very same logic as in the original examples/scripts, a +# little more transparent implementation to my taste. +# +# Dmitry V Golovashkin + +scriptName="${0##*/}" + +declare -i DEFAULT_TIMEOUT=9 +declare -i DEFAULT_INTERVAL=1 +declare -i DEFAULT_DELAY=1 + +# Timeout. +declare -i timeout=DEFAULT_TIMEOUT +# Interval between checks if the process is still alive. +declare -i interval=DEFAULT_INTERVAL +# Delay between posting the SIGTERM signal and destroying the process by SIGKILL. +declare -i delay=DEFAULT_DELAY + +function printUsage() { + cat < 0)); do + sleep $interval + kill -0 $$ || exit 0 + ((t -= interval)) + done + + # Be nice, post SIGTERM first. + # The 'exit 0' below will be executed if any preceeding command fails. + kill -s SIGTERM $$ && kill -0 $$ || exit 0 + sleep $delay + kill -s SIGKILL $$ +) 2> /dev/null & + +exec "$@" diff --git a/hw3/cinterop.c b/hw3/cinterop.c deleted file mode 100644 index f200ba2..0000000 --- a/hw3/cinterop.c +++ /dev/null @@ -1,32 +0,0 @@ -#include -#include -#include -#include - -void ll_puts(int8_t *s) { - puts((char *)s); -} - -int8_t* ll_strcat(int8_t* s1, int8_t* s2) { - int l1 = strlen((char*)s1); - int l2 = strlen((char*)s2); - char* buf = (char*)calloc(l1 + l2 + 1, sizeof(char)); - strncpy(buf, (char*)s1, l1); - strncpy(buf + l1, (char*)s2, l2+1); - return (int8_t*) buf; -} - -int64_t ll_callback(int64_t (*fun)(int64_t, int64_t)) { - int64_t x = 19L; - return fun(x, x); -} - -int8_t* ll_ltoa(int64_t i) { - char* buf = (char*)calloc(20, sizeof(char)); - snprintf((char *)buf, 20, "%ld", (long)i); - return (int8_t *)buf; -} - -void *ll_malloc(int64_t n, int64_t size) { - return calloc(n, size); -} diff --git a/hw3/dune-project b/hw3/dune-project new file mode 100644 index 0000000..63f382e --- /dev/null +++ b/hw3/dune-project @@ -0,0 +1,3 @@ +(lang dune 2.9) +(name hw3) +(using menhir 2.1) diff --git a/hw3/hw3.opam b/hw3/hw3.opam new file mode 100644 index 0000000..e69de29 diff --git a/hw3/lib/ll/dune b/hw3/lib/ll/dune new file mode 100644 index 0000000..74784a5 --- /dev/null +++ b/hw3/lib/ll/dune @@ -0,0 +1,7 @@ +(library + (name ll) + (modules ll llutil lllexer llparser llinterp) + (wrapped false)) + +(ocamllex lllexer) +(menhir (modules llparser)) diff --git a/hw3/lib/ll/ll-original.ml b/hw3/lib/ll/ll-original.ml new file mode 100644 index 0000000..c0acb18 --- /dev/null +++ b/hw3/lib/ll/ll-original.ml @@ -0,0 +1,81 @@ +(* LLVMlite: A simplified subset of the LLVM IR *) + +type uid = string (* Local identifiers *) +type gid = string (* Global identifiers *) +type tid = string (* Named types *) +type lbl = string (* Labels *) + +(* LLVM IR types *) +type ty = + | Void (* mix of unit/bottom from C *) + | I1 | I8 | I64 (* integer types *) + | Ptr of ty (* t* *) + | Struct of ty list (* { t1, t2, ... , tn } *) + | Array of int * ty (* [ NNN x t ] *) + | Fun of fty (* t1, ..., tn -> tr *) + | Namedt of tid (* named type aliases *) + +(* Function type: argument types and return type *) +and fty = ty list * ty + +(* Syntactic Values *) +type operand = + | Null (* null pointer *) + | Const of int64 (* integer constant *) + | Gid of gid (* A global identifier *) + | Id of uid (* A local identifier *) + +(* Type-annotated operands *) + +(* Binary operations *) +type bop = Add | Sub | Mul | Shl | Lshr | Ashr | And | Or | Xor + +(* Comparison Operators *) +type cnd = Eq | Ne | Slt | Sle | Sgt | Sge + +(* Instructions *) +type insn = + | Binop of bop * ty * operand * operand (* bop ty %o1, %o2 *) + | Alloca of ty (* alloca ty *) + | Load of ty * operand (* load ty %u *) + | Store of ty * operand * operand (* store ty %t, ty* %u *) + | Icmp of cnd * ty * operand * operand (* icmp %s ty %s, %s *) + | Call of ty * operand * (ty * operand) list (* fn(%1, %2, ...) *) + | Bitcast of ty * operand * ty (* bitcast ty1 %u to ty2 *) + | Gep of ty * operand * operand list (* getelementptr ty* %u, i64 %vi, ... *) + +(* Block terminators *) +type terminator = + | Ret of ty * operand option (* ret i64 %s *) + | Br of lbl (* br label %lbl *) + | Cbr of operand * lbl * lbl (* br i1 %s, label %l1, label %l2 *) + +(* Basic blocks *) +type block = { insns: (uid * insn) list; terminator: uid * terminator } + +(* Control Flow Graph: a pair of an entry block and a set labeled blocks *) +type cfg = block * (lbl * block) list + +(* Function declarations *) +type fdecl = { fty: fty; param: uid list; cfg: cfg } + +(* Initializers for global data *) +type ginit = + | GNull (* null literal *) + | GGid of gid (* reference another global *) + | GInt of int64 (* global integer value *) + | GString of string (* constant global string *) + | GArray of gdecl list (* global array *) + | GStruct of gdecl list (* global struct *) + +(* Global declaration *) +and gdecl = ty * ginit + +(* LLVMlite programs *) +type prog = + { tdecls: (tid * ty) list (* named types *) + ; gdecls: (gid * gdecl) list (* global data *) + ; fdecls: (gid * fdecl) list (* code *) + ; edecls: (gid * ty) list (* external declarations *) + } + diff --git a/hw3/ll/ll.ml b/hw3/lib/ll/ll.ml similarity index 90% rename from hw3/ll/ll.ml rename to hw3/lib/ll/ll.ml index 9cd2ff8..3b7ddfd 100644 --- a/hw3/ll/ll.ml +++ b/hw3/lib/ll/ll.ml @@ -94,5 +94,7 @@ type ginit = type gdecl = ty * ginit (* LLVMlite Programs *) -type prog = { tdecls : (tid * ty) list; gdecls : (gid * gdecl) list; - fdecls : (gid * fdecl) list; edecls : (gid * ty) list } +type prog = { tdecls : (tid * ty) list; + gdecls : (gid * gdecl) list; + fdecls : (gid * fdecl) list; + edecls : (gid * ty) list } diff --git a/hw3/ll/llinterp.ml b/hw3/lib/ll/llinterp.ml similarity index 92% rename from hw3/ll/llinterp.ml rename to hw3/lib/ll/llinterp.ml index 2e2388b..3fd39a1 100644 --- a/hw3/ll/llinterp.ml +++ b/hw3/lib/ll/llinterp.ml @@ -44,7 +44,7 @@ let mval_of_gdecl (gd:gdecl) : mval = let rec mtree_of_gdecl : gdecl -> mtree = function | ty, GNull -> MWord (VPtr (ty, NullId, [0])) | ty, GGid g -> MWord (VPtr (ty, GlobId g, [0])) - | _, GBitcast (t1, v,t2) -> mtree_of_gdecl (t1, v) + | _, GBitcast (t1, v, _) -> mtree_of_gdecl (t1, v) | _, GInt i -> MWord (VInt i) | _, GString s -> MStr s | _, GArray gs @@ -56,7 +56,7 @@ let mval_of_ty (nt:tid -> ty) (t:ty) : mval = let rec mtree_of_ty : ty -> mtree = function | I1 | I8 | I64 | Ptr _ -> MWord VUndef | Array (n, I8) -> MStr (String.make n '\x00') - | Array (n, t) -> MNode Array.(make n (MWord VUndef) |> to_list) + | Array (n, _t) -> MNode Array.(make n (MWord VUndef) |> to_list) | Struct ts -> MNode (List.map mtree_of_ty ts) | Fun _ | Void -> failwith "mval_of_ty: mval for bad type" | Namedt id -> mtree_of_ty (nt id) @@ -139,7 +139,8 @@ let interp_i1 : sval -> bool = function let rec interp_operand (nt:tid -> ty) (locs:locals) (ty:ty) (o:operand) : sval = match ty, o with - | I64, Const i -> VInt i + | I64, Const i + | I1, Const i -> VInt i | Ptr ty, Null -> VPtr (ty, NullId, [0]) | Ptr ty, Gid g -> VPtr (ty, GlobId g, [0]) | _, Id u -> locs u @@ -183,7 +184,7 @@ let rec load_idxs (m:mval) (idxs:idx list) : mtree = match idxs', List.nth m i with | [], mt -> mt | [0], MStr s -> MStr s (* [n x i8]* %p and gep [n x i8]* %p, 0, 0 alias *) - | _, MWord v -> failwith "load_idxs: attempted to index into word" + | _, MWord _ -> failwith "load_idxs: attempted to index into word" | _, MStr _ -> failwith "load_idxs: attempted to index into string" | _, MNode m' -> load_idxs m' idxs' @@ -195,7 +196,7 @@ let rec store_idxs (m:mval) (idxs:idx list) (mt:mtree) : mval = if len <= i || i < 0 then raise OOBIndexDeref else match idxs', List.nth m i with | [], _ -> replace_nth m i mt - | _, MWord v -> failwith "store_idxs: attempted to index into word" + | _, MWord _ -> failwith "store_idxs: attempted to index into word" | _, MStr _ -> failwith "store_idxs: attempted to index into string" | _, MNode m' -> replace_nth m i @@ MNode (store_idxs m' idxs' mt) @@ -242,7 +243,7 @@ let effective_tag (nt:tid -> ty) (tag, _, idxs :ptr) : ty = | Struct ts, i::idxs' -> if List.length ts <= i then failwith "effective_tag: index oob of struct" else loop (List.nth ts i) idxs' - | Array (n, t), i::idxs' -> loop t idxs' (* Don't check if OOB! *) + | Array (_, t), _::idxs' -> loop t idxs' (* Don't check if OOB! *) | Namedt id, _ -> loop (nt id) idxs | _, _::_ -> failwith "effective_tag: index into non-aggregate" in @@ -274,13 +275,13 @@ let legal_gep (nt:tid -> ty) (sty:ty) (tag:ty) : bool = let gep_ptr (nt:tid -> ty) (ot:ty) (p:ptr) (idxs':idx list) : sval = if not (legal_gep nt ot @@ effective_tag nt p) then VUndef else match p with - | t, NullId, idxs -> VUndef + | _t, NullId, _idxs -> VUndef | t, bid, idxs -> VPtr (t, bid, gep_idxs idxs idxs') (* LLVMlite reference interpreter *) -let interp_prog {tdecls; gdecls; fdecls} (args:string list) : sval = +let interp_prog {tdecls; gdecls; fdecls; _} (args:string list) : sval = let globals = List.map (fun (g,gd) -> g,mval_of_gdecl gd) gdecls in @@ -289,6 +290,12 @@ let interp_prog {tdecls; gdecls; fdecls} (args:string list) : sval = with Not_found -> failwith @@ "interp_prog: undefined named type " ^ id in + let rec effective_type t = + match t with + | Namedt id -> effective_type (nt id) + | _ -> t + in + let interp_op = interp_operand nt in let next_id : unit -> fid = @@ -318,7 +325,7 @@ let interp_prog {tdecls; gdecls; fdecls} (args:string list) : sval = let mv = [MStr (s1 ^ s2)] in let heap = (mid, mv)::c.heap in {c with heap}, VPtr (t, HeapId mid, [0]) - | I64, "ll_ltoa", [VInt i; VPtr dst] -> + | I64, "ll_ltoa", [VInt i; VPtr _dst] -> let mid = next_id () in let mv = [MStr (Int64.to_string i)] in let heap = (mid, mv)::c.heap in @@ -327,7 +334,7 @@ let interp_prog {tdecls; gdecls; fdecls} (args:string list) : sval = in - (* Interprety the body of a function *) + (* Interpret the body of a function *) let rec interp_cfg (k, blocks:cfg) (locs:locals) (c:config) : config * sval = match k.insns, k.term with @@ -358,7 +365,7 @@ let interp_prog {tdecls; gdecls; fdecls} (args:string list) : sval = | (u, Load (Ptr t, o))::insns, _ -> let mt = match interp_op locs (Ptr t) o with | VPtr p -> - if effective_tag nt p <> t + if effective_type (effective_tag nt p) <> effective_type t then raise IncompatTagDeref else load_ptr c p | VUndef -> raise UndefPtrDeref @@ -377,7 +384,7 @@ let interp_prog {tdecls; gdecls; fdecls} (args:string list) : sval = let vd = interp_op locs (Ptr t) od in let c' = match vd with | VPtr p -> - if effective_tag nt p <> t + if effective_type (effective_tag nt p) <> effective_type t then raise IncompatTagDeref else store_ptr c p (MWord vs) | VUndef -> raise UndefPtrDeref @@ -402,7 +409,8 @@ let interp_prog {tdecls; gdecls; fdecls} (args:string list) : sval = let locs' = update locs u v in interp_cfg ({k with insns}, blocks) locs' c - | (u, Gep (Ptr t, o, os))::insns, _ -> + | (u, Gep (ty, o, os))::insns, _ -> + let t = dptr tdecls ty in let idx_of_sval : sval -> idx = function | VInt i -> Int64.to_int i | _ -> failwith "idx_of_sval: non-integer value" @@ -412,7 +420,7 @@ let interp_prog {tdecls; gdecls; fdecls} (args:string list) : sval = let v' = match interp_op locs (Ptr t) o with | VPtr p -> gep_ptr nt t p idxs' | VUndef -> VUndef - | VInt _ -> failwith "non-ptr arg for gep" + | VInt _ -> failwith @@ "non-ptr arg for gep" ^ sot t in let locs' = update locs u v' in interp_cfg ({k with insns}, blocks) locs' c @@ -434,14 +442,14 @@ let interp_prog {tdecls; gdecls; fdecls} (args:string list) : sval = interp_cfg (k', blocks) locs c | (u,i)::_, _ -> failwith @@ "interp_cfg: invalid instruction \"" - ^ string_of_insn i ^ "\" at %" ^ u + ^ string_of_insn tdecls i ^ "\" at %" ^ u and interp_call (ty:ty) (fn:gid) (args:sval list) (c:config) : config * sval = if List.mem fn runtime_fns then runtime_call ty fn args c else - let {f_param; f_cfg} = try List.assoc fn fdecls - with Not_found -> failwith @@ "interp_call: undefined function " ^ fn + let {f_param; f_cfg; _} = try List.assoc fn fdecls + with Not_found -> failwith @@ "interp_call: undefined function " ^ fn in if List.(length f_param <> length args) then failwith @@ "interp_call: wrong no. arguments for " ^ fn; diff --git a/hw3/ll/lllexer.mll b/hw3/lib/ll/lllexer.mll similarity index 91% rename from hw3/ll/lllexer.mll rename to hw3/lib/ll/lllexer.mll index 2fbacba..83a3465 100644 --- a/hw3/ll/lllexer.mll +++ b/hw3/lib/ll/lllexer.mll @@ -1,5 +1,4 @@ -{ open Lexing - open Llparser +{ open Llparser exception SyntaxError of string } @@ -16,7 +15,8 @@ rule token = parse | eof { EOF } | whitespace+ { token lexbuf } | newline+ { token lexbuf } - | "c\"" { read_string (Buffer.create 17) lexbuf } + | "\"" { read_string (Buffer.create 16) lexbuf } + | "c\"" { read_string (Buffer.create 16) lexbuf } | '*' { STAR } | ',' { COMMA } | ':' { COLON } @@ -65,6 +65,8 @@ rule token = parse | "external" { EXTERNAL } | "alloca" { ALLOCA } | "bitcast" { BITCAST } + | "target" { TARGET } + | "triple" { TRIPLE } | '%' ('.' ?) (identifier as i) { UID i } | '@' ('.' ?) (identifier as i) { GID i } | "x" { CROSS } (* for Array types *) @@ -76,6 +78,7 @@ rule token = parse and read_string buf = parse | '\\' "00" '"' { STRING (Buffer.contents buf) } + | '"' { STRING (Buffer.contents buf) } | '\\' { Buffer.add_char buf '\\'; read_string buf lexbuf } | [^ '"' '\\']+ { Buffer.add_string buf (Lexing.lexeme lexbuf) ; read_string buf lexbuf } diff --git a/hw3/ll/llparser.mly b/hw3/lib/ll/llparser.mly similarity index 96% rename from hw3/ll/llparser.mly rename to hw3/lib/ll/llparser.mly index ca28340..4b70a84 100644 --- a/hw3/ll/llparser.mly +++ b/hw3/lib/ll/llparser.mly @@ -56,6 +56,8 @@ %token ALLOCA (* alloca *) %token BITCAST (* bitcast *) %token GEP (* getelementptr *) +%token TARGET (* target *) +%token TRIPLE (* triple *) %token INT (* int64 values *) %token LBL (* labels *) @@ -89,6 +91,11 @@ decls_rev: { { ds with tdecls = t :: ds.tdecls } } | ds=decls_rev e=edecl { { ds with edecls = e :: ds.edecls } } + | ds=decls_rev ttdecl + { ds } + +ttdecl: + TARGET TRIPLE EQUALS STRING {} fdecl: | DEFINE t=ty l=GID LPAREN a=arg_list RPAREN @@ -134,6 +141,8 @@ ty: { t } ty_list_rev: + | (* empty *) + { [] } | t=ty { [t] } | ts=ty_list_rev COMMA t=ty @@ -252,7 +261,7 @@ insn: { (u, Alloca t) } | u=UID EQUALS LOAD ty COMMA t=ty o=operand { (u, Load (t,o)) } - | STORE t1=ty o1=operand COMMA t2=ty o2=operand + | STORE t1=ty o1=operand COMMA _t2=ty o2=operand { (gensym "store", Store (t1,o1,o2)) } | u=UID EQUALS ICMP c=cnd t=ty o1=operand COMMA o2=operand { (u, Icmp (c,t,o1,o2)) } diff --git a/hw3/lib/ll/llruntime.c b/hw3/lib/ll/llruntime.c new file mode 100644 index 0000000..895fe36 --- /dev/null +++ b/hw3/lib/ll/llruntime.c @@ -0,0 +1,38 @@ +#include +#include +#include +#include + +/* TODO: if we enforce that all char literals are null-terminated, + and all allocated memory is zero-initialized, are these safe + when llvmlite program does not exhibit UB? */ + +void *ll_malloc(int64_t n, int64_t size) { + return calloc(n, size); +} + +int64_t ll_strlen(int8_t *s) { + return 0; +} + +int8_t *ll_strncopy(int8_t *dst, int8_t *src, int64_t i) { + int64_t src_size = ll_strlen(src); + int64_t dst_size = ll_strlen(dst); + if (i >= dst_size) + return dst; + else + return (int8_t*)strncpy((char *)dst + i, (char *)src, dst_size - i); +} + +void ll_puts(int8_t *s) { + puts((char *)s); +} + +int64_t ll_atol(int8_t *s) { + return atol((char *)s); +} + +int64_t ll_ltoa(int64_t i, int8_t *dst) { + int64_t size = ll_strlen(dst); + return snprintf((char *)dst, size, "%ld", (long)i); +} diff --git a/hw3/ll/llutil.ml b/hw3/lib/ll/llutil.ml similarity index 74% rename from hw3/ll/llutil.ml rename to hw3/lib/ll/llutil.ml index f7bba0f..c487b9b 100644 --- a/hw3/ll/llutil.ml +++ b/hw3/lib/ll/llutil.ml @@ -20,9 +20,12 @@ let rec string_of_ty : ty -> string = function let sot = string_of_ty -let dptr = function +let rec dptr tdecls = function | Ptr t -> t - | _ -> failwith "PP: expected pointer type" + | Namedt id -> + (try dptr tdecls (List.assoc id tdecls) + with Not_found -> failwith @@ "dptr: undefined named type " ^ id) + | t -> failwith @@ "PP: expected pointer type, got " ^ (sot t) let string_of_operand : operand -> string = function | Null -> "null" @@ -48,11 +51,12 @@ let string_of_gep_index : operand -> string = function | Const i -> "i32 " ^ Int64.to_string i | o -> "i64 " ^ soo o -let string_of_insn : insn -> string = function +let string_of_insn (tdecls:(tid * ty) list) (i:insn) : string = + match i with | Binop (b, t, o1, o2) -> pp "%s %s %s, %s" (string_of_bop b) (sot t) (soo o1) (soo o2) | Alloca t -> pp "alloca %s" (sot t) - | Load (t, o) -> pp "load %s, %s %s" (sot (dptr t)) (sot t) (soo o) + | Load (t, o) -> pp "load %s, %s %s" (sot (dptr tdecls t)) (sot t) (soo o) | Store (t, os, od) -> pp "store %s %s, %s %s" (sot t) (soo os) (sot (Ptr t)) (soo od) | Icmp (c, t, o1, o2) -> pp "icmp %s %s %s, %s" @@ -60,13 +64,13 @@ let string_of_insn : insn -> string = function | Call (t, o, oa) -> pp "call %s %s(%s)" (sot t) (soo o) (mapcat ", " soop oa) | Bitcast (t1, o, t2) -> pp "bitcast %s %s to %s" (sot t1) (soo o) (sot t2) - | Gep (t, o, oi) -> pp "getelementptr %s, %s %s, %s" (sot (dptr t)) (sot t) (soo o) + | Gep (t, o, oi) -> pp "getelementptr %s, %s %s, %s" (sot (dptr tdecls t)) (sot t) (soo o) (mapcat ", " string_of_gep_index oi) -let string_of_named_insn (u,i:uid * insn) : string = +let string_of_named_insn (tdecls:(tid * ty) list) (u,i:uid * insn) : string = match i with - | Store _ | Call (Void, _, _) -> string_of_insn i - | _ -> pp "%%%s = %s" u (string_of_insn i) + | Store _ | Call (Void, _, _) -> string_of_insn tdecls i + | _ -> pp "%%%s = %s" u (string_of_insn tdecls i) let string_of_terminator : terminator -> string = function | Ret (_, None) -> "ret void" @@ -74,26 +78,42 @@ let string_of_terminator : terminator -> string = function | Br l -> pp "br label %%%s" l | Cbr (o, l, m) -> pp "br i1 %s, label %%%s, label %%%s" (soo o) l m -let string_of_block (b:block) : string = - (mapcat "\n" (prefix " " string_of_named_insn) b.insns ^. "\n") +let string_of_block (tdecls:(tid * ty) list) (b:block) : string = + (mapcat "\n" (prefix " " (string_of_named_insn tdecls)) b.insns ^. "\n") ^ (prefix " " string_of_terminator) (snd b.term) -let string_of_cfg (e,bs:cfg) : string = - let string_of_named_block (l,b) = l ^ ":\n" ^ string_of_block b in - string_of_block e ^ "\n" ^. mapcat "\n" string_of_named_block bs +let string_of_cfg (tdecls:(tid * ty) list) (e,bs:cfg) : string = + let string_of_named_block (l,b) = l ^ ":\n" ^ string_of_block tdecls b in + string_of_block tdecls e ^ "\n" ^. mapcat "\n" string_of_named_block bs -let string_of_named_fdecl (g,f:gid * fdecl) : string = +let string_of_named_fdecl (tdecls:(tid * ty) list) (g,f:gid * fdecl) : string = let string_of_arg (t,u) = pp "%s %%%s" (sot t) u in let ts, t = f.f_ty in pp "define %s @%s(%s) {\n%s\n}\n" (sot t) g (mapcat ", " string_of_arg List.(combine ts f.f_param)) - (string_of_cfg f.f_cfg) + (string_of_cfg tdecls f.f_cfg) + + +(* Utility function to escape strings to use \hh encoding for various characters *) +let escape (s:string) : string = + let buf = Buffer.create (String.length s) in + let add_char c = + match c with + | '\n' -> Buffer.add_string buf "\\0A" + | '\t' -> Buffer.add_string buf "\\09" + | '\r' -> Buffer.add_string buf "\\0D" + | '"' -> Buffer.add_string buf "\\22" + | '\\' -> Buffer.add_string buf "\\5C" + | _ -> Buffer.add_char buf c + in + String.iter add_char s; + Buffer.contents buf let rec string_of_ginit : ginit -> string = function | GNull -> "null" | GGid g -> pp "@%s" g | GInt i -> Int64.to_string i - | GString s -> pp "c\"%s\\00\"" s + | GString s -> pp "c\"%s\\00\"" (escape s) | GArray gis -> pp "[ %s ]" (mapcat ", " string_of_gdecl gis) | GStruct gis -> pp "{ %s }" (mapcat ", " string_of_gdecl gis) | GBitcast (t1,g,t2) -> pp "bitcast (%s %s to %s)" (sot t1) (string_of_ginit g) (sot t2) @@ -116,8 +136,8 @@ let string_of_named_edecl (g,t:gid * ty) : string = let string_of_prog (p:prog) : string = (mapcat "\n" string_of_named_tdecl p.tdecls ^. "\n\n") ^ (mapcat "\n" string_of_named_gdecl p.gdecls ^. "\n\n") - ^ (mapcat "\n" string_of_named_fdecl p.fdecls ^. "\n\n") - ^ (mapcat "\n" string_of_named_edecl p.edecls) + ^ (mapcat "\n" (string_of_named_fdecl p.tdecls) p.fdecls ^. "\n\n") + ^ (mapcat "\n" string_of_named_edecl p.edecls) ^. "\n" (* comparison for testing ----------------------------------------------------- *) @@ -129,9 +149,9 @@ let compare_block (b:block) (c:block) : int = | Call (Void, _, _) -> "", i | _ -> u, i in - let del_term (u,t) = ("", t) + let del_term (_u,t) = ("", t) in - Pervasives.compare + Stdlib.compare {insns=List.map del_dummy b.insns; term=del_term b.term} {insns=List.map del_dummy c.insns; term=del_term c.term} diff --git a/hw3/util/assert.ml b/hw3/lib/util/assert.ml similarity index 89% rename from hw3/util/assert.ml rename to hw3/lib/util/assert.ml index a99d32e..1666dfb 100644 --- a/hw3/util/assert.ml +++ b/hw3/lib/util/assert.ml @@ -1,4 +1,4 @@ -(* Assertion Testing and Grading Infrastructure *) +(* cs131 Assertion Testing and Grading Infrastructure *) (* Author: Steve Zdancewic *) (* Do NOT modify this file -- we will overwrite it *) @@ -121,6 +121,9 @@ let result_test_to_string (name_pts : string) (r : result test) : string = cases +(* Number of digits of precision for a float x. Argument p is the number of decimal places desired (must be at least 1) *) +let prec_digits p x = (int_of_float @@ floor @@ log10 x) + (1 + p) + (* returns (name_pts, passed, failed, total, points_earned, max_given, max_hidden) *) let get_results (t : result test) = let num_passed cases = @@ -140,13 +143,11 @@ let get_results (t : result test) = let passed = num_passed cases in let failed = num_failed cases in let total = List.length cases in - if total > 0 + if total > 0 then - let points_earned = - float_of_int passed /. float_of_int total *. float_of_int pts - in - let name_pts = - Printf.sprintf "%s (%1.f/%d points)" name points_earned pts + let points_earned = ((float_of_int passed) /. (float_of_int total)) *. (float_of_int pts) in + let name_pts = + Printf.sprintf "%s (%1.*g/%d points = %d/%d tests)" name (prec_digits 1 points_earned) points_earned pts passed total in (name_pts, passed, failed, total, points_earned, pts, 0) else @@ -186,7 +187,7 @@ let outcome_to_string (o : outcome) : string = ^ Printf.sprintf "Passed: %d/%d\n\ Failed: %d/%d\n\ - Score: %1.f/%d (given)\n\ + Score: %1.1f/%d (given)\n\ \ ?/%d (hidden)" p tot f tot diff --git a/hw3/util/assert.mli b/hw3/lib/util/assert.mli similarity index 95% rename from hw3/util/assert.mli rename to hw3/lib/util/assert.mli index 0159cf7..6372076 100644 --- a/hw3/util/assert.mli +++ b/hw3/lib/util/assert.mli @@ -1,4 +1,4 @@ -(* Assertion Testing and Grading Infrastructure *) +(* cs131 Assertion Testing and Grading Infrastructure *) (* Author: Steve Zdancewic *) (* Do NOT modify this file -- we will overwrite it *) diff --git a/hw3/lib/util/dune b/hw3/lib/util/dune new file mode 100644 index 0000000..aa0f522 --- /dev/null +++ b/hw3/lib/util/dune @@ -0,0 +1,3 @@ +(library + (name util) + (libraries str unix)) \ No newline at end of file diff --git a/hw3/util/platform.ml b/hw3/lib/util/platform.ml similarity index 82% rename from hw3/util/platform.ml rename to hw3/lib/util/platform.ml index 4027171..13a96a0 100644 --- a/hw3/util/platform.ml +++ b/hw3/lib/util/platform.ml @@ -9,8 +9,12 @@ exception PlatformError of string * string (* paths -------------------------------------------------------------------- *) let path_sep = "/" +let bin_path = "./bin" + let dot_path = "./" +let executable_name = ref "a.out" + let output_path = ref "output" let libs = ref [] @@ -21,8 +25,6 @@ let lib_search_paths = ref [] let include_paths = ref [] -let executable_name = ref "a.out" - (* unix utility scripts ----------------------------------------------------- *) let pp_cmd = ref "cpp -E " @@ -37,6 +39,11 @@ let os = let () = close_in ic in uname +let cpu = + let ic = Unix.open_process_in "uname -m" in + let cpuname = input_line ic in + let () = close_in ic in + cpuname (* One of "Darwin" or "Linux" *) @@ -74,7 +81,7 @@ let verb msg = if !verbose then ( print_string msg ; - flush Pervasives.stdout ) + flush Stdlib.stdout ) let verb_os () = @@ -100,15 +107,21 @@ let create_output_dir () = (* clang invocation stuff --------------------------------------------------- *) -let common_flags = "-Wno-override-module -Wno-unused-command-line-argument -mstack-alignment=8" +let common_flags = "-Wno-override-module" + +let link_flags = "-Wno-unused-command-line-argument -mstackrealign" let clang_ll_mode = "-S" let as_mode = "-c" +let rosetta_prefix = "arch -x86_64 " + +let prefix = if cpu = "arm64" then rosetta_prefix else "" + let opt_level = ref "-O1 -Wall" -let clang args = Printf.sprintf "clang %s -o " (String.concat " " args) +let clang args = Printf.sprintf "%sclang %s -o " prefix (String.concat " " args) let clang_cmd () = clang [ clang_ll_mode; !opt_level; common_flags; !platform_flags ] @@ -116,7 +129,7 @@ let clang_cmd () = let as_cmd () = clang [ as_mode; !opt_level; common_flags; !platform_flags ] -let link_cmd () = clang [ common_flags; !opt_level; !platform_flags ] +let link_cmd () = clang [ common_flags; !opt_level; !platform_flags; link_flags ] (* filename munging --------------------------------------------------------- *) let path_to_basename_ext (path : string) : string * string = @@ -148,6 +161,20 @@ let sh (cmd : string) (ret : string -> int -> 'a) : 'a = | WSTOPPED i -> raise (PlatformError (cmd, sprintf "Stopped with %d." i)) +(* Platform independent shell command with a timeout (in seconds) *) +let timeout_sh (time: int)(cmd : string) (ret : string -> int -> 'a) : 'a = + let timeout_cmd = sprintf "%s/timeout3 -t %d %s" bin_path time cmd in + verb (sprintf "* %s\n" timeout_cmd) ; + match system timeout_cmd with + | WEXITED i -> + ret cmd i + | WSIGNALED i -> + if i == Sys.sigterm + then raise (PlatformError (cmd, sprintf "Timed-out after %d s" time)) + else raise (PlatformError (cmd, sprintf "Signaled with %d." i)) + | WSTOPPED i -> + raise (PlatformError (cmd, sprintf "Stopped with %d." i)) + (* Generate a file name that does not already exist. basedir includes the path separator diff --git a/hw3/lib/util/range.ml b/hw3/lib/util/range.ml new file mode 100644 index 0000000..9a78d1a --- /dev/null +++ b/hw3/lib/util/range.ml @@ -0,0 +1,56 @@ +open Lexing + +type pos = int * int (* Line number and column *) + +type t = string * pos * pos + +let line_of_pos (l, _) = l + +let col_of_pos (_, c) = c + +let mk_pos line col = (line, col) + +let file_of_range (f, _, _) = f + +let start_of_range (_, s, _) = s + +let end_of_range (_, _, e) = e + +let mk_range f s e = (f, s, e) + +let valid_pos (l, c) = l >= 0 && c >= 0 + +let merge_range ((f, s1, e1) as r1) ((f', s2, e2) as r2) = + if f <> f' + then + failwith + @@ Printf.sprintf "merge_range called on different files: %s and %s" f f' + else if not (valid_pos s1) + then r2 + else if not (valid_pos s2) + then r1 + else mk_range f (min s1 s2) (max e1 e2) + + +let string_of_range (f, (sl, sc), (el, ec)) = + Printf.sprintf "%s:[%d.%d-%d.%d]" f sl sc el ec + + +let ml_string_of_range (f, (sl, sc), (el, ec)) = + Printf.sprintf "(\"%s\", (%d, %d), (%d, %d))" f sl sc el ec + + +let norange = ("__internal", (0, 0), (0, 0)) + +(* Creates a Range.pos from the Lexing.position data *) +let pos_of_lexpos (p : position) : pos = + mk_pos p.pos_lnum (p.pos_cnum - p.pos_bol) + + +let mk_lex_range (p1 : position) (p2 : position) : t = + mk_range p1.pos_fname (pos_of_lexpos p1) (pos_of_lexpos p2) + + +(* Expose the lexer state as a Range.t value *) +let lex_range lexbuf : t = + mk_lex_range (lexeme_start_p lexbuf) (lexeme_end_p lexbuf) diff --git a/hw3/lib/util/range.mli b/hw3/lib/util/range.mli new file mode 100644 index 0000000..9603713 --- /dev/null +++ b/hw3/lib/util/range.mli @@ -0,0 +1,53 @@ +(* Ranges and utilities on ranges. *) + +(* A range represents a segment of text in a given file; it has a + * beginning and ending position specified in terms of line and column + * numbers. A range is associated with tokens during lexing to allow + * the compiler to give better error messages during lexing and + * parsing. + *) + +(* a position in the source file; line number and column *) +type pos = int * int + +(* a range of positions in a particular file *) +type t = string * pos * pos + +(* line of position *) +val line_of_pos : pos -> int + +(* column of position *) +val col_of_pos : pos -> int + +(* new position with given line and col *) +val mk_pos : int -> int -> pos + +(* the filename a range is in *) +val file_of_range : t -> string + +(* the beginning of the range *) +val start_of_range : t -> pos + +(* the end of the range *) +val end_of_range : t -> pos + +(* create a new range from the given filename and start, end positions *) +val mk_range : string -> pos -> pos -> t + +(* merge two ranges together *) +val merge_range : t -> t -> t + +(* pretty-print a range *) +val string_of_range : t -> string + +(* print a range as an ocaml value *) +val ml_string_of_range : t -> string + +(* use to tag generated AST nodes where range does not apply *) +val norange : t + +val pos_of_lexpos : Lexing.position -> pos + +val mk_lex_range : Lexing.position -> Lexing.position -> t + +val lex_range : Lexing.lexbuf -> t diff --git a/hw3/lib/x86/dune b/hw3/lib/x86/dune new file mode 100644 index 0000000..abab108 --- /dev/null +++ b/hw3/lib/x86/dune @@ -0,0 +1,3 @@ +(library + (name x86) + (modules x86)) diff --git a/hw3/x86/x86.ml b/hw3/lib/x86/x86.ml similarity index 95% rename from hw3/x86/x86.ml rename to hw3/lib/x86/x86.ml index 802ee18..514a5c5 100644 --- a/hw3/x86/x86.ml +++ b/hw3/lib/x86/x86.ml @@ -56,13 +56,13 @@ type prog = elem list (* Provide some syntactic sugar for writing x86 code in OCaml files. *) module Asm = struct - let (~$) i = Imm (Lit (Int64.of_int i)) (* int64 constants *) + let (~$) i = Imm (Lit (Int64.of_int i)) (* int64 constants *) let (~$$) l = Imm (Lbl l) (* label constants *) - let (~%) r = Reg r (* registers *) + let (~%) r = Reg r (* registers *) (* helper functions for building blocks of data or code *) - let data l ds = { lbl = l; global = true; asm = Data ds } - let text l is = { lbl = l; global = false; asm = Text is } + let data l ds = { lbl = l; global = true; asm = Data ds } + let text l is = { lbl = l; global = false; asm = Text is } let gtext l is = { lbl = l; global = true; asm = Text is } end @@ -127,7 +127,7 @@ let string_of_opcode : opcode -> string = function let map_concat s f l = String.concat s @@ List.map f l let string_of_shift op = function - | [ Imm i ; dst ] as args -> + | [ Imm _i ; _dst ] as args -> "\t" ^ string_of_opcode op ^ "\t" ^ map_concat ", " string_of_operand args | [ Reg Rcx ; dst ] -> Printf.sprintf "\t%s\t%%cl, %s" (string_of_opcode op) (string_of_operand dst) diff --git a/hw3/llprograms/c_weighted_sum.c b/hw3/llprograms/c_weighted_sum.c new file mode 100644 index 0000000..8e581be --- /dev/null +++ b/hw3/llprograms/c_weighted_sum.c @@ -0,0 +1,15 @@ +#include + +int64_t ll_weighted_sum(int64_t a1, int64_t a2, int64_t a3, int64_t a4, + int64_t a5, int64_t a6, int64_t a7, int64_t a8) { + int64_t sum = 0; + sum += a1 * 1; + sum += a2 * 2; + sum += a3 * 3; + sum += a4 * 4; + sum += a5 * 5; + sum += a6 * 6; + sum += a7 * 7; + sum += a8 * 8; + return sum; +} diff --git a/hw3/llprograms/example.ll b/hw3/llprograms/example.ll new file mode 100644 index 0000000..26ac52d --- /dev/null +++ b/hw3/llprograms/example.ll @@ -0,0 +1,37 @@ +declare i8* @ll_ltoa(i64) +declare void @ll_puts(i8*) + +%arr = type [10 x i64] + +@nums = global %arr [ i64 5, i64 1, i64 4, i64 2, i64 3, i64 6, i64 10, i64 9, i64 7, i64 8 ] + +define void @iter(void(i64)* %f, %arr* %l) { + %1 = alloca i64 + store i64 0, i64* %1 + br label %loop +loop: + %i = load i64, i64* %1 + %valid = icmp slt i64 %i, 10 + br i1 %valid, label %body, label %post +body: + %idx = load i64, i64* %1 + %p = getelementptr %arr, %arr* %l, i64 0, i64 %idx + %n = load i64, i64* %p + call void %f(i64 %n) + %newidx = add i64 %idx, 1 + store i64 %newidx, i64* %1 + br label %loop +post: + ret void +} + +define void @print(i64 %x) { + %1 = call i8* @ll_ltoa(i64 %x) + call void @ll_puts(i8* %1) + ret void +} + +define void @main(i64 %argc, i8** %arcv) { + call void @iter(void(i64)* @print, %arr* @nums) + ret void +} diff --git a/hw3/llprograms/funptr.ll b/hw3/llprograms/funptr.ll new file mode 100644 index 0000000..2845cbf --- /dev/null +++ b/hw3/llprograms/funptr.ll @@ -0,0 +1,14 @@ +define i64 @m(i64 %x) { + %ans = add i64 %x, 1 + ret i64 %ans +} + +define i64 @apply(i64(i64)* %f) { + %ans = call i64 %f(i64 34) + ret i64 %ans +} + +define i64 @main(i64 %argc, i8** %argv) { + %ans = call i64 @apply(i64(i64)* @m) + ret %ans +} diff --git a/hw3/llprograms/printf1.ll b/hw3/llprograms/printf1.ll new file mode 100644 index 0000000..4e5a44b --- /dev/null +++ b/hw3/llprograms/printf1.ll @@ -0,0 +1,9 @@ +declare void @printf(i8*) + +@format = global [15 x i8] c"test alignment\00" + +define i64 @main(i64 %argc, i8** %argv) { + %1 = getelementptr [15 x i8], [15 x i8]* @format, i32 0, i32 0 + call void @printf(i8* %1) + ret i64 0 +} diff --git a/hw3/llprograms/printf2.ll b/hw3/llprograms/printf2.ll new file mode 100644 index 0000000..1764bf0 --- /dev/null +++ b/hw3/llprograms/printf2.ll @@ -0,0 +1,10 @@ +declare void @printf(i8*) + +@format = global [15 x i8] c"test alignment\00" + +define i64 @main(i64 %argc, i8** %argv) { + %1 = getelementptr [15 x i8], [15 x i8]* @format, i32 0, i32 0 + %2 = add i64 0, 0 + call void @printf(i8* %1) + ret i64 %2 +} diff --git a/hw3/submit_zip_contents.txt b/hw3/submit_zip_contents.txt new file mode 100644 index 0000000..336def4 --- /dev/null +++ b/hw3/submit_zip_contents.txt @@ -0,0 +1,2 @@ +bin/backend.ml +test/studenttests.ml diff --git a/hw3/test/dune b/hw3/test/dune new file mode 100644 index 0000000..d4c0b90 --- /dev/null +++ b/hw3/test/dune @@ -0,0 +1,18 @@ +(env + (dev + (flags + (:standard -g -w "+a-4-7-9-26-27-29-30-32..42-44-45-48-50-60-66..70") + ))) + +(library + (name studenttests) + (modules studenttests) + (libraries gradedtests util x86 ll llbackend)) + +(library + (name gradedtests) + (modules + gradedtests +; project libraries + ) + (libraries util x86 ll llbackend)) diff --git a/hw3/gradedtests.ml b/hw3/test/gradedtests.ml similarity index 87% rename from hw3/gradedtests.ml rename to hw3/test/gradedtests.ml index b7c259a..2046b9c 100644 --- a/hw3/gradedtests.ml +++ b/hw3/test/gradedtests.ml @@ -1,7 +1,9 @@ -open Assert +open Util.Assert open X86 open Ll -open Backend +module Backend = Llbackend.Backend +module Driver = Llbackend.Driver +open Llbackend.Backend (* Do NOT modify this file -- we will overwrite it with our *) (* own version when we test your project. *) @@ -31,7 +33,7 @@ let exec_e2e_ast ll_ast args extra_files = let asm_str = X86.string_of_prog asm_ast in let _ = Driver.write_file dot_s_file asm_str in let _ = Platform.link (dot_s_file::extra_files) exec_file in - let result = Driver.run_executable args exec_file in + let result = Driver.run_executable 10 args exec_file in let _ = Platform.sh (Printf.sprintf "rm -f %s %s" dot_s_file exec_file) Platform.ignore_error in let _ = Platform.verb @@ Printf.sprintf "** Executable exited with: %d\n" result in Int64.of_int result @@ -50,7 +52,7 @@ let io_test path args = let asm_ast = Backend.compile_prog ll_ast in let asm_str = X86.string_of_prog asm_ast in let _ = Driver.write_file dot_s_file asm_str in - let _ = Platform.link (dot_s_file::["cinterop.c"]) exec_file in + let _ = Platform.link (dot_s_file::["bin/cinterop.c"]) exec_file in let args = String.concat " " args in let result = Driver.run_program args exec_file tmp_file in let _ = Platform.sh (Printf.sprintf "rm -f %s %s %s" dot_s_file exec_file tmp_file) Platform.ignore_error in @@ -67,7 +69,7 @@ let c_link_test c_files path args = let _ = Driver.write_file dot_s_file asm_str in let _ = Platform.link (dot_s_file::c_files) exec_file in let args = String.concat " " args in - let result = Driver.run_executable args exec_file in + let result = Driver.run_executable 10 args exec_file in let _ = Platform.sh (Printf.sprintf "rm -f %s %s" dot_s_file exec_file) Platform.ignore_error in Int64.of_int result @@ -143,8 +145,10 @@ let io_tests = ; "llprograms/string1.ll", [], "hello, world!hello, world!" ; "llprograms/callback1.ll", [], "38" ; "llprograms/args1.ll", ["hello"], "argc < 3" - ; "llprograms/args1.ll", ["hello"; "compilerdesign"], "hellocompilerdesign" - ; "llprograms/args1.ll", ["hello"; "compilerdesign"; "foo"], "argc > 3" + ; "llprograms/args1.ll", ["hello"; "cs131"], "hellocs131" + ; "llprograms/args1.ll", ["hello"; "cs131"; "foo"], "argc > 3" + ; "llprograms/printf1.ll", [], "test alignment" + ; "llprograms/printf2.ll", [], "test alignment" ] @@ -162,8 +166,8 @@ let large_tests = [ "llprograms/list1.ll", 3L ] - let tests : suite = + [ GradedTest("size_ty tests", 5, size_ty_tests) ; GradedTest("arg_loc tests", 5, arg_loc_tests) ; GradedTest("executed binop tests", 5, executed binop_tests) @@ -172,11 +176,20 @@ let tests : suite = ; GradedTest("calling convention tests", 15, executed calling_convention_tests) ; GradedTest("bitcast tests", 2, executed bitcast_tests) ; GradedTest("gep tests", 10, executed gep_tests) - ; GradedTest("large tests", 10, executed large_tests) - ; GradedTest("hidden large tests", 18, hidden_large_tests) + ; GradedTest("large tests", 5, executed large_tests) + ; GradedTest("hidden large tests", 13, hidden_large_tests) ; GradedTest("io tests", 10, executed_io io_tests) ] +let manual_tests : suite = [ + GradedTest ("Posted Test Case", 5, + [] + ); + GradedTest ("Other Student's Tests", 5, + [] + ); +] let graded_tests : suite = - tests + tests @ + manual_tests diff --git a/hw3/studenttests.ml b/hw3/test/studenttests.ml similarity index 61% rename from hw3/studenttests.ml rename to hw3/test/studenttests.ml index f878420..2d100f4 100644 --- a/hw3/studenttests.ml +++ b/hw3/test/studenttests.ml @@ -1,6 +1,8 @@ -open Assert +open Util.Assert +open Gradedtests + -(* These tests are provided by you -- they will not be graded *) +(* These tests are provided by you -- they will be graded manually *) (* You should also add additional test cases here to help you *) (* debug your program. *) diff --git a/hw3/x86/testX86.ml b/hw3/x86/testX86.ml deleted file mode 100644 index 1b23983..0000000 --- a/hw3/x86/testX86.ml +++ /dev/null @@ -1,34 +0,0 @@ -open X86 -open Cunit - -let hello_label = mk_lbl_named "hellostr" -let puts_label = mk_lbl_named "_puts" (* gcc on linux/mac uses _ to munge names *) - -let main_seq = [ - Push (esp); - Mov (ebp, esp); - - Add (esp, Imm (-8l)); (* Not sure why this has to be 8 *) - Mov (stack_offset 0l, Lbl hello_label); - Call (Lbl puts_label); - - Mov (esp, ebp); - Pop (ebp); - Ret -] - -let main_bb = { - (mk_insn_block (mk_lbl_named "_main") main_seq) with - global = true -} - -let hello_data = { - link = false; - label = (mk_lbl_named "hellostr"); - value = GStringz "Hello, world!" -} - -let cu = [Data hello_data; Code main_bb] - -let _ = - print_endline (string_of_cunit cu)