0-nostaging.ml

(*
This one has no staging.
The idea is a simple schema and values, but it's (probably) terribly slow.
*)

(* Schema and value definitions *)
type schema
  = SInt
  | SArray of schema

type value
  = VInt of int
  | VArray of value list

type file = int list


(* Load a "file" for given schema *)
exception LoadError;;

let rec load_file_go (s : schema) (xs : file) : value * file =
  match s, xs with
  | SInt , x :: xs
  -> VInt x, xs
  | SArray s, x :: xs
  -> let rec go i vs xs =
      match i with
      | 0 -> VArray (List.rev vs), xs
      | _ -> let (v,xs) = load_file_go s xs in
             go (i-1) (v :: vs) xs
     in go x [] xs

  | _, []
   -> raise LoadError
  ;;

let load_file (s : schema) (f : file) : value =
  match load_file_go s f with
  | v, [] -> v
  | _, x::xs -> raise LoadError
  ;;


assert (VArray [VInt 10; VInt 20] = load_file (SArray SInt) [2; 10; 20]);;


(* Some arbitrary operation we want to perform on the values *)
let rec value_twiddle (v : value) : value =
  match v with
  | VInt i  -> VInt (i + 1)
  | VArray vs -> VArray (List.map value_twiddle vs)
  ;;

assert (VInt 1 = value_twiddle (VInt 0));;
assert (VArray [VInt 1; VInt 2] = value_twiddle (VArray [VInt 0; VInt 1]));;


(* Writing back to file *)
let rec write_file (v : value) : file =
  match v with
  | VInt i -> [i]
  | VArray vs -> List.length vs :: List.concat (List.map write_file vs)
  ;;

assert ([2; 1; 0] = write_file (VArray [VInt 1; VInt 0]));;


(* The whole thing *)
let file_twiddle (s : schema) (f : file) : file =
  let v = load_file s f in
  let v = value_twiddle v in
  write_file v
;;

(* A silly test *)
assert ([2; 1; 2] = file_twiddle (SArray SInt) [2; 0; 1]);;

1-simple-staging.ml

(*
Some simple staging.
Here, we just specialise the load_file based on the schema.
That will give is a nicer load_file, but sadly it doesn't end up giving any more specialisation for the other operations.
*)
open Runcode;;

(* Schema and value definitions *)
type schema
  = SInt
  | SArray of schema

type value
  = VInt of int
  | VArray of value list

type file = int list


(* Load a "file" for given schema *)

let uncons xs =
  match xs with
  | x :: xs -> x, xs
  | []      -> raise Not_found
;;

let rec load_file_go (s : schema) : (file -> value * file) code =
  match s with
  | SInt -> .< fun xs ->
    let x, xs = uncons xs in
    VInt x, xs
  >.
  | SArray s -> .< fun xs ->
    let x, xs = uncons xs in
    let rec go i vs xs =
     match i with
     | 0 -> VArray (List.rev vs), xs
     | _ -> let (v,xs) = .~(load_file_go s) xs in
            go (i-1) (v :: vs) xs
    in go x [] xs
  >.
  ;;

let load_file (s : schema) : (file -> value) code =
  .< fun f ->
  fst ( .~(load_file_go s) f )
  >.
  ;;


let rec value_twiddle (v : value) : value =
  match v with
  | VInt i  -> VInt (i + 1)
  | VArray vs -> VArray (List.map value_twiddle vs)
  ;;

(* Writing back to file *)
let rec write_file (v : value) : file =
  match v with
  | VInt i -> [i]
  | VArray vs -> List.length vs :: List.concat (List.map write_file vs)
  ;;


(* The whole thing *)
let file_twiddle (s : schema) : (file -> file) code =
  .<fun f ->
    let v = .~(load_file s) f in
    let v = value_twiddle v in
    write_file v
  >.;;


assert ([2; 1; 2] = !. .<.~(file_twiddle (SArray SInt)) [2; 0; 1] >.);;

(* If we inspect the code that is produced for an array of ints, the load_file ends up being very good.
However the value_twiddle and write_file don't make any use of the static information.
*)

file_twiddle (SArray SInt);;

