added TRM Builtins

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

source/TRM.Builtins.Mod

@@ -0,0 +1,421 @@
+MODULE Builtins; (** AUTHOR ""; PURPOSE ""; *)
+(**
+@concept
+The module [[TRMRuntime]] provides run-time services implemented as procedures. The compiler \
+emits procedure calls for all invocations of the runtime.
+**)
+IMPORT SYSTEM;
+
+CONST expo = 7F800000H; bias = 3F800000H;
+	mant = 7FFFFFH; mant1 = LONGINT(0FFC00000H); mant2 = 0FFFFFFH;
+	LimE = 0C800000H; C = 800000H; S = LONGINT(80000000H); M= LONGINT(7FFFFFFFH);
+
+VAR
+	lastDataAddress-: ADDRESS;
+	emptyVariable: RECORD END; (* always linked to top of used memory *)
+
+(* for testing test with intel
+VAR high: LONGINT;
+
+	PROCEDURE SimulatedMul(l,r: LONGINT): LONGINT;
+	VAR h: HUGEINT;
+	BEGIN
+		h := HUGEINT(l)*r;
+		high := LONGINT(h DIV 100000000H);
+		RETURN LONGINT(h MOD 100000000H);
+	END SimulatedMul;
+
+	PROCEDURE H(): LONGINT;
+		RETURN high
+	END H;
+*)
+	PROCEDURE H(): LONGINT;
+	CODE
+		LDH R0
+	END H;
+
+	(* helper functions *)
+	PROCEDURE MSK(x,bits: LONGINT): LONGINT;
+	BEGIN
+		RETURN SYSTEM.VAL(LONGINT, SYSTEM.VAL(SET,x)*SYSTEM.VAL(SET,bits))
+	END MSK;
+
+	PROCEDURE NULLF(x: LONGINT): BOOLEAN;
+	BEGIN RETURN SYSTEM.VAL(SET,x) * SYSTEM.VAL(SET,M) = {}
+	END NULLF;
+
+	PROCEDURE ConvertIR*(x: LONGINT): REAL; (* Float 32 bit *)
+	VAR xe, s: LONGINT; odd,odd1: BOOLEAN; odds: LONGINT;
+	BEGIN s := x;
+		IF x # 0 THEN
+			x := ABS(x); xe := 4B000000H;
+			IF x >= 2*C THEN
+				odd := FALSE; odd1 := FALSE;
+				REPEAT
+					odd1 := odd1 OR odd;
+					odd := ODD(x); (* rounding bit *)
+					x := ROT(MSK(x, -2),-1); (*ASH(x,-1);*) INC(xe,C);
+					(*D.Hex(x,10); D.Ln;*)
+				UNTIL x <2*C;
+
+				(* round half to even, standard in IEEE 754 *)
+				IF odd & (ODD(x) OR odd1) & (x<2*C) THEN INC(x) END; (* rounding *)
+			ELSIF x < C THEN
+				REPEAT x := x+x; xe := xe - C UNTIL x >= C
+			END ;
+			x := xe - C + x;
+			IF s < 0 THEN x := x+S END
+		END ;
+		RETURN SYSTEM.VAL(REAL,x)
+	END ConvertIR;
+
+	PROCEDURE ConvertHR*(x: HUGEINT): REAL;
+	BEGIN HALT(200);
+	END ConvertHR;
+
+	PROCEDURE ConvertRI*(l: REAL): LONGINT; (* Floor 32bit *)
+	VAR x,xe, n, sign: LONGINT;
+	BEGIN
+		x := SYSTEM.VAL(LONGINT,l);
+		IF ~NULLF(x) THEN
+			sign := MSK(x, S);
+			xe := MSK(x, expo) - bias; x := MSK(x, mant) + C;
+			IF xe >= 0 THEN xe := ROT(xe, -23) ELSE xe := -1 END ;
+			IF sign < 0 THEN x := -x END ;
+			IF xe < 24 THEN n := 23 - xe;
+				WHILE n > 0 DO x := ROT(MSK(x, -2), -1) + sign; DEC(n) END
+			ELSIF xe >= 31 THEN x := MIN(LONGINT)
+			ELSE n := xe - 23;
+				WHILE n > 0 DO x := x+x; DEC(n) END
+			END
+		ELSE x := 0
+		END ;
+		RETURN x
+	END ConvertRI;
+
+	PROCEDURE ConvertRH*(x: REAL): HUGEINT ;
+	BEGIN HALT(200);
+	END ConvertRH;
+
+	(* 32 bit float instructions *)
+
+	PROCEDURE AddR*(l,r: REAL): REAL;
+	VAR x,y,xe, ye, xm, ym, sign: LONGINT; odd, odd1: BOOLEAN;
+	BEGIN
+		x := SYSTEM.VAL(LONGINT,l);
+		y := SYSTEM.VAL(LONGINT,r);
+		IF NULLF(x) THEN x := y
+		ELSIF ~NULLF(y) THEN
+			xe := MSK(x, expo) - bias; xm := MSK(x, mant) + C;
+			ye := MSK(y, expo) - bias; ym := MSK(y, mant) + C;
+			IF xe < ye THEN (*denorm x*)
+				IF ye - xe > LimE THEN xm := 0; xe := ye ELSE
+					odd1 := FALSE; odd := FALSE;
+					REPEAT odd1 := odd1 OR odd; odd := ODD(xm); xe := xe + C; xm := ROT(MSK(xm, -2), -1) UNTIL xe = ye;
+					(* half even rounding *)
+					IF odd & (odd1 OR ODD(xm)) THEN INC(xm) END;
+				END
+			ELSIF ye < xe THEN (*denorm y*)
+				IF xe - ye > LimE THEN ym := 0 ELSE
+					odd := FALSE; odd1 := FALSE;
+					REPEAT odd1 := odd1 OR odd; odd := ODD(ym); ye := ye + C; ym := ROT(MSK(ym, -2), -1) UNTIL ye = xe;
+					(* half even rounding *)
+					IF odd & (odd1 OR ODD(ym)) THEN INC(xm) END;
+				END
+			END ;
+			IF x < 0 THEN xm := -xm END ;
+			IF y < 0 THEN ym := -ym END ;
+			x := xm + ym; sign := MSK(x, S);
+			IF x # 0 THEN
+				IF x < 0 THEN x := -x END ;
+				IF x >= 2*C THEN
+					odd := ODD(x);
+					x := ROT(MSK(x, -2), -1);
+					(* half even rounding *)
+					IF odd & ODD(x) THEN INC(x) END;
+					xe := xe + C
+				ELSE (*normalize*)
+					WHILE x < C DO
+						x := ROT(x, -31); xe := xe - C
+					END
+				END ;
+				IF xe < -bias THEN x := 0  (*underflow*)
+				ELSIF (xe <= bias) THEN x := (x-C) + xe + bias + sign
+				ELSE xe := M
+				END
+			END
+		END ;
+		RETURN SYSTEM.VAL(REAL,x)
+	END AddR;
+
+	PROCEDURE SubR*(l,r: REAL): REAL;
+	BEGIN RETURN AddR(l,-r)
+	END SubR;
+
+	PROCEDURE MulR*(l,r: REAL): REAL; (* float 32 * float 32 => float 32 *)
+	VAR x,y,xe, ye, sign: LONGINT;
+	BEGIN
+		x := SYSTEM.VAL(LONGINT,l);
+		y := SYSTEM.VAL(LONGINT,r);
+		IF NULLF(y) THEN x := 0
+		ELSIF ~NULLF(x) THEN
+			sign := MSK(x, S) + MSK(y, S);
+			xe := MSK(x, expo) - bias; x := MSK(x, mant) + C;
+			ye := MSK(y, expo) - bias; y := MSK(y, mant) + C;
+			xe := xe + ye; x := x * y (*testing: SimulatedMul(x,y) *);
+			IF xe < -bias THEN x := 0  (*underflow*)
+			ELSIF (xe <= bias) THEN
+				x := ROT(MSK(x, mant1),-24)+ROT(H(),8);
+				IF MSK(x, C) = 0 THEN (*normalize*)
+					x := ROT(x, -31); xe := xe - C
+				END;
+				IF x < 0 THEN x := x + 1 (*round*) END;
+				x := MSK(x, mant2) + xe + bias + sign;
+			ELSE x := M;
+			END
+		ELSE x := 0;
+		END ;
+		RETURN SYSTEM.VAL(REAL,x)
+	END MulR;
+
+	PROCEDURE DivR*(l,r: REAL): REAL; (* float 32 / float 32 => float 32 *)
+	VAR x,y,xe, ye, q, n, sign: LONGINT;
+	BEGIN
+		x := SYSTEM.VAL(LONGINT,l);
+		y := SYSTEM.VAL(LONGINT,r);
+		ASSERT(ABS(y) # 0,26);
+		IF ~NULLF(x) THEN
+			sign := MSK(x, S) + MSK(y, S);
+			xe := MSK(x, expo) - bias; x := MSK(x, mant) + C;
+			ye := MSK(y, expo) - bias; y := MSK(y, mant) + C;
+			xe := xe - ye;
+			IF x < y THEN x := ROT(x, -31); xe := xe - C END ;
+			n := 25; q := 0;
+			REPEAT q := ROT(q, -31);
+				IF x >= y THEN x := x - y; INC(q) END ;
+				x := ROT(x, -31); DEC(n)
+			UNTIL n = 0;
+			q := ROT(MSK(q+1, -2), -1);  (*round*)
+			IF xe < -bias THEN x := 0  (*underflow*)
+			ELSIF (xe <= bias) THEN x := q - C + xe + bias + sign
+			ELSE x := M;
+			END
+		ELSE x := 0
+		END ;
+		RETURN SYSTEM.VAL(REAL,x)
+	END DivR;
+
+	PROCEDURE AbsR*(x: REAL): REAL;
+	BEGIN
+		IF x < 0 THEN RETURN -x ELSE RETURN x END
+	END AbsR;
+
+	PROCEDURE DivModL(dividend, divisor: LONGINT; VAR quotient, remainder: LONGINT);
+	VAR d: LONGINT;
+	BEGIN
+		ASSERT(dividend >=0); ASSERT(divisor > 0);
+		remainder := dividend;
+		quotient := 0;
+		d := divisor;
+		REPEAT d := ASH(d,1) UNTIL (d > dividend) OR (d < 0);
+		REPEAT d := LSH(d,-1); quotient := ASH(quotient,1);
+			IF remainder >= d THEN remainder := remainder - d; quotient := quotient+1 END
+		UNTIL d = divisor;
+	END DivModL;
+
+	(* 32 bit integer instructions *)
+	PROCEDURE DivL*(l,r: LONGINT): LONGINT;
+	VAR quotient, remainder: LONGINT;
+	BEGIN
+		IF l < 0 THEN
+			DivModL(-l,r,quotient,remainder);
+			RETURN -quotient-1;
+		ELSE
+			DivModL(l,r,quotient,remainder);
+			RETURN quotient
+		END;
+	END DivL;
+
+	PROCEDURE ModL*(l,r: LONGINT): LONGINT;
+	VAR quotient, remainder: LONGINT;
+	BEGIN
+		IF l < 0 THEN
+			DivModL(-l,r,quotient,remainder);
+			RETURN r - remainder;
+		ELSE
+			DivModL(l,r,quotient,remainder);
+			RETURN remainder
+		END;
+	END ModL;
+
+	(* 64 bit integer instructions *)
+	PROCEDURE DivH*(l,r: HUGEINT): HUGEINT ;
+	BEGIN HALT(200);
+	END DivH;
+	PROCEDURE ModH*(l,r: HUGEINT): HUGEINT ;
+	BEGIN HALT(200);
+	END ModH;
+	PROCEDURE AbsH*(x: HUGEINT): HUGEINT;
+	BEGIN IF x < 0 THEN RETURN -x ELSE RETURN x END;
+	END AbsH;
+	PROCEDURE AslH*(l,r: HUGEINT): HUGEINT ;
+	BEGIN HALT(200);
+	END AslH;
+	PROCEDURE LslH*(l,r: HUGEINT): HUGEINT ;
+	BEGIN HALT(200);
+	END LslH;
+	PROCEDURE AsrH*(l,r: HUGEINT): HUGEINT;
+	BEGIN HALT(200);
+	END AsrH;
+	PROCEDURE LsrH*(l,r: HUGEINT): HUGEINT ;
+	BEGIN HALT(200);
+	END LsrH;
+	PROCEDURE RorH*(l,r: HUGEINT): HUGEINT;
+	BEGIN HALT(200);
+	END RorH;
+	PROCEDURE RolH*(l,r: HUGEINT): HUGEINT;
+	BEGIN HALT(200);
+	END RolH;
+
+	(* currently unused 64 bit float support
+
+	(* conversions such as ENTIER, SHORT or implicit *)
+	PROCEDURE ConvertXR*(x: LONGREAL): REAL;
+	BEGIN HALT(200);
+	END ConvertXR;
+
+	PROCEDURE ConvertRX*(x: REAL): LONGREAL ;
+	BEGIN HALT(200);
+	END ConvertRX;
+
+	PROCEDURE ConvertIX*(x: LONGINT): LONGREAL;
+	VAR xe: LONGINT;  h: HUGEINT;
+	CONST B = 1023; C=10000000000000H;
+	BEGIN
+		IF x # 0 THEN
+			h := ABS(x); xe := 52;
+			IF h >= 2*C THEN
+				REPEAT h := h DIV 2; INC(xe) UNTIL h < 2*C
+			ELSIF h < C THEN
+				REPEAT h := 2*h; DEC(xe) UNTIL h >= C
+			END ;
+			h := (xe + B -1)*C + h;
+			IF x < 0 THEN h := -h END
+		END ;
+		RETURN SYSTEM.VAL(LONGREAL,h)
+	END ConvertIX;
+
+	PROCEDURE ConvertXI*(x: LONGREAL): LONGINT ;
+	BEGIN HALT(200);
+	END ConvertXI;
+
+	PROCEDURE ConvertXH*(x: LONGREAL): HUGEINT ;
+	BEGIN HALT(200);
+	END ConvertXH;
+
+	(* 64 bit float instructions *)
+	PROCEDURE AddX*(l,r: LONGREAL): LONGREAL ;
+	BEGIN HALT(200);
+	END AddX;
+
+	PROCEDURE SubX*(l,r: LONGREAL): LONGREAL ;
+	BEGIN HALT(200);
+	END SubX;
+
+	PROCEDURE MulX*(l,r: LONGREAL): LONGREAL;
+	BEGIN HALT(200);
+	END MulX;
+
+	PROCEDURE DivX*(l,r: LONGREAL): LONGREAL;
+	BEGIN HALT(200);
+	END DivX;
+
+	PROCEDURE AbsX*(x: LONGREAL): LONGREAL;
+	BEGIN 	IF x < 0 THEN RETURN -x ELSE RETURN x END
+	END AbsX;
+
+	PROCEDURE ConvertHX*(x: HUGEINT): LONGREAL;
+	BEGIN HALT(200);
+	END ConvertHX;
+	*)
+
+
+	(* compare strings,
+		returns 0 if strings are equal,
+		returns +1 if left is lexicographic greater than right,
+		returns -1 if left is lexicographics smaller than right
+		traps if src or destination is not 0X terminated and comparison is not finished
+	*)
+	PROCEDURE CompareString*(CONST left,right: ARRAY OF CHAR): SHORTINT;
+	VAR i: LONGINT; res: SHORTINT; l,r: CHAR;
+	BEGIN
+		i := 0; res := 0;
+		LOOP
+			l := left[i]; 		(* index check included *)
+			r := right[i];		(* index check included *)
+			IF (l > r) THEN
+				res := 1; EXIT
+			ELSIF (l<r) THEN
+				res := -1; EXIT
+			ELSIF l=0X THEN
+				EXIT
+			END;
+			INC(i);
+		END;
+		RETURN res
+	END CompareString;
+
+	(* copy string from src to dest, emits trap if not 0X terminated or destination too short *)
+	PROCEDURE CopyString*(VAR dest: ARRAY OF CHAR; CONST src: ARRAY OF CHAR);
+	VAR i: LONGINT; ch :CHAR; l1,l2: LONGINT;
+	BEGIN
+		(*
+		i := 0;
+		REPEAT
+			ch := src[i];		(* index check included *)
+			dest[i] := ch;	(* index check included *)
+			INC(i);
+		UNTIL ch=0X;
+		*)
+
+		(*! currently implemented: old PACO semantics *)
+		l1 := LEN(dest);
+		l2 := LEN(src);
+		IF l2 < l1 THEN l1 := l2 END;
+		SYSTEM.MOVE(ADDRESSOF(src[0]),ADDRESSOF(dest[0]),l1);
+		dest[l1-1] := 0X;
+	END CopyString;
+
+	PROCEDURE EnsureAllocatedStack*(size: SIZE);
+	VAR i,temp: ADDRESS;
+	BEGIN
+		FOR i := 0 TO size BY 4096 DO
+			temp := SYSTEM.GET32(ADDRESSOF(i)-i);
+			(*
+			SYSTEM.PUT(ADDRESSOF(val)-i,0);
+			*)
+		END;
+	(*
+	CODE{SYSTEM.i386}
+		MOV EAX, [EBP+size]
+		SHR EAX,12 ; divide by 4096
+		MOV ECX,-4
+	start:
+		MOV EDX,[EBP+ECX]
+		SUB ECX,4096
+		TST EAX
+		DEC EAX
+		JNZ start
+	*)
+	END EnsureAllocatedStack;
+
+	(*! should not be used, linker cannot deal with fixup here -- late time code generation does not help because this is a code section *)
+	(*
+	PROCEDURE {NOPAF} LastAddress; (* empty procedure, linker places this always at the end of code memory *)
+	CODE
+	END LastAddress;
+	*)
+
+BEGIN
+	lastDataAddress := ADDRESSOF(emptyVariable);
+END Builtins.