jmug/CS153
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Modified hw3 to newer version

Browse source 
Signed-off-by: jmug <u.g.a.mariano@gmail.com>
This commit is contained in:
Mariano Uvalle 2025-01-24 20:53:24 -08:00
parent 8437a82fbf
commit 07d34c0cd8
40 changed files with 856 additions and 271 deletions
Download patch file Download diff file Expand all files Collapse all files

2
hw3/.ocamlformat Normal file
View file

@ -0,0 +1,2 @@
profile = janestreet
version = 0.26.1

1
hw3/.ocamlinit Normal file
View file

@ -0,0 +1 @@
#use_output "dune top";;

38
hw3/Makefile
View file

@ -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
#

76
hw3/README
View file

@ -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 <dirname>
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

66
hw3/README.md Normal file
View file

@ -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 ``<dirname>`` | 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

59
hw3/backend.ml → hw3/bin/backend.ml
View file

@ -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)

64
hw3/bin/cinterop.c Normal file
View file

@ -0,0 +1,64 @@
#include <stdbool.h>
#include <stdint.h>
#include <stdlib.h>
#include <string.h>
#include <stdio.h>
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);
}

43
hw3/driver.ml → hw3/bin/driver.ml
View file

@ -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

24
hw3/bin/dune Normal file
View file

@ -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))

11
hw3/main.ml → hw3/bin/main.ml
View file

@ -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] <files>\n\
"cs131 main test harness\n\
USAGE: ./oatc [options] <files>\n\
see README for details about using the compiler";
process_files !files

91
hw3/bin/timeout3 Normal file
View file

@ -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 <Dmitry.Golovashkin@sas.com>
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 <<EOF
Synopsis
$scriptName [-t timeout] [-i interval] [-d delay] command
Execute a command with a time-out.
Upon time-out expiration SIGTERM (15) is sent to the process. If SIGTERM
signal is blocked, then the subsequent SIGKILL (9) terminates it.
-t timeout
Number of seconds to wait for command completion.
Default value: $DEFAULT_TIMEOUT seconds.
-i interval
Interval between checks if the process is still alive.
Positive integer, default value: $DEFAULT_INTERVAL seconds.
-d delay
Delay between posting the SIGTERM signal and destroying the
process by SIGKILL. Default value: $DEFAULT_DELAY seconds.
As of today, Bash does not support floating point arithmetic (sleep does),
therefore all delay/time values must be integers.
EOF
}
# Options.
while getopts ":t:i:d:" option; do
case "$option" in
t) timeout=$OPTARG ;;
i) interval=$OPTARG ;;
d) delay=$OPTARG ;;
*) printUsage; exit 1 ;;
esac
done
shift $((OPTIND - 1))
# $# should be at least 1 (the command to execute), however it may be strictly
# greater than 1 if the command itself has options.
if (($# == 0 || interval <= 0)); then
printUsage
exit 1
fi
# kill -0 pid Exit code indicates if a signal may be sent to $pid process.
(
((t = timeout))
while ((t > 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 "$@"

32
hw3/cinterop.c
View file

@ -1,32 +0,0 @@
#include <stdint.h>
#include <stdlib.h>
#include <string.h>
#include <stdio.h>
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);
}

3
hw3/dune-project Normal file
View file

@ -0,0 +1,3 @@
(lang dune 2.9)
(name hw3)
(using menhir 2.1)

0
hw3/hw3.opam Normal file
View file

7
hw3/lib/ll/dune Normal file
View file

@ -0,0 +1,7 @@
(library
(name ll)
(modules ll llutil lllexer llparser llinterp)
(wrapped false))
(ocamllex lllexer)
(menhir (modules llparser))

81
hw3/lib/ll/ll-original.ml Normal file
View file

@ -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 *)
}

6
hw3/ll/ll.ml → hw3/lib/ll/ll.ml
View file

@ -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 }

42
hw3/ll/llinterp.ml → hw3/lib/ll/llinterp.ml
View file

@ -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;

9
hw3/ll/lllexer.mll → hw3/lib/ll/lllexer.mll
View file

@ -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 }

11
hw3/ll/llparser.mly → hw3/lib/ll/llparser.mly
View file

@ -56,6 +56,8 @@
%token ALLOCA (* alloca *)
%token BITCAST (* bitcast *)
%token GEP (* getelementptr *)
%token TARGET (* target *)
%token TRIPLE (* triple *)
%token <int> INT (* int64 values *)
%token <string> 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)) }

38
hw3/lib/ll/llruntime.c Normal file
View file

@ -0,0 +1,38 @@
#include <inttypes.h>
#include <stdlib.h>
#include <string.h>
#include <stdio.h>
/* 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);
}

60
hw3/ll/llutil.ml → hw3/lib/ll/llutil.ml
View file

@ -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}

17
hw3/util/assert.ml → hw3/lib/util/assert.ml
View file

@ -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

2
hw3/util/assert.mli → hw3/lib/util/assert.mli
View file

@ -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 *)

3
hw3/lib/util/dune Normal file
View file

@ -0,0 +1,3 @@
(library
(name util)
(libraries str unix))

39
hw3/util/platform.ml → hw3/lib/util/platform.ml
View file

@ -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

56
hw3/lib/util/range.ml Normal file
View file

@ -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)

53
hw3/lib/util/range.mli Normal file
View file

@ -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

3
hw3/lib/x86/dune Normal file
View file

@ -0,0 +1,3 @@
(library
(name x86)
(modules x86))

10
hw3/x86/x86.ml → hw3/lib/x86/x86.ml
View file

@ -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)

15
hw3/llprograms/c_weighted_sum.c Normal file
View file

@ -0,0 +1,15 @@
#include <inttypes.h>
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;
}

37
hw3/llprograms/example.ll Normal file
View file

@ -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
}

14
hw3/llprograms/funptr.ll Normal file
View file

@ -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
}

9
hw3/llprograms/printf1.ll Normal file
View file

@ -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
}

10
hw3/llprograms/printf2.ll Normal file
View file

@ -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
}

2
hw3/submit_zip_contents.txt Normal file
View file

@ -0,0 +1,2 @@
bin/backend.ml
test/studenttests.ml

18
hw3/test/dune Normal file
View file

@ -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))

35
hw3/gradedtests.ml → hw3/test/gradedtests.ml
View file

@ -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

6
hw3/studenttests.ml → hw3/test/studenttests.ml
View file

@ -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. *)

34
hw3/x86/testX86.ml
View file

@ -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)