|
|
@@ -2,6 +2,45 @@ open Printf
|
|
|
open Types
|
|
|
open Util
|
|
|
|
|
|
+(* Check if a function defines a variable name *)
|
|
|
+let defines var = function
|
|
|
+ | FunDef (export, ret_type, name, params, Block (VarDecs decs :: tl), ann) ->
|
|
|
+ let rec trav_decs = function
|
|
|
+ | [] -> false
|
|
|
+ | Param (ArrayDims (_, dims), name, _) :: tl ->
|
|
|
+ name = var || trav_decs dims || trav_decs tl
|
|
|
+ | (Dim (name, _) | VarDec (_, name, _, _) | Param (_, name, _)) :: _
|
|
|
+ when name = var -> true
|
|
|
+ | _ :: tl -> trav_decs tl
|
|
|
+ in
|
|
|
+ trav_decs params || trav_decs decs
|
|
|
+ | _ -> raise InvalidNode
|
|
|
+
|
|
|
+(* Replace all occurences of a variable name with another name *)
|
|
|
+let rec replace_var var replacement node =
|
|
|
+ let trav = (replace_var var replacement) in
|
|
|
+ let trav_all = List.map trav in
|
|
|
+ let trav_opt = function None -> None | Some node -> Some (trav node) in
|
|
|
+ match node with
|
|
|
+ (* Replace variable name on match *)
|
|
|
+ | Var (name, ind, ann) when name = var ->
|
|
|
+ let ind = match ind with None -> None | Some ind -> Some (trav_all ind) in
|
|
|
+ Var (replacement, ind, ann)
|
|
|
+
|
|
|
+ (* Don't enter a function body if it redefines the variable *)
|
|
|
+ | FunDef _ when defines var node -> node
|
|
|
+
|
|
|
+ (* Don't traverse into a for-loop body if the loop counter redefines var *)
|
|
|
+ | For (counter, start, stop, step, body, ann) when counter = var ->
|
|
|
+ For (counter, trav start, trav stop, trav step, body, ann)
|
|
|
+
|
|
|
+ (* At this point, array dimension expressions may not have been moved to new
|
|
|
+ * variables yet, so traverse them explicitly *)
|
|
|
+ | VarDec (ArrayDims (ctype, dims), name, init, ann) ->
|
|
|
+ VarDec (ArrayDims (ctype, trav_all dims), name, trav_opt init, ann)
|
|
|
+
|
|
|
+ | node -> traverse_unit trav node
|
|
|
+
|
|
|
(* Create new constant variables for scalar initialisations on arrays so that
|
|
|
* they are only evaluated once *)
|
|
|
let rec move_scalars = function
|
|
|
@@ -21,56 +60,79 @@ let rec move_scalars = function
|
|
|
|
|
|
(* Generate new variables for array dimensions, to avoid re-evalutation when
|
|
|
* array dimensions are used (e.g., after array dimension reduction). *)
|
|
|
-let rec array_dims node =
|
|
|
- let make_dims make_dimname values make_dec =
|
|
|
- let names = mapi make_dimname values in
|
|
|
+let array_dims node =
|
|
|
+ (*
|
|
|
+ let make_dimname basename i = generate_const basename (i + 1) in
|
|
|
+ *)
|
|
|
+ let make_dimname = generate_const in
|
|
|
+ let patch_dims basename values make_decs =
|
|
|
+ let names = mapi (fun i _ -> make_dimname basename i) values in
|
|
|
|
|
|
- let decs = List.map2 make_dec values names in
|
|
|
+ let decs = List.concat (List.map2 make_decs values names) in
|
|
|
|
|
|
let make_dim value name = Dim (name, annof value) in
|
|
|
let dims = List.map2 make_dim values names in
|
|
|
|
|
|
(decs, dims)
|
|
|
in
|
|
|
- match node with
|
|
|
- | VarDec (ArrayDims (ctype, values), name, init, ann) ->
|
|
|
- (* Names for VarDec dimensions must be unique to avoid weid errors when
|
|
|
- * during context analysis, when an array variable is redeclared within the
|
|
|
- * same scope *)
|
|
|
- let make_dimname i _ = fresh_const (name ^ "_" ^ string_of_int (i + 1)) in
|
|
|
-
|
|
|
- let make_dec value name = VarDec (Int, name, Some value, []) in
|
|
|
- let (decs, dims) = make_dims make_dimname values make_dec in
|
|
|
- Block (decs @ [VarDec (ArrayDims (ctype, dims), name, init, ann)])
|
|
|
-
|
|
|
- | GlobalDef (export, ArrayDims (ctype, values), name, init, ann) ->
|
|
|
- (* For global decs, the name must be derived from the array base name, but
|
|
|
- * not constant (no trailing _) since the variable must exist for exporting
|
|
|
- * (and not pruned during constant propagation) *)
|
|
|
- let make_dimname i _ = generate_id name (i + 1) in
|
|
|
-
|
|
|
- let make_dec value name = GlobalDef (export, Int, name, Some value, []) in
|
|
|
- let (decs, dims) = make_dims make_dimname values make_dec in
|
|
|
- Block (decs @ [GlobalDef (export, ArrayDims (ctype, dims), name, init, ann)])
|
|
|
-
|
|
|
- (* DISABLED, this is also done in extern.ml
|
|
|
- | GlobalDec (ArrayDims (ctype, values), name, ann) ->
|
|
|
- (*
|
|
|
- let rec make_decs = function
|
|
|
- | [] -> []
|
|
|
- | Dim (name, ann) :: tl -> GlobalDec (Int, name, ann) :: (make_decs tl)
|
|
|
- | _ -> raise InvalidNode
|
|
|
- in
|
|
|
- let decs = make_decs values in
|
|
|
- Block (decs @ [GlobalDec (ArrayDims (ctype, dims), name, ann)])
|
|
|
- *)
|
|
|
|
|
|
- let make_dec value name = GlobalDec (Int, name, []) in
|
|
|
- let (decs, dims) = make_dims name values make_dec in
|
|
|
- Block (decs @ [GlobalDec (ArrayDims (ctype, dims), name, ann)])
|
|
|
- *)
|
|
|
+ (* Save dimension replacements in one global hash table (we are not replacing
|
|
|
+ * local vars, so everything is in the global scope) *)
|
|
|
+ let replacements = Hashtbl.create 10 in
|
|
|
+
|
|
|
+ let rec trav = function
|
|
|
+ | VarDec (ArrayDims (ctype, values), name, init, ann) ->
|
|
|
+ let make_decs value name = [VarDec (Int, name, Some value, [])] in
|
|
|
+ let (decs, dims) = patch_dims name values make_decs in
|
|
|
+ Block (decs @ [VarDec (ArrayDims (ctype, dims), name, init, ann)])
|
|
|
+
|
|
|
+ | GlobalDef (export, ArrayDims (ctype, values), name, init, ann) ->
|
|
|
+ (* Move array dimensions into new variables to avoid double evaluation of
|
|
|
+ * expressions with side effects (i.e. function calls) *)
|
|
|
+ let make_decs value name = [GlobalDef (export, Int, name, Some value, [])] in
|
|
|
+ let (decs, dims) = patch_dims name values make_decs in
|
|
|
+ Block (decs @ [GlobalDef (export, ArrayDims (ctype, dims), name, init, ann)])
|
|
|
+
|
|
|
+ | GlobalDec (ArrayDims (ctype, dims), name, ann) ->
|
|
|
+ (* Create an 'extern int ...' definition for each dimension with a
|
|
|
+ * consistent import name, and replace all local uses with the imported
|
|
|
+ * variable name *)
|
|
|
+ let make_decs dim impname =
|
|
|
+ match dim with
|
|
|
+ | Dim (dimname, _) ->
|
|
|
+ (* Fix name clashes (needed because context analysis has not been done
|
|
|
+ * yet) *)
|
|
|
+ if Hashtbl.mem replacements dimname then begin
|
|
|
+ raise (FatalError (NodeMsg (dim, "duplicate dimension name")))
|
|
|
+ end;
|
|
|
+
|
|
|
+ (* Occurences of dimension names are replaced after the traversal *)
|
|
|
+ Hashtbl.add replacements dimname impname;
|
|
|
+
|
|
|
+ [GlobalDec (Int, impname, [])]
|
|
|
+ | _ -> raise InvalidNode
|
|
|
+ in
|
|
|
+ let (decs, dims) = patch_dims name dims make_decs in
|
|
|
+ Block (decs @ [GlobalDec (ArrayDims (ctype, dims), name, ann)])
|
|
|
+
|
|
|
+ (*
|
|
|
+ let make_decs i = function
|
|
|
+ | Dim (dimname, dimann) ->
|
|
|
+ let impname = generate_id name (i + 1) in
|
|
|
+ let decs = [
|
|
|
+ GlobalDec (Int, impname, []);
|
|
|
+ GlobalDef (false, Int, dimname, Some (Var (impname, None, [])), [])
|
|
|
+ ] in
|
|
|
+ (decs, Dim (impname, dimann))
|
|
|
+ | _ -> raise InvalidNode
|
|
|
+ in
|
|
|
+ let (decs, dims) = List.split (mapi make_decs dims) in
|
|
|
+ Block (List.concat decs @ [GlobalDec (ArrayDims (ctype, dims), name, ann)])
|
|
|
+ *)
|
|
|
|
|
|
- | node -> traverse_unit array_dims node
|
|
|
+ | node -> traverse_unit trav node
|
|
|
+ in
|
|
|
+ Hashtbl.fold replace_var replacements (trav node)
|
|
|
|
|
|
(* Split variable initialisation into declaration and assignment *)
|
|
|
let rec split_inits = function
|
|
|
@@ -156,24 +218,14 @@ let rec move_inits = function
|
|
|
| node -> traverse_unit move_inits node
|
|
|
|
|
|
let for_to_while node =
|
|
|
- let rec replace_var var replacement node =
|
|
|
- let trav = (replace_var var replacement) in
|
|
|
- match node with
|
|
|
- | Var (name, None, ann) when name = var ->
|
|
|
- Var (replacement, None, ann)
|
|
|
- | For (counter, start, stop, step, body, ann) when counter = var ->
|
|
|
- For (replacement, trav start, trav stop, trav step, trav body, ann)
|
|
|
- | node ->
|
|
|
- traverse_unit trav node
|
|
|
- in
|
|
|
- let rec traverse new_vars = function
|
|
|
+ let rec trav new_vars = function
|
|
|
| FunDef (export, ret_type, name, params, body, ann) ->
|
|
|
let rec place_decs decs = function
|
|
|
| Block (VarDecs lst :: tl) -> Block (VarDecs (decs @ lst) :: tl)
|
|
|
| _ -> raise InvalidNode
|
|
|
in
|
|
|
let new_vars = ref [] in
|
|
|
- let body = traverse new_vars body in
|
|
|
+ let body = trav new_vars body in
|
|
|
let create_vardec name = VarDec (Int, name, None, []) in
|
|
|
let new_vardecs = List.map create_vardec !new_vars in
|
|
|
let body = place_decs new_vardecs body in
|
|
|
@@ -199,7 +251,7 @@ let for_to_while node =
|
|
|
Assign (_i, None, start, annof start);
|
|
|
Assign (_stop, None, stop, annof stop);
|
|
|
Assign (_step, None, step, annof step);
|
|
|
- traverse new_vars (While (cond, (Block (
|
|
|
+ trav new_vars (While (cond, (Block (
|
|
|
block_body (replace_var counter _i body) @
|
|
|
[Assign (_i, None, Binop (Add, vi, vstep, []), [])]
|
|
|
)), ann));
|
|
|
@@ -208,41 +260,35 @@ let for_to_while node =
|
|
|
(* Transform while-loops to do-while loops in if-statements *)
|
|
|
(* DISABLED, while-loops are explicitly supported by the assembly phase
|
|
|
| While (cond, body, ann) ->
|
|
|
- let cond = traverse new_vars cond in
|
|
|
- let body = traverse new_vars body in
|
|
|
+ let cond = trav new_vars cond in
|
|
|
+ let body = trav new_vars body in
|
|
|
Block [If (cond, Block [DoWhile (cond, body, ann)], ann)]
|
|
|
*)
|
|
|
|
|
|
- | node -> traverse_unit (traverse new_vars) node
|
|
|
+ | node -> traverse_unit (trav new_vars) node
|
|
|
in
|
|
|
- traverse (ref []) node
|
|
|
-
|
|
|
-let rec sublist n = function
|
|
|
- | [] when n > 0 -> raise (Invalid_argument "n")
|
|
|
- | [] -> []
|
|
|
- | lst when n = 0 -> lst
|
|
|
- | _ :: tl -> sublist (n - 1) tl
|
|
|
+ trav (ref []) node
|
|
|
|
|
|
let rec array_init = function
|
|
|
(* Transform array constant initialisation into separate assign statements
|
|
|
- * for all entries in the constant array *)
|
|
|
+ * for all entries in the array literal *)
|
|
|
| Assign (name, None, ArrayInit (ArrayConst _ as value, dims), ann) ->
|
|
|
let intconst i = Const (IntVal (Int32.of_int i), []) in
|
|
|
let ndims = List.length dims in
|
|
|
let rec make_assigns depth i indices = function
|
|
|
| [] -> []
|
|
|
| hd :: tl ->
|
|
|
- let assigns = traverse depth (i :: indices) hd in
|
|
|
+ let assigns = trav depth (i :: indices) hd in
|
|
|
make_assigns depth (i + 1) indices tl @ assigns
|
|
|
- and traverse depth indices = function
|
|
|
+ and trav depth indices = function
|
|
|
| ArrayConst (values, _) ->
|
|
|
make_assigns (depth + 1) 0 indices values
|
|
|
| value when depth = ndims ->
|
|
|
let indices = List.map intconst indices in
|
|
|
[Assign (name, Some (List.rev indices), value, ann)]
|
|
|
- (* DISABLED: nesting level must be equal to number of dimensions
|
|
|
+ (* DISABLED: nesting level must now be equal to number of dimensions
|
|
|
| value when depth < ndims ->
|
|
|
- (* Use the for-loops constructed for scalar assignment *)
|
|
|
+ (* Use for-loops for scalar assignment on sub-array *)
|
|
|
let value = ArrayInit (value, dims) in
|
|
|
let indices = List.map intconst indices in
|
|
|
[array_init (Assign (name, Some (List.rev indices), value, ann))]
|
|
|
@@ -252,28 +298,7 @@ let rec array_init = function
|
|
|
"dimension mismatch: expected %d nesting levels, got %d"
|
|
|
ndims depth)))
|
|
|
in
|
|
|
- Block (List.rev (traverse 0 [] value))
|
|
|
-
|
|
|
- (*
|
|
|
- let ndims = list_size dims in
|
|
|
- let rec make_assigns depth i indices = function
|
|
|
- | [] -> []
|
|
|
- | hd :: tl ->
|
|
|
- let assigns = traverse depth (i :: indices) hd in
|
|
|
- make_assigns depth (i + 1) indices tl @ assigns
|
|
|
- and traverse depth indices = function
|
|
|
- | ArrayConst (values, _) ->
|
|
|
- make_assigns (depth + 1) 0 indices values
|
|
|
- | value when depth = ndims ->
|
|
|
- let intconst i = Const (IntVal (Int32.of_int i), []) in
|
|
|
- [Assign (name, Some (List.rev_map intconst indices), value, loc)]
|
|
|
- | node ->
|
|
|
- raise (FatalError (NodeMsg (node, sprintf
|
|
|
- "dimension mismatch: expected %d nesting levels, got %d"
|
|
|
- ndims depth)))
|
|
|
- in
|
|
|
- Block (List.rev (traverse 0 [] value))
|
|
|
- *)
|
|
|
+ Block (List.rev (trav 0 [] value))
|
|
|
|
|
|
(* Replace no indices with empty indices to have a list below *)
|
|
|
| Assign (name, None, (ArrayInit _ as value), ann) ->
|
|
|
@@ -294,6 +319,12 @@ let rec array_init = function
|
|
|
in
|
|
|
For (counter, start, stop, step, body, [])
|
|
|
in
|
|
|
+ let rec sublist n = function
|
|
|
+ | [] when n > 0 -> raise (Invalid_argument "n")
|
|
|
+ | [] -> []
|
|
|
+ | lst when n = 0 -> lst
|
|
|
+ | _ :: tl -> sublist (n - 1) tl
|
|
|
+ in
|
|
|
let dims_left = sublist (List.length indices) dims in
|
|
|
add_loop indices dims_left
|
|
|
|
|
|
@@ -301,8 +332,9 @@ let rec array_init = function
|
|
|
|
|
|
let phase = function
|
|
|
| Ast node ->
|
|
|
- (* Generate variable declarations for expressions that must be evaluated
|
|
|
- * once and used multiple times *)
|
|
|
+ (* Move array dimensions and scalar initialisations into new variables as
|
|
|
+ * initialisations, so that they are evaluated exactly once, and so that
|
|
|
+ * dimension names are consistent with the array name *)
|
|
|
let node = move_scalars (array_dims node) in
|
|
|
|
|
|
(* Split variable initialisations into declarations and assignments, and
|
Taddeus Kroes