civicaml/phases/assemble.ml

open Types
open Util

let store ctype = function
    | 0 -> StoreGlob ()

let assemble program =
    let labcounter = ref 0 in
    let genlabel suffix =
        labcounter := !labcounter + 1;
        string_of_int !labcounter ^ "_" ^ suffix
    in

    let consts = ref [] in
    let const_index const =
        let rec trav_consts i = function
            | [] -> consts := !consts @ [const]; i
            | hd :: _ when hd = const -> i
            | hd :: tl -> trav_consts (i + 1) tl
        in
        trav_consts 0 !consts
    in

    let rec trav node =
        let rec trav_all = function
            | [] -> []
            | hd :: tl -> trav hd @ (trav_all tl)
        in
        match node with
        | Program (decls, _) ->
            trav_all decls

        | FunDec (ret_type, name, params, _) ->
            [Import (name, ret_type, List.map ctypeof params)]

        | FunDef (export, ret_type, name, params, body, _) ->
            let label = name in
            let param_types = List.map ctypeof params in
            let export = match export with
                | false -> []
                | true -> [Export (name, ret_type, param_types, label)]
            in
            Comment ("function \"" ^ name ^ "\":") ::
            (export @ (Label label :: (trav body)))

        | VarDec (ctype, name, None, _) ->
            []

        | VarLet (Assign (name, None, value, _), ctype, depth) ->
            [store ctype depth]
        (*
        | VarLet (Assign (name, Some indices, value, _), ctype, depth) ->
            [store deoth]
        *)

        | BoolConst _ ->
            [LoadImm node]

        | IntConst _ | FloatConst _ ->
            [LoadConst (ctypeof node, const_index node)]

        | _ -> []
        (*| _ -> raise InvalidNode*)
    in
    let instrs = trav program in
    let const_defs = List.map (fun c -> Const c) !consts in
    const_defs @ instrs

let rec phase input =
    prerr_endline "- Assembly";
    match input with
    | Types node -> Assembly (assemble node)
    | _ -> raise (InvalidInput "assembly")