Skip to content

Instantly share code, notes, and snippets.

@jdh30

jdh30/compiler7.fs

Created Mar 14, 2021
Embed
What would you like to do?
F# version of my tiny ARM A32 compiler version 7
(*
This tiny 211-line compiler converts programs written in a little ML dialect into 32-bit ARM
assembly.
This program is most easily run using FSI with flags to turn off FSI's output so the output
of this program can be piped into a file:
dotnet fsi --quiet --exec compiler7.fs >fib.s
That file can then be compiled with:
gcc -nostdlib -mcpu=cortex-a72 -mtune=cortex-a72 -mfpu=neon-fp-armv8 fib.s -o fib
Running the file appears to do nothing:
./fib
But the following line displays its exit code, the 10th Fibonacci number (55):
echo $?
*)
module Compiler7
type BinOp = Add | Sub | Mul | Div | And | Or | Eor | Bic
type Patt =
| PAny
| PInt of int
| PVar of string
| POr of Patt * Patt
type Expr =
| Int of int
| Var of string
| BinOp of Expr * BinOp * Expr
| Match of Expr * (Patt * Expr) list
| Apply of Expr * Expr
| Fun of string * Expr
| Let of string * Expr * Expr
static member (+) (f, g) = BinOp(f, Add, g)
static member (-) (f, g) = BinOp(f, Sub, g)
let stringOfOp = function
| Add -> "add "
| Sub -> "sub "
| Mul -> "mul "
| Div -> "sdiv"
| And -> "and "
| Or -> "orr "
| Eor -> "eor "
| Bic -> "bic "
let rec stringOfPatt () = function
| PAny -> "_"
| PInt n -> string n
| PVar v -> v
| POr(p1, p2) -> sprintf "%a | %a" stringOfPatt p1 stringOfPatt p2
and stringOfExpr () = function
| Int n -> string n
| Var v -> v
| BinOp(f, op, g) ->
sprintf "%s(%a, %a)" (stringOfOp op) stringOfExpr f stringOfExpr g
| Match(arg, cases) ->
sprintf "(match %a with %s)" stringOfExpr arg
(String.concat " | " (List.map stringOfCase cases))
| Apply(f, x) -> sprintf "(%a)(%a)" stringOfExpr f stringOfExpr x
| Fun(x, f) -> sprintf "(fun %s -> %a)" x stringOfExpr f
| Let(x, body, rest) ->
sprintf "let %s = %a in %a" x stringOfExpr body stringOfExpr rest
and stringOfCase (patt, expr) =
sprintf "%a -> %a" stringOfPatt patt stringOfExpr expr
module List =
let rec skip n xs =
match n, xs with
| 0, xs -> xs
| _, [] -> failwith "List.skip <n> []"
| n, _::xs -> skip (n-1) xs
let rec find o v = function
| [] ->
eprintf "Unknown variable '%s'\n" v
failwith "Unknown variable"
| vs::env ->
if List.exists ((=) v) vs then o else find (o+4) v env
let push env rs =
printf " push {r%s}\n" (String.concat ", r" (List.map (fun r -> string r) rs))
List.foldBack (fun _ env -> []::env) rs env
let pop env rs =
printf " pop {r%s}\n" (String.concat ", r" (List.map string rs))
List.skip (List.length rs) env
let mk f =
let n = ref 0 in
fun () ->
incr n
f !n
let mkLbl = mk (sprintf ".L%d")
let mkArg = mk (sprintf "arg%d")
let lr = 14
let nameTop env v =
match env with
| vs::env -> (v::vs)::env
| [] -> failwith "Attempt to name top of empty stack"
let emitLbl lbl =
printf "%s:\n" lbl
let emitInt n r =
printf " movw r%d, %d\n" r (n &&& 0xffffl)
printf " movt r%d, %d\n" r ((n >>> 16) &&& 0xffffl)
let emitVar env v r =
let offset = find 0 v env
printf " ldr r%d, [sp, #%d]\n" r offset
let rec emitPatt env arg patt fail_lbl =
match patt with
| PAny -> env
| PInt n ->
emitVar env arg 10
emitInt n 11
printf " cmp r10, r11\n"
printf " bne %s\n" fail_lbl
env
| PVar v -> nameTop env v
| POr(p1, p2) ->
let pass_lbl = mkLbl()
let next_lbl = mkLbl()
let env = emitPatt env arg p1 next_lbl
printf " b %s\n" pass_lbl
emitLbl next_lbl
let env = emitPatt env arg p2 fail_lbl
emitLbl pass_lbl
env
and emitExpr env = function
| Int n ->
emitInt n 11
push env [11]
| Var v ->
emitVar env v 11
nameTop (push env [11]) v
| BinOp(f, op, g) ->
let env = emitExpr env f
let env = emitExpr env g
let env = pop env [10; 11]
printf " %s r11, r11, r10\n" (stringOfOp op)
push env [11]
| Apply(f, x) ->
let env = emitExpr env f
let env = emitExpr env x
let env = pop env [10; 11]
let env = push env [10]
printf " blx r11\n"
env
| Match(arg, cases) ->
(* Push arg *)
let env = emitExpr env arg
(* Name top of stack *)
let arg = mkArg() in
emitCases (nameTop env arg) arg cases (mkLbl())
| Fun(x, f) ->
let fn_lbl = mkLbl()
let after_lbl = mkLbl()
printf " b %s\n" after_lbl
emitLbl fn_lbl
printf " push {lr}\n"
let env2 = emitExpr [[]; [x]] f
let env2 = pop env2 [9; 10; 11]
let _ = push env2 [9]
printf " bx r10\n"
emitLbl after_lbl
printf " ldr r11, =%s\n" fn_lbl
push env [11]
| Let(f, Fun(x, body), rest) ->
let fn_lbl = mkLbl()
let after_lbl = mkLbl()
printf " b %s\n" after_lbl
emitLbl fn_lbl
printf " ldr r11, =%s\n" fn_lbl
let env2 = push [[x]] [11; lr]
let env2 = nameTop env2 f
let env2 = emitExpr env2 body
let env2 = pop env2 [8; 9; 10; 11]
let _ = push env2 [8]
printf " bx r10\n"
emitLbl after_lbl
printf " ldr r11, =%s\n" fn_lbl
let env = push env [11]
let env = emitExpr (nameTop env f) rest
let env = pop env [10; 11]
push env [10]
| Let(x, body, rest) ->
let env = emitExpr env body
let env = emitExpr (nameTop env x) rest
let env = pop env [10; 11]
push env [10]
and emitCases env arg cases final_lbl =
match cases with
| [] ->
emitLbl final_lbl
(* Pop ret and arg off the stack and push ret back on. *)
let env = pop ([]::env) [10; 11]
push env [10]
| (patt, expr)::cases ->
let fail_lbl = mkLbl()
let env2 = emitPatt env arg patt fail_lbl
let _ = emitExpr env2 expr
printf " b %s\n" final_lbl
emitLbl fail_lbl
emitCases env arg cases final_lbl
let program =
Let("f",
Fun("n",
Match(Var "n",
[ POr(PInt 0, PInt 1), Var "n"
PVar "n", Apply(Var "f", Var "n" - Int 1) + Apply(Var "f", Var "n" - Int 2) ])),
Apply(Var "f", Int 10))
do
printf " .global _start\n"
printf "_start:\n"
let _ = emitExpr [] program
printf " pop {r0}\n"
printf " mov r7, #1\n"
printf " svc 0\n"
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment