st/lama_byterun
1
0
Fork 0
mirror of https://github.com/ProgramSnail/Lama.git synced 2025-12-06 14:58:50 +00:00
Code Issues Projects Releases Packages Wiki Activity Actions

Added flags and style fixed

Browse source
This commit is contained in:
Roman Venediktov 2024-07-05 13:23:20 +02:00
parent d13c559934
commit 02209117f4
6 changed files with 314 additions and 314 deletions
Download patch file Download diff file Expand all files Collapse all files

16
Makefile
View file

@ -8,23 +8,14 @@ BUILDDIR = build
all: all:
$(MAKE) -C src $(MAKE) -C src
$(MAKE) -C runtime $(MAKE) -C runtime
# $(MAKE) -C byterun
$(MAKE) -C stdlib $(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) STD_FILES=$(shell ls stdlib/*.[oi] stdlib/*.lama runtime/runtime.a runtime/Std.i)
remake_runtime: build: all
$(MAKE) -C runtime clean
$(MAKE) -C runtime all
copy_to_build: all remake_runtime
mkdir -p $(BUILDDIR) mkdir -p $(BUILDDIR)
cp -r runtime/Std.i runtime/runtime.a stdlib/* src/lamac $(BUILDDIR) cp -r runtime/Std.i runtime/runtime.a stdlib/* src/lamac $(BUILDDIR)
install: all install: all
$(INSTALL) $(EXECUTABLE) `opam var bin` $(INSTALL) $(EXECUTABLE) `opam var bin`
$(MKDIR) -p `opam var share`/Lama $(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/expressions
$(MAKE) clean check -j8 -C regression/deep-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: negative_scenarios_tests:
$(MAKE) -C runtime negative_tests $(MAKE) -C runtime negative_tests

6
runtime/Makefile
View file

@ -14,11 +14,9 @@ TEST_FLAGS=$(COMMON_FLAGS) -DDEBUG_VERSION
UNIT_TESTS_FLAGS=$(TEST_FLAGS) UNIT_TESTS_FLAGS=$(TEST_FLAGS)
INVARIANTS_CHECK_FLAGS=$(TEST_FLAGS) -DFULL_INVARIANT_CHECKS 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 all: gc64.o runtime64.o printf.o
ar rc runtime.a runtime64.o gc64.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 all32: gc.o runtime.o
ar rc runtime.a runtime.o gc.o ar rc runtime.a runtime.o gc.o
@ -31,16 +29,12 @@ $(NEGATIVE_TESTS): %: negative_scenarios/%.c
negative_tests: $(NEGATIVE_TESTS) 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 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 $(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 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 $(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 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 $(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
View file

@ -1,196 +1,4 @@
exception Commandline_error of string open Options
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
let[@ocaml.warning "-32"] main = let[@ocaml.warning "-32"] main =
try try

211
src/Options.ml Normal file
View 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
View file

@ -1,20 +1,11 @@
open GT open GT
open Language open Language
open SM open SM
open Options
(* X86 codegeneration interface *) (* X86 codegeneration interface *)
type os_t = Linux | Darwin type compilation_mode_t = { is_debug : bool; target_os : os_t }
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
module Register : sig module Register : sig
type t type t
@ -214,16 +205,16 @@ let stack_offset i =
if i >= 0 then (i + 1) * word_size else (-i + 1) * word_size if i >= 0 then (i + 1) * word_size else (-i + 1) * word_size
(* Instruction printer *) (* Instruction printer *)
let show instr = let show env instr =
let rec opnd = function let rec opnd = function
| R r -> Register.show r | R r -> Register.show r
| S i -> | S i ->
if i >= 0 then Printf.sprintf "-%d(%%rbp)" (stack_offset i) if i >= 0 then Printf.sprintf "-%d(%%rbp)" (stack_offset i)
else 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 (_, I, _, s) -> Printf.sprintf "%s(%%rip)" (env#prefixed s)
| M (F, E, _, s) -> Printf.sprintf "%s(%%rip)" (prefixed s) | M (F, E, _, s) -> Printf.sprintf "%s(%%rip)" (env#prefixed s)
| M (D, E, _, s) -> Printf.sprintf "%s@GOTPCREL(%%rip)" (prefixed s) | M (D, E, _, s) -> Printf.sprintf "%s@GOTPCREL(%%rip)" (env#prefixed s)
| C s -> Printf.sprintf "$%s" (prefixed s) | C s -> Printf.sprintf "$%s" (env#prefixed s)
| L i -> Printf.sprintf "$%d" i | L i -> Printf.sprintf "$%d" i
| I (0, x) -> Printf.sprintf "(%s)" (opnd x) | I (0, x) -> Printf.sprintf "(%s)" (opnd x)
| I (n, x) -> Printf.sprintf "%d(%s)" n (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) | Push s -> Printf.sprintf "\tpushq\t%s" (opnd s)
| Pop s -> Printf.sprintf "\tpopq\t%s" (opnd s) | Pop s -> Printf.sprintf "\tpopq\t%s" (opnd s)
| Ret -> "\tret" | 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) | CallI o -> Printf.sprintf "\tcall\t*(%s)" (opnd o)
| Label l -> Printf.sprintf "%s:\n" (prefixed l) | Label l -> Printf.sprintf "%s:\n" (env#prefixed l)
| Jmp l -> Printf.sprintf "\tjmp\t%s" (prefixed l) | Jmp l -> Printf.sprintf "\tjmp\t%s" (env#prefixed l)
| JmpI o -> Printf.sprintf "\tjmp\t*(%s)" (opnd o) | 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 | Meta s -> Printf.sprintf "%s\n" s
| Dec s -> Printf.sprintf "\tdecq\t%s" (opnd s) | Dec s -> Printf.sprintf "\tdecq\t%s" (opnd s)
| Or1 s -> Printf.sprintf "\torq\t$0x0001,\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 compile_tail_call env fname nargs
else compile_common_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 (* Symbolic stack machine evaluator
compile : env -> prg -> env * instr list compile : env -> prg -> env * instr list
@ -644,8 +638,7 @@ let compile cmd env imports code =
match scode with match scode with
| [] -> (env, []) | [] -> (env, [])
| instr :: scode' -> | instr :: scode' ->
(* Stack state for comment in generated code. TODO: add debug flag *) let stack_state = if env#mode.is_debug then env#show_stack else "" in
let stack = "" (* env#show_stack*) in
let env', code' = let env', code' =
if env#is_barrier then if env#is_barrier then
match instr with match instr with
@ -766,18 +759,16 @@ let compile cmd env imports code =
else f else f
in in
let stabs = let stabs =
match os with opt_stabs env
| Darwin -> [] (if f = "main" then
| Linux ->
if f = "main" then
[ Meta (Printf.sprintf "\t.type main, @function") ] [ Meta (Printf.sprintf "\t.type main, @function") ]
else else
let func = let func =
[ [
Meta (Printf.sprintf "\t.type %s, @function" name); Meta (Printf.sprintf "\t.type %s, @function" name);
Meta Meta
(Printf.sprintf "\t.stabs \"%s:F1\",36,0,0,%s" (Printf.sprintf "\t.stabs \"%s:F1\",36,0,0,%s" name
name f); f);
] ]
in in
let arguments = let arguments =
@ -786,7 +777,7 @@ let compile cmd env imports code =
let variables = let variables =
List.flatten @@ List.map stabs_scope scopes List.flatten @@ List.map stabs_scope scopes
in in
func @ arguments @ variables func @ arguments @ variables)
in in
env#assert_empty_stack; env#assert_empty_stack;
let has_closure = closure <> [] in let has_closure = closure <> [] in
@ -856,9 +847,7 @@ let compile cmd env imports code =
env#assert_empty_stack; env#assert_empty_stack;
let name = env#fname in let name = env#fname in
let stabs = let stabs =
match os with opt_stabs env
| Darwin -> []
| Linux ->
[ Meta (Printf.sprintf "\t.size %s, .-%s" name name) ] [ Meta (Printf.sprintf "\t.size %s, .-%s" name name) ]
in in
( env#leave, ( env#leave,
@ -878,13 +867,14 @@ let compile cmd env imports code =
Meta Meta
(* Allocate space for the symbolic stack (* Allocate space for the symbolic stack
Add extra word if needed to preserve alignment *) 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 (if env#allocated mod 2 == 0 then
env#allocated * word_size env#allocated * word_size
else (env#allocated + 1) * word_size)); else (env#allocated + 1) * word_size));
Meta Meta
(Printf.sprintf "\t.set\t%s,\t%d" (Printf.sprintf "\t.set\t%s,\t%d"
(prefixed env#allocated_size) (env#prefixed env#allocated_size)
env#allocated); env#allocated);
] ]
@ stabs ) @ stabs )
@ -931,7 +921,7 @@ let compile cmd env imports code =
(Printf.sprintf "Unexpected pattern: StrCmp %s: %d" (Printf.sprintf "Unexpected pattern: StrCmp %s: %d"
__FILE__ __LINE__)) __FILE__ __LINE__))
1 false 1 false
| LINE _line -> env#gen_line | LINE line -> env#gen_line line
| FAIL ((line, col), value) -> | FAIL ((line, col), value) ->
let v, env = if value then (env#peek, env) else env#pop in let v, env = if value then (env#peek, env) else env#pop in
let msg_addr, env = env#string cmd#get_infile 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)) (Printf.sprintf "invalid SM insn: %s\n" (GT.show insn i))
in in
let env'', code'' = compile' env' scode' in let env'', code'' = compile' env' scode' in
( env'', let debug_info =
[ Meta (Printf.sprintf "# %s / %s" (GT.show SM.insn instr) stack) ] let insn = GT.show SM.insn instr in
@ code' @ code'' ) if env#mode.is_debug then
[ Meta ("# " ^ insn); Meta ("# " ^ stack_state) ]
else [ Meta ("# " ^ insn) ]
in
(env'', debug_info @ code' @ code'')
in in
compile' env code compile' env code
@ -1079,8 +1073,6 @@ end = struct
(opnd_from_loc v loc1, opnd_from_loc v loc2) (opnd_from_loc v loc1, opnd_from_loc v loc2)
end end
(* Environment for symbolic stack machine *)
(* A set of strings *) (* A set of strings *)
module S = Set.Make (String) module S = Set.Make (String)
@ -1088,7 +1080,7 @@ module S = Set.Make (String)
module M = Map.Make (String) module M = Map.Make (String)
(* Environment implementation *) (* Environment implementation *)
class env prg = class env prg mode =
let chars = let chars =
"_abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789'" "_abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789'"
in in
@ -1109,6 +1101,7 @@ class env prg =
val fname = "" (* function name *) val fname = "" (* function name *)
val stackmap = M.empty (* labels to stack map *) val stackmap = M.empty (* labels to stack map *)
val barrier = false (* barrier condition *) val barrier = false (* barrier condition *)
val mode = mode (* compilation mode *)
val max_locals_size = val max_locals_size =
0 (* maximal number of stack position in all functions *) 0 (* maximal number of stack position in all functions *)
@ -1118,6 +1111,7 @@ class env prg =
val externs = S.empty val externs = S.empty
val nlabels = 0 val nlabels = 0
val first_line = true val first_line = true
method mode = mode
method publics = S.elements publics method publics = S.elements publics
method register_public name = {<publics = S.add name publics>} method register_public name = {<publics = S.add name publics>}
method register_extern name = {<externs = S.add name externs>} 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>} if stack_slots > max_locals_size then {<max_locals_size = stack_slots>}
else self 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 = method print_locals =
Printf.printf "LOCALS: size = %d\n" static_size; Printf.printf "LOCALS: size = %d\n" static_size;
@ -1291,50 +1292,52 @@ class env prg =
@ SymbolicStack.live_registers stack @ SymbolicStack.live_registers stack
(* generate a line number information for current function *) (* generate a line number information for current function *)
method gen_line = method gen_line line =
let lab = Printf.sprintf ".L%d" nlabels in let lab = Printf.sprintf ".L%d" nlabels in
( {<nlabels = nlabels + 1; first_line = false>}, ( {<nlabels = nlabels + 1; first_line = false>},
if fname = "main" then if fname = "main" then
[ opt_stabs self
(* Meta (Printf.sprintf "\t.stabn 68,0,%d,%s" line lab); *) [ Meta (Printf.sprintf "\t.stabn 68,0,%d,%s" line lab) ]
Label lab; @ [ Label lab ]
]
else else
(if first_line then (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 []) else [])
@ [ @ opt_stabs self
(* Meta (Printf.sprintf "\t.stabn 68,0,%d,%s-%s" line lab fname); *) [ Meta (Printf.sprintf "\t.stabn 68,0,%d,%s-%s" line lab fname) ]
Label lab; @ [ Label lab ] )
] )
method prefixed label =
match mode.target_os with Darwin -> "_" ^ label | Linux -> label
end end
(* Generates an assembler text for a program: (* Generates an assembler text for a program:
first compiles the program into the stack code, first compiles the program into the stack code,
then generates x86 assember code, then generates assember code,
then prints the assembler file *) then prints the assembler file *)
let genasm cmd prog = 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 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 = let globals =
List.map 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 env#publics
in in
let data = let data =
[ Meta "\t.data" ] [ Meta "\t.data" ]
@ List.map @ List.map
(fun (s, v) -> (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 env#strings
@ [ @ [
Meta (prefixed "init" ^ ":\t.quad 0"); Meta (env#prefixed "init" ^ ":\t.quad 0");
Meta Meta
(match os with (match env#mode.target_os with
| Darwin -> "\t.section __DATA, custom_data, regular, no_dead_strip" | Darwin -> "\t.section __DATA, custom_data, regular, no_dead_strip"
| Linux -> "\t.section custom_data,\"aw\",@progbits"); | Linux -> "\t.section custom_data,\"aw\",@progbits");
Meta 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); env#max_locals_size);
] ]
@ List.concat @ List.concat
@ -1345,33 +1348,26 @@ let genasm cmd prog =
(String.length global_label) (String.length global_label)
(String.length s - String.length global_label) (String.length s - String.length global_label)
in in
(match os with opt_stabs env
| Darwin -> []
| Linux ->
[ [
Meta Meta (Printf.sprintf "\t.stabs \"%s:S1\",40,0,0,%s" unlabled_s s);
(Printf.sprintf "\t.stabs \"%s:S1\",40,0,0,%s" unlabled_s s); ]
]) @ [ Meta (Printf.sprintf "%s:\t.quad\t1" (env#prefixed s)) ])
@ [ Meta (Printf.sprintf "%s:\t.quad\t1" (prefixed s)) ])
env#globals env#globals
in in
let asm = Buffer.create 1024 in let asm = Buffer.create 1024 in
List.iter 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) ] ([ Meta (Printf.sprintf "\t.file \"%s\"" cmd#get_absolute_infile) ]
@ (match os with @ opt_stabs env
| Darwin -> []
| Linux ->
[ [
Meta Meta
(Printf.sprintf "\t.stabs \"%s\",100,0,0,.Ltext" (Printf.sprintf "\t.stabs \"%s\",100,0,0,.Ltext"
cmd#get_absolute_infile); cmd#get_absolute_infile);
]) ]
@ globals @ data @ globals @ data
@ [ Meta "\t.text"; Label ".Ltext" ] @ [ Meta "\t.text"; Label ".Ltext" ]
@ (match os with @ opt_stabs env [ Meta "\t.stabs \"data:t1=r1;0;4294967295;\",128,0,0,0" ]
| Darwin -> []
| Linux -> [ Meta "\t.stabs \"data:t1=r1;0;4294967295;\",128,0,0,0" ])
@ code); @ code);
Buffer.contents asm Buffer.contents asm
@ -1398,10 +1394,15 @@ let build cmd prog =
in in
cmd#dump_file "s" (genasm cmd prog); cmd#dump_file "s" (genasm cmd prog);
cmd#dump_file "i" (Interface.gen prog); cmd#dump_file "i" (Interface.gen prog);
let compiler = match os with Darwin -> "clang" | Linux -> "gcc" in let compiler =
let compiler_flags, linker_flags = match cmd#target_os with Darwin -> "clang" | Linux -> "gcc"
match os with Darwin -> ("-arch x86_64", "-ld_classic") | Linux -> ("", "")
in 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 match cmd#get_mode with
| `Default -> | `Default ->
let objs = find_objects (fst @@ fst prog) cmd#get_include_paths in let objs = find_objects (fst @@ fst prog) cmd#get_include_paths in
@ -1413,12 +1414,12 @@ let build cmd prog =
objs; objs;
let gcc_cmdline = let gcc_cmdline =
Printf.sprintf "%s %s %s %s %s %s.s %s %s/runtime.a" compiler 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 cmd#basename (Buffer.contents buf) cmd#get_runtime_path
in in
Sys.command gcc_cmdline Sys.command gcc_cmdline
| `Compile -> | `Compile ->
Sys.command Sys.command
(Printf.sprintf "%s %s %s -c -g %s.s" compiler compiler_flags (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" | _ -> invalid_arg "must not happen"

2
src/dune
View file

@ -45,7 +45,7 @@
(library (library
(name liba) (name liba)
(modules Language Pprinter stdpath version X86_64 SM) (modules Language Pprinter stdpath version X86_64 SM Options)
(libraries GT ostap posix-uname) (libraries GT ostap posix-uname)
(flags (flags
(:standard (:standard