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

added No_Optimization

Browse Source
This commit is contained in:
hyung-hwan 2013-12-19 14:42:14 +00:00
parent 29b7183205
commit 228a5d09db
2 changed files with 38 additions and 30 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

63
lib/h2-scheme.adb
View File

@ -1925,12 +1925,15 @@ end Make_Test_Object;
Set_Frame_Opcode (Interp.Stack, Opcode_Evaluate_Group); Set_Frame_Opcode (Interp.Stack, Opcode_Evaluate_Group);
Set_Frame_Operand (Interp.Stack, Operand); Set_Frame_Operand (Interp.Stack, Operand);
-- I call Evaluate_Group for optimizatio here.
Evaluate_Group; -- for optimization only. not really needed. if (Interp.Trait.Trait_Bits and No_Optimization) = 0 then
-- I can jump to Start_Over because Evaluate_Group called -- I call Evaluate_Group for optimization here.
-- above pushes an Opcode_Evaluate_Object frame. Evaluate_Group; -- for optimization only. not really needed.
pragma Assert (Get_Frame_Opcode(Interp.Stack) = Opcode_Evaluate_Object); -- I can jump to Start_Over because Evaluate_Group called
goto Start_Over; -- for optimization only. not really needed. -- above pushes an Opcode_Evaluate_Object frame.
pragma Assert (Get_Frame_Opcode(Interp.Stack) = Opcode_Evaluate_Object);
goto Start_Over; -- for optimization only. not really needed.
end if;
end if; end if;
when Define_Syntax => when Define_Syntax =>
Text_IO.Put_Line ("define syntax"); Text_IO.Put_Line ("define syntax");
@ -1940,27 +1943,29 @@ end Make_Test_Object;
Set_Frame_Opcode (Interp.Stack, Opcode_Evaluate_Syntax); -- switch to syntax evaluation Set_Frame_Opcode (Interp.Stack, Opcode_Evaluate_Syntax); -- switch to syntax evaluation
end case; end case;
else else
while not Is_Normal_Pointer(Car) loop if (Interp.Trait.Trait_Bits and No_Optimization) = 0 then
-- This while block is for optimization only. It's not really needed. while not Is_Normal_Pointer(Car) loop
-- If I know that the next object to evaluate is a literal object, -- This while block is for optimization only. It's not really needed.
-- I can simply reverse-chain it to the return field of the current -- If I know that the next object to evaluate is a literal object,
-- frame without pushing another frame dedicated for it. -- I can simply reverse-chain it to the return field of the current
-- frame without pushing another frame dedicated for it.
-- TODO: some normal pointers may point to a literal object. e.g.) bignum -- TODO: some normal pointers may point to a literal object. e.g.) bignum
Chain_Frame_Return (Interp, Interp.Stack, Car); Chain_Frame_Return (Interp, Interp.Stack, Car);
if Is_Cons(Cdr) then if Is_Cons(Cdr) then
Operand := Cdr; Operand := Cdr;
Car := Get_Car(Operand); Car := Get_Car(Operand);
Cdr := Get_Cdr(Operand); Cdr := Get_Cdr(Operand);
else else
-- last cons -- last cons
Operand := Reverse_Cons(Get_Frame_Return(Interp.Stack)); Operand := Reverse_Cons(Get_Frame_Return(Interp.Stack));
Clear_Frame_Return (Interp.Stack); Clear_Frame_Return (Interp.Stack);
Set_Frame_Opcode (Interp.Stack, Opcode_Apply); Set_Frame_Opcode (Interp.Stack, Opcode_Apply);
Set_Frame_Operand (Interp.Stack, Operand); Set_Frame_Operand (Interp.Stack, Operand);
return; return;
end if; end if;
end loop; end loop;
end if;
if Is_Cons(Cdr) then if Is_Cons(Cdr) then
-- Not the last cons cell yet -- Not the last cons cell yet
@ -1980,8 +1985,10 @@ end Make_Test_Object;
end if; end if;
-- Arrange to evaluate the car object -- Arrange to evaluate the car object
Push_Frame (Opcode_Evaluate_Object, Car); if (Interp.Trait.Trait_Bits and No_Optimization) = 0 then
goto Start_Over; -- for optimization only. not really needed. Push_Frame (Opcode_Evaluate_Object, Car);
goto Start_Over; -- for optimization only. not really needed.
end if;
end if; end if;
when Mark_Object => when Mark_Object =>

3
lib/h2-scheme.ads
View File

@ -257,7 +257,8 @@ package H2.Scheme is
type Memory_Size is range 0 .. (2 ** (System.Word_Size - 1)) - 1; type Memory_Size is range 0 .. (2 ** (System.Word_Size - 1)) - 1;
type Trait_Mask is mod 2 ** System.Word_Size; type Trait_Mask is mod 2 ** System.Word_Size;
No_Garbage_Collection: constant Trait_Mask := 2 ** 0; No_Garbage_Collection: constant Trait_Mask := 2#0000_0000_0000_0001#;
No_Optimization: constant Trait_Mask := 2#0000_0000_0000_0010#;
type Option_Kind is (Trait_Option); type Option_Kind is (Trait_Option);
type Option_Record (Kind: Option_Kind) is record type Option_Record (Kind: Option_Kind) is record