Rename lit directory

9 files changed, 137 insertions, 16 deletions

diff --git a/lit/basic-block-generation.org b/docs/basic-block-generation.org
index b835e61..1d78dad 100644
--- a/lit/basic-block-generation.org
+++ b/docs/basic-block-generation.org
@@ -354,6 +354,125 @@ Section CORRECTNESS.
 End CORRECTNESS.
 #+end_src
 
+* Partition
+:PROPERTIES:
+:header-args:ocaml: :comments noweb :noweb no-export :padline yes :tangle ../src/hls/Partition.ml
+:END:
+
+#+begin_src ocaml :comments no :padline no :exports none
+<<license>>
+#+end_src
+
+#+name: partition-main
+#+begin_src ocaml
+open Printf
+open Clflags
+open Camlcoq
+open Datatypes
+open Coqlib
+open Maps
+open AST
+open Kildall
+open Op
+open RTLBlockInstr
+open RTLBlock
+
+(** Assuming that the nodes of the CFG [code] are numbered in reverse postorder (cf. pass
+   [Renumber]), an edge from [n] to [s] is a normal edge if [s < n] and a back-edge otherwise. *)
+let find_edge i n =
+  let succ = RTL.successors_instr i in
+  let filt = List.filter (fun s -> P.lt n s || P.lt s (P.pred n)) succ in
+  ((match filt with [] -> [] | _ -> [n]), filt)
+
+let find_edges c =
+  PTree.fold (fun l n i ->
+      let f = find_edge i n in
+      (List.append (fst f) (fst l), List.append (snd f) (snd l))) c ([], [])
+
+let prepend_instr i = function
+  | {bb_body = bb; bb_exit = e} -> {bb_body = (i :: bb); bb_exit = e}
+
+let translate_inst = function
+  | RTL.Inop _ -> Some RBnop
+  | RTL.Iop (op, ls, dst, _) -> Some (RBop (None, op, ls, dst))
+  | RTL.Iload (m, addr, ls, dst, _) -> Some (RBload (None, m, addr, ls, dst))
+  | RTL.Istore (m, addr, ls, src, _) -> Some (RBstore (None, m, addr, ls, src))
+  | _ -> None
+
+let translate_cfi = function
+  | RTL.Icall (s, r, ls, dst, n) -> Some (RBcall (s, r, ls, dst, n))
+  | RTL.Itailcall (s, r, ls) -> Some (RBtailcall (s, r, ls))
+  | RTL.Ibuiltin (e, ls, r, n) -> Some (RBbuiltin (e, ls, r, n))
+  | RTL.Icond (c, ls, dst1, dst2) -> Some (RBcond (c, ls, dst1, dst2))
+  | RTL.Ijumptable (r, ls) -> Some (RBjumptable (r, ls))
+  | RTL.Ireturn r -> Some (RBreturn r)
+  | _ -> None
+
+let rec next_bblock_from_RTL is_start e (c : RTL.code) s i =
+  let succ = List.map (fun i -> (i, PTree.get i c)) (RTL.successors_instr i) in
+  let trans_inst = (translate_inst i, translate_cfi i) in
+  match trans_inst, succ with
+  | (None, Some i'), _ ->
+    if List.exists (fun x -> x = s) (snd e) && not is_start then
+      Errors.OK { bb_body = [RBnop]; bb_exit = RBgoto s }
+    else
+      Errors.OK { bb_body = [RBnop]; bb_exit = i' }
+  | (Some i', None), (s', Some i_n)::[] ->
+    if List.exists (fun x -> x = s) (fst e) then
+      Errors.OK { bb_body = [i']; bb_exit = RBgoto s' }
+    else if List.exists (fun x -> x = s) (snd e) && not is_start then
+      Errors.OK { bb_body = [RBnop]; bb_exit = RBgoto s }
+    else begin
+      match next_bblock_from_RTL false e c s' i_n with
+      | Errors.OK bb ->
+        Errors.OK (prepend_instr i' bb)
+      | Errors.Error msg -> Errors.Error msg
+    end
+  | _, _ ->
+    Errors.Error (Errors.msg (coqstring_of_camlstring "next_bblock_from_RTL went wrong."))
+
+let rec traverseacc f l c =
+  match l with
+  | [] -> Errors.OK c
+  | x::xs ->
+    match f x c with
+    | Errors.Error msg -> Errors.Error msg
+    | Errors.OK x' ->
+      match traverseacc f xs x' with
+      | Errors.Error msg -> Errors.Error msg
+      | Errors.OK xs' -> Errors.OK xs'
+
+let rec translate_all edge c s res =
+  let c_bb, translated = res in
+  if List.exists (fun x -> P.eq x s) translated then Errors.OK (c_bb, translated) else
+    (match PTree.get s c with
+     | None -> Errors.Error (Errors.msg (coqstring_of_camlstring "Could not translate all."))
+     | Some i ->
+       match next_bblock_from_RTL true edge c s i with
+       | Errors.Error msg -> Errors.Error msg
+       | Errors.OK {bb_body = bb; bb_exit = e} ->
+         let succ = List.filter (fun x -> P.lt x s) (successors_instr e) in
+         (match traverseacc (translate_all edge c) succ (c_bb, s :: translated) with
+          | Errors.Error msg -> Errors.Error msg
+          | Errors.OK (c', t') ->
+            Errors.OK (PTree.set s {bb_body = bb; bb_exit = e} c', t')))
+
+(* Partition a function and transform it into RTLBlock. *)
+let function_from_RTL f =
+  let e = find_edges f.RTL.fn_code in
+  match translate_all e f.RTL.fn_code f.RTL.fn_entrypoint (PTree.empty, []) with
+  | Errors.Error msg -> Errors.Error msg
+  | Errors.OK (c, _) ->
+    Errors.OK { fn_sig = f.RTL.fn_sig;
+                fn_stacksize = f.RTL.fn_stacksize;
+                fn_params = f.RTL.fn_params;
+                fn_entrypoint = f.RTL.fn_entrypoint;
+                fn_code = c
+              }
+
+let partition = function_from_RTL
+#+end_src
+
 * License
 
 #+name: license
diff --git a/lit/scheduler-languages.org b/docs/scheduler-languages.org
index cf03b3a..cf03b3a 100644
--- a/lit/scheduler-languages.org
+++ b/docs/scheduler-languages.org
diff --git a/lit/scheduler.org b/docs/scheduler.org
index 018633c..018633c 100644
--- a/lit/scheduler.org
+++ b/docs/scheduler.org
diff --git a/src/hls/Partition.ml b/src/hls/Partition.ml
index d7972e5..545277b 100644
--- a/src/hls/Partition.ml
+++ b/src/hls/Partition.ml
@@ -1,6 +1,6 @@
- (*
+(*
  * Vericert: Verified high-level synthesis.
- * Copyright (C) 2020 Yann Herklotz <yann@yannherklotz.com>
+ * Copyright (C) 2020-2022 Yann Herklotz <yann@yannherklotz.com>
  *
  * This program is free software: you can redistribute it and/or modify
  * it under the terms of the GNU General Public License as published by
@@ -16,6 +16,7 @@
  * along with this program.  If not, see <https://www.gnu.org/licenses/>.
  *)
 
+(* [[file:../../docs/basic-block-generation.org::partition-main][partition-main]] *)
 open Printf
 open Clflags
 open Camlcoq
@@ -122,3 +123,4 @@ let function_from_RTL f =
               }
 
 let partition = function_from_RTL
+(* partition-main ends here *)
diff --git a/src/hls/RTLBlock.v b/src/hls/RTLBlock.v
index 539d5bc..50bff90 100644
--- a/src/hls/RTLBlock.v
+++ b/src/hls/RTLBlock.v
@@ -16,7 +16,7 @@
  * along with this program.  If not, see <https://www.gnu.org/licenses/>.
  *)
 
-(* [[file:../../lit/scheduler-languages.org::rtlblock-main][rtlblock-main]] *)
+(* [[file:../../docs/scheduler-languages.org::rtlblock-main][rtlblock-main]] *)
 Require Import compcert.backend.Registers.
 Require Import compcert.common.AST.
 Require Import compcert.common.Events.
diff --git a/src/hls/RTLBlockInstr.v b/src/hls/RTLBlockInstr.v
index 19b3928..801a5ea 100644
--- a/src/hls/RTLBlockInstr.v
+++ b/src/hls/RTLBlockInstr.v
@@ -16,7 +16,7 @@
  * along with this program.  If not, see <https://www.gnu.org/licenses/>.
  *)
 
-(* [[file:../../lit/scheduler-languages.org::rtlblockinstr-imports][rtlblockinstr-imports]] *)
+(* [[file:../../docs/scheduler-languages.org::rtlblockinstr-imports][rtlblockinstr-imports]] *)
 Require Import Coq.micromega.Lia.
 
 Require Import compcert.backend.Registers.
@@ -33,7 +33,7 @@ Require Import Predicate.
 Require Import Vericertlib.
 (* rtlblockinstr-imports ends here *)
 
-(* [[file:../../lit/scheduler-languages.org::rtlblockinstr-instr-def][rtlblockinstr-instr-def]] *)
+(* [[file:../../docs/scheduler-languages.org::rtlblockinstr-instr-def][rtlblockinstr-instr-def]] *)
 Definition node := positive.
 
 Inductive instr : Type :=
@@ -44,7 +44,7 @@ Inductive instr : Type :=
 | RBsetpred : option pred_op -> condition -> list reg -> predicate -> instr.
 (* rtlblockinstr-instr-def ends here *)
 
-(* [[file:../../lit/scheduler-languages.org::rtlblockinstr-cf-instr-def][rtlblockinstr-cf-instr-def]] *)
+(* [[file:../../docs/scheduler-languages.org::rtlblockinstr-cf-instr-def][rtlblockinstr-cf-instr-def]] *)
 Inductive cf_instr : Type :=
 | RBcall : signature -> reg + ident -> list reg -> reg -> node -> cf_instr
 | RBtailcall : signature -> reg + ident -> list reg -> cf_instr
@@ -57,7 +57,7 @@ Inductive cf_instr : Type :=
 | RBpred_cf : pred_op -> cf_instr -> cf_instr -> cf_instr.
 (* rtlblockinstr-cf-instr-def ends here *)
 
-(* [[file:../../lit/scheduler-languages.org::rtlblockinstr-helpers][rtlblockinstr-helpers]] *)
+(* [[file:../../docs/scheduler-languages.org::rtlblockinstr-helpers][rtlblockinstr-helpers]] *)
 Fixpoint successors_instr (i : cf_instr) : list node :=
   match i with
   | RBcall sig ros args res s => s :: nil
@@ -148,7 +148,7 @@ Fixpoint init_regs (vl: list val) (rl: list reg) {struct rl} : regset :=
   end.
 (* rtlblockinstr-helpers ends here *)
 
-(* [[file:../../lit/scheduler-languages.org::rtlblockinstr-instr-state][rtlblockinstr-instr-state]] *)
+(* [[file:../../docs/scheduler-languages.org::rtlblockinstr-instr-state][rtlblockinstr-instr-state]] *)
 Record instr_state := mk_instr_state {
   is_rs: regset;
   is_ps: predset;
@@ -156,7 +156,7 @@ Record instr_state := mk_instr_state {
 }.
 (* rtlblockinstr-instr-state ends here *)
 
-(* [[file:../../lit/scheduler-languages.org::rtlblockinstr-type-def][rtlblockinstr-type-def]] *)
+(* [[file:../../docs/scheduler-languages.org::rtlblockinstr-type-def][rtlblockinstr-type-def]] *)
 Section DEFINITION.
 
   Context {bblock_body: Type}.
@@ -221,7 +221,7 @@ Section DEFINITION.
 End DEFINITION.
 (* rtlblockinstr-type-def ends here *)
 
-(* [[file:../../lit/scheduler-languages.org::rtlblockinstr-semantics][rtlblockinstr-semantics]] *)
+(* [[file:../../docs/scheduler-languages.org::rtlblockinstr-semantics][rtlblockinstr-semantics]] *)
 Section RELSEM.
 
   Context {bblock_body : Type}.
diff --git a/src/hls/RTLBlockgen.v b/src/hls/RTLBlockgen.v
index 6d38e4f..beca0ea 100644
--- a/src/hls/RTLBlockgen.v
+++ b/src/hls/RTLBlockgen.v
@@ -16,7 +16,7 @@
  * along with this program.  If not, see <https://www.gnu.org/licenses/>.
  *)
 
-(* [[file:../../lit/basic-block-generation.org::rtlblockgen-imports][rtlblockgen-imports]] *)
+(* [[file:../../docs/basic-block-generation.org::rtlblockgen-imports][rtlblockgen-imports]] *)
 Require compcert.backend.RTL.
 Require Import compcert.common.AST.
 Require Import compcert.lib.Maps.
@@ -148,7 +148,7 @@ Defined.
 Definition ceq {A: Type} (eqd: forall a b: A, {a = b} + {a <> b}) (a b: A): bool :=
   if eqd a b then true else false.
 
-(* [[file:../../lit/basic-block-generation.org::rtlblockgen-main][rtlblockgen-main]] *)
+(* [[file:../../docs/basic-block-generation.org::rtlblockgen-main][rtlblockgen-main]] *)
 Parameter partition : RTL.function -> Errors.res function.
 
 (** [find_block max nodes index]: Does not need to be sorted, because we use filter and the max fold
diff --git a/src/hls/RTLBlockgenproof.v b/src/hls/RTLBlockgenproof.v
index 4433d52..d51e5d4 100644
--- a/src/hls/RTLBlockgenproof.v
+++ b/src/hls/RTLBlockgenproof.v
@@ -16,7 +16,7 @@
  * along with this program.  If not, see <https://www.gnu.org/licenses/>.
  *)
 
-(* [[file:../../lit/basic-block-generation.org::rtlblockgenproof-imports][rtlblockgenproof-imports]] *)
+(* [[file:../../docs/basic-block-generation.org::rtlblockgenproof-imports][rtlblockgenproof-imports]] *)
 Require compcert.backend.RTL.
 Require Import compcert.common.AST.
 Require Import compcert.lib.Maps.
@@ -25,7 +25,7 @@ Require Import vericert.hls.RTLBlock.
 Require Import vericert.hls.RTLBlockgen.
 (* rtlblockgenproof-imports ends here *)
 
-(* [[file:../../lit/basic-block-generation.org::rtlblockgenproof-match-states][rtlblockgenproof-match-states]] *)
+(* [[file:../../docs/basic-block-generation.org::rtlblockgenproof-match-states][rtlblockgenproof-match-states]] *)
 Inductive match_states : RTL.state -> RTLBlock.state -> Prop :=
 | match_state :
   forall stk f tf sp pc rs m
@@ -34,7 +34,7 @@ Inductive match_states : RTL.state -> RTLBlock.state -> Prop :=
                (RTLBlock.State stk tf sp (find_block max n i) rs m).
 (* rtlblockgenproof-match-states ends here *)
 
-(* [[file:../../lit/basic-block-generation.org::rtlblockgenproof-correctness][rtlblockgenproof-correctness]] *)
+(* [[file:../../docs/basic-block-generation.org::rtlblockgenproof-correctness][rtlblockgenproof-correctness]] *)
 Section CORRECTNESS.
 
   Context (prog : RTL.program).
diff --git a/src/hls/RTLPar.v b/src/hls/RTLPar.v
index 160f71c..f380d19 100644
--- a/src/hls/RTLPar.v
+++ b/src/hls/RTLPar.v
@@ -16,7 +16,7 @@
  * along with this program.  If not, see <https://www.gnu.org/licenses/>.
  *)
 
-(* [[file:../../lit/scheduler-languages.org::rtlpar-main][rtlpar-main]] *)
+(* [[file:../../docs/scheduler-languages.org::rtlpar-main][rtlpar-main]] *)
 Require Import compcert.backend.Registers.
 Require Import compcert.common.AST.
 Require Import compcert.common.Events.