Worked on assembly generation, added -noopt argument, tweaked verbority level

README.md

@@ -9,5 +9,4 @@ Issues & TODO
 
 - Keep file content in buffer to prevent error messages from crashing when
   reading from stdin.
-- Maybe declarations should be saved as references to allow the declarations to
-  be modified (does make pattern matching a bit harder).
+- NodeError now fails on nodes without location.

main.ml

@@ -50,8 +50,10 @@ let main () =
             "Output file (defaults to foo.s for foo.cvc)");
         ("-v", Arg.Int (fun i -> args.verbose <- i),
             "Set verbosity (0|1|2)");
-        ("-nocpp", Arg.Unit (fun i -> args.cpp <- false),
+        ("-nocpp", Arg.Unit (fun _ -> args.cpp <- false),
             "Disable C preprocessor");
+        ("-noopt", Arg.Unit (fun _ -> args.optimize <- false),
+            "Disable optimization");
     ] in
     let usage = "Usage: " ^ Sys.argv.(0) ^ " [-o <file>] [-nocpp] [-v <verbosity>] [<file>]" in
 

phases/assemble.ml

@@ -1,5 +1,9 @@
+open Printf
 open Types
 open Util
+open Stringify
+
+let comline comment = InlineComment (EmptyLine, comment)
 
 let assemble program =
     let labcounter = ref 0 in
@@ -10,28 +14,30 @@ let assemble program =
 
     let consts = Hashtbl.create 20 in
 
-    let rec trav_args callstack localfuns node =
-        let trav = trav_args callstack localfuns in
+    let rec trav_args callstack node =
+        let trav = trav_args callstack in
         let rec trav_all = function
             | [] -> []
             | hd :: tl -> trav hd @ (trav_all tl)
         in
-        let rec traverse_localfuns = function
-            | LocalFuns funs -> trav_all funs
-            | Block body -> List.concat (List.map traverse_localfuns body)
+        let rec traverse_localfuns callstack = function
+            | LocalFuns body -> List.concat (List.map (trav_args callstack) body)
+            | Block body -> List.concat (List.map (traverse_localfuns callstack) body)
             | _ -> []
         in
         match node with
+        (* Global *)
         | Program (decls, _) ->
             trav_all decls
 
+        | GlobalDef (_, ctype, _, _, _) ->
+            [Global ctype]
+
         | FunDec (ret_type, name, params, _) ->
             [Import (name, ret_type, List.map typeof params)]
 
         | FunDef (export, ret_type, name, params, body, _) ->
-            localfuns := node :: !localfuns;
             let callstack = name :: callstack in
-            let localfuns = ref [] in
             let label = String.concat "$" (List.rev callstack) in
             (if export then
                 let param_types = List.map typeof params in
@@ -42,29 +48,34 @@ let assemble program =
                 Label label;
                 RtnEnter (indexof node);
             ] @
-            (trav_args callstack localfuns body) @
+            (trav_args callstack body) @
             (match ret_type with Void -> [Ret Void] | _ -> []) @
             [EmptyLine] @
-            (traverse_localfuns body)
+            (traverse_localfuns callstack body)
+
+        | VarDec (ctype, name, _, _) ->
+            [comline (sprintf "index %d: %s %s" (indexof node) (type2str ctype) name)]
 
-        (* Local fucntions are traversed elsewhere *)
         | LocalFuns _ -> []
 
-        | Block body -> trav_all body
+        | Block body | VarDecs body -> trav_all body
 
+        (* Statements *)
         | VarLet (dec, None, value, _) ->
             let store = match (depthof dec, depthof node) with
                 | (0, _)            -> StoreGlob (typeof dec, indexof dec)
                 | (a, b) when a = b -> StoreLoc  (typeof dec, indexof dec)
                 | (a, b)            -> StoreRel  (typeof dec, b - a, indexof dec)
             in
-            trav value @ [store]
+            trav value @ [InlineComment (store, node2str node)]
 
         | Return (value, _) ->
-            trav value @ [Ret (typeof value)]
+            trav value @ [InlineComment (Ret (typeof value), node2str node)]
 
+        (* Expressions *)
         | Const (BoolVal _, _) ->
             [LoadImm node]
+
         | Const (value, _) ->
             let def = if Hashtbl.mem consts value then [] else (
                 Hashtbl.add consts value true;
@@ -72,13 +83,35 @@ let assemble program =
             ) in
             def @ [LoadConst (typeof node, indexof node)]
 
-        | _ -> []
+        | VarUse (dec, None, _) ->
+            let load = match (depthof dec, depthof node) with
+                | (0, _)            -> LoadGlob (typeof dec, indexof dec)
+                | (a, b) when a = b -> LoadLoc  (typeof dec, indexof dec)
+                | (a, b)            -> LoadRel  (typeof dec, b - a, indexof dec)
+            in
+            [InlineComment (load, node2str node)]
+
+        | Monop (op, value, _) ->
+            trav value @ [Op (op, typeof node)]
+
+        | Binop (op, left, right, _) ->
+            trav left @ (trav right) @ [Op (op, typeof node)]
+
+        | TypeCast (ctype, value, _) ->
+            let vtype = typeof value in
+            (match (ctype, vtype) with
+            | (Float, Int) | (Int, Float) -> ()
+            | _ -> raise (NodeError (node, "invalid typecast"))
+            );
+            trav value @ [Convert (vtype, ctype)]
+
+        | _ -> [Comment ("FIXME: " ^ Stringify.node2str node)]
         (*| _ -> raise InvalidNode*)
     in
