Finished first version of assembly phase

Makefile

@@ -1,6 +1,7 @@
 RESULT := civicc
 PHASES := load parse print desug context_analysis expand_dims typecheck \
-	dim_reduce bool_op extern_vars constant_propagation depth_analysis assemble
+	dim_reduce bool_op extern_vars constant_propagation depth_analysis assemble \
+	output
 SOURCES := types.ml stringify.mli stringify.ml util.mli util.ml lexer.mll \
 	parser.mly $(patsubst %,phases/%.ml,$(PHASES)) main.ml
 PRE_TARGETS := types.cmi types.o stringify.cmi stringify.o util.cmi util.o

README.md

@@ -10,3 +10,4 @@ Issues & TODO
 - Keep file content in buffer to prevent error messages from crashing when
   reading from stdin.
 - NodeError now fails on nodes without location.
+- "depth analysis" -> "index analysis"

main.ml

@@ -12,7 +12,7 @@ let compile () =
     in
     run_phases Empty [
         Load.phase;
-        (*Print.phase;*)
+        Print.phase;
         Parse.phase;
         (*Print.phase;*)
         Desug.phase;
@@ -39,6 +39,7 @@ let compile () =
         Peephole.phase;
         Print.phase;
         *)
+        Output.phase;
     ]
 
 (* Main function, returns exit status
@@ -55,7 +56,10 @@ let main () =
         ("-noopt", Arg.Unit (fun _ -> args.optimize <- false),
             "Disable optimization");
     ] in
-    let usage = "Usage: " ^ Sys.argv.(0) ^ " [-o <file>] [-nocpp] [-v <verbosity>] [<file>]" in
+    let usage =
+        "Usage: " ^ Sys.argv.(0) ^ " [-o <file>] [-nocpp] [-noopt] " ^
+        " [-v <verbosity>] [<file>]"
+    in
 
     try
         try
@@ -74,7 +78,7 @@ let main () =
         eprintf "Error: %s\n" msg;
         1
     | LocError (loc, msg) ->
-        prerr_loc_msg loc ("Error: " ^ msg) args.verbose;
+        prerr_loc_msg loc ("Error: " ^ msg);
         1
     | EmptyError ->
         1

phases/assemble.ml

@@ -14,15 +14,14 @@ let assemble program =
 
     let consts = Hashtbl.create 20 in
 
-    let rec trav_args callstack node =
-        let trav = trav_args callstack in
+    let rec trav node =
         let rec trav_all = function
             | [] -> []
             | hd :: tl -> trav hd @ (trav_all tl)
         in
-        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)
+        let rec traverse_localfuns = function
+            | LocalFuns body -> List.concat (List.map trav body)
+            | Block body -> List.concat (List.map traverse_localfuns body)
             | _ -> []
         in
         match node with
@@ -30,31 +29,32 @@ let assemble program =
         | Program (decls, _) ->
             trav_all decls
 
-        | GlobalDef (_, ctype, _, _, _) ->
-            [Global ctype]
+        | GlobalDef (_, ctype, name, _, _) ->
+            [Comment (sprintf "global var \"%s\" at index %d" name (indexof node));
+             Global ctype]
 
         | FunDec (ret_type, name, params, _) ->
-            [Import (name, ret_type, List.map typeof params)]
+            [Comment (sprintf "extern fun \"%s\" at index %d" name (indexof node));
+             Import (name, ret_type, List.map typeof params)]
 
         | FunDef (export, ret_type, name, params, body, _) ->
-            let callstack = name :: callstack in
-            let label = String.concat "$" (List.rev callstack) in
+            let label = labelof node in
             (if export then
                 let param_types = List.map typeof params in
                 [Export (name, ret_type, param_types, label)]
             else []) @
             [
-                Comment ("function \"" ^ label ^ "\":");
+                Comment (sprintf "fun \"%s\" with %d local vars" label (indexof node));
                 Label label;
                 RtnEnter (indexof node);
             ] @
-            (trav_args callstack body) @
+            (trav body) @
             (match ret_type with Void -> [Ret Void] | _ -> []) @
             [EmptyLine] @
-            (traverse_localfuns callstack body)
+            (traverse_localfuns body)
 
-        | VarDec (ctype, name, _, _) ->
-            [comline (sprintf "index %d: %s %s" (indexof node) (type2str ctype) name)]
+        | VarDec (_, name, _, _) ->
+            [comline (sprintf "local var \"%s\" at index %d" name (indexof node))]
 
         | LocalFuns _ -> []
 
