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

SCM Repository

[diderot] View of /branches/vis15/src/compiler/codegen/clang.sml
ViewVC logotype

View of /branches/vis15/src/compiler/codegen/clang.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 3927 - (download) (annotate)
Sat Jun 4 21:20:01 2016 UTC (3 years, 2 months ago) by jhr
File size: 15798 byte(s)
working on merge: code generation
(* clang.sml
 *
 * This code is part of the Diderot Project (http://diderot-language.cs.uchicago.edu)
 *
 * COPYRIGHT (c) 2015 The University of Chicago
 * All rights reserved.
 *
 * An tree representation of programs in a C-like language (e.g., C, C++, CUDA,
 * or OpenCL).
 *)

structure CLang =
  struct

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

    datatype ty
      = T_Num of RawTypes.t
      | T_Ptr of ty
      | T_RestrictPtr of ty	(* pointer type with "restrict" annotation *)
      | T_Array of ty * int option
      | T_Named of string
      | T_Template of string * ty list
      | T_Qual of attr * ty     (* qualified type *)

    datatype typed_var = V of ty * var

    val voidTy = T_Named "void"
    val voidPtr = T_Ptr voidTy
    val charTy = T_Named "char"
    val boolTy = T_Named "bool"
    val charPtr = T_Ptr charTy
    val charArrayPtr = T_Ptr charPtr
    val intTy = T_Named "int"
    val int8 = T_Num(RawTypes.RT_Int8)
    val uint8 = T_Num(RawTypes.RT_UInt8)
    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)

    datatype decl
      = D_Pragma of string list
      | 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
