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

Prototype pie executable

Browse source
This commit is contained in:
Roman Venediktov 2024-03-14 09:01:50 +01:00
parent 9fa02845cb
commit 8df129b518
2 changed files with 68 additions and 32 deletions
Download patch file Download diff file Expand all files Collapse all files

2
Makefile
View file

@ -22,7 +22,7 @@ remake_runtime:
copy_to_build: all remake_runtime copy_to_build: all remake_runtime
mkdir -p $(BUILDDIR) mkdir -p $(BUILDDIR)
cp runtime/Std.i runtime/runtime.a stdlib/* $(BUILDDIR) cp runtime/Std.i runtime/runtime.a stdlib/* src/lamac $(BUILDDIR)
install: all install: all

98
src/X86.ml
View file

@ -88,11 +88,21 @@ end
(* We need to know the word size to calculate offsets correctly *) (* We need to know the word size to calculate offsets correctly *)
let word_size = 8 let word_size = 8
type externality = I (**Internal*) | E (**External*)
type data_kind = F (**Function*) | D (**Data*)
type addressed = A (**Address*) | V (**Value*)
(* We need to distinguish the following operand types: *) (* We need to distinguish the following operand types: *)
type opnd = type opnd =
| R of Register.t (* hard register *) | R of Register.t (* hard register *)
| S of int (* a position on the hardware stack *) | S of int (* a position on the hardware stack *)
| M of string (* a named memory location *) | M of
(* a named memory location *)
data_kind
* externality
* addressed
* string
| C of string (* a named constant *)
| L of int (* an immediate operand *) | L of int (* an immediate operand *)
| I of int * opnd (* an indirect operand with offset *) | I of int * opnd (* an indirect operand with offset *)
@ -104,9 +114,15 @@ type argument_location = Register of opnd | Stack
let rec show_opnd = function let rec show_opnd = function
| R r -> Printf.sprintf "R %s" (Register.show r) | R r -> Printf.sprintf "R %s" (Register.show r)
| S i -> Printf.sprintf "S %d" i | S i -> Printf.sprintf "S %d" i
| M s -> Printf.sprintf "M %s" s
| L i -> Printf.sprintf "L %d" i | L i -> Printf.sprintf "L %d" i
| I (i, o) -> Printf.sprintf "I %d %s" i (show_opnd o) | I (i, o) -> Printf.sprintf "I %d %s" i (show_opnd o)
| C s -> Printf.sprintf "C %s" s
| M (e, d, a, s) ->
Printf.sprintf "M %s %s %s %s"
(match e with F -> "Function" | D -> "Data")
(match d with I -> "Internal" | E -> "External")
(match a with A -> "Address" | V -> "Value")
s
(* We need to know the word size to calculate offsets correctly *) (* We need to know the word size to calculate offsets correctly *)
@ -127,15 +143,18 @@ let r13 = R Registers.r13
let r14 = R Registers.r14 let r14 = R Registers.r14
let r15 = R Registers.r15 let r15 = R Registers.r15
(* Value that could be used to fill unused stack locations *)
let filler = M (D, I, A, "filler")
(* Now x86 instruction (we do not need all of them): *) (* Now x86 instruction (we do not need all of them): *)
type instr = type instr =
(* copies a value from the first to the second operand *) (* copies a value from the first to the second operand *)
| Mov of opnd * opnd | Mov of opnd * opnd
(* loads an address of the first operand into the second *) (* loads an address of the first operand into the second *)
| Lea of opnd * opnd | Lea of opnd * opnd
(* makes a binary operation; note, the first operand *) (* makes a binary operation; note, the first operand
designates x86 operator, not the source language one *)
| Binop of string * opnd * opnd | Binop of string * opnd * opnd
(* designates x86 operator, not the source language one *)
(* x86 integer division, see instruction set reference *) (* x86 integer division, see instruction set reference *)
| IDiv of opnd | IDiv of opnd
(* see instruction set reference *) (* see instruction set reference *)
@ -184,7 +203,10 @@ let show instr =
| 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 x -> x | M (_, I, _, s) -> Printf.sprintf "%s(%%rip)" s
| M (F, E, _, s) -> Printf.sprintf "%s@plt(%%rip)" s
| M (D, E, _, s) -> Printf.sprintf "%s@GOTPCREL(%%rip)" s
| C s -> Printf.sprintf "$%s" 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)
@ -207,8 +229,11 @@ let show instr =
| IDiv s1 -> Printf.sprintf "\tidivq\t%s" (opnd s1) | IDiv s1 -> Printf.sprintf "\tidivq\t%s" (opnd s1)
| Binop (op, s1, s2) -> | Binop (op, s1, s2) ->
Printf.sprintf "\t%s\t%s,\t%s" (binop op) (opnd s1) (opnd s2) Printf.sprintf "\t%s\t%s,\t%s" (binop op) (opnd s1) (opnd s2)
| Mov ((M (_, _, A, _) as x), y) | Lea (x, y) ->
(* TODO: It looks like a bad design.
Maybe we should introduce eopnd with the boolean if we referenceing an address but not a value *)
Printf.sprintf "\tleaq\t%s,\t%s" (opnd x) (opnd y)
| Mov (s1, s2) -> Printf.sprintf "\tmovq\t%s,\t%s" (opnd s1) (opnd s2) | Mov (s1, s2) -> Printf.sprintf "\tmovq\t%s,\t%s" (opnd s1) (opnd s2)
| Lea (x, y) -> Printf.sprintf "\tlea\t%s,\t%s" (opnd x) (opnd y)
| 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"
@ -225,7 +250,7 @@ let show instr =
| Sar1 s -> Printf.sprintf "\tsarq\t%s" (opnd s) | Sar1 s -> Printf.sprintf "\tsarq\t%s" (opnd s)
| Repmovsl -> Printf.sprintf "\trep movsq\t" | Repmovsl -> Printf.sprintf "\trep movsq\t"
let in_memory = function M _ | S _ | I _ -> true | R _ | L _ -> false let in_memory = function M _ | S _ | I _ -> true | C _ | R _ | L _ -> false
let big_numeric_literal = function L num -> num > 0xFFFFFFFF | _ -> false let big_numeric_literal = function L num -> num > 0xFFFFFFFF | _ -> false
let mov x s = let mov x s =
@ -482,7 +507,7 @@ let compile_call env ?fname nargs tail =
else if aligned then else if aligned then
([], [ Binop ("+", L (word_size * stack_arguments), rsp) ]) ([], [ Binop ("+", L (word_size * stack_arguments), rsp) ])
else else
( [ Push (M "$filler") ], ( [ Push filler ],
[ Binop ("+", L (word_size * (1 + stack_arguments)), rsp) ] ) [ Binop ("+", L (word_size * (1 + stack_arguments)), rsp) ] )
in in
let call env fname = let call env fname =
@ -553,7 +578,7 @@ let compile_call env ?fname nargs tail =
else if aligned then else if aligned then
([], [ Binop ("+", L (word_size * stack_arguments), rsp) ]) ([], [ Binop ("+", L (word_size * stack_arguments), rsp) ])
else else
( [ Push (M "$filler") ], ( [ Push filler ],
[ Binop ("+", L (word_size * (1 + stack_arguments)), rsp) ] ) [ Binop ("+", L (word_size * (1 + stack_arguments)), rsp) ] )
in in
let call env fname = (env, [ Call fname ]) in let call env fname = (env, [ Call fname ]) in
@ -609,6 +634,8 @@ let compile cmd env imports code =
| EXTERN name -> (env#register_extern name, []) | EXTERN name -> (env#register_extern name, [])
| IMPORT _ -> (env, []) | IMPORT _ -> (env, [])
| CLOSURE (name, closure) -> | CLOSURE (name, closure) ->
let ext = if env#is_external name then E else I in
let address = M (F, ext, A, name) in
let l, env = env#allocate in let l, env = env#allocate in
let env, push_closure_code = let env, push_closure_code =
List.fold_left List.fold_left
@ -622,15 +649,15 @@ let compile cmd env imports code =
(1 + List.length closure) (1 + List.length closure)
false false
in in
(env, push_closure_code @ (Mov (M ("$" ^ name), l) :: call_code)) (env, push_closure_code @ mov address l @ call_code)
| CONST n -> | CONST n ->
let s, env' = env#allocate in let s, env' = env#allocate in
(env', [ Mov (L (box n), s) ]) (env', [ Mov (L (box n), s) ])
| STRING s -> | STRING s ->
let s, env = env#string s in let addr, env = env#string s in
let l, env = env#allocate in let l, env = env#allocate in
let env, call = compile_call env ~fname:".string" 1 false in let env, call = compile_call env ~fname:".string" 1 false in
(env, Mov (M ("$" ^ s), l) :: call) (env, mov addr l @ call)
| LDA x -> | LDA x ->
let s, env' = (env#variable x)#allocate in let s, env' = (env#variable x)#allocate in
let s', env'' = env'#allocate in let s', env'' = env'#allocate in
@ -732,7 +759,7 @@ let compile cmd env imports code =
@ [ Meta "\t.cfi_startproc" ] @ [ Meta "\t.cfi_startproc" ]
@ (if f = cmd#topname then @ (if f = cmd#topname then
[ [
Mov (M "_init", rax); Mov (M (D, I, V, "_init"), rax);
Binop ("test", rax, rax); Binop ("test", rax, rax);
CJmp ("z", "_continue"); CJmp ("z", "_continue");
Ret; Ret;
@ -743,7 +770,7 @@ let compile cmd env imports code =
Call (label "binoperror2"); Call (label "binoperror2");
Ret; Ret;
Label "_continue"; Label "_continue";
Mov (L 1, M "_init"); Mov (L 1, M (D, I, V, "_init"));
] ]
else []) else [])
@ [ @ [
@ -752,13 +779,13 @@ let compile cmd env imports code =
Meta "\t.cfi_offset 5, -8"; Meta "\t.cfi_offset 5, -8";
Mov (rsp, rbp); Mov (rsp, rbp);
Meta "\t.cfi_def_cfa_register\t5"; Meta "\t.cfi_def_cfa_register\t5";
Binop ("-", M ("$" ^ env#lsize), rsp); Binop ("-", C env#lsize, rsp);
Mov (rdi, r12); Mov (rdi, r12);
Mov (rsi, r13); Mov (rsi, r13);
Mov (rcx, r14); Mov (rcx, r14);
Mov (rsp, rdi); Mov (rsp, rdi);
Mov (M "$filler", rsi); Mov (filler, rsi);
Mov (M ("$" ^ env#allocated_size), rcx); Mov (C env#allocated_size, rcx);
Repmovsl; Repmovsl;
Mov (r12, rdi); Mov (r12, rdi);
Mov (r13, rsi); Mov (r13, rsi);
@ -766,11 +793,11 @@ let compile cmd env imports code =
] ]
@ (if f = "main" then @ (if f = "main" then
[ [
(* Align stack as main function is the only function that could be called without alignment *) (* Align stack as main function is the only function that could be called without alignment. TODO *)
Mov (M "$0xF", rax); Mov (L 0xF, rax);
Binop ("test", rsp, rax); Binop ("test", rsp, rax);
CJmp ("z", "_ALIGNED"); CJmp ("z", "_ALIGNED");
Push (M "$filler"); Push filler;
Label "_ALIGNED"; Label "_ALIGNED";
(* Initialize gc and arguments *) (* Initialize gc and arguments *)
Push (R Registers.rdi); Push (R Registers.rdi);
@ -863,7 +890,7 @@ let compile cmd env imports code =
| LINE line -> env#gen_line 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 s, env = env#string cmd#get_infile in let msg_addr, env = env#string cmd#get_infile in
let vr, env = env#allocate in let vr, env = env#allocate in
let sr, env = env#allocate in let sr, env = env#allocate in
let liner, env = env#allocate in let liner, env = env#allocate in
@ -876,7 +903,7 @@ let compile cmd env imports code =
[ [
Mov (L col, colr); Mov (L col, colr);
Mov (L line, liner); Mov (L line, liner);
Mov (M ("$" ^ s), sr); Mov (msg_addr, sr);
Mov (v, vr); Mov (v, vr);
] ]
@ code ) @ code )
@ -1032,7 +1059,7 @@ class env prg =
object (self) object (self)
inherit SM.indexer prg inherit SM.indexer prg
val globals = S.empty (* a set of global variables *) val globals = S.empty (* a set of global variables *)
val stringm = M.empty (* a string map *) val stringm : string M.t = M.empty (* a string map *)
val scount = 0 (* string count *) val scount = 0 (* string count *)
val stack_slots = 0 (* maximal number of stack positions *) val stack_slots = 0 (* maximal number of stack positions *)
val static_size = 0 (* static data size *) val static_size = 0 (* static data size *)
@ -1104,11 +1131,18 @@ class env prg =
(*Printf.printf "Retrieving stack for %s\n" l;*) (*Printf.printf "Retrieving stack for %s\n" l;*)
M.mem l stackmap M.mem l stackmap
method is_external name = S.mem name externs
(* gets a name for a global variable *) (* gets a name for a global variable *)
method loc x = method loc x =
match x with match x with
| Value.Global name -> M ("global_" ^ name) | Value.Global name ->
| Value.Fun name -> M ("$" ^ name) let loc_name = "global_" ^ name in
let ext = if self#is_external name then E else I in
M (D, ext, V, loc_name)
| Value.Fun name ->
let ext = if self#is_external name then E else I in
M (F, ext, A, name)
| Value.Local i -> S i | Value.Local i -> S i
| Value.Arg i when i < num_of_argument_registers -> argument_registers.(i) | Value.Arg i when i < num_of_argument_registers -> argument_registers.(i)
| Value.Arg i -> S (-(i - num_of_argument_registers) - 1) | Value.Arg i -> S (-(i - num_of_argument_registers) - 1)
@ -1178,11 +1212,13 @@ class env prg =
Buffer.contents buf Buffer.contents buf
in in
let x = escape x in let x = escape x in
try (M.find x stringm, self) let name = M.find_opt x stringm in
with Not_found -> match name with
let y = Printf.sprintf "string_%d" scount in | Some name -> (M (D, I, A, name), self)
let m = M.add x y stringm in | None ->
(y, {<scount = scount + 1; stringm = m>}) let name = Printf.sprintf "string_%d" scount in
let m = M.add x name stringm in
(M (D, I, A, name), {<scount = scount + 1; stringm = m>})
(* gets number of arguments in the current function *) (* gets number of arguments in the current function *)
method nargs = nargs method nargs = nargs
@ -1314,7 +1350,7 @@ let build cmd prog =
cmd#dump_file "i" (Interface.gen prog); cmd#dump_file "i" (Interface.gen prog);
let inc = get_std_path () in let inc = get_std_path () in
let compiler = "gcc" in let compiler = "gcc" in
let flags = "-no-pie" in let flags = "-pie" 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