[MLton-devel] cvs commit: card maps and machine IL semantics change

Matthew Fluet fluet@users.sourceforge.net
Tue, 30 Jul 2002 09:53:44 -0700


fluet       02/07/30 09:53:44

  Modified:    mlton/atoms prim.fun prim.sig
               mlton/backend array-init.fun backend.fun machine.fun
                        rssa.fun rssa.sig ssa-to-rssa.fun
  Log:
  Changed the semantics of the machine IL back so that ArrayOffset does
  the dereference.  ArrayOffset addresses that are needed for the card
  map are computed explicitly.  C-codegen and x86-codegen both pass
  regressions and x86-codegen passes self-compile.

Revision  Changes    Path
1.33      +1 -0      mlton/mlton/atoms/prim.fun

Index: prim.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/prim.fun,v
retrieving revision 1.32
retrieving revision 1.33
diff -u -r1.32 -r1.33
--- prim.fun	30 Jul 2002 02:48:32 -0000	1.32
+++ prim.fun	30 Jul 2002 16:53:43 -0000	1.33
@@ -569,6 +569,7 @@
    in
       val intAdd = make Name.Int_add
       val intAddCheck = make Name.Int_addCheck
+      val intMul = make Name.Int_mul
       val intMulCheck = make Name.Int_mulCheck
       val intSubCheck = make Name.Int_subCheck
    end



1.27      +1 -0      mlton/mlton/atoms/prim.sig

Index: prim.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/prim.sig,v
retrieving revision 1.26
retrieving revision 1.27
diff -u -r1.26 -r1.27
--- prim.sig	30 Jul 2002 02:48:32 -0000	1.26
+++ prim.sig	30 Jul 2002 16:53:43 -0000	1.27
@@ -286,6 +286,7 @@
       val intInfEqual: t
       val intAdd: t
       val intAddCheck: t
+      val intMul: t
       val intMulCheck: t
       val intSubCheck: t
       val isCommutative: t -> bool



1.10      +3 -5      mlton/mlton/backend/array-init.fun

