Home My Page Projects Code Snippets Project Openings diderot
Summary Activity Tracker Tasks SCM

SCM Repository

[diderot] View of /branches/pure-cfg/src/compiler/codegen/clang.sml
ViewVC logotype

View of /branches/pure-cfg/src/compiler/codegen/clang.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1285 - (download) (annotate)
Tue Jun 7 10:33:17 2011 UTC (8 years, 3 months ago) by jhr
File size: 9169 byte(s)
  Made TreeToCL into a functor parameterized over the translation of variables.
  This allows different clients to have different representations for globals, etc.
(* clang.sml
 *
 * COPYRIGHT (c) 2011 The Diderot Project (http://diderot-language.cs.uchicago.edu)
 * All rights reserved.
 *
 * An tree representation of programs in a C-like language (e.g., C, CUDA,
 * or OpenCL).  The purpose of this code is to commonality between the various
 * backends, which are all generating C-like code.
 *)

structure CLang =
  struct

    type var = string
    type attr = string		(* e.g., "static", "kernel", etc ... *)

    datatype ty
      = T_Num of RawTypes.ty
      | T_Ptr of ty
      | T_Array of ty * int option
      | T_Named of string

    datatype typed_var = V of ty * var

    val voidTy = T_Named "void"
    val charTy = T_Named "char"
    val charPtr = T_Ptr(T_Named "char")
    val charArrayPtr = T_Ptr(charPtr) 
    val intTy = T_Named "int"
    val int32 = T_Num(RawTypes.RT_Int32)
    val uint32 = T_Num(RawTypes.RT_UInt32)
    val int64 = T_Num(RawTypes.RT_Int64)
    val float = T_Num(RawTypes.RT_Float)
    val double = T_Num(RawTypes.RT_Double)

(* FIXME: these types do not belong here! *)
    datatype decl
      = D_Comment of string list
    (* verbatim text (e.g., preprocessor directives) *)
      | D_Verbatim of string list
    (* global variable declaration *)
      | D_Var of attr list * ty * var * initializer option
    (* function definition *)
      | D_Func of attr list * ty * string * param list * stm
    (* typedef of struct type *)
      | D_StructDef of (ty * string) list * string

    and initializer
      = I_Exp of exp
      | I_Struct of (string * initializer) list
      | I_Array of (int * initializer) list

    and param = PARAM of attr list * ty * var

    and stm
      = S_Block of stm list		(* "{" stms "}" *)
      | S_Comment of string list
      | S_Decl of ty * var * initializer option	(* ty var [ '=' exp ]';' *)
      | S_Exp of exp			(* exp ';' *)
      | S_If of exp * stm * stm		(* 'if' exp stm 'else' stm *)
      | S_While of exp * stm		(* 'while' exp stm *)
      | S_For of (ty * var * exp) list * exp * exp list * stm
					(* 'for' '(' inits ';' exp ';' incrs ')' stm *)
      | S_Call of string * exp list	(* func '(' args ')' *)
      | S_Return of exp option		(* 'return' [ exp ] ';' *)
      | S_Break				(* 'break' ';' *)
      | S_Continue			(* 'continue' ';' *)

    and exp
      = E_Grp of exp			(* "(" e ")" *)
      | E_AssignOp of exp * assignop * exp (* lvalue op= e *)
      | E_BinOp of exp * binop * exp	(* e op e *)
      | E_UnOp of unop * exp		(* op e *)
      | E_PostOp of exp * postfix	(* e op *)
      | E_Apply of string * exp list	(* f "(" ... ")" *)
      | E_Subscript of exp * exp	(* e "[" e "]" *)
      | E_Select of exp * string	(* e "." f *)
      | E_Indirect of exp * string	(* e "->" f *)
      | E_Cast of ty * exp		(* "(" ty ")" e *)
      | E_Var of var
      | E_Int of IntegerLit.integer * ty
      | E_Flt of FloatLit.float * ty
      | E_Bool of bool
      | E_Str of string
      | E_Sizeof of ty			(* "sizeof(" ty ")" *)

  (* assignment operators *)
    and assignop
      = $= | += | *= | /= | %= | <<= | >>= | &= | ^= | |=

  (* binary operators in increasing order of precedence *)
    and binop
      = #||
      | #&&
      | #== | #!=
      | #< | #<= | #>= | #>
      | #<< | #>>
      | #+ | #-
      | #* | #/ | #%

    and unop = %- | %! | %& | %* | %~ | %++ | %--

    and postfix = ^++ | ^--

  (* smart constructors that add E_Grp wrappers based on operator precedence *)
    local
      val commaP	= 0
      val assignP	= 1
      val condP		= 2
      val lorP		= 3
      val landP		= 4
      val borP		= 5
      val bandP		= 6
      val eqP		= 7
      val relP		= 8
      val shiftP	= 9
      val addP		= 10
      val mulP		= 11
      val unaryP	= 12
      val preP		= 13
      val compundP	= 14	(* compound literal *)
      val postP		= 15
      val callP		= 16
      val subP		= 17
      val atomP		= 18
      fun precOfBinop rator = (case rator
	     of #|| => lorP
	      | #&& => landP
	      | #== => eqP | #!= => eqP
	      | #< => relP | #<= => relP | #>= => relP | #> => relP
	      | #<< => shiftP | #>> => shiftP
	      | #+ => addP | #- => addP
	      | #* => mulP | #/ => mulP | #% => mulP
	    (* end case *))
      fun prec (E_Grp _) = atomP
	| prec (E_AssignOp _) = assignP
	| prec (E_BinOp(_, rator, _)) = precOfBinop rator
	| prec (E_UnOp _) = preP
	| prec (E_PostOp _) = postP
	| prec (E_Apply _) = callP
	| prec (E_Subscript _) = postP
	| prec (E_Select _) = postP
	| prec (E_Indirect _) = postP
	| prec (E_Cast _) = unaryP
	| prec (E_Var _) = atomP
	| prec (E_Int _) = atomP
	| prec (E_Flt _) = atomP
	| prec (E_Bool _) = atomP
	| prec (E_Str _) = atomP
	| prec (E_Sizeof _) = callP
    in
    fun mkGrp e = if (prec e < atomP) then E_Grp e else e
    fun mkAssignOp (e1, rator, e2) = let
	  val e1' = if prec e1 < unaryP then E_Grp e1 else e1
	  val e2' = if prec e2 < assignP then E_Grp e2 else e2
	  in
	    E_AssignOp(e1', rator, e2')
	  end
  (* Note that all C binary operators are left associative. *)
    fun mkBinOp (e1, #-, e2 as E_UnOp(%-, _)) = let
	  val e1' = if prec e1 < addP then E_Grp e1 else e1
	  val e2' = E_Grp e2
	  in
	    E_BinOp(e1', #-, e2')
	  end
      | mkBinOp (e1, rator, e2) = let
	  val p = precOfBinop rator
	  val e1' = if prec e1 < p then E_Grp e1 else e1
	  val e2' = if prec e2 <= p then E_Grp e2 else e2
	  in
	    E_BinOp(e1', rator, e2')
	  end
    fun mkUnOp (%-, e as E_UnOp(%-, _)) = E_UnOp(%-, E_Grp e)
      | mkUnOp (%-, e as E_UnOp(%--, _)) = E_UnOp(%-, E_Grp e)
      | mkUnOp (%--, e as E_UnOp(%-, _)) = E_UnOp(%--, E_Grp e)
      | mkUnOp (%--, e as E_UnOp(%--, _)) = E_UnOp(%--, E_Grp e)
      | mkUnOp (rator, e) = if prec e < unaryP
	  then E_UnOp(rator, E_Grp e)
	  else E_UnOp(rator, e)
    fun mkPostOp (e, rator) = if prec e < postP
	  then E_PostOp(E_Grp e, rator)
	  else E_PostOp(e, rator)
    fun mkApply (f, args) = E_Apply(f, args)
    fun mkSubscript(e1, e2) = if prec e1 < postP
	  then E_Subscript(E_Grp e1, e2)
	  else E_Subscript(e1, e2)
    fun mkSelect (e, f) = if prec e < postP
	  then E_Select(E_Grp e, f)
	  else E_Select(e, f)
    fun mkIndirect (e, f) = if prec e < postP
	  then E_Indirect(E_Grp e, f)
	  else E_Indirect(e, f)
    fun mkCast (ty, e) = E_Cast(ty, e)
    val mkVar = E_Var
    fun mkInt (n, ty) = if n < 0 then E_UnOp(%-, E_Int(~n, ty)) else E_Int(n, ty)
    fun mkFlt (f, ty) = if FloatLit.isNeg f
	  then E_UnOp(%-, E_Flt(FloatLit.negate f, ty))
	  else E_Flt(f, ty)
    val mkBool = E_Bool
    val mkStr = E_Str
    val mkSizeof = E_Sizeof
    end (* local *)

    val skip = S_Block[]

    local
      fun paren (e as E_Grp _) = e
	| paren e = E_Grp e
    in
    val mkComment = S_Comment
    fun mkBlock [stm] = stm
      | mkBlock stms = S_Block stms
    val mkDecl = S_Decl
    val mkExpStm = S_Exp
    fun mkAssign (e1, e2) = S_Exp(mkAssignOp(e1, $=, e2))
    fun mkIfThenElse (e, b1, b2) = S_If(paren e, b1, b2)
    fun mkIfThen (e, b) = mkIfThenElse (e, b, skip)
    val mkFor = S_For
    fun mkWhile (e, b) = S_While(paren e, b)
    val mkCall = S_Call
    val mkReturn = S_Return
    val mkBreak = S_Break
    val mkContinue = S_Continue
    end (* local *)

  (* utility functions *)

    fun varToString x = x

    fun assignopToString rator = (case rator
	   of $= => "="
	    | += => "+="
	    | *= => "*="
	    | /= => "/="
	    | %= => "%="
	    | <<= => "<<="
	    | >>= => ">>="
	    | &= => "&="
	    | ^= => "^="
	    | |= => "|="
	  (* end case *))

    fun binopToString rator = (case rator
	   of #|| => "||"
	    | #&& => "&&"
	    | #== => "=="
	    | #!= => "!="
	    | #< => "<"
	    | #<= => "<="
	    | #>= => ">="
	    | #> => ">"
	    | #<< => "<<"
	    | #>> => ">>"
	    | #+ => "+"
	    | #- => "-"
	    | #* => "*"
	    | #/ => "/"
	    | #% => "%"
	  (* end case *))

    fun unopToString rator = (case rator
	   of %- => "-"
	    | %! => "!"
	    | %& => "&"
	    | %* => "*"
	    | %~ => "~"
	    | %++ => "++"
	    | %-- => "--"
	  (* end case *))

    fun postopToString rator = (case rator
	   of ^++ => "++"
	    | ^-- => "--"
	  (* end case *))

    fun expToString e = let
	  fun e2s (e, l) = (case e
	       of E_Grp e => "(" :: e2s(e, ")"::l)
		| E_AssignOp(e1, rator, e2) => e2s(e1, assignopToString rator :: e2s(e2, l))
		| E_BinOp(e1, rator, e2) => e2s(e1, binopToString rator :: e2s(e2, l))
		| E_UnOp(rator, e) => unopToString rator :: e2s(e, l)
		| E_PostOp(e, rator) => e2s(e, postopToString rator :: l)
		| E_Apply(f, es) => let
		    fun args2s ([], l) = l
		      | args2s ([e], l) = e2s(e, l)
		      | args2s (e::es, l) = e2s(e, ","::args2s(es, l))
		    in
		      f :: "(" :: args2s(es, ")"::l)
		    end
		| E_Subscript(e1, e2) => e2s(e1, "[" :: e2s(e2, "]"::l))
		| E_Select(e, f) => e2s(e, "." :: f :: l)
		| E_Indirect(e, f) => e2s(e, "->" :: f :: l)
		| E_Cast(ty, e) => "(ty)" :: e2s(e, l)  (* FIXME *)
		| E_Var x => x::l
		| E_Int(n, _) => IntegerLit.toString n :: l
		| E_Flt(f, _) => FloatLit.toString f :: l
		| E_Bool b => Bool.toString b :: l
		| E_Str s => concat["\"", String.toCString s, "\""] :: l
		| E_Sizeof ty => "sizeof(ty)" :: l
	      (* end case *))
	  in
	    String.concat(e2s(e, []))
	  end

  end

root@smlnj-gforge.cs.uchicago.edu
ViewVC Help
Powered by ViewVC 1.0.0