(*
===>

fun f_299  ->
  (* LOAD_FILE *)
  let v_313 =
    (fun f_300  ->
       Pervasives.fst
         ((fun xs_301  ->
             let (x_302,xs_303) = (* CSP uncons *) xs_301 in
             let rec go_304 i_305 vs_306 xs_307 =
               match i_305 with
               | 0 -> ((Stage1schema.VArray (List.rev vs_306)), xs_307)
               | _ ->
                   let (v_308,xs_309) =
                     (fun xs_310  ->
                        let (x_311,xs_312) = (* CSP uncons *) xs_310 in
                        ((Stage1schema.VInt x_311), xs_312)) xs_307 in
                   go_304 (i_305 - 1) (v_308 :: vs_306) xs_309 in
             go_304 x_302 [] xs_303) f_300)) f_299 in
             
  (* CALLS TO ORIGINAL value_twiddle AND write_file *)
  let v_314 = (* CSP value_twiddle *) v_313 in (* CSP write_file *) v_314>.
*)

2-crazy.ml

(*
Crazy staging plus fusion by turning the values into a stream.
This works, but the code no longer really resembles the original.
We need to move a lot of the work from the load_file into the write_file.
It also only works for this simple twiddle operation; other things would be harder.
*)
open Runcode;;



(* Schema and value definitions *)
type schema
  = SInt
  | SArray of schema

type ('a, 'b) gen = ('a -> 'b * 'a) code

type 'a value_stream
  = VGInt of ('a, int) gen
  | VGArray of ('a,int) gen * 'a value_stream

type file = int list

(* Load a "file" for given schema *)

let uncons xs =
  match xs with
  | x :: xs -> x, xs
  | []      -> raise Not_found
;;

let rec load_file (s : schema) : file value_stream =
  match s with
  | SInt -> VGInt .<fun f -> uncons f >.
  | SArray s -> VGArray
    (.< fun f -> uncons f >.  , load_file_go s)
  ;;

let rec value_twiddle (v : 'a value_stream) : 'a value_stream =
  match v with
  | VGInt c -> VGInt .< fun f ->
      let v, f = .~c f in
      v + 1, f >.
  | VGArray (lenc, valc) ->
    VGArray (lenc, value_twiddle valc)
;; 

let rec write_file_go (v : 'a value_stream) : ('a -> file * 'a) code =
  match v with
  | VGInt c -> .<fun fi ->
      let v, fi = .~c fi in
      [v], fi >.
  | VGArray (lenc, valc) -> .<fun fi ->
      let len, fi = .~lenc fi in
      let rec go i fo fi = (match i with
        | 0 -> len :: fo, fi
        | _ -> let v, fi = .~(write_file_go valc) fi in
               go (i - 1) (List.append fo v) fi )
        in go len [] fi>.
;;

let write_file (v : 'a value_stream) : ('a -> file) code =
  .< fun fi -> fst ( .~(write_file_go v) fi ) >.
;; 


(* The whole thing *)
let file_twiddle (s : schema) : (file -> file) code =
  let v = load_file s in
  let v = value_twiddle v in
  write_file v
;; 

assert ([2; 1; 2] = !. .<.~(file_twiddle (SArray SInt)) [2; 0; 1] >.);;

(* This one does seem to generate nice code *)
file_twiddle (SInt);;
(*
fun fi_23  ->
  Pervasives.fst
    ((fun fi_24  ->
        let (v_25,fi_26) =
          (fun f_20  ->
             let (v_21,f_22) = (fun f_19  -> (* CSP uncons *) f_19) f_20 in
             ((v_21 + 1), f_22)) fi_24 in
        ([v_25], fi_26)) fi_23)>.
*)

file_twiddle (SArray SInt);;
(*
fun fi_32  ->
  Pervasives.fst
    ((fun fi_33  ->
        let (len_34,fi_35) = (fun f_28  -> (* CSP uncons *) f_28) fi_33 in
        let rec go_36 i_37 fo_38 fi_39 =
          match i_37 with
          | 0 -> ((len_34 :: fo_38), fi_39)
          | _ ->
              let (v_40,fi_41) =
                (fun fi_42  ->
                   let (v_43,fi_44) =
                     (fun f_29  ->
                        let (v_30,f_31) =
                          (fun f_27  -> (* CSP uncons *) f_27) f_29 in
                        ((v_30 + 1), f_31)) fi_42 in
                   ([v_43], fi_44)) fi_39 in
              go_36 (i_37 - 1) (List.append fo_38 v_40) fi_41 in
        go_36 len_34 [] fi_35) fi_32)>.
*)