-    trav_args [] (ref []) program
+    trav_args [] program
 
 let rec phase input =
-    log_line 2 "- Assembly";
+    log_line 1 "- Assembly";
     match input with
     | Ast node -> Assembly (assemble node)
     | _ -> raise (InvalidInput "assembly")

phases/bool_op.ml

@@ -60,7 +60,7 @@ and bool_op = function
     | node -> transform_children bool_op node
 
 let rec phase input =
-    log_line 2 "- Convert bool operations";
+    log_line 1 "- Convert bool operations";
     match input with
     | Ast node -> Ast (bool_op node)
     | _ -> raise (InvalidInput "bool operations")

phases/constant_propagation.ml

@@ -163,10 +163,13 @@ let rec prune_vardecs consts = function
     | node -> transform_children (prune_vardecs consts) node
 
 let rec phase input =
-    log_line 2 "- Constant propagation";
+    log_line 1 "- Constant propagation";
     match input with
     | Ast node ->
-        let consts = Hashtbl.create 32 in
-        let node = propagate consts node in
-        Ast (prune_vardecs consts node)
+        if args.optimize then
+            let consts = Hashtbl.create 32 in
+            let node = propagate consts node in
+            Ast (prune_vardecs consts node)
+        else
+            input
     | _ -> raise (InvalidInput "constant propagation")

phases/context_analysis.ml

@@ -158,7 +158,7 @@ let analyse_context program =
     analyse scope 0 program
 
 let rec phase input =
-    log_line 2 "- Context analysis";
+    log_line 1 "- Context analysis";
     match input with
     | Ast node -> Ast (analyse_context node)
     | _ -> raise (InvalidInput "context analysis")

phases/depth_analysis.ml

@@ -46,7 +46,7 @@ let rec strip = function
     | node -> transform_children strip node
 
 let rec phase input =
-    log_line 2 "- Depth analysis";
+    log_line 1 "- Depth analysis";
     match input with
     | Ast node -> Ast (Context_analysis.analyse_context (tag_index (strip node)))
     | _ -> raise (InvalidInput "depth analysis")

phases/desug.ml

@@ -250,7 +250,7 @@ let rec array_dims = function
     | node -> transform_children array_dims node
 
 let rec phase input =
-    log_line 2 "- Desugaring";
+    log_line 1 "- Desugaring";
     match input with
     | Ast node ->
             Ast (for_to_while (array_init (var_init (array_dims node))))

phases/dim_reduce.ml

@@ -48,7 +48,7 @@ let rec simplify_decs = function
     | node -> transform_children simplify_decs node
 
 let rec phase input =
-    log_line 2 "- Array dimension reduction";
+    log_line 1 "- Array dimension reduction";
     match input with
     | Ast node -> Ast (simplify_decs (dim_reduce 0 node))
     | _ -> raise (InvalidInput "dimension reduction")

phases/expand_dims.ml

@@ -36,7 +36,7 @@ let rec expand_dims = function
     | node -> transform_children expand_dims node
 
 let rec phase input =
-    log_line 2 "- Expand array dimensions";
+    log_line 1 "- Expand array dimensions";
     match input with
     | Ast node -> Ast (expand_dims node)
     | _ -> raise (InvalidInput "expand dimensions")

phases/extern_vars.ml

@@ -124,7 +124,7 @@ let rec replace_vars scope depth = function
     | node -> transform_children (replace_vars scope depth) node
 
 let rec phase input =
-    log_line 2 "- Create getters and setters for extern variables";
+    log_line 1 "- Create getters and setters for extern variables";
     match input with
     | Ast node ->
         let globals = Hashtbl.create 20 in

phases/print.ml

@@ -7,25 +7,44 @@ let tab = "    "
 let si = string_of_int
 
 let rec repeat s n = if n < 1 then "" else s ^ (repeat s (n - 1))
-let pad width s = s ^ (repeat " " (String.length s - width))
-let paddall width = List.map (pad width)
+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  _ -> ""
+    | Void    -> ""
     | _       -> "a"
 
-let instr2str = function
+let rec instr2str = function
     (* Global / directives *)
     | Comment comment ->
-        "# " ^ comment
+        if args.verbose >= 2 then "# " ^ comment else ""
+    | InlineComment (instr, comment) ->
+        if args.verbose >= 2 then
+            expand 20 (instr2str instr) ^ "# " ^ comment
+        else ""
     | Label name ->
         name ^ ":"
     | Export (name, ret_type, arg_types, label) ->