@@ -63,39 +63,93 @@ let assemble program =
         (* 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)
+                | (0, _)            -> Store (typeof dec, Glob,        indexof dec)
+                | (a, b) when a = b -> Store (typeof dec, Current,     indexof dec)
+                | (a, b)            -> Store (typeof dec, Rel (b - a), indexof dec)
             in
             trav value @ [InlineComment (store, node2str node)]
 
         | Return (value, _) ->
             trav value @ [InlineComment (Ret (typeof value), node2str node)]
 
+        | If (cond, body, _) ->
+            let endlabel = genlabel "end" in
+            (trav cond) @
+            [Branch (false, endlabel);
+             comline ("if (" ^ (node2str cond) ^ ") {")] @
+            (trav body) @
+            [comline "}";
+             Label endlabel]
+
+        | IfElse (cond, true_body, false_body, _) ->
+            let elselabel = genlabel "else" in
+            let endlabel = genlabel "end" in
+            (trav cond) @
+            [Branch (false, elselabel);
+             comline ("if (" ^ (node2str cond) ^ ") {")] @
+            (trav true_body) @
+            [Jump endlabel;
+             comline "} else {";
+             Label elselabel] @
+            (trav false_body) @
+            [comline "}";
+             Label endlabel]
+
+        | While (cond, body, _) ->
+            let startlabel = genlabel "while" in
+            let endlabel = genlabel "end" in
+            let com = ("while (" ^ (node2str cond) ^ ") {") in
+            [Label startlabel] @
+            (trav cond) @
+            [InlineComment (Branch (false, endlabel), com)] @
+            (trav body) @
+            [Jump startlabel;
+             Label endlabel;
+             comline "}"]
+
+        | DoWhile (cond, body, _) ->
+            let startlabel = genlabel "dowhile" in
+            let com = ("} while (" ^ (node2str cond) ^ ");") in
+            [comline "do {";
+             Label startlabel] @
+            (trav body) @
+            (trav cond) @
+            [InlineComment (Branch (true, startlabel), com)]
+
+        (* Expression statement pops the disregarded expression value from the
+         * stack, if any *)
+        | Expr value ->
+            let pop = match typeof value with
+                | Void -> [comline (node2str node)]
+                | ctype -> [InlineComment (Pop ctype, node2str node)]
+            in
+            (trav value) @ pop
+
         (* Expressions *)
         | Const (BoolVal _, _) ->
             [LoadImm node]
 
         | Const (value, _) ->
-            let def = if Hashtbl.mem consts value then [] else (
-                Hashtbl.add consts value true;
-                [ConstDef value]
-            ) in
-            def @ [LoadConst (typeof node, indexof node)]
+            Hashtbl.replace consts value (typeof node, indexof node);
+            let load = LoadConst (typeof node, indexof node) in
+            [InlineComment (load, node2str 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)
+                | (0, _)            -> Load (typeof dec, Glob,        indexof dec)
+                | (a, b) when a = b -> Load (typeof dec, Current,     indexof dec)
+                | (a, b)            -> Load (typeof dec, Rel (b - a), indexof dec)
             in
             [InlineComment (load, node2str node)]
 
         | Monop (op, value, _) ->
-            trav value @ [Op (op, typeof node)]
+            (trav value) @
+            [InlineComment (Op (op, typeof value), op2str op)]
 
         | Binop (op, left, right, _) ->
-            trav left @ (trav right) @ [Op (op, typeof node)]
+            (trav left) @
+            (trav right) @
+            [InlineComment (Op (op, typeof left), op2str op)]
 
         | TypeCast (ctype, value, _) ->
             let vtype = typeof value in
@@ -105,10 +159,94 @@ let assemble program =
             );
             trav value @ [Convert (vtype, ctype)]
 
