Commits

Paweł Wieczorek committed d7a0b2c

Using new frame routines in Context in While ToyCompiller

Comments (0)

Files changed (1)

source/Compiler/WhileX86Compiler.ml

 module Context = struct 
     
     type scope_block =
-        { local_variable_map       : (AST.variable, location32) FrozenHashtbl.t
+        { local_variable_map       : (AST.variable, memory_location) FrozenHashtbl.t
         }
 
     type frame =
         ; symbol_table              : (AST.identifier, symbol) FrozenHashtbl.t
         ; global_variable_table     : (AST.variable,   symbol) FrozenHashtbl.t
         ; exception_symbol_table    : (AST.identifier, symbol) FrozenHashtbl.t
-        ; frame_leave               : symbol option ref
         ; current_frame             : frame option ref
         }
 
         FrozenHashtbl.fold (fun identifier symbol acc -> (identifier,symbol)::acc) context.exception_symbol_table []
 
     let get_frame_leave_symbol context =
-        match !(context.frame_leave) with
+        match !(context.current_frame) with
         | None ->
-            Error.internal_error "Getting frame-leave-symbol outside frame?"
-        | Some symbol ->
-            symbol
-
-    let reset_frame_leave_symbol context =
-        context.frame_leave:= None
-
+            Error.internal_error "Getting frame description outside frame?"
+        | Some frame_description ->
+            frame_description.leave_symbol
 
     let lookup_for_symbol context identifier =
         try
         ; symbol_table              = FrozenHashtbl.freeze (Helpers.compute_symbol_table declarations)
         ; global_variable_table     = FrozenHashtbl.freeze (Helpers.compute_global_variable_table declarations)
         ; exception_symbol_table    = FrozenHashtbl.freeze (Helpers.compute_exception_symbol_table declarations)
-        ; frame_leave               = ref None
         ; current_frame             = ref None
         } 
 
         let symbol = make_symbol (Printf.sprintf "_L%04u%s" num suffix) in
         symbol
 
-    let new_frame_leave_symbol context =
-        let frame_leave_symbol = create_fresh_local_symbol ~suffix:"_frame_leave"  context in
-        context.frame_leave := Some frame_leave_symbol;
-        frame_leave_symbol
-
-    let inside_frame context cont =
+    let inside_frame context formal_arguments cont =
         assert (Option.is_none !(context.current_frame));
         let leave_symbol = create_fresh_local_symbol ~suffix:"_frame_leave"  context in
         let frame = 
  *
  ********************************************************************************************************************)
 
-
 module Shrinker = struct
 
     let not_both a b =
         not (a && b)
 
     let rec shrink_emits ticks prev_emits next_emits = match prev_emits, next_emits with
+
+        (* Pushing and then poping *)
         | EMIT_Instruction (PUSHL (LV32_Location loc32_1)) :: prev_emits
         , EMIT_Instruction (POPL loc32_2)                  :: next_emits
           when loc32_1 = loc32_2 ->
             incr ticks;
             shrink_emits ticks prev_emits next_emits
 
-        
+        (* Indirect transfer *)
         | EMIT_Instruction (MOVL (lv32_a, loc32_a))                     :: prev_emits
         , EMIT_Instruction (MOVL ((LV32_Location loc32_b), loc32_c))    :: next_emits
         when loc32_a = loc32_b && not_both (lv32_is_memref lv32_a) (loc32_is_memref loc32_c) ->
             let new_emit = emit_MOVL lv32_a loc32_c in
             shrink_emits ticks prev_emits (new_emit::next_emits)
 
+        (* Silly pushing *)
         | EMIT_Instruction (MOVL (lv32_a, loc32_a))         :: prev_emits
         , EMIT_Instruction (PUSHL (LV32_Location loc32_b))  :: next_emits
         when loc32_a = loc32_b ->
             let new_emit = emit_PUSHL lv32_a in
             shrink_emits ticks prev_emits (new_emit::next_emits)
 
+        (* Transfers before comparision *)
         | EMIT_Instruction (MOVL (lv32_src_a, loc32_tmp_a))  
             :: EMIT_Instruction (MOVL ((LV32_Location loc32_src_b), loc32_tmp_b))
             :: prev_emits
             let new_emit = emit_CMP lv32_src_a loc32_src_b in
             shrink_emits ticks prev_emits (new_emit::next_emits)
 
-
-        | EMIT_Instruction (JMP loc32_a)
+        (* Unreachable instruction *)
+(*        | EMIT_Instruction (JMP loc32_a) *)
+          | EMIT_Instruction _
             :: (EMIT_Instruction (JMP loc32_b) as reachable_jmp)
             :: prev_emits
         , next_emits ->
             shrink_emits ticks prev_emits (reachable_jmp :: next_emits)
             
 
+        (* Pushing two values and moving them to EAX,EBX *)
         (* TODO guard *)
         | EMIT_Instruction (PUSHL lv32_1)
             :: EMIT_Instruction (PUSHL lv32_2)
             let new_emit1 = emit_MOVL lv32_2 (LOC32_Register EBX) in
             let new_emit2 = emit_MOVL lv32_1 (LOC32_Register EAX) in
             shrink_emits ticks prev_emits (new_emit1 :: new_emit2 :: next_emits)
-            
+        
+        (* Jump to next instruction *)
+        | EMIT_Instruction (JMP (LOC32_Memory (MEM_Symbol symbol_in_jump)))
+            :: prev_emits
 
+        , (EMIT_Label emited_label as current_emit)
+            :: next_emits
+        when emited_label = symbol_in_jump ->
+            incr ticks;
+            shrink_emits ticks (current_emit :: prev_emits) next_emits
+
+        (* Adding zero *)
+
+        | EMIT_Instruction (ADDL (LV32_Value (VAL32_Immediate 0l), loc32))
+            :: prev_emits
+        , next_emits ->
+            incr ticks;
+            shrink_emits ticks prev_emits next_emits
+
+
+        (* Going forward *)
 
         |              prev_emits
         , next_emit :: next_emits ->
             shrink_emits ticks (next_emit :: prev_emits) next_emits
 
+        (* Restart or give up *)
         | prev_emits
         , [] ->
             let final = List.rev prev_emits in
      * Translating program routine.
      *)
 
-    let compile_procedure_command context symbol command =
-        let frame_leave_symbol = Context.new_frame_leave_symbol context in
+    let compile_procedure_command context frame_leave_symbol symbol command =
         let compiled_command   = compile_command context command in
         let compiled_body      = Helpers.frame_wrap frame_leave_symbol compiled_command in
         emit_label symbol :: compiled_body
 
     let compile_declaration context (AST.DECL_Procedure (identifier, formal_arguments, command)) =
-        let symbol           = Context.lookup_for_symbol context identifier in
-        let compiled_command = compile_procedure_command context symbol command in
-        Shrinker.shrink compiled_command
+        Context.inside_frame context formal_arguments begin fun frame_leave_symbol ->
+            let symbol           = Context.lookup_for_symbol context identifier in
+            let compiled_command = compile_procedure_command context frame_leave_symbol symbol command in
+            Shrinker.shrink compiled_command
+        end
 
     (*----------------------------------------------------------------------------------------------------------------
      * Compiling text section.