Massive simplification of math array allocation

patches a bug with array allocation of var-pars
potentially patches a GC bug with tensors


git-svn-id: https://svn.inf.ethz.ch/svn/lecturers/a2/trunk@7144 8c9fc860-2736-0410-a75d-ab315db34111

source/FoxArrayBase.Mod

@@ -90,6 +90,44 @@ TYPE
 	FastMatMul* = PROCEDURE ( matrixA, matrixB, matrixC, IncA, StrideA, IncB, StrideB, IncC, StrideC, RowsA, ColsA, RowsB, ColsB: LONGINT ): BOOLEAN;
 	TransposeP* = PROCEDURE ( ladr, dadr, lstride, linc, dstride, dinc, rows, cols: LONGINT );
 
+	LenInc = RECORD
+		len: SIZE;
+		inc: SIZE
+	END;
+
+	ArrayDescriptor*= RECORD
+		ptr: ANY;
+		adr: ADDRESS;
+		flags: SET;
+		dim: SIZE;
+		elementSize: SIZE;
+	END;
+	
+	UnsafeArray*= POINTER {UNSAFE} TO RECORD(ArrayDescriptor)
+		lens: ARRAY 8 OF LenInc;
+	END;
+	
+	A0 = RECORD(ArrayDescriptor) END;
+	A1 = RECORD(ArrayDescriptor) lens : ARRAY 1 OF LenInc; END;
+	A2 = RECORD(ArrayDescriptor) lens : ARRAY 2 OF LenInc; END;
+	A3 = RECORD(ArrayDescriptor) lens : ARRAY 3 OF LenInc; END;
+	A4 = RECORD(ArrayDescriptor) lens : ARRAY 4 OF LenInc; END;
+	A5 = RECORD(ArrayDescriptor) lens : ARRAY 5 OF LenInc; END;
+	A6 = RECORD(ArrayDescriptor) lens : ARRAY 6 OF LenInc; END;
+	A7 = RECORD(ArrayDescriptor) lens : ARRAY 7 OF LenInc; END;
+	A8 = RECORD(ArrayDescriptor) lens : ARRAY 8 OF LenInc; END;
+	
+	T0 = POINTER TO A0;
+	T1 = POINTER TO A1;
+	T2 = POINTER TO A2;
+	T3 = POINTER TO A3;
+	T4 = POINTER TO A4;
+	T5 = POINTER TO A5;
+	T6 = POINTER TO A6;
+	T7 = POINTER TO A7;
+	T8 = POINTER TO A8;
+	
+	(*
 	(* tensor shape descriptors, statically typed, maximal dimension of a tensor limited to 32 for the time being *)
 	T0 = POINTER TO RECORD ptr: ANY; a: ARRAY MathLenOffset + 0* 8 OF CHAR END;
 	T1 = POINTER TO RECORD ptr: ANY; a:ARRAY MathLenOffset + 1 * 8 OF CHAR END;
@@ -100,6 +138,7 @@ TYPE
 	T6 = POINTER TO RECORD ptr: ANY; a:ARRAY MathLenOffset + 6 * 8 OF CHAR END;
 	T7 = POINTER TO RECORD ptr: ANY; a:ARRAY MathLenOffset + 7 * 8 OF CHAR END;
 	T8 = POINTER TO RECORD ptr: ANY; a:ARRAY MathLenOffset + 8 * 8 OF CHAR END;
+	*)
 	T9 = POINTER TO RECORD ptr: ANY; a:ARRAY MathLenOffset + 9 * 8 OF CHAR END;
 	T10 =POINTER TO  RECORD ptr: ANY;a: ARRAY MathLenOffset + 10 * 8 OF CHAR END;
 	T11 =POINTER TO  RECORD ptr: ANY;a: ARRAY MathLenOffset + 11 * 8 OF CHAR END;
@@ -2114,7 +2153,7 @@ Sufficient (but not necessary) conditions:
 			lval := ladr;
 			dval := dadr;
 			dval.val := op(lval.val);
-			(* SYSTEM.GET( ladr, lval );  SYSTEM.PUT( dadr, op(lval) );*)  INC( ladr, linc );  INC( dadr, dinc );
+			INC( ladr, linc );  INC( dadr, dinc );
 			DEC( len );
 		END;
 	END GenericLoopZ;
@@ -9551,6 +9590,58 @@ Sufficient (but not necessary) conditions:
 		END;
 	END DoReshape;
 
+	PROCEDURE AllocateTensorA*( CONST a: ARRAY OF SIZE;  elementSize: SIZE; tag: ADDRESS; VAR dest: ADDRESS );
+	VAR descr, data: ANY;  same: BOOLEAN;  i: LONGINT;  dim: LONGINT;
+
+		PROCEDURE NewData;
+		VAR len, size, i: LONGINT;
+		BEGIN
+			size := elementSize;
+			FOR i := dim - 1 TO 0 BY -1 DO
+				len := a[i];
+				PutInc( dest, i, size );  PutLen( dest, i, len );  size := size * len;
+			END;
+			IF tag = 0 THEN
+				SYSTEM.NEW( data, size );   (* Zero(data,size*Size); *)
+				PutAdr( dest, SYSTEM.VAL( LONGINT, data ) );
+			ELSE
+				Heaps.NewArr(data, tag, size DIV elementSize,1,FALSE);
+				PutAdr( dest, SYSTEM.VAL( LONGINT, data ) + ArrDataArrayOffset );
+			END;
+			PutPtr( dest, SYSTEM.VAL( LONGINT, data ) );  PutSize( dest, elementSize );
+		END NewData;
+
+		PROCEDURE ClearData;
+			(*! todo *)
+		END ClearData;
+
+	BEGIN
+		dim := LEN( a,0 );
+		IF (dest = 0) OR (dim # GetDim( dest )) THEN
+			IF dest # 0 THEN
+				IF (~(TensorFlag IN GetFlags( dest ))) THEN Err( "Array's number of dimension must not be modified (no TENSOR !)" );  END;
+			END;
+			descr := GetArrayDesc( LEN( a,0 ) );  dest := SYSTEM.VAL( LONGINT, descr );
+			NewData;
+		ELSE
+			i := 0;
+			WHILE (i < dim) & same DO
+				IF GetLen( dest, i ) # a[i] THEN same := FALSE;  END;
+				INC( i );
+			END;
+			IF ~same THEN
+				IF (RangeFlag IN GetFlags( dest )) THEN Err( "Array's shape must not be modified (is RANGE !) " );  END;
+				NewData
+			ELSE ClearData
+			END;
+		END;		
+	END AllocateTensorA;
+
+	PROCEDURE AllocateArrayA*( CONST a: ARRAY OF SIZE;  elementSize: SIZE; tag: ADDRESS; dest: ADDRESS );
+	BEGIN
+		AllocateTensorA(a,elementSize,tag,dest);
+	END AllocateArrayA;
+
 	PROCEDURE AllocateTensorX*( VAR destA: ARRAY [?]; CONST a: ARRAY [ * ] OF LONGINT;  Size: LONGINT; tag: LONGINT );
 	VAR descr, data: ANY;  same: BOOLEAN;  i: LONGINT;  dim: LONGINT; dest: Address;
 

source/FoxIntermediateBackend.Mod

@@ -8199,19 +8199,27 @@ TYPE
 						result := ResolveExpression(SyntaxTree.NewParameterDesignator(InvalidPosition, designator, actualParameters));
 						*)
 					ELSE
+						(* 
+						 	push len0
+						 	push len1
+						 	push len2
+						 	
+						 	push size
+						 	push len_adr
+						 	push element_size
+						 	push tag
+						 	push adr
+						*)
 
 						dim := 0;
 
 						IF type(SyntaxTree.MathArrayType).form = SyntaxTree.Tensor THEN
-							(* generate geometry descriptor *)
-							Designate(p0,l);
-							NewMathArrayDescriptor(l, x.parameters.Length()-1);
-							ReleaseOperand(l);
 							isTensor := TRUE;
 						ELSE
 							isTensor := FALSE;
 						END;
 
+						
 						FOR i := firstPar TO x.parameters.Length()-1 DO
 							IF ~isTensor THEN
 								type := type(SyntaxTree.MathArrayType).arrayBase.resolved;
@@ -8223,141 +8231,61 @@ TYPE
 								TrapC(BrgeL,r.op,tmp,ArraySizeTrap);
 							END;
 							Emit(Push(position,r.op));
-							IF i=1 THEN
-								CopyInt(reg, r.op);
-							ELSE
-								MulInt(reg, reg, r.op);
-							END;
 							ReleaseOperand(r);
 							INC(dim);
 						END;
-						Convert(reg,addressType);
+						
+						IntermediateCode.InitRegister(adr,addressType,IntermediateCode.GeneralPurposeRegister,AcquireRegister(addressType,IntermediateCode.GeneralPurposeRegister));
+						Emit(Mov(position, adr, sp));
+						Emit(Push(position, IntermediateCode.Immediate(sizeType, dim)));
+						Emit(Push(position, adr)); 
+						ReleaseIntermediateOperand(adr); 
 
 						openDim := dim;
 						ASSERT(~(type IS SyntaxTree.MathArrayType) OR (type(SyntaxTree.MathArrayType).form IN {SyntaxTree.Static,SyntaxTree.Tensor}));
 