+        (* Function calls *)
+        | FunUse (dec, args, _) ->
+            let init = match (depthof dec, depthof node) with
+                | (0, _)                -> RtnInit Glob
+                | (a, b) when a = b     -> RtnInit Current
+                | (a, b) when a = b + 1 -> RtnInit Local
+                | (a, b)                -> RtnInit (Rel (b - a))
+            in
+            let jmp = match dec with
+                | FunDec _ -> RtnJmp (ExternFun (indexof dec))
+                | FunDef _ -> RtnJmp (LocalFun (List.length args, labelof dec))
+                | _ -> raise InvalidNode
+            in
+            init :: (trav_all args) @ [jmp]
+
+        | Arg value -> trav value
+
+        (* Conditional expression (short-circuit evaluation) *)
+        (*     <cond>
+         *     branch_f else
+         *     <true_expr>
+         *     jump end
+         * else:
+         *     <false_expr>
+         * end:
+         *)
+        | Cond (cond, texp, fexp, _) ->
+            let elselabel = genlabel "false_expr" in
+            let endlabel = genlabel "end" in
+            (trav cond) @
+            [Branch (false, elselabel)] @
+            (trav texp) @
+            [Jump (endlabel);
+             Label (elselabel)] @
+            (trav fexp) @
+            [InlineComment (Label (endlabel), node2str node)]
+
+        (* Arrays *)
+        | Allocate (dec, dims, _) ->
+            let store = match (depthof dec, depthof node) with
+                | (0, _)            -> Store (typeof dec, Glob,    indexof dec)
+                | (a, b) when a = b -> Store (typeof dec, Current, indexof dec)
+                | _                 -> raise InvalidNode
+            in
+            trav_all dims @
+            [NewArray (basetypeof dec, List.length dims);
+             InlineComment (store, node2str node)]
+
+        | VarUse (dec, Some dims, _) ->
+            let load = match (depthof dec, depthof node) with
+                | (0, _)            -> Load (typeof dec, Glob,        indexof dec)
+                | (a, b) when a = b -> Load (typeof dec, Current,     indexof dec)
+                | (a, b)            -> Load (typeof dec, Rel (b - a), indexof dec)
+            in
+            (trav_all dims) @                     (* push dimensions *)
+            [InlineComment (load, nameof dec)] @  (* push array reference *)
+            [InlineComment (LoadArray (basetypeof dec), node2str node)]
+
+        | VarLet (dec, Some dims, value, _) ->
+            let load = match (depthof dec, depthof node) with
+                | (0, _)            -> Load (typeof dec, Glob,        indexof dec)
+                | (a, b) when a = b -> Load (typeof dec, Current,     indexof dec)
+                | (a, b)            -> Load (typeof dec, Rel (b - a), indexof dec)
+            in
+            (trav value) @                        (* push value *)
+            (trav_all dims) @                     (* push dimensions *)
+            [InlineComment (load, nameof dec)] @  (* push array reference *)
+            [InlineComment (StoreArray (basetypeof dec), node2str node)]
+
         | _ -> [Comment ("FIXME: " ^ Stringify.node2str node)]
         (*| _ -> raise InvalidNode*)
     in
-    trav_args [] program
+    let instrs = trav program in
+
+    (* Sort aggregated constants and add definitions
+     * If possible, this should be rewritten in the future because it's a little
+     * cumbersome right now... *)
+    let pairs = ref [] in
+    let add_pair value (ctype, index) =
+        let com = sprintf "index %d" index in
+        pairs := (InlineComment (ConstDef (ctype, value), com), index) :: !pairs;
+    in
+    Hashtbl.iter add_pair consts;
+    let cmp (_, i) (_, j) = compare i j in
+    let sorted_pairs = List.sort cmp !pairs in
+    let const_defs = List.map (fun (d, _) -> d) sorted_pairs in
+
+    instrs @ const_defs
 
 let rec phase input =
     log_line 1 "- Assembly";

phases/context_analysis.ml

@@ -35,8 +35,8 @@ let add_to_scope name dec depth (vars, funs) =
         * the same depth must be unique for consistency *)
     | Some (orig, orig_depth, _) when orig_depth >= depth ->
         let msg = sprintf "Error: cannot redeclare %s \"%s\"" name_type name in
-        prerr_loc_msg (locof dec) msg args.verbose;
-        prerr_loc_msg (locof orig) "Previously declared here:" args.verbose;
+        prerr_loc_msg (locof dec) msg;
+        prerr_loc_msg (locof orig) "Previously declared here:";
         raise EmptyError
     | Some _ ->
         Hashtbl.replace tbl name (dec, depth, name_type)
@@ -106,6 +106,10 @@ let rec analyse scope depth node =
             let (dec, dec_depth) = check_in_scope (Varname name) node scope in
             VarLet (dec, optmap collect dims, collect value, Depth depth :: ann)
 
+        | Allocate (dec, dims, ann) ->
+            let (dec, dec_depth) = check_in_scope (Varname (nameof dec)) node scope in
+            Allocate (dec, List.map collect dims, Depth depth :: ann)
+
         | _ -> transform_children collect node
     in
 

phases/depth_analysis.ml

@@ -3,22 +3,49 @@ open Util
 
 let tag_index program =
     let nglobs = ref 0 in
+    let nimport = ref 0 in
     let consts = Hashtbl.create 32 in
-    let rec trav stacklen node = match node with
+    let rec trav_localfuns trav = function
+        | LocalFuns body -> LocalFuns (List.map trav body)
+        | node -> transform_children (trav_localfuns trav) node
+    in
+    let rec tag stacklen callstack node =
+        let trav = tag stacklen callstack in
+        match node with
         | GlobalDef _ ->
             let index = !nglobs in
             nglobs := !nglobs + 1;
-            annotate (Index index) (transform_children (trav stacklen) node)
+            annotate (Index index) (transform_children trav node)
+
+        | FunDef (export, rtype, name, params, body, ann) ->
+            (* label name for local function is "<parent_label>$<name>" *)
+            let callstack = name :: callstack in
+            let label = String.concat "$" (List.rev callstack) in
 
-        | FunDef _ ->
             let stacklen = ref 0 in
-            let node = transform_children (trav stacklen) node in
-            annotate (Index !stacklen) node
+            let trav = tag stacklen callstack in
+
+            (* Traverse own function body first *)
+            let params = List.map trav params in
+            let body = trav body in
+            let ann = Index !stacklen :: ann in
+
+            (* Traverse local functions after the function body *)
+            let body = trav_localfuns trav body in
+
+            FunDef (export, rtype, name, params, body, LabelName label :: ann)
+
+        | LocalFuns _ -> node
 
         | VarDec _ | Dim _ ->
             let index = !stacklen in
             stacklen := !stacklen + 1;
-            annotate (Index index) (transform_children (trav stacklen) node)
+            annotate (Index index) (transform_children trav node)
+
+        | FunDec (_, name, _, _) ->
+            let index = !nimport in
+            nimport := !nimport + 1;
+            annotate (LabelName name) (annotate (Index index) node)
 
         | Const (value, _) ->
             let index = if Hashtbl.mem consts value then (
@@ -30,23 +57,25 @@ let tag_index program =
             ) in
             annotate (Index index) node
 
-        | _ -> transform_children (trav stacklen) node
-    in trav (ref 0) program
+        | _ -> transform_children trav node
+    in tag (ref 0) [] program
 
-let rec strip = function
+let rec strip_context = function
     | VarUse (dec, dims, ann) ->
-        Var (nameof dec, optmap strip dims, ann)
+        Var (nameof dec, optmap strip_context dims, ann)
 
     | VarLet (dec, dims, value, ann) ->
-        Assign (nameof dec, optmap strip dims, strip value, ann)
+        Assign (nameof dec, optmap strip_context dims, strip_context value, ann)
 
     | FunUse (dec, args, ann) ->
-        FunCall (nameof dec, List.map strip args, ann)
+        FunCall (nameof dec, List.map strip_context args, ann)
 
-    | node -> transform_children strip node
+    | node -> transform_children strip_context node
 
 let rec phase input =
     log_line 1 "- Depth analysis";
     match input with
-    | Ast node -> Ast (Context_analysis.analyse_context (tag_index (strip node)))
+    | Ast node ->
+        let tagged = tag_index (strip_context node) in
+        Ast (Context_analysis.analyse_context tagged)
     | _ -> raise (InvalidInput "depth analysis")

phases/desug.ml

@@ -47,7 +47,7 @@ let rec var_init = function
             | _ -> raise InvalidNode
         in
         let vardecs = List.map2 create_globaldef dims dimvars in
-        let alloc = [Allocate (name, dimvars, dec, ann)] in
+        let alloc = [Allocate (dec, dimvars, ann)] in
         Block (vardecs @
                [GlobalDef (export, Array (ctype, dimvars), name, None, ann)] @
                alloc)
@@ -70,7 +70,7 @@ let rec var_init = function
             | VarDec (ctype, name, init, ann) as dec ->
                 (* array definition: create __allocate statement *)
                 let alloc = match ctype with
-                    | Array (_, dims) -> [Allocate (name, dims, dec, ann)]
+                    | Array (_, dims) -> [Allocate (dec, dims, ann)]
                     | _ -> []
                 in
                 (* initialisation: create assign statement *)
@@ -141,11 +141,13 @@ let for_to_while node =
                 )), ann));
             ]
 
+        (* DISABLED, while-loops are explicittly supported by the assembly phase
         (* Transform while-loops to do-while loops in if-statements *)
         | While (cond, body, ann) ->
             let cond = traverse new_vars cond in
             let body = traverse new_vars body in
             Block [If (cond, Block [DoWhile (cond, body, ann)], ann)]
+        *)
 
         | node -> transform_children (traverse new_vars) node
     in

phases/dim_reduce.ml

@@ -20,8 +20,8 @@ let rec expand depth dims = function
         Binop (Add, mul, expand depth (List.tl dims) tl, [Type Int])
 
 and dim_reduce depth = function
-    | Allocate (name, dims, dec, ann) ->
-        Allocate (name, [multiply dims], dec, ann)
+    | Allocate (dec, dims, ann) ->
+        Allocate (dec, [multiply dims], ann)
 
     (* Increase nesting depth when goiing into function *)
     | FunDef (export, ret_type, name, params, body, ann) ->

phases/load.ml

@@ -29,7 +29,7 @@ let input_buffered ic chunksize =
     read_all (String.create chunksize) chunksize 0
 
 let phase ir =
-    prerr_endline "- Load input file";
+    log_line 2 "- Load input file";
     match ir with
     | Empty ->
         let display_name = match args.infile with
@@ -50,7 +50,7 @@ let phase ir =
                     cpp_out
             in
 
-            let _ = prerr_endline "- Run C preprocessor" in
+            let _ = log_line 2 "- Run C preprocessor" in
 
             (* Read preprocessed code from cpp's stdout *)
             let preprocessed = input_buffered cpp_out bufsize in

phases/output.ml

@@ -0,0 +1,20 @@
+open Types
+open Util
+
+let rec phase input =
+    log_line 1 "- Output assembly";
+    match input with
+    | Assembly instrs ->
+        (match args.outfile with
+        | Some filename ->
+            let oc = open_out filename in
+            Print.print_assembly oc instrs;
+            close_out oc
+        | None ->
+            if args.verbose >= 2 then (
+                prerr_endline "--------------------------------------------------"
+            );
+            Print.print_assembly stdout instrs
+        );
+        Empty
+    | _ -> raise (InvalidInput "output")

phases/parse.ml

@@ -1,5 +1,6 @@
 open Lexing
 open Types
+open Util
 
 let get_loc lexbuf =
     Util.loc_from_lexpos lexbuf.lex_curr_p lexbuf.lex_curr_p
@@ -17,7 +18,7 @@ let parse_with_error lexbuf =
         raise (LocError ((shift_back lexbuf), "syntax error"))
 
 let phase input =
-    prerr_endline "- Parse input";
+    log_line 2 "- Parse input";
     match input with
     | FileContent (display_name, content) ->
         let lexbuf = Lexing.from_string content in

phases/print.ml

@@ -3,6 +3,7 @@ open Util
 open Stringify
 
 let tab = "    "
+let max_instr_width = 26
 
 let si = string_of_int
 
@@ -37,14 +38,25 @@ let prefix = function
     | 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 ""
+        if args.verbose >= 2 then "; " ^ comment else ""
     | InlineComment (instr, comment) ->
         if args.verbose >= 2 then
-            expand 20 (instr2str instr) ^ "# " ^ comment
-        else ""
+            expand max_instr_width (instr2str instr) ^ " ; " ^ comment
+        else
+            instr2str instr
     | Label name ->
         name ^ ":"
     | Export (name, ret_type, arg_types, label) ->
@@ -55,25 +67,16 @@ let rec instr2str = function
         ".import \"" ^ name ^ "\" " ^ (String.concat " " types)
     | Global ctype ->
         ".global " ^ (type2str ctype)
-    | ConstDef node ->
-        ".const " ^ (const2str node)
+    | ConstDef (ctype, value) ->
+        ".const " ^ type2str ctype ^ " " ^ const2str value
 
     (* Store *)
-    | StoreGlob (ctype, index) ->
-        tab ^ prefix ctype ^ "storeg " ^ si index
-    | StoreLoc (ctype, index) ->
-        tab ^ prefix ctype ^ "store " ^ si index
-    | StoreRel (ctype, nesting, index) ->
-        tab ^ prefix ctype ^ "storen " ^ si nesting ^ " " ^ si index
+    | Store (ctype, scope, index) ->
+        tab ^ prefix ctype ^ "store" ^ suffix scope ^ " " ^ si index
 
     (* 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
-
+    | Load (ctype, scope, index) ->
+        tab ^ prefix ctype ^ "load" ^ suffix scope ^ " " ^ si index
     | LoadConst (ctype, index) ->
         tab ^ prefix ctype ^ "loadc " ^ si index
     | LoadImm (Const (BoolVal b, _)) ->
@@ -85,17 +88,39 @@ let rec instr2str = function
     | LoadImm (Const (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>"
@@ -109,19 +134,20 @@ let rec print_assembly oc instrs =
     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
+            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 a 0 7) (String.sub b 0 7) in
+        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))
     ); ()
 
@@ -144,16 +170,10 @@ let phase = function
         input
 
     | Assembly instrs as input ->
-        (match args.outfile with
-        | Some filename ->
-            let oc = open_out filename in
-            print_assembly oc instrs;
-            close_out oc
-        | None ->
-            if args.verbose >= 2 then
-                prerr_endline "--------------------------------------------------";
-
-            print_assembly stdout instrs;
+        if args.verbose >= 2 then (
+            prerr_endline "--------------------------------------------------";
+            print_assembly stderr instrs;
+            prerr_endline "--------------------------------------------------"
         );
         input
 

phases/typecheck.ml

@@ -119,8 +119,8 @@ let rec typecheck node =
         TypeCast (ctype, value, Type (typeof value) :: ann)
 
     (* Array allocation dimensions must have type int *)
-    | Allocate (name, dims, dec, ann) ->
-        Allocate (name, List.map (check_trav Int) dims, dec, ann)
+    | Allocate (dec, dims, ann) ->
+        Allocate (dec, List.map (check_trav Int) dims, ann)
 
     (* Array dimensions are always integers *)
     | Dim (name, ann) ->

stringify.ml

@@ -112,8 +112,8 @@ and node2str node =
         in
         let range = str start ^ ", " ^ str stop ^ step in
         "for (int " ^ counter ^ " = " ^ range ^ ") " ^ str body
-    | Allocate (name, dims, _, _) ->
-        name ^ " := <allocate>(" ^ concat ", " dims ^ ");"
+    | Allocate (dec, dims, _) ->
+        nameof dec ^ " := <allocate>(" ^ concat ", " dims ^ ");"
     | Block body ->
         let rec append = function
             | [] -> ""

types.ml

@@ -15,6 +15,7 @@ and annotation =
     | Depth of int
     | Index of int
     | Type of ctype
+    | LabelName of string
 and ann = annotation list
 and node =
     (* Global *)
@@ -43,8 +44,8 @@ and node =
       (* name, indices?, value *)
     | For of string * node * node * node * node * ann
       (* counter, start, stop, step, body *)
-    | Allocate of string * node list * node * ann
-      (* name, dims, decl  # name = __allocate(dims) *)
+    | Allocate of node * node list * ann
+      (* dec, dims  # name = __allocate(dims) *)
     | Return of node * ann                   (* return <value>; *)
     | Expr of node                           (* <expr>; *)
     | Block of node list                     (* { <body> } *)
@@ -73,6 +74,8 @@ and node =
     | Cond of node * node * node * ann         (* cond, true_expr, false_expr *)
     | DummyNode                                (* null node, pruned by traversals *)
 
+type stack_scope = Glob | Local | Rel of int | Current
+type rtn_scope = ExternFun of int | LocalFun of int * string
 type instr =
     | Comment of string                 (* # <comment> *)
     | InlineComment of instr * string   (* <instr>  # <comment> *)
@@ -84,32 +87,38 @@ type instr =
     (* .import "<name>" <ret_type> [ <arg_type>; ... ] *)
     | Import of string * ctype * ctype list
     (* .const <value> *)
-    | ConstDef of const
+    | ConstDef of ctype * const
     (* .global <type> *)
     | Global of ctype
 
-    | StoreGlob of ctype * int          (* [ifba]storeg G *)
-    | StoreLoc of ctype * int           (* [ifba]store L *)
-    | StoreRel of ctype * int * int     (* [ifba]storen N L *)
+    | Store of ctype * stack_scope * int (* [ifba]store[ gn] *)
 
-    | 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> *)
+    | Load of ctype * stack_scope * int  (* [ifb]load[ gn] G *)
+    | 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 *)
+    | Op of operator * ctype             (* [ifb]() *)
+    | Convert of ctype * ctype           (* i2f|f2i *)
 
     (* Control flow *)
+    | RtnInit of stack_scope
+    | RtnJmp of rtn_scope
     | RtnEnter of int
-    | RtnInit
-    | RtnJmp
     | Ret of ctype
+    | Branch of bool * string
+    | Jump of string
 
     (* Instructions *)
-    | Inc of int * int                  (* i(inc|dec) L C *)
-    | IncOne of int                     (* i(inc|dec)_1 C *)
+    | Inc of int * int                   (* iinc L C *)
+    | Dec of int * int                   (* idec L C *)
+
+    (* Stack management *)
+    | Pop of ctype                       (* [ifb]pop *)
+
+    (* Arrays *)
+    | NewArray of ctype * int
+    | LoadArray of ctype
+    | StoreArray of ctype
 
     | EmptyLine
     | DummyInstr

util.ml

@@ -43,19 +43,25 @@ let loc_from_lexpos pstart pend =
 
 let rec flatten_blocks lst =
     let flatten = flatten_blocks in
-    let trav = function
-        | FunDef (export, ret_type, name, params, Block body, ann) ->
-            FunDef (export, ret_type, name, flatten params, Block (flatten body), ann)
-        | If (cond, Block body, ann) ->
-            If (cond, Block (flatten body), ann)
-        | IfElse (cond, Block tbody, Block fbody, ann) ->
-            IfElse (cond, Block (flatten tbody), Block (flatten fbody), ann)
-        | While (cond, Block body, ann) ->
-            While (cond, Block (flatten body), ann)
-        | DoWhile (cond, Block body, ann) ->
-            DoWhile (cond, Block (flatten body), ann)
-        | For (counter, start, stop, step, Block body, ann) ->
-            For (counter, start, stop, step, Block (flatten body), ann)
+    let rec trav = function
+        | Block body ->
+            Block (flatten body)
+        | FunDef (export, ret_type, name, params, body, ann) ->
+            FunDef (export, ret_type, name, flatten params, trav body, ann)
+        | If (cond, body, ann) ->
+            If (cond, trav body, ann)
+        | IfElse (cond, tbody, fbody, ann) ->
+            IfElse (cond, trav tbody, trav fbody, ann)
+        | While (cond, body, ann) ->
+            While (cond, trav body, ann)
+        | DoWhile (cond, body, ann) ->
+            DoWhile (cond, trav body, ann)
+        | For (counter, start, stop, step, body, ann) ->
+            For (counter, start, stop, step, trav body, ann)
+        | VarDecs decs ->
+            VarDecs (flatten decs)
+        | LocalFuns decs ->
+            LocalFuns (flatten decs)
         | node -> node
     in
     match lst with
@@ -102,8 +108,8 @@ let transform_children trav node =
         DoWhile (trav cond, trav body, ann)
     | For (counter, start, stop, step, body, ann) ->
         For (counter, trav start, trav stop, trav step, trav body, ann)
-    | Allocate (name, dims, dec, ann) ->
-        Allocate (name, trav_all dims, dec, ann)
+    | Allocate (dec, dims, ann) ->
+        Allocate (dec, trav_all dims, ann)
     | Expr value ->
         Expr (trav value)
     | Block (body) ->
@@ -169,8 +175,8 @@ let annotate a = function
         DoWhile (cond, body, a :: ann)
     | For (counter, start, stop, step, body, ann) ->
         For (counter, start, stop, step, body, a :: ann)
-    | Allocate (name, dims, dec, ann) ->
-        Allocate (name, dims, dec, a :: ann)
+    | Allocate (dec, dims, ann) ->
+        Allocate (dec, dims, a :: ann)
     | Monop (op, value, ann) ->
         Monop (op, value, a :: ann)
     | Binop (op, left, right, ann) ->
@@ -221,7 +227,7 @@ let rec annof = function
     | While (_, _, ann)
     | DoWhile (_, _, ann)
     | For (_, _, _, _, _, ann)
-    | Allocate (_, _, _, ann)
+    | Allocate (_, _, ann)
     | Const (BoolVal _, ann)
     | Const (IntVal _, ann)
     | Const (FloatVal _, ann)
@@ -244,29 +250,29 @@ let rec annof = function
 
 let locof node =
      let rec trav = function
-         | []            -> noloc
-         | Loc loc :: tl -> loc
-         | _ :: tl       -> trav tl
+         | []           -> noloc
+         | Loc loc :: _ -> loc
+         | _ :: tl      -> trav tl
      in trav (annof node)
 
-let rec depthof node =
+let depthof node =
      let rec trav = function
          | [] ->
             prerr_string "cannot get depth for: ";
             prt_node node;
             raise InvalidNode
-         | Depth depth :: tl -> depth
-         | _ :: tl           -> trav tl
+         | Depth depth :: _ -> depth
+         | _ :: tl          -> trav tl
      in trav (annof node)
 
-let rec indexof node =
+let indexof node =
      let rec trav = function
          | [] ->
             prerr_string "cannot get index for: ";
             prt_node node;
             raise InvalidNode
-         | Index index :: tl -> index
-         | _ :: tl           -> trav tl
+         | Index index :: _ -> index
+         | _ :: tl          -> trav tl
      in trav (annof node)
 
 let typeof = function
@@ -287,10 +293,20 @@ let typeof = function
             prerr_string "cannot get type for: ";
             prt_node node;
             raise InvalidNode
-            | Type t :: tl -> t
-            | _ :: tl      -> trav tl
+            | Type t :: _ -> t
+            | _ :: tl     -> trav tl
         in trav (annof node)
 
+let labelof node =
+     let rec trav = function
+         | [] ->
+            prerr_string "cannot get label for: ";
+            prt_node node;
+            raise InvalidNode
+         | LabelName label :: _ -> label
+         | _ :: tl              -> trav tl
+     in trav (annof node)
+
 let prerr_loc (fname, ystart, yend, xstart, xend) =
     let file = open_in fname in
 
@@ -312,20 +328,22 @@ let prerr_loc (fname, ystart, yend, xstart, xend) =
     done;
     ()
 
-let prerr_loc_msg loc msg verbose =
-    let (fname, ystart, yend, xstart, xend) = loc in
-    let line_s = if yend != ystart
-        then sprintf "lines %d-%d" ystart yend
-        else sprintf "line %d" ystart
-    in
-    let char_s = if xend != xstart || yend != ystart
-        then sprintf "characters %d-%d" xstart xend
-        else sprintf "character %d" xstart
-    in
-    eprintf "File \"%s\", %s, %s:\n" fname line_s char_s;
-    eprintf "%s\n" msg;
-
-    if verbose >= 2 then prerr_loc loc;
+let prerr_loc_msg loc msg =
+    if args.verbose >= 1 then (
+        let (fname, ystart, yend, xstart, xend) = loc in
+        let line_s = if yend != ystart
+            then sprintf "lines %d-%d" ystart yend
+            else sprintf "line %d" ystart
+        in
+        let char_s = if xend != xstart || yend != ystart
+            then sprintf "characters %d-%d" xstart xend
+            else sprintf "character %d" xstart
+        in
+        eprintf "File \"%s\", %s, %s:\n" fname line_s char_s;
+        eprintf "%s\n" msg;
+
+        if args.verbose >= 2 then prerr_loc loc
+    );
     ()
 
 let block_body = function
@@ -338,6 +356,7 @@ let rec list_size = function
 
 let basetypeof node = match typeof node with
     | Array (ctype, _)
+    | FlatArray ctype
     | ctype -> ctype
 
 let array_depth = function

util.mli

@@ -29,12 +29,13 @@ val locof   : Types.node -> Types.location
 val depthof : Types.node -> int
 val indexof : Types.node -> int
 val typeof  : Types.node -> Types.ctype
+val labelof : Types.node -> string
 
 (* Print file location to stderr *)
 val prerr_loc : Types.location -> unit
 
 (* Print file location to stderr *)
-val prerr_loc_msg : Types.location -> string -> int -> unit
+val prerr_loc_msg : Types.location -> string -> unit
 
 (* Flatten Block nodes into the given array of nodes *)
 val flatten_blocks : Types.node list -> Types.node list