Support for Reference Counting:

Can be enabled with compiler option --writeBarriers (but has to be enabled for all files in the release).
Still experimental.

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

source/Compiler.Mod

@@ -571,7 +571,7 @@ BEGIN
 	NEW(platforms);
 
 	(* platform definitions hard coded for the common cases -- maybe (parts of it) should be outsourced to a file ?*)
-	DoAddPlatform("Win32","-b=AMD --newObjectFile --mergeSections --objectFileExtension=.GofW --symbolFileExtension=.SymW --preciseGC --trackLeave --writeBarriers --cellsAreObjects --platformCC=WINAPI");
+	DoAddPlatform("Win32","-b=AMD --newObjectFile --mergeSections --objectFileExtension=.GofW --symbolFileExtension=.SymW --preciseGC --trackLeave --cellsAreObjects --platformCC=WINAPI");
 	DoAddPlatform("Win64","-b=AMD --bits=64 --newObjectFile --mergeSections --objectFileExtension=.GofWw --symbolFileExtension=.SymWw --preciseGC --trackLeave --cellsAreObjects --platformCC=WINAPI");
 	DoAddPlatform("Win32C","-b=AMD --cooperative --newObjectFile --traceModule=Trace --objectFileExtension=.GofCW --symbolFileExtension=.SymCW --platformCC=WINAPI");
 	DoAddPlatform("ARM","-b=ARM --newObjectFile --metaData=simple --objectFileExtension=.Goa --symbolFileExtension=.Sya");

source/FoxIntermediateBackend.Mod

@@ -867,6 +867,8 @@ TYPE
 							IF implementationVisitor.profile  & ~isModuleBody THEN 
 								implementationVisitor.ProfilerEnterExit(implementationVisitor.numberProcedures-1, FALSE) 
 							END;
+						ELSE
+							IF backend.writeBarriers & HasPointers(scope) THEN implementationVisitor.ResetVariables2(scope,FALSE) END;
 						END;
 						implementationVisitor.EmitLeave(ir, x.position,x,callingConvention);
 						IF finalizer THEN
@@ -914,6 +916,7 @@ TYPE
 							implementationVisitor.EmitLeave(ir,x.position,x,callingConvention);
 							ir.Emit(Exit(x.position,procedureType.pcOffset,callingConvention, parametersSize));
 						ELSE
+							IF backend.writeBarriers & HasPointers(scope) THEN implementationVisitor.ResetVariables2(scope,FALSE) END;
 							ir.Emit(Nop(x.position));
 							IF scope.body.isUnchecked OR backend.noRuntimeChecks THEN (* return from procedure in any case *)
 								implementationVisitor.EmitLeave(ir,x.position,x,callingConvention);
@@ -2998,7 +3001,7 @@ TYPE
 		
 
 		PROCEDURE ResetVariables (scope: SyntaxTree.ProcedureScope);
-		VAR variable: SyntaxTree.Variable; parameter: SyntaxTree.Parameter; previousScope: SyntaxTree.Scope;   pc: LONGINT;
+		VAR variable: SyntaxTree.Variable; parameter: SyntaxTree.Parameter; previousScope: SyntaxTree.Scope;   pc: LONGINT; 
 
 			PROCEDURE Reset (symbol: SyntaxTree.Symbol);
 			VAR operand: Operand;
@@ -3030,6 +3033,123 @@ TYPE
 				currentScope := previousScope;
 		END ResetVariables;
 		