Index: array-init.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/array-init.fun,v
retrieving revision 1.9
retrieving revision 1.10
diff -u -r1.9 -r1.10
--- array-init.fun	30 Jul 2002 02:48:32 -0000	1.9
+++ array-init.fun	30 Jul 2002 16:53:43 -0000	1.10
@@ -28,11 +28,9 @@
 	    val loopStatements =
 	       Vector.new3
 	       (Statement.Move
-		{dst = (Operand.ArrayOffset
-			{base = Operand.Var {var = array,
-					     ty = Type.pointer},
-			 index = i,
-			 ty = Type.pointer}),
+		{dst = Operand.ArrayOffset {base = array,
+					    index = i,
+					    ty = Type.pointer},
 		 src = Operand.Pointer 1},
 		Statement.PrimApp
 		{args = Vector.new2 (Operand.Var {var = i, ty = Type.int},



1.34      +2 -2      mlton/mlton/backend/backend.fun

Index: backend.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/backend.fun,v
retrieving revision 1.33
retrieving revision 1.34
diff -u -r1.33 -r1.34
--- backend.fun	30 Jul 2002 02:48:32 -0000	1.33
+++ backend.fun	30 Jul 2002 16:53:43 -0000	1.34
@@ -369,7 +369,7 @@
 	       ArrayHeader z =>
 		  M.Operand.Uint (Runtime.typeIndexToHeader (arrayTypeIndex z))
 	     | ArrayOffset {base, index, ty} =>
-		  M.Operand.ArrayOffset {base = translateOperand base,
+		  M.Operand.ArrayOffset {base = varOperand base,
 					 index = varOperand index,
 					 ty = ty}
 	     | CastInt z => M.Operand.CastInt (translateOperand z)
@@ -381,7 +381,7 @@
 	     | GCState => M.Operand.GCState
 	     | Line => M.Operand.Line
 	     | Offset {base, bytes, ty} =>
-		  M.Operand.Offset {base = translateOperand base,
+		  M.Operand.Offset {base = varOperand base,
 				    offset = bytes,
 				    ty = ty}
 	     | Pointer n => M.Operand.Pointer n



1.26      +1 -1      mlton/mlton/backend/machine.fun

Index: machine.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/machine.fun,v
retrieving revision 1.25
retrieving revision 1.26
diff -u -r1.25 -r1.26
--- machine.fun	30 Jul 2002 02:48:33 -0000	1.25
+++ machine.fun	30 Jul 2002 16:53:44 -0000	1.26
@@ -140,7 +140,7 @@
     val layout = Layout.str o toString
 
     val ty =
-       fn ArrayOffset _ => Type.pointer
+       fn ArrayOffset {ty, ...} => ty
 	| CastInt _ => Type.int
 	| CastWord _ => Type.word
 	| Char _ => Type.char



1.16      +9 -9      mlton/mlton/backend/rssa.fun

Index: rssa.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/rssa.fun,v
retrieving revision 1.15
retrieving revision 1.16
diff -u -r1.15 -r1.16
--- rssa.fun	30 Jul 2002 02:48:33 -0000	1.15
+++ rssa.fun	30 Jul 2002 16:53:44 -0000	1.16
@@ -21,7 +21,7 @@
       datatype t =
 	 ArrayHeader of {numBytesNonPointers: int,
 			 numPointers: int}
-       | ArrayOffset of {base: t,
+       | ArrayOffset of {base: Var.t,
 			 index: Var.t,
 			 ty: Type.t}
        | CastInt of t
@@ -31,7 +31,7 @@
        | File
        | GCState
        | Line
-       | Offset of {base: t,
+       | Offset of {base: Var.t,
 		    bytes: int,
 		    ty: Type.t}
        | Pointer of int
@@ -53,7 +53,7 @@
 		       ")"]
 	  | ArrayOffset {base, index, ty} =>
 	       concat ["X", Type.name ty, 
-		       "(", toString base, ",", Var.toString index, ")"]
+		       "(", Var.toString base, ",", Var.toString index, ")"]
 	  | CastInt z => concat ["CastInt ", toString z]
 	  | CastWord z => concat ["CastWord ", toString z]
 	  | Const c => Const.toString c
@@ -63,7 +63,7 @@
 	  | Line => "<Line>"
 	  | Offset {base, bytes, ty} =>
 	       concat ["O", Type.name ty,
-		       "(", toString base, ",", Int.toString bytes, ")"]
+		       "(", Var.toString base, ",", Int.toString bytes, ")"]
 	  | Pointer n => concat ["IntAsPointer (", Int.toString n, ")"]
 	  | Runtime r => GCField.toString r
 	  | Var {var, ...} => Var.toString var
@@ -80,7 +80,7 @@
 
       val ty =
 	 fn ArrayHeader _ => Type.word
-	  | ArrayOffset _ => Type.pointer
+	  | ArrayOffset {ty, ...} => ty
 	  | CastInt _ => Type.int
 	  | CastWord _ => Type.word
 	  | Const c =>
@@ -115,10 +115,10 @@
 
       fun 'a foldVars (z: t, a: 'a, f: Var.t * 'a -> 'a): 'a =
 	 case z of
-	    ArrayOffset {base, index, ...} => f (index, foldVars (base, a, f))
+	    ArrayOffset {base, index, ...} => f (index, f (base, a))
 	  | CastInt z => foldVars (z, a, f)
 	  | CastWord z => foldVars (z, a, f)
-	  | Offset {base, ...} => foldVars (base, a, f)
+	  | Offset {base, ...} => f (base, a)
 	  | Var {var, ...} => f (var, a)
 	  | _ => a
 
@@ -778,7 +778,7 @@
 			    nbnp >= 0 andalso np >= 0
 			    
 		       | ArrayOffset {base, index, ty} =>
-			    Type.equals (Operand.ty base, Type.pointer)
+			    Type.equals (varType base, Type.pointer)
 			    andalso Type.equals (varType index, Type.int)
 		       | CastInt z => Type.equals (Operand.ty z, Type.pointer)
 		       | CastWord z => Type.equals (Operand.ty z, Type.pointer)
@@ -788,7 +788,7 @@
 		       | GCState => true
 		       | Line => true
 		       | Offset {base, ...} =>
-			    Type.equals (Operand.ty base, Type.pointer)
+			    Type.equals (varType base, Type.pointer)
 		       | Pointer n => 0 < Int.rem (n, Runtime.wordSize)
 		       | Runtime _ => true
 		       | Var {ty, var} => Type.equals (ty, varType var)



1.15      +3 -3      mlton/mlton/backend/rssa.sig

Index: rssa.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/rssa.sig,v
retrieving revision 1.14
retrieving revision 1.15
diff -u -r1.14 -r1.15
--- rssa.sig	30 Jul 2002 02:48:33 -0000	1.14
+++ rssa.sig	30 Jul 2002 16:53:44 -0000	1.15
@@ -57,7 +57,7 @@
 	    datatype t =
 	       ArrayHeader of {numBytesNonPointers: int,
 			       numPointers: int}
-	     | ArrayOffset of {base: t,
+	     | ArrayOffset of {base: Var.t,
 			       index: Var.t,
 			       ty: Type.t}
 	     | CastInt of t
@@ -73,7 +73,7 @@
 	     | File (* expand by codegen into string constant *)
 	     | GCState
 	     | Line (* expand by codegen into int constant *)
-	     | Offset of {base: t,
+	     | Offset of {base: Var.t,
 			  bytes: int,
 			  ty: Type.t}
 	     | Pointer of int (* the int must be nonzero mod Runtime.wordSize. *)
@@ -82,9 +82,9 @@
 		       ty: Type.t}
 
 	    val bool: bool -> t
-	    val char: char -> t
 	    val caseBytes: t * {big: t -> 'a,
 				small: word -> 'a} -> 'a
+	    val char: char -> t
 	    val int: int -> t
 	    val layout: t -> Layout.t
 	    val foreachVar: t * (Var.t -> unit) -> unit



1.20      +80 -57    mlton/mlton/backend/ssa-to-rssa.fun

Index: ssa-to-rssa.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/ssa-to-rssa.fun,v
retrieving revision 1.19
retrieving revision 1.20
diff -u -r1.19 -r1.20
--- ssa-to-rssa.fun	30 Jul 2002 02:48:33 -0000	1.19
+++ ssa-to-rssa.fun	30 Jul 2002 16:53:44 -0000	1.20
@@ -321,7 +321,6 @@
 				    | ConRep.Tuple => true
 				    | _ => false)
 	    val {info = {offsets, ...}, ...} = conInfo con
-	    val variant = Var {var = variant, ty = Type.pointer}
 	 in
 	    Vector.keepAllMap (offsets, fn off =>
 			       Option.map (off, fn {offset, ty} =>
@@ -457,8 +456,7 @@
 			    ((n, tail (j, conSelects (test, c))) :: cases,
 			     numLeft - 1)
 		       | _ => (cases, numLeft))
-	       in switch {test = Offset {base = Var {var = test,
-						     ty = Type.pointer},
+	       in switch {test = Offset {base = test,
 					 bytes = tagOffset,
 					 ty = Type.int},
 			  cases = Cases.Int cases,
@@ -757,42 +755,6 @@
 			add (Bind {isMutable = false,
 				   oper = oper,
 				   var = valOf var})
-		     fun assign (ty, {dst, src}) =
-			let
-			   val s = Move {dst = Operand.Offset {base = dst,
-							       bytes = 0,
-							       ty = ty},
-					 src = src}
-			in
-			   if Type.isPointer ty
-			      then
-				 let
-				    val index = Var.newNoname ()
-				    val ss =
-				       (PrimApp
-					{args = (Vector.new2
-						 (Operand.CastWord dst,
-						  Operand.word
-						  Runtime.bytesPerCardLog2)),
-					 dst = SOME (index, Type.int),
-					 prim = Prim.word32Rshift})
-				       :: (Move
-					   {dst = (Operand.Offset
-						   {base = 
-						    Operand.ArrayOffset
-						    {base = Operand.Runtime GCField.CardMap,
-						     index = index,
-						     ty = Type.char},
-						    bytes = 0,
-						    ty = Type.char}),
-					    src = Operand.char #"\001"})
-				       :: s
-				       :: ss
-				 in
-				    loop (i - 1, ss, t)
-				 end
-			   else add s
-			end
 		  in
 		     case exp of
 			S.Exp.ConApp {con, args} =>
@@ -812,13 +774,10 @@
 			      fun a i = Vector.sub (args, i)
 			      fun targ () = toType (Vector.sub (targs, 0))
 			      fun arrayOffset (ty: Type.t): Operand.t =
-				 ArrayOffset {base = varOp (a 0),
+				 ArrayOffset {base = a 0,
 					      index = a 1,
 					      ty = ty}
-			      fun sub (ty: Type.t) =
-				 move (Offset {base = arrayOffset ty,
-					       bytes = 0,
-					       ty = ty})
+			      fun sub (ty: Type.t) = move (arrayOffset ty)
 			      fun dst () =
 				 case var of
 				    SOME x =>
@@ -915,6 +874,79 @@
 					     numPointers = 0})),
 				   dst = dst (),
 				   prim = Prim.arrayAllocate})
+
+
+		     fun updateCard (addr, prefix, assign) =
+		        let
+			   val index = Var.newNoname ()
+			   val map = Var.newNoname ()
+			   val ss = 
+			      (PrimApp
+			       {args = (Vector.new2
+					(Operand.CastWord addr,
+					 Operand.word
+					 Runtime.bytesPerCardLog2)),
+				dst = SOME (index, Type.int),
+				prim = Prim.word32Rshift})
+			      :: (Bind {isMutable = false,
+					oper = Operand.Runtime GCField.CardMap,
+					var = map})
+			      :: (Move
+				  {dst = (Operand.ArrayOffset
+					  {base = map,
+					   index = index,
+					   ty = Type.char}),
+				   src = Operand.char #"\001"})
+			      :: assign
+			      :: ss
+			in
+			  loop (i - 1, prefix ss, t)
+			end
+		     fun arrayUpdate (ty, src) =
+		        if Type.isPointer ty
+			   then let
+				   val temp = Var.newNoname ()
+				   val tempOp = Operand.Var {var = temp,
+							     ty = Type.int}
+				   val addr = Var.newNoname ()
+				   val addrOp = Operand.Var {var = addr,
+							     ty = Type.pointer}
+				   fun prefix ss =
+				      (PrimApp
+				       {args = Vector.new2
+					       (varOp (a 1),
+					        Operand.int (Type.size ty)),
+				        dst = SOME (temp, Type.int),
+				        prim = Prim.intMul})
+				      :: (PrimApp
+					  {args = Vector.new2 (varOp (a 0), tempOp),
+					   dst = SOME (addr, Type.pointer),
+					   prim = Prim.intAdd})
+				      :: ss
+				   val assign = Move {dst = Operand.Offset
+						            {base = addr,
+							     bytes = 0,
+							     ty = ty},
+						      src = src}
+				in
+				   updateCard (addrOp, prefix, assign)
+				end
+			else add (Move {dst = arrayOffset ty,
+					src = src})
+		     fun refAssign (ty, src) =
+		        let
+			   val addr = a 0
+			   val assign = Move {dst = Operand.Offset {base = addr,
+								    bytes = 0,
+								    ty = ty},
+					      src = src}
+			in
+			   if Type.isPointer ty
+			      then updateCard (varOp addr, fn ss => ss, assign)
+			   else loop (i - 1, assign::ss, t)
+			end
+
+
 			      datatype z = datatype Prim.Name.t
 			   in
 			      case Prim.name prim of
@@ -1077,10 +1109,7 @@
 			       | Array_update =>
 				    (case targ () of
 					NONE => none ()
-				      | SOME t =>
-					   assign
-					   (t, {dst = arrayOffset t,
-						src = varOp (a 2)}))
+				      | SOME ty => arrayUpdate (ty, varOp (a 2)))
 			       | FFI name =>
 				    if Option.isNone (Prim.numArgs prim)
 				       then normal ()
@@ -1155,17 +1184,12 @@
 			       | Ref_assign =>
 				    (case targ () of
 					NONE => none ()
-				      | SOME ty =>
-					   assign
-					   (ty, {dst = Var {var = a 0,
-							    ty = Type.pointer},
-						 src = varOp (a 1)}))
+				      | SOME ty => refAssign (ty, varOp (a 1)))
 			       | Ref_deref =>
 				    (case targ () of
 					NONE => none ()
 				      | SOME ty =>
-					   move (Offset {base = Var {var = a 0,
-								     ty = Type.pointer},
+					   move (Offset {base = a 0,
 							 bytes = 0,
 							 ty = ty}))
 			       | Ref_ref =>
@@ -1305,8 +1329,7 @@
 					     offset) of
 			       NONE => none ()
 			     | SOME {offset, ty} =>
-				  move (Offset {base = Var {var = tuple,
-							    ty = Type.pointer},
+				  move (Offset {base = tuple,
 						bytes = offset,
 						ty = ty}))
 		      | S.Exp.SetExnStackLocal => add SetExnStackLocal





-------------------------------------------------------
This sf.net email is sponsored by: Dice - The leading online job board
for high-tech professionals. Search and apply for tech jobs today!
http://seeker.dice.com/seeker.epl?rel_code=31
_______________________________________________
MLton-devel mailing list
MLton-devel@lists.sourceforge.net
https://lists.sourceforge.net/lists/listinfo/mlton-devel