functor OPTBLOCKTOCODE(
     structure C : CodeSig 
     structure B : BlockSig
     structure S : 
        sig type Graph
            type Vertex
            val topSort : Graph -> Vertex list
        end 
     structure D : DictSig
     sharing type S.Graph  = B.Block
         and type S.Vertex = B.Expn = D.Key
         and type D.Item = string
     ): BlockToCodeSig
=
struct
structure C = C
structure B = B
exception BlockError

datatype Avail = A of (string list * int)

fun getvar (A (h :: t, n)) = (h, A(t,n))
  | getvar (A ([], n))     = ("_"^Prelude.stringOfInt n, A([],n+1))

fun putvar x (A(vs, n)) = A(x :: vs, n)

fun remove k' [] = []
  | remove k' ((k,e) :: d) = if k = k' then d else (k,e) :: remove k' d

fun enter ((k,e),d) = (k,e) :: remove k d
exception Lookup
fun lookup [] _ = raise Lookup 
  | lookup ((k,e):: d) k' = if k = k' then e else lookup d k'

fun reserved e [] = false
  | reserved e ((k,e')::t) = e = e' orelse reserved e t

fun dictblock [] = (A([], 0),[])
  | dictblock ((s,e) :: b) = 
    let val (tmp, dict) = dictblock b
        val (de, tmp')  = getvar tmp
     in (tmp', enter((e, de), dict)) end

local open C
in
fun blockToCode (B.Block b) = 
    let (* find an appropriate destination for the value of e  *)
        fun v e tmp dict = (Id (lookup dict e), tmp, dict) 
                          (* stick with previous decisions *)
            handle Lookup => 
            case e of B.Lit n => (Lit n, tmp, dict)
            | B.Id x => (Id x, tmp, dict)
            | _ => let val (dx, tmp') = getvar tmp
                    in (Id dx, tmp', enter((e, dx), dict)) end
        (* keep track of the unused variables        , tmp  *)
        (* any expressions that are already planned  , dict *)
        (* the code generated so far                 , code *)
        fun mkCode (tmp, dict, code) (e :: t) = 
        (case e of 
             B.Lit _ => mkCode (tmp, dict, code) t
           | B.Id  x => let val (Id de, tmpe, dicte) = v e tmp dict   
                            val tmp' = putvar x tmpe
                        in if de = x then mkCode(tmpe, dicte, code) t
                           else (de := V(Id x)) :: mkCode (tmp', dicte, code) t
                        end
           | _       =>
            let val (Id dest, tmpe, dicte) = v e tmp dict                            
                fun binop (x,y) opn =
                    let val tmp' = putvar dest tmpe
                        val (dx, tmpx, dictx) = v x tmp' dicte
                        val (dy, tmpy, dicty) = v y tmpx dictx
                    in
                    mkCode (tmpy, dicty, (dest := opn(dx, dy)) :: code) t
                    end
            in case e of
               B.*** (x,y) => binop (x,y) op ***
             | B.+++ (x,y) => binop (x,y) op +++
             | B.--- (x,y) => binop (x,y) op ---
             | B./// (x,y) => binop (x,y) op ///
             | _           => raise BlockError
            end
       )
       (* once we've generated code for all the expressions we check all the *)
       (* normal variables that should be given values by this block and add *)
       (* extra assignments if necessary (this will be needed if literals    *)
       (* are assigned to variables, or if two or more variables are given   *)
       (* the same value by a block)                                         *)
          | mkCode (tmp, dict, code) []       = 
            let fun addCode code []           = code
                  | addCode code ((x,e) :: t) = 
                    addCode
                    ( case e of B.Lit n => code @ [x := V(Lit n)]
                                | _     => let val reg = lookup dict e
                                           in if reg = x then code
                                              else code @ [x := V(Id reg)]
                                           end handle Lookup  => raise BlockError
                    )t 
             in
                addCode code b
            end
        val (tmp, dict) = dictblock b
     in   
        Code(mkCode (tmp, dict, []) (S.topSort (B.Block b)))
     end
 
end
end