civicaml/phases/print.ml

open Types
open Util
open Stringify

let tab = "    "
let max_instr_width = 26

let si = string_of_int

let rec repeat s n = if n < 1 then "" else s ^ (repeat s (n - 1))
let expand n text = text ^ repeat " " (n - String.length text)

let ctype2str = Stringify.type2str
let type2str = function
    | Array (t, dims) -> ctype2str t ^ repeat "," (List.length dims - 1)
    | t -> ctype2str t

let op2str = function
    | Neg -> "neg"
    | Not -> "not"
    | Add -> "add"
    | Sub -> "sub"
    | Mul -> "mul"
    | Div -> "div"
    | Mod -> "rem"
    | Eq  -> "eq"
    | Ne  -> "ne"
    | Lt  -> "lt"
    | Le  -> "le"
    | Gt  -> "gt"
    | Ge  -> "ge"
    | _ -> raise (CompileError ("operator unsupported by VM"))

let prefix = function
    | Bool _  -> "b"
    | Int _   -> "i"
    | Float _ -> "f"
    | Void    -> ""
    | _       -> "a"

let suffix = function
    | Glob        -> "g"
    | Current     -> ""
    | Local       -> "l"
    | Rel nesting -> "n " ^ si nesting

let rtn_suffix = function
    | ExternFun index        -> "e " ^ si index
    | LocalFun (size, label) -> " " ^ si size ^ label

let rec instr2str = function
    (* Global / directives *)
    | Comment comment ->
        if args.verbose >= 2 then "; " ^ comment else ""
    | InlineComment (instr, comment) ->
        if args.verbose >= 2 then
            expand max_instr_width (instr2str instr) ^ " ; " ^ comment
        else
            instr2str instr
    | Label name ->
        name ^ ":"
    | Export (name, ret_type, arg_types, label) ->
        let types = List.map type2str (ret_type :: arg_types) in
        ".export \"" ^ name ^ "\" " ^ (String.concat " " types) ^ " " ^ label
    | Import (name, ret_type, arg_types) ->
        let types = List.map type2str (ret_type :: arg_types) in
        ".import \"" ^ name ^ "\" " ^ (String.concat " " types)
    | Global ctype ->
        ".global " ^ (type2str ctype)
    | ConstDef (ctype, value) ->
        ".const " ^ type2str ctype ^ " " ^ const2str value

    (* Store *)
    | Store (ctype, scope, index) ->
        tab ^ prefix ctype ^ "store" ^ suffix scope ^ " " ^ si index

    (* Load *)
    | Load (ctype, scope, index) ->
        tab ^ prefix ctype ^ "load" ^ suffix scope ^ " " ^ si index
    | LoadConst (ctype, index) ->
        tab ^ prefix ctype ^ "loadc " ^ si index
    | LoadImm (BoolVal b) ->
        tab ^ "bloadc_" ^ (if b then "t" else "f")
    | LoadImm (IntVal i) when i < 0 ->
        tab ^ "iloadc_m" ^ si (-i)
    | LoadImm (IntVal i) ->
        tab ^ "iloadc_" ^ si i
    | LoadImm (FloatVal i) ->
        tab ^ "floadc_" ^ si (int_of_float i)

    (* Operators *)
    | Op (op, ctype) ->
        tab ^ prefix ctype ^ op2str op
    | Convert (src, tgt) ->
        tab ^ prefix src ^ "2" ^ prefix tgt

    (* Control flow *)
    | RtnInit scope ->
        tab ^ "isr" ^ suffix scope
    | RtnJmp scope ->
        tab ^ "jsr" ^ rtn_suffix scope
    | RtnEnter stack_len ->
        tab ^ "esr " ^ si stack_len
    | Ret ctype ->
        tab ^ prefix ctype ^ "return"
    | Branch (true, target) ->
        tab ^ "branch_t " ^ target
    | Branch (false, target) ->
        tab ^ "branch_f " ^ target
    | Jump target ->
        tab ^ "jump " ^ target

    (* Stack management *)
    | Pop ctype ->
        tab ^ prefix ctype ^ "pop"

    (* Arrays *)
    | NewArray (basetype, ndims) ->
        tab ^ prefix basetype ^ "newa " ^ si ndims
    | LoadArray basetype ->
        tab ^ prefix basetype ^ "loada"
    | StoreArray basetype ->
        tab ^ prefix basetype ^ "storea"

    | EmptyLine -> ""
    | DummyInstr -> tab ^ "<dummy>"
    | _ -> tab ^ "<unknown instruction>"

let rec print_assembly oc instrs =
    let output_line line =
        output_string oc line;
        output_char oc '\n';
    in
    let endbuf = ref [] in
    let rec trav = function
        | [] -> ()
        | EmptyLine :: tl -> output_line ""; trav tl
        | hd :: tl ->
            let line = instr2str hd in
            (if String.length line > 0 && line.[0] = '.' then
                endbuf := line :: !endbuf
            else (if String.length line > 0 then
                output_line line
            ));
            trav tl
    in
    trav instrs;
    if List.length !endbuf > 1 then (
        output_line (instr2str (Comment ("globals:")));
        let cmp a b = compare (String.sub b 0 7) (String.sub a 0 7) in
        List.iter output_line (List.sort cmp (List.rev !endbuf))
    ); ()

let phase = function
    | Ast node as input ->
        if args.verbose >= 2 then (
            prerr_endline "--------------------------------------------------";
            prerr_endline (node2str node);
            prerr_endline "--------------------------------------------------"
        );
        input

    | FileContent (display_name, content) as input ->
        if args.verbose >= 2 then (
            prerr_endline "--------------------------------------------------";
            prerr_endline (display_name ^ ":\n");
            prerr_endline content;
            prerr_endline "--------------------------------------------------"
        );
        input

    | Assembly instrs as input ->
        if args.verbose >= 2 then (
            prerr_endline "--------------------------------------------------";
            print_assembly stderr instrs;
            prerr_endline "--------------------------------------------------"
        );
        input

    | _ -> raise (InvalidInput "print")