mirror of
https://github.com/ProgramSnail/Lama.git
synced 2025-12-06 06:48:48 +00:00
Added flags and style fixed
This commit is contained in:
Roman Venediktov
parent
d13c559934
commit
02209117f4
6 changed files with 314 additions and 314 deletions
16
Makefile
16
Makefile
|
|
@ -8,23 +8,14 @@ BUILDDIR = build
|
|||
all:
|
||||
$(MAKE) -C src
|
||||
$(MAKE) -C runtime
|
||||
# $(MAKE) -C byterun
|
||||
$(MAKE) -C stdlib
|
||||
# $(MAKE) -C runtime unit_tests.o
|
||||
# $(MAKE) -C runtime invariants_check.o
|
||||
# $(MAKE) -C runtime invariants_check_debug_print.o
|
||||
|
||||
STD_FILES=$(shell ls stdlib/*.[oi] stdlib/*.lama runtime/runtime.a runtime/Std.i)
|
||||
|
||||
remake_runtime:
|
||||
$(MAKE) -C runtime clean
|
||||
$(MAKE) -C runtime all
|
||||
|
||||
copy_to_build: all remake_runtime
|
||||
build: all
|
||||
mkdir -p $(BUILDDIR)
|
||||
cp -r runtime/Std.i runtime/runtime.a stdlib/* src/lamac $(BUILDDIR)
|
||||
|
||||
|
||||
install: all
|
||||
$(INSTALL) $(EXECUTABLE) `opam var bin`
|
||||
$(MKDIR) -p `opam var share`/Lama
|
||||
|
|
@ -44,11 +35,6 @@ regression-expressions:
|
|||
$(MAKE) clean check -j8 -C regression/expressions
|
||||
$(MAKE) clean check -j8 -C regression/deep-expressions
|
||||
|
||||
unit_tests:
|
||||
./runtime/unit_tests.o
|
||||
./runtime/invariants_check.o
|
||||
./runtime/invariants_check_debug_print.o
|
||||
|
||||
negative_scenarios_tests:
|
||||
$(MAKE) -C runtime negative_tests
|
||||
|
||||
|
|
|
|||
|
|
@ -14,11 +14,9 @@ TEST_FLAGS=$(COMMON_FLAGS) -DDEBUG_VERSION
|
|||
UNIT_TESTS_FLAGS=$(TEST_FLAGS)
|
||||
INVARIANTS_CHECK_FLAGS=$(TEST_FLAGS) -DFULL_INVARIANT_CHECKS
|
||||
|
||||
# this target is the most important one, its' artefacts should be used as a runtime of x86-64 version of Lama
|
||||
all: gc64.o runtime64.o printf.o
|
||||
ar rc runtime.a runtime64.o gc64.o printf.o
|
||||
|
||||
# this target is the most important one, its' artefacts should be used as a runtime of x86 (32-bits) version Lama
|
||||
all32: gc.o runtime.o
|
||||
ar rc runtime.a runtime.o gc.o
|
||||
|
||||
|
|
@ -31,16 +29,12 @@ $(NEGATIVE_TESTS): %: negative_scenarios/%.c
|
|||
|
||||
negative_tests: $(NEGATIVE_TESTS)
|
||||
|
||||
# this is a target that runs unit tests, scenarios are written in a single file `test_main.c`
|
||||
unit_tests.o: gc.c gc.h runtime.c runtime.h runtime_common.h virt_stack.c virt_stack.h test_main.c test_util.s
|
||||
$(CC) -o unit_tests.o $(UNIT_TESTS_FLAGS) gc.c virt_stack.c runtime.c test_main.c test_util.s
|
||||
|
||||
# this target also runs unit tests but with additional expensive checks of GC invariants which aren't used in production version
|
||||
invariants_check.o: gc.c gc.h runtime.c runtime.h runtime_common.h virt_stack.c virt_stack.h test_main.c test_util.s
|
||||
$(CC) -o invariants_check.o $(INVARIANTS_CHECK_FLAGS) gc.c virt_stack.c runtime.c test_main.c test_util.s
|
||||
|
||||
# this target also runs unit tests but with additional expensive checks of GC invariants which aren't used in production version
|
||||
# additionally, it prints debug information
|
||||
invariants_check_debug_print.o: gc.c gc.h runtime.c runtime.h runtime_common.h virt_stack.c virt_stack.h test_main.c test_util.s
|
||||
$(CC) -o invariants_check_debug_print.o $(INVARIANTS_CHECK_FLAGS) -DDEBUG_PRINT gc.c virt_stack.c runtime.c test_main.c test_util.s
|
||||
|
||||
|
|
|
|||
194
src/Driver.ml
194
src/Driver.ml
|
|
@ -1,196 +1,4 @@
|
|||
exception Commandline_error of string
|
||||
|
||||
class options args =
|
||||
let n = Array.length args in
|
||||
let dump_ast = 0b1 in
|
||||
let dump_sm = 0b010 in
|
||||
let dump_source = 0b100 in
|
||||
(* Kakadu: binary masks are cool for C code, but for OCaml I don't see any reason to save memory like this *)
|
||||
let runtime_path_ =
|
||||
match Sys.getenv_opt "LAMA" with Some s -> s | None -> Stdpath.path
|
||||
in
|
||||
let help_string =
|
||||
"Lama compiler. (C) JetBrains Reserach, 2017-2020.\n"
|
||||
^ "Usage: lamac <options> <input file>\n\n"
|
||||
^ "When no options specified, builds the source file into executable.\n"
|
||||
^ "Options:\n" ^ " -c --- compile into object file\n"
|
||||
^ " -o <file> --- write executable into file <file>\n"
|
||||
^ " -I <path> --- add <path> into unit search path list\n"
|
||||
^ " -i --- interpret on a source-level interpreter\n"
|
||||
^ " -s --- compile into stack machine code and interpret on the \
|
||||
stack machine initerpreter\n"
|
||||
^ " -dp --- dump AST (the output will be written into .ast file)\n"
|
||||
^ " -dsrc --- dump pretty-printed source code\n"
|
||||
^ " -ds --- dump stack machine code (the output will be written \
|
||||
into .sm file; has no\n"
|
||||
^ " effect if -i option is specfied)\n"
|
||||
^ " -b --- compile to a stack machine bytecode\n"
|
||||
^ " -v --- show version\n" ^ " -h --- show this help\n"
|
||||
in
|
||||
object (self)
|
||||
val version = ref false
|
||||
val help = ref false
|
||||
val i = ref 1
|
||||
val infile = ref (None : string option)
|
||||
val outfile = ref (None : string option)
|
||||
val runtime_path = runtime_path_
|
||||
val paths = ref [ runtime_path_ ]
|
||||
val mode = ref (`Default : [ `Default | `Eval | `SM | `Compile | `BC ])
|
||||
val curdir = Unix.getcwd ()
|
||||
val debug = ref false
|
||||
|
||||
(* Workaround until Ostap starts to memoize properly *)
|
||||
val const = ref false
|
||||
|
||||
(* end of the workaround *)
|
||||
val dump = ref 0
|
||||
|
||||
initializer
|
||||
let rec loop () =
|
||||
match self#peek with
|
||||
| Some opt ->
|
||||
(match opt with
|
||||
(* Workaround until Ostap starts to memoize properly *)
|
||||
| "-w" -> self#set_workaround
|
||||
(* end of the workaround *)
|
||||
| "-c" -> self#set_mode `Compile
|
||||
| "-o" -> (
|
||||
match self#peek with
|
||||
| None ->
|
||||
raise
|
||||
(Commandline_error
|
||||
"File name expected after '-o' specifier")
|
||||
| Some fname -> self#set_outfile fname)
|
||||
| "-I" -> (
|
||||
match self#peek with
|
||||
| None ->
|
||||
raise
|
||||
(Commandline_error "Path expected after '-I' specifier")
|
||||
| Some path -> self#add_include_path path)
|
||||
| "-s" -> self#set_mode `SM
|
||||
| "-b" -> self#set_mode `BC
|
||||
| "-i" -> self#set_mode `Eval
|
||||
| "-ds" -> self#set_dump dump_sm
|
||||
| "-dsrc" -> self#set_dump dump_source
|
||||
| "-dp" -> self#set_dump dump_ast
|
||||
| "-h" -> self#set_help
|
||||
| "-v" -> self#set_version
|
||||
| "-g" -> self#set_debug
|
||||
| _ ->
|
||||
if opt.[0] = '-' then
|
||||
raise
|
||||
(Commandline_error
|
||||
(Printf.sprintf "Invalid command line specifier ('%s')"
|
||||
opt))
|
||||
else self#set_infile opt);
|
||||
loop ()
|
||||
| None -> ()
|
||||
in
|
||||
loop ()
|
||||
|
||||
(* Workaround until Ostap starts to memoize properly *)
|
||||
method is_workaround = !const
|
||||
method private set_workaround = const := true
|
||||
|
||||
(* end of the workaround *)
|
||||
method private set_help = help := true
|
||||
method private set_version = version := true
|
||||
method private set_dump mask = dump := !dump lor mask
|
||||
|
||||
method private set_infile name =
|
||||
match !infile with
|
||||
| None -> infile := Some name
|
||||
| Some name' ->
|
||||
raise
|
||||
(Commandline_error
|
||||
(Printf.sprintf "Input file ('%s') already specified" name'))
|
||||
|
||||
method private set_outfile name =
|
||||
match !outfile with
|
||||
| None -> outfile := Some name
|
||||
| Some name' ->
|
||||
raise
|
||||
(Commandline_error
|
||||
(Printf.sprintf "Output file ('%s') already specified" name'))
|
||||
|
||||
method private add_include_path path = paths := path :: !paths
|
||||
|
||||
method private set_mode s =
|
||||
match !mode with
|
||||
| `Default -> mode := s
|
||||
| _ -> raise (Commandline_error "Extra compilation mode specifier")
|
||||
|
||||
method private peek =
|
||||
let j = !i in
|
||||
if j < n then (
|
||||
incr i;
|
||||
Some args.(j))
|
||||
else None
|
||||
|
||||
method get_mode = !mode
|
||||
|
||||
method get_output_option =
|
||||
match !outfile with
|
||||
| None -> Printf.sprintf "-o %s" self#basename
|
||||
| Some name -> Printf.sprintf "-o %s" name
|
||||
|
||||
method get_absolute_infile =
|
||||
let f = self#get_infile in
|
||||
if Filename.is_relative f then Filename.concat curdir f else f
|
||||
|
||||
method get_infile =
|
||||
match !infile with
|
||||
| None -> raise (Commandline_error "Input file not specified")
|
||||
| Some name -> name
|
||||
|
||||
method get_help = !help
|
||||
method get_include_paths = !paths
|
||||
method get_runtime_path = runtime_path
|
||||
|
||||
method basename =
|
||||
Filename.chop_suffix (Filename.basename self#get_infile) ".lama"
|
||||
|
||||
method topname =
|
||||
match !mode with `Compile -> "init" ^ self#basename | _ -> "main"
|
||||
|
||||
method dump_file ext contents =
|
||||
let name = self#basename in
|
||||
let outf = open_out (Printf.sprintf "%s.%s" name ext) in
|
||||
Printf.fprintf outf "%s" contents;
|
||||
close_out outf
|
||||
|
||||
method dump_AST ast =
|
||||
if !dump land dump_ast > 0 then (
|
||||
let buf = Buffer.create 1024 in
|
||||
Buffer.add_string buf "<html>";
|
||||
Buffer.add_string buf
|
||||
(Printf.sprintf "<title> %s </title>" self#get_infile);
|
||||
Buffer.add_string buf "<body><li>";
|
||||
GT.html Language.Expr.t ast buf;
|
||||
Buffer.add_string buf "</li></body>";
|
||||
Buffer.add_string buf "</html>";
|
||||
self#dump_file "html" (Buffer.contents buf))
|
||||
|
||||
method dump_source (ast : Language.Expr.t) =
|
||||
if !dump land dump_source > 0 then Pprinter.pp Format.std_formatter ast
|
||||
|
||||
method dump_SM sm =
|
||||
if !dump land dump_sm > 0 then self#dump_file "sm" (SM.show_prg sm)
|
||||
else ()
|
||||
|
||||
method greet =
|
||||
(match !outfile with
|
||||
| None -> ()
|
||||
| Some _ -> (
|
||||
match !mode with
|
||||
| `Default -> ()
|
||||
| _ -> Printf.printf "Output file option ignored in this mode.\n"));
|
||||
if !version then Printf.printf "%s\n" Version.version;
|
||||
if !help then Printf.printf "%s" help_string
|
||||
|
||||
method get_debug = if !debug then "" else "-g"
|
||||
method set_debug = debug := true
|
||||
end
|
||||
open Options
|
||||
|
||||
let[@ocaml.warning "-32"] main =
|
||||
try
|
||||
|
|
|
|||
211
src/Options.ml
Normal file
211
src/Options.ml
Normal file
|
|
@ -0,0 +1,211 @@
|
|||
exception Commandline_error of string
|
||||
|
||||
type arch_t = X86_64 | X86
|
||||
type os_t = Linux | Darwin
|
||||
|
||||
class options args =
|
||||
let n = Array.length args in
|
||||
let dump_ast = 0b1 in
|
||||
let dump_sm = 0b010 in
|
||||
let dump_source = 0b100 in
|
||||
(* Kakadu: binary masks are cool for C code, but for OCaml I don't see any reason to save memory like this *)
|
||||
let runtime_path_ =
|
||||
match Sys.getenv_opt "LAMA" with Some s -> s | None -> Stdpath.path
|
||||
in
|
||||
let host_os =
|
||||
let uname = Posix_uname.uname () in
|
||||
match uname.sysname with
|
||||
| "Darwin" -> Darwin
|
||||
| "Linux" -> Linux
|
||||
| _ -> failwith "Unsupported OS"
|
||||
in
|
||||
let help_string =
|
||||
"Lama compiler. (C) JetBrains Reserach, 2017-2020.\n"
|
||||
^ "Usage: lamac <options> <input file>\n\n"
|
||||
^ "When no options specified, builds the source file into executable.\n"
|
||||
^ "Options:\n" ^ " -c --- compile into object file\n"
|
||||
^ " -o <file> --- write executable into file <file>\n"
|
||||
^ " -I <path> --- add <path> into unit search path list\n"
|
||||
^ " -i --- interpret on a source-level interpreter\n"
|
||||
^ " -s --- compile into stack machine code and interpret on the \
|
||||
stack machine initerpreter\n"
|
||||
^ " -m32 --- compile into x86 architecture\n"
|
||||
^ " -g --- add more debug info and runtime checks\n"
|
||||
^ " -dp --- dump AST (the output will be written into .ast file)\n"
|
||||
^ " -dsrc --- dump pretty-printed source code\n"
|
||||
^ " -ds --- dump stack machine code (the output will be written \
|
||||
into .sm file; has no\n"
|
||||
^ " effect if -i option is specfied)\n"
|
||||
^ " -b --- compile to a stack machine bytecode\n"
|
||||
^ " -v --- show version\n" ^ " -h --- show this help\n"
|
||||
in
|
||||
object (self)
|
||||
val version = ref false
|
||||
val help = ref false
|
||||
val i = ref 1
|
||||
val infile = ref (None : string option)
|
||||
val outfile = ref (None : string option)
|
||||
val runtime_path = runtime_path_
|
||||
val paths = ref [ runtime_path_ ]
|
||||
val mode = ref (`Default : [ `Default | `Eval | `SM | `Compile | `BC ])
|
||||
val curdir = Unix.getcwd ()
|
||||
val debug = ref false
|
||||
val arch = ref X86_64
|
||||
val target_os = host_os
|
||||
|
||||
(* Workaround until Ostap starts to memoize properly *)
|
||||
val const = ref false
|
||||
|
||||
(* end of the workaround *)
|
||||
val dump = ref 0
|
||||
|
||||
initializer
|
||||
let set_debug () = debug := true in
|
||||
let set_x86 () = arch := X86 in
|
||||
let rec loop () =
|
||||
match self#peek with
|
||||
| Some opt ->
|
||||
(match opt with
|
||||
(* Workaround until Ostap starts to memoize properly *)
|
||||
| "-w" -> self#set_workaround
|
||||
(* end of the workaround *)
|
||||
| "-c" -> self#set_mode `Compile
|
||||
| "-o" -> (
|
||||
match self#peek with
|
||||
| None ->
|
||||
raise
|
||||
(Commandline_error
|
||||
"File name expected after '-o' specifier")
|
||||
| Some fname -> self#set_outfile fname)
|
||||
| "-I" -> (
|
||||
match self#peek with
|
||||
| None ->
|
||||
raise
|
||||
(Commandline_error "Path expected after '-I' specifier")
|
||||
| Some path -> self#add_include_path path)
|
||||
| "-s" -> self#set_mode `SM
|
||||
| "-b" -> self#set_mode `BC
|
||||
| "-i" -> self#set_mode `Eval
|
||||
| "-ds" -> self#set_dump dump_sm
|
||||
| "-dsrc" -> self#set_dump dump_source
|
||||
| "-dp" -> self#set_dump dump_ast
|
||||
| "-h" -> self#set_help
|
||||
| "-v" -> self#set_version
|
||||
| "-g" -> set_debug ()
|
||||
| "-m32" -> set_x86 ()
|
||||
| _ ->
|
||||
if opt.[0] = '-' then
|
||||
raise
|
||||
(Commandline_error
|
||||
(Printf.sprintf "Invalid command line specifier ('%s')"
|
||||
opt))
|
||||
else self#set_infile opt);
|
||||
loop ()
|
||||
| None -> ()
|
||||
in
|
||||
loop ()
|
||||
|
||||
(* Workaround until Ostap starts to memoize properly *)
|
||||
method is_workaround = !const
|
||||
method private set_workaround = const := true
|
||||
|
||||
(* end of the workaround *)
|
||||
method private set_help = help := true
|
||||
method private set_version = version := true
|
||||
method private set_dump mask = dump := !dump lor mask
|
||||
|
||||
method private set_infile name =
|
||||
match !infile with
|
||||
| None -> infile := Some name
|
||||
| Some name' ->
|
||||
raise
|
||||
(Commandline_error
|
||||
(Printf.sprintf "Input file ('%s') already specified" name'))
|
||||
|
||||
method private set_outfile name =
|
||||
match !outfile with
|
||||
| None -> outfile := Some name
|
||||
| Some name' ->
|
||||
raise
|
||||
(Commandline_error
|
||||
(Printf.sprintf "Output file ('%s') already specified" name'))
|
||||
|
||||
method private add_include_path path = paths := path :: !paths
|
||||
|
||||
method private set_mode s =
|
||||
match !mode with
|
||||
| `Default -> mode := s
|
||||
| _ -> raise (Commandline_error "Extra compilation mode specifier")
|
||||
|
||||
method private peek =
|
||||
let j = !i in
|
||||
if j < n then (
|
||||
incr i;
|
||||
Some args.(j))
|
||||
else None
|
||||
|
||||
method get_mode = !mode
|
||||
|
||||
method get_output_option =
|
||||
match !outfile with
|
||||
| None -> Printf.sprintf "-o %s" self#basename
|
||||
| Some name -> Printf.sprintf "-o %s" name
|
||||
|
||||
method get_absolute_infile =
|
||||
let f = self#get_infile in
|
||||
if Filename.is_relative f then Filename.concat curdir f else f
|
||||
|
||||
method get_infile =
|
||||
match !infile with
|
||||
| None -> raise (Commandline_error "Input file not specified")
|
||||
| Some name -> name
|
||||
|
||||
method get_help = !help
|
||||
method get_include_paths = !paths
|
||||
method get_runtime_path = runtime_path
|
||||
|
||||
method basename =
|
||||
Filename.chop_suffix (Filename.basename self#get_infile) ".lama"
|
||||
|
||||
method topname =
|
||||
match !mode with `Compile -> "init" ^ self#basename | _ -> "main"
|
||||
|
||||
method dump_file ext contents =
|
||||
let name = self#basename in
|
||||
let outf = open_out (Printf.sprintf "%s.%s" name ext) in
|
||||
Printf.fprintf outf "%s" contents;
|
||||
close_out outf
|
||||
|
||||
method dump_AST ast =
|
||||
if !dump land dump_ast > 0 then (
|
||||
let buf = Buffer.create 1024 in
|
||||
Buffer.add_string buf "<html>";
|
||||
Buffer.add_string buf
|
||||
(Printf.sprintf "<title> %s </title>" self#get_infile);
|
||||
Buffer.add_string buf "<body><li>";
|
||||
GT.html Language.Expr.t ast buf;
|
||||
Buffer.add_string buf "</li></body>";
|
||||
Buffer.add_string buf "</html>";
|
||||
self#dump_file "html" (Buffer.contents buf))
|
||||
|
||||
method dump_source (ast : Language.Expr.t) =
|
||||
if !dump land dump_source > 0 then Pprinter.pp Format.std_formatter ast
|
||||
|
||||
method dump_SM sm =
|
||||
if !dump land dump_sm > 0 then self#dump_file "sm" (SM.show_prg sm)
|
||||
else ()
|
||||
|
||||
method greet =
|
||||
(match !outfile with
|
||||
| None -> ()
|
||||
| Some _ -> (
|
||||
match !mode with
|
||||
| `Default -> ()
|
||||
| _ -> Printf.printf "Output file option ignored in this mode.\n"));
|
||||
if !version then Printf.printf "%s\n" Version.version;
|
||||
if !help then Printf.printf "%s" help_string
|
||||
|
||||
method is_debug = !debug
|
||||
method arch = !arch
|
||||
method target_os = target_os
|
||||
end
|
||||
159
src/X86_64.ml
159
src/X86_64.ml
|
|
@ -1,20 +1,11 @@
|
|||
open GT
|
||||
open Language
|
||||
open SM
|
||||
open Options
|
||||
|
||||
(* X86 codegeneration interface *)
|
||||
|
||||
type os_t = Linux | Darwin
|
||||
|
||||
let os =
|
||||
let uname = Posix_uname.uname () in
|
||||
match uname.sysname with
|
||||
| "Darwin" -> Darwin
|
||||
| "Linux" -> Linux
|
||||
| _ -> failwith "Unsupported OS"
|
||||
|
||||
let prefix = match os with Linux -> "" | Darwin -> "_"
|
||||
let prefixed name = prefix ^ name
|
||||
type compilation_mode_t = { is_debug : bool; target_os : os_t }
|
||||
|
||||
module Register : sig
|
||||
type t
|
||||
|
|
@ -214,16 +205,16 @@ let stack_offset i =
|
|||
if i >= 0 then (i + 1) * word_size else (-i + 1) * word_size
|
||||
|
||||
(* Instruction printer *)
|
||||
let show instr =
|
||||
let show env instr =
|
||||
let rec opnd = function
|
||||
| R r -> Register.show r
|
||||
| S i ->
|
||||
if i >= 0 then Printf.sprintf "-%d(%%rbp)" (stack_offset i)
|
||||
else Printf.sprintf "%d(%%rbp)" (stack_offset i)
|
||||
| M (_, I, _, s) -> Printf.sprintf "%s(%%rip)" (prefixed s)
|
||||
| M (F, E, _, s) -> Printf.sprintf "%s(%%rip)" (prefixed s)
|
||||
| M (D, E, _, s) -> Printf.sprintf "%s@GOTPCREL(%%rip)" (prefixed s)
|
||||
| C s -> Printf.sprintf "$%s" (prefixed s)
|
||||
| M (_, I, _, s) -> Printf.sprintf "%s(%%rip)" (env#prefixed s)
|
||||
| M (F, E, _, s) -> Printf.sprintf "%s(%%rip)" (env#prefixed s)
|
||||
| M (D, E, _, s) -> Printf.sprintf "%s@GOTPCREL(%%rip)" (env#prefixed s)
|
||||
| C s -> Printf.sprintf "$%s" (env#prefixed s)
|
||||
| L i -> Printf.sprintf "$%d" i
|
||||
| I (0, x) -> Printf.sprintf "(%s)" (opnd x)
|
||||
| I (n, x) -> Printf.sprintf "%d(%s)" n (opnd x)
|
||||
|
|
@ -252,12 +243,12 @@ let show instr =
|
|||
| Push s -> Printf.sprintf "\tpushq\t%s" (opnd s)
|
||||
| Pop s -> Printf.sprintf "\tpopq\t%s" (opnd s)
|
||||
| Ret -> "\tret"
|
||||
| Call p -> Printf.sprintf "\tcall\t%s" (prefixed p)
|
||||
| Call p -> Printf.sprintf "\tcall\t%s" (env#prefixed p)
|
||||
| CallI o -> Printf.sprintf "\tcall\t*(%s)" (opnd o)
|
||||
| Label l -> Printf.sprintf "%s:\n" (prefixed l)
|
||||
| Jmp l -> Printf.sprintf "\tjmp\t%s" (prefixed l)
|
||||
| Label l -> Printf.sprintf "%s:\n" (env#prefixed l)
|
||||
| Jmp l -> Printf.sprintf "\tjmp\t%s" (env#prefixed l)
|
||||
| JmpI o -> Printf.sprintf "\tjmp\t*(%s)" (opnd o)
|
||||
| CJmp (s, l) -> Printf.sprintf "\tj%s\t%s" s (prefixed l)
|
||||
| CJmp (s, l) -> Printf.sprintf "\tj%s\t%s" s (env#prefixed l)
|
||||
| Meta s -> Printf.sprintf "%s\n" s
|
||||
| Dec s -> Printf.sprintf "\tdecq\t%s" (opnd s)
|
||||
| Or1 s -> Printf.sprintf "\torq\t$0x0001,\t%s" (opnd s)
|
||||
|
|
@ -632,6 +623,9 @@ let compile_call env ?fname nargs tail =
|
|||
compile_tail_call env fname nargs
|
||||
else compile_common_call env fname nargs
|
||||
|
||||
let opt_stabs env stabs =
|
||||
match env#mode.target_os with Darwin -> [] | Linux -> stabs
|
||||
|
||||
(* Symbolic stack machine evaluator
|
||||
|
||||
compile : env -> prg -> env * instr list
|
||||
|
|
@ -644,8 +638,7 @@ let compile cmd env imports code =
|
|||
match scode with
|
||||
| [] -> (env, [])
|
||||
| instr :: scode' ->
|
||||
(* Stack state for comment in generated code. TODO: add debug flag *)
|
||||
let stack = "" (* env#show_stack*) in
|
||||
let stack_state = if env#mode.is_debug then env#show_stack else "" in
|
||||
let env', code' =
|
||||
if env#is_barrier then
|
||||
match instr with
|
||||
|
|
@ -766,18 +759,16 @@ let compile cmd env imports code =
|
|||
else f
|
||||
in
|
||||
let stabs =
|
||||
match os with
|
||||
| Darwin -> []
|
||||
| Linux ->
|
||||
if f = "main" then
|
||||
opt_stabs env
|
||||
(if f = "main" then
|
||||
[ Meta (Printf.sprintf "\t.type main, @function") ]
|
||||
else
|
||||
let func =
|
||||
[
|
||||
Meta (Printf.sprintf "\t.type %s, @function" name);
|
||||
Meta
|
||||
(Printf.sprintf "\t.stabs \"%s:F1\",36,0,0,%s"
|
||||
name f);
|
||||
(Printf.sprintf "\t.stabs \"%s:F1\",36,0,0,%s" name
|
||||
f);
|
||||
]
|
||||
in
|
||||
let arguments =
|
||||
|
|
@ -786,7 +777,7 @@ let compile cmd env imports code =
|
|||
let variables =
|
||||
List.flatten @@ List.map stabs_scope scopes
|
||||
in
|
||||
func @ arguments @ variables
|
||||
func @ arguments @ variables)
|
||||
in
|
||||
env#assert_empty_stack;
|
||||
let has_closure = closure <> [] in
|
||||
|
|
@ -856,9 +847,7 @@ let compile cmd env imports code =
|
|||
env#assert_empty_stack;
|
||||
let name = env#fname in
|
||||
let stabs =
|
||||
match os with
|
||||
| Darwin -> []
|
||||
| Linux ->
|
||||
opt_stabs env
|
||||
[ Meta (Printf.sprintf "\t.size %s, .-%s" name name) ]
|
||||
in
|
||||
( env#leave,
|
||||
|
|
@ -878,13 +867,14 @@ let compile cmd env imports code =
|
|||
Meta
|
||||
(* Allocate space for the symbolic stack
|
||||
Add extra word if needed to preserve alignment *)
|
||||
(Printf.sprintf "\t.set\t%s,\t%d" (prefixed env#lsize)
|
||||
(Printf.sprintf "\t.set\t%s,\t%d"
|
||||
(env#prefixed env#lsize)
|
||||
(if env#allocated mod 2 == 0 then
|
||||
env#allocated * word_size
|
||||
else (env#allocated + 1) * word_size));
|
||||
Meta
|
||||
(Printf.sprintf "\t.set\t%s,\t%d"
|
||||
(prefixed env#allocated_size)
|
||||
(env#prefixed env#allocated_size)
|
||||
env#allocated);
|
||||
]
|
||||
@ stabs )
|
||||
|
|
@ -931,7 +921,7 @@ let compile cmd env imports code =
|
|||
(Printf.sprintf "Unexpected pattern: StrCmp %s: %d"
|
||||
__FILE__ __LINE__))
|
||||
1 false
|
||||
| LINE _line -> env#gen_line
|
||||
| LINE line -> env#gen_line line
|
||||
| FAIL ((line, col), value) ->
|
||||
let v, env = if value then (env#peek, env) else env#pop in
|
||||
let msg_addr, env = env#string cmd#get_infile in
|
||||
|
|
@ -956,9 +946,13 @@ let compile cmd env imports code =
|
|||
(Printf.sprintf "invalid SM insn: %s\n" (GT.show insn i))
|
||||
in
|
||||
let env'', code'' = compile' env' scode' in
|
||||
( env'',
|
||||
[ Meta (Printf.sprintf "# %s / %s" (GT.show SM.insn instr) stack) ]
|
||||
@ code' @ code'' )
|
||||
let debug_info =
|
||||
let insn = GT.show SM.insn instr in
|
||||
if env#mode.is_debug then
|
||||
[ Meta ("# " ^ insn); Meta ("# " ^ stack_state) ]
|
||||
else [ Meta ("# " ^ insn) ]
|
||||
in
|
||||
(env'', debug_info @ code' @ code'')
|
||||
in
|
||||
compile' env code
|
||||
|
||||
|
|
@ -1079,8 +1073,6 @@ end = struct
|
|||
(opnd_from_loc v loc1, opnd_from_loc v loc2)
|
||||
end
|
||||
|
||||
(* Environment for symbolic stack machine *)
|
||||
|
||||
(* A set of strings *)
|
||||
module S = Set.Make (String)
|
||||
|
||||
|
|
@ -1088,7 +1080,7 @@ module S = Set.Make (String)
|
|||
module M = Map.Make (String)
|
||||
|
||||
(* Environment implementation *)
|
||||
class env prg =
|
||||
class env prg mode =
|
||||
let chars =
|
||||
"_abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789'"
|
||||
in
|
||||
|
|
@ -1109,6 +1101,7 @@ class env prg =
|
|||
val fname = "" (* function name *)
|
||||
val stackmap = M.empty (* labels to stack map *)
|
||||
val barrier = false (* barrier condition *)
|
||||
val mode = mode (* compilation mode *)
|
||||
|
||||
val max_locals_size =
|
||||
0 (* maximal number of stack position in all functions *)
|
||||
|
|
@ -1118,6 +1111,7 @@ class env prg =
|
|||
val externs = S.empty
|
||||
val nlabels = 0
|
||||
val first_line = true
|
||||
method mode = mode
|
||||
method publics = S.elements publics
|
||||
method register_public name = {<publics = S.add name publics>}
|
||||
method register_extern name = {<externs = S.add name externs>}
|
||||
|
|
@ -1129,7 +1123,14 @@ class env prg =
|
|||
if stack_slots > max_locals_size then {<max_locals_size = stack_slots>}
|
||||
else self
|
||||
|
||||
method show_stack = show_opnd (SymbolicStack.peek stack)
|
||||
method show_stack =
|
||||
let rec show stack acc =
|
||||
if SymbolicStack.is_empty stack then acc
|
||||
else
|
||||
let stack, loc = SymbolicStack.pop stack in
|
||||
show stack (show_opnd loc ^ " " ^ acc)
|
||||
in
|
||||
show stack ""
|
||||
|
||||
method print_locals =
|
||||
Printf.printf "LOCALS: size = %d\n" static_size;
|
||||
|
|
@ -1291,50 +1292,52 @@ class env prg =
|
|||
@ SymbolicStack.live_registers stack
|
||||
|
||||
(* generate a line number information for current function *)
|
||||
method gen_line =
|
||||
method gen_line line =
|
||||
let lab = Printf.sprintf ".L%d" nlabels in
|
||||
( {<nlabels = nlabels + 1; first_line = false>},
|
||||
if fname = "main" then
|
||||
[
|
||||
(* Meta (Printf.sprintf "\t.stabn 68,0,%d,%s" line lab); *)
|
||||
Label lab;
|
||||
]
|
||||
opt_stabs self
|
||||
[ Meta (Printf.sprintf "\t.stabn 68,0,%d,%s" line lab) ]
|
||||
@ [ Label lab ]
|
||||
else
|
||||
(if first_line then
|
||||
[ (* Meta (Printf.sprintf "\t.stabn 68,0,%d,0" line) *) ]
|
||||
opt_stabs self [ Meta (Printf.sprintf "\t.stabn 68,0,%d,0" line) ]
|
||||
else [])
|
||||
@ [
|
||||
(* Meta (Printf.sprintf "\t.stabn 68,0,%d,%s-%s" line lab fname); *)
|
||||
Label lab;
|
||||
] )
|
||||
@ opt_stabs self
|
||||
[ Meta (Printf.sprintf "\t.stabn 68,0,%d,%s-%s" line lab fname) ]
|
||||
@ [ Label lab ] )
|
||||
|
||||
method prefixed label =
|
||||
match mode.target_os with Darwin -> "_" ^ label | Linux -> label
|
||||
end
|
||||
|
||||
(* Generates an assembler text for a program:
|
||||
first compiles the program into the stack code,
|
||||
then generates x86 assember code,
|
||||
then generates assember code,
|
||||
then prints the assembler file *)
|
||||
let genasm cmd prog =
|
||||
let mode = { is_debug = cmd#is_debug; target_os = cmd#target_os } in
|
||||
let sm = SM.compile cmd prog in
|
||||
let env, code = compile cmd (new env sm) (fst (fst prog)) sm in
|
||||
let env, code = compile cmd (new env sm mode) (fst (fst prog)) sm in
|
||||
let globals =
|
||||
List.map
|
||||
(fun s -> Meta (Printf.sprintf "\t.globl\t%s" (prefixed s)))
|
||||
(fun s -> Meta (Printf.sprintf "\t.globl\t%s" (env#prefixed s)))
|
||||
env#publics
|
||||
in
|
||||
let data =
|
||||
[ Meta "\t.data" ]
|
||||
@ List.map
|
||||
(fun (s, v) ->
|
||||
Meta (Printf.sprintf "%s:\t.string\t\"%s\"" (prefixed v) s))
|
||||
Meta (Printf.sprintf "%s:\t.string\t\"%s\"" (env#prefixed v) s))
|
||||
env#strings
|
||||
@ [
|
||||
Meta (prefixed "init" ^ ":\t.quad 0");
|
||||
Meta (env#prefixed "init" ^ ":\t.quad 0");
|
||||
Meta
|
||||
(match os with
|
||||
(match env#mode.target_os with
|
||||
| Darwin -> "\t.section __DATA, custom_data, regular, no_dead_strip"
|
||||
| Linux -> "\t.section custom_data,\"aw\",@progbits");
|
||||
Meta
|
||||
(Printf.sprintf "%s:\t.fill\t%d, 8, 1" (prefixed "filler")
|
||||
(Printf.sprintf "%s:\t.fill\t%d, 8, 1" (env#prefixed "filler")
|
||||
env#max_locals_size);
|
||||
]
|
||||
@ List.concat
|
||||
|
|
@ -1345,33 +1348,26 @@ let genasm cmd prog =
|
|||
(String.length global_label)
|
||||
(String.length s - String.length global_label)
|
||||
in
|
||||
(match os with
|
||||
| Darwin -> []
|
||||
| Linux ->
|
||||
opt_stabs env
|
||||
[
|
||||
Meta
|
||||
(Printf.sprintf "\t.stabs \"%s:S1\",40,0,0,%s" unlabled_s s);
|
||||
])
|
||||
@ [ Meta (Printf.sprintf "%s:\t.quad\t1" (prefixed s)) ])
|
||||
Meta (Printf.sprintf "\t.stabs \"%s:S1\",40,0,0,%s" unlabled_s s);
|
||||
]
|
||||
@ [ Meta (Printf.sprintf "%s:\t.quad\t1" (env#prefixed s)) ])
|
||||
env#globals
|
||||
in
|
||||
let asm = Buffer.create 1024 in
|
||||
List.iter
|
||||
(fun i -> Buffer.add_string asm (Printf.sprintf "%s\n" @@ show i))
|
||||
(fun i -> Buffer.add_string asm (Printf.sprintf "%s\n" @@ show env i))
|
||||
([ Meta (Printf.sprintf "\t.file \"%s\"" cmd#get_absolute_infile) ]
|
||||
@ (match os with
|
||||
| Darwin -> []
|
||||
| Linux ->
|
||||
@ opt_stabs env
|
||||
[
|
||||
Meta
|
||||
(Printf.sprintf "\t.stabs \"%s\",100,0,0,.Ltext"
|
||||
cmd#get_absolute_infile);
|
||||
])
|
||||
]
|
||||
@ globals @ data
|
||||
@ [ Meta "\t.text"; Label ".Ltext" ]
|
||||
@ (match os with
|
||||
| Darwin -> []
|
||||
| Linux -> [ Meta "\t.stabs \"data:t1=r1;0;4294967295;\",128,0,0,0" ])
|
||||
@ opt_stabs env [ Meta "\t.stabs \"data:t1=r1;0;4294967295;\",128,0,0,0" ]
|
||||
@ code);
|
||||
Buffer.contents asm
|
||||
|
||||
|
|
@ -1398,10 +1394,15 @@ let build cmd prog =
|
|||
in
|
||||
cmd#dump_file "s" (genasm cmd prog);
|
||||
cmd#dump_file "i" (Interface.gen prog);
|
||||
let compiler = match os with Darwin -> "clang" | Linux -> "gcc" in
|
||||
let compiler_flags, linker_flags =
|
||||
match os with Darwin -> ("-arch x86_64", "-ld_classic") | Linux -> ("", "")
|
||||
let compiler =
|
||||
match cmd#target_os with Darwin -> "clang" | Linux -> "gcc"
|
||||
in
|
||||
let compiler_flags, linker_flags =
|
||||
match cmd#target_os with
|
||||
| Darwin -> ("-arch x86_64", "-ld_classic")
|
||||
| Linux -> ("", "")
|
||||
in
|
||||
let debug_flags = if cmd#is_debug then "-g" else "" in
|
||||
match cmd#get_mode with
|
||||
| `Default ->
|
||||
let objs = find_objects (fst @@ fst prog) cmd#get_include_paths in
|
||||
|
|
@ -1413,12 +1414,12 @@ let build cmd prog =
|
|||
objs;
|
||||
let gcc_cmdline =
|
||||
Printf.sprintf "%s %s %s %s %s %s.s %s %s/runtime.a" compiler
|
||||
compiler_flags linker_flags cmd#get_debug cmd#get_output_option
|
||||
compiler_flags linker_flags debug_flags cmd#get_output_option
|
||||
cmd#basename (Buffer.contents buf) cmd#get_runtime_path
|
||||
in
|
||||
Sys.command gcc_cmdline
|
||||
| `Compile ->
|
||||
Sys.command
|
||||
(Printf.sprintf "%s %s %s -c -g %s.s" compiler compiler_flags
|
||||
cmd#get_debug cmd#basename)
|
||||
debug_flags cmd#basename)
|
||||
| _ -> invalid_arg "must not happen"
|
||||
|
|
|
|||
2
src/dune
2
src/dune
|
|
@ -45,7 +45,7 @@
|
|||
|
||||
(library
|
||||
(name liba)
|
||||
(modules Language Pprinter stdpath version X86_64 SM)
|
||||
(modules Language Pprinter stdpath version X86_64 SM Options)
|
||||
(libraries GT ostap posix-uname)
|
||||
(flags
|
||||
(:standard
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue