(* Code generator for Fasto *) module CodeGen (* compile : TypedProg -> Mips.Instruction list (* for debugging *) compileExp : TypedExp -> SymTab -> Mips.reg -> Mips.Instruction list *) open AbSyn exception MyError of string * Position type VarTable = SymTab.SymTab (* Name generator for labels and temporary symbolic registers *) (* Example usage: val tmp = newName "tmp" (* might produce _tmp_5_ *) *) let mutable counter = 0 let newName base_name = counter <- counter + 1 "_" + base_name + "_" + string counter + "_" let newReg reg_name = Mips.RS (newName reg_name) let newLab lab_name = newName lab_name (* Table storing all string literals, with labels given to them *) let stringTable : ((Mips.addr*string) list) ref = ref [] (* could also contain "\n", ",", "Index out of bounds in line ", but the format is a bit different (length and dummy pointer come first) *) (* Building a string in the heap, including initialisation code *) let buildString ( label : Mips.addr , str : string ) : (Mips.Instruction list * Mips.Instruction list) = let data = [ Mips.ALIGN 2 (* means: word-align *) ; Mips.LABEL label (* pointer *) ; Mips.SPACE 4 (* sizeof(Int) *) ; Mips.ASCIIZ str] let initR = Mips.RS (label + "_init") let addrR = Mips.RS (label + "_addr") let initcode = [ Mips.LA(addrR, label) ; Mips.LI(initR, String.length str) ; Mips.SW(initR, addrR, 0) ] (initcode, data) (* Link register *) let RA = Mips.RN 31 (* Register for stack pointer *) let SP = Mips.RN 29 (* Register for heap pointer *) let HP = Mips.RN 28 (* Constant-zero register *) let RZ = Mips.RN 0 (* General scratch-pad registers *) let RN2 = Mips.RN 2 let RN4 = Mips.RN 4 let RN5 = Mips.RN 5 let RN6 = Mips.RN 6 (* Suggested register division *) let minReg = 2 (* lowest usable register *) let maxCaller = 15 (* highest caller-saves register *) let maxReg = 25 (* highest allocatable register *) (* Syscall numbers for MARS, to be put in $2 *) let sysPrintInt = 1 (* print integer in $4 *) let sysPrintString = 4 (* print NUL-terminated string starting at $4 *) let sysReadInt = 5 (* read integer into $2 *) let sysExit = 10 (* terminate execution *) let sysPrintChar = 11 (* print character in $4 *) let sysReadChar = 12 (* read character into $2 *) (* Determine the size of an element in an array based on its type *) type ElemSize = ESByte | ESWord let getElemSize (tp : Type) : ElemSize = match tp with | Char -> ESByte | Bool -> ESByte | _ -> ESWord let elemSizeToInt (elmsz : ElemSize) : int = match elmsz with | ESByte -> 1 | ESWord -> 4 (* Pick the correct instruction from the element size. *) let mipsLoad elem_size = match elem_size with | ESByte -> Mips.LB | ESWord -> Mips.LW let mipsStore elem_size = match elem_size with | ESByte -> Mips.SB | ESWord -> Mips.SW (* generates the code to check that the array index is within bounds *) let checkBounds ( arr_beg : Mips.reg , ind_reg : Mips.reg , (line : int, c : int) ) : Mips.Instruction list = let size_reg = newReg "size_reg" let tmp_reg = newReg "tmp_reg" let err_lab = newLab "error_lab" let safe_lab = newLab "safe_lab" [ Mips.LW(size_reg, arr_beg, 0) ; Mips.BGEZ(ind_reg, safe_lab) (* check that ind_reg >= 0 *) ; Mips.LABEL(err_lab) ; Mips.LI(RN5, line) ; Mips.LA(RN6, "_Msg_IllegalIndex_") ; Mips.J "_RuntimeError_" ; Mips.LABEL(safe_lab) ; Mips.SUB(tmp_reg, ind_reg, size_reg) ; Mips.BGEZ(tmp_reg, err_lab) (* check that ind_reg < -size_reg *) ] (* dynalloc(size_reg, place, ty) generates code for allocating arrays of heap memory by incrementing the HP register (heap pointer) by a number of words. The arguments for this function are as follows: size_reg: contains the logical array size (number of array elements) place: will contain the address of new allocation (old HP) ty: char/bool elements take 1 byte, int elements take 4 bytes *) let dynalloc (size_reg : Mips.reg, place : Mips.reg, ty : Type ) : Mips.Instruction list = let tmp_reg = newReg "tmp" (* Use old HP as allocation address. *) let code1 = [ Mips.MOVE (place, HP) ] (* For char/bool: Align address to 4-byte boundary by rounding up. *) (* (By adding 3 and rounding down using SRA/SLL.) *) (* For int and arrays: Multiply logical size by 4, no alignment. *) let code2 = match getElemSize ty with | ESByte -> [ Mips.ADDI(tmp_reg, size_reg, 3) ; Mips.SRA (tmp_reg, tmp_reg, 2) ; Mips.SLL (tmp_reg, tmp_reg, 2) ] | ESWord -> [ Mips.SLL (tmp_reg, size_reg, 2) ] (* Make space for array size (+4). Increase HP. *) (* Save size of allocation in header. *) let code3 = [ Mips.ADDI (tmp_reg, tmp_reg, 4) ; Mips.ADD (HP, HP, tmp_reg) ; Mips.SW (size_reg, place, 0) ] [Mips.COMMENT "dynalloc"] @ code1 @ code2 @ code3 (* Pushing arguments on the stack: *) (* For each register 'r' in 'rs', copy them to registers from 'firstReg' and counting up. Return the full code and the next unused register (firstReg + num_args). *) let applyRegs ( fid : Mips.addr , args : Mips.reg list , place: Mips.reg , pos : Position ) : Mips.Instruction list = let regs_num = List.length args let caller_regs = List.map (fun n -> Mips.RN (n + minReg)) [0..regs_num-1] // List.tabulate (regs_num, fun n -> n + minReg) (* zipWith Mips.MOVE = zipWith (fun (regDest, regSrc) -> Mips.MOVE (regDest, regSrc)) *) let move_code = List.map Mips.MOVE (List.zip caller_regs args) if regs_num > maxCaller - minReg then raise (MyError("Number of arguments passed to " + fid + " exceeds number of caller registers", pos)) else move_code @ [ Mips.JAL(fid,caller_regs); Mips.MOVE(place, RN2) ] (* Compile 'e' under bindings 'vtable', putting the result in register 'place'. *) let rec compileExp (e : TypedExp) (vtable : VarTable) (place : Mips.reg) : Mips.Instruction list = match e with | Constant (IntVal n, pos) -> if n < 0 then compileExp (Negate (Constant (IntVal (-n), pos), pos)) vtable place else if n < 32768 then [ Mips.LI (place, n) ] else [ Mips.LUI (place, n / 65536) ; Mips.ORI (place, place, n % 65536) ] | Constant (BoolVal p, _) -> match p with | true -> [Mips.LI (place, 1)] | false -> [Mips.LI (place, 0)] | Constant (CharVal c, pos) -> [ Mips.LI (place, int c) ] (* Create/return a label here, collect all string literals of the program (in stringTable), and create them in the data section before the heap (Mips.ASCIIZ) *) | StringLit (strLit, pos) -> (* Convert string literal into label; only use valid characters. *) let normalChars0 = //String.filter System.Char.IsLetterOrDigit strLit String.map (fun c -> if System.Char.IsLetterOrDigit c then c else 'a') strLit let normalChars = normalChars0 + "__str__" let label = newLab (normalChars.Substring (0, 7)) let () = stringTable := (label, strLit)::(!stringTable) [ Mips.LA (place, label) ; Mips.COMMENT (label + ": string \"" + toCString strLit + "\"") ] | Constant (ArrayVal (vs, tp), pos) -> (* Create corresponding ArrayLit expression to re-use code. *) let arraylit = ArrayLit (List.map (fun v -> Constant (v, pos)) vs, tp, pos) compileExp arraylit vtable place | ArrayLit (elems, tp, pos) -> let elem_size = getElemSize tp let size_reg = newReg "size_reg" let addr_reg = newReg "addr_reg" let tmp_reg = newReg "tmp_reg" (* Store size of literal in size_reg, dynamically allocate that. *) (* Let addr_reg contain the address for the first array element. *) let header = [ Mips.LI (size_reg, List.length elems) ] @ dynalloc (size_reg, place, tp) @ [ Mips.ADDI (addr_reg, place, 4) ] let compileElem elem_exp = let elem_code = compileExp elem_exp vtable tmp_reg elem_code @ [ mipsStore elem_size (tmp_reg, addr_reg, 0) ; Mips.ADDI (addr_reg, addr_reg, elemSizeToInt elem_size) ] let elems_code = List.concat (List.map compileElem elems) header @ elems_code | Var (vname, pos) -> match SymTab.lookup vname vtable with | None -> raise (MyError ("Name " + vname + " not found", pos)) | Some reg_name -> [Mips.MOVE (place, reg_name)] | Plus (e1, e2, pos) -> let t1 = newReg "plus_L" let t2 = newReg "plus_R" let code1 = compileExp e1 vtable t1 let code2 = compileExp e2 vtable t2 code1 @ code2 @ [Mips.ADD (place,t1,t2)] | Minus (e1, e2, pos) -> let t1 = newReg "minus_L" let t2 = newReg "minus_R" let code1 = compileExp e1 vtable t1 let code2 = compileExp e2 vtable t2 code1 @ code2 @ [Mips.SUB (place,t1,t2)] | Times (e1, e2, pos) -> let t1 = newReg "times_L" let t2 = newReg "times_R" let code1 = compileExp e1 vtable t1 let code2 = compileExp e2 vtable t2 code1 @ code2 @ [Mips.MUL (place,t1,t2)] | Divide (e1, e2, pos) -> let t1 = newReg "divide_L" let t2 = newReg "divide_R" let code1 = compileExp e1 vtable t1 let code2 = compileExp e2 vtable t2 code1 @ code2 @ [Mips.DIV (place,t1,t2)] | Not (e, pos) -> let t = newReg "not_R" let code = compileExp e vtable t code @ [Mips.XORI (place,t,0)] | Negate (e, pos) -> let t = newReg "negate_R" let R0 = Mips.RN 0 let code = compileExp e vtable t code @ [Mips.SUB (place,R0,t)] | Let (dec, e1, pos) -> let (code1, vtable1) = compileDec dec vtable let code2 = compileExp e1 vtable1 place code1 @ code2 | If (e1, e2, e3, pos) -> let thenLabel = newLab "then" let elseLabel = newLab "else" let endLabel = newLab "endif" let code1 = compileCond e1 vtable thenLabel elseLabel let code2 = compileExp e2 vtable place let code3 = compileExp e3 vtable place code1 @ [Mips.LABEL thenLabel] @ code2 @ [ Mips.J endLabel; Mips.LABEL elseLabel ] @ code3 @ [Mips.LABEL endLabel] (* special case for length *) | Apply ("length", [arr], pos) -> let arr_addr = newReg "len_arr" let code1 = compileExp arr vtable arr_addr code1 @ [ Mips.LW(place,arr_addr, 0) ] | Apply (f, args, pos) -> (* Convention: args in regs (2..15), result in reg 2 *) let compileArg arg = let arg_reg = newReg "arg" (arg_reg, compileExp arg vtable arg_reg) let (arg_regs, argcode) = List.unzip (List.map compileArg args) let applyCode = applyRegs(f, arg_regs, place, pos) List.concat argcode @ (* Evaluate args *) applyCode (* Jump to function and store result in place *) (* dirty I/O. Read and Write: supported for basic types: Int, Char, Bool via system calls. Write of an Array(Chars) is also supported. The others are the user's responsibility. *) | Read(tp, pos) -> match tp with | Int -> [ Mips.JAL ("getint", [RN2]) ; Mips.MOVE(place, RN2) ] | Char -> [ Mips.JAL ("getchar", [RN2]) ; Mips.MOVE(place, RN2) ] | Bool -> (* Note: the following inputs booleans as integers, with 0 interpreted as false and everything else as true. This differs from the interpreter! *) let tl = newLab "true_lab" let fl = newLab "false_lab" let ml = newLab "merge_lab" let v = newReg "bool_var" [ Mips.JAL ("getint", [RN2]) ; Mips.MOVE(v, RN2) ; Mips.BEQ (v, RZ,fl) ; Mips.J tl ; Mips.LABEL fl ; Mips.MOVE(place, RZ) ; Mips.J ml ; Mips.LABEL tl ; Mips.LI (place, 1) ; Mips.J ml ; Mips.LABEL ml ] | _ -> raise (MyError("Read on an incompatible type: " + ppType tp, pos)) | Write(e, tp, pos) -> let tmp = newReg "tmp" let codeexp = compileExp e vtable tmp @ [ Mips.MOVE (place, tmp) ] match tp with | Int -> codeexp @ [ Mips.MOVE(RN2,place); Mips.JAL("putint", [RN2]) ] | Char -> codeexp @ [ Mips.MOVE(RN2,place); Mips.JAL("putchar",[RN2]) ] | Bool -> let tlab = newLab "wBoolF" codeexp @ [ Mips.LA (RN2, "_true") ; Mips.BNE (place, RZ, tlab) ; Mips.LA (RN2, "_false") ; Mips.LABEL tlab ; Mips.JAL ("putstring", [RN2]) ] | Array Char -> codeexp @ [ Mips.MOVE (RN2, tmp) ; Mips.JAL("putstring", [RN2]) ] | _ -> raise (MyError("Write on an incompatible type: " + ppType tp, pos)) (* Comparison checking, later similar code for And and Or. *) | Equal (e1, e2, pos) -> let t1 = newReg "eq_L" let t2 = newReg "eq_R" let code1 = compileExp e1 vtable t1 let code2 = compileExp e2 vtable t2 let falseLabel = newLab "false" code1 @ code2 @ [ Mips.LI (place, 0) ; Mips.BNE (t1,t2,falseLabel) ; Mips.LI (place, 1) ; Mips.LABEL falseLabel ] | Less (e1, e2, pos) -> let t1 = newReg "lt_L" let t2 = newReg "lt_R" let code1 = compileExp e1 vtable t1 let code2 = compileExp e2 vtable t2 code1 @ code2 @ [Mips.SLT (place,t1,t2)] | And (e1, e2, pos) -> let R0 = Mips.RS "0" let label = newLab "false" let code1 = compileExp e1 vtable place let code2 = compileExp e2 vtable place code1 @ [Mips.BEQ (place, R0, label)] @ code2 @ [Mips.LABEL label] | Or (e1, e2, pos) -> let R0 = Mips.RS "0" let label = newLab "true" let code1 = compileExp e1 vtable place let code2 = compileExp e2 vtable place code1 @ [Mips.BNE (place, R0, label)] @ code2 @ [Mips.LABEL label] (* Indexing: 1. generate code to compute the index 2. check index within bounds 3. add the start address with the index 4. get the element at that address *) | Index (arr_name, i_exp, ty, pos) -> let ind_reg = newReg "arr_ind" let ind_code = compileExp i_exp vtable ind_reg let arr_reg = newReg "arr_reg" (* Let arr_reg be the start of the data segment *) let arr_beg = match SymTab.lookup arr_name vtable with | None -> raise (MyError ("Name " + arr_name + " not found", pos)) | Some reg_name -> reg_name let init_code = [ Mips.ADDI(arr_reg, arr_beg, 4) ] (* code to check bounds *) let check_code = checkBounds(arr_beg, ind_reg, pos) (* for INT/ARRAY: ind *= 4 else ind is unchanged *) (* array_var += index; place = *array_var *) let load_code = match getElemSize ty with | ESByte -> [ Mips.ADD(arr_reg, arr_reg, ind_reg) ; Mips.LB(place, arr_reg, 0) ] | ESWord -> [ Mips.SLL(ind_reg, ind_reg, 2) ; Mips.ADD(arr_reg, arr_reg, ind_reg) ; Mips.LW(place, arr_reg, 0) ] ind_code @ init_code @ check_code @ load_code (* Second-Order Array Combinators (SOACs): iota, map, reduce *) | Iota (n_exp, (line, _)) -> let size_reg = newReg "size_reg" let n_code = compileExp n_exp vtable size_reg (* size_reg is now the integer n. *) (* Check that array size N >= 0: if N >= 0 then jumpto safe_lab jumpto "_IllegalArrSizeError_" safe_lab: ... *) let safe_lab = newLab "safe_lab" let checksize = [ Mips.BGEZ (size_reg, safe_lab) ; Mips.LI (RN5, line) ; Mips.LA (RN6, "_Msg_IllegalArraySize_") ; Mips.J "_RuntimeError_" ; Mips.LABEL (safe_lab) ] let addr_reg = newReg "addr_reg" let i_reg = newReg "i_reg" let init_regs = [ Mips.ADDI (addr_reg, place, 4) ; Mips.MOVE (i_reg, RZ) ] (* addr_reg is now the position of the first array element. *) (* Run a loop. Keep jumping back to loop_beg until it is not the case that i_reg < size_reg, and then jump to loop_end. *) let loop_beg = newLab "loop_beg" let loop_end = newLab "loop_end" let tmp_reg = newReg "tmp_reg" let loop_header = [ Mips.LABEL (loop_beg) ; Mips.SUB (tmp_reg, i_reg, size_reg) ; Mips.BGEZ (tmp_reg, loop_end) ] (* iota is just 'arr[i] = i'. arr[i] is addr_reg. *) let loop_iota = [ Mips.SW (i_reg, addr_reg, 0) ] let loop_footer = [ Mips.ADDI (addr_reg, addr_reg, 4) ; Mips.ADDI (i_reg, i_reg, 1) ; Mips.J loop_beg ; Mips.LABEL loop_end ] n_code @ checksize @ dynalloc (size_reg, place, Int) @ init_regs @ loop_header @ loop_iota @ loop_footer | Map (farg, arr_exp, elem_type, ret_type, pos) -> let size_reg = newReg "size_reg" (* size of input/output array *) let arr_reg = newReg "arr_reg" (* address of array *) let elem_reg = newReg "elem_reg" (* address of single element *) let res_reg = newReg "res_reg" let arr_code = compileExp arr_exp vtable arr_reg let get_size = [ Mips.LW (size_reg, arr_reg, 0) ] let addr_reg = newReg "addr_reg" (* address of element in new array *) let i_reg = newReg "i_reg" let init_regs = [ Mips.ADDI (addr_reg, place, 4) ; Mips.MOVE (i_reg, RZ) ; Mips.ADDI (elem_reg, arr_reg, 4) ] let loop_beg = newLab "loop_beg" let loop_end = newLab "loop_end" let tmp_reg = newReg "tmp_reg" let loop_header = [ Mips.LABEL (loop_beg) ; Mips.SUB (tmp_reg, i_reg, size_reg) ; Mips.BGEZ (tmp_reg, loop_end) ] (* map is 'arr[i] = f(old_arr[i])'. *) let src_size = getElemSize elem_type let dst_size = getElemSize ret_type let loop_map = [ mipsLoad src_size (res_reg, elem_reg, 0) ; Mips.ADDI(elem_reg, elem_reg, elemSizeToInt src_size) ] @ applyFunArg(farg, [res_reg], vtable, res_reg, pos) @ [ mipsStore dst_size (res_reg, addr_reg, 0) ; Mips.ADDI (addr_reg, addr_reg, elemSizeToInt dst_size) ] let loop_footer = [ Mips.ADDI (i_reg, i_reg, 1) ; Mips.J loop_beg ; Mips.LABEL loop_end ] [Mips.COMMENT "map"] @ arr_code @ get_size @ dynalloc (size_reg, place, ret_type) @ init_regs @ loop_header @ loop_map @ loop_footer (* reduce(f, acc, {x1, x2, ...xn}) = f(f(f(acc,x1),x2),...xn) *) | Reduce (binop, acc_exp, arr_exp, tp, pos) -> let arr_reg = newReg "arr_reg" (* address of array *) let size_reg = newReg "size_reg" (* size of input array *) let i_reg = newReg "ind_var" (* loop counter *) let tmp_reg = newReg "tmp_reg" (* several purposes *) let loop_beg = newLab "loop_beg" let loop_end = newLab "loop_end" let arr_code = compileExp arr_exp vtable arr_reg let header1 = [ Mips.LW(size_reg, arr_reg, 0) ] (* Compile initial value into place (will be updated below) *) let acc_code = compileExp acc_exp vtable place (* Set arr_reg to address of first element instead. *) (* Set i_reg to 0. While i < size_reg, loop. *) let loop_code = [ Mips.ADDI(arr_reg, arr_reg, 4) ; Mips.MOVE(i_reg, RZ) ; Mips.LABEL(loop_beg) ; Mips.SUB(tmp_reg, i_reg, size_reg) ; Mips.BGEZ(tmp_reg, loop_end) ] (* Load arr[i] into tmp_reg *) let elem_size = getElemSize tp let load_code = [ mipsLoad elem_size (tmp_reg, arr_reg, 0) ; Mips.ADDI (arr_reg, arr_reg, elemSizeToInt elem_size) ] (* place := binop(place, tmp_reg) *) let apply_code = applyFunArg(binop, [place; tmp_reg], vtable, place, pos) arr_code @ header1 @ acc_code @ loop_code @ load_code @ apply_code @ [ Mips.ADDI(i_reg, i_reg, 1) ; Mips.J loop_beg ; Mips.LABEL loop_end ] | Replicate (n_exp, a_exp, a_type, (line, _)) -> let a_size = getElemSize a_type let size_reg = newReg "size_reg" let n_code = compileExp n_exp vtable size_reg (* size_reg is now the integer n. *) let a_reg = newReg "a_reg" let a_code = compileExp a_exp vtable a_reg (* Check that array size N >= 0: if N >= 0 then jumpto safe_lab jumpto "_IllegalArrSizeError_" safe_lab: ... *) let safe_lab = newLab "safe_lab" let checksize = [ Mips.BGEZ (size_reg, safe_lab) ; Mips.LI (RN5, line) ; Mips.LA (RN6, "_Msg_IllegalArraySize_") ; Mips.J "_RuntimeError_" ; Mips.LABEL (safe_lab) ] let addr_reg = newReg "addr_reg" let i_reg = newReg "i_reg" let init_regs = [ Mips.ADDI (addr_reg, place, 4) ; Mips.MOVE (i_reg, RZ) ] (* addr_reg is now the position of the first array element. *) (* Run a loop. Keep jumping back to loop_beg until it is not the case that i_reg < size_reg, and then jump to loop_end. *) let loop_beg = newLab "loop_beg" let loop_end = newLab "loop_end" let tmp_reg = newReg "tmp_reg" let loop_header = [ Mips.LABEL (loop_beg) ; Mips.SUB (tmp_reg, i_reg, size_reg) ; Mips.BGEZ (tmp_reg, loop_end) ] (* 'arr[i] = a' *) let loop_replicate = [ mipsStore a_size (a_reg, addr_reg, 0) ] let loop_footer = [ Mips.ADDI (addr_reg, addr_reg, 4) ; Mips.ADDI (i_reg, i_reg, 1) ; Mips.J loop_beg ; Mips.LABEL loop_end ] n_code @ a_code @ checksize @ dynalloc (size_reg, place, Int) @ init_regs @ loop_header @ loop_replicate @ loop_footer | Filter (farg, arr_exp, a_type, pos) -> let size_reg = newReg "size_reg" (* size of input/output array *) let arr_reg = newReg "arr_reg" (* address of array *) let elem_reg = newReg "elem_reg" (* address of single element *) let res_reg = newReg "res_reg" let bool_reg = newReg "bool_reg" let arr_code = compileExp arr_exp vtable arr_reg let get_size = [ Mips.LW (size_reg, arr_reg, 0) ] let addr_reg = newReg "addr_reg" (* address of element in new array *) let i_reg = newReg "i_reg" let j_reg = newReg "j_reg" let init_regs = [ Mips.ADDI (addr_reg, place, 4) ; Mips.MOVE (i_reg, RZ) ; Mips.MOVE (j_reg, RZ) ; Mips.ADDI (elem_reg, arr_reg, 4) ] let loop_beg = newLab "loop_beg" let loop_end = newLab "loop_end" let not_true = newLab "not_true" let tmp_reg = newReg "tmp_reg" let loop_header = [ Mips.LABEL (loop_beg) ; Mips.SUB (tmp_reg, i_reg, size_reg) ; Mips.BGEZ (tmp_reg, loop_end) ] (* map is 'arr[i] = f(old_arr[i])'. *) let a_size = getElemSize a_type let loop_map = [ mipsLoad a_size (res_reg, elem_reg, 0) ; Mips.ADDI(elem_reg, elem_reg, elemSizeToInt a_size) ] @ applyFunArg(farg, [res_reg], vtable, bool_reg, pos) @ [ Mips.BEQ (bool_reg, RZ, not_true) ; mipsStore a_size (res_reg, addr_reg, 0) ; Mips.ADDI (j_reg, j_reg, 1) ; Mips.ADDI (addr_reg, addr_reg, elemSizeToInt a_size) ] let loop_footer = [ Mips.LABEL not_true ; Mips.ADDI (i_reg, i_reg, 1) ; Mips.J loop_beg ; Mips.LABEL loop_end ; Mips.SW (j_reg,place,0) ] arr_code @ get_size @ dynalloc (size_reg, place, a_type) @ init_regs @ loop_header @ loop_map @ loop_footer | Scan (farg, e_exp, arr_exp, a_type, pos) -> let size_reg = newReg "size_reg" (* size of input/output array *) let arr_reg = newReg "arr_reg" (* address of array *) let elem_reg = newReg "elem_reg" (* address of single element *) let res_reg = newReg "res_reg" let nelem_reg = newReg "nelem_reg" let arr_code = compileExp arr_exp vtable arr_reg let e_code = compileExp e_exp vtable nelem_reg let get_size = [ Mips.LW (size_reg, arr_reg, 0) ] let addr_reg = newReg "addr_reg" (* address of element in new array *) let i_reg = newReg "i_reg" let init_regs = [ Mips.ADDI (addr_reg, place, 4) ; Mips.MOVE (i_reg, RZ) ; Mips.ADDI (elem_reg, arr_reg, 4) ] let loop_beg = newLab "loop_beg" let loop_end = newLab "loop_end" let tmp_reg = newReg "tmp_reg" let loop_header = [ Mips.LABEL (loop_beg) ; Mips.SUB (tmp_reg, i_reg, size_reg) ; Mips.BGEZ (tmp_reg, loop_end) ] (* map is 'arr[i] = f(old_arr[i])'. *) let a_size = getElemSize a_type let loop_map = [ mipsLoad a_size (res_reg, elem_reg, 0) ; Mips.ADDI(elem_reg, elem_reg, elemSizeToInt a_size) ] @ applyFunArg(farg, [nelem_reg ; res_reg], vtable, nelem_reg, pos) @ [ mipsStore a_size (nelem_reg, addr_reg, 0) ; Mips.ADDI (addr_reg, addr_reg, elemSizeToInt a_size) ] let loop_footer = [ Mips.ADDI (i_reg, i_reg, 1) ; Mips.J loop_beg ; Mips.LABEL loop_end ] arr_code @ e_code @ get_size @ dynalloc (size_reg, place, a_type) @ init_regs @ loop_header @ loop_map @ loop_footer and applyFunArg ( ff : TypedFunArg , args : Mips.reg list , vtable : VarTable , place : Mips.reg , pos : Position ) : Mips.Instruction list = match ff with | FunName s -> let tmp_reg = newReg "tmp_reg" applyRegs(s, args, tmp_reg, pos) @ [Mips.MOVE(place, tmp_reg)] | Lambda (_, parms, body, lampos) -> let rec bindParams parms args vtable' = match (parms, args) with | (Param (pname,_)::parms', arg::args') -> bindParams parms' args' (SymTab.bind pname arg vtable') | _ -> vtable' let vtable' = bindParams parms args vtable let t = newReg "fun_arg_res" compileExp body vtable' t @ [ Mips.MOVE(place, t) ] (* compile condition *) and compileCond (c : TypedExp) (vtable : VarTable) (tlab : Mips.addr) (flab : Mips.addr) : Mips.Instruction list = let t1 = newReg "cond" let code1 = compileExp c vtable t1 code1 @ [Mips.BNE (t1, RZ, tlab); Mips.J flab] (* compile let declaration *) and compileDec (dec : TypedDec) (vtable : VarTable) : (Mips.Instruction list * VarTable) = let (Dec (s,e,pos)) = dec let t = newReg "letBind" let code = compileExp e vtable t let new_vtable = SymTab.bind s t vtable (code, new_vtable) (* code for saving and restoring callee-saves registers *) let rec stackSave (currentReg : int) (maxReg : int) (savecode : Mips.Instruction list) (restorecode : Mips.Instruction list) (offset : int) : (Mips.Instruction list * Mips.Instruction list * int) = if currentReg > maxReg then (savecode, restorecode, offset) (* done *) else stackSave (currentReg+1) maxReg (Mips.SW (Mips.RN currentReg, SP, offset) :: savecode) (* save register *) (Mips.LW (Mips.RN currentReg, SP, offset) :: restorecode) (* restore register *) (offset-4) (* adjust offset *) (* add function arguments to symbol table *) and getArgs (parms : Param list) (vtable : VarTable) (nextReg : int) : (Mips.Instruction list * VarTable) = match parms with | [] -> ([], vtable) | (Param (v,_)::vs) -> if nextReg > maxCaller then raise (MyError ("Passing too many arguments!", (0,0))) else let vname = newReg ("param_" + v) let vtable1 = SymTab.bind v vname vtable (* (v,vname)::vtable *) let (code2,vtable2) = getArgs vs vtable1 (nextReg + 1) ([Mips.MOVE (vname, Mips.RN nextReg)] @ code2, vtable2) (* compile function declaration *) and compileFun (fundec : TypedFunDec) : Mips.Prog = let (FunDec (fname, resty, args, exp, (line,col))) = fundec (* make a vtable from bound formal parameters, then evaluate expression in this context, return it *) (* arguments passed in registers, "move" into local vars. *) let (argcode, vtable_local) = getArgs args (SymTab.empty ()) minReg (* return value in register 2 *) let rtmp = newReg (fname + "res") let returncode = [Mips.MOVE (RN2,rtmp)] (* move return val to R2 *) let body = compileExp exp vtable_local rtmp (* target expr *) let (body1, _, maxr, spilled) = RegAlloc.registerAlloc (* call register allocator *) (argcode @ body @ returncode) (Set.singleton (RN2)) 2 maxCaller maxReg 0 let (savecode, restorecode, offset) = (* save/restore callee-saves *) stackSave (maxCaller+1) maxr [] [] (-8 + (-4 * spilled)) [Mips.COMMENT ("Function " + fname); Mips.LABEL fname; (* function label *) Mips.SW (RA, SP, -4)] (* save return address *) @ savecode (* save callee-saves registers *) @ [Mips.ADDI (SP,SP,offset)] (* SP adjustment *) @ body1 (* code for function body *) @ [Mips.ADDI (SP,SP,-offset)] (* move SP up *) @ restorecode (* restore callee-saves registers *) @ [Mips.LW (RA, SP, -4); (* restore return addr *) Mips.JR (RA, [])] (* return *) (* compile program *) let compile (funs : TypedProg) : Mips.Instruction list = let () = stringTable := [("_true","true"); ("_false","false")] let funsCode = List.concat (List.map compileFun funs) let (stringinit_sym, stringdata) = List.unzip (List.map buildString (!stringTable)) let (stringinit,_,_,_) = match stringinit_sym with | [] -> ([],Set.empty,0,0) | _ -> RegAlloc.registerAlloc (* call register allocator *) (List.concat stringinit_sym) (Set.singleton (RN2)) 2 maxCaller maxReg 0 let mips_prog = [Mips.TEXT "0x00400000"; Mips.GLOBL "main"] (* initialisation: heap pointer and string pointers *) @ (Mips.LA (HP, "_heap_"):: stringinit) (* jump to main (and stop after returning) *) @ [Mips.JAL ("main",[])] @ (* stop code *) [Mips.LABEL "_stop_"; Mips.LI (RN2, sysExit); Mips.SYSCALL] @ (* code for functions *) funsCode (* pre-defined ord: char -> int and chr: int -> char *) @ [Mips.LABEL "ord"; (* char returned unmodified, interpreted as int *) Mips.JR (RA,[]); Mips.LABEL "chr"; (* int values are truncated to 8 bit (ASCII), *) Mips.ANDI (RN2, RN2, 255); Mips.JR (RA,[])] (* built-in read and write functions *) @ [Mips.LABEL "putint"; (* putint function *) Mips.ADDI(SP,SP,-8); Mips.SW (RN2,SP,0); (* save used registers *) Mips.SW (RN4,SP,4); Mips.MOVE (RN4, RN2); (* convention: number to be written in r2 *) Mips.LI (RN2, sysPrintInt); Mips.SYSCALL; Mips.LI (RN2, sysPrintString); Mips.LA(RN4,"_space_"); Mips.SYSCALL; (* write CR *) Mips.LW (RN2,SP,0); (* reload used registers *) Mips.LW (RN4,SP,4); Mips.ADDI(SP,SP,8); Mips.JR (RA,[]); Mips.LABEL "getint"; (* getint function *) Mips.LI (RN2,sysReadInt); Mips.SYSCALL; Mips.JR (RA,[])] @ (* putchar *) [ Mips.LABEL "putchar"; Mips.ADDI(SP,SP,-8); (* make space for 2 registers on the stack *) Mips.SW (RN2,SP,0); (* save registers $2 and $4 to stack *) Mips.SW (RN4,SP,4); Mips.MOVE (RN4, RN2); (* put char in $4 for syscall to work on *) Mips.LI(RN2, sysPrintChar); Mips.SYSCALL; Mips.LI (RN2, sysPrintString); Mips.LA(RN4,"_space_"); (* the string we'll write is a space *) Mips.SYSCALL; Mips.LW (RN2,SP,0); (* reload registers $2 and $4 from stack *) Mips.LW (RN4,SP,4); Mips.ADDI(SP,SP,8); (* free stack space again *) Mips.JR (RA,[]) ] @ (* getchar *) [ Mips.LABEL "getchar"; Mips.ADDI(SP,SP,-8); (* make space for 2 registers on the stack *) Mips.SW (RN4,SP,0); (* save registers $4 and $5 to stack *) Mips.SW (RN5,SP,4); Mips.LI(RN2, sysReadChar); Mips.SYSCALL; Mips.MOVE(RN5,RN2); (* temporarily move the result in reg $5*) Mips.LI (RN2, sysPrintString); Mips.LA(RN4,"_cr_"); Mips.SYSCALL; (* write CR *) Mips.MOVE(RN2, RN5); (* put the result back in $2*) Mips.LW (RN4, SP, 0); (* restore registers *) Mips.LW (RN5, SP, 4); Mips.ADDI(SP,SP,8); (* free stack space again *) Mips.JR (RA,[]) ] @ (* putstring *) [ Mips.LABEL "putstring"; Mips.ADDI(SP, SP, -16); (* make space on stack for registers *) Mips.SW (RN2, SP, 0); (* save registers $2,$4,$5,$6 to stack *) Mips.SW (RN4, SP, 4); Mips.SW (RN5, SP, 8); Mips.SW (RN6, SP, 12); Mips.LW (RN4, RN2, 0); (* $4 := size($2) *) Mips.ADDI(RN5, RN2, 4); (* $5 := $2 + 4 *) Mips.ADD (RN6, RN5, RN4); (* $6 := $5 + $4 *) Mips.LI (RN2, sysPrintChar); Mips.LABEL "putstring_begin"; Mips.SUB (RN4, RN5, RN6); (* while ($5 < $6) { *) Mips.BGEZ(RN4, "putstring_done"); (* *) Mips.LB(RN4, RN5, 0); (* $4 := M[$5] *) Mips.SYSCALL; (* putchar($4) *) Mips.ADDI(RN5, RN5, 1); (* $5 := $5 + 1 *) Mips.J "putstring_begin"; (* } *) Mips.LABEL "putstring_done"; Mips.LW (RN2, SP, 0); (* restore registers $2,$4,$5,$6 *) Mips.LW (RN4, SP, 4); Mips.LW (RN5, SP, 8); Mips.LW (RN6, SP, 12); Mips.ADDI(SP, SP, 16); (* free stack space again *) Mips.JR (RA,[]) ] @ (* Fixed code for reporting runtime errors. expects source line number in $5, pointer to error message in $6 *) [Mips.LABEL "_RuntimeError_"; Mips.LA (RN4, "_ErrMsg_"); Mips.LI (RN2, sysPrintString); Mips.SYSCALL; Mips.MOVE (RN4, RN5); Mips.LI (RN2, sysPrintInt); Mips.SYSCALL; Mips.LA (RN4, "_colon_space_"); Mips.LI (RN2, sysPrintString); Mips.SYSCALL; Mips.MOVE (RN4, RN6); Mips.LI (RN2, sysPrintString); Mips.SYSCALL; Mips.LA (RN4, "_cr_"); Mips.LI (RN2, sysPrintString); Mips.SYSCALL; Mips.J "_stop_"] @ [Mips.DATA ""; Mips.COMMENT "Fixed strings for I/O"; Mips.LABEL "_ErrMsg_"; Mips.ASCIIZ "Runtime error at line "; Mips.LABEL "_colon_space_"; Mips.ASCIIZ ": "; Mips.LABEL "_cr_"; Mips.ASCIIZ "\n"; Mips.LABEL "_space_"; Mips.ASCIIZ " "] @ [Mips.COMMENT "Message strings for specific errors"; Mips.LABEL "_Msg_IllegalArraySize_"; Mips.ASCIIZ "negative array size"; Mips.LABEL "_Msg_IllegalIndex_"; Mips.ASCIIZ "array index out of bounds" Mips.LABEL "_Msg_DivZero_"; Mips.ASCIIZ "division by zero" ] @ (* String literals *) (Mips.COMMENT "String Literals" :: List.concat stringdata) (* Heap (to allocate arrays in, word-aligned) *) @ [Mips.ALIGN 2; Mips.LABEL "_heap_"; Mips.SPACE 100000] mips_prog