Add string pasting support to the gramamr.

[snipe.git] / trans / trans.sml

diff --git a/trans/trans.sml b/trans/trans.sml
index 80802be332d71daf4744d4458e2da0e93f7850d8..ec66fd5f4507cb8df767ae89babaacbb572d5e72 100644 (file)
--- a/trans/trans.sml
+++ b/trans/trans.sml
@@ -10,7 +10,7 @@
 signature TRANS =
 sig
   (* translate abstract syntax tree to IR tree *)
 signature TRANS =
 sig
   (* translate abstract syntax tree to IR tree *)

-  val translate : Ast.program -> Tree.func list
+  val translate : Ast.program -> Tree.program

 end
 
 structure Trans :> TRANS = 
 end
 
 structure Trans :> TRANS = 


@@ -39,31 +39,157 @@ struct
     | trans_oper A.GT = T.GT
     | trans_oper _ = raise ErrorMsg.InternalError "expected AST binop, got AST unop"
 
     | trans_oper A.GT = T.GT
     | trans_oper _ = raise ErrorMsg.InternalError "expected AST binop, got AST unop"
 

-  fun translate p =
+  fun translate (defs, funcs) =

     let
     let

-      val allfuncs = foldr (fn (A.Extern(_),b) => b
-                             | (A.Function(_, id, _, _, _), b) => Symbol.bind b (id, () ))
-                           Symbol.empty p
+      val funclist = Symbol.elemsi funcs
+      val _ = Type.alignment_reset()
+      val _ = Type.sizeof_reset()
+      fun sizeof a = Type.sizeof defs a
+      fun alignment a = Type.alignment defs a
+      fun align t curpos = Type.align defs t curpos
+
+      fun offset_s id (Type.Typedef(id')) =
+        let
+          val shit = Symbol.look' defs id'
+          fun eat (Type.Struct(l)) = l
+            | eat (Type.MarkedTypedef(a)) = eat (Mark.data a)
+          fun offset_s' ((id1,t)::l') curofs =
+            let
+              val a = align t curofs
+            in
+              if Symbol.compare(id,id1) = EQUAL
+                then a
+              else offset_s' l' (a + sizeof t)
+            end
+            | offset_s' nil _ = raise ErrorMsg.InternalError "looking for offset of something that isn't in the structure"
+        in
+          offset_s' (eat shit) 0
+        end
+        | offset_s _ _ = raise ErrorMsg.InternalError "cannot find offset into non-typedef"
+      
+      fun type_s id (Type.Typedef id') =
+        let
+          val td = 
+            case Type.defdata (Symbol.look' defs id')
+            of Type.Struct d => d
+             | _ => raise ErrorMsg.InternalError "data didn't return struct"
+          fun type_s' ((id',t)::l) =
+            if (Symbol.compare (id, id') = EQUAL)
+            then t
+            else type_s' l
+            | type_s' nil = raise ErrorMsg.InternalError "struct member not found in type_s"
+        in
+          type_s' td
+        end
+        | type_s id _ = raise ErrorMsg.InternalError "cannot find internal type non-typedef"
+      
+      fun deref (Type.Pointer i) = i
+        | deref (Type.Array i) = i
+        | deref _ = raise ErrorMsg.InternalError "cannot deref non-pointer"

 
       fun trans_unop A.NEGATIVE = T.NEG
         | trans_unop A.BITNOT = T.BITNOT
         | trans_unop A.BANG = T.BANG
         | trans_unop _ = raise ErrorMsg.InternalError "expected AST unop, got AST binop"
 
       fun trans_unop A.NEGATIVE = T.NEG
         | trans_unop A.BITNOT = T.BITNOT
         | trans_unop A.BANG = T.BANG
         | trans_unop _ = raise ErrorMsg.InternalError "expected AST unop, got AST binop"

+      
+      fun typeof' vartypes exp = TypeChecker.typeof (defs, funcs) vartypes NONE exp

 
 

-      fun trans_exp env (A.Var(id)) =
+      fun trans_exp env vartypes (A.Var(id)) =

         (* after type-checking, id must be declared; do not guard lookup *)
             T.TEMP (Symbol.look' env id)
         (* after type-checking, id must be declared; do not guard lookup *)
             T.TEMP (Symbol.look' env id)

-        | trans_exp env (A.ConstExp c) = T.CONST(c)
-        | trans_exp env (A.OpExp(oper, [e1, e2])) =
-            T.BINOP(trans_oper oper, trans_exp env e1, trans_exp env e2)
-        | trans_exp env (A.OpExp(oper, [e])) =
-            T.UNOP(trans_unop oper, trans_exp env e)
-        | trans_exp env (A.OpExp(oper, _)) =
+        | trans_exp env vartypes (A.Cast (ty, e)) = trans_exp env vartypes e (* lurrr *)
+        | trans_exp env vartypes (A.ConstExp c) = T.CONST(c)
+        | trans_exp env vartypes (A.StringExp s) = T.STRING(Stringref.new s)
+        | trans_exp env vartypes (A.OpExp(oper, [e1, e2])) =
+            T.BINOP(trans_oper oper, trans_exp env vartypes e1, trans_exp env vartypes e2)
+        | trans_exp env vartypes (A.OpExp(oper, [e])) =
+            T.UNOP(trans_unop oper, trans_exp env vartypes e)
+        | trans_exp env vartypes (A.OpExp(oper, _)) =

             raise ErrorMsg.InternalError "expected one or two operands, got it in the oven"
             raise ErrorMsg.InternalError "expected one or two operands, got it in the oven"

-        | trans_exp env (A.Marked(marked_exp)) =
-            trans_exp env (Mark.data marked_exp)
-        | trans_exp env (A.FuncCall(func, stms)) =
-            T.CALL(func, List.map (trans_exp env) stms)
+        | trans_exp env vartypes (A.Marked(marked_exp)) =
+            trans_exp env vartypes (Mark.data marked_exp)
+        | trans_exp env vartypes (A.FuncCall(func, stms)) =
+            T.CALL(func,
+              List.map
+                (fn exp => (trans_exp env vartypes exp))
+                stms)
+        | trans_exp env vartypes (A.Member (exp, id)) =
+            let
+              val apk = T.BINOP (T.ADD, trans_exp env vartypes exp, T.CONST (Word32.fromInt (offset_s id (typeof' vartypes exp))))
+              val tipo = type_s id (typeof' vartypes exp)
+            in
+             if Type.issmall tipo
+             then T.MEMORY(apk)
+             else apk
+           end
+        | trans_exp env vartypes (A.DerefMember (exp, id)) =
+            trans_exp env vartypes (A.Member (A.Dereference (exp), id))
+        | trans_exp env vartypes (A.Dereference(exp)) =
+            if (Type.issmall (deref (typeof' vartypes exp)))
+            then T.MEMORY(trans_exp env vartypes exp)
+            else trans_exp env vartypes exp
+        | trans_exp env vartypes (A.ArrIndex(exp1, exp2)) =
+            let
+              val asubk = T.BINOP(T.ADD, trans_exp env vartypes exp1, 
+                                  if sizeof (deref (typeof' vartypes exp1)) = 1
+                                  then trans_exp env vartypes exp2
+                                  else T.BINOP(T.MUL, trans_exp env vartypes exp2,
+                                               T.CONST(Word32.fromInt(sizeof (deref (typeof' vartypes exp1))))
+                                              )
+                                 )
+              val tipo = deref (typeof' vartypes exp1)
+              val d =
+                if not (Flag.isset Flags.safe)
+                then asubk
+                else T.COND (T.BINOP
+                              (T.BE,
+                               T.MEMORY (T.BINOP (
+                                 T.SUB,
+                                 trans_exp env vartypes exp1, 
+                                 T.CONST 0w8)),
+                               trans_exp env vartypes exp2),
+                             T.NULLPTR,
+                             asubk)
+            in
+              if Type.issmall tipo
+              then T.MEMORY(d)
+              else d
+            end
+        | trans_exp env vartypes (A.New(tipo)) =
+            let
+              val t1 = T.TEMP (Temp.new "result")
+            in
+              T.STMVAR (
+                [T.MOVE (t1, T.ALLOC (T.CONST (Word32.fromInt(sizeof tipo)))),
+                 T.EFFECT (T.MEMORY (t1))],
+                t1)
+            end
+        | trans_exp env vartypes (A.NewArr(tipo, exp)) =
+            let
+              val size = if (sizeof tipo) = 1
+                         then trans_exp env vartypes exp
+                         else T.BINOP(T.MUL, trans_exp env vartypes exp, T.CONST(Word32.fromInt(sizeof tipo)))
+              val t1 = T.TEMP (Temp.new "allocated address")
+              val ts = T.TEMP (Temp.new "size")
+            in
+              if not (Flag.isset Flags.safe)
+              then T.STMVAR ([T.MOVE (t1, T.ALLOC size),
+                              T.EFFECT (T.COND (T.BINOP (T.EQ, trans_exp env vartypes exp, T.CONST 0w0), T.CONST 0w0, T.MEMORY (t1)))],
+                             t1)
+              else T.COND (T.BINOP(T.EQ, size, T.CONST 0w0),
+                           T.NULLPTR,
+                           T.STMVAR (
+                             [T.MOVE(t1,
+                                T.COND(
+                                  T.BINOP(T.LT, size, T.CONST 0w0),
+                                  T.NULLPTR,
+                                  T.ALLOC (T.BINOP (T.ADD, size, T.CONST 0w8)))
+                                ),
+                              T.MOVE(T.MEMORY (t1), trans_exp env vartypes exp)],
+                             T.BINOP(T.ADD, t1, T.CONST 0w8)))
+            end
+        | trans_exp env vartypes (A.Null) = T.NULLPTR
+        | trans_exp env vartypes (A.Conditional(c,e1,e2)) = T.COND(trans_exp env vartypes c, trans_exp env vartypes e1, trans_exp env vartypes e2)

 
         (* anything else should be impossible *)
 
 
         (* anything else should be impossible *)
 


@@ -72,115 +198,122 @@ struct
        * we pass around the environment and the current loop context, if any
        * (usually called ls, which contains a continue label and a break label)
        *)
        * we pass around the environment and the current loop context, if any
        * (usually called ls, which contains a continue label and a break label)
        *)

-      fun trans_stms vars ls (A.Assign(id,e)::stms) =
+      fun trans_stms vars vartypes ls (A.Assign(e1,e2)::stms) = T.MOVE(trans_exp vars vartypes e1, trans_exp vars vartypes e2)::(trans_stms vars vartypes ls stms)
+        | trans_stms vars vartypes ls (A.AsnOp(oop,e1,e2)::stms) =

           let
           let

-            val t = Symbol.look' vars id handle Option => raise ErrorMsg.InternalError "Undeclared variable, should have been caught in typechecker..."
-            val remainder = trans_stms vars ls stms
+            val te1 = trans_exp vars vartypes e1
+            val te2 = trans_exp vars vartypes e2
+            val t1 = T.TEMP (Temp.new "memory deref cache")

           in
           in

-            T.MOVE(T.TEMP(t), trans_exp vars e)
-            :: remainder
+            case te1
+            of T.MEMORY(m) => T.MOVE(t1, m) :: T.MOVE (T.MEMORY(t1), T.BINOP(trans_oper oop, T.MEMORY(t1), te2)) :: (trans_stms vars vartypes ls stms)
+             | _ => T.MOVE(te1, T.BINOP(trans_oper oop, te1, te2)) :: (trans_stms vars vartypes ls stms)

           end
           end

-        | trans_stms vars ls (A.Return e::stms) =
+        | trans_stms vars vartypes ls (A.Return e::stms) =

           let
           let

-            val remainder = trans_stms vars ls stms
+            val remainder = trans_stms vars vartypes ls stms

           in 
           in 

-            T.RETURN (trans_exp vars e)
+            T.RETURN (trans_exp vars vartypes e)

             :: remainder
           end
             :: remainder
           end

-        
-        | trans_stms vars ls (A.If(e, s, NONE)::stms) =
+        | trans_stms vars vartypes ls (A.If(e, s, NONE)::stms) =

           let
             val l = Label.new ()
           let
             val l = Label.new ()

-            val strans = trans_stms vars ls s
-            val remainder = trans_stms vars ls stms
+            val strans = trans_stms vars vartypes ls s
+            val remainder = trans_stms vars vartypes ls stms

           in
           in

-            (T.JUMPIFN(trans_exp vars e, l)
+            (T.JUMPIFN(trans_exp vars vartypes e, l)

             :: strans
             @ [T.LABEL (l)]
             @ remainder)
           end
             :: strans
             @ [T.LABEL (l)]
             @ remainder)
           end

-        | trans_stms vars ls (A.If(e, s, SOME s2)::stms) =
+        | trans_stms vars vartypes ls (A.If(e, s, SOME s2)::stms) =

           let
             val l = Label.new ()
             val l2 = Label.new ()
           let
             val l = Label.new ()
             val l2 = Label.new ()

-            val s1trans = trans_stms vars ls s
-            val s2trans = trans_stms vars ls s2
-            val remainder = trans_stms vars ls stms
+            val s1trans = trans_stms vars vartypes ls s
+            val s2trans = trans_stms vars vartypes ls s2
+            val remainder = trans_stms vars vartypes ls stms

           in
           in

-            (T.JUMPIFN(trans_exp vars e, l)
+            (T.JUMPIFN(trans_exp vars vartypes e, l)

             :: s1trans
             @ [T.JUMP (l2), T.LABEL (l)]
             @ s2trans
             @ [T.LABEL (l2)]
             @ remainder)
           end
             :: s1trans
             @ [T.JUMP (l2), T.LABEL (l)]
             @ s2trans
             @ [T.LABEL (l2)]
             @ remainder)
           end

-        | trans_stms vars ls (A.For(s1, e, s2, s)::stms) = 
+        | trans_stms vars vartypes ls (A.For(s1, e, s2, s)::stms) = 

           let
             val head = Label.new ()
             val tail = Label.new ()
             val loop = Label.new ()
           let
             val head = Label.new ()
             val tail = Label.new ()
             val loop = Label.new ()

-            val stm1 = if isSome s1 then trans_stms vars NONE [valOf s1] else nil
-            val strans = trans_stms vars (SOME(loop,tail)) s
-            val stm2 = if isSome s2 then trans_stms vars NONE [valOf s2] else nil
-            val remainder = trans_stms vars ls stms
+            val stm1 = if isSome s1 then trans_stms vars vartypes NONE [valOf s1] else nil
+            val strans = trans_stms vars vartypes (SOME(loop,tail)) s
+            val stm2 = if isSome s2 then trans_stms vars vartypes NONE [valOf s2] else nil
+            val remainder = trans_stms vars vartypes ls stms

           in
             (stm1
           in
             (stm1

-            @ [T.LABEL head, T.JUMPIFN(trans_exp vars e, tail)]
+            @ [T.LABEL head, T.JUMPIFN(trans_exp vars vartypes e, tail)]

             @ strans
             @ [T.LABEL loop]
             @ stm2
             @ [T.JUMP head, T.LABEL tail]
             @ remainder)
           end
             @ strans
             @ [T.LABEL loop]
             @ stm2
             @ [T.JUMP head, T.LABEL tail]
             @ remainder)
           end

-        | trans_stms vars ls (A.While(e, s)::stms) =
+        | trans_stms vars vartypes ls (A.While(e, s)::stms) =

           let
             val head = Label.new ()
             val tail = Label.new ()
           let
             val head = Label.new ()
             val tail = Label.new ()

-            val strans = trans_stms vars (SOME(head,tail)) s
-            val remainder = trans_stms vars ls stms
+            val strans = trans_stms vars vartypes (SOME(head,tail)) s
+            val remainder = trans_stms vars vartypes ls stms

           in
             (T.LABEL head
           in
             (T.LABEL head

-            :: T.JUMPIFN(trans_exp vars e, tail)
+            :: T.JUMPIFN(trans_exp vars vartypes e, tail)

             :: strans
             @ [T.JUMP head, T.LABEL tail]
             @ remainder)
           end
             :: strans
             @ [T.JUMP head, T.LABEL tail]
             @ remainder)
           end

-
-        | trans_stms vars (SOME(b,e)) (A.Break::stms) =
+        | trans_stms vars vartypes ls (A.Effect(e)::stms) = (T.EFFECT (trans_exp vars vartypes e)) :: (trans_stms vars vartypes ls stms)
+        | trans_stms vars vartypes (SOME(b,e)) (A.Break::stms) =

           let
           let

-            val remainder = trans_stms vars (SOME(b,e)) stms
+            val remainder = trans_stms vars vartypes (SOME(b,e)) stms

           in
             ((T.JUMP e) :: remainder)
           end
           in
             ((T.JUMP e) :: remainder)
           end

-        | trans_stms vars  NONE       (A.Break::_) = raise ErrorMsg.InternalError "Break from invalid location... should have been caught in typechecker"
-        | trans_stms vars (SOME(b,e)) (A.Continue::stms) =
+        | trans_stms vars vartypes  NONE       (A.Break::_) = raise ErrorMsg.InternalError "Break from invalid location... should have been caught in typechecker"
+        | trans_stms vars vartypes (SOME(b,e)) (A.Continue::stms) =

           let
           let

-            val remainder = trans_stms vars (SOME(b,e)) stms
+            val remainder = trans_stms vars vartypes (SOME(b,e)) stms

           in
             ((T.JUMP b) :: remainder)
           end
           in
             ((T.JUMP b) :: remainder)
           end

-        | trans_stms vars  NONE       (A.Continue::_) = raise ErrorMsg.InternalError "Continue from invalid location... should have been caught in typechecker"
-        | trans_stms vars ls (A.Nop::stms) = trans_stms vars ls stms
-        | trans_stms vars ls (A.MarkedStm m :: stms) = trans_stms vars ls ((Mark.data m) :: stms)
-        | trans_stms vars _ nil = nil
+        | trans_stms vars vartypes  NONE       (A.Continue::_) = raise ErrorMsg.InternalError "Continue from invalid location... should have been caught in typechecker"
+        | trans_stms vars vartypes ls (A.Nop::stms) = trans_stms vars vartypes ls stms
+        | trans_stms vars vartypes ls (A.MarkedStm m :: stms) = trans_stms vars vartypes ls ((Mark.data m) :: stms)
+        | trans_stms vars vartypes _ nil = nil

 
 

-      fun trans_funcs (A.Extern(t, id, varl)::l) = trans_funcs l
-        | trans_funcs (A.Function(t, id, args, vars, body)::l) = 
+      fun trans_funcs ((id, A.Extern(_, _))::l) = trans_funcs l
+        | trans_funcs ((id, A.MarkedFunction a)::l) = trans_funcs ((id, Mark.data a)::l)
+        | trans_funcs ((id, A.Function(t, args, vars, body))::l) =

             let
             let

-              val (a,_) = ListPair.unzip (args @ vars)
-              val allvars = foldr (fn (a,b) => Symbol.bind b (a, Temp.new(Symbol.name(a)))) Symbol.empty a
-              val b = trans_stms allvars NONE body
+              val allvars = foldr
+                              (fn ((name, t),b) =>
+                                Symbol.bind b (name, Temp.new (Symbol.name(name))))
+                              Symbol.empty
+                              (args @ vars)
+              val vartypes = foldr (fn ((i, t), b) => Symbol.bind b (i, t)) Symbol.empty (args @ vars)
+              val b = trans_stms allvars vartypes NONE body

               val (argn,_) = ListPair.unzip args
               val numberedargs = ListPair.zip (List.tabulate (length argn, fn x => x), argn)
               val argmv = map
               val (argn,_) = ListPair.unzip args
               val numberedargs = ListPair.zip (List.tabulate (length argn, fn x => x), argn)
               val argmv = map

-                (fn (n, argname) => T.MOVE(T.TEMP (Symbol.look' allvars argname), T.ARG n))
+                (fn (n, argname) => T.MOVE(T.TEMP (Symbol.look' allvars argname), T.ARG (n)))

                 numberedargs
             in
               (T.FUNCTION(id, argmv @ b)) :: (trans_funcs l)
             end
         | trans_funcs nil = nil
                 numberedargs
             in
               (T.FUNCTION(id, argmv @ b)) :: (trans_funcs l)
             end
         | trans_funcs nil = nil

+

     in
     in

-      trans_funcs p
+      trans_funcs funclist

     end
     end

-

 end
 end