added built in: apply.

[bugg-scheme-compiler.git] / src / sml / cg.sml

(* Code Generation *)

(* Data Segment - initialized data segment (constants) *)
structure DataSegment: sig
    val reset: unit -> unit            (* reset symbol and constant tables between code generations *)
    val add: Sexpr -> string           (* register a new constant *)
    val emit: unit -> string           (* emit code for all constants *)
    val symbols: (string*string) list  (* fetch all constant symbols *)
end = struct
    (* new_name - generate unique names *)
    val initial_names =
        ["a", "boot",
        "sc_undef", "sc_void", "sc_nil", "sc_false_data", "sc_true_data"]
    val (names:string list ref) = ref initial_names

    local
        fun is_new name = not (List.exists (fn n => n=name) (!names)) (* allocate new distinct name *)
        fun add name = names := name :: !names                        (* add names to the table of existing ones *)
    in
        (* if the name is not in the table, register and return it,
        otherwise, add an increasing number to it until a distinct name is found *)
        fun new_name name =
            if is_new name then
            ( add name
            ; name )
            else
            let fun subname name i =
                let val name' = name ^ (Int.toString i)
                in if is_new name' then
                    ( add name'
                    ; name' )
                else
                    subname name (i + 1) end
            in subname name 0 end
    end; (* local *)

    (* list of constants *)
    val consts = ref [] : (string*Sexpr) list ref;

    (* convert the collected consts to global variables in C *)

    (* table of symbol names and representations;
    used to
        - maintain a single representation for all occurences of a symbol
        - register symbols in run-time symbol table for symbol->string and string->symbol *)
    val (symbols: (string*string) list ref) = ref []

    (* return existing name for singletons, otherwise generate a new one;
    the singletons are hardcoded once and forever, so that they are eq? comparable *)
    fun const_name (x) =
        case x of
        Void => "sc_void"
        | Nil => "sc_nil"
        | Bool false => "sc_false"
        | Bool true => "sc_true"
        | Symbol s => (* symbols must be eq? comparable *)
        (case List.find (fn sc => (#1 sc)=s) (!symbols)
            of SOME sc => #2 sc
             | NONE => let val name = new_name ("sc_symbol")
                in symbols := (s, name) :: (!symbols);
                   name
                end)
        | _ => (* anything else is just new constant every time *)
        (new_name (case x 
                of (Pair _) => "sc_pair"
                | (Vector _) => "sc_vector"
                | (String _) => "sc_string"
                | (Number _) => "sc_number"
                | (Char _) => "sc_char"))

    (* generate code for a single constant:
        data definition
    followed by
        constant definition - a value of SchemeObject type *)

    fun const_code (name, scheme_type, data_name, data_variant, data_value) =
        "SchemeObjectData " ^ data_name ^ " = {" ^ "." ^ data_variant ^ " = {" ^ data_value ^ "}};\n" ^
        "SchemeObject " ^ name ^ " = {" ^ scheme_type ^ ", &" ^ data_name ^ "};\n"

    (* symbol representation is written once for every symbol *)

    val (written_symbols: string list ref) = ref []

    fun emit_const (name, value) = 
        case value
        of Pair (a,d) => emit_pair (name, a, d)
        | Vector es => emit_vector (name, es)
        | Symbol s => (* the same symbol may appear several times, but must be emitted only once *)
        if (List.exists (fn n=>n=name) (!written_symbols))
        then ""
        else ( written_symbols := name :: (!written_symbols)
            ; emit_symbol (name, s) )
        | String s => emit_string (name, s)
        | Number i => emit_number (name, i)
        | Char c => emit_char (name, c)
        | _ => "" (* singletons *)

    and emit_pair (name, a, d) = 
        let
            val a_name = const_name (a)
            val d_name = const_name (d)
            val data_name = new_name (name ^ "_data")
            (* recusrively define car and cdr *)
            val a_code = emit_const (a_name, a)
            val d_code = emit_const (d_name, d)
        in (a_code ^ d_code ^ (const_code (name, "SCHEME_PAIR", data_name,
                                "spd", "&" ^ a_name ^ ", &" ^ d_name))) end

    (* generates names and statements for a list of constants.
       returns a list of names and a (matching) list of statements *)
    and sexprs_to_stmts [] names stmts = (names,stmts)
      | sexprs_to_stmts (em :: rest) names stmts =
        let val name = const_name em        (* generate name *)
            val stmt = emit_const (name,em) (* generate code *)
        in
            sexprs_to_stmts rest (names @ [name]) (stmts @ [stmt])
        end

    and emit_vector (name, es) =
        let
            (* generate names and statements for the vector elements *)
            val (em_names,em_stmts) = sexprs_to_stmts es [] []
            (* generate name,statement for the array that holds the elements *)
            val arr_name = new_name (name^"_arr")
            val arr_stmt = "SchemeObject* "^arr_name^"[] = {&"^
                           (String.concatWith ", &" em_names)^"};\n"
            val data_name = new_name (name^"_data")
        in
            (String.concat em_stmts)^
            arr_stmt^
            const_code (name, "SCHEME_VECTOR", data_name, "svd",
                (Int.toString (List.length es))^", "^arr_name)
        end

    and emit_symbol (name, s) =
        let val data_name = new_name (name ^ "_data")
            val syment_name = new_name (name ^ "_syment")
        in ("SymbolEntry "^syment_name^" = {\""^(String.toCString s)^"\",0,NULL};\n"^
            const_code (name, "SCHEME_SYMBOL", data_name, "smd",
                "&"^syment_name))
        end

    and emit_string (name, s) =
        let val data_name = new_name (name ^ "_data")
        in (const_code (name, "SCHEME_STRING", data_name, "ssd",
                (Int.toString (String.size s))^", \""^(String.toCString s)^"\""))
        end

    and emit_number (name, i) =
        let val data_name = new_name (name ^ "_data")
        in (const_code (name, "SCHEME_INT", data_name, "sid",
                "(int)" ^ (if i<0 then "-"^(Int.toString (~i))
                                  else (Int.toString i))))
        end

    and emit_char (name, c) =
        let val data_name = new_name (name ^ "_data")
        in (const_code (name, "SCHEME_CHAR", data_name,
                "scd", "(char)" ^ (Int.toString (Char.ord c)))) end

    fun reset () =
        ( consts := []
        ; symbols := []
        ; written_symbols := [] )

    fun add x =
        let val name = const_name x
        in consts := (name, x) :: (!consts) (* repeated symbols are detected in emit_const *)
        ; name end

    fun emit () = 
        "SchemeObject sc_undef = {-1, NULL};\n" ^
        "SchemeObject sc_void = {SCHEME_VOID, NULL};\n" ^
        "SchemeObject sc_nil = {SCHEME_NIL, NULL};\n" ^
        "SchemeObjectData sc_false_data = {.sbd = {0}};\n" ^
        "SchemeObject sc_false = {SCHEME_BOOL, &sc_false_data};\n" ^
        "SchemeObjectData sc_true_data = {.sbd = {1}};\n" ^
        "SchemeObject sc_true = {SCHEME_BOOL, &sc_true_data};\n" ^
        String.concat (map emit_const (List.rev (!consts)))

    (* freeze the symbols *)
    val symbols = !symbols

end; (* DataSegment *)

structure ErrType = struct
    datatype Type =
        None
        | ArgsCount of string * int
        | AppNonProc
        | NotAPair
        | UndefinedSymbol of string;

    fun toString None = "\"\""
        | toString (ArgsCount (proc,formals)) = "MSG_ERR_ARGCOUNT(\""^
                                                (String.toCString proc)^"\","^
                                                (intToCString formals)^")"
        | toString AppNonProc = "MSG_ERR_APPNONPROC"
        | toString NotAPair = "MSG_ERR_NOTPAIR"
        | toString (UndefinedSymbol name) = "\"Symbol "^(String.toCString name)^" not defined\""
end;

structure CodeSegment (* : sig
    val ErrType;
    type StatementType;
    val reset : unit -> unit;
    val add : StatementType -> unit;
    val emit : unit -> string;
end *) = struct
    datatype StatementType =
        Comment of string
      | Debug of string
      | Label of string
      | Assertion of string * ErrType.Type
      | Error of ErrType.Type
      | ErrorIf of string * ErrType.Type
      | Branch of string
      | BranchIf of string * string
      | Set of string * string
      | Push of string
      | Pop of string
      | Return
      | Statement of string;

    fun statementToString (Statement stmt) = "\t"^stmt^";"
      | statementToString (Set (n,v)) = "\t"^n^" = "^v^";"
      | statementToString (Branch l) = "\tgoto "^l^";"
      | statementToString (BranchIf (c,l)) = "\tif ("^c^") goto "^l^";"
      | statementToString (Comment s) = "\t/* "^s^" */"
      | statementToString (Debug s) = "" (* "\tfprintf(stderr,\"DEBUG: "^(String.toCString s)^"\\n\");" *)
      | statementToString (Label s) = s^":"
      | statementToString (Assertion (p,e)) = "\tASSERT_ALWAYS("^p^","^(ErrType.toString e)^");"
      | statementToString (Error e) = "\tfprintf(stderr,"^(ErrType.toString e)^"); exit(-1);"
      | statementToString (ErrorIf (p,e)) = "\tif ("^p^") {fprintf(stderr,"^(ErrType.toString e)^"); fprintf(stderr,\"%s %d\\n\",__FILE__,__LINE__); exit(-1);}"
      | statementToString (Push s) = "\tpush("^s^");"
      | statementToString (Pop s) = "\t"^s^" = pop();"
      | statementToString Return = "\tRETURN();"
    ;

    val statements = ref [] : StatementType list ref;

    fun reset () =
        statements := [];

    fun add stmt = statements := !statements @ [stmt];

    fun emit () =
        ""^
        (String.concatWith "\n" (List.map statementToString (!statements)))^
        "\n\t;";

end; (* CodeSegment *)

structure Program: sig
    val reset : unit -> unit;
    val gen : Expr -> int -> unit;
    val emit : int * int -> string;
end = struct

    fun makeLabeler prefix =
        let
            val number = ref 0;
        in
            fn () => (number:= !number + 1
                     ;prefix^(Int.toString (!number)))
        end;

    val makeLabelElse = makeLabeler "else";
    val makeLabelEndif = makeLabeler "endIf";
    val makeLabelEndOr = makeLabeler "endOr";
    val makeLabelSkipBody = makeLabeler "skipBody";
    val makeLabelBody = makeLabeler "body";
    val makeLabelRet = makeLabeler "ret";
    val makeLabelApp = makeLabeler "app";

    val CSadd = CodeSegment.add;

    fun addProlog () =
        (CSadd (CodeSegment.Comment "<push an initial activation frame>")
        ;CSadd (CodeSegment.Comment "no arguments")
        ;CSadd (CodeSegment.Push "0")
        ;CSadd (CodeSegment.Comment "no enviroment")
        ;CSadd (CodeSegment.Push "(int)NULL")
        ;CSadd (CodeSegment.Comment "no return address (yet. will be set later)")
        ;CSadd (CodeSegment.Push "(int)NULL")
        ;CSadd (CodeSegment.Push "fp")
        ;CSadd (CodeSegment.Set ("fp","sp"))
        ;CSadd (CodeSegment.Comment "</push an initial activation frame>")
        );

    fun addEpilog () =
        (CSadd (CodeSegment.Comment "<pop the initial activation frame>")
        ;CSadd (CodeSegment.Pop "fp")
        ;CSadd (CodeSegment.Comment "</pop the initial activation frame>")
        );

    fun reset () =
        (DataSegment.reset ()
        ;CodeSegment.reset ()
        ;addProlog ()
        );

    fun maprtl f l = map f (List.rev l);

    fun genDebug (App (VarFree name,_))   = CSadd (CodeSegment.Debug ("Applying free-var "^name))
      | genDebug (AppTP (VarFree name,_)) = CSadd (CodeSegment.Debug ("Applying free-var "^name))
      | genDebug (App (VarParam (name,_),_))   = CSadd (CodeSegment.Debug ("Applying param "^name))
      | genDebug (AppTP (VarParam (name,_),_)) = CSadd (CodeSegment.Debug ("Applying param "^name))
      | genDebug (App (VarBound (name,_,_),_))   = CSadd (CodeSegment.Debug ("Applying bound-var "^name))
      | genDebug (AppTP (VarBound (name,_,_),_)) = CSadd (CodeSegment.Debug ("Applying bound-var "^name))
      | genDebug _ = ()
    ;

    (* Generate code for a given expression
       THE INVARIANT:      r_res contains the value of the
                             expression after execution
    *)
    fun genExpr (Const se) absDepth =
        let
            val lblConst = DataSegment.add se
        in
            CSadd (CodeSegment.Set ("r_res","(int)&"^lblConst))
        end
      | genExpr (Var _)         absDepth = raise Match (* shouldn't be here *)
      | genExpr (VarFree name)  absDepth =
        let
            val lblElse = makeLabelElse ()
            val lblEndif = makeLabelEndif ()
        in (* probe for symbol in runtime data-structure *)
            (CSadd (CodeSegment.Set ("r_res","(int)probeSymbolDefined(\""^name^"\",topLevel)"))
            ;CSadd (CodeSegment.BranchIf ("r_res==0",lblElse))
            ;CSadd (CodeSegment.BranchIf ("! ((SymbolEntry*)r_res)->isDefined",lblElse))
            ;CSadd (CodeSegment.Set ("r_res","(int)((SymbolEntry*)r_res)->sob"))
            ;CSadd (CodeSegment.Branch lblEndif)
            ;CSadd (CodeSegment.Label lblElse)
            ;CSadd (CodeSegment.Error (ErrType.UndefinedSymbol name))
            ;CSadd (CodeSegment.Label lblEndif)
            )
        end
      | genExpr (VarParam (name,ndx))         absDepth =
        (CSadd (CodeSegment.Assertion ("("^(intToCString ndx)^">=0) & ("^(intToCString ndx)^"<ST_ARG_COUNT())",ErrType.None))
        ;CSadd (CodeSegment.Set ("r_res",("ST_ARG("^(intToCString ndx)^")")))
        )
      | genExpr (VarBound (name,major,minor)) absDepth =
        CSadd (CodeSegment.Set ("r_res",("((int**)ST_ENV())["^(intToCString major)^"]["^(intToCString minor)^"]")))
      | genExpr (If (test,dit,dif))           absDepth =
        let
            val lblElse = makeLabelElse ()
            val lblEndif = makeLabelEndif ()
            val lblFalse = DataSegment.add (Bool false)
        in
            (genExpr test absDepth
            ;CSadd (CodeSegment.BranchIf ("(SchemeObject*)r_res==&"^lblFalse,lblElse))
            ;genExpr dit absDepth
            ;CSadd (CodeSegment.Branch lblEndif)
            ;CSadd (CodeSegment.Label lblElse)
            ;genExpr dif absDepth
            ;CSadd (CodeSegment.Label lblEndif)
            )
        end
      | genExpr (abs as Abs _)    absDepth = genAbs abs absDepth
      | genExpr (abs as AbsOpt _) absDepth = genAbs abs absDepth
      | genExpr (abs as AbsVar _) absDepth = genAbs abs absDepth
      | genExpr (App (proc,args)) absDepth =
        (genDebug (App (proc,args));
        let
            val lblRet = makeLabelRet ()
            val lblApp = makeLabelApp ()
        in
            (* for each arg in args (backwards) do:
                  evaluate arg
                  push r_res to stack *)
            ((maprtl (fn arg => (genExpr arg absDepth;
                                 CSadd (CodeSegment.Push "r_res")))
                     args)
            (* push length(args) to stack *)
            ;CSadd (CodeSegment.Push (intToCString (List.length args)))
            (* evaluate proc *)
            ;genExpr proc absDepth
            (* if r_res is not a closure then: error *)
            ;CSadd (CodeSegment.BranchIf ("IS_SOB_CLOSURE(r_res)",lblApp))
            ;CSadd (CodeSegment.Error ErrType.AppNonProc)
            ;CSadd (CodeSegment.Label lblApp)
            (* push proc.env to stack *)
            ;CSadd (CodeSegment.Push "(int)SOB_CLOSURE_ENV(r_res)")
            (* push return address *)
            ;CSadd (CodeSegment.Push ("(int)&&"^lblRet))
            (* goto proc.code *)
            ;CSadd (CodeSegment.Branch "*(SOB_CLOSURE_CODE(r_res))")
            (* return address *)
            ;CSadd (CodeSegment.Label lblRet)
            (* restore sp - discard:
                - enviroment pointer (at sp-1)
                - n, the number of arguments (at sp-2)
                - n arguments *)
            ;CSadd (CodeSegment.Set ("sp","sp-2-stack[sp-2]"))
            )
        end
        )
      | genExpr (AppTP (proc,args))         absDepth =
        (genDebug (AppTP (proc,args));
        (* for each arg in args (backwards) do:
                evaluate arg
                push r_res to stack *)
        ((maprtl (fn arg => (genExpr arg absDepth;
                                CSadd (CodeSegment.Push "r_res")))
                    args)
        (* push length(args) to stack *)
        ;CSadd (CodeSegment.Push (intToCString (List.length args)))
        (* evaluate proc *)
        ;genExpr proc absDepth
        (* if r_res is not a closure then: error *)
        ;CSadd (CodeSegment.ErrorIf ("! IS_SOB_CLOSURE(r_res)",ErrType.AppNonProc))
        (* push proc.env to stack *)
        ;CSadd (CodeSegment.Push "(int)SOB_CLOSURE_ENV(r_res)")
        (* push return address (of current activation frame) *)
        ;CSadd (CodeSegment.Push "ST_RET()")
        (* override current activation frame *)
        ;CSadd (CodeSegment.Statement ("shiftActFrmDown()"))
        (* goto proc.code *)
        ;CSadd (CodeSegment.Branch "*(SOB_CLOSURE_CODE(r_res))")
        (* restore sp - discard:
                - enviroment pointer (at sp-1)
                - n, the number of arguments (at sp-2)
                - n arguments *)
        ;CSadd (CodeSegment.Set ("sp","sp-2-stack[sp-2]")) (* todo: remove? its a tail call - we would never get back here *)
        )
        )
      | genExpr (Seq [])          absDepth = ()
      | genExpr (Seq (e :: rest)) absDepth = (genExpr e absDepth; genExpr (Seq rest) absDepth)
      | genExpr (Or preds)        absDepth =
        let
            val lblEndOr = makeLabelEndOr ()
        in
           (genOrPreds lblEndOr preds absDepth
           ;CSadd (CodeSegment.Label lblEndOr)
           )
        end
      | genExpr (Set ((VarFree name),value)) absDepth =
        (* Set on VarFree is just the same as Def on VarFree *)
        genExpr (Def ((VarFree name),value)) absDepth
      | genExpr (Set ((VarParam (name,ndx)),value)) absDepth =
        let val lblVoid = DataSegment.add Void
        in
            (genExpr value absDepth
            ;CSadd (CodeSegment.Assertion ("("^(intToCString ndx)^">=0) & ("^(intToCString ndx)^"<ST_ARG_COUNT())",ErrType.None))
            ;CSadd (CodeSegment.Set (("ST_ARG("^(intToCString ndx)^")"),"r_res"))
            ;CSadd (CodeSegment.Set ("r_res","(int)&"^lblVoid))
            )
        end
      | genExpr (Set ((VarBound (name,major,minor)),value)) absDepth =
        let val lblVoid = DataSegment.add Void
        in
            (genExpr value absDepth
            ;CSadd (CodeSegment.Set (("((int**)ST_ENV())["^(intToCString major)^"]["^(intToCString minor)^"]"),"r_res"))
            ;CSadd (CodeSegment.Set ("r_res","(int)&"^lblVoid))
            )
        end
      | genExpr (Def ((VarFree name),value)) absDepth =
        let val lblVoid = DataSegment.add Void
        in
            (CSadd (CodeSegment.Debug ("binding symbol: "^name))
            ;genExpr value absDepth
            ;CSadd (CodeSegment.Set ("r[0]","(int)getSymbol(\""^name^"\",topLevel)"))
            ;CSadd (CodeSegment.Set ("((SymbolEntry*)r[0])->isDefined","1"))
            ;CSadd (CodeSegment.Set ("((SymbolEntry*)r[0])->sob","(SchemeObject*)r_res"))
            ;CSadd (CodeSegment.Set ("r_res","(int)&"^lblVoid))
            )
        end
      | genExpr (Def (_,_)) absDepth = raise Match (* shouldn't be here *)
    and genOrPreds _ [] absDepth = ()
      | genOrPreds lblEndOr (p :: rest) absDepth =
        let
            val lblFalse = DataSegment.add (Bool false)
        in
            (genExpr p absDepth
            ;CSadd (CodeSegment.BranchIf ("(SchemeObject*)r_res!=&"^lblFalse,lblEndOr))
            ;genOrPreds lblEndOr rest absDepth
            )
        end
    and genAbs abs absDepth =
        let
            val formalParams = case abs of
                Abs    (params,_)   => List.length params
              | AbsOpt (params,_,_) => List.length params + 1
              | AbsVar (_,_)        => 1
              | _ => raise Match (* shouldn't be here *)
            val body = case abs of
                Abs    (_,body)   => body
              | AbsOpt (_,_,body) => body
              | AbsVar (_,body)   => body
              | _ => raise Match (* shouldn't be here *)
            val lblSkipBody = makeLabelSkipBody ()
            val lblBody = makeLabelBody ()
        in
            (* 1. extend enviroment *)
            (CSadd (CodeSegment.Set ("r[0]","(int)extendEnviroment( (int**)"^
                                            (if absDepth=0 then "NULL"
                                                           else "ST_ENV()")^
                                            ", "^
                                            (intToCString absDepth)^
                                            ")"))
            (* 2. prepare code *)
            ;CSadd (CodeSegment.Branch lblSkipBody)
            ;CSadd (CodeSegment.Label lblBody)
            (* prolog *)
            ;CSadd (CodeSegment.Push "fp")
            ;CSadd (CodeSegment.Set ("fp","sp"))
            (* fix stack if needed *)
            ;case abs of
                (Abs _)    => ()
              | (AbsOpt _) => CSadd (CodeSegment.Statement ("prepareStackForAbsOpt("^(intToCString formalParams)^")"))
              | (AbsVar _) => CSadd (CodeSegment.Statement ("prepareStackForAbsOpt("^(intToCString formalParams)^")"))
              | _ => raise Match (* shouldn't be here *)
            (* verify number of actual arguments *)
            ;CSadd (CodeSegment.ErrorIf ("ST_ARG_COUNT()!="^(intToCString formalParams),
                                         (ErrType.ArgsCount ("user-procedure",formalParams))))
            (* body *)
            ;genExpr body (absDepth+1)
            (* epilog *)
            ;CSadd (CodeSegment.Pop ("fp"))
            ;CSadd CodeSegment.Return
            ;CSadd (CodeSegment.Label lblSkipBody)
            (* 3. create closure *)
            ;CSadd (CodeSegment.Set ("r_res","(int)makeSchemeClosure((void*)r[0],&&"^lblBody^")"))
            )
        end
    ;

    fun gen expr absDepth =
        let
            val lblRet = makeLabelRet ()
        in
            (* Set return address - the initial frame contains a dummy
               return address. Here we set it to instruction after `expr`.
               In case of several expressions compiled one after the other,
               we could pop the initial activation frame (it was pushed in
               addProlog) and push a new one. But since the only thing that
               changes is the return address, we just hack it.
            *)
            (CSadd (CodeSegment.Comment "set return address")
            ;CSadd (CodeSegment.Set ("ST_RET()","(int)&&"^lblRet))
            (* Compile the expression *)
            ;genExpr expr absDepth
            (* Don't forget the return address.. *)
            ;CSadd (CodeSegment.Label lblRet)
            )
        end
    ;

    fun emit (nregs,stacksize) =
       (addEpilog ();
        "/* COMP091 Scheme->C Compiler Generated Code */\n\n" ^
        "#include \"scheme.h\"\n" ^
        "#include \"assertions.h\"\n" ^
        "#include \"arch.h\"\n" ^
        "#include \"rtemgr.h\"\n" ^
        "#include \"strings.h\"\n" ^
        "extern SymbolNode *topLevel;\n"^
        "\n/* Data Segment */\n" ^
        (DataSegment.emit ()) ^
        "\n/* Code Segment */\n" ^
        "void schemeCompiledFunction() {\n" ^
        "\t#include \"builtins.c\"\n\n"^
        "\tinitArchitecture("^Int.toString(stacksize)^","^Int.toString(nregs)^");\n" ^
        "\n" ^
        (CodeSegment.emit ()) ^
        "\n}\n"
       );

end; (* Program *)