Add string pasting support to the gramamr.

[snipe.git] / trans / trans.sml

diff --git a/trans/trans.sml b/trans/trans.sml
index 6148ce82454349bb725d3f90267d49013e7a8486..ec66fd5f4507cb8df767ae89babaacbb572d5e72 100644 (file)
--- a/trans/trans.sml
+++ b/trans/trans.sml
@@ -10,14 +10,13 @@
 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 = 
 struct
 
   structure A = Ast
 end
 
 structure Trans :> TRANS = 
 struct
 
   structure A = Ast

-  structure AU = AstUtils

   structure T = Tree
   
   fun trans_oper A.PLUS = T.ADD
   structure T = Tree
   
   fun trans_oper A.PLUS = T.ADD


@@ -43,72 +42,24 @@ struct
   fun translate (defs, funcs) =
     let
       val funclist = Symbol.elemsi funcs
   fun translate (defs, funcs) =
     let
       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

 
 

-      val alignments = ref Symbol.empty  (* Ref for memoization. *)
-      fun alignment A.Int = 4
-        | alignment (A.Typedef(id)) =
-         (case Symbol.look (!alignments) id
-            of NONE =>
-              let
-                val r = alignment_s (Symbol.look' defs id)
-                val _ = (alignments := (Symbol.bind (!alignments) (id, r)))
-              in
-                r
-              end
-             | SOME r => r)
-        | alignment (A.Pointer(_)) = 8
-        | alignment (A.Array(_)) = 8
-        | alignment (A.TNull) = raise ErrorMsg.InternalError "alignmentof TNull?"
-      and alignment_s (A.Struct(members)) =
-            foldl
-              (fn ((_,t),al) => Int.max (al, alignment t))
-              1
-              members
-        | alignment_s (A.MarkedTypedef(a)) = alignment_s (Mark.data a)
-
-      fun align t curpos =
-        let
-          val al = alignment t
-        in
-          if (curpos mod al) = 0
-          then curpos
-          else curpos + al - (curpos mod al)
-        end
-
-      val sizes = ref Symbol.empty
-      fun sizeof_v A.Int = 4
-        | sizeof_v (A.Typedef(id)) =
-         (case Symbol.look (!sizes) id
-            of NONE =>
-              let
-                val r = sizeof_s (Symbol.look' defs id)
-                val _ = (sizes := (Symbol.bind (!sizes) (id, r)))
-              in
-                r
-              end
-             | SOME r => r)
-        | sizeof_v (A.Pointer(_)) = 8
-        | sizeof_v (A.Array(_)) = 8
-        | sizeof_v (A.TNull) = raise ErrorMsg.InternalError "sizeof TNull?"
-      and sizeof_s (A.Struct(l)) =
-          foldl
-            (fn ((_,t),curpos) => align t curpos + sizeof_v t)
-            0
-            l
-        | sizeof_s (A.MarkedTypedef(a)) = sizeof_s (Mark.data a)
-
-      fun offset_s id (A.Typedef(id')) =
+      fun offset_s id (Type.Typedef(id')) =

         let
           val shit = Symbol.look' defs id'
         let
           val shit = Symbol.look' defs id'

-          fun eat (A.Struct(l)) = l
-            | eat (A.MarkedTypedef(a)) = eat (Mark.data a)
+          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
           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_v t)
+              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
             end
             | offset_s' nil _ = raise ErrorMsg.InternalError "looking for offset of something that isn't in the structure"
         in


@@ -116,11 +67,11 @@ struct
         end
         | offset_s _ _ = raise ErrorMsg.InternalError "cannot find offset into non-typedef"
       
         end
         | offset_s _ _ = raise ErrorMsg.InternalError "cannot find offset into non-typedef"
       

-      fun type_s id (A.Typedef id') =
+      fun type_s id (Type.Typedef id') =

         let
           val td = 
         let
           val td = 

-            case AU.Typedef.data (Symbol.look' defs id')
-            of A.Struct d => d
+            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)
              | _ => raise ErrorMsg.InternalError "data didn't return struct"
           fun type_s' ((id',t)::l) =
             if (Symbol.compare (id, id') = EQUAL)


@@ -132,8 +83,8 @@ struct
         end
         | type_s id _ = raise ErrorMsg.InternalError "cannot find internal type non-typedef"
       
         end
         | type_s id _ = raise ErrorMsg.InternalError "cannot find internal type non-typedef"
       

-      fun deref (A.Pointer i) = i
-        | deref (A.Array i) = i
+      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
         | deref _ = raise ErrorMsg.InternalError "cannot deref non-pointer"
 
       fun trans_unop A.NEGATIVE = T.NEG


@@ -146,7 +97,9 @@ struct
       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)
       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)

+        | 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.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])) =
         | 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])) =