-						(*! the following code is only correct for "standard" Oberon calling convention *)
-						IF SemanticChecker.ContainsPointer(SemanticChecker.ArrayBase(type,MAX(LONGINT))) THEN
-							t := type;
-							IF ~isTensor & (t IS SyntaxTree.MathArrayType) THEN
-								staticLength := 1;
-								WHILE (t IS SyntaxTree.MathArrayType) DO (* static array *)
-									staticLength := staticLength * t(SyntaxTree.MathArrayType).staticLength;
-									t := t(SyntaxTree.MathArrayType).arrayBase.resolved;
-								END;
-								tmp := IntermediateCode.Immediate(reg.type,staticLength);
-								MulInt(reg,reg,tmp);
-							END;
-							Designate(p0,l);
-							IF isTensor THEN
-								Dereference(l,type,FALSE);
-								t := SemanticChecker.ArrayBase(type,MAX(LONGINT));
-							END;
-							Emit(Push(position,l.tag)); (* address for use after syscall *)
-							Emit(Push(position,l.tag)); (* address *)
-							ReleaseOperand(l);
+						IF isTensor THEN
+							baseType := SemanticChecker.ArrayBase(type,MAX(LONGINT));
+						ELSE
+							baseType := SemanticChecker.ArrayBase(type,openDim);
+						END;
+
 
-							tmp := TypeDescriptorAdr(t);
+						staticLength := ToMemoryUnits(system,system.AlignedSizeOf(baseType));
+						Emit(Push(position, IntermediateCode.Immediate(sizeType, staticLength)));
+
+						IF SemanticChecker.ContainsPointer(baseType) THEN
+							tmp := TypeDescriptorAdr(baseType);
 							IF ~newObjectFile THEN
 								IntermediateCode.MakeMemory(tmp,addressType);
 							END;
-							Emit(Push(position,tmp)); (* type descriptor *)
-							ReleaseIntermediateOperand(tmp);
-
-							Emit(Push(position,reg)); (* number Elements *)
-							ReleaseIntermediateOperand(reg);
-							tmp := IntermediateCode.Immediate(addressType,0);
-							Emit(Push(position,tmp)); (* dimensions = 0, we control dimensions in the geometry descriptor *)
-							(* push realtime flag: false by default *)
-							Emit(Push(position,false));
-							CallThis(position,"Heaps","NewArr",5);
-							IntermediateCode.InitRegister(adr,addressType,IntermediateCode.GeneralPurposeRegister,AcquireRegister(addressType,IntermediateCode.GeneralPurposeRegister));
-							Emit(Pop(position,adr));
-							GetMathArrayField(tmp,adr,MathPtrOffset);
-							IntermediateCode.InitRegister(reg,addressType,IntermediateCode.GeneralPurposeRegister,AcquireRegister(addressType,IntermediateCode.GeneralPurposeRegister));
-							AddInt(reg, tmp, IntermediateCode.Immediate(addressType,ToMemoryUnits(system,ArrDataArrayOffset)));
-							PutMathArrayField(adr,reg,MathAdrOffset);
-							ReleaseIntermediateOperand(tmp);
-							ReleaseIntermediateOperand(reg);
 						ELSE