+					PROCEDURE Reset (symbol: SyntaxTree.Symbol; refer: BOOLEAN);
+			VAR operand: Operand; type: SyntaxTree.Type; saved: RegisterEntry; size: SIZE; base: SyntaxTree.Type;  arg: IntermediateCode.Operand;
+			BEGIN
+				type := symbol.type.resolved; 
+				
+				SaveRegisters();ReleaseUsedRegisters(saved);
+				IF SemanticChecker.IsPointerType(type) OR (type IS SyntaxTree.PortType) THEN
+					Symbol(symbol, operand);
+					ToMemory(operand.op,addressType,0);
+					Emit(Push(position,operand.op));
+					IF refer THEN
+					CallThis(position,"Heaps","Refer",1);
+					ELSE
+					CallThis(position,"Heaps","Reset",1);
+					END;
+					
+				ELSIF type.IsRecordType() THEN
+					Symbol(symbol, operand);
+					Emit(Push(position,operand.op));
+					Emit(Push(position,operand.tag)); (* type desc *)
+					IF refer THEN
+					CallThis(position,"Heaps","ReferRecord",2);
+					ELSE
+					CallThis(position,"Heaps","ResetRecord",2);
+					END;
+				ELSIF IsStaticArray(type) THEN
+					size := StaticArrayNumElements(type);
+					base := StaticArrayBaseType(type);
+					Symbol(symbol, operand);
+					arg := TypeDescriptorAdr(base);
+					IF ~newObjectFile THEN IntermediateCode.MakeMemory(arg, addressType) END;
+					Emit(Push(position,operand.op));
+					Emit(Push(position,arg));
+					Emit(Push(position,IntermediateCode.Immediate(addressType,size)));
+					ReleaseIntermediateOperand(arg);
+					IF refer THEN
+						CallThis(position,"Heaps","ReferArray",3);					
+					ELSE
+						CallThis(position,"Heaps","ResetArray",3);
+					END;
+				ELSIF  IsStaticMathArray(type) THEN (* the representation of a static math array coincides with static array *)
+					size := StaticMathArrayNumElements(type);
+					base := StaticMathArrayBaseType(type);
+					Symbol(symbol, operand);
+
+					arg := TypeDescriptorAdr(base);
+					IF ~newObjectFile THEN IntermediateCode.MakeMemory(arg, addressType) END;
+
+					Emit(Push(position,operand.op));
+					Emit(Push(position,arg));
+					Emit(Push(position,IntermediateCode.Immediate(addressType,size)));
+					ReleaseIntermediateOperand(arg);
+					IF refer THEN
+						CallThis(position,"Heaps","ReferArray",3);					
+					ELSE
+						CallThis(position,"Heaps","ResetArray",3);
+					END;
+				ELSIF type IS SyntaxTree.MathArrayType THEN
+					Symbol(symbol, operand);
+					IF type(SyntaxTree.MathArrayType).form = SyntaxTree.Tensor THEN
+						Emit (Push(position, operand.op));				
+					ELSE
+						Emit (Push(position, operand.tag));				
+					END;
+					IF refer THEN
+						CallThis(position,"Heaps","ReferMathArray", 1);
+					ELSE
+						CallThis(position,"Heaps","ResetMathArray", 1);
+					END;
+				ELSIF type IS SyntaxTree.ProcedureType THEN
+					ASSERT(type(SyntaxTree.ProcedureType).isDelegate); 
+					Symbol(symbol, operand);
+					Emit (Push(position, operand.tag));
+					IF refer THEN
+						CallThis(position,"Heaps","Refer", 1);
+					ELSE
+						CallThis(position,"Heaps","Reset", 1);
+					END;
+				ELSE HALT(100); (* missing ? *)
+				END;
+				ReleaseOperand(operand);
+
+				RestoreRegisters(saved);
+				
+			END Reset;
+
+		
+		PROCEDURE ResetVariables2 (scope: SyntaxTree.ProcedureScope; refer: BOOLEAN);
+		VAR variable: SyntaxTree.Variable; parameter: SyntaxTree.Parameter; previousScope: SyntaxTree.Scope;   pc: LONGINT; prevOffset: SIZE;
+
+
+		BEGIN
+			previousScope := currentScope;
+			currentScope := scope;
+			pc := section.pc;
+			IF ~ refer THEN
+				variable := scope.firstVariable;
+				prevOffset := MAX(SIZE);
+				WHILE variable # NIL DO
+					IF variable.NeedsTrace() & (variable.offsetInBits # prevOffset) (* multiple temporaries *) THEN
+						Reset (variable,refer);
+						prevOffset := variable.offsetInBits;
+					END;
+					variable := variable.nextVariable;
+				END;
+			END;
+			parameter := scope.ownerProcedure.type(SyntaxTree.ProcedureType).firstParameter;
+			WHILE parameter # NIL DO
+				IF parameter.NeedsTrace() & ~IsVariableParameter(parameter) & (parameter.kind # SyntaxTree.ConstParameter) & ~IsOpenArray(parameter.type) THEN
+					Reset (parameter,refer);
+				END;
+				parameter := parameter.nextParameter;
+			END;
+				INC(statCoopResetVariables, section.pc - pc); 
+				currentScope := previousScope;
+		END ResetVariables2;
+		
 		PROCEDURE CreateProcedureDescriptor (procedure: SyntaxTree.Procedure);
 		VAR previousSection: IntermediateCode.Section; name: Basic.SegmentedName;
 		VAR op: IntermediateCode.Operand; context: Context;
@@ -6729,6 +6849,7 @@ TYPE
 
 		PROCEDURE InitVariable(VAR variable: SyntaxTree.Variable; temporary: BOOLEAN);
 		VAR type: SyntaxTree.Type; operand: Operand; tmp, mem: IntermediateCode.Operand; reference: SyntaxTree.Expression; symbol: SyntaxTree.Symbol;
+			saved: RegisterEntry;
 		BEGIN
 			type := variable.type.resolved;
 			IF (type IS SyntaxTree.MathArrayType) THEN
@@ -6740,21 +6861,31 @@ TYPE
 							PutMathArrayField(operand.tag, IntermediateCode.Immediate(addressType,SYSTEM.VAL(LONGINT,{StackFlag})),MathFlagsOffset);
 						END;
 					ELSIF type.form = SyntaxTree.Tensor THEN
-						Symbol(variable, operand);
-						MakeMemory(tmp,operand.op,addressType,0);
-						ReleaseOperand(operand);
-						IF temporary THEN
-							(* trick -- temporary object from array base *)
-							symbol := GetSymbol(moduleScope,"FoxArrayBase","temporary");
-							Symbol(symbol,operand);
-							MakeMemory(mem,operand.op,addressType,0);
-							ReleaseOperand(operand);
-							Emit(Mov(position,tmp, mem) );
+						IF temporary & backend.writeBarriers THEN
+							SaveRegisters();ReleaseUsedRegisters(saved);
+							Symbol(variable, operand); 
+							Emit(Push(position,operand.op));
 							ReleaseOperand(operand);
+							Emit(Push(position,nil));
+							CallThis(position,"FoxArrayBase","Assign",2);
+							RestoreRegisters(saved);
 						ELSE
-							Emit(Mov(position,tmp, nil ) );
+							Symbol(variable, operand);
+							MakeMemory(tmp,operand.op,addressType,0);
+							ReleaseOperand(operand);
+							IF temporary THEN
+									(* trick -- temporary object from array base *)
+									symbol := GetSymbol(moduleScope,"FoxArrayBase","temporary");
+									Symbol(symbol,operand);
+									MakeMemory(mem,operand.op,addressType,0);
+									ReleaseOperand(operand);
+									Emit(Mov(position,tmp, mem) );
+									ReleaseOperand(operand);
+							ELSE
+								Emit(Mov(position,tmp, nil ) );
+							END;
+							ReleaseIntermediateOperand(tmp)
 						END;
-						ReleaseIntermediateOperand(tmp);
 					END;
 				END;
 			ELSE
@@ -6766,11 +6897,21 @@ TYPE
 					Assign(reference,variable.initializer);
 				ELSIF temporary THEN
 					IF SemanticChecker.IsPointerType(variable.type) THEN
-						Symbol(variable, operand);
-						MakeMemory(tmp,operand.op,addressType,0);
-						ReleaseOperand(operand);
-						Emit(Mov(position,tmp, nil ) );
-						ReleaseIntermediateOperand(tmp);
+						IF backend.writeBarriers THEN
+							SaveRegisters();ReleaseUsedRegisters(saved);
+							Symbol(variable, operand); 
+							Emit(Push(position,operand.op));
+							ReleaseOperand(operand);
+							Emit(Push(position,nil));
+							CallThis(position,"Heaps","Assign",2);
+							RestoreRegisters(saved);
+						ELSE
+							Symbol(variable, operand);
+							MakeMemory(tmp,operand.op,addressType,0);
+							ReleaseOperand(operand);
+							Emit(Mov(position,tmp, nil ) );
+							ReleaseIntermediateOperand(tmp);
+						END;
 					END;
 				END;
 				InitFields(type, operand.op,0);
@@ -10721,6 +10862,8 @@ TYPE
 				type := expression.type.resolved;
 				IF (expression IS SyntaxTree.ResultDesignator) THEN
 					IF locked THEN Lock(FALSE) END;
+					IF backend.writeBarriers & HasPointers(procedure.procedureScope) THEN ResetVariables2(procedure.procedureScope,FALSE) END;
+
 					IF ~backend.cooperative & profile THEN ProfilerEnterExit(numberProcedures,FALSE) END;
 					(* "RETURN RESULT" -> no assignment, it is assumed that result has been written to return parameter via structured return type *)
 				ELSIF (type IS SyntaxTree.BasicType) & ~(type IS SyntaxTree.RangeType) & ~(type IS SyntaxTree.ComplexType) & ~type.IsPointer() OR (type IS SyntaxTree.EnumerationType) OR (procedureType.callingConvention # SyntaxTree.OberonCallingConvention) THEN
@@ -10732,12 +10875,15 @@ TYPE
 						IF delegate THEN HALT(200) END;
 						ReleaseOperand(res);
 						IF locked THEN Lock(FALSE) END;
+						IF backend.writeBarriers & HasPointers(procedure.procedureScope) THEN ResetVariables2(procedure.procedureScope,FALSE) END;
 						IF ~backend.cooperative & profile THEN ProfilerEnterExit(numberProcedures,FALSE) END;
+
 						reg := NewRegisterOperand(res.op.type);
 						Emit(Pop(position,reg));
 						Emit(Return(position,reg));
 						ReleaseIntermediateOperand(reg);
 					ELSE
+						IF backend.writeBarriers & HasPointers(procedure.procedureScope) THEN ResetVariables2(procedure.procedureScope,FALSE) END;
 						Emit(Return(position,res.op));
 						ReleaseOperand(res);
 					END;
@@ -10799,6 +10945,7 @@ TYPE
 					END;
 					ReleaseIntermediateOperand(left);
 					IF locked THEN Lock(FALSE) END;
+					IF backend.writeBarriers & HasPointers(procedure.procedureScope) THEN ResetVariables2(procedure.procedureScope,FALSE) END;
 					IF ~backend.cooperative & profile THEN ProfilerEnterExit(numberProcedures,FALSE) END;
 				ELSIF (type IS SyntaxTree.MathArrayType) OR (type IS SyntaxTree.ProcedureType) THEN
 					parameter := procedureType.returnParameter;
@@ -10811,12 +10958,15 @@ TYPE
 						Assign(parameterDesignator,expression);
 					END;
 					IF locked THEN Lock(FALSE) END;
+					IF backend.writeBarriers & HasPointers(procedure.procedureScope) THEN ResetVariables2(procedure.procedureScope,FALSE) END;
+
 					IF ~backend.cooperative & profile THEN ProfilerEnterExit(numberProcedures,FALSE) END;
 				ELSE
 					HALT(200);
 				END;
 			ELSE
 				IF locked THEN Lock(FALSE) END;
+				IF backend.writeBarriers & HasPointers(procedure.procedureScope) THEN ResetVariables2(procedure.procedureScope,FALSE) END;
 				IF ~backend.cooperative & profile THEN ProfilerEnterExit(numberProcedures,FALSE) END;
 			END;
 
@@ -11341,6 +11491,7 @@ TYPE
 					Emit(Mov(position, left, right));
 				END;
 				
+				IF HasPointers (procedure.procedureScope) & backend.writeBarriers THEN ResetVariables2(procedure.procedureScope,TRUE) END;
 				(* must be done after the descriptor is there, otherwise copied parameters are forgotten to be traced *)
 				ParameterCopies(procedureType);
 
@@ -11470,7 +11621,7 @@ TYPE
 		VAR offset: LONGINT; name: Basic.SegmentedName; symbol: SyntaxTree.Symbol;
 		BEGIN
 			(* change this when Heaps.HeapBlock is modified *)
-			INC(dataAdrOffset,6);
+			INC(dataAdrOffset,7);
 			
 			Info(section,"headerAdr");
 			Address(section,0);
@@ -11482,7 +11633,11 @@ TYPE
 
 			Info(section,"mark: LONGINT;");
 			Longint(section,-1);
+			Info(section,"refCount: LONGINT;");
+			Longint(section,0);
+			(*
 			IF module.system.addressType.sizeInBits = 64 THEN Longint(section, 0); INC(dataAdrOffset); END;
+			*)
 			
 			Info(section,"dataAdr-: ADDRESS");
 			Symbol(section,section, dataAdrOffset,0);

source/FoxParser.Mod

@@ -1543,12 +1543,14 @@ TYPE
 			type: SyntaxTree.Type;
 			base: SyntaxTree.Type;
 			expression: SyntaxTree.Expression;
+			modifiers: SyntaxTree.Modifier;
 
 			PROCEDURE MathArray(): SyntaxTree.Type;
 			VAR mathType: SyntaxTree.MathArrayType; base: SyntaxTree.Type;
 			BEGIN
 				IF Optional(Scanner.Questionmark) THEN
 					mathType := SyntaxTree.NewMathArrayType(position,parentScope, SyntaxTree.Tensor);
+					
 				ELSIF Optional(Scanner.Times) THEN (* open array *)
 					mathType := SyntaxTree.NewMathArrayType(position,parentScope, SyntaxTree.Open);
 				ELSE (* size given *)
@@ -1563,13 +1565,20 @@ TYPE
 						base := Type(SyntaxTree.invalidIdentifier , parentScope );   (* base type *)
 					END;
 				END;
+				mathType.SetModifiers(modifiers);
+				modifiers := NIL; 
 				mathType.SetArrayBase(base);
 				RETURN mathType;
 			END MathArray;
 
 		BEGIN
 			IF Trace THEN S( "ArrayType" ) END;
-			(* array symbol already consumed *)
+			(* array symbol already consumed *)				
+			
+			IF Optional(Scanner.LeftBrace) THEN
+				modifiers := Flags();
+			END;
+
 			IF Optional(Scanner.LeftBracket) THEN (* math array *)
 				type := MathArray();
 			ELSIF Optional( Scanner.Of ) THEN  (* open array *)
@@ -1591,6 +1600,9 @@ TYPE
 					arrayType.SetArrayBase( base );
 				END;
 			END;
+			IF modifiers # NIL THEN
+				Error(modifiers.position, Diagnostics.Invalid, "forbidden modifiers");
+			END;
 			IF Trace THEN E( "ArrayType" ) END;
 			RETURN type
 		END ArrayType;

source/FoxSemanticChecker.Mod

@@ -602,7 +602,7 @@ TYPE
 				- static array of open array forbidden
 		**)
 		PROCEDURE VisitMathArrayType*(x: SyntaxTree.MathArrayType);
-		VAR arrayBase: SyntaxTree.Type;
+		VAR arrayBase: SyntaxTree.Type; modifiers: SyntaxTree.Modifier; position: SyntaxTree.Position;
 		BEGIN
 			IF TypeNeedsResolution(x) THEN
 				x.SetArrayBase(ResolveType(x.arrayBase));
@@ -628,6 +628,9 @@ TYPE
 					END;
 					x.SetHasPointers((x.form # SyntaxTree.Static) OR arrayBase.hasPointers);
 				END;
+				modifiers := x.modifiers;
+				x.SetUnsafe(HasFlag(modifiers,Global.NameUnsafe,position));
+				CheckModifiers(modifiers, TRUE);
 				x.SetState(SyntaxTree.Resolved);
 			END;
 			resolvedType := ResolvedType(x);
@@ -1769,6 +1772,8 @@ TYPE
 					result := CompatibleTo(system,actualType,formalType);
 				ELSIF (formalType IS SyntaxTree.ArrayType) & (formalType(SyntaxTree.ArrayType).form = SyntaxTree.Open) THEN
 					result := OpenArrayCompatible(formalType(SyntaxTree.ArrayType),actualType);
+				ELSIF IsUnsafePointer(formalType) & IsUnsafePointer(actualType) THEN
+					result := TRUE;
 				ELSIF (formalType IS SyntaxTree.MathArrayType) THEN
 					IF IsArrayStructuredObjectType(actualType) THEN
 						actualType := MathArrayStructureOfType(actualType)
@@ -2641,7 +2646,11 @@ TYPE
 					INC(inConversion); 
 					IF inConversion < 10 THEN 
 						IF expression.type.resolved IS SyntaxTree.MathArrayType THEN
-							result := MathArrayConversion(position, expression,type);
+							IF IsTensor(expression.type) & (IsUnsafePointer(type) OR (type IS SyntaxTree.AddressType)) THEN
+								result := expression
+							ELSE
+								result := MathArrayConversion(position, expression,type);
+							END;
 						ELSIF IsArrayStructuredObjectType(expression.type) THEN
 							expression := ConvertToMathArray(expression);
 							type := MathArrayStructureOfType(type);
@@ -2652,7 +2661,9 @@ TYPE
 					END;
 					DEC(inConversion);
 			ELSIF (expression.type.resolved IS SyntaxTree.MathArrayType) THEN
-					IF (expression.type.resolved(SyntaxTree.MathArrayType).form # SyntaxTree.Static)
+					IF IsTensor(expression.type) & (IsUnsafePointer(type) OR (type IS SyntaxTree.AddressType)) THEN
+						result := expression; result.SetType(type);
+					ELSIF (expression.type.resolved(SyntaxTree.MathArrayType).form # SyntaxTree.Static)
 						OR ~(type IS SyntaxTree.ArrayType) THEN
 						Error(expression.position,"cannot convert array type to non-array type")
 					END;
@@ -8680,7 +8691,7 @@ TYPE
 											ASSERT(thatParameter # NIL);
 											IF ~SameType(thisParameter.type, thatParameter.type) THEN
 												operandsAreEqual := FALSE;
-												IF ~CompatibleTo(system, thisParameter.type, thatParameter.type) THEN
+												IF TypeDistance(system, thisParameter.type, thatParameter.type, thisParameter.kind = SyntaxTree.VarParameter) =Infinity THEN
 													operandsAreCompatible := FALSE
 												END
 											END;
@@ -9041,7 +9052,9 @@ TYPE
 					result := IsCharacterType(this)
 				ELSIF (to IS SyntaxTree.SizeType) & ((this IS SyntaxTree.SizeType) OR (this IS SyntaxTree.IntegerType) OR IsAddressType(this, system.addressSize)) THEN
 					result := to.sizeInBits >= this.sizeInBits (*! weak compatibility: signed size type may be assigned with unsigned address type of same size *)
-				ELSIF (to IS SyntaxTree.AddressType) & ((this IS SyntaxTree.AddressType) OR (this IS SyntaxTree.IntegerType) OR (this IS SyntaxTree.SizeType) OR IsPointerType(this) OR (this IS SyntaxTree.ProcedureType)) THEN
+				ELSIF (to IS SyntaxTree.AddressType) & ((this IS SyntaxTree.AddressType) OR (this IS SyntaxTree.IntegerType) OR (this IS SyntaxTree.SizeType) OR IsPointerType(this) OR (this IS SyntaxTree.ProcedureType)
+					OR IsTensor(this)
+				) THEN
 					result := to.sizeInBits >= this.sizeInBits; (*! weak compatibility: addresses may be assigned with signed integer *)
 				ELSIF (to IS SyntaxTree.RangeType) & (this IS SyntaxTree.RangeType) THEN
 					result := TRUE;
@@ -9050,11 +9063,13 @@ TYPE
 				ELSE
 					result := FALSE
 				END;
-
+			ELSIF IsUnsafePointer(to) & IsUnsafePointer(this) THEN
+				result := TRUE;
 			ELSIF to IS SyntaxTree.PointerType THEN
-				result := (this IS SyntaxTree.NilType) OR ((this IS SyntaxTree.AddressType) OR (this IS SyntaxTree.IntegerType)) & to(SyntaxTree.PointerType).isUnsafe OR
-						IsPointerType(this) & (IsTypeExtension(to,this) OR to(SyntaxTree.PointerType).isUnsafe OR ((to(SyntaxTree.PointerType).pointerBase.resolved IS SyntaxTree.ArrayType) & SameType(to,this)))
-				     & (~to.isRealtime OR this.isRealtime);
+				result := (this IS SyntaxTree.NilType) OR
+						IsUnsafePointer(to) & ( (this IS SyntaxTree.AddressType) OR (this IS SyntaxTree.IntegerType) OR IsPointerType(this) OR IsTensor(this)) OR
+						(IsPointerType(this) & IsTypeExtension(to,this) OR 
+						((to(SyntaxTree.PointerType).pointerBase.resolved IS SyntaxTree.ArrayType) & SameType(to,this))) & (~to.isRealtime OR this.isRealtime);
 			ELSIF to IS SyntaxTree.ProcedureType THEN
 				result := (this IS SyntaxTree.NilType) OR (this IS SyntaxTree.ProcedureType) & this.CompatibleTo(to)
 			ELSIF (to IS SyntaxTree.RecordType) & to(SyntaxTree.RecordType).isObject THEN
@@ -9742,7 +9757,9 @@ TYPE
 		IF type = NIL THEN result := FALSE
 		ELSE
 		type := type.resolved;
-		result :=  (type IS SyntaxTree.PointerType) & type(SyntaxTree.PointerType).isUnsafe;
+		result :=  (type IS SyntaxTree.PointerType) & type(SyntaxTree.PointerType).isUnsafe OR 
+			(type IS SyntaxTree.MathArrayType) & (type(SyntaxTree.MathArrayType).form = SyntaxTree.Tensor) 
+			& type(SyntaxTree.MathArrayType).isUnsafe;
 		END;
 		RETURN result
 	END IsUnsafePointer;
@@ -10243,10 +10260,6 @@ TYPE
 		RETURN (procedureType # NIL) & (procedureType.callingConvention=SyntaxTree.OberonCallingConvention) & ReturnedAsParameter(procedureType.returnType);
 	END StructuredReturnType;
 	
-	
-
-
-
 
 END FoxSemanticChecker.
 

source/FoxSyntaxTree.Mod

@@ -1159,17 +1159,29 @@ TYPE
 	(** <<ARRAY '[' length | '*' | '?' ']' OF baseType>> **)
 	MathArrayType* = OBJECT (Type)
 		VAR
+			modifiers-: Modifier; (* set by the parser *)
 			arrayBase-: Type;
 			length-: Expression;
 			staticLength-: LONGINT;
 			staticIncrementInBits-: LONGINT;
 			form-: LONGINT;
+			isUnsafe-: BOOLEAN;
 
 		PROCEDURE & InitMathArrayType(position: Position;scope: Scope; form: LONGINT);
 		BEGIN
-			length := NIL; arrayBase := NIL; InitType(position); staticLength := 0; staticIncrementInBits := 0; SetForm(form); SELF.scope := scope;
+			length := NIL; arrayBase := NIL; InitType(position); staticLength := 0; staticIncrementInBits := 0; SetForm(form); SELF.scope := scope; isUnsafe := FALSE; modifiers := NIL;
 		END InitMathArrayType;
-
+		
+		PROCEDURE SetModifiers*(m: Modifier);
+		BEGIN
+			modifiers := m;
+		END SetModifiers;
+		
+		PROCEDURE SetUnsafe*(unsafe: BOOLEAN);
+		BEGIN
+			isUnsafe := unsafe;
+		END SetUnsafe;
+		
 		PROCEDURE SetForm*(form: LONGINT);
 		BEGIN
 			SELF.form := form; IF form # Static THEN SetHasPointers(TRUE) END;
@@ -2639,10 +2651,10 @@ TYPE
 
 		PROCEDURE NeedsTrace* (): BOOLEAN;
 		BEGIN 
-			(*! semantic of x.y.z := new : if x is untraced then the effect of y.z := new remains untraced! 
-				In other words: difference between y := x.y; y.z := new and x.y.z := new.
+			(*! semantic of x.y := new : 
+				if x is untraced then assignments to x^.y can be traced, depending on traceability of field y in x
 			*)
-			RETURN left.NeedsTrace() & type.NeedsTrace(); (* for x^: if x is an untraced pointer, the content of x^ is also treated untraced *)
+			RETURN type.NeedsTrace(); (* for x^: if x is an untraced pointer, the content of x^ is also treated untraced *)
 		END NeedsTrace;
 
 	END DereferenceDesignator;

source/Heaps.Mod

@@ -13,6 +13,7 @@ MODULE Heaps;	(** AUTHOR "pjm/Luc Bläser/U. Glavitsch (ug)"; PURPOSE "Heap mana
 IMPORT Runtime (* enforce import order *), SYSTEM, Trace, Machine;
 
 CONST
+	EnableRefCount =TRUE;
 
 	Paranoid = TRUE; (* if paranoid =true, then during mark phase the GC can accept spurious pointers but reports them
 									paranoid = false expects correct metadata and correct settings of untraced variables
@@ -93,7 +94,8 @@ TYPE
 		heapBlock {FICTIVE =HeapBlockOffset}: ADDRESS; 
 		typeDesc {FICTIVE =TypeDescOffset}: POINTER {UNSAFE,UNTRACED} TO StaticTypeDesc; 
 		(* when this is changed --> change constant in Machine too and provide changes in FoxIntermediateBackend where noted *)
-		mark: LONGINT;
+		mark: WORD;
+		refCount: WORD;
 		dataAdr-: ADDRESS;
 		size-: SIZE;
 		nextMark {UNTRACED}: HeapBlock;
@@ -116,7 +118,7 @@ TYPE
 	FreeBlock* = POINTER TO FreeBlockDesc;
 	FreeBlockU = POINTER {UNSAFE,UNTRACED} TO FreeBlockDesc;
 	FreeBlockDesc* = RECORD (HeapBlockDesc)
-		next: FreeBlock;
+		next{UNTRACED}: FreeBlock;
 	END;
 
 	SystemBlock* = POINTER TO SystemBlockDesc;
@@ -267,6 +269,8 @@ VAR
 	EnableFreeLists, EnableReturnBlocks, trace-: BOOLEAN;
 
 	allocationLogger-: PROCEDURE(p: ANY);
+	
+	VAR resets, refers, assigns: SIZE;
 
 (* for low level debugging of allocation -- beware: errors or traps in allocation logger can produce catastrophy - loggers may not allocate memory  *)
 PROCEDURE SetAllocationLogger*(a: PROCEDURE (p:ANY));
@@ -302,7 +306,7 @@ BEGIN
 END CheckPointer;
 
 
-PROCEDURE AppendToMarkList(heapBlock: HeapBlock);
+PROCEDURE AppendToMarkList(heapBlock: HeapBlockU);
 BEGIN
 	IF markList.first = NIL THEN
 		markList.first := heapBlock
@@ -313,8 +317,8 @@ BEGIN
 	heapBlock.nextMark := NIL; (* sanity of the list *)
 END AppendToMarkList;
 
-PROCEDURE ExtractFromMarkList(): HeapBlock;
-VAR heapBlock: HeapBlock;
+PROCEDURE ExtractFromMarkList(): HeapBlockU;
+VAR heapBlock: HeapBlockU;
 BEGIN
 		heapBlock := markList.first;
 		IF heapBlock # NIL THEN
@@ -340,6 +344,7 @@ END ShowCards;
 PROCEDURE ClearCardSet;
 VAR i: LONGINT;
 BEGIN
+	HALT(100);
 	FOR i := 0 TO LEN(cardSet)-1 DO
 		cardSet[i] := {};
 	END;
@@ -349,6 +354,7 @@ END ClearCardSet;
 PROCEDURE EnterInCardSet(adr: ADDRESS);
 VAR value: SET;
 BEGIN
+	HALT(100);
 	adr := adr DIV CardSize;
 	IF	adr MOD SetSize IN CAS(cardSet[adr DIV SetSize],{},{}) THEN 
 		RETURN 
@@ -361,19 +367,6 @@ BEGIN
 	END;
 END EnterInCardSet;
 
-PROCEDURE CheckInternalAssignment(dest, src: DataBlockU);
-BEGIN
-	IF (src # NIL) & (src.heapBlock # NIL) & (src.heapBlock.mark MOD GenerationMask = Young) THEN
-		EnterInCardSet(dest);
-	END;
-END CheckInternalAssignment;
-
-PROCEDURE CheckAssignment*(dest, src: DataBlockU);
-BEGIN
-	IF (currentGeneration = Young) OR (youngCounts > 0) THEN
-		CheckInternalAssignment(dest, src);
-	END;
-END CheckAssignment;
 
 (* Sweep phase *)
 PROCEDURE SweepCardSet();
@@ -387,6 +380,7 @@ VAR
 	mark: BOOLEAN;
 	time1, time2: HUGEINT;
 BEGIN {UNCHECKED}
+	HALT(100);
 	(* blocks in the bootheap are not found by the sweep card set! *)
 	time1 := Machine.GetTimer ();
 	count := 0; count2 := 0;
@@ -436,7 +430,8 @@ BEGIN
 	IF (block = NIL) OR Paranoid & ~CheckPointer(block) THEN RETURN END;
 	blockMeta := block;
 	heapBlock := blockMeta.heapBlock; 
-	IF (heapBlock = NIL) OR (heapBlock.mark >= currentMarkValue) OR (heapBlock.mark MOD GenerationMask > generation) & ~((blockMeta.typeBlock#NIL) & (block IS RootObject)) THEN RETURN END;
+	IF (heapBlock = NIL)
+		OR (heapBlock.mark >= currentMarkValue) OR (heapBlock.mark MOD GenerationMask > generation) & ~((blockMeta.typeBlock#NIL) & (block IS RootObject)) THEN RETURN END;
 	(* blocks in the bootheap are not found by the sweep card set, thus the root objects must be traversed in all cases *)
 	heapBlock.mark := currentMarkValue + Old (* surviving objects age *); 
 	IF Stats THEN INC(Nmarked) END;
@@ -456,7 +451,7 @@ PROCEDURE Mark*(p {UNTRACED}: ANY);
 VAR orgBlock: ADDRESS; staticTypeBlock {UNTRACED}: StaticTypeBlock;
 	orgHeapBlock {UNTRACED}: HeapBlock;
 	currentArrayElemAdr, lastArrayElemAdr: ADDRESS; i: LONGINT;
-	protected: ProtRecBlock;
+	protected {UNTRACED}: ProtRecBlock;
 	b {UNTRACED}: POINTER {UNSAFE} TO RECORD p: ANY END;
 	meta {UNTRACED }: POINTER {UNSAFE} TO RECORD staticTypeBlock {FICTIVE=TypeDescOffset}: StaticTypeBlock; last, current, first: ADDRESS END;
 BEGIN{UNCHECKED} (* omit any range checks etc.*)
@@ -558,8 +553,8 @@ BEGIN
 END AppendFree;
 
 (* get last element from fifo *)
-PROCEDURE GetFree(VAR freeList: FreeList): FreeBlock;
-VAR block: FreeBlock;
+PROCEDURE GetFree(VAR freeList: FreeList): FreeBlockU;
+VAR block: FreeBlockU;
 BEGIN
 	IF freeList.first = NIL THEN block := NIL;
 	ELSIF freeList.first = freeList.last THEN block := freeList.first; freeList.first := NIL; freeList.last := NIL
@@ -693,7 +688,7 @@ VAR
 	lastFreeBlockAdr: ADDRESS;
 	lastFreeBlockSize: ADDRESS;
 	block : HeapBlockU ; freeBlock, lastFreeBlock: FreeBlockU; 
-	blockMark, blockGeneration: LONGINT; blockSize: SIZE;
+	blockMark, blockGeneration, refCount: LONGINT; blockSize: SIZE;
 	time1, time2: HUGEINT;
 CONST FreeBlockHeaderSize = SIZEOF(FreeBlockDesc) + BlockHeaderSize;
 CONST StrongChecks = FALSE;
@@ -717,8 +712,10 @@ BEGIN{UNCHECKED}
 			block := sweepBlockAdr + BlockHeaderSize;
 			blockMark := block.mark; (* cache these values since they may be overwritten during concatenation *)
 			blockGeneration := block.mark MOD GenerationMask;
+			refCount := block.refCount;
 			blockSize := block.size;
-			IF (blockMark < generationMarkValues[blockGeneration]) THEN
+			IF (blockMark < generationMarkValues[blockGeneration]) 
+				OR (refCount =  -1)  & EnableRefCount THEN
 				IF (block.typeDesc # freeBlockTag) THEN
 					Machine.Fill32(sweepBlockAdr + FreeBlockHeaderSize, blockSize - FreeBlockHeaderSize, DebugValue);
 				END;
@@ -738,7 +735,7 @@ BEGIN{UNCHECKED}
 				ASSERT(block.typeDesc = freeBlockTag);
 			END;
 			
-			IF (lastFreeBlockAdr # NIL) & ((blockMark >= (* sweepMarkValue *) generationMarkValues[blockGeneration]) OR (lastFreeBlockSize >= size) OR (sweepBlockAdr + blockSize = sweepMemBlock.endBlockAdr) )
+			IF (lastFreeBlockAdr # NIL) & ((refCount # -1) & (blockMark >= (* sweepMarkValue *) generationMarkValues[blockGeneration]) OR (lastFreeBlockSize >= size) OR (sweepBlockAdr + blockSize = sweepMemBlock.endBlockAdr) )
 			THEN (* no further merging is possible *)
 				IF StrongChecks THEN ASSERT(sweepBlockAdr + blockSize <= sweepMemBlock.endBlockAdr) END;
 				IF lastFreeBlockSize >= size THEN (* block found - may be too big *)
@@ -969,7 +966,7 @@ PROCEDURE CheckFinalizedObjects;
 VAR n, p, t: FinalizerNode; heapBlock {UNTRACED}: HeapBlock;
 
 	PROCEDURE MarkDelegate(p: Finalizer);
-	VAR pointer: ANY;
+	VAR pointer {UNTRACED}: ANY;
 	BEGIN
 		SYSTEM.GET(ADDRESSOF(p)+SIZEOF(ADDRESS),pointer);
 		IF pointer # NIL THEN Mark(pointer) END;
@@ -979,7 +976,9 @@ BEGIN
 	n := checkRoot;
 	WHILE n # NIL DO	(* move unmarked checked objects to finalize list *)
 		SYSTEM.GET(SYSTEM.VAL(ADDRESS, n.objWeak) + HeapBlockOffset, heapBlock);
-		IF (heapBlock.mark < generationMarkValues[heapBlock.mark MOD GenerationMask]) THEN
+		IF (heapBlock.mark < generationMarkValues[heapBlock.mark MOD GenerationMask]) 
+			OR (heapBlock.refCount = -1) & EnableRefCount
+			THEN
 			IF n = checkRoot THEN checkRoot := n.nextFin ELSE p.nextFin := n.nextFin END;
 			n.objStrong := n.objWeak;	(* anchor the object for finalization *)
 			n.finalizerStrong := n.finalizer; (* anchor the finalizer for finalization *)
@@ -1102,8 +1101,8 @@ BEGIN
 		IF currentGeneration = Young THEN
 			(* sweep and enter all old blocks containing old -> new pointers *)
 			SweepCardSet();
+			ClearCardSet();
 		END; 
-		ClearCardSet();
 
 		AddRootObject(root);
 
@@ -1216,6 +1215,7 @@ BEGIN
 	freeBlock.heapBlock := NIL;
 	(* initialize heap block fields *)
 	freeBlock.mark := mark + Young; 
+	freeBlock.refCount := 1;
 	freeBlock.dataAdr := dataAdr;
 	freeBlock.size := size;
 	(* initialize free block fields *)
@@ -1240,7 +1240,7 @@ BEGIN
 	CheckPostGC;
 	try := 1;
 	p := NIL;
-	IF  (GC = NilGC) OR (throughput < 32*1024*1024) THEN
+	IF  (GC = NilGC) OR (throughput < 32*1024*1024) OR TRUE THEN
 		GetFreeBlock(size, p);
 		IF  (p=NIL) THEN (* try restart sweep for once *)
 			GetFreeBlock(size, p);
@@ -1342,6 +1342,7 @@ BEGIN
 		dataBlock.typeDesc := NilVal;
 		dataBlock.heapBlock := systemBlock;
 		systemBlock.mark := currentMarkValue + Young;
+		systemBlock.refCount := 0;
 		systemBlock.dataAdr := dataBlockAdr;
 		systemBlock.size := blockSize;
 		(*! disable realtime block handling for the time being
@@ -1352,7 +1353,8 @@ BEGIN
 			systemBlock.nextRealtime := NIL
 		END;
 		*)
-		SetPC(dataBlock);
+		SetPC(dataBlock);		
+		(*CheckAssignment(ADDRESS OF p, dataBlock);*)
 		p := dataBlock;
 		(* clear could be done outside lock because SysBlks are not traced, but for conformity it is done inside the lock *)
 		Machine.Fill32(dataBlockAdr, blockSize - systemBlockSize - BlockHeaderSize, 0);	(* clear everything from dataBlockAdr until end of block *)
@@ -1392,6 +1394,7 @@ BEGIN
 			dataBlock.typeDesc := tag;
 			dataBlock.heapBlock := recordBlockAdr;
 			recordBlock.mark := currentMarkValue + Young;
+			recordBlock.refCount := 0; 
 			recordBlock.dataAdr := dataBlockAdr;
 			recordBlock.size := blockSize; 
 			
@@ -1435,7 +1438,10 @@ BEGIN
 
 	Machine.Acquire(Machine.Heaps);
 	protRecBlockAdr := NewBlock(blockSize);
+
 	IF protRecBlockAdr # 0 THEN
+		(* fill muste be done first in order to remove DEAD from pointers (referecne counting!) *)
+		Machine.Fill32(protRecBlockAdr, blockSize-BlockHeaderSize, 0);	(* clear everything from dataBlockAdr to end of block *)
 		protRecBlock := protRecBlockAdr;
 		dataBlockAdr := protRecBlockAdr + SIZEOF(ProtRecBlockDesc) + BlockHeaderSize;
 		dataBlock := dataBlockAdr;
@@ -1443,7 +1449,9 @@ BEGIN
 		dataBlock.typeDesc := tag;
 		dataBlock.heapBlock := protRecBlockAdr;
 		protRecBlock.mark := currentMarkValue + Young;
+		protRecBlock.refCount := 0;
 		protRecBlock.dataAdr := dataBlockAdr;
+
 		protRecBlock.size := blockSize;
 		(*! disable realtime block handling for the time being
 		IF isRealtime THEN
@@ -1473,7 +1481,6 @@ BEGIN
 		END;
 
 		(* clear must be done inside lock to ensure all traced pointer fields are initialized to NIL *)
-		Machine.Fill32(dataBlockAdr, blockSize - SIZEOF(ProtRecBlockDesc) - 2 * BlockHeaderSize, 0);	(* clear everything from dataBlockAdr to end of block *)
 	ELSE
 		p := NIL
 	END;
@@ -1523,6 +1530,7 @@ BEGIN
 				dataBlock.typeDesc := elemType;
 				dataBlock.heapBlock := arrayBlock; 
 				arrayBlock.mark := currentMarkValue + Young;
+				arrayBlock.refCount := 0; 
 				arrayBlock.dataAdr := dataBlockAdr;
 				arrayBlock.size := blockSize;
 
@@ -1637,6 +1645,7 @@ END FillStaticType;
 PROCEDURE AddFinalizer*(obj: ANY; n: FinalizerNode);
 BEGIN
 	n.objWeak := obj; n.objStrong := NIL; n.finalizerStrong := NIL;
+	Refer(obj); (* make sure this object is not removed via reference counting *)
 	Machine.Acquire(Machine.Heaps);
 	n.nextFin := checkRoot; checkRoot := n;
 	IF Stats THEN INC(NfinalizeAlive) END;
@@ -1683,37 +1692,310 @@ BEGIN
 	RETURN total-free;
 END Used;
 
-VAR assigns*: LONGINT;
+PROCEDURE GetPCs*();
+VAR bp,pc: ADDRESS;
+BEGIN
+		bp := CheckBP(Machine.CurrentBP()); 
+		SYSTEM.GET(bp, bp); 
+		bp := CheckBP(bp);
+		SYSTEM.GET(bp+SIZEOF(ADDRESS), pc);
+		TRACE(pc);
+		SYSTEM.GET(bp, bp); 
+		bp := CheckBP(bp);
+		SYSTEM.GET(bp+SIZEOF(ADDRESS), pc);
+		TRACE(pc);
+END GetPCs;
+
+PROCEDURE DecRefCount(VAR count: WORD): BOOLEAN;
+VAR value: WORD;
+BEGIN
+		LOOP
+			value := CAS (count,0,0);
+			ASSERT(value > 0); 
+			IF CAS (count, value, value-1) = value THEN RETURN value =1 END;
+		END;
+END DecRefCount;
+
+PROCEDURE RefCount*(p: DataBlockU): WORD;
+BEGIN
+	RETURN p.heapBlock.refCount;
+END RefCount;
+
+
+
+
+(** Mark - Mark an object and its decendents. Used by findRoots. *)
+PROCEDURE RecursiveReset(h {UNTRACED}: HeapBlock);
+VAR 
+	orgBlock: ADDRESS;
+	staticTypeBlock {UNTRACED}: StaticTypeBlock;
+	currentArrayElemAdr, lastArrayElemAdr: ADDRESS; i: LONGINT;
+	protected {UNTRACED}: ProtRecBlock;
+	b {UNTRACED}: POINTER {UNSAFE} TO RECORD p: ANY END;
+	meta {UNTRACED }: POINTER {UNSAFE} TO RECORD staticTypeBlock {FICTIVE=TypeDescOffset}: StaticTypeBlock; last, current, first: ADDRESS END;
+	
+	(* markStack {UNTRACED}: HeapBlockU; *)
+	first {UNTRACED}, last{UNTRACED}: HeapBlockU;
+	count: SIZE;
+	PROCEDURE EnterMe(d: DataBlockU);
+	VAR h: HeapBlockU
+	BEGIN
+		IF (d # NIL) THEN 
+			h := d.heapBlock;
+			IF (h # NIL) & DecRefCount(h.refCount) THEN
+				INC(count); 
+				h.heapBlock := first;
+				(*
+				IF last = NIL THEN 
+					first := h;
+				ELSE
+					last.heapBlock := h;
+				END;
+				last := h;
+				*)
+				first := h;
+			END;
+		END;
+	END EnterMe;
+	
+	(* for queue
+	PROCEDURE Get(): {UNTRACED} HeapBlock;
+	VAR h {UNTRACED}: HeapBlockU;
+	BEGIN
+		h := first;
+		IF h # NIL THEN
+			first := h.heapBlock;
+			IF first = NIL THEN last := NIL END;
+		END;
+		RETURN h;
+	END Get;
+	*)
+
+BEGIN{UNCHECKED} (* omit any range checks etc.*)
+		(* all blocks remain visible from the GC until the reference count is set to -1 *)
+		first := NIL; last := NIL;
+		(*EnterMe(p);*)
+		
+		
+		h.heapBlock := NIL;
+		first := h;
+		
+		(* misuse markstack for stack of objects to reset 
+			objects on this stack are already free by reference counting but the GC still sees them and does not collect them
+		*)
+		WHILE (first # NIL) DO 
+			(*
+			h := Get();
+			*)
+			h := first;
+			first := h.heapBlock;
+			
+			meta := h.dataAdr;
+			
+			staticTypeBlock := meta.staticTypeBlock;
+			IF staticTypeBlock # NIL THEN
+				orgBlock := h.dataAdr;
+
+				IF ~(h IS ArrayBlock) THEN
+					FOR i := 0 TO LEN(staticTypeBlock.pointerOffsets) - 1 DO
+						b := orgBlock + staticTypeBlock.pointerOffsets[i];
+						EnterMe(b.p);
+					END
+				ELSE
+					currentArrayElemAdr := meta.first;
+					
+					lastArrayElemAdr := meta.first + meta.last * staticTypeBlock.recSize;
+					WHILE currentArrayElemAdr < lastArrayElemAdr DO
+						FOR i := 0 TO LEN(staticTypeBlock.pointerOffsets) - 1 DO
+							b := currentArrayElemAdr + staticTypeBlock.pointerOffsets[i];
+							EnterMe(b.p);
+						END;
+						INC(currentArrayElemAdr, staticTypeBlock.recSize);
+					END
+				END;
+				IF h IS ProtRecBlock THEN
+					protected := h(ProtRecBlock);
+					EnterMe(protected.awaitingLock.head);
+					EnterMe(protected.awaitingCond.head);
+					EnterMe(protected.lockedBy);
+					EnterMe(protected.lock);
+				END;
+			END;
+			h.refCount := -1;
+		END;
+		IF count > 100 THEN
+		TRACE(count);
+		END;
+		(*
+		ASSERT(CheckPointer(p));
+		meta := p;
+		staticTypeBlock := meta.staticTypeBlock;
+		IF staticTypeBlock = NIL THEN RETURN END; (* no outgoing pointers *)
+		orgHeapBlock := p.heapBlock;
+		orgBlock := p;
+
+		IF ~(orgHeapBlock IS ArrayBlock) THEN
+			FOR i := 0 TO LEN(staticTypeBlock.pointerOffsets) - 1 DO
+				b := orgBlock + staticTypeBlock.pointerOffsets[i];
+				Reset(b.p)
+			END
+		ELSE
+			currentArrayElemAdr := meta.first;
+			
+			lastArrayElemAdr := meta.first + meta.last * staticTypeBlock.recSize;
+			WHILE currentArrayElemAdr < lastArrayElemAdr DO
+				FOR i := 0 TO LEN(staticTypeBlock.pointerOffsets) - 1 DO
+					b := currentArrayElemAdr + staticTypeBlock.pointerOffsets[i];
+					Reset(b.p)
+				END;
+				INC(currentArrayElemAdr, staticTypeBlock.recSize);
+			END
+		END;
+		IF orgHeapBlock IS ProtRecBlock THEN
+			protected := orgHeapBlock(ProtRecBlock);
+			Reset(protected.awaitingLock.head);
+			Reset(protected.awaitingCond.head);
+			Reset(protected.lockedBy);
+			Reset(protected.lock);
+		END;
+		*)
+END RecursiveReset;
+
+PROCEDURE Reset*(old: DataBlockU);
+BEGIN
+	INC(resets);
+	IF (old # NIL) & (old.heapBlock # NIL) THEN
+		ASSERT(old - old.heapBlock < 256); 
+		IF DecRefCount(old.heapBlock.refCount) THEN 
+			RecursiveReset(old.heapBlock);
+			(*old.heapBlock.refCount := -1;*)
+		END;
+	END;	
+END Reset;
+
+PROCEDURE ResetMathArray*(p: POINTER {UNTRACED,UNSAFE} TO RECORD p: ADDRESS END);
+BEGIN
+	IF p # NIL THEN
+		Reset(p.p);
+	END;
+END ResetMathArray;
+
+PROCEDURE ResetRecord*(src: ADDRESS; tag: StaticTypeBlockU);
+VAR i: SIZE;sval: ADDRESS;
+BEGIN
+	FOR i := 0 TO LEN(tag.pointerOffsets)-1 DO
+		SYSTEM.GET(src+tag.pointerOffsets[i], sval);
+		Reset(sval); 
+	END;
+END ResetRecord;
+
+PROCEDURE ResetArray*(src: ADDRESS; tag: StaticTypeBlockU;  numElems: SIZE);
+VAR i, j: SIZE; sval: ADDRESS; 
+BEGIN
+	FOR j := 0 TO LEN(tag.pointerOffsets)-1 DO
+		FOR i := 0 TO numElems-1 DO
+			SYSTEM.GET(src+ i * tag.recSize + tag.pointerOffsets[j], sval);
+			Reset(sval);
+		END;
+	END;
+END ResetArray;
+
+PROCEDURE Refer*(old: DataBlockU);
+BEGIN
+	INC(refers);
+	IF (old # NIL) & (old.heapBlock # NIL) THEN
+		ASSERT(old - old.heapBlock < 256); 
+		Machine.AtomicInc(old.heapBlock.refCount);
+	END;	
+END Refer;
+
+PROCEDURE ReferMathArray*(p: POINTER {UNTRACED,UNSAFE} TO RECORD p: ADDRESS END);
+BEGIN
+	IF p # NIL THEN 
+		Refer(p.p);
+	END;
+END ReferMathArray;
+
+PROCEDURE ReferRecord*(src: ADDRESS; tag: StaticTypeBlockU);
+VAR i: SIZE;sval: ADDRESS;
+BEGIN
+	FOR i := 0 TO LEN(tag.pointerOffsets)-1 DO
+		SYSTEM.GET(src+tag.pointerOffsets[i], sval);
+		Refer(sval); 
+	END;
+END ReferRecord;
+
+PROCEDURE ReferArray*(src: ADDRESS; tag: StaticTypeBlockU;  numElems: SIZE);
+VAR i, j: SIZE; sval: ADDRESS; 
+BEGIN
+	FOR j := 0 TO LEN(tag.pointerOffsets)-1 DO
+		FOR i := 0 TO numElems-1 DO
+			SYSTEM.GET(src+i * tag.recSize + tag.pointerOffsets[j], sval);
+			Refer(sval);
+		END;
+	END;
+END ReferArray;
+
+PROCEDURE CheckInternalAssignment(dest, src: DataBlockU);
+VAR old: DataBlockU;
+BEGIN
+	INC(assigns); 
+	IF (src # NIL) & (src.heapBlock # NIL) THEN 
+		ASSERT(src - src.heapBlock < 256);
+		Machine.AtomicInc(src.heapBlock.refCount);
+	END;
+
+	SYSTEM.GET(dest, old);
+	Reset(old);
+	(*IF (old # NIL) & (old.heapBlock # NIL) THEN
+		IF (old - old.heapBlock < 256) THEN
+			Machine.AtomicDec(old.heapBlock.refCount);
+			IF (old.heapBlock.refCount < 0) THEN TRACE(old.heapBlock.refCount);HALT(100); GetPCs(); END; 
+		ELSE
+			TRACE(old, old.heapBlock, old-old.heapBlock);
+			HALT(100); 
+			GetPCs();
+			
+		END;
+	END;
+	*)
+	
+END CheckInternalAssignment;
+
+PROCEDURE CheckAssignment*(dest, src: DataBlockU);
+BEGIN
+	(*IF (currentGeneration = Young) OR (youngCounts > 0) THEN*)
+		CheckInternalAssignment(dest, src);
+	(*END;*)
+END CheckAssignment;
 
 PROCEDURE Assign*(VAR dest: ADDRESS; src: ADDRESS);
 BEGIN
 	CheckInternalAssignment(ADDRESS OF dest,src);
 	dest := src;
-	INC(assigns);
 END Assign;
 
 PROCEDURE AssignRecord*(dest: ADDRESS; tag: StaticTypeBlockU; src: ADDRESS);
-VAR i: LONGINT; sval: ADDRESS;
+VAR i: SIZE; sval: ADDRESS;
 BEGIN
 	FOR i := 0 TO LEN(tag.pointerOffsets)-1 DO
 		SYSTEM.GET(src+tag.pointerOffsets[i], sval);
 		CheckInternalAssignment(dest + tag.pointerOffsets[i], sval); 
 	END;
 	SYSTEM.MOVE(src,dest,tag.recSize);
-	INC(assigns);
 END AssignRecord;
 
 PROCEDURE AssignArray*(dest: ADDRESS; tag: StaticTypeBlockU;  numElems: SIZE; src: ADDRESS);
-VAR i, j: SIZE; sval: ADDRESS; 
+VAR i, j: SIZE; sval,offset: ADDRESS; 
 BEGIN
 	FOR j := 0 TO LEN(tag.pointerOffsets)-1 DO
-	FOR i := 0 TO numElems-1 DO
-		SYSTEM.GET(src+tag.pointerOffsets[i] + i * tag.recSize + tag.pointerOffsets[j], sval);
-		CheckInternalAssignment(dest+ i * tag.recSize + tag.pointerOffsets[j], sval);
-	END;
+		FOR i := 0 TO numElems-1 DO
+			offset := i * tag.recSize + tag.pointerOffsets[j];
+			SYSTEM.GET(src+offset, sval);
+			CheckInternalAssignment(dest+ offset, sval);
+		END;
 	END;
 	SYSTEM.MOVE(src,dest,tag.recSize * numElems);
-	INC(assigns);	
 END AssignArray;
 
 (* NilGC - Default garbage collector. *)
@@ -1811,6 +2093,12 @@ BEGIN
 	Machine.Release(Machine.Heaps);
 END SetOld;
 
+PROCEDURE Report*;
+BEGIN
+	TRACE(resets, refers, assigns);
+END Report;
+
+
 
 
 PROCEDURE SetHeuristic*;