(* This module translates [UPP] into [RTL]. It relies on [Upp2rtlI] for translating expressions, conditions, and instructions. It deals with translating procedures (which involves creating the environment module required by [Upp2rtlI]) and programs. *) (* ------------------------------------------------------------------------- *) (* Translating procedures. [translate_procedure f proc] translates a procedure whose name is [f] and whose definition is [proc]. *) let translate_procedure f proc = (* Allocate a fresh universe of pseudo-registers. *) let runiverse = Register.new_universe "%" in (* Allocate a reference that will hold the set of all pseudo-registers in use. *) let locals = ref Register.Set.empty in (* Define a function that allocates a fresh pseudo-register, adds it to the set of pseudo-registers in use, and returns it. *) let allocate () = let register = Register.fresh runiverse in locals := Register.Set.add register !locals; register in (* Create an environment that maps the formal parameters, the result variable, and the local variables to fresh pseudo-registers. *) let env, formals = List.fold_right (fun formal (env, formals) -> let register = allocate() in StringMap.add formal register env, register :: formals ) proc.UPP.formals (StringMap.empty, []) in let env, result = if proc.UPP.result then let register = allocate() in StringMap.add f register env, Some register else env, None in let env = StringSet.fold (fun local env -> let register = allocate() in StringMap.add local register env ) proc.UPP.locals env in (* Define a function that looks up a variable in this environment. *) let lookup x = try StringMap.find x env with Not_found -> assert false in (* Allocate a fresh universe of control flow graph labels. *) let luniverse = Label.new_universe f in (* Allocate a reference that will hold the control flow graph, represented as a mapping of labels to instructions. Define a function that adds an instruction at a fresh label to the control flow graph. *) let graph, generate = Label.Map.generator luniverse in (* Define a function that adds an [IGoto] instruction at a fresh label [label] to the control flow graph. The construction is recursive, in the sense that the target label of the branch instruction is provided by a computation that is allowed to use [label] itself. This allows creating cycles in the control flow graph. The definition of this function is made somewhat subtle by the fact that the [subgraph] function is allowed to alter the graph. Thus, the definition of [t] cannot be inlined into the next line. *) let loop (subgraph : Label.t -> Label.t) : Label.t = let exit = Label.fresh luniverse in let entry = subgraph exit in graph := Label.Map.add exit (RTL.IGoto entry) !graph; entry in (* Allocate a graph label that stands for the procedure's exit point. No instruction is associated to it. *) let exit = Label.fresh luniverse in (* Define a function that allows recognizing the exit label. This is used to determine which instructions are in tail position. *) let is_exit label = Label.equal exit label in (* We are now ready to instantiate the functor that deals with the translation of expressions, conditions, and instructions. The reason why we make this a separate functor is purely pedagogical. Smaller modules are easier to understand. *) let module I = Upp2rtlI.Make (struct let lookup = lookup let allocate = allocate let generate = generate let loop = loop let is_exit = is_exit let result = if proc.UPP.result then Some f else None end) in (* Translate the procedure's body. This yields the control flow graph's entry label. *) let entry = I.translate_instruction proc.UPP.body exit in (* This sums it up. *) { RTL.formals = formals; RTL.result = result; RTL.runiverse = runiverse; RTL.locals = !locals; RTL.luniverse = luniverse; RTL.entry = entry; RTL.exit = exit; RTL.graph = !graph } (* ------------------------------------------------------------------------- *) (* Translating programs. *) let translate_program (p : UPP.program) : RTL.program = { RTL.globals = p.UPP.globals; RTL.defs = StringMap.mapi translate_procedure p.UPP.defs }