(*
From Robin Popplestone Fri Mar  5 15:37:35 EST 1999
To: sheard@cse.ogi.edu
Tim - to section 7 is (mostly) ok and commented. Later sections are work in
progress. Environments no longer have a time-stamp. That would be necessary
for a semantics of Par if we had it as a kind of statement.
*)


(*minilang.ml       Robin Popplestone & Tim Sheard MAR 99 *)

(*


         CONTENTS - (Use <ENTER> g to access required sections)

 -- 1 Setting up some standard capabilities.
 -- 1.1 (lookup x fmap) looks up a value in a finite map
 -- 1.2 (update var fmap val) gives var a new value
 -- 1.3 (merge fmap1 fmap2) -helps merge environments
 -- 2 Variables and field-names
 -- 3 The Types of Minilang
 -- 4 The values of the language
 -- 5 Expressions are immutable
 -- 6 Statements are Mutable
 -- 7 Declarations
 -- 8 Environments hold the value of variables; also "it"
 -- 8.1 (declare xs env) makes a new environment with variables xs declared
 -- 9 Machines have state

-- 1 Setting up some standard capabilities. ---------------------------
*)

load NJCompat.ml;          (* make POPLOG SML compatible with New Joisey *)

datatype 'a option = NONE | SOME of 'a;


type ('a,'b) finite_map = ('a*'b)list;

exception Lookup;

(* we also need this basic data-type to mark the passage of time *)

datatype time = T of int;

fun later (T t1) (T t2) = t1>t2;

fun tick (T t) = T(t+1);
(*
-- 1.1 (lookup x fmap) looks up a value in a finite map ---------------
*)


fun lookup s ((a,b)::alist)
    = if s=a then b else lookup s alist
|   lookup s [] = raise Lookup
;



(*
-- 1.2 (update var fmap val) gives a variable a new value
*)

fun
   update less s1 [] v1 = [(s1, v1)]
|  update less s1 (alist as ((s2,v2)::alist1)) v1
    = if s1=s2 then (s1,v1)::alist1
      else
         if less(s1,s2) then
              (s1,v1) :: alist
         else
         (s2,v2) :: update less s1 alist v1;


(*
-- 1.2 (update_ts var fmap val) gives a location a new time-stamped value
*)

fun
   update_ts (s1:int) [] v1 = [(s1, (v1,T 1))]
|  update_ts s1 (alist as ((s2,(v2,T i2))::alist1)) v1
    = if s1=s2 then (s1,(v1,T(i2+1)))::alist1
      else
         if s1<s2 then
              (s1,(v1,T 1)) :: alist
         else
         (s2,(v2,T i2)) :: update_ts s1 alist v1;

(*
-- 1.3 (merge fmap1 fmap2) -helps merge environments-------------------
*)

