Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Tree: 5e911c6466
Fetching contributors…

Cannot retrieve contributors at this time

178 lines (150 sloc) 6.268 kB
(* **********************************************************
* Copyright 2009 VMware, Inc. All rights reserved.
* **********************************************************)
(*
* Lower module: performs "expression lowering", i.e. translates
* high-level expressions into low-level address arithmetic
* computations. Lowered expressions include: field accesses, array
* acceses, pointer arithmetic expressions, and char* aggregate
* indexes.
*)
open Globals
open Ast
open Symtab
open Type
open Memmodel
open Int64
(*
* buildMemAccess -- create a memory access with the appropriate accessor
* (getguest, getvmw, etc.) of the appropriate size for the expr's type.
* A check is made that the size of the memory access will fit in a VpInt
* (8 bytes) to guard against reading in large pieces of data (e.g. structs).
*)
let buildMemAccess(mm: mmident) (e: expr) (t: typ) : expr =
let size = getTypeSize(t) in
let accfunc = mmGetAccessor(mm) in
let vpIntWidth = 8 in
let expr = ExprCall(accfunc, [e]) in
match compare size (of_int vpIntWidth) with
| 0 -> expr
| n when n < 0 -> exprBinary("$mask", ExprIntConst size, expr)
| _ ->
failwith (Printf.sprintf
"Memory access: object too large (size %s, type %s, expr %s)"
(to_string size) (typeToString t) (exprToString e))
(*
* Left, right -- mutually recursive functions that compute an
* expression's lvalue and rvalue, respectively.
*)
let rec right(e: expr) : expr =
match e with
| ExprStrConst _
| ExprIntConst _
| ExprIdent _ -> e
| ExprCast(t, e1) -> stringConv t e1
| ExprAddr(mm, e1) -> snd(left e1)
| ExprUnary(op, e1) -> exprUnary(op, right e1)
| ExprBinary(op, e1, e2) ->
(match op, getExprType(e1) with
| "+", TypePtr(_, t)
| "-", TypePtr(_, t)
| "+", TypeArray(t, _)
| "-", TypeArray(t, _) ->
let sz = ExprIntConst(getTypeSize t) in
exprBinary(op, right e1, exprBinary("*", right e2, sz))
| "+", TypeString ->
let tmp = freshTemp() in
let fmt = ExprStrConst("\"%s%s\"") in
let args = [tmp; fmt; right e1; right e2] in
ExprComma([ExprCall("sprintf", args); tmp])
| "!=", TypeString
| "==", TypeString ->
let strcmp = ExprCall("$strcmp", [right e1; right e2]) in
exprBinary(op, strcmp, ExprIntConst(zero))
| _ -> exprBinary(op, right e1, right e2))
(*
* Rewrite: assert(cond, fmt, par, ..)
* as: assert(cond, (sprintf(tmp, fmt, par, ..), tmp))
*)
| ExprCall("assert", cond::fmt::par::rest) ->
let tmp = freshTemp() in
let args = tmp::fmt::par::rest in
let fmtExpr = ExprComma([ExprCall("sprintf", args); tmp]) in
right(ExprCall("assert", [cond; fmtExpr]))
| ExprCond(c, t, f) -> ExprCond(right c, right t, right f)
| ExprComma(l) -> ExprComma(List.map right l)
| ExprCall(id, al) -> ExprCall(id, List.map right al)
| ExprAssign(id, e1) -> ExprAssign(id, right e1)
| ExprAssignBag(id,e1,e2) -> ExprAssignBag(id, right e1, right e2)
| ExprAssignAggr(id, l1, l2, e1)
-> let stringConv' = stringConv TypeString in
ExprAssignAggr(id, List.map right l1,
List.map stringConv' l2, right e1)
| ExprBag(id, e1) -> ExprBag(id, right e1)
| _ when typeIsArray(getExprType e) -> snd(left e)
| _ -> let mm, le = left(e) in
buildMemAccess mm le (getExprType e)
and left(e: expr) : mmident * expr =
match e with
| ExprCast(t, e1) -> left(e1)
| ExprPointer(e1) -> getMemModel(getExprType e1), right(e1)
| ExprField(b, e1, id) ->
let e1 = if b then ExprPointer(e1) else e1 in
let offset = getFieldOffset id (getExprType e1) in
let mm, le1 = left(e1) in
mm, exprBinary("+", le1, ExprIntConst offset)
| ExprArray(e1, e2) ->
let e1 =
match getExprType e1 with
| TypePtr(_, t) -> ExprPointer(e1)
| TypeArray(t, _) -> e1
| _ -> failwith "Not reached" in
let elemSize = ExprIntConst(getTypeSize(getExprType e)) in
let offset = exprBinary("*", right e2, elemSize) in
let mm, le1 = left(e1) in
mm, exprBinary("+", le1, offset)
| e -> failwith ("Invalid lvalue: " ^ (exprToString e))
and freshTemp() =
let id = freshTempName() in
symtabVarDecl id TypeString true;
ExprIdent(id)
(*
* stringConv -- a function that generates code to convert a char* or
* char[] expression "e" to an emmett string, provided that type "t"
* is string. Such string conversions are generated for cast
* expressions and aggregate indices.
*)
and stringConv (t: typ) (e: expr) : expr =
let magic(e) =
let mm, le = left(e) in
let acc = (mmGetAccessor mm) ^ "str" in
let tmp = freshTemp() in
let e1 = ExprCall(acc, [tmp; exprIntConst(255); le]) in
ExprComma[e1; tmp]
in
match t, getExprType(e) with
| TypeString, TypePtr(_, TypeInt(_, "char")) -> magic(ExprPointer e)
| TypeString, TypeArray(TypeInt(_, "char"), _) -> magic(e)
| _ -> right(e)
(*
* lowerExpr, lowerStat -- recursively walk syntax trees and replace
* each use of an expression e with right(e). For statements, provide
* the return type of the enclosing function.
*)
let lowerExpr: expr -> expr = right
let rec lowerStat (t: typ) : stat -> stat = function
| StatEmpty -> StatEmpty
| StatExpr(e) -> StatExpr(lowerExpr e)
| StatReturn(e) -> StatReturn(lowerExpr e)
| StatBlock(l) -> StatBlock(List.map (lowerStat t) l)
| StatIf(e, s1) -> StatIf(lowerExpr e, lowerStat t s1)
| StatIfElse(e, s1, s2) -> StatIfElse(lowerExpr e,
lowerStat t s1, lowerStat t s2)
(*
* lowerPass -- lower the bodies of all probles and functions.
*)
let lowerPass() : unit =
let lowerFunc(id, fe) = fe.fbody <- lowerStat (getRetType id) fe.fbody in
let lowerProbe(id, pe) = pe.pbody <- lowerStat TypeVoid pe.pbody in
if !verbose then Printf.printf "# Lowering...\n";
compilerPass lowerFunc lowerProbe
Jump to Line
Something went wrong with that request. Please try again.