-							IF isTensor THEN
-								size := ToMemoryUnits(system,system.AlignedSizeOf(SemanticChecker.ArrayBase(type,MAX(LONGINT))));
-							ELSE
-								size := ToMemoryUnits(system,system.AlignedSizeOf(SemanticChecker.ArrayBase(type,openDim)));
-							END;
-							IF (size # 1) THEN
-								MulInt(reg,reg,IntermediateCode.Immediate(addressType,size)); (*! optimize the multiplication of immediate operands *)
-							END;
-							tmp := IntermediateCode.Immediate(addressType,ToMemoryUnits(system,SysDataArrayOffset));
-							AddInt(reg,reg,tmp);
-
-							Designate(p0,l);
-							IF isTensor THEN
-								Dereference(l,type,FALSE);
-							END;
-							Emit(Push(position,l.tag)); (* address for use after syscall *)
-							Emit(Push(position,l.tag)); (* address for syscall *)
-							ReleaseOperand(l); (* pointer address *)
-
-							Emit(Push(position,reg)); (* size *)
-							ReleaseIntermediateOperand(reg);
-							(* push realtime flag: false by default *)
-							Emit(Push(position,false));
-							CallThis(position,"Heaps","NewSys",3);
-							IntermediateCode.InitRegister(adr,addressType,IntermediateCode.GeneralPurposeRegister,AcquireRegister(addressType,IntermediateCode.GeneralPurposeRegister));
-							Emit(Pop(position,adr));
-							GetMathArrayField(tmp,adr,MathPtrOffset);
-							IntermediateCode.InitRegister(reg,addressType,IntermediateCode.GeneralPurposeRegister,AcquireRegister(addressType,IntermediateCode.GeneralPurposeRegister));
-							AddInt(reg,tmp,IntermediateCode.Immediate(addressType,ToMemoryUnits(system,SysDataArrayOffset)));
-							PutMathArrayField(adr,reg,MathAdrOffset);
-							ReleaseIntermediateOperand(tmp);
-							ReleaseIntermediateOperand(reg);
+							tmp := nil;
 						END;
+						Emit(Push(position,tmp)); (* type descriptor *)
 
-
-						flags := {};
-						IntermediateCode.InitImmediate(tmp,addressType,SYSTEM.VAL(LONGINT,flags));
-						PutMathArrayField(adr,tmp,MathFlagsOffset);
-						IntermediateCode.InitImmediate(tmp,addressType,openDim);
-						PutMathArrayField(adr,tmp,MathDimOffset);
-
-						else := NewLabel();
-						BreqL(else,IntermediateCode.Memory(addressType,adr,0),IntermediateCode.Immediate(addressType,0));
-
-						i := openDim-1;
-						IntermediateCode.InitRegister(reg,addressType,IntermediateCode.GeneralPurposeRegister,AcquireRegister(addressType,IntermediateCode.GeneralPurposeRegister));
+						IF isTensor & GetRuntimeProcedure ("FoxArrayBase","AllocateTensorA", procedure, TRUE) THEN
+						ELSIF GetRuntimeProcedure ("FoxArrayBase","AllocateArrayA", procedure, TRUE) THEN
+						ELSE (* error message has already been emited *)
+							RETURN;
+						END;
+						 
+						Designate(p0,l);
 						IF isTensor THEN
-							IntermediateCode.InitImmediate(tmp,addressType,ToMemoryUnits(system,system.AlignedSizeOf(SemanticChecker.ArrayBase(type,MAX(LONGINT)))));
+							Emit(Push(position,l.op)); (* address *)
 						ELSE
-							IntermediateCode.InitImmediate(tmp,addressType,ToMemoryUnits(system,system.AlignedSizeOf(SemanticChecker.ArrayBase(type,openDim))));
-						END;
-						PutMathArrayField(adr,tmp,MathElementSizeOffset);
-						WHILE (i >= 0) DO
-							Emit(Pop(position,reg));
-							PutMathArrayLength(adr,reg,i);
-							PutMathArrayIncrement(adr,tmp,i);
-							IF i > 0 THEN
-								IF i=openDim-1 THEN
-									CopyInt(tmp,tmp);
-								END;
-								MulInt(tmp,tmp,reg);
-							END;
-							DEC(i);
+							Emit(Push(position,l.tag)); (* address *)
 						END;
-						ReleaseIntermediateOperand(adr);
-						ReleaseIntermediateOperand(reg);
-						ReleaseIntermediateOperand(tmp);
+						ReleaseOperand(l);
 
-						exit := NewLabel();
-						BrL(exit);
-						SetLabel(else);
-						(* else part: array could not be allocated *)
-						tmp := IntermediateCode.Immediate(addressType,ToMemoryUnits(system,openDim*system.addressSize));
+						StaticCallOperand(result,procedure);
+						Emit(Call(position,result.op,ProcedureParametersSize(system,procedure)));
+						ReleaseOperand(result);
+						
+						tmp := IntermediateCode.Immediate(addressType,ToMemoryUnits(system,dim*system.addressSize));
 						Emit(Add(position,sp,sp,tmp));
-
-						SetLabel(exit);
-					END;
-				ELSIF (type IS SyntaxTree.PointerType) & (type(SyntaxTree.PointerType).pointerBase.resolved  IS SyntaxTree.CellType) 
+				END;
+			ELSIF (type IS SyntaxTree.PointerType) & (type(SyntaxTree.PointerType).pointerBase.resolved  IS SyntaxTree.CellType) 
 				THEN
 					IF ~backend.cellsAreObjects THEN RETURN END;
 					IF InCellScope(currentScope) THEN