Fixed version of hw2
Signed-off-by: jmug <u.g.a.mariano@gmail.com>
This commit is contained in:
parent
3308388106
commit
b8fc429f4d
25 changed files with 1983 additions and 1963 deletions
|
|
@ -4,32 +4,35 @@ FROM ubuntu:20.04
|
|||
|
||||
# Create a user
|
||||
|
||||
ARG USERNAME=cis3410
|
||||
ARG USERNAME=cs131
|
||||
ARG USER_UID=1000
|
||||
ARG USER_GID=$USER_UID
|
||||
|
||||
ENV TZ='Asia/Shanghai'
|
||||
# !!![zjy] apt change ustc source
|
||||
RUN apt-get update -y\
|
||||
RUN apt-get update -y \
|
||||
&& apt-get install -y --no-install-recommends \
|
||||
apt-transport-https \
|
||||
ca-certificates \
|
||||
dos2unix \
|
||||
tzdata \
|
||||
&& sed -i "s@http://.*.ubuntu.com@https://mirrors.ustc.edu.cn@g" /etc/apt/sources.list \
|
||||
&& rm -rf /var/apt/cache/*
|
||||
|
||||
RUN groupadd --gid $USER_GID $USERNAME \
|
||||
#
|
||||
# [Optional] Add sudo support. Omit if you don't need to install software after connecting.
|
||||
&& apt-get update -y \
|
||||
&& apt-get update \
|
||||
&& apt-get install -y sudo \
|
||||
&& echo $USERNAME ALL=\(root\) NOPASSWD:ALL > /etc/sudoers.d/$USERNAME \
|
||||
&& chmod 0440 /etc/sudoers.d/$USERNAME
|
||||
|
||||
|
||||
## Hack needs root permissions
|
||||
|
||||
# See hack.sh
|
||||
COPY hack.sh /tmp/hack.sh
|
||||
# windows compatibility
|
||||
RUN dos2unix /tmp/hack.sh
|
||||
RUN chmod +x /tmp/hack.sh
|
||||
RUN /tmp/hack.sh
|
||||
|
||||
|
|
@ -46,8 +49,10 @@ RUN apt-get install -y zsh
|
|||
# !!![zjy] install zsh first then set user
|
||||
RUN useradd --uid $USER_UID --gid $USER_GID -m $USERNAME --shell /bin/zsh
|
||||
|
||||
|
||||
## Set up user environmnent
|
||||
COPY .zshrc /home/$USERNAME/
|
||||
RUN dos2unix /home/$USERNAME/.zshrc
|
||||
RUN chown $USERNAME /home/$USERNAME/.zshrc
|
||||
|
||||
## Run in usermode
|
||||
|
|
@ -60,12 +65,13 @@ RUN touch /home/$USERNAME/.local/state/utop-history
|
|||
|
||||
# Configure opam/ocaml
|
||||
# !!![zjy] change default repo to github (SJTU repo is failed)
|
||||
RUN opam init --yes --disable-sandboxing default https://github.com/ocaml/opam-repository.git
|
||||
RUN opam switch create 4.14.1 ocaml-base-compiler.4.14.1
|
||||
# RUN opam init --yes --disable-sandboxing default https://github.com/ocaml/opam-repository.git
|
||||
RUN opam init -y --disable-sandboxing --compiler=4.14.1
|
||||
# RUN opam switch create 4.14.1 ocaml-base-compiler.4.14.1
|
||||
RUN opam switch 4.14.1
|
||||
RUN opam install -y dune
|
||||
RUN opam install -y num
|
||||
RUN opam install -y menhir
|
||||
RUN opam install --yes dune
|
||||
RUN opam install --yes num
|
||||
RUN opam install --yes menhir
|
||||
RUN opam install -y utop
|
||||
RUN opam install -y ocamlformat
|
||||
RUN opam install -y ocaml-lsp-server
|
||||
|
|
|
|||
|
|
@ -20,8 +20,7 @@
|
|||
"customizations": {
|
||||
"vscode": {
|
||||
"extensions": [
|
||||
"ocamllabs.ocaml-platform",
|
||||
"allanblanchard.ocp-indent"
|
||||
"ocamllabs.ocaml-platform"
|
||||
]
|
||||
}
|
||||
}
|
||||
|
|
|
|||
10
hw2/.gitignore
vendored
10
hw2/.gitignore
vendored
|
|
@ -1,6 +1,6 @@
|
|||
.vscode
|
||||
_build
|
||||
bin/main.exe
|
||||
oatc
|
||||
ocamlbin
|
||||
.vscode
|
||||
_build
|
||||
bin/main.exe
|
||||
oatc
|
||||
ocamlbin
|
||||
*~
|
||||
|
|
@ -1,2 +1,2 @@
|
|||
profile = janestreet
|
||||
version = 0.26.1
|
||||
profile = janestreet
|
||||
version = 0.26.2
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
#use "topfind";;
|
||||
#require "str";;
|
||||
#require "unix";;
|
||||
|
||||
#use_output "dune top"
|
||||
|
||||
#use "topfind";;
|
||||
#require "str";;
|
||||
#require "unix";;
|
||||
|
||||
#use_output "dune top"
|
||||
|
||||
|
|
|
|||
60
hw2/Makefile
60
hw2/Makefile
|
|
@ -1,30 +1,30 @@
|
|||
SUBMIT := $(shell cat submit_zip_contents.txt)
|
||||
HWNAME := hw2
|
||||
TIMESTAMP := $(shell /bin/date "+%Y-%m-%d-%H:%M:%S")
|
||||
ZIPNAME := $(HWNAME)-submit-$(TIMESTAMP).zip
|
||||
|
||||
.PHONY: all oatc test clean zip
|
||||
|
||||
all: oatc
|
||||
|
||||
dev:
|
||||
dune build --watch --terminal-persistence=clear-on-rebuild
|
||||
|
||||
oatc:
|
||||
dune build
|
||||
@cp bin/main.exe oatc
|
||||
|
||||
test: oatc
|
||||
./oatc --test
|
||||
|
||||
utop:
|
||||
utop
|
||||
|
||||
zip: $(SUBMIT)
|
||||
zip '$(ZIPNAME)' $(SUBMIT)
|
||||
|
||||
clean:
|
||||
dune clean
|
||||
rm -rf oatc ocamlbin bin/main.exe
|
||||
|
||||
#
|
||||
SUBMIT := $(shell cat submit_zip_contents.txt)
|
||||
HWNAME := hw2
|
||||
TIMESTAMP := $(shell /bin/date "+%Y-%m-%d-%H:%M:%S")
|
||||
ZIPNAME := $(HWNAME)-submit-$(TIMESTAMP).zip
|
||||
|
||||
.PHONY: all oatc test clean zip
|
||||
|
||||
all: oatc
|
||||
|
||||
dev:
|
||||
dune build --watch --terminal-persistence=clear-on-rebuild
|
||||
|
||||
oatc:
|
||||
dune build
|
||||
@cp bin/main.exe oatc
|
||||
|
||||
test: oatc
|
||||
./oatc --test
|
||||
|
||||
utop:
|
||||
utop
|
||||
|
||||
zip: $(SUBMIT)
|
||||
zip '$(ZIPNAME)' $(SUBMIT)
|
||||
|
||||
clean:
|
||||
dune clean
|
||||
rm -rf oatc ocamlbin bin/main.exe
|
||||
|
||||
#
|
||||
|
|
|
|||
|
|
@ -1,13 +1,13 @@
|
|||
# HW2: x86lite simulator
|
||||
|
||||
Quick Start:
|
||||
|
||||
1. clone this repository using `git clone`
|
||||
2. open the folder in VSCode (it will prompt you to "Reopen in dev container" -- do that)
|
||||
3. start an OCaml sandbox terminal
|
||||
4. run `make test` from the command line
|
||||
5. open `bin/simulator.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.
|
||||
|
||||
# HW2: x86lite simulator
|
||||
|
||||
Quick Start:
|
||||
|
||||
1. clone this repository using `git clone`
|
||||
2. open the folder in VSCode (it will prompt you to "Reopen in dev container" -- do that)
|
||||
3. start an OCaml sandbox terminal
|
||||
4. run `make test` from the command line
|
||||
5. open `bin/simulator.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.
|
||||
|
||||
|
|
|
|||
44
hw2/bin/dune
44
hw2/bin/dune
|
|
@ -1,22 +1,22 @@
|
|||
(library
|
||||
(name sim)
|
||||
(modules simulator int64_overflow)
|
||||
(libraries x86 num))
|
||||
|
||||
(env
|
||||
(dev
|
||||
(flags
|
||||
(:standard -g -w "+a-4-7-9-26-27-29-30-32..42-44-45-48-50-60-66..70"))))
|
||||
|
||||
(executable
|
||||
(public_name main)
|
||||
(name main)
|
||||
(modules main)
|
||||
(promote (until-clean))
|
||||
(libraries
|
||||
; OCaml standard libraries
|
||||
; project libraries
|
||||
util
|
||||
x86
|
||||
studenttests
|
||||
gradedtests))
|
||||
(library
|
||||
(name sim)
|
||||
(modules simulator int64_overflow)
|
||||
(libraries x86 num))
|
||||
|
||||
(env
|
||||
(dev
|
||||
(flags
|
||||
(:standard -g -w "+a-4-7-9-26-27-29-30-32..42-44-45-48-50-60-66..70"))))
|
||||
|
||||
(executable
|
||||
(public_name main)
|
||||
(name main)
|
||||
(modules main)
|
||||
(promote (until-clean))
|
||||
(libraries
|
||||
; OCaml standard libraries
|
||||
; project libraries
|
||||
util
|
||||
x86
|
||||
studenttests
|
||||
gradedtests))
|
||||
|
|
|
|||
|
|
@ -1,27 +1,27 @@
|
|||
open Big_int
|
||||
type t = { value : int64; overflow : bool }
|
||||
|
||||
let ok i = { value = i; overflow = false }
|
||||
|
||||
exception Overflow
|
||||
|
||||
let with_overflow1 g f i =
|
||||
let res = f i in
|
||||
{ value = res
|
||||
; overflow = not @@ eq_big_int (big_int_of_int64 res) (g @@ big_int_of_int64 i)
|
||||
}
|
||||
|
||||
let with_overflow2 g f i j =
|
||||
let res = f i j in
|
||||
{ value = res
|
||||
; overflow = not @@ eq_big_int (big_int_of_int64 res)
|
||||
(g (big_int_of_int64 i) (big_int_of_int64 j))
|
||||
}
|
||||
|
||||
let neg = with_overflow1 minus_big_int Int64.neg
|
||||
let succ = with_overflow1 succ_big_int Int64.succ
|
||||
let pred = with_overflow1 pred_big_int Int64.pred
|
||||
|
||||
let add = with_overflow2 add_big_int Int64.add
|
||||
let sub = with_overflow2 sub_big_int Int64.sub
|
||||
open Big_int
|
||||
type t = { value : int64; overflow : bool }
|
||||
|
||||
let ok i = { value = i; overflow = false }
|
||||
|
||||
exception Overflow
|
||||
|
||||
let with_overflow1 g f i =
|
||||
let res = f i in
|
||||
{ value = res
|
||||
; overflow = not @@ eq_big_int (big_int_of_int64 res) (g @@ big_int_of_int64 i)
|
||||
}
|
||||
|
||||
let with_overflow2 g f i j =
|
||||
let res = f i j in
|
||||
{ value = res
|
||||
; overflow = not @@ eq_big_int (big_int_of_int64 res)
|
||||
(g (big_int_of_int64 i) (big_int_of_int64 j))
|
||||
}
|
||||
|
||||
let neg = with_overflow1 minus_big_int Int64.neg
|
||||
let succ = with_overflow1 succ_big_int Int64.succ
|
||||
let pred = with_overflow1 pred_big_int Int64.pred
|
||||
|
||||
let add = with_overflow2 add_big_int Int64.add
|
||||
let sub = with_overflow2 sub_big_int Int64.sub
|
||||
let mul = with_overflow2 mult_big_int Int64.mul
|
||||
|
|
@ -1,13 +1,13 @@
|
|||
exception Overflow
|
||||
|
||||
type t = { value : int64; overflow : bool }
|
||||
|
||||
val ok : int64 -> t
|
||||
|
||||
val neg : int64 -> t
|
||||
val succ : int64 -> t
|
||||
val pred : int64 -> t
|
||||
|
||||
val add : int64 -> int64 -> t
|
||||
val sub : int64 -> int64 -> t
|
||||
exception Overflow
|
||||
|
||||
type t = { value : int64; overflow : bool }
|
||||
|
||||
val ok : int64 -> t
|
||||
|
||||
val neg : int64 -> t
|
||||
val succ : int64 -> t
|
||||
val pred : int64 -> t
|
||||
|
||||
val add : int64 -> int64 -> t
|
||||
val sub : int64 -> int64 -> t
|
||||
val mul : int64 -> int64 -> t
|
||||
|
|
@ -1,31 +1,31 @@
|
|||
open Util.Assert
|
||||
open Arg
|
||||
open X86
|
||||
open Sim.Simulator
|
||||
|
||||
exception Ran_tests
|
||||
let worklist = ref []
|
||||
|
||||
let suite = ref (timeout_suite 5 (Studenttests.provided_tests @ Gradedtests.graded_tests))
|
||||
|
||||
let exec_tests () =
|
||||
let o = run_suite !suite in
|
||||
Printf.printf "%s\n" (outcome_to_string o);
|
||||
raise Ran_tests
|
||||
|
||||
let do_one_file fn =
|
||||
let _ = Printf.printf "Processing: %s\n" fn in ()
|
||||
|
||||
(* Use the --test option to run unit tests and the quit the program. *)
|
||||
let argspec = [
|
||||
("--test", Unit exec_tests, "run the test suite, ignoring other inputs");
|
||||
]
|
||||
|
||||
let _ =
|
||||
try
|
||||
Arg.parse argspec (fun f -> worklist := f :: !worklist)
|
||||
"CIS341 main test harness \n";
|
||||
match !worklist with
|
||||
| [] -> print_endline "* Nothing to do"
|
||||
| _ -> List.iter do_one_file !worklist
|
||||
with Ran_tests -> ()
|
||||
open Util.Assert
|
||||
open Arg
|
||||
open X86
|
||||
open Sim.Simulator
|
||||
|
||||
exception Ran_tests
|
||||
let worklist = ref []
|
||||
|
||||
let suite = ref (timeout_suite 5 (Studenttests.provided_tests @ Gradedtests.graded_tests))
|
||||
|
||||
let exec_tests () =
|
||||
let o = run_suite !suite in
|
||||
Printf.printf "%s\n" (outcome_to_string o);
|
||||
raise Ran_tests
|
||||
|
||||
let do_one_file fn =
|
||||
let _ = Printf.printf "Processing: %s\n" fn in ()
|
||||
|
||||
(* Use the --test option to run unit tests and the quit the program. *)
|
||||
let argspec = [
|
||||
("--test", Unit exec_tests, "run the test suite, ignoring other inputs");
|
||||
]
|
||||
|
||||
let _ =
|
||||
try
|
||||
Arg.parse argspec (fun f -> worklist := f :: !worklist)
|
||||
"CIS341 main test harness \n";
|
||||
match !worklist with
|
||||
| [] -> print_endline "* Nothing to do"
|
||||
| _ -> List.iter do_one_file !worklist
|
||||
with Ran_tests -> ()
|
||||
|
|
|
|||
|
|
@ -1,304 +1,319 @@
|
|||
(* X86lite Simulator *)
|
||||
|
||||
(* See the documentation in the X86lite specification, available on the
|
||||
course web pages, for a detailed explanation of the instruction
|
||||
semantics.
|
||||
*)
|
||||
|
||||
open X86
|
||||
|
||||
(* simulator machine state -------------------------------------------------- *)
|
||||
|
||||
let mem_bot = 0x400000L (* lowest valid address *)
|
||||
let mem_top = 0x410000L (* one past the last byte in memory *)
|
||||
let mem_size = Int64.to_int (Int64.sub mem_top mem_bot)
|
||||
let nregs = 17 (* including Rip *)
|
||||
let ins_size = 8L (* assume we have a 8-byte encoding *)
|
||||
let exit_addr = 0xfdeadL (* halt when m.regs(%rip) = exit_addr *)
|
||||
|
||||
(* The simulator memory maps addresses to symbolic bytes. Symbolic
|
||||
bytes are either actual data indicated by the Byte constructor or
|
||||
'symbolic instructions' that take up eight bytes for the purposes of
|
||||
layout.
|
||||
|
||||
The symbolic bytes abstract away from the details of how
|
||||
instructions are represented in memory. Each instruction takes
|
||||
exactly eight consecutive bytes, where the first byte InsB0 stores
|
||||
the actual instruction, and the next sevent bytes are InsFrag
|
||||
elements, which aren't valid data.
|
||||
|
||||
For example, the two-instruction sequence:
|
||||
at&t syntax ocaml syntax
|
||||
movq %rdi, (%rsp) Movq, [~%Rdi; Ind2 Rsp]
|
||||
decq %rdi Decq, [~%Rdi]
|
||||
|
||||
is represented by the following elements of the mem array (starting
|
||||
at address 0x400000):
|
||||
|
||||
0x400000 : InsB0 (Movq, [~%Rdi; Ind2 Rsp])
|
||||
0x400001 : InsFrag
|
||||
0x400002 : InsFrag
|
||||
0x400003 : InsFrag
|
||||
0x400004 : InsFrag
|
||||
0x400005 : InsFrag
|
||||
0x400006 : InsFrag
|
||||
0x400007 : InsFrag
|
||||
0x400008 : InsB0 (Decq, [~%Rdi])
|
||||
0x40000A : InsFrag
|
||||
0x40000B : InsFrag
|
||||
0x40000C : InsFrag
|
||||
0x40000D : InsFrag
|
||||
0x40000E : InsFrag
|
||||
0x40000F : InsFrag
|
||||
0x400010 : InsFrag
|
||||
*)
|
||||
type sbyte = InsB0 of ins (* 1st byte of an instruction *)
|
||||
| InsFrag (* 2nd - 8th bytes of an instruction *)
|
||||
| Byte of char (* non-instruction byte *)
|
||||
|
||||
(* memory maps addresses to symbolic bytes *)
|
||||
type mem = sbyte array
|
||||
|
||||
(* Flags for condition codes *)
|
||||
type flags = { mutable fo : bool
|
||||
; mutable fs : bool
|
||||
; mutable fz : bool
|
||||
}
|
||||
|
||||
(* Register files *)
|
||||
type regs = int64 array
|
||||
|
||||
(* Complete machine state *)
|
||||
type mach = { flags : flags
|
||||
; regs : regs
|
||||
; mem : mem
|
||||
}
|
||||
|
||||
(* simulator helper functions ----------------------------------------------- *)
|
||||
|
||||
(* The index of a register in the regs array *)
|
||||
let rind : reg -> int = function
|
||||
| Rip -> 16
|
||||
| Rax -> 0 | Rbx -> 1 | Rcx -> 2 | Rdx -> 3
|
||||
| Rsi -> 4 | Rdi -> 5 | Rbp -> 6 | Rsp -> 7
|
||||
| R08 -> 8 | R09 -> 9 | R10 -> 10 | R11 -> 11
|
||||
| R12 -> 12 | R13 -> 13 | R14 -> 14 | R15 -> 15
|
||||
|
||||
(* Helper functions for reading/writing sbytes *)
|
||||
|
||||
(* Convert an int64 to its sbyte representation *)
|
||||
let sbytes_of_int64 (i:int64) : sbyte list =
|
||||
let open Char in
|
||||
let open Int64 in
|
||||
List.map (fun n -> Byte (shift_right i n |> logand 0xffL |> to_int |> chr))
|
||||
[0; 8; 16; 24; 32; 40; 48; 56]
|
||||
|
||||
(* Convert an sbyte representation to an int64 *)
|
||||
let int64_of_sbytes (bs:sbyte list) : int64 =
|
||||
let open Char in
|
||||
let open Int64 in
|
||||
let f b i = match b with
|
||||
| Byte c -> logor (shift_left i 8) (c |> code |> of_int)
|
||||
| _ -> 0L
|
||||
in
|
||||
List.fold_right f bs 0L
|
||||
|
||||
(* Convert a string to its sbyte representation *)
|
||||
let sbytes_of_string (s:string) : sbyte list =
|
||||
let rec loop acc = function
|
||||
| i when i < 0 -> acc
|
||||
| i -> loop (Byte s.[i]::acc) (pred i)
|
||||
in
|
||||
loop [Byte '\x00'] @@ String.length s - 1
|
||||
|
||||
(* Serialize an instruction to sbytes *)
|
||||
let sbytes_of_ins (op, args:ins) : sbyte list =
|
||||
let check = function
|
||||
| Imm (Lbl _) | Ind1 (Lbl _) | Ind3 (Lbl _, _) ->
|
||||
invalid_arg "sbytes_of_ins: tried to serialize a label!"
|
||||
| _ -> ()
|
||||
in
|
||||
List.iter check args;
|
||||
[InsB0 (op, args); InsFrag; InsFrag; InsFrag;
|
||||
InsFrag; InsFrag; InsFrag; InsFrag]
|
||||
|
||||
(* Serialize a data element to sbytes *)
|
||||
let sbytes_of_data : data -> sbyte list = function
|
||||
| Quad (Lit i) -> sbytes_of_int64 i
|
||||
| Asciz s -> sbytes_of_string s
|
||||
| Quad (Lbl _) -> invalid_arg "sbytes_of_data: tried to serialize a label!"
|
||||
|
||||
|
||||
(* It might be useful to toggle printing of intermediate states of your
|
||||
simulator. Our implementation uses this mutable flag to turn on/off
|
||||
printing. For instance, you might write something like:
|
||||
|
||||
[if !debug_simulator then print_endline @@ string_of_ins u; ...]
|
||||
|
||||
*)
|
||||
let debug_simulator = ref false
|
||||
|
||||
|
||||
(* override some useful operators *)
|
||||
let ( +. ) = Int64.add
|
||||
let ( -. ) = Int64.sub
|
||||
let ( *. ) = Int64.mul
|
||||
let ( <. ) a b = (Int64.compare a b) < 0
|
||||
let ( >. ) a b = (Int64.compare a b) > 0
|
||||
let ( <=. ) a b = (Int64.compare a b) <= 0
|
||||
let ( >=. ) a b = (Int64.compare a b) >= 0
|
||||
|
||||
(* Interpret a condition code with respect to the given flags. *)
|
||||
(* !!! Check the Specification for Help *)
|
||||
let interp_cnd {fo; fs; fz} : cnd -> bool = fun x -> failwith "interp_cnd unimplemented"
|
||||
|
||||
|
||||
(* Maps an X86lite address into Some OCaml array index,
|
||||
or None if the address is not within the legal address space. *)
|
||||
let map_addr (addr:quad) : int option =
|
||||
failwith "map_addr not implemented"
|
||||
|
||||
(* Your simulator should raise this exception if it tries to read from or
|
||||
store to an address not within the valid address space. *)
|
||||
exception X86lite_segfault
|
||||
|
||||
(* Raise X86lite_segfault when addr is invalid. *)
|
||||
let map_addr_segfault (addr:quad) : int =
|
||||
failwith "map_addr_segfault not implemented"
|
||||
|
||||
(* Simulates one step of the machine:
|
||||
- fetch the instruction at %rip
|
||||
- compute the source and/or destination information from the operands
|
||||
- simulate the instruction semantics
|
||||
- update the registers and/or memory appropriately
|
||||
- set the condition flags
|
||||
|
||||
We provide the basic structure of step function and helper functions.
|
||||
Implement the subroutine below to complete the step function.
|
||||
See step function to understand each subroutine and how they
|
||||
are glued together.
|
||||
*)
|
||||
|
||||
let readquad (m:mach) (addr:quad) : quad =
|
||||
failwith "readquad not implemented"
|
||||
|
||||
|
||||
let writequad (m:mach) (addr:quad) (w:quad) : unit =
|
||||
failwith "writequad not implemented"
|
||||
|
||||
let fetchins (m:mach) (addr:quad) : ins =
|
||||
failwith "fetchins not implemented"
|
||||
|
||||
(* Compute the instruction result.
|
||||
* NOTE: See int64_overflow.ml for the definition of the return type
|
||||
* Int64_overflow.t. *)
|
||||
let interp_opcode (m: mach) (o:opcode) (args:int64 list) : Int64_overflow.t =
|
||||
let open Int64 in
|
||||
let open Int64_overflow in
|
||||
match o, args with
|
||||
| _ -> failwith "interp_opcode not implemented"
|
||||
|
||||
(** Update machine state with instruction results. *)
|
||||
let ins_writeback (m: mach) : ins -> int64 -> unit =
|
||||
failwith "ins_writeback not implemented"
|
||||
|
||||
|
||||
(* mem addr ---> mem array index *)
|
||||
let interp_operands (m:mach) : ins -> int64 list =
|
||||
failwith "interp_operands not implemented"
|
||||
|
||||
let validate_operands : ins -> unit = function
|
||||
| _ -> failwith "validate_operands not implemented"
|
||||
|
||||
|
||||
let crack : ins -> ins list = function
|
||||
| _ -> failwith "crack not implemented"
|
||||
|
||||
|
||||
(* TODO: double check against spec *)
|
||||
let set_flags (m:mach) (op:opcode) (ws: quad list) (w : Int64_overflow.t) : unit =
|
||||
failwith "set_flags not implemented"
|
||||
|
||||
let step (m:mach) : unit =
|
||||
(* execute an instruction *)
|
||||
let (op, args) as ins = fetchins m m.regs.(rind Rip) in
|
||||
validate_operands ins;
|
||||
|
||||
(* Some instructions involve running two or more basic instructions.
|
||||
* For other instructions, just return a list of one instruction.
|
||||
* See the X86lite specification for details. *)
|
||||
let uops: ins list = crack (op,args) in
|
||||
|
||||
m.regs.(rind Rip) <- m.regs.(rind Rip) +. ins_size;
|
||||
|
||||
List.iter
|
||||
(fun (uop,_ as u) ->
|
||||
if !debug_simulator then print_endline @@ string_of_ins u;
|
||||
let ws = interp_operands m u in
|
||||
let res = interp_opcode m uop ws in
|
||||
ins_writeback m u @@ res.Int64_overflow.value;
|
||||
set_flags m op ws res
|
||||
) uops
|
||||
|
||||
(* Runs the machine until the rip register reaches a designated
|
||||
memory address. Returns the contents of %rax when the
|
||||
machine halts. *)
|
||||
let run (m:mach) : int64 =
|
||||
while m.regs.(rind Rip) <> exit_addr do step m done;
|
||||
m.regs.(rind Rax)
|
||||
|
||||
(* assembling and linking --------------------------------------------------- *)
|
||||
|
||||
(* A representation of the executable *)
|
||||
type exec = { entry : quad (* address of the entry point *)
|
||||
; text_pos : quad (* starting address of the code *)
|
||||
; data_pos : quad (* starting address of the data *)
|
||||
; text_seg : sbyte list (* contents of the text segment *)
|
||||
; data_seg : sbyte list (* contents of the data segment *)
|
||||
}
|
||||
|
||||
(* Assemble should raise this when a label is used but not defined *)
|
||||
exception Undefined_sym of lbl
|
||||
|
||||
(* Assemble should raise this when a label is defined more than once *)
|
||||
exception Redefined_sym of lbl
|
||||
|
||||
(* Convert an X86 program into an object file:
|
||||
- separate the text and data segments
|
||||
- compute the size of each segment
|
||||
Note: the size of an Asciz string section is (1 + the string length)
|
||||
due to the null terminator
|
||||
|
||||
- resolve the labels to concrete addresses and 'patch' the instructions to
|
||||
replace Lbl values with the corresponding Imm values.
|
||||
HINT: consider building a mapping from symboli Lbl to memory address
|
||||
|
||||
- the text segment starts at the lowest address
|
||||
- the data segment starts after the text segment
|
||||
|
||||
HINT: List.fold_left and List.fold_right are your friends.
|
||||
*)
|
||||
let is_size (is: ins list): quad =
|
||||
failwith "is_size not implemented"
|
||||
|
||||
let ds_size (ds: data list): quad =
|
||||
failwith "ds_size not implemented"
|
||||
|
||||
let assemble (p:prog) : exec =
|
||||
failwith "assemble unimplemented"
|
||||
|
||||
(* Convert an object file into an executable machine state.
|
||||
- allocate the mem array
|
||||
- set up the memory state by writing the symbolic bytes to the
|
||||
appropriate locations
|
||||
- create the inital register state
|
||||
- initialize rip to the entry point address
|
||||
- initializes rsp to the last word in memory
|
||||
- the other registers are initialized to 0
|
||||
- the condition code flags start as 'false'
|
||||
|
||||
Hint: The Array.make, Array.blit, and Array.of_list library functions
|
||||
may be of use.
|
||||
*)
|
||||
let load {entry; text_pos; data_pos; text_seg; data_seg} : mach =
|
||||
failwith "load not implemented"
|
||||
(* X86lite Simulator *)
|
||||
|
||||
(* See the documentation in the X86lite specification, available on the
|
||||
course web pages, for a detailed explanation of the instruction
|
||||
semantics.
|
||||
*)
|
||||
|
||||
open X86
|
||||
|
||||
(* simulator machine state -------------------------------------------------- *)
|
||||
|
||||
let mem_bot = 0x400000L (* lowest valid address *)
|
||||
let mem_top = 0x410000L (* one past the last byte in memory *)
|
||||
let mem_size = Int64.to_int (Int64.sub mem_top mem_bot)
|
||||
let nregs = 17 (* including Rip *)
|
||||
let ins_size = 8L (* assume we have a 8-byte encoding *)
|
||||
let exit_addr = 0xfdeadL (* halt when m.regs(%rip) = exit_addr *)
|
||||
|
||||
(* The simulator memory maps addresses to symbolic bytes. Symbolic
|
||||
bytes are either actual data indicated by the Byte constructor or
|
||||
'symbolic instructions' that take up eight bytes for the purposes of
|
||||
layout.
|
||||
|
||||
The symbolic bytes abstract away from the details of how
|
||||
instructions are represented in memory. Each instruction takes
|
||||
exactly eight consecutive bytes, where the first byte InsB0 stores
|
||||
the actual instruction, and the next sevent bytes are InsFrag
|
||||
elements, which aren't valid data.
|
||||
|
||||
For example, the two-instruction sequence:
|
||||
at&t syntax ocaml syntax
|
||||
movq %rdi, (%rsp) Movq, [~%Rdi; Ind2 Rsp]
|
||||
decq %rdi Decq, [~%Rdi]
|
||||
|
||||
is represented by the following elements of the mem array (starting
|
||||
at address 0x400000):
|
||||
|
||||
0x400000 : InsB0 (Movq, [~%Rdi; Ind2 Rsp])
|
||||
0x400001 : InsFrag
|
||||
0x400002 : InsFrag
|
||||
0x400003 : InsFrag
|
||||
0x400004 : InsFrag
|
||||
0x400005 : InsFrag
|
||||
0x400006 : InsFrag
|
||||
0x400007 : InsFrag
|
||||
0x400008 : InsB0 (Decq, [~%Rdi])
|
||||
0x40000A : InsFrag
|
||||
0x40000B : InsFrag
|
||||
0x40000C : InsFrag
|
||||
0x40000D : InsFrag
|
||||
0x40000E : InsFrag
|
||||
0x40000F : InsFrag
|
||||
0x400010 : InsFrag
|
||||
*)
|
||||
type sbyte =
|
||||
| InsB0 of ins (* 1st byte of an instruction *)
|
||||
| InsFrag (* 2nd - 8th bytes of an instruction *)
|
||||
| Byte of char (* non-instruction byte *)
|
||||
|
||||
(* memory maps addresses to symbolic bytes *)
|
||||
type mem = sbyte array
|
||||
|
||||
(* Flags for condition codes *)
|
||||
type flags =
|
||||
{ mutable fo : bool
|
||||
; mutable fs : bool
|
||||
; mutable fz : bool
|
||||
}
|
||||
|
||||
(* Register files *)
|
||||
type regs = int64 array
|
||||
|
||||
(* Complete machine state *)
|
||||
type mach =
|
||||
{ flags : flags
|
||||
; regs : regs
|
||||
; mem : mem
|
||||
}
|
||||
|
||||
(* simulator helper functions ----------------------------------------------- *)
|
||||
|
||||
(* The index of a register in the regs array *)
|
||||
let rind : reg -> int = function
|
||||
| Rip -> 16
|
||||
| Rax -> 0
|
||||
| Rbx -> 1
|
||||
| Rcx -> 2
|
||||
| Rdx -> 3
|
||||
| Rsi -> 4
|
||||
| Rdi -> 5
|
||||
| Rbp -> 6
|
||||
| Rsp -> 7
|
||||
| R08 -> 8
|
||||
| R09 -> 9
|
||||
| R10 -> 10
|
||||
| R11 -> 11
|
||||
| R12 -> 12
|
||||
| R13 -> 13
|
||||
| R14 -> 14
|
||||
| R15 -> 15
|
||||
;;
|
||||
|
||||
(* Helper functions for reading/writing sbytes *)
|
||||
|
||||
(* Convert an int64 to its sbyte representation *)
|
||||
let sbytes_of_int64 (i : int64) : sbyte list =
|
||||
let open Char in
|
||||
let open Int64 in
|
||||
List.map
|
||||
(fun n -> Byte (shift_right i n |> logand 0xffL |> to_int |> chr))
|
||||
[ 0; 8; 16; 24; 32; 40; 48; 56 ]
|
||||
;;
|
||||
|
||||
(* Convert an sbyte representation to an int64 *)
|
||||
let int64_of_sbytes (bs : sbyte list) : int64 =
|
||||
let open Char in
|
||||
let open Int64 in
|
||||
let f b i =
|
||||
match b with
|
||||
| Byte c -> logor (shift_left i 8) (c |> code |> of_int)
|
||||
| _ -> 0L
|
||||
in
|
||||
List.fold_right f bs 0L
|
||||
;;
|
||||
|
||||
(* Convert a string to its sbyte representation *)
|
||||
let sbytes_of_string (s : string) : sbyte list =
|
||||
let rec loop acc = function
|
||||
| i when i < 0 -> acc
|
||||
| i -> loop (Byte s.[i] :: acc) (pred i)
|
||||
in
|
||||
loop [ Byte '\x00' ] @@ (String.length s - 1)
|
||||
;;
|
||||
|
||||
(* Serialize an instruction to sbytes *)
|
||||
let sbytes_of_ins ((op, args) : ins) : sbyte list =
|
||||
let check = function
|
||||
| Imm (Lbl _) | Ind1 (Lbl _) | Ind3 (Lbl _, _) ->
|
||||
invalid_arg "sbytes_of_ins: tried to serialize a label!"
|
||||
| _ -> ()
|
||||
in
|
||||
List.iter check args;
|
||||
[ InsB0 (op, args); InsFrag; InsFrag; InsFrag; InsFrag; InsFrag; InsFrag; InsFrag ]
|
||||
;;
|
||||
|
||||
(* Serialize a data element to sbytes *)
|
||||
let sbytes_of_data : data -> sbyte list = function
|
||||
| Quad (Lit i) -> sbytes_of_int64 i
|
||||
| Asciz s -> sbytes_of_string s
|
||||
| Quad (Lbl _) -> invalid_arg "sbytes_of_data: tried to serialize a label!"
|
||||
;;
|
||||
|
||||
(* It might be useful to toggle printing of intermediate states of your
|
||||
simulator. Our implementation uses this mutable flag to turn on/off
|
||||
printing. For instance, you might write something like:
|
||||
|
||||
[if !debug_simulator then print_endline @@ string_of_ins u; ...]
|
||||
*)
|
||||
let debug_simulator = ref false
|
||||
|
||||
(* override some useful operators *)
|
||||
let ( +. ) = Int64.add
|
||||
let ( -. ) = Int64.sub
|
||||
let ( *. ) = Int64.mul
|
||||
let ( <. ) a b = Int64.compare a b < 0
|
||||
let ( >. ) a b = Int64.compare a b > 0
|
||||
let ( <=. ) a b = Int64.compare a b <= 0
|
||||
let ( >=. ) a b = Int64.compare a b >= 0
|
||||
|
||||
(* Interpret a condition code with respect to the given flags. *)
|
||||
(* !!! Check the Specification for Help *)
|
||||
let interp_cnd { fo; fs; fz } : cnd -> bool = fun x -> failwith "interp_cnd unimplemented"
|
||||
|
||||
(* Maps an X86lite address into Some OCaml array index,
|
||||
or None if the address is not within the legal address space. *)
|
||||
let map_addr (addr : quad) : int option = failwith "map_addr not implemented"
|
||||
|
||||
(* Your simulator should raise this exception if it tries to read from or
|
||||
store to an address not within the valid address space. *)
|
||||
exception X86lite_segfault
|
||||
|
||||
(* Raise X86lite_segfault when addr is invalid. *)
|
||||
let map_addr_segfault (addr : quad) : int = failwith "map_addr_segfault not implemented"
|
||||
|
||||
(* Simulates one step of the machine:
|
||||
- fetch the instruction at %rip
|
||||
- compute the source and/or destination information from the operands
|
||||
- simulate the instruction semantics
|
||||
- update the registers and/or memory appropriately
|
||||
- set the condition flags
|
||||
|
||||
We provide the basic structure of step function and helper functions.
|
||||
Implement the subroutine below to complete the step function.
|
||||
See step function to understand each subroutine and how they
|
||||
are glued together.
|
||||
*)
|
||||
|
||||
let readquad (m : mach) (addr : quad) : quad = failwith "readquad not implemented"
|
||||
|
||||
let writequad (m : mach) (addr : quad) (w : quad) : unit =
|
||||
failwith "writequad not implemented"
|
||||
;;
|
||||
|
||||
let fetchins (m : mach) (addr : quad) : ins = failwith "fetchins not implemented"
|
||||
|
||||
(* Compute the instruction result.
|
||||
* NOTE: See int64_overflow.ml for the definition of the return type
|
||||
* Int64_overflow.t. *)
|
||||
let interp_opcode (m : mach) (o : opcode) (args : int64 list) : Int64_overflow.t =
|
||||
let open Int64 in
|
||||
let open Int64_overflow in
|
||||
match o, args with
|
||||
| _ -> failwith "interp_opcode not implemented"
|
||||
;;
|
||||
|
||||
(** Update machine state with instruction results. *)
|
||||
let ins_writeback (m : mach) : ins -> int64 -> unit =
|
||||
failwith "ins_writeback not implemented"
|
||||
;;
|
||||
|
||||
(* mem addr ---> mem array index *)
|
||||
let interp_operands (m : mach) : ins -> int64 list =
|
||||
failwith "interp_operands not implemented"
|
||||
;;
|
||||
|
||||
let validate_operands : ins -> unit = function
|
||||
| _ -> failwith "validate_operands not implemented"
|
||||
;;
|
||||
|
||||
let crack : ins -> ins list = function
|
||||
| _ -> failwith "crack not implemented"
|
||||
;;
|
||||
|
||||
(* TODO: double check against spec *)
|
||||
let set_flags (m : mach) (op : opcode) (ws : quad list) (w : Int64_overflow.t) : unit =
|
||||
failwith "set_flags not implemented"
|
||||
;;
|
||||
|
||||
let step (m : mach) : unit =
|
||||
(* execute an instruction *)
|
||||
let ((op, args) as ins) = fetchins m m.regs.(rind Rip) in
|
||||
validate_operands ins;
|
||||
(* Some instructions involve running two or more basic instructions.
|
||||
* For other instructions, just return a list of one instruction.
|
||||
* See the X86lite specification for details. *)
|
||||
let uops : ins list = crack (op, args) in
|
||||
m.regs.(rind Rip) <- m.regs.(rind Rip) +. ins_size;
|
||||
List.iter
|
||||
(fun ((uop, _) as u) ->
|
||||
if !debug_simulator then print_endline @@ string_of_ins u;
|
||||
let ws = interp_operands m u in
|
||||
let res = interp_opcode m uop ws in
|
||||
ins_writeback m u @@ res.Int64_overflow.value;
|
||||
set_flags m op ws res)
|
||||
uops
|
||||
;;
|
||||
|
||||
(* Runs the machine until the rip register reaches a designated
|
||||
memory address. Returns the contents of %rax when the
|
||||
machine halts. *)
|
||||
let run (m : mach) : int64 =
|
||||
while m.regs.(rind Rip) <> exit_addr do
|
||||
step m
|
||||
done;
|
||||
m.regs.(rind Rax)
|
||||
;;
|
||||
|
||||
(* assembling and linking --------------------------------------------------- *)
|
||||
|
||||
(* A representation of the executable *)
|
||||
type exec =
|
||||
{ entry : quad (* address of the entry point *)
|
||||
; text_pos : quad (* starting address of the code *)
|
||||
; data_pos : quad (* starting address of the data *)
|
||||
; text_seg : sbyte list (* contents of the text segment *)
|
||||
; data_seg : sbyte list (* contents of the data segment *)
|
||||
}
|
||||
|
||||
(* Assemble should raise this when a label is used but not defined *)
|
||||
exception Undefined_sym of lbl
|
||||
|
||||
(* Assemble should raise this when a label is defined more than once *)
|
||||
exception Redefined_sym of lbl
|
||||
|
||||
(* Convert an X86 program into an object file:
|
||||
- separate the text and data segments
|
||||
- compute the size of each segment
|
||||
Note: the size of an Asciz string section is (1 + the string length)
|
||||
due to the null terminator
|
||||
|
||||
- resolve the labels to concrete addresses and 'patch' the instructions to
|
||||
replace Lbl values with the corresponding Imm values.
|
||||
HINT: consider building a mapping from symboli Lbl to memory address
|
||||
|
||||
- the text segment starts at the lowest address
|
||||
- the data segment starts after the text segment
|
||||
|
||||
HINT: List.fold_left and List.fold_right are your friends.
|
||||
*)
|
||||
let is_size (is : ins list) : quad = failwith "is_size not implemented"
|
||||
let ds_size (ds : data list) : quad = failwith "ds_size not implemented"
|
||||
let assemble (p : prog) : exec = failwith "assemble unimplemented"
|
||||
|
||||
(* Convert an object file into an executable machine state.
|
||||
- allocate the mem array
|
||||
- set up the memory state by writing the symbolic bytes to the
|
||||
appropriate locations
|
||||
- create the inital register state
|
||||
- initialize rip to the entry point address
|
||||
- initializes rsp to the last word in memory
|
||||
- the other registers are initialized to 0
|
||||
- the condition code flags start as 'false'
|
||||
|
||||
Hint: The Array.make, Array.blit, and Array.of_list library functions
|
||||
may be of use.
|
||||
*)
|
||||
let load { entry; text_pos; data_pos; text_seg; data_seg } : mach =
|
||||
failwith "load not implemented"
|
||||
;;
|
||||
|
|
|
|||
|
|
@ -1,2 +1,2 @@
|
|||
(lang dune 3.0)
|
||||
(name hw2)
|
||||
(lang dune 3.0)
|
||||
(name hw2)
|
||||
|
|
|
|||
|
|
@ -1,195 +1,195 @@
|
|||
(* CIS341 Assertion Testing and Grading Infrastructure *)
|
||||
(* Author: Steve Zdancewic *)
|
||||
|
||||
(* Do NOT modify this file -- we will overwrite it *)
|
||||
(* with our own version when testing your code. *)
|
||||
|
||||
(* An assertion is just a unit->unit function that either *)
|
||||
(* succeeds silently or throws an Failure exception. *)
|
||||
type assertion = unit -> unit
|
||||
|
||||
type 'a test =
|
||||
| GradedTest of string * int * (string * 'a) list
|
||||
| Test of string * (string * 'a) list
|
||||
|
||||
type suite = assertion test list
|
||||
|
||||
(**************)
|
||||
(* Assertions *)
|
||||
|
||||
let assert_eq v1 v2 : assertion =
|
||||
fun () -> if v1 <> v2 then failwith "not equal" else ()
|
||||
|
||||
|
||||
let assert_eqf f v2 : assertion =
|
||||
fun () -> if f () <> v2 then failwith "not equal" else ()
|
||||
|
||||
|
||||
let assert_eqfs f v2 : assertion =
|
||||
fun () ->
|
||||
let s1 = f () in
|
||||
if s1 <> v2
|
||||
then failwith @@ Printf.sprintf "not equal\n\texpected:%s\n\tgot:%s\n" v2 s1
|
||||
else ()
|
||||
|
||||
|
||||
let assert_fail : assertion = fun () -> failwith "assert fail"
|
||||
|
||||
exception Timeout
|
||||
|
||||
let timeout_assert (time : int) (a : assertion) : assertion =
|
||||
fun () ->
|
||||
let handler = Sys.Signal_handle (fun _ -> raise Timeout) in
|
||||
let old = Sys.signal Sys.sigalrm handler in
|
||||
let reset_sigalrm () = Sys.set_signal Sys.sigalrm old in
|
||||
ignore (Unix.alarm time) ;
|
||||
try
|
||||
a () ;
|
||||
reset_sigalrm ()
|
||||
with
|
||||
| Timeout ->
|
||||
reset_sigalrm () ;
|
||||
failwith @@ Printf.sprintf "Timed out after %d seconds" time
|
||||
| exc ->
|
||||
reset_sigalrm () ;
|
||||
raise exc
|
||||
|
||||
|
||||
let timeout_test (time : int) (t : assertion test) : assertion test =
|
||||
let map_timeout l = List.map (fun (i, a) -> (i, timeout_assert time a)) l in
|
||||
match t with
|
||||
| GradedTest (s, i, ls) ->
|
||||
GradedTest (s, i, map_timeout ls)
|
||||
| Test (s, ls) ->
|
||||
Test (s, map_timeout ls)
|
||||
|
||||
|
||||
let timeout_suite (time : int) (s : suite) : suite =
|
||||
List.map (timeout_test time) s
|
||||
|
||||
|
||||
(***************************)
|
||||
(* Generating Test Results *)
|
||||
|
||||
type result =
|
||||
| Pass
|
||||
| Fail of string
|
||||
|
||||
type outcome = result test list
|
||||
|
||||
let run_assertion (f : assertion) : result =
|
||||
try
|
||||
f () ;
|
||||
Pass
|
||||
with
|
||||
| Failure m ->
|
||||
Fail m
|
||||
| e ->
|
||||
Fail ("test threw exception: " ^ Printexc.to_string e)
|
||||
|
||||
|
||||
let run_test (t : assertion test) : result test =
|
||||
let run_case (cn, f) = (cn, run_assertion f) in
|
||||
match t with
|
||||
| GradedTest (n, s, cases) ->
|
||||
Printf.eprintf "Running test %s\n%!" n ;
|
||||
GradedTest (n, s, List.map run_case cases)
|
||||
| Test (n, cases) ->
|
||||
Printf.eprintf "Running test %s\n%!" n ;
|
||||
Test (n, List.map run_case cases)
|
||||
|
||||
|
||||
let run_suite (s : suite) : outcome = List.map run_test s
|
||||
|
||||
(***********************)
|
||||
(* Reporting functions *)
|
||||
|
||||
let result_test_to_string (name_pts : string) (r : result test) : string =
|
||||
let string_of_case (name, res) =
|
||||
match res with
|
||||
| Pass ->
|
||||
"passed - " ^ name
|
||||
| Fail msg ->
|
||||
"FAILED - " ^ name ^ ": " ^ msg
|
||||
in
|
||||
match r with
|
||||
| GradedTest (_, _, cases) | Test (_, cases) ->
|
||||
name_pts
|
||||
^ List.fold_left
|
||||
(fun rest case -> rest ^ "\n" ^ string_of_case case)
|
||||
""
|
||||
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 =
|
||||
List.fold_left
|
||||
(fun cnt (_, r) -> match r with Pass -> cnt + 1 | _ -> cnt)
|
||||
0
|
||||
cases
|
||||
in
|
||||
let num_failed cases =
|
||||
List.fold_left
|
||||
(fun cnt (_, r) -> match r with Fail _ -> cnt + 1 | _ -> cnt)
|
||||
0
|
||||
cases
|
||||
in
|
||||
match t with
|
||||
| GradedTest (name, pts, cases) ->
|
||||
let passed = num_passed cases in
|
||||
let failed = num_failed cases in
|
||||
let total = List.length cases in
|
||||
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.*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
|
||||
let name_pts = Printf.sprintf "%s (?/%d points)" name pts in
|
||||
(name_pts, passed, failed, total, 0.0, 0, pts)
|
||||
| Test (name, cases) ->
|
||||
let total = List.length cases in
|
||||
let passed = num_passed cases in
|
||||
let failed = num_failed cases in
|
||||
(name, passed, failed, total, 0.0, 0, 0)
|
||||
|
||||
|
||||
let outcome_to_string (o : outcome) : string =
|
||||
let sep = "\n---------------------------------------------------\n" in
|
||||
let helper (passed, failed, total, pts, maxg, maxh, str) (t : result test) =
|
||||
let name_pts, p, f, tot, s, mg, mh = get_results t in
|
||||
( passed + p
|
||||
, failed + f
|
||||
, total + tot
|
||||
, s +. pts
|
||||
, maxg + mg
|
||||
, maxh + mh
|
||||
, str
|
||||
^ "\n"
|
||||
^
|
||||
if f > 0
|
||||
then result_test_to_string name_pts t
|
||||
else if tot > 0
|
||||
then name_pts ^ ":\n OK"
|
||||
else name_pts ^ ":\n Hidden" )
|
||||
in
|
||||
let p, f, tot, pts, maxg, maxh, str =
|
||||
List.fold_left helper (0, 0, 0, 0.0, 0, 0, "") o
|
||||
in
|
||||
str
|
||||
^ sep
|
||||
^ Printf.sprintf
|
||||
"Passed: %d/%d\n\
|
||||
Failed: %d/%d\n\
|
||||
Score: %1.1f/%d (given)\n\
|
||||
\ ?/%d (hidden)"
|
||||
p tot
|
||||
f tot
|
||||
pts maxg
|
||||
maxh
|
||||
(* CIS341 Assertion Testing and Grading Infrastructure *)
|
||||
(* Author: Steve Zdancewic *)
|
||||
|
||||
(* Do NOT modify this file -- we will overwrite it *)
|
||||
(* with our own version when testing your code. *)
|
||||
|
||||
(* An assertion is just a unit->unit function that either *)
|
||||
(* succeeds silently or throws an Failure exception. *)
|
||||
type assertion = unit -> unit
|
||||
|
||||
type 'a test =
|
||||
| GradedTest of string * int * (string * 'a) list
|
||||
| Test of string * (string * 'a) list
|
||||
|
||||
type suite = assertion test list
|
||||
|
||||
(**************)
|
||||
(* Assertions *)
|
||||
|
||||
let assert_eq v1 v2 : assertion =
|
||||
fun () -> if v1 <> v2 then failwith "not equal" else ()
|
||||
|
||||
|
||||
let assert_eqf f v2 : assertion =
|
||||
fun () -> if f () <> v2 then failwith "not equal" else ()
|
||||
|
||||
|
||||
let assert_eqfs f v2 : assertion =
|
||||
fun () ->
|
||||
let s1 = f () in
|
||||
if s1 <> v2
|
||||
then failwith @@ Printf.sprintf "not equal\n\texpected:%s\n\tgot:%s\n" v2 s1
|
||||
else ()
|
||||
|
||||
|
||||
let assert_fail : assertion = fun () -> failwith "assert fail"
|
||||
|
||||
exception Timeout
|
||||
|
||||
let timeout_assert (time : int) (a : assertion) : assertion =
|
||||
fun () ->
|
||||
let handler = Sys.Signal_handle (fun _ -> raise Timeout) in
|
||||
let old = Sys.signal Sys.sigalrm handler in
|
||||
let reset_sigalrm () = Sys.set_signal Sys.sigalrm old in
|
||||
ignore (Unix.alarm time) ;
|
||||
try
|
||||
a () ;
|
||||
reset_sigalrm ()
|
||||
with
|
||||
| Timeout ->
|
||||
reset_sigalrm () ;
|
||||
failwith @@ Printf.sprintf "Timed out after %d seconds" time
|
||||
| exc ->
|
||||
reset_sigalrm () ;
|
||||
raise exc
|
||||
|
||||
|
||||
let timeout_test (time : int) (t : assertion test) : assertion test =
|
||||
let map_timeout l = List.map (fun (i, a) -> (i, timeout_assert time a)) l in
|
||||
match t with
|
||||
| GradedTest (s, i, ls) ->
|
||||
GradedTest (s, i, map_timeout ls)
|
||||
| Test (s, ls) ->
|
||||
Test (s, map_timeout ls)
|
||||
|
||||
|
||||
let timeout_suite (time : int) (s : suite) : suite =
|
||||
List.map (timeout_test time) s
|
||||
|
||||
|
||||
(***************************)
|
||||
(* Generating Test Results *)
|
||||
|
||||
type result =
|
||||
| Pass
|
||||
| Fail of string
|
||||
|
||||
type outcome = result test list
|
||||
|
||||
let run_assertion (f : assertion) : result =
|
||||
try
|
||||
f () ;
|
||||
Pass
|
||||
with
|
||||
| Failure m ->
|
||||
Fail m
|
||||
| e ->
|
||||
Fail ("test threw exception: " ^ Printexc.to_string e)
|
||||
|
||||
|
||||
let run_test (t : assertion test) : result test =
|
||||
let run_case (cn, f) = (cn, run_assertion f) in
|
||||
match t with
|
||||
| GradedTest (n, s, cases) ->
|
||||
Printf.eprintf "Running test %s\n%!" n ;
|
||||
GradedTest (n, s, List.map run_case cases)
|
||||
| Test (n, cases) ->
|
||||
Printf.eprintf "Running test %s\n%!" n ;
|
||||
Test (n, List.map run_case cases)
|
||||
|
||||
|
||||
let run_suite (s : suite) : outcome = List.map run_test s
|
||||
|
||||
(***********************)
|
||||
(* Reporting functions *)
|
||||
|
||||
let result_test_to_string (name_pts : string) (r : result test) : string =
|
||||
let string_of_case (name, res) =
|
||||
match res with
|
||||
| Pass ->
|
||||
"passed - " ^ name
|
||||
| Fail msg ->
|
||||
"FAILED - " ^ name ^ ": " ^ msg
|
||||
in
|
||||
match r with
|
||||
| GradedTest (_, _, cases) | Test (_, cases) ->
|
||||
name_pts
|
||||
^ List.fold_left
|
||||
(fun rest case -> rest ^ "\n" ^ string_of_case case)
|
||||
""
|
||||
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 =
|
||||
List.fold_left
|
||||
(fun cnt (_, r) -> match r with Pass -> cnt + 1 | _ -> cnt)
|
||||
0
|
||||
cases
|
||||
in
|
||||
let num_failed cases =
|
||||
List.fold_left
|
||||
(fun cnt (_, r) -> match r with Fail _ -> cnt + 1 | _ -> cnt)
|
||||
0
|
||||
cases
|
||||
in
|
||||
match t with
|
||||
| GradedTest (name, pts, cases) ->
|
||||
let passed = num_passed cases in
|
||||
let failed = num_failed cases in
|
||||
let total = List.length cases in
|
||||
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.*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
|
||||
let name_pts = Printf.sprintf "%s (?/%d points)" name pts in
|
||||
(name_pts, passed, failed, total, 0.0, 0, pts)
|
||||
| Test (name, cases) ->
|
||||
let total = List.length cases in
|
||||
let passed = num_passed cases in
|
||||
let failed = num_failed cases in
|
||||
(name, passed, failed, total, 0.0, 0, 0)
|
||||
|
||||
|
||||
let outcome_to_string (o : outcome) : string =
|
||||
let sep = "\n---------------------------------------------------\n" in
|
||||
let helper (passed, failed, total, pts, maxg, maxh, str) (t : result test) =
|
||||
let name_pts, p, f, tot, s, mg, mh = get_results t in
|
||||
( passed + p
|
||||
, failed + f
|
||||
, total + tot
|
||||
, s +. pts
|
||||
, maxg + mg
|
||||
, maxh + mh
|
||||
, str
|
||||
^ "\n"
|
||||
^
|
||||
if f > 0
|
||||
then result_test_to_string name_pts t
|
||||
else if tot > 0
|
||||
then name_pts ^ ":\n OK"
|
||||
else name_pts ^ ":\n Hidden" )
|
||||
in
|
||||
let p, f, tot, pts, maxg, maxh, str =
|
||||
List.fold_left helper (0, 0, 0, 0.0, 0, 0, "") o
|
||||
in
|
||||
str
|
||||
^ sep
|
||||
^ Printf.sprintf
|
||||
"Passed: %d/%d\n\
|
||||
Failed: %d/%d\n\
|
||||
Score: %1.1f/%d (given)\n\
|
||||
\ ?/%d (hidden)"
|
||||
p tot
|
||||
f tot
|
||||
pts maxg
|
||||
maxh
|
||||
|
|
|
|||
|
|
@ -1,57 +1,57 @@
|
|||
(* CIS341 Assertion Testing and Grading Infrastructure *)
|
||||
(* Author: Steve Zdancewic *)
|
||||
|
||||
(* Do NOT modify this file -- we will overwrite it *)
|
||||
(* with our own version when testing your code. *)
|
||||
|
||||
exception Timeout
|
||||
|
||||
(* An assertion is just a unit->unit function that either *)
|
||||
(* succeeds silently or throws an Failure exception. *)
|
||||
type assertion = unit -> unit
|
||||
|
||||
type 'a test =
|
||||
| GradedTest of string * int * (string * 'a) list
|
||||
| Test of string * (string * 'a) list
|
||||
|
||||
type suite = assertion test list
|
||||
|
||||
(**************)
|
||||
(* Assertions *)
|
||||
|
||||
val assert_eq : 'a -> 'a -> assertion
|
||||
|
||||
val assert_eqf : (unit -> 'a) -> 'a -> assertion
|
||||
|
||||
val assert_eqfs : (unit -> string) -> string -> assertion
|
||||
|
||||
val assert_fail : assertion
|
||||
|
||||
val timeout_assert : int -> assertion -> assertion
|
||||
|
||||
val timeout_test : int -> assertion test -> assertion test
|
||||
|
||||
val timeout_suite : int -> suite -> suite
|
||||
|
||||
(***************************)
|
||||
(* Generating Test Results *)
|
||||
|
||||
type result =
|
||||
| Pass
|
||||
| Fail of string
|
||||
|
||||
type outcome = result test list
|
||||
|
||||
val run_assertion : assertion -> result
|
||||
|
||||
val run_test : assertion test -> result test
|
||||
|
||||
val run_suite : suite -> outcome
|
||||
|
||||
(***********************)
|
||||
(* Reporting functions *)
|
||||
|
||||
val result_test_to_string : string -> result test -> string
|
||||
|
||||
(* val get_results result test -> (string * int * int * int * float * int * int) *)
|
||||
val outcome_to_string : outcome -> string
|
||||
(* CIS341 Assertion Testing and Grading Infrastructure *)
|
||||
(* Author: Steve Zdancewic *)
|
||||
|
||||
(* Do NOT modify this file -- we will overwrite it *)
|
||||
(* with our own version when testing your code. *)
|
||||
|
||||
exception Timeout
|
||||
|
||||
(* An assertion is just a unit->unit function that either *)
|
||||
(* succeeds silently or throws an Failure exception. *)
|
||||
type assertion = unit -> unit
|
||||
|
||||
type 'a test =
|
||||
| GradedTest of string * int * (string * 'a) list
|
||||
| Test of string * (string * 'a) list
|
||||
|
||||
type suite = assertion test list
|
||||
|
||||
(**************)
|
||||
(* Assertions *)
|
||||
|
||||
val assert_eq : 'a -> 'a -> assertion
|
||||
|
||||
val assert_eqf : (unit -> 'a) -> 'a -> assertion
|
||||
|
||||
val assert_eqfs : (unit -> string) -> string -> assertion
|
||||
|
||||
val assert_fail : assertion
|
||||
|
||||
val timeout_assert : int -> assertion -> assertion
|
||||
|
||||
val timeout_test : int -> assertion test -> assertion test
|
||||
|
||||
val timeout_suite : int -> suite -> suite
|
||||
|
||||
(***************************)
|
||||
(* Generating Test Results *)
|
||||
|
||||
type result =
|
||||
| Pass
|
||||
| Fail of string
|
||||
|
||||
type outcome = result test list
|
||||
|
||||
val run_assertion : assertion -> result
|
||||
|
||||
val run_test : assertion test -> result test
|
||||
|
||||
val run_suite : suite -> outcome
|
||||
|
||||
(***********************)
|
||||
(* Reporting functions *)
|
||||
|
||||
val result_test_to_string : string -> result test -> string
|
||||
|
||||
(* val get_results result test -> (string * int * int * int * float * int * int) *)
|
||||
val outcome_to_string : outcome -> string
|
||||
|
|
|
|||
|
|
@ -1,3 +1,3 @@
|
|||
(library
|
||||
(name util)
|
||||
(library
|
||||
(name util)
|
||||
(libraries str unix))
|
||||
|
|
@ -1,237 +1,237 @@
|
|||
(* -------------------------------------------------------------------------- *)
|
||||
(** Assembling and linking for X86. Depends on the underlying OS platform *)
|
||||
|
||||
open Printf
|
||||
open Unix
|
||||
|
||||
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 []
|
||||
|
||||
let lib_paths = ref []
|
||||
|
||||
let lib_search_paths = ref []
|
||||
|
||||
let include_paths = ref []
|
||||
|
||||
(* unix utility scripts ----------------------------------------------------- *)
|
||||
let pp_cmd = ref "cpp -E "
|
||||
|
||||
let rm_cmd = ref "rm -rf "
|
||||
|
||||
(* -------------------------------------------------------------------------- *)
|
||||
(* Platform specific configuration: Unix/Linux vs. Mac OS X *)
|
||||
|
||||
let os =
|
||||
let ic = Unix.open_process_in "uname -s" in
|
||||
let uname = input_line ic in
|
||||
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" *)
|
||||
|
||||
let linux = ref false
|
||||
|
||||
let mangle name = if !linux then name else "_" ^ name
|
||||
|
||||
let osx_target_triple = "x86_64-apple-macosx10.13.0"
|
||||
|
||||
let linux_target_triple = "x86_64-unknown-linux"
|
||||
|
||||
let target_triple = ref osx_target_triple
|
||||
|
||||
let platform_flags = ref ""
|
||||
|
||||
(* Set the link commands properly, ensure output directory exists *)
|
||||
let configure_os () =
|
||||
if os = "Linux"
|
||||
then (
|
||||
linux := true ;
|
||||
target_triple := linux_target_triple ;
|
||||
platform_flags := "" )
|
||||
else if os = "Darwin"
|
||||
then (
|
||||
linux := false ;
|
||||
target_triple := osx_target_triple ;
|
||||
platform_flags := "-fno-asynchronous-unwind-tables -mstackrealign" )
|
||||
else failwith @@ "Unsupported OS detected: " ^ os
|
||||
|
||||
|
||||
(* verbose compiler output -------------------------------------------------- *)
|
||||
let verbose = ref false
|
||||
|
||||
let verb msg =
|
||||
if !verbose
|
||||
then (
|
||||
print_string msg ;
|
||||
flush Stdlib.stdout )
|
||||
|
||||
|
||||
let verb_os () =
|
||||
verb
|
||||
@@ Printf.sprintf
|
||||
"* PLATFORM: %s TRIPLE: %s FLAGS %s\n"
|
||||
os
|
||||
!target_triple
|
||||
!platform_flags
|
||||
|
||||
|
||||
let enable_verbose () =
|
||||
verbose := true ;
|
||||
verb_os ()
|
||||
|
||||
|
||||
(* create the output directory, which is assumed to exist *)
|
||||
let create_output_dir () =
|
||||
try ignore (stat !output_path) with
|
||||
| Unix_error (ENOENT, _, _) ->
|
||||
verb @@ Printf.sprintf "creating output directory: %s\n" !output_path ;
|
||||
mkdir !output_path 0o755
|
||||
|
||||
|
||||
(* clang invocation stuff --------------------------------------------------- *)
|
||||
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 "%sclang %s -o " prefix (String.concat " " args)
|
||||
|
||||
let clang_cmd () =
|
||||
clang [ clang_ll_mode; !opt_level; common_flags; !platform_flags ]
|
||||
|
||||
|
||||
let as_cmd () = clang [ as_mode; !opt_level; common_flags; !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 =
|
||||
(* The path is of the form ... "foo/bar/baz/<file>.ext" *)
|
||||
let paths = Str.split (Str.regexp_string path_sep) path in
|
||||
let _ =
|
||||
if List.length paths = 0 then failwith @@ sprintf "bad path: %s" path
|
||||
in
|
||||
let filename = List.hd (List.rev paths) in
|
||||
match Str.split (Str.regexp_string ".") filename with
|
||||
| [ root ] ->
|
||||
(root, "")
|
||||
| [ root; ext ] ->
|
||||
(root, ext)
|
||||
| _ ->
|
||||
failwith @@ sprintf "bad filename: %s" filename
|
||||
|
||||
|
||||
(* compilation and shell commands-------------------------------------------- *)
|
||||
|
||||
(* Platform independent shell command *)
|
||||
let sh (cmd : string) (ret : string -> int -> 'a) : 'a =
|
||||
verb (sprintf "* %s\n" cmd) ;
|
||||
match system cmd with
|
||||
| WEXITED i ->
|
||||
ret cmd i
|
||||
| WSIGNALED i ->
|
||||
raise (PlatformError (cmd, sprintf "Signaled with %d." i))
|
||||
| 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
|
||||
*)
|
||||
let gen_name (basedir : string) (basen : string) (baseext : string) : string =
|
||||
let rec nocollide ofs =
|
||||
let nfn =
|
||||
sprintf
|
||||
"%s/%s%s%s"
|
||||
basedir
|
||||
basen
|
||||
(if ofs = 0 then "" else "_" ^ string_of_int ofs)
|
||||
baseext
|
||||
in
|
||||
try
|
||||
ignore (stat nfn) ;
|
||||
nocollide (ofs + 1)
|
||||
with
|
||||
| Unix_error (ENOENT, _, _) ->
|
||||
nfn
|
||||
in
|
||||
nocollide 0
|
||||
|
||||
|
||||
let raise_error cmd i =
|
||||
if i <> 0 then raise (PlatformError (cmd, sprintf "Exited with status %d." i))
|
||||
|
||||
|
||||
let ignore_error _ _ = ()
|
||||
|
||||
let preprocess (dot_oat : string) (dot_i : string) : unit =
|
||||
sh
|
||||
(sprintf
|
||||
"%s%s %s %s"
|
||||
!pp_cmd
|
||||
(List.fold_left (fun s i -> s ^ " -I" ^ i) "" !include_paths)
|
||||
dot_oat
|
||||
dot_i)
|
||||
raise_error
|
||||
|
||||
|
||||
let clang_compile (dot_ll : string) (dot_s : string) : unit =
|
||||
sh (sprintf "%s%s %s" (clang_cmd ()) dot_s dot_ll) raise_error
|
||||
|
||||
|
||||
let assemble (dot_s : string) (dot_o : string) : unit =
|
||||
sh (sprintf "%s%s %s" (as_cmd ()) dot_o dot_s) raise_error
|
||||
|
||||
|
||||
let link (mods : string list) (out_fn : string) : unit =
|
||||
sh
|
||||
(sprintf
|
||||
"%s%s %s %s %s %s"
|
||||
(link_cmd ())
|
||||
out_fn
|
||||
(String.concat " " (mods @ !lib_paths))
|
||||
(List.fold_left (fun s i -> s ^ " -L" ^ i) "" !lib_search_paths)
|
||||
(List.fold_left (fun s i -> s ^ " -I" ^ i) "" !include_paths)
|
||||
(List.fold_left (fun s l -> s ^ " -l" ^ l) "" !libs))
|
||||
raise_error
|
||||
(* -------------------------------------------------------------------------- *)
|
||||
(** Assembling and linking for X86. Depends on the underlying OS platform *)
|
||||
|
||||
open Printf
|
||||
open Unix
|
||||
|
||||
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 []
|
||||
|
||||
let lib_paths = ref []
|
||||
|
||||
let lib_search_paths = ref []
|
||||
|
||||
let include_paths = ref []
|
||||
|
||||
(* unix utility scripts ----------------------------------------------------- *)
|
||||
let pp_cmd = ref "cpp -E "
|
||||
|
||||
let rm_cmd = ref "rm -rf "
|
||||
|
||||
(* -------------------------------------------------------------------------- *)
|
||||
(* Platform specific configuration: Unix/Linux vs. Mac OS X *)
|
||||
|
||||
let os =
|
||||
let ic = Unix.open_process_in "uname -s" in
|
||||
let uname = input_line ic in
|
||||
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" *)
|
||||
|
||||
let linux = ref false
|
||||
|
||||
let mangle name = if !linux then name else "_" ^ name
|
||||
|
||||
let osx_target_triple = "x86_64-apple-macosx10.13.0"
|
||||
|
||||
let linux_target_triple = "x86_64-unknown-linux"
|
||||
|
||||
let target_triple = ref osx_target_triple
|
||||
|
||||
let platform_flags = ref ""
|
||||
|
||||
(* Set the link commands properly, ensure output directory exists *)
|
||||
let configure_os () =
|
||||
if os = "Linux"
|
||||
then (
|
||||
linux := true ;
|
||||
target_triple := linux_target_triple ;
|
||||
platform_flags := "" )
|
||||
else if os = "Darwin"
|
||||
then (
|
||||
linux := false ;
|
||||
target_triple := osx_target_triple ;
|
||||
platform_flags := "-fno-asynchronous-unwind-tables -mstackrealign" )
|
||||
else failwith @@ "Unsupported OS detected: " ^ os
|
||||
|
||||
|
||||
(* verbose compiler output -------------------------------------------------- *)
|
||||
let verbose = ref false
|
||||
|
||||
let verb msg =
|
||||
if !verbose
|
||||
then (
|
||||
print_string msg ;
|
||||
flush Stdlib.stdout )
|
||||
|
||||
|
||||
let verb_os () =
|
||||
verb
|
||||
@@ Printf.sprintf
|
||||
"* PLATFORM: %s TRIPLE: %s FLAGS %s\n"
|
||||
os
|
||||
!target_triple
|
||||
!platform_flags
|
||||
|
||||
|
||||
let enable_verbose () =
|
||||
verbose := true ;
|
||||
verb_os ()
|
||||
|
||||
|
||||
(* create the output directory, which is assumed to exist *)
|
||||
let create_output_dir () =
|
||||
try ignore (stat !output_path) with
|
||||
| Unix_error (ENOENT, _, _) ->
|
||||
verb @@ Printf.sprintf "creating output directory: %s\n" !output_path ;
|
||||
mkdir !output_path 0o755
|
||||
|
||||
|
||||
(* clang invocation stuff --------------------------------------------------- *)
|
||||
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 "%sclang %s -o " prefix (String.concat " " args)
|
||||
|
||||
let clang_cmd () =
|
||||
clang [ clang_ll_mode; !opt_level; common_flags; !platform_flags ]
|
||||
|
||||
|
||||
let as_cmd () = clang [ as_mode; !opt_level; common_flags; !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 =
|
||||
(* The path is of the form ... "foo/bar/baz/<file>.ext" *)
|
||||
let paths = Str.split (Str.regexp_string path_sep) path in
|
||||
let _ =
|
||||
if List.length paths = 0 then failwith @@ sprintf "bad path: %s" path
|
||||
in
|
||||
let filename = List.hd (List.rev paths) in
|
||||
match Str.split (Str.regexp_string ".") filename with
|
||||
| [ root ] ->
|
||||
(root, "")
|
||||
| [ root; ext ] ->
|
||||
(root, ext)
|
||||
| _ ->
|
||||
failwith @@ sprintf "bad filename: %s" filename
|
||||
|
||||
|
||||
(* compilation and shell commands-------------------------------------------- *)
|
||||
|
||||
(* Platform independent shell command *)
|
||||
let sh (cmd : string) (ret : string -> int -> 'a) : 'a =
|
||||
verb (sprintf "* %s\n" cmd) ;
|
||||
match system cmd with
|
||||
| WEXITED i ->
|
||||
ret cmd i
|
||||
| WSIGNALED i ->
|
||||
raise (PlatformError (cmd, sprintf "Signaled with %d." i))
|
||||
| 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
|
||||
*)
|
||||
let gen_name (basedir : string) (basen : string) (baseext : string) : string =
|
||||
let rec nocollide ofs =
|
||||
let nfn =
|
||||
sprintf
|
||||
"%s/%s%s%s"
|
||||
basedir
|
||||
basen
|
||||
(if ofs = 0 then "" else "_" ^ string_of_int ofs)
|
||||
baseext
|
||||
in
|
||||
try
|
||||
ignore (stat nfn) ;
|
||||
nocollide (ofs + 1)
|
||||
with
|
||||
| Unix_error (ENOENT, _, _) ->
|
||||
nfn
|
||||
in
|
||||
nocollide 0
|
||||
|
||||
|
||||
let raise_error cmd i =
|
||||
if i <> 0 then raise (PlatformError (cmd, sprintf "Exited with status %d." i))
|
||||
|
||||
|
||||
let ignore_error _ _ = ()
|
||||
|
||||
let preprocess (dot_oat : string) (dot_i : string) : unit =
|
||||
sh
|
||||
(sprintf
|
||||
"%s%s %s %s"
|
||||
!pp_cmd
|
||||
(List.fold_left (fun s i -> s ^ " -I" ^ i) "" !include_paths)
|
||||
dot_oat
|
||||
dot_i)
|
||||
raise_error
|
||||
|
||||
|
||||
let clang_compile (dot_ll : string) (dot_s : string) : unit =
|
||||
sh (sprintf "%s%s %s" (clang_cmd ()) dot_s dot_ll) raise_error
|
||||
|
||||
|
||||
let assemble (dot_s : string) (dot_o : string) : unit =
|
||||
sh (sprintf "%s%s %s" (as_cmd ()) dot_o dot_s) raise_error
|
||||
|
||||
|
||||
let link (mods : string list) (out_fn : string) : unit =
|
||||
sh
|
||||
(sprintf
|
||||
"%s%s %s %s %s %s"
|
||||
(link_cmd ())
|
||||
out_fn
|
||||
(String.concat " " (mods @ !lib_paths))
|
||||
(List.fold_left (fun s i -> s ^ " -L" ^ i) "" !lib_search_paths)
|
||||
(List.fold_left (fun s i -> s ^ " -I" ^ i) "" !include_paths)
|
||||
(List.fold_left (fun s l -> s ^ " -l" ^ l) "" !libs))
|
||||
raise_error
|
||||
|
|
|
|||
|
|
@ -1,56 +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)
|
||||
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)
|
||||
|
|
|
|||
|
|
@ -1,53 +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
|
||||
(* 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
|
||||
|
|
|
|||
|
|
@ -1,3 +1,3 @@
|
|||
(library
|
||||
(name x86)
|
||||
(modules x86))
|
||||
(library
|
||||
(name x86)
|
||||
(modules x86))
|
||||
|
|
|
|||
|
|
@ -1,165 +1,165 @@
|
|||
(* X86lite language representation. *)
|
||||
|
||||
(* assembler syntax --------------------------------------------------------- *)
|
||||
|
||||
(* Labels for code blocks and global data. *)
|
||||
type lbl = string
|
||||
|
||||
type quad = int64
|
||||
|
||||
(* Immediate operands *)
|
||||
type imm = Lit of quad
|
||||
| Lbl of lbl
|
||||
|
||||
(* Registers:
|
||||
instruction pointer: rip
|
||||
arguments: rdi, rsi, rdx, rcx, r09, r08
|
||||
callee-save: rbx, rbp, r12-r15
|
||||
*)
|
||||
type reg = Rip
|
||||
| Rax | Rbx | Rcx | Rdx | Rsi | Rdi | Rbp | Rsp
|
||||
| R08 | R09 | R10 | R11 | R12 | R13 | R14 | R15
|
||||
|
||||
type operand = Imm of imm (* immediate *)
|
||||
| Reg of reg (* register *)
|
||||
| Ind1 of imm (* indirect: displacement *)
|
||||
| Ind2 of reg (* indirect: (%reg) *)
|
||||
| Ind3 of (imm * reg) (* indirect: displacement(%reg) *)
|
||||
|
||||
(* Condition Codes *)
|
||||
type cnd = Eq | Neq | Gt | Ge | Lt | Le
|
||||
|
||||
type opcode = Movq | Pushq | Popq
|
||||
| Leaq
|
||||
| Incq | Decq | Negq | Notq
|
||||
| Addq | Subq | Imulq | Xorq | Orq | Andq
|
||||
| Shlq | Sarq | Shrq
|
||||
| Jmp | J of cnd
|
||||
| Cmpq | Set of cnd
|
||||
| Callq | Retq
|
||||
|
||||
(* An instruction is an opcode plus its operands.
|
||||
Note that arity and other constraints about the operands
|
||||
are not checked. *)
|
||||
type ins = opcode * operand list
|
||||
|
||||
type data = Asciz of string
|
||||
| Quad of imm
|
||||
|
||||
type asm = Text of ins list (* code *)
|
||||
| Data of data list (* data *)
|
||||
|
||||
(* labeled blocks of data or code *)
|
||||
type elem = { lbl: lbl; global: bool; asm: asm }
|
||||
|
||||
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 (~$$) l = Imm (Lbl l) (* label constants *)
|
||||
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 gtext l is = { lbl = l; global = true; asm = Text is }
|
||||
end
|
||||
|
||||
(* pretty printing ----------------------------------------------------------- *)
|
||||
|
||||
let string_of_reg : reg -> string = function
|
||||
| Rip -> "%rip"
|
||||
| Rax -> "%rax" | Rbx -> "%rbx" | Rcx -> "%rcx" | Rdx -> "%rdx"
|
||||
| Rsi -> "%rsi" | Rdi -> "%rdi" | Rbp -> "%rbp" | Rsp -> "%rsp"
|
||||
| R08 -> "%r8 " | R09 -> "%r9 " | R10 -> "%r10" | R11 -> "%r11"
|
||||
| R12 -> "%r12" | R13 -> "%r13" | R14 -> "%r14" | R15 -> "%r15"
|
||||
|
||||
let string_of_byte_reg : reg -> string = function
|
||||
| Rip -> failwith "%rip used as byte register"
|
||||
| Rax -> "%al" | Rbx -> "%bl" | Rcx -> "%cl" | Rdx -> "%dl"
|
||||
| Rsi -> "%sil" | Rdi -> "%dil" | Rbp -> "%bpl" | Rsp -> "%spl"
|
||||
| R08 -> "%r8b" | R09 -> "%r9b" | R10 -> "%r10b" | R11 -> "%r11b"
|
||||
| R12 -> "%r12b" | R13 -> "%r13b" | R14 -> "%r14b" | R15 -> "%r15b"
|
||||
|
||||
let string_of_lbl (l:lbl) : string = l
|
||||
|
||||
let string_of_imm : imm -> string = function
|
||||
| Lit i -> Int64.to_string i
|
||||
| Lbl l -> string_of_lbl l
|
||||
|
||||
let string_of_operand : operand -> string = function
|
||||
| Imm i -> "$" ^ string_of_imm i
|
||||
| Reg r -> string_of_reg r
|
||||
| Ind1 i -> string_of_imm i
|
||||
| Ind2 r -> "(" ^ string_of_reg r ^ ")"
|
||||
| Ind3 (i, r) -> string_of_imm i ^ "(" ^ string_of_reg r ^ ")"
|
||||
|
||||
let string_of_byte_operand : operand -> string = function
|
||||
| Imm i -> "$" ^ string_of_imm i
|
||||
| Reg r -> string_of_byte_reg r
|
||||
| Ind1 i -> string_of_imm i
|
||||
| Ind2 r -> "(" ^ string_of_reg r ^ ")"
|
||||
| Ind3 (i, r) -> string_of_imm i ^ "(" ^ string_of_reg r ^ ")"
|
||||
|
||||
let string_of_jmp_operand : operand -> string = function
|
||||
| Imm i -> string_of_imm i
|
||||
| Reg r -> "*" ^ string_of_reg r
|
||||
| Ind1 i -> "*" ^ string_of_imm i
|
||||
| Ind2 r -> "*" ^ "(" ^ string_of_reg r ^ ")"
|
||||
| Ind3 (i, r) -> "*" ^ string_of_imm i ^ "(" ^ string_of_reg r ^ ")"
|
||||
|
||||
let string_of_cnd : cnd -> string = function
|
||||
| Eq -> "e" | Neq -> "ne" | Gt -> "g"
|
||||
| Ge -> "ge" | Lt -> "l" | Le -> "le"
|
||||
|
||||
let string_of_opcode : opcode -> string = function
|
||||
| Movq -> "movq" | Pushq -> "pushq" | Popq -> "popq"
|
||||
| Leaq -> "leaq"
|
||||
| Incq -> "incq" | Decq -> "decq" | Negq -> "negq" | Notq -> "notq"
|
||||
| Addq -> "addq" | Subq -> "subq" | Imulq -> "imulq"
|
||||
| Xorq -> "xorq" | Orq -> "orq" | Andq -> "andq"
|
||||
| Shlq -> "shlq" | Sarq -> "sarq" | Shrq -> "shrq"
|
||||
| Jmp -> "jmp" | J c -> "j" ^ string_of_cnd c
|
||||
| Cmpq -> "cmpq" | Set c -> "set" ^ string_of_cnd c
|
||||
| Callq -> "callq" | Retq -> "retq"
|
||||
|
||||
let map_concat s f l = String.concat s @@ List.map f l
|
||||
|
||||
let string_of_shift op = function
|
||||
| [ 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)
|
||||
| args -> failwith (Printf.sprintf "shift instruction has invalid operands: %s\n"
|
||||
(map_concat ", " string_of_operand args))
|
||||
|
||||
let string_of_ins (op, args: ins) : string =
|
||||
match op with
|
||||
| Shlq | Sarq | Shrq -> string_of_shift op args
|
||||
| _ ->
|
||||
let f = match op with
|
||||
| J _ | Jmp | Callq -> string_of_jmp_operand
|
||||
| Set _ -> string_of_byte_operand
|
||||
| _ -> string_of_operand
|
||||
in
|
||||
"\t" ^ string_of_opcode op ^ "\t" ^ map_concat ", " f args
|
||||
|
||||
let string_of_data : data -> string = function
|
||||
| Asciz s -> "\t.asciz\t" ^ "\"" ^ (String.escaped s) ^ "\""
|
||||
| Quad i -> "\t.quad\t" ^ string_of_imm i
|
||||
|
||||
let string_of_asm : asm -> string = function
|
||||
| Text is -> "\t.text\n" ^ map_concat "\n" string_of_ins is
|
||||
| Data ds -> "\t.data\n" ^ map_concat "\n" string_of_data ds
|
||||
|
||||
let string_of_elem {lbl; global; asm} : string =
|
||||
let sec, body = match asm with
|
||||
| Text is -> "\t.text\n", map_concat "\n" string_of_ins is
|
||||
| Data ds -> "\t.data\n", map_concat "\n" string_of_data ds
|
||||
in
|
||||
let glb = if global then "\t.globl\t" ^ string_of_lbl lbl ^ "\n" else "" in
|
||||
sec ^ glb ^ string_of_lbl lbl ^ ":\n" ^ body
|
||||
|
||||
let string_of_prog (p:prog) : string =
|
||||
String.concat "\n" @@ List.map string_of_elem p
|
||||
(* X86lite language representation. *)
|
||||
|
||||
(* assembler syntax --------------------------------------------------------- *)
|
||||
|
||||
(* Labels for code blocks and global data. *)
|
||||
type lbl = string
|
||||
|
||||
type quad = int64
|
||||
|
||||
(* Immediate operands *)
|
||||
type imm = Lit of quad
|
||||
| Lbl of lbl
|
||||
|
||||
(* Registers:
|
||||
instruction pointer: rip
|
||||
arguments: rdi, rsi, rdx, rcx, r09, r08
|
||||
callee-save: rbx, rbp, r12-r15
|
||||
*)
|
||||
type reg = Rip
|
||||
| Rax | Rbx | Rcx | Rdx | Rsi | Rdi | Rbp | Rsp
|
||||
| R08 | R09 | R10 | R11 | R12 | R13 | R14 | R15
|
||||
|
||||
type operand = Imm of imm (* immediate *)
|
||||
| Reg of reg (* register *)
|
||||
| Ind1 of imm (* indirect: displacement *)
|
||||
| Ind2 of reg (* indirect: (%reg) *)
|
||||
| Ind3 of (imm * reg) (* indirect: displacement(%reg) *)
|
||||
|
||||
(* Condition Codes *)
|
||||
type cnd = Eq | Neq | Gt | Ge | Lt | Le
|
||||
|
||||
type opcode = Movq | Pushq | Popq
|
||||
| Leaq
|
||||
| Incq | Decq | Negq | Notq
|
||||
| Addq | Subq | Imulq | Xorq | Orq | Andq
|
||||
| Shlq | Sarq | Shrq
|
||||
| Jmp | J of cnd
|
||||
| Cmpq | Set of cnd
|
||||
| Callq | Retq
|
||||
|
||||
(* An instruction is an opcode plus its operands.
|
||||
Note that arity and other constraints about the operands
|
||||
are not checked. *)
|
||||
type ins = opcode * operand list
|
||||
|
||||
type data = Asciz of string
|
||||
| Quad of imm
|
||||
|
||||
type asm = Text of ins list (* code *)
|
||||
| Data of data list (* data *)
|
||||
|
||||
(* labeled blocks of data or code *)
|
||||
type elem = { lbl: lbl; global: bool; asm: asm }
|
||||
|
||||
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 (~$$) l = Imm (Lbl l) (* label constants *)
|
||||
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 gtext l is = { lbl = l; global = true; asm = Text is }
|
||||
end
|
||||
|
||||
(* pretty printing ----------------------------------------------------------- *)
|
||||
|
||||
let string_of_reg : reg -> string = function
|
||||
| Rip -> "%rip"
|
||||
| Rax -> "%rax" | Rbx -> "%rbx" | Rcx -> "%rcx" | Rdx -> "%rdx"
|
||||
| Rsi -> "%rsi" | Rdi -> "%rdi" | Rbp -> "%rbp" | Rsp -> "%rsp"
|
||||
| R08 -> "%r8 " | R09 -> "%r9 " | R10 -> "%r10" | R11 -> "%r11"
|
||||
| R12 -> "%r12" | R13 -> "%r13" | R14 -> "%r14" | R15 -> "%r15"
|
||||
|
||||
let string_of_byte_reg : reg -> string = function
|
||||
| Rip -> failwith "%rip used as byte register"
|
||||
| Rax -> "%al" | Rbx -> "%bl" | Rcx -> "%cl" | Rdx -> "%dl"
|
||||
| Rsi -> "%sil" | Rdi -> "%dil" | Rbp -> "%bpl" | Rsp -> "%spl"
|
||||
| R08 -> "%r8b" | R09 -> "%r9b" | R10 -> "%r10b" | R11 -> "%r11b"
|
||||
| R12 -> "%r12b" | R13 -> "%r13b" | R14 -> "%r14b" | R15 -> "%r15b"
|
||||
|
||||
let string_of_lbl (l:lbl) : string = l
|
||||
|
||||
let string_of_imm : imm -> string = function
|
||||
| Lit i -> Int64.to_string i
|
||||
| Lbl l -> string_of_lbl l
|
||||
|
||||
let string_of_operand : operand -> string = function
|
||||
| Imm i -> "$" ^ string_of_imm i
|
||||
| Reg r -> string_of_reg r
|
||||
| Ind1 i -> string_of_imm i
|
||||
| Ind2 r -> "(" ^ string_of_reg r ^ ")"
|
||||
| Ind3 (i, r) -> string_of_imm i ^ "(" ^ string_of_reg r ^ ")"
|
||||
|
||||
let string_of_byte_operand : operand -> string = function
|
||||
| Imm i -> "$" ^ string_of_imm i
|
||||
| Reg r -> string_of_byte_reg r
|
||||
| Ind1 i -> string_of_imm i
|
||||
| Ind2 r -> "(" ^ string_of_reg r ^ ")"
|
||||
| Ind3 (i, r) -> string_of_imm i ^ "(" ^ string_of_reg r ^ ")"
|
||||
|
||||
let string_of_jmp_operand : operand -> string = function
|
||||
| Imm i -> string_of_imm i
|
||||
| Reg r -> "*" ^ string_of_reg r
|
||||
| Ind1 i -> "*" ^ string_of_imm i
|
||||
| Ind2 r -> "*" ^ "(" ^ string_of_reg r ^ ")"
|
||||
| Ind3 (i, r) -> "*" ^ string_of_imm i ^ "(" ^ string_of_reg r ^ ")"
|
||||
|
||||
let string_of_cnd : cnd -> string = function
|
||||
| Eq -> "e" | Neq -> "ne" | Gt -> "g"
|
||||
| Ge -> "ge" | Lt -> "l" | Le -> "le"
|
||||
|
||||
let string_of_opcode : opcode -> string = function
|
||||
| Movq -> "movq" | Pushq -> "pushq" | Popq -> "popq"
|
||||
| Leaq -> "leaq"
|
||||
| Incq -> "incq" | Decq -> "decq" | Negq -> "negq" | Notq -> "notq"
|
||||
| Addq -> "addq" | Subq -> "subq" | Imulq -> "imulq"
|
||||
| Xorq -> "xorq" | Orq -> "orq" | Andq -> "andq"
|
||||
| Shlq -> "shlq" | Sarq -> "sarq" | Shrq -> "shrq"
|
||||
| Jmp -> "jmp" | J c -> "j" ^ string_of_cnd c
|
||||
| Cmpq -> "cmpq" | Set c -> "set" ^ string_of_cnd c
|
||||
| Callq -> "callq" | Retq -> "retq"
|
||||
|
||||
let map_concat s f l = String.concat s @@ List.map f l
|
||||
|
||||
let string_of_shift op = function
|
||||
| [ 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)
|
||||
| args -> failwith (Printf.sprintf "shift instruction has invalid operands: %s\n"
|
||||
(map_concat ", " string_of_operand args))
|
||||
|
||||
let string_of_ins (op, args: ins) : string =
|
||||
match op with
|
||||
| Shlq | Sarq | Shrq -> string_of_shift op args
|
||||
| _ ->
|
||||
let f = match op with
|
||||
| J _ | Jmp | Callq -> string_of_jmp_operand
|
||||
| Set _ -> string_of_byte_operand
|
||||
| _ -> string_of_operand
|
||||
in
|
||||
"\t" ^ string_of_opcode op ^ "\t" ^ map_concat ", " f args
|
||||
|
||||
let string_of_data : data -> string = function
|
||||
| Asciz s -> "\t.asciz\t" ^ "\"" ^ (String.escaped s) ^ "\""
|
||||
| Quad i -> "\t.quad\t" ^ string_of_imm i
|
||||
|
||||
let string_of_asm : asm -> string = function
|
||||
| Text is -> "\t.text\n" ^ map_concat "\n" string_of_ins is
|
||||
| Data ds -> "\t.data\n" ^ map_concat "\n" string_of_data ds
|
||||
|
||||
let string_of_elem {lbl; global; asm} : string =
|
||||
let sec, body = match asm with
|
||||
| Text is -> "\t.text\n", map_concat "\n" string_of_ins is
|
||||
| Data ds -> "\t.data\n", map_concat "\n" string_of_data ds
|
||||
in
|
||||
let glb = if global then "\t.globl\t" ^ string_of_lbl lbl ^ "\n" else "" in
|
||||
sec ^ glb ^ string_of_lbl lbl ^ ":\n" ^ body
|
||||
|
||||
let string_of_prog (p:prog) : string =
|
||||
String.concat "\n" @@ List.map string_of_elem p
|
||||
|
|
|
|||
|
|
@ -1,2 +1,2 @@
|
|||
bin/simulator.ml
|
||||
test/studenttests.ml
|
||||
bin/simulator.ml
|
||||
test/studenttests.ml
|
||||
|
|
|
|||
|
|
@ -1,17 +1,17 @@
|
|||
(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 util sim x86 gradedtests))
|
||||
|
||||
(library
|
||||
(name gradedtests)
|
||||
(modules
|
||||
gradedtests
|
||||
; project libraries
|
||||
)
|
||||
(libraries util sim x86))
|
||||
(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 util sim x86 gradedtests))
|
||||
|
||||
(library
|
||||
(name gradedtests)
|
||||
(modules
|
||||
gradedtests
|
||||
; project libraries
|
||||
)
|
||||
(libraries util sim x86))
|
||||
|
|
|
|||
File diff suppressed because it is too large
Load diff
|
|
@ -1,57 +1,57 @@
|
|||
open Util.Assert
|
||||
open X86
|
||||
open Sim.Simulator
|
||||
open Gradedtests
|
||||
open Asm
|
||||
(* 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. *)
|
||||
|
||||
|
||||
let test_my =
|
||||
let bin = [
|
||||
InsB0 (Movq, Asm.[ ~$42; ~%Rax ]);
|
||||
InsFrag;
|
||||
InsFrag;
|
||||
InsFrag;
|
||||
InsFrag;
|
||||
InsFrag;
|
||||
InsFrag;
|
||||
InsFrag;
|
||||
]
|
||||
|
||||
in
|
||||
|
||||
let asm = [gtext "main"
|
||||
[
|
||||
Movq, [~$42; ~%Rax]];
|
||||
] in
|
||||
|
||||
(assert_eqf (fun() -> (assemble asm).text_seg) bin )
|
||||
|
||||
|
||||
let mov_ri =
|
||||
test_machine
|
||||
[
|
||||
InsB0 (Movq, Asm.[ ~$42; ~%Rax ]);
|
||||
InsFrag;
|
||||
InsFrag;
|
||||
InsFrag;
|
||||
InsFrag;
|
||||
InsFrag;
|
||||
InsFrag;
|
||||
InsFrag;
|
||||
]
|
||||
|
||||
let provided_tests : suite = [
|
||||
|
||||
Test ("My Tests", [
|
||||
("assert", test_my)
|
||||
]);
|
||||
|
||||
Test ("Student-Provided Big Test for Part III: Score recorded as PartIIITestCase", [
|
||||
|
||||
]);
|
||||
|
||||
]
|
||||
open Util.Assert
|
||||
open X86
|
||||
open Sim.Simulator
|
||||
open Gradedtests
|
||||
open Asm
|
||||
(* 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. *)
|
||||
|
||||
|
||||
let test_my =
|
||||
let bin = [
|
||||
InsB0 (Movq, Asm.[ ~$42; ~%Rax ]);
|
||||
InsFrag;
|
||||
InsFrag;
|
||||
InsFrag;
|
||||
InsFrag;
|
||||
InsFrag;
|
||||
InsFrag;
|
||||
InsFrag;
|
||||
]
|
||||
|
||||
in
|
||||
|
||||
let asm = [gtext "main"
|
||||
[
|
||||
Movq, [~$42; ~%Rax]];
|
||||
] in
|
||||
|
||||
(assert_eqf (fun() -> (assemble asm).text_seg) bin )
|
||||
|
||||
|
||||
let mov_ri =
|
||||
test_machine
|
||||
[
|
||||
InsB0 (Movq, Asm.[ ~$42; ~%Rax ]);
|
||||
InsFrag;
|
||||
InsFrag;
|
||||
InsFrag;
|
||||
InsFrag;
|
||||
InsFrag;
|
||||
InsFrag;
|
||||
InsFrag;
|
||||
]
|
||||
|
||||
let provided_tests : suite = [
|
||||
|
||||
Test ("My Tests", [
|
||||
("assert", test_my)
|
||||
]);
|
||||
|
||||
Test ("Student-Provided Big Test for Part III: Score recorded as PartIIITestCase", [
|
||||
|
||||
]);
|
||||
|
||||
]
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue