Rewrote default traversal function such that a traversal now has a secondary result

phases/boolop.ml

@@ -60,7 +60,7 @@ and bool_op = function
   | TypeCast (ctype, value, ann) when typeof value = ctype ->
     bool_op value
 
-  | node -> transform_children bool_op node
+  | node -> traverse_unit bool_op node
 
 let phase = function
   | Ast node -> Ast (bool_op node)

phases/constprop.ml

@@ -175,11 +175,11 @@ let rec propagate consts node =
     | _ -> TypeCast (ctype, value, ann)
     end
 
-  | _ -> transform_children propagate node
+  | _ -> traverse_unit propagate node
 
 let rec prune_vardecs consts = function
   | VarDec (_, name, _, _) when Hashtbl.mem consts name -> DummyNode
-  | node -> transform_children (prune_vardecs consts) node
+  | node -> traverse_unit (prune_vardecs consts) node
 
 let propagate_consts node =
     let consts = Hashtbl.create 32 in

phases/context.ml

@@ -103,7 +103,7 @@ let rec analyse scope depth node =
       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
+    | _ -> traverse_unit collect node
   in
 
   let rec traverse scope depth node =
@@ -140,7 +140,7 @@ let rec analyse scope depth node =
      * parameters must not be added to the namespace *)
     | FunDec _ -> node
 
-    | _ -> transform_children (traverse scope depth) node
+    | _ -> traverse_unit (traverse scope depth) node
   in
 
   (*

phases/desug.ml

@@ -37,7 +37,7 @@ let rec consts_to_vars node =
       VarDec (ctype, name, Some (Var (scalar_name, None, annof value)), ann);
     ]
 
-  | node -> transform_children consts_to_vars node
+  | node -> traverse_unit consts_to_vars node
 
 let make_dims make_dimname values make_dec =
   let names = mapi make_dimname values in
@@ -90,7 +90,7 @@ let rec array_dims node =
     Block (decs @ [GlobalDec (ArrayDims (ctype, dims), name, ann)])
   *)
 
-  | node -> transform_children array_dims node
+  | node -> traverse_unit array_dims node
 
 (* Split variable initialisation into declaration and assignment *)
 let rec split_inits = function
@@ -119,7 +119,7 @@ let rec split_inits = function
       Assign (name, None, init, ann);
     ]
 
-  | node -> transform_children split_inits node
+  | node -> traverse_unit split_inits node
 
 (* Add <allocate> statements after array declarations *)
 let rec add_allocs node =
@@ -134,7 +134,7 @@ let rec add_allocs node =
   | GlobalDef (_, ArrayDims (_, dims), _, _, ann) ->
     Block [node; Allocate (node, List.map create_dimvar dims, ann)]
 
-  | node -> transform_children add_allocs node
+  | node -> traverse_unit add_allocs node
 
 let extract_inits lst =
   let rec trav inits = function
@@ -173,7 +173,7 @@ let rec move_inits = function
     let body = Block (place_inits [] body) in
     FunDef (export, ret_type, name, params, body, ann)
 
-  | node -> transform_children move_inits node
+  | node -> traverse_unit move_inits node
 
 let for_to_while node =
   let rec replace_var var replacement node =
@@ -184,7 +184,7 @@ let for_to_while node =
     | For (counter, start, stop, step, body, ann) when counter = var ->
       For (replacement, trav start, trav stop, trav step, trav body, ann)
     | node ->
-      transform_children trav node
+      traverse_unit trav node
   in
   let rec traverse new_vars = function
     | FunDef (export, ret_type, name, params, body, ann) ->
@@ -233,7 +233,7 @@ let for_to_while node =
       Block [If (cond, Block [DoWhile (cond, body, ann)], ann)]
     *)
 
-    | node -> transform_children (traverse new_vars) node
+    | node -> traverse_unit (traverse new_vars) node
   in
   traverse (ref []) node
 
@@ -295,7 +295,7 @@ let rec array_init = function
     let dims_left = sublist (List.length indices) dims in
     add_loop indices dims_left
 
-  | node -> transform_children array_init node
+  | node -> traverse_unit array_init node
 
 let phase = function
   | Ast node ->

phases/dimreduce.ml

@@ -59,7 +59,7 @@ let rec expand_dims = function
     in
     Block (do_expand dims)
 
-  | node -> transform_children expand_dims node
+  | node -> traverse_unit expand_dims node
 
 let rec multiply = function
   | []       -> raise InvalidNode
@@ -124,7 +124,7 @@ and dim_reduce depth = function
     | _ -> raise InvalidNode
     end
 
-  | node -> transform_children (dim_reduce depth) node
+  | node -> traverse_unit (dim_reduce depth) node
 
 let phase = function
   | Ast node -> Ast (dim_reduce 0 (expand_dims node))

phases/extern.ml

@@ -104,7 +104,7 @@ let rec create_funcs globals = function
   | GlobalDec (ctype, name, ann) as node ->
     Block (create_getset globals node)
 
-  | node -> transform_children (create_funcs globals) node
+  | node -> traverse_unit (create_funcs globals) node
 
 (* Replace uses for imported/exported variabels with getter/setter functions *)
 let rec replace_vars scope depth = function
@@ -136,7 +136,7 @@ let rec replace_vars scope depth = function
     let (_, set) = Hashtbl.find scope (nameof dec) in
     Expr (set (dims @ [replace_vars scope depth value]) depth)
 
-  | node -> transform_children (replace_vars scope depth) node
+  | node -> traverse_unit (replace_vars scope depth) node
 
 let phase = function
   | Ast node ->

phases/index.ml

@@ -8,7 +8,7 @@ let tag_index program =
   let consts = Hashtbl.create 32 in
   let rec trav_localfuns trav = function
     | LocalFuns body -> LocalFuns (List.map trav body)
-    | node -> transform_children (trav_localfuns trav) node
+    | node -> traverse_unit (trav_localfuns trav) node
   in
   let rec tag stacklen callstack node =
     let trav = tag stacklen callstack in
@@ -16,7 +16,7 @@ let tag_index program =
     | GlobalDef _ ->
       let index = !nglobs in
       nglobs := !nglobs + 1;
-      annotate (Index index) (transform_children trav node)
+      annotate (Index index) (traverse_unit trav node)
 
     | FunDef (export, rtype, name, params, body, ann) ->
       (* label name for local function is "__<parent_label>_<name>" *)
@@ -42,7 +42,7 @@ let tag_index program =
     | VarDec _ | Param _ | Dim _ ->
       let index = !stacklen in
       stacklen := !stacklen + 1;
-      annotate (Index index) (transform_children trav node)
+      annotate (Index index) (traverse_unit trav node)
 
     | FunDec (_, name, _, _) ->
       let index = !nimport in
@@ -60,7 +60,7 @@ let tag_index program =
       in
       annotate (Index index) node
 
-    | _ -> transform_children trav node
+    | _ -> traverse_unit trav node
   in tag (ref 0) [] program
 
 (* Undo context analysis *)
@@ -74,7 +74,7 @@ let rec strip_context = function
   | FunUse (dec, args, ann) ->
     FunCall (nameof dec, List.map strip_context args, ann)
 
-  | node -> transform_children strip_context node
+  | node -> traverse_unit strip_context node
 
 let phase = function
   | Ast node ->

phases/typecheck.ml

@@ -265,7 +265,7 @@ let rec typecheck node =
     raise (NodeError (node, "array constants can only be used in array \
                              initialisation"))
 
-  | _ -> transform_children typecheck node
+  | _ -> traverse_unit typecheck node
 
 let phase = function
   | Ast node -> Ast (typecheck node)

phases/unroll.ml

@@ -14,7 +14,7 @@ let rec assigns name = function
 
 let rec replace_var name replacement = function
   | VarUse (VarDec (_, var, _, _), None, _) when var = name -> replacement
-  | node -> transform_children (replace_var name replacement) node
+  | node -> traverse_unit (replace_var name replacement) node
 
 let rec get_body_step i rest = function
   | [] -> None
@@ -77,11 +77,11 @@ let rec unroll_body counters = function
 
 and unroll counters = function
   | Block stats -> Block (unroll_body counters stats)
-  | node -> transform_children (unroll counters) node
+  | node -> traverse_unit (unroll counters) node
 
 let rec prune_vardecs counters = function
   | VarDec (_, name, _, _) when Hashtbl.mem counters name -> DummyNode
-  | node -> transform_children (prune_vardecs counters) node
+  | node -> traverse_unit (prune_vardecs counters) node
 
 let phase = function
   | Ast node ->

types.mli

@@ -138,7 +138,7 @@ and node =
         Used for short-circuit evaluation. *)
   | DummyNode
     (** Null node, pruned by {!Util.flatten_blocks}, which is called by
-        {!Util.transform_children} in a traversal. *)
+        {!Util.traverse_unit} in a traversal. *)
 
 (** {2 Assembly instructions} *)
 

util.ml

@@ -97,77 +97,131 @@ let rec flatten_blocks lst =
 
 (* Default tree transformation
  * (node -> node) -> node -> node *)
-let transform_children trav node =
-  let trav_all nodes = List.map trav nodes in
+let rec traverse u ( *: ) trav node =
+  let trav_all nodes =
+    let (nodes, res) = List.split (List.map trav nodes) in
+    (nodes, List.fold_left ( *: ) u res)
+  in
   match node with
   | Program (decls, ann) ->
-    Program (flatten_blocks (trav_all decls), ann)
+    let (decls, res_decls) = trav_all decls in
+    (Program (flatten_blocks decls, ann), res_decls)
   | FunDec (ret_type, name, params, ann) ->
-    FunDec (ret_type, name, trav_all params, ann)
+    let (params, res_params) = trav_all params in
+    (FunDec (ret_type, name, params, ann), res_params)
   | FunDef (export, ret_type, name, params, body, ann) ->
-    FunDef (export, ret_type, name, trav_all params, trav body, ann)
+    let (params, resp) = trav_all params in
+    let (body, resb) = trav body in
+    (FunDef (export, ret_type, name, params, body, ann), resp *: resb)
   | GlobalDec (ctype, name, ann) ->
-    GlobalDec (ctype, name, ann)
+    (GlobalDec (ctype, name, ann), u)
   | GlobalDef (export, ctype, name, Some init, ann) ->
-    GlobalDef (export, ctype, name, Some (trav init), ann)
+    let (init, res_init) = trav init in
+    (GlobalDef (export, ctype, name, Some init, ann), res_init)
 
   | VarDecs decs ->
-    VarDecs (trav_all decs)
+    let (decs, res_decs) = trav_all decs in
+    (VarDecs decs, res_decs)
   | LocalFuns funs ->
-    LocalFuns (trav_all funs)
+    let (funs, res_funs) = trav_all funs in
+    (LocalFuns funs, res_funs)
 
   | VarDec (ctype, name, Some init, ann) ->
-    VarDec (ctype, name, Some (trav init), ann)
+    let (init, res_init) = trav init in
+    (VarDec (ctype, name, Some init, ann), res_init)
   | Assign (name, None, value, ann) ->
-    Assign (name, None, trav value, ann)
+    let (value, res_value) = trav value in
+    (Assign (name, None, value, ann), res_value)
   | Assign (name, Some dims, value, ann) ->
-    Assign (name, Some (trav_all dims), trav value, ann)
+    let (dims, res_dims) = trav_all dims in
+    let (value, res_value) = trav value in
+    (Assign (name, Some dims, value, ann), res_dims *: res_value)
   | VarLet (dec, None, value, ann) ->
-    VarLet (dec, None, trav value, ann)
+    let (value, res_value) = trav value in
+    (VarLet (dec, None, value, ann), res_value)
   | VarLet (dec, Some dims, value, ann) ->
-    VarLet (dec, Some (trav_all dims), trav value, ann)
+    let (dims, res_dims) = trav_all dims in
+    let (value, res_value) = trav value in
+    (VarLet (dec, Some dims, value, ann), res_dims *: res_value)
   | Return (value, ann) ->
-    Return (trav value, ann)
+    let (value, res_value) = trav value in
+    (Return (value, ann), res_value)
   | If (cond, body, ann) ->
-    If (trav cond, trav body, ann)
-  | IfElse (cond, true_body, false_body, ann) ->
-    IfElse (trav cond, trav true_body, trav false_body, ann)
+    let (cond, res_cond) = trav cond in
+    let (body, res_body) = trav body in
+    (If (cond, body, ann), res_cond *: res_body)
+  | IfElse (cond, tbody, fbody, ann) ->
+    let (cond, resa) = trav cond in
+    let (tbody, resb) = trav tbody in
+    let (fbody, resc) = trav fbody in
+    (IfElse (cond, tbody, fbody, ann), resa *: resb *: resc)
   | While (cond, body, ann) ->
-    While (trav cond, trav body, ann)
+    let (cond, resc) = trav cond in
+    let (body, resb) = trav body in
+    (While (cond, body, ann), resc *: resb)
   | DoWhile (cond, body, ann) ->
-    DoWhile (trav cond, trav body, ann)
+    let (cond, resc) = trav cond in
+    let (body, resb) = trav body in
+    (DoWhile (cond, body, ann), resc *: resb)
   | For (counter, start, stop, step, body, ann) ->
-    For (counter, trav start, trav stop, trav step, trav body, ann)
+    let (start, resa) = trav start in
+    let (stop, resb) = trav stop in
+    let (step, resc) = trav step in
+    let (body, resd) = trav body in
+    let res = resa *: resb *: resc *: resd in
+    (For (counter, start, stop, step, body, ann), res)
   | Allocate (dec, dims, ann) ->
-    Allocate (dec, trav_all dims, ann)
+    let (dims, res_dims) = trav_all dims in
+    (Allocate (dec, dims, ann), res_dims)
   | Expr value ->
-    Expr (trav value)
+    let (value, res_value) = trav value in
+    (Expr value, res_value)
   | Block (body) ->
-    Block (trav_all body)
+    let (body, res_body) = trav_all body in
+    (Block body, res_body)
 
   | Monop (op, value, ann) ->
-    Monop (op, trav value, ann)
+    let (value, res_value) = trav value in
+    (Monop (op, value, ann), res_value)
   | Binop (op, left, right, ann) ->
-    Binop (op, trav left, trav right, ann)
-  | Cond (cond, true_expr, false_expr, ann) ->
-    Cond (trav cond, trav true_expr, trav false_expr, ann)
+    let (left, res_left) = trav left in
+    let (right, res_right) = trav right in
+    (Binop (op, left, right, ann), res_left *: res_right)
+  | Cond (cond, texpr, fexpr, ann) ->
+    let (cond, resa) = trav cond in
+    let (texpr, resb) = trav texpr in
+    let (fexpr, resc) = trav fexpr in
+    (Cond (cond, texpr, fexpr, ann), resa *: resb *: resc)
   | TypeCast (ctype, value, ann) ->
-    TypeCast (ctype, trav value, ann)
+    let (value, res_value) = trav value in
+    (TypeCast (ctype, value, ann), res_value)
   | FunCall (name, args, ann) ->
-    FunCall (name, trav_all args, ann)
+    let (args, res_args) = trav_all args in
+    (FunCall (name, args, ann), res_args)
   | Arg value ->
-    Arg (trav value)
+    let (value, res_value) = trav value in
+    (Arg value, res_value)
 
   | ArrayInit (value, dims) ->
-    ArrayInit (trav value, dims)
+    let (value, res_value) = trav value in
+    (ArrayInit (value, dims), res_value)
   | Var (dec, Some dims, ann) ->
-    Var (dec, Some (trav_all dims), ann)
+    let (dims, res_dims) = trav_all dims in
+    (Var (dec, Some dims, ann), res_dims)
   | VarUse (dec, Some dims, ann) ->
-    VarUse (dec, Some (trav_all dims), ann)
+    let (dims, res_dims) = trav_all dims in
+    (VarUse (dec, Some dims, ann), res_dims)
   | FunUse (dec, params, ann) ->
-    FunUse (dec, trav_all params, ann)
+    let (params, res_params) = trav_all params in
+    (FunUse (dec, params, ann), res_params)
+
+  | _ -> (node, u)
+
+let traverse_unit visit node =
+  let (node, _) = traverse () (fun () () -> ()) (fun n -> (visit n, ())) node in
+  node
 
-  | _ -> node
+let traverse_list visit = traverse [] (@) visit
 
 let annotate a = function
   | Program (decls, ann) ->

util.mli

@@ -1,5 +1,7 @@
 (** Utility functions used by multiple phases. *)
 
+open Types
+
 (** {2 Generating variables} *)
 
 (** Generate a new identifier from a given base, e.g. ["foo"] becomes
@@ -24,14 +26,28 @@ val generate_id : string -> int -> string
 
 (** {2 AST traversal} *)
 
-(** Default transformation traversal for AST nodes of arbitrary constructor.
-    For each constructor that has one or more children of type {!Types.node},
-    the children are transformed with the given transformation function, and a
-    new node is returned with the transformed children. For [Program] nodes,
-    {!flatten_blocks} is called on the resulting declaration list. This allows
-    the transformation function to return multiple nodes as a replacement, in
-    the form of a [Block] node with multiple children. *)
-val transform_children : (Types.node -> Types.node) -> Types.node -> Types.node
+(** Default transformation traversal for AST nodes of arbitrary constructor:
+    [traverse unit_type fold_results visit_node node]. For each constructor that
+    has one or more children of type {!Types.node}, the children are transformed
+    with the given transformation function. A [(node, result)] tuple is
+    returned, where the secondary result has the type of the given unit type.
+    [visit_node] must also return such a tuple. [fold_results] is used to reduce
+    results of multiple children to a single result.
+
+    For [Program] nodes, {!flatten_blocks} is called on the resulting
+    declaration list. This allows the transformation function to return multiple
+    nodes as a replacement, in the form of a [Block] node with multiple
+    children. *)
+val traverse : 'a -> ('a -> 'a -> 'a) -> (node -> (node * 'a)) -> node ->
+               (node * 'a)
+
+(** Wrapper for {!traverse} that ignores the secondary traversal result. Returns
+    {!Types.node} instead of a tuple. *)
+val traverse_unit : (node -> node) -> node -> node
+
+(** Wrapper for {!traverse} for list results. Defined as:
+    [let traverse_list visit = traverse [] (@) visit] *)
+val traverse_list : (node -> (node * 'a list)) -> node -> (node * 'a list)
 
 (** Flatten [Block] nodes into containing node lists.
     E.g., [[A; Block [B; Block [C; D]]; E] -> [A; B; C; D; E]].
@@ -40,36 +56,36 @@ val transform_children : (Types.node -> Types.node) -> Types.node -> Types.node
     practice is to call this function once on the children of a [Program] node
     after any traversal that may generate [Block] nodes that need to be
     flattened. *)
-val flatten_blocks : Types.node list -> Types.node list
+val flatten_blocks : node list -> node list
 
 (** Extract the list of child nodes from a [Block] node. *)
-val block_body : Types.node -> Types.node list
+val block_body : node -> node list
 
 (** {2 AST node annotations} *)
 
 (** Add a single annotation to a node. *)
-val annotate : Types.annotation -> Types.node -> Types.node
+val annotate : annotation -> node -> node
 
 (** Extract annotations from a node of arbitrary constructor. *)
-val annof : Types.node -> Types.annotation list
+val annof : node -> annotation list
 
 (** Get the value of the [Loc] annotation of a node, or {!noloc} if no location
     can be found. *)
-val locof : Types.node -> Types.location
+val locof : node -> location
 
 (** Empty node location: [("", 0, 0, 0, 0)]. Used then location of a node is
     unknown (if the annotation was removed at some point) or
     non-existant/irrelevant (for generated nodes on which no errors will occur --
     hopefully...). *)
-val noloc : Types.location
+val noloc : location
 
 (** Get the value of the [Depth] annotation of a node. Raises
     {!Types.InvalidNode} if the annotation can not be found. *)
-val depthof : Types.node -> int
+val depthof : node -> int
 
 (** Get the value of the [Index] annotation of a node. Raises
     {!Types.InvalidNode} if the annotation can not be found. *)
-val indexof : Types.node -> int
+val indexof : node -> int
 
 (** Get the value of the [Type] annotation of a node. Some node types
     do not need to be annotated since they have inherent types. For example, a
@@ -78,33 +94,33 @@ val indexof : Types.node -> int
     are [VarDec], [Param], [FunDec], [FunDef], [GlobalDec], [GlobalDef],
     [TypeCast], and [Dim]. Raises a {!Types.InvalidNode} if the annotation can
     not be found, and the type has no inherent type. *)
-val typeof : Types.node -> Types.ctype
+val typeof : node -> ctype
 
 (** Get the value of the [LabelName] annotation of a node. Raises
     {!Types.InvalidNode} if the annotation can not be found. *)
-val labelof : Types.node -> string
+val labelof : node -> string
 
 (** Get the basic type of a declaration, removing array dimensions *)
-val basetypeof : Types.node -> Types.ctype
+val basetypeof : node -> ctype
 
 (** Get the value of the name attribute from a variable or function declaration
     (similar to {!typeof} for nodes that have types attributes). Raises
     {!Types.InvalidNode} if the node is not one of [GlobalDec], [GlobalDef],
     [FunDec], [FunDef], [VarDec], [Param], or [Dim]. *)
-val nameof : Types.node -> string
+val nameof : node -> string
 
 (** Get the CiviC data type of a constant value. *)
-val const_type : Types.const -> Types.ctype
+val const_type : const -> ctype
 
 (** Check if a constant value is eligible for creating optimized assembly
     instructions. E.g. [Intval (-1)] is eligible because the instruction
     [iloadc_m1] exists. Used to decide on which {!Types.instr} constructor to
     use during the assembly phases. This function always returns [false] when
     optimizations are disabled (when {!Globals.args}[.optimize = false]). *)
-val is_immediate_const : Types.const -> bool
+val is_immediate_const : const -> bool
 
 (** Check if a node has an array type. I.e., [Array] or [ArrayDims]. *)
-val is_array : Types.node -> bool
+val is_array : node -> bool
 
 (** {2 Logging} *)
 
@@ -113,7 +129,7 @@ val hline : string
 
 (** Print the stringification of a node to [stderr] (uses
     {!Stringify.node2str}). *)
-val prt_node : Types.node -> unit
+val prt_node : node -> unit
 
 (** Output a line to stderr if the verbosity level in {!Globals.args} is at
     least as high as the specified verbosity level. The line is indented with a
@@ -127,10 +143,10 @@ val log_plain_line : int -> string -> unit
 
 (** Same as {!log_line}, but prints a node stringification instead of a literal
     string. *)
-val log_node : int -> Types.node -> unit
+val log_node : int -> node -> unit
 
-(** Generate an Types.location tuple from Lexing data structures *)
-val loc_from_lexpos : Lexing.position -> Lexing.position -> Types.location
+(** Generate an location tuple from Lexing data structures *)
+val loc_from_lexpos : Lexing.position -> Lexing.position -> location
 
 (** Print location tuple to stderr. Produces
     something like the following: {v
@@ -138,7 +154,7 @@ int foo;
     ^^^ v}
     The location tuple is likely to originate from a node annotation, extracted
     using {!locof}.*)
-val prerr_loc : Types.location -> unit
+val prerr_loc : location -> unit
 
 (** Print location tuple to stderr, along with an error message. Produces
     something like the following: {v
@@ -146,13 +162,13 @@ File "foo.cvc", line 10, characters 8-11:
 <message>
     int foo;
         ^^^ v} *)
-val prerr_loc_msg : Types.location -> string -> unit
+val prerr_loc_msg : location -> string -> unit
 
 (** Print an error message for a node. Calls {!prerr_loc_msg}. *)
-val node_error : Types.node -> string -> unit
+val node_error : node -> string -> unit
 
 (** Print a warning message for a node. Calls {!prerr_loc_msg}. *)
-val node_warning : Types.node -> string -> unit
+val node_warning : node -> string -> unit
 
 (** {2 String utilities} *)