|
|
@@ -2,32 +2,12 @@ open Printf
|
|
|
open Types
|
|
|
open Util
|
|
|
|
|
|
-(* Create new constant variables for all assigned array values so that they are
|
|
|
- * only evaluated once *)
|
|
|
-let rec consts_to_vars node =
|
|
|
- let rec create_vars new_vars values = function
|
|
|
- | [] -> (new_vars, values)
|
|
|
- | hd :: tl ->
|
|
|
- let (new_vars, value) = match hd with
|
|
|
- | ArrayConst (values, ann) ->
|
|
|
- let (new_vars, values) = create_vars new_vars [] values in
|
|
|
- (new_vars, ArrayConst (values, ann))
|
|
|
- | value ->
|
|
|
- let index = fresh_const "const" in
|
|
|
- (new_vars @ [(index, value)], Var (index, None, annof value))
|
|
|
- in
|
|
|
- create_vars new_vars (values @ [value]) tl
|
|
|
- in
|
|
|
- match node with
|
|
|
- (* Add vardecs for values in arrayconst *)
|
|
|
- | VarDec (ArrayDims _ as ctype, name, Some (ArrayConst (values, vann)), ann) ->
|
|
|
- let (new_vars, values) = create_vars [] [] values in
|
|
|
- let value = ArrayConst (values, vann) in
|
|
|
- let create_vardec (name, value) =
|
|
|
- VarDec (basetypeof node, name, Some value, annof value)
|
|
|
- in
|
|
|
- let new_vardecs = List.map create_vardec new_vars in
|
|
|
- Block (new_vardecs @ [VarDec (ctype, name, Some value, ann)])
|
|
|
+(* Create new constant variables for scalar initialisations on arrays so that
|
|
|
+ * they are only evaluated once *)
|
|
|
+let rec move_scalars = function
|
|
|
+ (* Prevent next match for ArrayConst initialisations *)
|
|
|
+ | VarDec (ArrayDims _, _, Some (ArrayConst _), _) as node ->
|
|
|
+ node
|
|
|
|
|
|
(* Add vardec for scalar value *)
|
|
|
| VarDec (ArrayDims _ as ctype, name, Some value, ann) as node ->
|
|
|
@@ -37,21 +17,21 @@ let rec consts_to_vars node =
|
|
|
VarDec (ctype, name, Some (Var (scalar_name, None, annof value)), ann);
|
|
|
]
|
|
|
|
|
|
- | node -> traverse_unit consts_to_vars node
|
|
|
-
|
|
|
-let make_dims make_dimname values make_dec =
|
|
|
- let names = mapi make_dimname values in
|
|
|
-
|
|
|
- let decs = List.map2 make_dec values names in
|
|
|
-
|
|
|
- let make_dim value name = Dim (name, annof value) in
|
|
|
- let dims = List.map2 make_dim values names in
|
|
|
-
|
|
|
- (decs, dims)
|
|
|
+ | node -> traverse_unit move_scalars node
|
|
|
|
|
|
(* 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 decs = List.map2 make_dec 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
|
|
|
@@ -65,7 +45,7 @@ let rec array_dims node =
|
|
|
|
|
|
| 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
|
|
|
+ * 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
|
|
|
|
|
|
@@ -260,19 +240,40 @@ let rec array_init = function
|
|
|
| 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
|
|
|
| value when depth < ndims ->
|
|
|
(* Use the for-loops constructed for scalar assignment *)
|
|
|
let value = ArrayInit (value, dims) in
|
|
|
let indices = List.map intconst indices in
|
|
|
[array_init (Assign (name, Some (List.rev indices), value, ann))]
|
|
|
+ *)
|
|
|
| node ->
|
|
|
- let msg = sprintf
|
|
|
+ raise (FatalError (NodeMsg (node, sprintf
|
|
|
"dimension mismatch: expected %d nesting levels, got %d"
|
|
|
- ndims depth
|
|
|
- in
|
|
|
- raise (FatalError (NodeMsg (node, msg)))
|
|
|
+ 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))
|
|
|
+ *)
|
|
|
|
|
|
(* Replace no indices with empty indices to have a list below *)
|
|
|
| Assign (name, None, (ArrayInit _ as value), ann) ->
|
|
|
@@ -302,7 +303,7 @@ let phase = function
|
|
|
| Ast node ->
|
|
|
(* Generate variable declarations for expressions that must be evaluated
|
|
|
* once and used multiple times *)
|
|
|
- let node = consts_to_vars (array_dims node) in
|
|
|
+ let node = move_scalars (array_dims node) in
|
|
|
|
|
|
(* Split variable initialisations into declarations and assignments, and
|
|
|
* move the assignments to the function body *)
|
|
|
@@ -310,6 +311,6 @@ let phase = function
|
|
|
|
|
|
(* Transform ArrayConst assignment to assignments in for-loops, and
|
|
|
* transform all for-loops to while-loops afterwards *)
|
|
|
- Ast (for_to_while (array_init (node)))
|
|
|
+ Ast (for_to_while (array_init node))
|
|
|
|
|
|
| _ -> raise InvalidInput
|