(* TODO: merge D_Proto and D_Func into one by making the body an option *)
    (* function prototype *)
      | D_Proto of attr list * ty * string * param list
    (* function definition *)
      | D_Func of attr list * ty * string * param list * stm
    (* class constructor definition or prototype:
     *     D_Constr(attrs, namespace, class, params, inits, body)
     * the inits should be of the form "id(exp)"
     *)
      | D_Constr of attr list * string option * string * param list * exp list * stm option
    (* class destructor definition or prototype *)
      | D_Destr of attr list * string option * string * stm option
    (* struct type declaration; if the third argument is SOME name, then a
     * typedef is generated.
     *)
      | D_StructDef of string option * (ty * string) list * string option
    (* C++ struct/class definition *)
      | D_ClassDef of {
	    name : string,		(* class/struct name *)
	    from : string option,	(* optional base class *)
	    public : decl list,
	    protected : decl list,
	    private : decl list
	  }

    and initializer
      = I_Exp of exp
      | I_Exps of initializer list
      | I_Struct of (string * initializer) list	(* C99 labeled struct initializer *)
      | I_Array of (int * initializer) list	(* C99 labeled array initializer *)
      | I_Cons of ty * exp list

    and param = PARAM of attr list * ty * var

    and stm
      = S_Block of stm list             (* "{" stms "}" *)
      | S_Comment of string list
      | S_Verbatim of string list
      | S_Decl of attr list * 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_DoWhile of stm * exp          (* 'do' stm 'while' exp *)
      | S_For of (ty * var * exp) list * exp * exp list * stm
                                        (* 'for' '(' inits ';' exp ';' incrs ')' stm *)
      | S_KernCall of string * exp list * exp list
					(* f "<<<" ... ">>>" "(" ... ")" [CUDA] *)
      | 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_Cond of exp * exp * exp       (* e "?" e ":" 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 exp * exp list	(* e "(" ... ")" *)
      | E_TApply of string * ty list * exp list
					(* f "<" ... ">" "(" ... ")" *)
      | E_Cons of ty * exp list		(* ty "(" ... ")" [C++,CUDA]*)
      | E_New of ty * exp list		(* "new" ty "(" ... ")" [C++,CUDA]*)
      | 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_XCast of string * ty * exp    (* "xxx_cast<" ty ">(" e ")"  [C++] *)
      | E_Vec of ty * exp list		(* vector-expression; syntax depends on target [C,OpenCL] *)
      | E_Var of var
      | E_Int of IntLit.t * ty
      | E_Flt of RealLit.t * ty
      | E_Bool of bool
      | E_Str of string
      | E_Char of char
      | 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 bxorP         = 6
      val bandP         = 7
      val eqP           = 8
      val relP          = 9
      val shiftP        = 10
      val addP          = 11
      val mulP          = 12
      val castP         = 13
      val unaryP        = 14
      val preP          = 15
      val compundP      = 16    (* compound literal *)
      val postP         = 17
      val callP         = 18
      val subP          = 19
      val atomP         = 20
      fun precOfBinop rator = (case rator
             of #|| => lorP
              | #&& => landP
              | #| => borP
              | #^ => bxorP
              | #& => bandP
              | #== => 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_Cond _) = condP
        | prec (E_BinOp(_, rator, _)) = precOfBinop rator
        | prec (E_UnOp _) = preP
        | prec (E_PostOp _) = postP
        | prec (E_Apply _) = callP
	| prec (E_TApply _) = callP
        | prec (E_Cons _) = callP (* check this *)
        | prec (E_New _) = callP (* check this *)
        | prec (E_Subscript _) = postP
        | prec (E_Select _) = postP
        | prec (E_Indirect _) = postP
        | prec (E_Cast _) = castP
        | prec (E_XCast _) = atomP
        | prec (E_Vec _) = castP
        | prec (E_Var _) = atomP
        | prec (E_Int _) = atomP
        | prec (E_Flt _) = atomP
        | prec (E_Bool _) = atomP
        | prec (E_Str _) = atomP
        | prec (E_Char _) = 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 we over-parenthesize here, but it makes nested conditionals easeier to read *)
    fun mkCond (e1, e2, e3) = E_Cond(
          if prec e1 <= condP then E_Grp e1 else e1,
          if prec e2 <= condP then E_Grp e2 else e2,
          if prec e3 < condP then E_Grp e3 else e3)
  (* 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 (%&, E_UnOp(%*, e)) = e
      | mkUnOp (%*, E_UnOp(%&, e)) = 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(E_Var f, args)
(* FIXME: check precedence *)
    fun mkApplyExp (e, args) = E_Apply(e, args)
    fun mkTemplateApply (f, tys, args) = E_TApply(f, tys, args)
    val mkCons = E_Cons
    val mkNew = E_New
    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 mkDispatch (e, meth, args) = mkApplyExp(mkSelect(e, meth), args)
    fun mkIndirectDispatch (e, meth, args) = mkApplyExp(mkIndirect(e, meth), args)
    fun mkCast (ty, e) = if prec e < castP
          then E_Cast(ty, E_Grp e)
          else E_Cast(ty, e)
    fun mkConstCast (ty, e) = E_XCast("const_cast", ty, e)
    fun mkDynamicCast (ty, e) = E_XCast("dynamic_cast", ty, e)
    fun mkReinterpretCast (ty, e) = E_XCast("reinterpret_cast", ty, e)
    fun mkStaticCast (ty, e) = E_XCast("static_cast", ty, e)
    val mkVec = E_Vec
    val mkVar = E_Var
    fun mkIntTy (n, ty) = if n < 0 then E_UnOp(%-, E_Int(~n, ty)) else E_Int(n, ty)
    fun mkInt n = mkIntTy(n, intTy)
    fun mkFlt (f, ty) = if RealLit.isNeg f
          then E_UnOp(%-, E_Flt(RealLit.negate f, ty))
          else E_Flt(f, ty)
    val mkBool = E_Bool
    val mkStr = E_Str
    val mkChar = E_Char
    val mkSizeof = E_Sizeof
    fun mkAddrOf x = mkUnOp(%&, x)
    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
    fun unBlock (S_Block stms) = stms
      | unBlock stm = [stm]
    fun prependStm (stm, blk) = mkBlock(stm :: unBlock blk)
    fun appendStm (blk, stm) = mkBlock(unBlock blk @ [stm])
    fun concatBlocks blocks = mkBlock(List.concat(List.map unBlock blocks))
    fun mkDecl (ty, x, init) = S_Decl([], ty, x, init)
    fun mkDeclInit (ty, x, init) = S_Decl([], ty, x, SOME(I_Exp init))
    val mkAttrDecl = S_Decl
    val mkExpStm = S_Exp
    fun mkAssign (e1, e2) = S_Exp(mkAssignOp(e1, $=, e2))
    fun mkAssign' (e1, rator, e2) = S_Exp(mkAssignOp(e1, rator, 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)
    fun mkDoWhile (b, e) = S_DoWhile(b, paren e)
    fun mkCall (f, args) = S_Exp(mkApply(f, args))
    fun mkCallExp (f, args) = S_Exp(mkApplyExp(f, args))
    fun mkTemplateCall (f, tys, args) = S_Exp(mkTemplateApply(f, tys, args))
    val mkKernCall = S_KernCall
    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 *))

  (* generate verbatim text from a template string by substituting for placeholders
   * Placeholders have the syntax @<id>@ and are replaced with the string associated
   * with <id> in the list of substitutions.  If <id> is empty, then no substitution
   * is applied, instead the "@@" is replaced by "@".
   *)
    local
      fun verbatim sl subs = List.map (StringSubst.expand subs) sl
    in
    fun verbatimDcl sl subs = D_Verbatim(verbatim sl subs)
    fun verbatimStm sl subs = S_Verbatim(verbatim sl subs)
    end (* local *)

  (* for debugging (not syntactically correct!) *)
    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_Cond(e1, e2, e3) => "(" :: e2s(e1, "?" :: e2s(e2, ":" :: e2s (e3, ")" :: 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(e, es) => e2s(e, "(" :: args2s(es, ")"::l))
		| E_TApply(f, tys, es) => f :: "<ty>" :: "(" :: args2s(es, ")"::l)
		| E_Cons(ty, es) => e2s(e, "ty(" :: args2s(es, ")"::l))
		| E_New(ty, es) => e2s(e, "new ty (" :: args2s(es, ")"::l))
                | 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: need tyToString *)
                | E_XCast(c, ty, e) => c :: "<ty>(" :: e2s(e, ")" :: l)  (* FIXME: need tyToString *)
                | E_Vec(ty, args) => "(vec)(" :: args2s(args, ")"::l)  (* FIXME: need tyToString *)
                | E_Var x => x::l
                | E_Int(n, _) => IntLit.toString n :: l
                | E_Flt(f, _) => RealLit.toString f :: l
                | E_Bool b => Bool.toString b :: l
                | E_Str s => "\"" :: String.toCString s :: "\"" :: l
                | E_Char c => "'" :: Char.toCString c :: "'" :: l
                | E_Sizeof ty => "sizeof(ty)" :: l
              (* end case *))
	  and args2s ([], l) = l
	    | args2s ([e], l) = e2s(e, l)
	    | args2s (e::es, l) = e2s(e, ","::args2s(es, l))
          in
            String.concat(e2s(e, []))
          end

  end

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