fixed bug in prepareStackForAbsOpt (rtemgr.c).

[bugg-scheme-compiler.git] / src / sml / pseudo-gene.sml

(* ******************************************************************* Pseudo *)
(* pseudocode abstraction for our architecture *)
structure Pseudo = struct

(* int to C string, handles negative numbers *)
fun Int_toCString i = if i>=0 then Int.toString i else "-" ^ (Int.toString (~i))

(* code and data labels are just strings: *)
type clabel = string (* code label is a goto target *)
type dlabel = string (* data label is a global variable of function *)

(* processor registers: three special purpose registers and some general ones *)
structure R = struct

datatype t = BP          (* stack base *)
           | SP          (* stack pointer *)
           | RET         (* return value of every expression *)
           | REG of int  (* one of a few general purpose registers, numbered from 0 *)

fun toString BP = "fp"
  | toString SP = "sp"
  | toString RET = "r_res"
  | toString (REG i) = "r["^(Int.toString i)^"]" 

end

(* addresses (places): different addressing modes *)
structure A = struct

datatype t = Lbl of dlabel  (* address of the data the label points to *)
           | Reg of R.t     (* a register *)
           | Ind of t       (* address referenced by place *)
           | Ofs of (t*int) (* offset from address referenced by place *)

fun toString (Lbl l) = l (* global variables are pointers *)
  | toString (Reg r) = R.toString r
  | toString (Ind a) = "*(void**)" ^ (toString a)
  | toString (Ofs (a,i)) = "*((void**)" ^ (toString a) ^ " + " ^ (Int_toCString i) ^ ")"

end 

(* value is
 - a place's value,
 - a place's address, 
 - or a constant *)
structure V = struct

datatype t = Val of A.t       (* address of the place *)
           | Adr of A.t       (* value in the place *)
           | Cst of int       (* constant *)
           | ConstStr of string (* constant string *)

fun toString (Val a) = A.toString a
  | toString (Adr a) = "(void*)&" ^ (A.toString a)
  | toString (Cst i) = Int_toCString i
  | toString (ConstStr s) = "\""^s^"\""

end

(* instructions: be very CISCy, allow all places to be targets *)
structure I = struct

datatype t = Move of A.t*V.t          (* move value to place *)
           | Push of V.t              (* push value onto stack *)
           | Pop of A.t               (* pop from stack to place *)
           | Label of clabel          (* put a code label *)
           | Goto of clabel           (* goto code label *)
           | Goif of V.t*clabel       (* go if value if not true *)
           | Call of clabel*clabel    (* call function (first, return is second) *)
           | Ret                      (* return from function *)
           | Add of A.t*V.t           (* add value to place *)
           | Sub of A.t*V.t           (* subtract value from place *)
           | Mul of A.t*V.t           (* multiply place by value *)
           | Div of A.t*V.t           (* divide place by value *)
           | Ccall of string * V.t list (* call a C function, an analogue of a system call *)
           | Cfunc of A.t * string * V.t list
           | Comment of string        (* comment *)
           | Pass                     (* do nothing, for labeling *)

fun seq insts = String.concatWith "\n" (List.map indent insts) (* serialize a sequence of instructions *)

(* indent instructions by a tab *)
and indent (i as (Label _)) = toString i  (* but outdent labels *)
  | indent i = "\t" ^ (toString i)

(* convert an instruction to a piece of C code, the final newline is omitted and added in seq *)
and toString (Move (a,v)) = (A.toString a) ^ " = " ^ (V.toString v) ^ ";"
(*
  | toString (Push v) = seq [Move (A.Reg R.SP, V.Adr (A.Ofs (A.Reg R.SP, ~1))),
                                         Move (A.Ind (A.Reg R.SP), v)]
  | toString (Pop a) = seq [Move (a, V.Val (A.Ind (A.Reg R.SP))),
                            Move (A.Reg R.SP, V.Adr (A.Ofs (A.Reg R.SP, 1)))]
*)
  | toString (Push v) = toString (Ccall ("push",[v]))
  | toString (Pop a) = toString (Ccall ("pop",[V.Adr a]))
  | toString (Label l) = l ^ ":"
  | toString (Goto l) = "goto " ^ l ^ ";"
  | toString (Goif (v,l)) = "if (" ^ (V.toString v) ^ ") goto " ^ l ^ ";"
  | toString (Add (a,v)) = (A.toString a) ^ " += " ^ (V.toString v) ^ ";"
  | toString (Sub (a,v)) = (A.toString a) ^ " -= " ^ (V.toString v) ^ ";"
  | toString (Mul (a,v)) = (A.toString a) ^ " *= " ^ (V.toString v) ^ ";"
  | toString (Div (a,v)) = (A.toString a) ^ " /= " ^ (V.toString v) ^ ";"
  | toString (Ccall (f,vs)) = f ^ "(" ^
                              (String.concatWith "," (List.map V.toString vs)) ^
                              ");"
  | toString (Cfunc (a,f,vs)) = (A.toString a) ^ " = " ^ f ^ "(" ^
                              (String.concatWith "," (List.map V.toString vs)) ^
                              ");"
  | toString (Comment s) = "// " ^ s
  | toString Pass = ";"
end

(* boots the pseudo-processor: allocates registers and stack
fun boot (nregs, stacksize) =
    "struct {int bp, sp, ret, reg[" ^ (Int.toString nregs) ^ "];\n" ^
    "        int stack[" ^ (Int.toString stacksize) ^ "]; } a;\n" ^
    "\n" ^
    "void boot() {\n" ^
    "  a.bp = (int)(a.stack+" ^ (Int.toString stacksize) ^ ");\n" ^
    "  a.sp = a.bp;\n" ^
    "}\n"
*)

fun mkInitArchitecture(nregs,stacksize) =
    "initArchitecture("^Int.toString(nregs)^","^Int.toString(stacksize)^");\n";

end

(* ******************************************************************** Gene *)

structure Gene: sig

    val reset: unit -> unit
    val add: Expr -> unit
    val emit: (int*int) -> string

end = struct (* code generation *)

open Reader
open TagParser
open Pseudo


structure Free: sig
    val add: string -> string
    val emit: unit -> string
    val reset: unit -> unit
end = struct

    val (freevars: (string*string) list ref) = ref []

    (* add a new free variable, or use an existing one *)
    fun add varname = 
        case List.find (fn vn=>(#1 vn)=varname) (!freevars)
        of SOME (v,n) => n
        | NONE => 
        let
            (* val name = new_name ("sv_" ^ varname) *)
            val name = varname
        in
            freevars := (varname, name) :: (!freevars)
          ; name
        end

    (* fun emit_free (v,n) = "void* " ^ n ^ " = (void* )&sc_undef;\n" *)
    fun emit_free (v,n) = ""

    (* all free variables initially equal (int)&sc_undef *)
    fun emit () = String.concat (map emit_free (List.rev (!freevars)))

    fun reset () = freevars := []

end (* struct *)




val initial_code = []
val (code: I.t list ref) = ref initial_code

local
    (* add single instr to the code *)
    fun % i = code := i :: (!code)
in
    (* add expression's code to the code list *) 
    fun add (Const sexpr) = (* value is address of constant *)
            let val cname = Const.add(sexpr)
            in % (I.Move ((A.Reg R.RET), V.Adr (A.Lbl cname))) end
      | add (Var _) = raise Match (* can't be here, must have been resolved earlier *)
      | add (VarFree name) = (* value is variable *)
            let val vname = Free.add(name)
            in (
                (* % (I.Move ((A.Reg R.RET), V.Val (A.Lbl vname))) *)
                % (I.Cfunc ((A.Reg R.RET), "probeSymbolDefined", [V.ConstStr vname, V.Val (A.Lbl "topLevel")]))
                (* add: check if defined or not *)
               ;% (I.Move ((A.Reg R.RET), V.Val (A.Lbl "((SymbolEntry*)r_res)->sob")))
               )
            end
      | add (If (i, t, e)) =
            let val then_label = new_name "THEN"
            val else_label = new_name "ELSE"
            val fi_label = new_name "ENDIF"
            in
                add i
              ; % (I.Sub ((A.Reg R.RET), V.Adr (A.Lbl (Const.add (Bool false)))))  (* difference between value and #f *)
              ; % (I.Goif (V.Val (A.Reg R.RET), then_label))                       (* if different, goto the true branch *)
              ; % (I.Goto else_label)                                              (* otherwise, goto the false branch *)
              ; % (I.Label then_label)                           (* the true branch *)
              ; add t
              ; % (I.Goto fi_label)
              ; % (I.Label else_label)                           (* the false branch *)
              ; add e
              ; % (I.Label fi_label)
            end
      | add _ = ()
end (* local *)

(* Adds the free variables for the built-in procedures. The variables
   themselves are initialized in initBuiltins() *)
fun addBuiltinsFreeVars() =
    (map (fn(n)=>Free.add n)
         ["apply", "binary-add", "binary-div", "binary<?",
          "binary-mul", "binary=?", "binary-sub",
          "boolean?", "car", "cdr", "char?", "char->integer",
          "cons", "eq?", "integer->char",
          "make-string", "make-vector", "null?", "number?",
          "pair?", "procedure?", "remainder", "set-car!",
          "set-cdr!", "string-length", "string-ref", "string?",
          "string-set!", "vector-length",
          "vector-ref", "vector?", "vector-set!", "zero?"]
    ;());

fun mkInitBuiltins() = "initBuiltins();";

fun emit (nregs, stacksize) =
   (addBuiltinsFreeVars();
    "\n/* COMP091 Scheme->C Compiler Generated Code */\n\n" ^
    "#include \"scheme.h\"\n" ^
    "#include \"assertions.h\"\n" ^
    "#include \"arch.h\"\n" ^
    "#include \"builtins.h\"\n" ^
    "extern SymbolNode *topLevel;\n"^
    "\n/* Constants */\n" ^
    (Const.emit ()) ^
    "\n/* Free variables */\n" ^
    (Free.emit ()) ^
    "\n/* Code */\n" ^
    "void schemeCompiledFunction() {\n" ^
    "\t"^mkInitArchitecture(nregs,stacksize)^"\n" ^
    "\t"^mkInitBuiltins()^"\n" ^
    "\n" ^
    (I.seq (List.rev (!code))) ^
    "\n}\n"
   )

fun reset () =
    ( names := initial_names
    ; Const.reset ()
    ; Free.reset () 
    ; code := initial_code )

end (* struct *)