F# version of my tiny ARM A32 compiler version 7

compiler7.fs

(*
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"