fun merge [] (alist2: (int,'a*time)finite_map) = alist2
|   merge alist1 [] = alist1
|   merge (alist1 as (s1,(v1,t1))::alist3)
          (alist2 as (s2,(v2,t2))::alist4) =
    if s1 < s2 then (s1,(v1,t1)):: (merge alist3 alist2)
    else
    if s1 = s2 then
        (if later t1 t2 then (s1,(v1,t1))::(merge alist3 alist4)
        else  (s2,(v2,t2))::(merge alist3 alist4))
    else
        (s2,(v2,t2)) :: (merge alist1 alist4)
;





(*
-- 2 Variables and field-names ---------------------------------------
*)

type variable = string;
type field = string;



(*
-- 3 The Types of Minilang ----------------------------------------------

The types of minilang are as follows *)

datatype typ =
    SInt of int                       (* signed integer, width n bits   *)
|   UInt of int                       (* unsigned integer, width n bits *)
|   Float32                           (* 32 bit floating point IEEE 754 *)
|   Float64                           (* 64 bit floating point IEEE 754 *)
|   Char
|   Boolean
|   Pointer of typ                   (* pointer to object of given type *)
|   Array of int*typ
|   Struct of  (field*typ) list
|   Union  of  (field*typ) list
|   Function of (typ list) * typ
|   Action of typ
|   Void
;

(*
-- 4 The values of the language ---------------------------------------
These are the values with which we compute *)

(* The operators of our language will normally be realisable by a
single machine-code instruction. In the expression language
we apply an operator to arguments in the manner of Scheme,
or ML for that matter *)

datatype operator =
    Plus | Minus | Times | Divide | BWAnd | BWOr | LogAnd | LogOr;



datatype value =
    SI of int * int    (* SI(n,w) is a signed-integer, value n, width w *)
  | UI of int * int    (* UI(n,w) is an unsigned-integer  *)
  | FF32 of real       (* value of type Float32           *)
  | FF64 of real       (* value of type Float64           *)
  | BB of bool         (* boolean value                   *)
  | Loc of int         (* an address of a memory location *)
  | NoVal;             (* the undefined value             *)

fun max (x:int) y = if x>y then x else y;

exception Compute;



fun add_val (SI(i1,w1)) (SI(i2,w2))  = SI(i1+i2,max w1 w2)
|   add_val (UI(i1,w1)) (UI(i2,w2))  = UI(i1+i2,max w1 w2)
|   add_val (FF32(x))   (FF32(y))    = FF32(x+y)
|   add_val (FF64(x))   (FF64(y))    = FF64(x+y)
|   add_val _            _           = raise Compute;


fun sub_val (SI(i1,w1)) (SI(i2,w2))  = SI(i1-i2,max w1 w2)
|   sub_val (UI(i1,w1)) (UI(i2,w2))  = UI(i1-i2,max w1 w2)
|   sub_val (FF32(x))   (FF32(y))    = FF32(x-y)
|   sub_val (FF64(x))   (FF64(y))    = FF64(x-y)
|   sub_val _            _           = raise Compute;

(* more work to be done here *)
fun
    compute_vals Plus [SI(i1,w1),SI(i2,w2)] = SI(i1+i2,max w1 w2)
|   compute_vals Plus [UI(i1,w1),UI(i2,w2)] = UI(i1+i2,max w1 w2)
|   compute_vals Plus [FF32(x),FF32(y)]     = FF32(x+y)
|   compute_vals Plus [FF64(x),FF64(y)]     = FF64(x+y)
|   compute_vals LogAnd [BB(b1),BB(b2)]     = BB(b1 andalso b2)

;


(*
-- 5 Expressions are immutable ----------------------------------------
*)

(* An expression always has a fixed denotation within the scope of the
variables occurring in it.
*)

datatype expr =
    V    of variable                   (* an immutable variable    *)
|   L    of value                      (* a literal                *)
|   Let  of variable * expr * expr     (* let var = expr1 in expr2 *)
|   Ap   of expr*expr list             (* function application     *)
|   Cond of expr*expr*expr
|   Op   of operator
;

(*
-- 6 Statements are Mutable -------------------------------------------
*)

datatype stmt =
    Assign  of lhs * stmt
|   Block   of (variable * typ) list * stmt
|   Call    of variable * (stmt list)
|   Deref   of stmt
|   If      of stmt * stmt * stmt
|   OpS     of operator
|   Pure    of expr
|   Seq     of (variable option)* stmt * stmt
|   VS      of variable                            (* a mutable variable*)
|   While   of stmt * stmt
|   Addr    of lhs
(* |   Par     of stmt*stmt ?? ... *)

and
    lhs =
           LV of variable
|          LDeref of stmt
|          LDot of lhs * field;

(*
-- 7 Declarations -----------------------------------------------------
*)

datatype decl =
    VarDec of variable*typ
|   FunDec of variable*(variable*typ)list*expr
|   ActDec of variable*(variable*typ)list*stmt
|   TypeDec of variable*typ


datatype program =
    Prog of decl list * stmt;



(*
Environments map from variables to values etc.
*)

(*
-- 8 Environments hold the value of variables; also "it" --------------

An environment  represents the  state of  the computation.  For our  language,
which only has  identifiers as left-hand-values  we can make  use of a  simple
environment, which consists of a value, representing the value (if any) of  an
expression, together with an association  list which maps from variables  to a
(value,time) pair and a time-stamp. The int is essential to allow us to  define
the semantics of phi.

*)


datatype 'a env =
    Env of
        value                        (* the value of an expression      *)
     * (variable,'a)finite_map

;

(* here's an example of an environment *)

val env1 = Env(SI(5,8), [("x",SI(3,8))]);


(*

-- 8.1 (declare xs env) makes a new environment with variables xs declared

(declare xs env) makes a new environment with the variables in the list
xs declared and initialised to NoVal
Note that it does not handle scope of variables ..

*)

(*
fun declare [] env = env
  | declare (x::xs) (Env(v,map)) =
       declare xs (Env(v, update less_strg x map NoVal));

declare : variable list -> 'a env -> 'a env;
*)



(*
9 Evaluating an expression requires only an environment.

We will however do our staged evaluation by transforming expressions
to statements.
*)

val less_string = op < : string*string->bool;

exception Apply;
fun apply f args = raise Apply;

exception Eval;
fun
    eval_expr (V v) env                 = lookup v env
  | eval_expr (L l) env                 = l

  | eval_expr (Let(v,expr_i,expr)) env  =
          eval_expr expr (update less_string v env (eval_expr expr_i env))

  | eval_expr (Ap (Op(opr), es)) env  =
        compute_vals opr (map (fn e=>eval_expr e env) es)

  | eval_expr  (Ap(f,es))  env        =
         apply (eval_expr f env) (map (fn e=>eval_expr e env) es)

  | eval_expr   (Cond(e1,e2,e3)) env   =
        let val v1 = eval_expr e1 env
        in
            case v1 of
                BB(true) => eval_expr e2 env
            |   BB(false) => eval_expr e3 env
            |   _         =>raise Eval
        end


  | eval_expr ( Op(opr))       env         = raise Eval;
;

eval_expr (L ( SI(2,8))) [];



(*
-- 9 Machines have state ------------------------------------------------

9.1 The machine data-type provides appropriate state-transformations

So, what do we want of a machine? The single-address model is unrealistic,
'cos even the weediest processors have more than one register, and we'd like to
have the vocabulary to talk about optimisation. The stack-machine model
is easy to work with, but has an awkward translation to most real machines,
if efficiency is desired. But we don't want to be specific about a particular
architecture.

We would like the machine model to support the generation of real code.
We can think of the stack machine as providing run-time allocation of memory,
whereas a compile-time allocation is more appropriate.

But the machine as a data-type is the appropriate place to put knowledge of
specific machines.  It seems therefore that the machine must play a role
in two stages, namely the allocation of locations and in their use.
Thus if we need a location to store a value temporarily, we might call a
function bundled in a machine m

    (allocate m) (t:typ)

which would return a specification of a location (main memory or register)
in which a value of the specified type can be stored.

However, allocation is not just a function on type. For a start, a location
once allocated may not be re-allocated until it is free for storing a value.
Thus, it seems, we need the notion of a compile-time state of a machine.


    let val (l s_c1) = (allocate m) t s_c in ...

would bind  l to be a location, s_c1 to be a new compile-time state.
Is this rich enough? Well, no.

(1) In many machines, not all operations can be performed in all  locations.
The 68HC11, for example, can perform arithmetic in the A,B,D registers, and
de-referencing using the X and Y registers, with various registers as the
destination of the dereferenced entity.

(2) Which location is the best choice to hold a value depends on non-local
considerations, which may be more manifest in the original program structure
than at the level of the machine. For example, if we can identify a "hot"
variable that gets used in an inner loop, we would wish it to occupy a
register at the expense of a "cold" variable.


*)

type bidder = real->bool;
type ('loc,'cstate) allocator      = typ -> operator -> bidder -> 'cstate
                                        -> ('cstate * 'loc);
type ('loc,'state) binary_operator = 'loc -> 'loc -> 'state -> 'state;
type ('loc,'state)loader           = 'loc -> 'loc -> 'state -> 'state;
type ('loc,'state)dereferencer     = 'loc -> 'loc -> 'state -> 'state;

datatype ('loc,'cstate,'state) machine =
    Machine of
        {allocate : ('loc,'cstate)allocator,
         add      : ('loc,'state)binary_operator,
         sub      : ('loc,'state)binary_operator,
         load     : ('loc,'state)loader,
         deref    : ('loc,'state)dereferencer
        };


val less_int = op< : int*int->bool;

datatype location_0 =
   Dir_0 of int  | Imm_0 of value;
type state_0 = (int,value)finite_map;
type cstate_0 = int;

fun alloc_0 t opr b n = (n+1,Dir_0 n);

alloc_0 : (location_0,cstate_0)allocator;


fun val_loc (Dir_0 a) s = lookup a s
  | val_loc (Imm_0 v) s = v;


fun obey_0 f (Dir_0 a) l2 s =
    let val v1 = lookup a s
        val v2 = val_loc l2 s
        val v  = f v1 v2
    in
        update less_int a s v
    end;

obey_0 : (value -> value -> value) -> (location_0,state_0) binary_operator;

exception Machine_0;

fun load_0  (Dir_0 a) l s=
    update less_int a s (val_loc l s);

load_0: (location_0,state_0) loader;

fun deref_0 (Dir_0 a1) (Dir_0 a2) s =
    let val (v1:value) = lookup a1 s
    in
        case v1 of
          (Loc a) => update less_int a2 s (lookup a s)
         | _       => raise Machine_0
    end;

deref_0: (location_0,state_0) dereferencer;

val machine_0 =
    Machine {
        allocate = alloc_0,
        add      = obey_0 add_val,
        sub      = obey_0 sub_val,
        load     = load_0,
        deref    = deref_0
    }

(*
        x + 2*y  --->  x + (y<<1)

        LDA y
        ASL 1
        ADD x

      (+    x  (<<  y   1))
      acc  sto acc sto imp

(Original)     (+   (!     (+  p 2) ) (>>     y   1))
(Result in)    [D]  [XYD]  [D] s s     [D]    s   s
(Argument)          [D|s]  [XY]        [D|s]  s   s



*)


fun  allocator (Machine {allocate, ...}) = allocate;

exception Eval_stmt;


fun eval_stmt m stmt env loc state =
        case stmt of
            Call(f,args) => eval_call m (f,args) env state
and
    eval_call m (Plus,args) env state =
       let loc = (allocator m) (type_list args env) Plus b cs
       in
          (adder m)
       end


fun eval_stmt m stmt env state =
    let val alloc = allocator m
    case stmt of
      Assign(lhs,stmt1)           =>  raise Eval_stmt
(*
        let val state1 = eval_stmt m stmt1 env state
            val v      = ex state1
            val state2 = eval_lhs  m lhs   env state1
        in
            ud  state2 v
        end
*)
    | Block(decls,stmt1)          => raise Eval_stmt
    | Call(var,stmts)            => raise Eval_stmt
    | Deref(stmt1)                =>
        let val state1 = eval_stmt m stmt1 env state
        in
           dr state1
        end
    | If(stmt1,stmt2,stmt3)      => raise Eval_stmt
    | Call OpS(Plus)                  =>
            let val loc = alloc

    | Pure(expr)                 => ld (eval_expr expr env) state
    | Seq(NONE,stmt1,stmt2)      => raise Eval_stmt
    | Seq(SOME(var),stmt1,stmt2) => raise Eval_stmt
    | VS(var)                    => ld (lookup var env) state
    | While(stmt1,stmt2)         => raise Eval_stmt
    | Addr(lhs)                  => raise Eval_stmt
;



(*
The Standard State and Machine
*)

datatype state_standard =
    SS of (value*(int,value)finite_map)
 ;

exception DEREF;

fun deref_standard (SS(Loc v1,map)) = SS((lookup v1 map),map)
  | deref_standard (SS(_,_))        = raise DEREF;

val machine_standard =
    Machine(
        fn v => fn (SS(v1,map)) => SS(v,map),   (* the load operation *)
        deref_standard,
        fn SS(v,m) => v
     );

val state_0 = SS(NoVal,[]);

val eval_ms = eval_stmt machine_standard;

eval_ms (Assign(LV("x"),Pure(L(SI(34,8))))) [] state_0;

eval_ms (Pure(L(Loc 20))) [] (SS(NoVal,[]));

eval_ms (Deref (Pure(L(Loc 20)))) [] (SS(NoVal,[]));