@@ -158,38 +111,85 @@ struct
         | trans_exp env vartypes (A.FuncCall(func, stms)) =
             T.CALL(func,
               List.map
         | trans_exp env vartypes (A.FuncCall(func, stms)) =
             T.CALL(func,
               List.map

-                (fn exp => (trans_exp env vartypes exp, AU.Type.size (typeof' vartypes exp)))
-                stms,
-              AU.Type.size (AU.Function.returntype (Symbol.look' funcs func)) )
+                (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))))
         | 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
             in

-             if (AU.Type.issmall (type_s id (typeof' vartypes exp)))
+             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)) =
              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 (AU.Type.issmall (deref (typeof' vartypes 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, 
             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, 

-                                  T.BINOP(T.MUL, trans_exp env vartypes exp2,
-                                          T.CONST(Word32.fromInt(sizeof_v (deref (typeof' 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
             in

-              if (AU.Type.issmall (deref (typeof' vartypes exp1)))
-              then T.MEMORY(asubk)
-              else asubk
+              if Type.issmall tipo
+              then T.MEMORY(d)
+              else d

             end
         | trans_exp env vartypes (A.New(tipo)) =
             end
         | trans_exp env vartypes (A.New(tipo)) =

-            T.ALLOC(T.CONST (Word32.fromInt(sizeof_v 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)) =
         | trans_exp env vartypes (A.NewArr(tipo, exp)) =

-            T.ALLOC(T.BINOP(T.MUL, trans_exp env vartypes exp, T.CONST(Word32.fromInt(sizeof_v tipo))))
-        | trans_exp env vartypes (A.Null) = T.CONST(0w0)
+            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 *)
 


@@ -198,23 +198,22 @@ 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 vartypes ls (A.Assign(e1,e2)::stms) = T.MOVE(trans_exp vars vartypes e1, trans_exp vars vartypes e2, AU.Type.size (typeof' vartypes e2))::(trans_stms vars vartypes ls 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
             val te1 = trans_exp vars vartypes e1
             val te2 = trans_exp vars vartypes e2
         | trans_stms vars vartypes ls (A.AsnOp(oop,e1,e2)::stms) =
           let
             val te1 = trans_exp vars vartypes e1
             val te2 = trans_exp vars vartypes e2

-            val t1 = T.TEMP (Temp.new "memory deref cache" 8)
-            val size = AU.Type.size (typeof' vartypes e2)
+            val t1 = T.TEMP (Temp.new "memory deref cache")

           in
             case te1
           in
             case te1

-            of T.MEMORY(m) => T.MOVE(t1, m, 8) :: T.MOVE (T.MEMORY(t1), T.BINOP(trans_oper oop, T.MEMORY(t1), te2), size) :: (trans_stms vars vartypes ls stms)
-             | _ => T.MOVE(te1, T.BINOP(trans_oper oop, te1, te2), size) :: (trans_stms vars vartypes ls stms)
+            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
         | trans_stms vars vartypes ls (A.Return e::stms) =
           let
             val remainder = trans_stms vars vartypes ls stms
           in 
           end
         | trans_stms vars vartypes ls (A.Return e::stms) =
           let
             val remainder = trans_stms vars vartypes ls stms
           in 

-            T.RETURN (trans_exp vars vartypes e, AU.Type.size (typeof' vartypes e))
+            T.RETURN (trans_exp vars vartypes e)

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


@@ -274,7 +273,7 @@ struct
             @ [T.JUMP head, T.LABEL tail]
             @ remainder)
           end
             @ [T.JUMP head, T.LABEL tail]
             @ remainder)
           end

-        | trans_stms vars vartypes ls (A.Effect(e)::stms) = (T.EFFECT (trans_exp vars vartypes e, AU.Type.size (typeof' vartypes e))) :: (trans_stms vars vartypes ls 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
             val remainder = trans_stms vars vartypes (SOME(b,e)) stms
         | trans_stms vars vartypes (SOME(b,e)) (A.Break::stms) =
           let
             val remainder = trans_stms vars vartypes (SOME(b,e)) stms


@@ -299,7 +298,7 @@ struct
             let
               val allvars = foldr
                               (fn ((name, t),b) =>
             let
               val allvars = foldr
                               (fn ((name, t),b) =>

-                                Symbol.bind b (name, Temp.new (Symbol.name(name)) (AU.Type.size t)))
+                                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)
                               Symbol.empty
                               (args @ vars)
               val vartypes = foldr (fn ((i, t), b) => Symbol.bind b (i, t)) Symbol.empty (args @ vars)


@@ -307,7 +306,7 @@ struct
               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, Temp.size (Symbol.look' allvars argname)), Temp.size (Symbol.look' allvars argname)))
+                (fn (n, argname) => T.MOVE(T.TEMP (Symbol.look' allvars argname), T.ARG (n)))

                 numberedargs
             in
               (T.FUNCTION(id, argmv @ b)) :: (trans_funcs l)
                 numberedargs
             in
               (T.FUNCTION(id, argmv @ b)) :: (trans_funcs l)