hyung-hwan/hcl
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

added bigint multiplication

Browse Source
This commit is contained in:
hyung-hwan 2014-02-24 15:17:57 +00:00
parent bee0815c1e
commit 998f5a2e55
3 changed files with 260 additions and 120 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

295
lib/h2-scheme-bigint.adb
View File

@ -13,7 +13,8 @@ package body Bigint is
System.Default_Bit_Order = System.Low_Order_First
);
Half_Word_Bits: constant := Object_Pointer_Bits / 2;
--Half_Word_Bits: constant := Object_Pointer_Bits / 2;
Half_Word_Bits: constant := Object_Half_Word'Size;
Half_Word_Bytes: constant := Half_Word_Bits / System.Storage_Unit;
type Word_Record is record
@ -35,6 +36,8 @@ package body Bigint is
--for Word_Record'Bit_Order use System.High_Order_First;
--for Word_Record'Bit_Order use System.Low_Order_First;
-----------------------------------------------------------------------------
function Get_Low (W: in Object_Word) return Object_Half_Word is
R: Word_Record;
for R'Address use W'Address;
@ -60,6 +63,8 @@ package body Bigint is
return W;
end Make_Word;
-----------------------------------------------------------------------------
function Is_Less_Unsigned (X: in Object_Pointer;
Y: in Object_Pointer) return Standard.Boolean is
pragma Inline (Is_Less_Unsigned);
@ -99,9 +104,20 @@ package body Bigint is
return X.Size = 1 and then X.Half_Word_Slot(1) = 0;
end Is_Zero;
function Normalize (X: in Object_Pointer) return Object_Pointer is
-----------------------------------------------------------------------------
function Normalize (Interp: access Interpreter_Record;
X: in Object_Pointer) return Object_Pointer is
Last: Half_Word_Object_Size := 1;
begin
case X.Size is
for I in reverse 1 .. X.Size loop
if X.Half_Word_Slot(I) /= 0 then
Last := I;
exit;
end if;
end loop;
case Last is
when 1 =>
if X.Sign = Negative_Sign then
return Integer_To_Pointer(-Object_Integer(X.Half_Word_Slot(1)));
@ -115,29 +131,90 @@ package body Bigint is
if X.Sign = Negative_Sign then
if W in 0 .. Object_Word(-Object_Signed_Word(Object_Integer'First)) then
return Integer_To_Pointer(-Object_Integer(W));
else
return X;
end if;
else
if W in 0 .. Object_Word(Object_Integer'Last) then
return Integer_To_Pointer(Object_Integer(W));
else
return X;
end if;
end if;
end;
when others =>
return X;
null;
end case;
if X.Size = Last then
return X;
else
return Make_Bigint(Interp, X, Last);
end if;
end Normalize;
-----------------------------------------------------------------------------
generic
with function Operator (X: in Object_Integer;
Y: in Object_Integer) return Object_Integer;
procedure Plain_Integer_Op (Interp: access Interpreter_Record;
X: in out Object_Pointer;
Y: in out Object_Pointer;
Z: out Object_Pointer);
procedure Plain_Integer_Op (Interp: access Interpreter_Record;
X: in out Object_Pointer;
Y: in out Object_Pointer;
Z: out Object_Pointer) is
A: aliased Object_Pointer := X;
B: aliased Object_Pointer := Y;
begin
if Is_Integer(A) and then Is_Integer(B) then
declare
G: Object_Integer := Pointer_To_Integer(A);
H: Object_Integer := Pointer_To_Integer(B);
begin
X := A;
Y := B;
Z := Integer_To_Pointer(Operator(G, H));
return;
exception
when Constraint_Error =>
Push_Top (Interp.all, A'Unchecked_Access);
Push_Top (Interp.all, B'Unchecked_Access);
-- TODO: allocate A and B from a non-GC heap.
-- I know that pointers returned by Make_Bigint here are short-lived
-- and not needed after actual operation. non-GC heap is a better choice.
A := Make_Bigint(Interp, Value => G);
B := Make_Bigint(Interp, Value => H);
Pop_Tops (Interp.all, 2);
end;
else
Push_Top (Interp.all, A'Unchecked_Access);
Push_Top (Interp.all, B'Unchecked_Access);
if Is_Integer(A) then
A := Make_Bigint(Interp, Value => Pointer_To_Integer(A));
end if;
if Is_Integer(B) then
B := Make_Bigint(Interp, Value => Pointer_To_Integer(B));
end if;
Pop_Tops (Interp.all, 2);
end if;
X := A;
Y := B;
Z := null;
end Plain_Integer_Op;
procedure Add_Integers is new Plain_Integer_Op (Operator => "+");
procedure Subtract_Integers is new Plain_Integer_Op (Operator => "-");
procedure Multiply_Integers is new Plain_Integer_Op (Operator => "*");
procedure Divide_Integers is new Plain_Integer_Op (Operator => "/");
-----------------------------------------------------------------------------
function Add_Unsigned (Interp: access Interpreter_Record;
X: in Object_Pointer;
Y: in Object_Pointer) return Object_Pointer is
--pragma Assert (Is_Integer(X) or else Is_Bigint(X));
--pragma Assert (Is_Integer(Y) or else Is_Bigint(Y));
pragma Assert (Is_Bigint(X));
pragma Assert (Is_Bigint(Y));
@ -187,14 +264,6 @@ package body Bigint is
end;
end if;
declare
package Int_IO is new ada.text_io.modular_IO(object_half_word);
begin
for I in reverse Z.Half_Word_Slot'Range loop
int_io.put (Z.Half_Word_Slot(I), base=>16);
ada.text_io.new_line;
end loop;
end;
Pop_Tops (Interp.all, 3);
return Z;
end Add_Unsigned;
@ -246,52 +315,75 @@ end;
end if;
end loop;
ada.text_io.put_line ("------------SUBTRACT-");
declare
package Int_IO is new ada.text_io.modular_IO(object_half_word);
begin
for I in reverse Z.Half_Word_Slot'Range loop
int_io.put (Z.Half_Word_Slot(I), base=>16);
ada.text_io.new_line;
end loop;
end;
return Z;
end Subtract_Unsigned;
function Multiply_Unsigned (Interp: access Interpreter_Record;
X: in Object_Pointer;
Y: in Object_Pointer) return Object_Pointer is
A, B, Z: aliased Object_Pointer;
W: Object_Word;
Low, High: Object_Half_Word;
Carry: Object_Half_Word;
Index: Half_Word_Object_Size;
begin
Push_Top (Interp.all, A'Unchecked_Access);
Push_Top (Interp.all, B'Unchecked_Access);
Push_Top (Interp.all, Z'Unchecked_Access);
A := X;
B := Y;
Z := Make_Bigint (Interp.Self, A.Size + B.Size);
--for I in B.Half_Word_Slot'Range loop
for I in 1 .. B.Size loop
if B.Half_Word_Slot(I) = 0 then
Z.Half_Word_Slot(A.Size + I) := 0;
else
Carry := 0;
--for J in A.Half_Word_Slot'Range loop
for J in 1 .. A.Size loop
W := Object_Word(A.Half_Word_Slot(J)) * Object_Word(B.Half_Word_Slot(I));
Low := Get_Low(W);
High := Get_High(W);
Low := Low + Carry;
if Low < Carry then
High := High + 1;
end if;
Index := J + I - 1;
Low := Low + Z.Half_Word_Slot(Index);
if Low < Z.Half_Word_SLot(Index) then
High := High + 1;
end if;
Z.Half_Word_Slot(Index) := Low;
Carry := High;
end loop;
Z.Half_Word_Slot(A.Size + I) := Carry;
end if;
end loop;
Pop_Tops (Interp.all, 3);
return Z;
end Multiply_Unsigned;
-----------------------------------------------------------------------------
function Add (Interp: access Interpreter_Record;
X: in Object_Pointer;
Y: in Object_Pointer) return Object_Pointer is
Z: Object_Pointer;
A: aliased Object_Pointer;
B: aliased Object_Pointer;
A: Object_Pointer := X;
B: Object_Pointer := Y;
Sign: Object_Sign;
begin
if Is_Integer(X) and then Is_Integer(Y) then
declare
G: Object_Integer := Pointer_To_Integer(X);
H: Object_Integer := Pointer_To_Integer(Y);
T: Object_Integer;
begin
T := G + H;
return Integer_To_Pointer(T);
exception
when Constraint_Error =>
Push_Top (Interp.all, A'Unchecked_Access);
Push_Top (Interp.all, B'Unchecked_Access);
A := Make_Bigint(Interp, G);
B := Make_Bigint(Interp, H);
end;
else
Push_Top (Interp.all, A'Unchecked_Access);
Push_Top (Interp.all, B'Unchecked_Access);
A := X;
B := Y;
if Is_Integer(A) then
A := Make_Bigint(Interp, Pointer_To_Integer(A));
end if;
if Is_Integer(B) then
B := Make_Bigint(Interp, Pointer_To_Integer(B));
end if;
Add_Integers (Interp, A, B, Z);
if Z /= null then
return Z;
end if;
if A.Sign /= B.Sign then
@ -301,75 +393,78 @@ end;
Z := Subtract (Interp, A, B);
end if;
else
Sign := A.Sign;
Z := Add_Unsigned (Interp, A, B);
Z.Sign := A.Sign;
Z.Sign := Sign;
end if;
Pop_Tops (Interp.all, 2);
return Normalize(Z);
return Normalize(Interp, Z);
end Add;
function Subtract (Interp: access Interpreter_Record;
X: in Object_Pointer;
Y: in Object_Pointer) return Object_Pointer is
Z: Object_Pointer;
A: aliased Object_Pointer;
B: aliased Object_Pointer;
A: Object_Pointer := X;
B: Object_Pointer := Y;
Sign: Object_Sign;
begin
if Is_Integer(X) and then Is_Integer(Y) then
declare
G: Object_Integer := Pointer_To_Integer(X);
H: Object_Integer := Pointer_To_Integer(Y);
T: Object_Integer;
begin
T := G + H;
return Integer_To_Pointer(T);
exception
when Constraint_Error =>
Push_Top (Interp.all, A'Unchecked_Access);
Push_Top (Interp.all, B'Unchecked_Access);
A := Make_Bigint(Interp, G);
B := Make_Bigint(Interp, H);
end;
else
Push_Top (Interp.all, A'Unchecked_Access);
Push_Top (Interp.all, B'Unchecked_Access);
A := X;
B := Y;
if Is_Integer(A) then
A := Make_Bigint(Interp, Pointer_To_Integer(A));
end if;
if Is_Integer(B) then
B := Make_Bigint(Interp, Pointer_To_Integer(B));
end if;
Subtract_Integers (Interp, A, B, Z);
if Z /= null then
return Z;
end if;
if A.Sign /= B.Sign then
Sign := A.Sign;
Z := Add_Unsigned (Interp, A, B);
Z.Sign := A.Sign;
--if A.Sign = Negative_Sign then
-- Z.Sign := Negative_Sign;
-- Z.Sign := Negative_Sign;
--else
-- Z := Add_Unsigned (Interp, A, B);
--end if;
Z.Sign := Sign;
else
if Is_Less_Unsigned(A, B) then
Z := Subtract_Unsigned (Interp, B, A);
--Z.Sign := Object_Sign'Val(not Object_Sign'Pos(A.Sign)); -- opposite A.Sign
--Sign := Object_Sign'Val(not Object_Sign'Pos(A.Sign)); -- opposite A.Sign
if A.Sign = Negative_Sign then
Z.Sign := Positive_Sign;
Sign := Positive_Sign;
else
Z.Sign := Negative_Sign;
Sign := Negative_Sign;
end if;
Z := Subtract_Unsigned (Interp, B, A);
Z.Sign := Sign;
else
Sign := A.Sign;
Z := Subtract_Unsigned (Interp, A, B);
Z.Sign := A.Sign;
Z.Sign := Sign;
end if;
end if;
Pop_Tops (Interp.all, 2);
return Normalize(Z);
return Normalize(Interp, Z);
end Subtract;
function Multiply (Interp: access Interpreter_Record;
X: in Object_Pointer;
Y: in Object_Pointer) return Object_Pointer is
Z: Object_Pointer;
A: Object_Pointer := X;
B: Object_Pointer := Y;
Sign: Object_Sign;
begin
Multiply_Integers (Interp, A, B, Z);
if Z /= null then
return Z;
end if;
-- Determine the sign earlier than any object allocation
-- to avoid GC side-effects because A and B are not pushed
-- as temporarry object pointers.
if A.Sign = B.Sign then
Sign := Positive_Sign;
else
Sign := Negative_Sign;
end if;
Z := Multiply_Unsigned (Interp, A, B);
Z.Sign := Sign;
return Normalize(Interp, Z);
end Multiply;
end Bigint;

66
lib/h2-scheme.adb
View File

@ -273,12 +273,12 @@ package body H2.Scheme is
return Get_Pointer_Type(Pointer) = Object_Pointer_Type_Byte;
end Is_Byte;
function Integer_To_Pointer (Int: in Object_Integer) return Object_Pointer is
function Integer_To_Pointer (Value: in Object_Integer) return Object_Pointer is
Pointer: Object_Pointer;
Word: Object_Word;
for Word'Address use Pointer'Address;
begin
if Int < 0 then
if Value < 0 then
-- change the sign of a negative number.
-- '-Int' may violate the range of Object_Integer
-- if it is Object_Integer'First. So I add 1 to 'Int'
@ -287,22 +287,21 @@ package body H2.Scheme is
--Word := Object_Word (-(Int + 1)) + 1;
-- Let me use Object_Signed_Word instead of the trick shown above
Word := Object_Word(-Object_Signed_Word(Int));
Word := Object_Word(-Object_Signed_Word(Value));
-- shift the number to the left by 2 and
-- set the highest bit on by force.
Word := (Word * (2 ** Object_Pointer_Type_Bits)) or Object_Word(Object_Pointer_Type_Integer) or (2 ** (Word'Size - 1));
else
Word := Object_Word(Int);
Word := Object_Word(Value);
-- Shift 'Word' to the left by 2 and set the integer mark.
Word := (Word * (2 ** Object_Pointer_Type_Bits)) or Object_Word(Object_Pointer_Type_Integer);
end if;
--return Object_Label_To_Object_Pointer (Word);
return Pointer;
end Integer_To_Pointer;
function Character_To_Pointer (Char: in Object_Character) return Object_Pointer is
function Character_To_Pointer (Value: in Object_Character) return Object_Pointer is
Pointer: Object_Pointer;
Word: Object_Word;
for Word'Address use Pointer'Address;
@ -313,18 +312,17 @@ package body H2.Scheme is
-- or short. In reality, the last Unicode code point assigned is far
-- less than #16#7FFFFFFF# as of this writing. So I should not be
-- worried about it for the time being.
Word := Object_Character'Pos(Char);
Word := Object_Character'Pos(Value);
Word := (Word * (2 ** Object_Pointer_Type_Bits)) or Object_Word(Object_Pointer_Type_Character);
--return Object_Label_To_Object_Pointer (Word);
return Pointer;
end Character_To_Pointer;
function Byte_To_Pointer (Byte: in Object_Byte) return Object_Pointer is
function Byte_To_Pointer (Value: in Object_Byte) return Object_Pointer is
Pointer: Object_Pointer;
Word: Object_Word;
for Word'Address use Pointer'Address;
begin
Word := Object_Word(Byte);
Word := Object_Word(Value);
Word := (Word * (2 ** Object_Pointer_Type_Bits)) or Object_Word(Object_Pointer_Type_Byte);
return Pointer;
end Byte_To_Pointer;
@ -339,7 +337,7 @@ package body H2.Scheme is
--end Pointer_To_Word;
function Pointer_To_Integer (Pointer: in Object_Pointer) return Object_Integer is
Word: Object_Word := Pointer_To_Word (Pointer);
Word: Object_Word := Pointer_To_Word(Pointer);
begin
if (Word and (2 ** (Word'Size - 1))) /= 0 then
-- if the highest bit is set, it's a negative number
@ -1423,8 +1421,24 @@ end if;
Ptr.Sign := Negative_Sign;
end if;
ada.text_io.put_line (Object_Half_Word'image(bigint.get_high(w)));
ada.text_io.put_line (Object_Half_Word'image(bigint.get_low(w)));
return Ptr;
end Make_Bigint;
function Make_Bigint (Interp: access Interpreter_Record;
Source: in Object_Pointer;
Last: in Half_Word_Object_Size) return Object_Pointer is
pragma Assert (Is_Bigint(Source));
pragma Assert (Last <= Source.Size);
X: aliased Object_Pointer := Source;
Ptr: Object_Pointer;
begin
Push_Top (Interp.all, X'Unchecked_Access);
Ptr := Allocate_Half_Word_Object(Interp, Last);
Ptr.Tag := Bigint_Object;
Ptr.Sign := Source.Sign;
Ptr.Half_Word_Slot := X.Half_Word_Slot(1 .. Last);
Pop_Tops (Interp.all, 1);
return Ptr;
end Make_Bigint;
@ -2260,6 +2274,25 @@ ada.text_io.put_line (Object_Half_Word'image(bigint.get_low(w)));
Ada.Text_IO.Put ("#Array");
when Bigint_Object =>
Ada.Text_IO.Put ("#Bigint(");
declare
package Int_IO is new ada.text_io.modular_IO(object_half_word);
begin
if Atom.Sign = Negative_Sign then
ada.text_io.put ("-");
else
ada.text_io.put ("+");
end if;
for I in reverse Atom.Half_Word_Slot'Range loop
ada.text_io.put (" ");
int_io.put (Atom.Half_Word_Slot(I), base=>16);
end loop;
end;
Ada.Text_IO.Put(")");
when Others =>
if Atom.Kind = Character_Object then
Output_Character_Array (Atom.Character_Slot);
@ -2659,9 +2692,12 @@ Push_Top (Interp, B'Unchecked_Access);
--A := Bigint.Add (Interp.Self, A, B);
--end loop;
A := Make_Bigint (Interp.Self, Value => 16#FFFF_00000001#);
B := Make_Bigint (Interp.Self, Value => 16#FFFF_0000000F#);
--B := Make_Bigint (Interp.Self, Value => 16#FFFF_0000000F#);
B := Make_Bigint (Interp.Self, Value => 16#FFFFFF_00000001#);
B.sign := Negative_Sign;
--A := Bigint.Subtract (Interp.Self, integer_to_pointer(16), B);
A := Bigint.Subtract (Interp.Self, B, integer_to_pointer(16));
--A := Bigint.Multiply (Interp.Self, B, integer_to_pointer(2));
A := Bigint.Add (Interp.Self, integer_to_pointer(object_integer'first), integer_to_pointer(-1));
print (interp, A);
Pop_tops (Interp, 2);
end;

17
lib/h2-scheme.ads
View File

@ -113,6 +113,7 @@ package H2.Scheme is
-- -----------------------------------------------------------------------
-- What is a better choice? TODO: decide what to use
-- -----------------------------------------------------------------------
-- Let Object_Integer take up as large a space as Object_Pointer
-- despite the actual range of Object_Integer.
for Object_Integer'Size use Object_Pointer_Bits;
@ -289,9 +290,9 @@ package H2.Scheme is
function Is_Character (Pointer: in Object_Pointer) return Standard.Boolean;
function Is_Byte (Pointer: in Object_Pointer) return Standard.Boolean;
function Integer_To_Pointer (Int: in Object_Integer) return Object_Pointer;
function Character_To_Pointer (Char: in Object_Character) return Object_Pointer;
function Byte_To_Pointer (Byte: in Object_Byte) return Object_Pointer;
function Integer_To_Pointer (Value: in Object_Integer) return Object_Pointer;
function Character_To_Pointer (Value: in Object_Character) return Object_Pointer;
function Byte_To_Pointer (Value: in Object_Byte) return Object_Pointer;
function Pointer_To_Integer (Pointer: in Object_Pointer) return Object_Integer;
function Pointer_To_Character (Pointer: in Object_Pointer) return Object_Character;
@ -304,7 +305,7 @@ package H2.Scheme is
pragma Inline (Integer_To_Pointer);
pragma Inline (Character_To_Pointer);
pragma Inline (Byte_To_Pointer);
pragma Inline (Pointer_To_Integer);
--pragma Inline (Pointer_To_Integer);
pragma Inline (Pointer_To_Character);
pragma Inline (Pointer_To_Byte);
@ -470,6 +471,10 @@ package H2.Scheme is
function Make_Bigint (Interp: access Interpreter_Record;
Value: Object_Integer) return Object_Pointer;
function Make_Bigint (Interp: access Interpreter_Record;
Source: in Object_Pointer;
Last: in Half_Word_Object_Size) return Object_Pointer;
-- -----------------------------------------------------------------------------
@ -597,6 +602,10 @@ private
X: in Object_Pointer;
Y: in Object_Pointer) return Object_Pointer;
function Multiply (Interp: access Interpreter_Record;
X: in Object_Pointer;
Y: in Object_Pointer) return Object_Pointer;
end Bigint;
end H2.Scheme;