@@ -34,20 +53,27 @@ let instr2str = function
     | Import (name, ret_type, arg_types) ->
         let types = List.map type2str (ret_type :: arg_types) in
         ".import \"" ^ name ^ "\" " ^ (String.concat " " types)
-    | ConstDef node ->
-        ".const  " ^ (const2str node)
     | Global ctype ->
         ".global " ^ (type2str ctype)
+    | ConstDef node ->
+        ".const " ^ (const2str node)
 
     (* Store *)
     | StoreGlob (ctype, index) ->
         tab ^ prefix ctype ^ "storeg " ^ si index
     | StoreLoc (ctype, index) ->
-        tab ^ prefix ctype ^ "store  " ^ si index
+        tab ^ prefix ctype ^ "store " ^ si index
     | StoreRel (ctype, nesting, index) ->
         tab ^ prefix ctype ^ "storen " ^ si nesting ^ " " ^ si index
 
-    (* Load constant *)
+    (* Load *)
+    | LoadGlob (ctype, index) ->
+        tab ^ prefix ctype ^ "loadg " ^ si index
+    | LoadLoc (ctype, index) ->
+        tab ^ prefix ctype ^ "load " ^ si index
+    | LoadRel (ctype, nesting, index) ->
+        tab ^ prefix ctype ^ "loadn " ^ si nesting ^ " " ^ si index
+
     | LoadConst (ctype, index) ->
         tab ^ prefix ctype ^ "loadc " ^ si index
     | LoadImm (Const (BoolVal b, _)) ->
@@ -59,6 +85,12 @@ let instr2str = function
     | LoadImm (Const (FloatVal i, _)) ->
         tab ^ "floadc_" ^ si (int_of_float i)
 
+    | Op (op, ctype) ->
+        tab ^ prefix ctype ^ op2str op
+
+    | Convert (src, tgt) ->
+        tab ^ prefix src ^ "2" ^ prefix tgt
+
     (* Control flow *)
     | RtnEnter stack_len ->
         tab ^ "esr " ^ si stack_len
@@ -89,7 +121,7 @@ let rec print_assembly oc instrs =
     trav instrs;
     if List.length !endbuf > 1 then (
         output_line (instr2str (Comment ("globals:")));
-        let cmp a b = compare (String.sub a 0 8) (String.sub b 0 8) in
+        let cmp a b = compare (String.sub a 0 7) (String.sub b 0 7) in
         List.iter output_line (List.sort cmp (List.rev !endbuf))
     ); ()
 

phases/typecheck.ml

@@ -211,7 +211,7 @@ let rec typecheck node =
     | _ -> transform_children typecheck node
 
 let rec phase input =
-    log_line 2 "- Type checking";
+    log_line 1 "- Type checking";
     match input with
     | Ast node -> Ast (typecheck node)
     | _ -> raise (InvalidInput "typecheck")

types.ml

@@ -74,10 +74,9 @@ and node =
     | DummyNode                                (* null node, pruned by traversals *)
 
 type instr =
-    (* # <comment> *)
-    | Comment of string
-    (* <label>: *)
-    | Label of string
+    | Comment of string                 (* # <comment> *)
+    | InlineComment of instr * string   (* <instr>  # <comment> *)
+    | Label of string                   (* <label>: *)
 
     (* Directives *)
     (* .export "<name>" <ret_type> [ <arg_type>; ... ] <label> *)
@@ -93,10 +92,15 @@ type instr =
     | StoreLoc of ctype * int           (* [ifba]store L *)
     | StoreRel of ctype * int * int     (* [ifba]storen N L *)
 
-    | LoadGlob of node                  (* [ifb]loadg G *)
+    | LoadGlob of ctype * int           (* [ifb]loadg G *)
+    | LoadLoc of ctype * int            (* [ifba]load L *)
+    | LoadRel of ctype * int * int      (* [ifba]loadn N L *)
     | LoadConst of ctype * int          (* [ifb]loadc C *)
     | LoadImm of node                   (* [ifb]load_[01tf] <value> *)
 
+    | Op of operator * ctype            (* [ifb]() *)
+    | Convert of ctype * ctype          (* i2f|f2i *)
+
     (* Control flow *)
     | RtnEnter of int
     | RtnInit
@@ -112,10 +116,11 @@ type instr =
 
 (* Container for command-line arguments *)
 type args_record = {
-    mutable infile  : string option;
-    mutable outfile : string option;
-    mutable verbose : int;
-    mutable cpp     : bool;
+    mutable infile   : string option;
+    mutable outfile  : string option;
+    mutable verbose  : int;
+    mutable cpp      : bool;
+    mutable optimize : bool;
 }
 
 (* Default config *)
@@ -126,10 +131,11 @@ let verbosity_debug   = 3
  * (yes, it IS dirty, but I don't know how to do this without passin [args] to
  * every function) *)
 let args = {
-    infile  = None;
-    outfile = None;
-    verbose = verbosity_default;
-    cpp     = true;
+    infile   = None;
+    outfile  = None;
+    verbose  = verbosity_default;
+    cpp      = true;
+    optimize = true;
 }
 
 (* intermediate representations between phases *)